suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Constant expression evaluation

Browse Source
This commit is contained in:
Adam Sampson 2007-04-20 21:15:36 +00:00
parent e7be8814ad
commit c39d7ee237
12 changed files with 177 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
fco2/AST.hs
View File

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

108
fco2/EvalConstants.hs Normal file
View File

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

21
fco2/GenerateC.hs
View File

@ -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

1
fco2/Makefile
View File

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

39
fco2/Parse.hs
View File

@ -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 ;

9
fco2/ParseState.hs
View File

@ -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

3
fco2/SimplifyExprs.hs
View File

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

6
fco2/TODO
View File

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

78
fco2/Types.hs
View File

@ -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

8
fco2/Unnest.hs
View File

@ -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

8
fco2/testcases/const-expr.occ Normal file
View File

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

3
fco2/testcases/constants.occ
View File

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