%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[ConFold]{Constant Folder}
ToDo:
check boundaries before folding, e.g. we can fold the Float addition
(i1 + i2) only if it results in a valid Float.
- See the @IntDivOp@ below.
\begin{code}
#include "HsVersions.h"
module ConFold ( completePrim ) where
-IMPORT_Trace
+IMP_Ubiq(){-uitous-}
-import PlainCore
-import TaggedCore
+import CoreSyn
+import CoreUnfold ( whnfDetails, UnfoldingDetails(..), FormSummary(..) )
+import Id ( idType )
+import Literal ( mkMachInt, mkMachWord, Literal(..) )
+import MagicUFs ( MagicUnfoldingFun )
+import PrimOp ( PrimOp(..) )
import SimplEnv
import SimplMonad
+import TysWiredIn ( trueDataCon, falseDataCon )
-import AbsPrel ( trueDataCon, falseDataCon, PrimOp(..), PrimKind
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import BasicLit ( mkMachInt, mkMachWord, BasicLit(..) )
-import Id ( Id, getIdUniType )
-import Maybes ( Maybe(..) )
-import Util
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+chr = toEnum :: Int -> Char
+#endif
\end{code}
\begin{code}
-completePrim :: SimplEnv
- -> PrimOp -> [OutType] -> [OutAtom]
- -> SmplM OutExpr
+completePrim :: SimplEnv
+ -> PrimOp -> [OutArg]
+ -> SmplM OutExpr
\end{code}
In the parallel world, we use _seq_ to control the order in which
don't let the simplifier know that. We also use a special error
value, parError#, which is *not* a bottoming Id, so as far as the
simplifier is concerned, we have to evaluate seq# a before we know
-whether or not b will be evaluated.
-
+whether or not y will be evaluated.
+
+If we didn't have the extra case, then after inlining the compiler might
+see:
+ f p q = case seq# p of { _ -> p+q }
+
+If it sees that, it can see that f is strict in q, and hence it might
+evaluate q before p! The "0# ->" case prevents this happening.
+By having the parError# branch we make sure that anything in the
+other branch stays there!
+
This is fine, but we'd like to get rid of the extraneous code. Hence,
we *do* let the simplifier know that seq# is strict in its argument.
As a result, we hope that `a' will be evaluated before seq# is called.
case a of
a' -> let b' = case seq# a of { True -> b; False -> parError# }
- in case b' of ...
+ in case b' of ...
=>
case a of
- a' -> let b' = case True of { True -> b; False -> parError# }
- in case b' of ...
+ a' -> let b' = case True of { True -> b; False -> parError# }
+ in case b' of ...
=>
case a of
a' -> let b' = b
- in case b' of ...
+ in case b' of ...
=>
The second case must never be floated outside of the first!
\begin{code}
-completePrim env SeqOp [ty] [CoLitAtom lit]
- = returnSmpl (CoLit (mkMachInt 1))
-
-completePrim env op@SeqOp tys@[ty] args@[CoVarAtom var]
- = case (lookupUnfolding env var) of
- NoUnfoldingDetails -> give_up
- LiteralForm _ -> hooray
- OtherLiteralForm _ -> hooray
- ConstructorForm _ _ _ -> hooray
- OtherConstructorForm _ -> hooray
- GeneralForm _ WhnfForm _ _ -> hooray
- _ -> give_up
- where
- give_up = returnSmpl (CoPrim op tys args)
- hooray = returnSmpl (CoLit (mkMachInt 1))
+completePrim env SeqOp [TyArg ty, LitArg lit]
+ = returnSmpl (Lit (mkMachInt 1))
+
+completePrim env op@SeqOp args@[TyArg ty, VarArg var]
+ | whnfDetails (lookupUnfolding env var)
+ = returnSmpl (Lit (mkMachInt 1))
+ | otherwise
+ = returnSmpl (Prim op args)
\end{code}
\begin{code}
-completePrim env op tys args
+completePrim env op args
= case args of
- [CoLitAtom (MachChar char_lit)] -> oneCharLit op char_lit
- [CoLitAtom (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
- op int_lit
- [CoLitAtom (MachFloat float_lit)] -> oneFloatLit op float_lit
- [CoLitAtom (MachDouble double_lit)] -> oneDoubleLit op double_lit
- [CoLitAtom other_lit] -> oneLit op other_lit
+ [LitArg (MachChar char_lit)] -> oneCharLit op char_lit
+ [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
+ op int_lit
+ [LitArg (MachFloat float_lit)] -> oneFloatLit op float_lit
+ [LitArg (MachDouble double_lit)] -> oneDoubleLit op double_lit
+ [LitArg other_lit] -> oneLit op other_lit
- [CoLitAtom (MachChar char_lit1),
- CoLitAtom (MachChar char_lit2)] -> twoCharLits op char_lit1 char_lit2
+ [LitArg (MachChar char_lit1),
+ LitArg (MachChar char_lit2)] -> twoCharLits op char_lit1 char_lit2
- [CoLitAtom (MachInt int_lit1 True), -- both *signed* literals
- CoLitAtom (MachInt int_lit2 True)] -> twoIntLits op int_lit1 int_lit2
+ [LitArg (MachInt int_lit1 True), -- both *signed* literals
+ LitArg (MachInt int_lit2 True)] -> twoIntLits op int_lit1 int_lit2
- [CoLitAtom (MachInt int_lit1 False), -- both *unsigned* literals
- CoLitAtom (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
+ [LitArg (MachInt int_lit1 False), -- both *unsigned* literals
+ LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
- [CoLitAtom (MachInt int_lit1 False), -- unsigned+signed (shift ops)
- CoLitAtom (MachInt int_lit2 True)] -> oneWordOneIntLit op int_lit1 int_lit2
+ [LitArg (MachInt int_lit1 False), -- unsigned+signed (shift ops)
+ LitArg (MachInt int_lit2 True)] -> oneWordOneIntLit op int_lit1 int_lit2
- [CoLitAtom (MachFloat float_lit1),
- CoLitAtom (MachFloat float_lit2)] -> twoFloatLits op float_lit1 float_lit2
+ [LitArg (MachFloat float_lit1),
+ LitArg (MachFloat float_lit2)] -> twoFloatLits op float_lit1 float_lit2
- [CoLitAtom (MachDouble double_lit1),
- CoLitAtom (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
+ [LitArg (MachDouble double_lit1),
+ LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
- [CoLitAtom lit, CoVarAtom var] -> litVar op lit var
- [CoVarAtom var, CoLitAtom lit] -> litVar op lit var
-
- other -> give_up
+ [LitArg lit, VarArg var] -> litVar op lit var
+ [VarArg var, LitArg lit] -> litVar op lit var
+ other -> give_up
where
- give_up = returnSmpl (CoPrim op tys args)
+ give_up = returnSmpl (Prim op args)
- return_char c = returnSmpl (CoLit (MachChar c))
- return_int i = returnSmpl (CoLit (mkMachInt i))
- return_word i = returnSmpl (CoLit (mkMachWord i))
- return_float f = returnSmpl (CoLit (MachFloat f))
- return_double d = returnSmpl (CoLit (MachDouble d))
- return_lit lit = returnSmpl (CoLit lit)
+ return_char c = returnSmpl (Lit (MachChar c))
+ return_int i = returnSmpl (Lit (mkMachInt i))
+ return_word i = returnSmpl (Lit (mkMachWord i))
+ return_float f = returnSmpl (Lit (MachFloat f))
+ return_double d = returnSmpl (Lit (MachDouble d))
+ return_lit lit = returnSmpl (Lit lit)
return_bool True = returnSmpl trueVal
return_bool False = returnSmpl falseVal
return_prim_case var lit val_if_eq val_if_neq
- = newId (getIdUniType var) `thenSmpl` \ unused_binder ->
+ = newId (idType var) `thenSmpl` \ unused_binder ->
let
result
- = CoCase (CoVar var)
- (CoPrimAlts [(lit,val_if_eq)]
- (CoBindDefault unused_binder val_if_neq))
+ = Case (Var var)
+ (PrimAlts [(lit,val_if_eq)]
+ (BindDefault unused_binder val_if_neq))
in
--- pprTrace "return_prim_case:" (ppr PprDebug result) (
returnSmpl result
--- )
--------- Ints --------------
oneIntLit IntNegOp i = return_int (-i)
twoIntLits IntSubOp i1 i2 = return_int (i1-i2)
twoIntLits IntMulOp i1 i2 = return_int (i1*i2)
twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2)
- twoIntLits IntDivOp i1 i2 | i2 /= 0 = return_int (i1 `div` i2)
twoIntLits IntRemOp i1 i2 | i2 /= 0 = return_int (i1 `rem` i2)
twoIntLits IntGtOp i1 i2 = return_bool (i1 > i2)
twoIntLits IntGeOp i1 i2 = return_bool (i1 >= i2)
twoIntLits IntLtOp i1 i2 = return_bool (i1 < i2)
twoIntLits IntLeOp i1 i2 = return_bool (i1 <= i2)
-- ToDo: something for integer-shift ops?
- twoIntLits _ _ _ = {-trace "twoIntLits: giving up"-} give_up
+ twoIntLits _ _ _ = give_up
twoWordLits WordGtOp w1 w2 = return_bool (w1 > w2)
twoWordLits WordGeOp w1 w2 = return_bool (w1 >= w2)
twoWordLits WordLtOp w1 w2 = return_bool (w1 < w2)
twoWordLits WordLeOp w1 w2 = return_bool (w1 <= w2)
-- ToDo: something for AndOp, OrOp?
- twoWordLits _ _ _ = {-trace "twoWordLits: giving up"-} give_up
+ twoWordLits _ _ _ = give_up
-- ToDo: something for shifts
- oneWordOneIntLit _ _ _ = {-trace "oneWordOneIntLit: giving up"-} give_up
+ oneWordOneIntLit _ _ _ = give_up
--------- Floats --------------
oneFloatLit FloatNegOp f = return_float (-f)
#else
-- hard to do all that in Rationals ?? (WDP 94/10) ToDo
#endif
- oneFloatLit _ _ = {-trace "oneFloatLits: giving up"-} give_up
+ oneFloatLit _ _ = give_up
twoFloatLits FloatGtOp f1 f2 = return_bool (f1 > f2)
twoFloatLits FloatGeOp f1 f2 = return_bool (f1 >= f2)
twoFloatLits FloatSubOp f1 f2 = return_float (f1 - f2)
twoFloatLits FloatMulOp f1 f2 = return_float (f1 * f2)
twoFloatLits FloatDivOp f1 f2 | f2 /= 0 = return_float (f1 / f2)
-#if __GLASGOW_HASKELL__ <= 22
- twoFloatLits FloatPowerOp f1 f2 = return_float (f1 ** f2)
-#else
- -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
-#endif
- twoFloatLits _ _ _ = {-trace "twoFloatLits: giving up"-} give_up
+ twoFloatLits _ _ _ = give_up
--------- Doubles --------------
oneDoubleLit DoubleNegOp d = return_double (-d)
-#if __GLASGOW_HASKELL__ <= 22
- oneDoubleLit DoubleExpOp d = return_double (exp d)
- oneDoubleLit DoubleLogOp d = return_double (log d)
- oneDoubleLit DoubleSqrtOp d = return_double (sqrt d)
- oneDoubleLit DoubleSinOp d = return_double (sin d)
- oneDoubleLit DoubleCosOp d = return_double (cos d)
- oneDoubleLit DoubleTanOp d = return_double (tan d)
- oneDoubleLit DoubleAsinOp d = return_double (asin d)
- oneDoubleLit DoubleAcosOp d = return_double (acos d)
- oneDoubleLit DoubleAtanOp d = return_double (atan d)
- oneDoubleLit DoubleSinhOp d = return_double (sinh d)
- oneDoubleLit DoubleCoshOp d = return_double (cosh d)
- oneDoubleLit DoubleTanhOp d = return_double (tanh d)
-#else
- -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
-#endif
- oneDoubleLit _ _ = {-trace "oneDoubleLit: giving up"-} give_up
+ oneDoubleLit _ _ = give_up
twoDoubleLits DoubleGtOp d1 d2 = return_bool (d1 > d2)
twoDoubleLits DoubleGeOp d1 d2 = return_bool (d1 >= d2)
twoDoubleLits DoubleSubOp d1 d2 = return_double (d1 - d2)
twoDoubleLits DoubleMulOp d1 d2 = return_double (d1 * d2)
twoDoubleLits DoubleDivOp d1 d2 | d2 /= 0 = return_double (d1 / d2)
-#if __GLASGOW_HASKELL__ <= 22
- twoDoubleLits DoublePowerOp d1 d2 = return_double (d1 ** d2)
-#else
- -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
-#endif
- twoDoubleLits _ _ _ = {-trace "twoDoubleLits: giving up"-} give_up
+ twoDoubleLits _ _ _ = give_up
--------- Characters --------------
oneCharLit OrdOp c = return_int (fromInt (ord c))
- oneCharLit _ _ = {-trace "oneCharLIt: giving up"-} give_up
+ oneCharLit _ _ = give_up
twoCharLits CharGtOp c1 c2 = return_bool (c1 > c2)
twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2)
twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2)
twoCharLits CharLtOp c1 c2 = return_bool (c1 < c2)
twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2)
- twoCharLits _ _ _ = {-trace "twoCharLits: giving up"-} give_up
+ twoCharLits _ _ _ = give_up
--------- Miscellaneous --------------
oneLit Addr2IntOp (MachAddr i) = return_int i
-- This stuff turns
-- n ==# 3#
-- into
- -- case n of
+ -- case n of
-- 3# -> True
-- m -> False
--
litVar other_op lit var = give_up
-trueVal = CoCon trueDataCon [] []
-falseVal = CoCon falseDataCon [] []
+trueVal = Con trueDataCon []
+falseVal = Con falseDataCon []
\end{code}
projects / ghc-hetmet.git / blobdiff