diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/Backend')
| -rw-r--r-- | src/Language/Fiddle/Compiler/Backend/C.hs | 423 |
1 files changed, 340 insertions, 83 deletions
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs index 645fa85..9dbbec6 100644 --- a/src/Language/Fiddle/Compiler/Backend/C.hs +++ b/src/Language/Fiddle/Compiler/Backend/C.hs @@ -1,27 +1,36 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeApplications #-} module Language.Fiddle.Compiler.Backend.C (cBackend) where -import Control.Arrow (Arrow (second)) +import Control.Arrow +import Control.Monad (unless) import Control.Monad.RWS +import Control.Monad.State (State) +import Control.Monad.Trans.Writer (Writer, execWriter) import Data.Char (isSpace) import Data.Data (Typeable, cast) import Data.Foldable (forM_, toList) import Data.Kind (Type) +import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as Text import Language.Fiddle.Ast import Language.Fiddle.Compiler.Backend import Language.Fiddle.Internal.UnitInterface +import Language.Fiddle.Internal.UnitNumbers import Language.Fiddle.Types import Options.Applicative +import Text.Printf (printf) data ImplementationInHeader = ImplementationInHeader @@ -30,17 +39,31 @@ data CBackendFlags = CBackendFlags cHeaderOut :: FilePath } -newtype FilePosition = FilePosition Int +type StructName = Text + +newtype Fragment = Fragment Int deriving (Eq, Ord) -headerPos :: FilePosition -headerPos = FilePosition 0 +-- | Header fragment. The top. Starts which include guards and has include +-- statements. +hF :: Fragment +hF = Fragment 0 + +-- | Structures fragment. The text fragment where structures are defined. +sF :: Fragment +sF = Fragment 25 + +-- | Implementation fragment. This is where function implementations go. +iF :: Fragment +iF = Fragment 75 -middlePos :: FilePosition -middlePos = FilePosition 50 +-- | Assert fragment. This is where static asserts go. +aF :: Fragment +aF = Fragment 50 -footerPos :: FilePosition -footerPos = FilePosition 100 +-- | Footer fragment. This is wehre the file include endif goes. +fF :: Fragment +fF = Fragment 100 tellLn :: (MonadWriter Text m) => Text -> m () tellLn s = tell s >> tell "\n" @@ -49,8 +72,10 @@ type A = Commented SourceSpan type I = Identity --- | Current local state information while traversing the tree. data St = St + +-- | Current local state information while traversing the tree. +data Fmt = Fmt { indentLevel :: Int, pendingLine :: Text } @@ -58,16 +83,16 @@ data St = St newtype M a = M {unM :: RWS () () (St, Files) a} deriving newtype (Functor, Applicative, Monad, MonadState (St, Files)) -newtype FormattedWriter a = FormattedWriter (RWS () Text St a) - deriving newtype (Functor, Applicative, Monad, MonadState St) +newtype FormattedWriter a = FormattedWriter (RWS () Text Fmt a) + deriving newtype (Functor, Applicative, Monad, MonadState Fmt) -indented :: FormattedWriter a -> FormattedWriter a +indented :: FileM a -> FileM a indented fn = do - modify (\(St id p) -> St (id + 1) p) - fn <* modify (\(St id p) -> St (id - 1) p) + textM (modify (\(Fmt id p) -> Fmt (id + 1) p)) + fn <* textM (modify (\(Fmt id p) -> Fmt (id - 1) p)) execFormattedWriter :: FormattedWriter a -> Text -execFormattedWriter ((>> flush) -> FormattedWriter rws) = snd $ execRWS rws () (St 0 "") +execFormattedWriter ((>> flush) -> FormattedWriter rws) = snd $ execRWS rws () (Fmt 0 "") flush :: FormattedWriter () flush = do @@ -75,23 +100,68 @@ flush = do modify $ \s -> s {pendingLine = ""} tell p -data Files = Files - { filepaths :: Map FilePath (Map FilePosition (FormattedWriter ())) +newtype FileFragments = FileFragments (Map Fragment (FormattedWriter ())) + +instance Semigroup FileFragments where + (FileFragments m1) <> (FileFragments m2) = FileFragments (Map.unionWith (>>) m1 m2) + +instance Monoid FileFragments where + mempty = FileFragments mempty + +newtype CFileState = CFileState + { includedFiles :: Set String } -withFileAt :: FilePath -> FilePosition -> FormattedWriter () -> M () -withFileAt fp pos wr = do +newtype FileM a = FileM {unFileM :: RWS Fragment FileFragments CFileState a} + deriving newtype (Functor, Applicative, Monad, MonadWriter FileFragments, MonadReader Fragment, MonadState CFileState) + +execFileM :: FileM a -> Text +execFileM fm = + let (_, FileFragments mp) = execRWS (unFileM fm) hF (CFileState mempty) + in ( execFormattedWriter + . sequence_ + . Map.elems + ) + mp + +requireInclude :: String -> FileM () +requireInclude file = do + b <- (Set.member file) <$> gets includedFiles + unless b $ do + under hF $ + text $ + Text.pack $ + printf "#include <%s>\n" file + modify $ \s -> s {includedFiles = Set.insert file (includedFiles s)} + +-- | Writes text to the current fragment context +text :: Text -> FileM () +text t = flip tellF_ t =<< ask + +-- | Writes text to the current fragment context +textM :: FormattedWriter () -> FileM () +textM t = flip tellFM_ t =<< ask + +-- | Executes a file monad within a different fragment. +under :: Fragment -> FileM () -> FileM () +under fr = local (const fr) + +tellF_ :: Fragment -> Text -> FileM () +tellF_ fp txt = tell $ FileFragments $ Map.singleton fp (tell txt) + +tellFM_ :: Fragment -> FormattedWriter () -> FileM () +tellFM_ fp txtM = tell $ FileFragments $ Map.singleton fp txtM + +newtype Files = Files + { filepaths :: Map FilePath (FileM ()) + } + +withFile :: FilePath -> FileM () -> M () +withFile fp fn = do modify ( second $ \(Files {filepaths = fps}) -> Files - { filepaths = - Map.alter - ( \(fromMaybe mempty -> posMap) -> - Just $ - Map.alter (Just . (>> wr) . fromMaybe (return ())) pos posMap - ) - fp - fps + { filepaths = Map.alter (Just . (>> fn) . fromMaybe (return ())) fp fps } ) @@ -106,7 +176,7 @@ instance MonadWriter Text FormattedWriter where tell pending tell line tell "\n" - modify $ \s -> s {pendingLine = last lines} + modify $ \s -> s {pendingLine = pendingLine s <> last lines} listen (FormattedWriter fn) = FormattedWriter $ listen fn @@ -143,13 +213,7 @@ cBackend = toTranspileResult :: Files -> TranspileResult toTranspileResult Files {filepaths = fps} = - TranspileResult $ - fmap - ( execFormattedWriter - . sequence_ - . Map.elems - ) - fps + TranspileResult $ fmap execFileM fps transpile :: CBackendFlags -> @@ -162,21 +226,28 @@ transpile cSourceOut = sourceFile } () - fiddleUnit = toTranspileResult . snd . fst $ execRWS (unM run) () (St 0 "", Files mempty) + fiddleUnit = toTranspileResult . snd . fst $ execRWS (unM run) () (St, Files mempty) where run :: M () run = do - withFileAt headerFile headerPos $ do - tell $ "#ifndef " <> headerGuard <> "\n" - tell $ "#define " <> headerGuard <> "\n" + withFile headerFile $ do + textM $ do + tell $ "#ifndef " <> headerGuard <> "\n" + tell $ "#define " <> headerGuard <> "\n\n" + tell "#include <stdint.h>\n" + + -- Pad out the implementation + under iF $ text "\n" walk (transpileWalk sourceFile headerFile) fiddleUnit () - withFileAt headerFile footerPos $ tell headerFinal - withFileAt headerFile headerPos $ do - tell "\n#include <stdint.h>\n" + withFile headerFile $ do + under hF $ + textM $ do + tell "\nstatic_assert(true); // https://github.com/clangd/clangd/issues/1167\n" - tell "\nstatic_assert(true); // https://github.com/clangd/clangd/issues/1167\n" + under fF $ + text headerFinal headerFinal = "\n#endif /* " <> headerGuard <> " */\n" @@ -208,43 +279,210 @@ ensureNL = do tell p tell "\n" -pad :: (IsString t, MonadWriter t m) => m a -> m a -pad f = tell "\n" *> f <* tell "\n" +pad :: FileM () -> FileM () +pad f = text "\n" *> f <* text "\n" + +writeStaticAssert :: Text -> String -> N Bytes -> FileM () +writeStaticAssert structName regname off = do + requireInclude "stddef.h" + text $ + Text.pack $ + printf + "\n_Static_assert(offsetof(%s, %s) == 0x%x, \"Offset wrong\");\n" + structName + regname + off + +sizeToType :: N Bytes -> Maybe String +sizeToType = \case + 1 -> Just "uint8_t" + 2 -> Just "uint16_t" + 4 -> Just "uint32_t" + 8 -> Just "uint64_t" + _ -> Nothing + +selectByModifier :: Modifier f an -> (a, a) -> [a] +selectByModifier mod (getter, setter) = + case mod of + (ModifierKeyword Rw _) -> [getter, setter] + (ModifierKeyword Ro _) -> [getter] + (ModifierKeyword Wo _) -> [setter] + (ModifierKeyword Pr _) -> [] + +writeRegGet :: StructName -> QRegMetadata True -> FileM () +writeRegGet + structType + ( QRegMetadata + { regSpan = + Present + FieldSpan + { size = size + }, + regFullPath = fullPath + } + ) = do + let fnName = "get_" <> qualifiedPathToIdentifier fullPath + returnType = sizeToType size + fieldName = NonEmpty.last fullPath + + case returnType of + Just rt -> do + textM $ do + tell $ + Text.pack $ + printf "static inline %s %s(const %s* o) {\n" rt fnName structType + tell $ Text.pack $ printf " return o->%s;\n" fieldName + tell "}\n\n" + Nothing -> + -- Return type is not defined, fallback to byte-by-byte copy. + textM $ do + tell $ + Text.pack $ + printf + "static inline void %s(%s* o, uint8_t out[%d]) {\n" + fnName + structType + size + forM_ [0 .. size - 1] $ \i -> + tell $ Text.pack $ printf " out[%d] = o->%s[%d];\n" i fieldName i + tell "}\n\n" + +writeRegSet :: StructName -> QRegMetadata True -> FileM () +writeRegSet + structType + ( QRegMetadata + { regSpan = + Present + FieldSpan + { size = size + }, + regFullPath = fullPath + } + ) = do + let fnName = "set_" <> qualifiedPathToIdentifier fullPath + setType = sizeToType size + fieldName = NonEmpty.last 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 + tell $ Text.pack $ printf " o->%s = v;\n" fieldName + tell "}\n\n" + Nothing -> + -- Return type is not defined, fallback to byte-by-byte copy. + textM $ do + tell $ + Text.pack $ + printf + "static inline void %s(%s* o, const uint8_t in[%d]) {\n" + fnName + structType + size + forM_ [0 .. size - 1] $ \i -> + tell $ Text.pack $ printf " o->%s[%d] = in[%d];\n" fieldName i i + tell "}\n\n" + +pattern DefinedBitsP :: String -> NonEmpty String -> N Bits -> RegisterBitsDecl Checked f a +pattern DefinedBitsP bitsName bitsFullPath offset <- + ( DefinedBits + { qBitsMetadata = + Present + QBitsMetadata + { bitsSpan = + Present + FieldSpan + { offset = offset + }, + bitsFullPath = (NonEmpty.last &&& id -> (bitsName, bitsFullPath)) + } + } + ) + +writeRegisterBody :: StructName -> QRegMetadata True -> RegisterBody Checked I A -> FileM () +writeRegisterBody structName regmeta = walk_ registerWalk + where + registerWalk :: forall t. (Walk t, Typeable t) => t I A -> FileM () + registerWalk t = case () of + () + | (Just (DefinedBitsP bitsName fullPath offset)) <- castTS t -> + text $ + Text.pack $ + printf + "// Emit bits %s (%s) at %d\n" + bitsName + (qualifiedPathToIdentifier fullPath) + offset + _ -> return () -structBody :: ObjTypeBody Checked I A -> FormattedWriter () -structBody (ObjTypeBody _ decls _) = do + castTS :: + forall (t' :: SynTree) (t :: StagedSynTree) (f :: Type -> Type) (a :: Type). + ( Typeable t', + Typeable t, + Typeable f, + Typeable a + ) => + t' f a -> + Maybe (t Checked f a) + castTS = cast + +writeImplementation :: + StructName -> + QRegMetadata True -> + Modifier f a -> + Maybe (RegisterBody Checked I A) -> + FileM () + +-- | Register is just padding, don't emit anything +writeImplementation _ (regIsPadding -> True) _ _ = return () +writeImplementation structName qMeta mod bod = do + unless (regIsUnnamed qMeta) $ + sequence_ $ + selectByModifier mod (writeRegGet structName qMeta, writeRegSet structName qMeta) + + mapM_ (writeRegisterBody structName qMeta) bod + +structBody :: StructName -> ObjTypeBody Checked I A -> FileM () +structBody structName (ObjTypeBody _ decls _) = do forM_ decls $ \(Directed _ decl _) -> case decl of RegisterDecl - { regSpan = Present (FieldSpan _ sz), + { qRegMeta = Present regMetadata, regIdent = Guaranteed (identToString -> i), + regModifier = Guaranteed mod, + regBody = bod, 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" + let (Present (FieldSpan off sz)) = regSpan regMetadata + + textM $ do + emitDocComments ann + tell (sizeToField i sz) + tell ";\n" + + under aF $ + writeStaticAssert structName i off + + under iF $ + writeImplementation structName regMetadata mod bod TypeSubStructure { subStructureBody = Identity bod, subStructureName = mname } -> do - tell $ case objBodyType bod of - Union {} -> "union " - Struct {} -> "struct " + text $ + case objBodyType bod of + Union {} -> "union " + Struct {} -> "struct " - body $ structBody bod + body $ structBody structName bod - forM_ mname $ \name -> - tell (Text.pack $ identToString name) + textM $ do + forM_ mname $ \name -> + tell (Text.pack $ identToString name) - tell ";\n" + tell ";\n" where sizeToField (Text.pack -> f) = \case 1 -> "volatile uint8_t " <> f @@ -253,24 +491,24 @@ structBody (ObjTypeBody _ decls _) = do 8 -> "volatile uint64_t " <> f n -> "volatile uint8_t " <> f <> "[" <> Text.pack (show n) <> "]" -union :: Text -> FormattedWriter () -> FormattedWriter () +union :: Text -> FileM () -> FileM () union identifier fn = do - tell "#pragma pack(push, 1)\n" - tell $ "union " <> identifier <> " " + text "#pragma pack(push, 1)\n" + text $ "union " <> identifier <> " " body fn - tell ";\n" - tell "#pragma pack(pop)\n" + text ";\n" + text "#pragma pack(pop)\n" -struct :: Text -> FormattedWriter () -> FormattedWriter () +struct :: Text -> FileM () -> FileM () struct identifier fn = do - tell "#pragma pack(push, 1)\n" - tell $ "struct " <> identifier <> " " + text "#pragma pack(push, 1)\n" + text $ "struct " <> identifier <> " " body fn - tell ";\n" - tell "#pragma pack(pop)\n" + text ";\n" + text "#pragma pack(pop)\n" -body :: FormattedWriter a -> FormattedWriter a -body f = tell "{\n" *> indented f <* (ensureNL >> tell "}") +body :: FileM a -> FileM a +body f = text "{\n" *> indented f <* textM (ensureNL >> tell "}") identifierFor :: (ExportableDecl d) => d -> Text identifierFor = qualifiedPathToIdentifier . metadataFullyQualifiedPath . getMetadata @@ -313,14 +551,29 @@ transpileWalk _ headerFile t _ = case () of Union {} -> union Struct {} -> struct - withFileAt headerFile middlePos $ do - pad $ do - emitDocComments a - structureType (identifierFor (unwrap metadata)) $ do - structBody objTypeBody + withFile headerFile $ do + under sF $ do + pad $ do + textM $ emitDocComments a + let structName = identifierFor (unwrap metadata) + structureType structName $ do + structBody structName objTypeBody return Stop + () | Just (getExportedObjectDecl -> Just e) <- castTS t -> do + let qname = qualifiedPathToIdentifier (metadataFullyQualifiedPath (getMetadata e)) + withFile headerFile $ + under fF $ do + text "#define " + text qname + text $ Text.pack $ printf " ((%s*)0x%08x)\n" (toLiteralTypeName (exportedObjectDeclType e)) (exportedObjectDeclLocation e) + + return Stop _ -> return (Continue ()) where + toLiteralTypeName :: ReferencedObjectType -> Text + toLiteralTypeName (ReferencedObjectType str) = qualifiedPathToIdentifier str + toLiteralTypeName (ArrayObjectType ro _) = toLiteralTypeName ro + castTS :: forall (t' :: SynTree) (t :: StagedSynTree) (f :: Type -> Type) (a :: Type). ( Typeable t', @@ -331,3 +584,7 @@ transpileWalk _ headerFile t _ = case () of t' f a -> Maybe (t Checked f a) castTS = cast + + getExportedObjectDecl :: FiddleDecl Checked I A -> Maybe ExportedObjectDecl + getExportedObjectDecl (ObjectDecl {objectQualificationMetadata = Identity (Present decl)}) = Just decl + getExportedObjectDecl _ = Nothing |