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

Split up phase 2 into multiple modules

Browse source
This commit is contained in:
Joscha 2020-04-05 09:51:24 +00:00
parent d82ce69b1b
commit 8d0e70cf5d
5 changed files with 503 additions and 436 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,441 +1,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Mima.Asm.Phase2 module Mima.Asm.Phase2
( phaseS1 -- TODO only leave the proper types ( phase2
, phaseS2
) where ) 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 qualified Mima.Asm.Phase1 as P1
import Mima.Asm.Types
import Mima.Asm.Weed import Mima.Asm.Weed
import qualified Mima.Vm.Instruction as Vm import qualified Mima.Vm.State as Vm
import qualified Mima.Vm.Word as Vm
data Subphase phase2 :: P1.Phase1 s -> Weed (WeedError s) Vm.MimaState
= S1 phase2 = error "to be implemented"
-- ^ 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

138
src/Mima/Asm/Phase2/Subphase1.hs Normal file
View 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
View 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
View 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
View 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