--- Does one analysis pass through a list of mutually recursive bindings.
-do_one_pass :: (CPREnv, [(CoreBndr,CoreExpr)]) -> (CPREnv, [(CoreBndr,CoreExpr)])
-do_one_pass (i_rho,bounders)
- = foldl anal_bind (i_rho, []) bounders
- where
- anal_bind (c_rho, done) (b,e) = (modifyVarEnv (const e_absval') c_rho b,
- done ++ [(b,e')])
- where (e', e_absval) = cprAnalExpr c_rho e
- e_absval' = snd (pinCPR b e e_absval)
-
-
--- take a binding pair and the abs val calculated from the rhs and
--- calculate a new absval taking into account sufficient manifest
--- lambda condition and that product arguments must be non-functional
--- to have CPR property.
--- Also we pin the var's CPR property to it. This only has the CPR property if
--- its a function
-
-pinCPR :: Var -> CoreExpr -> AbsVal -> (Var, AbsVal)
-pinCPR v e av = case av of
- Tuple _ ->
- -- v is function with sufficent lambdas?
- if v_is_fn then
- if {- pprTrace "pinCPR:" (ppr v <+> text "type args:" <+>
- ppr argtys <+> text "lambda bound vars" <+>
- ppr val_binders) -} (length argtys == length val_binders) then
- (addCpr av, av)
- else (addCpr Top, Top)
- else
- -- not a function.
- -- Pin NoInfo to v. If v appears in the interface file then an
- -- importing module will check to see if it has an unfolding
- -- with a constructor at its head. If it does it will re-analyse
- -- the folding. I could do the check here, but I don't know if
- -- the current unfolding info is final.
- (addCpr Top,
- -- OK, not a function but retain CPR info if it has a constructor
- -- at its head, and thus will be inlined and simplified by
- -- case of a known constructor
- if isCon e then
- -- Need to filter out functions from nested results
- filterAbsTuple (av, v_type)
- else Top)
- _ -> (addCpr av, av)
- where
- -- func to pin CPR info on a var
- addCpr :: AbsVal -> Var
- addCpr = (setIdCprInfo v).absToCprInfo
- v_type = varType v
- -- Split argument types and result type from v's type
- (_, argtys, zz_result_type) = splitTypeToFunArgAndRes v_type
- v_is_fn = argtys /= []
- -- val_binders are the explicit lambdas at the head of the expression
- (binders,zz_stripped_exp) = collectBinders e
- val_binders = filter (not.isTyVar) binders
-
-filterAbsTuple :: (AbsVal, Type) -> AbsVal
-filterAbsTuple (av@(Tuple args), ty)
- = case split_ty of
- Nothing -> Top
- Just (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) ->
- if isNewTyCon tycon then
- ASSERT ( null $ tail inst_con_arg_tys )
- filterAbsTuple (av, head inst_con_arg_tys)
- else
- Tuple $ map filterAbsTuple $ zipEqual "cprFilter" args inst_con_arg_tys
- where
- split_ty = case splitAlgTyConApp_maybe ty of
- Just (arg_tycon, tycon_arg_tys, [data_con]) ->
- -- The main event: a single-constructor data type
- Just (data_con, arg_tycon, tycon_arg_tys, dataConArgTys data_con tycon_arg_tys)
- Just (_, _, data_cons) ->
- pprPanic "cprFilter:" (text "not one constructor" $$ ppr ty)
- -- hmmm, Isn't this a panic too?
- Nothing -> Nothing
-filterAbsTuple (av, _) = av
-
-absToCprInfo :: AbsVal -> CprInfo
-absToCprInfo (Tuple args) = CPRInfo $ map absToCprInfo args
-absToCprInfo _ = NoCPRInfo
-
-cprInfoToAbs :: CprInfo -> AbsVal
-cprInfoToAbs NoCPRInfo = Top
-cprInfoToAbs (CPRInfo args) = Tuple $ map cprInfoToAbs args
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Utilities}
-%* *
-%************************************************************************
-
-
-Now we define a couple of functions that split up types, they should
-be moved to Type.lhs if it is agreed that they are doing something
-that is sensible.
-
-\begin{code}
-
--- Split a function type into forall tyvars, argument types and result type.
--- If the type isn't a function type then tyvars and argument types will be
--- empty lists.
-
--- Experimental, look through new types. I have given up on this for now,
--- if the target of a function is a new type which is a function (see monadic
--- functions for examples) we could look into these. However, it turns out that
--- the (necessary) coercions in the code stop the beneficial simplifications.
-splitTypeToFunArgAndRes :: Type -> ([TyVar], [Type], Type)
-splitTypeToFunArgAndRes ty = (tyvars, argtys, resty)
- where (tyvars, funty) = splitForAllTys ty
- (argtys, resty) = splitFunTysIgnoringNewTypes funty
--- (argtys, resty) = splitFunTys funty
-
--- Taken from splitFunTys in Type.lhs. Modified to keep searching through newtypes
--- Should move to Type.lhs if it is doing something sensible.
-splitFunTysIgnoringNewTypes :: Type -> ([Type], Type)
-splitFunTysIgnoringNewTypes ty = split [] ty ty