Constant expression evaluation

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)]

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
+--}}}

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.Add e f = genFuncDyadic "occam_add" e f
-genDyadic A.Subtr e f = genEitherDyadic "occam_subtr" (genSimpleDyadic "-") e f
+genDyadic A.Subtr e f = genFuncDyadic "occam_subtr" e f
-genDyadic A.Mul e f = genEitherDyadic "occam_mul" (genSimpleDyadic "*") e f
+genDyadic A.Mul e f = genFuncDyadic "occam_mul" e f
-genDyadic A.Div e f = genEitherDyadic "occam_div" (genSimpleDyadic "/") e f
+genDyadic A.Div e f = genFuncDyadic "occam_div" e f
-genDyadic A.Rem e f = genEitherDyadic "occam_rem" (genSimpleDyadic "%") 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

fco2/Makefile

@@ -5,6 +5,7 @@ all: $(targets)
 sources = \
 	AST.hs \
 	Errors.hs \
+	EvalConstants.hs \
 	GenerateC.hs \
 	Indentation.hs \
 	Main.hs \

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)
+    =  do ps <- getState
-          return $ A.Specification m n' st
+          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
+          case simplifyExpression ps e of
-            then return e
+            Left err -> fail $ "expected constant expression (" ++ err ++ ")"
-            else fail "expected constant expression"
+            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 ;
+            <|> valIsAbbrev
-                      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 } }
             <|> 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 ;

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
+

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...
+            = do let m = metaOfExpression e
-                 let m = []
                  spec@(A.Specification _ n _) <- makeNonceIsExpr "array_expr" m t e
                  addPulled $ A.ProcSpec m spec
                  return $ A.ExprVariable m (A.Variable m n)

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).
 

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

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

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
+:

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: