[project @ 2001-10-15 15:06:01 by simonpj]

--------------------------
	Tidy up arity propagation
	--------------------------

Due to excessive complexity, correct arity information was getting
lost on the way to interface files.  As a result, a function that had
CPR info __S SLm (say), was getting arity 0, and this confused the (old)
CPR analyser ("lub of function and HasCPR").

I hope this fixes the above error (which showed up somewhere in
compiling Edison), but I'm going to commit it right now anyway.
Meanwhile I'll recompile Edison too.

Details
~~~~~~~
Digging out the rather obscure cause made me tidy up the CgInfo stuff.
The story is now

* The CgInfo field of an Id gets attached to the Id *only* in
  the TypeEnv of the ModuleDetails, during CoreTidy.

  This ModuleDetails stuff is used
	a) to generate the interface file
	b) to import into other modules in GHCi

* No CgInfo field is in the CoreBindings which are passed
  downsteam to CorePrep and thence CodeGen.  Quite right too...
  it's the downstream stuff that *generates* the CgInfo.

* But the Arity field *is* now passed on through CoreTidy
  (like strictness info) since it is usefully used by CorePrep.

* On the way I simplified the ArityInfo field of an IdInfo
  to simply
		Arity
  instead of
		Maybe Arity

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index c45304f..b212920 100644 (file)
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -43,7 +43,7 @@ module Id (
 
        -- IdInfo stuff
        setIdUnfolding,
-       setIdArityInfo,
+       setIdArity,
        setIdDemandInfo, setIdNewDemandInfo, 
        setIdStrictness, setIdNewStrictness, zapIdNewStrictness,
         setIdTyGenInfo,
@@ -53,7 +53,7 @@ module Id (
        setIdCprInfo,
        setIdOccInfo,
 
-       idArity, idArityInfo, 
+       idArity, 
        idDemandInfo, idNewDemandInfo,
        idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness,
         idTyGenInfo,
@@ -108,7 +108,7 @@ import Outputable
 import Unique          ( Unique, mkBuiltinUnique )
 
 infixl         1 `setIdUnfolding`,
-         `setIdArityInfo`,
+         `setIdArity`,
          `setIdDemandInfo`,
          `setIdStrictness`,
          `setIdNewDemandInfo`,
@@ -309,14 +309,11 @@ isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
 \begin{code}
        ---------------------------------
        -- ARITY
-idArityInfo :: Id -> ArityInfo
-idArityInfo id = arityInfo (idInfo id)
-
 idArity :: Id -> Arity
-idArity id = arityLowerBound (idArityInfo id)
+idArity id = arityInfo (idInfo id)
 
-setIdArityInfo :: Id -> Arity -> Id
-setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id
+setIdArity :: Id -> Arity -> Id
+setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
 
        ---------------------------------
        -- STRICTNESS 

diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index cfc1d38..0a8067b 100644 (file)
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -20,8 +20,8 @@ module IdInfo (
 
        -- Arity
        ArityInfo,
-       exactArity, unknownArity, hasArity,
-       arityInfo, setArityInfo, ppArityInfo, arityLowerBound,
+       unknownArity, 
+       arityInfo, setArityInfo, ppArityInfo, 
 
        -- New demand and strictness info
        newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo,
@@ -49,7 +49,7 @@ module IdInfo (
        demandInfo, setDemandInfo, 
 
        -- Inline prags
-       InlinePragInfo(..), 
+       InlinePragInfo, 
        inlinePragInfo, setInlinePragInfo, 
 
        -- Occurrence info
@@ -310,7 +310,7 @@ setUnfoldingInfo  info uf
   = info { unfoldingInfo = uf }
 
 setDemandInfo    info dd = info { demandInfo = dd }
-setArityInfo     info ar = info { arityInfo = Just ar  }
+setArityInfo     info ar = info { arityInfo = ar  }
 setCgInfo         info cg = info { cgInfo = cg }
 setCprInfo        info cp = info { cprInfo = cp }
 setLBVarInfo      info lb = info { lbvarInfo = lb }
@@ -359,7 +359,7 @@ of their arities; so it should not be asking...      (but other things
 besides the code-generator need arity info!)
 
 \begin{code}
-type ArityInfo = Maybe Arity
+type ArityInfo = Arity
        -- A partial application of this Id to up to n-1 value arguments
        -- does essentially no work.  That is not necessarily the
        -- same as saying that it has n leading lambdas, because coerces
@@ -369,21 +369,12 @@ type ArityInfo = Maybe Arity
        -- an extra lambda floats up to the binding site.
 
 seqArity :: ArityInfo -> ()
-seqArity a = arityLowerBound a `seq` ()
+seqArity a = a `seq` ()
 
-exactArity   = Just
-unknownArity = Nothing
+unknownArity = 0 :: Arity
 
-arityLowerBound :: ArityInfo -> Arity
-arityLowerBound Nothing  = 0
-arityLowerBound (Just n) = n
-
-hasArity :: ArityInfo -> Bool
-hasArity Nothing = False
-hasArity other   = True
-
-ppArityInfo Nothing     = empty
-ppArityInfo (Just arity) = hsep [ptext SLIT("Arity"), int arity]
+ppArityInfo 0 = empty
+ppArityInfo n = hsep [ptext SLIT("Arity"), int n]
 \end{code}
 
 %************************************************************************

diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index 82b15af..4e1a4d5 100644 (file)
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -24,7 +24,7 @@ import Id             ( idType, idInfo, idName, isExportedId,
                          idSpecialisation, idUnique, isDataConWrapId,
                          mkVanillaGlobal, mkGlobalId, isLocalId, 
                          isDataConId, mkUserLocal, isGlobalId, globalIdDetails,
-                         idNewDemandInfo, setIdNewDemandInfo, 
+                         idNewDemandInfo, setIdNewDemandInfo, setIdCgInfo,
                          idNewStrictness, setIdNewStrictness
                        ) 
 import IdInfo          {- loads of stuff -}
@@ -155,7 +155,7 @@ tidyCorePgm dflags mod pcs cg_info_env
                                                   isGlobalName (idName bndr)]
 
        ; let ((orig_ns', occ_env, subst_env), tidy_binds) 
-                       = mapAccumL (tidyTopBind mod ext_ids cg_info_env) 
+                       = mapAccumL (tidyTopBind mod ext_ids) 
                                    init_tidy_env binds_in
 
        ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
@@ -163,7 +163,8 @@ tidyCorePgm dflags mod pcs cg_info_env
        ; let prs' = prs { prsOrig = orig_ns' }
              pcs' = pcs { pcs_PRS = prs' }
 
-       ; let final_ids  = [ id | bind <- tidy_binds
+       ; let final_ids  = [ addCgInfo cg_info_env id 
+                          | bind <- tidy_binds
                           , id <- bindersOf bind
                           , isGlobalName (idName id)]
 
@@ -189,6 +190,16 @@ tidyCorePgm dflags mod pcs cg_info_env
        ; 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}
@@ -375,19 +386,18 @@ type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var)
 tidyTopBind :: Module
            -> IdEnv Bool       -- Domain = Ids that should be external
                                -- True <=> their unfolding is external too
-           -> CgInfoEnv
            -> TopTidyEnv -> CoreBind
            -> (TopTidyEnv, CoreBind)
 
-tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs)
+tidyTopBind mod ext_ids top_tidy_env (NonRec bndr rhs)
   = ((orig,occ,subst) , NonRec bndr' rhs')
   where
     ((orig,occ,subst), bndr')
-        = tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs' top_tidy_env bndr
+        = tidyTopBinder mod ext_ids rec_tidy_env rhs' top_tidy_env bndr
     rec_tidy_env = (occ,subst)
     rhs' = tidyExpr rec_tidy_env rhs
 
-tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs)
+tidyTopBind mod ext_ids top_tidy_env (Rec prs)
   = (final_env, Rec prs')
   where
     (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
@@ -397,13 +407,12 @@ tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs)
        = ((orig,occ,subst), (bndr',rhs'))
        where
        ((orig,occ,subst), bndr')
-          = tidyTopBinder mod ext_ids cg_info_env 
+          = tidyTopBinder mod ext_ids
                rec_tidy_env rhs' top_tidy_env bndr
 
         rhs' = tidyExpr rec_tidy_env rhs
 
 tidyTopBinder :: Module -> IdEnv Bool
-             -> CgInfoEnv
              -> TidyEnv -> CoreExpr
                        -- The TidyEnv is used to tidy the IdInfo
                        -- The expr is the already-tided RHS
@@ -411,7 +420,7 @@ tidyTopBinder :: Module -> IdEnv Bool
              -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
   -- NB: tidyTopBinder doesn't affect the unique supply
 
-tidyTopBinder mod ext_ids cg_info_env tidy_env rhs
+tidyTopBinder mod ext_ids tidy_env rhs
              env@(ns2, occ_env2, subst_env2) id
 
   | isDataConWrapId id -- Don't tidy constructor wrappers
@@ -451,8 +460,7 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs
                                               is_external
                                               (idName id)
     ty'            = tidyTopType (idType id)
-    cg_info = lookupCgInfo cg_info_env name'
-    idinfo' = tidyIdInfo tidy_env is_external unfold_info cg_info id
+    idinfo' = tidyIdInfo tidy_env is_external unfold_info id
 
     id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo'
        | otherwise     = mkVanillaGlobal                 name' ty' idinfo'
@@ -470,17 +478,17 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs
                | otherwise   = noUnfolding
 
 
-tidyIdInfo tidy_env is_external unfold_info cg_info id
+tidyIdInfo tidy_env is_external unfold_info id
   | opt_OmitInterfacePragmas || not is_external
        -- No IdInfo if the Id isn't external, or if we don't have -O
   = vanillaIdInfo 
-       `setCgInfo`            cg_info
+       `setArityInfo`         arityInfo core_idinfo
        `setNewStrictnessInfo` newStrictnessInfo core_idinfo
-       -- Keep strictness; it's used by CorePrep
+       -- Keep strictness and arity; both are used by CorePrep
 
   | otherwise
   =  vanillaIdInfo 
-       `setCgInfo`            cg_info
+       `setArityInfo`         arityInfo core_idinfo
        `setNewStrictnessInfo` newStrictnessInfo core_idinfo
        `setInlinePragInfo`    inlinePragInfo core_idinfo
        `setUnfoldingInfo`     unfold_info

diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs
index 9a90422..1f3a7d1 100644 (file)
--- a/ghc/compiler/ilxGen/IlxGen.lhs
+++ b/ghc/compiler/ilxGen/IlxGen.lhs
@@ -8,8 +8,7 @@ module IlxGen( ilxGen ) where
 
 import Char    ( ord, chr )
 import StgSyn
-import Id      ( idType, idName, isDeadBinder, idArityInfo )
-import IdInfo   ( arityLowerBound )
+import Id      ( idType, idName, isDeadBinder, idArity )
 import Var     ( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName )
 import VarEnv
 import VarSet   ( isEmptyVarSet )
@@ -772,7 +771,7 @@ ilxFunAppAfterPush env fun args tail_call
       case lookupIlxBindEnv env fun of
          Just (_, StgRhsClosure  _ _ _ Updatable _ _)   -> Nothing 
          Just (place, StgRhsClosure  _ _ fvs _ args _)  -> Just (place,fun,args,fvs)
-         _ -> Nothing -- trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun)))
+         _ -> Nothing -- trace (show fun ++ " --> " ++ show (idArity fun))
 
 type KnownClosure = Maybe (  IlxEnv    -- Of the binding site of the function
                           , Id         -- The function