X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FConFold.lhs;h=7c09ad11daa92058fd2f8a7cf42abb474a1b818e;hb=2c8f04b5b883db74f449dfc8c224929fe28b027d;hp=19c2a78d8a1ed2aa2773679002b8ae73e30be463;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs index 19c2a78..7c09ad1 100644 --- a/ghc/compiler/simplCore/ConFold.lhs +++ b/ghc/compiler/simplCore/ConFold.lhs @@ -1,39 +1,34 @@ % -% (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 +#include "HsVersions.h" -import PlainCore -import TaggedCore +import CoreSyn +import CoreUnfold ( Unfolding ) +import Id ( idType ) +import Literal ( mkMachInt, mkMachWord, Literal(..) ) +import PrimOp ( PrimOp(..) ) import SimplEnv import SimplMonad +import SimplUtils ( newId ) +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 +import Char ( ord, chr ) \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 @@ -47,8 +42,17 @@ Now, we know that the seq# primitive will never return 0#, but we 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. @@ -60,19 +64,19 @@ NB: If we ever do case-floating, we have an extra worry: 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 ... => @@ -82,80 +86,68 @@ NB: If we ever do case-floating, we have an extra worry: 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] + | isEvaluated (lookupUnfolding env var) = returnSmpl (Lit (mkMachInt 1)) -- var is eval'd + | otherwise = returnSmpl (Prim op args) -- var not eval'd \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) @@ -176,7 +168,6 @@ completePrim env op tys args 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) @@ -185,7 +176,7 @@ completePrim env op tys args 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) @@ -194,30 +185,15 @@ completePrim env op tys args 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) -#if __GLASGOW_HASKELL__ <= 22 - oneFloatLit FloatExpOp f = return_float (exp f) - oneFloatLit FloatLogOp f = return_float (log f) - oneFloatLit FloatSqrtOp f = return_float (sqrt f) - oneFloatLit FloatSinOp f = return_float (sin f) - oneFloatLit FloatCosOp f = return_float (cos f) - oneFloatLit FloatTanOp f = return_float (tan f) - oneFloatLit FloatAsinOp f = return_float (asin f) - oneFloatLit FloatAcosOp f = return_float (acos f) - oneFloatLit FloatAtanOp f = return_float (atan f) - oneFloatLit FloatSinhOp f = return_float (sinh f) - oneFloatLit FloatCoshOp f = return_float (cosh f) - oneFloatLit FloatTanhOp f = return_float (tanh f) -#else - -- hard to do all that in Rationals ?? (WDP 94/10) ToDo -#endif - oneFloatLit _ _ = {-trace "oneFloatLits: giving up"-} give_up + -- hard to do float ops in Rationals ?? (WDP 94/10) ToDo + oneFloatLit _ _ = give_up twoFloatLits FloatGtOp f1 f2 = return_bool (f1 > f2) twoFloatLits FloatGeOp f1 f2 = return_bool (f1 >= f2) @@ -229,32 +205,11 @@ completePrim env op tys args 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) @@ -266,16 +221,11 @@ completePrim env op tys args 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) @@ -283,7 +233,7 @@ completePrim env op tys args 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 @@ -293,7 +243,7 @@ completePrim env op tys args -- This stuff turns -- n ==# 3# -- into - -- case n of + -- case n of -- 3# -> True -- m -> False -- @@ -316,6 +266,6 @@ completePrim env op tys args litVar other_op lit var = give_up -trueVal = CoCon trueDataCon [] [] -falseVal = CoCon falseDataCon [] [] +trueVal = Con trueDataCon [] +falseVal = Con falseDataCon [] \end{code}