diff options
24 files changed, 399 insertions, 306 deletions
diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index 8fbcbb7a88..220ef9edd1 100644 --- a/compiler/basicTypes/Literal.lhs +++ b/compiler/basicTypes/Literal.lhs @@ -52,6 +52,7 @@ import FastString import BasicTypes import Binary import Constants +import DynFlags import UniqFM import Util @@ -216,14 +217,14 @@ instance Ord Literal where ~~~~~~~~~~~~ \begin{code} -- | Creates a 'Literal' of type @Int#@ -mkMachInt :: Integer -> Literal -mkMachInt x = ASSERT2( inIntRange x, integer x ) - MachInt x +mkMachInt :: DynFlags -> Integer -> Literal +mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x ) + MachInt x -- | Creates a 'Literal' of type @Word#@ -mkMachWord :: Integer -> Literal -mkMachWord x = ASSERT2( inWordRange x, integer x ) - MachWord x +mkMachWord :: DynFlags -> Integer -> Literal +mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x ) + MachWord x -- | Creates a 'Literal' of type @Int64#@ mkMachInt64 :: Integer -> Literal @@ -254,9 +255,9 @@ mkMachString s = MachStr (fastStringToFastBytes $ mkFastString s) mkLitInteger :: Integer -> Type -> Literal mkLitInteger = LitInteger -inIntRange, inWordRange :: Integer -> Bool -inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT -inWordRange x = x >= 0 && x <= tARGET_MAX_WORD +inIntRange, inWordRange :: DynFlags -> Integer -> Bool +inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags +inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags inCharRange :: Char -> Bool inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR @@ -275,23 +276,23 @@ isZeroLit _ = False Coercions ~~~~~~~~~ \begin{code} -word2IntLit, int2WordLit, - narrow8IntLit, narrow16IntLit, narrow32IntLit, +narrow8IntLit, narrow16IntLit, narrow32IntLit, narrow8WordLit, narrow16WordLit, narrow32WordLit, char2IntLit, int2CharLit, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, float2DoubleLit, double2FloatLit :: Literal -> Literal -word2IntLit (MachWord w) - | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1) - | otherwise = MachInt w -word2IntLit l = pprPanic "word2IntLit" (ppr l) +word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal +word2IntLit dflags (MachWord w) + | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1) + | otherwise = MachInt w +word2IntLit _ l = pprPanic "word2IntLit" (ppr l) -int2WordLit (MachInt i) - | i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD +int2WordLit dflags (MachInt i) + | i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD | otherwise = MachWord i -int2WordLit l = pprPanic "int2WordLit" (ppr l) +int2WordLit _ l = pprPanic "int2WordLit" (ppr l) narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8)) narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l) @@ -343,11 +344,11 @@ litIsTrivial _ = True -- | True if code space does not go bad if we duplicate this literal -- Currently we treat it just like 'litIsTrivial' -litIsDupable :: Literal -> Bool +litIsDupable :: DynFlags -> Literal -> Bool -- c.f. CoreUtils.exprIsDupable -litIsDupable (MachStr _) = False -litIsDupable (LitInteger i _) = inIntRange i -litIsDupable _ = True +litIsDupable _ (MachStr _) = False +litIsDupable dflags (LitInteger i _) = inIntRange dflags i +litIsDupable _ _ = True litFitsInChar :: Literal -> Bool litFitsInChar (MachInt i) diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 0bd199ff18..fda2bccf9a 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -471,7 +471,7 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) cpeRhsE env (Lit (LitInteger i _)) - = cpeRhsE env (cvtLitInteger (getMkIntegerId env) i) + = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env) i) cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr @@ -521,16 +521,16 @@ cpeRhsE env (Case scrut bndr ty alts) ; rhs' <- cpeBodyNF env2 rhs ; return (con, bs', rhs') } -cvtLitInteger :: Id -> Integer -> CoreExpr +cvtLitInteger :: DynFlags -> Id -> Integer -> CoreExpr -- Here we convert a literal Integer to the low-level -- represenation. Exactly how we do this depends on the -- library that implements Integer. If it's GMP we -- use the S# data constructor for small literals. -- See Note [Integer literals] in Literal -cvtLitInteger mk_integer i +cvtLitInteger dflags mk_integer i | cIntegerLibraryType == IntegerGMP - , inIntRange i -- Special case for small integers in GMP - = mkConApp integerGmpSDataCon [Lit (mkMachInt i)] + , inIntRange dflags i -- Special case for small integers in GMP + = mkConApp integerGmpSDataCon [Lit (mkMachInt dflags i)] | otherwise = mkApps (Var mk_integer) [isNonNegative, ints] @@ -540,7 +540,7 @@ cvtLitInteger mk_integer i f 0 = [] f x = let low = x .&. mask high = x `shiftR` bits - in mkConApp intDataCon [Lit (mkMachInt low)] : f high + in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high bits = 31 mask = 2 ^ bits - 1 diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index e9a044e951..2fb5aafd61 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -1118,23 +1118,23 @@ mkConApp con args = mkApps (Var (dataConWorkId con)) args -- | Create a machine integer literal expression of type @Int#@ from an @Integer@. -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' -mkIntLit :: Integer -> Expr b +mkIntLit :: DynFlags -> Integer -> Expr b -- | Create a machine integer literal expression of type @Int#@ from an @Int@. -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' -mkIntLitInt :: Int -> Expr b +mkIntLitInt :: DynFlags -> Int -> Expr b -mkIntLit n = Lit (mkMachInt n) -mkIntLitInt n = Lit (mkMachInt (toInteger n)) +mkIntLit dflags n = Lit (mkMachInt dflags n) +mkIntLitInt dflags n = Lit (mkMachInt dflags (toInteger n)) -- | Create a machine word literal expression of type @Word#@ from an @Integer@. -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' -mkWordLit :: Integer -> Expr b +mkWordLit :: DynFlags -> Integer -> Expr b -- | Create a machine word literal expression of type @Word#@ from a @Word@. -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' -mkWordLitWord :: Word -> Expr b +mkWordLitWord :: DynFlags -> Word -> Expr b -mkWordLit w = Lit (mkMachWord w) -mkWordLitWord w = Lit (mkMachWord (toInteger w)) +mkWordLit dflags w = Lit (mkMachWord dflags w) +mkWordLitWord dflags w = Lit (mkMachWord dflags (toInteger w)) mkWord64LitWord64 :: Word64 -> Expr b mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w)) diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index f15c648694..cad80128b9 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -64,6 +64,7 @@ import TyCon import Unique import Outputable import TysPrim +import DynFlags import FastString import Maybes import Platform @@ -602,8 +603,8 @@ Note [exprIsDupable] \begin{code} -exprIsDupable :: CoreExpr -> Bool -exprIsDupable e +exprIsDupable :: DynFlags -> CoreExpr -> Bool +exprIsDupable dflags e = isJust (go dupAppSize e) where go :: Int -> CoreExpr -> Maybe Int @@ -613,7 +614,7 @@ exprIsDupable e go n (Tick _ e) = go n e go n (Cast e _) = go n e go n (App f a) | Just n' <- go n a = go n' f - go n (Lit lit) | litIsDupable lit = decrement n + go n (Lit lit) | litIsDupable dflags lit = decrement n go _ _ = Nothing decrement :: Int -> Maybe Int diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index 0857cd556e..e903ab2084 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -84,6 +84,7 @@ import BasicTypes import Util import Pair import Constants +import DynFlags import Data.Char ( ord ) import Data.List @@ -233,20 +234,20 @@ mkCoreLams = mkLams \begin{code} -- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExpr :: Integer -> CoreExpr -- Result = I# i :: Int -mkIntExpr i = mkConApp intDataCon [mkIntLit i] +mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int +mkIntExpr dflags i = mkConApp intDataCon [mkIntLit dflags i] -- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExprInt :: Int -> CoreExpr -- Result = I# i :: Int -mkIntExprInt i = mkConApp intDataCon [mkIntLitInt i] +mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int +mkIntExprInt dflags i = mkConApp intDataCon [mkIntLitInt dflags i] -- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value -mkWordExpr :: Integer -> CoreExpr -mkWordExpr w = mkConApp wordDataCon [mkWordLit w] +mkWordExpr :: DynFlags -> Integer -> CoreExpr +mkWordExpr dflags w = mkConApp wordDataCon [mkWordLit dflags w] -- | Create a 'CoreExpr' which will evaluate to the given @Word@ -mkWordExprWord :: Word -> CoreExpr -mkWordExprWord w = mkConApp wordDataCon [mkWordLitWord w] +mkWordExprWord :: DynFlags -> Word -> CoreExpr +mkWordExprWord dflags w = mkConApp wordDataCon [mkWordLitWord dflags w] -- | Create a 'CoreExpr' which will evaluate to the given @Integer@ mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index e02ef7b385..b5e38c8af2 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -149,11 +149,12 @@ unboxArg arg -- Booleans | Just tc <- tyConAppTyCon_maybe arg_ty, tc `hasKey` boolTyConKey - = do prim_arg <- newSysLocalDs intPrimTy + = do dflags <- getDynFlags + prim_arg <- newSysLocalDs intPrimTy return (Var prim_arg, \ body -> Case (mkWildCase arg arg_ty intPrimTy - [(DataAlt falseDataCon,[],mkIntLit 0), - (DataAlt trueDataCon, [],mkIntLit 1)]) + [(DataAlt falseDataCon,[],mkIntLit dflags 0), + (DataAlt trueDataCon, [],mkIntLit dflags 1)]) -- In increasing tag order! prim_arg (exprType body) @@ -335,11 +336,13 @@ resultWrapper result_ty -- Base case 3: the boolean type | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey - = return + = do + dflags <- getDynFlags + return (Just intPrimTy, \e -> mkWildCase e intPrimTy boolTy - [(DEFAULT ,[],Var trueDataConId ), - (LitAlt (mkMachInt 0),[],Var falseDataConId)]) + [(DEFAULT ,[],Var trueDataConId ), + (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)]) -- Recursive newtypes | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index cc6b6afada..0cf4b97159 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -430,7 +430,7 @@ dsFExportDynamic id co0 cconv = do to be entered using an external calling convention (stdcall, ccall). -} - adj_args = [ mkIntLitInt (ccallConvToInt cconv) + adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv) , Var stbl_value , Lit (MachLabel fe_nm mb_sz_args IsFunction) , Lit (mkMachString typestring) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 874f8b0f41..15dab47ca1 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -62,6 +62,7 @@ import Unique import BasicTypes import Outputable import Bag +import DynFlags import FastString import ForeignCall import MonadUtils @@ -798,7 +799,8 @@ repTy (HsTyLit lit) = do repTy ty = notHandled "Exotic form of type" (ppr ty) repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ) -repTyLit (HsNumTy i) = rep2 numTyLitName [mkIntExpr i] +repTyLit (HsNumTy i) = do dflags <- getDynFlags + rep2 numTyLitName [mkIntExpr dflags i] repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s ; rep2 strTyLitName [s'] } @@ -1730,11 +1732,13 @@ repNamedTyCon (MkC s) = rep2 conTName [s] repTupleTyCon :: Int -> DsM (Core TH.TypeQ) -- Note: not Core Int; it's easier to be direct here -repTupleTyCon i = rep2 tupleTName [mkIntExprInt i] +repTupleTyCon i = do dflags <- getDynFlags + rep2 tupleTName [mkIntExprInt dflags i] repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ) -- Note: not Core Int; it's easier to be direct here -repUnboxedTupleTyCon i = rep2 unboxedTupleTName [mkIntExprInt i] +repUnboxedTupleTyCon i = do dflags <- getDynFlags + rep2 unboxedTupleTName [mkIntExprInt dflags i] repArrowTyCon :: DsM (Core TH.TypeQ) repArrowTyCon = rep2 arrowTName [] @@ -1746,7 +1750,8 @@ repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) repPromotedTyCon (MkC s) = rep2 promotedTName [s] repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ) -repPromotedTupleTyCon i = rep2 promotedTupleTName [mkIntExprInt i] +repPromotedTupleTyCon i = do dflags <- getDynFlags + rep2 promotedTupleTName [mkIntExprInt dflags i] repPromotedNilTyCon :: DsM (Core TH.TypeQ) repPromotedNilTyCon = rep2 promotedNilTName [] @@ -1769,7 +1774,8 @@ repKCon :: Core TH.Name -> DsM (Core TH.Kind) repKCon (MkC s) = rep2 conKName [s] repKTuple :: Int -> DsM (Core TH.Kind) -repKTuple i = rep2 tupleKName [mkIntExprInt i] +repKTuple i = do dflags <- getDynFlags + rep2 tupleKName [mkIntExprInt dflags i] repKArrow :: DsM (Core TH.Kind) repKArrow = rep2 arrowKName [] @@ -1878,7 +1884,8 @@ coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } ------------ Literals & Variables ------------------- coreIntLit :: Int -> DsM (Core Int) -coreIntLit i = return (MkC (mkIntExprInt i)) +coreIntLit i = do dflags <- getDynFlags + return (MkC (mkIntExprInt dflags i)) coreVar :: Id -> Core TH.Name -- The Id has type Name coreVar id = MkC (Var id) diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 52944e8347..0053484b13 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -308,11 +308,12 @@ mkCoPrimCaseMatchResult var ty match_alts mkCoAlgCaseMatchResult - :: Id -- Scrutinee + :: DynFlags + -> Id -- Scrutinee -> Type -- Type of exp -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts) -> MatchResult -mkCoAlgCaseMatchResult var ty match_alts +mkCoAlgCaseMatchResult dflags var ty match_alts | isNewTyCon tycon -- Newtype case; use a let = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 @@ -423,7 +424,7 @@ mkCoAlgCaseMatchResult var ty match_alts lit = MachInt $ toInteger (dataConSourceArity con) binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args] -- - indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i] + indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i] \end{code} %************************************************************************ diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 8fd3a203f3..adb9099c14 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -292,12 +292,13 @@ match [] ty eqns match vars@(v:_) ty eqns = ASSERT( not (null eqns ) ) - do { -- Tidy the first pattern, generating + do { dflags <- getDynFlags + ; -- Tidy the first pattern, generating -- auxiliary bindings if necessary (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns -- Group the equations and match each group in turn - ; let grouped = groupEquations tidy_eqns + ; let grouped = groupEquations dflags tidy_eqns -- print the view patterns that are commoned up to help debug ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped) @@ -787,13 +788,13 @@ data PatGroup -- the LHsExpr is the expression e Type -- the Type is the type of p (equivalently, the result type of e) -groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] +groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]] -- If the result is of form [g1, g2, g3], -- (a) all the (pg,eq) pairs in g1 have the same pg -- (b) none of the gi are empty -- The ordering of equations is unchanged -groupEquations eqns - = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns] +groupEquations dflags eqns + = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns] where same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 @@ -948,16 +949,16 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_co (TcTyConAppCo tc1 cos1) (TcTyConAppCo tc2 cos2) = tc1==tc2 && eq_list eq_co cos1 cos2 eq_co _ _ = False -patGroup :: Pat Id -> PatGroup -patGroup (WildPat {}) = PgAny -patGroup (BangPat {}) = PgBang -patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) -patGroup (LitPat lit) = PgLit (hsLitKey lit) -patGroup (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) -patGroup (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) -patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern -patGroup (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) -patGroup pat = pprPanic "patGroup" (ppr pat) +patGroup :: DynFlags -> Pat Id -> PatGroup +patGroup _ (WildPat {}) = PgAny +patGroup _ (BangPat {}) = PgBang +patGroup _ (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) +patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) +patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) +patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern +patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) +patGroup _ pat = pprPanic "patGroup" (ppr pat) \end{code} Note [Grouping overloaded literal patterns] diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index e1b2ef83df..10270e50ca 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -31,6 +31,7 @@ import ListSetOps ( runs ) import Id import NameEnv import SrcLoc +import DynFlags import Outputable import Control.Monad(liftM) \end{code} @@ -92,8 +93,9 @@ matchConFamily :: [Id] -> DsM MatchResult -- Each group of eqns is for a single constructor matchConFamily (var:vars) ty groups - = do { alts <- mapM (matchOneCon vars ty) groups - ; return (mkCoAlgCaseMatchResult var ty alts) } + = do dflags <- getDynFlags + alts <- mapM (matchOneCon vars ty) groups + return (mkCoAlgCaseMatchResult dflags var ty alts) matchConFamily [] _ _ = panic "matchConFamily []" type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id)) diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 4032093541..69d46c2096 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -42,6 +42,7 @@ import Data.Ratio import MonadUtils import Outputable import BasicTypes +import DynFlags import Util import FastString \end{code} @@ -81,7 +82,8 @@ dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) dsLit (HsChar c) = return (mkCharExpr c) dsLit (HsString str) = mkStringExprFS str dsLit (HsInteger i _) = mkIntegerExpr i -dsLit (HsInt i) = return (mkIntExpr i) +dsLit (HsInt i) = do dflags <- getDynFlags + return (mkIntExpr dflags i) dsLit (HsRat r ty) = do num <- mkIntegerExpr (numerator (fl_value r)) @@ -95,12 +97,16 @@ dsLit (HsRat r ty) = do x -> pprPanic "dsLit" (ppr x) dsOverLit :: HsOverLit Id -> DsM CoreExpr +dsOverLit lit = do dflags <- getDynFlags + dsOverLit' dflags lit + +dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr -- Post-typechecker, the SyntaxExpr field of an OverLit contains -- (an expression for) the literal value itself -dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable - , ol_witness = witness, ol_type = ty }) +dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable + , ol_witness = witness, ol_type = ty }) | not rebindable - , Just expr <- shortCutLit val ty = dsExpr expr -- Note [Literal short cut] + , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut] | otherwise = dsExpr witness \end{code} @@ -113,22 +119,22 @@ much better do do so. \begin{code} -hsLitKey :: HsLit -> Literal +hsLitKey :: DynFlags -> HsLit -> Literal -- Get a Core literal to use (only) a grouping key -- Hence its type doesn't need to match the type of the original literal -- (and doesn't for strings) -- It only works for primitive types and strings; -- others have been removed by tidy -hsLitKey (HsIntPrim i) = mkMachInt i -hsLitKey (HsWordPrim w) = mkMachWord w -hsLitKey (HsInt64Prim i) = mkMachInt64 i -hsLitKey (HsWord64Prim w) = mkMachWord64 w -hsLitKey (HsCharPrim c) = MachChar c -hsLitKey (HsStringPrim s) = MachStr s -hsLitKey (HsFloatPrim f) = MachFloat (fl_value f) -hsLitKey (HsDoublePrim d) = MachDouble (fl_value d) -hsLitKey (HsString s) = MachStr (fastStringToFastBytes s) -hsLitKey l = pprPanic "hsLitKey" (ppr l) +hsLitKey dflags (HsIntPrim i) = mkMachInt dflags i +hsLitKey dflags (HsWordPrim w) = mkMachWord dflags w +hsLitKey _ (HsInt64Prim i) = mkMachInt64 i +hsLitKey _ (HsWord64Prim w) = mkMachWord64 w +hsLitKey _ (HsCharPrim c) = MachChar c +hsLitKey _ (HsStringPrim s) = MachStr s +hsLitKey _ (HsFloatPrim f) = MachFloat (fl_value f) +hsLitKey _ (HsDoublePrim d) = MachDouble (fl_value d) +hsLitKey _ (HsString s) = MachStr (fastStringToFastBytes s) +hsLitKey _ l = pprPanic "hsLitKey" (ppr l) hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal -- Ditto for HsOverLit; the boolean indicates to negate @@ -247,9 +253,10 @@ matchLiterals (var:vars) ty sub_groups where match_group :: [EquationInfo] -> DsM (Literal, MatchResult) match_group eqns - = do { let LitPat hs_lit = firstPat (head eqns) - ; match_result <- match vars ty (shiftEqns eqns) - ; return (hsLitKey hs_lit, match_result) } + = do dflags <- getDynFlags + let LitPat hs_lit = firstPat (head eqns) + match_result <- match vars ty (shiftEqns eqns) + return (hsLitKey dflags hs_lit, match_result) wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult -- Equality check for string literals diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index d4c3d535d6..70ade2ad78 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -122,6 +122,7 @@ module DynFlags ( wORD_SIZE_IN_BITS, tAG_MASK, mAX_PTR_TAG, + tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD, ) where #include "HsVersions.h" @@ -155,11 +156,13 @@ import Control.Monad import Data.Bits import Data.Char +import Data.Int import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set +import Data.Word import System.FilePath import System.IO @@ -3162,3 +3165,21 @@ tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 mAX_PTR_TAG :: DynFlags -> Int mAX_PTR_TAG = tAG_MASK +-- Might be worth caching these in targetPlatform? +tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer +tARGET_MIN_INT dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (minBound :: Int32) + 8 -> toInteger (minBound :: Int64) + w -> panic ("tARGET_MIN_INT: Unknown platformWordSize: " ++ show w) +tARGET_MAX_INT dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (maxBound :: Int32) + 8 -> toInteger (maxBound :: Int64) + w -> panic ("tARGET_MAX_INT: Unknown platformWordSize: " ++ show w) +tARGET_MAX_WORD dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (maxBound :: Word32) + 8 -> toInteger (maxBound :: Word64) + w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w) + diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index ffd5de809d..309f2e2d9b 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -1238,7 +1238,7 @@ hasCafRefs dflags this_pkg p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where - mentions_cafs = isFastTrue (cafRefsE p expr) + mentions_cafs = isFastTrue (cafRefsE dflags p expr) is_dynamic_name = isDllName dflags this_pkg is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr) @@ -1248,28 +1248,28 @@ hasCafRefs dflags this_pkg p arity expr -- CorePrep later on, and we don't want to duplicate that -- knowledge in rhsIsStatic below. -cafRefsE :: (Id, VarEnv Id) -> Expr a -> FastBool -cafRefsE p (Var id) = cafRefsV p id -cafRefsE p (Lit lit) = cafRefsL p lit -cafRefsE p (App f a) = fastOr (cafRefsE p f) (cafRefsE p) a -cafRefsE p (Lam _ e) = cafRefsE p e -cafRefsE p (Let b e) = fastOr (cafRefsEs p (rhssOfBind b)) (cafRefsE p) e -cafRefsE p (Case e _bndr _ alts) = fastOr (cafRefsE p e) (cafRefsEs p) (rhssOfAlts alts) -cafRefsE p (Tick _n e) = cafRefsE p e -cafRefsE p (Cast e _co) = cafRefsE p e -cafRefsE _ (Type _) = fastBool False -cafRefsE _ (Coercion _) = fastBool False - -cafRefsEs :: (Id, VarEnv Id) -> [Expr a] -> FastBool -cafRefsEs _ [] = fastBool False -cafRefsEs p (e:es) = fastOr (cafRefsE p e) (cafRefsEs p) es - -cafRefsL :: (Id, VarEnv Id) -> Literal -> FastBool +cafRefsE :: DynFlags -> (Id, VarEnv Id) -> Expr a -> FastBool +cafRefsE _ p (Var id) = cafRefsV p id +cafRefsE dflags p (Lit lit) = cafRefsL dflags p lit +cafRefsE dflags p (App f a) = fastOr (cafRefsE dflags p f) (cafRefsE dflags p) a +cafRefsE dflags p (Lam _ e) = cafRefsE dflags p e +cafRefsE dflags p (Let b e) = fastOr (cafRefsEs dflags p (rhssOfBind b)) (cafRefsE dflags p) e +cafRefsE dflags p (Case e _bndr _ alts) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) (rhssOfAlts alts) +cafRefsE dflags p (Tick _n e) = cafRefsE dflags p e +cafRefsE dflags p (Cast e _co) = cafRefsE dflags p e +cafRefsE _ _ (Type _) = fastBool False +cafRefsE _ _ (Coercion _) = fastBool False + +cafRefsEs :: DynFlags -> (Id, VarEnv Id) -> [Expr a] -> FastBool +cafRefsEs _ _ [] = fastBool False +cafRefsEs dflags p (e:es) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) es + +cafRefsL :: DynFlags -> (Id, VarEnv Id) -> Literal -> FastBool -- Don't forget that mk_integer id might have Caf refs! -- We first need to convert the Integer into its final form, to -- see whether mkInteger is used. -cafRefsL p@(mk_integer, _) (LitInteger i _) = cafRefsE p (cvtLitInteger mk_integer i) -cafRefsL _ _ = fastBool False +cafRefsL dflags p@(mk_integer, _) (LitInteger i _) = cafRefsE dflags p (cvtLitInteger dflags mk_integer i) +cafRefsL _ _ _ = fastBool False cafRefsV :: (Id, VarEnv Id) -> Id -> FastBool cafRefsV (_, p) id diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 2e09e03446..0d4229fb7b 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -80,60 +80,61 @@ primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ] -- Int operations primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) - , identity zeroi ] + , identityDynFlags zeroi ] primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) - , rightIdentity zeroi - , equalArgs >> return (Lit zeroi) ] + , rightIdentityDynFlags zeroi + , equalArgs >> retLit zeroi ] primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) , zeroElem zeroi - , identity onei ] + , identityDynFlags onei ] primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) , leftZero zeroi - , rightIdentity onei - , equalArgs >> return (Lit onei) ] + , rightIdentityDynFlags onei + , equalArgs >> retLit onei ] primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) , leftZero zeroi , do l <- getLiteral 1 - guard (l == onei) - return (Lit zeroi) - , equalArgs >> return (Lit zeroi) - , equalArgs >> return (Lit zeroi) ] + dflags <- getDynFlags + guard (l == onei dflags) + retLit zeroi + , equalArgs >> retLit zeroi + , equalArgs >> retLit zeroi ] primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp ] primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL) - , rightIdentity zeroi ] + , rightIdentityDynFlags zeroi ] primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR) - , rightIdentity zeroi ] + , rightIdentityDynFlags zeroi ] primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 shiftRightLogical) - , rightIdentity zeroi ] + , rightIdentityDynFlags zeroi ] -- Word operations primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) - , identity zerow ] + , identityDynFlags zerow ] primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) - , rightIdentity zerow - , equalArgs >> return (Lit zerow) ] + , rightIdentityDynFlags zerow + , equalArgs >> retLit zerow ] primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) - , identity onew ] + , identityDynFlags onew ] primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) - , rightIdentity onew ] + , rightIdentityDynFlags onew ] primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) - , rightIdentity onew ] + , rightIdentityDynFlags onew ] primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) , zeroElem zerow ] primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) - , identity zerow ] + , identityDynFlags zerow ] primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) - , identity zerow - , equalArgs >> return (Lit zerow) ] + , identityDynFlags zerow + , equalArgs >> retLit zerow ] primOpRules nm SllOp = mkPrimOpRule nm 2 [ binaryLit (wordShiftOp2 Bits.shiftL) - , rightIdentity zeroi ] + , rightIdentityDynFlags zeroi ] primOpRules nm SrlOp = mkPrimOpRule nm 2 [ binaryLit (wordShiftOp2 shiftRightLogical) - , rightIdentity zeroi ] + , rightIdentityDynFlags zeroi ] -- coercions -primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLit word2IntLit +primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit , inversePrimOp Int2WordOp ] -primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLit int2WordLit +primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit , inversePrimOp Word2IntOp ] primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit ] primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit ] @@ -240,7 +241,7 @@ mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) mkRelOpRule nm cmp extra = mkPrimOpRule nm 2 $ rules ++ extra where - rules = [ binaryLit (cmpOp cmp) + rules = [ binaryLit (\_ -> cmpOp cmp) , equalArgs >> -- x `cmp` x does not depend on x, so -- compute it for the arbitrary value 'True' @@ -250,11 +251,13 @@ mkRelOpRule nm cmp extra else falseVal) ] -- common constants -zeroi, onei, zerow, onew, zerof, onef, zerod, oned :: Literal -zeroi = mkMachInt 0 -onei = mkMachInt 1 -zerow = mkMachWord 0 -onew = mkMachWord 1 +zeroi, onei, zerow, onew :: DynFlags -> Literal +zeroi dflags = mkMachInt dflags 0 +onei dflags = mkMachInt dflags 1 +zerow dflags = mkMachWord dflags 0 +onew dflags = mkMachWord dflags 1 + +zerof, onef, zerod, oned :: Literal zerof = mkMachFloat 0.0 onef = mkMachFloat 1.0 zerod = mkMachDouble 0.0 @@ -279,20 +282,20 @@ cmpOp cmp = go -------------------------- -negOp :: Literal -> Maybe CoreExpr -- Negate -negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational -negOp (MachFloat f) = Just (mkFloatVal (-f)) -negOp (MachDouble 0.0) = Nothing -negOp (MachDouble d) = Just (mkDoubleVal (-d)) -negOp (MachInt i) = intResult (-i) -negOp _ = Nothing +negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate +negOp _ (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational +negOp _ (MachFloat f) = Just (mkFloatVal (-f)) +negOp _ (MachDouble 0.0) = Nothing +negOp _ (MachDouble d) = Just (mkDoubleVal (-d)) +negOp dflags (MachInt i) = intResult dflags (-i) +negOp _ _ = Nothing -------------------------- intOp2 :: (Integral a, Integral b) => (a -> b -> Integer) - -> Literal -> Literal -> Maybe CoreExpr -intOp2 op (MachInt i1) (MachInt i2) = intResult (fromInteger i1 `op` fromInteger i2) -intOp2 _ _ _ = Nothing -- Could find LitLit + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +intOp2 op dflags (MachInt i1) (MachInt i2) = intResult dflags (fromInteger i1 `op` fromInteger i2) +intOp2 _ _ _ _ = Nothing -- Could find LitLit shiftRightLogical :: Integer -> Int -> Integer -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do @@ -302,32 +305,41 @@ shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word) -------------------------- +retLit :: (DynFlags -> Literal) -> RuleM CoreExpr +retLit l = do dflags <- getDynFlags + return $ Lit $ l dflags + wordOp2 :: (Integral a, Integral b) => (a -> b -> Integer) - -> Literal -> Literal -> Maybe CoreExpr -wordOp2 op (MachWord w1) (MachWord w2) = wordResult (fromInteger w1 `op` fromInteger w2) -wordOp2 _ _ _ = Nothing -- Could find LitLit - -wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +wordOp2 op dflags (MachWord w1) (MachWord w2) + = wordResult dflags (fromInteger w1 `op` fromInteger w2) +wordOp2 _ _ _ _ = Nothing -- Could find LitLit + +wordShiftOp2 :: (Integer -> Int -> Integer) + -> DynFlags -> Literal -> Literal + -> Maybe CoreExpr -- Shifts take an Int; hence second arg of op is Int -wordShiftOp2 op (MachWord x) (MachInt n) - = wordResult (x `op` fromInteger n) +wordShiftOp2 op dflags (MachWord x) (MachInt n) + = wordResult dflags (x `op` fromInteger n) -- Do the shift at type Integer -wordShiftOp2 _ _ _ = Nothing +wordShiftOp2 _ _ _ _ = Nothing -------------------------- -floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal +floatOp2 :: (Rational -> Rational -> Rational) + -> DynFlags -> Literal -> Literal -> Maybe (Expr CoreBndr) -floatOp2 op (MachFloat f1) (MachFloat f2) +floatOp2 op _ (MachFloat f1) (MachFloat f2) = Just (mkFloatVal (f1 `op` f2)) -floatOp2 _ _ _ = Nothing +floatOp2 _ _ _ _ = Nothing -------------------------- -doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal +doubleOp2 :: (Rational -> Rational -> Rational) + -> DynFlags -> Literal -> Literal -> Maybe (Expr CoreBndr) -doubleOp2 op (MachDouble f1) (MachDouble f2) +doubleOp2 op _ (MachDouble f1) (MachDouble f2) = Just (mkDoubleVal (f1 `op` f2)) -doubleOp2 _ _ _ = Nothing +doubleOp2 _ _ _ _ = Nothing -------------------------- -- This stuff turns @@ -411,13 +423,13 @@ isMaxBound _ = False -- ((124076834 :: Word32) + (2147483647 :: Word32)) -- would yield a warning. Instead we simply squash the value into the -- *target* Int/Word range. -intResult :: Integer -> Maybe CoreExpr -intResult result - = Just (mkIntVal (toInteger (fromInteger result :: TargetInt))) +intResult :: DynFlags -> Integer -> Maybe CoreExpr +intResult dflags result + = Just (mkIntVal dflags (toInteger (fromInteger result :: TargetInt))) -wordResult :: Integer -> Maybe CoreExpr -wordResult result - = Just (mkWordVal (toInteger (fromInteger result :: TargetWord))) +wordResult :: DynFlags -> Integer -> Maybe CoreExpr +wordResult dflags result + = Just (mkWordVal dflags (toInteger (fromInteger result :: TargetWord))) inversePrimOp :: PrimOp -> RuleM CoreExpr inversePrimOp primop = do @@ -440,31 +452,38 @@ mkBasicRule op_name n_args rm = BuiltinRule { ru_name = occNameFS (nameOccName op_name), ru_fn = op_name, ru_nargs = n_args, - ru_try = \_ _ -> runRuleM rm } + ru_try = \dflags _ -> runRuleM rm dflags } newtype RuleM r = RuleM - { runRuleM :: IdUnfoldingFun -> [CoreExpr] -> Maybe r } + { runRuleM :: DynFlags -> IdUnfoldingFun -> [CoreExpr] -> Maybe r } instance Monad RuleM where - return x = RuleM $ \_ _ -> Just x - RuleM f >>= g = RuleM $ \iu e -> case f iu e of + return x = RuleM $ \_ _ _ -> Just x + RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of Nothing -> Nothing - Just r -> runRuleM (g r) iu e + Just r -> runRuleM (g r) dflags iu e fail _ = mzero instance MonadPlus RuleM where - mzero = RuleM $ \_ _ -> Nothing - mplus (RuleM f1) (RuleM f2) = RuleM $ \iu args -> - f1 iu args `mplus` f2 iu args + mzero = RuleM $ \_ _ _ -> Nothing + mplus (RuleM f1) (RuleM f2) = RuleM $ \dflags iu args -> + f1 dflags iu args `mplus` f2 dflags iu args + +instance HasDynFlags RuleM where + getDynFlags = RuleM $ \dflags _ _ -> Just dflags liftMaybe :: Maybe a -> RuleM a liftMaybe Nothing = mzero liftMaybe (Just x) = return x liftLit :: (Literal -> Literal) -> RuleM CoreExpr -liftLit f = do +liftLit f = liftLitDynFlags (const f) + +liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr +liftLitDynFlags f = do + dflags <- getDynFlags [Lit lit] <- getArgs - return $ Lit (f lit) + return $ Lit (f dflags lit) removeOp32 :: RuleM CoreExpr #if WORD_SIZE_IN_BITS == 32 @@ -476,56 +495,71 @@ removeOp32 = mzero #endif getArgs :: RuleM [CoreExpr] -getArgs = RuleM $ \_ args -> Just args +getArgs = RuleM $ \_ _ args -> Just args getIdUnfoldingFun :: RuleM IdUnfoldingFun -getIdUnfoldingFun = RuleM $ \iu _ -> Just iu +getIdUnfoldingFun = RuleM $ \_ iu _ -> Just iu -- return the n-th argument of this rule, if it is a literal -- argument indices start from 0 getLiteral :: Int -> RuleM Literal -getLiteral n = RuleM $ \_ exprs -> case drop n exprs of +getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of (Lit l:_) -> Just l _ -> Nothing -unaryLit :: (Literal -> Maybe CoreExpr) -> RuleM CoreExpr +unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr unaryLit op = do + dflags <- getDynFlags [Lit l] <- getArgs - liftMaybe $ op (convFloating l) + liftMaybe $ op dflags (convFloating l) -binaryLit :: (Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr binaryLit op = do + dflags <- getDynFlags [Lit l1, Lit l2] <- getArgs - liftMaybe $ convFloating l1 `op` convFloating l2 + liftMaybe $ op dflags (convFloating l1) (convFloating l2) leftIdentity :: Literal -> RuleM CoreExpr -leftIdentity id_lit = do +leftIdentity id_lit = leftIdentityDynFlags (const id_lit) + +rightIdentity :: Literal -> RuleM CoreExpr +rightIdentity id_lit = rightIdentityDynFlags (const id_lit) + +identity :: Literal -> RuleM CoreExpr +identity lit = leftIdentity lit `mplus` rightIdentity lit + +leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +leftIdentityDynFlags id_lit = do + dflags <- getDynFlags [Lit l1, e2] <- getArgs - guard $ l1 == id_lit + guard $ l1 == id_lit dflags return e2 -rightIdentity :: Literal -> RuleM CoreExpr -rightIdentity id_lit = do +rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +rightIdentityDynFlags id_lit = do + dflags <- getDynFlags [e1, Lit l2] <- getArgs - guard $ l2 == id_lit + guard $ l2 == id_lit dflags return e1 -identity :: Literal -> RuleM CoreExpr -identity lit = leftIdentity lit `mplus` rightIdentity lit +identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit -leftZero :: Literal -> RuleM CoreExpr +leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr leftZero zero = do + dflags <- getDynFlags [Lit l1, _] <- getArgs - guard $ l1 == zero - return $ Lit zero + guard $ l1 == zero dflags + return $ Lit l1 -rightZero :: Literal -> RuleM CoreExpr +rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr rightZero zero = do + dflags <- getDynFlags [_, Lit l2] <- getArgs - guard $ l2 == zero - return $ Lit zero + guard $ l2 == zero dflags + return $ Lit l2 -zeroElem :: Literal -> RuleM CoreExpr +zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr zeroElem lit = leftZero lit `mplus` rightZero lit equalArgs :: RuleM () @@ -571,10 +605,10 @@ ltVal = Var ltDataConId eqVal = Var eqDataConId gtVal = Var gtDataConId -mkIntVal :: Integer -> Expr CoreBndr -mkIntVal i = Lit (mkMachInt i) -mkWordVal :: Integer -> Expr CoreBndr -mkWordVal w = Lit (mkMachWord w) +mkIntVal :: DynFlags -> Integer -> Expr CoreBndr +mkIntVal dflags i = Lit (mkMachInt dflags i) +mkWordVal :: DynFlags -> Integer -> Expr CoreBndr +mkWordVal dflags w = Lit (mkMachWord dflags w) mkFloatVal :: Rational -> Expr CoreBndr mkFloatVal f = Lit (convFloating (MachFloat f)) mkDoubleVal :: Rational -> Expr CoreBndr @@ -649,11 +683,12 @@ dataToTagRule = a `mplus` b guard $ ty1 `eqType` ty2 return tag -- dataToTag (tagToEnum x) ==> x b = do + dflags <- getDynFlags [_, val_arg] <- getArgs id_unf <- getIdUnfoldingFun (dc,_,_) <- liftMaybe $ exprIsConApp_maybe id_unf val_arg ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () - return $ mkIntVal (toInteger (dataConTag dc - fIRST_TAG)) + return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG)) \end{code} %************************************************************************ @@ -732,8 +767,8 @@ builtinIntegerRules = rule_Word64ToInteger "word64ToInteger" word64ToIntegerName, rule_convert "integerToWord" integerToWordName mkWordLitWord, rule_convert "integerToInt" integerToIntName mkIntLitInt, - rule_convert "integerToWord64" integerToWord64Name mkWord64LitWord64, - rule_convert "integerToInt64" integerToInt64Name mkInt64LitInt64, + rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64), + rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64), rule_binop "plusInteger" plusIntegerName (+), rule_binop "minusInteger" minusIntegerName (-), rule_binop "timesInteger" timesIntegerName (*), @@ -752,10 +787,10 @@ builtinIntegerRules = rule_divop_one "quotInteger" quotIntegerName quot, rule_divop_one "remInteger" remIntegerName rem, rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, - rule_convert "floatFromInteger" floatFromIntegerName mkFloatLitFloat, + rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat), rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, - rule_convert "doubleFromInteger" doubleFromIntegerName mkDoubleLitDouble, + rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble), rule_binop "gcdInteger" gcdIntegerName gcd, rule_binop "lcmInteger" lcmIntegerName lcm, rule_binop "andInteger" andIntegerName (.&.), @@ -948,15 +983,15 @@ match_Word64ToInteger _ _ _ _ = Nothing ------------------------------------------------- match_Integer_convert :: Num a - => (a -> Expr CoreBndr) + => (DynFlags -> a -> Expr CoreBndr) -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_convert convert _ _ id_unf [xl] +match_Integer_convert convert dflags _ id_unf [xl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - = Just (convert (fromInteger x)) + = Just (convert dflags (fromInteger x)) match_Integer_convert _ _ _ _ _ = Nothing match_Integer_unop :: (Integer -> Integer) diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index ab3df0dfd0..681c183132 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -33,6 +33,7 @@ import Type ( isUnLiftedType ) import VarSet import Util import UniqFM +import DynFlags import Outputable \end{code} @@ -40,13 +41,13 @@ Top-level interface function, @floatInwards@. Note that we do not actually float any bindings downwards from the top-level. \begin{code} -floatInwards :: CoreProgram -> CoreProgram -floatInwards = map fi_top_bind +floatInwards :: DynFlags -> CoreProgram -> CoreProgram +floatInwards dflags = map fi_top_bind where fi_top_bind (NonRec binder rhs) - = NonRec binder (fiExpr [] (freeVars rhs)) + = NonRec binder (fiExpr dflags [] (freeVars rhs)) fi_top_bind (Rec pairs) - = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ] + = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ] \end{code} %************************************************************************ @@ -131,20 +132,21 @@ data FloatInBind = FB BoundVarSet FreeVarSet FloatBind type FloatInBinds = [FloatInBind] -- In reverse dependency order (innermost binder first) -fiExpr :: FloatInBinds -- Binds we're trying to drop - -- as far "inwards" as possible - -> CoreExprWithFVs -- Input expr - -> CoreExpr -- Result - -fiExpr to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit -fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty -fiExpr to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) -fiExpr to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) -fiExpr to_drop (_, AnnCast expr (fvs_co, co)) +fiExpr :: DynFlags + -> FloatInBinds -- Binds we're trying to drop + -- as far "inwards" as possible + -> CoreExprWithFVs -- Input expr + -> CoreExpr -- Result + +fiExpr _ to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit +fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty +fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) +fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) +fiExpr dflags to_drop (_, AnnCast expr (fvs_co, co)) = wrapFloats (drop_here ++ co_drop) $ - Cast (fiExpr e_drop expr) co + Cast (fiExpr dflags e_drop expr) co where - [drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop + [drop_here, e_drop, co_drop] = sepBindsByDropPoint dflags False [freeVarsOf expr, fvs_co] to_drop \end{code} Applications: we do float inside applications, mainly because we @@ -152,16 +154,16 @@ need to get at all the arguments. The next simplifier run will pull out any silly ones. \begin{code} -fiExpr to_drop (_,AnnApp fun arg@(arg_fvs, ann_arg)) +fiExpr dflags to_drop (_,AnnApp fun arg@(arg_fvs, ann_arg)) | noFloatIntoRhs ann_arg = wrapFloats drop_here $ wrapFloats arg_drop $ - App (fiExpr fun_drop fun) (fiExpr [] arg) + App (fiExpr dflags fun_drop fun) (fiExpr dflags [] arg) -- It's inconvenient to test for an unlifted arg here, -- and it really doesn't matter if we float into one | otherwise = wrapFloats drop_here $ - App (fiExpr fun_drop fun) (fiExpr arg_drop arg) + App (fiExpr dflags fun_drop fun) (fiExpr dflags arg_drop arg) where [drop_here, fun_drop, arg_drop] - = sepBindsByDropPoint False [freeVarsOf fun, arg_fvs] to_drop + = sepBindsByDropPoint dflags False [freeVarsOf fun, arg_fvs] to_drop \end{code} Note [Floating in past a lambda group] @@ -203,13 +205,13 @@ Urk! if all are tyvars, and we don't float in, we may miss an opportunity to float inside a nested case branch \begin{code} -fiExpr to_drop lam@(_, AnnLam _ _) +fiExpr dflags to_drop lam@(_, AnnLam _ _) | okToFloatInside bndrs -- Float in -- NB: Must line up with noFloatIntoRhs (AnnLam...); see Trac #7088 - = mkLams bndrs (fiExpr to_drop body) + = mkLams bndrs (fiExpr dflags to_drop body) | otherwise -- Dump it all here - = wrapFloats to_drop (mkLams bndrs (fiExpr [] body)) + = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body)) where (bndrs, body) = collectAnnBndrs lam @@ -221,13 +223,13 @@ We don't float lets inwards past an SCC. cc, change current cc to the new one and float binds into expr. \begin{code} -fiExpr to_drop (_, AnnTick tickish expr) +fiExpr dflags to_drop (_, AnnTick tickish expr) | tickishScoped tickish = -- Wimp out for now - we could push values in - wrapFloats to_drop (Tick tickish (fiExpr [] expr)) + wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr)) | otherwise - = Tick tickish (fiExpr to_drop expr) + = Tick tickish (fiExpr dflags to_drop expr) \end{code} For @Lets@, the possible ``drop points'' for the \tr{to_drop} @@ -281,8 +283,8 @@ idFreeVars. \begin{code} -fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) - = fiExpr new_to_drop body +fiExpr dflags to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) + = fiExpr dflags new_to_drop body where body_fvs = freeVarsOf body `delVarSet` id @@ -295,7 +297,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) -- Ditto ok-for-speculation unlifted RHSs [shared_binds, extra_binds, rhs_binds, body_binds] - = sepBindsByDropPoint False [extra_fvs, rhs_fvs, body_fvs] to_drop + = sepBindsByDropPoint dflags False [extra_fvs, rhs_fvs, body_fvs] to_drop new_to_drop = body_binds ++ -- the bindings used only in the body [FB (unitVarSet id) rhs_fvs' @@ -304,12 +306,12 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) shared_binds -- the bindings used both in rhs and body -- Push rhs_binds into the right hand side of the binding - rhs' = fiExpr rhs_binds rhs + rhs' = fiExpr dflags rhs_binds rhs rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds `unionVarSet` rule_fvs -- Don't forget the rule_fvs; the binding mentions them! -fiExpr to_drop (_,AnnLet (AnnRec bindings) body) - = fiExpr new_to_drop body +fiExpr dflags to_drop (_,AnnLet (AnnRec bindings) body) + = fiExpr dflags new_to_drop body where (ids, rhss) = unzip bindings rhss_fvs = map freeVarsOf rhss @@ -322,7 +324,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) , noFloatIntoRhs rhs ] (shared_binds:extra_binds:body_binds:rhss_binds) - = sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop + = sepBindsByDropPoint dflags False (extra_fvs:body_fvs:rhss_fvs) to_drop new_to_drop = body_binds ++ -- the bindings used only in the body [FB (mkVarSet ids) rhs_fvs' @@ -341,7 +343,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) -> [(Id, CoreExpr)] fi_bind to_drops pairs - = [ (binder, fiExpr to_drop rhs) + = [ (binder, fiExpr dflags to_drop rhs) | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] \end{code} @@ -358,32 +360,32 @@ alternative that binds the elements of the tuple. We now therefore also support floating in cases with a single alternative that may bind values. \begin{code} -fiExpr to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) +fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) | isUnLiftedType (idType case_bndr) , exprOkForSideEffects (deAnnotate scrut) = wrapFloats shared_binds $ - fiExpr (case_float : rhs_binds) rhs + fiExpr dflags (case_float : rhs_binds) rhs where case_float = FB (mkVarSet (case_bndr : alt_bndrs)) scrut_fvs (FloatCase scrut' case_bndr con alt_bndrs) - scrut' = fiExpr scrut_binds scrut + scrut' = fiExpr dflags scrut_binds scrut [shared_binds, scrut_binds, rhs_binds] - = sepBindsByDropPoint False [freeVarsOf scrut, rhs_fvs] to_drop + = sepBindsByDropPoint dflags False [freeVarsOf scrut, rhs_fvs] to_drop rhs_fvs = freeVarsOf rhs `delVarSetList` (case_bndr : alt_bndrs) scrut_fvs = freeVarsOf scrut -fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) +fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts) = wrapFloats drop_here1 $ wrapFloats drop_here2 $ - Case (fiExpr scrut_drops scrut) case_bndr ty + Case (fiExpr dflags scrut_drops scrut) case_bndr ty (zipWith fi_alt alts_drops_s alts) where -- Float into the scrut and alts-considered-together just like App [drop_here1, scrut_drops, alts_drops] - = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop + = sepBindsByDropPoint dflags False [scrut_fvs, all_alts_fvs] to_drop -- Float into the alts with the is_case flag set - (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops + (drop_here2 : alts_drops_s) = sepBindsByDropPoint dflags True alts_fvs alts_drops scrut_fvs = freeVarsOf scrut alts_fvs = map alt_fvs alts @@ -392,7 +394,7 @@ fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) -- Delete case_bndr and args from free vars of rhs -- to get free vars of alt - fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs) + fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs) okToFloatInside :: [Var] -> Bool okToFloatInside bndrs = all ok bndrs @@ -444,7 +446,8 @@ We have to maintain the order on these drop-point-related lists. \begin{code} sepBindsByDropPoint - :: Bool -- True <=> is case expression + :: DynFlags + -> Bool -- True <=> is case expression -> [FreeVarSet] -- One set of FVs per drop point -> FloatInBinds -- Candidate floaters -> [FloatInBinds] -- FIRST one is bindings which must not be floated @@ -459,10 +462,10 @@ sepBindsByDropPoint type DropBox = (FreeVarSet, FloatInBinds) -sepBindsByDropPoint _is_case drop_pts [] +sepBindsByDropPoint _ _is_case drop_pts [] = [] : [[] | _ <- drop_pts] -- cut to the chase scene; it happens -sepBindsByDropPoint is_case drop_pts floaters +sepBindsByDropPoint dflags is_case drop_pts floaters = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts)) where go :: FloatInBinds -> [DropBox] -> [FloatInBinds] @@ -498,7 +501,7 @@ sepBindsByDropPoint is_case drop_pts floaters || (is_case && -- We are looking at case alternatives n_used_alts > 1 && -- It's used in more than one n_used_alts < n_alts && -- ...but not all - floatIsDupable bind) -- and we can duplicate the binding + floatIsDupable dflags bind) -- and we can duplicate the binding new_boxes | drop_here = (insert here_box : fork_boxes) | otherwise = (here_box : new_fork_boxes) @@ -525,8 +528,8 @@ wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr wrapFloats [] e = e wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) -floatIsDupable :: FloatBind -> Bool -floatIsDupable (FloatCase scrut _ _ _) = exprIsDupable scrut -floatIsDupable (FloatLet (Rec prs)) = all (exprIsDupable . snd) prs -floatIsDupable (FloatLet (NonRec _ r)) = exprIsDupable r +floatIsDupable :: DynFlags -> FloatBind -> Bool +floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut +floatIsDupable dflags (FloatLet (Rec prs)) = all (exprIsDupable dflags . snd) prs +floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r \end{code} diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 731f55128c..268a918e37 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -378,8 +378,8 @@ doCorePass _ CoreCSE = {-# SCC "CommonSubExpr" #-} doCorePass _ CoreLiberateCase = {-# SCC "LiberateCase" #-} doPassD liberateCase -doCorePass _ CoreDoFloatInwards = {-# SCC "FloatInwards" #-} - doPass floatInwards +doCorePass dflags CoreDoFloatInwards = {-# SCC "FloatInwards" #-} + doPass (floatInwards dflags) doCorePass _ (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} doPassDUM (floatOutwards f) diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 68c82f5718..f76fec1033 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -2338,11 +2338,12 @@ mkDupableAlts env case_bndr' the_alts mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr) -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr)) -mkDupableAlt env case_bndr (con, bndrs', rhs') - | exprIsDupable rhs' -- Note [Small alternative rhs] - = return (env, (con, bndrs', rhs')) - | otherwise - = do { let rhs_ty' = exprType rhs' +mkDupableAlt env case_bndr (con, bndrs', rhs') = do + dflags <- getDynFlags + if exprIsDupable dflags rhs' -- Note [Small alternative rhs] + then return (env, (con, bndrs', rhs')) + else + do { let rhs_ty' = exprType rhs' scrut_ty = idType case_bndr case_bndr_w_unf = case con of diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index bbad59ec6e..2de781578d 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -251,15 +251,24 @@ cases (the rest are caught in lookupInst). \begin{code} newOverloadedLit :: CtOrigin - -> HsOverLit Name - -> TcRhoType - -> TcM (HsOverLit TcId) -newOverloadedLit orig + -> HsOverLit Name + -> TcRhoType + -> TcM (HsOverLit TcId) +newOverloadedLit orig lit res_ty + = do dflags <- getDynFlags + newOverloadedLit' dflags orig lit res_ty + +newOverloadedLit' :: DynFlags + -> CtOrigin + -> HsOverLit Name + -> TcRhoType + -> TcM (HsOverLit TcId) +newOverloadedLit' dflags orig lit@(OverLit { ol_val = val, ol_rebindable = rebindable , ol_witness = meth_name }) res_ty | not rebindable - , Just expr <- shortCutLit val res_ty + , Just expr <- shortCutLit dflags val res_ty -- Do not generate a LitInst for rebindable syntax. -- Reason: If we do, tcSimplify will call lookupInst, which -- will call tcSyntaxName, which does unification, diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 1ddcd316c1..84907fb306 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -126,24 +126,24 @@ hsLitType (HsDoublePrim _) = doublePrimTy Overloaded literals. Here mainly becuase it uses isIntTy etc \begin{code} -shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId) -shortCutLit (HsIntegral i) ty - | isIntTy ty && inIntRange i = Just (HsLit (HsInt i)) - | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i)) - | isIntegerTy ty = Just (HsLit (HsInteger i ty)) - | otherwise = shortCutLit (HsFractional (integralFractionalLit i)) ty +shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId) +shortCutLit dflags (HsIntegral i) ty + | isIntTy ty && inIntRange dflags i = Just (HsLit (HsInt i)) + | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim i)) + | isIntegerTy ty = Just (HsLit (HsInteger i ty)) + | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit, -- so we'll call shortCutIntLit, but of course it's a float -- This can make a big difference for programs with a lot of -- literals, compiled without -O -shortCutLit (HsFractional f) ty +shortCutLit _ (HsFractional f) ty | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f)) | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f)) | otherwise = Nothing -shortCutLit (HsIsString s) ty +shortCutLit _ (HsIsString s) ty | isStringTy ty = Just (HsLit (HsString s)) | otherwise = Nothing diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 8c5ef0045d..527cbfcb4d 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -728,11 +728,12 @@ vectLam inline loop_breaker expr@(fvs, AnnLam _ _) vi -- in Figure 6 of HtM. break_loop lc ty (ve, le) | loop_breaker - = do { empty <- emptyPD ty + = do { dflags <- getDynFlags + ; empty <- emptyPD ty ; lty <- mkPDataType ty ; return (ve, mkWildCase (Var lc) intPrimTy lty [(DEFAULT, [], le), - (LitAlt (mkMachInt 0), [], empty)]) + (LitAlt (mkMachInt dflags 0), [], empty)]) } | otherwise = return (ve, le) vectLam _ _ _ _ = panic "vectLam" @@ -844,9 +845,10 @@ vectAlgCase tycon _ty_args scrut bndr ty alts (VITNode _ (scrutVit : altVits)) proc_alt arity sel _ lty ((DataAlt dc, bndrs, body), vi) = do + dflags <- getDynFlags vect_dc <- maybeV dataConErr (lookupDataCon dc) let ntag = dataConTagZ vect_dc - tag = mkDataConTag vect_dc + tag = mkDataConTag dflags vect_dc fvs = freeVarsOf body `delVarSetList` bndrs sel_tags <- liftM (`App` sel) (builtin (selTags arity)) diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 0051d072a4..5dfbaa5555 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -36,6 +36,7 @@ import OccName import Util import Outputable +import DynFlags import FastString import MonadUtils @@ -375,8 +376,9 @@ vectDataConWorkers orig_tc vect_tc arr_tc rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc mk_data_con con tys pre post - = liftM2 (,) (vect_data_con con) - (lift_data_con tys pre post (mkDataConTag con)) + = do dflags <- getDynFlags + liftM2 (,) (vect_data_con con) + (lift_data_con tys pre post (mkDataConTag dflags con)) sel_replicate len tag | arity > 1 = do diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index 9ed4e2c60e..a03875f116 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -37,6 +37,7 @@ import Type import TyCon import DataCon import MkId +import DynFlags import FastString -- Simple Types --------------------------------------------------------------- @@ -58,8 +59,8 @@ newLocalVVar fs vty -- Constructors --------------------------------------------------------------- -mkDataConTag :: DataCon -> CoreExpr -mkDataConTag = mkIntLitInt . dataConTagZ +mkDataConTag :: DynFlags -> DataCon -> CoreExpr +mkDataConTag dflags = mkIntLitInt dflags . dataConTagZ dataConTagZ :: DataCon -> Int dataConTagZ con = dataConTag con - fIRST_TAG diff --git a/includes/HaskellConstants.hs b/includes/HaskellConstants.hs index 4ad7deef19..bf0e99e58e 100644 --- a/includes/HaskellConstants.hs +++ b/includes/HaskellConstants.hs @@ -48,11 +48,6 @@ type TargetWord = Word64 #error unknown SIZEOF_HSWORD #endif -tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: Integer -tARGET_MIN_INT = fromIntegral (minBound :: TargetInt) -tARGET_MAX_INT = fromIntegral (maxBound :: TargetInt) -tARGET_MAX_WORD = fromIntegral (maxBound :: TargetWord) - tARGET_MAX_CHAR :: Int tARGET_MAX_CHAR = 0x10ffff |