From c39d7ee237fcbce9132819e537ee0fef82bc42db Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Fri, 20 Apr 2007 21:15:36 +0000 Subject: [PATCH] Constant expression evaluation --- fco2/AST.hs | 1 - fco2/EvalConstants.hs | 108 ++++++++++++++++++++++++++++++++++ fco2/GenerateC.hs | 21 ++----- fco2/Makefile | 1 + fco2/Parse.hs | 39 ++++++++---- fco2/ParseState.hs | 9 +++ fco2/SimplifyExprs.hs | 3 +- fco2/TODO | 6 +- fco2/Types.hs | 78 +++--------------------- fco2/Unnest.hs | 8 +-- fco2/testcases/const-expr.occ | 8 +++ fco2/testcases/constants.occ | 3 +- 12 files changed, 177 insertions(+), 108 deletions(-) create mode 100644 fco2/EvalConstants.hs create mode 100644 fco2/testcases/const-expr.occ diff --git a/fco2/AST.hs b/fco2/AST.hs index b214173..75c63e5 100644 --- a/fco2/AST.hs +++ b/fco2/AST.hs @@ -192,7 +192,6 @@ data SpecType = | Declaration Meta Type | Is Meta AbbrevMode Type Variable | IsExpr Meta AbbrevMode Type Expression - -- FIXME Can these be multidimensional? | IsChannelArray Meta Type [Variable] | DataType Meta Type | DataTypeRecord Meta Bool [(Name, Type)] diff --git a/fco2/EvalConstants.hs b/fco2/EvalConstants.hs new file mode 100644 index 0000000..59c301c --- /dev/null +++ b/fco2/EvalConstants.hs @@ -0,0 +1,108 @@ +-- | Evaluate constant expressions. +module EvalConstants where + +import Control.Monad.Error +import Control.Monad.Identity +import Control.Monad.State +import Data.Bits +import Data.Generics +import Data.Int +import Data.Maybe +import Numeric + +import qualified AST as A +import Metadata +import ParseState +import Types + +-- | Attempt to simplify an expression as far as possible by precomputing +-- constant bits. +simplifyExpression :: ParseState -> A.Expression -> Either String A.Expression +-- Literals are "simple" already. +simplifyExpression _ e@(A.ExprLiteral _ _) = Right e +simplifyExpression _ e@(A.True _) = Right e +simplifyExpression _ e@(A.False _) = Right e +simplifyExpression ps e + = case runIdentity (evalStateT (runErrorT (evalExpression e)) ps) of + Left err -> Left err + Right val -> Right $ renderValue (metaOfExpression e) val + +--{{{ expression evaluator +type EvalM a = ErrorT String (StateT ParseState Identity) a + +-- | Occam values of various types. +data OccValue = + OccBool Bool + | OccInt Int32 + deriving (Show, Eq, Typeable, Data) + +-- | Turn the result of one of the read* functions into an OccValue, +-- or throw an error if it didn't parse. +fromRead :: (t -> OccValue) -> [(t, String)] -> EvalM OccValue +fromRead cons [(v, "")] = return $ cons v +fromRead _ _ = throwError "cannot parse literal" + +evalLiteral :: A.Literal -> EvalM OccValue +evalLiteral (A.Literal _ A.Int (A.IntLiteral _ s)) = fromRead OccInt $ readDec s +evalLiteral (A.Literal _ A.Int (A.HexLiteral _ s)) = fromRead OccInt $ readHex s +evalLiteral _ = throwError "bad literal" + +evalExpression :: A.Expression -> EvalM OccValue +evalExpression (A.Monadic _ op e) + = do v <- evalExpression e + evalMonadic op v +evalExpression (A.Dyadic _ op e1 e2) + = do v1 <- evalExpression e1 + v2 <- evalExpression e2 + evalDyadic op v1 v2 +evalExpression (A.MostPos _ A.Int) = return $ OccInt maxBound +evalExpression (A.MostNeg _ A.Int) = return $ OccInt minBound +evalExpression (A.ExprLiteral _ l) = evalLiteral l +evalExpression (A.ExprVariable _ (A.Variable _ n)) + = do ps <- get + case lookup (A.nameName n) (psConstants ps) of + Just e -> evalExpression e + Nothing -> throwError $ "non-constant variable " ++ show n ++ " used" +evalExpression (A.True _) = return $ OccBool True +evalExpression (A.False _) = return $ OccBool False +evalExpression _ = throwError "bad expression" + +evalMonadic :: A.MonadicOp -> OccValue -> EvalM OccValue +evalMonadic A.MonadicSubtr (OccInt i) = return $ OccInt (0 - i) +evalMonadic A.MonadicBitNot (OccInt i) = return $ OccInt (complement i) +evalMonadic A.MonadicNot (OccBool b) = return $ OccBool (not b) +evalMonadic _ _ = throwError "bad monadic op" + +evalDyadic :: A.DyadicOp -> OccValue -> OccValue -> EvalM OccValue +-- FIXME These should check for overflow. +evalDyadic A.Add (OccInt a) (OccInt b) = return $ OccInt (a + b) +evalDyadic A.Subtr (OccInt a) (OccInt b) = return $ OccInt (a - b) +evalDyadic A.Mul (OccInt a) (OccInt b) = return $ OccInt (a * b) +evalDyadic A.Div (OccInt a) (OccInt b) = return $ OccInt (a `div` b) +evalDyadic A.Rem (OccInt a) (OccInt b) = return $ OccInt (a `mod` b) +-- ... end FIXME +evalDyadic A.Plus (OccInt a) (OccInt b) = return $ OccInt (a + b) +evalDyadic A.Minus (OccInt a) (OccInt b) = return $ OccInt (a - b) +evalDyadic A.Times (OccInt a) (OccInt b) = return $ OccInt (a * b) +evalDyadic A.BitAnd (OccInt a) (OccInt b) = return $ OccInt (a .&. b) +evalDyadic A.BitOr (OccInt a) (OccInt b) = return $ OccInt (a .|. b) +evalDyadic A.BitXor (OccInt a) (OccInt b) = return $ OccInt (a `xor` b) +evalDyadic A.And (OccBool a) (OccBool b) = return $ OccBool (a && b) +evalDyadic A.Or (OccBool a) (OccBool b) = return $ OccBool (a || b) +evalDyadic A.Eq a b = return $ OccBool (a == b) +evalDyadic A.NotEq a b + = do (OccBool b) <- evalDyadic A.Eq a b + return $ OccBool (not b) +evalDyadic A.Less (OccInt a) (OccInt b) = return $ OccBool (a < b) +evalDyadic A.More (OccInt a) (OccInt b) = return $ OccBool (a > b) +evalDyadic A.LessEq a b = evalDyadic A.More b a +evalDyadic A.MoreEq a b = evalDyadic A.Less b a +evalDyadic A.After (OccInt a) (OccInt b) = return $ OccBool ((a - b) > 0) +evalDyadic _ _ _ = throwError "bad dyadic op" + +-- | Convert a value back into a literal. +renderValue :: Meta -> OccValue -> A.Expression +renderValue m (OccInt i) = A.ExprLiteral m (A.Literal m A.Int (A.IntLiteral m $ show i)) +renderValue m (OccBool True) = A.True m +renderValue m (OccBool False) = A.False m +--}}} diff --git a/fco2/GenerateC.hs b/fco2/GenerateC.hs index b8d2b16..78a4f1e 100644 --- a/fco2/GenerateC.hs +++ b/fco2/GenerateC.hs @@ -390,23 +390,12 @@ genFuncDyadic s e f genExpression f tell [")"] -genEitherDyadic :: String -> (A.Expression -> A.Expression -> CGen ()) -> A.Expression -> A.Expression -> CGen () -genEitherDyadic s const e f - = do ps <- get - -- If both arms of the expression are constant, then use an - -- unchecked implementation of the operator. - -- FIXME We might want to check that it doesn't overflow at - -- compile time. - if isConstExpression ps e && isConstExpression ps f - then const e f - else genFuncDyadic s e f - genDyadic :: A.DyadicOp -> A.Expression -> A.Expression -> CGen () -genDyadic A.Add e f = genEitherDyadic "occam_add" (genSimpleDyadic "+") e f -genDyadic A.Subtr e f = genEitherDyadic "occam_subtr" (genSimpleDyadic "-") e f -genDyadic A.Mul e f = genEitherDyadic "occam_mul" (genSimpleDyadic "*") e f -genDyadic A.Div e f = genEitherDyadic "occam_div" (genSimpleDyadic "/") e f -genDyadic A.Rem e f = genEitherDyadic "occam_rem" (genSimpleDyadic "%") e f +genDyadic A.Add e f = genFuncDyadic "occam_add" e f +genDyadic A.Subtr e f = genFuncDyadic "occam_subtr" e f +genDyadic A.Mul e f = genFuncDyadic "occam_mul" e f +genDyadic A.Div e f = genFuncDyadic "occam_div" e f +genDyadic A.Rem e f = genFuncDyadic "occam_rem" e f genDyadic A.Plus e f = genSimpleDyadic "+" e f genDyadic A.Minus e f = genSimpleDyadic "-" e f genDyadic A.Times e f = genSimpleDyadic "*" e f diff --git a/fco2/Makefile b/fco2/Makefile index ce6afa5..d7c69cc 100644 --- a/fco2/Makefile +++ b/fco2/Makefile @@ -5,6 +5,7 @@ all: $(targets) sources = \ AST.hs \ Errors.hs \ + EvalConstants.hs \ GenerateC.hs \ Indentation.hs \ Main.hs \ diff --git a/fco2/Parse.hs b/fco2/Parse.hs index 6631c8a..dbf9111 100644 --- a/fco2/Parse.hs +++ b/fco2/Parse.hs @@ -14,10 +14,11 @@ import qualified IO import Numeric (readHex) import qualified AST as A +import Errors +import EvalConstants +import Indentation import Metadata import ParseState -import Errors -import Indentation import Types --{{{ setup stuff for Parsec @@ -434,10 +435,21 @@ scopeInRep (A.For m n b c) scopeOutRep :: A.Replicator -> OccParser () scopeOutRep (A.For m n b c) = scopeOut n +-- This one's more complicated because we need to check if we're introducing a constant. scopeInSpec :: A.Specification -> OccParser A.Specification scopeInSpec (A.Specification m n st) - = do n' <- scopeIn n st (abbrevModeOfSpec st) - return $ A.Specification m n' st + = do ps <- getState + let (st', isConst) = case st of + (A.IsExpr m A.ValAbbrev t e) -> + case simplifyExpression ps e of + Left _ -> (st, False) + Right e' -> (A.IsExpr m A.ValAbbrev t e', True) + _ -> (st, False) + n' <- scopeIn n st' (abbrevModeOfSpec st') + if isConst + then updateState (\ps -> ps { psConstants = (A.nameName n', case st' of A.IsExpr _ _ _ e' -> e') : psConstants ps }) + else return () + return $ A.Specification m n' st' scopeOutSpec :: A.Specification -> OccParser () scopeOutSpec (A.Specification _ n _) = scopeOut n @@ -680,9 +692,9 @@ constExprOfType :: A.Type -> OccParser A.Expression constExprOfType wantT = do e <- exprOfType wantT ps <- getState - if isConstExpression ps e - then return e - else fail "expected constant expression" + case simplifyExpression ps e of + Left err -> fail $ "expected constant expression (" ++ err ++ ")" + Right e' -> return e' constIntExpr = constExprOfType A.Int "constant integer expression" @@ -867,9 +879,7 @@ abbreviation = do m <- md (do { (n, v) <- tryVXV newVariableName sIS variable; sColon; eol; t <- pTypeOfVariable v; return $ A.Specification m n $ A.Is m A.Abbrev t v } <|> do { (s, n, v) <- try (do { s <- specifier; n <- newVariableName; sIS; v <- variable; return (s, n, v) }); sColon; eol; t <- pTypeOfVariable v; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s v } - <|> do { sVAL ; - do { (n, e) <- try (do { n <- newVariableName; sIS; e <- expression; return (n, e) }); sColon; eol; t <- pTypeOfExpression e; return $ A.Specification m n $ A.IsExpr m A.ValAbbrev t e } - <|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- pTypeOfExpression e; matchType s t; return $ A.Specification m n $ A.IsExpr m A.ValAbbrev s e } } + <|> valIsAbbrev <|> try (do { n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c }) <|> try (do { n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c }) <|> try (do { n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c }) @@ -880,6 +890,15 @@ abbreviation <|> try (do { s <- specifier; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; matchType s t; return $ A.Specification m n $ A.IsChannelArray m s cs })) "abbreviation" +valIsAbbrev :: OccParser A.Specification +valIsAbbrev + = do m <- md + sVAL + (n, t, e) <- do { (n, e) <- tryVXV newVariableName sIS expression; sColon; eol; t <- pTypeOfExpression e; return (n, t, e) } + <|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- pTypeOfExpression e; matchType s t; return (n, t, e) } + return $ A.Specification m n $ A.IsExpr m A.ValAbbrev t e + "VAL IS abbreviation" + definition :: OccParser A.Specification definition = do { m <- md; sDATA; sTYPE; n <- newDataTypeName ; diff --git a/fco2/ParseState.hs b/fco2/ParseState.hs index d866d55..b908b7f 100644 --- a/fco2/ParseState.hs +++ b/fco2/ParseState.hs @@ -19,6 +19,7 @@ data ParseState = ParseState { psLocalNames :: [(String, A.Name)], psNames :: [(String, A.NameDef)], psNameCounter :: Int, + psConstants :: [(String, A.Expression)], -- Set by passes psNonceCounter :: Int, @@ -39,6 +40,7 @@ emptyState = ParseState { psLocalNames = [], psNames = [], psNameCounter = 0, + psConstants = [], psNonceCounter = 0, psFunctionReturns = [], @@ -113,3 +115,10 @@ makeNonceVariable :: MonadState ParseState m => String -> Meta -> A.Type -> A.Na makeNonceVariable s m t nt am = defineNonce m s (A.Declaration m t) nt am +-- | Is a name on the list of constants? +isConstantName :: ParseState -> A.Name -> Bool +isConstantName ps n + = case lookup (A.nameName n) (psConstants ps) of + Just _ -> True + Nothing -> False + diff --git a/fco2/SimplifyExprs.hs b/fco2/SimplifyExprs.hs index e425ccb..0bd0a31 100644 --- a/fco2/SimplifyExprs.hs +++ b/fco2/SimplifyExprs.hs @@ -100,8 +100,7 @@ pullUp = doGeneric `extM` doProcess `extM` doSpecification `extM` doExpression ` where pull :: A.Type -> A.Expression -> PassM A.Expression pull t e - = do -- FIXME Should get Meta from somewhere... - let m = [] + = do let m = metaOfExpression e spec@(A.Specification _ n _) <- makeNonceIsExpr "array_expr" m t e addPulled $ A.ProcSpec m spec return $ A.ExprVariable m (A.Variable m n) diff --git a/fco2/TODO b/fco2/TODO index 4c54c32..133f13f 100644 --- a/fco2/TODO +++ b/fco2/TODO @@ -3,15 +3,13 @@ To-do list for FCO Add an option for whether to compile out overflow/bounds checks. +Add a -o option to control where the output goes (stdout by default for now). + Have a final pass that checks all the mangling has been done -- i.e. function calls have been removed, and so on. Multidimensional array literals won't work. -We do need to have a constant folding pass -- irritatingly -- because C won't do it. -Should be a new module, and have an eval function that returns Maybe -A.Expression (or similar). - Array indexing needs to be checked against the bounds (which'll do away with a lot of the "_sizes unused" warnings). diff --git a/fco2/Types.hs b/fco2/Types.hs index d9dc329..b9bc131 100644 --- a/fco2/Types.hs +++ b/fco2/Types.hs @@ -4,6 +4,7 @@ module Types where -- FIXME: This module is a mess -- sort it and document the functions. import Control.Monad +import Data.Generics import Data.Maybe import qualified AST as A @@ -108,76 +109,6 @@ typeOfLiteral ps (A.SubscriptedLiteral m s l) = typeOfLiteral ps l >>= subscriptType ps s --}}} ---{{{ identifying constants --- | Can an expression's value be determined at compile time? -isConstExpression :: ParseState -> A.Expression -> Bool -isConstExpression ps e - = case e of - A.Monadic m op e -> isConstExpression ps e - A.Dyadic m op e f -> - isConstExpression ps e && isConstExpression ps f - A.MostPos m t -> True - A.MostNeg m t -> True - A.SizeType m t -> True - A.SizeExpr m e -> isConstExpression ps e - A.SizeVariable m v -> isConstVariable ps v - A.Conversion m cm t e -> isConstExpression ps e - A.ExprVariable m v -> isConstVariable ps v - A.ExprLiteral m l -> isConstLiteral ps l - A.True m -> True - A.False m -> True - -- This could be true if we could identify functions with constant - -- arguments and evaluate them at compile time, but I don't think we - -- really want to go there... - A.FunctionCall m n es -> False - A.SubscriptedExpr m s e -> - isConstSubscript ps s && isConstExpression ps e - A.BytesInExpr m e -> isConstExpression ps e - A.BytesInType m t -> True - A.OffsetOf m t n -> True - --- | Can an literal's value be determined at compile time? --- (Don't laugh -- array literals can't always!) -isConstLiteral :: ParseState -> A.Literal -> Bool -isConstLiteral ps (A.Literal _ _ lr) = isConstLiteralRepr ps lr -isConstLiteral ps (A.SubscriptedLiteral _ s l) - = isConstSubscript ps s && isConstLiteral ps l - -isConstLiteralRepr :: ParseState -> A.LiteralRepr -> Bool -isConstLiteralRepr ps (A.ArrayLiteral _ es) - = and [isConstExpression ps e | e <- es] -isConstLiteralRepr _ _ = True - --- | Can a variable's value be determined at compile time? -isConstVariable :: ParseState -> A.Variable -> Bool -isConstVariable ps (A.Variable _ n) = isConstName ps n -isConstVariable ps (A.SubscriptedVariable _ s v) - = isConstSubscript ps s && isConstVariable ps v - --- | Does a name refer to a constant variable? -isConstName :: ParseState -> A.Name -> Bool -isConstName ps n = isConstSpecType ps $ fromJust $ specTypeOfName ps n - --- | Can a specification's value (that is, the value of a variable defined --- using that specification) be determined at compile time? -isConstSpecType :: ParseState -> A.SpecType -> Bool -isConstSpecType ps (A.Is _ _ _ v) = isConstVariable ps v -isConstSpecType ps (A.IsExpr _ _ _ e) = isConstExpression ps e -isConstSpecType ps (A.Retypes _ _ _ v) = isConstVariable ps v -isConstSpecType ps (A.RetypesExpr _ _ _ e) = isConstExpression ps e -isConstSpecType _ _ = False - --- | Can a subscript's value (that is, the range of subscripts it extracts) be --- determined at compile time? -isConstSubscript :: ParseState -> A.Subscript -> Bool -isConstSubscript ps (A.Subscript _ e) = isConstExpression ps e -isConstSubscript ps (A.SubscriptField _ _) = True -isConstSubscript ps (A.SubscriptFromFor _ e f) - = isConstExpression ps e && isConstExpression ps f -isConstSubscript ps (A.SubscriptFrom _ e) = isConstExpression ps e -isConstSubscript ps (A.SubscriptFor _ e) = isConstExpression ps e ---}}} - returnTypesOfFunction :: ParseState -> A.Name -> Maybe [A.Type] returnTypesOfFunction ps n = case specTypeOfName ps n of @@ -220,3 +151,10 @@ stripArrayType t = t -- | Generate a constant expression from an integer -- for array sizes and the like. makeConstant :: Meta -> Int -> A.Expression makeConstant m n = A.ExprLiteral m $ A.Literal m A.Int $ A.IntLiteral m (show n) + +-- | Find the Meta value in an expression. +metaOfExpression :: A.Expression -> Meta +metaOfExpression e = concat $ gmapQ (mkQ [] findMeta) e + where + findMeta :: Meta -> Meta + findMeta m = m diff --git a/fco2/Unnest.hs b/fco2/Unnest.hs index 86bcb0d..25bba9c 100644 --- a/fco2/Unnest.hs +++ b/fco2/Unnest.hs @@ -99,7 +99,7 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess A.ChannelName -> True A.VariableName -> True _ -> False, - not $ isConstName ps n] + not $ isConstantName ps n] let types = [fromJust $ typeOfName ps n | n <- freeNames] let ams = [case fromJust $ abbrevModeOfName ps n of A.Original -> A.Abbrev @@ -154,9 +154,9 @@ removeNesting p doGeneric = gmapM pullSpecs doSpecification :: A.Specification -> PassM A.Specification - doSpecification spec@(A.Specification m _ st) + doSpecification spec@(A.Specification m n st) = do ps <- get - if canPull ps st then + if isConstantName ps n || canPull ps st then do spec' <- doGeneric spec addPulled $ A.ProcSpec m spec' return A.NoSpecification @@ -168,7 +168,7 @@ removeNesting p canPull _ (A.DataTypeRecord _ _ _) = True canPull _ (A.Protocol _ _) = True canPull _ (A.ProtocolCase _ _) = True - canPull ps st = isConstSpecType ps st + canPull _ _ = False -- | Remove specifications that have been turned into NoSpecifications. removeNoSpecs :: Data t => t -> PassM t diff --git a/fco2/testcases/const-expr.occ b/fco2/testcases/const-expr.occ new file mode 100644 index 0000000..64de7fd --- /dev/null +++ b/fco2/testcases/const-expr.occ @@ -0,0 +1,8 @@ +PROC p () + VAL INT a IS 42: + VAL INT b IS 24: + VAL INT c IS a + b: + VAL BOOL d IS a AFTER b: + INT x: + x := c +: diff --git a/fco2/testcases/constants.occ b/fco2/testcases/constants.occ index bd28a84..e706f8f 100644 --- a/fco2/testcases/constants.occ +++ b/fco2/testcases/constants.occ @@ -13,12 +13,13 @@ PROC P () VAL INT g IS BYTESIN (a): VAL BOOL aft IS a AFTER b: -- ... and these shouldn't. + [c]INT array.of.const.size: INT A: VAL INT B IS A + 1: VAL INT C IS X + B: VAL []INT D IS [1, 2, X, 4]: VAL INT E IS D[2]: -- technically the others should be OK, but I think that's excessive analysis! - INT32 F RETYPES A: + VAL INT32 F RETYPES A: VAL INT G IS BYTESIN (E): VAL BOOL AFT IS A AFTER B: