diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler')
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage1.hs | 18 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage2.hs | 202 |
2 files changed, 182 insertions, 38 deletions
diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs index 3a97757..25ee66b 100644 --- a/src/Language/Fiddle/Compiler/Stage1.hs +++ b/src/Language/Fiddle/Compiler/Stage1.hs @@ -123,11 +123,20 @@ enumConstantToStage2 path = \case EnumConstantReserved e a -> EnumConstantReserved <$> toStage2Expr e <*> pure a objTypeBodyToStage2 :: Path -> ObjTypeBody Stage1 I Annot -> M Annot (ObjTypeBody Stage2 I Annot) -objTypeBodyToStage2 path (ObjTypeBody decls annot) = ObjTypeBody <$> mapM (objTypeDeclToStage2 path) decls <*> pure annot +objTypeBodyToStage2 path (ObjTypeBody bodyType decls annot) = + ObjTypeBody bodyType <$> mapM (objTypeDeclToStage2 path) decls <*> pure annot objTypeDeclToStage2 :: Path -> ObjTypeDecl Stage1 I Annot -> M Annot (ObjTypeDecl Stage2 I Annot) objTypeDeclToStage2 path = \case (AssertPosStatement expr annot) -> AssertPosStatement <$> toStage2Expr expr <*> pure annot + (TypeSubStructure (Identity deferredBody) maybeIdent annot) -> + let path' = maybe path (`pushId` path) maybeIdent + in TypeSubStructure . Identity + <$> objTypeBodyToStage2 path' deferredBody + <*> pure maybeIdent + <*> pure annot + (ReservedDecl expr a) -> + ReservedDecl <$> toStage2Expr expr <*> pure a (RegisterDecl maybeModifier maybeIdentifier expression maybeBody annot) -> let path' = maybe path (`pushId` path) maybeIdentifier in RegisterDecl @@ -138,8 +147,8 @@ objTypeDeclToStage2 path = \case <*> pure annot registerBodyToStage2 :: Path -> RegisterBody Stage1 I Annot -> M Annot (RegisterBody Stage2 I Annot) -registerBodyToStage2 path (RegisterBody (Identity (DeferredRegisterBody registerBitsDecl a1)) a2) = - RegisterBody . Identity +registerBodyToStage2 path (RegisterBody bodyType (Identity (DeferredRegisterBody registerBitsDecl a1)) a2) = + RegisterBody bodyType . Identity <$> ( DeferredRegisterBody <$> mapM (registerBitsDeclToStage2 path) registerBitsDecl <*> pure a1 @@ -149,6 +158,9 @@ registerBodyToStage2 path (RegisterBody (Identity (DeferredRegisterBody register registerBitsDeclToStage2 :: Path -> RegisterBitsDecl Stage1 I Annot -> M Annot (RegisterBitsDecl Stage2 I Annot) registerBitsDeclToStage2 path = \case ReservedBits expr a -> ReservedBits <$> toStage2Expr expr <*> pure a + BitsSubStructure registerBody maybeIdent annot -> + let path' = maybe path (`pushId` path) maybeIdent + in BitsSubStructure <$> registerBodyToStage2 path' registerBody <*> pure maybeIdent <*> pure annot DefinedBits maybeModifier identifier registerBitsTyperef annot -> let path' = pushId identifier path in ( DefinedBits diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/Stage2.hs index baa61e3..727f153 100644 --- a/src/Language/Fiddle/Compiler/Stage2.hs +++ b/src/Language/Fiddle/Compiler/Stage2.hs @@ -117,8 +117,8 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do [ Diagnostic Warning ( printf - "Missing enum constants %s. Please fully pack a small enum.\ - \ Use 'reserved' if needed." + "Missing enum constants %s. Small enums should be fully \ + \ populated. Use 'reserved' if needed." (intercalate ", " (map show missing)) ) (unCommented ann) @@ -136,7 +136,7 @@ fiddleDeclToStage3 = \case addTypeSize id typeSize BitsDecl id <$> bitTypeToStage3 typ <*> pure a ObjTypeDecl ident body a -> - ObjTypeDecl ident <$> mapM objTypeBodyToStage3 body <*> pure a + ObjTypeDecl ident <$> mapM (\bt -> fst <$> objTypeBodyToStage3 bt 0) body <*> pure a ObjectDecl ident expr typ a -> ObjectDecl ident (expressionToStage3 expr) <$> objTypeToStage3 typ <*> pure a @@ -152,7 +152,11 @@ objTypeToStage3 = \case registerBodyToStage3 :: RegisterBody Stage2 I Annot -> Compile Stage3State (RegisterBody Stage3 I Annot, Word32) -registerBodyToStage3 (RegisterBody (Identity deferredRegisterBody) a') = +registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a') = do + let isUnion = case bodyType of + Union {} -> True + _ -> False + case deferredRegisterBody of DeferredRegisterBody decls a -> do (cur, returned) <- @@ -160,17 +164,79 @@ registerBodyToStage3 (RegisterBody (Identity deferredRegisterBody) a') = ( \(cursor, returned) decl -> case decl of ReservedBits expr a -> do - size <- exprToSize expr + size <- fromIntegral <$> exprToSize expr let s3 = ReservedBits (expressionToStage3 expr) a - return (cursor + fromIntegral size, s3 : returned) + if isUnion + then checkUnion cursor size (s3 : returned) a + else + return (cursor + size, s3 : returned) + BitsSubStructure registerBody maybeIdent annot -> do + checkBitsSubStructure registerBody maybeIdent annot + + (newBody, subsize) <- registerBodyToStage3 registerBody + let s3 = BitsSubStructure newBody maybeIdent annot + + if isUnion + then checkUnion cursor subsize (s3 : returned) a + else + return (cursor + subsize, s3 : returned) DefinedBits modifier identifier typeref a -> do (s3TypeRef, size) <- registerBitsTypeRefToStage3 typeref - return (cursor + size, DefinedBits modifier identifier s3TypeRef a : returned) + let s3 = DefinedBits modifier identifier s3TypeRef a + + if isUnion + then checkUnion cursor size (s3 : returned) a + else + return (cursor + size, s3 : returned) ) (0, []) decls - return (RegisterBody (Identity (DeferredRegisterBody (reverse returned) a)) a', cur) + return (RegisterBody bodyType (Identity (DeferredRegisterBody (reverse returned) a)) a', cur) + where + checkBitsSubStructure + (RegisterBody bodyType (Identity (DeferredRegisterBody decls _)) _) + maybeIdent + annot = + let emitWarning s = tell [Diagnostic Warning s (unCommented annot)] + in case () of + () + | [_] <- decls, + (Union {}) <- bodyType -> + emitWarning "Union with a single field. Should this be a struct?" + () + | [_] <- decls, + (Struct {}) <- bodyType, + Nothing <- maybeIdent -> + emitWarning "Anonymous sub-struct with single field is superfluous." + () + | [] <- decls -> + emitWarning + ( printf + "Empty sub-%s is superfluous." + ( case bodyType of + Union {} -> "union" + Struct {} -> "struct" + ) + ) + _ -> return () + +checkUnion :: Word32 -> Word32 -> b -> Commented SourceSpan -> Compile Stage3State (Word32, b) +checkUnion cursor subsize ret a = do + when (cursor /= 0 && subsize /= cursor) $ do + tell + [ Diagnostic + Warning + ( printf + "Jagged union found. Found size %d, expected %d.\n \ + \ Please wrap smaller fields in a struct with padding so all \ + \ fields are the same size?" + subsize + cursor + ) + (unCommented a) + ] + return (max cursor subsize, ret) registerBitsTypeRefToStage3 :: RegisterBitsTypeRef Stage2 I Annot -> @@ -191,8 +257,11 @@ registerBitsTypeRefToStage3 = \case <$> exprToSize expr objTypeBodyToStage3 :: - ObjTypeBody Stage2 I Annot -> Compile Stage3State (ObjTypeBody Stage3 I Annot) -objTypeBodyToStage3 (ObjTypeBody decls a) = do + ObjTypeBody Stage2 I Annot -> Word32 -> Compile Stage3State (ObjTypeBody Stage3 I Annot, Word32) +objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do + let isUnion = case bodyType of + Union {} -> True + _ -> False (cur, returned) <- foldlM ( \(cursor, returned) decl -> @@ -209,7 +278,7 @@ objTypeBodyToStage3 (ObjTypeBody decls a) = do s3RegisterBody a - declaredSizeBits <- exprToSize expr + declaredSizeBits <- fromIntegral <$> exprToSize expr when ((declaredSizeBits `mod` 8) /= 0) $ tell @@ -222,45 +291,108 @@ objTypeBodyToStage3 (ObjTypeBody decls a) = do forM_ mCalculatedSize $ \(fromIntegral -> calculatedSize) -> unless (calculatedSize == declaredSizeBits) $ let helpful = - if calculatedSize < declaredSizeBits then - printf "\nPerhaps you should add 'reserved(%d)' to the end of your register declaration?" - (declaredSizeBits - calculatedSize) - else "" - in - - tell - [ Diagnostic - Error - ( printf - "Calculated size %d does not match declared size %d.%s" - calculatedSize - declaredSizeBits - helpful - ) - (unCommented a) - ] - - return (cursor + declaredSizeBits `div` 8, s3 : returned) + if calculatedSize < declaredSizeBits + then + printf + "\nPerhaps you should add 'reserved(%d)' to the end of your register declaration?" + (declaredSizeBits - calculatedSize) + else "" + in tell + [ Diagnostic + Error + ( printf + "Calculated size %d does not match declared size %d.%s" + calculatedSize + declaredSizeBits + helpful + ) + (unCommented a) + ] + + if isUnion + then + checkUnion cursor (declaredSizeBits `div` 8) (s3 : returned) a + else + return (cursor + declaredSizeBits `div` 8, s3 : returned) + TypeSubStructure (Identity subBody) maybeIdent annot -> do + (newBody, size) <- + objTypeBodyToStage3 + subBody + ( if isUnion then startOff else cursor + ) + let s3 = TypeSubStructure (Identity newBody) maybeIdent annot + + checkTypesSubStructure subBody maybeIdent annot + if isUnion + then + checkUnion cursor size (s3 : returned) a + else + return (cursor + size, s3 : returned) + ReservedDecl expr annot -> do + size' <- fromIntegral <$> exprToSize expr + when ((size' `mod` 8) /= 0) $ + tell + [ Diagnostic + Error + "Can only reserve a multiple of 8 bits in this context." + (unCommented a) + ] + let size = size' `div` 8 + let s3 = ReservedDecl (expressionToStage3 expr) annot + if isUnion + then + checkUnion cursor size (s3 : returned) a + else + return (cursor + size, s3 : returned) AssertPosStatement expr a -> do - declaredPos <- exprToSize expr - when (cursor /= declaredPos) $ do + declaredPos <- fromIntegral <$> exprToSize expr + + let expectedPos = if isUnion then startOff else cursor + startOff + + when (expectedPos /= declaredPos) $ do tell [ Diagnostic Error ( printf "Position assertion failed. Asserted 0x%x, calculated 0x%x" declaredPos - cursor + expectedPos ) (unCommented a) ] return (cursor, returned) ) - (0 :: Integer, []) + (0, []) decls - return $ ObjTypeBody (reverse returned) a + return (ObjTypeBody bodyType (reverse returned) a, cur) where + checkTypesSubStructure + (ObjTypeBody bodyType decls _) + maybeIdent + annot = + let emitWarning s = tell [Diagnostic Warning s (unCommented annot)] + in case () of + () + | [_] <- decls, + (Union {}) <- bodyType -> + emitWarning "Union with a single field. Should this be a struct?" + () + | [_] <- decls, + (Struct {}) <- bodyType, + Nothing <- maybeIdent -> + emitWarning "Anonymous sub-struct with single field is superfluous." + () + | [] <- decls -> + emitWarning + ( printf + "Empty sub-%s is superfluous." + ( case bodyType of + Union {} -> "union" + Struct {} -> "struct" + ) + ) + _ -> return () fUnzip xs = (fst <$> xs, snd <$> xs) pushApply :: Maybe (a, b) -> (Maybe a, Maybe b) pushApply (Just (a, b)) = (Just a, Just b) |