Enforce that registers are either 8, 16, 32, or 64 bits.

Fixed the issues where the output C code did not use correct register
sizes.

6 files changed, 104 insertions, 31 deletions

diff --git a/src/Language/Fiddle/Ast/Internal/MetaTypes.hs b/src/Language/Fiddle/Ast/Internal/MetaTypes.hs
index 2be212e..139637d 100644
--- a/src/Language/Fiddle/Ast/Internal/MetaTypes.hs
+++ b/src/Language/Fiddle/Ast/Internal/MetaTypes.hs
@@ -16,6 +16,14 @@ module Language.Fiddle.Ast.Internal.MetaTypes
     Variant (..),
     foldVariant,
     toEither,
+    getLeft,
+    getRight,
+    progress,
+    progressBack,
+    progressM,
+    progressBackM,
+    changeLeft,
+    changeRight,
   )
 where
 
@@ -223,9 +231,33 @@ toEither :: Variant b t f -> Either t f
 toEither (LeftV l) = Left l
 toEither (RightV l) = Right l
 
+getLeft :: Variant True l r -> l
+getLeft (LeftV l) = l
+
+getRight :: Variant False l r -> r
+getRight (RightV r) = r
+
 foldVariant :: (t -> r) -> (f -> r) -> Variant b t f -> r
 foldVariant fl fr = either fl fr . toEither
 
+changeLeft :: Variant False l r -> Variant False l' r
+changeLeft (RightV r) = RightV r
+
+changeRight :: Variant True l r -> Variant True l r'
+changeRight (LeftV r) = LeftV r
+
+progressM :: (Functor m) => (l -> m r) -> Variant True l r -> m (Variant False l' r)
+progressM fn (LeftV l) = RightV <$> fn l
+
+progress :: (l -> r) -> Variant True l r -> Variant False l' r
+progress fn (LeftV l) = RightV (fn l)
+
+progressBack :: (r -> l) -> Variant False l r -> Variant True l r'
+progressBack fn (RightV r) = LeftV (fn r)
+
+progressBackM :: (Functor m) => (r -> m l) -> Variant False l r -> m (Variant True l r')
+progressBackM fn (RightV r) = LeftV <$> fn r
+
 instance Functor (Variant b t) where
   fmap _ (LeftV x) = LeftV x
   fmap f (RightV x) = RightV (f x)
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 0d0bc32..b597a25 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -18,6 +18,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     FieldSpan (..),
     QRegMetadata (..),
     QBitsMetadata (..),
+    RegSz(..),
     -- Witness Types
     Witness (..),
     -- AST Types
@@ -50,6 +51,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     EnumConstantDecl (..),
     PackageBody (..),
     -- Helper Functions
+    regSzToBits,
     mapDirected,
     mapDirectedM,
     asDirected,
@@ -105,6 +107,15 @@ deriving instance
   (FromJSON (When s (FieldSpan Bytes))) =>
   FromJSON (QRegMetadata s)
 
+data RegSz = RegSz8 | RegSz16 | RegSz32  | RegSz64
+  deriving (Eq, Ord, Show, Enum, Generic, ToJSON, FromJSON)
+
+regSzToBits :: RegSz -> N Bits
+regSzToBits RegSz8 = 8
+regSzToBits RegSz16 = 16
+regSzToBits RegSz32 = 32
+regSzToBits RegSz64 = 64
+
 data QBitsMetadata (checkStage :: Bool) where
   QBitsMetadata ::
     { bitsSpan :: When checkStage (FieldSpan Bits),
@@ -520,7 +531,7 @@ data ObjTypeDecl stage f a where
       -- doesn't exist.
       regIdent :: Guaranteed (stage .>= Qualified) (Identifier f a),
       -- | Size of the register.
-      regSize :: Expression Bits stage f a,
+      regSize :: Variant (stage .>= Qualified) RegSz (Expression Bits stage f a),
       -- | Optional register body.
       regBody :: Maybe (RegisterBody stage f a),
       -- | Annotation for the register declaration.
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index 26ea065..77eadf6 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -273,7 +273,8 @@ writeRegGet
               },
         regFullPath = fullPath
       }
-    ) docComms = do
+    )
+  docComms = do
     let fnName = qualifiedPathToIdentifier fullPath <> "__get"
         returnType = sizeToType size
         fieldName = basenamePart fullPath
@@ -313,7 +314,8 @@ writeRegSet
               },
         regFullPath = fullPath
       }
-    ) docComs = do
+    )
+  docComs = do
     let fnName = qualifiedPathToIdentifier fullPath <> "__set"
         setType = sizeToType size
         fieldName = basenamePart fullPath
@@ -370,16 +372,18 @@ pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef annot <-
 
 writeBitsGet ::
   StructName ->
-  String ->
+  QRegMetadata True ->
   QualifiedPath String ->
   N Bits ->
   RegisterBitsTypeRef 'Checked I A ->
   A ->
   M SIntf
-writeBitsGet structName regName fullPath offset typeRef docComms = do
+writeBitsGet structName regmeta fullPath offset typeRef docComms = do
   let fnName = qualifiedPathToIdentifier fullPath <> "__get"
       bitsName = basenamePart fullPath
       retType = typeRefBaseType typeRef
+      regName = basenamePart (regFullPath regmeta)
+      regCType = getRegCType regmeta
 
   text $ "inline static " <> retType <> " "
   text fnName
@@ -404,13 +408,13 @@ writeBitsGet structName regName fullPath offset typeRef docComms = do
   withIndent $ do
     if null shiftArguments
       then do
-        text "unsigned shift_ = 0"
+        text $ regCType <> " shift_ = 0"
       else do
-        text "unsigned shift_ = "
+        text $ regCType <> " shift_ = "
         text $ Text.intercalate " + " shiftArguments
     text ";\n"
 
-    text "unsigned mask_ = "
+    text $ regCType <> " mask_ = "
     text $ typeRefToGetMask typeRef
     text " << shift_;\n"
 
@@ -467,18 +471,26 @@ writeBitsGet structName regName fullPath offset typeRef docComms = do
             num = (1 `Data.Bits.shiftL` fromIntegral sz) - 1
          in "0x" <> Text.pack (showHex num "")
 
+getRegCType :: QRegMetadata True -> Text
+getRegCType meta =
+  Text.pack $
+    fromMaybe "unsigned" $
+      sizeToType (size (unwrap (regSpan meta)))
+
 writeBitsSet ::
   Bool ->
   StructName ->
-  String ->
+  QRegMetadata True ->
   QualifiedPath String ->
   N Bits ->
   RegisterBitsTypeRef 'Checked I A ->
   A ->
   M SIntf
-writeBitsSet writeOnly structName regName fullPath offset typeRef docComms = do
+writeBitsSet writeOnly structName regmeta fullPath offset typeRef docComms = do
   let fnName = qualifiedPathToIdentifier fullPath <> "__set"
       bitsName = basenamePart fullPath
+      regName = basenamePart (regFullPath regmeta)
+      regCType = getRegCType regmeta
 
   text "inline static void "
   text fnName
@@ -498,10 +510,10 @@ writeBitsSet writeOnly structName regName fullPath offset typeRef docComms = do
   withIndent $ do
     let mask = typeRefToMask typeRef
 
-    text $ "unsigned mask_ = " <> mask <> ";\n"
+    text $ regCType <> " mask_ = " <> mask <> ";\n"
     unless (null shiftArguments) $ do
       text $
-        "unsigned shift_ = " <> Text.intercalate " + " shiftArguments <> ";\n"
+        regCType <> " shift_ = " <> Text.intercalate " + " shiftArguments <> ";\n"
       text "mask_ <<= shift_;\n"
 
     text "int to_set_ = value"
@@ -512,7 +524,7 @@ writeBitsSet writeOnly structName regName fullPath offset typeRef docComms = do
     text "to_set_ &= mask_;\n"
 
     unless writeOnly $ do
-      text $ "unsigned current_ = o->" <> Text.pack regName <> ";\n"
+      text $ regCType <> " current_ = o->" <> Text.pack regName <> ";\n"
       text "to_set_ = current_ ^ (current_ & mask_) ^ to_set_;\n"
 
     text $ "o->" <> Text.pack regName <> " = to_set_;\n"
@@ -614,8 +626,6 @@ writeRegisterBody ::
   StructName -> QRegMetadata True -> RegisterBody Checked I A -> M SIntf
 writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk
   where
-    regName = basenamePart (regFullPath regmeta)
-
     registerWalk ::
       forall t.
       (Walk t, Typeable t) =>
@@ -632,8 +642,8 @@ writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk
                   sequence_ $
                     selectByModifier
                       modifier
-                      ( tell =<< lift (writeBitsGet structName regName fullPath offset typeRef annot),
-                        tell =<< lift (writeBitsSet isWo structName regName fullPath offset typeRef annot)
+                      ( tell =<< lift (writeBitsGet structName regmeta fullPath offset typeRef annot),
+                        tell =<< lift (writeBitsSet isWo structName regmeta fullPath offset typeRef annot)
                       )
       -- text $
       --   Text.pack $
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 3def59d..00a53dc 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -156,25 +156,33 @@ advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
                     checkPositionAssertion (annot e) assertedPos offset
                     return (ret, offset)
                   (RegisterDecl qmeta mod ident size Nothing a) -> do
-                    (sizeExpr, reifiedSize) <- advanceAndGetSize size
-                    reifiedSizeBytes <- checkBitsSizeMod8 a reifiedSize
+                    let declaredSize = regSzToBits (getLeft size)
+                    reifiedSizeBytes <- checkBitsSizeMod8 a declaredSize
 
                     let span = Present (FieldSpan offset reifiedSizeBytes)
                         qmeta' = fmap (\q -> q {regSpan = span}) qmeta
-                    doReturn (RegisterDecl qmeta' mod ident sizeExpr Nothing a)
-                      =<< checkBitsSizeMod8 a reifiedSize
+                    doReturn (RegisterDecl qmeta' mod ident (changeRight size) Nothing a)
+                      =<< checkBitsSizeMod8 a declaredSize
                   (RegisterDecl qmeta mod ident size (Just body) a) -> do
-                    declaredSize <- expressionToIntM size
-                    (actualSize, body') <- advanceRegisterBody 0 body
+                    let declaredSize = regSzToBits (getLeft size)
 
+                    (actualSize, body') <- advanceRegisterBody 0 body
                     checkSizeMismatch a declaredSize actualSize
-
-                    (sizeExpr, reifiedSize) <- advanceAndGetSize size
-                    reifiedSizeBytes <- checkBitsSizeMod8 a reifiedSize
+                    reifiedSizeBytes <- checkBitsSizeMod8 a declaredSize
 
                     let span = Present (FieldSpan offset reifiedSizeBytes)
                         qmeta' = fmap (\q -> q {regSpan = span}) qmeta
-                    doReturn (RegisterDecl qmeta' mod ident sizeExpr (Just body') a) reifiedSizeBytes
+
+                    doReturn
+                      ( RegisterDecl
+                          qmeta'
+                          mod
+                          ident
+                          (changeRight size)
+                          (Just body')
+                          a
+                      )
+                      reifiedSizeBytes
                   (TypeSubStructure (Identity body) name a) -> do
                     (size, body') <- advanceObjTypeBody body offset
                     doReturn (TypeSubStructure (Identity body') name a) size
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index e8ab479..eae219e 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -177,6 +177,18 @@ instance AdvanceStage S RegisterBitsDecl where
         <$> advanceStage localState typ
         <*> pure an
 
+getProperRegSize :: (stage .< Expanded ~ False) => Expression Bits stage F A -> M RegSz
+getProperRegSize expr = do
+  v <- expressionToIntM expr
+  case v of
+    8 -> return RegSz8
+    16 -> return RegSz16
+    32 -> return RegSz32
+    64 -> return RegSz64
+    _ -> do
+      emitDiagnosticError "Exotic register size." (annot expr)
+      return RegSz32
+
 instance AdvanceStage S ObjTypeDecl where
   advanceStage localState = \case
     AssertPosStatement d e a ->
@@ -202,7 +214,7 @@ instance AdvanceStage S ObjTypeDecl where
         (Present qRegMeta)
         (guarantee (ModifierKeyword Rw ann) mod)
         ident'
-        <$> advanceStage localState'' size
+        <$> progressBackM getProperRegSize size
         <*> mapM (advanceStage localState'') bod
         <*> pure ann
     ReservedDecl _ expr ann -> do
@@ -222,7 +234,7 @@ instance AdvanceStage S ObjTypeDecl where
         (Present qRegMeta)
         (Guaranteed $ ModifierKeyword Pr ann)
         (Guaranteed ident)
-        <$> advanceStage localState expr
+        <$> fmap LeftV (getProperRegSize expr)
         <*> pure Nothing
         <*> pure ann
     TypeSubStructure bod name an -> do
@@ -482,7 +494,7 @@ calculateTypeSize (ObjTypeBody bodyType decls _) =
     calculateDeclSize (undirected -> decl) =
       case decl of
         AssertPosStatement {} -> return 0
-        RegisterDecl {regSize = size} -> fst . bitsToBytes <$> expressionToIntM size
+        RegisterDecl {regSize = size} -> fst . bitsToBytes <$> expressionToIntM (getRight size)
         ReservedDecl {reservedExpr = size} -> fst . bitsToBytes <$> expressionToIntM size
         TypeSubStructure {subStructureBody = b} -> calculateTypeSize =<< resolveOrFail b
 
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index 1bc75bc..415852c 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -224,7 +224,7 @@ objTypeDeclP =
               tok_ KWReg
               RegisterDecl Vacant modifier . Perhaps
                 <$> optionMaybe ident
-                <*> exprInParenP
+                <*> fmap RightV exprInParenP
                 <*> optionMaybe (tok TokColon *> registerBodyP)
           )