Add "Unregisterised" as a field in the settings file
authorIan Lynagh <ian@well-typed.com>
Tue, 7 Aug 2012 00:27:44 +0000 (01:27 +0100)
committerIan Lynagh <ian@well-typed.com>
Tue, 7 Aug 2012 00:27:44 +0000 (01:27 +0100)
To explicitly choose whether you want an unregisterised build you now
need to use the "--enable-unregisterised"/"--disable-unregisterised"
configure flags.

28 files changed:
compiler/cmm/CmmCallConv.hs
compiler/cmm/CmmLayoutStack.hs
compiler/cmm/MkGraph.hs
compiler/codeGen/CgCallConv.hs
compiler/codeGen/CgClosure.lhs
compiler/codeGen/CgCon.lhs
compiler/codeGen/CgTailCall.lhs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmMonad.hs
compiler/ghc.mk
compiler/iface/BinIface.hs
compiler/llvmGen/LlvmCodeGen.hs
compiler/llvmGen/LlvmCodeGen/Base.hs
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
compiler/main/DynFlags.hs
compiler/main/StaticFlagParser.hs
compiler/main/StaticFlags.hs
compiler/main/SysTools.lhs
compiler/utils/Platform.hs
configure.ac
ghc/Main.hs
mk/build.mk.sample
mk/config.mk.in
settings.in

index a76ad6f..c92ad0f 100644 (file)
@@ -20,8 +20,9 @@ import PprCmm ()
 
 import Constants
 import qualified Data.List as L
-import StaticFlags (opt_Unregisterised)
+import DynFlags
 import Outputable
+import Platform
 
 -- Calculate the 'GlobalReg' or stack locations for function call
 -- parameters as used by the Cmm calling convention.
@@ -37,22 +38,22 @@ instance Outputable ParamLocation where
 -- | JD: For the new stack story, I want arguments passed on the stack to manifest as
 -- positive offsets in a CallArea, not negative offsets from the stack pointer.
 -- Also, I want byte offsets, not word offsets.
-assignArgumentsPos :: Convention -> (a -> CmmType) -> [a] ->
+assignArgumentsPos :: DynFlags -> Convention -> (a -> CmmType) -> [a] ->
                       [(a, ParamLocation)]
 -- Given a list of arguments, and a function that tells their types,
 -- return a list showing where each argument is passed
-assignArgumentsPos conv arg_ty reps = assignments
+assignArgumentsPos dflags conv arg_ty reps = assignments
     where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
       regs = case (reps, conv) of
-               (_,   NativeNodeCall)   -> getRegsWithNode
-               (_,   NativeDirectCall) -> getRegsWithoutNode
+               (_,   NativeNodeCall)   -> getRegsWithNode dflags
+               (_,   NativeDirectCall) -> getRegsWithoutNode dflags
                ([_], NativeReturn)     -> allRegs
-               (_,   NativeReturn)     -> getRegsWithNode
+               (_,   NativeReturn)     -> getRegsWithNode dflags
                -- GC calling convention *must* put values in registers
                (_,   GC)               -> allRegs
                (_,   PrimOpCall)       -> allRegs
                ([_], PrimOpReturn)     -> allRegs
-               (_,   PrimOpReturn)     -> getRegsWithNode
+               (_,   PrimOpReturn)     -> getRegsWithNode dflags
                (_,   Slow)             -> noRegs
       -- The calling conventions first assign arguments to registers,
       -- then switch to the stack when we first run out of registers
@@ -110,25 +111,34 @@ type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
 -- We take these register supplies from the *real* registers, i.e. those
 -- that are guaranteed to map to machine registers.
 
-vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
-vanillaRegNos | opt_Unregisterised = []
-              | otherwise          = regList mAX_Real_Vanilla_REG
-floatRegNos      | opt_Unregisterised = []
-              | otherwise          = regList mAX_Real_Float_REG
-doubleRegNos  | opt_Unregisterised = []
-              | otherwise          = regList mAX_Real_Double_REG
-longRegNos       | opt_Unregisterised = []
-              | otherwise          = regList mAX_Real_Long_REG
+vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
+vanillaRegNos dflags
+ | platformUnregisterised (targetPlatform dflags) = []
+ | otherwise                                      = regList mAX_Real_Vanilla_REG
+floatRegNos dflags
+ | platformUnregisterised (targetPlatform dflags) = []
+ | otherwise                                      = regList mAX_Real_Float_REG
+doubleRegNos dflags
+ | platformUnregisterised (targetPlatform dflags) = []
+ | otherwise                                      = regList mAX_Real_Double_REG
+longRegNos dflags
+ | platformUnregisterised (targetPlatform dflags) = []
+ | otherwise                                      = regList mAX_Real_Long_REG
 
 -- 
-getRegsWithoutNode, getRegsWithNode :: AvailRegs
-getRegsWithoutNode =
+getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
+getRegsWithoutNode dflags =
   (filter (\r -> r VGcPtr /= node) intRegs,
-   map FloatReg  floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
-    where intRegs = map VanillaReg vanillaRegNos
-getRegsWithNode =
-  (intRegs, map FloatReg  floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
-    where intRegs = map VanillaReg vanillaRegNos
+   map FloatReg  (floatRegNos dflags),
+   map DoubleReg (doubleRegNos dflags),
+   map LongReg   (longRegNos dflags))
+    where intRegs = map VanillaReg (vanillaRegNos dflags)
+getRegsWithNode dflags =
+  (intRegs,
+   map FloatReg  (floatRegNos dflags),
+   map DoubleReg (doubleRegNos dflags),
+   map LongReg   (longRegNos dflags))
+    where intRegs = map VanillaReg (vanillaRegNos dflags)
 
 allFloatRegs, allDoubleRegs, allLongRegs :: [GlobalReg]
 allVanillaRegs :: [VGcPtr -> GlobalReg]
index 02c90e6..5aca286 100644 (file)
@@ -929,7 +929,7 @@ lowerSafeForeignCall dflags block
                   caller_load <*>
                   loadThreadState dflags load_tso load_stack
 
-        (ret_args, regs, copyout) = copyOutOflow NativeReturn Jump (Young succ)
+        (ret_args, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ)
                                            (map (CmmReg . CmmLocal) res)
                                            updfr (0, [])
 
index 4703b47..60704b5 100644 (file)
@@ -24,6 +24,7 @@ import CmmCallConv (assignArgumentsPos, ParamLocation(..))
 
 
 import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
+import DynFlags
 import FastString
 import ForeignCall
 import Outputable
@@ -172,31 +173,35 @@ mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
 mkStore  l r  = mkMiddle $ CmmStore  l r
 
 ---------- Control transfer
-mkJump          :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
-mkJump e actuals updfr_off =
-  lastWithArgs Jump Old NativeNodeCall actuals updfr_off $
+mkJump          :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
+                -> CmmAGraph
+mkJump dflags e actuals updfr_off =
+  lastWithArgs dflags Jump Old NativeNodeCall actuals updfr_off $
     toCall e Nothing updfr_off 0
 
-mkDirectJump    :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
-mkDirectJump e actuals updfr_off =
-  lastWithArgs Jump Old NativeDirectCall actuals updfr_off $
+mkDirectJump    :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
+                -> CmmAGraph
+mkDirectJump dflags e actuals updfr_off =
+  lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
     toCall e Nothing updfr_off 0
 
-mkJumpGC        :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
-mkJumpGC e actuals updfr_off =
-  lastWithArgs Jump Old GC actuals updfr_off $
+mkJumpGC        :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
+                -> CmmAGraph
+mkJumpGC dflags e actuals updfr_off =
+  lastWithArgs dflags Jump Old GC actuals updfr_off $
     toCall e Nothing updfr_off 0
 
-mkForeignJump   :: Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
+mkForeignJump   :: DynFlags
+                -> Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
                 -> CmmAGraph
-mkForeignJump conv e actuals updfr_off =
-  mkForeignJumpExtra conv e actuals updfr_off noExtraStack
+mkForeignJump dflags conv e actuals updfr_off =
+  mkForeignJumpExtra dflags conv e actuals updfr_off noExtraStack
 
-mkForeignJumpExtra :: Convention -> CmmExpr -> [CmmActual]
+mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
                 -> UpdFrameOffset -> (ByteOff, [(CmmExpr, ByteOff)])
                 -> CmmAGraph
-mkForeignJumpExtra conv e actuals updfr_off extra_stack =
-  lastWithArgsAndExtraStack Jump Old conv actuals updfr_off extra_stack $
+mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack =
+  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
     toCall e Nothing updfr_off 0
 
 mkCbranch       :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
@@ -205,45 +210,47 @@ mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
 mkSwitch        :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
 mkSwitch e tbl   = mkLast $ CmmSwitch e tbl
 
-mkReturn        :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
-mkReturn e actuals updfr_off =
-  lastWithArgs Ret  Old NativeReturn actuals updfr_off $
+mkReturn        :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
+                -> CmmAGraph
+mkReturn dflags e actuals updfr_off =
+  lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $
     toCall e Nothing updfr_off 0
 
-mkReturnSimple  :: [CmmActual] -> UpdFrameOffset -> CmmAGraph
-mkReturnSimple actuals updfr_off =
-  mkReturn e actuals updfr_off
+mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
+mkReturnSimple dflags actuals updfr_off =
+  mkReturn dflags e actuals updfr_off
   where e = CmmLoad (CmmStackSlot Old updfr_off) gcWord
 
 mkBranch        :: BlockId -> CmmAGraph
 mkBranch bid     = mkLast (CmmBranch bid)
 
-mkFinalCall   :: CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
+mkFinalCall   :: DynFlags
+              -> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
               -> CmmAGraph
-mkFinalCall f _ actuals updfr_off =
-  lastWithArgs Call Old NativeDirectCall actuals updfr_off $
+mkFinalCall dflags f _ actuals updfr_off =
+  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
     toCall f Nothing updfr_off 0
 
-mkCallReturnsTo :: CmmExpr -> Convention -> [CmmActual]
+mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
                 -> BlockId
                 -> ByteOff
                 -> UpdFrameOffset
                 -> (ByteOff, [(CmmExpr,ByteOff)])
                 -> CmmAGraph
-mkCallReturnsTo f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
-  lastWithArgsAndExtraStack Call (Young ret_lbl) callConv actuals
+mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
+  lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
      updfr_off extra_stack $
        toCall f (Just ret_lbl) updfr_off ret_off
 
 -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
 -- already on the stack).
-mkJumpReturnsTo :: CmmExpr -> Convention -> [CmmActual]
+mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
                 -> BlockId
                 -> ByteOff
                 -> UpdFrameOffset
                 -> CmmAGraph
-mkJumpReturnsTo f callConv actuals ret_lbl ret_off updfr_off  = do
-  lastWithArgs JumpRet (Young ret_lbl) callConv actuals updfr_off $
+mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do
+  lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
        toCall f (Just ret_lbl) updfr_off ret_off
 
 mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
@@ -269,25 +276,26 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
 -- the variables in their spill slots.
 -- Therefore, for copying arguments and results, we provide different
 -- functions to pass the arguments in an overflow area and to pass them in spill slots.
-copyInOflow  :: Convention -> Area -> [CmmFormal] -> (Int, CmmAGraph)
+copyInOflow  :: DynFlags -> Convention -> Area -> [CmmFormal]
+             -> (Int, CmmAGraph)
 
-copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
-  where (offset, nodes) = copyIn oneCopyOflowI conv area formals
+copyInOflow dflags conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
+  where (offset, nodes) = copyIn dflags oneCopyOflowI conv area formals
 
 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
                           (ByteOff, [CmmNode O O])
-type CopyIn  = SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
+type CopyIn  = DynFlags -> SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
 
 -- Return the number of bytes used for copying arguments, as well as the
 -- instructions to copy the arguments.
 copyIn :: CopyIn
-copyIn oflow conv area formals =
+copyIn dflags oflow conv area formals =
   foldr ci (init_offset, []) args'
   where ci (reg, RegisterParam r) (n, ms) =
           (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
         ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
         init_offset = widthInBytes wordWidth -- infotable
-        args  = assignArgumentsPos conv localRegType formals
+        args  = assignArgumentsPos dflags conv localRegType formals
         args' = foldl adjust [] args
           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
                 adjust rst x@(_, RegisterParam _) = x : rst
@@ -303,7 +311,7 @@ oneCopyOflowI area (reg, off) (n, ms) =
 
 data Transfer = Call | JumpRet | Jump | Ret deriving Eq
 
-copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual]
+copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
              -> UpdFrameOffset
              -> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff
              -> (Int, [GlobalReg], CmmAGraph)
@@ -317,7 +325,7 @@ copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual]
 -- the info table for return and adjust the offsets of the other
 -- parameters.  If this is a call instruction, we adjust the offsets
 -- of the other parameters.
-copyOutOflow conv transfer area actuals updfr_off
+copyOutOflow dflags conv transfer area actuals updfr_off
   (extra_stack_off, extra_stack_stuff)
   = foldr co (init_offset, [], mkNop) (args' ++ stack_params)
   where 
@@ -347,7 +355,7 @@ copyOutOflow conv transfer area actuals updfr_off
     arg_offset = init_offset + extra_stack_off
 
     args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
-    args = assignArgumentsPos conv cmmExprType actuals
+    args = assignArgumentsPos dflags conv cmmExprType actuals
 
     args' = foldl adjust setRA args
       where adjust rst   (v, StackParam off)  = (v, StackParam (off + arg_offset)) : rst
@@ -355,26 +363,27 @@ copyOutOflow conv transfer area actuals updfr_off
 
 
 
-mkCallEntry :: Convention -> [CmmFormal] -> (Int, CmmAGraph)
-mkCallEntry conv formals = copyInOflow conv Old formals
+mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> (Int, CmmAGraph)
+mkCallEntry dflags conv formals = copyInOflow dflags conv Old formals
 
-lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual]
+lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
              -> UpdFrameOffset
              -> (ByteOff -> [GlobalReg] -> CmmAGraph)
              -> CmmAGraph
-lastWithArgs transfer area conv actuals updfr_off last =
-  lastWithArgsAndExtraStack transfer area conv actuals
+lastWithArgs dflags transfer area conv actuals updfr_off last =
+  lastWithArgsAndExtraStack dflags transfer area conv actuals
                             updfr_off noExtraStack last
 
-lastWithArgsAndExtraStack :: Transfer -> Area -> Convention -> [CmmActual]
+lastWithArgsAndExtraStack :: DynFlags
+             -> Transfer -> Area -> Convention -> [CmmActual]
              -> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)])
              -> (ByteOff -> [GlobalReg] -> CmmAGraph)
              -> CmmAGraph
-lastWithArgsAndExtraStack transfer area conv actuals updfr_off
+lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
                           extra_stack last =
   copies <*> last outArgs regs
  where
-  (outArgs, regs, copies) = copyOutOflow conv transfer area actuals
+  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
                                updfr_off extra_stack
 
 
index 332ec07..9443e0e 100644 (file)
@@ -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
index 053314b..f1da2d4 100644 (file)
@@ -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
index 15347de..4c451ec 100644 (file)
@@ -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
index 6f98e4a..6db1b46 100644 (file)
@@ -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
index a38078a..cb2b41d 100644 (file)
@@ -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 }
 
index 35533ec..1d016d6 100644 (file)
@@ -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
index 8fec067..3976dee 100644 (file)
@@ -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))
index ddb6dd0..d3bf17f 100644 (file)
@@ -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
index 4e2b478..e20e4a2 100644 (file)
@@ -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)
         }
 
index 3d34cb9..1819e44 100644 (file)
@@ -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
index de191ea..be2b631 100644 (file)
@@ -91,8 +91,6 @@ endif
        @echo 'cGhcWithSMP           = "$(GhcWithSMP)"'                     >> $@
        @echo 'cGhcRTSWays           :: String'                             >> $@
        @echo 'cGhcRTSWays           = "$(GhcRTSWays)"'                     >> $@
-       @echo 'cGhcUnregisterised    :: String'                             >> $@
-       @echo 'cGhcUnregisterised    = "$(GhcUnregisterised)"'              >> $@
        @echo 'cGhcEnableTablesNextToCode :: String'                        >> $@
        @echo 'cGhcEnableTablesNextToCode = "$(GhcEnableTablesNextToCode)"' >> $@
        @echo 'cLeadingUnderscore    :: String'                             >> $@
index 9298a03..965b1a9 100644 (file)
@@ -44,7 +44,6 @@ import Panic
 import Binary
 import SrcLoc
 import ErrUtils
-import Config
 import FastMutInt
 import Unique
 import Outputable
@@ -572,8 +571,8 @@ instance Binary ModIface where
 
 getWayDescr :: DynFlags -> String
 getWayDescr dflags
-  | cGhcUnregisterised == "YES" = 'u':tag
-  | otherwise                   = tag
+  | platformUnregisterised (targetPlatform dflags) = 'u':tag
+  | otherwise                                      =     tag
   where tag = buildTag dflags
         -- if this is an unregisterised build, make sure our interfaces
         -- can't be used by a registerised build.
index a4c4805..a813433 100644 (file)
@@ -45,7 +45,7 @@ llvmCodeGen dflags h us cmms
             let lbl = strCLabel_llvm env $ case topInfoTable p of
                         Nothing                   -> l
                         Just (Statics info_lbl _) -> info_lbl
-                env' = funInsert lbl llvmFunTy e
+                env' = funInsert lbl (llvmFunTy dflags) e
             in (d,env')
     in do
         showPass dflags "LlVM CodeGen"
index 19ca511..a9dfebb 100644 (file)
@@ -31,7 +31,6 @@ import LlvmCodeGen.Regs
 
 import CLabel
 import CgUtils ( activeStgRegs )
-import Config
 import Constants
 import DynFlags
 import FastString
@@ -84,23 +83,25 @@ widthToLlvmInt :: Width -> LlvmType
 widthToLlvmInt w = LMInt $ widthInBits w
 
 -- | GHC Call Convention for LLVM
-llvmGhcCC :: LlvmCallConvention
-llvmGhcCC | cGhcUnregisterised == "NO" = CC_Ncc 10
-          | otherwise                  = CC_Ccc
+llvmGhcCC :: DynFlags -> LlvmCallConvention
+llvmGhcCC dflags
+ | platformUnregisterised (targetPlatform dflags) = CC_Ncc 10
+ | otherwise                                      = CC_Ccc
 
 -- | Llvm Function type for Cmm function
-llvmFunTy :: LlvmType
-llvmFunTy = LMFunction $ llvmFunSig' (fsLit "a") ExternallyVisible
+llvmFunTy :: DynFlags -> LlvmType
+llvmFunTy dflags = LMFunction $ llvmFunSig' dflags (fsLit "a") ExternallyVisible
 
 -- | Llvm Function signature
 llvmFunSig :: LlvmEnv -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl
-llvmFunSig env lbl link = llvmFunSig' (strCLabel_llvm env lbl) link
+llvmFunSig env lbl link
+    = llvmFunSig' (getDflags env) (strCLabel_llvm env lbl) link
 
-llvmFunSig' :: LMString -> LlvmLinkageType -> LlvmFunctionDecl
-llvmFunSig' lbl link
+llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
+llvmFunSig' dflags lbl link
   = let toParams x | isPointer x = (x, [NoAlias, NoCapture])
                    | otherwise   = (x, [])
-    in LlvmFunctionDecl lbl link llvmGhcCC LMVoid FixedArgs
+    in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
                         (map (toParams . getVarType) llvmFunArgs) llvmFunAlign
 
 -- | Create a Haskell function in LLVM.
index 2a2104d..0bd1bb7 100644 (file)
@@ -516,7 +516,7 @@ genJump env (CmmLit (CmmLabel lbl)) live = do
 
 -- Call to unknown function / address
 genJump env expr live = do
-    let fty = llvmFunTy
+    let fty = llvmFunTy (getDflags env)
     (env', vf, stmts, top) <- exprToVar env expr
 
     let cast = case getVarType vf of
@@ -1293,7 +1293,8 @@ trashStmts = concatOL $ map trashReg activeStgRegs
 -- with foreign functions.
 getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
 getHsFunc env lbl
-  = let fn = strCLabel_llvm env lbl
+  = let dflags = getDflags env
+        fn = strCLabel_llvm env lbl
         ty    = funLookup fn env
     in case ty of
         -- Function in module in right form
@@ -1305,8 +1306,8 @@ getHsFunc env lbl
         Just ty' -> do
             let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
                             Nothing Nothing False
-            (v1, s1) <- doExpr (pLift llvmFunTy) $
-                            Cast LM_Bitcast fun (pLift llvmFunTy)
+            (v1, s1) <- doExpr (pLift (llvmFunTy dflags)) $
+                            Cast LM_Bitcast fun (pLift (llvmFunTy dflags))
             return (env, v1, unitOL s1, [])
 
         -- label not in module, create external reference
index c528402..8abe664 100644 (file)
@@ -46,7 +46,7 @@ module DynFlags (
         DynLibLoader(..),
         fFlags, fWarningFlags, fLangFlags, xFlags,
         wayNames, dynFlagDependencies,
-        tablesNextToCode,
+        tablesNextToCode, mkTablesNextToCode,
 
         printOutputForUser, printInfoForUser,
 
@@ -871,25 +871,28 @@ data PackageFlag
   | DistrustPackage String
   deriving Eq
 
-defaultHscTarget :: HscTarget
+defaultHscTarget :: Platform -> HscTarget
 defaultHscTarget = defaultObjectTarget
 
 -- | The 'HscTarget' value corresponding to the default way to create
 -- object files on the current platform.
-defaultObjectTarget :: HscTarget
-defaultObjectTarget
-  | cGhcUnregisterised    == "YES"      =  HscC
+defaultObjectTarget :: Platform -> HscTarget
+defaultObjectTarget platform
+  | platformUnregisterised platform     =  HscC
   | cGhcWithNativeCodeGen == "YES"      =  HscAsm
   | otherwise                           =  HscLlvm
 
--- Derived, not a real option.  Determines whether we will be compiling
+tablesNextToCode :: DynFlags -> Bool
+tablesNextToCode dflags
+    = mkTablesNextToCode (platformUnregisterised (targetPlatform dflags))
+
+-- Determines whether we will be compiling
 -- info tables that reside just before the entry code, or with an
 -- indirection to the entry code.  See TABLES_NEXT_TO_CODE in
 -- includes/rts/storage/InfoTables.h.
-tablesNextToCode :: DynFlags -> Bool
-tablesNextToCode _ = not opt_Unregisterised
-                  && cGhcEnableTablesNextToCode == "YES"
-
+mkTablesNextToCode :: Bool -> Bool
+mkTablesNextToCode unregisterised
+    = not unregisterised && cGhcEnableTablesNextToCode == "YES"
 
 data DynLibLoader
   = Deployable
@@ -925,7 +928,7 @@ defaultDynFlags mySettings =
      DynFlags {
         ghcMode                 = CompManager,
         ghcLink                 = LinkBinary,
-        hscTarget               = defaultHscTarget,
+        hscTarget               = defaultHscTarget (sTargetPlatform mySettings),
         hscOutName              = "",
         extCoreName             = "",
         verbosity               = 0,
@@ -1866,7 +1869,7 @@ dynamic_flags = [
   , Flag "fno-code"         (NoArg (do upd $ \d -> d{ ghcLink=NoLink }
                                        setTarget HscNothing))
   , Flag "fbyte-code"       (NoArg (setTarget HscInterpreted))
-  , Flag "fobject-code"     (NoArg (setTarget defaultHscTarget))
+  , Flag "fobject-code"     (NoArg (setTargetWithPlatform defaultHscTarget))
   , Flag "fglasgow-exts"    (NoArg (enableGlasgowExts >> deprecate "Use individual extensions instead"))
   , Flag "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead"))
 
@@ -2637,11 +2640,15 @@ setPackageName p s =  s{ thisPackage = stringToPackageId p }
 -- If we're linking a binary, then only targets that produce object
 -- code are allowed (requests for other target types are ignored).
 setTarget :: HscTarget -> DynP ()
-setTarget l = upd set
+setTarget l = setTargetWithPlatform (const l)
+
+setTargetWithPlatform :: (Platform -> HscTarget) -> DynP ()
+setTargetWithPlatform f = upd set
   where
-   set dfs
-     | ghcLink dfs /= LinkBinary || isObjectTarget l  = dfs{ hscTarget = l }
-     | otherwise = dfs
+   set dfs = let l = f (targetPlatform dfs)
+             in if ghcLink dfs /= LinkBinary || isObjectTarget l
+                then dfs{ hscTarget = l }
+                else dfs
 
 -- Changes the target only if we're compiling object code.  This is
 -- used by -fasm and -fllvm, which switch from one to the other, but
@@ -2654,7 +2661,7 @@ setObjTarget l = updM set
      | isObjectTarget (hscTarget dflags)
        = case l of
          HscC
-          | cGhcUnregisterised /= "YES" ->
+          | platformUnregisterised (targetPlatform dflags) ->
              do addWarn ("Compiler not unregisterised, so ignoring " ++ flag)
                 return dflags
          HscAsm
@@ -2679,7 +2686,7 @@ setFPIC :: DynP ()
 setFPIC = updM set
   where
    set dflags
-    | cGhcWithNativeCodeGen == "YES" || cGhcUnregisterised == "YES"
+    | cGhcWithNativeCodeGen == "YES" || platformUnregisterised (targetPlatform dflags)
        = let platform = targetPlatform dflags
          in case hscTarget dflags of
             HscLlvm
@@ -2913,7 +2920,6 @@ compilerInfo dflags
        ("Object splitting supported",  cSupportsSplitObjs),
        ("Have native code generator",  cGhcWithNativeCodeGen),
        ("Support SMP",                 cGhcWithSMP),
-       ("Unregisterised",              cGhcUnregisterised),
        ("Tables next to code",         cGhcEnableTablesNextToCode),
        ("RTS ways",                    cGhcRTSWays),
        ("Leading underscore",          cLeadingUnderscore),
index adda6f1..2b7f95a 100644 (file)
@@ -21,7 +21,6 @@ import qualified StaticFlags as SF
 import StaticFlags ( v_opt_C_ready, getWayFlags, WayName(..)
                    , opt_SimplExcessPrecision )
 import CmdLineParser
-import Config
 import SrcLoc
 import Util
 import Panic
@@ -69,14 +68,9 @@ parseStaticFlagsFull flagsAvailable args = do
   way_flags <- getWayFlags
   let way_flags' = map (mkGeneralLocated "in way flags") way_flags
 
-    -- if we're unregisterised, add some more flags
-  let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
-                  | otherwise = []
-
     -- as these are GHC generated flags, we parse them with all static flags
     -- in scope, regardless of what availableFlags are passed in.
-  (more_leftover, errs, warns2) <-
-      processArgs flagsStatic (unreg_flags ++ way_flags')
+  (more_leftover, errs, warns2) <- processArgs flagsStatic way_flags'
 
     -- see sanity code in staticOpts
   writeIORef v_opt_C_ready True
@@ -174,7 +168,6 @@ isStaticFlag f =
     "fexcess-precision",
     "static",
     "fhardwire-lib-paths",
-    "funregisterised",
     "fcpr-off",
     "ferror-spans",
     "fhpc"
@@ -190,12 +183,6 @@ isStaticFlag f =
     "funfolding-keeness-factor"
      ]
 
-unregFlags :: [Located String]
-unregFlags = map (mkGeneralLocated "in unregFlags")
-   [ "-optc-DNO_REGS"
-   , "-optc-DUSE_MINIINTERPRETER"
-   , "-funregisterised" ]
-
 -----------------------------------------------------------------------------
 -- convert sizes like "3.5M" into integers
 
index f19497c..2334940 100644 (file)
@@ -72,7 +72,6 @@ module StaticFlags (
        -- misc opts
        opt_ErrorSpans,
        opt_HistorySize,
-        opt_Unregisterised,
        v_Ld_inputs,
         opt_StubDeadValues,
         opt_Ticky,
@@ -309,8 +308,6 @@ opt_UF_DearOp            = ( 40 :: Int)
 -- Related to linking
 opt_Static :: Bool
 opt_Static                     = lookUp  (fsLit "-static")
-opt_Unregisterised :: Bool
-opt_Unregisterised             = lookUp  (fsLit "-funregisterised")
 
 -- Include full span info in error messages, instead of just the start position.
 opt_ErrorSpans :: Bool
index 295aa59..7d905d3 100644 (file)
@@ -51,7 +51,6 @@ import Platform
 import Util
 import DynFlags
 import Exception
-import StaticFlags
 
 import Data.IORef
 import Control.Monad
@@ -207,6 +206,7 @@ initSysTools mbMinusB
        targetArch <- readSetting "target arch"
        targetOS <- readSetting "target os"
        targetWordSize <- readSetting "target word size"
+       targetUnregisterised <- getBooleanSetting "Unregisterised"
        targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
        targetHasIdentDirective <- readSetting "target has .ident directive"
        targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
@@ -218,12 +218,17 @@ initSysTools mbMinusB
        -- to make that possible, so for now you can't.
        gcc_prog <- getSetting "C compiler command"
        gcc_args_str <- getSetting "C compiler flags"
-       let
+       let unreg_gcc_args = if targetUnregisterised
+                            then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
+                            else []
            -- TABLES_NEXT_TO_CODE affects the info table layout.
            tntc_gcc_args
-            | tablesNextToCode' = ["-DTABLES_NEXT_TO_CODE"]
-            | otherwise         = []
-           gcc_args = map Option (words gcc_args_str ++ tntc_gcc_args)
+            | mkTablesNextToCode targetUnregisterised
+               = ["-DTABLES_NEXT_TO_CODE"]
+            | otherwise = []
+           gcc_args = map Option (words gcc_args_str
+                               ++ unreg_gcc_args
+                               ++ tntc_gcc_args)
        ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
        ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
        ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
@@ -280,6 +285,7 @@ initSysTools mbMinusB
                           platformArch = targetArch,
                           platformOS   = targetOS,
                           platformWordSize = targetWordSize,
+                          platformUnregisterised = targetUnregisterised,
                           platformHasGnuNonexecStack = targetHasGnuNonexecStack,
                           platformHasIdentDirective = targetHasIdentDirective,
                           platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
@@ -322,14 +328,6 @@ initSysTools mbMinusB
                     sOpt_lo      = [],
                     sOpt_lc      = []
              }
-
--- Derived, not a real option.  Determines whether we will be compiling
--- info tables that reside just before the entry code, or with an
--- indirection to the entry code.  See TABLES_NEXT_TO_CODE in
--- includes/rts/storage/InfoTables.h.
-tablesNextToCode' :: Bool
-tablesNextToCode' = not opt_Unregisterised
-                 && cGhcEnableTablesNextToCode == "YES"
 \end{code}
 
 \begin{code}
index 76bb386..b53ece9 100644 (file)
@@ -24,6 +24,7 @@ data Platform
               -- Word size in bytes (i.e. normally 4 or 8,
               -- for 32bit and 64bit platforms respectively)
               platformWordSize                 :: {-# UNPACK #-} !Int,
+              platformUnregisterised           :: Bool,
               platformHasGnuNonexecStack       :: Bool,
               platformHasIdentDirective        :: Bool,
               platformHasSubsectionsViaSymbols :: Bool
index 397e8a5..4ca64f2 100644 (file)
@@ -260,6 +260,29 @@ esac
 
 AC_SUBST(SOLARIS_BROKEN_SHLD)
 
+dnl ** Do an unregisterised build?
+dnl --------------------------------------------------------------
+case "$HostArch" in
+    i386|x86_64|powerpc|arm)
+        UnregisterisedDefault=NO
+        ;;
+    *)
+        UnregisterisedDefault=YES
+        ;;
+esac
+AC_ARG_ENABLE(unregisterised,
+[AC_HELP_STRING([--enable-unregisterised],
+[Build an unregisterised compiler (enabled by default on platforms without registerised support) [default="$UnregisterisedDefault"]])],
+[ if test x"$enableval" = x"yes"; then
+        Unregisterised=YES
+  else
+        Unregisterised=NO
+  fi
+],
+[Unregisterised="$UnregisterisedDefault"]
+)
+AC_SUBST(Unregisterised)
+
 AC_ARG_WITH(hc,
 [AC_HELP_STRING([--with-hc=ARG],
         [Use ARG as the path to the compiler for compiling ordinary
index a53912c..1e9d0a2 100644 (file)
@@ -558,12 +558,12 @@ mode_flags =
   ]
 
 setGenerateC :: String -> EwM ModeM ()
-setGenerateC f
-  | cGhcUnregisterised /= "YES" = do
-        addWarn ("Compiler not unregisterised, so ignoring " ++ f)
-  | otherwise = do
-        setMode (stopBeforeMode HCc) f
-        addFlag "-fvia-C" f
+setGenerateC f = do -- TODO: We used to warn and ignore when
+                    -- unregisterised, but we no longer know whether
+                    -- we are unregisterised at this point. Should
+                    -- we check later on?
+                    setMode (stopBeforeMode HCc) f
+                    addFlag "-fvia-C" f
 
 setMode :: Mode -> String -> EwM ModeM ()
 setMode newMode newFlag = liftEwM $ do
index e979f39..83ff4b7 100644 (file)
@@ -30,9 +30,6 @@
 # A development build, working on the stage 2 compiler:
 #BuildFlavour = devel2
 
-# An unregisterised, optimised build of ghc, for porting:
-#BuildFlavour = unreg
-
 GhcLibWays = v
 
 # -------- 1. A Performance/Distribution build--------------------------------
@@ -167,30 +164,6 @@ LAX_DEPENDENCIES   = YES
 
 endif
 
-# -------- A Unregisterised build) -------------------------------------------
-
-ifeq "$(BuildFlavour)" "unreg"
-
-# Note that the LLVM backend works in unregisterised mode as well as
-# registerised mode. This often makes it a good choice for porting
-# GHC.
-
-GhcUnregisterised    = YES
-GhcWithNativeCodeGen = NO
-
-SRC_HC_OPTS          = -O -H64m # -fllvm
-GhcStage1HcOpts      = -O
-GhcStage2HcOpts      = -O2
-GhcHcOpts            = -Rghc-timing
-GhcLibHcOpts         = -O2
-SplitObjs            = NO
-HADDOCK_DOCS         = NO
-BUILD_DOCBOOK_HTML   = NO
-BUILD_DOCBOOK_PS     = NO
-BUILD_DOCBOOK_PDF    = NO
-
-endif
-
 # -----------------------------------------------------------------------------
 # Other settings that might be useful
 
index 769bce8..806d53d 100644 (file)
@@ -139,11 +139,7 @@ PlatformSupportsSharedLibs = $(if $(filter $(TARGETPLATFORM),\
 # the compiler you build with is generating registerised binaries), but
 # the stage2 compiler will be an unregisterised binary.
 #
-ifneq "$(findstring $(TargetArch_CPP), i386 x86_64 powerpc arm)" ""
-GhcUnregisterised=NO
-else
-GhcUnregisterised=YES
-endif
+GhcUnregisterised=@Unregisterised@
 
 # Build a compiler with a native code generator backend
 # (as well as a C backend)
@@ -154,8 +150,7 @@ endif
 ArchSupportsNCG=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 powerpc sparc)))
 OsSupportsNCG=$(strip $(patsubst $(TargetOS_CPP), YES, $(patsubst aix,,$(TargetOS_CPP))))
 
-# lazy test, because $(GhcUnregisterised) might be set in build.mk later.
-GhcWithNativeCodeGen=$(strip\
+GhcWithNativeCodeGen := $(strip\
     $(if $(filter YESYESNO,\
                  $(OsSupportsNCG)$(ArchSupportsNCG)$(GhcUnregisterised)),YES,NO))
 
@@ -165,8 +160,7 @@ HaveLibDL = @HaveLibDL@
 # includes/stg/SMP.h
 ArchSupportsSMP=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 sparc powerpc arm)))
 
-# lazy test, because $(GhcUnregisterised) might be set in build.mk later.
-GhcWithSMP=$(strip $(if $(filter YESNO, $(ArchSupportsSMP)$(GhcUnregisterised)),YES,NO))
+GhcWithSMP := $(strip $(if $(filter YESNO, $(ArchSupportsSMP)$(GhcUnregisterised)),YES,NO))
 
 # Whether to include GHCi in the compiler.  Depends on whether the RTS linker
 # has support for this OS/ARCH combination.
@@ -304,8 +298,7 @@ ArchSupportsSplitObjs=$(strip $(if $(filter $(TargetArch_CPP),i386 x86_64 powerp
 OsSupportsSplitObjs=$(strip $(if $(filter $(TargetOS_CPP),mingw32 cygwin32 linux darwin solaris2 freebsd dragonfly netbsd openbsd),YES,NO))
 SplitObjsBroken = @SplitObjsBroken@
 
-# lazy test, so that $(GhcUnregisterised) can be set in build.mk
-SupportsSplitObjs=$(strip \
+SupportsSplitObjs := $(strip \
                     $(if $(and $(filter YES,$(ArchSupportsSplitObjs)),\
                                $(filter YES,$(OsSupportsSplitObjs)),\
                                $(filter NO,$(SplitObjsBroken)),\
index dbf15fd..1258369 100644 (file)
@@ -18,6 +18,7 @@
  ("target has GNU nonexec stack", "@HaskellHaveGnuNonexecStack@"),
  ("target has .ident directive", "@HaskellHaveIdentDirective@"),
  ("target has subsections via symbols", "@HaskellHaveSubsectionsViaSymbols@"),
+ ("Unregisterised", "@Unregisterised@"),
  ("LLVM llc command", "@SettingsLlcCommand@"),
  ("LLVM opt command", "@SettingsOptCommand@")
  ]