#include "HsVersions.h"
import Cmm
+import CmmUtils ( hasNoGlobalRegs )
import CLabel ( entryLblToInfoLbl )
import MachOp
import SMRep ( tablesNextToCode )
lookForInline u expr (stmt:stmts)
= 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
+ 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.
CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList,
isNopStmt,
- isTrivialCmmExpr,
+ isTrivialCmmExpr, hasNoGlobalRegs,
cmmRegOff, cmmLabelOff, cmmOffset, cmmOffsetLit, cmmIndex,
cmmOffsetExpr, cmmIndexExpr, cmmLoadIndex,
isTrivialCmmExpr (CmmReg _) = 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
-----------------------------------------------------------------------------
module CgForeignCall (
- emitForeignCall,
cgForeignCall,
+ emitForeignCall,
+ emitForeignCall',
shimForeignCallArg,
emitSaveThreadState, -- will be needed by the Cmm parser
emitLoadThreadState, -- ditto
import CgProf ( curCCS, curCCSAddr )
import CgBindery ( getVolatileRegs, getArgAmodes )
import CgMonad
-import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp )
+import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp,
+ assignTemp )
import Type ( tyConAppTyCon, repType )
import TysPrim
import CLabel ( mkForeignLabel, mkRtsCodeLabel )
-> Code
emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
- | not (playSafe safety)
- = do
- vols <- getVolatileRegs live
- 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
-
+ = do vols <- getVolatileRegs live
+ emitForeignCall' safety results
+ (CmmForeignCall cmm_target cconv) call_args (Just vols)
where
(call_args, cmm_target)
= case target of
(mkForeignLabel lbl call_size False)))
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
-- 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
-- ToDo: this might not be correct for 64-bit API
arg_size rep = max (machRepByteWidth rep) wORD_SIZE
-
emitForeignCall results (DNCall _) args live
= 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")))
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
import ForeignCall ( CCallConv(CCallConv) )
import StgSyn ( StgLiveVars, StgArg )
+import CgForeignCall ( emitForeignCall' )
import CgBindery ( getVolatileRegs, getArgAmodes )
import CgMonad
import CgInfoTbls ( getConstrTag )
-- for now, just implement this in a C function
-- later, we might want to inline it.
vols <- getVolatileRegs live
- stmtC (CmmCall (CmmForeignCall newspark CCallConv) [(res,NoHint)]
- [(CmmReg (CmmGlobal BaseReg), PtrHint),
- (arg,PtrHint)]
- (Just vols))
+ emitForeignCall' PlayRisky
+ [(res,NoHint)]
+ (CmmForeignCall newspark CCallConv)
+ [(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)]
+ (Just vols)
where
newspark = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("newSpark")))
= do
stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var)
vols <- getVolatileRegs live
- stmtC (CmmCall (CmmForeignCall (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
- CCallConv)
- [{-no results-}]
- [(CmmReg (CmmGlobal BaseReg), PtrHint),
- (mutv,PtrHint)]
- (Just vols))
+ emitForeignCall' PlayRisky
+ [{-no results-}]
+ (CmmForeignCall (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
+ CCallConv)
+ [(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)]
+ (Just vols)
-- #define sizzeofByteArrayzh(r,a) \
-- r = (((StgArrWords *)(a))->words * sizeof(W_))
emitPrimOp [res] op args live
| Just prim <- callishOp op
= do vols <- getVolatileRegs live
- stmtC (CmmCall (CmmPrim prim) [(res,NoHint)]
- [(a,NoHint) | a<-args] (Just vols)) -- ToDo: hints?
+ emitForeignCall' PlayRisky
+ [(res,NoHint)]
+ (CmmPrim prim)
+ [(a,NoHint) | a<-args] -- ToDo: hints?
+ (Just vols)
| Just mop <- translateOp op
= let stmt = CmmAssign res (CmmMachOp mop args) in
projects / ghc-hetmet.git / commitdiff