diff options
| -rw-r--r-- | src/Language/Fiddle/Ast/Internal/SyntaxTree.hs | 10 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Backend/C.hs | 58 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/ConsistencyCheck.hs | 8 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Qualification.hs | 21 | ||||
| -rw-r--r-- | src/Language/Fiddle/Parser.hs | 15 |
5 files changed, 95 insertions, 17 deletions
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs index 2774507..a4f98e3 100644 --- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs +++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs @@ -119,7 +119,8 @@ regSzToBits RegSz64 = 64 data QBitsMetadata (checkStage :: Bool) where QBitsMetadata :: { bitsSpan :: When checkStage (FieldSpan Bits), - bitsFullPath :: QualifiedPath String + bitsFullPath :: QualifiedPath String, + bitsUnnamed :: Bool } -> QBitsMetadata checkStage deriving (Generic, ToJSON) @@ -666,7 +667,12 @@ data RegisterBitsDecl stage f a where RegisterBitsDecl stage f a -- | Substructure within a register. BitsSubStructure :: - { -- | The body of the substructure. + { -- | Metadata about the bits. + qBitsMetadata :: When (stage .>= Qualified) (QBitsMetadata (stage .>= Checked)), + -- | Modifier for these bits. Useful when multiple fields need to be set + -- atomically. + bitsModifier :: Guaranteed (stage .>= Qualified) (Modifier f a), + -- | The body of the substructure. bitsSubRegBody :: RegisterBody stage f a, -- | Optional name for the substructure. bitsSubName :: Maybe (Identifier f a), diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs index 4b4b3ea..1ab22bb 100644 --- a/src/Language/Fiddle/Compiler/Backend/C.hs +++ b/src/Language/Fiddle/Compiler/Backend/C.hs @@ -361,6 +361,33 @@ pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef annot <- } ) +pattern BitsSubstructureP :: + Modifier f a -> + String -> + QualifiedPath String -> + N Bits -> + N Bits -> + RegisterBody Checked f A -> + A -> + RegisterBitsDecl Checked f A +pattern BitsSubstructureP modifier bitsName bitsFullPath offset size subRegisterBody annot <- + BitsSubStructure + { qBitsMetadata = + Present + QBitsMetadata + { bitsSpan = + Present + FieldSpan + { offset = offset, + size = size + }, + bitsFullPath = (basenamePart &&& id -> (bitsName, bitsFullPath)) + }, + bitsModifier = (Guaranteed modifier), + bitsSubRegBody = subRegisterBody, + bitsSubAnnot = annot + } + writeBitsGet :: StructName -> QRegMetadata True -> @@ -616,13 +643,13 @@ typeRefToArgs reg = -- decomposeBitsTypeRef (RegisterBitsJustBits ) writeRegisterBody :: StructName -> QRegMetadata True -> RegisterBody Checked I A -> M SIntf -writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk +writeRegisterBody structName regmeta t = execWriterT $ walk (\t' () -> registerWalk t') t () where registerWalk :: forall t. (Walk t, Typeable t) => t I A -> - WriterT SIntf (FilesM () FormattedWriter CFileState) () + WriterT SIntf (FilesM () FormattedWriter CFileState) (WalkContinuation ()) registerWalk t = case () of () | (Just (DefinedBitsP modifier _ fullPath offset typeRef annot)) <- castTS t -> @@ -637,6 +664,31 @@ writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk ( tell =<< lift (writeBitsGet structName regmeta fullPath offset typeRef annot), tell =<< lift (writeBitsSet isWo structName regmeta fullPath offset typeRef annot) ) + return Stop + () | (Just (BitsSubstructureP modifier bitsName fullPath offset size subBody annot)) <- castTS t -> do + sIntf <- lift (writeRegisterBody structName regmeta subBody) + let isWo = case modifier of + ModifierKeyword Wo _ -> True + _ -> False + if null bitsName + then tell sIntf + else do + -- Make a typeref here which is defined as "just bitse" + let typeRef = + RegisterBitsJustBits + (ConstExpression (LeftV size) annot) + annot + + tell $ sIntfSingleton bitsName sIntf + lift $ textM $ emitDocComments annot + sequence_ $ + selectByModifier + modifier + ( tell =<< lift (writeBitsGet structName regmeta fullPath offset typeRef annot), + tell =<< lift (writeBitsSet isWo structName regmeta fullPath offset typeRef annot) + ) + + return Stop -- text $ -- Text.pack $ -- printf @@ -644,7 +696,7 @@ writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk -- bitsName -- (qualifiedPathToIdentifier fullPath) -- offset - _ -> return () + _ -> return $ Continue () castTS :: forall (t' :: SynTree) (t :: StagedSynTree) (f :: Type -> Type) (a :: Type). diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs index f85d9d4..c4924da 100644 --- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs +++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs @@ -299,9 +299,11 @@ advanceDecl offset = \case (size,) <$> (DefinedBits qmeta' mod ident <$> advanceStage () typ <*> pure annot) - BitsSubStructure subBody subName ann -> do - (sz, body') <- advanceRegisterBody offset subBody - return (sz, BitsSubStructure body' subName ann) + BitsSubStructure qmeta modifier subBody subName ann -> do + (size, body') <- advanceRegisterBody offset subBody + let span = Present (FieldSpan offset size) + qmeta' = fmap (\q -> q {bitsSpan = span}) qmeta + return (size, BitsSubStructure qmeta' modifier body' subName ann) bitsTypeSize :: RegisterBitsTypeRef S F A -> M (N Bits) bitsTypeSize (RegisterBitsArray tr nExpr _) = do diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs index 8bae2de..ac99f48 100644 --- a/src/Language/Fiddle/Compiler/Qualification.hs +++ b/src/Language/Fiddle/Compiler/Qualification.hs @@ -159,9 +159,21 @@ deriving instance AdvanceStage S EnumConstantDecl instance AdvanceStage S RegisterBitsDecl where advanceStage localState = \case ReservedBits expr an -> ReservedBits <$> advanceStage localState expr <*> pure an - BitsSubStructure bod name an -> - BitsSubStructure - <$> advanceStage localState bod + BitsSubStructure Vacant mod bod name an -> do + let (path, localState') = + maybe + (fmap (const "") (currentQualifiedPath localState), localState) + ( \ident -> pushRegister (identToString ident) localState + ) + name + qMeta = + QBitsMetadata + { bitsSpan = Vacant, + bitsFullPath = path, + bitsUnnamed = isNothing name + } + BitsSubStructure (Present qMeta) (guarantee (ModifierKeyword Rw an) mod) + <$> advanceStage localState' bod <*> pure name <*> pure an DefinedBits _ mod ident typ an -> do @@ -169,7 +181,8 @@ instance AdvanceStage S RegisterBitsDecl where qMeta = QBitsMetadata { bitsSpan = Vacant, - bitsFullPath = path + bitsFullPath = path, + bitsUnnamed = False } DefinedBits (Present qMeta) (guarantee (ModifierKeyword Rw an) mod) ident <$> advanceStage localState typ diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs index c3056bd..e91fa41 100644 --- a/src/Language/Fiddle/Parser.hs +++ b/src/Language/Fiddle/Parser.hs @@ -276,11 +276,16 @@ registerBitsDeclP = ( do tok KWReserved >> ReservedBits <$> exprInParenP ) - <|> (BitsSubStructure <$> registerBodyP <*> optionMaybe ident) - <|> ( DefinedBits Vacant . Perhaps - <$> optionMaybe modifierP - <*> ident - <*> (tok TokColon >> registerBitsTypeRefP) + <|> ( do + mod <- optionMaybe modifierP + ( BitsSubStructure Vacant (Perhaps mod) + <$> registerBodyP + <*> optionMaybe ident + ) + <|> ( DefinedBits Vacant (Perhaps mod) + <$> ident + <*> (tok TokColon >> registerBitsTypeRefP) + ) ) registerBitsTypeRefP :: Pa RegisterBitsTypeRef |