Implement subphase4

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
+  pure $ LocRelative s offset
-p1ToP2Location (P1.LocationLabel name) = pure $ Loc1Label $ p1ToP2Name name
+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) =

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 $ idWord word
-  pure $ Just $ TokenLit s address newWord
 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

src/Mima/Asm/Phase2/Subphase3.hs

@@ -2,6 +2,7 @@
 
 module Mima.Asm.Phase2.Subphase3
   ( subphase3
+  , ResultS3
   ) where
 
 import           Control.Monad.Trans.Class

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

src/Mima/Asm/Phase2/Types.hs

@@ -11,8 +11,7 @@ module Mima.Asm.Phase2.Types
   , Name(..)
   , AddressX
   -- * Locations
-  , Location1(..)
+  , Location(..)
-  , Location2(..)
   , 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
+data Location s
-  = Loc1Absolute s Vm.MimaAddress
+  = LocAbsolute s Vm.MimaAddress
-  | Loc1Relative s Integer
+  | LocRelative s Integer
-  | Loc1Label (Name s)
+  | LocLabel (Name s)
-  | Loc1LabelRel s (Name s) s Integer
+  | LocLabelRel s (Name s) s Integer
   deriving (Show, Functor)
 
-instance Onion Location1 where
+instance Onion Location where
-  peel (Loc1Absolute s _)     = s
+  peel (LocAbsolute s _)     = s
-  peel (Loc1Relative s _)     = s
+  peel (LocRelative s _)     = s
-  peel (Loc1Label l)          = peel l
+  peel (LocLabel l)          = peel l
-  peel (Loc1LabelRel s _ _ _) = s
+  peel (LocLabelRel 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 'S1 s = Location s
-type instance LocationX 'S2 s = Location2 s
+type instance LocationX 'S2 s = Location s
-type instance LocationX 'S3 s = Location2 s
+type instance LocationX 'S3 s = Location s
 type instance LocationX 'S4 s = Vm.MimaAddress
 type instance LocationX 'S5 s = Vm.MimaAddress