summaryrefslogtreecommitdiff
path: root/src/Language/Fiddle/Compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/Fiddle/Compiler')
-rw-r--r--src/Language/Fiddle/Compiler/Backend/C.hs42
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs28
-rw-r--r--src/Language/Fiddle/Compiler/Qualification.hs18
3 files changed, 59 insertions, 29 deletions
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index 26ea065..77eadf6 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -273,7 +273,8 @@ writeRegGet
},
regFullPath = fullPath
}
- ) docComms = do
+ )
+ docComms = do
let fnName = qualifiedPathToIdentifier fullPath <> "__get"
returnType = sizeToType size
fieldName = basenamePart fullPath
@@ -313,7 +314,8 @@ writeRegSet
},
regFullPath = fullPath
}
- ) docComs = do
+ )
+ docComs = do
let fnName = qualifiedPathToIdentifier fullPath <> "__set"
setType = sizeToType size
fieldName = basenamePart fullPath
@@ -370,16 +372,18 @@ pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef annot <-
writeBitsGet ::
StructName ->
- String ->
+ QRegMetadata True ->
QualifiedPath String ->
N Bits ->
RegisterBitsTypeRef 'Checked I A ->
A ->
M SIntf
-writeBitsGet structName regName fullPath offset typeRef docComms = do
+writeBitsGet structName regmeta fullPath offset typeRef docComms = do
let fnName = qualifiedPathToIdentifier fullPath <> "__get"
bitsName = basenamePart fullPath
retType = typeRefBaseType typeRef
+ regName = basenamePart (regFullPath regmeta)
+ regCType = getRegCType regmeta
text $ "inline static " <> retType <> " "
text fnName
@@ -404,13 +408,13 @@ writeBitsGet structName regName fullPath offset typeRef docComms = do
withIndent $ do
if null shiftArguments
then do
- text "unsigned shift_ = 0"
+ text $ regCType <> " shift_ = 0"
else do
- text "unsigned shift_ = "
+ text $ regCType <> " shift_ = "
text $ Text.intercalate " + " shiftArguments
text ";\n"
- text "unsigned mask_ = "
+ text $ regCType <> " mask_ = "
text $ typeRefToGetMask typeRef
text " << shift_;\n"
@@ -467,18 +471,26 @@ writeBitsGet structName regName fullPath offset typeRef docComms = do
num = (1 `Data.Bits.shiftL` fromIntegral sz) - 1
in "0x" <> Text.pack (showHex num "")
+getRegCType :: QRegMetadata True -> Text
+getRegCType meta =
+ Text.pack $
+ fromMaybe "unsigned" $
+ sizeToType (size (unwrap (regSpan meta)))
+
writeBitsSet ::
Bool ->
StructName ->
- String ->
+ QRegMetadata True ->
QualifiedPath String ->
N Bits ->
RegisterBitsTypeRef 'Checked I A ->
A ->
M SIntf
-writeBitsSet writeOnly structName regName fullPath offset typeRef docComms = do
+writeBitsSet writeOnly structName regmeta fullPath offset typeRef docComms = do
let fnName = qualifiedPathToIdentifier fullPath <> "__set"
bitsName = basenamePart fullPath
+ regName = basenamePart (regFullPath regmeta)
+ regCType = getRegCType regmeta
text "inline static void "
text fnName
@@ -498,10 +510,10 @@ writeBitsSet writeOnly structName regName fullPath offset typeRef docComms = do
withIndent $ do
let mask = typeRefToMask typeRef
- text $ "unsigned mask_ = " <> mask <> ";\n"
+ text $ regCType <> " mask_ = " <> mask <> ";\n"
unless (null shiftArguments) $ do
text $
- "unsigned shift_ = " <> Text.intercalate " + " shiftArguments <> ";\n"
+ regCType <> " shift_ = " <> Text.intercalate " + " shiftArguments <> ";\n"
text "mask_ <<= shift_;\n"
text "int to_set_ = value"
@@ -512,7 +524,7 @@ writeBitsSet writeOnly structName regName fullPath offset typeRef docComms = do
text "to_set_ &= mask_;\n"
unless writeOnly $ do
- text $ "unsigned current_ = o->" <> Text.pack regName <> ";\n"
+ text $ regCType <> " current_ = o->" <> Text.pack regName <> ";\n"
text "to_set_ = current_ ^ (current_ & mask_) ^ to_set_;\n"
text $ "o->" <> Text.pack regName <> " = to_set_;\n"
@@ -614,8 +626,6 @@ writeRegisterBody ::
StructName -> QRegMetadata True -> RegisterBody Checked I A -> M SIntf
writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk
where
- regName = basenamePart (regFullPath regmeta)
-
registerWalk ::
forall t.
(Walk t, Typeable t) =>
@@ -632,8 +642,8 @@ writeRegisterBody structName regmeta = execWriterT . walk_ registerWalk
sequence_ $
selectByModifier
modifier
- ( tell =<< lift (writeBitsGet structName regName fullPath offset typeRef annot),
- tell =<< lift (writeBitsSet isWo structName regName fullPath offset typeRef annot)
+ ( tell =<< lift (writeBitsGet structName regmeta fullPath offset typeRef annot),
+ tell =<< lift (writeBitsSet isWo structName regmeta fullPath offset typeRef annot)
)
-- text $
-- Text.pack $
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 3def59d..00a53dc 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -156,25 +156,33 @@ advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
checkPositionAssertion (annot e) assertedPos offset
return (ret, offset)
(RegisterDecl qmeta mod ident size Nothing a) -> do
- (sizeExpr, reifiedSize) <- advanceAndGetSize size
- reifiedSizeBytes <- checkBitsSizeMod8 a reifiedSize
+ let declaredSize = regSzToBits (getLeft size)
+ reifiedSizeBytes <- checkBitsSizeMod8 a declaredSize
let span = Present (FieldSpan offset reifiedSizeBytes)
qmeta' = fmap (\q -> q {regSpan = span}) qmeta
- doReturn (RegisterDecl qmeta' mod ident sizeExpr Nothing a)
- =<< checkBitsSizeMod8 a reifiedSize
+ doReturn (RegisterDecl qmeta' mod ident (changeRight size) Nothing a)
+ =<< checkBitsSizeMod8 a declaredSize
(RegisterDecl qmeta mod ident size (Just body) a) -> do
- declaredSize <- expressionToIntM size
- (actualSize, body') <- advanceRegisterBody 0 body
+ let declaredSize = regSzToBits (getLeft size)
+ (actualSize, body') <- advanceRegisterBody 0 body
checkSizeMismatch a declaredSize actualSize
-
- (sizeExpr, reifiedSize) <- advanceAndGetSize size
- reifiedSizeBytes <- checkBitsSizeMod8 a reifiedSize
+ reifiedSizeBytes <- checkBitsSizeMod8 a declaredSize
let span = Present (FieldSpan offset reifiedSizeBytes)
qmeta' = fmap (\q -> q {regSpan = span}) qmeta
- doReturn (RegisterDecl qmeta' mod ident sizeExpr (Just body') a) reifiedSizeBytes
+
+ doReturn
+ ( RegisterDecl
+ qmeta'
+ mod
+ ident
+ (changeRight size)
+ (Just body')
+ a
+ )
+ reifiedSizeBytes
(TypeSubStructure (Identity body) name a) -> do
(size, body') <- advanceObjTypeBody body offset
doReturn (TypeSubStructure (Identity body') name a) size
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index e8ab479..eae219e 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -177,6 +177,18 @@ instance AdvanceStage S RegisterBitsDecl where
<$> advanceStage localState typ
<*> pure an
+getProperRegSize :: (stage .< Expanded ~ False) => Expression Bits stage F A -> M RegSz
+getProperRegSize expr = do
+ v <- expressionToIntM expr
+ case v of
+ 8 -> return RegSz8
+ 16 -> return RegSz16
+ 32 -> return RegSz32
+ 64 -> return RegSz64
+ _ -> do
+ emitDiagnosticError "Exotic register size." (annot expr)
+ return RegSz32
+
instance AdvanceStage S ObjTypeDecl where
advanceStage localState = \case
AssertPosStatement d e a ->
@@ -202,7 +214,7 @@ instance AdvanceStage S ObjTypeDecl where
(Present qRegMeta)
(guarantee (ModifierKeyword Rw ann) mod)
ident'
- <$> advanceStage localState'' size
+ <$> progressBackM getProperRegSize size
<*> mapM (advanceStage localState'') bod
<*> pure ann
ReservedDecl _ expr ann -> do
@@ -222,7 +234,7 @@ instance AdvanceStage S ObjTypeDecl where
(Present qRegMeta)
(Guaranteed $ ModifierKeyword Pr ann)
(Guaranteed ident)
- <$> advanceStage localState expr
+ <$> fmap LeftV (getProperRegSize expr)
<*> pure Nothing
<*> pure ann
TypeSubStructure bod name an -> do
@@ -482,7 +494,7 @@ calculateTypeSize (ObjTypeBody bodyType decls _) =
calculateDeclSize (undirected -> decl) =
case decl of
AssertPosStatement {} -> return 0
- RegisterDecl {regSize = size} -> fst . bitsToBytes <$> expressionToIntM size
+ RegisterDecl {regSize = size} -> fst . bitsToBytes <$> expressionToIntM (getRight size)
ReservedDecl {reservedExpr = size} -> fst . bitsToBytes <$> expressionToIntM size
TypeSubStructure {subStructureBody = b} -> calculateTypeSize =<< resolveOrFail b
generated by cgit (git 2.34.1) at 2025-04-28 20:46:08 +0000