diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler')
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage0.hs | 2 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage1.hs | 49 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage2.hs | 286 |
3 files changed, 304 insertions, 33 deletions
diff --git a/src/Language/Fiddle/Compiler/Stage0.hs b/src/Language/Fiddle/Compiler/Stage0.hs index 77c396e..fbc554b 100644 --- a/src/Language/Fiddle/Compiler/Stage0.hs +++ b/src/Language/Fiddle/Compiler/Stage0.hs @@ -55,7 +55,7 @@ parseErrorToDiagnostic pe = "unknown" "expecting" "unexpected" - "end of body or input (maybe a missing semicolon?)" + "end of body or input (maybe a missing semicolon or comma?)" (errorMessages pe) ) (SourceSpan (errorPos pe) (errorPos pe)) diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs index 7a048fa..3a97757 100644 --- a/src/Language/Fiddle/Compiler/Stage1.hs +++ b/src/Language/Fiddle/Compiler/Stage1.hs @@ -41,18 +41,9 @@ data Stage2CompilerState a -- Anonymous enum bodies that need to be re-linked ![(Linkage, AnonymousBitsType Stage2 I a)] -class EasyStage2 t where - toS2 :: t s1 I a -> t s2 I a - -instance EasyStage2 Identifier where - toS2 (Identifier t a) = Identifier t a - -instance EasyStage2 Modifier where - toS2 (ModifierKeyword keyword annot) = ModifierKeyword keyword annot - type M a = Compile (Stage2CompilerState a) -internObjType :: Path -> ObjTypeBody Stage2 I a -> M a (Identifier Stage2 I a) +internObjType :: Path -> ObjTypeBody Stage2 I a -> M a (Identifier I a) internObjType path body = let str = Text.pack $ joinPath path in do @@ -60,7 +51,7 @@ internObjType path body = Stage2CompilerState ((Linkage str, body) : objTypeBodies) a return (Identifier str (annot body)) -internAnonymousBitsType :: Path -> AnonymousBitsType Stage2 I a -> M a (Identifier Stage2 I a) +internAnonymousBitsType :: Path -> AnonymousBitsType Stage2 I a -> M a (Identifier I a) internAnonymousBitsType path anonymousBitsType = let str = Text.pack $ joinPath path in do @@ -68,12 +59,6 @@ internAnonymousBitsType path anonymousBitsType = Stage2CompilerState a ((Linkage str, anonymousBitsType) : anonymousBitsTypes) return (Identifier str (annot anonymousBitsType)) -traceState :: M a () -traceState = do - (Stage2CompilerState anonymousObjTypes anonymousBitsTypes) <- get - traceM $ printf "objtypes': %s\n" (show $ map fst anonymousObjTypes) - traceM $ printf "bittypes': %s\n" (show $ map fst anonymousBitsTypes) - -- The second stage is a simplified version of the AST without anonymous -- declarations. toStage2 :: FiddleUnit Stage1 I Annot -> Compile () (FiddleUnit Stage2 I Annot) @@ -106,21 +91,21 @@ reconfigureFiddleDecls p decls = do resolveAnonymousBitsType (Linkage linkage, AnonymousEnumBody expr body a) = BitsDecl (Identifier linkage a) (EnumBitType expr body a) a -pushId :: Identifier stage f a -> Path -> Path +pushId :: Identifier f a -> Path -> Path pushId (Identifier str _) (Path lst) = Path (PathExpression (Text.unpack str) : lst) fiddleDeclToStage2 :: Path -> FiddleDecl Stage1 I Annot -> M Annot (FiddleDecl Stage2 I Annot) fiddleDeclToStage2 path decl = do case decl of - (OptionDecl i1 i2 a) -> return $ OptionDecl (toS2 i1) (toS2 i2) a + (OptionDecl i1 i2 a) -> return $ OptionDecl i1 i2 a (PackageDecl i (Identity body) a) -> do - (PackageDecl (toS2 i) . Identity <$> packageBodyToStage2 (pushId i path) body) <*> pure a - (LocationDecl i expr a) -> LocationDecl (toS2 i) <$> toStage2Expr expr <*> pure a - (BitsDecl i typ a) -> BitsDecl (toS2 i) <$> bitsTypeToStage2 (pushId i path) typ <*> pure a - (ObjTypeDecl i body a) -> ObjTypeDecl (toS2 i) <$> mapM (objTypeBodyToStage2 (pushId i path)) body <*> pure a + (PackageDecl i . Identity <$> packageBodyToStage2 (pushId i path) body) <*> pure a + (LocationDecl i expr a) -> LocationDecl i <$> toStage2Expr expr <*> pure a + (BitsDecl i typ a) -> BitsDecl i <$> bitsTypeToStage2 (pushId i path) typ <*> pure a + (ObjTypeDecl i body a) -> ObjTypeDecl i <$> mapM (objTypeBodyToStage2 (pushId i path)) body <*> pure a (ObjectDecl i expr typ a) -> - ObjectDecl (toS2 i) <$> toStage2Expr expr <*> objectTypeToStage2 (pushId i path) typ <*> pure a + ObjectDecl i <$> toStage2Expr expr <*> objectTypeToStage2 (pushId i path) typ <*> pure a bitsTypeToStage2 :: Path -> BitType Stage1 I Annot -> M Annot (BitType Stage2 I Annot) bitsTypeToStage2 path = \case @@ -134,7 +119,7 @@ enumBodyToStage2 path = \case enumConstantToStage2 :: Path -> EnumConstantDecl Stage1 I Annot -> M Annot (EnumConstantDecl Stage2 I Annot) enumConstantToStage2 path = \case - EnumConstantDecl i e a -> EnumConstantDecl (toS2 i) <$> toStage2Expr e <*> pure a + EnumConstantDecl i e a -> EnumConstantDecl i <$> toStage2Expr e <*> pure a EnumConstantReserved e a -> EnumConstantReserved <$> toStage2Expr e <*> pure a objTypeBodyToStage2 :: Path -> ObjTypeBody Stage1 I Annot -> M Annot (ObjTypeBody Stage2 I Annot) @@ -146,8 +131,8 @@ objTypeDeclToStage2 path = \case (RegisterDecl maybeModifier maybeIdentifier expression maybeBody annot) -> let path' = maybe path (`pushId` path) maybeIdentifier in RegisterDecl - (fmap toS2 maybeModifier) - (fmap toS2 maybeIdentifier) + maybeModifier + maybeIdentifier <$> toStage2Expr expression <*> mapM (registerBodyToStage2 path') maybeBody <*> pure annot @@ -167,8 +152,8 @@ registerBitsDeclToStage2 path = \case DefinedBits maybeModifier identifier registerBitsTyperef annot -> let path' = pushId identifier path in ( DefinedBits - (fmap toS2 maybeModifier) - (toS2 identifier) + maybeModifier + identifier <$> registerBitsTypeRefToStage2 path' registerBitsTyperef <*> pure annot ) @@ -180,7 +165,7 @@ registerBitsTypeRefToStage2 path = \case <$> registerBitsTypeRefToStage2 path typeref <*> toStage2Expr expr <*> pure annot - RegisterBitsReference ident annot -> return (RegisterBitsReference (toS2 ident) annot) + RegisterBitsReference ident annot -> return (RegisterBitsReference ident annot) RegisterBitsJustBits expr annot -> RegisterBitsJustBits <$> toStage2Expr expr <*> pure annot RegisterBitsAnonymousType anonType annot -> do ident <- internAnonymousBitsType path =<< anonymousBitsTypeToStage2 path anonType @@ -200,7 +185,7 @@ objectTypeToStage2 path = \case body' <- objTypeBodyToStage2 path body identifier <- internObjType path body' return (ReferencedObjType identifier annot) - (ReferencedObjType ident annot) -> return $ ReferencedObjType (toS2 ident) annot + (ReferencedObjType ident annot) -> return $ ReferencedObjType ident annot (ArrayObjType objType expr a) -> ArrayObjType <$> objectTypeToStage2 path objType <*> toStage2Expr expr <*> pure a @@ -210,7 +195,7 @@ packageBodyToStage2 p (PackageBody decls a) = toStage2Expr :: Expression Stage1 I Annot -> M Annot (Expression Stage2 I Annot) toStage2Expr = \case - (Var i a) -> return $ Var (toS2 i) a + (Var i a) -> return $ Var i a (LitNum t a) -> LitNum <$> parseNum (unCommented a) t <*> pure a parseNum :: SourceSpan -> Text -> M a Integer diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/Stage2.hs new file mode 100644 index 0000000..baa61e3 --- /dev/null +++ b/src/Language/Fiddle/Compiler/Stage2.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- Stage3 doesn't change much from Stage2. Stage3 primarily removes the assert +-- statements and checks that they are consistent with the calculations. +module Language.Fiddle.Compiler.Stage2 where + +import Control.Monad (forM_, unless, when) +import Control.Monad.RWS (MonadWriter (tell), gets, modify') +import Data.Foldable (foldlM) +import Data.Functor.Identity +import qualified Data.IntMap as IntMap +import Data.Kind (Type) +import Data.List (intercalate) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Word +import Language.Fiddle.Ast +import Language.Fiddle.Compiler +import Language.Fiddle.Types (Commented (unCommented), SourceSpan) +import Text.Printf (printf) +import Prelude hiding (unzip) + +type I = Identity + +type Annot = Commented SourceSpan + +type SizeBits = Word32 + +type SizeBytes = Word32 + +data Stage3State = Stage3State + { typeSizes :: Map String SizeBits, + objectSizes :: Map String SizeBytes, + cursorBytes :: Word32, + cursorBits :: Word32 + } + +addTypeSize :: Identifier f a -> SizeBits -> Compile Stage3State () +addTypeSize (Identifier s _) size = do + modify' $ + \stage3State -> + stage3State {typeSizes = Map.insert (Text.unpack s) size (typeSizes stage3State)} + +lookupTypeSize :: Identifier I Annot -> Compile Stage3State SizeBits +lookupTypeSize (Identifier s a) = do + mSize <- gets $ Map.lookup (Text.unpack s) . typeSizes + case mSize of + Just sz -> return sz + Nothing -> do + tell + [ Diagnostic + Error + (printf "%s is not declared" s) + (unCommented a) + ] + compilationFailure + +expressionToStage3 :: Expression Stage2 f Annot -> Expression Stage3 f Annot +expressionToStage3 = \case + LitNum n a -> LitNum n a + Var i a -> Var i a + +emptyState = Stage3State mempty mempty 0 0 + +toStage3 :: FiddleUnit Stage2 I Annot -> Compile () (FiddleUnit Stage3 I Annot) +toStage3 (FiddleUnit decls a) = + snd + <$> subCompile + emptyState + ( FiddleUnit <$> mapM fiddleDeclToStage3 decls <*> pure a + ) + +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 + +getTypeSize :: BitType Stage2 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 <- + foldlM + ( \imap 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 + ) + 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. Please fully pack a small enum.\ + \ Use 'reserved' if needed." + (intercalate ", " (map show missing)) + ) + (unCommented ann) + ] + + return declaredSize + +fiddleDeclToStage3 :: FiddleDecl Stage2 I Annot -> Compile Stage3State (FiddleDecl Stage3 I Annot) +fiddleDeclToStage3 = \case + OptionDecl i1 i2 a -> return $ OptionDecl i1 i2 a + PackageDecl id body a -> PackageDecl id <$> mapM packageBodyToStage3 body <*> pure a + LocationDecl id expr a -> return $ LocationDecl id (expressionToStage3 expr) a + BitsDecl id typ a -> do + typeSize <- getTypeSize typ + addTypeSize id typeSize + BitsDecl id <$> bitTypeToStage3 typ <*> pure a + ObjTypeDecl ident body a -> + ObjTypeDecl ident <$> mapM objTypeBodyToStage3 body <*> pure a + ObjectDecl ident expr typ a -> + ObjectDecl ident (expressionToStage3 expr) <$> objTypeToStage3 typ <*> pure a + +objTypeToStage3 :: ObjType Stage2 I Annot -> Compile Stage3State (ObjType Stage3 I Annot) +objTypeToStage3 = \case + ArrayObjType objtype expr a -> + ArrayObjType + <$> objTypeToStage3 objtype + <*> pure (expressionToStage3 expr) + <*> pure a + ReferencedObjType ident a -> return $ ReferencedObjType ident a + +registerBodyToStage3 :: + RegisterBody Stage2 I Annot -> + Compile Stage3State (RegisterBody Stage3 I Annot, Word32) +registerBodyToStage3 (RegisterBody (Identity deferredRegisterBody) a') = + case deferredRegisterBody of + DeferredRegisterBody decls a -> do + (cur, returned) <- + foldlM + ( \(cursor, returned) decl -> + case decl of + ReservedBits expr a -> do + size <- exprToSize expr + let s3 = ReservedBits (expressionToStage3 expr) a + return (cursor + fromIntegral size, s3 : returned) + DefinedBits modifier identifier typeref a -> do + (s3TypeRef, size) <- registerBitsTypeRefToStage3 typeref + return (cursor + size, DefinedBits modifier identifier s3TypeRef a : returned) + ) + (0, []) + decls + + return (RegisterBody (Identity (DeferredRegisterBody (reverse returned) a)) a', cur) + +registerBitsTypeRefToStage3 :: + RegisterBitsTypeRef Stage2 I Annot -> + Compile Stage3State (RegisterBitsTypeRef Stage3 I Annot, Word32) +registerBitsTypeRefToStage3 = \case + RegisterBitsArray ref expr a -> do + (ref', size) <- registerBitsTypeRefToStage3 ref + multiplier <- exprToSize expr + return + ( RegisterBitsArray ref' (expressionToStage3 expr) a, + size * fromIntegral multiplier + ) + RegisterBitsReference ident a -> + (RegisterBitsReference ident a,) <$> lookupTypeSize ident + RegisterBitsJustBits expr a -> + (RegisterBitsJustBits (expressionToStage3 expr) a,) + . fromIntegral + <$> exprToSize expr + +objTypeBodyToStage3 :: + ObjTypeBody Stage2 I Annot -> Compile Stage3State (ObjTypeBody Stage3 I Annot) +objTypeBodyToStage3 (ObjTypeBody decls a) = do + (cur, returned) <- + foldlM + ( \(cursor, returned) decl -> + case decl of + RegisterDecl mMod mIdent expr mBody a -> do + (s3RegisterBody, mCalculatedSize) <- + fUnzip <$> mapM registerBodyToStage3 mBody + + let s3 = + RegisterDecl + mMod + mIdent + (expressionToStage3 expr) + s3RegisterBody + a + + declaredSizeBits <- 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) + ] + + return (cursor + declaredSizeBits `div` 8, s3 : returned) + AssertPosStatement expr a -> do + declaredPos <- exprToSize expr + when (cursor /= declaredPos) $ do + tell + [ Diagnostic + Error + ( printf + "Position assertion failed. Asserted 0x%x, calculated 0x%x" + declaredPos + cursor + ) + (unCommented a) + ] + return (cursor, returned) + ) + (0 :: Integer, []) + decls + + return $ ObjTypeBody (reverse returned) a + where + fUnzip xs = (fst <$> xs, snd <$> xs) + pushApply :: Maybe (a, b) -> (Maybe a, Maybe b) + pushApply (Just (a, b)) = (Just a, Just b) + pushApply Nothing = (Nothing, Nothing) + +bitTypeToStage3 :: BitType Stage2 I Annot -> Compile Stage3State (BitType Stage3 I Annot) +bitTypeToStage3 (EnumBitType expr body a) = + EnumBitType (expressionToStage3 expr) + <$> mapM enumBodyToStage3 body + <*> pure a + +enumBodyToStage3 :: EnumBody Stage2 I Annot -> Compile Stage3State (EnumBody Stage3 I Annot) +enumBodyToStage3 (EnumBody constants a) = + EnumBody <$> mapM enumConstantDeclToStage3 constants <*> pure a + +enumConstantDeclToStage3 :: EnumConstantDecl Stage2 I Annot -> Compile Stage3State (EnumConstantDecl Stage3 I Annot) +enumConstantDeclToStage3 = \case + EnumConstantDecl ident expr a -> return $ EnumConstantDecl ident (expressionToStage3 expr) a + EnumConstantReserved expr a -> return $ EnumConstantReserved (expressionToStage3 expr) a + +packageBodyToStage3 :: PackageBody Stage2 I Annot -> Compile Stage3State (PackageBody Stage3 I Annot) +packageBodyToStage3 (PackageBody decls a) = + PackageBody <$> mapM fiddleDeclToStage3 decls <*> pure a |