[project @ 2000-04-07 13:45:46 by simonpj]

* Fix 'foreign export' and 'foreign export dynamic' so
  that we can export pure (non-IO) functions as well as IO-ish ones

  NB: There's a change to PrelIOBase, so you'll
      need to recompile the Prelude

* Add Type.mkDictTys and call it in various places.

ghc/compiler/basicTypes/DataCon.lhs

@@ -31,7 +31,7 @@ import CmdLineOpts	( opt_DictsStrict )
 import TysPrim
 import Type		( Type, ThetaType, TauType, ClassContext,
 			  mkForAllTys, mkFunTys, mkTyConApp, 
-			  mkTyVarTys, mkDictTy,
+			  mkTyVarTys, mkDictTys,
 			  splitAlgTyConApp_maybe, classesToPreds
 			)
 import TyCon		( TyCon, tyConDataCons, isDataTyCon, isProductTyCon,
@@ -262,7 +262,7 @@ mkDataCon name arg_stricts fields
 
     (real_arg_stricts, strict_arg_tyss) 
 	= unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys)
-    rep_arg_tys = [mkDictTy cls tys | (cls,tys) <- ex_theta] ++ concat strict_arg_tyss
+    rep_arg_tys = mkDictTys ex_theta ++ concat strict_arg_tyss
 	
     ex_dict_stricts = map mk_dict_strict_mark ex_theta
 	-- Add a strictness flag for the existential dictionary arguments

ghc/compiler/basicTypes/MkId.lhs

@@ -40,7 +40,7 @@ import TysWiredIn	( boolTy, charTy, mkListTy )
 import PrelMods		( pREL_ERR, pREL_GHC )
 import PrelRules	( primOpRule )
 import Rules		( addRule )
-import Type		( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
+import Type		( Type, ClassContext, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys,
 			  mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
 			  isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes,
 			  splitSigmaTy, splitFunTy_maybe, 
@@ -286,8 +286,8 @@ mkDataConWrapId data_con
     (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
     all_tyvars   = tyvars ++ ex_tyvars
 
-    dict_tys     = [mkDictTy clas tys | (clas,tys) <- theta]
-    ex_dict_tys  = [mkDictTy clas tys | (clas,tys) <- ex_theta]
+    dict_tys     = mkDictTys theta
+    ex_dict_tys  = mkDictTys ex_theta
     all_arg_tys  = dict_tys ++ ex_dict_tys ++ orig_arg_tys
     result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
 

ghc/compiler/basicTypes/Unique.lhs

@@ -154,6 +154,7 @@ module Unique (
 	recConErrorIdKey,
 	recSelErrIdKey,
 	recUpdErrorIdKey,
+	returnIOIdKey,
 	returnMClassOpKey,
 	runSTRepIdKey,
 	showClassKey,
@@ -635,9 +636,10 @@ concatIdKey		      = mkPreludeMiscIdUnique 33
 filterIdKey		      = mkPreludeMiscIdUnique 34
 zipIdKey		      = mkPreludeMiscIdUnique 35
 bindIOIdKey		      = mkPreludeMiscIdUnique 36
-deRefStablePtrIdKey	      = mkPreludeMiscIdUnique 37
-makeStablePtrIdKey	      = mkPreludeMiscIdUnique 38
-getTagIdKey		      = mkPreludeMiscIdUnique 39
+returnIOIdKey		      = mkPreludeMiscIdUnique 37
+deRefStablePtrIdKey	      = mkPreludeMiscIdUnique 38
+makeStablePtrIdKey	      = mkPreludeMiscIdUnique 39
+getTagIdKey		      = mkPreludeMiscIdUnique 40
 \end{code}
 
 Certain class operations from Prelude classes.  They get their own

ghc/compiler/deSugar/DsForeign.lhs

@@ -20,7 +20,7 @@ import HsSyn		( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) )
 import HsDecls		( extNameStatic )
 import CallConv
 import TcHsSyn		( TypecheckedForeignDecl )
-import CoreUtils	( exprType, mkInlineMe, bindNonRec )
+import CoreUtils	( exprType, mkInlineMe )
 import DataCon		( DataCon, dataConWrapId )
 import Id		( Id, idType, idName, mkWildId, mkVanillaId )
 import MkId		( mkWorkerId )
@@ -30,16 +30,16 @@ import Name		( mkGlobalName, nameModule, nameOccName, getOccString,
 			  mkForeignExportOcc, isLocalName,
 			  NamedThing(..), Provenance(..), ExportFlag(..)
 			)
-import PrelInfo		( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME )
+import PrelInfo		( deRefStablePtr_NAME, returnIO_NAME, bindIO_NAME, makeStablePtr_NAME )
 import Type		( unUsgTy,
 			  splitTyConApp_maybe, splitFunTys, splitForAllTys,
 			  Type, mkFunTys, mkForAllTys, mkTyConApp,
-			  mkTyVarTy, mkFunTy, splitAppTy
+			  mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy
 			)
 import PrimOp		( PrimOp(..), CCall(..), CCallTarget(..) )
 import Var		( TyVar )
 import TysPrim		( realWorldStatePrimTy, addrPrimTy )
-import TysWiredIn	( unitTyCon, addrTy, stablePtrTyCon,
+import TysWiredIn	( unitTy, addrTy, stablePtrTyCon,
 			  unboxedTupleCon, addrDataCon
 			)
 import Unique
@@ -193,22 +193,30 @@ dsFExport :: Id
 		 , SDoc
 		 , SDoc
 		 )
-dsFExport i ty mod_name ext_name cconv isDyn =
-     getUniqueDs					`thenDs` \ uniq ->
-     getSrcLocDs					`thenDs` \ src_loc ->
-     let
-	f_helper_glob = mkVanillaId helper_name helper_ty
-		      where
-			name	            = idName i
-			mod	
-			 | isLocalName name = mod_name
-			 | otherwise        = nameModule name
-
-			occ	            = mkForeignExportOcc (nameOccName name)
-			prov	            = LocalDef src_loc Exported
-			helper_name         = mkGlobalName uniq mod occ prov
-     in
-     newSysLocalsDs fe_arg_tys				`thenDs` \ fe_args ->
+dsFExport i ty mod_name ext_name cconv isDyn
+  = 	-- BUILD THE returnIO WRAPPER, if necessary
+	-- Look at the result type of the exported function, orig_res_ty
+	-- If it's IO t, return		(\x.x,	        IO t, t)
+	-- If it's plain t, return	(\x.returnIO x, IO t, t)
+     (case splitTyConApp_maybe orig_res_ty of
+	Just (ioTyCon, [res_ty])
+	      -> ASSERT( getUnique ioTyCon == ioTyConKey )
+			-- The function already returns IO t
+		 returnDs (\body -> body, orig_res_ty, res_ty)
+
+	other -> 	-- The function returns t, so wrap the call in returnIO
+		 dsLookupGlobalValue returnIO_NAME	`thenDs` \ retIOId ->
+	         returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body],
+		           funResultTy (applyTy (idType retIOId) orig_res_ty), 
+				-- We don't have ioTyCon conveniently to hand
+			   orig_res_ty)
+
+     )		`thenDs` \ (return_io_wrapper, 	-- Either identity or returnIO
+			    io_res_ty, 		-- IO t
+			    res_ty) ->		-- t
+
+
+	-- BUILD THE deRefStablePtr WRAPPER, if necessary
      (if isDyn then 
         newSysLocalDs stbl_ptr_ty			`thenDs` \ stbl_ptr ->
 	newSysLocalDs stbl_ptr_to_ty			`thenDs` \ stbl_value ->
@@ -217,19 +225,13 @@ dsFExport i ty mod_name ext_name cconv isDyn =
 	 the_deref_app = mkApps (Var deRefStablePtrId)
 				[ Type stbl_ptr_to_ty, Var stbl_ptr ]
         in
-	newSysLocalDs (exprType the_deref_app)	 `thenDs` \ x_deref_app ->
         dsLookupGlobalValue bindIO_NAME			 `thenDs` \ bindIOId ->
-	newSysLocalDs (mkFunTy stbl_ptr_to_ty 
-			       (mkTyConApp ioTyCon [res_ty])) `thenDs` \ x_cont ->
 	let
-	 stbl_app      = \ cont -> 
-		bindNonRec x_cont   (mkLams [stbl_value] cont) $
-		bindNonRec x_deref_app the_deref_app  
-			   (mkApps (Var bindIOId)
-				     [ Type stbl_ptr_to_ty
-				     , Type res_ty
-				     , Var x_deref_app
-				     , Var x_cont])
+	 stbl_app cont = mkApps (Var bindIOId)
+				[ Type stbl_ptr_to_ty
+				, Type res_ty
+				, the_deref_app
+				, mkLams [stbl_value] cont]
         in
 	returnDs (stbl_value, stbl_app, stbl_ptr)
       else
@@ -237,67 +239,56 @@ dsFExport i ty mod_name ext_name cconv isDyn =
 	          \ body -> body,
 		  panic "stbl_ptr"  -- should never be touched.
 		  ))			`thenDs` \ (i, getFun_wrapper, stbl_ptr) ->
-     let
-      wrapper_args
-       | isDyn      = stbl_ptr:fe_args
-       | otherwise  = fe_args
 
-      wrapper_arg_tys
-       | isDyn      = stbl_ptr_ty:helper_arg_tys
-       | otherwise  = helper_arg_tys
 
-      the_app  = 
-         getFun_wrapper $
- 	 mkApps (Var i) (map (Type . mkTyVarTy) tvs ++ map Var fe_args)
-     in
+	-- BUILD THE HELPER
      getModuleDs			`thenDs` \ mod -> 
      getUniqueDs			`thenDs` \ uniq ->
+     getSrcLocDs			`thenDs` \ src_loc ->
+     newSysLocalsDs fe_arg_tys		`thenDs` \ fe_args ->
      let
-      the_body = mkLams (tvs ++ wrapper_args) the_app
-      c_nm     = extNameStatic ext_name
+        wrapper_args | isDyn      = stbl_ptr:fe_args
+		     | otherwise  = fe_args
 
-      (h_stub, c_stub) = fexportEntry (moduleUserString mod)
+        wrapper_arg_tys | isDyn      = stbl_ptr_ty:fe_arg_tys
+		        | otherwise  = fe_arg_tys
+
+	helper_ty =  mkForAllTys tvs $
+		     mkFunTys wrapper_arg_tys io_res_ty
+
+	f_helper_glob = mkVanillaId helper_name helper_ty
+		      where
+			name	            = idName i
+			mod	
+			 | isLocalName name = mod_name
+			 | otherwise        = nameModule name
+
+			occ	            = mkForeignExportOcc (nameOccName name)
+			prov	            = LocalDef src_loc Exported
+			helper_name         = mkGlobalName uniq mod occ prov
+
+      	the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args)))
+      	the_body = mkLams (tvs ++ wrapper_args) the_app
+      	c_nm     = extNameStatic ext_name
+  
+      	(h_stub, c_stub) = fexportEntry (moduleUserString mod)
       				      c_nm f_helper_glob
-                                      wrapper_arg_tys the_result_ty cconv isDyn
+                                      wrapper_arg_tys res_ty cconv isDyn
      in
      returnDs (NonRec f_helper_glob the_body, h_stub, c_stub)
 
   where
-
    (tvs,sans_foralls)			= splitForAllTys ty
-   (fe_arg_tys', io_res)	        = splitFunTys sans_foralls
-
-
-   Just (ioTyCon, [res_ty])	        = splitTyConApp_maybe io_res
+   (fe_arg_tys', orig_res_ty)	        = splitFunTys sans_foralls
 
    (_, stbl_ptr_ty')			= splitForAllTys stbl_ptr_ty
    (_, stbl_ptr_to_ty)			= splitAppTy stbl_ptr_ty'
 
-   fe_arg_tys
-     | isDyn	    = tail fe_arg_tys'
-     | otherwise    = fe_arg_tys'
-
-   (stbl_ptr_ty, helper_arg_tys) = 
-     case fe_arg_tys' of
-       (x:xs) | isDyn -> (x,xs)
-       ls	      -> (error "stbl_ptr_ty", ls)
-
-   helper_ty      =  
-	mkForAllTys tvs $
-	mkFunTys arg_tys io_res
-        where
-	  arg_tys
-	   | isDyn	= stbl_ptr_ty : helper_arg_tys
-	   | otherwise  = helper_arg_tys
-
-   the_result_ty =
-     case splitTyConApp_maybe io_res of
-       Just (_,[res_ty]) ->
-         case splitTyConApp_maybe res_ty of
-	   Just (tc,_) | getUnique tc /= getUnique unitTyCon -> Just res_ty
-	   _						     -> Nothing
-       _		 -> Nothing
-   
+   fe_arg_tys | isDyn	  = tail fe_arg_tys'
+	      | otherwise = fe_arg_tys'
+
+   stbl_ptr_ty | isDyn     = head fe_arg_tys'
+	       | otherwise = error "stbl_ptr_ty"
 \end{code}
 
 @foreign export dynamic@ lets you dress up Haskell IO actions
@@ -345,25 +336,21 @@ dsFExportDynamic i ty mod_name ext_name cconv =
      in
      dsFExport  i export_ty mod_name fe_ext_name cconv True
      `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) ->
-     newSysLocalDs arg_ty			            `thenDs` \ cback ->
-     dsLookupGlobalValue makeStablePtr_NAME	   `thenDs` \ makeStablePtrId ->
+     newSysLocalDs arg_ty			`thenDs` \ cback ->
+     dsLookupGlobalValue makeStablePtr_NAME	`thenDs` \ makeStablePtrId ->
      let
 	mk_stbl_ptr_app    = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ]
-	mk_stbl_ptr_app_ty = exprType mk_stbl_ptr_app
      in
-     newSysLocalDs mk_stbl_ptr_app_ty			`thenDs` \ x_mk_stbl_ptr_app ->
      dsLookupGlobalValue bindIO_NAME		        `thenDs` \ bindIOId ->
      newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
      let
-      stbl_app      = \ x_cont cont ret_ty -> 
-	bindNonRec x_cont	     cont	     $
-	bindNonRec x_mk_stbl_ptr_app mk_stbl_ptr_app $
-		   (mkApps (Var bindIOId)
-			   [ Type (mkTyConApp stablePtrTyCon [arg_ty])
-			   , Type ret_ty
-			   , Var x_mk_stbl_ptr_app
-			   , Var x_cont
-			   ])
+      stbl_app cont ret_ty 
+	= mkApps (Var bindIOId)
+		 [ Type (mkTyConApp stablePtrTyCon [arg_ty])
+		 , Type ret_ty
+		 , mk_stbl_ptr_app
+		 , cont
+		 ]
 
        {-
         The arguments to the external function which will
@@ -380,34 +367,31 @@ dsFExportDynamic i ty mod_name ext_name cconv =
 	-- (probably in the RTS.) 
       adjustor	    = SLIT("createAdjustor")
      in
-     dsCCall adjustor adj_args False False addrTy `thenDs` \ ccall_adj ->
+     dsCCall adjustor adj_args False False ioAddrTy `thenDs` \ ccall_adj ->
      let ccall_adj_ty = exprType ccall_adj
+         ccall_io_adj = mkLams [stbl_value]		     $
+			Note (Coerce io_res_ty (unUsgTy ccall_adj_ty))
+			     ccall_adj
      in
-     newSysLocalDs ccall_adj_ty			  `thenDs` \ x_ccall_adj ->
-     let ccall_io_adj = 
-	    mkLams [stbl_value]		     $
-	    bindNonRec x_ccall_adj ccall_adj $
-	    Note (Coerce (mkTyConApp ioTyCon [res_ty]) (unUsgTy ccall_adj_ty))
-		 (Var x_ccall_adj)
-     in
-     newSysLocalDs (exprType ccall_io_adj)	  `thenDs` \ x_ccall_io_adj ->
      let io_app = mkLams tvs	 $
 		  mkLams [cback] $
-		  stbl_app x_ccall_io_adj ccall_io_adj addrTy
+		  stbl_app ccall_io_adj addrTy
      in
      returnDs (NonRec i io_app, fe, h_code, c_code)
 
  where
   (tvs,sans_foralls)		   = splitForAllTys ty
-  ([arg_ty], io_res)		   = splitFunTys sans_foralls
+  ([arg_ty], io_res_ty)		   = splitFunTys sans_foralls
 
-  Just (ioTyCon, [res_ty])	   = splitTyConApp_maybe io_res
+  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}
 
 %*
@@ -425,11 +409,11 @@ fexportEntry :: String
 	     -> FAST_STRING
 	     -> Id 
 	     -> [Type] 
-	     -> Maybe Type 
+	     -> Type 
 	     -> CallConv 
 	     -> Bool
 	     -> (SDoc, SDoc)
-fexportEntry mod_nm c_nm helper args res cc isDyn = (header_bits, c_bits)
+fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
  where
    -- name of the (Haskell) helper function generated by the desugarer.
   h_nm	    = ppr helper <> text "_closure"
@@ -449,7 +433,9 @@ fexportEntry mod_nm c_nm helper args res cc isDyn = (header_bits, c_bits)
 	  -- create the application + perform it.
      ,   text "rc=rts_evalIO" <> 
                   parens (foldl appArg (text "(StgClosure*)&" <> h_nm) (zip args c_args) <> comma <> text "&ret") <> semi
-     ,   returnResult
+     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (text mod_nm <> char '.' <> ptext c_nm) 
+						<> comma <> text "rc") <> semi
+     ,   text "return" <> return_what <> semi
      , rbrace
      ]
 
@@ -458,10 +444,10 @@ fexportEntry mod_nm c_nm helper args res cc isDyn = (header_bits, c_bits)
 
   cParamTypes  = map showStgType real_args
 
-  cResType = 
-   case res of
-     Nothing -> text "void"
-     Just t  -> showStgType t
+  res_ty_is_unit = res_ty == unitTy
+
+  cResType | res_ty_is_unit = text "void"
+	   | otherwise	    = showStgType res_ty
 
   pprCconv
    | cc == cCallConv = empty
@@ -473,17 +459,8 @@ fexportEntry mod_nm c_nm helper args res cc isDyn = (header_bits, c_bits)
 
   mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
 
-  returnResult = 
-    text "rts_checkSchedStatus" <> 
-    parens (doubleQuotes (text mod_nm <> char '.' <> ptext c_nm) <> comma <> text "rc") <> semi $$
-    (case res of
-      Nothing -> text "return"
-      Just _  -> text "return" <> parens (res_name)) <> semi
-
-  res_name = 
-    case res of
-      Nothing -> empty
-      Just t  -> unpackHObj t <> parens (text "ret")
+  return_what | res_ty_is_unit = empty
+	      | otherwise      = parens (unpackHObj res_ty <> parens (text "ret"))
 
   c_args = mkCArgNames 0 args
 

ghc/compiler/prelude/PrelInfo.lhs

@@ -21,7 +21,7 @@ module PrelInfo (
 	-- Random other things
 	main_NAME, ioTyCon_NAME,
 	deRefStablePtr_NAME, makeStablePtr_NAME,
-	bindIO_NAME,
+	bindIO_NAME, returnIO_NAME,
 
 	maybeCharLikeCon, maybeIntLikeCon,
 	needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys, 
@@ -203,6 +203,7 @@ main_NAME	  = mkKnownKeyGlobal (main_RDR,	         mainKey)
 
  -- Operations needed when compiling FFI decls
 bindIO_NAME	    = mkKnownKeyGlobal (bindIO_RDR,	    bindIOIdKey)
+returnIO_NAME	    = mkKnownKeyGlobal (returnIO_RDR,	    returnIOIdKey)
 deRefStablePtr_NAME = mkKnownKeyGlobal (deRefStablePtr_RDR, deRefStablePtrIdKey)
 makeStablePtr_NAME  = mkKnownKeyGlobal (makeStablePtr_RDR,  makeStablePtrIdKey)
 
@@ -266,6 +267,7 @@ knownKeyNames
     , (deRefStablePtr_RDR,	deRefStablePtrIdKey)
     , (makeStablePtr_RDR,	makeStablePtrIdKey)
     , (bindIO_RDR,		bindIOIdKey)
+    , (returnIO_RDR,		returnIOIdKey)
 
     , (map_RDR,			mapIdKey)
     , (append_RDR,		appendIdKey)
@@ -320,6 +322,7 @@ intTyCon_RDR		= nameRdrName (getName intTyCon)
 ioTyCon_RDR		= tcQual   pREL_IO_BASE_Name SLIT("IO")
 ioDataCon_RDR  	   	= dataQual pREL_IO_BASE_Name SLIT("IO")
 bindIO_RDR	        = varQual  pREL_IO_BASE_Name SLIT("bindIO")
+returnIO_RDR	        = varQual  pREL_IO_BASE_Name SLIT("returnIO")
 
 orderingTyCon_RDR	= tcQual   pREL_BASE_Name SLIT("Ordering")
 

ghc/compiler/rename/RnIfaces.lhs

@@ -123,8 +123,7 @@ loadInterface doc_str mod_name from
 	mod_map_result ->
 
 	-- READ THE MODULE IN
-   findAndReadIface doc_str mod_name from below_me
-   `thenRn` \ (hi_boot_read, read_result) ->
+   findAndReadIface doc_str mod_name from below_me   `thenRn` \ (hi_boot_read, read_result) ->
    case read_result of {
 	Nothing -> 	-- Not found, so add an empty export env to the Ifaces map
 			-- so that we don't look again
@@ -1049,7 +1048,9 @@ cannaeReadFile file err
 	  text (show err)]
 
 getDeclErr name
-  = ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name)
+  = vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name),
+	  ptext SLIT("from module") <+> quotes (ppr (nameModule name))
+	 ]
 
 getDeclWarn name loc
   = sep [ptext SLIT("Failed to find (optional) interface decl for") <+> quotes (ppr name),

ghc/compiler/rename/RnMonad.lhs

@@ -760,5 +760,4 @@ lookupModuleRn x =
   case lookupFM himap x of
     Nothing    -> returnRn (mkVanillaModule x)
     Just (_,x) -> returnRn x
-
 \end{code}

ghc/compiler/rename/RnSource.lhs

@@ -43,7 +43,7 @@ import OccName		( mkDefaultMethodOcc )
 import BasicTypes	( TopLevelFlag(..) )
 import FiniteMap	( elemFM )
 import PrelInfo		( derivableClassKeys,
-			  deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME
+			  deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME, returnIO_NAME
 			)
 import Bag		( bagToList )
 import List		( partition, nub )
@@ -358,7 +358,7 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 		FoLabel    		-> emptyFVs
 		FoExport   | isDyn	-> mkNameSet [makeStablePtr_NAME,
 						      deRefStablePtr_NAME,
-						      bindIO_NAME]
+						      bindIO_NAME, returnIO_NAME]
 			   | otherwise  -> mkNameSet [name']
 		_ -> emptyFVs
     in

ghc/compiler/simplCore/SimplCore.lhs

@@ -59,9 +59,7 @@ import StrictAnal	( saBinds )
 import WorkWrap	        ( wwTopBinds )
 import CprAnalyse       ( cprAnalyse )
 
-import Unique		( Unique, Uniquable(..),
-			  ratioTyConKey
-		        )
+import Unique		( Unique, Uniquable(..) )
 import UniqSupply	( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
 import Util		( mapAccumL )
 import SrcLoc		( noSrcLoc )

ghc/compiler/stranal/SaAbsInt.lhs

@@ -571,7 +571,8 @@ absApply AbsAnal (AbsApproxFun (d:ds) val) arg
 		other -> AbsApproxFun ds val
 
 #ifdef DEBUG
-absApply anal f@(AbsProd _)       arg = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
+absApply anal f@(AbsProd _) arg 
+  = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
 #endif
 \end{code}
 

ghc/compiler/typecheck/Inst.lhs

@@ -476,8 +476,8 @@ instToId :: Inst -> TcId
 instToId inst = instToIdBndr inst
 
 instToIdBndr :: Inst -> TcId
-instToIdBndr (Dict u (Class clas ty) (_,loc,_))
-  = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
+instToIdBndr (Dict u (Class clas tys) (_,loc,_))
+  = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas tys) loc
 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
   = ipToId n ty loc
 

ghc/compiler/typecheck/TcClassDcl.lhs

@@ -54,7 +54,7 @@ import Name		( Name, nameOccName, isLocallyDefined, NamedThing(..) )
 import NameSet		( emptyNameSet )
 import Outputable
 import Type		( Type, ThetaType, ClassContext,
-			  mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
+			  mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkDictTys,
 			  mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds,
 			  boxedTypeKind, mkArrowKind
 			)
@@ -241,7 +241,7 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names
 
     let
        sc_theta' = classesOfPreds sc_theta
-       sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta']
+       sc_tys = mkDictTys sc_theta'
        sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
     in
 	-- Done

ghc/compiler/typecheck/TcForeign.lhs

@@ -177,53 +177,53 @@ checkForeignImport is_dynamic is_safe ty args res
      (x:xs) ->
         check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
         mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs	`thenTc_`
-	checkForeignRes (isFFIResultTy) res
+	checkForeignRes True {-NonIO ok-} isFFIResultTy res
  | otherwise =
      mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args     `thenTc_`
-     checkForeignRes (isFFIResultTy) res
+     checkForeignRes True {-NonIO ok-} isFFIResultTy res
 
 checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()
 checkForeignExport is_dynamic ty args res
  | is_dynamic = 
     -- * the first (and only!) arg has got to be a function type
-    -- * result type is an Addr
+    --   and it must return IO t
+    -- * result type is an Addr or IO Addr
    case args of
      [arg]  ->
 	case splitFunTys arg of
 	   (arg_tys, res_ty) -> 
-		mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
-		checkForeignRes (isFFIResultTy) res_ty		`thenTc_`
-		checkForeignRes (isAddrTy) res
+		mapTc (checkForeignArg isFFIExternalTy) arg_tys		`thenTc_`
+		checkForeignRes True  {-NonIO ok-} isFFIResultTy res_ty	`thenTc_`
+		checkForeignRes False {-Must be IO-} isAddrTy	   res
      _      -> check False (illegalForeignTyErr True{-Arg-} ty)
  | otherwise =
      mapTc (checkForeignArg isFFIExternalTy) args  	        `thenTc_`
-     checkForeignRes (isFFIResultTy) res
+     checkForeignRes True {-NonIO ok-} isFFIResultTy res
  
-check :: Bool -> Message -> TcM s ()
-check True _	   = returnTc ()
-check _    the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
-
 checkForeignArg :: (Type -> Bool) -> Type -> TcM s ()
 checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
 
 -- Check that the type has the form 
 --    (IO t) or (t) , and that t satisfies the given predicate.
 --
-checkForeignRes :: (Type -> Bool) -> Type -> TcM s ()
-checkForeignRes pred_res_ty ty =
+checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM s ()
+checkForeignRes non_io_result_ok pred_res_ty ty =
  case (splitTyConApp_maybe ty) of
     Just (io, [res_ty]) 
         | (getUnique io) == ioTyConKey && pred_res_ty res_ty 
 	-> returnTc ()
     _   
-        | pred_res_ty ty -> returnTc ()
-	| otherwise      -> check False (illegalForeignTyErr False{-Res-} ty)
-
+        -> check (non_io_result_ok && pred_res_ty ty) 
+		 (illegalForeignTyErr False{-Res-} ty)
 \end{code}
 
 Warnings
 
 \begin{code}
+check :: Bool -> Message -> TcM s ()
+check True _	   = returnTc ()
+check _    the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
+
 illegalForeignTyErr isArg ty
   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
 	 4 (hsep [ppr ty])
@@ -235,5 +235,4 @@ illegalForeignTyErr isArg ty
 foreignDeclCtxt fo = 
  hang (ptext SLIT("When checking declaration:"))
   4   (ppr fo)
-
 \end{code}

ghc/compiler/typecheck/TcTyClsDecls.lhs

@@ -29,7 +29,7 @@ import TcTyDecls	( tcTyDecl, kcTyDecl )
 import TcMonoType	( kcHsTyVar )
 import TcType		( TcKind, newKindVar, newKindVars, kindToTcKind, zonkTcKindToKind )
 
-import Type		( mkArrowKind, boxedTypeKind, mkDictTy )
+import Type		( mkArrowKind, boxedTypeKind )
 
 import Class		( Class )
 import Var		( TyVar, tyVarKind )

ghc/compiler/types/Type.lhs

@@ -34,7 +34,7 @@ module Type (
 
 	mkTyConApp, mkTyConTy, splitTyConApp_maybe,
 	splitAlgTyConApp_maybe, splitAlgTyConApp, 
-	mkDictTy, mkPredTy, splitPredTy_maybe, splitDictTy_maybe, isDictTy,
+	mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe, splitDictTy_maybe, isDictTy,
 
 	mkSynTy, isSynTy, deNoteType, 
 
@@ -335,23 +335,13 @@ tell from the type constructor whether it's a dictionary or not.
 mkDictTy :: Class -> [Type] -> Type
 mkDictTy clas tys = TyConApp (classTyCon clas) tys
 
+mkDictTys :: ClassContext -> [Type]
+mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt]
+
 mkPredTy :: PredType -> Type
 mkPredTy (Class clas tys) = TyConApp (classTyCon clas) tys
 mkPredTy (IParam n ty)    = NoteTy (IPNote n) ty
 
-{-
-splitDictTy_maybe :: Type -> Maybe (Class, [Type])
-splitDictTy_maybe (TyConApp tc tys)