Merge remote-tracking branch 'origin/master' into tc-untouchables
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 18 Sep 2012 16:40:23 +0000 (17:40 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 18 Sep 2012 16:40:23 +0000 (17:40 +0100)
40 files changed:
compiler/basicTypes/Literal.lhs
compiler/basicTypes/MkId.lhs
compiler/cmm/CLabel.hs
compiler/cmm/CmmPipeline.hs
compiler/cmm/CmmType.hs
compiler/codeGen/CgProf.hs
compiler/codeGen/CgTicky.hs
compiler/codeGen/StgCmmProf.hs
compiler/codeGen/StgCmmTicky.hs
compiler/coreSyn/CorePrep.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/coreSyn/MkCore.lhs
compiler/deSugar/DsCCall.lhs
compiler/deSugar/DsForeign.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsUtils.lhs
compiler/deSugar/Match.lhs
compiler/deSugar/MatchCon.lhs
compiler/deSugar/MatchLit.lhs
compiler/ghc.mk
compiler/ghci/DebuggerUtils.hs
compiler/ghci/Linker.lhs
compiler/main/Constants.lhs
compiler/main/DynFlags.hs
compiler/main/TidyPgm.lhs
compiler/prelude/PrelRules.lhs
compiler/simplCore/FloatIn.lhs
compiler/simplCore/SimplCore.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/Rules.lhs
compiler/specialise/Specialise.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/vectorise/Vectorise/Exp.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Utils/Base.hs
includes/HaskellConstants.hs [deleted file]
rts/sm/GC.c

index 8fbcbb7..220ef9e 100644 (file)
@@ -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)
index 7bb5d16..1805ccd 100644 (file)
@@ -505,14 +505,14 @@ mkDictSelId no_unf name clas
                                -- varToCoreExpr needed for equality superclass selectors
                                --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
 
-dictSelRule :: Int -> Arity 
-            -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+dictSelRule :: Int -> Arity
+            -> DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
 -- Tries to persuade the argument to look like a constructor
 -- application, using exprIsConApp_maybe, and then selects
 -- from it
 --       sel_i t1..tk (D t1..tk op1 ... opm) = opi
 --
-dictSelRule val_index n_ty_args _ id_unf args
+dictSelRule val_index n_ty_args _ id_unf args
   | (dict_arg : _) <- drop n_ty_args args
   , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
   = Just (con_args !! val_index)
@@ -935,12 +935,13 @@ seqId = pcMiscPrelId seqName ty info
                                 , ru_try   = match_seq_of_cast
                                 }
 
-match_seq_of_cast :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+match_seq_of_cast :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr]
+                  -> Maybe CoreExpr
     -- See Note [Built-in RULES for seq]
-match_seq_of_cast _ _ [Type _, Type res_ty, Cast scrut co, expr]
+match_seq_of_cast _ _ [Type _, Type res_ty, Cast scrut co, expr]
   = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
                               scrut, expr])
-match_seq_of_cast _ _ _ = Nothing
+match_seq_of_cast _ _ _ = Nothing
 
 ------------------------------------------------
 lazyId :: Id   -- See Note [lazyId magic]
index 907f852..1ff76c6 100644 (file)
@@ -590,9 +590,9 @@ hasCAF _                            = False
 
 needsCDecl :: CLabel -> Bool
   -- False <=> it's pre-declared; don't bother
-  -- don't bother declaring SRT & Bitmap labels, we always make sure
+  -- don't bother declaring Bitmap labels, we always make sure
   -- they are defined before use.
-needsCDecl (SRTLabel _ _)               = False
+needsCDecl (SRTLabel _ _)               = True
 needsCDecl (LargeSRTLabel _)            = False
 needsCDecl (LargeBitmapLabel _)         = False
 needsCDecl (IdLabel _ _ _)              = True
@@ -788,7 +788,7 @@ labelType (RtsLabel (RtsApFast _))              = CodeLabel
 labelType (CaseLabel _ CaseReturnInfo)          = DataLabel
 labelType (CaseLabel _ _)                       = CodeLabel
 labelType (PlainModuleInitLabel _)              = CodeLabel
-labelType (SRTLabel _ _)                        = CodeLabel
+labelType (SRTLabel _ _)                        = DataLabel
 labelType (LargeSRTLabel _)                     = DataLabel
 labelType (LargeBitmapLabel _)                  = DataLabel
 labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel
index 7692726..25fda1c 100644 (file)
@@ -82,7 +82,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
                   return call_pps
 
        let noncall_pps = proc_points `setDifference` call_pps
-       when (not (setNull noncall_pps)) $
+       when (not (setNull noncall_pps) && dopt Opt_D_dump_cmmz dflags) $
          pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
 
        ----------- Sink and inline assignments *before* stack layout -----------
index c0ce9e3..b6deb01 100644 (file)
@@ -104,9 +104,9 @@ bHalfWord dflags = cmmBits (halfWordWidth dflags)
 gcWord :: DynFlags -> CmmType
 gcWord dflags = CmmType GcPtrCat (wordWidth dflags)
 
-cInt, cLong :: CmmType
-cInt  = cmmBits cIntWidth
-cLong = cmmBits cLongWidth
+cInt, cLong :: DynFlags -> CmmType
+cInt  dflags = cmmBits (cIntWidth  dflags)
+cLong dflags = cmmBits (cLongWidth dflags)
 
 
 ------------ Predicates ----------------
@@ -178,18 +178,15 @@ halfWordMask dflags
  | otherwise             = panic "MachOp.halfWordMask: Unknown word size"
 
 -- cIntRep is the Width for a C-language 'int'
-cIntWidth, cLongWidth :: Width
-#if SIZEOF_INT == 4
-cIntWidth = W32
-#elif  SIZEOF_INT == 8
-cIntWidth = W64
-#endif
-
-#if SIZEOF_LONG == 4
-cLongWidth = W32
-#elif  SIZEOF_LONG == 8
-cLongWidth = W64
-#endif
+cIntWidth, cLongWidth :: DynFlags -> Width
+cIntWidth dflags = case cINT_SIZE dflags of
+                   4 -> W32
+                   8 -> W64
+                   s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s)
+cLongWidth dflags = case cLONG_SIZE dflags of
+                    4 -> W32
+                    8 -> W64
+                    s -> panic ("cIntWidth: Unknown cLONG_SIZE: " ++ show s)
 
 widthInBits :: Width -> Int
 widthInBits W8   = 8
index 6d87ee7..1c78dd8 100644 (file)
@@ -307,8 +307,8 @@ ldvEnter cl_ptr = do
            (stmtC (CmmStore ldv_wd new_ldv_wd))
 
 loadEra :: DynFlags -> CmmExpr
-loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags))
-                           [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt]
+loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
+                           [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) (cInt dflags)]
 
 ldvWord :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes the address of a closure, and returns
index 9e98175..79215f6 100644 (file)
@@ -302,9 +302,9 @@ tickyAllocHeap hp
                        (CmmLit (cmmLabelOffB ticky_ctr 
                                (oFFSET_StgEntCounter_allocs dflags))) hp,
                -- Bump ALLOC_HEAP_ctr
-           addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1,
+           addToMemLbl (cLongWidth dflags) (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1,
                -- Bump ALLOC_HEAP_tot
-           addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] }
+           addToMemLbl (cLongWidth dflags) (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] }
 
 -- -----------------------------------------------------------------------------
 -- Ticky utils
@@ -323,7 +323,8 @@ bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackag
 
 bumpTickyCounter' :: CmmLit -> Code
 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
-bumpTickyCounter' lhs = stmtC (addToMemLong (CmmLit lhs) 1)
+bumpTickyCounter' lhs = do dflags <- getDynFlags
+                           stmtC (addToMemLong dflags (CmmLit lhs) 1)
 
 bumpHistogram :: FastString -> Int -> Code
 bumpHistogram _lbl _n
@@ -346,8 +347,8 @@ bumpHistogramE lbl n
 -}
 
 ------------------------------------------------------------------
-addToMemLong :: CmmExpr -> Int -> CmmStmt
-addToMemLong = addToMem cLongWidth
+addToMemLong :: DynFlags -> CmmExpr -> Int -> CmmStmt
+addToMemLong dflags = addToMem (cLongWidth dflags)
 
 ------------------------------------------------------------------
 -- Showing the "type category" for ticky-ticky profiling
index e6e9899..d2f4984 100644 (file)
@@ -369,8 +369,9 @@ ldvEnter cl_ptr = do
                      mkNop
 
 loadEra :: DynFlags -> CmmExpr
-loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags))
-         [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt]
+loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
+    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era")))
+             (cInt dflags)]
 
 ldvWord :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes the address of a closure, and returns 
index 137764d..d7517e8 100644 (file)
@@ -325,9 +325,9 @@ tickyAllocHeap hp
                        (CmmLit (cmmLabelOffB ticky_ctr 
                                (oFFSET_StgEntCounter_allocs dflags))) hp,
                -- Bump ALLOC_HEAP_ctr
-           addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1,
+           addToMemLbl (cLong dflags) (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1,
                -- Bump ALLOC_HEAP_tot
-           addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) hp] }
+           addToMemLbl (cLong dflags) (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) hp] }
 
 -- -----------------------------------------------------------------------------
 -- Ticky utils
@@ -343,7 +343,8 @@ bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackag
 
 bumpTickyCounter' :: CmmLit -> FCode ()
 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
-bumpTickyCounter' lhs = emit (addToMem cLong (CmmLit lhs) 1)
+bumpTickyCounter' lhs = do dflags <- getDynFlags
+                           emit (addToMem (cLong dflags) (CmmLit lhs) 1)
 
 bumpHistogram :: FastString -> Int -> FCode ()
 bumpHistogram _lbl _n
index 0bd199f..fda2bcc 100644 (file)
@@ -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
 
index f972fc7..2fb5aaf 100644 (file)
@@ -101,6 +101,7 @@ import DataCon
 import Module
 import TyCon
 import BasicTypes
+import DynFlags
 import FastString
 import Outputable
 import Util
@@ -561,7 +562,7 @@ data CoreRule
        ru_fn    :: Name,       -- ^ As above
        ru_nargs :: Int,        -- ^ Number of arguments that 'ru_try' consumes,
                                -- if it fires, including type arguments
-       ru_try  :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+       ru_try  :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
                -- ^ This function does the rewrite.  It given too many
                -- arguments, it simply discards them; the returned 'CoreExpr'
                -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
@@ -1117,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))
index f15c648..cad8012 100644 (file)
@@ -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
index 0857cd5..e903ab2 100644 (file)
@@ -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
index e02ef7b..b5e38c8 100644 (file)
@@ -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
index cc6b6af..0cf4b97 100644 (file)
@@ -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)
index 874f8b0..15dab47 100644 (file)
@@ -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)
index 52944e8..0053484 100644 (file)
@@ -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}
 
 %************************************************************************
index 8fd3a20..adb9099 100644 (file)
@@ -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]
index e1b2ef8..10270e5 100644 (file)
@@ -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))
index 4032093..69d46c2 100644 (file)
@@ -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
index f65813d..a0754af 100644 (file)
@@ -474,16 +474,12 @@ $(compiler_stage1_depfile_haskell) : $(COMPILER_INCLUDES_DEPS)
 $(compiler_stage2_depfile_haskell) : $(COMPILER_INCLUDES_DEPS)
 $(compiler_stage3_depfile_haskell) : $(COMPILER_INCLUDES_DEPS)
 
-# Every Constants.o object file depends on includes/GHCConstants.h:
-$(eval $(call compiler-hs-dependency,Constants,$(includes_GHCCONSTANTS) includes/HaskellConstants.hs))
-
 # Every PrimOp.o object file depends on $(PRIMOP_BITS):
 $(eval $(call compiler-hs-dependency,PrimOp,$(PRIMOP_BITS)))
 
 # GHC itself doesn't know about the above dependencies, so we have to
-# switch off the recompilation checker for those modules:
+# switch off the recompilation checker for that module:
 compiler/prelude/PrimOp_HC_OPTS  += -fforce-recomp
-compiler/main/Constants_HC_OPTS  += -fforce-recomp
 
 # LibFFI.hs #includes ffi.h
 compiler/stage2/build/LibFFI.hs : $(libffi_HEADERS)
index cd46ec3..ab7fcd1 100644 (file)
@@ -14,7 +14,6 @@ import Module
 import OccName
 import Name
 import Outputable
-import MonadUtils ()
 import Util
 
 import Data.Char
index 565cf0b..6b47db3 100644 (file)
@@ -772,7 +772,7 @@ dynLinkObjs dflags pls objs = do
 
         mapM_ loadObj (map nameOfObject unlinkeds)
 
-        -- Link the all together
+        -- Link them all together
         ok <- resolveObjs
 
         -- If resolving failed, unload all our
index 0cecb82..497bae5 100644 (file)
@@ -4,21 +4,26 @@
 \section[Constants]{Info about this compilation}
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module Constants (module Constants) where
 
 import Config
 
-#include "ghc_boot_platform.h"
-
-#include "../includes/HaskellConstants.hs"
-
 hiVersion :: Integer
 hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
+
+-- All pretty arbitrary:
+
+mAX_TUPLE_SIZE :: Int
+mAX_TUPLE_SIZE = 62 -- Should really match the number
+                    -- of decls in Data.Tuple
+
+mAX_CONTEXT_REDUCTION_DEPTH :: Int
+mAX_CONTEXT_REDUCTION_DEPTH = 200
+  -- Increase to 200; see Trac #5395
+
+wORD64_SIZE :: Int
+wORD64_SIZE = 8
+
+tARGET_MAX_CHAR :: Int
+tARGET_MAX_CHAR = 0x10ffff
 \end{code}
index 9ff5ea7..c0667b0 100644 (file)
@@ -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
 
@@ -3164,3 +3167,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)
+
index ffd5de8..309f2e2 100644 (file)
@@ -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
index b5b350b..3f12365 100644 (file)
@@ -43,14 +43,15 @@ import Name        ( Name, nameOccName )
 import Outputable
 import FastString
 import StaticFlags ( opt_SimplExcessPrecision )
-import Constants
 import BasicTypes
+import DynFlags
+import Platform
 import Util
 
 import Control.Monad
 import Data.Bits as Bits
-import Data.Int    ( Int64 )
-import Data.Word   ( Word, Word64 )
+import Data.Int
+import Data.Word
 \end{code}
 
 
@@ -79,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 ]
@@ -239,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'
@@ -249,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
@@ -278,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
@@ -301,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
@@ -410,13 +423,19 @@ 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)))
-
-wordResult :: Integer -> Maybe CoreExpr
-wordResult result
-  = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
+intResult :: DynFlags -> Integer -> Maybe CoreExpr
+intResult dflags result = Just (mkIntVal dflags result')
+    where result' = case platformWordSize (targetPlatform dflags) of
+                    4 -> toInteger (fromInteger result :: Int32)
+                    8 -> toInteger (fromInteger result :: Int64)
+                    w -> panic ("intResult: Unknown platformWordSize: " ++ show w)
+
+wordResult :: DynFlags -> Integer -> Maybe CoreExpr
+wordResult dflags result = Just (mkWordVal dflags result')
+    where result' = case platformWordSize (targetPlatform dflags) of
+                    4 -> toInteger (fromInteger result :: Word32)
+                    8 -> toInteger (fromInteger result :: Word64)
+                    w -> panic ("wordResult: Unknown platformWordSize: " ++ show w)
 
 inversePrimOp :: PrimOp -> RuleM CoreExpr
 inversePrimOp primop = do
@@ -439,31 +458,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
@@ -475,56 +501,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 ()
@@ -570,10 +611,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
@@ -648,11 +689,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}
 
 %************************************************************************
@@ -716,11 +758,11 @@ builtinRules :: [CoreRule]
 builtinRules
   = [BuiltinRule { ru_name = fsLit "AppendLitString",
                    ru_fn = unpackCStringFoldrName,
-                   ru_nargs = 4, ru_try = \_ -> match_append_lit },
+                   ru_nargs = 4, ru_try = \_ -> match_append_lit },
      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
-                   ru_nargs = 2, ru_try = \_ -> match_eq_string },
+                   ru_nargs = 2, ru_try = \_ -> match_eq_string },
      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
-                   ru_nargs = 2, ru_try = \_ -> match_inline }]
+                   ru_nargs = 2, ru_try = \_ -> match_inline }]
  ++ builtinIntegerRules
 
 builtinIntegerRules :: [CoreRule]
@@ -731,8 +773,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        (*),
@@ -751,10 +793,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          (.&.),
@@ -889,98 +931,106 @@ match_inline _ _ = Nothing
 --   wordToInteger (79::Word#) = 79::Integer   
 -- Similarly Int64, Word64
 
-match_IntToInteger :: Id
+match_IntToInteger :: DynFlags
+                   -> Id
                    -> IdUnfoldingFun
                    -> [Expr CoreBndr]
                    -> Maybe (Expr CoreBndr)
-match_IntToInteger id id_unf [xl]
+match_IntToInteger id id_unf [xl]
   | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
         Just (Lit (LitInteger x integerTy))
     _ ->
         panic "match_IntToInteger: Id has the wrong type"
-match_IntToInteger _ _ _ = Nothing
+match_IntToInteger _ _ _ = Nothing
 
-match_WordToInteger :: Id
+match_WordToInteger :: DynFlags
+                    -> Id
                     -> IdUnfoldingFun
                     -> [Expr CoreBndr]
                     -> Maybe (Expr CoreBndr)
-match_WordToInteger id id_unf [xl]
+match_WordToInteger id id_unf [xl]
   | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
         Just (Lit (LitInteger x integerTy))
     _ ->
         panic "match_WordToInteger: Id has the wrong type"
-match_WordToInteger _ _ _ = Nothing
+match_WordToInteger _ _ _ = Nothing
 
-match_Int64ToInteger :: Id
+match_Int64ToInteger :: DynFlags
+                     -> Id
                      -> IdUnfoldingFun
                      -> [Expr CoreBndr]
                      -> Maybe (Expr CoreBndr)
-match_Int64ToInteger id id_unf [xl]
+match_Int64ToInteger id id_unf [xl]
   | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
         Just (Lit (LitInteger x integerTy))
     _ ->
         panic "match_Int64ToInteger: Id has the wrong type"
-match_Int64ToInteger _ _ _ = Nothing
+match_Int64ToInteger _ _ _ = Nothing
 
-match_Word64ToInteger :: Id
+match_Word64ToInteger :: DynFlags
+                      -> Id
                       -> IdUnfoldingFun
                       -> [Expr CoreBndr]
                       -> Maybe (Expr CoreBndr)
-match_Word64ToInteger id id_unf [xl]
+match_Word64ToInteger id id_unf [xl]
   | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
         Just (Lit (LitInteger x integerTy))
     _ ->
         panic "match_Word64ToInteger: Id has the wrong type"
-match_Word64ToInteger _ _ _ = Nothing
+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))
-match_Integer_convert _ _ _ _ = Nothing
+  = Just (convert dflags (fromInteger x))
+match_Integer_convert _ _ _ _ = Nothing
 
 match_Integer_unop :: (Integer -> Integer)
+                   -> DynFlags
                    -> Id
                    -> IdUnfoldingFun
                    -> [Expr CoreBndr]
                    -> Maybe (Expr CoreBndr)
-match_Integer_unop unop _ id_unf [xl]
+match_Integer_unop unop _ id_unf [xl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   = Just (Lit (LitInteger (unop x) i))
-match_Integer_unop _ _ _ _ = Nothing
+match_Integer_unop _ _ _ _ = Nothing
 
 match_Integer_binop :: (Integer -> Integer -> Integer)
+                    -> DynFlags
                     -> Id
                     -> IdUnfoldingFun
                     -> [Expr CoreBndr]
                     -> Maybe (Expr CoreBndr)
-match_Integer_binop binop _ id_unf [xl,yl]
+match_Integer_binop binop _ id_unf [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just (Lit (LitInteger (x `binop` y) i))
-match_Integer_binop _ _ _ _ = Nothing
+match_Integer_binop _ _ _ _ = Nothing
 
 -- This helper is used for the quotRem and divMod functions
 match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer))
+                         -> DynFlags
                          -> Id
                          -> IdUnfoldingFun
                          -> [Expr CoreBndr]
                          -> Maybe (Expr CoreBndr)
-match_Integer_divop_both divop _ id_unf [xl,yl]
+match_Integer_divop_both divop _ id_unf [xl,yl]
   | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
@@ -990,74 +1040,80 @@ match_Integer_divop_both divop _ id_unf [xl,yl]
                      Type t,
                      Lit (LitInteger r t),
                      Lit (LitInteger s t)]
-match_Integer_divop_both _ _ _ _ = Nothing
+match_Integer_divop_both _ _ _ _ = Nothing
 
 -- This helper is used for the quotRem and divMod functions
 match_Integer_divop_one :: (Integer -> Integer -> Integer)
+                        -> DynFlags
                         -> Id
                         -> IdUnfoldingFun
                         -> [Expr CoreBndr]
                         -> Maybe (Expr CoreBndr)
-match_Integer_divop_one divop _ id_unf [xl,yl]
+match_Integer_divop_one divop _ id_unf [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
   = Just (Lit (LitInteger (x `divop` y) i))
-match_Integer_divop_one _ _ _ _ = Nothing
+match_Integer_divop_one _ _ _ _ = Nothing
 
 match_Integer_Int_binop :: (Integer -> Int -> Integer)
+                        -> DynFlags
                         -> Id
                         -> IdUnfoldingFun
                         -> [Expr CoreBndr]
                         -> Maybe (Expr CoreBndr)
-match_Integer_Int_binop binop _ id_unf [xl,yl]
+match_Integer_Int_binop binop _ id_unf [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
   = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
-match_Integer_Int_binop _ _ _ _ = Nothing
+match_Integer_Int_binop _ _ _ _ = Nothing
 
 match_Integer_binop_Bool :: (Integer -> Integer -> Bool)
+                         -> DynFlags
                          -> Id
                          -> IdUnfoldingFun
                          -> [Expr CoreBndr]
                          -> Maybe (Expr CoreBndr)
-match_Integer_binop_Bool binop _ id_unf [xl, yl]
+match_Integer_binop_Bool binop _ id_unf [xl, yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just (if x `binop` y then trueVal else falseVal)
-match_Integer_binop_Bool _ _ _ _ = Nothing
+match_Integer_binop_Bool _ _ _ _ = Nothing
 
 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering)
+                             -> DynFlags
                              -> Id
                              -> IdUnfoldingFun
                              -> [Expr CoreBndr]
                              -> Maybe (Expr CoreBndr)
-match_Integer_binop_Ordering binop _ id_unf [xl, yl]
+match_Integer_binop_Ordering binop _ id_unf [xl, yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just $ case x `binop` y of
              LT -> ltVal
              EQ -> eqVal
              GT -> gtVal
-match_Integer_binop_Ordering _ _ _ _ = Nothing
+match_Integer_binop_Ordering _ _ _ _ = Nothing
 
 match_Integer_Int_encodeFloat :: RealFloat a
                               => (a -> Expr CoreBndr)
+                              -> DynFlags
                               -> Id
                               -> IdUnfoldingFun
                               -> [Expr CoreBndr]
                               -> Maybe (Expr CoreBndr)
-match_Integer_Int_encodeFloat mkLit _ id_unf [xl,yl]
+match_Integer_Int_encodeFloat mkLit _ id_unf [xl,yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
   = Just (mkLit $ encodeFloat x (fromInteger y))
-match_Integer_Int_encodeFloat _ _ _ _ = Nothing
+match_Integer_Int_encodeFloat _ _ _ _ = Nothing
 
-match_decodeDouble :: Id
+match_decodeDouble :: DynFlags
+                   -> Id
                    -> IdUnfoldingFun
                    -> [Expr CoreBndr]
                    -> Maybe (Expr CoreBndr)
-match_decodeDouble fn id_unf [xl]
+match_decodeDouble fn id_unf [xl]
   | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
   = case idType fn of
     FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
@@ -1070,25 +1126,27 @@ match_decodeDouble fn id_unf [xl]
                              Lit (MachInt (toInteger z))]
     _ ->
         panic "match_decodeDouble: Id has the wrong type"
-match_decodeDouble _ _ _ = Nothing
+match_decodeDouble _ _ _ = Nothing
 
 match_XToIntegerToX :: Name
+                    -> DynFlags
                     -> Id
                     -> IdUnfoldingFun
                     -> [Expr CoreBndr]
                     -> Maybe (Expr CoreBndr)
-match_XToIntegerToX n _ _ [App (Var x) y]
+match_XToIntegerToX n _ _ [App (Var x) y]
   | idName x == n
   = Just y
-match_XToIntegerToX _ _ _ _ = Nothing
+match_XToIntegerToX _ _ _ _ = Nothing
 
 match_smallIntegerTo :: PrimOp
+                     -> DynFlags
                      -> Id
                      -> IdUnfoldingFun
                      -> [Expr CoreBndr]
                      -> Maybe (Expr CoreBndr)
-match_smallIntegerTo primOp _ _ [App (Var x) y]
+match_smallIntegerTo primOp _ _ [App (Var x) y]
   | idName x == smallIntegerName
   = Just $ App (Var (mkPrimOpId primOp)) y
-match_smallIntegerTo _ _ _ _ = Nothing
+match_smallIntegerTo _ _ _ _ = Nothing
 \end{code}
index ab3df0d..681c183 100644 (file)
@@ -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}
index 731f551..268a918 100644 (file)
@@ -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)
index bc991b3..f76fec1 100644 (file)
@@ -1553,7 +1553,8 @@ tryRules env rules fn args call_cont
   | null rules
   = return Nothing
   | otherwise
-  = do { case lookupRule (activeRule env) (getUnfoldingInRuleMatch env)
+  = do { dflags <- getDynFlags
+       ; case lookupRule dflags (activeRule env) (getUnfoldingInRuleMatch env)
                          (getInScope env) fn args rules of {
            Nothing               -> return Nothing ;   -- No rule matches
            Just (rule, rule_rhs) ->
@@ -2337,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
index 231fd27..9c473e5 100644 (file)
@@ -47,6 +47,7 @@ import Name             ( Name, NamedThing(..) )
 import NameEnv
 import Unify            ( ruleMatchTyX, MatchEnv(..) )
 import BasicTypes       ( Activation, CompilerPhase, isActive )
+import DynFlags         ( DynFlags )
 import StaticFlags      ( opt_PprStyle_Debug )
 import Outputable
 import FastString
@@ -350,7 +351,8 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
 -- supplied rules to this instance of an application in a given
 -- context, returning the rule applied and the resulting expression if
 -- successful.
-lookupRule :: (Activation -> Bool)      -- When rule is active
+lookupRule :: DynFlags
+            -> (Activation -> Bool)      -- When rule is active
             -> IdUnfoldingFun           -- When Id can be unfolded
             -> InScopeSet
             -> Id -> [CoreExpr]
@@ -358,7 +360,7 @@ lookupRule :: (Activation -> Bool)      -- When rule is active
 
 -- See Note [Extra args in rule matching]
 -- See comments on matchRule
-lookupRule is_active id_unf in_scope fn args rules
+lookupRule dflags is_active id_unf in_scope fn args rules
   = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
     case go [] rules of
         []     -> Nothing
@@ -368,7 +370,7 @@ lookupRule is_active id_unf in_scope fn args rules
 
     go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
     go ms []           = ms
-    go ms (r:rs) = case (matchRule fn is_active id_unf in_scope args rough_args r) of
+    go ms (r:rs) = case (matchRule dflags fn is_active id_unf in_scope args rough_args r) of
                         Just e  -> go ((r,e):ms) rs
                         Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
                                    --   ppr [ (arg_id, unfoldingTemplate unf)
@@ -445,7 +447,7 @@ to lookupRule are the result of a lazy substitution
 
 \begin{code}
 ------------------------------------
-matchRule :: Id -> (Activation -> Bool) -> IdUnfoldingFun
+matchRule :: DynFlags -> Id -> (Activation -> Bool) -> IdUnfoldingFun
           -> InScopeSet
           -> [CoreExpr] -> [Maybe Name]
           -> CoreRule -> Maybe CoreExpr
@@ -472,14 +474,14 @@ matchRule :: Id -> (Activation -> Bool) -> IdUnfoldingFun
 -- Any 'surplus' arguments in the input are simply put on the end
 -- of the output.
 
-matchRule fn _is_active id_unf _in_scope args _rough_args
+matchRule dflags fn _is_active id_unf _in_scope args _rough_args
           (BuiltinRule { ru_try = match_fn })
 -- Built-in rules can't be switched off, it seems
-  = case match_fn fn id_unf args of
+  = case match_fn dflags fn id_unf args of
         Just expr -> Just expr
         Nothing   -> Nothing
 
-matchRule _ is_active id_unf in_scope args rough_args
+matchRule _ is_active id_unf in_scope args rough_args
           (Rule { ru_act = act, ru_rough = tpl_tops,
                   ru_bndrs = tpl_vars, ru_args = tpl_args,
                   ru_rhs = rhs })
@@ -1085,21 +1087,22 @@ ruleAppCheck_help env fn args rules
     i_args = args `zip` [1::Int ..]
     rough_args = map roughTopName args
 
-    check_rule rule = rule_herald rule <> colon <+> rule_info rule
+    check_rule rule = sdocWithDynFlags $ \dflags ->
+                      rule_herald rule <> colon <+> rule_info dflags rule
 
     rule_herald (BuiltinRule { ru_name = name })
         = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name)
     rule_herald (Rule { ru_name = name })
         = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
 
-    rule_info rule
-        | Just _ <- matchRule fn noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule
+    rule_info dflags rule
+        | Just _ <- matchRule dflags fn noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule
         = text "matches (which is very peculiar!)"
 
-    rule_info (BuiltinRule {}) = text "does not match"
+    rule_info (BuiltinRule {}) = text "does not match"
 
-    rule_info (Rule { ru_act = act,
-                      ru_bndrs = rule_bndrs, ru_args = rule_args})
+    rule_info (Rule { ru_act = act,
+                        ru_bndrs = rule_bndrs, ru_args = rule_args})
         | not (rc_is_active env act)  = text "active only in later phase"
         | n_args < n_rule_args        = text "too few arguments"
         | n_mismatches == n_rule_args = text "no arguments match"
index 4307ff7..083d150 100644 (file)
@@ -1063,9 +1063,9 @@ specCalls subst rules_for_me calls_for_me fn rhs
     body         = mkLams (drop n_dicts rhs_ids) rhs_body
                 -- Glue back on the non-dict lambdas
 
-    already_covered :: [CoreExpr] -> Bool
-    already_covered args          -- Note [Specialisations already covered]
-       = isJust (lookupRule (const True) realIdUnfolding
+    already_covered :: DynFlags -> [CoreExpr] -> Bool
+    already_covered dflags args      -- Note [Specialisations already covered]
+       = isJust (lookupRule dflags (const True) realIdUnfolding
                             (substInScope subst)
                             fn args rules_for_me)
 
@@ -1119,7 +1119,8 @@ specCalls subst rules_for_me calls_for_me fn rhs
                  ty_args   = mk_ty_args call_ts poly_tyvars
                  inst_args = ty_args ++ map Var inst_dict_ids
 
-           ; if already_covered inst_args then
+           ; dflags <- getDynFlags
+           ; if already_covered dflags inst_args then
                 return Nothing
              else do
            {    -- Figure out the type of the specialised function
index 11bfbe0..67b66fd 100644 (file)
@@ -248,15 +248,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, 
index ef53f4e..9da6ea5 100644 (file)
@@ -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
 
index 22e17b7..c62b188 100644 (file)
@@ -1043,7 +1043,9 @@ tcConArg new_or_data bty
   = do  { traceTc "tcConArg 1" (ppr bty)
         ; arg_ty <- tcHsConArgType new_or_data bty
         ; traceTc "tcConArg 2" (ppr bty)
-        ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty)
+        ; dflags <- getDynFlags
+        ; let strict_mark = chooseBoxingStrategy dflags arg_ty (getBangStrictness bty)
+                            -- Must be computed lazily
        ; return (arg_ty, strict_mark) }
 
 tcConRes :: ResType (LHsType Name) -> TcM (ResType Type)
@@ -1179,10 +1181,20 @@ conRepresentibleWithH98Syntax
 --
 -- We have turned off unboxing of newtypes because coercions make unboxing 
 -- and reboxing more complicated
-chooseBoxingStrategy :: TcType -> HsBang -> TcM HsBang
-chooseBoxingStrategy arg_ty bang
-  = do { dflags <- getDynFlags
-       ; let choice = case bang of
+chooseBoxingStrategy :: DynFlags -> TcType -> HsBang -> HsBang
+chooseBoxingStrategy dflags arg_ty bang
+  = case initial_choice of
+      HsUnpack | dopt Opt_OmitInterfacePragmas dflags
+               -> HsStrict
+      _other   -> initial_choice
+       -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
+       -- See Trac #5252: unpacking means we must not conceal the
+       --                 representation of the argument type
+       -- However: even when OmitInterfacePragmas is on, we still want
+       -- to know if we have HsUnpackFailed, because we omit a
+       -- warning in that case (#3966)
+  where
+    initial_choice = case bang of
                       HsNoBang -> HsNoBang
                       HsStrict | dopt Opt_UnboxStrictFields dflags
                                 -> can_unbox HsStrict arg_ty
@@ -1192,18 +1204,6 @@ chooseBoxingStrategy arg_ty bang
                        HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
                                          -- Source code never has HsUnpackFailed
 
-       ; case choice of
-           HsUnpack | dopt Opt_OmitInterfacePragmas dflags
-                    -> return HsStrict
-           _other   -> return choice
-            -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
-           -- See Trac #5252: unpacking means we must not conceal the
-           --                 representation of the argument type
-            -- However: even when OmitInterfacePragmas is on, we still want
-            -- to know if we have HsUnpackFailed, because we omit a
-            -- warning in that case (#3966)
-       }
-  where
     can_unbox :: HsBang -> TcType -> HsBang
     -- Returns   HsUnpack  if we can unpack arg_ty
     --                  fail_bang if we know what arg_ty is but we can't unpack it
index 8c5ef00..527cbfc 100644 (file)
@@ -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))
index 0051d07..5dfbaa5 100644 (file)
@@ -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
index 9ed4e2c..a03875f 100644 (file)
@@ -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
deleted file mode 100644 (file)
index 4ad7dee..0000000
+++ /dev/null
@@ -1,58 +0,0 @@
-
-import Data.Word
-import Data.Int
-
--- This magical #include brings in all the everybody-knows-these magic
--- constants unfortunately, we need to be *explicit* about which one
--- we want; if we just hope a -I... will get the right one, we could
--- be in trouble.
-
-{-
-Pull in the autoconf defines (HAVE_FOO), but don't include
-ghcconfig.h, because that will include ghcplatform.h which has the
-wrong platform settings for the compiler (it has the platform
-settings for the target plat instead).
--}
-#include "../includes/ghcautoconf.h"
-
-#include "stg/HaskellMachRegs.h"
-
-#include "rts/Constants.h"
-#include "MachDeps.h"
-#include "../includes/dist-derivedconstants/header/DerivedConstants.h"
-
--- import Util
-
--- All pretty arbitrary:
-
-mAX_TUPLE_SIZE :: Int
-mAX_TUPLE_SIZE = 62 -- Should really match the number
-                    -- of decls in Data.Tuple
-
-mAX_CONTEXT_REDUCTION_DEPTH :: Int
-mAX_CONTEXT_REDUCTION_DEPTH = 200
-  -- Increase to 200; see Trac #5395
-
-wORD64_SIZE :: Int
-wORD64_SIZE = 8
-
--- Define a fixed-range integral type equivalent to the target Int/Word
-
-#if SIZEOF_HSWORD == 4
-type TargetInt  = Int32
-type TargetWord = Word32
-#elif SIZEOF_HSWORD == 8
-type TargetInt  = Int64
-type TargetWord = Word64
-#else
-#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
-
index 7bdaef5..9360645 100644 (file)
@@ -404,6 +404,10 @@ GarbageCollect (nat collect_gen,
       break;
   }
 
+  if (n_gc_threads != 1) {
+      gct->allocated = clearNursery(cap);
+  }
+
   shutdown_gc_threads(gct->thread_index);
 
   // Now see which stable names are still alive.
@@ -636,9 +640,15 @@ GarbageCollect (nat collect_gen,
           allocated += clearNursery(&capabilities[n]);
       }
   } else {
-      gct->allocated = clearNursery(cap);
+      // When doing parallel GC, clearNursery() is called by the
+      // worker threads, and the value returned is stored in
+      // gct->allocated.
       for (n = 0; n < n_capabilities; n++) {
-          allocated += gc_threads[n]->allocated;
+          if (gc_threads[n]->idle) {
+              allocated += clearNursery(&capabilities[n]);
+          } else {
+              allocated += gc_threads[n]->allocated;
+          }
       }
   }