From: Duncan Coutts Date: Tue, 9 Jun 2009 15:11:55 +0000 (+0000) Subject: Add PrimCall to the STG layer and update Core -> STG translation X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hp=5b7e2a875b089f31cd8dedb52d47ef9a93f276be Add PrimCall to the STG layer and update Core -> STG translation It adds a third case to StgOp which already hold StgPrimOp and StgFCallOp. The code generation for the new StgPrimCallOp case is almost exactly the same as for out-of-line primops. They now share the tailCallPrim function. In the Core -> STG translation we map foreign calls using the "prim" calling convention to the StgPrimCallOp case. This is because in Core we represent prim calls using the ForeignCall stuff. At the STG level however the prim calls are really much more like primops than foreign calls. --- diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 0702785..9ba55ac 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -90,6 +90,8 @@ module CLabel ( mkRtsApFastLabel, + mkPrimCallLabel, + mkForeignLabel, addLabelSize, foreignLabelStdcallInfo, @@ -375,6 +377,11 @@ mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) + -- Primitive / cmm call labels + +mkPrimCallLabel :: PrimCall -> CLabel +mkPrimCallLabel (PrimCall str) = ForeignLabel str Nothing False IsFunction + -- Foreign labels mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index eb1d9f0..71087ca 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -179,6 +179,9 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty) performReturn emitReturnInstr where result_info = getPrimOpResultInfo primop + +cgExpr (StgOpApp (StgPrimCallOp primcall) args _res_ty) + = tailCallPrimCall primcall args \end{code} %******************************************************** diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index 60a8561..89c0504 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -11,6 +11,7 @@ module CgTailCall ( returnUnboxedTuple, ccallReturnUnboxedTuple, pushUnboxedTuple, tailCallPrimOp, + tailCallPrimCall, pushReturnAddress ) where @@ -382,13 +383,21 @@ ccallReturnUnboxedTuple amodes before_jump -- Calling an out-of-line primop tailCallPrimOp :: PrimOp -> [StgArg] -> Code -tailCallPrimOp op args +tailCallPrimOp op + = tailCallPrim (mkRtsPrimOpLabel op) + +tailCallPrimCall :: PrimCall -> [StgArg] -> Code +tailCallPrimCall primcall + = tailCallPrim (mkPrimCallLabel primcall) + +tailCallPrim :: CLabel -> [StgArg] -> Code +tailCallPrim lbl args = do { -- We're going to perform a normal-looking tail call, -- except that *all* the arguments will be in registers. -- Hence the ASSERT( null leftovers ) arg_amodes <- getArgAmodes args ; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes - jump_to_primop = jumpToLbl (mkRtsPrimOpLabel op) + jump_to_primop = jumpToLbl lbl ; ASSERT(null leftovers) -- no stack-resident args emitSimultaneously (assignToRegs arg_regs) diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 7bc75de..80a4bb6 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -110,6 +110,11 @@ cgOpApp (StgPrimOp primop) args res_ty where result_info = getPrimOpResultInfo primop +cgOpApp (StgPrimCallOp primcall) args _res_ty + = do { cmm_args <- getNonVoidArgAmodes args + ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) + ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args } + --------------------------------------------------- cgPrimOp :: [LocalReg] -- where to put the results -> PrimOp -- the op diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index 6338941..a9a8fa2 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -21,7 +21,9 @@ module PrimOp ( primOpOutOfLine, primOpNeedsWrapper, primOpOkForSpeculation, primOpIsCheap, primOpIsDupable, - getPrimOpResultInfo, PrimOpResultInfo(..) + getPrimOpResultInfo, PrimOpResultInfo(..), + + PrimCall(..) ) where #include "HsVersions.h" @@ -36,6 +38,7 @@ import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon, typePrimRep ) import BasicTypes ( Arity, Boxity(..) ) +import ForeignCall ( CLabelString ) import Unique ( Unique, mkPrimOpIdUnique ) import Outputable import FastTypes @@ -506,3 +509,17 @@ pprPrimOp :: PrimOp -> SDoc pprPrimOp other_op = pprOccName (primOpOcc other_op) \end{code} + +%************************************************************************ +%* * +\subsubsection[PrimCall]{User-imported primitive calls} +%* * +%************************************************************************ + +\begin{code} +newtype PrimCall = PrimCall CLabelString + +instance Outputable PrimCall where + ppr (PrimCall lbl) = ppr lbl + +\end{code} diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 6dd0255..b2d7257 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -34,6 +34,8 @@ import Outputable import MonadUtils import FastString import Util +import ForeignCall +import PrimOp ( PrimCall(..) ) \end{code} %************************************************************************ @@ -528,6 +530,11 @@ coreToStgApp _ f args = do DataConWorkId dc | saturated -> StgConApp dc args' PrimOpId op -> ASSERT( saturated ) StgOpApp (StgPrimOp op) args' res_ty + FCallId (CCall (CCallSpec (StaticTarget lbl) PrimCallConv _)) + -- prim calls are represented as FCalls in core, + -- but in stg we distinguish them + -> ASSERT( saturated ) + StgOpApp (StgPrimCallOp (PrimCall lbl)) args' res_ty FCallId call -> ASSERT( saturated ) StgOpApp (StgFCallOp call (idUnique f)) args' res_ty TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index 2530843..973514c 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -56,7 +56,7 @@ import ForeignCall ( ForeignCall ) import DataCon ( DataCon, dataConName ) import CoreSyn ( AltCon ) import PprCore ( {- instances -} ) -import PrimOp ( PrimOp ) +import PrimOp ( PrimOp, PrimCall ) import Outputable import Type ( Type ) import TyCon ( TyCon ) @@ -557,6 +557,8 @@ in StgOpApp and COpStmt. \begin{code} data StgOp = StgPrimOp PrimOp + | StgPrimCallOp PrimCall + | StgFCallOp ForeignCall Unique -- The Unique is occasionally needed by the C pretty-printer -- (which lacks a unique supply), notably when generating a @@ -765,6 +767,7 @@ pprStgAlt (con, params, _use_mask, expr) pprStgOp :: StgOp -> SDoc pprStgOp (StgPrimOp op) = ppr op +pprStgOp (StgPrimCallOp op)= ppr op pprStgOp (StgFCallOp op _) = ppr op instance Outputable AltType where