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.

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