Further implement C backend.

There is a problem where I'm mixing up bits and bytes. I think I'll try
to resolve that using more type-level constraints.

5 files changed, 133 insertions, 31 deletions

diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 610fdb2..f467141 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -1,9 +1,10 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE IncoherentInstances #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -12,7 +13,10 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     NumberType,
     RegisterOffset,
     BitsOffset,
-    QMd (..),
+    QMd,
+    N (..),
+    Unit (..),
+    FieldSpan (..),
     -- Witness Types
     Witness (..),
     -- AST Types
@@ -48,11 +52,12 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     mapDirectedM,
     asDirected,
     undirected,
+    bitsToBytes,
   )
 where
 
 import Control.Monad (forM_)
-import Data.Aeson (ToJSON (..))
+import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.Kind (Type)
 import Data.List.NonEmpty hiding (map)
 import Data.Text (Text)
@@ -69,6 +74,33 @@ import Language.Fiddle.Internal.UnitInterface
 
 type QMd s t = When (s .>= Qualified) t
 
+-- | Phantom type used to ensure Bits and Bytes don't get mixed up in the code.
+data Unit = Bits | Bytes
+
+-- | An integer with a unit.
+newtype N (u :: Unit) = N Word32
+  deriving newtype (Real, Enum, Num, Eq, Ord, Integral)
+
+instance (Show (N u)) where
+  show (N b) = show b
+
+instance (ToJSON (N u)) where
+  toJSON (N b) = toJSON b
+
+instance (FromJSON (N u)) where
+  parseJSON v = N <$> parseJSON v
+
+bitsToBytes :: N Bits -> (N Bytes, N Bits)
+bitsToBytes (N a) = let (y, i) = divMod a 8 in (N y, N i)
+
+data FieldSpan (u :: Unit) where
+  FieldSpan ::
+    { offset :: N u,
+      size :: N u
+    } ->
+    FieldSpan u
+  deriving (Eq, Ord, Show, Generic, ToJSON, FromJSON)
+
 type BitsOffset stage = RegisterOffset stage
 
 -- | Type used for the RegisterOffset type. This is populated in the check
@@ -449,7 +481,7 @@ data ObjTypeDecl stage f a where
   RegisterDecl ::
     { -- | Offset within the register. Calculated during the consistency check.
       -- The offset is calculated from the top-level structure.
-      regOffset :: RegisterOffset stage,
+      regSpan :: When (stage .>= Checked) (FieldSpan Bytes),
       -- | Optional register modifier.
       regModifier :: Maybe (Modifier f a),
       -- | Optional register identifier. This is guaranteed to exist after
@@ -466,7 +498,11 @@ data ObjTypeDecl stage f a where
     ObjTypeDecl stage f a
   -- | A reserved declaration for padding or alignment.
   ReservedDecl ::
-    { -- | The expression for reserved space.
+    { -- | Offset and size of this reserved block.
+      regSpan :: When (stage .>= Checked) (FieldSpan Bytes),
+      -- | Generated identifier for this reserved field.
+      reservedIdent :: When (stage .>= Qualified) String,
+      -- | The expression for reserved space.
       reservedExpr :: Expression stage f a,
       -- | Annotation for the reserved declaration.
       reservedAnnot :: a
@@ -503,8 +539,7 @@ data ModifierKeyword = Rw | Ro | Wo
 --   declarations.
 data DeferredRegisterBody stage f a where
   DeferredRegisterBody ::
-    { -- | Bit declarations.
-      deferredBits :: [Directed RegisterBitsDecl stage f a],
+    { deferredBits :: [Directed RegisterBitsDecl stage f a],
       -- | Annotation for the deferred register body.
       deferredAnnot :: a
     } ->
@@ -553,7 +588,8 @@ data RegisterBitsDecl stage f a where
   DefinedBits ::
     { -- | The offset for these bits. This is calculated during the
       -- ConsistencyCheck phase, so until this phase it's just ().
-      definedBitsOffset :: BitsOffset stage,
+      definedBitsSpan :: When (stage .>= Checked) (FieldSpan Bits),
+      -- | Bit declarations.
       -- | Optional modifier for the bits.
       definedBitsModifier :: Maybe (Modifier f a),
       -- | Identifier for the bits.
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index 2e6421e..645fa85 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -6,10 +6,7 @@
 module Language.Fiddle.Compiler.Backend.C (cBackend) where
 
 import Control.Arrow (Arrow (second))
-import Control.Exception (TypeError (TypeError))
-import Control.Monad.Identity (Identity (Identity))
 import Control.Monad.RWS
-import Control.Monad.Writer
 import Data.Char (isSpace)
 import Data.Data (Typeable, cast)
 import Data.Foldable (forM_, toList)
@@ -33,13 +30,16 @@ data CBackendFlags = CBackendFlags
     cHeaderOut :: FilePath
   }
 
-data FilePosition = FilePosition Int
+newtype FilePosition = FilePosition Int
   deriving (Eq, Ord)
 
+headerPos :: FilePosition
 headerPos = FilePosition 0
 
+middlePos :: FilePosition
 middlePos = FilePosition 50
 
+footerPos :: FilePosition
 footerPos = FilePosition 100
 
 tellLn :: (MonadWriter Text m) => Text -> m ()
@@ -212,7 +212,54 @@ pad :: (IsString t, MonadWriter t m) => m a -> m a
 pad f = tell "\n" *> f <* tell "\n"
 
 structBody :: ObjTypeBody Checked I A -> FormattedWriter ()
-structBody _ = return ()
+structBody (ObjTypeBody _ decls _) = do
+  forM_ decls $ \(Directed _ decl _) ->
+    case decl of
+      RegisterDecl
+        { regSpan = Present (FieldSpan _ sz),
+          regIdent = Guaranteed (identToString -> i),
+          regAnnot = ann
+        } -> do
+          emitDocComments ann
+          tell (sizeToField i sz)
+          tell ";\n"
+      ReservedDecl
+        { regSpan = Present (FieldSpan _ sz),
+          reservedIdent = Present i,
+          reservedAnnot = ann
+        } -> do
+          emitDocComments ann
+          tell (sizeToField i sz)
+          tell ";\n"
+      TypeSubStructure
+        { subStructureBody = Identity bod,
+          subStructureName = mname
+        } -> do
+          tell $ case objBodyType bod of
+            Union {} -> "union "
+            Struct {} -> "struct "
+
+          body $ structBody bod
+
+          forM_ mname $ \name ->
+            tell (Text.pack $ identToString name)
+
+          tell ";\n"
+  where
+    sizeToField (Text.pack -> f) = \case
+      1 -> "volatile uint8_t " <> f
+      2 -> "volatile uint16_t " <> f
+      4 -> "volatile uint32_t " <> f
+      8 -> "volatile uint64_t " <> f
+      n -> "volatile uint8_t " <> f <> "[" <> Text.pack (show n) <> "]"
+
+union :: Text -> FormattedWriter () -> FormattedWriter ()
+union identifier fn = do
+  tell "#pragma pack(push, 1)\n"
+  tell $ "union " <> identifier <> " "
+  body fn
+  tell ";\n"
+  tell "#pragma pack(pop)\n"
 
 struct :: Text -> FormattedWriter () -> FormattedWriter ()
 struct identifier fn = do
@@ -228,8 +275,8 @@ body f = tell "{\n" *> indented f <* (ensureNL >> tell "}")
 identifierFor :: (ExportableDecl d) => d -> Text
 identifierFor = qualifiedPathToIdentifier . metadataFullyQualifiedPath . getMetadata
 
-emitDocComments :: (MonadWriter Text m) => A -> m ()
-emitDocComments (Commented comments _) =
+emitDocComments :: A -> FormattedWriter ()
+emitDocComments (Commented comments _) = do
   mapM_ (\t -> tellLn $ "// " <> t) $
     mapMaybe
       ( \case
@@ -237,6 +284,7 @@ emitDocComments (Commented comments _) =
           _ -> Nothing
       )
       comments
+  ensureNL
   where
     trimDocComment =
       Text.dropWhileEnd isSpace
@@ -244,28 +292,31 @@ emitDocComments (Commented comments _) =
         . dropIf (== '*')
         . Text.dropWhile isSpace
 
-    dropIf fn t | Text.null t = mempty
+    dropIf _ t | Text.null t = mempty
     dropIf fn t =
       if fn (Text.head t)
         then Text.tail t
         else t
 
 transpileWalk :: Either ImplementationInHeader FilePath -> FilePath -> (forall t. (Walk t, Typeable t) => t I A -> () -> M (WalkContinuation ()))
-transpileWalk sourceFile headerFile t _ = case () of
+transpileWalk _ headerFile t _ = case () of
   ()
     | Just
         ( ObjTypeDecl
             { objTypeQualificationMetadata = Identity metadata,
-              objTypeIdent = (identToString -> identifier),
               objTypeBody = Identity objTypeBody,
               objTypeAnnot = a
             }
           ) <-
         castTS t -> do
+        let structureType = case objBodyType objTypeBody of
+              Union {} -> union
+              Struct {} -> struct
+
         withFileAt headerFile middlePos $ do
           pad $ do
             emitDocComments a
-            struct (identifierFor (unwrap metadata)) $ do
+            structureType (identifierFor (unwrap metadata)) $ do
               structBody objTypeBody
         return Stop
   _ -> return (Continue ())
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 552ea40..e0c7876 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -149,18 +149,21 @@ advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
                     return (ret, offset)
                   (RegisterDecl _ mod ident size Nothing a) -> do
                     (sizeExpr, reifiedSize) <- advanceAndGetSize size
-                    doReturn (RegisterDecl offset mod ident sizeExpr Nothing a)
+                    let span = Present (FieldSpan (N offset) (N reifiedSize))
+                    doReturn (RegisterDecl span mod ident sizeExpr Nothing a)
                       =<< checkBitsSizeMod8 a reifiedSize
                   (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 offset mod ident sizeExpr (Just body') a)
+                    let span = Present (FieldSpan (N offset) (N reifiedSize))
+                    doReturn (RegisterDecl span mod ident sizeExpr (Just body') a)
                       =<< checkBitsSizeMod8 a reifiedSize
-                  (ReservedDecl size a) -> do
+                  (ReservedDecl _ i size a) -> do
                     (sizeExpr, reifiedSize) <- advanceAndGetSize size
-                    doReturn (ReservedDecl sizeExpr a) reifiedSize
+                    let span = Present (FieldSpan (N offset) (N reifiedSize))
+                    doReturn (ReservedDecl span i sizeExpr a) reifiedSize
                   (TypeSubStructure (Identity body) name a) -> do
                     (size, body') <- advanceObjTypeBody body offset
                     doReturn (TypeSubStructure (Identity body') name a) size
@@ -231,8 +234,9 @@ advanceDecl offset = \case
           )
   DefinedBits _ mod ident typ annot -> do
     size <- bitsTypeSize typ
+    let span = Present (FieldSpan (N offset) (N size))
     (size,)
-      <$> (DefinedBits offset mod ident <$> advanceStage () typ <*> pure annot)
+      <$> (DefinedBits span 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/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index e09725e..70378c3 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -45,14 +45,17 @@ type A = Commented SourceSpan
 
 type M = Compile GlobalState
 
-uniqueString :: M String
-uniqueString = do
+uniqueString :: String -> M String
+uniqueString prefix = do
   cnt <- gets uniqueCounter
   modify $ \g -> g {uniqueCounter = cnt + 1}
-  return $ "__anon" ++ show cnt
+  return $ "_" ++ prefix ++ show cnt
 
 uniqueIdentifier :: a -> M (Identifier F a)
-uniqueIdentifier a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString
+uniqueIdentifier a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString "ident"
+
+uniqueReservedIdentifier :: a -> M (Identifier F a)
+uniqueReservedIdentifier a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString "reserved"
 
 instance CompilationStage Expanded where
   type StageAfter Expanded = Qualified
@@ -82,6 +85,14 @@ instance
   where
   convertInStage _ ann _ = guaranteeM (uniqueIdentifier ann)
 
+instance
+  StageConvertible
+    Expanded
+    (When False String)
+    (When True String)
+  where
+  convertInStage _ _ _ _ = Present <$> uniqueString "reserved"
+
 deriving instance AdvanceStage S ObjTypeBody
 
 deriving instance AdvanceStage S DeferredRegisterBody
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index e8f1b62..8d2eab2 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -207,7 +207,7 @@ objTypeDeclP =
     )
       <|> ( do
               tok_ KWReserved
-              ReservedDecl <$> exprInParenP
+              ReservedDecl Vacant Vacant <$> exprInParenP
           )
       <|> ( do
               bt <- bodyTypeP
@@ -216,7 +216,7 @@ objTypeDeclP =
       <|> ( do
               modifier <- optionMaybe modifierP
               tok_ KWReg
-              RegisterDecl () modifier . Perhaps
+              RegisterDecl Vacant modifier . Perhaps
                 <$> optionMaybe ident
                 <*> exprInParenP
                 <*> optionMaybe (tok TokColon *> registerBodyP)
@@ -258,7 +258,7 @@ registerBitsDeclP =
         tok KWReserved >> ReservedBits <$> exprInParenP
     )
       <|> (BitsSubStructure <$> registerBodyP <*> optionMaybe ident)
-      <|> ( DefinedBits ()
+      <|> ( DefinedBits Vacant
               <$> optionMaybe modifierP
               <*> ident
               <*> (tok TokColon >> registerBitsTypeRefP)