From cc6dadfd3e0c7158cfba767721a34963e9551f03 Mon Sep 17 00:00:00 2001 From: Joscha Date: Sun, 5 Apr 2020 15:53:18 +0000 Subject: [PATCH] Implement subphase 3 Also... - Parse .meta-global correctly - Keep .meta until subphase 3 - Add identity functions for some phase 2 types - Minor clean ups --- src/Mima/Asm/Phase1/Format.hs | 6 +- src/Mima/Asm/Phase1/Parse.hs | 44 ++++++----- src/Mima/Asm/Phase1/Types.hs | 30 ++++---- src/Mima/Asm/Phase2/Subphase1.hs | 123 +++++++++--------------------- src/Mima/Asm/Phase2/Subphase3.hs | 124 +++++++++++++++++++++++++++++++ src/Mima/Asm/Phase2/Types.hs | 36 +++++++-- 6 files changed, 234 insertions(+), 129 deletions(-) create mode 100644 src/Mima/Asm/Phase2/Subphase3.hs diff --git a/src/Mima/Asm/Phase1/Format.hs b/src/Mima/Asm/Phase1/Format.hs index 02d626f..8353314 100644 --- a/src/Mima/Asm/Phase1/Format.hs +++ b/src/Mima/Asm/Phase1/Format.hs @@ -63,11 +63,13 @@ formatDirective (Org _ _ addr) = ".org " <> formatAddress addr formatDirective (Lit _ _ val) = ".lit " <> formatMimaWord val formatDirective (Arr _ _ vals) = ".arr [" <> T.intercalate ", " (map formatMimaWord vals) <> "]" -formatDirective (Meta _ _ n val) = - ".meta " <> formatName n <> " " <> formatJsonValue val +formatDirective (MetaGlobal _ _ n val) = + ".meta-global " <> formatName n <> " " <> formatJsonValue val formatDirective (MetaStart _ _ n val) = ".meta-start " <> formatName n <> " " <> formatJsonValue val formatDirective (MetaStop _ _ n) = ".meta-stop " <> formatName n +formatDirective (Meta _ _ n val) = + ".meta " <> formatName n <> " " <> formatJsonValue val formatToken :: AsmToken a -> T.Text formatToken (TokenLabel n) = formatName n <> ":" diff --git a/src/Mima/Asm/Phase1/Parse.hs b/src/Mima/Asm/Phase1/Parse.hs index 50f9d1b..58acca2 100644 --- a/src/Mima/Asm/Phase1/Parse.hs +++ b/src/Mima/Asm/Phase1/Parse.hs @@ -138,15 +138,38 @@ registerDirective = singleDirective RegSp "SP" location <|> singleDirective RegFp "FP" location +jsonValue :: Parser (JsonValue Span) +jsonValue = do + (valueSpan, jsonText) <- withSpan $ takeWhile1P (Just "json value") (/= '\n') + let jsonBS = BS.fromStrict $ T.encodeUtf8 jsonText + case A.eitherDecode jsonBS of + Left msg -> fail msg + Right value -> pure $ JsonValue valueSpan value + +metaValue + :: (Span -> Span -> Name Span -> JsonValue Span -> Directive Span) + -> T.Text + -> Parser (Directive Span) +metaValue constructor dirName = do + (outerSpan, (dirSpan, metaName, value)) <- withSpan $ do + (dirSpan, _) <- withSpan $ chunk dirName + inlineSpace1 + metaName <- name + inlineSpace1 + value <- jsonValue + pure (dirSpan, metaName, value) + pure $ constructor outerSpan dirSpan metaName value + directive :: Parser (Directive Span) directive = singleDirective Reg ".reg" registerDirective <|> singleDirective Org ".org" address <|> singleDirective Lit ".lit" mimaWord <|> arr <|> - metaStart MetaStart ".meta-start" <|> + metaValue MetaGlobal ".meta-global" <|> + metaValue MetaStart ".meta-start" <|> singleDirective MetaStop ".meta-stop" name <|> - metaStart Meta ".meta" + metaValue Meta ".meta" where arr = do (outerSpan, (regSpan, mimaWords)) <- withSpan $ do @@ -157,23 +180,6 @@ directive = pure (dirSpan, mimaWords) pure $ Arr outerSpan regSpan mimaWords - metaStart f keyword = do - (outerSpan, (regSpan, metaName, jsonValue)) <- withSpan $ do - (dirSpan, _) <- withSpan $ chunk keyword - inlineSpace1 - metaName <- name - inlineSpace1 - - (valueSpan, rawJsonValue) <- withSpan $ do - metaValueBS <- BS.fromStrict . T.encodeUtf8 - <$> takeWhile1P (Just "json value") (/= '\n') - case A.eitherDecode metaValueBS of - Left msg -> fail msg - Right value -> pure value - - pure (dirSpan, metaName, JsonValue valueSpan rawJsonValue) - pure $ f outerSpan regSpan metaName jsonValue - comment :: Bool -> Parser (AsmToken Span) comment inline = fmap (\(s, text) -> TokenComment s text inline) $ withSpan $ char ';' *> takeWhileP (Just "comment") (/= '\n') diff --git a/src/Mima/Asm/Phase1/Types.hs b/src/Mima/Asm/Phase1/Types.hs index 580d888..31dfa73 100644 --- a/src/Mima/Asm/Phase1/Types.hs +++ b/src/Mima/Asm/Phase1/Types.hs @@ -132,23 +132,25 @@ instance Onion JsonValue where -- | The first @a@ parameter represents the span of the whole thing. The second -- @a@ parameter represents the span of the directive literal (e. g. @.org@). data Directive a - = Reg a a (RegisterDirective a) - | Org a a (Address a) - | Lit a a (MimaWord a) - | Arr a a [MimaWord a] - | Meta a a (Name a) (JsonValue a) - | MetaStart a a (Name a) (JsonValue a) - | MetaStop a a (Name a) + = Reg a a (RegisterDirective a) + | Org a a (Address a) + | Lit a a (MimaWord a) + | Arr a a [MimaWord a] + | MetaGlobal a a (Name a) (JsonValue a) + | MetaStart a a (Name a) (JsonValue a) + | MetaStop a a (Name a) + | Meta a a (Name a) (JsonValue a) deriving (Show, Functor) instance Onion Directive where - peel (Reg a _ _) = a - peel (Org a _ _) = a - peel (Lit a _ _) = a - peel (Arr a _ _) = a - peel (Meta a _ _ _) = a - peel (MetaStart a _ _ _) = a - peel (MetaStop a _ _) = a + peel (Reg a _ _) = a + peel (Org a _ _) = a + peel (Lit a _ _) = a + peel (Arr a _ _) = a + peel (MetaGlobal a _ _ _) = a + peel (MetaStart a _ _ _) = a + peel (MetaStop a _ _) = a + peel (Meta a _ _ _) = a -- | A single token. The @s@ type parameter is the type of location annotations. data AsmToken a diff --git a/src/Mima/Asm/Phase2/Subphase1.hs b/src/Mima/Asm/Phase2/Subphase1.hs index 63f3b92..25409ff 100644 --- a/src/Mima/Asm/Phase2/Subphase1.hs +++ b/src/Mima/Asm/Phase2/Subphase1.hs @@ -4,20 +4,15 @@ 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 Data.Traversable -import qualified Mima.Asm.Phase1 as P1 +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 -} +type WeedS1 s = Weed (WeedError s) p1ToP2Name :: P1.Name s -> Name s p1ToP2Name (P1.Name s text) = Name s text @@ -26,12 +21,13 @@ 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.AddressAbsolute s addr) = + 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 + Loc1Absolute s <$> intToBounded s addr p1ToP2Location (P1.LocationAddress (P1.AddressRelative s offset)) = pure $ Loc1Relative s offset p1ToP2Location (P1.LocationLabel name) = pure $ Loc1Label $ p1ToP2Name name @@ -42,13 +38,11 @@ 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 + val <- for maybeSv $ \(P1.SmallValue s v) -> 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.WordRaw s w) = WordRaw <$> intToBounded s w p1ToP2Word (P1.WordLocation loc) = WordLocation <$> p1ToP2Location loc p1ToP2RegDir :: P1.RegisterDirective s -> WeedS1 s (RegisterDirective 'S1 s) @@ -58,81 +52,36 @@ 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 +p1ToP2Directive :: P1.Directive s -> WeedS1 s [AsmToken 'S1 s] +p1ToP2Directive (P1.Reg s _ regDir) = do r <- p1ToP2RegDir regDir - addToken $ TokenReg s () r -addP1Token (P1.TokenDirective (P1.Org s _ addr)) = do - withMetas $ pure () + pure [TokenReg s () r] +p1ToP2Directive (P1.Org s _ addr) = do a <- p1ToP2Address addr - addToken $ TokenOrg s a -addP1Token (P1.TokenDirective (P1.Lit s _ word)) = do + pure [TokenOrg s a] +p1ToP2Directive (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 () + pure [TokenLit s () w] +p1ToP2Directive (P1.Arr s _ ws) = for ws $ \word -> do + w <- p1ToP2Word word + pure $ TokenLit s () w +p1ToP2Directive (P1.MetaGlobal s _ name value) = + pure [TokenMeta s () $ MetaGlobal s (p1ToP2Name name) (p1ToP2JsonValue value)] +p1ToP2Directive (P1.MetaStart s _ name value) = + pure [TokenMeta s () $ MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)] +p1ToP2Directive (P1.MetaStop s _ name) = + pure [TokenMeta s () $ MetaStop s (p1ToP2Name name)] +p1ToP2Directive (P1.Meta s _ name value) = + pure [TokenMeta s () $ Meta s (p1ToP2Name name) (p1ToP2JsonValue value)] + +p1ToP2Token :: P1.AsmToken s -> WeedS1 s [AsmToken 'S1 s] +p1ToP2Token (P1.TokenLabel name) = + pure [TokenLabel (peel name) () $ p1ToP2Name name] +p1ToP2Token (P1.TokenInstruction instr) = do + i <- p1ToP2Instruction instr + pure [TokenInstr (peel instr) () i] +p1ToP2Token (P1.TokenDirective dir) = p1ToP2Directive dir +p1ToP2Token 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 +subphase1 ts = concat <$> traverse p1ToP2Token ts diff --git a/src/Mima/Asm/Phase2/Subphase3.hs b/src/Mima/Asm/Phase2/Subphase3.hs new file mode 100644 index 0000000..9fbd3c0 --- /dev/null +++ b/src/Mima/Asm/Phase2/Subphase3.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DataKinds #-} + +module Mima.Asm.Phase2.Subphase3 + ( subphase3 + ) where + +import Control.Monad.Trans.Class +import Control.Monad.Trans.State +import qualified Data.Aeson as A +import Data.Foldable +import Data.List +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import Data.Void + +import Mima.Asm.Phase2.Types +import Mima.Asm.Weed +import qualified Mima.Vm.Metadata as Vm +import qualified Mima.Vm.Word as Vm + +data SortedByIndex a = SortedByIndex Int a + deriving (Show) + +instance Eq (SortedByIndex a) where + (SortedByIndex a _) == (SortedByIndex b _) = a == b + +instance Ord (SortedByIndex a) where + compare (SortedByIndex a _) (SortedByIndex b _) = compare a b + +getValue :: SortedByIndex a -> a +getValue (SortedByIndex _ a) = a + +data StateS3 s = StateS3 + { s3Labels :: Map.Map T.Text Vm.MimaAddress + , s3GlobalMeta :: Vm.MetaInfo + , s3LocalMeta :: [SortedByIndex Vm.Range] + , s3OpenMetaRanges :: Map.Map T.Text [SortedByIndex (s, A.Value, Vm.MimaAddress)] + , s3Index :: Int + } deriving (Show) + +type WeedS3 s = StateT (StateS3 s) (Weed (WeedError s)) + +nextIndex :: WeedS3 s Int +nextIndex = do + s3 <- get + let i = s3Index s3 + put s3{s3Index = i + 1} + pure i + +addLabel :: Vm.MimaAddress -> Name s -> WeedS3 s () +addLabel addr (Name s nameText) = do + s3 <- get + let labels = s3Labels s3 + if nameText `Map.member` labels + then lift $ harmless $ errorWith s "label already set previously" + else put s3{s3Labels = Map.insert nameText addr labels} + +addGlobalMeta :: Name s -> A.Value -> WeedS3 s () +addGlobalMeta (Name s nameText) val = do + s3 <- get + let globalMeta = s3GlobalMeta s3 + if nameText `Map.member` globalMeta + then lift $ harmless $ errorWith s "global meta with this name already set" + else put s3 {s3GlobalMeta = Map.insert nameText val globalMeta} + +addRange :: Int -> Vm.Range -> WeedS3 s () +addRange i r = + modify $ \s3 -> s3 {s3LocalMeta = SortedByIndex i r : s3LocalMeta s3} + +addLocalMeta :: Vm.MimaAddress -> Name s -> A.Value -> WeedS3 s () +addLocalMeta addr (Name _ nameText) val = do + i <- nextIndex + addRange i $ Vm.RangeAt (Map.singleton nameText val) addr + +startLocalMeta :: Vm.MimaAddress -> s -> Name s -> A.Value -> WeedS3 s () +startLocalMeta addr s (Name _ nameText) val = do + i <- nextIndex + s3 <- get + let ranges = s3OpenMetaRanges s3 + tuple = SortedByIndex i (s, val, addr) + ranges' = Map.alter (Just . (tuple :) . fromMaybe []) nameText ranges + put s3{s3OpenMetaRanges = ranges'} + +stopLocalMeta :: Vm.MimaAddress -> Name s -> WeedS3 s () +stopLocalMeta stopAddr (Name s nameText) = do + s3 <- get + let ranges = s3OpenMetaRanges s3 + case fromMaybe [] $ ranges Map.!? nameText of + [] -> lift $ harmless $ errorWith s "closing unopened meta" + (SortedByIndex i (_, val, startAddr):xs) -> do + let range = Vm.RangeFromTo (Map.singleton nameText val) startAddr stopAddr + ranges' = Map.insert nameText xs ranges + put s3{s3OpenMetaRanges = ranges'} + addRange i range + +handleMeta :: Vm.MimaAddress -> Meta s -> WeedS3 s () +handleMeta _ (MetaGlobal _ name (JsonValue _ val)) = addGlobalMeta name val +handleMeta addr (MetaStart s name (JsonValue _ val)) = startLocalMeta addr s name val +handleMeta addr (MetaStop _ name) = stopLocalMeta addr name +handleMeta addr (Meta _ name (JsonValue _ val)) = addLocalMeta addr name val + +updateToken :: AsmToken 'S2 s -> WeedS3 s [AsmToken 'S3 s] +updateToken (TokenOrg _ x) = absurd x +updateToken (TokenLabel _ addr name) = [] <$ addLabel addr name +updateToken (TokenMeta _ addr meta) = [] <$ handleMeta addr meta +updateToken (TokenLit s addr word) = pure [TokenLit s addr $ idWord word] +updateToken (TokenInstr s addr i) = pure [TokenInstr s addr $ idInstruction i] +updateToken (TokenReg s addr reg) = pure [TokenReg s addr $ idRegDir reg] + +type ResultS3 s = (Phase2 'S3 s, Map.Map T.Text Vm.MimaAddress, Vm.Metadata) + +subphase3 :: Phase2 'S2 s -> Weed (WeedError s) (ResultS3 s) +subphase3 tokens = do + let initialS = StateS3 Map.empty Map.empty [] Map.empty 0 + (newTokens, finalS) <- runStateT (traverse updateToken tokens) initialS + let labels = s3Labels finalS + global = s3GlobalMeta finalS + local = map getValue $ sort $ s3LocalMeta finalS + metadata = Vm.Metadata global local + openRanges = map getValue $ concat $ Map.elems $ s3OpenMetaRanges finalS + for_ openRanges $ \(s, _, _) -> + harmless $ errorWith s "meta range was not closed" + pure (concat newTokens, labels, metadata) diff --git a/src/Mima/Asm/Phase2/Types.hs b/src/Mima/Asm/Phase2/Types.hs index dd8a0e6..5b8121e 100644 --- a/src/Mima/Asm/Phase2/Types.hs +++ b/src/Mima/Asm/Phase2/Types.hs @@ -27,10 +27,13 @@ module Mima.Asm.Phase2.Types , TokenMetaX -- ** Instruction token , MimaWord(..) + , idWord , Instruction(..) + , idInstruction , TokenInstrX -- ** Register token , RegisterDirective(..) + , idRegDir , TokenRegX ) where @@ -46,11 +49,11 @@ data Subphase -- ^ 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 + -- ^ 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. + -- ^ 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. @@ -139,13 +142,17 @@ instance Onion JsonValue where -- | A representation for .meta-start and .meta-stop directives. data Meta s - = MetaStart s (Name s) (JsonValue s) - | MetaStop s (Name s) + = Meta s (Name s) (JsonValue s) + | MetaStart s (Name s) (JsonValue s) + | MetaStop s (Name s) + | MetaGlobal s (Name s) (JsonValue s) deriving (Show, Functor) instance Onion Meta where - peel (MetaStart s _ _) = s - peel (MetaStop s _) = s + peel (Meta s _ _) = s + peel (MetaStart s _ _) = s + peel (MetaStop s _) = s + peel (MetaGlobal s _ _) = s type family TokenMetaX (t :: Subphase) (s :: *) type instance TokenMetaX 'S1 s = Meta s @@ -160,6 +167,10 @@ data MimaWord (t :: Subphase) (s :: *) = WordRaw Vm.MimaWord | WordLocation (LocationX t s) +idWord :: (LocationX a s ~ LocationX b s) => MimaWord a s -> MimaWord b s +idWord (WordRaw word) = WordRaw word +idWord (WordLocation loc) = WordLocation loc + deriving instance Show s => Show (MimaWord 'S1 s) deriving instance Show s => Show (MimaWord 'S2 s) deriving instance Show s => Show (MimaWord 'S3 s) @@ -172,6 +183,10 @@ data Instruction (t :: Subphase) (s :: *) = SmallInstruction Vm.SmallOpcode (LocationX t s) | LargeInstruction Vm.LargeOpcode (Maybe Vm.SmallValue) +idInstruction :: (LocationX a s ~ LocationX b s) => Instruction a s -> Instruction b s +idInstruction (SmallInstruction so loc) = SmallInstruction so loc +idInstruction (LargeInstruction lo sv) = LargeInstruction lo sv + deriving instance Show s => Show (Instruction 'S1 s) deriving instance Show s => Show (Instruction 'S2 s) deriving instance Show s => Show (Instruction 'S3 s) @@ -192,6 +207,13 @@ data RegisterDirective (t :: Subphase) (s :: *) | RegSp s (LocationX t s) | RegFp s (LocationX t s) +idRegDir :: (LocationX a s ~ LocationX b s) => RegisterDirective a s -> RegisterDirective b s +idRegDir (RegIar s loc) = RegIar s loc +idRegDir (RegAcc s word) = RegAcc s $ idWord word +idRegDir (RegRa s loc) = RegRa s loc +idRegDir (RegSp s loc) = RegSp s loc +idRegDir (RegFp s loc) = RegFp s loc + deriving instance Show s => Show (RegisterDirective 'S1 s) deriving instance Show s => Show (RegisterDirective 'S2 s) deriving instance Show s => Show (RegisterDirective 'S3 s)