--------------------------
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
-- IdInfo stuff
setIdUnfolding,
-- IdInfo stuff
setIdUnfolding,
setIdDemandInfo, setIdNewDemandInfo,
setIdStrictness, setIdNewStrictness, zapIdNewStrictness,
setIdTyGenInfo,
setIdDemandInfo, setIdNewDemandInfo,
setIdStrictness, setIdNewStrictness, zapIdNewStrictness,
setIdTyGenInfo,
setIdCprInfo,
setIdOccInfo,
setIdCprInfo,
setIdOccInfo,
idDemandInfo, idNewDemandInfo,
idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness,
idTyGenInfo,
idDemandInfo, idNewDemandInfo,
idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness,
idTyGenInfo,
import Unique ( Unique, mkBuiltinUnique )
infixl 1 `setIdUnfolding`,
import Unique ( Unique, mkBuiltinUnique )
infixl 1 `setIdUnfolding`,
`setIdDemandInfo`,
`setIdStrictness`,
`setIdNewDemandInfo`,
`setIdDemandInfo`,
`setIdStrictness`,
`setIdNewDemandInfo`,
\begin{code}
---------------------------------
-- ARITY
\begin{code}
---------------------------------
-- ARITY
-idArityInfo :: Id -> ArityInfo
-idArityInfo id = arityInfo (idInfo id)
-
-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
---------------------------------
-- STRICTNESS
- exactArity, unknownArity, hasArity,
- arityInfo, setArityInfo, ppArityInfo, arityLowerBound,
+ unknownArity,
+ arityInfo, setArityInfo, ppArityInfo,
-- New demand and strictness info
newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo,
-- New demand and strictness info
newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo,
demandInfo, setDemandInfo,
-- Inline prags
demandInfo, setDemandInfo,
-- Inline prags
inlinePragInfo, setInlinePragInfo,
-- Occurrence info
inlinePragInfo, setInlinePragInfo,
-- Occurrence info
= info { unfoldingInfo = uf }
setDemandInfo info dd = info { demandInfo = dd }
= 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 }
setCgInfo info cg = info { cgInfo = cg }
setCprInfo info cp = info { cprInfo = cp }
setLBVarInfo info lb = info { lbvarInfo = lb }
besides the code-generator need arity info!)
\begin{code}
besides the code-generator need arity info!)
\begin{code}
-type ArityInfo = Maybe 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
-- 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
-- an extra lambda floats up to the binding site.
seqArity :: ArityInfo -> ()
-- an extra lambda floats up to the binding site.
seqArity :: ArityInfo -> ()
-seqArity a = arityLowerBound 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}
%************************************************************************
\end{code}
%************************************************************************
idSpecialisation, idUnique, isDataConWrapId,
mkVanillaGlobal, mkGlobalId, isLocalId,
isDataConId, mkUserLocal, isGlobalId, globalIdDetails,
idSpecialisation, idUnique, isDataConWrapId,
mkVanillaGlobal, mkGlobalId, isLocalId,
isDataConId, mkUserLocal, isGlobalId, globalIdDetails,
- idNewDemandInfo, setIdNewDemandInfo,
+ idNewDemandInfo, setIdNewDemandInfo, setIdCgInfo,
idNewStrictness, setIdNewStrictness
)
import IdInfo {- loads of stuff -}
idNewStrictness, setIdNewStrictness
)
import IdInfo {- loads of stuff -}
isGlobalName (idName bndr)]
; let ((orig_ns', occ_env, subst_env), tidy_binds)
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
init_tidy_env binds_in
; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
; 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 = [ id | bind <- tidy_binds
+ ; let final_ids = [ addCgInfo cg_info_env id
+ | bind <- tidy_binds
, id <- bindersOf bind
, isGlobalName (idName id)]
, id <- bindersOf bind
, isGlobalName (idName id)]
; 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}
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
-> TopTidyEnv -> CoreBind
-> (TopTidyEnv, CoreBind)
-> 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')
= ((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
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
= (final_env, Rec prs')
where
(final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env 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 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
rec_tidy_env rhs' top_tidy_env bndr
rhs' = tidyExpr rec_tidy_env rhs
tidyTopBinder :: Module -> IdEnv Bool
-> 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
-> 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 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
env@(ns2, occ_env2, subst_env2) id
| isDataConWrapId id -- Don't tidy constructor wrappers
is_external
(idName id)
ty' = tidyTopType (idType id)
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'
id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo'
| otherwise = mkVanillaGlobal name' ty' idinfo'
| otherwise = noUnfolding
| 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
| 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
`setNewStrictnessInfo` newStrictnessInfo core_idinfo
- -- Keep strictness; it's used by CorePrep
+ -- Keep strictness and arity; both are used by CorePrep
| otherwise
= vanillaIdInfo
| otherwise
= vanillaIdInfo
+ `setArityInfo` arityInfo core_idinfo
`setNewStrictnessInfo` newStrictnessInfo core_idinfo
`setInlinePragInfo` inlinePragInfo core_idinfo
`setUnfoldingInfo` unfold_info
`setNewStrictnessInfo` newStrictnessInfo core_idinfo
`setInlinePragInfo` inlinePragInfo core_idinfo
`setUnfoldingInfo` unfold_info
import Char ( ord, chr )
import StgSyn
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 )
import Var ( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName )
import VarEnv
import VarSet ( isEmptyVarSet )
case lookupIlxBindEnv env fun of
Just (_, StgRhsClosure _ _ _ Updatable _ _) -> Nothing
Just (place, StgRhsClosure _ _ fvs _ args _) -> Just (place,fun,args,fvs)
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
type KnownClosure = Maybe ( IlxEnv -- Of the binding site of the function
, Id -- The function