summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
5b7e2a8)
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.
mkForeignLabel,
addLabelSize,
foreignLabelStdcallInfo,
mkForeignLabel,
addLabelSize,
foreignLabelStdcallInfo,
mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off)
mkApEntryLabel upd off = RtsLabel (RtsApEntry 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
-- Foreign labels
mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel
performReturn emitReturnInstr
where
result_info = getPrimOpResultInfo primop
performReturn emitReturnInstr
where
result_info = getPrimOpResultInfo primop
+
+cgExpr (StgOpApp (StgPrimCallOp primcall) args _res_ty)
+ = tailCallPrimCall primcall args
\end{code}
%********************************************************
\end{code}
%********************************************************
returnUnboxedTuple, ccallReturnUnboxedTuple,
pushUnboxedTuple,
tailCallPrimOp,
returnUnboxedTuple, ccallReturnUnboxedTuple,
pushUnboxedTuple,
tailCallPrimOp,
pushReturnAddress
) where
pushReturnAddress
) where
-- Calling an out-of-line primop
tailCallPrimOp :: PrimOp -> [StgArg] -> Code
-- Calling an out-of-line primop
tailCallPrimOp :: PrimOp -> [StgArg] -> Code
+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
= 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)
; ASSERT(null leftovers) -- no stack-resident args
emitSimultaneously (assignToRegs arg_regs)
where
result_info = getPrimOpResultInfo primop
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
---------------------------------------------------
cgPrimOp :: [LocalReg] -- where to put the results
-> PrimOp -- the op
primOpOutOfLine, primOpNeedsWrapper,
primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
primOpOutOfLine, primOpNeedsWrapper,
primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
- getPrimOpResultInfo, PrimOpResultInfo(..)
+ getPrimOpResultInfo, PrimOpResultInfo(..),
+
+ PrimCall(..)
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon,
typePrimRep )
import BasicTypes ( Arity, Boxity(..) )
import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon,
typePrimRep )
import BasicTypes ( Arity, Boxity(..) )
+import ForeignCall ( CLabelString )
import Unique ( Unique, mkPrimOpIdUnique )
import Outputable
import FastTypes
import Unique ( Unique, mkPrimOpIdUnique )
import Outputable
import FastTypes
pprPrimOp other_op = pprOccName (primOpOcc other_op)
\end{code}
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}
import MonadUtils
import FastString
import Util
import MonadUtils
import FastString
import Util
+import ForeignCall
+import PrimOp ( PrimCall(..) )
\end{code}
%************************************************************************
\end{code}
%************************************************************************
DataConWorkId dc | saturated -> StgConApp dc args'
PrimOpId op -> ASSERT( saturated )
StgOpApp (StgPrimOp op) args' res_ty
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')
FCallId call -> ASSERT( saturated )
StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
import DataCon ( DataCon, dataConName )
import CoreSyn ( AltCon )
import PprCore ( {- instances -} )
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 )
import Outputable
import Type ( Type )
import TyCon ( TyCon )
\begin{code}
data StgOp = StgPrimOp PrimOp
\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
| StgFCallOp ForeignCall Unique
-- The Unique is occasionally needed by the C pretty-printer
-- (which lacks a unique supply), notably when generating a
pprStgOp :: StgOp -> SDoc
pprStgOp (StgPrimOp op) = ppr op
pprStgOp :: StgOp -> SDoc
pprStgOp (StgPrimOp op) = ppr op
+pprStgOp (StgPrimCallOp op)= ppr op
pprStgOp (StgFCallOp op _) = ppr op
instance Outputable AltType where
pprStgOp (StgFCallOp op _) = ppr op
instance Outputable AltType where