Commit c2348859 authored by Simon Marlow's avatar Simon Marlow

Fix a bug in stack layout with safe foreign calls (#8083)

We weren't properly tracking the number of stack arguments in the
continuation of a foreign call.  It happened to work when the
continuation was not a join point, but when it was a join point we
were using the wrong amount of stack fixup.
parent be89c675
......@@ -96,7 +96,7 @@ hash_block block =
hash_node (CmmBranch _) = 23 -- NB. ignore the label
hash_node (CmmCondBranch p _ _) = hash_e p
hash_node (CmmCall e _ _ _ _ _) = hash_e e
hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
hash_node (CmmSwitch e _) = hash_e e
hash_reg :: CmmReg -> Word32
......
......@@ -264,7 +264,7 @@ collectContInfo blocks
CmmCall { cml_cont = Just l, .. }
-> (Just (l, cml_ret_args), cml_ret_off)
CmmForeignCall { .. }
-> (Just (succ, 0), updfr) -- ??
-> (Just (succ, ret_args), ret_off)
_other -> (Nothing, 0)
......@@ -346,8 +346,8 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
CmmForeignCall{ succ = cont_lbl, .. } -> do
return $ lastCall cont_lbl (wORD_SIZE dflags) (wORD_SIZE dflags) (sm_ret_off stack0)
-- one word each for args and results: the return address
return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off
-- one word of args: the return address
CmmBranch{..} -> handleBranches
CmmCondBranch{..} -> handleBranches
......@@ -932,9 +932,10 @@ lowerSafeForeignCall dflags block
caller_load <*>
loadThreadState dflags load_tso load_stack
(ret_args, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ)
(map (CmmReg . CmmLocal) res)
updfr []
(_, regs, copyout) =
copyOutOflow dflags NativeReturn Jump (Young succ)
(map (CmmReg . CmmLocal) res)
ret_off []
-- NB. after resumeThread returns, the top-of-stack probably contains
-- the stack frame for succ, but it might not: if the current thread
......@@ -947,7 +948,7 @@ lowerSafeForeignCall dflags block
, cml_args_regs = regs
, cml_args = widthInBytes (wordWidth dflags)
, cml_ret_args = ret_args
, cml_ret_off = updfr }
, cml_ret_off = ret_off }
graph' <- lgraphOfAGraph $ suspend <*>
midCall <*>
......
......@@ -178,7 +178,7 @@ lintCmmLast labels node = case node of
_ <- lintCmmExpr target
maybe (return ()) checkTarget cont
CmmForeignCall tgt _ args succ _ _ -> do
CmmForeignCall tgt _ args succ _ _ _ -> do
lintTarget tgt
mapM_ lintCmmExpr args
checkTarget succ
......
......@@ -122,7 +122,8 @@ data CmmNode e x where
res :: [CmmFormal], -- zero or more results
args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing]
succ :: ULabel, -- Label of continuation
updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
ret_args :: ByteOff, -- same as cml_ret_args
ret_off :: ByteOff, -- same as cml_ret_off
intrbl:: Bool -- whether or not the call is interruptible
} -> CmmNode O C
......@@ -367,7 +368,7 @@ mapExp _ l@(CmmBranch _) = l
mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt}
mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep f = mapExp $ wrapRecExp f
......@@ -397,10 +398,10 @@ mapExpM f (CmmUnsafeForeignCall tgt fs as)
= case mapForeignTargetM f tgt of
Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
mapExpM f (CmmForeignCall tgt fs as succ updfr intrbl)
mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
= case mapForeignTargetM f tgt of
Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ updfr intrbl)
Nothing -> (\xs -> CmmForeignCall tgt fs xs succ updfr intrbl) `fmap` mapListM f as
Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as
-- share as much as possible
mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
......
......@@ -68,11 +68,9 @@ cpsTop hsc_env proc =
, do_layout = do_layout }} = h
----------- Eliminate common blocks -------------------------------------
g <- if False -- temporarily disabled: See #8083
then {-# SCC "elimCommonBlocks" #-}
condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
g <- {-# SCC "elimCommonBlocks" #-}
condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
Opt_D_dump_cmm_cbe "Post common block elimination"
else return g
-- Any work storing block Labels must be performed _after_
-- elimCommonBlocks
......
......@@ -247,14 +247,15 @@ pprNode node = pp_node <+> pp_debug
| Just r <- k = ptext (sLit "returns to") <+> ppr r <> comma
| otherwise = empty
CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} ->
CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
[ ptext (sLit "foreign call"), space
, ppr t, ptext (sLit "(...)"), space
, ptext (sLit "returns to") <+> ppr s
<+> ptext (sLit "args:") <+> parens (ppr as)
<+> ptext (sLit "ress:") <+> parens (ppr rs)
, ptext (sLit "upd:") <+> ppr u
, ptext (sLit "ret_args:") <+> ppr a
, ptext (sLit "ret_off:") <+> ppr u
, semi ]
pp_debug :: SDoc
......
......@@ -225,7 +225,8 @@ emitForeignCall safety results target args
, res = results
, args = args'
, succ = k
, updfr = updfr_off
, ret_args = off
, ret_off = updfr_off
, intrbl = playInterruptible safety })
<*> mkLabel k
<*> copyout
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment