summaryrefslogtreecommitdiff
path: root/src/Language/Fiddle/Compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/Fiddle/Compiler')
-rw-r--r--src/Language/Fiddle/Compiler/Backend/C.hs73
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs14
-rw-r--r--src/Language/Fiddle/Compiler/Qualification.hs19
3 files changed, 86 insertions, 20 deletions
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
generated by cgit (git 2.34.1) at 2025-07-05 21:44:23 +0000