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

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

1 files changed, 97 insertions, 87 deletions

diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 100d821cb0..4471b78151 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -57,7 +57,6 @@ import ForeignCall
 import IdInfo
 import Type
 import TyCon
-import Constants
 import SMRep
 import Module
 import Literal
@@ -68,7 +67,6 @@ import Unique
 import DynFlags
 import FastString
 import Outputable
-import Platform
 
 import Data.Char
 import Data.List
@@ -86,31 +84,32 @@ import Data.Maybe
 cgLit :: Literal -> FCode CmmLit
 cgLit (MachStr s) = newByteStringCLit (bytesFB s)
  -- not unpackFS; we want the UTF-8 byte stream.
-cgLit other_lit   = return (mkSimpleLit other_lit)
+cgLit other_lit   = do dflags <- getDynFlags
+                       return (mkSimpleLit dflags other_lit)
 
-mkLtOp :: Literal -> MachOp
+mkLtOp :: DynFlags -> Literal -> MachOp
 -- On signed literals we must do a signed comparison
-mkLtOp (MachInt _)    = MO_S_Lt wordWidth
-mkLtOp (MachFloat _)  = MO_F_Lt W32
-mkLtOp (MachDouble _) = MO_F_Lt W64
-mkLtOp lit            = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
+mkLtOp dflags (MachInt _)    = MO_S_Lt (wordWidth dflags)
+mkLtOp _      (MachFloat _)  = MO_F_Lt W32
+mkLtOp _      (MachDouble _) = MO_F_Lt W64
+mkLtOp dflags lit            = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit)))
                                 -- ToDo: seems terribly indirect!
 
-mkSimpleLit :: Literal -> CmmLit
-mkSimpleLit (MachChar   c)    = CmmInt (fromIntegral (ord c)) wordWidth
-mkSimpleLit MachNullAddr      = zeroCLit
-mkSimpleLit (MachInt i)       = CmmInt i wordWidth
-mkSimpleLit (MachInt64 i)     = CmmInt i W64
-mkSimpleLit (MachWord i)      = CmmInt i wordWidth
-mkSimpleLit (MachWord64 i)    = CmmInt i W64
-mkSimpleLit (MachFloat r)     = CmmFloat r W32
-mkSimpleLit (MachDouble r)    = CmmFloat r W64
-mkSimpleLit (MachLabel fs ms fod)
+mkSimpleLit :: DynFlags -> Literal -> CmmLit
+mkSimpleLit dflags (MachChar   c)    = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
+mkSimpleLit dflags MachNullAddr      = zeroCLit dflags
+mkSimpleLit dflags (MachInt i)       = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (MachInt64 i)     = CmmInt i W64
+mkSimpleLit dflags (MachWord i)      = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (MachWord64 i)    = CmmInt i W64
+mkSimpleLit _      (MachFloat r)     = CmmFloat r W32
+mkSimpleLit _      (MachDouble r)    = CmmFloat r W64
+mkSimpleLit _      (MachLabel fs ms fod)
         = CmmLabel (mkForeignLabel fs ms labelSrc fod)
         where
                 -- TODO: Literal labels might not actually be in the current package...
                 labelSrc = ForeignLabelInThisPackage
-mkSimpleLit other             = pprPanic "mkSimpleLit" (ppr other)
+mkSimpleLit _ other             = pprPanic "mkSimpleLit" (ppr other)
 
 --------------------------------------------------------------------------
 --
@@ -142,14 +141,15 @@ addToMemE rep ptr n
 --
 -------------------------------------------------------------------------
 
-mkTaggedObjectLoad :: LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph
+mkTaggedObjectLoad :: DynFlags -> LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph
 -- (loadTaggedObjectField reg base off tag) generates assignment
 --      reg = bitsK[ base + off - tag ]
 -- where K is fixed by 'reg'
-mkTaggedObjectLoad reg base offset tag
+mkTaggedObjectLoad dflags reg base offset tag
   = mkAssign (CmmLocal reg)
-             (CmmLoad (cmmOffsetB (CmmReg (CmmLocal base))
-                                  (wORD_SIZE*offset - tag))
+             (CmmLoad (cmmOffsetB dflags
+                                  (CmmReg (CmmLocal base))
+                                  (wORD_SIZE dflags * offset - tag))
                       (localRegType reg))
 
 -------------------------------------------------------------------------
@@ -159,9 +159,9 @@ mkTaggedObjectLoad reg base offset tag
 --
 -------------------------------------------------------------------------
 
-tagToClosure :: TyCon -> CmmExpr -> CmmExpr
-tagToClosure tycon tag
-  = CmmLoad (cmmOffsetExprW closure_tbl tag) bWord
+tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
+tagToClosure dflags tycon tag
+  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)
   where closure_tbl = CmmLit (CmmLabel lbl)
         lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
 
@@ -251,11 +251,11 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
     regs_to_save = filter (callerSaves platform) system_regs
 
     callerSaveGlobalReg reg
-        = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg))
+        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
 
     callerRestoreGlobalReg reg
         = mkAssign (CmmGlobal reg)
-                    (CmmLoad (get_GlobalReg_addr platform reg) (globalRegType reg))
+                    (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
 
 -- -----------------------------------------------------------------------------
 -- Global registers
@@ -266,42 +266,42 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
 -- register table address for it.
 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
 
-get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr
-get_GlobalReg_addr _        BaseReg = regTableOffset 0
-get_GlobalReg_addr platform mid
-    = get_Regtable_addr_from_offset platform
-                                    (globalRegType mid) (baseRegOffset mid)
+get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
+get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
+get_GlobalReg_addr dflags mid
+    = get_Regtable_addr_from_offset dflags
+                                    (globalRegType dflags mid) (baseRegOffset dflags mid)
 
 -- Calculate a literal representing an offset into the register table.
 -- Used when we don't have an actual BaseReg to offset from.
-regTableOffset :: Int -> CmmExpr
-regTableOffset n =
-  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
+regTableOffset :: DynFlags -> Int -> CmmExpr
+regTableOffset dflags n =
+  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
 
-get_Regtable_addr_from_offset :: Platform -> CmmType -> Int -> CmmExpr
-get_Regtable_addr_from_offset platform _rep offset =
-    if haveRegBase platform
+get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
+get_Regtable_addr_from_offset dflags _rep offset =
+    if haveRegBase (targetPlatform dflags)
     then CmmRegOff (CmmGlobal BaseReg) offset
-    else regTableOffset offset
+    else regTableOffset dflags offset
 
 
 -- -----------------------------------------------------------------------------
 -- Information about global registers
 
-baseRegOffset :: GlobalReg -> Int
-
-baseRegOffset Sp                  = oFFSET_StgRegTable_rSp
-baseRegOffset SpLim               = oFFSET_StgRegTable_rSpLim
-baseRegOffset (LongReg 1)         = oFFSET_StgRegTable_rL1
-baseRegOffset Hp                  = oFFSET_StgRegTable_rHp
-baseRegOffset HpLim               = oFFSET_StgRegTable_rHpLim
-baseRegOffset CCCS                = oFFSET_StgRegTable_rCCCS
-baseRegOffset CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO
-baseRegOffset CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery
-baseRegOffset HpAlloc             = oFFSET_StgRegTable_rHpAlloc
-baseRegOffset GCEnter1            = oFFSET_stgGCEnter1
-baseRegOffset GCFun               = oFFSET_stgGCFun
-baseRegOffset reg                 = pprPanic "baseRegOffset:" (ppr reg)
+baseRegOffset :: DynFlags -> GlobalReg -> Int
+
+baseRegOffset dflags Sp             = oFFSET_StgRegTable_rSp dflags
+baseRegOffset dflags SpLim          = oFFSET_StgRegTable_rSpLim dflags
+baseRegOffset dflags (LongReg 1)    = oFFSET_StgRegTable_rL1 dflags
+baseRegOffset dflags Hp             = oFFSET_StgRegTable_rHp dflags
+baseRegOffset dflags HpLim          = oFFSET_StgRegTable_rHpLim dflags
+baseRegOffset dflags CCCS           = oFFSET_StgRegTable_rCCCS dflags
+baseRegOffset dflags CurrentTSO     = oFFSET_StgRegTable_rCurrentTSO dflags
+baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
+baseRegOffset dflags HpAlloc        = oFFSET_StgRegTable_rHpAlloc dflags
+baseRegOffset dflags GCEnter1       = oFFSET_stgGCEnter1 dflags
+baseRegOffset dflags GCFun          = oFFSET_stgGCFun dflags
+baseRegOffset _      reg            = pprPanic "baseRegOffset:" (ppr reg)
 
 -------------------------------------------------------------------------
 --
@@ -344,8 +344,9 @@ assignTemp :: CmmExpr -> FCode LocalReg
 -- due to them being trashed on foreign calls--though it means
 -- the optimization pass doesn't have to do as much work)
 assignTemp (CmmReg (CmmLocal reg)) = return reg
-assignTemp e = do { uniq <- newUnique
-                  ; let reg = LocalReg uniq (cmmExprType e)
+assignTemp e = do { dflags <- getDynFlags
+                  ; uniq <- newUnique
+                  ; let reg = LocalReg uniq (cmmExprType dflags e)
                   ; emitAssign (CmmLocal reg) e
                   ; return reg }
 
@@ -360,8 +361,9 @@ newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
 -- regs it wants will save later assignments.
 newUnboxedTupleRegs res_ty
   = ASSERT( isUnboxedTupleType res_ty )
-    do  { sequel <- getSequel
-        ; regs <- choose_regs sequel
+    do  { dflags <- getDynFlags
+        ; sequel <- getSequel
+        ; regs <- choose_regs dflags sequel
         ; ASSERT( regs `equalLength` reps )
           return (regs, map primRepForeignHint reps) }
   where
@@ -370,8 +372,8 @@ newUnboxedTupleRegs res_ty
            | ty <- ty_args
            , let rep = typePrimRep ty
            , not (isVoidRep rep) ]
-    choose_regs (AssignTo regs _) = return regs
-    choose_regs _other            = mapM (newTemp . primRepCmmType) reps
+    choose_regs _ (AssignTo regs _) = return regs
+    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps
 
 
 
@@ -423,17 +425,18 @@ unscramble vertices = mapM_ do_component components
                 -- Cyclic?  Then go via temporaries.  Pick one to
                 -- break the loop and try again with the rest.
         do_component (CyclicSCC ((_,first_stmt) : rest)) = do
+            dflags <- getDynFlags
             u <- newUnique
-            let (to_tmp, from_tmp) = split u first_stmt
+            let (to_tmp, from_tmp) = split dflags u first_stmt
             mk_graph to_tmp
             unscramble rest
             mk_graph from_tmp
 
-        split :: Unique -> Stmt -> (Stmt, Stmt)
-        split uniq (reg, rhs)
+        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
+        split dflags uniq (reg, rhs)
           = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
           where
-            rep = cmmExprType rhs
+            rep = cmmExprType dflags rhs
             tmp = LocalReg uniq rep
 
         mk_graph :: Stmt -> FCode ()
@@ -510,11 +513,11 @@ mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _
 
 -- SINGLETON BRANCH: one equality check to do
 mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
-  = return (mkCbranch cond deflt lbl)
-  where
-    cond =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
-        -- We have lo_tag < hi_tag, but there's only one branch,
-        -- so there must be a default
+  = do dflags <- getDynFlags
+       let cond =  cmmNeWord dflags tag_expr (mkIntExpr dflags tag)
+            -- We have lo_tag < hi_tag, but there's only one branch,
+            -- so there must be a default
+       return (mkCbranch cond deflt lbl)
 
 -- ToDo: we might want to check for the two branch case, where one of
 -- the branches is the tag 0, because comparing '== 0' is likely to be
@@ -531,7 +534,7 @@ mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
 --
 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
   | use_switch  -- Use a switch
-  = let
+  = do let
         find_branch :: ConTagZ -> Maybe BlockId
         find_branch i = case (assocMaybe branches i) of
                           Just lbl -> Just lbl
@@ -542,33 +545,36 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
         -- tag of a real branch is real_lo_tag (not lo_tag).
         arms :: [Maybe BlockId]
         arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
-    in
-    return (mkSwitch (cmmOffset tag_expr (- real_lo_tag)) arms)
+       dflags <- getDynFlags
+       return (mkSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms)
 
   -- if we can knock off a bunch of default cases with one if, then do so
   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
-  = do stmts <- mk_switch tag_expr branches mb_deflt
+  = do dflags <- getDynFlags
+       stmts <- mk_switch tag_expr branches mb_deflt
                         lowest_branch hi_tag via_C
        mkCmmIfThenElse
-        (cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch)))
+        (cmmULtWord dflags tag_expr (mkIntExpr dflags lowest_branch))
         (mkBranch deflt)
         stmts
 
   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
-  = do stmts <- mk_switch tag_expr branches mb_deflt
+  = do dflags <- getDynFlags
+       stmts <- mk_switch tag_expr branches mb_deflt
                         lo_tag highest_branch via_C
        mkCmmIfThenElse
-        (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
+        (cmmUGtWord dflags tag_expr (mkIntExpr dflags highest_branch))
         (mkBranch deflt)
         stmts
 
   | otherwise   -- Use an if-tree
-  = do lo_stmts <- mk_switch tag_expr lo_branches mb_deflt
+  = do dflags <- getDynFlags
+       lo_stmts <- mk_switch tag_expr lo_branches mb_deflt
                              lo_tag (mid_tag-1) via_C
        hi_stmts <- mk_switch tag_expr hi_branches mb_deflt
                              mid_tag hi_tag via_C
        mkCmmIfThenElse
-        (cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag)))
+        (cmmUGeWord dflags tag_expr (mkIntExpr dflags mid_tag))
         hi_stmts
         lo_stmts
         -- we test (e >= mid_tag) rather than (e < mid_tag), because
@@ -649,17 +655,20 @@ mk_lit_switch :: CmmExpr -> BlockId
               -> [(Literal,BlockId)]
               -> FCode CmmAGraph
 mk_lit_switch scrut deflt [(lit,blk)]
-  = return (mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk)
-  where
-    cmm_lit = mkSimpleLit lit
-    cmm_ty  = cmmLitType cmm_lit
+  = do
+  dflags <- getDynFlags
+  let
+    cmm_lit = mkSimpleLit dflags lit
+    cmm_ty  = cmmLitType dflags cmm_lit
     rep     = typeWidth cmm_ty
     ne      = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
+  return (mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk)
 
 mk_lit_switch scrut deflt_blk_id branches
-  = do lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
+  = do dflags <- getDynFlags
+       lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
        hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
-       mkCmmIfThenElse cond lo_blk hi_blk
+       mkCmmIfThenElse (cond dflags) lo_blk hi_blk
   where
     n_branches = length branches
     (mid_lit,_) = branches !! (n_branches `div` 2)
@@ -668,8 +677,8 @@ mk_lit_switch scrut deflt_blk_id branches
     (lo_branches, hi_branches) = span is_lo branches
     is_lo (t,_) = t < mid_lit
 
-    cond = CmmMachOp (mkLtOp mid_lit)
-                        [scrut, CmmLit (mkSimpleLit mid_lit)]
+    cond dflags = CmmMachOp (mkLtOp dflags mid_lit)
+                            [scrut, CmmLit (mkSimpleLit dflags mid_lit)]
 
 
 --------------
@@ -705,7 +714,8 @@ assignTemp' :: CmmExpr -> FCode CmmExpr
 assignTemp' e
   | isTrivialCmmExpr e = return e
   | otherwise = do
-       lreg <- newTemp (cmmExprType e)
+       dflags <- getDynFlags
+       lreg <- newTemp (cmmExprType dflags e)
        let reg = CmmLocal lreg
        emitAssign reg e
        return (CmmReg reg)