diff options
| -rw-r--r-- | goal.fiddle | 5 | ||||
| -rw-r--r-- | src/Language/Fiddle/Ast/Internal/SyntaxTree.hs | 52 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Backend/C.hs | 73 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/ConsistencyCheck.hs | 14 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Qualification.hs | 19 | ||||
| -rw-r--r-- | src/Language/Fiddle/Parser.hs | 6 |
6 files changed, 135 insertions, 34 deletions
diff --git a/goal.fiddle b/goal.fiddle index 8b8a93b..24203b5 100644 --- a/goal.fiddle +++ b/goal.fiddle @@ -44,10 +44,10 @@ package stm32l4.gpio { } [16]; }; + assert_pos(0x04); /** * The output type. */ - assert_pos(0x04); [[ noexport ]] reg ocfg_r(32) : struct { otype_r : enum(1) { @@ -67,11 +67,10 @@ package stm32l4.gpio { reserved(16); // Have to pad out the remaining 16 bits. }; + assert_pos(0x08); /** * Sets the speed of the provided GPIO pin. */ - assert_pos(0x08); - [[ noexport ]] reg (32) : struct { ospeed_r : enum(2) { 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) |