Attempt to clean up phase 2
This commit is contained in:
parent
5fe7b26daf
commit
96c28c1f31
3 changed files with 172 additions and 63 deletions
|
|
@ -2,9 +2,9 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Mima.Asm.Phase1
|
||||
( Onion(..)
|
||||
(
|
||||
-- * Types
|
||||
, Name(..)
|
||||
Name(..)
|
||||
, Address(..)
|
||||
, Location(..)
|
||||
, SmallOpcode(..)
|
||||
|
|
@ -38,6 +38,7 @@ import Text.Megaparsec
|
|||
import Text.Megaparsec.Char
|
||||
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
|
||||
|
|
@ -61,9 +62,6 @@ import qualified Mima.Vm.Word as Vm
|
|||
.meta-stop <name>
|
||||
-}
|
||||
|
||||
class Onion o where
|
||||
peel :: o a -> a
|
||||
|
||||
{- Types -}
|
||||
|
||||
data Name a = Name a T.Text
|
||||
|
|
|
|||
|
|
@ -1,20 +1,26 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Mima.Asm.Phase2
|
||||
( phaseS1
|
||||
( phaseS1 -- TODO only leave the proper types
|
||||
) 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 qualified Data.Text as T
|
||||
import Data.Void
|
||||
|
||||
import qualified Mima.Asm.Phase1 as P1
|
||||
import Mima.Asm.Types
|
||||
import Mima.Asm.Weed
|
||||
import qualified Mima.Vm.Instruction as Vm
|
||||
import qualified Mima.Vm.Word as Vm
|
||||
|
||||
data Subphase
|
||||
|
|
@ -33,18 +39,44 @@ data Subphase
|
|||
| S5
|
||||
-- ^ After extracting all initial register values.
|
||||
|
||||
data LocationNoRel a
|
||||
= LocationNoRelAddress a Vm.MimaAddress
|
||||
| LocationNoRelLabel (P1.Name a)
|
||||
deriving (Show)
|
||||
-- | 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)
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion Location1 where
|
||||
peel (Loc1Absolute s _) = s
|
||||
peel (Loc1Relative s _) = s
|
||||
peel (Loc1Label l) = peel l
|
||||
|
||||
-- | A location defined by an absolute address or by a label.
|
||||
data Location2 s
|
||||
= Loc2Absolute s Vm.MimaAddress
|
||||
| Loc2Label (Name s)
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion Location2 where
|
||||
peel (Loc2Absolute s _) = s
|
||||
peel (Loc2Label l) = peel l
|
||||
|
||||
-- | A type family for locations in various stages of resolution.
|
||||
type family LocationX (t :: Subphase) (s :: *)
|
||||
type instance LocationX 'S1 s = P1.Location s
|
||||
type instance LocationX 'S2 s = LocationNoRel s
|
||||
type instance LocationX 'S3 s = LocationNoRel 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
|
||||
|
|
@ -52,24 +84,46 @@ 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 = P1.Address 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 = P1.Name s
|
||||
type instance TokenLabelX 'S2 s = P1.Name 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 (P1.Name s) (P1.JsonValue s)
|
||||
| MetaStop (P1.Name s)
|
||||
deriving (Show)
|
||||
= 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
|
||||
|
|
@ -78,27 +132,49 @@ 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 s Vm.MimaWord
|
||||
= 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 (P1.SmallOpcode s) (LocationX t s)
|
||||
| LargeInstruction (P1.LargeOpcode s) (Maybe (P1.SmallValue 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 = Instruction 'S4 s
|
||||
type instance TokenInstrX 'S4 s = Void
|
||||
type instance TokenInstrX 'S5 s = Void
|
||||
|
||||
data RegisterDirective (t :: Subphase) (s :: *)
|
||||
= RegIar s s (LocationX t s)
|
||||
| RegAcc s s (MimaWord t s)
|
||||
| RegRa s s (LocationX t s)
|
||||
| RegSp s s (LocationX t s)
|
||||
| RegFp s s (LocationX t 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)
|
||||
|
||||
type family TokenRegX (t :: Subphase) (s :: *)
|
||||
type instance TokenRegX 'S1 s = RegisterDirective 'S1 s
|
||||
|
|
@ -115,20 +191,60 @@ data AsmToken (t :: Subphase) (s :: *)
|
|||
| TokenInstr (AddressX t s) (TokenInstrX t s)
|
||||
| TokenReg (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)
|
||||
|
||||
type Phase2 t s = [AsmToken t s]
|
||||
|
||||
{- Subphase 1 -}
|
||||
|
||||
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 -> OrgAddress s
|
||||
p1ToP2Address (P1.AddressAbsolute s addr) = OrgAddrAbsolute s addr
|
||||
p1ToP2Address (P1.AddressRelative s offset) = OrgAddrRelative s offset
|
||||
|
||||
p1ToP2Location :: P1.Location s -> Location1 s
|
||||
p1ToP2Location (P1.LocationAddress (P1.AddressAbsolute s addr)) =
|
||||
Loc1Absolute s addr
|
||||
p1ToP2Location (P1.LocationAddress (P1.AddressRelative s offset)) =
|
||||
Loc1Relative s offset
|
||||
p1ToP2Location (P1.LocationLabel name) = Loc1Label $ p1ToP2Name name
|
||||
|
||||
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
|
||||
|
||||
p1ToP2Word :: P1.MimaWord s -> MimaWord 'S1 s
|
||||
p1ToP2Word (P1.WordRaw _ w) = WordRaw 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
|
||||
|
||||
data MetaS1 s = MetaS1 s s (P1.Name s) (P1.JsonValue s)
|
||||
deriving (Show)
|
||||
|
||||
instance P1.Onion MetaS1 where
|
||||
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))
|
||||
|
||||
|
|
@ -149,48 +265,37 @@ s1TakeMetas = do
|
|||
s1WithMetas :: WeedS1 s () -> WeedS1 s ()
|
||||
s1WithMetas f = do
|
||||
metas <- s1TakeMetas
|
||||
for_ (reverse metas) $ \(MetaS1 _ _ name value) ->
|
||||
s1AddToken $ TokenMeta () $ MetaStart name value
|
||||
for_ (reverse metas) $ \(MetaS1 s _ name value) ->
|
||||
s1AddToken $ TokenMeta () $
|
||||
MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)
|
||||
f
|
||||
for_ metas $ \(MetaS1 _ _ name _) ->
|
||||
s1AddToken $ TokenMeta () $ MetaStop name
|
||||
for_ metas $ \(MetaS1 s _ name _) ->
|
||||
s1AddToken $ TokenMeta () $
|
||||
MetaStop s (p1ToP2Name name)
|
||||
|
||||
s1AddToken :: AsmToken 'S1 s -> WeedS1 s ()
|
||||
s1AddToken t = modify $ \s -> s{s1Tokens = t : s1Tokens s}
|
||||
|
||||
p1InstrToP2Instr :: P1.Instruction s -> Instruction 'S1 s
|
||||
p1InstrToP2Instr (P1.SmallInstruction _ so loc) = SmallInstruction so loc
|
||||
p1InstrToP2Instr (P1.LargeInstruction _ lo sv) = LargeInstruction lo sv
|
||||
|
||||
p1WordToP2Word :: P1.MimaWord s -> MimaWord 'S1 s
|
||||
p1WordToP2Word (P1.WordRaw s w) = WordRaw s w
|
||||
p1WordToP2Word (P1.WordLocation loc) = WordLocation loc
|
||||
|
||||
p1RegDirToP2RegDir :: P1.RegisterDirective s -> RegisterDirective 'S1 s
|
||||
p1RegDirToP2RegDir (P1.RegIar s1 s2 loc) = RegIar s1 s2 loc
|
||||
p1RegDirToP2RegDir (P1.RegAcc s1 s2 word) = RegAcc s1 s2 $ p1WordToP2Word word
|
||||
p1RegDirToP2RegDir (P1.RegRa s1 s2 loc) = RegRa s1 s2 loc
|
||||
p1RegDirToP2RegDir (P1.RegSp s1 s2 loc) = RegSp s1 s2 loc
|
||||
p1RegDirToP2RegDir (P1.RegFp s1 s2 loc) = RegFp s1 s2 loc
|
||||
|
||||
s1AddP1Token :: P1.AsmToken s -> WeedS1 s ()
|
||||
s1AddP1Token (P1.TokenLabel name) = s1AddToken $ TokenLabel () name
|
||||
s1AddP1Token (P1.TokenLabel name) =
|
||||
s1AddToken $ TokenLabel () $ p1ToP2Name name
|
||||
s1AddP1Token (P1.TokenInstruction instr) =
|
||||
s1AddToken $ TokenInstr () $ p1InstrToP2Instr instr
|
||||
s1AddToken $ TokenInstr () $ p1ToP2Instruction instr
|
||||
s1AddP1Token (P1.TokenDirective (P1.Reg _ _ regDir)) =
|
||||
s1AddToken $ TokenReg () $ p1RegDirToP2RegDir regDir
|
||||
s1AddToken $ TokenReg () $ p1ToP2RegDir regDir
|
||||
s1AddP1Token (P1.TokenDirective (P1.Org _ _ addr)) =
|
||||
s1AddToken $ TokenOrg addr
|
||||
s1AddToken $ TokenOrg $ p1ToP2Address addr
|
||||
s1AddP1Token (P1.TokenDirective (P1.Lit _ _ w)) =
|
||||
s1WithMetas $ s1AddToken $ TokenLit () $ p1WordToP2Word w
|
||||
s1WithMetas $ s1AddToken $ TokenLit () $ p1ToP2Word w
|
||||
s1AddP1Token (P1.TokenDirective (P1.Arr _ _ ws)) =
|
||||
s1WithMetas $ for_ ws $ s1AddToken . TokenLit () . p1WordToP2Word
|
||||
s1WithMetas $ for_ ws $ s1AddToken . TokenLit () . p1ToP2Word
|
||||
s1AddP1Token (P1.TokenDirective (P1.Meta s1 s2 name value)) =
|
||||
s1AddMeta s1 s2 name value
|
||||
s1AddP1Token (P1.TokenDirective (P1.MetaStart _ _ name value)) =
|
||||
s1AddToken $ TokenMeta () $ MetaStart name value
|
||||
s1AddP1Token (P1.TokenDirective (P1.MetaStop _ _ name)) =
|
||||
s1AddToken $ TokenMeta () $ MetaStop name
|
||||
s1AddP1Token (P1.TokenDirective (P1.MetaStart s _ name value)) =
|
||||
s1AddToken $ TokenMeta () $
|
||||
MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)
|
||||
s1AddP1Token (P1.TokenDirective (P1.MetaStop s _ name)) =
|
||||
s1AddToken $ TokenMeta () $ MetaStop s (p1ToP2Name name)
|
||||
s1AddP1Token P1.TokenComment{} = pure ()
|
||||
|
||||
phaseS1 :: P1.Phase1 s -> Weed (WeedError s) (Phase2 'S1 s)
|
||||
|
|
@ -198,5 +303,5 @@ phaseS1 ts = do
|
|||
let initialS = StateS1 Map.empty []
|
||||
s <- execStateT (traverse_ s1AddP1Token ts) initialS
|
||||
for_ (Map.elems $ s1Metas s) $ \m ->
|
||||
harmless $ errorWith (P1.peel m) "unconsumed .meta"
|
||||
harmless $ errorWith (peel m) "unconsumed .meta"
|
||||
pure $ s1Tokens s
|
||||
|
|
|
|||
6
src/Mima/Asm/Types.hs
Normal file
6
src/Mima/Asm/Types.hs
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
module Mima.Asm.Types
|
||||
( Onion(..)
|
||||
) where
|
||||
|
||||
class Onion o where
|
||||
peel :: o a -> a
|
||||
Loading…
Add table
Add a link
Reference in a new issue