[project @ 2001-05-22 13:43:14 by simonpj]

-------------------------------------------
	Towards generalising 'foreign' declarations
	-------------------------------------------

This is a first step towards generalising 'foreign' declarations to
handle langauges other than C.  Quite a lot of files are touched,
but nothing has really changed.  Everything should work exactly as
before.

	But please be on your guard for ccall-related bugs.

Main things

Basic data types: ForeignCall.lhs
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Remove absCSyn/CallConv.lhs

* Add prelude/ForeignCall.lhs.  This defines the ForeignCall
  type and its variants

* Define ForeignCall.Safety to say whether a call is unsafe
  or not (was just a boolean).  Lots of consequential chuffing.

* Remove all CCall stuff from PrimOp, and put it in ForeignCall


Take CCallOp out of the PrimOp type (where it was always a glitch)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Add IdInfo.FCallId variant to the type IdInfo.GlobalIdDetails,
	along with predicates Id.isFCallId, Id.isFCallId_maybe

* Add StgSyn.StgOp, to sum PrimOp with FCallOp, because it
  *is* useful to sum them together in Stg and AbsC land.  If
  nothing else, it minimises changes.


Also generally rename "CCall" stuff to "FCall" where it's generic
to all foreign calls.

ghc/compiler/absCSyn/AbsCSyn.lhs

 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: AbsCSyn.lhs,v 1.35 2000/10/12 15:17:07 sewardj Exp $
+% $Id: AbsCSyn.lhs,v 1.36 2001/05/22 13:43:14 simonpj Exp $
 %
 \section[AbstractC]{Abstract C: the last stop before machine code}
 
@@ -44,10 +44,10 @@ import Constants   	( mAX_Vanilla_REG, mAX_Float_REG,
 			  mAX_Double_REG, spRelToInt )
 import CostCentre       ( CostCentre, CostCentreStack )
 import Literal		( mkMachInt, Literal(..) )
+import ForeignCall	( CCallSpec )
 import PrimRep		( PrimRep(..) )
-import PrimOp           ( PrimOp, CCall )
 import Unique           ( Unique )
-import StgSyn		( SRT(..) )
+import StgSyn		( StgOp, SRT(..) )
 import TyCon		( TyCon )
 import BitSet				-- for liveness masks
 import FastTypes
@@ -117,7 +117,7 @@ stored in a mixed type location.)
 
   | COpStmt
 	[CAddrMode]	-- Results
-	PrimOp
+	StgOp
 	[CAddrMode]	-- Arguments
 	[MagicId]	-- Potentially volatile/live registers
 			-- (to save/restore around the call/op)
@@ -164,7 +164,7 @@ stored in a mixed type location.)
        compiling 'foreign import dynamic's)
     -}
   | CCallTypedef Bool {- True => use "typedef"; False => use "extern"-}
-  		 CCall [CAddrMode] [CAddrMode]
+  		 CCallSpec Unique [CAddrMode] [CAddrMode]
 
   -- *** the next three [or so...] are DATA (those above are CODE) ***
 

ghc/compiler/absCSyn/AbsCUtils.lhs

@@ -28,7 +28,8 @@ import Unique		( Unique{-instance Eq-} )
 import UniqSupply	( uniqFromSupply, uniqsFromSupply, splitUniqSupply, 
 			  UniqSupply )
 import CmdLineOpts      ( opt_EmitCExternDecls )
-import PrimOp		( PrimOp(..), CCall(..), isDynamicTarget )
+import ForeignCall	( ForeignCall(..), CCallSpec(..), isDynamicTarget )
+import StgSyn		( StgOp(..) )
 import Panic		( panic )
 import FastTypes
 
@@ -340,16 +341,12 @@ flatAbsC (CSwitch discrim alts deflt)
       = flatAbsC absC	`thenFlt` \ (alt_heres, alt_tops) ->
 	returnFlt ( (tag, alt_heres), alt_tops )
 
-flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs)
-  | isCandidate
-  = returnFlt (stmt, tdef)
-  | otherwise
-  = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _ is_asm)) uniq) args _)
+  |  is_dynamic	 				-- Emit a typedef if its a dynamic call
+  || (opt_EmitCExternDecls && not is_asm)	-- or we want extern decls
+  = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
   where
-    isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm
-    is_dynamic  = isDynamicTarget target
-
-    tdef = CCallTypedef is_dynamic ccall results args
+    is_dynamic = isDynamicTarget target
 
 flatAbsC stmt@(CSimultaneous abs_c)
   = flatAbsC abs_c		`thenFlt` \ (stmts_here, tops) ->
@@ -367,14 +364,14 @@ flatAbsC stmt@(CCallProfCtrMacro str amodes)
   | otherwise		 	= returnFlt (stmt, AbsCNop)
 
 -- Some statements need no flattening at all:
-flatAbsC stmt@(CMacroStmt macro amodes) 	= returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CCallProfCCMacro str amodes) 	= returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CAssign dest source) 		= returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CJump target) 			= returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CFallThrough target) 		= returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CReturn target return_info) 	= returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CInitHdr a b cc) 		= returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(COpStmt results op args vol_regs)= returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CMacroStmt macro amodes) 	 = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CCallProfCCMacro str amodes) 	 = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CAssign dest source) 		 = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CJump target) 			 = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CFallThrough target) 		 = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CReturn target return_info) 	 = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CInitHdr a b cc) 		 = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(COpStmt results op args vol_regs) = returnFlt (stmt, AbsCNop)
 
 -- Some statements only make sense at the top level, so we always float
 -- them.  This probably isn't necessary.
@@ -494,11 +491,6 @@ doSimultaneously1 vertices
       = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
     (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
       = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
-
---    (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
---    (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
-
-
 \end{code}
 
 

ghc/compiler/absCSyn/CallConv.lhs

-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[Calling conventions]{External calling conventions}
-
-\begin{code}
-module CallConv
-       (
-	 CallConv
-       , pprCallConv
-       , callConvToInt
-
-       , stdCallConv
-       , cCallConv
-       , defaultCallConv
-       , callConvAttribute
-       ) where
-
-#include "HsVersions.h"
-
-import Outputable
-import PrimRep     ( PrimRep, getPrimRepSizeInBytes )
-\end{code}
-
-\begin{code}
-type CallConv = Int
-
-pprCallConv :: CallConv -> SDoc
-pprCallConv 0 = ptext SLIT("__stdcall")
-pprCallConv _ = ptext SLIT("_ccall")
-
-stdCallConv :: CallConv
-stdCallConv = 0
-
-cCallConv  :: CallConv
-cCallConv = 1
-
-defaultCallConv :: CallConv
-defaultCallConv = cCallConv
-
-callConvToInt :: CallConv -> Int
-callConvToInt x = x
-\end{code}
-
-Generate the gcc attribute corresponding to the given
-calling convention (used by PprAbsC):
-
-ToDo: The stdcall calling convention is x86 (win32) specific,
-so perhaps we should emit a warning if it's being used on other
-platforms.
-
-\begin{code}
-callConvAttribute :: CallConv -> String
-callConvAttribute cc
- | cc == stdCallConv   = "__stdcall"
- | cc == cCallConv     = ""
- | otherwise	       = panic ("callConvAttribute: cannot handle" ++ showSDoc (pprCallConv cc))
-
-\end{code}

ghc/compiler/absCSyn/Costs.lhs

 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: Costs.lhs,v 1.28 2001/01/15 16:55:24 sewardj Exp $
+% $Id: Costs.lhs,v 1.29 2001/05/22 13:43:14 simonpj Exp $
 %
 % Only needed in a GranSim setup -- HWL
 % ---------------------------------------------------------------------------
@@ -62,6 +62,7 @@ module Costs( costs,
 #include "HsVersions.h"
 
 import AbsCSyn
+import StgSyn		( StgOp(..) )
 import PrimOp		( primOpNeedsWrapper, PrimOp(..) )
 import Panic		( trace )
 
@@ -88,10 +89,6 @@ instance Num CostRes where
 mapOp :: (Int -> Int) -> CostRes -> CostRes
 mapOp g ( Cost (i, b, l, s, f) )  = Cost (g i, g b, g l, g s, g f)
 
-foldrOp :: (Int -> a -> a) -> a -> CostRes -> a
-foldrOp o x  ( Cost (i1, b1, l1, s1, f1) )   =
-	i1 `o` ( b1 `o` ( l1 `o` ( s1 `o` ( f1 `o` x))))
-
 binOp :: (Int -> Int -> Int) -> CostRes -> CostRes -> CostRes
 binOp o ( Cost (i1, b1, l1, s1, f1) ) ( Cost  (i2, b2, l2, s2, f2) )  =
 	( Cost (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) )
@@ -185,7 +182,7 @@ costs absC =
 			   For costing the args of this macro
 			   see PprAbsC.lhs where args are inserted -}
 
-   COpStmt modes_res primOp modes_args _ ->
+   COpStmt modes_res op modes_args _ ->
 	{-
 	   let
 		n = length modes_res
@@ -198,9 +195,7 @@ costs absC =
 	-}
 	foldl (+) nullCosts [addrModeCosts mode Lhs | mode <- modes_res]  +
 	foldl (+) nullCosts [addrModeCosts mode Rhs | mode <- modes_args]  +
-	primOpCosts primOp +
-	if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
-				     else nullCosts
+	opCosts op
 
    CSimultaneous absC	     -> costs absC
 
@@ -220,7 +215,7 @@ costs absC =
   -- *** the next three [or so...] are DATA (those above are CODE) ***
   -- as they are data rather than code they all have nullCosts	       -- HWL
 
-   CCallTypedef _ _ _ _      -> nullCosts
+   CCallTypedef _ _ _ _ _    -> nullCosts
 
    CStaticClosure _ _ _ _    -> nullCosts
 
@@ -242,6 +237,7 @@ costs absC =
 
    _ -> trace ("Costs.costs") nullCosts
 
+
 -- ---------------------------------------------------------------------------
 
 addrModeCosts :: CAddrMode -> Side -> CostRes
@@ -368,17 +364,24 @@ umul_costs = Cost (21,4,0,0,0)	   -- due to spy counts
 rem_costs =  Cost (30,15,0,0,0)	   -- due to spy counts
 div_costs =  Cost (30,15,0,0,0)	   -- due to spy counts
 
-primOpCosts :: PrimOp -> CostRes
 
--- Special cases
 
-primOpCosts (CCallOp _) = SAVE_COSTS + RESTORE_COSTS  	
-	                          -- don't guess costs of ccall proper
-                                  -- for exact costing use a GRAN_EXEC
-                                  -- in the C code
+-- ---------------------------------------------------------------------------
+
+opCosts :: StgOp -> CostRes
 
--- Usually 3 mov instructions are needed to get args and res in right place.
+opCosts (StgFCallOp _ _) = SAVE_COSTS + RESTORE_COSTS  	
+	-- Don't guess costs of ccall proper
+        -- for exact costing use a GRAN_EXEC in the C code
 
+opCosts (StgPrimOp primop)
+  = primOpCosts primop +
+    if primOpNeedsWrapper primop then SAVE_COSTS + RESTORE_COSTS
+				 else nullCosts
+
+primOpCosts :: PrimOp -> CostRes
+
+-- Usually 3 mov instructions are needed to get args and res in right place.
 primOpCosts IntMulOp  = Cost (3, 1, 0, 0, 0)  + umul_costs
 primOpCosts IntQuotOp = Cost (3, 1, 0, 0, 0)  + div_costs
 primOpCosts IntRemOp  = Cost (3, 1, 0, 0, 0)  + rem_costs
@@ -421,19 +424,4 @@ primOpCosts primOp
   | primOp `elem` gmpOps   = Cost (30, 5, 10, 10, 0) :: CostRes  -- GUESS; check it
   | otherwise		   = Cost (1, 0, 0, 0, 0)
 
--- ---------------------------------------------------------------------------
-{- HWL: currently unused
-
-costsByKind :: PrimRep -> Side -> CostRes
-
--- The following PrimKinds say that the data is already in a reg
-
-costsByKind CharRep	_ = nullCosts
-costsByKind IntRep	_ = nullCosts
-costsByKind WordRep	_ = nullCosts
-costsByKind AddrRep	_ = nullCosts
-costsByKind FloatRep	_ = nullCosts
-costsByKind DoubleRep	_ = nullCosts
--}
--- ---------------------------------------------------------------------------
 \end{code}

ghc/compiler/absCSyn/PprAbsC.lhs

@@ -26,7 +26,7 @@ import AbsCUtils	( getAmodeRep, nonemptyAbsC,
 			)
 
 import Constants	( mIN_UPD_SIZE )
-import CallConv		( callConvAttribute )
+import ForeignCall	( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute )
 import CLabel		( externallyVisibleCLabel,
 			  needsCDecl, pprCLabel,
 			  mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
@@ -45,15 +45,15 @@ import TyCon		( tyConDataCons )
 import Name		( NamedThing(..) )
 import DataCon		( dataConWrapId )
 import Maybes		( maybeToBool, catMaybes )
-import PrimOp		( primOpNeedsWrapper, pprCCallOp, 
-			  PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
+import PrimOp		( primOpNeedsWrapper )
+import ForeignCall	( ForeignCall(..), isDynamicTarget )
 import PrimRep		( isFloatingRep, PrimRep(..), getPrimRepSize )
 import SMRep		( pprSMRep )
 import Unique		( pprUnique, Unique{-instance NamedThing-} )
 import UniqSet		( emptyUniqSet, elementOfUniqSet,
 			  addOneToUniqSet, UniqSet
 			)
-import StgSyn		( SRT(..) )
+import StgSyn		( SRT(..), StgOp(..) )
 import BitSet		( intBS )
 import Outputable
 import GlaExts
@@ -213,10 +213,10 @@ pprAbsC (CSwitch discrim alts deflt) c -- general case
     -- Costs for addressing header of switch and cond. branching        -- HWL
     switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
 
-pprAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) _
-  = pprCCall ccall args results vol_regs
+pprAbsC stmt@(COpStmt results (StgFCallOp fcall uniq) args vol_regs) _
+  = pprFCall fcall uniq args results vol_regs
 
-pprAbsC stmt@(COpStmt results op args vol_regs) _
+pprAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) _
   = let
 	non_void_args = grab_non_void_amodes args
 	non_void_results = grab_non_void_amodes results
@@ -284,7 +284,7 @@ pprAbsC (CCallProfCtrMacro op as) _
 pprAbsC (CCallProfCCMacro op as) _
   = hcat [ptext op, lparen,
 	hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
-pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results args) _
+pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _ _) uniq results args) _
   =  hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
 	  , ccall_res_ty
 	  , fun_nm
@@ -322,13 +322,13 @@ pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results ar
     -}
 
      fun_nm
-       | is_tdef   = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
-       | otherwise = text (callConvAttribute cconv) <+> ccall_fun_ty
+       | is_tdef   = parens (text (ccallConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
+       | otherwise = text (ccallConvAttribute cconv) <+> ccall_fun_ty
 
      ccall_fun_ty = 
         case op_str of
-	  DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u
-	  StaticTarget x  -> pprCLabelString x
+	  DynamicTarget  -> ptext SLIT("_ccall_fun_ty") <> ppr uniq
+	  StaticTarget x -> pprCLabelString x
 
      ccall_res_ty = 
        case non_void_results of
@@ -775,7 +775,7 @@ Amendment to the above: if we can GC, we have to:
   that the runtime check that PerformGC is being used sensibly will work.
 
 \begin{code}
-pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
+pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results vol_regs
   = vcat [
       char '{',
       declare_local_vars,   -- local var for *result*
@@ -789,15 +789,15 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
   where
     (pp_saves, pp_restores) = ppr_vol_regs vol_regs
     (pp_save_context, pp_restore_context)
-	| may_gc  = ( text "{ I_ id; SUSPEND_THREAD(id);"
-		    , text "RESUME_THREAD(id);}"
-		    )
+	| playSafe safety = ( text "{ I_ id; SUSPEND_THREAD(id);"
+			    , text "RESUME_THREAD(id);}"
+			    )
 	| otherwise = (	pp_basic_saves $$ pp_saves,
 			pp_basic_restores $$ pp_restores)
 
     non_void_args = 
 	let nvas = init args
-	in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode args) )
+	in ASSERT2 ( all non_void nvas, ppr call <+> hsep (map pprAmode args) )
 	nvas
     -- the last argument will be the "I/O world" token (a VoidRep)
     -- all others should be non-void
@@ -820,7 +820,7 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
     -- Remainder only used for ccall
 
     fun_name = case op_str of
-		 DynamicTarget u -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr u) <> text "%0")
+		 DynamicTarget   -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
 		 StaticTarget st -> pprCLabelString st
 
     ccall_str = showSDoc
@@ -837,7 +837,6 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
 		   | otherwise 		    = ccall_args
 
     ccall_args    = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
-
 \end{code}
 
 If the argument is a heap object, we need to reach inside and pull out
@@ -1478,7 +1477,7 @@ ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)
     info_lbl = infoTableLabelFromCI cl_info
 
 ppr_decls_AbsC (COpStmt	results	_ args _) = ppr_decls_Amodes (results ++ args)
-ppr_decls_AbsC (CSimultaneous abc)  	    = ppr_decls_AbsC abc
+ppr_decls_AbsC (CSimultaneous abc)  	  = ppr_decls_AbsC abc
 
 ppr_decls_AbsC (CCheck  	    _ amodes code) = 
      ppr_decls_Amodes amodes `thenTE` \p1 ->

ghc/compiler/basicTypes/Id.lhs

@@ -28,6 +28,7 @@ module Id (
 	isSpecPragmaId,	isExportedId, isLocalId, isGlobalId,
 	isRecordSelector,
 	isPrimOpId, isPrimOpId_maybe, 
+	isFCallId, isFCallId_maybe,
 	isDataConId, isDataConId_maybe, 
 	isDataConWrapId, isDataConWrapId_maybe,
 	isBottomingId,
@@ -233,6 +234,14 @@ isPrimOpId_maybe id = case globalIdDetails id of
 			    PrimOpId op -> Just op
 			    other	-> Nothing
 
+isFCallId id = case globalIdDetails id of
+		    FCallId call -> True
+		    other	 -> False
+
+isFCallId_maybe id = case globalIdDetails id of
+			    FCallId call -> Just call
+			    other	 -> Nothing
+
 isDataConId id = case globalIdDetails id of
 			DataConId _ -> True
 			other	    -> False
@@ -255,6 +264,7 @@ isDataConWrapId id = case globalIdDetails id of
 hasNoBinding id = case globalIdDetails id of
 			DataConId _ -> True
 			PrimOpId _  -> True
+			FCallId _   -> True
 			other	    -> False
 
 isImplicitId :: Id -> Bool
@@ -264,6 +274,7 @@ isImplicitId :: Id -> Bool
 isImplicitId id
   = case globalIdDetails id of
 	RecordSelId _   -> True	-- Includes dictionary selectors
+        FCallId _       -> True
         PrimOpId _      -> True
         DataConId _     -> True
 	DataConWrapId _ -> True

ghc/compiler/basicTypes/IdInfo.lhs

@@ -88,6 +88,7 @@ import BasicTypes	( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea
 			  Arity
 			)
 import DataCon		( DataCon )
+import ForeignCall	( ForeignCall )
 import FieldLabel	( FieldLabel )
 import Type		( usOnce, usMany )
 import Demand		-- Lots of stuff
@@ -134,6 +135,7 @@ data GlobalIdDetails
 				--     Id back to the data con]
 
   | PrimOpId PrimOp		-- The Id for a primitive operator
+  | FCallId ForeignCall		-- The Id for a foreign call
 
   | NotGlobalId			-- Used as a convenient extra return value from globalIdDetails
     
@@ -145,6 +147,7 @@ instance Outputable GlobalIdDetails where
     ppr (DataConId _)     = ptext SLIT("[DataCon]")
     ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]")
     ppr (PrimOpId _)      = ptext SLIT("[PrimOp]")
+    ppr (FCallId _)       = ptext SLIT("[ForeignCall]")
     ppr (RecordSelId _)   = ptext SLIT("[RecSel]")
 \end{code}
 

ghc/compiler/basicTypes/MkId.lhs

@@ -18,7 +18,7 @@ module MkId (
 
 	mkDataConId, mkDataConWrapId,
 	mkRecordSelId, rebuildConArgs,
-	mkPrimOpId, mkCCallOpId,
+	mkPrimOpId, mkFCallId,
 
 	-- And some particular Ids; see below for why they are wired in
 	wiredInIds,
@@ -54,12 +54,10 @@ import TyCon		( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
 import Class		( Class, classTyCon, classTyVars, classSelIds )
 import Var		( Id, TyVar )
 import VarSet		( isEmptyVarSet )
-import Name		( mkWiredInName, mkCCallName, Name )
+import Name		( mkWiredInName, mkFCallName, Name )
 import OccName		( mkVarOcc )
-import PrimOp		( PrimOp(DataToTagOp, CCallOp), 
-			  primOpSig, mkPrimOpIdName,
-			  CCall, pprCCallOp
-			)
+import PrimOp		( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
+import ForeignCall	( ForeignCall )
 import Demand		( wwStrict, wwPrim, mkStrictnessInfo, 
 			  StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
 import DataCon		( DataCon, 
@@ -631,19 +629,18 @@ mkPrimOpId prim_op
 -- details of the ccall, type and all.  This means that the interface 
 -- file reader can reconstruct a suitable Id
 
-mkCCallOpId :: Unique -> CCall -> Type -> Id
-mkCCallOpId uniq ccall ty
+mkFCallId :: Unique -> ForeignCall -> Type -> Id
+mkFCallId uniq fcall ty
   = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
 	-- A CCallOpId should have no free type variables; 
 	-- when doing substitutions won't substitute over it
-    mkGlobalId (PrimOpId prim_op) name ty info
+    mkGlobalId (FCallId fcall) name ty info
   where
-    occ_str = showSDocIface (braces (pprCCallOp ccall <+> ppr ty))
+    occ_str = showSDocIface (braces (ppr fcall <+> ppr ty))
 	-- The "occurrence name" of a ccall is the full info about the
 	-- ccall; it is encoded, but may have embedded spaces etc!
 
-    name    = mkCCallName uniq occ_str
-    prim_op = CCallOp ccall
+    name = mkFCallName uniq occ_str
 
     info = noCafNoTyGenIdInfo
 	   `setCgArity` 	arity

ghc/compiler/basicTypes/Name.lhs

@@ -10,7 +10,7 @@ module Name (
 
 	-- The Name type
 	Name,					-- Abstract
-	mkLocalName, mkSysLocalName, mkCCallName,
+	mkLocalName, mkSysLocalName, mkFCallName,
 	mkIPName,
 	mkGlobalName, mkKnownKeyGlobal, mkWiredInName,
 
@@ -180,10 +180,10 @@ mkSysLocalName :: Unique -> UserFS -> Name
 mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = System, 
 				n_occ = mkVarOcc fs, n_loc = noSrcLoc }
 
-mkCCallName :: Unique -> EncodedString -> Name
+mkFCallName :: Unique -> EncodedString -> Name
 	-- The encoded string completely describes the ccall
-mkCCallName uniq str =  Name { n_uniq = uniq, n_sort = Local, 
-			       n_occ = mkCCallOcc str, n_loc = noSrcLoc }
+mkFCallName uniq str =  Name { n_uniq = uniq, n_sort = Local, 
+			       n_occ = mkFCallOcc str, n_loc = noSrcLoc }
 
 mkIPName :: Unique -> OccName -> Name
 mkIPName uniq occ

ghc/compiler/basicTypes/OccName.lhs

@@ -14,7 +14,7 @@ module OccName (
 	OccName, 	-- Abstract, instance of Outputable
 	pprOccName, 
 
-	mkOccFS, mkSysOcc, mkSysOccFS, mkCCallOcc, mkVarOcc, mkKindOccFS,
+	mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkVarOcc, mkKindOccFS,
 	mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
 	mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
  	mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
@@ -164,12 +164,12 @@ mkSysOccFS :: NameSpace -> EncodedFS -> OccName
 mkSysOccFS occ_sp fs = ASSERT2( alreadyEncodedFS fs, ppr fs )
 		       OccName occ_sp fs
 
-mkCCallOcc :: EncodedString -> OccName
+mkFCallOcc :: EncodedString -> OccName
 -- This version of mkSysOcc doesn't check that the string is already encoded,
 -- because it will be something like "{__ccall f dyn Int# -> Int#}" 
 -- This encodes a lot into something that then parses like an Id.
 -- But then alreadyEncoded complains about the braces!
-mkCCallOcc str = OccName varName (_PK_ str)
+mkFCallOcc str = OccName varName (_PK_ str)
 
 -- Kind constructors get a special function.  Uniquely, they are not encoded,
 -- so that they have names like '*'.  This means that *even in interface files*

ghc/compiler/codeGen/CgCase.lhs

 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgCase.lhs,v 1.51 2000/12/06 13:19:49 simonmar Exp $
+% $Id: CgCase.lhs,v 1.52 2001/05/22 13:43:15 simonpj Exp $
 %
 %********************************************************
 %*							*
@@ -56,7 +56,7 @@ import PrimRep		( getPrimRepSize, retPrimRepSize, PrimRep(..)
 import TyCon		( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep	)
 import Unique           ( Unique, Uniquable(..), newTagUnique )
 import Maybes		( maybeToBool )
-import Util
+import Util		( only )
 import Outputable
 \end{code}
 
@@ -142,30 +142,32 @@ CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it
 doesn't clash with anything else.
 
 \begin{code}
-cgCase (StgPrimApp op args _)
+cgCase (StgOpApp op args _)
        live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt)
   | isEnumerationTyCon tycon
   = getArgAmodes args `thenFC` \ arg_amodes ->
 
-    let tag_amode = case op of 
-			TagToEnumOp -> only arg_amodes
-			_ -> CTemp (newTagUnique (getUnique bndr) 'C') IntRep
-
-	closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
-    in
-
     case op of {
-	TagToEnumOp -> nopC;  -- no code!
+	StgPrimOp TagToEnumOp	-- No code!
+	   -> returnFC (only arg_amodes) ;
+
+	_  -> 		-- Perform the operation
+	      let
+		tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
+	      in
+	      getVolatileRegs live_in_alts			`thenFC` \ vol_regs ->
+ 	      absC (COpStmt [tag_amode] op arg_amodes vol_regs)	`thenC`
+				-- NB: no liveness arg
+	      returnFC tag_amode
+    }						`thenFC` \ tag_amode ->
 
-	_ -> 	-- Perform the operation
-	       getVolatileRegs live_in_alts     `thenFC` \ vol_regs ->
-
- 	       absC (COpStmt [tag_amode] op
-		 arg_amodes -- note: no liveness arg
-		 vol_regs)
-    } 						`thenC`
+    let
+	closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) 
+			       tag_amode PtrRep) 
+		       PtrRep
+    in
 
- 	-- bind the default binder if necessary
+ 	-- Bind the default binder if necessary
 	-- The deadness info is set by StgVarInfo
     (if (isDeadBinder bndr)
 	then nopC
@@ -185,9 +187,9 @@ cgCase (StgPrimApp op args _)
 Special case #2: inline PrimOps.
 
 \begin{code}
-cgCase (StgPrimApp op args _) 
+cgCase (StgOpApp op@(StgPrimOp primop) args _) 
        live_in_whole_case live_in_alts bndr srt alts
-  | not (primOpOutOfLine op)
+  | not (primOpOutOfLine primop)
   =
 	-- Get amodes for the arguments and results
     getArgAmodes args			`thenFC` \ arg_amodes ->

ghc/compiler/codeGen/CgExpr.lhs

 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgExpr.lhs,v 1.42 2001/03/13 12:50:30 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.43 2001/05/22 13:43:15 simonpj Exp $
 %
 %********************************************************
 %*							*
@@ -114,13 +114,13 @@ get in a tail-call position, however, we need to actually perform the
 call, so we treat it as an inline primop.
 
 \begin{code}
-cgExpr (StgPrimApp op@(CCallOp