Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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.
  • Loading branch information...
commit f917eeb824cfb7143dde9b12e501d4ddb0049b65 1 parent e6ef5ab
igfoo igfoo authored
Showing with 272 additions and 251 deletions.
  1. +33 −23 compiler/cmm/CmmCallConv.hs
  2. +1 −1  compiler/cmm/CmmLayoutStack.hs
  3. +56 −47 compiler/cmm/MkGraph.hs
  4. +43 −33 compiler/codeGen/CgCallConv.hs
  5. +5 −3 compiler/codeGen/CgClosure.lhs
  6. +4 −2 compiler/codeGen/CgCon.lhs
  7. +3 −2 compiler/codeGen/CgTailCall.lhs
  8. +3 −2 compiler/codeGen/StgCmmBind.hs
  9. +3 −3 compiler/codeGen/StgCmmExpr.hs
  10. +2 −1  compiler/codeGen/StgCmmForeign.hs
  11. +13 −10 compiler/codeGen/StgCmmHeap.hs
  12. +9 −7 compiler/codeGen/StgCmmLayout.hs
  13. +6 −4 compiler/codeGen/StgCmmMonad.hs
  14. +0 −2  compiler/ghc.mk
  15. +2 −3 compiler/iface/BinIface.hs
  16. +1 −1  compiler/llvmGen/LlvmCodeGen.hs
  17. +11 −10 compiler/llvmGen/LlvmCodeGen/Base.hs
  18. +5 −4 compiler/llvmGen/LlvmCodeGen/CodeGen.hs
  19. +25 −19 compiler/main/DynFlags.hs
  20. +1 −14 compiler/main/StaticFlagParser.hs
  21. +0 −3  compiler/main/StaticFlags.hs
  22. +11 −13 compiler/main/SysTools.lhs
  23. +1 −0  compiler/utils/Platform.hs
  24. +23 −0 configure.ac
  25. +6 −6 ghc/Main.hs
  26. +0 −27 mk/build.mk.sample
  27. +4 −11 mk/config.mk.in
  28. +1 −0  settings.in
56 compiler/cmm/CmmCallConv.hs
View
@@ -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]
2  compiler/cmm/CmmLayoutStack.hs
View
@@ -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, [])
103 compiler/cmm/MkGraph.hs
View
@@ -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
76 compiler/codeGen/CgCallConv.hs
View
@@ -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
8 compiler/codeGen/CgClosure.lhs
View
@@ -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
6 compiler/codeGen/CgCon.lhs
View
@@ -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
5 compiler/codeGen/CgTailCall.lhs
View
@@ -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
5 compiler/codeGen/StgCmmBind.hs
View
@@ -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 }
6 compiler/codeGen/StgCmmExpr.hs
View
@@ -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
3  compiler/codeGen/StgCmmForeign.hs
View
@@ -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))
23 compiler/codeGen/StgCmmHeap.hs
View
@@ -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
16 compiler/codeGen/StgCmmLayout.hs
View
@@ -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)
}
10 compiler/codeGen/StgCmmMonad.hs
View
@@ -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
2  compiler/ghc.mk
View
@@ -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' >> $@
5 compiler/iface/BinIface.hs
View
@@ -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.
2  compiler/llvmGen/LlvmCodeGen.hs
View
@@ -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"
21 compiler/llvmGen/LlvmCodeGen/Base.hs
View
@@ -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.
9 compiler/llvmGen/LlvmCodeGen/CodeGen.hs
View
@@ -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
44 compiler/main/DynFlags.hs
View
@@ -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),
15 compiler/main/StaticFlagParser.hs
View
@@ -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
3  compiler/main/StaticFlags.hs
View
@@ -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
24 compiler/main/SysTools.lhs
View
@@ -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}
1  compiler/utils/Platform.hs
View
@@ -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
23 configure.ac
View
@@ -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
12 ghc/Main.hs
View
@@ -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
27 mk/build.mk.sample
View
@@ -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
15 mk/config.mk.in
View
@@ -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)),\
1  settings.in
View
@@ -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@")
]
Please sign in to comment.
Something went wrong with that request. Please try again.