From 49ac6c398f2915de9eadff3cd2631bc31f806ec8 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 25 Feb 2004 13:54:31 +0000
Subject: [PATCH] [project @ 2004-02-25 13:54:30 by simonpj] Yet another fix
 to the -Onot optimisation that hides data type
 representations in .hi files.

1.  Expose the representation if any fields are exposed

2.  Don't expose newtypes whose data-cons are abstract, unless the
    rep type is a FFI type.  (Previously we were more conservative
    and always exposed newtypes, just in case of a foreign decl.)
---
 ghc/compiler/iface/MkIface.lhs    |   41 +++++++++++++++++++++++--------------
 ghc/compiler/typecheck/TcType.lhs |   10 +++++++++
 2 files changed, 36 insertions(+), 15 deletions(-)

diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs
index 019b44f..f937379 100644
--- a/ghc/compiler/iface/MkIface.lhs
+++ b/ghc/compiler/iface/MkIface.lhs
@@ -183,6 +183,7 @@ import LoadIface	( readIface, loadInterface, ifaceInstGates )
 import BasicTypes	( Version, initialVersion, bumpVersion )
 import TcRnMonad
 import TcRnTypes	( ImportAvails(..), mkModDeps )
+import TcType		( isFFITy )
 import HscTypes		( ModIface(..), TyThing(..),
 			  ModGuts(..), ModGuts, IfaceExport,
 			  GhciMode(..), 
@@ -208,9 +209,10 @@ import OccName		( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOc
 			  extendOccSet, extendOccSetList,
 			  isEmptyOccSet, intersectOccSet, intersectsOccSet,
 			  occNameFS, isTcOcc )
-import TyCon		( visibleDataCons, tyConDataCons, isNewTyCon )
+import TyCon		( visibleDataCons, tyConDataCons, isNewTyCon, newTyConRep )
 import Class		( classSelIds )
-import DataCon		( dataConName )
+import DataCon		( dataConName, dataConFieldLabels )
+import FieldLabel	( fieldLabelName )
 import Module		( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
 			  ModLocation(..), mkSysModuleNameFS, moduleUserString,
 			  ModuleEnv, emptyModuleEnv, lookupModuleEnv,
@@ -274,7 +276,7 @@ mkIface hsc_env location maybe_old_iface
 		    | not omit_prags = emptyNameSet		-- In the -O case, nothing is abstract
 	    	    | otherwise	     = mkNameSet [ getName thing 
 						 | thing <- local_things
-				 		 , isAbstractThing exports thing]
+				 		 , not (mustExposeThing exports thing)]
 
 		; decls  = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm thing 
 			   | thing <- local_things, wantDeclFor exports abstract_tcs thing ]
@@ -340,24 +342,33 @@ mkIface hsc_env location maybe_old_iface
      omit_prags = dopt Opt_OmitInterfacePragmas dflags
 
 					      
-isAbstractThing :: NameSet -> TyThing -> Bool
-isAbstractThing exports (ATyCon tc) 
-  =  not (isNewTyCon tc)  
-	-- Always expose the rep for newtypes.  This is for a
-	-- very annoying reason.  'Foreign import' is meant to
+mustExposeThing :: NameSet -> TyThing -> Bool
+-- We are compiling without -O, and thus trying to write as little as 
+-- possible into the interface file.  But we must expose the details of
+-- any data types and classes whose constructors, fields, methods are 
+-- visible to an importing module
+mustExposeThing exports (ATyCon tc) 
+  =  any exported_data_con (tyConDataCons tc)
+	-- Expose rep if any datacon or field is exported
+
+  || (isNewTyCon tc && isFFITy (snd (newTyConRep tc)))
+	-- Expose the rep for newtypes if the rep is an FFI type.  
+	-- For a very annoying reason.  'Foreign import' is meant to
 	-- be able to look through newtypes transparently, but it
 	-- can only do that if it can "see" the newtype representation
-	-- So, for now anyway, we always expose the rep of newtypes. Sigh.
-  && not (any exported_data_con (tyConDataCons tc))
-	-- Don't expose rep if no datacons are exported
   where	 	
-     exported_data_con con = dataConName con `elemNameSet` exports
+     exported_data_con con 
+	= any (`elemNameSet` exports) (dataConName con : field_names)
+	where
+	  field_names = map fieldLabelName (dataConFieldLabels con)
      		
-isAbstractThing exports (AClass cls) = not (any exported_class_op (classSelIds cls))
-  where	 	-- Don't expose rep if no classs op is exported
+mustExposeThing exports (AClass cls) 
+  = any exported_class_op (classSelIds cls)
+  where	 	-- Expose rep if any classs op is exported
      exported_class_op op = getName op `elemNameSet` exports
 
-isAbstractThing exports other = False
+mustExposeThing exports other = False
+
 
 wantDeclFor :: NameSet	-- User-exported things
 	    -> NameSet	-- Abstract things
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 43e8cd2..753ad4f 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -73,6 +73,7 @@ module TcType (
   isFFILabelTy,        -- :: Type -> Bool
   isFFIDotnetTy,       -- :: DynFlags -> Type -> Bool
   isFFIDotnetObjTy,    -- :: Type -> Bool
+  isFFITy,	       -- :: Type -> Bool
   
   toDNType,            -- :: Type -> DNType
 
@@ -770,6 +771,10 @@ restricted set of types as arguments and results (the restricting factor
 being the )
 
 \begin{code}
+isFFITy :: Type -> Bool
+-- True for any TyCon that can possibly be an arg or result of an FFI call
+isFFITy ty = checkRepTyCon legalFFITyCon ty
+
 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
 -- Checks for valid argument type for a 'foreign import'
 isFFIArgumentTy dflags safety ty 
@@ -909,6 +914,11 @@ legalOutgoingTyCon dflags safety tc
   | otherwise
   = marshalableTyCon dflags tc
 
+legalFFITyCon :: TyCon -> Bool
+-- True for any TyCon that can possibly be an arg or result of an FFI call
+legalFFITyCon tc
+  = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
+
 marshalableTyCon dflags tc
   =  (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
   || boxedMarshalableTyCon tc
-- 
1.7.10.4