[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.

3 files changed, 40 insertions, 43 deletions

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index ee5d7d509a..c03df9e2ad 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -6,7 +6,7 @@
 \begin{code}
 module DsCCall 
 	( dsCCall
-	, mkCCall
+	, mkFCall
 	, unboxArg
 	, boxResult
 	, resultWrapper
@@ -20,11 +20,11 @@ import DsMonad
 
 import CoreUtils	( exprType, mkCoerce )
 import Id		( Id, mkWildId, idType )
-import MkId		( mkCCallOpId, realWorldPrimId, mkPrimOpId )
+import MkId		( mkFCallId, realWorldPrimId, mkPrimOpId )
 import Maybes		( maybeToBool )
-import PrimOp		( CCall(..), CCallTarget(..) )
+import ForeignCall	( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) )
 import DataCon		( splitProductType_maybe, dataConSourceArity, dataConWrapId )
-import CallConv
+import ForeignCall	( ForeignCall, CCallTarget(..) )
 import Type		( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
 			  splitTyConApp_maybe, tyVarsOfType, mkForAllTys, 
 			  isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
@@ -86,7 +86,7 @@ follows:
 \begin{code}
 dsCCall :: CLabelString	-- C routine to invoke
 	-> [CoreExpr]	-- Arguments (desugared)
-	-> Bool		-- True <=> might cause Haskell GC
+	-> Safety	-- Safety of the call
 	-> Bool		-- True <=> really a "_casm_"
 	-> Type		-- Type of the result: IO t
 	-> DsM CoreExpr
@@ -96,12 +96,12 @@ dsCCall lbl args may_gc is_asm result_ty
     boxResult [] result_ty	`thenDs` \ (ccall_result_ty, res_wrapper) ->
     getUniqueDs			`thenDs` \ uniq ->
     let
-	the_ccall    = CCall (StaticTarget lbl) is_asm may_gc cCallConv
- 	the_prim_app = mkCCall uniq the_ccall unboxed_args ccall_result_ty
+	the_fcall    = CCall (CCallSpec (StaticTarget lbl) CCallConv may_gc is_asm)
+ 	the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
     in
     returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
 
-mkCCall :: Unique -> CCall 
+mkFCall :: Unique -> ForeignCall 
 	-> [CoreExpr] 	-- Args
 	-> Type 	-- Result type
 	-> CoreExpr
@@ -114,14 +114,14 @@ mkCCall :: Unique -> CCall
 -- Here we build a ccall thus
 --	(ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
 --			a b s x c
-mkCCall uniq the_ccall val_args res_ty
-  = mkApps (mkVarApps (Var the_ccall_id) tyvars) val_args
+mkFCall uniq the_fcall val_args res_ty
+  = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
   where
     arg_tys = map exprType val_args
     body_ty = (mkFunTys arg_tys res_ty)
     tyvars  = varSetElems (tyVarsOfType body_ty)
     ty 	    = mkForAllTys tyvars body_ty
-    the_ccall_id = mkCCallOpId uniq the_ccall ty
+    the_fcall_id = mkFCallId uniq the_fcall ty
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 46ea86c286..06faf73407 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -12,12 +12,11 @@ module DsForeign ( dsForeigns ) where
 
 import CoreSyn
 
-import DsCCall		( dsCCall, mkCCall, boxResult, unboxArg, resultWrapper )
+import DsCCall		( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
 import DsMonad
 
 import HsSyn		( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) )
 import HsDecls		( extNameStatic )
-import CallConv
 import TcHsSyn		( TypecheckedForeignDecl )
 import CoreUtils	( exprType, mkInlineMe )
 import Id		( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
@@ -34,7 +33,11 @@ import Type		( repType, splitTyConApp_maybe,
 			  Type, mkFunTys, mkForAllTys, mkTyConApp,
 			  mkFunTy, splitAppTy, applyTy, funResultTy
 			)
-import PrimOp		( CCall(..), CCallTarget(..), dynamicTarget )
+import ForeignCall	( ForeignCall(..), CCallSpec(..), 
+			  Safety(..), playSafe,
+			  CCallTarget(..), dynamicTarget,
+			  CCallConv(..), ccallConvToInt
+			)
 import TysWiredIn	( unitTy, addrTy, stablePtrTyCon )
 import TysPrim		( addrPrimTy )
 import PrelNames	( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
@@ -99,8 +102,7 @@ dsForeigns mod_name fos = foldlDs combine ([], [], empty, empty) fos
 	  FoLabel -> True
 	  _       -> False
 
-    (FoImport uns)   = imp_exp
-
+    FoImport uns = imp_exp
 \end{code}
 
 Desugaring foreign imports is just the matter of creating a binding
@@ -125,11 +127,11 @@ because it exposes the boxing to the call site.
 \begin{code}
 dsFImport :: Id
 	  -> Type		-- Type of foreign import.
-	  -> Bool		-- True <=> cannot re-enter the Haskell RTS
+	  -> Safety		-- Whether can re-enter the Haskell RTS, do GC etc
 	  -> ExtName
-	  -> CallConv
+	  -> CCallConv
 	  -> DsM [Binding]
-dsFImport fn_id ty unsafe ext_name cconv 
+dsFImport fn_id ty safety ext_name cconv 
   = let
 	(tvs, fun_ty)        = splitForAllTys ty
 	(arg_tys, io_res_ty) = splitFunTys fun_ty
@@ -140,11 +142,11 @@ dsFImport fn_id ty unsafe ext_name cconv
     let
 	work_arg_ids  = [v | Var v <- val_args]	-- All guaranteed to be vars
 
-	-- these are the ids we pass to boxResult, which are used to decide
+	-- These are the ids we pass to boxResult, which are used to decide
 	-- whether to touch# an argument after the call (used to keep
 	-- ForeignObj#s live across a 'safe' foreign import).
-	maybe_arg_ids | unsafe    = []
-		      | otherwise = work_arg_ids
+	maybe_arg_ids | playSafe safety = work_arg_ids
+		      | otherwise	= []
     in
     boxResult maybe_arg_ids io_res_ty  		`thenDs` \ (ccall_result_ty, res_wrapper) ->
 
@@ -157,8 +159,8 @@ dsFImport fn_id ty unsafe ext_name cconv
 
 	-- Build the worker
 	worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
-	the_ccall     = CCall lbl False (not unsafe) cconv
- 	the_ccall_app = mkCCall ccall_uniq the_ccall val_args ccall_result_ty
+	the_ccall     = CCall (CCallSpec lbl cconv safety False)
+ 	the_ccall_app = mkFCall ccall_uniq the_ccall val_args ccall_result_ty
 	work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
 	work_id       = mkSysLocal SLIT("$wccall") work_uniq worker_ty
 
@@ -198,7 +200,7 @@ dsFExport :: Id
 	  -> Type		-- Type of foreign export.
 	  -> Module
 	  -> ExtName
-	  -> CallConv
+	  -> CCallConv
 	  -> Bool		-- True => invoke IO action that's hanging off 
 				-- the first argument's stable pointer
 	  -> DsM ( Id		-- The foreign-exported Id
@@ -329,7 +331,7 @@ dsFExportDynamic :: Id
 		 -> Type		-- Type of foreign export.
 		 -> Module
 		 -> ExtName
-		 -> CallConv
+		 -> CCallConv
 		 -> DsM (Id, [Binding], SDoc, SDoc)
 dsFExportDynamic i ty mod_name ext_name cconv =
      newSysLocalDs ty					 `thenDs` \ fe_id ->
@@ -363,7 +365,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
 	to be entered using an external calling convention
 	(stdcall, ccall).
        -}
-      adj_args      = [ mkIntLitInt (callConvToInt cconv)
+      adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
 		      , Var stbl_value
 		      , mkLit (MachLabel (_PK_ fe_nm))
 		      ]
@@ -371,13 +373,13 @@ dsFExportDynamic i ty mod_name ext_name cconv =
 	-- (probably in the RTS.) 
       adjustor	    = SLIT("createAdjustor")
      in
-     dsCCall adjustor adj_args False False io_res_ty `thenDs` \ ccall_adj ->
+     dsCCall adjustor adj_args PlayRisky False io_res_ty	`thenDs` \ ccall_adj ->
+	-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
      let ccall_adj_ty = exprType ccall_adj
          ccall_io_adj = mkLams [stbl_value]		     $
 			Note (Coerce io_res_ty ccall_adj_ty)
 			     ccall_adj
-     in
-     let io_app = mkLams tvs	 $
+         io_app = mkLams tvs	 $
 		  mkLams [cback] $
 		  stbl_app ccall_io_adj res_ty
 	 fed = (i `setInlinePragma` neverInlinePrag, io_app)
@@ -389,14 +391,9 @@ dsFExportDynamic i ty mod_name ext_name cconv =
  where
   (tvs,sans_foralls)		   = splitForAllTys ty
   ([arg_ty], io_res_ty)		   = splitFunTys sans_foralls
-
   Just (ioTyCon, [res_ty])	   = splitTyConApp_maybe io_res_ty
-
   export_ty			   = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
 
-  ioAddrTy :: Type	-- IO Addr
-  ioAddrTy = mkTyConApp ioTyCon [addrTy]
-
 toCName :: Id -> String
 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
 \end{code}
@@ -417,7 +414,7 @@ fexportEntry :: String
 	     -> Id 
 	     -> [Type] 
 	     -> Type 
-	     -> CallConv 
+	     -> CCallConv 
 	     -> Bool
 	     -> (SDoc, SDoc)
 fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
@@ -456,9 +453,9 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
   cResType | res_ty_is_unit = text "void"
 	   | otherwise	    = showStgType res_ty
 
-  pprCconv
-   | cc == cCallConv = empty
-   | otherwise	     = pprCallConv cc
+  pprCconv = case cc of
+		CCallConv   -> empty
+		StdCallConv -> ppr cc
      
   declareResult  = text "HaskellObj ret;"
 
@@ -479,9 +476,10 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
    needed by the Adjustor.c code to get the stack cleanup right.
   -}
   (proto_args, real_args)
-    | cc == cCallConv && isDyn = ( text "a0" : text "a_" : mkCArgNames 1 (tail args)
-				, head args : addrTy : tail args)
-    | otherwise = (mkCArgNames 0 args, args)
+    = case cc of
+	CCallConv | isDyn -> ( text "a0" : text "a_" : mkCArgNames 1 (tail args)
+			     , head args : addrTy : tail args)
+        other		  -> (mkCArgNames 0 args, args)
 
 mkCArgNames :: Int -> [a] -> [SDoc]
 mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..] 
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 717faad02c..3c783ed2d6 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -38,7 +38,6 @@ import Type             ( Type )
 import UniqSupply	( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
 			  UniqSM, UniqSupply )
 import Unique		( Unique )
-import Util		( zipWithEqual )
 import Name		( Name )
 import CmdLineOpts	( DynFlags )