From: Simon Marlow Date: Tue, 28 Feb 2006 15:29:42 +0000 (+0000) Subject: Allow C argument regs to be used as global regs (R1, R2, etc.) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=14a5c62a2d27830ea8b3716bb32a04f23678b355 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). --- diff --git a/ghc/compiler/cmm/CmmOpt.hs b/ghc/compiler/cmm/CmmOpt.hs index 95d1318..c8d48b4 100644 --- a/ghc/compiler/cmm/CmmOpt.hs +++ b/ghc/compiler/cmm/CmmOpt.hs @@ -15,6 +15,7 @@ module CmmOpt ( #include "HsVersions.h" import Cmm +import CmmUtils ( hasNoGlobalRegs ) import CLabel ( entryLblToInfoLbl ) import MachOp import SMRep ( tablesNextToCode ) @@ -85,8 +86,17 @@ lookForInline u expr (CmmNop : rest) 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. diff --git a/ghc/compiler/cmm/CmmParse.y b/ghc/compiler/cmm/CmmParse.y index cfb2a9d..aee1516 100644 --- a/ghc/compiler/cmm/CmmParse.y +++ b/ghc/compiler/cmm/CmmParse.y @@ -32,7 +32,7 @@ import MachOp import SMRep ( fixedHdrSize, CgRep(..) ) import Lexer -import ForeignCall ( CCallConv(..) ) +import ForeignCall ( CCallConv(..), Safety(..) ) import Literal ( mkMachInt ) import Unique import UniqFM @@ -732,7 +732,8 @@ foreignCall "C" results_code expr_code args_code vols results <- sequence results_code expr <- expr_code args <- sequence args_code - stmtEC (CmmCall (CmmForeignCall expr CCallConv) results args vols) + code (emitForeignCall' PlayRisky results + (CmmForeignCall expr CCallConv) args vols) foreignCall conv _ _ _ _ = fail ("unknown calling convention: " ++ conv) diff --git a/ghc/compiler/cmm/CmmUtils.hs b/ghc/compiler/cmm/CmmUtils.hs index b2a107c..a04935b 100644 --- a/ghc/compiler/cmm/CmmUtils.hs +++ b/ghc/compiler/cmm/CmmUtils.hs @@ -10,7 +10,7 @@ module CmmUtils( CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList, isNopStmt, - isTrivialCmmExpr, + isTrivialCmmExpr, hasNoGlobalRegs, cmmRegOff, cmmLabelOff, cmmOffset, cmmOffsetLit, cmmIndex, cmmOffsetExpr, cmmIndexExpr, cmmLoadIndex, @@ -90,6 +90,14 @@ isTrivialCmmExpr (CmmLit _) = True 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 diff --git a/ghc/compiler/codeGen/CgForeignCall.hs b/ghc/compiler/codeGen/CgForeignCall.hs index e56189a..10f41bd 100644 --- a/ghc/compiler/codeGen/CgForeignCall.hs +++ b/ghc/compiler/codeGen/CgForeignCall.hs @@ -7,8 +7,9 @@ ----------------------------------------------------------------------------- module CgForeignCall ( - emitForeignCall, cgForeignCall, + emitForeignCall, + emitForeignCall', shimForeignCallArg, emitSaveThreadState, -- will be needed by the Cmm parser emitLoadThreadState, -- ditto @@ -22,7 +23,8 @@ import StgSyn ( StgLiveVars, StgArg, stgArgType ) 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 ) @@ -68,32 +70,9 @@ emitForeignCall -> 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 @@ -101,9 +80,6 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live (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 @@ -115,13 +91,66 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live -- 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 diff --git a/ghc/compiler/codeGen/CgPrimOp.hs b/ghc/compiler/codeGen/CgPrimOp.hs index c1264be..bc7c914 100644 --- a/ghc/compiler/codeGen/CgPrimOp.hs +++ b/ghc/compiler/codeGen/CgPrimOp.hs @@ -14,6 +14,7 @@ module CgPrimOp ( import ForeignCall ( CCallConv(CCallConv) ) import StgSyn ( StgLiveVars, StgArg ) +import CgForeignCall ( emitForeignCall' ) import CgBindery ( getVolatileRegs, getArgAmodes ) import CgMonad import CgInfoTbls ( getConstrTag ) @@ -117,10 +118,11 @@ emitPrimOp [res] ParOp [arg] live -- 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"))) @@ -131,12 +133,12 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live = 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_)) @@ -336,8 +338,11 @@ emitPrimOp [res] op [arg] live 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