From 200619042d1a6a6d221ec02d66d282f889729bb2 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Thu, 3 May 2007 02:17:53 +0000 Subject: [PATCH] Implement user datatypes --- fco2/GenerateC.hs | 8 ++- fco2/Main.hs | 4 +- fco2/Makefile | 1 + fco2/Parse.hs | 86 ++++++++++++++++++++++++++------ fco2/SimplifyTypes.hs | 37 ++++++++++++++ fco2/TODO | 6 --- fco2/Types.hs | 10 ++++ fco2/testcases/_bad_datatype.occ | 8 +++ fco2/testcases/datatype.occ | 38 ++++++++++++++ fco2/testcases/datatype2.occ | 27 ++++++++++ 10 files changed, 202 insertions(+), 23 deletions(-) create mode 100644 fco2/SimplifyTypes.hs create mode 100644 fco2/testcases/_bad_datatype.occ create mode 100644 fco2/testcases/datatype.occ create mode 100644 fco2/testcases/datatype2.occ diff --git a/fco2/GenerateC.hs b/fco2/GenerateC.hs index 316a098..78f90fb 100644 --- a/fco2/GenerateC.hs +++ b/fco2/GenerateC.hs @@ -828,7 +828,11 @@ abbrevExpression am t@(A.Array _ _) e genTypeSize :: A.Type -> (A.Name -> CGen ()) genTypeSize (A.Array ds _) - = genArraySize False $ sequence_ $ intersperse genComma [tell [show n] | A.Dimension n <- ds] + = genArraySize False $ sequence_ $ intersperse genComma dims + where dims = [case d of + A.Dimension n -> tell [show n] + _ -> die "unknown dimension in literal array type" + | d <- ds] abbrevExpression am _ e = (genExpression e, noSize) --}}} @@ -962,7 +966,7 @@ introduceSpec (A.Specification _ n (A.IsChannelArray _ t cs)) sequence_ $ intersperse genComma (map genVariable cs) tell ["};\n"] declareArraySizes [A.Dimension $ length cs] (genName n) ---introduceSpec (A.Specification m n (A.DataType m t)) +introduceSpec (A.Specification _ _ (A.DataType _ _)) = return () introduceSpec (A.Specification _ n (A.RecordType _ b fs)) = do tell ["typedef struct {\n"] sequence_ [case t of diff --git a/fco2/Main.hs b/fco2/Main.hs index 1477b11..e657670 100644 --- a/fco2/Main.hs +++ b/fco2/Main.hs @@ -17,11 +17,13 @@ import Pass import PrettyShow import SimplifyExprs import SimplifyProcs +import SimplifyTypes import Unnest passes :: [(String, Pass)] passes = - [ ("Simplify expressions", simplifyExprs) + [ ("Simplify types", simplifyTypes) + , ("Simplify expressions", simplifyExprs) , ("Simplify processes", simplifyProcs) , ("Flatten nested declarations", unnest) ] diff --git a/fco2/Makefile b/fco2/Makefile index 2abda9d..0a474e7 100644 --- a/fco2/Makefile +++ b/fco2/Makefile @@ -18,6 +18,7 @@ sources = \ PrettyShow.hs \ SimplifyExprs.hs \ SimplifyProcs.hs \ + SimplifyTypes.hs \ TLP.hs \ Types.hs \ Unnest.hs \ diff --git a/fco2/Parse.hs b/fco2/Parse.hs index 85cb249..58b9567 100644 --- a/fco2/Parse.hs +++ b/fco2/Parse.hs @@ -445,12 +445,26 @@ listType m l = listType' m (length l) l = if t1 == t2 then listType' m len rest else fail $ "multiple types in list: " ++ show t1 ++ " and " ++ show t2 +-- | Check that the second second of dimensions can be used in a context where +-- the first is expected. +areValidDimensions :: [A.Dimension] -> [A.Dimension] -> Bool +areValidDimensions [] [] = True +areValidDimensions (A.UnknownDimension:ds1) (A.UnknownDimension:ds2) + = areValidDimensions ds1 ds2 +areValidDimensions (A.UnknownDimension:ds1) (A.Dimension _:ds2) + = areValidDimensions ds1 ds2 +areValidDimensions (A.Dimension n1:ds1) (A.Dimension n2:ds2) + = if n1 /= n2 then False else areValidDimensions ds1 ds2 +areValidDimensions _ _ = False + -- | Check that a type we've inferred matches the type we expected. matchType :: A.Type -> A.Type -> OccParser () matchType et rt = case (et, rt) of ((A.Array ds t), (A.Array ds' t')) -> - if length ds == length ds' then return () else bad + if areValidDimensions ds ds' + then matchType t t' + else bad _ -> if rt == et then return () else bad where bad = fail $ "type mismatch (got " ++ show rt ++ "; expected " ++ show et ++ ")" @@ -653,12 +667,42 @@ portType "port type" --}}} --{{{ literals -isValidLiteralType :: A.Type -> A.Type -> Bool -isValidLiteralType defT t - = case defT of - A.Real32 -> isRealType t - A.Int -> isIntegerType t - A.Byte -> isIntegerType t +--{{{ type utilities for literals +-- | Can a literal of type defT be used for a value type t? +isValidLiteralType :: A.Type -> A.Type -> OccParser Bool +isValidLiteralType defT' realT' + = do realT <- underlyingType realT' + defT <- underlyingType defT' + case (defT, realT) of + (A.Real32, _) -> return $ isRealType realT + (A.Int, _) -> return $ isIntegerType realT + (A.Byte, _) -> return $ isIntegerType realT + (A.Array ds1 t1, A.Array ds2 t2) -> + if areValidDimensions ds2 ds1 + then isValidLiteralType t1 t2 + else return False + (a, b) -> return $ a == b + +checkValidLiteralType :: A.Type -> A.Type -> OccParser () +checkValidLiteralType defT t + = do isValid <- isValidLiteralType defT t + when (not isValid) $ + fail $ "type given/inferred for literal (" ++ show t ++ ") is not valid for this sort of literal (" ++ show defT ++ ")" + +-- | Apply dimensions from one type to another as far as possible. +-- This should only be used when you know the two types are compatible first +-- (i.e. they've passed isValidLiteralType). +applyDimensions :: A.Type -> A.Type -> A.Type +applyDimensions (A.Array ods _) (A.Array tds t) = A.Array (dims ods tds) t + where + dims :: [A.Dimension] -> [A.Dimension] -> [A.Dimension] + dims (d@(A.Dimension _):ods) (A.UnknownDimension:tds) + = d : dims ods tds + dims (_:ods) (d:tds) + = d : dims ods tds + dims _ ds = ds +applyDimensions _ t = t +--}}} literal :: OccParser A.Expression literal @@ -666,8 +710,7 @@ literal (defT, lr) <- untypedLiteral t <- do { try sLeftR; t <- dataType; sRightR; return t } <|> (getTypeContext defT) - when (not $ isValidLiteralType defT t) $ - fail $ "type given/inferred for literal (" ++ show t ++ ") is not valid for this sort of literal (" ++ show defT ++ ")" + checkValidLiteralType defT t return $ A.Literal m t lr "literal" @@ -727,16 +770,31 @@ table' = do m <- md (s, dim) <- stringLiteral let defT = A.Array [dim] A.Byte - do { sLeftR; t <- dataType; sRightR; matchType defT t; return $ A.Literal m t s } - <|> (return $ A.Literal m defT s) + t <- do sLeftR + t <- dataType + sRightR + return t + <|> getTypeContext defT + checkValidLiteralType defT t + return $ A.Literal m t s <|> do m <- md pushSubscriptTypeContext es <- tryXVX sLeft (sepBy1 expression sComma) sRight popTypeContext + ets <- mapM typeOfExpression es - t <- listType m ets - aes <- mapM collapseArrayElem es - return $ A.Literal m t (A.ArrayLiteral m aes) + defT <- listType m ets + + array <- liftM (A.ArrayLiteral m) $ mapM collapseArrayElem es + + t <- do sLeftR + t <- dataType + sRightR + return t + <|> getTypeContext defT + checkValidLiteralType defT t + let t' = applyDimensions defT t + return $ A.Literal m t' array <|> maybeSliced table A.SubscriptedExpr typeOfExpression "table'" diff --git a/fco2/SimplifyTypes.hs b/fco2/SimplifyTypes.hs new file mode 100644 index 0000000..72b6ba8 --- /dev/null +++ b/fco2/SimplifyTypes.hs @@ -0,0 +1,37 @@ +-- | Simplify types in the AST. +module SimplifyTypes (simplifyTypes) where + +import Control.Monad.State +import Data.Generics + +import qualified AST as A +import Pass +import Types + +simplifyTypes :: A.Process -> PassM A.Process +simplifyTypes = runPasses passes + where + passes = + [ ("Resolve types in AST", resolveNamedTypes) + , ("Resolve types in state", rntState) + ] + +-- | Turn named data types into their underlying types. +resolveNamedTypes :: Data t => t -> PassM t +resolveNamedTypes = doGeneric `extM` doType + where + doGeneric :: Data t => t -> PassM t + doGeneric = makeGeneric resolveNamedTypes + + doType :: A.Type -> PassM A.Type + doType t@(A.UserDataType _) = underlyingType t + doType t = doGeneric t + +-- | Resolve named types in ParseState. +rntState :: A.Process -> PassM A.Process +rntState p + = do st <- get + st' <- resolveNamedTypes st + put st' + return p + diff --git a/fco2/TODO b/fco2/TODO index 3b015a4..2f99193 100644 --- a/fco2/TODO +++ b/fco2/TODO @@ -33,9 +33,6 @@ names in it replaced appropriately. ## Passes -There should be a mkGeneric which produces a version of doGeneric that prunes -out things we don't need to recurse into -- like Strings. - Come up with an approach to combining simple passes to avoid multiple tree walks (for example, giving passes a "next thing to try" parameter). @@ -48,9 +45,6 @@ We should generally try to reduce the number of unnecessary pullups we do: - plain subscripts that result in a non-array shouldn't pull up (e.g. x[i][j]) - expressions that are already a variable should just be turned into the variable -Before code generation, have a pass that resolves all the DATA TYPE .. IS -directives to their real types. - Pass to turn complicated conversions into simpler ones (currently done in GenerateC). diff --git a/fco2/Types.hs b/fco2/Types.hs index 778b5fa..5ff6ec9 100644 --- a/fco2/Types.hs +++ b/fco2/Types.hs @@ -202,6 +202,16 @@ abbrevModeOfSpec s A.RetypesExpr _ am _ _ -> am _ -> A.Original +-- | Resolve a datatype into its underlying type -- i.e. if it's a named data +-- type, then return the underlying real type. +underlyingType :: (PSM m, Die m) => A.Type -> m A.Type +underlyingType (A.UserDataType n) + = do st <- specTypeOfName n + case st of + A.DataType _ t -> underlyingType t + _ -> die $ "not a type name " ++ show n +underlyingType t = return t + -- | Add an array dimension to a type; if it's already an array it'll just add -- a new dimension to the existing array. makeArrayType :: A.Dimension -> A.Type -> A.Type diff --git a/fco2/testcases/_bad_datatype.occ b/fco2/testcases/_bad_datatype.occ new file mode 100644 index 0000000..eb8ca16 --- /dev/null +++ b/fco2/testcases/_bad_datatype.occ @@ -0,0 +1,8 @@ +DATA TYPE ANGLE IS INT: +DATA TYPE LENGTH IS INT: +VAL ANGLE a IS 45: +VAL LENGTH b IS 10: +VAL LENGTH c IS a + b: +PROC P () + SKIP +: diff --git a/fco2/testcases/datatype.occ b/fco2/testcases/datatype.occ new file mode 100644 index 0000000..50c68a2 --- /dev/null +++ b/fco2/testcases/datatype.occ @@ -0,0 +1,38 @@ +-- Test basic stuff with named datatypes. + +DATA TYPE NUM IS INT: +PROC P () + DATA TYPE CHAR IS BYTE: + + NUM n: + CHAR c: + + [10]NUM ns: + [10]CHAR cs: + + SEQ + n := 42 + c := 42 + + n := 42 (NUM) + c := 42 (CHAR) + + n := NUM (42 (INT)) + c := CHAR (42 (BYTE)) + + n := NUM c + c := CHAR n + + SEQ i = 0 FOR 10 + SEQ + ns[i] := n + cs[i] := c + n := ns[i] + c := cs[i] + + n := ns[2] + ns[4] + c := cs[2] + cs[4] + + ASSERT (n = 84) + ASSERT (c = 84) +: diff --git a/fco2/testcases/datatype2.occ b/fco2/testcases/datatype2.occ new file mode 100644 index 0000000..e4322bc --- /dev/null +++ b/fco2/testcases/datatype2.occ @@ -0,0 +1,27 @@ +-- Test tables of user datatypes, and user datatypes that are arrays. + +PROC P () + DATA TYPE CHAR IS BYTE: + DATA TYPE CHARS IS [5]BYTE: + CHAR ch: + VAL CHARS s2 IS "hello" (CHARS): + VAL CHARS s IS "hello": + + DATA TYPE ONE IS INT: + DATA TYPE FOUR IS [4]INT: + VAL ONE o IS 42: + VAL FOUR g IS [1, 2, 3, 4] (FOUR): + VAL FOUR f IS [1, 2, 3, 4]: + + VAL []INT is IS [1, 2, 3, 4]: + VAL []ONE os IS [1, 2, 3, 4]: + VAL []ONE os2 IS [1 (ONE), 2, 3, 4]: + -- I don't see why this shouldn't work, but occ21 doesn't like it. + --VAL []CHAR cs IS "hello": + + SEQ + ASSERT (o = 42) + ASSERT (f[2] = 3) + ASSERT (g[2] = 3) + ASSERT (os[1] = 2) +: