X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=1515fb982725041fa0e0fde0af8a4d858a9850d4;hb=ecfe3ca0242abe90128375c1b6666f505b0acd52;hp=67eb06f9d975514ece9902170ddf40c3ce6e6d8e;hpb=7e8cba32c6f045dde3db8a9ddc9831ec8ab4ed43;p=ghc-hetmet.git diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 67eb06f..1515fb9 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -21,7 +21,7 @@ module PrelRules ( primOpRules, builtinRules ) where import CoreSyn import MkCore ( mkWildCase ) -import Id ( idUnfolding ) +import Id ( realIdUnfolding ) import Literal ( Literal(..), mkMachInt, mkMachWord , literalType , word2IntLit, int2WordLit @@ -35,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, @@ -45,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} @@ -353,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} @@ -455,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))) @@ -548,7 +551,7 @@ match_eq_string _ = Nothing --------------------------------------------------- -- The rule is this: -- inline f_ty (f a b c) = a b c --- (if f has an unfolding) +-- (if f has an unfolding, EVEN if it's a loop breaker) -- -- It's important to allow the argument to 'inline' to have args itself -- (a) because its more forgiving to allow the programmer to write @@ -561,7 +564,7 @@ match_eq_string _ = Nothing match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) match_inline (Type _ : e : _) | (Var f, args1) <- collectArgs e, - Just unf <- maybeUnfoldingTemplate (idUnfolding f) + Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) = Just (mkApps unf args1) match_inline _ = Nothing