Commit f917eeb8 authored by ian@well-typed.com's avatar ian@well-typed.com

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.
parent e6ef5ab6
......@@ -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 = []
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
vanillaRegNos dflags
| platformUnregisterised (targetPlatform dflags) = []
| otherwise = regList mAX_Real_Vanilla_REG
floatRegNos | opt_Unregisterised = []
floatRegNos dflags
| platformUnregisterised (targetPlatform dflags) = []
| otherwise = regList mAX_Real_Float_REG
doubleRegNos | opt_Unregisterised = []
doubleRegNos dflags
| platformUnregisterised (targetPlatform dflags) = []
| otherwise = regList mAX_Real_Double_REG
longRegNos | opt_Unregisterised = []
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]
......
......@@ -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, [])
......
This diff is collapsed.
......@@ -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
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
useVanillaRegs :: DynFlags -> Int
useVanillaRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Vanilla_REG
useFloatRegs :: Int
useFloatRegs | opt_Unregisterised = 0
useFloatRegs :: DynFlags -> Int
useFloatRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Float_REG
useDoubleRegs :: Int
useDoubleRegs | opt_Unregisterised = 0
useDoubleRegs :: DynFlags -> Int
useDoubleRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Double_REG
useLongRegs :: Int
useLongRegs | opt_Unregisterised = 0
useLongRegs :: DynFlags -> Int
useLongRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Long_REG
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
vanillaRegNos = regList useVanillaRegs
floatRegNos = regList useFloatRegs
doubleRegNos = regList useDoubleRegs
longRegNos = regList useLongRegs
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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 }
......
......@@ -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
......
......@@ -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))
......
......@@ -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
......
......@@ -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)
}
......
......@@ -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
......
......@@ -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' >> $@
......
......@@ -44,7 +44,6 @@ import Panic
import Binary
import SrcLoc
import ErrUtils
import Config
import FastMutInt
import Unique
import Outputable
......@@ -572,7 +571,7 @@ instance Binary ModIface where
getWayDescr :: DynFlags -> String
getWayDescr dflags
| cGhcUnregisterised == "YES" = 'u':tag
| platformUnregisterised (targetPlatform dflags) = 'u':tag
| otherwise = tag
where tag = buildTag dflags
-- if this is an unregisterised build, make sure our interfaces
......
......@@ -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"
......
......@@ -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
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.
......
......@@ -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
......
......@@ -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),
......
......@@ -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"
]