[project @ 2001-10-18 16:29:12 by simonpj]

----------------------------------------------
	The CoreTidy/CorePrep/CoreToStg saga continues
	[actually, this commit mostly completes the job]
	----------------------------------------------

			DO NOT MERGE!

* CorePrep injects implicit bindings, not the type checker,
  nor CgConTbls.   (This way, all the code generators see
  them, so no need to fiddle with the byte code generator.)

  As a result, all bindings in the module are for LocalIds,
  at least until CoreTidy.   This is a Big Win.

  Hence remove nasty isImplicitId test in update_bndr in
  SimplCore and DmdAnal

* hasNoBinding is no longer true of a dataConId (worker).
  There's an implicit curried binding for it.

* Remove yukky test in exprIsTrivial that did not regard
  a hasNoBinding Id as trivial; similarly in SimplUtils.tryEtaReduce

* In CoreTidy, get the names to avoid from the type env.
  That way it includes implicit bindings too.

* CoreTidy set the Arity of a top-level Id permanently;
  it's up to the rest of the compiler to respect it.
  Notably, CorePrep uses etaExpand to make the manifest arity
  match the claimed arity.

* As a result, nuke CgArity, so that CgInfo now contains only
  CafInfo.  The CafInfo is knot-tied as before.

Other things

* In Simplify.simplLazyBind, be a bit keener to float bindings
  out if it's a top-level binding.

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index b212920..9575acd 100644 (file)
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -62,7 +62,6 @@ module Id (
        idSpecialisation,
        idCgInfo,
        idCafInfo,
        idSpecialisation,
        idCgInfo,
        idCafInfo,

-       idCgArity,

        idCprInfo,
        idLBVarInfo,
        idOccInfo,
        idCprInfo,
        idLBVarInfo,
        idOccInfo,

@@ -266,11 +265,12 @@ isDataConWrapId id = case globalIdDetails id of
                        DataConWrapId con -> True
                        other             -> False
 
                        DataConWrapId con -> True
                        other             -> False
 

-       -- hasNoBinding returns True of an Id which may not have a
-       -- binding, even though it is defined in this module.  Notably,
-       -- the constructors of a dictionary are in this situation.
+-- hasNoBinding returns True of an Id which may not have a
+-- binding, even though it is defined in this module.  
+-- Data constructor workers used to be things of this kind, but
+-- they aren't any more.  Instead, we inject a binding for 
+-- them at the CorePrep stage.

 hasNoBinding id = case globalIdDetails id of
 hasNoBinding id = case globalIdDetails id of

-                       DataConId _ -> True

                        PrimOpId _  -> True
                        FCallId _   -> True
                        other       -> False
                        PrimOpId _  -> True
                        FCallId _   -> True
                        other       -> False

@@ -429,17 +429,6 @@ idCafInfo id = cgCafInfo (idCgInfo id)
 #endif
 
        ---------------------------------
 #endif
 
        ---------------------------------

-       -- CG ARITY
-idCgArity :: Id -> Arity
-#ifdef DEBUG
-idCgArity id = case cgInfo (idInfo id) of
-                 NoCgInfo -> pprPanic "idCgArity" (ppr id)
-                 info     -> cgArity info
-#else
-idCgArity id = cgArity (idCgInfo id)
-#endif
-
-       ---------------------------------

        -- CPR INFO
 idCprInfo :: Id -> CprInfo
 idCprInfo id = case cprInfo (idInfo id) of
        -- CPR INFO
 idCprInfo :: Id -> CprInfo
 idCprInfo id = case cprInfo (idInfo id) of

diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 0a8067b..07598a3 100644 (file)
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -62,9 +62,8 @@ module IdInfo (
 
        -- CG info
        CgInfo(..), cgInfo, setCgInfo,  pprCgInfo,
 
        -- CG info
        CgInfo(..), cgInfo, setCgInfo,  pprCgInfo,

-       cgArity, cgCafInfo, vanillaCgInfo,
+       cgCafInfo, vanillaCgInfo,

        CgInfoEnv, lookupCgInfo,
        CgInfoEnv, lookupCgInfo,

-       setCgArity,

 
        -- CAF info
        CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs,
 
        -- CAF info
        CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs,

@@ -118,7 +117,6 @@ infixl      1 `setDemandInfo`,
          `setOccInfo`,
          `setCgInfo`,
          `setCafInfo`,
          `setOccInfo`,
          `setCgInfo`,
          `setCafInfo`,

-         `setCgArity`,

          `setNewStrictnessInfo`,
          `setNewDemandInfo`
        -- infixl so you can say (id `set` a `set` b)
          `setNewStrictnessInfo`,
          `setNewDemandInfo`
        -- infixl so you can say (id `set` a `set` b)

@@ -341,7 +339,7 @@ vanillaIdInfo
           }
 
 noCafNoTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever
           }
 
 noCafNoTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever

-                                  `setCgInfo`    (CgInfo 0 NoCafRefs)
+                                  `setCgInfo`    CgInfo NoCafRefs

        -- Used for built-in type Ids in MkId.
        -- Many built-in things have fixed types, so we shouldn't
        -- run around generalising them
        -- Used for built-in type Ids in MkId.
        -- Many built-in things have fixed types, so we shouldn't
        -- run around generalising them

@@ -539,33 +537,24 @@ but only as a thunk --- the information is only actually produced further
 downstream, by the code generator.
 
 \begin{code}
 downstream, by the code generator.
 
 \begin{code}

-data CgInfo = CgInfo 
-               !Arity          -- Exact arity for calling purposes
-               !CafInfo
-#ifdef DEBUG
+#ifndef DEBUG
+newtype CgInfo = CgInfo CafInfo        -- We are back to only having CafRefs in CgInfo
+noCgInfo = panic "NoCgInfo!"
+#else
+data CgInfo = CgInfo CafInfo

            | NoCgInfo          -- In debug mode we don't want a black hole here
                                -- See Id.idCgInfo
            | NoCgInfo          -- In debug mode we don't want a black hole here
                                -- See Id.idCgInfo

-

        -- noCgInfo is used for local Ids, which shouldn't need any CgInfo
 noCgInfo = NoCgInfo
        -- noCgInfo is used for local Ids, which shouldn't need any CgInfo
 noCgInfo = NoCgInfo

-#else
-noCgInfo = panic "NoCgInfo!"

 #endif
 
 #endif
 

-cgArity   (CgInfo arity _)    = arity
-cgCafInfo (CgInfo _ caf_info) = caf_info
-
-setCafInfo info caf_info = 
-  case cgInfo info of { CgInfo arity _  -> 
-       info `setCgInfo` CgInfo arity caf_info }
+cgCafInfo (CgInfo caf_info) = caf_info

 
 

-setCgArity info arity = 
-  case cgInfo info of { CgInfo _ caf_info  -> 
-       info `setCgInfo` CgInfo arity caf_info }
+setCafInfo info caf_info = info `setCgInfo` CgInfo caf_info 

 
 seqCg c = c `seq` ()  -- fields are strict anyhow
 
 
 seqCg c = c `seq` ()  -- fields are strict anyhow
 

-vanillaCgInfo = CgInfo 0 MayHaveCafRefs                -- Definitely safe
+vanillaCgInfo = CgInfo MayHaveCafRefs          -- Definitely safe

 
 -- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs).
 
 
 -- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs).
 

@@ -583,7 +572,7 @@ mayHaveCafRefs _           = False
 
 seqCaf c = c `seq` ()
 
 
 seqCaf c = c `seq` ()
 

-pprCgInfo (CgInfo arity caf_info) = ppArity arity <+> ppCafInfo caf_info
+pprCgInfo (CgInfo caf_info) = ppCafInfo caf_info

 
 ppArity 0 = empty
 ppArity n = hsep [ptext SLIT("__A"), int n]
 
 ppArity 0 = empty
 ppArity n = hsep [ptext SLIT("__A"), int n]

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 7fc7804..75060e9 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -71,10 +71,10 @@ import Id           ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
                        )
 import IdInfo          ( IdInfo, noCafNoTyGenIdInfo,
                          setUnfoldingInfo, 
                        )
 import IdInfo          ( IdInfo, noCafNoTyGenIdInfo,
                          setUnfoldingInfo, 

-                         setArityInfo, setSpecInfo,  setCgInfo,
+                         setArityInfo, setSpecInfo,  setCgInfo, setCafInfo,

                          mkNewStrictnessInfo, setNewStrictnessInfo,
                          GlobalIdDetails(..), CafInfo(..), CprInfo(..), 
                          mkNewStrictnessInfo, setNewStrictnessInfo,
                          GlobalIdDetails(..), CafInfo(..), CprInfo(..), 

-                         CgInfo(..), setCgArity
+                         CgInfo 

                        )
 import NewDemand       ( mkStrictSig, strictSigResInfo, DmdResult(..),
                          mkTopDmdType, topDmd, evalDmd, Demand(..), Keepity(..) )
                        )
 import NewDemand       ( mkStrictSig, strictSigResInfo, DmdResult(..),
                          mkTopDmdType, topDmd, evalDmd, Demand(..), Keepity(..) )

@@ -145,7 +145,6 @@ mkDataConId work_name data_con
   = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
   where
     info = noCafNoTyGenIdInfo
   = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
   where
     info = noCafNoTyGenIdInfo

-          `setCgArity`                 arity

           `setArityInfo`               arity
           `setNewStrictnessInfo`       Just strict_sig
 
           `setArityInfo`               arity
           `setNewStrictnessInfo`       Just strict_sig
 

@@ -234,7 +233,6 @@ mkDataConWrapId data_con
 
     info = noCafNoTyGenIdInfo
           `setUnfoldingInfo`   mkTopUnfolding (mkInlineMe wrap_rhs)
 
     info = noCafNoTyGenIdInfo
           `setUnfoldingInfo`   mkTopUnfolding (mkInlineMe wrap_rhs)

-          `setCgArity`         arity

                -- The NoCaf-ness is set by noCafNoTyGenIdInfo
           `setArityInfo`       arity
                -- It's important to specify the arity, so that partial
                -- The NoCaf-ness is set by noCafNoTyGenIdInfo
           `setArityInfo`       arity
                -- It's important to specify the arity, so that partial

@@ -433,7 +431,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
        -- With all this unpackery it's not easy!
 
     info = noCafNoTyGenIdInfo
        -- With all this unpackery it's not easy!
 
     info = noCafNoTyGenIdInfo

-          `setCgInfo`            CgInfo arity caf_info
+          `setCafInfo`           caf_info

           `setArityInfo`         arity
           `setUnfoldingInfo`     mkTopUnfolding rhs_w_str
           `setNewStrictnessInfo` Just strict_sig
           `setArityInfo`         arity
           `setUnfoldingInfo`     mkTopUnfolding rhs_w_str
           `setNewStrictnessInfo` Just strict_sig

@@ -570,7 +568,6 @@ mkDictSelId name clas
     tag       = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
 
     info      = noCafNoTyGenIdInfo
     tag       = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
 
     info      = noCafNoTyGenIdInfo

-               `setCgArity`            1

                `setArityInfo`          1
                `setUnfoldingInfo`      mkTopUnfolding rhs
                `setNewStrictnessInfo`  Just strict_sig
                `setArityInfo`          1
                `setUnfoldingInfo`      mkTopUnfolding rhs
                `setNewStrictnessInfo`  Just strict_sig

@@ -630,7 +627,6 @@ mkPrimOpId prim_op
                
     info = noCafNoTyGenIdInfo
           `setSpecInfo`        rules
                
     info = noCafNoTyGenIdInfo
           `setSpecInfo`        rules

-          `setCgArity`         arity

           `setArityInfo`       arity
           `setNewStrictnessInfo`       Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
        -- Until we modify the primop generation code
           `setArityInfo`       arity
           `setNewStrictnessInfo`       Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
        -- Until we modify the primop generation code

@@ -661,7 +657,6 @@ mkFCallId uniq fcall ty
     name = mkFCallName uniq occ_str
 
     info = noCafNoTyGenIdInfo
     name = mkFCallName uniq occ_str
 
     info = noCafNoTyGenIdInfo

-          `setCgArity`                 arity

           `setArityInfo`               arity
           `setNewStrictnessInfo`       Just strict_sig
 
           `setArityInfo`               arity
           `setNewStrictnessInfo`       Just strict_sig
 

diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index ee5b37b..6666b14 100644 (file)
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -9,22 +9,17 @@ module CgConTbls ( genStaticConBits ) where
 #include "HsVersions.h"
 
 import AbsCSyn
 #include "HsVersions.h"
 
 import AbsCSyn

-import StgSyn

 import CgMonad
 
 import AbsCUtils       ( mkAbstractCs, mkAbsCStmts )
 import CostCentre      ( subsumedCCS )
 import CgMonad
 
 import AbsCUtils       ( mkAbstractCs, mkAbsCStmts )
 import CostCentre      ( subsumedCCS )

-import CgCon           ( cgTopRhsCon )
-import CgClosure       ( cgTopRhsClosure )

 import CgTailCall      ( performReturn, mkStaticAlgReturnCode )
 import CgTailCall      ( performReturn, mkStaticAlgReturnCode )

-import ClosureInfo     ( layOutStaticConstr, layOutDynConstr, mkClosureLFInfo, ClosureInfo )
-import DataCon         ( DataCon, dataConName, dataConRepArgTys, dataConId, isNullaryDataCon )
-import Id              ( mkTemplateLocals )
+import ClosureInfo     ( layOutStaticConstr, layOutDynConstr, ClosureInfo )
+import DataCon         ( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon )

 import Name            ( getOccName )
 import OccName         ( occNameUserString )
 import TyCon           ( tyConDataCons, isEnumerationTyCon, TyCon )
 import Type            ( typePrimRep )
 import Name            ( getOccName )
 import OccName         ( occNameUserString )
 import TyCon           ( tyConDataCons, isEnumerationTyCon, TyCon )
 import Type            ( typePrimRep )

-import BasicTypes      ( TopLevelFlag(..) )

 import Outputable
 \end{code}
 
 import Outputable
 \end{code}
 

@@ -114,8 +109,7 @@ genConInfo comp_info data_con
   =    -- Order of things is to reduce forward references
     mkAbstractCs [CSplitMarker,
                  closure_code,
   =    -- Order of things is to reduce forward references
     mkAbstractCs [CSplitMarker,
                  closure_code,

-                 static_code,
-                 wrkr_code]
+                 static_code]

   where
     (closure_info, body_code) = mkConCodeAndInfo data_con
 
   where
     (closure_info, body_code) = mkConCodeAndInfo data_con
 

@@ -128,7 +122,6 @@ genConInfo comp_info data_con
                      profCtrC SLIT("TICK_ENT_CON") [CReg node] `thenC`
                      body_code)
 
                      profCtrC SLIT("TICK_ENT_CON") [CReg node] `thenC`
                      body_code)
 

-    wrkr_code  = initC comp_info (cgWorker data_con `thenFC` \ _ -> returnFC ())

     con_descr  = occNameUserString (getOccName data_con)
 
     -- Don't need any dynamic closure code for zero-arity constructors
     con_descr  = occNameUserString (getOccName data_con)
 
     -- Don't need any dynamic closure code for zero-arity constructors

@@ -169,27 +162,3 @@ mkConCodeAndInfo con
        in
        (closure_info, body_code)
 \end{code}
        in
        (closure_info, body_code)
 \end{code}

-
-For a constructor C, make a binding
-
-       $wC = \x y -> $wC x y
-
-i.e. a curried constructor that allocates.  This means that we can treat
-the worker for a constructor like any other function in the rest of the compiler.
-
-\begin{code}
-cgWorker data_con
-  | isNullaryDataCon data_con
-  = cgTopRhsCon work_id data_con []
-
-  | otherwise
-  = cgTopRhsClosure work_id
-           subsumedCCS noBinderInfo NoSRT
-           arg_ids rhs
-           lf_info
-  where
-    work_id = dataConId data_con
-    arg_ids = mkTemplateLocals (dataConRepArgTys data_con)
-    rhs     = StgConApp data_con [StgVarArg id | id <- arg_ids]
-    lf_info = mkClosureLFInfo work_id TopLevel [{-no fvs-}] ReEntrant arg_ids
-\end{code}

diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 6ba2ec0..b7e6ace 100644 (file)
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %

-% $Id: ClosureInfo.lhs,v 1.48 2001/09/26 15:11:50 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.49 2001/10/18 16:29:13 simonpj Exp $

 %
 \section[ClosureInfo]{Data structures which describe closures}
 
 %
 \section[ClosureInfo]{Data structures which describe closures}
 

@@ -77,7 +77,7 @@ import CLabel         ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
 import CmdLineOpts     ( opt_SccProfilingOn, opt_OmitBlackHoling,
                          opt_Parallel, opt_DoTickyProfiling,
                          opt_SMP )
 import CmdLineOpts     ( opt_SccProfilingOn, opt_OmitBlackHoling,
                          opt_Parallel, opt_DoTickyProfiling,
                          opt_SMP )

-import Id              ( Id, idType, idCgArity )
+import Id              ( Id, idType, idArity )

 import DataCon         ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
                          isNullaryDataCon, dataConName
                        )
 import DataCon         ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
                          isNullaryDataCon, dataConName
                        )

@@ -249,7 +249,7 @@ mkLFLetNoEscape = LFLetNoEscape
 
 mkLFImported :: Id -> LambdaFormInfo
 mkLFImported id
 
 mkLFImported :: Id -> LambdaFormInfo
 mkLFImported id

-  = case idCgArity id of
+  = case idArity id of

       n | n > 0 -> LFReEntrant (idType id) TopLevel n True  -- n > 0
       other -> LFImported      -- Not sure of exact arity
 \end{code}
       n | n > 0 -> LFReEntrant (idType id) TopLevel n True  -- n > 0
       other -> LFImported      -- Not sure of exact arity
 \end{code}

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index 36495d2..eb543a3 100644 (file)
--- a/ghc/compiler/coreSyn/CorePrep.lhs
+++ b/ghc/compiler/coreSyn/CorePrep.lhs
@@ -24,9 +24,11 @@ import VarSet
 import VarEnv
 import Id      ( mkSysLocal, idType, idNewDemandInfo, idArity,
                  setIdType, isPrimOpId_maybe, isFCallId, isGlobalId, 
 import VarEnv
 import Id      ( mkSysLocal, idType, idNewDemandInfo, idArity,
                  setIdType, isPrimOpId_maybe, isFCallId, isGlobalId, 

-                 hasNoBinding, idNewStrictness, setIdArity
+                 hasNoBinding, idNewStrictness, 
+                 isDataConId_maybe, idUnfolding

                )
                )

-import HscTypes ( ModDetails(..) )
+import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
+import Unique  ( mkBuiltinUnique )

 import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNotTopLevel,
                    RecFlag(..), isNonRec
                  )
 import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNotTopLevel,
                    RecFlag(..), isNonRec
                  )

@@ -72,13 +74,19 @@ The goal of this pass is to prepare for code generation.
 7.  Give each dynamic CCall occurrence a fresh unique; this is
     rather like the cloning step above.
 
 7.  Give each dynamic CCall occurrence a fresh unique; this is
     rather like the cloning step above.
 

+8.  Inject bindings for the "implicit" Ids:
+       * Constructor wrappers
+       * Constructor workers
+       * Record selectors
+    We want curried definitions for all of these in case they
+    aren't inlined by some caller.
+       

 This is all done modulo type applications and abstractions, so that
 when type erasure is done for conversion to STG, we don't end up with
 any trivial or useless bindings.
 
   
 
 This is all done modulo type applications and abstractions, so that
 when type erasure is done for conversion to STG, we don't end up with
 any trivial or useless bindings.
 
   
 

-

 -- -----------------------------------------------------------------------------
 -- Top level stuff
 -- -----------------------------------------------------------------------------
 -- -----------------------------------------------------------------------------
 -- Top level stuff
 -- -----------------------------------------------------------------------------

@@ -89,13 +97,18 @@ corePrepPgm dflags mod_details
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
 
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
 

-       let floats    = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
-           new_binds = foldrOL get [] floats
-           get (FloatLet b) bs = b:bs
-           get b            bs = pprPanic "corePrepPgm" (ppr b)
+       let implicit_binds = mkImplicitBinds (md_types mod_details)
+               -- NB: we must feed mkImplicitBinds through corePrep too
+               -- so that they are suitably cloned and eta-expanded

 
 

-        endPass dflags "CorePrep" Opt_D_dump_prep new_binds
-       return (mod_details { md_binds = new_binds })
+           binds_out = initUs_ us (
+                         corePrepTopBinds (md_binds mod_details)       `thenUs` \ floats1 ->
+                         corePrepTopBinds implicit_binds               `thenUs` \ floats2 ->
+                         returnUs (deFloatTop (floats1 `appOL` floats2))
+                       )
+           
+        endPass dflags "CorePrep" Opt_D_dump_prep binds_out
+       return (mod_details { md_binds = binds_out })

 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 corePrepExpr dflags expr
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 corePrepExpr dflags expr

@@ -105,7 +118,52 @@ corePrepExpr dflags expr
        dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" 
                     (ppr new_expr)
        return new_expr
        dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" 
                     (ppr new_expr)
        return new_expr

+\end{code}
+
+-- -----------------------------------------------------------------------------
+-- Implicit bindings
+-- -----------------------------------------------------------------------------
+
+Create any necessary "implicit" bindings (data constructors etc).
+Namely:
+       * Constructor workers
+       * Constructor wrappers
+       * Data type record selectors
+       * Class op selectors
+
+In the latter three cases, the Id contains the unfolding to use for
+the binding.  In the case of data con workers we create the rather 
+strange (non-recursive!) binding
+
+       $wC = \x y -> $wC x y
+
+i.e. a curried constructor that allocates.  This means that we can
+treat the worker for a constructor like any other function in the rest
+of the compiler.  The point here is that CoreToStg will generate a
+StgConApp for the RHS, rather than a call to the worker (which would
+give a loop).  As Lennart says: the ice is thin here, but it works.
+
+Hmm.  Should we create bindings for dictionary constructors?  They are
+always fully applied, and the bindings are just there to support
+partial applications. But it's easier to let them through.
+
+\begin{code}
+mkImplicitBinds type_env
+  = [ NonRec id (get_unfolding id)
+    | id <- implicitTyThingIds (typeEnvElts type_env) ]
+       -- The etaExpand is so that the manifest arity of the
+       -- binding matches its claimed arity, which is an 
+       -- invariant of top level bindings going into the code gen
+  where
+    tmpl_uniqs = map mkBuiltinUnique [1..]

 
 

+get_unfolding id       -- See notes above
+  | Just data_con <- isDataConId_maybe id = Var id     -- The ice is thin here, but it works
+  | otherwise                            = unfoldingTemplate (idUnfolding id)
+\end{code}
+       
+
+\begin{code}

 -- ---------------------------------------------------------------------------
 -- Dealing with bindings
 -- ---------------------------------------------------------------------------
 -- ---------------------------------------------------------------------------
 -- Dealing with bindings
 -- ---------------------------------------------------------------------------

@@ -120,6 +178,14 @@ instance Outputable FloatingBind where
 
 type CloneEnv = IdEnv Id       -- Clone local Ids
 
 
 type CloneEnv = IdEnv Id       -- Clone local Ids
 

+deFloatTop :: OrdList FloatingBind -> [CoreBind]
+-- For top level only; we don't expect any FloatCases
+deFloatTop floats
+  = foldrOL get [] floats
+  where
+    get (FloatLet b) bs = b:bs
+    get b           bs = pprPanic "corePrepPgm" (ppr b)
+

 allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
 allLazy top_lvl is_rec floats 
   = foldrOL check True floats
 allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
 allLazy top_lvl is_rec floats 
   = foldrOL check True floats

@@ -137,13 +203,14 @@ allLazy top_lvl is_rec floats
 --                     Bindings
 -- ---------------------------------------------------------------------------
 
 --                     Bindings
 -- ---------------------------------------------------------------------------
 

-corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM (OrdList FloatingBind)
-corePrepTopBinds env [] = returnUs nilOL
-
-corePrepTopBinds env (bind : binds)
-  = corePrepTopBind env bind           `thenUs` \ (env', bind') ->
-    corePrepTopBinds env' binds                `thenUs` \ binds' ->
-    returnUs (bind' `appOL` binds')
+corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
+corePrepTopBinds binds 
+  = go emptyVarEnv binds
+  where
+    go env []            = returnUs nilOL
+    go env (bind : binds) = corePrepTopBind env bind   `thenUs` \ (env', bind') ->
+                           go env' binds               `thenUs` \ binds' ->
+                           returnUs (bind' `appOL` binds')

 
 -- NB: we do need to float out of top-level bindings
 -- Consider    x = length [True,False]
 
 -- NB: we do need to float out of top-level bindings
 -- Consider    x = length [True,False]

@@ -159,6 +226,7 @@ corePrepTopBinds env (bind : binds)
 --     x* = f a
 -- And then x will actually end up case-bound
 
 --     x* = f a
 -- And then x will actually end up case-bound
 

+--------------------------------

 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
 corePrepTopBind env (NonRec bndr rhs) 
   = cloneBndr env bndr                                 `thenUs` \ (env', bndr') ->
 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
 corePrepTopBind env (NonRec bndr rhs) 
   = cloneBndr env bndr                                 `thenUs` \ (env', bndr') ->

@@ -167,6 +235,7 @@ corePrepTopBind env (NonRec bndr rhs)
 
 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
 
 
 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
 

+--------------------------------

 corePrepBind ::  CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
        -- This one is used for *local* bindings
 corePrepBind env (NonRec bndr rhs)
 corePrepBind ::  CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
        -- This one is used for *local* bindings
 corePrepBind env (NonRec bndr rhs)

@@ -217,14 +286,12 @@ corePrepArg env arg dem
   = corePrepExprFloat env arg          `thenUs` \ (floats, arg') ->
     if exprIsTrivial arg'
     then returnUs (floats, arg')
   = corePrepExprFloat env arg          `thenUs` \ (floats, arg') ->
     if exprIsTrivial arg'
     then returnUs (floats, arg')

-    else newVar (exprType arg') (exprArity arg')       `thenUs` \ v ->
-        mkLocalNonRec v dem floats arg'                `thenUs` \ floats' -> 
+    else newVar (exprType arg')                        `thenUs` \ v ->
+        mkLocalNonRec v dem floats arg'        `thenUs` \ floats' -> 

         returnUs (floats', Var v)
 
 -- version that doesn't consider an scc annotation to be trivial.
         returnUs (floats', Var v)
 
 -- version that doesn't consider an scc annotation to be trivial.

-exprIsTrivial (Var v)
-  | hasNoBinding v                    = idArity v == 0
-  | otherwise                          = True
+exprIsTrivial (Var v)                 = True

 exprIsTrivial (Type _)                = True
 exprIsTrivial (Lit lit)               = True
 exprIsTrivial (App e arg)             = isTypeArg arg && exprIsTrivial e
 exprIsTrivial (Type _)                = True
 exprIsTrivial (Lit lit)               = True
 exprIsTrivial (App e arg)             = isTypeArg arg && exprIsTrivial e

@@ -369,7 +436,7 @@ corePrepExprFloat env expr@(App _ _)
        -- non-variable fun, better let-bind it
     collect_args fun depth
        = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->
        -- non-variable fun, better let-bind it
     collect_args fun depth
        = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->

-         newVar ty (exprArity fun')                    `thenUs` \ fn_id ->
+         newVar ty                                     `thenUs` \ fn_id ->

           mkLocalNonRec fn_id onceDem fun_floats fun'  `thenUs` \ floats ->
          returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
         where
           mkLocalNonRec fn_id onceDem fun_floats fun'  `thenUs` \ floats ->
          returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
         where

@@ -444,6 +511,10 @@ mkLocalNonRec bndr dem floats rhs
   = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)       `thenUs` \ (floats', rhs') ->
     returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
 
   = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)       `thenUs` \ (floats', rhs') ->
     returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
 

+  where
+    bndr_ty     = idType bndr
+    bndr_rep_ty  = repType bndr_ty
+

 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
 mkBinds binds body 
   | isNilOL binds = returnUs body
 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
 mkBinds binds body 
   | isNilOL binds = returnUs body

@@ -484,7 +555,13 @@ etaExpandRhs bndr rhs
        --              f = /\a -> \y -> let s = h 3 in g s y
        --
     getUniquesUs               `thenUs` \ us ->
        --              f = /\a -> \y -> let s = h 3 in g s y
        --
     getUniquesUs               `thenUs` \ us ->

-    returnUs (etaExpand (idArity bndr) us rhs (idType bndr))
+    returnUs (etaExpand arity us rhs (idType bndr))
+  where
+       -- For a GlobalId, take the Arity from the Id.
+       -- It was set in CoreTidy and must not change
+       -- For all others, just expand at will
+    arity | isGlobalId bndr = idArity bndr
+         | otherwise       = exprArity rhs

 
 -- ---------------------------------------------------------------------------
 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 
 -- ---------------------------------------------------------------------------
 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)

@@ -505,7 +582,7 @@ deLam expr
   | otherwise 
   = case tryEta bndrs body of
       Just no_lam_result -> returnUs no_lam_result
   | otherwise 
   = case tryEta bndrs body of
       Just no_lam_result -> returnUs no_lam_result

-      Nothing           -> newVar (exprType expr) (exprArity expr) `thenUs` \ fn ->
+      Nothing           -> newVar (exprType expr)      `thenUs` \ fn ->

                            returnUs (Let (NonRec fn expr) (Var fn))
   where
     (bndrs,body) = collectBinders expr
                            returnUs (Let (NonRec fn expr) (Var fn))
   where
     (bndrs,body) = collectBinders expr

@@ -677,12 +754,9 @@ fiddleCCall id
 -- Generating new binders
 -- ---------------------------------------------------------------------------
 
 -- Generating new binders
 -- ---------------------------------------------------------------------------
 

-newVar :: Type -> Arity -> UniqSM Id
--- We're creating a new let binder, and we must give
--- it the right arity for the benefit of the code generator.
-newVar ty arity
+newVar :: Type -> UniqSM Id
+newVar ty

  = seqType ty                  `seq`
    getUniqueUs                 `thenUs` \ uniq ->
  = seqType ty                  `seq`
    getUniqueUs                 `thenUs` \ uniq ->

-   returnUs (mkSysLocal SLIT("sat") uniq ty
-            `setIdArity` arity)
+   returnUs (mkSysLocal SLIT("sat") uniq ty)

 \end{code}
 \end{code}

diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index 4e1a4d5..bc3dd71 100644 (file)
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -21,11 +21,9 @@ import VarEnv
 import VarSet
 import Var             ( Id, Var )
 import Id              ( idType, idInfo, idName, isExportedId, 
 import VarSet
 import Var             ( Id, Var )
 import Id              ( idType, idInfo, idName, isExportedId, 

-                         idSpecialisation, idUnique, isDataConWrapId,
-                         mkVanillaGlobal, mkGlobalId, isLocalId, 
-                         isDataConId, mkUserLocal, isGlobalId, globalIdDetails,
-                         idNewDemandInfo, setIdNewDemandInfo, setIdCgInfo,
-                         idNewStrictness, setIdNewStrictness
+                         idSpecialisation, idUnique, 
+                         mkVanillaGlobal, isLocalId, 
+                         isImplicitId, mkUserLocal, setIdInfo

                        ) 
 import IdInfo          {- loads of stuff -}
 import NewDemand       ( isBottomingSig, topSig )
                        ) 
 import IdInfo          {- loads of stuff -}
 import NewDemand       ( isBottomingSig, topSig )

@@ -40,7 +38,7 @@ import Module         ( Module, moduleName )
 import HscTypes                ( PersistentCompilerState( pcs_PRS ), 
                          PersistentRenamerState( prsOrig ),
                          NameSupply( nsNames, nsUniqs ),
 import HscTypes                ( PersistentCompilerState( pcs_PRS ), 
                          PersistentRenamerState( prsOrig ),
                          NameSupply( nsNames, nsUniqs ),

-                         TypeEnv, extendTypeEnvList, 
+                         TypeEnv, extendTypeEnvList, typeEnvIds,

                          ModDetails(..), TyThing(..)
                        )
 import FiniteMap       ( lookupFM, addToFM )
                          ModDetails(..), TyThing(..)
                        )
 import FiniteMap       ( lookupFM, addToFM )

@@ -151,11 +149,18 @@ tidyCorePgm dflags mod pcs cg_info_env
                orig_ns       = prsOrig prs
 
                init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)
                orig_ns       = prsOrig prs
 
                init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)

-               avoids        = [getOccName bndr | bndr <- bindersOfBinds binds_in,
-                                                  isGlobalName (idName bndr)]
+               avoids        = [getOccName name | bndr <- typeEnvIds env_tc,
+                                                  let name = idName bndr,
+                                                  isGlobalName name]
+               -- In computing our "avoids" list, we must include
+               --      all implicit Ids
+               --      all things with global names (assigned once and for
+               --                                      all by the renamer)
+               -- since their names are "taken".
+               -- The type environment is a convenient source of such things.

 
        ; let ((orig_ns', occ_env, subst_env), tidy_binds) 
 
        ; let ((orig_ns', occ_env, subst_env), tidy_binds) 

-                       = mapAccumL (tidyTopBind mod ext_ids) 
+                       = mapAccumL (tidyTopBind mod ext_ids cg_info_env) 

                                    init_tidy_env binds_in
 
        ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
                                    init_tidy_env binds_in
 
        ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules

@@ -163,7 +168,7 @@ tidyCorePgm dflags mod pcs cg_info_env
        ; let prs' = prs { prsOrig = orig_ns' }
              pcs' = pcs { pcs_PRS = prs' }
 
        ; let prs' = prs { prsOrig = orig_ns' }
              pcs' = pcs { pcs_PRS = prs' }
 

-       ; let final_ids  = [ addCgInfo cg_info_env id 
+       ; let final_ids  = [ id 

                           | bind <- tidy_binds
                           , id <- bindersOf bind
                           , isGlobalName (idName id)]
                           | bind <- tidy_binds
                           , id <- bindersOf bind
                           , isGlobalName (idName id)]

@@ -190,16 +195,6 @@ tidyCorePgm dflags mod pcs cg_info_env
        ; return (pcs', tidy_details)
        }
 
        ; return (pcs', tidy_details)
        }
 

-addCgInfo :: CgInfoEnv -> Id -> Id
--- Pin on the info that comes from the code generator
--- This doesn't make its way into the *bindings* that 
--- go on to the code generator (that might give black holes etc)
--- Rather, it's pinned onto the Id in the type environment 
--- that (a) generates the interface file
---     (b) in GHCi goes into subsequent compilations
-addCgInfo cg_info_env id 
-  = id `setIdCgInfo` lookupCgInfo cg_info_env (idName id)
-

 tidyCoreExpr :: CoreExpr -> IO CoreExpr
 tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr)
 \end{code}
 tidyCoreExpr :: CoreExpr -> IO CoreExpr
 tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr)
 \end{code}

@@ -235,9 +230,9 @@ mkFinalTypeEnv type_env final_ids
        -- in interface files, because they are needed by importing modules when
        -- using the compilation manager
 
        -- in interface files, because they are needed by importing modules when
        -- using the compilation manager
 

-       -- We keep constructor workers, 
-       -- because they won't appear in the bindings from which final_ids are derived!
-    keep_it (AnId id) = isDataConId id -- Remove all Ids except constructor workers
+       -- We keep implicit Ids, because they won't appear 
+       -- in the bindings from which final_ids are derived!
+    keep_it (AnId id) = isImplicitId id        -- Remove all Ids except implicit ones

     keep_it other     = True           -- Keep all TyCons and Classes
 \end{code}
 
     keep_it other     = True           -- Keep all TyCons and Classes
 \end{code}
 

@@ -386,18 +381,20 @@ type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var)
 tidyTopBind :: Module
            -> IdEnv Bool       -- Domain = Ids that should be external
                                -- True <=> their unfolding is external too
 tidyTopBind :: Module
            -> IdEnv Bool       -- Domain = Ids that should be external
                                -- True <=> their unfolding is external too

+           -> CgInfoEnv

            -> TopTidyEnv -> CoreBind
            -> (TopTidyEnv, CoreBind)
 
            -> TopTidyEnv -> CoreBind
            -> (TopTidyEnv, CoreBind)
 

-tidyTopBind mod ext_ids top_tidy_env (NonRec bndr rhs)
+tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs)

   = ((orig,occ,subst) , NonRec bndr' rhs')
   where
     ((orig,occ,subst), bndr')
   = ((orig,occ,subst) , NonRec bndr' rhs')
   where
     ((orig,occ,subst), bndr')

-        = tidyTopBinder mod ext_ids rec_tidy_env rhs' top_tidy_env bndr
+        = tidyTopBinder mod ext_ids cg_info_env 
+                        rec_tidy_env rhs' top_tidy_env bndr

     rec_tidy_env = (occ,subst)
     rhs' = tidyExpr rec_tidy_env rhs
 
     rec_tidy_env = (occ,subst)
     rhs' = tidyExpr rec_tidy_env rhs
 

-tidyTopBind mod ext_ids top_tidy_env (Rec prs)
+tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs)

   = (final_env, Rec prs')
   where
     (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
   = (final_env, Rec prs')
   where
     (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs

@@ -407,12 +404,12 @@ tidyTopBind mod ext_ids top_tidy_env (Rec prs)
        = ((orig,occ,subst), (bndr',rhs'))
        where
        ((orig,occ,subst), bndr')
        = ((orig,occ,subst), (bndr',rhs'))
        where
        ((orig,occ,subst), bndr')

-          = tidyTopBinder mod ext_ids
+          = tidyTopBinder mod ext_ids cg_info_env

                rec_tidy_env rhs' top_tidy_env bndr
 
         rhs' = tidyExpr rec_tidy_env rhs
 
                rec_tidy_env rhs' top_tidy_env bndr
 
         rhs' = tidyExpr rec_tidy_env rhs
 

-tidyTopBinder :: Module -> IdEnv Bool
+tidyTopBinder :: Module -> IdEnv Bool -> CgInfoEnv

              -> TidyEnv -> CoreExpr
                        -- The TidyEnv is used to tidy the IdInfo
                        -- The expr is the already-tided RHS
              -> TidyEnv -> CoreExpr
                        -- The TidyEnv is used to tidy the IdInfo
                        -- The expr is the already-tided RHS

@@ -420,34 +417,10 @@ tidyTopBinder :: Module -> IdEnv Bool
              -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
   -- NB: tidyTopBinder doesn't affect the unique supply
 
              -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
   -- NB: tidyTopBinder doesn't affect the unique supply
 

-tidyTopBinder mod ext_ids tidy_env rhs
+tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs

              env@(ns2, occ_env2, subst_env2) id
              env@(ns2, occ_env2, subst_env2) id

-
-  | isDataConWrapId id -- Don't tidy constructor wrappers
-  = (env, id)          -- The Id is stored in the TyCon, so it would be bad
-                       -- if anything changed
-
--- HACK ALERT: we *do* tidy record selectors.  Reason: they mention error
--- messages, which may be floated out:
---     x_field pt = case pt of
---                     Rect x y -> y
---                     Pol _ _  -> error "buggle wuggle"
--- The error message will be floated out so we'll get
---     lvl5 = error "buggle wuggle"
---     x_field pt = case pt of
---                     Rect x y -> y
---                     Pol _ _  -> lvl5
---
--- When this happens, it's vital that the Id exposed to importing modules
--- (by ghci) mentions lvl5 in its unfolding, not the un-tidied version.
--- 
--- What about the Id in the TyCon?  It probably shouldn't be in the TyCon at
--- all, but in any case it will have the error message inline so it won't matter.
-
-
-  | otherwise

        -- This function is the heart of Step 2
        -- This function is the heart of Step 2

-       -- The second env is the one to use for the IdInfo
+       -- The rec_tidy_env is the one to use for the IdInfo

        -- It's necessary because when we are dealing with a recursive
        -- group, a variable late in the group might be mentioned
        -- in the IdInfo of one early in the group
        -- It's necessary because when we are dealing with a recursive
        -- group, a variable late in the group might be mentioned
        -- in the IdInfo of one early in the group

@@ -459,13 +432,12 @@ tidyTopBinder mod ext_ids tidy_env rhs
     (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2
                                               is_external
                                               (idName id)
     (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2
                                               is_external
                                               (idName id)

-    ty'            = tidyTopType (idType id)
-    idinfo' = tidyIdInfo tidy_env is_external unfold_info id
+    ty'           = tidyTopType (idType id)
+    idinfo = tidyTopIdInfo rec_tidy_env is_external 
+                          (idInfo id) unfold_info
+                          (lookupCgInfo cg_info_env name')

 
 

-    id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo'
-       | otherwise     = mkVanillaGlobal                 name' ty' idinfo'
-       -- The test ensures that record selectors (which must be tidied; see above)
-       -- retain their details.  If it's forgotten, importing modules get confused.
+    id' = mkVanillaGlobal name' ty' idinfo

 
     subst_env' = extendVarEnv subst_env2 id id'
 
 
     subst_env' = extendVarEnv subst_env2 id id'
 

@@ -478,26 +450,46 @@ tidyTopBinder mod ext_ids tidy_env rhs
                | otherwise   = noUnfolding
 
 
                | otherwise   = noUnfolding
 
 

-tidyIdInfo tidy_env is_external unfold_info id
+-- tidyTopIdInfo creates the final IdInfo for top-level
+-- binders.  There are two delicate pieces:
+--
+--  * Arity.  We assume that the simplifier has just run, so
+--     that there is a reasonable arity on each binder.
+--     After CoreTidy, this arity must not change any more.
+--     Indeed, CorePrep must eta expand where necessary to make
+--     the manifest arity equal to the claimed arity.
+--
+-- * CAF info, which comes from the CoreToStg pass via a knot.
+--     The CAF info will not be looked at by the downstream stuff:
+--     it *generates* it, and knot-ties it back.  It will only be
+--     looked at by (a) MkIface when generating an interface file
+--                  (b) In GHCi, importing modules
+--     Nevertheless, we add the info here so that it propagates to all
+--     occurrences of the binders in RHSs, and hence to occurrences in
+--     unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
+--     
+--     An alterative would be to do a second pass over the unfoldings 
+--     of Ids, and rules, right at the top, but that would be a pain.
+
+tidyTopIdInfo tidy_env is_external idinfo unfold_info cg_info

   | opt_OmitInterfacePragmas || not is_external
   | opt_OmitInterfacePragmas || not is_external

-       -- No IdInfo if the Id isn't external, or if we don't have -O
-  = vanillaIdInfo 
-       `setArityInfo`         arityInfo core_idinfo
-       `setNewStrictnessInfo` newStrictnessInfo core_idinfo
-       -- Keep strictness and arity; both are used by CorePrep
+       -- Only basic info if the Id isn't external, or if we don't have -O
+  = basic_info

 
 

-  | otherwise
-  =  vanillaIdInfo 
-       `setArityInfo`         arityInfo core_idinfo
-       `setNewStrictnessInfo` newStrictnessInfo core_idinfo
-       `setInlinePragInfo`    inlinePragInfo core_idinfo
+  | otherwise  -- Add extra optimisation info
+  = basic_info
+       `setInlinePragInfo`    inlinePragInfo idinfo

        `setUnfoldingInfo`     unfold_info
        `setUnfoldingInfo`     unfold_info

-       `setWorkerInfo`        tidyWorker tidy_env (workerInfo core_idinfo)
-       -- NB: we throw away the Rules
-       -- They have already been extracted by findExternalRules
+       `setWorkerInfo`        tidyWorker tidy_env (workerInfo idinfo)
+               -- NB: we throw away the Rules
+               -- They have already been extracted by findExternalRules
+  

   where
   where

-    core_idinfo = idInfo id
-
+       -- baasic_info is attached to every top-level binder
+    basic_info = vanillaIdInfo 
+                       `setCgInfo`            cg_info
+                       `setArityInfo`         arityInfo idinfo
+                       `setNewStrictnessInfo` newStrictnessInfo idinfo

 
 -- This is where we set names to local/global based on whether they really are 
 -- externally visible (see comment at the top of this module).  If the name
 
 -- This is where we set names to local/global based on whether they really are 
 -- externally visible (see comment at the top of this module).  If the name

@@ -523,7 +515,9 @@ tidyTopName mod ns occ_env external name
                           Nothing   -> (ns { nsUniqs = us2, nsNames = ns_names' }, occ_env', global_name)
        -- If we want to globalise a currently-local name, check
        -- whether we have already assigned a unique for it.
                           Nothing   -> (ns { nsUniqs = us2, nsNames = ns_names' }, occ_env', global_name)
        -- If we want to globalise a currently-local name, check
        -- whether we have already assigned a unique for it.

-       -- If so, use it; if not, extend the table
+       -- If so, use it; if not, extend the table.
+       -- This is needed when *re*-compiling a module in GHCi; we want to
+       -- use the same name for externally-visible things as we did before.

 
   where
     global          = isGlobalName name
 
   where
     global          = isGlobalName name

@@ -647,8 +641,14 @@ tidyLetBndr env (id,rhs)
        --
        -- Similarly for the demand info - on a let binder, this tells 
        -- CorePrep to turn the let into a case.
        --
        -- Similarly for the demand info - on a let binder, this tells 
        -- CorePrep to turn the let into a case.

-    final_id = new_id `setIdNewDemandInfo` idNewDemandInfo id
-                     `setIdNewStrictness` idNewStrictness id
+       --
+       -- Similarly arity info for eta expansion in CorePrep
+    final_id = new_id `setIdInfo` new_info
+    idinfo   = idInfo id
+    new_info = vanillaIdInfo 
+               `setArityInfo`          arityInfo idinfo
+               `setNewStrictnessInfo`  newStrictnessInfo idinfo
+               `setNewDemandInfo`      newDemandInfo idinfo

 
     -- Override the env we get back from tidyId with the new IdInfo
     -- so it gets propagated to the usage sites.
 
     -- Override the env we get back from tidyId with the new IdInfo
     -- so it gets propagated to the usage sites.

@@ -662,8 +662,8 @@ tidyIdBndr env@(tidy_env, var_env) id
        -- The SrcLoc isn't important now, 
        -- though we could extract it from the Id
        -- 
        -- The SrcLoc isn't important now, 
        -- though we could extract it from the Id
        -- 

-       -- All local Ids now have the same IdInfo, which should save some
-       -- space.
+       -- All nested Ids now have the same IdInfo, namely none,
+       -- which should save some space.

        (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
         ty'              = tidyType env (idType id)
        id'               = mkUserLocal occ' (idUnique id) ty' noSrcLoc
        (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
         ty'              = tidyType env (idType id)
        id'               = mkUserLocal occ' (idUnique id) ty' noSrcLoc

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index c8f800f..21bb2bf 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -19,10 +19,11 @@ module CoreUtils (
        exprIsValue,exprOkForSpeculation, exprIsBig, 
        exprIsConApp_maybe, exprIsAtom,
        idAppIsBottom, idAppIsCheap,
        exprIsValue,exprOkForSpeculation, exprIsBig, 
        exprIsConApp_maybe, exprIsAtom,
        idAppIsBottom, idAppIsCheap,

-       exprArity, 

 
 

-       -- Expr transformation
-       etaExpand, exprArity, exprEtaExpandArity, 
+
+       -- Arity and eta expansion
+       manifestArity, exprArity, 
+       exprEtaExpandArity, etaExpand, 

 
        -- Size
        coreBindsSize,
 
        -- Size
        coreBindsSize,

@@ -49,7 +50,7 @@ import DataCon                ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon,
 import PrimOp          ( primOpOkForSpeculation, primOpIsCheap )
 import Id              ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo, 
                          mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
 import PrimOp          ( primOpOkForSpeculation, primOpIsCheap )
 import Id              ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo, 
                          mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,

-                         isDataConId_maybe, mkSysLocal, hasNoBinding, isDataConId, isBottomingId
+                         isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId

                        )
 import IdInfo          ( LBVarInfo(..),  
                          GlobalIdDetails(..),
                        )
 import IdInfo          ( LBVarInfo(..),  
                          GlobalIdDetails(..),

@@ -298,26 +299,25 @@ findAlt con alts
 @exprIsBottom@ is true of expressions that are guaranteed to diverge
 
 
 @exprIsBottom@ is true of expressions that are guaranteed to diverge
 
 

+There used to be a gruesome test for (hasNoBinding v) in the
+Var case:
+       exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
+The idea here is that a constructor worker, like $wJust, is
+really short for (\x -> $wJust x), becuase $wJust has no binding.
+So it should be treated like a lambda.  Ditto unsaturated primops.
+But now constructor workers are not "have-no-binding" Ids.  And
+completely un-applied primops and foreign-call Ids are sufficiently
+rare that I plan to allow them to be duplicated and put up with
+saturating them.
+

 \begin{code}
 \begin{code}

-exprIsTrivial (Var v)
-  | hasNoBinding v                    = idArity v == 0
-       -- WAS: | Just op <- isPrimOpId_maybe v      = primOpIsDupable op
-       -- The idea here is that a constructor worker, like $wJust, is
-       -- really short for (\x -> $wJust x), becuase $wJust has no binding.
-       -- So it should be treated like a lambda.
-       -- Ditto unsaturated primops.
-       -- This came up when dealing with eta expansion/reduction for
-       --      x = $wJust
-       -- Here we want to eta-expand.  This looks like an optimisation,
-       -- but it's important (albeit tiresome) that CoreSat doesn't increase 
-       -- anything's arity
-  | otherwise                          = True
-exprIsTrivial (Type _)                = True
-exprIsTrivial (Lit lit)               = True
-exprIsTrivial (App e arg)             = not (isRuntimeArg arg) && exprIsTrivial e
-exprIsTrivial (Note _ e)              = exprIsTrivial e
-exprIsTrivial (Lam b body)             = not (isRuntimeVar b) && exprIsTrivial body
-exprIsTrivial other                   = False
+exprIsTrivial (Var v)     = True       -- See notes above
+exprIsTrivial (Type _)    = True
+exprIsTrivial (Lit lit)    = True
+exprIsTrivial (App e arg)  = not (isRuntimeArg arg) && exprIsTrivial e
+exprIsTrivial (Note _ e)   = exprIsTrivial e
+exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
+exprIsTrivial other       = False

 
 exprIsAtom :: CoreExpr -> Bool
 -- Used to decide whether to let-binding an STG argument
 
 exprIsAtom :: CoreExpr -> Bool
 -- Used to decide whether to let-binding an STG argument

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 5da7b8d..0a95cec 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -435,19 +435,14 @@ myCoreToStg dflags this_mod tidy_binds
           <- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds
 
       let env_rhs :: CgInfoEnv
           <- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds
 
       let env_rhs :: CgInfoEnv

-         env_rhs = mkNameEnv [ (idName bndr, CgInfo (stgRhsArity rhs) caf_info)
+         env_rhs = mkNameEnv [ (idName bndr, CgInfo caf_info)

                              | (bind,_) <- stg_binds2, 
                                let caf_info 
                                     | stgBindHasCafRefs bind = MayHaveCafRefs
                              | (bind,_) <- stg_binds2, 
                                let caf_info 
                                     | stgBindHasCafRefs bind = MayHaveCafRefs

-                                    | otherwise = NoCafRefs,
-                               (bndr,rhs) <- stgBindPairs bind ]
+                                    | otherwise              = NoCafRefs,
+                               bndr <- stgBinders bind ]

 
       return (stg_binds2, cost_centre_info, env_rhs)
 
       return (stg_binds2, cost_centre_info, env_rhs)

-   where
-      stgBindPairs (StgNonRec _ b r) = [(b,r)]
-      stgBindPairs (StgRec    _ prs) = prs
-
-

 \end{code}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 3c76b60..c29421c 100644 (file)
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -26,7 +26,7 @@ module HscTypes (
 
        TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv,
        extendTypeEnvList, extendTypeEnvWithIds,
 
        TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv,
        extendTypeEnvList, extendTypeEnvWithIds,

-       typeEnvClasses, typeEnvTyCons, typeEnvIds,
+       typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,

 
        ImportedModuleInfo, WhetherHasOrphans, ImportVersion, WhatsImported(..),
        PersistentRenamerState(..), IsBootInterface, DeclsMap,
 
        ImportedModuleInfo, WhetherHasOrphans, ImportVersion, WhatsImported(..),
        PersistentRenamerState(..), IsBootInterface, DeclsMap,

@@ -64,7 +64,7 @@ import Rules          ( RuleBase )
 import CoreSyn         ( CoreBind )
 import Id              ( Id )
 import Class           ( Class, classSelIds )
 import CoreSyn         ( CoreBind )
 import Id              ( Id )
 import Class           ( Class, classSelIds )

-import TyCon           ( TyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )
+import TyCon           ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )

 import DataCon         ( dataConId, dataConWrapId )
 
 import BasicTypes      ( Version, initialVersion, Fixity )
 import DataCon         ( dataConId, dataConWrapId )
 
 import BasicTypes      ( Version, initialVersion, Fixity )

@@ -189,7 +189,7 @@ data ModDetails
 -- The ModDetails takes on several slightly different forms:
 --
 -- After typecheck + desugar
 -- The ModDetails takes on several slightly different forms:
 --
 -- After typecheck + desugar

---     md_types        Contains TyCons, Classes, and hasNoBinding Ids
+--     md_types        Contains TyCons, Classes, and implicit Ids

 --     md_insts        All instances from this module (incl derived ones)
 --     md_rules        All rules from this module
 --     md_binds        Desugared bindings
 --     md_insts        All instances from this module (incl derived ones)
 --     md_rules        All rules from this module
 --     md_binds        Desugared bindings

@@ -317,9 +317,16 @@ instance Outputable TyThing where
   ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
   ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
 
   ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
   ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
 

-typeEnvClasses env = [cl | AClass cl <- nameEnvElts env]
-typeEnvTyCons  env = [tc | ATyCon tc <- nameEnvElts env] 
-typeEnvIds     env = [id | AnId id   <- nameEnvElts env] 
+
+typeEnvElts    :: TypeEnv -> [TyThing]
+typeEnvClasses :: TypeEnv -> [Class]
+typeEnvTyCons  :: TypeEnv -> [TyCon]
+typeEnvIds     :: TypeEnv -> [Id]
+
+typeEnvElts    env = nameEnvElts env
+typeEnvClasses env = [cl | AClass cl <- typeEnvElts env]
+typeEnvTyCons  env = [tc | ATyCon tc <- typeEnvElts env] 
+typeEnvIds     env = [id | AnId id   <- typeEnvElts env] 

 
 implicitTyThingIds :: [TyThing] -> [Id]
 -- Add the implicit data cons and selectors etc 
 
 implicitTyThingIds :: [TyThing] -> [Id]
 -- Add the implicit data cons and selectors etc 

@@ -331,8 +338,13 @@ implicitTyThingIds things
     go (ATyCon tc) = tyConGenIds tc ++
                     tyConSelIds tc ++
                     [ n | dc <- tyConDataConsIfAvailable tc, 
     go (ATyCon tc) = tyConGenIds tc ++
                     tyConSelIds tc ++
                     [ n | dc <- tyConDataConsIfAvailable tc, 

-                          n  <- [dataConId dc, dataConWrapId dc] ] 
+                          n  <- implicitConIds tc dc]

                -- Synonyms return empty list of constructors and selectors
                -- Synonyms return empty list of constructors and selectors

+
+    implicitConIds tc dc       -- Newtypes have a constructor wrapper,
+                               -- but no worker
+       | isNewTyCon tc = [dataConWrapId dc]
+       | otherwise     = [dataConId dc, dataConWrapId dc]

 \end{code}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 4f24901..734f64b 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -29,7 +29,7 @@ import HscTypes               ( VersionInfo(..), ModIface(..), ModDetails(..),
                          TyThing(..), DFunId, Avails,
                          WhatsImported(..), GenAvailInfo(..), 
                          ImportVersion, AvailInfo, Deprecations(..),
                          TyThing(..), DFunId, Avails,
                          WhatsImported(..), GenAvailInfo(..), 
                          ImportVersion, AvailInfo, Deprecations(..),

-                         lookupVersion,
+                         lookupVersion, typeEnvIds

                        )
 
 import CmdLineOpts
                        )
 
 import CmdLineOpts

@@ -256,7 +256,7 @@ ifaceTyThing (AnId id) = iface_sig
     id_type = idType id
     id_info = idInfo id
     cg_info = idCgInfo id
     id_type = idType id
     id_info = idInfo id
     cg_info = idCgInfo id

-    arity_info = cgArity cg_info
+    arity_info = arityInfo id_info

     caf_info   = cgCafInfo cg_info
 
     hs_idinfo | opt_OmitInterfacePragmas = []
     caf_info   = cgCafInfo cg_info
 
     hs_idinfo | opt_OmitInterfacePragmas = []

@@ -452,7 +452,7 @@ pprModDetails (ModDetails { md_types = type_env, md_insts = dfun_ids, md_rules =
 dump_types dfun_ids type_env
   = text "TYPE SIGNATURES" $$ nest 4 (dump_sigs ids)
   where
 dump_types dfun_ids type_env
   = text "TYPE SIGNATURES" $$ nest 4 (dump_sigs ids)
   where

-    ids = [id | AnId id <- nameEnvElts type_env, want_sig id]
+    ids = [id | id <- typeEnvIds type_env, want_sig id]

     want_sig id | opt_PprStyle_Debug = True
                | otherwise          = isLocalId id && 
                                       isGlobalName (idName id) && 
     want_sig id | opt_PprStyle_Debug = True
                | otherwise          = isLocalId id && 
                                       isGlobalName (idName id) && 

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 5ed34a4..f5fb7c9 100644 (file)
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -31,7 +31,7 @@ import ErrUtils               ( dumpIfSet, dumpIfSet_dyn, showPass )
 import CoreLint                ( endPass )
 import FloatIn         ( floatInwards )
 import FloatOut                ( floatOutwards )
 import CoreLint                ( endPass )
 import FloatIn         ( floatInwards )
 import FloatOut                ( floatOutwards )

-import Id              ( idName, setIdLocalExported, isImplicitId )
+import Id              ( idName, setIdLocalExported )

 import VarSet
 import LiberateCase    ( liberateCase )
 import SAT             ( doStaticArgs )
 import VarSet
 import LiberateCase    ( liberateCase )
 import SAT             ( doStaticArgs )

@@ -282,12 +282,6 @@ updateBinders rule_ids rule_rhs_fvs is_exported binds
     update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
 
     update_bndr bndr 
     update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
 
     update_bndr bndr 

-       | isImplicitId bndr = bndr_with_rules
-               -- Constructors, selectors; doesn't 
-               -- make sense to call setIdLocalExported
-               -- They can have rules, though; e.g. 
-               --      class Foo a where { op :: a->a }
-               --      {-# RULES  op x = y #-}

        | dont_discard bndr = setIdLocalExported bndr_with_rules
        | otherwise         = bndr_with_rules
        where
        | dont_discard bndr = setIdLocalExported bndr_with_rules
        | otherwise         = bndr_with_rules
        where

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 4d68228..ffeb43c 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -5,8 +5,8 @@
 
 \begin{code}
 module SimplUtils (
 
 \begin{code}
 module SimplUtils (

-       simplBinder, simplBinders, simplRecBndrs, simplLetBndr, 
-       simplLamBndrs, simplTopBndrs,
+       simplBinder, simplBinders, simplRecBndrs, 
+       simplLetBndr, simplLamBndrs, 

        newId, mkLam, mkCase,
 
        -- The continuation type
        newId, mkLam, mkCase,
 
        -- The continuation type

@@ -30,8 +30,8 @@ import CoreUtils      ( cheapEqExpr, exprType,
                          findDefault, exprOkForSpeculation, exprIsValue
                        )
 import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
                          findDefault, exprOkForSpeculation, exprIsValue
                        )
 import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )

-import Id              ( Id, idType, idInfo, isLocalId,
-                         mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
+import Id              ( Id, idType, idInfo, 
+                         mkSysLocal, isDeadBinder, idNewDemandInfo,

                          idUnfolding, idNewStrictness
                        )
 import NewDemand       ( isStrictDmd, isBotRes, splitStrictSig )
                          idUnfolding, idNewStrictness
                        )
 import NewDemand       ( isStrictDmd, isBotRes, splitStrictSig )

@@ -447,26 +447,11 @@ simplLetBndr env id
     seqBndr id'                `seq`
     returnSmpl (setSubst env subst', id')
 
     seqBndr id'                `seq`
     returnSmpl (setSubst env subst', id')
 

-simplTopBndrs, simplLamBndrs, simplRecBndrs 
+simplLamBndrs, simplRecBndrs 

        :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
        :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])

-simplTopBndrs = simplBndrs simplTopBinder

 simplRecBndrs = simplBndrs Subst.simplLetId
 simplLamBndrs = simplBndrs Subst.simplLamBndr
 
 simplRecBndrs = simplBndrs Subst.simplLetId
 simplLamBndrs = simplBndrs Subst.simplLamBndr
 

--- For top-level binders, don't use simplLetId for GlobalIds. 
--- There are some of these, notably consructor wrappers, and we don't
--- want to clone them or fiddle with them at all.  
--- Rather tiresomely, the specialiser may float a use of a constructor
--- wrapper to before its definition (which shouldn't really matter)
--- because it doesn't see the constructor wrapper as free in the binding
--- it is floating (because it's a GlobalId).
--- Then the simplifier brings all top level Ids into scope at the
--- beginning, and we don't want to lose the IdInfo on the constructor
--- wrappers.  It would also be Bad to clone it!
-simplTopBinder subst bndr
-  | isLocalId bndr = Subst.simplLetId subst bndr
-  | otherwise     = (subst, bndr)
-

 simplBndrs simpl_bndr env bndrs
   = let
        (subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs
 simplBndrs simpl_bndr env bndrs
   = let
        (subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs

@@ -561,9 +546,7 @@ tryEtaReduce bndrs body
     go []       (Var fun)     | ok_fun fun   = Just (Var fun)  -- Success!
     go _        _                           = Nothing          -- Failure!
 
     go []       (Var fun)     | ok_fun fun   = Just (Var fun)  -- Success!
     go _        _                           = Nothing          -- Failure!
 

-    ok_fun fun   = not (fun `elem` bndrs) && not (hasNoBinding fun)
-                       -- Note the awkward "hasNoBinding" test
-                       -- Details with exprIsTrivial
+    ok_fun fun   = not (fun `elem` bndrs)

     ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
 \end{code}
 
     ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
 \end{code}
 

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 09b8cb0..88e6348 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -14,7 +14,7 @@ import CmdLineOpts    ( dopt, DynFlag(Opt_D_dump_inlinings),
 import SimplMonad
 import SimplUtils      ( mkCase, mkLam, newId,
                          simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
 import SimplMonad
 import SimplUtils      ( mkCase, mkLam, newId,
                          simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,

-                         simplTopBndrs, SimplCont(..), DupFlag(..), LetRhsFlag(..), 
+                         SimplCont(..), DupFlag(..), LetRhsFlag(..), 

                          mkStop, mkBoringStop,  pushContArgs,
                          contResultType, countArgs, contIsDupable, contIsRhsOrArg,
                          getContArgs, interestingCallContext, interestingArg, isStrictType
                          mkStop, mkBoringStop,  pushContArgs,
                          contResultType, countArgs, contIsDupable, contIsRhsOrArg,
                          getContArgs, interestingCallContext, interestingArg, isStrictType

@@ -24,8 +24,7 @@ import VarEnv
 import Id              ( Id, idType, idInfo, idArity, isDataConId, 
                          idUnfolding, setIdUnfolding, isDeadBinder,
                          idNewDemandInfo, setIdInfo,
 import Id              ( Id, idType, idInfo, idArity, isDataConId, 
                          idUnfolding, setIdUnfolding, isDeadBinder,
                          idNewDemandInfo, setIdInfo,

-                         setIdOccInfo, isLocalId,
-                         zapLamIdInfo, setOneShotLambda, 
+                         setIdOccInfo, zapLamIdInfo, setOneShotLambda, 

                        )
 import IdInfo          ( OccInfo(..), isLoopBreaker,
                          setArityInfo, 
                        )
 import IdInfo          ( OccInfo(..), isLoopBreaker,
                          setArityInfo, 

@@ -38,9 +37,9 @@ import CoreSyn
 import PprCore         ( pprParendExpr, pprCoreExpr )
 import CoreUnfold      ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
 import CoreUtils       ( exprIsDupable, exprIsTrivial, needsCaseBinding,
 import PprCore         ( pprParendExpr, pprCoreExpr )
 import CoreUnfold      ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
 import CoreUtils       ( exprIsDupable, exprIsTrivial, needsCaseBinding,

-                         exprIsConApp_maybe, mkPiType, findAlt, findDefault,
+                         exprIsConApp_maybe, mkPiType, findAlt, 

                          exprType, coreAltsType, exprIsValue, 
                          exprType, coreAltsType, exprIsValue, 

-                         exprOkForSpeculation, exprArity, 
+                         exprOkForSpeculation, exprArity, findDefault,

                          mkCoerce, mkSCC, mkInlineMe, mkAltExpr
                        )
 import Rules           ( lookupRule )
                          mkCoerce, mkSCC, mkInlineMe, mkAltExpr
                        )
 import Rules           ( lookupRule )

@@ -54,7 +53,7 @@ import Subst          ( mkSubst, substTy, substExpr,
                        )
 import TysPrim         ( realWorldStatePrimTy )
 import PrelInfo                ( realWorldPrimId )
                        )
 import TysPrim         ( realWorldStatePrimTy )
 import PrelInfo                ( realWorldPrimId )

-import BasicTypes      ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
+import BasicTypes      ( TopLevelFlag(..), isTopLevel, 

                          RecFlag(..), isNonRec
                        )
 import OrdList
                          RecFlag(..), isNonRec
                        )
 import OrdList

@@ -230,7 +229,7 @@ simplTopBinds env binds
        -- so that if a transformation rule has unexpectedly brought
        -- anything into scope, then we don't get a complaint about that.
        -- It's rather as if the top-level binders were imported.
        -- so that if a transformation rule has unexpectedly brought
        -- anything into scope, then we don't get a complaint about that.
        -- It's rather as if the top-level binders were imported.

-    simplTopBndrs env (bindersOfBinds binds)   `thenSmpl` \ (env, bndrs') -> 
+    simplRecBndrs env (bindersOfBinds binds)   `thenSmpl` \ (env, bndrs') -> 

     simpl_binds env binds bndrs'               `thenSmpl` \ (floats, _) ->
     freeTick SimplifierDone                    `thenSmpl_`
     returnSmpl (floatBinds floats)
     simpl_binds env binds bndrs'               `thenSmpl` \ (floats, _) ->
     freeTick SimplifierDone                    `thenSmpl_`
     returnSmpl (floatBinds floats)

@@ -442,11 +441,12 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
        --
        -- NB: does no harm for non-recursive bindings
     let
        --
        -- NB: does no harm for non-recursive bindings
     let

+       is_top_level      = isTopLevel top_lvl

        bndr_ty'          = idType bndr'
        bndr''            = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
        env1              = modifyInScope env bndr'' bndr''
        rhs_env           = setInScope rhs_se env1
        bndr_ty'          = idType bndr'
        bndr''            = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
        env1              = modifyInScope env bndr'' bndr''
        rhs_env           = setInScope rhs_se env1

-       ok_float_unlifted = isNotTopLevel top_lvl && isNonRec is_rec
+       ok_float_unlifted = not is_top_level && isNonRec is_rec

        rhs_cont          = mkStop bndr_ty' AnRhs
     in
        -- Simplify the RHS; note the mkStop, which tells 
        rhs_cont          = mkStop bndr_ty' AnRhs
     in
        -- Simplify the RHS; note the mkStop, which tells 

@@ -481,7 +481,8 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
        -- Either we must be careful not to float demanded non-values, or
        -- we must use exprIsValue for the test, which ensures that the
        -- thing is non-strict.  I think.  The WARN below tests for this.
        -- Either we must be careful not to float demanded non-values, or
        -- we must use exprIsValue for the test, which ensures that the
        -- thing is non-strict.  I think.  The WARN below tests for this.

-    else if exprIsTrivial rhs2 || exprIsValue rhs2 then
+    else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
+

                -- There's a subtlety here.  There may be a binding (x* = e) in the
                -- floats, where the '*' means 'will be demanded'.  So is it safe
                -- to float it out?  Answer no, but it won't matter because
                -- There's a subtlety here.  There may be a binding (x* = e) in the
                -- floats, where the '*' means 'will be demanded'.  So is it safe
                -- to float it out?  Answer no, but it won't matter because

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index da043d0..c99c76f 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -176,7 +176,7 @@ coreTopBindToStg env body_fvs (NonRec id rhs)
   = let 
        caf_info  = hasCafRefs env rhs
        env'      = extendVarEnv env id how_bound
   = let 
        caf_info  = hasCafRefs env rhs
        env'      = extendVarEnv env id how_bound

-       how_bound = LetBound (TopLet caf_info) (predictArity rhs)
+       how_bound = LetBound (TopLet caf_info) (manifestArity rhs)

 
         (stg_rhs, fvs', lv_info) = 
            initLne env (
 
         (stg_rhs, fvs', lv_info) = 
            initLne env (

@@ -187,7 +187,8 @@ coreTopBindToStg env body_fvs (NonRec id rhs)
        
        bind = StgNonRec (mkSRT lv_info) id stg_rhs
     in
        
        bind = StgNonRec (mkSRT lv_info) id stg_rhs
     in

-    ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id)
+    ASSERT2(isLocalId id || idArity id == manifestArity rhs, ppr id)
+    ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)

     ASSERT2(consistent caf_info bind, ppr id)
 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
     (env', fvs' `unionFVInfo` body_fvs, bind)
     ASSERT2(consistent caf_info bind, ppr id)
 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
     (env', fvs' `unionFVInfo` body_fvs, bind)

@@ -205,7 +206,7 @@ coreTopBindToStg env body_fvs (Rec pairs)
        caf_info = hasCafRefss env1{-NB: not env'-} rhss
 
        env' = extendVarEnvList env 
        caf_info = hasCafRefss env1{-NB: not env'-} rhss
 
        env' = extendVarEnvList env 

-               [ (b, LetBound (TopLet caf_info) (predictArity rhs)) 
+               [ (b, LetBound (TopLet caf_info) (manifestArity rhs)) 

                | (b,rhs) <- pairs ]
 
         (stg_rhss, fvs', lv_info)
                | (b,rhs) <- pairs ]
 
         (stg_rhss, fvs', lv_info)

@@ -219,7 +220,8 @@ coreTopBindToStg env body_fvs (Rec pairs)
 
        bind = StgRec (mkSRT lv_info) (zip binders stg_rhss)
     in
 
        bind = StgRec (mkSRT lv_info) (zip binders stg_rhss)
     in

-    ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
+    ASSERT2(and [isLocalId bndr || manifestArity rhs == idArity bndr | (bndr,rhs) <- pairs], ppr binders)
+    ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)

     ASSERT2(consistent caf_info bind, ppr binders)
 --    WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
     (env', fvs' `unionFVInfo` body_fvs, bind)
     ASSERT2(consistent caf_info bind, ppr binders)
 --    WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
     (env', fvs' `unionFVInfo` body_fvs, bind)

@@ -678,7 +680,7 @@ coreToStgLet let_no_escape bind body
     binders       = bindersOf bind
 
     mk_binding bind_lv_info binder rhs
     binders       = bindersOf bind
 
     mk_binding bind_lv_info binder rhs

-       = (binder, LetBound (NestedLet live_vars) (predictArity rhs))
+       = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))

        where
           live_vars | let_no_escape = addLiveVar bind_lv_info binder
                     | otherwise     = unitLiveVar binder
        where
           live_vars | let_no_escape = addLiveVar bind_lv_info binder
                     | otherwise     = unitLiveVar binder

@@ -734,28 +736,6 @@ is_join_var :: Id -> Bool
 is_join_var j = occNameUserString (getOccName j) == "$j"
 \end{code}
 
 is_join_var j = occNameUserString (getOccName j) == "$j"
 \end{code}
 

-%************************************************************************
-%*                                                                     *
-\subsection{Arity prediction}
-%*                                                                     *
-%************************************************************************
-
-To avoid yet another knot, we predict the arity of each function from
-its Core form, based on the number of visible top-level lambdas.  
-It should be the same as the arity of the STG RHS!
-
-\begin{code}
-predictArity :: CoreExpr -> Int
-predictArity (Lam x e)
-  | isTyVar x = predictArity e
-  | otherwise = 1 + predictArity e
-predictArity (Note _ e)
-  -- Ignore coercions.   Top level sccs are removed by the final 
-  -- profiling pass, so we ignore those too.
-  = predictArity e
-predictArity _ = 0
-\end{code}
-

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs
index 17775e7..11071d4 100644 (file)
--- a/ghc/compiler/stranal/DmdAnal.lhs
+++ b/ghc/compiler/stranal/DmdAnal.lhs
@@ -20,8 +20,8 @@ import PprCore
 import CoreUtils       ( exprIsValue, exprArity )
 import DataCon         ( dataConTyCon )
 import TyCon           ( isProductTyCon, isRecursiveTyCon )
 import CoreUtils       ( exprIsValue, exprArity )
 import DataCon         ( dataConTyCon )
 import TyCon           ( isProductTyCon, isRecursiveTyCon )

-import Id              ( Id, idType, idDemandInfo, idArity,
-                         isDataConId, isImplicitId, isGlobalId,
+import Id              ( Id, idType, idDemandInfo, 
+                         isDataConId, isGlobalId, idArity,

                          idNewStrictness, idNewStrictness_maybe, getNewStrictness, setIdNewStrictness,
                          idNewDemandInfo, setIdNewDemandInfo, newStrictnessFromOld )
 import IdInfo          ( newDemand )
                          idNewStrictness, idNewStrictness_maybe, getNewStrictness, setIdNewStrictness,
                          idNewDemandInfo, setIdNewDemandInfo, newStrictnessFromOld )
 import IdInfo          ( newDemand )

@@ -78,9 +78,6 @@ dmdAnalTopBind :: SigEnv
               -> CoreBind 
               -> (SigEnv, CoreBind)
 dmdAnalTopBind sigs (NonRec id rhs)
               -> CoreBind 
               -> (SigEnv, CoreBind)
 dmdAnalTopBind sigs (NonRec id rhs)

-  | isImplicitId id            -- Don't touch the info on constructors, selectors etc
-  = (sigs, NonRec id rhs)      -- It's pre-computed in MkId.lhs
-  | otherwise

   = let
        (sigs', _, (id', rhs')) = dmdAnalRhs TopLevel sigs (id, rhs)
     in
   = let
        (sigs', _, (id', rhs')) = dmdAnalRhs TopLevel sigs (id, rhs)
     in

@@ -161,7 +158,7 @@ dmdAnal sigs dmd (App fun (Type ty))
 
 -- Lots of the other code is there to make this
 -- beautiful, compositional, application rule :-)
 
 -- Lots of the other code is there to make this
 -- beautiful, compositional, application rule :-)

-dmdAnal sigs dmd (App fun arg) -- Non-type arguments
+dmdAnal sigs dmd e@(App fun arg)       -- Non-type arguments

   = let                                -- [Type arg handled above]
        (fun_ty, fun')    = dmdAnal sigs (Call dmd) fun
        (arg_ty, arg')    = dmdAnal sigs arg_dmd arg
   = let                                -- [Type arg handled above]
        (fun_ty, fun')    = dmdAnal sigs (Call dmd) fun
        (arg_ty, arg')    = dmdAnal sigs arg_dmd arg

@@ -475,7 +472,7 @@ splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
 splitDmdTy ty@(DmdType fv [] TopRes)      = (Lazy, ty)
 splitDmdTy ty@(DmdType fv [] BotRes)      = (Bot,  ty)
        -- NB: Bot not Abs
 splitDmdTy ty@(DmdType fv [] TopRes)      = (Lazy, ty)
 splitDmdTy ty@(DmdType fv [] BotRes)      = (Bot,  ty)
        -- NB: Bot not Abs

-splitDmdTy (DmdType fv [] RetCPR)        = panic "splitDmdTy"
+splitDmdTy ty@(DmdType fv [] RetCPR)             = panic "splitDmdTy"

        -- We should not be applying a product as a function!
 \end{code}
 
        -- We should not be applying a product as a function!
 \end{code}
 

@@ -909,8 +906,7 @@ get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
 get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
 
 get_changes_pr (id,rhs) 
 get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
 
 get_changes_pr (id,rhs) 

-  | isImplicitId id = empty  -- We don't look inside these
-  | otherwise      = get_changes_var id $$ get_changes_expr rhs
+  = get_changes_var id $$ get_changes_expr rhs

 
 get_changes_var var
   | isId var  = get_changes_str var $$ get_changes_dmd var
 
 get_changes_var var
   | isId var  = get_changes_str var $$ get_changes_dmd var

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index d6aefcd..cc7d9b6 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -88,8 +88,7 @@ tcIdInfo unf_env in_scope_vars name ty info_ins
     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`   NoCafRefs)
 
     tcPrag info (HsArity arity) = 
     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`   NoCafRefs)
 
     tcPrag info (HsArity arity) = 

-       returnTc (info `setArityInfo` arity
-                      `setCgArity`   arity)
+       returnTc (info `setArityInfo` arity)

 
     tcPrag info (HsUnfold inline_prag expr)
        = tcPragExpr unf_env name in_scope_vars expr    `thenNF_Tc` \ maybe_expr' ->
 
     tcPrag info (HsUnfold inline_prag expr)
        = tcPragExpr unf_env name in_scope_vars expr    `thenNF_Tc` \ maybe_expr' ->

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 53fff48..e799f09 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -61,7 +61,7 @@ import ErrUtils               ( printErrorsAndWarnings, errorsFound,
 import Id              ( Id, idType, idUnfolding )
 import Module           ( Module, moduleName )
 import Name            ( Name )
 import Id              ( Id, idType, idUnfolding )
 import Module           ( Module, moduleName )
 import Name            ( Name )

-import NameEnv         ( nameEnvElts, lookupNameEnv )
+import NameEnv         ( lookupNameEnv )

 import TyCon           ( tyConGenInfo )
 import BasicTypes       ( EP(..), Fixity, RecFlag(..) )
 import SrcLoc          ( noSrcLoc )
 import TyCon           ( tyConGenInfo )
 import BasicTypes       ( EP(..), Fixity, RecFlag(..) )
 import SrcLoc          ( noSrcLoc )

@@ -70,8 +70,8 @@ import IO             ( stdout )
 import HscTypes                ( PersistentCompilerState(..), HomeSymbolTable, 
                          PackageTypeEnv, ModIface(..),
                          ModDetails(..), DFunId,
 import HscTypes                ( PersistentCompilerState(..), HomeSymbolTable, 
                          PackageTypeEnv, ModIface(..),
                          ModDetails(..), DFunId,

-                         TypeEnv, extendTypeEnvList, 
-                         TyThing(..), implicitTyThingIds, 
+                         TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts,
+                         TyThing(..), 

                          mkTypeEnv
                        )
 \end{code}
                          mkTypeEnv
                        )
 \end{code}

@@ -447,17 +447,7 @@ tcModule pcs hst get_fixity this_mod decls
        zonkRules more_local_rules      `thenNF_Tc` \ more_local_rules' ->
        
        
        zonkRules more_local_rules      `thenNF_Tc` \ more_local_rules' ->
        
        

-       let     local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
-       
-               -- Create any necessary "implicit" bindings (data constructors etc)
-               -- Should we create bindings for dictionary constructors?
-               -- They are always fully applied, and the bindings are just there
-               -- to support partial applications. But it's easier to let them through.
-               implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
-                                                | id <- implicitTyThingIds local_things
-                                                , let unf = idUnfolding id
-                                                , hasUnfolding unf
-                                                ]
+       let     local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))

        
                local_type_env :: TypeEnv
                local_type_env = mkTypeEnv local_things
        
                local_type_env :: TypeEnv
                local_type_env = mkTypeEnv local_things

@@ -469,7 +459,7 @@ tcModule pcs hst get_fixity this_mod decls
                  new_pcs,
                  TcResults { tc_env     = local_type_env,
                              tc_insts   = map iDFunId local_insts,
                  new_pcs,
                  TcResults { tc_env     = local_type_env,
                              tc_insts   = map iDFunId local_insts,

-                             tc_binds   = implicit_binds `AndMonoBinds` all_binds', 
+                             tc_binds   = all_binds', 

                              tc_fords   = foi_decls ++ foe_decls',
                              tc_rules   = all_local_rules
                            }
                              tc_fords   = foi_decls ++ foe_decls',
                              tc_rules   = all_local_rules
                            }

@@ -519,7 +509,7 @@ typecheckIface dflags pcs hst mod_iface decls
                            deriv_binds, local_rules) ->
          ASSERT(nullBinds deriv_binds)
          let 
                            deriv_binds, local_rules) ->
          ASSERT(nullBinds deriv_binds)
          let 

-             local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv env))
+             local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv env))

 
              mod_details = ModDetails { md_types = mkTypeEnv local_things,
                                         md_insts = map iDFunId local_inst_info,
 
              mod_details = ModDetails { md_types = mkTypeEnv local_things,
                                         md_insts = map iDFunId local_inst_info,

@@ -587,7 +577,7 @@ tcImports unf_env pcs hst get_fixity this_mod decls
     
     tcGetEnv                                           `thenTc` \ unf_env ->
     let
     
     tcGetEnv                                           `thenTc` \ unf_env ->
     let

-        all_things = nameEnvElts (getTcGEnv unf_env)
+        all_things = typeEnvElts (getTcGEnv unf_env)

     
          -- sometimes we're compiling in the context of a package module
          -- (on the GHCi command line, for example).  In this case, we
     
          -- sometimes we're compiling in the context of a package module
          -- (on the GHCi command line, for example).  In this case, we

@@ -722,7 +712,7 @@ dump_tc_iface dflags results
          ppr_rules (tc_rules results),
 
          if dopt Opt_Generics dflags then
          ppr_rules (tc_rules results),
 
          if dopt Opt_Generics dflags then

-               ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
+               ppr_gen_tycons (typeEnvTyCons (tc_env results))

          else 
                empty
     ]
          else 
                empty
     ]