3 files changed, 42 insertions, 22 deletions

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 97721797ad..07acdd370a 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -27,7 +27,6 @@ import VarSet
 import VarEnv
 import DataCon		( dataConWrapId )
 import IdInfo		( OccInfo(..) )
-import TysPrim		( foreignObjPrimTyCon )
 import Maybes		( maybeToBool )
 import Name		( getOccName, isExternallyVisibleName, isDllName )
 import OccName		( occNameUserString )
@@ -468,20 +467,6 @@ coreToStgExpr (Let bind body)
     returnLne (new_let, fvs, escs)
 \end{code}
 
-If we've got a case containing a _ccall_GC_ primop, we need to
-ensure that the arguments are kept live for the duration of the
-call. This only an issue
-
-\begin{code}
-isForeignObjArg :: Id -> Bool
-isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
-
-isForeignObjPrimTy ty
-   = case splitTyConApp_maybe ty of
-	Just (tycon, _) -> tycon == foreignObjPrimTyCon
-	Nothing		-> False
-\end{code}
-
 \begin{code}
 mkStgAlgAlts ty alts deflt
  =  case alts of
@@ -552,9 +537,11 @@ coreToStgApp maybe_thunk_body f args
 	--	   continuation, but it does no harm to just union the
 	--	   two regardless.
 
+	res_ty = exprType (mkApps (Var f) args)
 	app = case globalIdDetails f of
-      		DataConId dc -> StgConApp dc args'
-	        PrimOpId op  -> StgPrimApp op args' (exprType (mkApps (Var f) args))
+      		DataConId dc -> StgConApp dc				 args'
+	        PrimOpId op  -> StgOpApp  (StgPrimOp op)		 args' res_ty
+		FCallId call -> StgOpApp  (StgFCallOp call (idUnique f)) args' res_ty
 		_other       -> StgApp f args'
 
     in
diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 0eda05d6e4..72a1ffb56c 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -166,7 +166,13 @@ lintStgExpr e@(StgConApp con args)
   where
     con_ty = dataConRepType con
 
-lintStgExpr e@(StgPrimApp op args _)
+lintStgExpr e@(StgOpApp (StgFCallOp _ _) args res_ty)
+  = 	-- We don't have enough type information to check
+	-- the application; ToDo
+    mapMaybeL lintStgArg args	`thenL` \ maybe_arg_tys ->
+    returnL (Just res_ty)
+
+lintStgExpr e@(StgOpApp (StgPrimOp op) args _)
   = mapMaybeL lintStgArg args	`thenL` \ maybe_arg_tys ->
     case maybe_arg_tys of
       Nothing 	    -> returnL Nothing
diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs
index 633d5beabc..b100b1e112 100644
--- a/ghc/compiler/stgSyn/StgSyn.lhs
+++ b/ghc/compiler/stgSyn/StgSyn.lhs
@@ -10,7 +10,7 @@ suited to spineless tagless code generation.
 
 \begin{code}
 module StgSyn (
-	GenStgArg(..),
+	GenStgArg(..), 
 	GenStgLiveVars,
 
 	GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
@@ -27,6 +27,9 @@ module StgSyn (
 	StgBinding, StgExpr, StgRhs,
 	StgCaseAlts, StgCaseDefault,
 
+	-- StgOp
+	StgOp(..),
+
 	-- SRTs
 	SRT(..), noSRT,
 
@@ -49,12 +52,14 @@ import VarSet		( IdSet, isEmptyVarSet )
 import Id		( Id, idName, idPrimRep, idType )
 import Name		( isDllName )
 import Literal		( Literal, literalType, isLitLitLit, literalPrimRep )
+import ForeignCall	( ForeignCall )
 import DataCon		( DataCon, dataConName )
 import PrimOp		( PrimOp )
 import Outputable
 import Type             ( Type )
 import TyCon            ( TyCon )
 import UniqSet		( isEmptyUniqSet, uniqSetToList, UniqSet )
+import Unique		( Unique )
 import CmdLineOpts	( opt_SccProfilingOn )
 \end{code}
 
@@ -166,7 +171,7 @@ constructors, primitives, and literals.
   | StgConApp	DataCon
 		[GenStgArg occ]	-- Saturated
 
-  | StgPrimApp	PrimOp
+  | StgOpApp	StgOp		-- Primitive op or foreign call
 		[GenStgArg occ]	-- Saturated
 		Type		-- Result type; we need to know the result type
 				-- so that we can assign result registers.
@@ -533,6 +538,26 @@ isUpdatable Updatable   = True
 
 %************************************************************************
 %*                                                                      *
+\subsubsection{StgOp}
+%*                                                                      *
+%************************************************************************
+
+An StgOp allows us to group together PrimOps and ForeignCalls.
+It's quite useful to move these around together, notably
+in StgOpApp and COpStmt.
+
+\begin{code}
+data StgOp = StgPrimOp  PrimOp
+
+	   | StgFCallOp ForeignCall Unique
+		-- The Unique is occasionally needed by the C pretty-printer
+		-- (which lacks a unique supply), notably when generating a
+		-- typedef for foreign-export-dynamic
+\end{code}
+
+
+%************************************************************************
+%*                                                                      *
 \subsubsection[Static Reference Tables]{@SRT@}
 %*                                                                      *
 %************************************************************************
@@ -646,8 +671,8 @@ pprStgExpr (StgApp func args)
 pprStgExpr (StgConApp con args)
   = hsep [ ppr con, brackets (interppSP args)]
 
-pprStgExpr (StgPrimApp op args _)
-  = hsep [ ppr op, brackets (interppSP args)]
+pprStgExpr (StgOpApp op args _)
+  = hsep [ pprStgOp op, brackets (interppSP args)]
 
 pprStgExpr (StgLam _ bndrs body)
   =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
@@ -746,6 +771,8 @@ pprStgDefault StgNoDefault	    = empty
 pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 
 					 4 (ppr expr)
 
+pprStgOp (StgPrimOp  op)   = ppr op
+pprStgOp (StgFCallOp op _) = ppr op
 \end{code}
 
 \begin{code}