[project @ 2000-04-05 16:25:51 by simonpj]

* Add new flag -fddump-minimal-imports, which dumps a file
  M.imports that contains the (allegedly) minimal bunch of
  imports that make the system work.
  It's done by Rename.printMinimalImports

* Extend foreign import/export to handle
	* Booleans
	* newtypes
  as requested by the FFI team

* Tidy up DsCCall quite a bit
  Remove maybeBoxedPrimTy from TcHsSyn

ghc/compiler/absCSyn/PprAbsC.lhs

@@ -45,7 +45,8 @@ import TyCon		( tyConDataCons )
 import Name		( NamedThing(..) )
 import DataCon		( DataCon{-instance NamedThing-}, dataConWrapId )
 import Maybes		( maybeToBool, catMaybes )
-import PrimOp		( primOpNeedsWrapper, pprPrimOp, PrimOp(..), CCall(..), CCallTarget(..) )
+import PrimOp		( primOpNeedsWrapper, pprPrimOp, pprCCallOp, 
+			  PrimOp(..), CCall(..), CCallTarget(..) )
 import PrimRep		( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
 import SMRep		( pprSMRep )
 import Unique		( pprUnique, Unique{-instance NamedThing-} )
@@ -777,7 +778,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 (CCall op_str is_asm may_gc cconv) args results vol_regs
+pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
   = vcat [
       char '{',
       declare_local_vars,   -- local var for *result*
@@ -797,10 +798,10 @@ pprCCall (CCall op_str is_asm may_gc cconv) args results vol_regs
 	| otherwise = (	pp_basic_saves $$ pp_saves,
 			pp_basic_restores $$ pp_restores)
 
-    non_void_args =
-	let nvas = tail args
-	in ASSERT (all non_void nvas) nvas
-    -- the first argument will be the "I/O world" token (a VoidRep)
+    non_void_args = let nvas = take (length args - 1) args
+	  	    in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode args) )
+		       nvas
+    -- the last argument will be the "I/O world" token (a VoidRep)
     -- all others should be non-void
 
     non_void_results =

ghc/compiler/basicTypes/MkId.lhs

@@ -43,7 +43,7 @@ import Rules		( addRule )
 import Type		( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
 			  mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
 			  isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes,
-			  splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
+			  splitSigmaTy, splitFunTy_maybe, 
 			  splitFunTys, splitForAllTys, unUsgTy,
 			  mkUsgTy, UsageAnn(..)
 			)

ghc/compiler/basicTypes/Name.lhs

@@ -23,8 +23,9 @@ module Name (
 	tidyTopName, 
 	nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule,
 
-	isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, nameSrcLoc,
-	isLocallyDefinedName, isDynName,
+	isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, 
+	maybeUserImportedFrom,
+	nameSrcLoc, isLocallyDefinedName, isDynName,
 
 	isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
 	
@@ -431,6 +432,9 @@ isUserImportedExplicitlyName other			           			 = False
 isUserImportedName (Name { n_prov = NonLocalDef (UserImport _ _ _) _ }) = True
 isUserImportedName other			           		= False
 
+maybeUserImportedFrom (Name { n_prov = NonLocalDef (UserImport m _ _) _ }) = Just m
+maybeUserImportedFrom other			           		   = Nothing
+
 isDynName :: Name -> Bool
 	-- Does this name come from a DLL?
 isDynName nm = not (isLocallyDefinedName nm) && 

ghc/compiler/codeGen/CgRetConv.lhs

 %
 % (c) The GRASP Project, Glasgow University, 1992-1998
 %
-% $Id: CgRetConv.lhs,v 1.20 2000/03/23 17:45:19 simonpj Exp $
+% $Id: CgRetConv.lhs,v 1.21 2000/04/05 16:25:51 simonpj Exp $
 %
 \section[CgRetConv]{Return conventions for the code generator}
 
@@ -31,8 +31,7 @@ import DataCon		( DataCon )
 import PrimOp		( PrimOp{-instance Outputable-} )
 import PrimRep		( isFloatingRep, PrimRep(..), is64BitRep )
 import TyCon		( TyCon, tyConDataCons, tyConFamilySize )
-import Type		( Type, typePrimRep, isUnLiftedType, 
-			  splitAlgTyConApp_maybe )
+import Type		( Type, typePrimRep, isUnLiftedType )
 import Util		( isn'tIn )
 
 import Outputable

ghc/compiler/coreSyn/CoreLint.lhs

@@ -36,7 +36,6 @@ import Type		( Type, Kind, tyVarsOfType,
 			  splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
 			  splitForAllTy_maybe, splitTyConApp_maybe,
 			  isUnLiftedType, typeKind, 
-			  splitAlgTyConApp_maybe,
 			  isUnboxedTupleType,
 			  hasMoreBoxityInfo
 			)

ghc/compiler/coreSyn/CoreUnfold.lhs

@@ -56,7 +56,7 @@ import Literal		( isLitLitLit )
 import PrimOp		( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm )
 import IdInfo		( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..), insideLam, workerExists )
 import TyCon		( tyConFamilySize )
-import Type		( splitAlgTyConApp_maybe, splitFunTy_maybe, isUnLiftedType )
+import Type		( splitFunTy_maybe, isUnLiftedType )
 import Unique		( Unique, buildIdKey, augmentIdKey )
 import Maybes		( maybeToBool )
 import Bag

ghc/compiler/coreSyn/CoreUtils.lhs

@@ -159,9 +159,7 @@ mkInlineMe e | exprIsTrivial e = e
 
 
 \begin{code}
-mkCoerce :: Type -> Type -> Expr b -> Expr b
--- In (mkCoerce to_ty from_ty e), we require that from_ty = exprType e
--- But exprType is defined in CoreUtils, so we don't check the assertion
+mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
 
 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
   = ASSERT( from_ty == to_ty2 )
@@ -169,7 +167,8 @@ mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
 
 mkCoerce to_ty from_ty expr
   | to_ty == from_ty = expr
-  | otherwise	     = Note (Coerce to_ty from_ty) expr
+  | otherwise	     = ASSERT( from_ty == exprType expr )
+		       Note (Coerce to_ty from_ty) expr
 \end{code}
 
 \begin{code}

ghc/compiler/deSugar/DsCCall.lhs

@@ -9,9 +9,7 @@ module DsCCall
 	, mkCCall
 	, unboxArg
 	, boxResult
-	,  wrapUnboxedValue
-	, can'tSeeDataConsPanic
-	
+	, resultWrapper
 	) where
 
 #include "HsVersions.h"
@@ -21,31 +19,31 @@ import CoreSyn
 import DsMonad
 import DsUtils
 
-import TcHsSyn		( maybeBoxedPrimType )
-import CoreUtils	( exprType )
+import CoreUtils	( exprType, mkCoerce )
 import Id		( Id, mkWildId )
-import MkId		( mkCCallOpId )
+import MkId		( mkCCallOpId, realWorldPrimId )
 import Maybes		( maybeToBool )
 import PrelInfo		( packStringForCId )
 import PrimOp		( PrimOp(..), CCall(..), CCallTarget(..) )
-import DataCon		( DataCon, splitProductType_maybe )
+import DataCon		( DataCon, splitProductType_maybe, dataConSourceArity, dataConWrapId )
 import CallConv
 import Type		( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
-			  splitTyConApp_maybe, tyVarsOfType, mkForAllTys, Type
+			  splitTyConApp_maybe, tyVarsOfType, mkForAllTys, 
+			  isNewType, repType, isUnLiftedType, mkFunTy,
+			  Type
 			)
 import TysPrim		( byteArrayPrimTy, realWorldStatePrimTy,
-			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
-			  intPrimTy
+			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy
 			)
-import TysWiredIn	( unitDataConId, stringTy, boolTy,
-			  falseDataCon, falseDataConId,
-			  trueDataCon, trueDataConId,
+import TysWiredIn	( unitDataConId, stringTy,
 			  unboxedPairDataCon,
-			  mkUnboxedTupleTy, unboxedTupleCon
+			  mkUnboxedTupleTy, unboxedTupleCon,
+			  boolTy, trueDataCon, falseDataCon, trueDataConId, falseDataConId,
+			  unitTy
 			)
 import Literal		( mkMachInt )
 import CStrings		( CLabelString )
-import Unique		( Unique )
+import Unique		( Unique, Uniquable(..), ioTyConKey )
 import VarSet		( varSetElems )
 import Outputable
 \end{code}
@@ -90,22 +88,18 @@ dsCCall :: CLabelString	-- C routine to invoke
 	-> [CoreExpr]	-- Arguments (desugared)
 	-> Bool		-- True <=> might cause Haskell GC
 	-> Bool		-- True <=> really a "_casm_"
-	-> Type		-- Type of the result (a boxed-prim IO type)
+	-> Type		-- Type of the result: IO t
 	-> DsM CoreExpr
 
 dsCCall lbl args may_gc is_asm result_ty
-  = newSysLocalDs realWorldStatePrimTy	`thenDs` \ old_s ->
-
-    mapAndUnzipDs unboxArg args	`thenDs` \ (unboxed_args, arg_wrappers) ->
-    boxResult result_ty		`thenDs` \ (final_result_ty, res_wrapper) ->
+  = mapAndUnzipDs unboxArg args	`thenDs` \ (unboxed_args, arg_wrappers) ->
+    boxResult result_ty		`thenDs` \ (ccall_result_ty, res_wrapper) ->
     getUniqueDs			`thenDs` \ uniq ->
     let
-	val_args     = Var old_s : unboxed_args
 	the_ccall    = CCall (StaticTarget lbl) is_asm may_gc cCallConv
- 	the_prim_app = mkCCall uniq the_ccall val_args final_result_ty
-	the_body     = foldr ($) (res_wrapper the_prim_app) arg_wrappers
+ 	the_prim_app = mkCCall uniq the_ccall unboxed_args ccall_result_ty
     in
-    returnDs (Lam old_s the_body)
+    returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
 
 mkCCall :: Unique -> CCall 
 	-> [CoreExpr] 	-- Args
@@ -135,32 +129,42 @@ unboxArg :: CoreExpr			-- The supplied argument
 	 -> DsM (CoreExpr,		-- To pass as the actual argument
 		 CoreExpr -> CoreExpr	-- Wrapper to unbox the arg
 		)
-unboxArg arg
+-- Example: if the arg is e::Int, unboxArg will return
+--	(x#::Int#, \W. case x of I# x# -> W)
+-- where W is a CoreExpr that probably mentions x#
 
-  -- Primitive types
-  -- ADR Question: can this ever be used?  None of the PrimTypes are
-  -- instances of the CCallable class.
-  --
-  -- SOF response:
-  --    Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
-  --  that accept unboxed arguments is a Good Thing if you have a stub generator
-  --  which generates the boiler-plate box-unbox code for you, i.e., it may help
-  --  us nuke this very module :-)
-  --
+unboxArg arg
+  -- Unlifted types: nothing to unbox
   | isUnLiftedType arg_ty
   = returnDs (arg, \body -> body)
 
-  -- Strings
-  | arg_ty == stringTy
-  -- ToDo (ADR): - allow synonyms of Strings too?
-  = newSysLocalDs byteArrayPrimTy		`thenDs` \ prim_arg ->
+  -- Newtypes
+  | isNewType arg_ty
+  = unboxArg (mkCoerce (repType arg_ty) arg_ty arg)
+      
+  -- Booleans
+  | arg_ty == boolTy
+  = newSysLocalDs intPrimTy		`thenDs` \ prim_arg ->
     returnDs (Var prim_arg,
-	      \body -> Case (App (Var packStringForCId) arg) 
-			    prim_arg [(DEFAULT,[],body)])
+	      \ body -> Case (Case arg (mkWildId arg_ty)
+  		                       [(DataAlt falseDataCon,[],mkIntLit 0),
+	                                (DataAlt trueDataCon, [],mkIntLit 1)])
+                             prim_arg 
+			     [(DEFAULT,[],body)])
+
+  -- Data types with a single constructor, which has a single, primitive-typed arg
+  -- This deals with Int, Float etc
+  | is_product_type && data_con_arity == 1 
+  = ASSERT(isUnLiftedType data_con_arg_ty1 )	-- Typechecker ensures this
+    newSysLocalDs arg_ty		`thenDs` \ case_bndr ->
+    newSysLocalDs data_con_arg_ty1	`thenDs` \ prim_arg ->
+    returnDs (Var prim_arg,
+	      \ body -> Case arg case_bndr [(DataAlt data_con,[prim_arg],body)]
+    )
 
   -- Byte-arrays, both mutable and otherwise; hack warning
   | is_product_type &&
-    length data_con_arg_tys == 3 &&
+    data_con_arity == 3 &&
     maybeToBool maybe_arg3_tycon &&
     (arg3_tycon ==  byteArrayPrimTyCon ||
      arg3_tycon ==  mutableByteArrayPrimTyCon)
@@ -171,141 +175,134 @@ unboxArg arg
 	      \ body -> Case arg case_bndr [(DataAlt data_con,vars,body)]
     )
 
-  -- Data types with a single constructor, which has a single, primitive-typed arg
-  | maybeToBool maybe_boxed_prim_arg_ty
-  = newSysLocalDs arg_ty		`thenDs` \ case_bndr ->
-    newSysLocalDs the_prim_arg_ty	`thenDs` \ prim_arg ->
-    returnDs (Var prim_arg,
-	      \ body -> Case arg case_bndr [(DataAlt box_data_con,[prim_arg],body)]
-    )
-
-  -- Booleans
-  | arg_ty == boolTy
-  = newSysLocalDs intPrimTy		`thenDs` \ prim_arg ->
-    returnDs (Var prim_arg,
-	      \ body -> Case (Case arg (mkWildId arg_ty) [
-                                (DataAlt falseDataCon,[],mkIntLit 0),
-                                (DataAlt trueDataCon, [],mkIntLit 1)])
-                             prim_arg [(DEFAULT,[],body)]
-    )
-
   | otherwise
   = getSrcLocDs `thenDs` \ l ->
     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
   where
-    arg_ty = exprType arg
-
-    maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
-    (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
+    arg_ty     = exprType arg
+    arg_rep_ty = repType arg_ty
 
     maybe_product_type 			   	  = splitProductType_maybe arg_ty
     is_product_type			   	  = maybeToBool maybe_product_type
     Just (tycon, _, data_con, data_con_arg_tys)   = maybe_product_type
-    (data_con_arg_ty1 : data_con_arg_ty2 : data_con_arg_ty3 :_)
-	  = data_con_arg_tys
-
-    maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
-    Just (arg3_tycon,_) = maybe_arg3_tycon
+    data_con_arity				  = dataConSourceArity data_con
+    (data_con_arg_ty1 : _)			  = data_con_arg_tys
 
-can'tSeeDataConsPanic thing ty
-  = pprPanic
-     "ERROR: Can't see the data constructor(s) for _ccall_/_casm_/foreign declaration"
-     (hcat [ text thing, text "; type: ", ppr ty
-           , text "(try compiling with -fno-prune-tydecls ..)\n"])
+    (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
+    maybe_arg3_tycon    	   = splitTyConApp_maybe data_con_arg_ty3
+    Just (arg3_tycon,_)		   = maybe_arg3_tycon
 \end{code}
 
 
 \begin{code}
-boxResult :: Type			-- Type of desired result
-	  -> DsM (Type,			-- Type of the result of the ccall itself
-		  CoreExpr -> CoreExpr)	-- Wrapper for the ccall
-					-- to box the result
-boxResult result_ty
-  -- Data types with a single nullary constructor
-  | (maybeToBool maybe_product_type) &&				-- Data type
-    (null data_con_arg_tys)
-  =
-    newSysLocalDs realWorldStatePrimTy		`thenDs` \ prim_state_id ->
-{-
-    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 ->
--}
-    let
-	the_pair = mkConApp unboxedPairDataCon
-			    [Type realWorldStatePrimTy, Type result_ty, 
-			     Var prim_state_id, 
-			     Var unitDataConId]
-	the_alt  = (DataAlt (unboxedTupleCon 1), [prim_state_id], the_pair)
-	scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
-    in
-    returnDs (scrut_ty, \prim_app -> Case prim_app (mkWildId scrut_ty) [the_alt]
-    )
+boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
+
+-- Takes the result of the user-level ccall: 
+--	either (IO t), 
+--	or maybe just t for an side-effect-free call
+-- Returns a wrapper for the primitive ccall itself, along with the
+-- type of the result of the primitive ccall.  This result type
+-- will be of the form  
+--	State# RealWorld -> (# State# RealWorld, t' #)
+-- where t' is the unwrapped form of t.  If t is simply (), then
+-- the result type will be 
+--	State# RealWorld -> (# State# RealWorld #)
 
-  -- Data types with a single constructor, which has a single, primitive-typed arg
-  | (maybeToBool maybe_product_type) &&				-- Data type
-    not (null data_con_arg_tys) && null other_args_tys	&& 	-- Just one arg
-    isUnLiftedType the_prim_result_ty				-- of primitive type
-  =
-    newSysLocalDs realWorldStatePrimTy		`thenDs` \ prim_state_id ->
-    newSysLocalDs the_prim_result_ty 		`thenDs` \ prim_result_id ->
-    newSysLocalDs ccall_res_type 		`thenDs` \ case_bndr ->
-
-    let
-	the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
-	the_pair   = mkConApp unboxedPairDataCon
-				[Type realWorldStatePrimTy, Type result_ty, 
-				 Var prim_state_id, the_result]
-	the_alt    = (DataAlt unboxedPairDataCon, [prim_state_id, prim_result_id], the_pair)
-    in
-    returnDs (ccall_res_type, \prim_app -> Case prim_app case_bndr [the_alt]
-    )
+boxResult result_ty
+  = case splitAlgTyConApp_maybe result_ty of
+
+	-- The result is IO t, so wrap the result in an IO constructor
+	Just (io_tycon, [io_res_ty], [io_data_con]) | getUnique io_tycon == ioTyConKey
+		-> mk_alt return_result 
+			  (resultWrapper io_res_ty)	`thenDs` \ (ccall_res_ty, the_alt) ->
+		   newSysLocalDs realWorldStatePrimTy	 `thenDs` \ state_id ->
+		   let
+			wrap = \ the_call -> mkApps (Var (dataConWrapId io_data_con))
+						    [Type io_res_ty, Lam state_id $
+								     Case (App the_call (Var state_id))
+									  (mkWildId ccall_res_ty)
+									  [the_alt]]
+		   in
+		   returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+		where
+		   return_result state ans = mkConApp unboxedPairDataCon 
+						      [Type realWorldStatePrimTy, Type io_res_ty, 
+						       state, ans]
+
+	-- It isn't, so do unsafePerformIO
+	-- It's not conveniently available, so we inline it
+	other -> mk_alt return_result
+			(resultWrapper result_ty) 	`thenDs` \ (ccall_res_ty, the_alt) ->
+		 let
+		    wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) 
+					      (mkWildId ccall_res_ty)
+					      [the_alt]
+		 in
+		 returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+	      where
+		 return_result state ans = ans
+  where
+    mk_alt return_result (Nothing, wrap_result)
+	= 	-- The ccall returns ()
+	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
+	  let
+		the_rhs      = return_result (Var state_id) (wrap_result (panic "boxResult"))
+		ccall_res_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
+		the_alt      = (DataAlt (unboxedTupleCon 1), [state_id], the_rhs)
+	  in
+	  returnDs (ccall_res_ty, the_alt)
+
+    mk_alt return_result (Just prim_res_ty, wrap_result)
+	=	-- The ccall returns a non-() value
+	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
+	  newSysLocalDs prim_res_ty 		`thenDs` \ result_id ->
+	  let
+		the_rhs      = return_result (Var state_id) (wrap_result (Var result_id))
+		ccall_res_ty = mkUnboxedTupleTy 2 [realWorldStatePrimTy, prim_res_ty]
+		the_alt	     = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
+	  in
+	  returnDs (ccall_res_ty, the_alt)
+
+
+resultWrapper :: Type
+   	      -> (Maybe Type,		-- Type of the expected result, if any
+		  CoreExpr -> CoreExpr)	-- Wrapper for the result 
+resultWrapper result_ty
+  -- Base case 1: primitive types
+  | isUnLiftedType result_ty
+  = (Just result_ty, \e -> e)
+
+  -- Base case 1: the unit type ()
+  | result_ty == unitTy
+  = (Nothing, \e -> Var unitDataConId)
 
-  -- Booleans
   | result_ty == boolTy
-  = returnDs (mkUnboxedTupleTy 2 [realWorldStatePrimTy, intPrimTy],
-              \ prim_app -> Case prim_app (mkWildId intPrimTy) [
-                               (LitAlt (mkMachInt 0),[],Var falseDataConId),
-                               (DEFAULT             ,[],Var trueDataConId )])
+  = (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+	                          [(LitAlt (mkMachInt 0),[],Var falseDataConId),
+	                           (DEFAULT             ,[],Var trueDataConId )])
+
+  -- Data types with a single constructor, which has a single arg
+  | is_product_type && data_con_arity == 1
+  = let
+        (maybe_ty, wrapper)    = resultWrapper unwrapped_res_ty
+	(unwrapped_res_ty : _) = data_con_arg_tys
+    in
+    (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) 
+			    (map Type tycon_arg_tys ++ [wrapper e]))
+
+  -- newtypes
+  | isNewType result_ty
+  = let
+	rep_ty		    = repType result_ty
+        (maybe_ty, wrapper) = resultWrapper rep_ty
+    in
+    (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e))
 
   | otherwise
-  = pprPanic "boxResult: " (ppr result_ty)
+  = pprPanic "resultWrapper" (ppr result_ty)
   where
     maybe_product_type 					    = splitProductType_maybe result_ty
+    is_product_type					    = maybeToBool maybe_product_type
     Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
-    (the_prim_result_ty : other_args_tys)		    = data_con_arg_tys
-
-    ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty]
-
--- wrap up an unboxed value.
-wrapUnboxedValue :: Type -> DsM (Type, Id, CoreExpr)
-wrapUnboxedValue ty
-  | (maybeToBool maybe_product_type) &&				-- Data type
-    not (null data_con_arg_tys) && null other_args_tys	&& 	-- Just one arg
-    isUnLiftedType the_prim_result_ty				-- of primitive type
-  =
-    newSysLocalDs the_prim_result_ty 		         `thenDs` \ prim_result_id ->
-    let
-	the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
-    in
-    returnDs (ccall_res_type, prim_result_id, the_result)
-
-  -- Data types with a single nullary constructor
-  | (maybeToBool maybe_product_type) &&				-- Data type
-    (null data_con_arg_tys)
-  =
-    let 
-	scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
-    in
-    returnDs (scrut_ty, unitDataConId, Var unitDataConId)
-
-  | otherwise
-  = pprPanic "boxResult: " (ppr ty)
- where
-   maybe_product_type		      			   = splitProductType_maybe ty
-   Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
-   (the_prim_result_ty : other_args_tys)  		   = data_con_arg_tys
-   ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty]
+    data_con_arity					    = dataConSourceArity data_con
 \end{code}

ghc/compiler/deSugar/DsExpr.lhs

@@ -15,9 +15,7 @@ import HsSyn		( failureFreePat,
 			  mkSimpleMatch
 			)
 import TcHsSyn		( TypecheckedHsExpr, TypecheckedHsBinds,
-			  TypecheckedStmt,
-			  maybeBoxedPrimType
-
+			  TypecheckedStmt
 			)
 import CoreSyn
 import CoreUtils	( exprType, mkIfThenElse, bindNonRec )
@@ -25,7 +23,7 @@ import CoreUtils	( exprType, mkIfThenElse, bindNonRec )
 import DsMonad
 import DsBinds		( dsMonoBinds, AutoScc(..) )
 import DsGRHSs		( dsGuarded )
-import DsCCall		( dsCCall )
+import DsCCall		( dsCCall, resultWrapper )
 import DsListComp	( dsListComp )
 import DsUtils		( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr )
 import Match		( matchWrapper, matchSimply )
@@ -164,29 +162,11 @@ dsExpr (HsLitOut (HsString str) _)
   = returnDs (mkStringLitFS str)
 
 dsExpr (HsLitOut (HsLitLit str) ty)
-  | isUnLiftedType ty
-  = returnDs (mkLit (MachLitLit str ty))
-  | otherwise
-  = case (maybeBoxedPrimType ty) of
-      Just (boxing_data_con, prim_ty) ->
-	    returnDs ( mkConApp boxing_data_con [mkLit (MachLitLit str prim_ty)] )
-      _ -> 
-	pprError "ERROR:"
-		 (vcat
-		   [ hcat [ text "Cannot see data constructor of ``literal-literal''s type: "
-		         , text "value:", quotes (quotes (ptext str))
-		         , text "; type: ", ppr ty
-		         ]
-		   , text "Try compiling with -fno-prune-tydecls."
-		   ])
-		  
+  = ASSERT( maybeToBool maybe_ty )
+    returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
   where
-    (data_con, prim_ty)
-      = case (maybeBoxedPrimType ty) of
-	  Just (boxing_data_con, prim_ty) -> (boxing_data_con, prim_ty)
-	  Nothing
-	    -> pprPanic "ERROR: ``literal-literal'' not a single-constructor type: "
-			(hcat [ptext str, text "; type: ", ppr ty])
+    (maybe_ty, wrap_fn) = resultWrapper ty
+    Just rep_ty 	= maybe_ty
 
 dsExpr (HsLitOut (HsInt i) ty)
   = returnDs (mkIntegerLit i)

ghc/compiler/deSugar/DsForeign.lhs

@@ -12,7 +12,7 @@ module DsForeign ( dsForeigns ) where
 
 import CoreSyn
 
-import DsCCall		( dsCCall, mkCCall, boxResult, unboxArg, wrapUnboxedValue )
+import DsCCall		( dsCCall, mkCCall, boxResult, unboxArg )
 import DsMonad
 import DsUtils
 
@@ -23,15 +23,15 @@ import TcHsSyn		( TypecheckedForeignDecl )
 import CoreUtils	( exprType, mkInlineMe, bindNonRec )
 import DataCon		( DataCon, dataConWrapId )
 import Id		( Id, idType, idName, mkWildId, mkVanillaId )
-import MkId		( mkCCallOpId, mkWorkerId )
+import MkId		( mkWorkerId )
 import Literal		( Literal(..) )
 import Module		( Module, moduleUserString )
 import Name		( mkGlobalName, nameModule, nameOccName, getOccString, 
 			  mkForeignExportOcc, isLocalName,
 			  NamedThing(..), Provenance(..), ExportFlag(..)
 			)
-import PrelInfo		( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME, realWorldPrimId )
-import Type		( splitAlgTyConApp_maybe,  unUsgTy,
+import PrelInfo		( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME )
+import Type		( unUsgTy,
 			  splitTyConApp_maybe, splitFunTys, splitForAllTys,
 			  Type, mkFunTys, mkForAllTys, mkTyConApp,
 			  mkTyVarTy, mkFunTy, splitAppTy
@@ -45,10 +45,6 @@ import TysWiredIn	( unitTyCon, addrTy, stablePtrTyCon,
 import Unique
 import Maybes		( maybeToBool )
 import Outputable
-
-#if __GLASGOW_HASKELL__ >= 404
-import GlaExts		( fromInt )
-#endif
 \end{code}
 
 Desugaring of @foreign@ declarations is naturally split up into
@@ -133,21 +129,12 @@ dsFImport :: Id
 	  -> DsM [CoreBind]
 dsFImport fn_id ty may_not_gc ext_name cconv 
   = let
-	(tvs, arg_tys, mbIoDataCon, io_res_ty) = splitForeignTyDs ty
-	is_io_action 			       = maybeToBool mbIoDataCon
+	(tvs, fun_ty)        = splitForAllTys ty
+	(arg_tys, io_res_ty) = splitFunTys fun_ty
     in
     newSysLocalsDs arg_tys  			`thenDs` \ args ->
-    newSysLocalDs realWorldStatePrimTy		`thenDs` \ old_s ->
-    mapAndUnzipDs unboxArg (map Var args)	`thenDs` \ (unboxed_args, arg_wrappers) ->
-
-    (if not is_io_action then
-       newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_tok ->
-       wrapUnboxedValue io_res_ty		`thenDs` \ (ccall_result_ty, v, res_v) ->
-       returnDs ( ccall_result_ty
-                , \ prim_app -> Case prim_app  (mkWildId ccall_result_ty)
-				    [(DataAlt (unboxedTupleCon 2), [state_tok, v], res_v)])
-     else
-       boxResult io_res_ty)			`thenDs` \ (ccall_result_ty, res_wrapper) ->
+    mapAndUnzipDs unboxArg (map Var args)	`thenDs` \ (val_args, arg_wrappers) ->
+    boxResult io_res_ty				`thenDs` \ (ccall_result_ty, res_wrapper) ->
 
     (case ext_name of
        Dynamic       -> getUniqueDs `thenDs` \ u -> 
@@ -157,11 +144,7 @@ dsFImport fn_id ty may_not_gc ext_name cconv
     getUniqueDs						`thenDs` \ ccall_uniq ->
     getUniqueDs						`thenDs` \ work_uniq ->
     let
-	the_state_arg | is_io_action = old_s
-		      | otherwise    = realWorldPrimId
-
 	-- Build the worker
-	val_args      = Var the_state_arg : unboxed_args
 	work_arg_ids  = [v | Var v <- val_args]		-- All guaranteed to be vars
 	worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
 	the_ccall     = CCall lbl False (not may_not_gc) cconv
@@ -172,32 +155,12 @@ dsFImport fn_id ty may_not_gc ext_name cconv
 	-- Build the wrapper
 	work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
 	wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
-        io_app 	     = case mbIoDataCon of
-			   Nothing        -> wrapper_body
-			   Just ioDataCon -> mkApps (Var (dataConWrapId ioDataCon)) 
-						    [Type io_res_ty, Lam old_s wrapper_body]
-        wrap_rhs = mkInlineMe (mkLams (tvs ++ args) io_app)
+        wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
     in
     returnDs [NonRec fn_id wrap_rhs, NonRec work_id work_rhs]
 \end{code}
 
-Given the type of a foreign import declaration, split it up into
-its constituent parts.
-
-\begin{code}
-splitForeignTyDs :: Type -> ([TyVar], [Type], Maybe DataCon, Type)
-