Commit 14a5c62a authored by Simon Marlow's avatar Simon Marlow

Allow C argument regs to be used as global regs (R1, R2, etc.)

The problem here was that we generated C calls with expressions
involving R1 etc. as parameters.  When some of the R registers are
also C argument registers, both GCC and the native code generator
generate incorrect code.  The hacky workaround is to assign
problematic arguments to temporaries first; fortunately this works
with both GCC and the NCG, but we have to be careful not to undo this
with later optimisations (see changes to CmmOpt).
parent 04db0e9f
...@@ -15,6 +15,7 @@ module CmmOpt ( ...@@ -15,6 +15,7 @@ module CmmOpt (
#include "HsVersions.h" #include "HsVersions.h"
import Cmm import Cmm
import CmmUtils ( hasNoGlobalRegs )
import CLabel ( entryLblToInfoLbl ) import CLabel ( entryLblToInfoLbl )
import MachOp import MachOp
import SMRep ( tablesNextToCode ) import SMRep ( tablesNextToCode )
...@@ -85,8 +86,17 @@ lookForInline u expr (CmmNop : rest) ...@@ -85,8 +86,17 @@ lookForInline u expr (CmmNop : rest)
lookForInline u expr (stmt:stmts) lookForInline u expr (stmt:stmts)
= case lookupUFM (getStmtUses stmt) u of = case lookupUFM (getStmtUses stmt) u of
Just 1 -> Just (inlineStmt u expr stmt : stmts) Just 1 | ok_to_inline -> Just (inlineStmt u expr stmt : stmts)
_other -> Nothing _other -> Nothing
where
-- we don't inline into CmmCall if the expression refers to global
-- registers. This is a HACK to avoid global registers clashing with
-- C argument-passing registers, really the back-end ought to be able
-- to handle it properly, but currently neither PprC nor the NCG can
-- do it. See also CgForeignCall:load_args_into_temps.
ok_to_inline = case stmt of
CmmCall{} -> hasNoGlobalRegs expr
_ -> True
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Boring Cmm traversals for collecting usage info and substitutions. -- Boring Cmm traversals for collecting usage info and substitutions.
......
...@@ -32,7 +32,7 @@ import MachOp ...@@ -32,7 +32,7 @@ import MachOp
import SMRep ( fixedHdrSize, CgRep(..) ) import SMRep ( fixedHdrSize, CgRep(..) )
import Lexer import Lexer
import ForeignCall ( CCallConv(..) ) import ForeignCall ( CCallConv(..), Safety(..) )
import Literal ( mkMachInt ) import Literal ( mkMachInt )
import Unique import Unique
import UniqFM import UniqFM
...@@ -732,7 +732,8 @@ foreignCall "C" results_code expr_code args_code vols ...@@ -732,7 +732,8 @@ foreignCall "C" results_code expr_code args_code vols
results <- sequence results_code results <- sequence results_code
expr <- expr_code expr <- expr_code
args <- sequence args_code args <- sequence args_code
stmtEC (CmmCall (CmmForeignCall expr CCallConv) results args vols) code (emitForeignCall' PlayRisky results
(CmmForeignCall expr CCallConv) args vols)
foreignCall conv _ _ _ _ foreignCall conv _ _ _ _
= fail ("unknown calling convention: " ++ conv) = fail ("unknown calling convention: " ++ conv)
......
...@@ -10,7 +10,7 @@ module CmmUtils( ...@@ -10,7 +10,7 @@ module CmmUtils(
CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList, CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList,
isNopStmt, isNopStmt,
isTrivialCmmExpr, isTrivialCmmExpr, hasNoGlobalRegs,
cmmRegOff, cmmLabelOff, cmmOffset, cmmOffsetLit, cmmIndex, cmmRegOff, cmmLabelOff, cmmOffset, cmmOffsetLit, cmmIndex,
cmmOffsetExpr, cmmIndexExpr, cmmLoadIndex, cmmOffsetExpr, cmmIndexExpr, cmmLoadIndex,
...@@ -90,6 +90,14 @@ isTrivialCmmExpr (CmmLit _) = True ...@@ -90,6 +90,14 @@ isTrivialCmmExpr (CmmLit _) = True
isTrivialCmmExpr (CmmReg _) = True isTrivialCmmExpr (CmmReg _) = True
isTrivialCmmExpr (CmmRegOff _ _) = True isTrivialCmmExpr (CmmRegOff _ _) = True
hasNoGlobalRegs :: CmmExpr -> Bool
hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e
hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es
hasNoGlobalRegs (CmmLit _) = True
hasNoGlobalRegs (CmmReg (CmmLocal _)) = True
hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
hasNoGlobalRegs _ = False
--------------------------------------------------- ---------------------------------------------------
-- --
-- Expr Construction helpers -- Expr Construction helpers
......
...@@ -7,8 +7,9 @@ ...@@ -7,8 +7,9 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module CgForeignCall ( module CgForeignCall (
emitForeignCall,
cgForeignCall, cgForeignCall,
emitForeignCall,
emitForeignCall',
shimForeignCallArg, shimForeignCallArg,
emitSaveThreadState, -- will be needed by the Cmm parser emitSaveThreadState, -- will be needed by the Cmm parser
emitLoadThreadState, -- ditto emitLoadThreadState, -- ditto
...@@ -22,7 +23,8 @@ import StgSyn ( StgLiveVars, StgArg, stgArgType ) ...@@ -22,7 +23,8 @@ import StgSyn ( StgLiveVars, StgArg, stgArgType )
import CgProf ( curCCS, curCCSAddr ) import CgProf ( curCCS, curCCSAddr )
import CgBindery ( getVolatileRegs, getArgAmodes ) import CgBindery ( getVolatileRegs, getArgAmodes )
import CgMonad import CgMonad
import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp ) import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp,
assignTemp )
import Type ( tyConAppTyCon, repType ) import Type ( tyConAppTyCon, repType )
import TysPrim import TysPrim
import CLabel ( mkForeignLabel, mkRtsCodeLabel ) import CLabel ( mkForeignLabel, mkRtsCodeLabel )
...@@ -68,32 +70,9 @@ emitForeignCall ...@@ -68,32 +70,9 @@ emitForeignCall
-> Code -> Code
emitForeignCall results (CCall (CCallSpec target cconv safety)) args live emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
| not (playSafe safety) = do vols <- getVolatileRegs live
= do emitForeignCall' safety results
vols <- getVolatileRegs live (CmmForeignCall cmm_target cconv) call_args (Just vols)
stmtC (the_call vols)
| otherwise -- it's a safe foreign call
= do
vols <- getVolatileRegs live
id <- newTemp wordRep
emitSaveThreadState
stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
[(id,PtrHint)]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
(Just vols)
)
stmtC (the_call vols)
stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
[ (CmmGlobal BaseReg, PtrHint) ]
-- Assign the result to BaseReg: we
-- might now have a different
-- Capability!
[ (CmmReg id, PtrHint) ]
(Just vols)
)
emitLoadThreadState
where where
(call_args, cmm_target) (call_args, cmm_target)
= case target of = case target of
...@@ -101,9 +80,6 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live ...@@ -101,9 +80,6 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
(mkForeignLabel lbl call_size False))) (mkForeignLabel lbl call_size False)))
DynamicTarget -> case args of (fn,_):rest -> (rest, fn) DynamicTarget -> case args of (fn,_):rest -> (rest, fn)
the_call vols = CmmCall (CmmForeignCall cmm_target cconv)
results call_args (Just vols)
-- in the stdcall calling convention, the symbol needs @size appended -- in the stdcall calling convention, the symbol needs @size appended
-- to it, where size is the total number of bytes of arguments. We -- to it, where size is the total number of bytes of arguments. We
-- attach this info to the CLabel here, and the CLabel pretty printer -- attach this info to the CLabel here, and the CLabel pretty printer
...@@ -115,13 +91,66 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live ...@@ -115,13 +91,66 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
-- ToDo: this might not be correct for 64-bit API -- ToDo: this might not be correct for 64-bit API
arg_size rep = max (machRepByteWidth rep) wORD_SIZE arg_size rep = max (machRepByteWidth rep) wORD_SIZE
emitForeignCall results (DNCall _) args live emitForeignCall results (DNCall _) args live
= panic "emitForeignCall: DNCall" = panic "emitForeignCall: DNCall"
-- alternative entry point, used by CmmParse
emitForeignCall'
:: Safety
-> [(CmmReg,MachHint)] -- where to put the results
-> CmmCallTarget -- the op
-> [(CmmExpr,MachHint)] -- arguments
-> Maybe [GlobalReg] -- live vars, in case we need to save them
-> Code
emitForeignCall' safety results target args vols
| not (playSafe safety) = do
temp_args <- load_args_into_temps args
stmtC (CmmCall target results temp_args vols)
| otherwise = do
id <- newTemp wordRep
temp_args <- load_args_into_temps args
emitSaveThreadState
stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
[(id,PtrHint)]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
vols
)
stmtC (CmmCall target results temp_args vols)
stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
[ (CmmGlobal BaseReg, PtrHint) ]
-- Assign the result to BaseReg: we
-- might now have a different
-- Capability!
[ (CmmReg id, PtrHint) ]
vols
)
emitLoadThreadState
suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread"))) suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread"))) resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
-- we might need to load arguments into temporaries before
-- making the call, because certain global registers might
-- overlap with registers that the C calling convention uses
-- for passing arguments.
--
-- This is a HACK; really it should be done in the back end, but
-- it's easier to generate the temporaries here.
load_args_into_temps args = mapM maybe_assignTemp args
maybe_assignTemp (e, hint)
| hasNoGlobalRegs e = return (e, hint)
| otherwise = do
-- don't use assignTemp, it uses its own notion of "trivial"
-- expressions, which are wrong here
reg <- newTemp (cmmExprRep e)
stmtC (CmmAssign reg e)
return (CmmReg reg, hint)
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Save/restore the thread state in the TSO -- Save/restore the thread state in the TSO
......
...@@ -14,6 +14,7 @@ module CgPrimOp ( ...@@ -14,6 +14,7 @@ module CgPrimOp (
import ForeignCall ( CCallConv(CCallConv) ) import ForeignCall ( CCallConv(CCallConv) )
import StgSyn ( StgLiveVars, StgArg ) import StgSyn ( StgLiveVars, StgArg )
import CgForeignCall ( emitForeignCall' )
import CgBindery ( getVolatileRegs, getArgAmodes ) import CgBindery ( getVolatileRegs, getArgAmodes )
import CgMonad import CgMonad
import CgInfoTbls ( getConstrTag ) import CgInfoTbls ( getConstrTag )
...@@ -117,10 +118,11 @@ emitPrimOp [res] ParOp [arg] live ...@@ -117,10 +118,11 @@ emitPrimOp [res] ParOp [arg] live
-- for now, just implement this in a C function -- for now, just implement this in a C function
-- later, we might want to inline it. -- later, we might want to inline it.
vols <- getVolatileRegs live vols <- getVolatileRegs live
stmtC (CmmCall (CmmForeignCall newspark CCallConv) [(res,NoHint)] emitForeignCall' PlayRisky
[(CmmReg (CmmGlobal BaseReg), PtrHint), [(res,NoHint)]
(arg,PtrHint)] (CmmForeignCall newspark CCallConv)
(Just vols)) [(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)]
(Just vols)
where where
newspark = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("newSpark"))) newspark = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("newSpark")))
...@@ -131,12 +133,12 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live ...@@ -131,12 +133,12 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live
= do = do
stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var) stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var)
vols <- getVolatileRegs live vols <- getVolatileRegs live
stmtC (CmmCall (CmmForeignCall (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) emitForeignCall' PlayRisky
CCallConv)
[{-no results-}] [{-no results-}]
[(CmmReg (CmmGlobal BaseReg), PtrHint), (CmmForeignCall (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
(mutv,PtrHint)] CCallConv)
(Just vols)) [(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)]
(Just vols)
-- #define sizzeofByteArrayzh(r,a) \ -- #define sizzeofByteArrayzh(r,a) \
-- r = (((StgArrWords *)(a))->words * sizeof(W_)) -- r = (((StgArrWords *)(a))->words * sizeof(W_))
...@@ -336,8 +338,11 @@ emitPrimOp [res] op [arg] live ...@@ -336,8 +338,11 @@ emitPrimOp [res] op [arg] live
emitPrimOp [res] op args live emitPrimOp [res] op args live
| Just prim <- callishOp op | Just prim <- callishOp op
= do vols <- getVolatileRegs live = do vols <- getVolatileRegs live
stmtC (CmmCall (CmmPrim prim) [(res,NoHint)] emitForeignCall' PlayRisky
[(a,NoHint) | a<-args] (Just vols)) -- ToDo: hints? [(res,NoHint)]
(CmmPrim prim)
[(a,NoHint) | a<-args] -- ToDo: hints?
(Just vols)
| Just mop <- translateOp op | Just mop <- translateOp op
= let stmt = CmmAssign res (CmmMachOp mop args) in = let stmt = CmmAssign res (CmmMachOp mop args) in
......
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