X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=236cee6074c2df0a18f2028140dc0b9dffc12a60;hb=72462499b891d5779c19f3bda03f96e24f9554ae;hp=2555dcc3eb4c6b1b15f98b88a687cebb6a8761c6;hpb=934a8cdc2b593acdda1263a737aeadfaa029a478;p=ghc-hetmet.git diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 2555dcc..236cee6 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -20,7 +20,8 @@ module PrelRules ( primOpRules, builtinRules ) where #include "HsVersions.h" import CoreSyn -import Id ( mkWildId, idUnfolding ) +import MkCore ( mkWildCase ) +import Id ( idUnfolding ) import Literal ( Literal(..), mkMachInt, mkMachWord , literalType , word2IntLit, int2WordLit @@ -34,7 +35,8 @@ import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) -import CoreUtils ( cheapEqExpr, exprIsConApp_maybe ) +import CoreUtils ( cheapEqExpr ) +import CoreUnfold ( exprIsConApp_maybe ) import Type ( tyConAppTyCon, coreEqType ) import OccName ( occNameFS ) import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, @@ -44,6 +46,8 @@ import Name ( Name, nameOccName ) import Outputable import FastString import StaticFlags ( opt_SimplExcessPrecision ) +import Constants + import Data.Bits as Bits import Data.Word ( Word ) \end{code} @@ -340,7 +344,7 @@ litEq op_name is_eq rule_fn _ = Nothing do_lit_eq lit expr - = Just (Case expr (mkWildId (literalType lit)) boolTy + = Just (mkWildCase expr (literalType lit) boolTy [(DEFAULT, [], val_if_neq), (LitAlt lit, [], val_if_eq)]) val_if_eq | is_eq = trueVal @@ -352,14 +356,14 @@ litEq op_name is_eq -- runtime either, and compilation of completely harmless things like -- ((124076834 :: Word32) + (2147483647 :: Word32)) -- would yield a warning. Instead we simply squash the value into the --- Int range, but not in a way suitable for cross-compiling... :-( +-- *target* Int/Word range. intResult :: Integer -> Maybe CoreExpr intResult result - = Just (mkIntVal (toInteger (fromInteger result :: Int))) + = Just (mkIntVal (toInteger (fromInteger result :: TargetInt))) wordResult :: Integer -> Maybe CoreExpr wordResult result - = Just (mkWordVal (toInteger (fromInteger result :: Word))) + = Just (mkWordVal (toInteger (fromInteger result :: TargetWord))) \end{code} @@ -454,7 +458,7 @@ dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] = Just tag -- dataToTag (tagToEnum x) ==> x dataToTagRule [_, val_arg] - | Just (dc,_) <- exprIsConApp_maybe val_arg + | Just (dc,_,_) <- exprIsConApp_maybe val_arg = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) @@ -564,4 +568,4 @@ match_inline (Type _ : e : _) = Just (mkApps unf args1) match_inline _ = Nothing -\end{code} +\end{code}