diff options
author | Josh Rahm <joshuarahm@gmail.com> | 2024-09-20 10:43:43 -0600 |
---|---|---|
committer | Josh Rahm <joshuarahm@gmail.com> | 2024-09-20 10:43:43 -0600 |
commit | f0c4da33e9576d2509b8c6330b1663e044e2dff3 (patch) | |
tree | 15120a7b0ca3795fc7b35478f708d54c1c988ec5 /src | |
parent | f1128c7c60809d1e96009eaed98c0756831fe29f (diff) | |
download | fiddle-f0c4da33e9576d2509b8c6330b1663e044e2dff3.tar.gz fiddle-f0c4da33e9576d2509b8c6330b1663e044e2dff3.tar.bz2 fiddle-f0c4da33e9576d2509b8c6330b1663e044e2dff3.zip |
Some major changes to the structure of the language.
Added structures and unions to better define the layout and model
overlapping concerns.
renamed objtype -> type and object -> instance.
added reserved statements for types.
Diffstat (limited to 'src')
-rw-r--r-- | src/Language/Fiddle/Ast.hs | 35 | ||||
-rw-r--r-- | src/Language/Fiddle/Compiler/Stage1.hs | 18 | ||||
-rw-r--r-- | src/Language/Fiddle/Compiler/Stage2.hs | 202 | ||||
-rw-r--r-- | src/Language/Fiddle/GenericTree.hs | 16 | ||||
-rw-r--r-- | src/Language/Fiddle/Parser.hs | 51 | ||||
-rw-r--r-- | src/Language/Fiddle/Tokenizer.hs | 22 |
6 files changed, 284 insertions, 60 deletions
diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs index d440a44..8352975 100644 --- a/src/Language/Fiddle/Ast.hs +++ b/src/Language/Fiddle/Ast.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -5,7 +6,6 @@ {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ConstraintKinds #-} module Language.Fiddle.Ast where @@ -18,6 +18,8 @@ import Data.Typeable import GHC.Generics import GHC.TypeLits +-- The type of a number at each stage in compilation. Numbers should be parsed +-- in Stage2. type family NumberType (a :: Stage) where NumberType Stage1 = Text NumberType Stage2 = Integer @@ -88,7 +90,7 @@ data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where deriving (Generic, Annotated, Alter, Typeable) data ObjTypeBody (stage :: Stage) (f :: Type -> Type) a where - ObjTypeBody :: [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a + ObjTypeBody :: BodyType f a -> [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a deriving (Generic, Annotated, Alter, Typeable) data ObjType stage f a where @@ -119,6 +121,14 @@ data ObjTypeDecl stage f a where Maybe (RegisterBody stage f a) -> a -> ObjTypeDecl stage f a + {- reserved(n); -} + ReservedDecl :: Expression stage f a -> a -> ObjTypeDecl stage f a + {- <struct|union> { subfields } <name>; -} + TypeSubStructure :: + f (ObjTypeBody stage f a) -> + Maybe (Identifier f a) -> + a -> + ObjTypeDecl stage f a deriving (Typeable) data Modifier f a where @@ -134,8 +144,13 @@ data DeferredRegisterBody stage f a where DeferredRegisterBody stage f a deriving (Generic, Annotated, Alter, Typeable) +data BodyType (f :: Type -> Type) a where + Union :: a -> BodyType f a + Struct :: a -> BodyType f a + deriving (Generic, Annotated, Alter, Typeable) + data RegisterBody stage f a where - RegisterBody :: f (DeferredRegisterBody stage f a) -> a -> RegisterBody stage f a + RegisterBody :: BodyType f a -> f (DeferredRegisterBody stage f a) -> a -> RegisterBody stage f a deriving (Generic, Annotated, Alter, Typeable) data RegisterBitsDecl stage f a where @@ -148,6 +163,11 @@ data RegisterBitsDecl stage f a where RegisterBitsTypeRef stage f a -> a -> RegisterBitsDecl stage f a + BitsSubStructure :: + RegisterBody stage f a -> + Maybe (Identifier f a) -> + a -> + RegisterBitsDecl stage f a deriving (Generic, Annotated, Alter, Typeable) data RegisterBitsTypeRef stage f a where @@ -195,6 +215,15 @@ instance Alter (ObjTypeDecl stage) where <*> alter ffn fn expr <*> mapM (alter ffn fn) mBody <*> fn a + (TypeSubStructure mBody mIdent a) -> + TypeSubStructure + <$> (ffn =<< mapM (alter ffn fn) mBody) + <*> mapM (alter ffn fn) mIdent + <*> fn a + (ReservedDecl expr a) -> + ReservedDecl + <$> alter ffn fn expr + <*> fn a instance Annotated (ObjTypeDecl stage) where annot = \case 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) diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs index 668c290..00824ed 100644 --- a/src/Language/Fiddle/GenericTree.hs +++ b/src/Language/Fiddle/GenericTree.hs @@ -174,6 +174,8 @@ instance (GToGenericSyntaxTree r f a) => (GToGenericSyntaxTree (M1 i c r) f a) w deriving instance (ToGenericSyntaxTree Identifier) +deriving instance (ToGenericSyntaxTree BodyType) + deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleUnit stage)) deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleDecl stage)) @@ -206,6 +208,20 @@ instance (Context stage) => (ToGenericSyntaxTree (ObjTypeDecl stage)) where toGenericSyntaxTree t = case t of (AssertPosStatement expr a) -> SyntaxTreeObject "AssertPosStatement" [toGenericSyntaxTree expr] a t + (TypeSubStructure body mIdent a) -> + SyntaxTreeObject + "TypeSubStructure" + ( Data.Foldable.toList (toGenericSyntaxTree <$> body) + ++ Data.Foldable.toList (toGenericSyntaxTree <$> mIdent) + ) + a + t + (ReservedDecl expr a) -> + SyntaxTreeObject + "ReservedDecl" + [toGenericSyntaxTree expr] + a + t (RegisterDecl mMod mIdent expr mBody a) -> SyntaxTreeObject "RegisterDecl" diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs index 37ef34e..7eed0f2 100644 --- a/src/Language/Fiddle/Parser.hs +++ b/src/Language/Fiddle/Parser.hs @@ -7,8 +7,8 @@ module Language.Fiddle.Parser ) where -import Data.Kind (Type) import Data.Functor.Identity +import Data.Kind (Type) import Data.Text (Text) import qualified Data.Text import Debug.Trace @@ -28,6 +28,7 @@ type P = ParsecT S () Identity type A = Commented SourceSpan type Pa (a :: Stage -> (Type -> Type) -> Type -> Type) = P (a 'Stage1 F (Commented SourceSpan)) + type PaS (a :: (Type -> Type) -> Type -> Type) = P (a F (Commented SourceSpan)) comment :: P Comment @@ -68,9 +69,15 @@ fiddleDecl = do <*> defer body packageBody KWLocation -> LocationDecl <$> ident <*> (tok TokEq >> expression) KWBits -> BitsDecl <$> ident <*> (tok TokColon >> bitType) - KWObjtype -> - ObjTypeDecl <$> ident <*> (tok TokColon >> defer body objTypeBody) - KWObject -> + KWType -> + ObjTypeDecl + <$> ident + <*> ( do + tok TokColon + bt <- bodyType + defer body (objTypeBody bt) + ) + KWInstance -> ObjectDecl <$> ident <*> (tok KWAt *> expression) @@ -114,15 +121,18 @@ objType = do baseObj :: P (A -> ObjType Stage1 F A) baseObj = (ReferencedObjType <$> ident) - <|> (AnonymousObjType <$> defer body objTypeBody) + <|> ( do + t <- bodyType + AnonymousObjType <$> defer body (objTypeBody t) + ) exprInParen :: Pa Expression exprInParen = tok TokLParen *> expression <* tok TokRParen -objTypeBody :: Pa ObjTypeBody -objTypeBody = +objTypeBody :: BodyType F (Commented SourceSpan) -> Pa ObjTypeBody +objTypeBody bt = withMeta $ - ObjTypeBody <$> many (objTypeDecl <* tok TokSemi) + ObjTypeBody bt <$> many (objTypeDecl <* tok TokSemi) objTypeDecl :: Pa ObjTypeDecl objTypeDecl = @@ -132,6 +142,14 @@ objTypeDecl = AssertPosStatement <$> exprInParen ) <|> ( do + tok KWReserved + ReservedDecl <$> exprInParen + ) + <|> ( do + bt <- bodyType + TypeSubStructure <$> defer body (objTypeBody bt) <*> optionMaybe ident + ) + <|> ( do mod <- optionMaybe modifier tok KWReg RegisterDecl mod @@ -150,8 +168,19 @@ modifier = tok KWWo >> return Wo ] +bitBodyType :: PaS BodyType +bitBodyType = + withMeta $ + (tok KWStruct >> return Struct) + <|> (tok KWUnion >> return Union) + +bodyType :: PaS BodyType +bodyType = + withMeta $ + (tok KWStruct >> return Struct) <|> (tok KWUnion >> return Union) + registerBody :: Pa RegisterBody -registerBody = withMeta $ RegisterBody <$> defer body deferredRegisterBody +registerBody = withMeta $ RegisterBody <$> bitBodyType <*> defer body deferredRegisterBody deferredRegisterBody :: Pa DeferredRegisterBody deferredRegisterBody = @@ -164,7 +193,9 @@ registerBitsDecl = ( do tok KWReserved >> ReservedBits <$> exprInParen ) - <|> ( DefinedBits <$> optionMaybe modifier + <|> (BitsSubStructure <$> registerBody <*> optionMaybe ident) + <|> ( DefinedBits + <$> optionMaybe modifier <*> ident <*> (tok TokColon >> registerBitsTypeRef) ) diff --git a/src/Language/Fiddle/Tokenizer.hs b/src/Language/Fiddle/Tokenizer.hs index 4e06b92..08f5649 100644 --- a/src/Language/Fiddle/Tokenizer.hs +++ b/src/Language/Fiddle/Tokenizer.hs @@ -12,29 +12,31 @@ import qualified Text.Parsec data T = KWAssertPos - | TokIdent !Text | KWAt | KWBits | KWEnum - | TokComment !Text - | TokDocComment !Text + | KWInstance | KWLocation - | KWObject - | KWObjtype | KWOption | KWPackage | KWReg | KWReserved | KWRo - | KWWo | KWRw - | TokLitNum !Text + | KWStruct + | KWType + | KWUnion + | KWWo | TokColon | TokComma + | TokComment !Text + | TokDocComment !Text | TokEq + | TokIdent !Text | TokLBrace | TokLBracket | TokLParen + | TokLitNum !Text | TokRBrace | TokRBracket | TokRParen @@ -60,8 +62,8 @@ parseToken = spaces *> tok parseToken' <* spaces "bits" -> KWBits "enum" -> KWEnum "location" -> KWLocation - "object" -> KWObject - "objtype" -> KWObjtype + "instance" -> KWInstance + "type" -> KWType "option" -> KWOption "package" -> KWPackage "reg" -> KWReg @@ -69,6 +71,8 @@ parseToken = spaces *> tok parseToken' <* spaces "wo" -> KWWo "rw" -> KWRw "reserved" -> KWReserved + "union" -> KWUnion + "struct" -> KWStruct "assert_pos" -> KWAssertPos (Data.Text.head -> h) | isDigit h -> TokLitNum str ident -> TokIdent ident |