Add offset information to some AST elements.wip

4 files changed, 45 insertions, 27 deletions

diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 73c4303..1e9ace7 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -13,6 +13,8 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     FiddleUnitInterface,
     QualificationMetadata,
     CommonQualificationData (..),
+    RegisterOffset,
+    BitsOffset,
     -- Witness Types
     Witness (..),
     WitnessType,
@@ -59,6 +61,7 @@ import Data.Text (Text)
 import Data.Type.Bool
 import Data.Typeable
 import Data.Void (Void)
+import Data.Word (Word32)
 import GHC.Generics
 import Language.Fiddle.Ast.Internal.Instances
 import Language.Fiddle.Ast.Internal.Kinds
@@ -73,6 +76,16 @@ newtype CommonQualificationData
   }
   deriving (Eq, Ord, Show)
 
+type BitsOffset stage = RegisterOffset stage
+
+-- | Type used for the RegisterOffset type. This is populated in the check
+-- stage, which will attach the appropriate offset to the register. This helps
+-- backends so they don't have to recalculate this offset.
+type family RegisterOffset stage where
+  RegisterOffset stage = If (stage < Checked) () Word32
+
+-- | Type which stores metadata after qualification. Before qualification, this
+-- metadata has not been calculated and so is unset.
 type family QualificationMetadata stage t where
   QualificationMetadata stage t =
     If (stage < Qualified) () t
@@ -470,7 +483,10 @@ data ObjTypeDecl stage f a where
     ObjTypeDecl stage f a
   -- | A register declaration.
   RegisterDecl ::
-    { -- | Optional register modifier.
+    { -- | Offset within the register. Calculated during the consistency check.
+      -- The offset is calculated from the top-level structure.
+      regOffset :: RegisterOffset stage,
+      -- | Optional register modifier.
       regModifier :: Maybe (Modifier f a),
       -- | Optional register identifier.
       regIdent :: Maybe (Identifier f a),
@@ -569,7 +585,10 @@ data RegisterBitsDecl stage f a where
     RegisterBitsDecl stage f a
   -- | Declaration for defined bits in a register.
   DefinedBits ::
-    { -- | Optional modifier for the bits.
+    { -- | The offset for these bits. This is calculated during the
+      -- ConsistencyCheck phase, so until this phase it's just ().
+      definedBitsOffset :: BitsOffset stage,
+      -- | Optional modifier for the bits.
       definedBitsModifier :: Maybe (Modifier f a),
       -- | Identifier for the bits.
       definedBitsIdent :: Identifier f a,
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 2172694..903e6f4 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -55,10 +55,6 @@ consistencyCheckPhase = pureCompilationPhase $ advanceStage ()
 instance AdvanceStage S ObjTypeBody where
   advanceStage () objTypeBody = snd <$> advanceObjTypeBody objTypeBody 0
 
-deriving instance AdvanceStage S DeferredRegisterBody
-
-deriving instance AdvanceStage S RegisterBody
-
 deriving instance AdvanceStage S AnonymousBitsType
 
 deriving instance AdvanceStage S ImportStatement
@@ -75,8 +71,6 @@ deriving instance AdvanceStage S EnumBody
 
 deriving instance AdvanceStage S EnumConstantDecl
 
-deriving instance AdvanceStage S RegisterBitsDecl
-
 deriving instance AdvanceStage S PackageBody
 
 deriving instance AdvanceStage S FiddleDecl
@@ -150,16 +144,16 @@ advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
                     assertedPos <- expressionToIntM expr
                     checkPositionAssertion (annot e) assertedPos offset
                     return (ret, offset)
-                  (RegisterDecl mod ident size Nothing a) -> do
+                  (RegisterDecl _ mod ident size Nothing a) -> do
                     (sizeExpr, reifiedSize) <- advanceAndGetSize size
-                    doReturn (RegisterDecl mod ident sizeExpr Nothing a)
+                    doReturn (RegisterDecl offset mod ident sizeExpr Nothing a)
                       =<< checkBitsSizeMod8 a reifiedSize
-                  (RegisterDecl mod ident size (Just body) a) -> do
+                  (RegisterDecl _ mod ident size (Just body) a) -> do
                     declaredSize <- expressionToIntM size
                     (actualSize, body') <- advanceRegisterBody body
                     checkSizeMismatch a declaredSize actualSize
                     (sizeExpr, reifiedSize) <- advanceAndGetSize size
-                    doReturn (RegisterDecl mod ident sizeExpr (Just body') a)
+                    doReturn (RegisterDecl offset mod ident sizeExpr (Just body') a)
                       =<< checkBitsSizeMod8 a reifiedSize
                   (ReservedDecl size a) -> do
                     (sizeExpr, reifiedSize) <- advanceAndGetSize size
@@ -182,19 +176,23 @@ advanceRegisterBody :: RegisterBody S F A -> M (Word32, RegisterBody S' F A)
 -- Handle the case where it's a union.
 advanceRegisterBody
   (RegisterBodyPattern us (NonEmpty.nonEmpty -> Just decls) a b) = do
-    decls' <-
-      mapM
-        ( \d -> do
-            (sz, t) <- advanceDecl (undirected d)
-            return (sz, mapDirected (const t) d)
+    (structSize, reverse -> decls') <-
+      foldlM
+        ( \(offset, ret) d -> do
+            (sz, t) <- advanceDecl offset (undirected d)
+            let advanceOffset off sz =
+                  case us of
+                    Union {} -> off
+                    Struct {} -> off + sz
+            return (advanceOffset offset sz, (sz, mapDirected (const t) d) : ret)
         )
+        (0, [])
         decls
     calcSize <- case us of
       Union {} -> do
-        checkJagged (toList decls')
-        return $ maximum (map fst (toList decls'))
-      Struct {} -> do
-        return $ sum (map fst (toList decls'))
+        checkJagged decls'
+        return $ maximum (map fst decls')
+      Struct {} -> return structSize
 
     return (calcSize, RegisterBodyPattern us (map snd $ toList decls') a b)
 
@@ -219,8 +217,8 @@ checkJagged decls = do
         )
         a
 
-advanceDecl :: RegisterBitsDecl S F A -> M (Word32, RegisterBitsDecl S' F A)
-advanceDecl = \case
+advanceDecl :: Word32 -> RegisterBitsDecl S F A -> M (Word32, RegisterBitsDecl S' F A)
+advanceDecl offset = \case
   ReservedBits expr an -> do
     sz <- expressionToIntM expr
     (sz,)
@@ -228,10 +226,10 @@ advanceDecl = \case
               <$> advanceStage () expr
               <*> pure an
           )
-  DefinedBits mod ident typ annot -> do
+  DefinedBits _ mod ident typ annot -> do
     size <- bitsTypeSize typ
     (size,)
-      <$> (DefinedBits mod ident <$> advanceStage () typ <*> pure annot)
+      <$> (DefinedBits offset mod ident <$> advanceStage () typ <*> pure annot)
   BitsSubStructure subBody subName ann -> do
     (sz, body') <- advanceRegisterBody subBody
     return (sz, BitsSubStructure body' subName ann)
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index e951623..cbaf447 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -28,6 +28,7 @@ type Context stage =
   ( Show (NumberType stage),
     Typeable stage,
     ToJSON (NumberType stage),
+    ToJSON (RegisterOffset stage),
     ToJSON (ImportInterface stage),
     ToJSON (FiddleUnitInterface stage),
     ToJSON (QualificationMetadata stage ()),
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index a2368ed..ef40cc9 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -211,7 +211,7 @@ objTypeDeclP =
       <|> ( do
               modifier <- optionMaybe modifierP
               tok_ KWReg
-              RegisterDecl modifier
+              RegisterDecl () modifier
                 <$> optionMaybe ident
                 <*> exprInParenP
                 <*> optionMaybe (tok TokColon *> registerBodyP)
@@ -253,7 +253,7 @@ registerBitsDeclP =
         tok KWReserved >> ReservedBits <$> exprInParenP
     )
       <|> (BitsSubStructure <$> registerBodyP <*> optionMaybe ident)
-      <|> ( DefinedBits
+      <|> ( DefinedBits ()
               <$> optionMaybe modifierP
               <*> ident
               <*> (tok TokColon >> registerBitsTypeRefP)