Merge remote-tracking branch 'origin/master' into tc-untouchables

Conflicts:
	compiler/typecheck/TcMType.lhs
	compiler/typecheck/TcSMonad.lhs

1 files changed, 24 insertions, 26 deletions

diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index 083e615b78..c822a64e2c 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -31,7 +31,6 @@ import MkGraph
 import SMRep
 import CostCentre
 import Module
-import Constants
 import DataCon
 import DynFlags
 import FastString
@@ -56,14 +55,14 @@ cgTopRhsCon :: Id               -- Name of thing bound to this RHS
             -> [StgArg]         -- Args
             -> FCode (CgIdInfo, FCode ())
 cgTopRhsCon id con args
-  = return ( id_info, gen_code )
+  = do dflags <- getDynFlags
+       let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)
+       return ( id_info, gen_code )
   where
    name          = idName id
    caffy         = idCafInfo id -- any stgArgHasCafRefs args
    closure_label = mkClosureLabel name caffy
 
-   id_info = litIdInfo id (mkConLFInfo con) (CmmLabel closure_label)
-
    gen_code =
      do { dflags <- getDynFlags
         ; when (platformOS (targetPlatform dflags) == OSMinGW32) $
@@ -149,8 +148,8 @@ premature looking at the args will cause the compiler to black-hole!
 -- which have exclusively size-zero (VoidRep) args, we generate no code
 -- at all.
 
-buildDynCon' _ _ binder _cc con []
-  = return (litIdInfo binder (mkConLFInfo con)
+buildDynCon' dflags _ binder _cc con []
+  = return (litIdInfo dflags binder (mkConLFInfo con)
                 (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
             return mkNop)
 
@@ -184,14 +183,14 @@ buildDynCon' dflags platform binder _cc con [arg]
   | maybeIntLikeCon con
   , platformOS platform /= OSMinGW32 || not (dopt Opt_PIC dflags)
   , StgLitArg (MachInt val) <- arg
-  , val <= fromIntegral mAX_INTLIKE     -- Comparisons at type Integer!
-  , val >= fromIntegral mIN_INTLIKE     -- ...ditto...
+  , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
+  , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
   = do  { let intlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
               val_int = fromIntegral val :: Int
-              offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize dflags + 1)
+              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1)
                 -- INTLIKE closures consist of a header and one word payload
-              intlike_amode = cmmLabelOffW intlike_lbl offsetW
-        ; return ( litIdInfo binder (mkConLFInfo con) intlike_amode
+              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW
+        ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
                  , return mkNop) }
 
 buildDynCon' dflags platform binder _cc con [arg]
@@ -199,13 +198,13 @@ buildDynCon' dflags platform binder _cc con [arg]
   , platformOS platform /= OSMinGW32 || not (dopt Opt_PIC dflags)
   , StgLitArg (MachChar val) <- arg
   , let val_int = ord val :: Int
-  , val_int <= mAX_CHARLIKE
-  , val_int >= mIN_CHARLIKE
+  , val_int <= mAX_CHARLIKE dflags
+  , val_int >= mIN_CHARLIKE dflags
   = do  { let charlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
-              offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize dflags + 1)
+              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1)
                 -- CHARLIKE closures consist of a header and one word payload
-              charlike_amode = cmmLabelOffW charlike_lbl offsetW
-        ; return ( litIdInfo binder (mkConLFInfo con) charlike_amode
+              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
+        ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode
                  , return mkNop) }
 
 -------- buildDynCon': the general case -----------
@@ -225,7 +224,7 @@ buildDynCon' dflags _ binder ccs con args
                                 ptr_wds nonptr_wds
           ; hp_plus_n <- allocDynClosure info_tbl lf_info
                                           use_cc blame_cc args_w_offsets
-          ; return (mkRhsInit reg lf_info hp_plus_n) }
+          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
     where
       use_cc      -- cost-centre to stick in the object
         | isCurrentCCS ccs = curCCS
@@ -247,16 +246,15 @@ bindConArgs (DataAlt con) base args
   = ASSERT(not (isUnboxedTupleCon con))
     do dflags <- getDynFlags
        let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)
+           tag = tagForCon dflags con
+
+           -- The binding below forces the masking out of the tag bits
+           -- when accessing the constructor field.
+           bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
+           bind_arg (arg, offset)
+               = do emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag
+                    bindArgToReg arg
        mapM bind_arg args_w_offsets
-  where
-    tag = tagForCon con
-
-          -- The binding below forces the masking out of the tag bits
-          -- when accessing the constructor field.
-    bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
-    bind_arg (arg, offset)
-        = do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag
-             ; bindArgToReg arg }
 
 bindConArgs _other_con _base args
   = ASSERT( null args ) return []