From e9ed9fe9aae2c0ac913cf1d175166e983e0a1b30 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sat, 19 Oct 2024 01:05:10 -0600 Subject: Provide more data during qualification about how a path is qualified. Now it includes information about the package a symobl is in. The object its in and the register its in. This allows better code generation in the backend that's somewhat more organized. --- src/Language/Fiddle/Compiler/Backend/C.hs | 104 ++++++++++++++++++----- src/Language/Fiddle/Compiler/Backend/Internal.hs | 18 ++++ 2 files changed, 102 insertions(+), 20 deletions(-) create mode 100644 src/Language/Fiddle/Compiler/Backend/Internal.hs (limited to 'src/Language/Fiddle/Compiler/Backend') 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) ..] -- cgit