[project @ 2000-11-27 09:55:43 by simonpj]

Fixes to new version machinery

4 files changed, 33 insertions, 16 deletions

diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index f1f3142ac8..a137e7a7e0 100644
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -23,7 +23,8 @@ import Id		( idType, idInfo, idName, isExportedId,
 			  mkVanillaId, mkId, isLocalId, omitIfaceSigForId,
 			  setIdStrictness, setIdDemandInfo,
 			) 
-import IdInfo		( constantIdInfo,
+import IdInfo		( mkIdInfo,
+			  IdFlavour(..), flavourInfo, ppFlavourInfo,
 			  specInfo, setSpecInfo, 
 			  cprInfo, setCprInfo,
 			  inlinePragInfo, setInlinePragInfo, isNeverInlinePrag,
@@ -326,20 +327,32 @@ tidyTopBinder mod ext_ids env_idinfo rhs env@(orig_env, occ_env, subst_env) id
 
 tidyIdInfo (_, occ_env, subst_env) is_external unfold_info id
   | opt_OmitInterfacePragmas || not is_external
-	-- No IdInfo if the Id isn't 
-  = constantIdInfo
+	-- No IdInfo if the Id isn't external, or if we don't have -O
+  = mkIdInfo new_flavour
+	`setStrictnessInfo` strictnessInfo core_idinfo
+	-- Keep strictness info; it's used by the code generator
 
   | otherwise
-  = constantIdInfo `setCprInfo`   	 cprInfo core_idinfo
-		   `setStrictnessInfo`	 strictnessInfo core_idinfo
-		   `setInlinePragInfo`   inlinePragInfo core_idinfo
-		   `setUnfoldingInfo`	 unfold_info
-		   `setWorkerInfo`	 tidyWorker tidy_env (workerInfo core_idinfo)
-		   `setSpecInfo`	 tidyRules tidy_env (specInfo core_idinfo)
+  = mkIdInfo new_flavour
+	`setCprInfo`	    cprInfo core_idinfo
+	`setStrictnessInfo` strictnessInfo core_idinfo
+	`setInlinePragInfo` inlinePragInfo core_idinfo
+	`setUnfoldingInfo`  unfold_info
+	`setWorkerInfo`	    tidyWorker tidy_env (workerInfo core_idinfo)
+	`setSpecInfo`	    tidyRules  tidy_env (specInfo core_idinfo)
   where
     tidy_env    = (occ_env, subst_env)
     core_idinfo = idInfo id
 
+	-- A DFunId must stay a DFunId, so that we can gather the
+	-- DFunIds up later.  Other local things become ConstantIds.
+    new_flavour = case flavourInfo core_idinfo of
+		    VanillaId  -> ConstantId
+		    ExportedId -> ConstantId
+		    DictFunId  -> DictFunId
+		    flavour    -> pprTrace "tidyIdInfo" (ppr id <+> ppFlavourInfo flavour)
+				  flavour
+
 tidyTopName mod orig_env occ_env external name
   | global && internal = (orig_env, occ_env,  localiseName name)
   | local  && internal = (orig_env, occ_env', setNameOcc name occ')
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 70748aa44c..8bf94867a3 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -578,9 +578,7 @@ pprUsage (m, has_orphans, is_boot, whats_imported)
     pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr 
 					      <+> hsep [ pprOcc n <+> int v | (n,v) <- nvs ]
 
-	-- HACK for the moment: print the export-list version even if
-	-- we don't use it, so that syntax of interface files doesn't change
-    pp_export_version Nothing  = int 1
+    pp_export_version Nothing  = empty
     pp_export_version (Just v) = int v
 \end{code}
 
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index c5d3d55fbd..f2882c3e42 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -254,6 +254,7 @@ whats_imported      :: { WhatsImported OccName }
 whats_imported      :                                           	{ NothingAtAll }
 		    | '::' version					{ Everything $2 }
                     | '::' version version version name_version_pairs   { Specifically $2 (Just $3) $5 $4 }
+                    | '::' version version name_version_pairs		{ Specifically $2 Nothing $4 $3 }
 
 name_version_pairs  ::	{ [(OccName, Version)] }
 name_version_pairs  :  						{ [] }
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 74767ae3bf..b67458c53e 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -20,7 +20,7 @@ import StgSyn		-- output
 import CoreUtils	( exprType )
 import SimplUtils	( findDefault )
 import CostCentre	( noCCS )
-import Id		( Id, mkSysLocal, idType, idStrictness, isExportedId, 
+import Id		( Id, mkSysLocal, idType, idStrictness, 
 			  mkVanillaId, idName, idDemandInfo, idArity, setIdType,
 			  idFlavour
 			)
@@ -29,7 +29,7 @@ import IdInfo		( StrictnessInfo(..), IdFlavour(..) )
 import DataCon		( dataConWrapId, dataConTyCon )
 import TyCon		( isAlgTyCon )
 import Demand		( Demand, isStrict, wwLazy )
-import Name	        ( setNameUnique, globaliseName, isLocalName )
+import Name	        ( setNameUnique, globaliseName, isLocalName, isGlobalName )
 import VarEnv
 import PrimOp		( PrimOp(..), setCCallUnique )
 import Type		( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
@@ -258,8 +258,13 @@ coreBindToStg :: TopLvl -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
 coreBindToStg top_lev env (NonRec binder rhs)
   = coreExprToStgFloat env rhs			`thenUs` \ (floats, stg_rhs) ->
     case (floats, stg_rhs) of
-	([], StgApp var []) | not (isExportedId binder)
-		     -> returnUs (NoBindF, extendVarEnv env binder var)
+	([], StgApp var [])
+		|  not (isGlobalName (idName binder))
+		-> returnUs (NoBindF, extendVarEnv env binder var)
+
+		|  otherwise
+		-> newBinder top_lev env binder		`thenUs` \ (new_env, new_binder) ->
+		   returnUs (NonRecF new_binder stg_rhs dem floats, extendVarEnv new_env binder var)
 		-- A trivial binding let x = y in ...
 		-- can arise if postSimplExpr floats a NoRep literal out
 		-- so it seems sensible to deal with it well.