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

Fixes to new version machinery

diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index f1f3142..a137e7a 100644 (file)
--- 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 70748aa..8bf9486 100644 (file)
--- 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 c5d3d55..f2882c3 100644 (file)
--- 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 74767ae..b67458c 100644 (file)
--- 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.