Commit d0e3776f authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge in more HEAD, fix stuff up

parents 23075169 3a3dcc31
......@@ -158,7 +158,6 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
test -z "[$]2" || eval "[$]2=ArchX86"
;;
x86_64)
GET_ARM_ISA()
test -z "[$]2" || eval "[$]2=ArchX86_64"
;;
powerpc)
......@@ -174,7 +173,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
GET_ARM_ISA()
test -z "[$]2" || eval "[$]2=\"ArchARM {armISA = \$ARM_ISA, armISAExt = \$ARM_ISA_EXT}\""
;;
hppa|hppa1_1|ia64|m68k|rs6000|s390|s390x|sparc64|vax)
alpha|mips|mipseb|mipsel|hppa|hppa1_1|ia64|m68k|rs6000|s390|s390x|sparc64|vax)
test -z "[$]2" || eval "[$]2=ArchUnknown"
;;
*)
......@@ -371,6 +370,18 @@ AC_DEFUN([FP_SETTINGS],
SettingsDllWrapCommand="/bin/false"
SettingsWindresCommand="/bin/false"
SettingsTouchCommand='touch'
if test -z "$LlcCmd"
then
SettingsLlcCommand="llc"
else
SettingsLlcCommand="$LlcCmd"
fi
if test -z "$OptCmd"
then
SettingsOptCommand="opt"
else
SettingsOptCommand="$OptCmd"
fi
fi
AC_SUBST(SettingsCCompilerCommand)
AC_SUBST(SettingsCCompilerFlags)
......@@ -378,6 +389,8 @@ AC_DEFUN([FP_SETTINGS],
AC_SUBST(SettingsDllWrapCommand)
AC_SUBST(SettingsWindresCommand)
AC_SUBST(SettingsTouchCommand)
AC_SUBST(SettingsLlcCommand)
AC_SUBST(SettingsOptCommand)
])
......@@ -539,6 +552,35 @@ AC_ARG_WITH($2,
]) # FP_ARG_WITH_PATH_GNU_PROG
# FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL
# --------------------
# XXX
#
# $1 = the variable to set
# $2 = the command to look for
#
AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL],
[
AC_ARG_WITH($2,
[AC_HELP_STRING([--with-$2=ARG],
[Use ARG as the path to $2 [default=autodetect]])],
[
if test "$HostOS" = "mingw32"
then
AC_MSG_WARN([Request to use $withval will be ignored])
else
$1=$withval
fi
],
[
if test "$HostOS" != "mingw32"
then
AC_PATH_PROG([$1], [$2])
fi
]
)
]) # FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL
# FP_PROG_CONTEXT_DIFF
# --------------------
# Figure out how to do context diffs. Sets the output variable ContextDiffCmd.
......@@ -1947,10 +1989,12 @@ AC_DEFUN([XCODE_VERSION],[
# Finds where gcc is
AC_DEFUN([FIND_GCC],[
if test "$TargetOS_CPP" = "darwin" &&
test "$XCodeVersion1" -ge 4
test "$XCodeVersion1" -eq 4 &&
test "$XCodeVersion2" -lt 2
then
# From Xcode 4, use 'gcc-4.2' to force the use of the gcc legacy
# backend (instead of the LLVM backend)
# In Xcode 4.1, 'gcc-4.2' is the gcc legacy backend (rather
# than the LLVM backend). We prefer the legacy gcc, but in
# Xcode 4.2 'gcc-4.2' was removed.
FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc-4.2])
else
FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc])
......
......@@ -105,8 +105,10 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
, Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
| otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
CmmCall e _ _ _ _ -> [Old.CmmJump e]
-- ToDo: STG Live
CmmCall e _ _ _ _ -> [Old.CmmJump e Nothing]
CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
Old.BasicBlock _ stmts -> stmts
where Just block = mapLookup bid $ toBlockMap g
......@@ -143,7 +143,7 @@ lintCmmStmt platform labels = lint
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <>
text " :: " <> ppr erep)
lint (CmmJump e) = lintCmmExpr platform e >> return ()
lint (CmmJump e _) = lintCmmExpr platform e >> return ()
lint (CmmReturn) = return ()
lint (CmmBranch id) = checkTarget id
checkTarget id = if setMember id labels then return ()
......
......@@ -65,7 +65,7 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
stmt m (CmmBranch b) = b:m
stmt m (CmmCondBranch e b) = b:(expr m e)
stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
stmt m (CmmJump e) = expr m e
stmt m (CmmJump e _) = expr m e
stmt m (CmmReturn) = m
actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as
-- We have to do a deep fold into CmmExpr because
......@@ -273,7 +273,7 @@ inlineStmt u a (CmmCall target regs es ret)
es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ]
inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
inlineStmt u a (CmmJump e) = CmmJump (inlineExpr u a e)
inlineStmt u a (CmmJump e live) = CmmJump (inlineExpr u a e) live
inlineStmt _ _ other_stmt = other_stmt
inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
......@@ -669,7 +669,7 @@ cmmLoopifyForC (CmmProc (Just info@(Statics info_lbl _)) entry_lbl
where blocks' = [ BasicBlock id (map do_stmt stmts)
| BasicBlock id stmts <- blocks ]
do_stmt (CmmJump (CmmLit (CmmLabel lbl))) | lbl == jump_lbl
do_stmt (CmmJump (CmmLit (CmmLabel lbl)) _) | lbl == jump_lbl
= CmmBranch top_id
do_stmt stmt = stmt
......
......@@ -411,8 +411,8 @@ stmt :: { ExtCode }
{ do as <- sequence $5; doSwitch $2 $3 as $6 }
| 'goto' NAME ';'
{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
| 'jump' expr ';'
{ do e <- $2; stmtEC (CmmJump e) }
| 'jump' expr vols ';'
{ do e <- $2; stmtEC (CmmJump e $3) }
| 'return' ';'
{ stmtEC CmmReturn }
| 'if' bool_expr 'goto' NAME
......@@ -940,12 +940,12 @@ doStore rep addr_code val_code
emitRetUT :: [(CgRep,CmmExpr)] -> Code
emitRetUT args = do
tickyUnboxedTupleReturn (length args) -- TICK
(sp, stmts) <- pushUnboxedTuple 0 args
(sp, stmts, live) <- pushUnboxedTuple 0 args
emitSimultaneously stmts -- NB. the args might overlap with the stack slots
-- or regs that we assign to, so better use
-- simultaneous assignments here (#3546)
when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
stmtC $ CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord))
stmtC $ CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live)
-- -----------------------------------------------------------------------------
-- If-then-else and boolean expressions
......
......@@ -146,32 +146,46 @@ data CmmStmt
= CmmNop
| CmmComment FastString
| CmmAssign CmmReg CmmExpr -- Assign to register
| CmmAssign CmmReg CmmExpr -- Assign to register
| CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
| CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
| CmmCall -- A call (foreign, native or primitive), with
CmmCallTarget
[HintedCmmFormal] -- zero or more results
[HintedCmmActual] -- zero or more arguments
CmmReturnInfo
-- Some care is necessary when handling the arguments of these, see
-- [Register parameter passing] and the hack in cmm/CmmOpt.hs
| CmmCall -- A call (foreign, native or primitive), with
CmmCallTarget
[HintedCmmFormal] -- zero or more results
[HintedCmmActual] -- zero or more arguments
CmmReturnInfo
-- Some care is necessary when handling the arguments of these, see
-- [Register parameter passing] and the hack in cmm/CmmOpt.hs
| CmmBranch BlockId -- branch to another BB in this fn
| CmmCondBranch CmmExpr BlockId -- conditional branch
| CmmSwitch CmmExpr [Maybe BlockId] -- Table branch
-- The scrutinee is zero-based;
-- zero -> first block
-- one -> second block etc
-- Undefined outside range, and when there's a Nothing
| CmmJump CmmExpr -- Jump to another C-- function,
| CmmReturn -- Return from a native C-- function,
| CmmSwitch -- Table branch
CmmExpr -- The scrutinee is zero-based;
[Maybe BlockId] -- zero -> first block
-- one -> second block etc
-- Undefined outside range, and when
-- there's a Nothing
| CmmJump -- Jump to another C-- function,
CmmExpr -- Target
(Maybe [GlobalReg]) -- Live registers at call site;
-- Nothing -> no information, assume
-- all live
-- Just .. -> info on liveness, []
-- means no live registers
-- This isn't all 'live' registers, just
-- the argument STG registers that are live
-- AND also possibly mapped to machine
-- registers. (So Sp, Hp, HpLim... ect
-- are never included here as they are
-- always live, only R2.., D1.. are
-- on this list)
| CmmReturn -- Return from a native C-- function,
data CmmHinted a
= CmmHinted {
......@@ -201,7 +215,7 @@ instance UserOfLocalRegs CmmStmt where
stmt (CmmBranch _) = id
stmt (CmmCondBranch e _) = gen e
stmt (CmmSwitch e _) = gen e
stmt (CmmJump e) = gen e
stmt (CmmJump e _) = gen e
stmt (CmmReturn) = id
gen :: UserOfLocalRegs a => a -> b -> b
......
......@@ -32,12 +32,11 @@
-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
--
module OldPprCmm
( pprStmt
, module PprCmmDecl
, module PprCmmExpr
)
where
module OldPprCmm (
pprStmt,
module PprCmmDecl,
module PprCmmExpr
) where
import BlockId
import CLabel
......@@ -46,7 +45,6 @@ import OldCmm
import PprCmmDecl
import PprCmmExpr
import BasicTypes
import ForeignCall
import Outputable
......@@ -109,7 +107,7 @@ pprStmt platform stmt = case stmt of
-- ;
CmmNop -> semi
-- // text
-- // text
CmmComment s -> text "//" <+> ftext s
-- reg = expr;
......@@ -153,7 +151,7 @@ pprStmt platform stmt = case stmt of
CmmBranch ident -> genBranch ident
CmmCondBranch expr ident -> genCondBranch platform expr ident
CmmJump expr -> genJump platform expr
CmmJump expr live -> genJump platform expr live
CmmReturn -> genReturn platform
CmmSwitch arg ids -> genSwitch platform arg ids
......@@ -176,7 +174,6 @@ pprUpdateFrame platform (UpdateFrame expr args) =
, space
, parens ( commafy $ map (pprPlatform platform) args ) ]
-- --------------------------------------------------------------------------
-- goto local label. [1], section 6.6
--
......@@ -203,17 +200,17 @@ genCondBranch platform expr ident =
--
-- jump foo(a, b, c);
--
genJump :: Platform -> CmmExpr -> SDoc
genJump platform expr =
genJump :: Platform -> CmmExpr -> Maybe [GlobalReg] -> SDoc
genJump platform expr live =
hcat [ ptext (sLit "jump")
, space
, if isTrivialCmmExpr expr
then pprExpr platform expr
else case expr of
CmmLoad (CmmReg _) _ -> pprExpr platform expr
_ -> parens (pprExpr platform expr)
, semi ]
_ -> parens (pprExpr platform expr)
, semi <+> ptext (sLit "// ")
, maybe empty ppr live]
-- --------------------------------------------------------------------------
-- Return from a function. [1], Section 6.8.2 of version 1.128
......@@ -264,3 +261,4 @@ genSwitch platform expr maybe_ids
commafy :: [SDoc] -> SDoc
commafy xs = fsep $ punctuate comma xs
......@@ -248,7 +248,7 @@ pprStmt platform stmt = case stmt of
CmmBranch ident -> pprBranch ident
CmmCondBranch expr ident -> pprCondBranch platform expr ident
CmmJump lbl -> mkJMP_(pprExpr platform lbl) <> semi
CmmJump lbl _ -> mkJMP_(pprExpr platform lbl) <> semi
CmmSwitch arg ids -> pprSwitch platform arg ids
pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
......@@ -930,7 +930,7 @@ te_Stmt (CmmCall _ rs es _) = mapM_ (te_temp.hintlessCmm) rs >>
mapM_ (te_Expr.hintlessCmm) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
te_Stmt (CmmJump e) = te_Expr e
te_Stmt (CmmJump e _) = te_Expr e
te_Stmt _ = return ()
te_Expr :: CmmExpr -> TE ()
......
......@@ -362,6 +362,7 @@ mkSlowEntryCode cl_info reg_args
= mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
0 reps_w_regs
load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
(CmmLoad (cmmRegOffW spReg offset)
......@@ -374,7 +375,8 @@ mkSlowEntryCode cl_info reg_args
stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI cl_info))
live_regs = Just $ map snd reps_w_regs
jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI cl_info)) live_regs
\end{code}
......@@ -412,6 +414,7 @@ funWrapper :: ClosureInfo -- Closure whose code body this is
-> Code
funWrapper closure_info arg_regs reg_save_code fun_body = do
{ let node_points = nodeMustPointToIt (closureLFInfo closure_info)
live = Just $ map snd arg_regs
{-
-- Debugging: check that R1 has the correct tag
......@@ -431,8 +434,7 @@ funWrapper closure_info arg_regs reg_save_code fun_body = do
; granYield arg_regs node_points
-- Heap and/or stack checks wrap the function body
; funEntryChecks closure_info reg_save_code
fun_body
; funEntryChecks closure_info reg_save_code live fun_body
}
\end{code}
......@@ -590,7 +592,7 @@ link_caf cl_info _is_upd = do
-- assuming lots of things, like the stack pointer hasn't
-- moved since we entered the CAF.
let target = entryCode (closureInfoPtr (CmmReg nodeReg)) in
stmtC (CmmJump target)
stmtC (CmmJump target $ Just [node])
; returnFC hp_rel }
where
......
......@@ -116,7 +116,7 @@ buildDynCon :: Id -- Name of the thing to which this constr will
-> CostCentreStack -- Where to grab cost centre from;
-- current CCS if currentOrSubsumedCCS
-> DataCon -- The data constructor
-> [(CgRep,CmmExpr)] -- Its args
-> [(CgRep,CmmExpr)] -- Its args
-> FCode CgIdInfo -- Return details about how to find it
buildDynCon binder ccs con args
= do dflags <- getDynFlags
......@@ -348,12 +348,15 @@ cgReturnDataCon con amodes
| otherwise -> build_it_then (jump_to deflt_lbl) }
_otherwise -- The usual case
-> build_it_then emitReturnInstr
-> build_it_then $ emitReturnInstr node_live
}
where
node_live = Just [node]
enter_it = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)),
CmmJump (entryCode (closureInfoPtr (CmmReg nodeReg)))]
jump_to lbl = stmtC (CmmJump (CmmLit lbl))
CmmJump (entryCode $ closureInfoPtr $ CmmReg nodeReg)
node_live
]
jump_to lbl = stmtC $ CmmJump (CmmLit lbl) node_live
build_it_then return_code
= do { -- BUILD THE OBJECT IN THE HEAP
-- The first "con" says that the name bound to this
......@@ -472,7 +475,7 @@ cgDataCon data_con
-- The case continuation code is expecting a tagged pointer
; stmtC (CmmAssign nodeReg
(tagCons data_con (CmmReg nodeReg)))
; performReturn emitReturnInstr }
; performReturn $ emitReturnInstr (Just []) }
-- noStmts: Ptr to thing already in Node
; whenC (not (isNullaryRepDataCon data_con))
......
......@@ -149,7 +149,7 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
; amode' <- assignTemp amode -- We're going to use it twice,
-- so save in a temp if non-trivial
; stmtC (CmmAssign nodeReg (tagToClosure tycon amode'))
; performReturn emitReturnInstr }
; performReturn $ emitReturnInstr (Just [node]) }
where
-- If you're reading this code in the attempt to figure
-- out why the compiler panic'ed here, it is probably because
......@@ -172,7 +172,8 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty)
| ReturnsPrim VoidRep <- result_info
= do cgPrimOp [] primop args emptyVarSet
performReturn emitReturnInstr
-- ToDo: STG Live -- worried about this
performReturn $ emitReturnInstr (Just [])
| ReturnsPrim rep <- result_info
= do res <- newTemp (typeCmmType res_ty)
......@@ -191,7 +192,8 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty)
stmtC (CmmAssign nodeReg
(tagToClosure tycon
(CmmReg (CmmLocal tag_reg))))
performReturn emitReturnInstr
-- ToDo: STG Live -- worried about this
performReturn $ emitReturnInstr (Just [node])
where
result_info = getPrimOpResultInfo primop
......
......@@ -54,6 +54,7 @@ import Outputable
import FastString
import Data.List
import Data.Maybe (fromMaybe)
\end{code}
......@@ -273,21 +274,22 @@ an automatic context switch is done.
A heap/stack check at a function or thunk entry point.
\begin{code}
funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code
funEntryChecks cl_info reg_save_code code
= hpStkCheck cl_info True reg_save_code code
funEntryChecks :: ClosureInfo -> CmmStmts -> Maybe [GlobalReg] -> Code -> Code
funEntryChecks cl_info reg_save_code live code
= hpStkCheck cl_info True reg_save_code live code
thunkEntryChecks :: ClosureInfo -> Code -> Code
thunkEntryChecks cl_info code
= hpStkCheck cl_info False noStmts code
= hpStkCheck cl_info False noStmts (Just [node]) code
hpStkCheck :: ClosureInfo -- Function closure
-> Bool -- Is a function? (not a thunk)
-> CmmStmts -- Register saves
-> Maybe [GlobalReg] -- Live registers
-> Code
-> Code
hpStkCheck cl_info is_fun reg_save_code code
hpStkCheck cl_info is_fun reg_save_code live code
= getFinalStackHW $ \ spHw -> do
{ sp <- getRealSp
; let stk_words = spHw - sp
......@@ -295,17 +297,18 @@ hpStkCheck cl_info is_fun reg_save_code code
{ -- Emit heap checks, but be sure to do it lazily so
-- that the conditionals on hpHw don't cause a black hole
codeOnly $ do
{ do_checks stk_words hpHw full_save_code rts_label
{ do_checks stk_words hpHw full_save_code rts_label full_live
; tickyAllocHeap hpHw }
; setRealHp hpHw
; code }
}
where
node_asst
(node_asst, full_live)
| nodeMustPointToIt (closureLFInfo cl_info)
= noStmts
= (noStmts, live)
| otherwise
= oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
= (oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
,Just $ node : fromMaybe [] live)
-- Strictly speaking, we should tag node here. But if
-- node doesn't point to the closure, the code for the closure
-- cannot depend on the value of R1 anyway, so we're safe.
......@@ -349,12 +352,17 @@ altHeapCheck alt_type code
{ codeOnly $ do
{ do_checks 0 {- no stack chk -} hpHw
noStmts {- nothign to save -}
(rts_label alt_type)
rts_label live
; tickyAllocHeap hpHw }
; setRealHp hpHw
; code }
where
rts_label PolyAlt = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1")))
(rts_label, live) = gc_info alt_type
mkL l = CmmLit . CmmLabel $ mkCmmCodeLabel rtsPackageId (fsLit l)
gc_info PolyAlt = (mkL "stg_gc_unpt_r1" , Just [node])
-- Do *not* enter R1 after a heap check in
-- a polymorphic case. It might be a function
-- and the entry code for a function (currently)
......@@ -362,22 +370,21 @@ altHeapCheck alt_type code
--
-- However R1 is guaranteed to be a pointer
rts_label (AlgAlt _) = stg_gc_enter1
gc_info (AlgAlt _) = (stg_gc_enter1, Just [node])
-- Enter R1 after the heap check; it's a pointer
rts_label (PrimAlt tc)
= CmmLit $ CmmLabel $
case primRepToCgRep (tyConPrimRep tc) of
VoidArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs")
FloatArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_f1")
DoubleArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_d1")
LongArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_l1")
gc_info (PrimAlt tc)
= case primRepToCgRep (tyConPrimRep tc) of
VoidArg -> (mkL "stg_gc_noregs", Just [])
FloatArg -> (mkL "stg_gc_f1", Just [FloatReg 1])
DoubleArg -> (mkL "stg_gc_d1", Just [DoubleReg 1])
LongArg -> (mkL "stg_gc_l1", Just [LongReg 1])
-- R1 is boxed but unlifted:
PtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1")
PtrArg -> (mkL "stg_gc_unpt_r1", Just [node])
-- R1 is unboxed:
NonPtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unbx_r1")
NonPtrArg -> (mkL "stg_gc_unbx_r1", Just [node])
rts_label (UbxTupAlt _) = panic "altHeapCheck"
gc_info (UbxTupAlt _) = panic "altHeapCheck"
\end{code}
......@@ -404,7 +411,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code
| otherwise
= initHeapUsage $ \ hpHw -> do
{ codeOnly $ do { do_checks 0 {- no stack check -} hpHw
full_fail_code rts_label
full_fail_code rts_label live
; tickyAllocHeap hpHw }
; setRealHp hpHw
; code }
......@@ -413,6 +420,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code
assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho!
(CmmLit (mkWordCLit liveness))
liveness = mkRegLiveness regs ptrs nptrs
live = Just $ map snd regs
rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut")))
\end{code}
......@@ -434,14 +442,15 @@ again on re-entry because someone else might have stolen the resource
in the meantime.
\begin{code}
do_checks :: WordOff -- Stack headroom
-> WordOff -- Heap headroom
-> CmmStmts -- Assignments to perform on failure
-> CmmExpr -- Rts address to jump to on failure
do_checks :: WordOff -- Stack headroom
-> WordOff -- Heap headroom
-> CmmStmts -- Assignments to perform on failure
-> CmmExpr -- Rts address to jump to on failure
-> Maybe [GlobalReg] -- Live registers
-> Code
do_checks 0 0 _ _ = nopC
do_checks 0 0 _ _ _ = nopC
do_checks _ hp _ _
do_checks _ hp _ _ _
| hp > bLOCKS_PER_MBLOCK * bLOCK_SIZE_W
= sorry (unlines [
"Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK * bLOCK_SIZE) ++ " bytes.",
......@@ -450,21 +459,22 @@ do_checks _ hp _ _
"Suggestion: read data from a file instead of having large static data",
"structures in the code."])
do_checks stk hp reg_save_code rts_lbl
do_checks stk hp reg_save_code rts_lbl live
= do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE)))
(CmmLit (mkIntCLit (hp*wORD_SIZE)))
(stk /= 0) (hp /= 0) reg_save_code rts_lbl
(stk /= 0) (hp /= 0) reg_save_code rts_lbl live
-- The offsets are now in *bytes*
do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr -> Code
do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr
-> Maybe [GlobalReg] -> Code
do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live
= do { doGranAllocate hp_expr
-- The failure block: this saves the registers and jumps to
-- the appropriate RTS stub.
; exit_blk_id <- forkLabelledCode $ do {
; emitStmts reg_save_code
; stmtC (CmmJump rts_lbl) }
; stmtC (CmmJump rts_lbl live) }
-- In the case of a heap-check failure, we must also set
-- HpAlloc. NB. HpAlloc is *only* set if Hp has been
......@@ -514,7 +524,8 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
\begin{code}
hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
hpChkGen bytes liveness reentry
= do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen
= do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns
stg_gc_gen (Just activeStgRegs)
where
assigns = mkStmts [ mk_vanilla_assignment 9 liveness,
mk_vanilla_assignment 10 reentry ]
......@@ -523,12 +534,14 @@ hpChkGen bytes liveness reentry
-- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code
hpChkNodePointsAssignSp0 bytes sp0
= do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1
= do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign
stg_gc_enter1 (Just [node])
where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
stkChkGen bytes liveness reentry
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns
stg_gc_gen (Just activeStgRegs)
where
assigns = mkStmts [ mk_vanilla_assignment 9 liveness,
mk_vanilla_assignment 10 reentry ]
......@@ -539,7 +552,8 @@ mk_vanilla_assignment n e
stkChkNodePoints :: CmmExpr -> Code
stkChkNodePoints bytes
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts
stg_gc_enter1 (Just [node])
stg_gc_gen :: CmmExpr
stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen")))
......
......@@ -250,10 +250,10 @@ emitAlgReturnTarget name branches mb_deflt fam_sz
-- global labels, so we can't use them at the 'call site'
--------------------------------
emitReturnInstr :: Code
emitReturnInstr
= do { info_amode <- getSequelAmode
; stmtC (CmmJump (entryCode info_amode)) }
emitReturnInstr :: Maybe [GlobalReg] -> Code
emitReturnInstr live
= do { info_amode <- getSequelAmode
; stmtC (CmmJump (entryCode info_amode) live) }
-----------------------------------------------------------------------------
--
......
......@@ -249,7 +249,7 @@ flattenCgStmts id stmts =
where (block,blocks) = flatten ss
isJump :: CmmStmt -> Bool
isJump (CmmJump _ ) = True
isJump (CmmJump _ _) = True
isJump (CmmBranch _ ) = True
isJump (CmmSwitch _ _) = True
isJump (CmmReturn ) = True
......
......@@ -45,6 +45,7 @@ import Outputable
import StaticFlags
import Control.Monad
import Data.Maybe
-----------------------------------------------------------------------------
-- Tail Calls
......@@ -103,17 +104,19 @@ performTailCall fun_info arg_amodes pending_assts
-- to make the heap check easier. The tail-call sequence
-- is very similar to returning an unboxed tuple, so we
-- share some code.
do { (final_sp, arg_assts) <- pushUnboxedTuple join_sp arg_amodes
do { (final_sp, arg_assts, live) <- pushUnboxedTuple join_sp arg_amodes
; emitSimultaneously (pending_assts `plusStmts` arg_assts)
; let lbl = enterReturnPtLabel (idUnique (cgIdInfoId fun_info))
; doFinalJump final_sp True {- Is LNE -} (jumpToLbl lbl) }
; doFinalJump final_sp True $ jumpToLbl lbl (Just live) }
| otherwise