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

@@ -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) =
+formatDirective (MetaGlobal _ _ n val) =
-  ".meta " <> formatName n <> " " <> formatJsonValue 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 <> ":"

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')

src/Mima/Asm/Phase1/Types.hs

@@ -136,9 +136,10 @@ data Directive a
   | Org        a a (Address a)
   | Lit        a a (MimaWord a)
   | Arr        a a [MimaWord a]
-  | Meta      a a (Name a) (JsonValue 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
@@ -146,9 +147,10 @@ instance Onion Directive where
   peel (Org        a _ _)   = a
   peel (Lit        a _ _)   = a
   peel (Arr        a _ _)   = a
-  peel (Meta      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

src/Mima/Asm/Phase2/Subphase1.hs

@@ -4,12 +4,7 @@ module Mima.Asm.Phase2.Subphase1
   ( subphase1
   ) where
 
-import           Control.Monad
+import           Data.Traversable
-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
@@ -17,7 +12,7 @@ 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
+  val <- for maybeSv $ \(P1.SmallValue s v) -> intToBounded s v
-    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.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 -}
+p1ToP2Directive :: P1.Directive s -> WeedS1 s [AsmToken 'S1 s]
-
+p1ToP2Directive (P1.Reg s _ regDir) = do
-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
+  pure [TokenReg s () r]
-addP1Token (P1.TokenDirective (P1.Org s _ addr)) = do
+p1ToP2Directive (P1.Org s _ addr) = do
-  withMetas $ pure ()
   a <- p1ToP2Address addr
-  addToken $ TokenOrg s a
+  pure [TokenOrg s a]
-addP1Token (P1.TokenDirective (P1.Lit s _ word)) = do
+p1ToP2Directive (P1.Lit s _ word) = do
   w <- p1ToP2Word word
-  withMetas $ addToken $ TokenLit s () w
+  pure [TokenLit s () w]
-addP1Token (P1.TokenDirective (P1.Arr s _ ws)) =
+p1ToP2Directive (P1.Arr s _ ws) = for ws $ \word -> do
-  withMetas $ for_ ws $ \word -> do
   w <- p1ToP2Word word
-    addToken $ TokenLit s () w
+  pure $ TokenLit s () w
-addP1Token (P1.TokenDirective (P1.Meta s _ name value)) =
+p1ToP2Directive (P1.MetaGlobal s _ name value) =
-  addMeta s name value
+  pure [TokenMeta s () $ MetaGlobal s (p1ToP2Name name) (p1ToP2JsonValue value)]
-addP1Token (P1.TokenDirective (P1.MetaStart s _ name value)) =
+p1ToP2Directive (P1.MetaStart s _ name value) =
-  addToken $ TokenMeta s () $
+  pure [TokenMeta s () $ MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)]
-  MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)
+p1ToP2Directive (P1.MetaStop s _ name) =
-addP1Token (P1.TokenDirective (P1.MetaStop s _ name)) =
+  pure [TokenMeta s () $ MetaStop s (p1ToP2Name name)]
-  addToken $ TokenMeta s () $ MetaStop s (p1ToP2Name name)
+p1ToP2Directive (P1.Meta s _ name value) =
-addP1Token P1.TokenComment{} = pure ()
+  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
+subphase1 ts = concat <$> traverse p1ToP2Token ts
-  let initialS = StateS1 Map.empty []
-  s <- flip execStateT initialS $ do
-    traverse_ addP1Token ts
-    withMetas $ pure ()
-  pure $ reverse $ s1Tokens s

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)

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
+  -- ^ 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.
+  -- 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)
+  = 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 (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)