%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[ConFold]{Constant Folder}
(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
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)
-- 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)
--------- 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)
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 --------------
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}
projects / ghc-hetmet.git / blobdiff