From 7f6e987c33a60e5f5071d7d1cb527e15f276db85 Mon Sep 17 00:00:00 2001 From: I-Al-Istannen Date: Wed, 8 Apr 2020 16:29:50 +0200 Subject: [PATCH] Implement subphase4 --- src/Mima/Asm/Phase2/Subphase1.hs | 10 ++-- src/Mima/Asm/Phase2/Subphase2.hs | 41 +------------- src/Mima/Asm/Phase2/Subphase3.hs | 1 + src/Mima/Asm/Phase2/Subphase4.hs | 94 ++++++++++++++++++++++++++++++++ src/Mima/Asm/Phase2/Types.hs | 41 +++++--------- 5 files changed, 117 insertions(+), 70 deletions(-) create mode 100644 src/Mima/Asm/Phase2/Subphase4.hs diff --git a/src/Mima/Asm/Phase2/Subphase1.hs b/src/Mima/Asm/Phase2/Subphase1.hs index 25409ff..3772d5b 100644 --- a/src/Mima/Asm/Phase2/Subphase1.hs +++ b/src/Mima/Asm/Phase2/Subphase1.hs @@ -25,14 +25,14 @@ 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.Location s -> WeedS1 s (Location s) p1ToP2Location (P1.LocationAddress (P1.AddressAbsolute s addr)) = - Loc1Absolute s <$> intToBounded s addr + LocAbsolute s <$> intToBounded s addr p1ToP2Location (P1.LocationAddress (P1.AddressRelative s offset)) = - pure $ Loc1Relative s offset -p1ToP2Location (P1.LocationLabel name) = pure $ Loc1Label $ p1ToP2Name name + pure $ LocRelative s offset +p1ToP2Location (P1.LocationLabel name) = pure $ LocLabel $ p1ToP2Name name p1ToP2Location (P1.LocationLabelRel s name s' offset) = - pure $ Loc1LabelRel s (p1ToP2Name name) s' offset + pure $ LocLabelRel s (p1ToP2Name name) s' offset p1ToP2Instruction :: P1.Instruction s -> WeedS1 s (Instruction 'S1 s) p1ToP2Instruction (P1.SmallInstruction _ (P1.SmallOpcode _ so) loc) = diff --git a/src/Mima/Asm/Phase2/Subphase2.hs b/src/Mima/Asm/Phase2/Subphase2.hs index e972867..0d399ca 100644 --- a/src/Mima/Asm/Phase2/Subphase2.hs +++ b/src/Mima/Asm/Phase2/Subphase2.hs @@ -10,7 +10,6 @@ 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 @@ -43,39 +42,6 @@ nextAddress s = do 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 @@ -90,14 +56,13 @@ convertP2Token (TokenMeta s _ meta) = do pure $ Just $ TokenMeta s address meta convertP2Token (TokenLit s _ word) = do address <- nextAddress s - newWord <- convertMimaWord address word - pure $ Just $ TokenLit s address newWord + pure $ Just $ TokenLit s address $ idWord word convertP2Token (TokenInstr s _ instr) = do address <- nextAddress s - Just . TokenInstr s address <$> convertInstruction address instr + pure $ Just $ TokenInstr s address $ idInstruction instr convertP2Token (TokenReg s _ reg) = do address <- s2CurrentAddress <$> get - Just . TokenReg s address <$> convertRegisterDirective address reg + pure $ Just $ TokenReg s address $ idRegDir reg subphase2 :: Phase2 'S1 s -> Weed (WeedError s) (Phase2 'S2 s) subphase2 s1 = do diff --git a/src/Mima/Asm/Phase2/Subphase3.hs b/src/Mima/Asm/Phase2/Subphase3.hs index 9fbd3c0..21fc23c 100644 --- a/src/Mima/Asm/Phase2/Subphase3.hs +++ b/src/Mima/Asm/Phase2/Subphase3.hs @@ -2,6 +2,7 @@ module Mima.Asm.Phase2.Subphase3 ( subphase3 + , ResultS3 ) where import Control.Monad.Trans.Class diff --git a/src/Mima/Asm/Phase2/Subphase4.hs b/src/Mima/Asm/Phase2/Subphase4.hs new file mode 100644 index 0000000..e6f4d66 --- /dev/null +++ b/src/Mima/Asm/Phase2/Subphase4.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} + +module Mima.Asm.Phase2.Subphase4 + ( subphase4 + , throughThePhases + ) where + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Void +import Text.Megaparsec + +import Mima.Asm.Phase1.Parse +import Mima.Asm.Phase2.Subphase1 +import Mima.Asm.Phase2.Subphase2 +import Mima.Asm.Phase2.Subphase3 +import Mima.Asm.Phase2.Types +import Mima.Asm.Weed +import qualified Mima.Vm.Instruction as Vm +import qualified Mima.Vm.Word as Vm + +type WeedS4 s = ReaderT (Map.Map T.Text Vm.MimaAddress) (Weed (WeedError s)) + +resolveLabel :: Name s -> WeedS4 s Vm.MimaAddress +resolveLabel (Name s nameText) = do + labels <- ask + case labels Map.!? nameText of + Nothing -> lift $ critical $ errorWith s "unknown label" + Just addr -> pure addr + +resolveRelative :: s -> Vm.MimaAddress -> Integer -> WeedS4 s Vm.MimaAddress +resolveRelative s base offset = do + let maxValue = toInteger (maxBound :: Vm.MimaAddress) + res = toInteger base + offset + when (res < 0 || res > maxValue) $ + lift $ harmless $ errorWith s $ "address " ++ show res ++ " out of bounds" + pure $ fromInteger res + +resolveLocation :: Vm.MimaAddress -> Location s -> WeedS4 s Vm.MimaAddress +resolveLocation _ (LocAbsolute _ addr) = pure addr +resolveLocation baseAddr (LocRelative s offset) = + resolveRelative s baseAddr offset +resolveLocation _ (LocLabel name) = resolveLabel name +resolveLocation _ (LocLabelRel s name _ offset) = do + baseAddr <- resolveLabel name + resolveRelative s baseAddr offset + +convertInstruction :: Vm.MimaAddress -> Instruction 'S3 s -> WeedS4 s Vm.Instruction +convertInstruction baseAddr (SmallInstruction so loc) = + Vm.SmallInstruction so <$> resolveLocation baseAddr loc +convertInstruction _ (LargeInstruction lo mv) = + pure $ Vm.LargeInstruction lo $ fromMaybe 0 mv + +resolveWord :: Vm.MimaAddress -> MimaWord 'S3 s -> WeedS4 s (MimaWord 'S4 s) +resolveWord _ (WordRaw w) = pure $ WordRaw w +resolveWord baseAddr (WordLocation loc) = + WordLocation <$> resolveLocation baseAddr loc + +resolveReg :: Vm.MimaAddress -> RegisterDirective 'S3 s -> WeedS4 s (RegisterDirective 'S4 s) +resolveReg baseAddr (RegAcc s word) = RegAcc s <$> resolveWord baseAddr word +resolveReg baseAddr (RegIar s loc) = RegIar s <$> resolveLocation baseAddr loc +resolveReg baseAddr (RegRa s loc) = RegRa s <$> resolveLocation baseAddr loc +resolveReg baseAddr (RegSp s loc) = RegSp s <$> resolveLocation baseAddr loc +resolveReg baseAddr (RegFp s loc) = RegFp s <$> resolveLocation baseAddr loc + +updateToken :: AsmToken 'S3 s -> WeedS4 s (AsmToken 'S4 s) +updateToken (TokenOrg _ v) = absurd v +updateToken (TokenLabel _ _ v) = absurd v +updateToken (TokenMeta _ _ v) = absurd v +updateToken (TokenLit s addr word) = + TokenLit s addr <$> resolveWord addr word +updateToken (TokenInstr s addr instr) = + TokenLit s addr . WordRaw . Vm.instructionToWord <$> convertInstruction addr instr +updateToken (TokenReg s addr reg) = TokenReg s addr <$> resolveReg addr reg + +subphase4 :: Map.Map T.Text Vm.MimaAddress -> Phase2 'S3 s -> Weed (WeedError s) (Phase2 'S4 s) +subphase4 labelMap phase2 = runReaderT (traverse updateToken phase2) labelMap + +throughThePhases :: String -> IO (Phase2 'S4 Span) +throughThePhases name = do + text <- T.readFile name + let Right res1 = parse parsePhase1 name text + let Right s1 = runWeed $ subphase1 res1 + let Right s2 = runWeed $ subphase2 s1 + _ <- traverse print s2 + putStrLn "HEY" + let Right (s3, m, _) = runWeed $ subphase3 s2 + let Right s4 = runWeed $ subphase4 m s3 + pure s4 diff --git a/src/Mima/Asm/Phase2/Types.hs b/src/Mima/Asm/Phase2/Types.hs index 5b8121e..4dc88cd 100644 --- a/src/Mima/Asm/Phase2/Types.hs +++ b/src/Mima/Asm/Phase2/Types.hs @@ -11,8 +11,7 @@ module Mima.Asm.Phase2.Types , Name(..) , AddressX -- * Locations - , Location1(..) - , Location2(..) + , Location(..) , LocationX -- * Tokens , AsmToken(..) @@ -68,36 +67,24 @@ 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 +data Location s + = LocAbsolute s Vm.MimaAddress + | LocRelative s Integer + | LocLabel (Name s) + | LocLabelRel 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 +instance Onion Location where + peel (LocAbsolute s _) = s + peel (LocRelative s _) = s + peel (LocLabel l) = peel l + peel (LocLabelRel 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 'S1 s = Location s +type instance LocationX 'S2 s = Location s +type instance LocationX 'S3 s = Location s type instance LocationX 'S4 s = Vm.MimaAddress type instance LocationX 'S5 s = Vm.MimaAddress