summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/cmm/CLabel.hs7
-rw-r--r--compiler/codeGen/CgExpr.lhs3
-rw-r--r--compiler/codeGen/CgTailCall.lhs13
-rw-r--r--compiler/codeGen/StgCmmPrim.hs5
-rw-r--r--compiler/prelude/PrimOp.lhs19
-rw-r--r--compiler/stgSyn/CoreToStg.lhs7
-rw-r--r--compiler/stgSyn/StgSyn.lhs5
7 files changed, 55 insertions, 4 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 0702785e2f..9ba55ac7b2 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 eb1d9f082c..71087ca7c5 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 60a856177c..89c050406f 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 7bc75de940..80a4bb6160 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 6338941662..a9a8fa277e 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 6dd0255d60..b2d725796d 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 2530843556..973514cbaf 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
View Lorry Controller Status