Split up phase 2 into multiple modules
This commit is contained in:
parent
d82ce69b1b
commit
8d0e70cf5d
5 changed files with 503 additions and 436 deletions
|
|
@ -1,441 +1,10 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Mima.Asm.Phase2
|
||||
( phaseS1 -- TODO only leave the proper types
|
||||
, phaseS2
|
||||
( phase2
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.State
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Foldable
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Data.Void
|
||||
|
||||
import qualified Mima.Asm.Phase1 as P1
|
||||
import Mima.Asm.Types
|
||||
import qualified Mima.Asm.Phase1 as P1
|
||||
import Mima.Asm.Weed
|
||||
import qualified Mima.Vm.Instruction as Vm
|
||||
import qualified Mima.Vm.Word as Vm
|
||||
import qualified Mima.Vm.State as Vm
|
||||
|
||||
data Subphase
|
||||
= S1
|
||||
-- ^ Freshly converted from 'Phase1'. Arrays are converted into multiple
|
||||
-- literal values. Comments are removed.
|
||||
| S2
|
||||
-- ^ After resolving all .org-s and relative positions and assigning each
|
||||
-- token an address.
|
||||
| S3
|
||||
-- ^ After extracting and removing all labels and .meta-s. This step results
|
||||
-- in a map to resolve labels and a complete set of .meta-* metadata.
|
||||
| S4
|
||||
-- ^ After resolving all labels. Instructions are converted into literal
|
||||
-- values.
|
||||
| S5
|
||||
-- ^ After extracting all initial register values.
|
||||
|
||||
-- | The name of a label or a meta tag.
|
||||
data Name s = Name s T.Text
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion Name where
|
||||
peel (Name s _) = s
|
||||
|
||||
-- | A location defined by an absolute or relative address or by a label.
|
||||
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 :: *)
|
||||
type instance LocationX 'S1 s = Location1 s
|
||||
type instance LocationX 'S2 s = Location2 s
|
||||
type instance LocationX 'S3 s = Location2 s
|
||||
type instance LocationX 'S4 s = Vm.MimaAddress
|
||||
type instance LocationX 'S5 s = Vm.MimaAddress
|
||||
|
||||
-- | A type family for addresses of various tokens.
|
||||
type family AddressX (t :: Subphase) (s :: *)
|
||||
type instance AddressX 'S1 s = ()
|
||||
type instance AddressX 'S2 s = Vm.MimaAddress
|
||||
type instance AddressX 'S3 s = Vm.MimaAddress
|
||||
type instance AddressX 'S4 s = Vm.MimaAddress
|
||||
type instance AddressX 'S5 s = Vm.MimaAddress
|
||||
|
||||
-- | A representation for .org addresses.
|
||||
data OrgAddress s
|
||||
= OrgAddrAbsolute s Vm.MimaAddress
|
||||
| OrgAddrRelative s Integer
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion OrgAddress where
|
||||
peel (OrgAddrAbsolute s _) = s
|
||||
peel (OrgAddrRelative s _) = s
|
||||
|
||||
type family TokenOrgX (t :: Subphase) (s :: *)
|
||||
type instance TokenOrgX 'S1 s = OrgAddress s
|
||||
type instance TokenOrgX 'S2 s = Void
|
||||
type instance TokenOrgX 'S3 s = Void
|
||||
type instance TokenOrgX 'S4 s = Void
|
||||
type instance TokenOrgX 'S5 s = Void
|
||||
|
||||
type family TokenLabelX (t :: Subphase) (s :: *)
|
||||
type instance TokenLabelX 'S1 s = Name s
|
||||
type instance TokenLabelX 'S2 s = Name s
|
||||
type instance TokenLabelX 'S3 s = Void
|
||||
type instance TokenLabelX 'S4 s = Void
|
||||
type instance TokenLabelX 'S5 s = Void
|
||||
|
||||
-- | A wrapper that annotates a 'A.Value' with an @s@ value.
|
||||
data JsonValue s = JsonValue s A.Value
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion JsonValue where
|
||||
peel (JsonValue s _) = s
|
||||
|
||||
-- | A representation for .meta-start and .meta-stop directives.
|
||||
data Meta s
|
||||
= MetaStart s (Name s) (JsonValue s)
|
||||
| MetaStop s (Name s)
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion Meta where
|
||||
peel (MetaStart s _ _) = s
|
||||
peel (MetaStop s _) = s
|
||||
|
||||
type family TokenMetaX (t :: Subphase) (s :: *)
|
||||
type instance TokenMetaX 'S1 s = Meta s
|
||||
type instance TokenMetaX 'S2 s = Meta s
|
||||
type instance TokenMetaX 'S3 s = Void
|
||||
type instance TokenMetaX 'S4 s = Void
|
||||
type instance TokenMetaX 'S5 s = Void
|
||||
|
||||
-- | A stripped-down representation of Mima words that does not have an 'Onion'
|
||||
-- instance because none is required.
|
||||
data MimaWord (t :: Subphase) (s :: *)
|
||||
= WordRaw Vm.MimaWord
|
||||
| WordLocation (LocationX t s)
|
||||
|
||||
deriving instance Show s => Show (MimaWord 'S1 s)
|
||||
deriving instance Show s => Show (MimaWord 'S2 s)
|
||||
deriving instance Show s => Show (MimaWord 'S3 s)
|
||||
deriving instance Show s => Show (MimaWord 'S4 s)
|
||||
deriving instance Show s => Show (MimaWord 'S5 s)
|
||||
|
||||
-- | A stripped-down representation of Mima instructions that does not have an
|
||||
-- 'Onion' instance because none is required.
|
||||
data Instruction (t :: Subphase) (s :: *)
|
||||
= SmallInstruction Vm.SmallOpcode (LocationX t s)
|
||||
| LargeInstruction Vm.LargeOpcode (Maybe Vm.SmallValue)
|
||||
|
||||
deriving instance Show s => Show (Instruction 'S1 s)
|
||||
deriving instance Show s => Show (Instruction 'S2 s)
|
||||
deriving instance Show s => Show (Instruction 'S3 s)
|
||||
deriving instance Show s => Show (Instruction 'S4 s)
|
||||
deriving instance Show s => Show (Instruction 'S5 s)
|
||||
|
||||
type family TokenInstrX (t :: Subphase) (s :: *)
|
||||
type instance TokenInstrX 'S1 s = Instruction 'S1 s
|
||||
type instance TokenInstrX 'S2 s = Instruction 'S2 s
|
||||
type instance TokenInstrX 'S3 s = Instruction 'S3 s
|
||||
type instance TokenInstrX 'S4 s = Void
|
||||
type instance TokenInstrX 'S5 s = Void
|
||||
|
||||
data RegisterDirective (t :: Subphase) (s :: *)
|
||||
= RegIar s (LocationX t s)
|
||||
| RegAcc s (MimaWord t s)
|
||||
| RegRa s (LocationX t s)
|
||||
| RegSp s (LocationX t s)
|
||||
| RegFp s (LocationX t s)
|
||||
|
||||
deriving instance Show s => Show (RegisterDirective 'S1 s)
|
||||
deriving instance Show s => Show (RegisterDirective 'S2 s)
|
||||
deriving instance Show s => Show (RegisterDirective 'S3 s)
|
||||
deriving instance Show s => Show (RegisterDirective 'S4 s)
|
||||
deriving instance Show s => Show (RegisterDirective 'S5 s)
|
||||
|
||||
instance Onion (RegisterDirective t) where
|
||||
peel (RegIar s _) = s
|
||||
peel (RegAcc s _) = s
|
||||
peel (RegRa s _) = s
|
||||
peel (RegSp s _) = s
|
||||
peel (RegFp s _) = s
|
||||
|
||||
type family TokenRegX (t :: Subphase) (s :: *)
|
||||
type instance TokenRegX 'S1 s = RegisterDirective 'S1 s
|
||||
type instance TokenRegX 'S2 s = RegisterDirective 'S2 s
|
||||
type instance TokenRegX 'S3 s = RegisterDirective 'S3 s
|
||||
type instance TokenRegX 'S4 s = RegisterDirective 'S4 s
|
||||
type instance TokenRegX 'S5 s = Void
|
||||
|
||||
data AsmToken (t :: Subphase) (s :: *)
|
||||
= TokenOrg s (TokenOrgX t s)
|
||||
| TokenLabel s (AddressX t s) (TokenLabelX t s)
|
||||
| TokenMeta s (AddressX t s) (TokenMetaX t s)
|
||||
| TokenLit s (AddressX t s) (MimaWord t s)
|
||||
| TokenInstr s (AddressX t s) (TokenInstrX t s)
|
||||
| TokenReg s (AddressX t s) (TokenRegX t s)
|
||||
|
||||
deriving instance Show s => Show (AsmToken 'S1 s)
|
||||
deriving instance Show s => Show (AsmToken 'S2 s)
|
||||
deriving instance Show s => Show (AsmToken 'S3 s)
|
||||
deriving instance Show s => Show (AsmToken 'S4 s)
|
||||
deriving instance Show s => Show (AsmToken 'S5 s)
|
||||
|
||||
instance Onion (AsmToken t) where
|
||||
peel (TokenOrg s _) = s
|
||||
peel (TokenLabel s _ _) = s
|
||||
peel (TokenMeta s _ _) = s
|
||||
peel (TokenLit s _ _) = s
|
||||
peel (TokenInstr s _ _) = s
|
||||
peel (TokenReg s _ _) = s
|
||||
|
||||
type Phase2 t s = [AsmToken t s]
|
||||
|
||||
{- Phae 1 to Phase 2 -}
|
||||
|
||||
p1ToP2Name :: P1.Name s -> Name s
|
||||
p1ToP2Name (P1.Name s text) = Name s text
|
||||
|
||||
p1ToP2JsonValue :: P1.JsonValue s -> JsonValue s
|
||||
p1ToP2JsonValue (P1.JsonValue s value) = JsonValue s value
|
||||
|
||||
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
|
||||
|
||||
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)) =
|
||||
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 -> 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 -> 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 -> 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 -}
|
||||
|
||||
data MetaS1 s = MetaS1 s (P1.Name s) (P1.JsonValue s)
|
||||
deriving (Show)
|
||||
|
||||
instance Onion MetaS1 where
|
||||
peel (MetaS1 s _ _) = s
|
||||
|
||||
data StateS1 s = StateS1
|
||||
{ s1Metas :: Map.Map T.Text (MetaS1 s)
|
||||
, s1Tokens :: [AsmToken 'S1 s]
|
||||
} deriving (Show)
|
||||
|
||||
type WeedS1 s = StateT (StateS1 s) (Weed (WeedError s))
|
||||
|
||||
s1AddMeta :: s -> P1.Name s -> P1.JsonValue s -> WeedS1 s ()
|
||||
s1AddMeta s name@(P1.Name namePos nameText) value = do
|
||||
s1 <- get
|
||||
when (nameText `Map.member` s1Metas s1) $
|
||||
lift $ harmless $ errorWith namePos "duplicate .meta names"
|
||||
let meta = MetaS1 s name value
|
||||
put s1{s1Metas = Map.insert nameText meta $ s1Metas s1}
|
||||
|
||||
s1TakeMetas :: WeedS1 s [MetaS1 s]
|
||||
s1TakeMetas = do
|
||||
s <- get
|
||||
put s{s1Metas = Map.empty}
|
||||
pure $ Map.elems $ s1Metas s
|
||||
|
||||
s1WithMetas :: WeedS1 s () -> WeedS1 s ()
|
||||
s1WithMetas f = do
|
||||
metas <- s1TakeMetas
|
||||
for_ (reverse metas) $ \(MetaS1 s name value) ->
|
||||
s1AddToken $ TokenMeta s () $
|
||||
MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)
|
||||
f
|
||||
for_ metas $ \(MetaS1 s name _) ->
|
||||
s1AddToken $ TokenMeta s () $ MetaStop s (p1ToP2Name name)
|
||||
|
||||
s1AddToken :: AsmToken 'S1 s -> WeedS1 s ()
|
||||
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) = 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 ()
|
||||
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 $ \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)) =
|
||||
s1AddToken $ TokenMeta s () $
|
||||
MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)
|
||||
s1AddP1Token (P1.TokenDirective (P1.MetaStop s _ name)) =
|
||||
s1AddToken $ TokenMeta s () $ MetaStop s (p1ToP2Name name)
|
||||
s1AddP1Token P1.TokenComment{} = pure ()
|
||||
|
||||
phaseS1 :: P1.Phase1 s -> Weed (WeedError s) (Phase2 'S1 s)
|
||||
phaseS1 ts = do
|
||||
let initialS = StateS1 Map.empty []
|
||||
s <- flip execStateT initialS $ do
|
||||
traverse_ s1AddP1Token ts
|
||||
s1WithMetas $ pure ()
|
||||
pure $ reverse $ s1Tokens s
|
||||
|
||||
{- Subphase 2 -}
|
||||
|
||||
data StateS2 s = StateS2
|
||||
{ s2CurrentAddress :: Vm.MimaAddress
|
||||
, s2AddressFilled :: Bool
|
||||
} deriving (Show)
|
||||
|
||||
type WeedS2 s = StateT (StateS2 s) (Weed (WeedError s))
|
||||
|
||||
s2AddAddress :: s -> Int -> WeedS2 s ()
|
||||
s2AddAddress s amount = do
|
||||
s2 <- get
|
||||
s2SetAddress s (s2CurrentAddress s2 + fromIntegral amount)
|
||||
|
||||
s2SetAddress :: s -> Vm.MimaAddress -> WeedS2 s ()
|
||||
s2SetAddress s newAddress = do
|
||||
s2 <- get
|
||||
let oldAddress = s2CurrentAddress s2
|
||||
when (oldAddress > newAddress) $
|
||||
lift $ harmless $
|
||||
errorWith s "new address must not be smaller than current address"
|
||||
put $ s2{s2CurrentAddress = newAddress}
|
||||
when (newAddress /= oldAddress) $
|
||||
modify $ \s2' -> s2'{s2AddressFilled = False}
|
||||
|
||||
s2NextAddress :: s -> WeedS2 s Vm.MimaAddress
|
||||
s2NextAddress s = do
|
||||
s2 <- get
|
||||
when (s2AddressFilled s2) $ s2AddAddress s 1
|
||||
pure $ s2CurrentAddress s2
|
||||
|
||||
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
|
||||
val <- lift $ intToBounded s newAddr
|
||||
pure $ Loc2Absolute s val
|
||||
|
||||
s2ConvertMimaWord :: Vm.MimaAddress -> MimaWord 'S1 s -> WeedS2 s (MimaWord 'S2 s)
|
||||
s2ConvertMimaWord baseAddr (WordLocation loc) =
|
||||
WordLocation <$> s2ConvertLocation baseAddr loc
|
||||
s2ConvertMimaWord _ (WordRaw word) = pure $ WordRaw word
|
||||
|
||||
s2ConvertInstruction :: Vm.MimaAddress -> Instruction 'S1 s -> WeedS2 s (Instruction 'S2 s)
|
||||
s2ConvertInstruction baseAddr (SmallInstruction opcode loc) =
|
||||
SmallInstruction opcode <$> s2ConvertLocation baseAddr loc
|
||||
s2ConvertInstruction _ (LargeInstruction opcode val) =
|
||||
pure $ LargeInstruction opcode val
|
||||
|
||||
s2ConvertRegisterDirective :: Vm.MimaAddress -> RegisterDirective 'S1 s -> WeedS2 s (RegisterDirective 'S2 s)
|
||||
s2ConvertRegisterDirective baseAddr (RegIar s loc) =
|
||||
RegIar s <$> s2ConvertLocation baseAddr loc
|
||||
s2ConvertRegisterDirective baseAddr (RegAcc s word) =
|
||||
RegAcc s <$> s2ConvertMimaWord baseAddr word
|
||||
s2ConvertRegisterDirective baseAddr (RegRa s loc) =
|
||||
RegRa s <$> s2ConvertLocation baseAddr loc
|
||||
s2ConvertRegisterDirective baseAddr (RegSp s loc) =
|
||||
RegSp s <$> s2ConvertLocation baseAddr loc
|
||||
s2ConvertRegisterDirective baseAddr (RegFp s loc) =
|
||||
RegFp s <$> s2ConvertLocation baseAddr loc
|
||||
|
||||
s2ConvertP2Token :: AsmToken 'S1 s -> WeedS2 s (Maybe (AsmToken 'S2 s))
|
||||
s2ConvertP2Token (TokenOrg _ (OrgAddrAbsolute s address))
|
||||
= Nothing <$ s2SetAddress s address
|
||||
s2ConvertP2Token (TokenOrg _ (OrgAddrRelative s address))
|
||||
| address < 0 = Nothing <$ s2SetAddress s (maxBound + fromIntegral address)
|
||||
| otherwise = Nothing <$ s2AddAddress s (fromIntegral address)
|
||||
s2ConvertP2Token (TokenLabel s _ name) = do
|
||||
address <- s2CurrentAddress <$> get
|
||||
pure $ Just $ TokenLabel s address name
|
||||
s2ConvertP2Token (TokenMeta s _ meta) = do
|
||||
address <- s2CurrentAddress <$> get
|
||||
pure $ Just $ TokenMeta s address meta
|
||||
s2ConvertP2Token (TokenLit s _ word) = do
|
||||
address <- s2NextAddress s
|
||||
newWord <- s2ConvertMimaWord address word
|
||||
pure $ Just $ TokenLit s address newWord
|
||||
s2ConvertP2Token (TokenInstr s _ instr) = do
|
||||
address <- s2NextAddress s
|
||||
Just . TokenInstr s address <$> s2ConvertInstruction address instr
|
||||
s2ConvertP2Token (TokenReg s _ reg) = do
|
||||
address <- s2CurrentAddress <$> get
|
||||
Just . TokenReg s address <$> s2ConvertRegisterDirective address reg
|
||||
|
||||
phaseS2 :: Phase2 'S1 s -> Weed (WeedError s) (Phase2 'S2 s)
|
||||
phaseS2 s1 = do
|
||||
let initialS = StateS2 0 False
|
||||
catMaybes <$> evalStateT (traverse s2ConvertP2Token s1) initialS
|
||||
phase2 :: P1.Phase1 s -> Weed (WeedError s) Vm.MimaState
|
||||
phase2 = error "to be implemented"
|
||||
|
|
|
|||
138
src/Mima/Asm/Phase2/Subphase1.hs
Normal file
138
src/Mima/Asm/Phase2/Subphase1.hs
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module Mima.Asm.Phase2.Subphase1
|
||||
( subphase1
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.State
|
||||
import Data.Foldable
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
import qualified Mima.Asm.Phase1 as P1
|
||||
import Mima.Asm.Phase2.Types
|
||||
import Mima.Asm.Phase2.Util
|
||||
import Mima.Asm.Types
|
||||
import Mima.Asm.Weed
|
||||
|
||||
{- Converting phase 1 types to phase 2 types -}
|
||||
|
||||
p1ToP2Name :: P1.Name s -> Name s
|
||||
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 -> 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)) =
|
||||
pure $ Loc1Relative s offset
|
||||
p1ToP2Location (P1.LocationLabel name) = pure $ Loc1Label $ p1ToP2Name name
|
||||
p1ToP2Location (P1.LocationLabelRel s name s' offset) =
|
||||
pure $ Loc1LabelRel s (p1ToP2Name name) s' offset
|
||||
|
||||
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 -> 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 -> 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 -}
|
||||
|
||||
data SingleMeta s = SingleMeta s (P1.Name s) (P1.JsonValue s)
|
||||
deriving (Show)
|
||||
|
||||
instance Onion SingleMeta where
|
||||
peel (SingleMeta s _ _) = s
|
||||
|
||||
data StateS1 s = StateS1
|
||||
{ s1Metas :: Map.Map T.Text (SingleMeta s)
|
||||
, s1Tokens :: [AsmToken 'S1 s]
|
||||
} deriving (Show)
|
||||
|
||||
type WeedS1 s = StateT (StateS1 s) (Weed (WeedError s))
|
||||
|
||||
addMeta :: s -> P1.Name s -> P1.JsonValue s -> WeedS1 s ()
|
||||
addMeta s name@(P1.Name namePos nameText) value = do
|
||||
s1 <- get
|
||||
when (nameText `Map.member` s1Metas s1) $
|
||||
lift $ harmless $ errorWith namePos "duplicate .meta names"
|
||||
let meta = SingleMeta s name value
|
||||
put s1{s1Metas = Map.insert nameText meta $ s1Metas s1}
|
||||
|
||||
takeMetas :: WeedS1 s [SingleMeta s]
|
||||
takeMetas = do
|
||||
s <- get
|
||||
put s{s1Metas = Map.empty}
|
||||
pure $ Map.elems $ s1Metas s
|
||||
|
||||
withMetas :: WeedS1 s () -> WeedS1 s ()
|
||||
withMetas f = do
|
||||
metas <- takeMetas
|
||||
for_ (reverse metas) $ \(SingleMeta s name value) ->
|
||||
addToken $ TokenMeta s () $
|
||||
MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)
|
||||
f
|
||||
for_ metas $ \(SingleMeta s name _) ->
|
||||
addToken $ TokenMeta s () $ MetaStop s (p1ToP2Name name)
|
||||
|
||||
addToken :: AsmToken 'S1 s -> WeedS1 s ()
|
||||
addToken t = modify $ \s -> s{s1Tokens = t : s1Tokens s}
|
||||
|
||||
addP1Token :: P1.AsmToken s -> WeedS1 s ()
|
||||
addP1Token (P1.TokenLabel name) =
|
||||
addToken $ TokenLabel (peel name) () $ p1ToP2Name name
|
||||
addP1Token (P1.TokenInstruction instr) = do
|
||||
i <- p1ToP2Instruction instr
|
||||
withMetas $ addToken $ TokenInstr (peel instr) () i
|
||||
addP1Token (P1.TokenDirective (P1.Reg s _ regDir)) = do
|
||||
r <- p1ToP2RegDir regDir
|
||||
addToken $ TokenReg s () r
|
||||
addP1Token (P1.TokenDirective (P1.Org s _ addr)) = do
|
||||
withMetas $ pure ()
|
||||
a <- p1ToP2Address addr
|
||||
addToken $ TokenOrg s a
|
||||
addP1Token (P1.TokenDirective (P1.Lit s _ word)) = do
|
||||
w <- p1ToP2Word word
|
||||
withMetas $ addToken $ TokenLit s () w
|
||||
addP1Token (P1.TokenDirective (P1.Arr s _ ws)) =
|
||||
withMetas $ for_ ws $ \word -> do
|
||||
w <- p1ToP2Word word
|
||||
addToken $ TokenLit s () w
|
||||
addP1Token (P1.TokenDirective (P1.Meta s _ name value)) =
|
||||
addMeta s name value
|
||||
addP1Token (P1.TokenDirective (P1.MetaStart s _ name value)) =
|
||||
addToken $ TokenMeta s () $
|
||||
MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)
|
||||
addP1Token (P1.TokenDirective (P1.MetaStop s _ name)) =
|
||||
addToken $ TokenMeta s () $ MetaStop s (p1ToP2Name name)
|
||||
addP1Token P1.TokenComment{} = pure ()
|
||||
|
||||
subphase1 :: P1.Phase1 s -> Weed (WeedError s) (Phase2 'S1 s)
|
||||
subphase1 ts = do
|
||||
let initialS = StateS1 Map.empty []
|
||||
s <- flip execStateT initialS $ do
|
||||
traverse_ addP1Token ts
|
||||
withMetas $ pure ()
|
||||
pure $ reverse $ s1Tokens s
|
||||
105
src/Mima/Asm/Phase2/Subphase2.hs
Normal file
105
src/Mima/Asm/Phase2/Subphase2.hs
Normal file
|
|
@ -0,0 +1,105 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module Mima.Asm.Phase2.Subphase2
|
||||
( subphase2
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.State
|
||||
import Data.Maybe
|
||||
|
||||
import Mima.Asm.Phase2.Types
|
||||
import Mima.Asm.Phase2.Util
|
||||
import Mima.Asm.Weed
|
||||
import qualified Mima.Vm.Word as Vm
|
||||
|
||||
data StateS2 s = StateS2
|
||||
{ s2CurrentAddress :: Vm.MimaAddress
|
||||
, s2AddressFilled :: Bool
|
||||
} deriving (Show)
|
||||
|
||||
type WeedS2 s = StateT (StateS2 s) (Weed (WeedError s))
|
||||
|
||||
addAddress :: s -> Int -> WeedS2 s ()
|
||||
addAddress s amount = do
|
||||
s2 <- get
|
||||
setAddress s (s2CurrentAddress s2 + fromIntegral amount)
|
||||
|
||||
setAddress :: s -> Vm.MimaAddress -> WeedS2 s ()
|
||||
setAddress s newAddress = do
|
||||
s2 <- get
|
||||
let oldAddress = s2CurrentAddress s2
|
||||
when (oldAddress > newAddress) $
|
||||
lift $ harmless $
|
||||
errorWith s "new address must not be smaller than current address"
|
||||
put $ s2{s2CurrentAddress = newAddress}
|
||||
when (newAddress /= oldAddress) $
|
||||
modify $ \s2' -> s2'{s2AddressFilled = False}
|
||||
|
||||
nextAddress :: s -> WeedS2 s Vm.MimaAddress
|
||||
nextAddress s = do
|
||||
s2 <- get
|
||||
when (s2AddressFilled s2) $ addAddress s 1
|
||||
pure $ s2CurrentAddress s2
|
||||
|
||||
convertLocation :: Vm.MimaAddress -> LocationX 'S1 s -> WeedS2 s (LocationX 'S2 s)
|
||||
convertLocation _ (Loc1Absolute s addr) = pure $ Loc2Absolute s addr
|
||||
convertLocation _ (Loc1Label name) = pure $ Loc2Label name
|
||||
convertLocation _ (Loc1LabelRel s name s' offset) =
|
||||
pure $ Loc2LabelRel s name s' offset
|
||||
convertLocation baseAddr (Loc1Relative s delta) = do
|
||||
let newAddr = toInteger baseAddr + delta
|
||||
val <- lift $ intToBounded s newAddr
|
||||
pure $ Loc2Absolute s val
|
||||
|
||||
convertMimaWord :: Vm.MimaAddress -> MimaWord 'S1 s -> WeedS2 s (MimaWord 'S2 s)
|
||||
convertMimaWord baseAddr (WordLocation loc) =
|
||||
WordLocation <$> convertLocation baseAddr loc
|
||||
convertMimaWord _ (WordRaw word) = pure $ WordRaw word
|
||||
|
||||
convertInstruction :: Vm.MimaAddress -> Instruction 'S1 s -> WeedS2 s (Instruction 'S2 s)
|
||||
convertInstruction baseAddr (SmallInstruction opcode loc) =
|
||||
SmallInstruction opcode <$> convertLocation baseAddr loc
|
||||
convertInstruction _ (LargeInstruction opcode val) =
|
||||
pure $ LargeInstruction opcode val
|
||||
|
||||
convertRegisterDirective :: Vm.MimaAddress -> RegisterDirective 'S1 s -> WeedS2 s (RegisterDirective 'S2 s)
|
||||
convertRegisterDirective baseAddr (RegIar s loc) =
|
||||
RegIar s <$> convertLocation baseAddr loc
|
||||
convertRegisterDirective baseAddr (RegAcc s word) =
|
||||
RegAcc s <$> convertMimaWord baseAddr word
|
||||
convertRegisterDirective baseAddr (RegRa s loc) =
|
||||
RegRa s <$> convertLocation baseAddr loc
|
||||
convertRegisterDirective baseAddr (RegSp s loc) =
|
||||
RegSp s <$> convertLocation baseAddr loc
|
||||
convertRegisterDirective baseAddr (RegFp s loc) =
|
||||
RegFp s <$> convertLocation baseAddr loc
|
||||
|
||||
convertP2Token :: AsmToken 'S1 s -> WeedS2 s (Maybe (AsmToken 'S2 s))
|
||||
convertP2Token (TokenOrg _ (OrgAddrAbsolute s address))
|
||||
= Nothing <$ setAddress s address
|
||||
convertP2Token (TokenOrg _ (OrgAddrRelative s address))
|
||||
| address < 0 = Nothing <$ setAddress s (maxBound + fromIntegral address)
|
||||
| otherwise = Nothing <$ addAddress s (fromIntegral address)
|
||||
convertP2Token (TokenLabel s _ name) = do
|
||||
address <- s2CurrentAddress <$> get
|
||||
pure $ Just $ TokenLabel s address name
|
||||
convertP2Token (TokenMeta s _ meta) = do
|
||||
address <- s2CurrentAddress <$> get
|
||||
pure $ Just $ TokenMeta s address meta
|
||||
convertP2Token (TokenLit s _ word) = do
|
||||
address <- nextAddress s
|
||||
newWord <- convertMimaWord address word
|
||||
pure $ Just $ TokenLit s address newWord
|
||||
convertP2Token (TokenInstr s _ instr) = do
|
||||
address <- nextAddress s
|
||||
Just . TokenInstr s address <$> convertInstruction address instr
|
||||
convertP2Token (TokenReg s _ reg) = do
|
||||
address <- s2CurrentAddress <$> get
|
||||
Just . TokenReg s address <$> convertRegisterDirective address reg
|
||||
|
||||
subphase2 :: Phase2 'S1 s -> Weed (WeedError s) (Phase2 'S2 s)
|
||||
subphase2 s1 = do
|
||||
let initialS = StateS2 0 False
|
||||
catMaybes <$> evalStateT (traverse convertP2Token s1) initialS
|
||||
237
src/Mima/Asm/Phase2/Types.hs
Normal file
237
src/Mima/Asm/Phase2/Types.hs
Normal file
|
|
@ -0,0 +1,237 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Mima.Asm.Phase2.Types
|
||||
( Phase2
|
||||
, Subphase(..)
|
||||
-- * Utility types
|
||||
, Name(..)
|
||||
, AddressX
|
||||
-- * Locations
|
||||
, Location1(..)
|
||||
, Location2(..)
|
||||
, LocationX
|
||||
-- * Tokens
|
||||
, AsmToken(..)
|
||||
-- ** Org token
|
||||
, OrgAddress(..)
|
||||
, TokenOrgX
|
||||
-- ** Label token
|
||||
, TokenLabelX
|
||||
-- ** Meta token
|
||||
, JsonValue(..)
|
||||
, Meta(..)
|
||||
, TokenMetaX
|
||||
-- ** Instruction token
|
||||
, MimaWord(..)
|
||||
, Instruction(..)
|
||||
, TokenInstrX
|
||||
-- ** Register token
|
||||
, RegisterDirective(..)
|
||||
, TokenRegX
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Text as T
|
||||
import Data.Void
|
||||
import Mima.Asm.Types
|
||||
import qualified Mima.Vm.Instruction as Vm
|
||||
import qualified Mima.Vm.Word as Vm
|
||||
|
||||
data Subphase
|
||||
= S1
|
||||
-- ^ Freshly converted from 'Phase1'. Arrays are converted into multiple
|
||||
-- literal values. Comments are removed.
|
||||
| S2
|
||||
-- ^ After resolving all .org-s and relative positions and assigning each
|
||||
-- token an address.
|
||||
| S3
|
||||
-- ^ After extracting and removing all labels and .meta-s. This step results
|
||||
-- in a map to resolve labels and a complete set of .meta-* metadata.
|
||||
| S4
|
||||
-- ^ After resolving all labels. Instructions are converted into literal
|
||||
-- values.
|
||||
| S5
|
||||
-- ^ After extracting all initial register values.
|
||||
|
||||
-- | The name of a label or a meta tag.
|
||||
data Name s = Name s T.Text
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion Name where
|
||||
peel (Name s _) = s
|
||||
|
||||
-- | A location defined by an absolute or relative address or by a label.
|
||||
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 :: *)
|
||||
type instance LocationX 'S1 s = Location1 s
|
||||
type instance LocationX 'S2 s = Location2 s
|
||||
type instance LocationX 'S3 s = Location2 s
|
||||
type instance LocationX 'S4 s = Vm.MimaAddress
|
||||
type instance LocationX 'S5 s = Vm.MimaAddress
|
||||
|
||||
-- | A type family for addresses of various tokens.
|
||||
type family AddressX (t :: Subphase) (s :: *)
|
||||
type instance AddressX 'S1 s = ()
|
||||
type instance AddressX 'S2 s = Vm.MimaAddress
|
||||
type instance AddressX 'S3 s = Vm.MimaAddress
|
||||
type instance AddressX 'S4 s = Vm.MimaAddress
|
||||
type instance AddressX 'S5 s = Vm.MimaAddress
|
||||
|
||||
-- | A representation for .org addresses.
|
||||
data OrgAddress s
|
||||
= OrgAddrAbsolute s Vm.MimaAddress
|
||||
| OrgAddrRelative s Integer
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion OrgAddress where
|
||||
peel (OrgAddrAbsolute s _) = s
|
||||
peel (OrgAddrRelative s _) = s
|
||||
|
||||
type family TokenOrgX (t :: Subphase) (s :: *)
|
||||
type instance TokenOrgX 'S1 s = OrgAddress s
|
||||
type instance TokenOrgX 'S2 s = Void
|
||||
type instance TokenOrgX 'S3 s = Void
|
||||
type instance TokenOrgX 'S4 s = Void
|
||||
type instance TokenOrgX 'S5 s = Void
|
||||
|
||||
type family TokenLabelX (t :: Subphase) (s :: *)
|
||||
type instance TokenLabelX 'S1 s = Name s
|
||||
type instance TokenLabelX 'S2 s = Name s
|
||||
type instance TokenLabelX 'S3 s = Void
|
||||
type instance TokenLabelX 'S4 s = Void
|
||||
type instance TokenLabelX 'S5 s = Void
|
||||
|
||||
-- | A wrapper that annotates a 'A.Value' with an @s@ value.
|
||||
data JsonValue s = JsonValue s A.Value
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion JsonValue where
|
||||
peel (JsonValue s _) = s
|
||||
|
||||
-- | A representation for .meta-start and .meta-stop directives.
|
||||
data Meta s
|
||||
= MetaStart s (Name s) (JsonValue s)
|
||||
| MetaStop s (Name s)
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion Meta where
|
||||
peel (MetaStart s _ _) = s
|
||||
peel (MetaStop s _) = s
|
||||
|
||||
type family TokenMetaX (t :: Subphase) (s :: *)
|
||||
type instance TokenMetaX 'S1 s = Meta s
|
||||
type instance TokenMetaX 'S2 s = Meta s
|
||||
type instance TokenMetaX 'S3 s = Void
|
||||
type instance TokenMetaX 'S4 s = Void
|
||||
type instance TokenMetaX 'S5 s = Void
|
||||
|
||||
-- | A stripped-down representation of Mima words that does not have an 'Onion'
|
||||
-- instance because none is required.
|
||||
data MimaWord (t :: Subphase) (s :: *)
|
||||
= WordRaw Vm.MimaWord
|
||||
| WordLocation (LocationX t s)
|
||||
|
||||
deriving instance Show s => Show (MimaWord 'S1 s)
|
||||
deriving instance Show s => Show (MimaWord 'S2 s)
|
||||
deriving instance Show s => Show (MimaWord 'S3 s)
|
||||
deriving instance Show s => Show (MimaWord 'S4 s)
|
||||
deriving instance Show s => Show (MimaWord 'S5 s)
|
||||
|
||||
-- | A stripped-down representation of Mima instructions that does not have an
|
||||
-- 'Onion' instance because none is required.
|
||||
data Instruction (t :: Subphase) (s :: *)
|
||||
= SmallInstruction Vm.SmallOpcode (LocationX t s)
|
||||
| LargeInstruction Vm.LargeOpcode (Maybe Vm.SmallValue)
|
||||
|
||||
deriving instance Show s => Show (Instruction 'S1 s)
|
||||
deriving instance Show s => Show (Instruction 'S2 s)
|
||||
deriving instance Show s => Show (Instruction 'S3 s)
|
||||
deriving instance Show s => Show (Instruction 'S4 s)
|
||||
deriving instance Show s => Show (Instruction 'S5 s)
|
||||
|
||||
type family TokenInstrX (t :: Subphase) (s :: *)
|
||||
type instance TokenInstrX 'S1 s = Instruction 'S1 s
|
||||
type instance TokenInstrX 'S2 s = Instruction 'S2 s
|
||||
type instance TokenInstrX 'S3 s = Instruction 'S3 s
|
||||
type instance TokenInstrX 'S4 s = Void
|
||||
type instance TokenInstrX 'S5 s = Void
|
||||
|
||||
data RegisterDirective (t :: Subphase) (s :: *)
|
||||
= RegIar s (LocationX t s)
|
||||
| RegAcc s (MimaWord t s)
|
||||
| RegRa s (LocationX t s)
|
||||
| RegSp s (LocationX t s)
|
||||
| RegFp s (LocationX t s)
|
||||
|
||||
deriving instance Show s => Show (RegisterDirective 'S1 s)
|
||||
deriving instance Show s => Show (RegisterDirective 'S2 s)
|
||||
deriving instance Show s => Show (RegisterDirective 'S3 s)
|
||||
deriving instance Show s => Show (RegisterDirective 'S4 s)
|
||||
deriving instance Show s => Show (RegisterDirective 'S5 s)
|
||||
|
||||
instance Onion (RegisterDirective t) where
|
||||
peel (RegIar s _) = s
|
||||
peel (RegAcc s _) = s
|
||||
peel (RegRa s _) = s
|
||||
peel (RegSp s _) = s
|
||||
peel (RegFp s _) = s
|
||||
|
||||
type family TokenRegX (t :: Subphase) (s :: *)
|
||||
type instance TokenRegX 'S1 s = RegisterDirective 'S1 s
|
||||
type instance TokenRegX 'S2 s = RegisterDirective 'S2 s
|
||||
type instance TokenRegX 'S3 s = RegisterDirective 'S3 s
|
||||
type instance TokenRegX 'S4 s = RegisterDirective 'S4 s
|
||||
type instance TokenRegX 'S5 s = Void
|
||||
|
||||
data AsmToken (t :: Subphase) (s :: *)
|
||||
= TokenOrg s (TokenOrgX t s)
|
||||
| TokenLabel s (AddressX t s) (TokenLabelX t s)
|
||||
| TokenMeta s (AddressX t s) (TokenMetaX t s)
|
||||
| TokenLit s (AddressX t s) (MimaWord t s)
|
||||
| TokenInstr s (AddressX t s) (TokenInstrX t s)
|
||||
| TokenReg s (AddressX t s) (TokenRegX t s)
|
||||
|
||||
deriving instance Show s => Show (AsmToken 'S1 s)
|
||||
deriving instance Show s => Show (AsmToken 'S2 s)
|
||||
deriving instance Show s => Show (AsmToken 'S3 s)
|
||||
deriving instance Show s => Show (AsmToken 'S4 s)
|
||||
deriving instance Show s => Show (AsmToken 'S5 s)
|
||||
|
||||
instance Onion (AsmToken t) where
|
||||
peel (TokenOrg s _) = s
|
||||
peel (TokenLabel s _ _) = s
|
||||
peel (TokenMeta s _ _) = s
|
||||
peel (TokenLit s _ _) = s
|
||||
peel (TokenInstr s _ _) = s
|
||||
peel (TokenReg s _ _) = s
|
||||
|
||||
type Phase2 t s = [AsmToken t s]
|
||||
18
src/Mima/Asm/Phase2/Util.hs
Normal file
18
src/Mima/Asm/Phase2/Util.hs
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Mima.Asm.Phase2.Util
|
||||
( intToBounded
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Mima.Asm.Weed
|
||||
|
||||
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
|
||||
Loading…
Add table
Add a link
Reference in a new issue