X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FConFold.lhs;h=1af5fbf652ea65b151bed39d96f7a6654a0555d3;hb=b106d6412e354f2944a64f1fa135cb439ba2965f;hp=ef787b2d23c8140d876f792714f312c15028ac47;hpb=dabfa71f33eabc5a2d10959728f772aa016f1c84;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs index ef787b2..1af5fbf 100644 --- a/ghc/compiler/simplCore/ConFold.lhs +++ b/ghc/compiler/simplCore/ConFold.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[ConFold]{Constant Folder} @@ -8,27 +8,29 @@ ToDo: (i1 + i2) only if it results in a valid Float. \begin{code} -#include "HsVersions.h" - -module ConFold ( completePrim ) where +module ConFold ( tryPrimOp ) where -import Ubiq{-uitous-} +#include "HsVersions.h" import CoreSyn -import CoreUnfold ( UnfoldingDetails(..), FormSummary(..) ) -import Id ( idType ) -import Literal ( mkMachInt, mkMachWord, Literal(..) ) -import MagicUFs ( MagicUnfoldingFun ) +import Id ( getIdUnfolding ) +import Const ( mkMachInt, mkMachWord, Literal(..), Con(..) ) import PrimOp ( PrimOp(..) ) -import SimplEnv import SimplMonad import TysWiredIn ( trueDataCon, falseDataCon ) +import TyCon ( tyConDataCons, isEnumerationTyCon ) +import DataCon ( dataConTag, fIRST_TAG ) +import Type ( splitTyConApp_maybe ) + +import Char ( ord, chr ) +import Outputable \end{code} \begin{code} -completePrim :: SimplEnv - -> PrimOp -> [OutArg] - -> SmplM OutExpr +tryPrimOp :: PrimOp -> [CoreArg] -- op arg1 ... argn + -- Args are already simplified + -> Maybe CoreExpr -- Nothing => no transformation + -- Just e => transforms to e \end{code} In the parallel world, we use _seq_ to control the order in which @@ -85,78 +87,86 @@ 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}p +tryPrimOp SeqOp [Type ty, Con (Literal lit) _] + = Just (Con (Literal (mkMachInt 1)) []) + +tryPrimOp SeqOp args@[Type ty, Var var] + | isEvaluated (getIdUnfolding var) = Just (Con (Literal (mkMachInt 1)) [])) -- var is eval'd + | otherwise = Nothing -- var not eval'd +\end{code} + \begin{code} -completePrim env SeqOp [TyArg ty, LitArg lit] - = returnSmpl (Lit (mkMachInt 1)) - -completePrim env op@SeqOp args@[TyArg ty, VarArg var] - = case (lookupUnfolding env var) of - NoUnfoldingDetails -> give_up - LitForm _ -> hooray - OtherLitForm _ -> hooray - ConForm _ _ -> hooray - OtherConForm _ -> hooray - GenForm _ WhnfForm _ _ -> hooray - _ -> give_up +tryPrimOp TagToEnumOp [Type ty, Con (Literal (MachInt i _)) _] + | isEnumerationTyCon tycon = Just (Con (DataCon dc) []) + | otherwise = panic "tryPrimOp: tagToEnum# on non-enumeration type" + where tag = fromInteger i + constrs = tyConDataCons tycon + (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc ] + (Just (tycon,_)) = splitTyConApp_maybe ty + +tryPrimOp DataToTagOp [Type ty, Con (DataCon dc) _] + = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) []) +tryPrimOp DataToTagOp [Type ty, Var x] + | unfolding_is_constr + = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) []) where - give_up = returnSmpl (Prim op args) - hooray = returnSmpl (Lit (mkMachInt 1)) + unfolding = getIdUnfolding var + CoreUnfolding form guidance unf_template = unfolding + unfolding_is_constr = case unf_template of + Con con@(DataCon _) _ -> conOkForAlt con + other -> False + Con (DataCon dc) con_args = unf_template \end{code} \begin{code} -completePrim env op args +tryPrimOp op args = case args of - [LitArg (MachChar char_lit)] -> oneCharLit op char_lit - [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit) + [Con (Literal (MachChar char_lit)) _] -> oneCharLit op char_lit + [Con (Literal (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 + [Con (Literal (MachFloat float_lit)) _] -> oneFloatLit op float_lit + [Con (Literal (MachDouble double_lit)) _] -> oneDoubleLit op double_lit + [Con (Literal other_lit) _] -> oneLit op other_lit - [LitArg (MachChar char_lit1), - LitArg (MachChar char_lit2)] -> twoCharLits op char_lit1 char_lit2 + [Con (Literal (MachChar char_lit1)) _, + Con (Literal (MachChar char_lit2)) _] -> twoCharLits op char_lit1 char_lit2 - [LitArg (MachInt int_lit1 True), -- both *signed* literals - LitArg (MachInt int_lit2 True)] -> twoIntLits op int_lit1 int_lit2 + [Con (Literal (MachInt int_lit1 True)) _, -- both *signed* literals + Con (Literal (MachInt int_lit2 True)) _] -> twoIntLits op int_lit1 int_lit2 - [LitArg (MachInt int_lit1 False), -- both *unsigned* literals - LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2 + [Con (Literal (MachInt int_lit1 False)) _, -- both *unsigned* literals + Con (Literal (MachInt int_lit2 False)) _] -> twoWordLits 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 + [Con (Literal (MachInt int_lit1 False)) _, -- unsigned+signed (shift ops) + Con (Literal (MachInt int_lit2 True)) _] -> oneWordOneIntLit op int_lit1 int_lit2 - [LitArg (MachFloat float_lit1), - LitArg (MachFloat float_lit2)] -> twoFloatLits op float_lit1 float_lit2 + [Con (Literal (MachFloat float_lit1)) _, + Con (Literal (MachFloat float_lit2)) _] -> twoFloatLits op float_lit1 float_lit2 - [LitArg (MachDouble double_lit1), - LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2 + [Con (Literal (MachDouble double_lit1)) _, + Con (Literal (MachDouble double_lit2)) _] -> twoDoubleLits op double_lit1 double_lit2 - [LitArg lit, VarArg var] -> litVar op lit var - [VarArg var, LitArg lit] -> litVar op lit var + [Con (Literal lit) _, Var var] -> litVar op lit var + [Var var, Con (Literal lit) _] -> litVar op lit var - other -> give_up + other -> give_up where - give_up = returnSmpl (Prim op args) + give_up = Nothing - 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_char c = Just (Con (Literal (MachChar c)) []) + return_int i = Just (Con (Literal (mkMachInt i)) []) + return_word i = Just (Con (Literal (mkMachWord i)) []) + return_float f = Just (Con (Literal (MachFloat f)) []) + return_double d = Just (Con (Literal (MachDouble d)) []) + return_lit lit = Just (Con (Literal lit) []) - return_bool True = returnSmpl trueVal - return_bool False = returnSmpl falseVal + return_bool True = Just trueVal + return_bool False = Just falseVal return_prim_case var lit val_if_eq val_if_neq - = newId (idType var) `thenSmpl` \ unused_binder -> - let - result - = Case (Var var) - (PrimAlts [(lit,val_if_eq)] - (BindDefault unused_binder val_if_neq)) - in - returnSmpl result + = Just (Case (Var var) var [(Literal lit, [], val_if_eq), + (DEFAULT, [], val_if_neq)]) --------- Ints -------------- oneIntLit IntNegOp i = return_int (-i) @@ -173,9 +183,9 @@ completePrim env op args -- oneWordLit NotOp w = ??? ToDo: sort-of a pain oneWordLit _ _ = {-trace "oneIntLit: giving up"-} give_up - twoIntLits IntAddOp i1 i2 = return_int (i1+i2) - twoIntLits IntSubOp i1 i2 = return_int (i1-i2) - twoIntLits IntMulOp i1 i2 = return_int (i1*i2) + twoIntLits IntAddOp i1 i2 = checkRange (i1+i2) + twoIntLits IntSubOp i1 i2 = checkRange (i1-i2) + twoIntLits IntMulOp i1 i2 = checkRange (i1*i2) twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2) twoIntLits IntRemOp i1 i2 | i2 /= 0 = return_int (i1 `rem` i2) twoIntLits IntGtOp i1 i2 = return_bool (i1 > i2) @@ -201,22 +211,7 @@ completePrim env op args --------- 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 + -- hard to do float ops in Rationals ?? (WDP 94/10) ToDo oneFloatLit _ _ = give_up twoFloatLits FloatGtOp f1 f2 = return_bool (f1 > f2) @@ -260,7 +255,7 @@ completePrim env op args twoCharLits _ _ _ = give_up --------- Miscellaneous -------------- - oneLit Addr2IntOp (MachAddr i) = return_int i + oneLit Addr2IntOp (MachAddr i) = return_int (fromInteger i) oneLit op lit = give_up --------- Equality and inequality for Int/Char -------------- @@ -290,6 +285,17 @@ completePrim env op args litVar other_op lit var = give_up -trueVal = Con trueDataCon [] -falseVal = Con falseDataCon [] + checkRange :: Integer -> Maybe CoreExpr + checkRange val + | (val > fromInt maxInt) || (val < fromInt minInt) = + -- Better tell the user that we've overflowed... + pprTrace "Warning:" (text "Integer overflow in expression: " <> + ppr ((mkPrimApp op args)::CoreExpr)) $ + -- ..not that it stops us from actually folding! + -- ToDo: a SrcLoc would be nice. + return_int val + | otherwise = return_int val + +trueVal = Con (DataCon trueDataCon) [] +falseVal = Con (DataCon falseDataCon) [] \end{code}