Add "Unregisterised" as a field in the settings file

To explicitly choose whether you want an unregisterised build you now
need to use the "--enable-unregisterised"/"--disable-unregisterised"
configure flags.

10 files changed, 91 insertions, 67 deletions

diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs
index 332ec0746a..9443e0e936 100644
--- a/compiler/codeGen/CgCallConv.hs
+++ b/compiler/codeGen/CgCallConv.hs
@@ -43,10 +43,10 @@ import Id
 import Name
 import Util
 import DynFlags
-import StaticFlags
 import Module
 import FastString
 import Outputable
+import Platform
 import Data.Bits
 
 -------------------------------------------------------------------------
@@ -255,16 +255,19 @@ getSequelAmode
 -- registers.  This is used for calling special RTS functions and PrimOps
 -- which expect their arguments to always be in the same registers.
 
-assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
-        :: [(CgRep,a)]          -- Arg or result values to assign
-        -> ([(a, GlobalReg)],   -- Register assignment in same order
-                                -- for *initial segment of* input list
-                                --   (but reversed; doesn't matter)
-                                -- VoidRep args do not appear here
-            [(CgRep,a)])        -- Leftover arg or result values
+type AssignRegs a = [(CgRep,a)]          -- Arg or result values to assign
+                 -> ([(a, GlobalReg)],   -- Register assignment in same order
+                                         -- for *initial segment of* input list
+                                         --   (but reversed; doesn't matter)
+                                         -- VoidRep args do not appear here
+                     [(CgRep,a)])        -- Leftover arg or result values
 
-assignCallRegs args
-  = assign_regs args (mkRegTbl [node])
+assignCallRegs       :: DynFlags -> AssignRegs a
+assignPrimOpCallRegs ::             AssignRegs a
+assignReturnRegs     :: DynFlags -> AssignRegs a
+
+assignCallRegs dflags args
+  = assign_regs args (mkRegTbl dflags [node])
         -- The entry convention for a function closure
         -- never uses Node for argument passing; instead
         -- Node points to the function closure itself
@@ -273,7 +276,7 @@ assignPrimOpCallRegs args
  = assign_regs args (mkRegTbl_allRegs [])
         -- For primops, *all* arguments must be passed in registers
 
-assignReturnRegs args
+assignReturnRegs dflags args
  -- when we have a single non-void component to return, use the normal
  -- unpointed return convention.  This make various things simpler: it
  -- means we can assume a consistent convention for IO, which is useful
@@ -285,7 +288,7 @@ assignReturnRegs args
  | [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
     = ([(arg, r)], [])
  | otherwise
-    = assign_regs args (mkRegTbl [])
+    = assign_regs args (mkRegTbl dflags [])
         -- For returning unboxed tuples etc,
         -- we use all regs
  where
@@ -327,24 +330,28 @@ assign_reg _         _                  = Nothing
 -- We take these register supplies from the *real* registers, i.e. those
 -- that are guaranteed to map to machine registers.
 
-useVanillaRegs :: Int
-useVanillaRegs | opt_Unregisterised = 0
-               | otherwise          = mAX_Real_Vanilla_REG
-useFloatRegs :: Int
-useFloatRegs   | opt_Unregisterised = 0
-               | otherwise          = mAX_Real_Float_REG
-useDoubleRegs :: Int
-useDoubleRegs  | opt_Unregisterised = 0
-               | otherwise          = mAX_Real_Double_REG
-useLongRegs :: Int
-useLongRegs    | opt_Unregisterised = 0
-               | otherwise          = mAX_Real_Long_REG
-
-vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
-vanillaRegNos    = regList useVanillaRegs
-floatRegNos      = regList useFloatRegs
-doubleRegNos     = regList useDoubleRegs
-longRegNos       = regList useLongRegs
+useVanillaRegs :: DynFlags -> Int
+useVanillaRegs dflags
+ | platformUnregisterised (targetPlatform dflags) = 0
+ | otherwise                                      = mAX_Real_Vanilla_REG
+useFloatRegs :: DynFlags -> Int
+useFloatRegs dflags
+ | platformUnregisterised (targetPlatform dflags) = 0
+ | otherwise                                      = mAX_Real_Float_REG
+useDoubleRegs :: DynFlags -> Int
+useDoubleRegs dflags
+ | platformUnregisterised (targetPlatform dflags) = 0
+ | otherwise                                      = mAX_Real_Double_REG
+useLongRegs :: DynFlags -> Int
+useLongRegs dflags
+ | platformUnregisterised (targetPlatform dflags) = 0
+ | otherwise                                      = mAX_Real_Long_REG
+
+vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
+vanillaRegNos dflags = regList $ useVanillaRegs dflags
+floatRegNos   dflags = regList $ useFloatRegs   dflags
+doubleRegNos  dflags = regList $ useDoubleRegs  dflags
+longRegNos    dflags = regList $ useLongRegs    dflags
 
 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
 allVanillaRegNos = regList mAX_Vanilla_REG
@@ -361,9 +368,12 @@ type AvailRegs = ( [Int]   -- available vanilla regs.
                  , [Int]   -- longs (int64 and word64)
                  )
 
-mkRegTbl :: [GlobalReg] -> AvailRegs
-mkRegTbl regs_in_use
-  = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
+mkRegTbl :: DynFlags -> [GlobalReg] -> AvailRegs
+mkRegTbl dflags regs_in_use
+  = mkRegTbl' regs_in_use (vanillaRegNos dflags)
+                          (floatRegNos   dflags)
+                          (doubleRegNos  dflags)
+                          (longRegNos    dflags)
 
 mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
 mkRegTbl_allRegs regs_in_use
diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index 053314b966..f1da2d4235 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -273,10 +273,12 @@ Node points to closure is available. -- HWL
 \begin{code}
 closureCodeBody _binder_info cl_info cc args body 
   = ASSERT( length args > 0 )
-  do { 	-- Get the current virtual Sp (it might not be zero, 
+  do {
+    dflags <- getDynFlags
+        -- Get the current virtual Sp (it might not be zero, 
 	-- eg. if we're compiling a let-no-escape).
-    vSp <- getVirtSp
-  ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
+  ; vSp <- getVirtSp
+  ; let (reg_args, other_args) = assignCallRegs dflags (addIdReps args)
 	(sp_top, stk_args)     = mkVirtStkOffsets vSp other_args
 
 	-- Allocate the global ticky counter
diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index 15347de060..4c451ec339 100644
--- a/compiler/codeGen/CgCon.lhs
+++ b/compiler/codeGen/CgCon.lhs
@@ -271,11 +271,13 @@ bindUnboxedTupleComponents
 
 bindUnboxedTupleComponents args
  =  do  {
-          vsp <- getVirtSp
+          dflags <- getDynFlags
+
+        ; vsp <- getVirtSp
         ; rsp <- getRealSp
 
            -- Assign as many components as possible to registers
-        ; let (reg_args, stk_args) = assignReturnRegs (addIdReps args)
+        ; let (reg_args, stk_args) = assignReturnRegs dflags (addIdReps args)
 
                 -- Separate the rest of the args into pointers and non-pointers
               (ptr_args, nptr_args) = separateByPtrFollowness stk_args
diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs
index 6f98e4a09c..6db1b46d77 100644
--- a/compiler/codeGen/CgTailCall.lhs
+++ b/compiler/codeGen/CgTailCall.lhs
@@ -255,7 +255,7 @@ directCall sp lbl args extra_args live_node assts = do
   dflags <- getDynFlags
   let
 	-- First chunk of args go in registers
-	(reg_arg_amodes, stk_args) = assignCallRegs args
+	(reg_arg_amodes, stk_args) = assignCallRegs dflags args
      
 	-- Any "extra" arguments are placed in frames on the
 	-- stack after the other arguments.
@@ -354,7 +354,8 @@ pushUnboxedTuple :: VirtualSpOffset		-- Sp at which to start pushing
 pushUnboxedTuple sp [] 
   = return (sp, noStmts, [])
 pushUnboxedTuple sp amodes
-  = do	{ let	(reg_arg_amodes, stk_arg_amodes) = assignReturnRegs amodes
+  = do	{ dflags <- getDynFlags
+        ; let	(reg_arg_amodes, stk_arg_amodes) = assignReturnRegs dflags amodes
                 live_regs = map snd reg_arg_amodes
 	
 		-- separate the rest of the args into pointers and non-pointers
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index a38078a1c8..cb2b41d852 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -470,7 +470,8 @@ mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
        let slow_lbl = closureSlowEntryLabel  cl_info
            fast_lbl = closureLocalEntryLabel dflags cl_info
            -- mkDirectJump does not clobber `Node' containing function closure
-           jump = mkDirectJump (mkLblExpr fast_lbl)
+           jump = mkDirectJump dflags
+                               (mkLblExpr fast_lbl)
                                (map (CmmReg . CmmLocal) arg_regs)
                                initUpdFrameOff
        emitProcWithConvention Slow Nothing slow_lbl arg_regs jump
@@ -680,7 +681,7 @@ link_caf _is_upd = do
         -- assuming lots of things, like the stack pointer hasn't
         -- moved since we entered the CAF.
        (let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in
-        mkJump target [] updfr)
+        mkJump dflags target [] updfr)
 
   ; return hp_rel }
 
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 35533ec933..1d016d6b3d 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -674,7 +674,7 @@ emitEnter fun = do
       -- test, just generating an enter.
       Return _ -> do
         { let entry = entryCode dflags $ closureInfoPtr $ CmmReg nodeReg
-        ; emit $ mkForeignJump NativeNodeCall entry
+        ; emit $ mkForeignJump dflags NativeNodeCall entry
                     [cmmUntag fun] updfr_off
         ; return AssignedDirectly
         }
@@ -706,11 +706,11 @@ emitEnter fun = do
       --
       AssignTo res_regs _ -> do
        { lret <- newLabelC
-       ; let (off, copyin) = copyInOflow NativeReturn (Young lret) res_regs
+       ; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs
        ; lcall <- newLabelC
        ; updfr_off <- getUpdFrameOff
        ; let area = Young lret
-       ; let (outArgs, regs, copyout) = copyOutOflow NativeNodeCall Call area
+       ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area
                                           [fun] updfr_off (0,[])
          -- refer to fun via nodeReg after the copyout, to avoid having
          -- both live simultaneously; this sometimes enables fun to be
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index 8fec067288..3976dee6f8 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -214,10 +214,11 @@ emitForeignCall safety results target args _ret
     return AssignedDirectly
 
   | otherwise = do
+    dflags <- getDynFlags
     updfr_off <- getUpdFrameOff
     temp_target <- load_target_into_temp target
     k <- newLabelC
-    let (off, copyout) = copyInOflow NativeReturn (Young k) results
+    let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results
        -- see Note [safe foreign call convention]
     emit $
            (    mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth))
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index ddb6dd01e4..d3bf17f7d7 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -348,7 +348,8 @@ entryHeapCheck :: ClosureInfo
                -> FCode ()
 
 entryHeapCheck cl_info offset nodeSet arity args code
-  = do let is_thunk = arity == 0
+  = do dflags <- getDynFlags
+       let is_thunk = arity == 0
            is_fastf = case closureFunInfo cl_info of
                            Just (_, ArgGen _) -> False
                            _otherwise         -> True
@@ -365,9 +366,9 @@ entryHeapCheck cl_info offset nodeSet arity args code
               Function (slow): Set R1 = node, call generic_gc -}
            gc_call upd = setN <*> gc_lbl upd
            gc_lbl upd
-               | is_thunk  = mkDirectJump (CmmReg $ CmmGlobal GCEnter1) [] sp
-               | is_fastf  = mkDirectJump (CmmReg $ CmmGlobal GCFun) [] sp
-               | otherwise = mkForeignJump Slow (CmmReg $ CmmGlobal GCFun) args' upd
+               | is_thunk  = mkDirectJump dflags (CmmReg $ CmmGlobal GCEnter1) [] sp
+               | is_fastf  = mkDirectJump dflags (CmmReg $ CmmGlobal GCFun) [] sp
+               | otherwise = mkForeignJump dflags Slow (CmmReg $ CmmGlobal GCFun) args' upd
                where sp = max offset upd
            {- DT (12/08/10) This is a little fishy, mainly the sp fix up amount.
             - This is since the ncg inserts spills before the stack/heap check.
@@ -447,8 +448,9 @@ altHeapCheck regs code
   = case cannedGCEntryPoint regs of
       Nothing -> genericGC code
       Just gc -> do
+        dflags <- getDynFlags
         lret <- newLabelC
-        let (off, copyin) = copyInOflow NativeReturn (Young lret) regs
+        let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs
         lcont <- newLabelC
         emitOutOfLine lret (copyin <*> mkBranch lcont)
         emitLabel lcont
@@ -464,15 +466,16 @@ cannedGCReturnsTo :: Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
                   -> FCode a
                   -> FCode a
 cannedGCReturnsTo cont_on_stack gc regs lret off code
-  = do updfr_sz <- getUpdFrameOff
-       heapCheck False (gc_call gc updfr_sz) code
+  = do dflags <- getDynFlags
+       updfr_sz <- getUpdFrameOff
+       heapCheck False (gc_call dflags gc updfr_sz) code
   where
     reg_exprs = map (CmmReg . CmmLocal) regs
       -- Note [stg_gc arguments]
 
-    gc_call label sp
-      | cont_on_stack = mkJumpReturnsTo label GC reg_exprs lret off sp
-      | otherwise     = mkCallReturnsTo label GC reg_exprs lret off sp (0,[])
+    gc_call dflags label sp
+      | cont_on_stack = mkJumpReturnsTo dflags label GC reg_exprs lret off sp
+      | otherwise     = mkCallReturnsTo dflags label GC reg_exprs lret off sp (0,[])
 
 genericGC :: FCode a -> FCode a
 genericGC code
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 4e2b478f77..e20e4a29bd 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -78,12 +78,13 @@ import FastString
 --
 emitReturn :: [CmmExpr] -> FCode ReturnKind
 emitReturn results
-  = do { sequel    <- getSequel;
+  = do { dflags    <- getDynFlags
+       ; sequel    <- getSequel
        ; updfr_off <- getUpdFrameOff
        ; case sequel of
            Return _ ->
              do { adjustHpBackwards
-                ; emit (mkReturnSimple results updfr_off) }
+                ; emit (mkReturnSimple dflags results updfr_off) }
            AssignTo regs adjust ->
              do { if adjust then adjustHpBackwards else return ()
                 ; emitMultiAssign  regs results }
@@ -109,18 +110,19 @@ emitCallWithExtraStack
    :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
    -> (ByteOff, [(CmmExpr,ByteOff)]) -> FCode ReturnKind
 emitCallWithExtraStack (callConv, retConv) fun args extra_stack
-  = do	{ adjustHpBackwards
+  = do	{ dflags <- getDynFlags
+        ; adjustHpBackwards
 	; sequel <- getSequel
 	; updfr_off <- getUpdFrameOff
         ; case sequel of
             Return _ -> do
-              emit $ mkForeignJumpExtra callConv fun args updfr_off extra_stack
+              emit $ mkForeignJumpExtra dflags callConv fun args updfr_off extra_stack
               return AssignedDirectly
             AssignTo res_regs _ -> do
               k <- newLabelC
               let area = Young k
-                  (off, copyin) = copyInOflow retConv area res_regs
-                  copyout = mkCallReturnsTo fun callConv args k off updfr_off
+                  (off, copyin) = copyInOflow dflags retConv area res_regs
+                  copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off
                                    extra_stack
               emit (copyout <*> mkLabel k <*> copyin)
               return (ReturnedTo k off)
@@ -537,7 +539,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
         ; let args' = if node_points then (node : arg_regs) else arg_regs
               conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall
                                                           else NativeDirectCall
-              (offset, _) = mkCallEntry conv args'
+              (offset, _) = mkCallEntry dflags conv args'
         ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
         }
 
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 3d34cb9bdd..1819e44bb6 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -725,8 +725,9 @@ emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
 emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
                        -> [CmmFormal] -> CmmAGraph -> FCode ()
 emitProcWithConvention conv mb_info lbl args blocks
-  = do  { us <- newUniqSupply
-        ; let (offset, entry) = mkCallEntry conv args
+  = do  { dflags <- getDynFlags
+        ; us <- newUniqSupply
+        ; let (offset, entry) = mkCallEntry dflags conv args
               blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
         ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff}
               tinfo = TopInfo {info_tbls = infos, stack_info=sinfo}
@@ -783,10 +784,11 @@ mkCmmIfThen e tbranch = do
 mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
        -> UpdFrameOffset -> (ByteOff,[(CmmExpr,ByteOff)]) -> FCode CmmAGraph
 mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
+  dflags <- getDynFlags
   k <- newLabelC
   let area = Young k
-      (off, copyin) = copyInOflow retConv area results
-      copyout = mkCallReturnsTo f callConv actuals k off updfr_off extra_stack
+      (off, copyin) = copyInOflow dflags retConv area results
+      copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
   return (copyout <*> mkLabel k <*> copyin)
 
 mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset