Commit be0b1dff authored by ian@well-typed.com's avatar ian@well-typed.com

In CMM, only allow foreign calls to labels, not arbitrary expressions

I'm not sure if we want to make this change permanently, but for now it
fixes the unreg build.

I've also removed some redundant special-case code that generated
prototypes for foreign functions. The standard pprTempAndExternDecls
now generates them.
parent dbd96451
......@@ -398,13 +398,13 @@ mkConEntryLabel name c = IdLabel name c ConEntry
mkStaticConEntryLabel name c = IdLabel name c StaticConEntry
-- Constructing Cmm Labels
mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, mkUpdInfoLabel,
mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
mkMAP_FROZEN_infoLabel, mkMAP_DIRTY_infoLabel,
mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,
mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel :: CLabel
mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") CmmCode
mkDirty_MUT_VAR_Label = CmmLabel rtsPackageId (fsLit "dirty_MUT_VAR") CmmCode
mkUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_upd_frame") CmmInfo
mkBHUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_bh_upd_frame" ) CmmInfo
mkIndStaticInfoLabel = CmmLabel rtsPackageId (fsLit "stg_IND_STATIC") CmmInfo
......
......@@ -6,13 +6,13 @@ module CmmLayoutStack (
import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX layering violation
import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX layering violation
import BasicTypes
import Cmm
import CmmInfo
import BlockId
import CLabel
import CmmUtils
import MkGraph
import Module
import ForeignCall
import CmmLive
import CmmProcPoint
......@@ -965,7 +965,7 @@ lowerSafeForeignCall dflags block
foreignLbl :: FastString -> CmmExpr
foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
newTemp :: CmmType -> UniqSM LocalReg
newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
......
......@@ -557,7 +557,7 @@ stmt :: { CmmParse () }
-- we tweak the syntax to avoid the conflict. The later
-- option is taken here because the other way would require
-- multiple levels of expanding and get unwieldy.
| foreign_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
| foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
{% foreignCall $3 $1 $4 $6 $8 $9 }
| foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
{% primCall $1 $4 $6 }
......@@ -588,6 +588,9 @@ stmt :: { CmmParse () }
| 'push' '(' exprs0 ')' maybe_body
{ pushStackFrame $3 $5 }
foreignLabel :: { CmmParse CmmExpr }
: NAME { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction))) }
opt_never_returns :: { CmmReturnInfo }
: { CmmMayReturn }
| 'never' 'returns' { CmmNeverReturns }
......
......@@ -189,7 +189,6 @@ pprStmt stmt =
rep = cmmExprType dflags src
CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->
maybe_proto $$
fnCall
where
(res_hints, arg_hints) = foreignTargetHints target
......@@ -200,40 +199,29 @@ pprStmt stmt =
cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)
real_fun_proto lbl = char ';' <>
pprCFunType (ppr lbl) cconv hresults hargs <>
noreturn_attr <> semi
noreturn_attr = case ret of
CmmNeverReturns -> text "__attribute__ ((noreturn))"
CmmMayReturn -> empty
-- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
(maybe_proto, fnCall) =
fnCall =
case fn of
CmmLit (CmmLabel lbl)
| StdCallConv <- cconv ->
let myCall = pprCall (ppr lbl) cconv hresults hargs
in (real_fun_proto lbl, myCall)
pprCall (ppr lbl) cconv hresults hargs
-- stdcall functions must be declared with
-- a function type, otherwise the C compiler
-- doesn't add the @n suffix to the label. We
-- can't add the @n suffix ourselves, because
-- it isn't valid C.
| CmmNeverReturns <- ret ->
let myCall = pprCall (ppr lbl) cconv hresults hargs
in (real_fun_proto lbl, myCall)
pprCall cast_fn cconv hresults hargs <> semi
| not (isMathFun lbl) ->
pprForeignCall (ppr lbl) cconv hresults hargs
_ ->
(empty {- no proto -},
pprCall cast_fn cconv hresults hargs <> semi)
pprCall cast_fn cconv hresults hargs <> semi
-- for a dynamic call, no declaration is necessary.
CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty
CmmUnsafeForeignCall target@(PrimTarget op) results args ->
proto $$ fn_call
fn_call
where
cconv = CCallConv
fn = pprCallishMachOp_for_C op
......@@ -242,15 +230,16 @@ pprStmt stmt =
hresults = zip results res_hints
hargs = zip args arg_hints
(proto, fn_call)
fn_call
-- The mem primops carry an extra alignment arg, must drop it.
-- We could maybe emit an alignment directive using this info.
-- We also need to cast mem primops to prevent conflicts with GCC
-- builtins (see bug #5967).
| op `elem` [MO_Memcpy, MO_Memset, MO_Memmove]
= pprForeignCall fn cconv hresults (init hargs)
= (ptext (sLit ";EF_(") <> fn <> char ')' <> semi) $$
pprForeignCall fn cconv hresults (init hargs)
| otherwise
= (empty, pprCall fn cconv hresults hargs)
= pprCall fn cconv hresults hargs
CmmBranch ident -> pprBranch ident
CmmCondBranch expr yes no -> pprCondBranch expr yes no
......@@ -263,8 +252,8 @@ pprStmt stmt =
type Hinted a = (a, ForeignHint)
pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
-> (SDoc, SDoc)
pprForeignCall fn cconv results args = (proto, fn_call)
-> SDoc
pprForeignCall fn cconv results args = fn_call
where
fn_call = braces (
pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
......@@ -272,7 +261,6 @@ pprForeignCall fn cconv results args = (proto, fn_call)
$$ pprCall (text "ghcFunPtr") cconv results args <> semi
)
cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi
pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
pprCFunType ppr_fn cconv ress args
......
......@@ -731,7 +731,7 @@ link_caf node _is_upd = do
-- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion
; ret <- newTemp (bWord dflags)
; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF")
; emitRtsCallGen [(ret,NoHint)] (mkForeignLabel (fsLit "newCAF") Nothing ForeignLabelInExternalPackage IsFunction)
[ (CmmReg (CmmGlobal BaseReg), AddrHint),
(CmmReg (CmmLocal node), AddrHint),
(hp_rel, AddrHint) ]
......
......@@ -36,7 +36,6 @@ import CLabel
import CmmUtils
import PrimOp
import SMRep
import Module
import FastString
import Outputable
import Util
......@@ -214,7 +213,7 @@ emitPrimOp _ [res] ParOp [arg]
-- later, we might want to inline it.
emitCCall
[(res,NoHint)]
(CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
(CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
[(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)]
emitPrimOp dflags [res] SparkOp [arg]
......@@ -226,7 +225,7 @@ emitPrimOp dflags [res] SparkOp [arg]
tmp2 <- newTemp (bWord dflags)
emitCCall
[(tmp2,NoHint)]
(CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
(CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
[(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
......
......@@ -173,22 +173,21 @@ tagToClosure dflags tycon tag
-------------------------------------------------------------------------
emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args safe
emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCallWithResult res hint pkg fun args safe
= emitRtsCallGen [(res,hint)] pkg fun args safe
= emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
-- Make a call to an RTS C procedure
emitRtsCallGen
:: [(LocalReg,ForeignHint)]
-> PackageId
-> FastString
-> CLabel
-> [(CmmExpr,ForeignHint)]
-> Bool -- True <=> CmmSafe call
-> FCode ()
emitRtsCallGen res pkg fun args safe
emitRtsCallGen res lbl args safe
= do { dflags <- getDynFlags
; updfr_off <- getUpdFrameOff
; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
......@@ -204,7 +203,7 @@ emitRtsCallGen res pkg fun args safe
emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
(args', arg_hints) = unzip args
(res', res_hints) = unzip res
fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
fun_expr = mkLblExpr lbl
-----------------------------------------------------------------------------
......
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