summaryrefslogtreecommitdiff
path: root/src/Language/Fiddle/Compiler/Backend
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/Fiddle/Compiler/Backend')
-rw-r--r--src/Language/Fiddle/Compiler/Backend/C.hs104
-rw-r--r--src/Language/Fiddle/Compiler/Backend/Internal.hs18
2 files changed, 102 insertions, 20 deletions
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index df31c8c..f4132c6 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -26,6 +26,7 @@ import Data.Text (Text)
import qualified Data.Text as Text
import Language.Fiddle.Ast
import Language.Fiddle.Compiler.Backend
+import Language.Fiddle.Compiler.Backend.Internal
import Language.Fiddle.Compiler.Backend.Internal.FormattedWriter
import qualified Language.Fiddle.Compiler.Backend.Internal.FragTree as FragTree
import Language.Fiddle.Compiler.Backend.Internal.Writer
@@ -174,8 +175,8 @@ instance IsText String where
instance IsText Text where
toText = id
-qualifiedPathToIdentifier :: (Foldable f, IsText t) => f t -> Text
-qualifiedPathToIdentifier = Text.intercalate "_" . map toText . toList
+qualifiedPathToIdentifier :: QualifiedPath String -> Text
+qualifiedPathToIdentifier = Text.pack . qualifiedPathToString "__" "_"
pad :: M () -> M ()
pad f = text "\n" *> f <* text "\n"
@@ -219,9 +220,9 @@ writeRegGet
regFullPath = fullPath
}
) = do
- let fnName = "get_" <> qualifiedPathToIdentifier fullPath
+ let fnName = qualifiedPathToIdentifier fullPath <> "__get"
returnType = sizeToType size
- fieldName = NonEmpty.last fullPath
+ fieldName = basenamePart fullPath
case returnType of
Just rt -> do
@@ -257,16 +258,16 @@ writeRegSet
regFullPath = fullPath
}
) = do
- let fnName = "set_" <> qualifiedPathToIdentifier fullPath
+ let fnName = qualifiedPathToIdentifier fullPath <> "__set"
setType = sizeToType size
- fieldName = NonEmpty.last fullPath
+ fieldName = basenamePart fullPath
case setType of
Just rt -> do
textM $ do
tell $
Text.pack $
- printf "static inline void %s(%s* o, %s v) {\n" fnName structType rt
+ printf "static inline void %s(struct %s* o, %s v) {\n" fnName structType rt
tell $ Text.pack $ printf " o->%s = v;\n" fieldName
tell "}\n\n"
Nothing ->
@@ -275,7 +276,7 @@ writeRegSet
tell $
Text.pack $
printf
- "static inline void %s(%s* o, const uint8_t in[%d]) {\n"
+ "static inline void %s(struct %s* o, const uint8_t in[%d]) {\n"
fnName
structType
size
@@ -283,8 +284,8 @@ writeRegSet
tell $ Text.pack $ printf " o->%s[%d] = in[%d];\n" fieldName i i
tell "}\n\n"
-pattern DefinedBitsP :: String -> NonEmpty String -> N Bits -> RegisterBitsTypeRef Checked f a -> RegisterBitsDecl Checked f a
-pattern DefinedBitsP bitsName bitsFullPath offset typeRef <-
+pattern DefinedBitsP :: Modifier f a -> String -> QualifiedPath String -> N Bits -> RegisterBitsTypeRef Checked f a -> RegisterBitsDecl Checked f a
+pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef <-
( DefinedBits
{ qBitsMetadata =
Present
@@ -294,12 +295,68 @@ pattern DefinedBitsP bitsName bitsFullPath offset typeRef <-
FieldSpan
{ offset = offset
},
- bitsFullPath = (NonEmpty.last &&& id -> (bitsName, bitsFullPath))
+ bitsFullPath = (basenamePart &&& id -> (bitsName, bitsFullPath))
},
- definedBitsTypeRef = typeRef
+ definedBitsTypeRef = typeRef,
+ definedBitsModifier = (Guaranteed modifier)
}
)
+writeBitsGet ::
+ StructName ->
+ String ->
+ QualifiedPath String ->
+ N Bits ->
+ RegisterBitsTypeRef 'Checked I A ->
+ M ()
+writeBitsGet _ _ _ _ _ = return ()
+
+writeBitsSet ::
+ StructName ->
+ String ->
+ QualifiedPath String ->
+ N Bits ->
+ RegisterBitsTypeRef 'Checked I A ->
+ M ()
+writeBitsSet structName bitsNam fullPath offset typeRef = do
+ text "inline static void "
+ text (qualifiedPathToIdentifier fullPath)
+ text "__set(\n struct "
+ text structName
+ text " *o,\n "
+ typeRefToArgs typeRef
+ text ") {\n"
+ text "}\n\n"
+
+typeRefToArgs :: RegisterBitsTypeRef 'Checked I A -> M ()
+typeRefToArgs reg =
+ text
+ $ Text.intercalate ",\n "
+ $ zipWith
+ (\n t -> t <> " " <> n)
+ setterArgumentNames
+ $ typeRefToArgs' reg
+ where
+ typeRefToArgs'
+ ( RegisterBitsJustBits
+ { justBitsExpr = ConstExpression (LeftV v) _
+ }
+ ) = [typeForBits v]
+ typeRefToArgs'
+ ( RegisterBitsReference
+ { bitsRefQualificationMetadata = (Identity (Present md))
+ }
+ ) = [qualifiedPathToIdentifier $ metadataFullyQualifiedPath $ getMetadata md]
+ typeRefToArgs' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) =
+ typeRefToArgs' tr ++ ["int"]
+
+ typeForBits = \case
+ 64 -> "uint64_t"
+ 32 -> "uint32_t"
+ 16 -> "uint16_t"
+ 8 -> "uint8_t"
+ _ -> "unsigend"
+
-- | Decomposes a type ref into a type name (String) and a list of dimensions
-- (in the case of being an array)
-- decomposeBitsTypeRef :: RegisterBitsTypeRef Checked I A -> (String, [N Unitless])
@@ -310,14 +367,21 @@ writeRegisterBody structName regmeta = walk_ registerWalk
registerWalk :: forall t. (Walk t, Typeable t) => t I A -> M ()
registerWalk t = case () of
()
- | (Just (DefinedBitsP bitsName fullPath offset typeRef)) <- castTS t ->
- text $
- Text.pack $
- printf
- "// Emit bits %s (%s) at %d\n"
- bitsName
- (qualifiedPathToIdentifier fullPath)
- offset
+ | (Just (DefinedBitsP modifier bitsName fullPath offset typeRef)) <- castTS t -> do
+ sequence_ $
+ selectByModifier
+ modifier
+ ( writeBitsGet structName bitsName fullPath offset typeRef,
+ writeBitsSet structName bitsName fullPath offset typeRef
+ )
+
+ -- text $
+ -- Text.pack $
+ -- printf
+ -- "// Emit bits %s (%s) at %d\n"
+ -- bitsName
+ -- (qualifiedPathToIdentifier fullPath)
+ -- offset
_ -> return ()
castTS ::
diff --git a/src/Language/Fiddle/Compiler/Backend/Internal.hs b/src/Language/Fiddle/Compiler/Backend/Internal.hs
new file mode 100644
index 0000000..4e513f1
--- /dev/null
+++ b/src/Language/Fiddle/Compiler/Backend/Internal.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.Fiddle.Compiler.Backend.Internal where
+
+import qualified Data.Text
+
+-- | An infinite list of common setter argument names to use.
+setterArgumentNames :: [Data.Text.Text]
+setterArgumentNames =
+ ["value", "i", "j", "k"]
+ ++ map (("i" <>) . Data.Text.pack . show) [(0 :: Int) ..]
+
+-- | An infinite list of common getter argument names to use. A getter will have
+-- an argument for each index into an array for bit arrays.
+getterArgumentNames :: [Data.Text.Text]
+getterArgumentNames =
+ ["i", "j", "k"]
+ ++ map (("i" <>) . Data.Text.pack . show) [(0 :: Int) ..]
generated by cgit (git 2.34.1) at 2025-07-03 04:45:54 +0000