diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/ConsistencyCheck.hs')
| -rw-r--r-- | src/Language/Fiddle/Compiler/ConsistencyCheck.hs | 839 |
1 files changed, 243 insertions, 596 deletions
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs index 3bdae4a..410f3e2 100644 --- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs +++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs @@ -2,636 +2,283 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UndecidableInstances #-} -module Language.Fiddle.Compiler.ConsistencyCheck - ( checkConsistency, - consistencyCheckPhase, - ) -where +module Language.Fiddle.Compiler.ConsistencyCheck (consistencyCheckPhase) where -import Control.Monad (forM_, unless, when) -import Control.Monad.RWS (MonadState (get, put), MonadWriter (tell), gets, modify') -import Data.Foldable (foldlM) +import Control.Monad (forM_, when) +import Control.Monad.RWS (MonadWriter (tell)) +import Control.Monad.Trans.Writer (Writer, execWriter) +import Data.Foldable (foldlM, toList) import Data.Functor.Identity -import Data.List (intercalate) -import Data.Maybe (mapMaybe) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Typeable import Data.Word (Word32) import GHC.TypeError as TypeError import Language.Fiddle.Ast import Language.Fiddle.Compiler -import Language.Fiddle.Internal.Scopes import Language.Fiddle.Internal.UnitInterface as UnitInterface -import Language.Fiddle.Types (Comment (DocComment), Commented (Commented, unCommented), SourceSpan) -import Prelude hiding (unzip) +import Language.Fiddle.Types import Text.Printf (printf) +import Prelude hiding (unzip) -import qualified Data.IntMap as IntMap -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Text as Text - -data GlobalState = GlobalState - { globalScope :: Scope String (Either SizeBits SizeBytes), - _fileDependencies :: [FilePath], - unitInterface :: UnitInterface - } - -newtype LocalState = LocalState (ScopePath String) - -type CurrentStage = Qualified - -type I = Identity - -type Annot = Commented SourceSpan +type S = Qualified -type SizeBits = Word32 +type S' = Checked -type SizeBytes = Word32 +type F = Identity -consistencyCheckPhase :: CompilationPhase CurrentStage Checked -consistencyCheckPhase = pureCompilationPhase checkConsistency +type A = Commented SourceSpan -checkConsistency :: - FiddleUnit CurrentStage I Annot -> - Compile () (FiddleUnit Checked I Annot) -checkConsistency = - fmap snd - . subCompile (GlobalState mempty mempty mempty) - . advanceStage (LocalState mempty) +type M = Compile () instance CompilationStage Checked where type StageAfter Checked = TypeError (TypeError.Text "No stage after Checked") - type StageMonad Checked = Compile GlobalState - type StageState Checked = LocalState + type StageMonad Checked = M + type StageState Checked = () type StageFunctor Checked = Identity - type StageAnnotation Checked = Commented SourceSpan - -instance CompilationStage CurrentStage where - type StageAfter CurrentStage = Checked - type StageMonad CurrentStage = Compile GlobalState - type StageState CurrentStage = LocalState - type StageFunctor CurrentStage = Identity - type StageAnnotation CurrentStage = Commented SourceSpan - -instance AdvanceStage CurrentStage FiddleUnit where - advanceStage localState (FiddleUnit _ decls a) = do - decls' <- mapM (advanceStage localState) decls - intf <- gets unitInterface - return $ FiddleUnit intf decls' a + type StageAnnotation Checked = A --- advanceStage localState (FiddleUnit decls _ annot) = do +instance CompilationStage S where + type StageAfter S = S' + type StageMonad S = M + type StageState S = () + type StageFunctor S = F + type StageAnnotation S = A --- decls' <- mapM (advanceStage localState) decls +consistencyCheckPhase :: CompilationPhase S S' +consistencyCheckPhase = pureCompilationPhase $ advanceStage () -deriving instance AdvanceStage CurrentStage Expression +instance AdvanceStage S ObjTypeBody where + advanceStage () objTypeBody = snd <$> advanceObjTypeBody objTypeBody 0 -deriving instance AdvanceStage CurrentStage ObjType +deriving instance AdvanceStage S DeferredRegisterBody -deriving instance AdvanceStage CurrentStage DeferredRegisterBody +deriving instance AdvanceStage S RegisterBody -deriving instance AdvanceStage CurrentStage RegisterBitsDecl +deriving instance AdvanceStage S AnonymousBitsType -deriving instance AdvanceStage CurrentStage RegisterBitsTypeRef +deriving instance AdvanceStage S ImportStatement -deriving instance AdvanceStage CurrentStage AnonymousBitsType +deriving instance AdvanceStage S BitType -deriving instance AdvanceStage CurrentStage BitType +deriving instance AdvanceStage S EnumBody -deriving instance AdvanceStage CurrentStage EnumBody +deriving instance AdvanceStage S EnumConstantDecl -deriving instance AdvanceStage CurrentStage EnumConstantDecl +deriving instance AdvanceStage S RegisterBitsDecl -deriving instance AdvanceStage CurrentStage PackageBody +deriving instance AdvanceStage S PackageBody -instance AdvanceStage CurrentStage ImportStatement where - modifyState - ( ImportStatement - { importInterface = - ( UnitInterface - { rootScope = unitScope, - dependencies = importDependencies - } - ) - } - ) - ls = do - modify' - ( \s@GlobalState - { globalScope = globalScope, - unitInterface = unitInterface - } -> - s - { globalScope = - unitInterfaceScopeToGlobalScope unitScope <> globalScope, - unitInterface = - unitInterface - { dependencies = - importDependencies ++ dependencies unitInterface - } - } - ) - return ls - where - unitInterfaceScopeToGlobalScope = - fmap - ( \(_, exportedValue) -> case exportedValue of - ExportedBitsType sz -> Left sz - ExportedObjType sz -> Right sz - ) - -deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t) - -instance AdvanceStage CurrentStage RegisterBody where - advanceStage s body = fst <$> registerBodyToStage3 s body - -instance AdvanceStage CurrentStage ObjTypeBody where - advanceStage s body = fst <$> objTypeBodyToStage3 s body 0 - -deriving instance AdvanceStage CurrentStage FiddleDecl - -instance AdvanceStage CurrentStage (Directed FiddleDecl) where - modifyState (Directed _ t _) s = case t of - (BitsDecl _ id typ annotation) -> do - typeSize <- getTypeSize typ - insertTypeSize annotation s id typeSize - return s - (PackageDecl _ n _ _) -> do - let strs = nameToList n - let (LocalState scopePath) = s - - return $ - LocalState $ - scopePath {currentScope = strs ++ currentScope scopePath} - (UsingDecl _ n _) -> - let (LocalState scopePath) = s - in return $ - LocalState $ - scopePath - { usingPaths = nameToList n : usingPaths scopePath - } - _ -> return s - - customAdvanceStage (Directed directives t a) (LocalState scopePath) = case t of - (ObjTypeDecl q ident (Identity body) annot) -> do - (body', size) <- objTypeBodyToStage3 (LocalState scopePath) body 0 - - let fullName = - NonEmpty.prependList - (currentScope scopePath) - (NonEmpty.singleton (Text.unpack (identifierName ident))) - - ui <- gets unitInterface - let ui' = insertIntoUnitInterface fullName ui annot (ExportedObjType size) - modify' $ \gs -> gs {unitInterface = ui'} - - return $ Just $ Directed directives (ObjTypeDecl q ident (Identity body') annot) a - _ -> return Nothing - -objTypeBodyToStage3 :: - LocalState -> - ObjTypeBody CurrentStage I Annot -> - Word32 -> - Compile GlobalState (ObjTypeBody Checked I Annot, Word32) -objTypeBodyToStage3 st (ObjTypeBody bodyType decls a) startOff = do - let isUnion = case bodyType of - Union {} -> True - _ -> False - (cur, returned) <- - foldlM - ( \(cursor, returned) decl -> - case undirected decl of - RegisterDecl mMod mIdent expr mBody a -> do - (s3RegisterBody, mCalculatedSize) <- - fUnzip <$> mapM (registerBodyToStage3 st) mBody - - nExpr <- advanceStage st expr - - let s3 = - mapDirected - ( const $ - RegisterDecl - mMod - mIdent - nExpr - s3RegisterBody - a - ) - decl - - declaredSizeBits <- fromIntegral <$> exprToSize expr - - when ((declaredSizeBits `mod` 8) /= 0) $ - tell - [ Diagnostic - Error - "Register size is not a multiple of 8. Please pad register size to align with 8. " - (unCommented a) - ] - - 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) - ] - - 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 - st - subBody - ( if isUnion then startOff else cursor - ) - let s3 = mapDirected (const $ TypeSubStructure (Identity newBody) maybeIdent annot) decl - - 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) - ] - - expr' <- advanceStage st expr - let size = size' `div` 8 - let s3 = mapDirected (const $ ReservedDecl expr' annot) decl - if isUnion - then - checkUnion cursor size (s3 : returned) a - else - return (cursor + size, s3 : returned) - AssertPosStatement _ expr a -> 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 - expectedPos - ) - (unCommented a) - ] - return (cursor, returned) - ) - (0, []) - decls +deriving instance AdvanceStage S FiddleDecl - 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) - -registerBodyToStage3 :: - LocalState -> - RegisterBody CurrentStage I Annot -> - Compile GlobalState (RegisterBody Checked I Annot, Word32) -registerBodyToStage3 - st - (RegisterBody bodyType (Identity deferredRegisterBody) a') = do - let isUnion = case bodyType of - Union {} -> True - _ -> False - - case deferredRegisterBody of - DeferredRegisterBody decls a -> do - (cur, returned) <- - foldlM - ( \(cursor, returned) decl -> - case undirected decl of - ReservedBits expr a -> do - size <- fromIntegral <$> exprToSize expr - expr' <- advanceStage st expr - let s3 = - mapDirected - (const $ ReservedBits expr' a) - decl - 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 st registerBody - let s3 = - mapDirected - (const $ BitsSubStructure newBody maybeIdent annot) - decl - - if isUnion - then checkUnion cursor subsize (s3 : returned) a - else - return (cursor + subsize, s3 : returned) - DefinedBits modifier identifier typeref a -> do - (s3TypeRef, size) <- registerBitsTypeRefToStage3 st typeref - let s3 = - mapDirected - (const $ DefinedBits modifier identifier s3TypeRef a) - decl - - if isUnion - then checkUnion cursor size (s3 : returned) a - else - return (cursor + size, s3 : returned) - ) - (0, []) - decls - - return - ( RegisterBody - bodyType - (Identity (DeferredRegisterBody (reverse returned) a)) - a', - cur - ) +instance AdvanceStage S FiddleUnit where + advanceStage () fu@(FiddleUnit _ decls a) = + FiddleUnit (getUnitInterface fu) <$> mapM (advanceStage ()) decls <*> pure a 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 () - -registerBitsTypeRefToStage3 :: - LocalState -> - RegisterBitsTypeRef CurrentStage I Annot -> - Compile GlobalState (RegisterBitsTypeRef Checked I Annot, Word32) -registerBitsTypeRefToStage3 localState = \case - RegisterBitsArray ref expr a -> do - (ref', size) <- registerBitsTypeRefToStage3 localState ref - multiplier <- exprToSize expr - expr' <- advanceStage localState expr - return - ( RegisterBitsArray ref' expr' a, - size * fromIntegral multiplier - ) - RegisterBitsReference q name a -> - (RegisterBitsReference q name a,) <$> lookupTypeSize localState name - RegisterBitsJustBits expr a -> do - expr' <- advanceStage localState expr - (RegisterBitsJustBits expr' a,) - . fromIntegral - <$> exprToSize expr - -checkUnion :: Word32 -> Word32 -> b -> Commented SourceSpan -> Compile s (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) - -exprToSize :: - (NumberType stage ~ Integer) => - Expression stage I Annot -> - Compile s Integer -exprToSize (LitNum num _) = return num -exprToSize e = do - tell [Diagnostic Error "Variables not allowed" (unCommented $ annot e)] - compilationFailure - -lookupTypeSize :: LocalState -> Name I Annot -> Compile GlobalState SizeBits -lookupTypeSize (LocalState scopePath) (Name idents a) = do - -- Convert the list of identifiers to a string path - let path = fmap (\(Identifier s _) -> Text.unpack s) idents - - -- Get the current scope and perform the lookup - results <- gets $ lookupScopeWithPath scopePath path . globalScope - - case results of - -- Successfully resolved to a unique size - [(_, Left sz)] -> return sz - -- Multiple ambiguous results found - matches@(_ : _ : _) -> do - -- Generate a list of ambiguous paths for error reporting - let ambiguousPaths = - map - ( \(resolvedPath, _) -> - intercalate "." (NonEmpty.toList resolvedPath) - ) - matches - tell - [ Diagnostic - Error - ( printf - "Ambiguous occurrence of '%s'. Multiple matches found:\n%s" - (intercalate "." $ NonEmpty.toList path) - (unlines ambiguousPaths) -- List all ambiguous paths - ) - (unCommented a) - ] - compilationFailure - - -- No matches found - [] -> do - tell - [ Diagnostic - Error - ( printf - "Cannot resolve '%s'. No matching symbols found." - (intercalate "." $ NonEmpty.toList path) - ) - (unCommented a) - ] - compilationFailure - _ -> compilationFailure - -getTypeSize :: BitType CurrentStage I Annot -> Compile s SizeBits -getTypeSize (RawBits expr _) = fromIntegral <$> exprToSize expr -getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do - declaredSize <- fromIntegral <$> exprToSize expr - - -- If the declared size is less than or equal to 4, we'll enforce that the - -- enum is packed. This is to make sure the user has covered all bases. - when (declaredSize <= 4) $ do - imap <- + getUnitInterface = execWriter . walk_ doWalk + + doWalk :: forall t'. (Walk t', Typeable t') => t' F A -> Writer UnitInterface () + doWalk t = + case () of + () + | (Just (PackageDecl {packageQualificationMetadata = (Identity d)})) <- + castTS t -> + tell (UnitInterface.singleton d) + | (Just (LocationDecl {locationQualificationMetadata = (Identity d)})) <- + castTS t -> + tell (UnitInterface.singleton d) + | (Just (BitsDecl {bitsQualificationMetadata = (Identity d)})) <- + castTS t -> + tell (UnitInterface.singleton d) + | (Just (ObjTypeDecl {objTypeQualificationMetadata = (Identity d)})) <- + castTS t -> + tell (UnitInterface.singleton d) + | (Just (ObjectDecl {objectQualificationMetadata = (Identity d)})) <- + castTS t -> + tell (UnitInterface.singleton d) + | (Just (ImportStatement {importInterface = ii})) <- + castTS t -> + tell (UnitInterface mempty (dependencies ii)) + _ -> return () + + castTS :: + (Typeable t', Typeable t, Typeable f, Typeable a) => + t' f a -> + Maybe (t S f a) + castTS = cast + +deriving instance AdvanceStage S Expression + +deriving instance AdvanceStage S RegisterBitsTypeRef + +deriving instance AdvanceStage S ObjType + +deriving instance (AdvanceStage S t) => AdvanceStage S (Directed t) + +advanceObjTypeBody :: ObjTypeBody S F A -> Word32 -> M (Word32, ObjTypeBody S' F A) +advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do + (decls', _) <- advanceDecls + + calcSize <- case us of + Union {} -> do + checkJagged decls' + return $ maximum (map fst decls') + Struct {} -> return $ sum (map fst decls') + + return (calcSize, ObjTypeBody us (reverse $ map snd decls') a) + where + advanceDecls :: M ([(Word32, Directed ObjTypeDecl S' F A)], Word32) + advanceDecls = do foldlM - ( \imap (undirected -> enumConst) -> do - number <- case enumConst of - EnumConstantDecl _ expr _ -> exprToSize expr - EnumConstantReserved expr _ -> exprToSize expr - - when (number >= 2 ^ declaredSize) $ - tell - [ Diagnostic - Error - ( printf - "Enum constant too large. Max allowed %d\n" - ((2 :: Int) ^ declaredSize) - ) - (unCommented (annot enumConst)) - ] - - return $ IntMap.insert (fromIntegral number) True imap + ( \(ret, offset) d -> + let advanceOffset = case us of + Union {} -> const + Struct {} -> (+) + doReturn x size = return ((size, mapDirected (const x) d) : ret, advanceOffset offset size) + in case undirected d of + e@AssertPosStatement {assertExpr = expr} -> do + assertedPos <- expressionToIntM expr + checkPositionAssertion (annot e) assertedPos offset + return (ret, offset) + (RegisterDecl mod ident size Nothing a) -> do + (sizeExpr, reifiedSize) <- advanceAndGetSize size + doReturn (RegisterDecl 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 mod ident sizeExpr (Just body') a) + =<< checkBitsSizeMod8 a reifiedSize + (ReservedDecl size a) -> do + (sizeExpr, reifiedSize) <- advanceAndGetSize size + doReturn (ReservedDecl sizeExpr a) reifiedSize + (TypeSubStructure (Identity body) name a) -> do + (size, body') <- advanceObjTypeBody body offset + doReturn (TypeSubStructure (Identity body') name a) size ) - IntMap.empty - constants - let missing = - filter (not . (`IntMap.member` imap)) [0 .. 2 ^ declaredSize - 1] - unless (null missing) $ - tell - [ Diagnostic - Warning - ( printf - "Missing enum constants %s. Small enums should be fully \ - \ populated. Use 'reserved' if needed." - (intercalate ", " (map show missing)) - ) - (unCommented ann) - ] - - return declaredSize - -diagnosticError :: String -> Annot -> Compile a () -diagnosticError str a = tell [Diagnostic Error str (unCommented a)] - -insertIntoUnitInterface :: - NonEmpty.NonEmpty String -> - UnitInterface -> - Commented SourceSpan -> - ExportedValue -> - UnitInterface -insertIntoUnitInterface path ui (Commented comments srcspan) val = - let docComments = - mconcat - ( mapMaybe - ( \com -> do - (DocComment txt) <- Just com - return txt - ) - comments + (([], startOffset) :: ([(Word32, Directed ObjTypeDecl S' F A)], Word32)) + decls + + advanceAndGetSize e = (,) <$> advanceStage () e <*> expressionToIntM e + +pattern RegisterBodyPattern :: BodyType F A -> [Directed RegisterBitsDecl s F A] -> A -> A -> RegisterBody s F A +pattern RegisterBodyPattern u decls a b = RegisterBody u (Identity (DeferredRegisterBody decls b)) a + +-- registerBodyPattern u decls a b = RegisterBody u (Identity (DeferredRegisterBody decls a)) a + +advanceRegisterBody :: RegisterBody S F A -> M (Word32, RegisterBody S' F A) +-- Handle the case where it's a union. +advanceRegisterBody + (RegisterBodyPattern us (NonEmpty.nonEmpty -> Just decls) a b) = do + decls' <- + mapM + ( \d -> do + (sz, t) <- advanceDecl (undirected d) + return (sz, mapDirected (const t) d) + ) + decls + calcSize <- case us of + Union {} -> do + checkJagged (toList decls') + return $ maximum (map fst (toList decls')) + Struct {} -> do + return $ sum (map fst (toList decls')) + + return (calcSize, RegisterBodyPattern us (map snd $ toList decls') a b) + +-- Handle the case where there's no decls. +advanceRegisterBody (RegisterBodyPattern u _ a b) = + return (0, RegisterBodyPattern u [] a b) +advanceRegisterBody RegisterBody {} = error "GHC not smart enuf" + +checkJagged :: (Annotated t) => [(Word32, t f A)] -> Compile s () +checkJagged decls = do + let expectedSize = maximum (fmap fst decls) + forM_ decls $ \(sz, annot -> a) -> + when (sz /= expectedSize) $ + emitDiagnosticWarning + ( printf + "[JaggedUnion] - All elements of a union should be the same size. \ + \ this element is size %d, expected size %d. Maybe bundle this with \ + \ reserved(%d)?" + sz + expectedSize + (expectedSize - sz) + ) + a + +advanceDecl :: RegisterBitsDecl S F A -> M (Word32, RegisterBitsDecl S' F A) +advanceDecl = \case + ReservedBits expr an -> do + sz <- expressionToIntM expr + (sz,) + <$> ( ReservedBits + <$> advanceStage () expr + <*> pure an ) - in ui - { rootScope = - insertScope - path - ( Metadata srcspan docComments [], - val - ) - (rootScope ui) - } - -insertTypeSize :: - Annot -> - LocalState -> - Identifier f Annot -> - SizeBits -> - Compile GlobalState () -insertTypeSize annot (LocalState scopePath) (Identifier s idannot) size = do - modifyM $ - \state@GlobalState - { globalScope = globalScope, - unitInterface = unitInterface - } -> - let fullName = - NonEmpty.prependList - (currentScope scopePath) - (NonEmpty.singleton (Text.unpack s)) - in case upsertScope fullName (Left size) globalScope of - (Just _, _) -> do - diagnosticError (printf "Duplicate type %s" s) idannot - - compilationFailure - (Nothing, n) -> - let unitInterface' = - insertIntoUnitInterface - fullName - unitInterface - annot - (ExportedBitsType size) - in return $ - state - { globalScope = n, - unitInterface = unitInterface' - } - where - modifyM fn = do - s <- get - put =<< fn s + DefinedBits mod ident typ annot -> do + size <- bitsTypeSize typ + (size,) + <$> (DefinedBits mod ident <$> advanceStage () typ <*> pure annot) + BitsSubStructure subBody subName ann -> do + (sz, body') <- advanceRegisterBody subBody + return (sz, BitsSubStructure body' subName ann) + +bitsTypeSize :: RegisterBitsTypeRef S F A -> M Word32 +bitsTypeSize (RegisterBitsArray tr nExpr _) = do + sz <- bitsTypeSize tr + n <- expressionToIntM nExpr + return (sz * n) +bitsTypeSize + RegisterBitsReference + { bitsRefQualificationMetadata = + Identity (ExportedBitsDecl {exportedBitsDeclSizeBits = sz}) + } = return sz +bitsTypeSize (RegisterBitsJustBits expr _) = + expressionToIntM expr + +checkSizeMismatch :: A -> Word32 -> Word32 -> Compile s () +checkSizeMismatch _ a b | a == b = return () +checkSizeMismatch pos declaredSize calculatedSize = + emitDiagnosticError + ( printf + "Size assertion failed. Declared size %d, calculated %d" + declaredSize + calculatedSize + ) + pos + +checkPositionAssertion :: A -> Word32 -> Word32 -> Compile s () +checkPositionAssertion _ a b | a == b = return () +checkPositionAssertion pos declaredPosition calculatedPostion = + emitDiagnosticError + ( printf + "Position assertion failed. Asserted 0x%x, calculated 0x%x" + declaredPosition + calculatedPostion + ) + pos + +expressionToIntM :: + (Integral i, Integral (NumberType stage)) => + Expression stage f A -> + Compile s i +expressionToIntM expr = + resolveOrFail $ + either + ( \reason -> Left [Diagnostic Error reason (unCommented $ annot expr)] + ) + return + (expressionToInt expr) + +checkBitsSizeMod8 :: A -> Word32 -> M Word32 +checkBitsSizeMod8 _ w | w `mod` 8 == 0 = return (w `div` 8) +checkBitsSizeMod8 a w = do + emitDiagnosticWarning + (printf "Register size %d is not a multiple of 8. Please add padding to this register." w) + a + return ((w `div` 8) + 1) |