Garmelon/mima-tools
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add proper relative and label-relative addresses

Browse source
This commit is contained in:
I-Al-Istannen 2020-04-04 17:32:05 +02:00
parent e942544044
commit d82ce69b1b
2 changed files with 94 additions and 73 deletions
Download patch file Download diff file Expand all files Collapse all files

51
src/Mima/Asm/Phase1.hs
View file

@ -41,7 +41,6 @@ import Text.Megaparsec.Char.Lexer hiding (space)
import Mima.Asm.Types
import Mima.Format
import qualified Mima.Vm.Instruction as Vm
import qualified Mima.Vm.Word as Vm
{-
<value> := <word> | <address>
@ -71,7 +70,7 @@ instance Onion Name where
peel (Name a _) = a
data Address a
= AddressAbsolute a Vm.MimaAddress
= AddressAbsolute a Integer
| AddressRelative a Integer
deriving (Show, Functor)
@ -82,11 +81,14 @@ instance Onion Address where
data Location a
= LocationAddress (Address a)
| LocationLabel (Name a)
| LocationLabelRel a (Name a) a Integer
-- ^ @Lo LocationLabelRel completeSpan name offsetSpan offset@
deriving (Show, Functor)
instance Onion Location where
peel (LocationAddress a) = peel a
peel (LocationLabel a) = peel a
peel (LocationLabelRel a _ _ _) = a
data SmallOpcode a = SmallOpcode a Vm.SmallOpcode
deriving (Show, Functor)
@ -101,7 +103,7 @@ instance Onion LargeOpcode where
peel (LargeOpcode a _) = a
data MimaWord a
= WordRaw a Vm.MimaWord
= WordRaw a Integer
| WordLocation (Location a)
deriving (Show, Functor)
@ -109,7 +111,7 @@ instance Onion MimaWord where
peel (WordRaw a _) = a
peel (WordLocation a) = peel a
data SmallValue a = SmallValue a Vm.SmallValue
data SmallValue a = SmallValue a Integer
deriving (Show, Functor)
instance Onion SmallValue where
@ -223,31 +225,26 @@ number =
(chunk "0x" *> hexadecimal) <|>
decimal
optionallySignedNumber :: (Num a) => Parser a
optionallySignedNumber = signed (pure ()) number -- do not allow any space
signedNumber :: (Num a) => Parser a
signedNumber = lookAhead (char '+' <|> char '-') *> optionallySignedNumber
boundedNumber :: (Bounded n, Num n) => Parser n
boundedNumber = do
n <- optionallySignedNumber :: Parser Integer
when (n < minVal || n > maxVal) $ fail $
"invalid range: " ++
show n ++ " is not between " ++
show minVal ++ " and " ++ show maxVal
pure $ fromInteger n
where
maxVal = toInteger (maxBound :: Vm.MimaWord)
minVal = -(maxVal + 1)
signedNumber = signed (pure ()) number -- do not allow any space
address :: Parser (Address Span)
address =
fmap (uncurry AddressRelative) (withSpan signedNumber) <|>
fmap (uncurry AddressAbsolute) (withSpan boundedNumber)
fmap (uncurry AddressRelative) (withSpan $ between (char '[') (char ']') signedNumber) <|>
fmap (uncurry AddressAbsolute) (withSpan signedNumber)
labelWithOffset :: Parser (Location Span)
labelWithOffset = do
(completeSpan, (n, offsetSpan, offset)) <- withSpan $ do
n <- name
(offsetSpan, offset) <- withSpan $ between (char '[') (char ']') signedNumber
pure (n, offsetSpan, offset)
pure $ LocationLabelRel completeSpan n offsetSpan offset
location :: Parser (Location Span)
location = (LocationAddress <$> address) <|> (LocationLabel <$> name)
location =
(LocationAddress <$> address) <|> try labelWithOffset <|> (LocationLabel <$> name)
smallOpcode :: Parser (SmallOpcode Span)
smallOpcode = asum $ map parseOpcode [minBound..maxBound]
@ -265,10 +262,10 @@ largeOpcode = asum $ map parseOpcode [minBound..maxBound]
mimaWord :: Parser (MimaWord Span)
mimaWord =
(uncurry WordRaw <$> withSpan boundedNumber) <|> (WordLocation <$> location)
(uncurry WordRaw <$> withSpan signedNumber) <|> (WordLocation <$> location)
smallValue :: Parser (SmallValue Span)
smallValue = uncurry SmallValue <$> withSpan boundedNumber
smallValue = uncurry SmallValue <$> withSpan signedNumber
instruction :: Parser (Instruction Span)
instruction = small <|> large
@ -363,7 +360,7 @@ labels = do
ls <- many $ try $ inlineSpace1 *> label_
pure $ l : ls
where
label_ = (TokenLabel <$> name) <* (inlineSpace <* char ':')
label_ = (TokenLabel <$> name) <* char ':'
-- | Parses a single line consisting of zero or more tokens:
-- inlineSpace, zero or more labels, zero or more instructions/directives,
@ -398,6 +395,8 @@ formatAddress (AddressRelative _ rel)
formatLocation :: Location a -> T.Text
formatLocation (LocationAddress addr) = formatAddress addr
formatLocation (LocationLabel l) = formatName l
formatLocation (LocationLabelRel _ l _ offset)
= formatName l <> "[" <> toDec offset <> "]"
formatSmallOpcode :: SmallOpcode a -> T.Text
formatSmallOpcode (SmallOpcode _ opcode) = T.pack $ show opcode

92
src/Mima/Asm/Phase2.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
@ -53,22 +54,26 @@ data Location1 s
= Loc1Absolute s Vm.MimaAddress
| Loc1Relative s Integer
| Loc1Label (Name s)
| Loc1LabelRel s (Name s) s Integer
deriving (Show, Functor)
instance Onion Location1 where
peel (Loc1Absolute s _) = s
peel (Loc1Relative s _) = s
peel (Loc1Label l) = peel l
peel (Loc1LabelRel s _ _ _) = s
-- | A location defined by an absolute address or by a label.
data Location2 s
= Loc2Absolute s Vm.MimaAddress
| Loc2Label (Name s)
| Loc2LabelRel s (Name s) s Integer
deriving (Show, Functor)
instance Onion Location2 where
peel (Loc2Absolute s _) = s
peel (Loc2Label l) = peel l
peel (Loc2LabelRel s _ _ _) = s
-- | A type family for locations in various stages of resolution.
type family LocationX (t :: Subphase) (s :: *)
@ -224,33 +229,45 @@ p1ToP2Name (P1.Name s text) = Name s text
p1ToP2JsonValue :: P1.JsonValue s -> JsonValue s
p1ToP2JsonValue (P1.JsonValue s value) = JsonValue s value
p1ToP2Address :: P1.Address s -> OrgAddress s
p1ToP2Address (P1.AddressAbsolute s addr) = OrgAddrAbsolute s addr
p1ToP2Address (P1.AddressRelative s offset) = OrgAddrRelative s offset
intToBounded :: forall s n. (Bounded n, Integral n) => s -> Integer -> Weed (WeedError s) n
intToBounded s val = do
when (val < minVal || val > maxVal) $
harmless $ errorWith s "value out of bounds"
pure $ fromInteger val
where
maxVal = toInteger (maxBound :: n)
minVal = -maxVal - 1
p1ToP2Location :: P1.Location s -> Location1 s
p1ToP2Location (P1.LocationAddress (P1.AddressAbsolute s addr)) =
Loc1Absolute s addr
p1ToP2Address :: P1.Address s -> WeedS1 s (OrgAddress s)
p1ToP2Address (P1.AddressAbsolute s addr) = lift $ OrgAddrAbsolute s <$> intToBounded s addr
p1ToP2Address (P1.AddressRelative s offset) = pure $ OrgAddrRelative s offset
p1ToP2Location :: P1.Location s -> WeedS1 s (Location1 s)
p1ToP2Location (P1.LocationAddress (P1.AddressAbsolute s addr)) = lift $ Loc1Absolute s <$> intToBounded s addr
p1ToP2Location (P1.LocationAddress (P1.AddressRelative s offset)) =
Loc1Relative s offset
p1ToP2Location (P1.LocationLabel name) = Loc1Label $ p1ToP2Name name
pure $ Loc1Relative s offset
p1ToP2Location (P1.LocationLabel name) = pure $ Loc1Label $ p1ToP2Name name
p1ToP2Location (P1.LocationLabelRel s name s1 offset)
= pure $ Loc1LabelRel s (p1ToP2Name name) s1 offset
p1ToP2Instruction :: P1.Instruction s -> Instruction 'S1 s
p1ToP2Instruction (P1.SmallInstruction _ (P1.SmallOpcode _ so) loc) =
SmallInstruction so $ p1ToP2Location loc
p1ToP2Instruction (P1.LargeInstruction _ (P1.LargeOpcode _ lo) maybeSv) =
LargeInstruction lo $ fmap (\(P1.SmallValue _ sv) -> sv) maybeSv
p1ToP2Instruction :: P1.Instruction s -> WeedS1 s (Instruction 'S1 s)
p1ToP2Instruction (P1.SmallInstruction _ (P1.SmallOpcode _ so) loc) = SmallInstruction so <$> p1ToP2Location loc
p1ToP2Instruction (P1.LargeInstruction _ (P1.LargeOpcode _ lo) maybeSv) = do
val <- case maybeSv of
Nothing -> pure Nothing
Just (P1.SmallValue s v) -> lift $ Just <$> intToBounded s v
pure $ LargeInstruction lo val
p1ToP2Word :: P1.MimaWord s -> MimaWord 'S1 s
p1ToP2Word (P1.WordRaw _ w) = WordRaw w
p1ToP2Word (P1.WordLocation loc) = WordLocation $ p1ToP2Location loc
p1ToP2Word :: P1.MimaWord s -> WeedS1 s (MimaWord 'S1 s)
p1ToP2Word (P1.WordRaw s w) = lift $ WordRaw <$> intToBounded s w
p1ToP2Word (P1.WordLocation loc) = WordLocation <$> p1ToP2Location loc
p1ToP2RegDir :: P1.RegisterDirective s -> RegisterDirective 'S1 s
p1ToP2RegDir (P1.RegIar s _ loc) = RegIar s $ p1ToP2Location loc
p1ToP2RegDir (P1.RegAcc s _ word) = RegAcc s $ p1ToP2Word word
p1ToP2RegDir (P1.RegRa s _ loc) = RegRa s $ p1ToP2Location loc
p1ToP2RegDir (P1.RegSp s _ loc) = RegSp s $ p1ToP2Location loc
p1ToP2RegDir (P1.RegFp s _ loc) = RegFp s $ p1ToP2Location loc
p1ToP2RegDir :: P1.RegisterDirective s -> WeedS1 s (RegisterDirective 'S1 s)
p1ToP2RegDir (P1.RegIar s _ loc) = RegIar s <$> p1ToP2Location loc
p1ToP2RegDir (P1.RegAcc s _ word) = RegAcc s <$> p1ToP2Word word
p1ToP2RegDir (P1.RegRa s _ loc) = RegRa s <$> p1ToP2Location loc
p1ToP2RegDir (P1.RegSp s _ loc) = RegSp s <$> p1ToP2Location loc
p1ToP2RegDir (P1.RegFp s _ loc) = RegFp s <$> p1ToP2Location loc
{- Subphase 1 -}
@ -297,17 +314,23 @@ s1AddToken t = modify $ \s -> s{s1Tokens = t : s1Tokens s}
s1AddP1Token :: P1.AsmToken s -> WeedS1 s ()
s1AddP1Token (P1.TokenLabel name) =
s1AddToken $ TokenLabel (peel name) () $ p1ToP2Name name
s1AddP1Token (P1.TokenInstruction instr) =
s1WithMetas $ s1AddToken $ TokenInstr (peel instr) () $ p1ToP2Instruction instr
s1AddP1Token (P1.TokenDirective (P1.Reg s _ regDir)) =
s1AddToken $ TokenReg s () $ p1ToP2RegDir regDir
s1AddP1Token (P1.TokenInstruction instr) = do
i <- p1ToP2Instruction instr
s1WithMetas $ s1AddToken $ TokenInstr (peel instr) () i
s1AddP1Token (P1.TokenDirective (P1.Reg s _ regDir)) = do
r <- p1ToP2RegDir regDir
s1AddToken $ TokenReg s () r
s1AddP1Token (P1.TokenDirective (P1.Org s _ addr)) = do
s1WithMetas $ pure ()
s1AddToken $ TokenOrg s $ p1ToP2Address addr
s1AddP1Token (P1.TokenDirective (P1.Lit s _ w)) =
s1WithMetas $ s1AddToken $ TokenLit s () $ p1ToP2Word w
a <- p1ToP2Address addr
s1AddToken $ TokenOrg s a
s1AddP1Token (P1.TokenDirective (P1.Lit s _ word)) = do
w <- p1ToP2Word word
s1WithMetas $ s1AddToken $ TokenLit s () w
s1AddP1Token (P1.TokenDirective (P1.Arr s _ ws)) =
s1WithMetas $ for_ ws $ s1AddToken . TokenLit s () . p1ToP2Word
s1WithMetas $ for_ ws $ \word -> do
w <- p1ToP2Word word
pure $ s1AddToken $ TokenLit s () w
s1AddP1Token (P1.TokenDirective (P1.Meta s _ name value)) =
s1AddMeta s name value
s1AddP1Token (P1.TokenDirective (P1.MetaStart s _ name value)) =
@ -359,13 +382,12 @@ s2NextAddress s = do
s2ConvertLocation :: Vm.MimaAddress -> LocationX 'S1 s -> WeedS2 s (LocationX 'S2 s)
s2ConvertLocation _ (Loc1Absolute s addr) = pure $ Loc2Absolute s addr
s2ConvertLocation _ (Loc1Label name) = pure $ Loc2Label name
s2ConvertLocation _ (Loc1LabelRel s name s1 offset)
= pure $ Loc2LabelRel s name s1 offset
s2ConvertLocation baseAddr (Loc1Relative s delta) = do
let newAddr = toInteger baseAddr + delta
minAddr = toInteger (minBound :: Vm.MimaAddress)
maxAddr = toInteger (maxBound :: Vm.MimaAddress)
when (newAddr < minAddr || newAddr > maxAddr) $
lift $ harmless $ errorWith s $ "address out of bounds: " ++ show newAddr
pure $ Loc2Absolute s $ fromInteger newAddr
val <- lift $ intToBounded s newAddr
pure $ Loc2Absolute s val
s2ConvertMimaWord :: Vm.MimaAddress -> MimaWord 'S1 s -> WeedS2 s (MimaWord 'S2 s)
s2ConvertMimaWord baseAddr (WordLocation loc) =