[project @ 1998-11-13 19:35:42 by sof]

Relax restriction that 'foreign import' has got to be an IO action

ghc/compiler/deSugar/DsCCall.lhs

@@ -10,6 +10,7 @@ module DsCCall
 	,  getIoOkDataCon
 	,  unboxArg
 	,  boxResult
+	,  wrapUnboxedValue
 	,  can'tSeeDataConsPanic
 	) where
 
@@ -205,10 +206,8 @@ boxResult ioOkDataCon result_ty
     isUnpointedType the_prim_result_ty				-- of primitive type
   =
     newSysLocalDs realWorldStatePrimTy		`thenDs` \ prim_state_id ->
-    newSysLocalDs the_prim_result_ty 		`thenDs` \ prim_result_id ->
-
-    mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
-
+    wrapUnboxedValue result_ty			`thenDs` \ (state_and_prim_datacon,
+							    state_and_prim_ty, prim_result_id, the_result) ->
     mkConDs ioOkDataCon
 	    [TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
 							`thenDs` \ the_pair ->
@@ -239,7 +238,6 @@ boxResult ioOkDataCon result_ty
 
   | otherwise
   = pprPanic "boxResult: " (ppr result_ty)
-
   where
     maybe_data_type 			   = splitAlgTyConApp_maybe result_ty
     Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
@@ -248,7 +246,43 @@ boxResult ioOkDataCon result_ty
     data_con_arg_tys		           = dataConArgTys the_data_con tycon_arg_tys
     (the_prim_result_ty : other_args_tys)  = data_con_arg_tys
 
-    (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
+--    (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
+
+-- wrap up an unboxed value.
+wrapUnboxedValue :: Type -> DsM (Id, Type, Id, CoreExpr)
+wrapUnboxedValue ty
+  | null data_cons
+      -- oops! can't see the data constructors
+  = can'tSeeDataConsPanic "result" ty
+    -- Data types with a single constructor, which has a single, primitive-typed arg
+  | (maybeToBool maybe_data_type) &&				-- Data type
+    (null other_data_cons) &&					-- Just one constr
+    not (null data_con_arg_tys) && null other_args_tys	&& 	-- Just one arg
+    isUnpointedType the_prim_result_ty				-- of primitive type
+  =
+    newSysLocalDs the_prim_result_ty 		         `thenDs` \ prim_result_id ->
+    mkConDs the_data_con (map TyArg tycon_arg_tys ++ 
+                          [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
+    returnDs (state_and_prim_datacon, state_and_prim_ty, prim_result_id, the_result)
+
+  -- Data types with a single nullary constructor
+  | (maybeToBool maybe_data_type) &&				-- Data type
+    (null other_data_cons) &&					-- Just one constr
+    (null data_con_arg_tys)
+  =
+    let unit = unitDataCon in
+    returnDs (stateDataCon, realWorldStateTy, unit, Var unit)
+  | otherwise
+  = pprPanic "boxResult: " (ppr ty)
+ where
+   maybe_data_type			  = splitAlgTyConApp_maybe ty
+   Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
+   (the_data_con : other_data_cons)       = data_cons
+
+   data_con_arg_tys		          = dataConArgTys the_data_con tycon_arg_tys
+   (the_prim_result_ty : other_args_tys)  = data_con_arg_tys
+   (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
+
 \end{code}
 
 This grimy bit of code is for digging out the IOok constructor from an

ghc/compiler/deSugar/DsForeign.lhs

@@ -14,7 +14,7 @@ module DsForeign ( dsForeigns ) where
 import CoreSyn
 
 import DsCCall		( getIoOkDataCon, boxResult, unboxArg,
-			  can'tSeeDataConsPanic
+			  can'tSeeDataConsPanic, wrapUnboxedValue
 			)
 import DsMonad
 import DsUtils
@@ -31,7 +31,7 @@ import IdInfo		( noIdInfo )
 import Literal		( Literal(..), mkMachInt )
 import Maybes		( maybeToBool )
 import Name		( nameString, occNameString, nameOccName, nameUnique )
-import PrelVals		( packStringForCId, eRROR_ID )
+import PrelVals		( packStringForCId, eRROR_ID, realWorldPrimId )
 import PrimOp		( PrimOp(..) )
 import Type		( isUnpointedType, splitAlgTyConApp_maybe, 
 			  splitTyConApp_maybe, splitFunTys, splitForAllTys,
@@ -54,6 +54,7 @@ import TysWiredIn	( getStatePairingConInfo,
 			  stateAndPtrPrimDataCon,
 			  addrDataCon
 			)
+import Unique
 import Outputable
 \end{code}
 
@@ -125,13 +126,29 @@ dsFImport nm ty may_not_gc ext_name cconv =
     mkArgs ty				`thenDs` \ (tvs, args, io_res_ty)  ->
     mapAndUnzipDs unboxArg args		`thenDs` \ (unboxed_args, arg_wrappers) ->
     let
-	 final_args = Var old_s : unboxed_args
+	 the_state_arg
+	   | is_io_action = old_s
+	   | otherwise    = realWorldPrimId
+
+	 final_args = Var the_state_arg : unboxed_args
 	 (ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty
+
+	 is_io_action =
+	   case (splitTyConApp_maybe io_res_ty) of
+	     Just (iot,[_]) -> (uniqueOf iot) == ioTyConKey
+	     _		    -> False
     in
-    boxResult ioOkDataCon result_ty	`thenDs` \ (final_result_ty, res_wrapper) ->
+    (if not is_io_action then
+	newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok ->
+	wrapUnboxedValue io_res_ty         `thenDs` \ (state_and_foo, state_and_foo_ty, v, res_v) ->
+	let the_alt = (state_and_foo, [state_tok,v], res_v) in
+        returnDs (state_and_foo_ty, \ prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault))
+     else
+        boxResult ioOkDataCon result_ty)      `thenDs` \ (final_result_ty, res_wrapper) ->
     (case ext_name of
-       Dynamic       -> getUniqueDs `thenDs` \ u -> returnDs (Right u)
-       ExtName fs _  -> returnDs (Left fs)) `thenDs` \ label ->
+       Dynamic       -> getUniqueDs `thenDs` \ u -> 
+			returnDs (Right u)
+       ExtName fs _  -> returnDs (Left fs))   `thenDs` \ label ->
     let
 	the_ccall_op = CCallOp label False (not may_not_gc) cconv
 			       (map coreExprType final_args)
@@ -139,12 +156,18 @@ dsFImport nm ty may_not_gc ext_name cconv =
     in
     mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
     let
-	the_body = mkValLam [old_s]
-			    (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
+	body = foldr ($) (res_wrapper the_prim_app) arg_wrappers 
+
+	the_body
+	  | not is_io_action = body
+	  | otherwise        = mkValLam [old_s] body
     in
     newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
     let
-      io_app = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds]
+      io_app 
+       | is_io_action = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds]
+       | otherwise    = Var ds
+
       fo_rhs = mkTyLam  tvs $
 	       mkValLam (map (\ (Var x) -> x) args)
 			(mkCoLetAny (NonRec ds the_body) io_app)

ghc/compiler/typecheck/TcForeign.lhs

@@ -222,7 +222,8 @@ checkForeignRes pred_res_ty ty =
         | (uniqueOf io) == ioTyConKey &&
           pred_res_ty res_ty 
 	-> returnTc ()
-    _   -> check False (illegalForeignTyErr False{-Res-} ty)
+    _   | pred_res_ty ty -> returnTc ()
+        | otherwise      -> check False (illegalForeignTyErr False{-Res-} ty)
 
 \end{code}