X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWwLib.lhs;h=ac3b6ce4cf3fda814b6d54b39bde6998900c21a0;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=a7dd9e3eba4bfe83b926c2081f2b80ab5d7ca27e;hpb=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index a7dd9e3..ac3b6ce 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -1,31 +1,35 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % \section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser} \begin{code} -#include "HsVersions.h" - module WwLib ( WwBinding(..), - mkWwBodies, mAX_WORKER_ARGS + worthSplitting, setUnpackStrategy, + mkWwBodies, mkWrapper ) where -import Ubiq{-uitous-} +#include "HsVersions.h" import CoreSyn -import Id ( idType, mkSysLocal, dataConArgTys ) -import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) ) -import PrelInfo ( aBSENT_ERROR_ID ) -import SrcLoc ( mkUnknownSrcLoc ) -import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys, - maybeAppDataTyCon +import Id ( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo ) +import Const ( Con(..) ) +import DataCon ( dataConArgTys ) +import Demand ( Demand(..) ) +import PrelVals ( aBSENT_ERROR_ID ) +import TysWiredIn ( unitTy, unitDataCon ) +import Type ( isUnLiftedType, mkTyVarTys, mkTyVarTy, mkFunTys, + splitForAllTys, splitFunTys, + splitAlgTyConApp_maybe, + Type ) -import UniqSupply ( returnUs, thenUs, thenMaybeUs, - getUniques, UniqSM(..) - ) -import Util ( zipWithEqual, assertPanic, panic ) +import BasicTypes ( NewOrData(..) ) +import Var ( TyVar ) +import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, UniqSM ) +import Util ( zipWithEqual ) +import Outputable \end{code} %************************************************************************ @@ -40,7 +44,7 @@ an ``intermediate form'' that can later be turned into a \tr{let} or \begin{code} data WwBinding - = WwLet [CoreBinding] + = WwLet [CoreBind] | WwCase (CoreExpr -> CoreExpr) -- the "case" will be a "strict let" of the form: -- @@ -155,238 +159,251 @@ probably slightly paranoid, but OK in practice.) If it isn't the same, we ``revise'' the strictness info, so that we won't propagate the unusable strictness-info into the interfaces. -========================== -Here's the real fun... The wrapper's ``deconstructing'' of arguments -and the worker's putting them back together again are ``duals'' in -some sense. +%************************************************************************ +%* * +\subsection{Functions over Demands} +%* * +%************************************************************************ -What we do is walk along the @Demand@ list, producing two -expressions (one for wrapper, one for worker...), each with a ``hole'' -in it, where we will later plug in more information. For our previous -example, the expressions-with-HOLES are: -\begin{verbatim} -\ x ys -> -- wrapper - case x of - I# x# -> <> x# ys +\begin{code} +mAX_WORKER_ARGS :: Int -- ToDo: set via flag +mAX_WORKER_ARGS = 6 -\ x# ys -> -- worker - let - x = I# x# - in - <> -\end{verbatim} -(Actually, we add the lambda-bound arguments at the end...) (The big -Lambdas are added on the front later.) +setUnpackStrategy :: [Demand] -> [Demand] +setUnpackStrategy ds + = snd (go (mAX_WORKER_ARGS - nonAbsentArgs ds) ds) + where + go :: Int -- Max number of args available for sub-components of [Demand] + -> [Demand] + -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked + + go n (WwUnpack nd _ cs : ds) | n' >= 0 + = WwUnpack nd True cs' `cons` go n'' ds + | otherwise + = WwUnpack nd False cs `cons` go n ds + where + n' = n + 1 - nonAbsentArgs cs + -- Add one because we don't pass the top-level arg any more + -- Delete # of non-absent args to which we'll now be committed + (n'',cs') = go n' cs + + go n (d:ds) = d `cons` go n ds + go n [] = (n,[]) + + cons d (n,ds) = (n, d:ds) + +nonAbsentArgs :: [Demand] -> Int +nonAbsentArgs [] = 0 +nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds +nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds + +worthSplitting :: [Demand] -> Bool -- True <=> the wrapper would not be an identity function +worthSplitting ds = any worth_it ds + where + worth_it (WwLazy True) = True -- Absent arg + worth_it (WwUnpack _ True _) = True -- Arg to unpack + worth_it WwStrict = True + worth_it other = False -\begin{code} -mkWwBodies - :: Type -- Type of the *body* of the orig - -- function; i.e. /\ tyvars -> \ vars -> body - -> [TyVar] -- Type lambda vars of original function - -> [Id] -- Args of original function - -> [Demand] -- Strictness info for those args - - -> UniqSM (Maybe -- Nothing iff (a) no interesting split possible - -- (b) any unpack on abstract type - (Id -> CoreExpr, -- Wrapper expr w/ - -- hole for worker id - CoreExpr -> CoreExpr, -- Worker expr w/ hole - -- for original fn body - StrictnessInfo, -- Worker strictness info - Type -> Type) -- Worker type w/ hole - ) -- for type of original fn body - - -mkWwBodies body_ty tyvars args arg_infos - = ASSERT(length args == length arg_infos) - -- or you can get disastrous user/definer-module mismatches - if (all_absent_args_and_unboxed_value body_ty arg_infos) - then returnUs Nothing - - else -- the rest... - mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos) - `thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) -> - let - (work_args, wrkr_demands) = unzip work_args_info +allAbsent :: [Demand] -> Bool +allAbsent ds = all absent ds + where + absent (WwLazy is_absent) = is_absent + absent (WwUnpack _ True cs) = allAbsent cs + absent other = False +\end{code} - wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker... - wrapper_w_hole = \ worker_id -> - mkLam tyvars args ( - wrap_frag ( - mkTyApp (Var worker_id) (mkTyVarTys tyvars) - )) +%************************************************************************ +%* * +\subsection{The worker wrapper core} +%* * +%************************************************************************ - worker_w_hole = \ orig_body -> - mkLam tyvars work_args ( - work_frag orig_body - ) +@mkWrapper@ is called when importing a function. We have the type of +the function and the name of its worker, and we want to make its body (the wrapper). - worker_ty_w_hole = \ body_ty -> - mkForAllTys tyvars $ - mkFunTys (map idType work_args) body_ty +\begin{code} +mkWrapper :: Type -- Wrapper type + -> [Demand] -- Wrapper strictness info + -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id + +mkWrapper fun_ty demands + = let + n_wrap_args = length demands in - returnUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole)) - where - -- "all_absent_args_and_unboxed_value": - -- check for the obscure case of "\ x y z ... -> body" where - -- (a) *all* of the args x, y, z,... are absent, and - -- (b) the type of body is unboxed - -- If these conditions are true, we must *not* play worker/wrapper games! - - all_absent_args_and_unboxed_value body_ty arg_infos - = not (null arg_infos) - && all is_absent_arg arg_infos - && isPrimType body_ty - - is_absent_arg (WwLazy True) = True - is_absent_arg _ = False + getUniquesUs n_wrap_args `thenUs` \ wrap_uniqs -> + let + (tyvars, tau_ty) = splitForAllTys fun_ty + (arg_tys, body_ty) = splitFunTys tau_ty + -- The "expanding dicts" part here is important, even for the splitForAll + -- The imported thing might be a dictionary, such as Functor Foo + -- But Functor Foo = forall a b. (a->b) -> Foo a -> Foo b + -- and as such might have some strictness info attached. + -- Then we need to have enough args to zip to the strictness info + + wrap_args = ASSERT( n_wrap_args <= length arg_tys ) + zipWith mk_ww_local wrap_uniqs arg_tys + + leftover_arg_tys = drop n_wrap_args arg_tys + final_body_ty = mkFunTys leftover_arg_tys body_ty + in + mkWwBodies tyvars wrap_args final_body_ty demands `thenUs` \ (wrap_fn, _, _) -> + returnUs wrap_fn \end{code} -Important: mk_ww_arg_processing doesn't check -for an "interesting" split. It just races ahead and makes the -split, even if there's no unpacking at all. This is important for -when it calls itself recursively. - -It returns Nothing only if it encounters an abstract type in mid-flight. +@mkWwBodies@ is called when doing the worker/wrapper split inside a module. \begin{code} -mAX_WORKER_ARGS :: Int -- ToDo: set via flag -mAX_WORKER_ARGS = 6 -- Hmm... but this is an everything-must- - -- be-compiled-with-the-same-val thing... - -mk_ww_arg_processing - :: [Id] -- Args of original function - -> [Demand] -- Strictness info for those args - -- must be at least as long as args - - -> Int -- Number of extra args we are prepared to add. - -- This prevents over-eager unpacking, leading - -- to huge-arity functions. - - -> UniqSM (Maybe -- Nothing iff any unpack on abstract type - (CoreExpr -> CoreExpr, -- Wrapper expr w/ - -- hole for worker id - -- applied to types - [(Id,Demand)], -- Worker's args - -- and their strictness info - CoreExpr -> CoreExpr) -- Worker body expr w/ hole - ) -- for original fn body - -mk_ww_arg_processing [] _ _ = returnUs (Just (id, [], id)) - -mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args - = -- Absent argument - -- So, finish args to the right... - --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) ( +mkWwBodies :: [TyVar] -> [Id] -> Type -- Original fn args and body type + -> [Demand] -- Strictness info for original fn; corresp 1-1 with args + -> UniqSM (Id -> CoreExpr, -- Wrapper body, lacking only the worker Id + CoreExpr -> CoreExpr, -- Worker body, lacking the original function body + [Demand]) -- Strictness info for worker + +mkWwBodies tyvars args body_ty demands + | allAbsent demands && + isUnLiftedType body_ty + = -- Horrid special case. If the worker would have no arguments, and the + -- function returns a primitive type value, that would make the worker into + -- an unboxed value. We box it by passing a dummy void argument, thus: + -- + -- f = /\abc. \xyz. fw abc void + -- fw = /\abc. \v. body + -- + getUniqueUs `thenUs` \ void_arg_uniq -> let - arg_ty = idType arg + void_arg = mk_ww_local void_arg_uniq unitTy in - mk_ww_arg_processing args infos max_extra_args - -- we've already discounted for absent args, - -- so we don't change max_extra_args - `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> - - -- wrapper doesn't pass this arg to worker: - returnUs (Just ( - -- wrapper: - \ hole -> wrap_rest hole, - - -- worker: - work_args_info, -- NB: no argument added - \ hole -> mk_absent_let arg arg_ty (work_rest hole) - )) - --) - where - mk_absent_let arg arg_ty body - = if not (isPrimType arg_ty) then - Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body - else -- quite horrible - panic "WwLib: haven't done mk_absent_let for primitives yet" - - -mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args - | new_max_extra_args > 0 -- Check that we are prepared to add arguments - = -- this is the complicated one. - --pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) ( - case maybeAppDataTyCon arg_ty of - - Nothing -> -- Not a data type - panic "mk_ww_arg_processing: not datatype" - - Just (_, _, []) -> -- An abstract type - -- We have to give up on the whole idea - returnUs Nothing - Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd - panic "mk_ww_arg_processing: multi-constr" - - Just (arg_tycon, tycon_arg_tys, [data_con]) -> - -- The main event: a single-constructor data type - - let - inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys - in - getUniques (length inst_con_arg_tys) `thenUs` \ uniqs -> - - let - unpk_args = zipWithEqual - (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc) - uniqs inst_con_arg_tys - in - -- In processing the rest, push the sub-component args - -- and infos on the front of the current bunch - mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args - `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> - - returnUs (Just ( - -- wrapper: unpack the value - \ hole -> mk_unpk_case arg unpk_args - data_con arg_tycon - (wrap_rest hole), - - -- worker: expect the unpacked value; - -- reconstruct the orig value with a "let" - work_args_info, - \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole) - )) - --) + returnUs (\ work_id -> mkLams tyvars $ mkLams args $ + mkApps (Var work_id) + (map (Type . mkTyVarTy) tyvars ++ [mkConApp unitDataCon []]), + \ body -> mkLams (tyvars ++ [void_arg]) body, + [WwLazy True]) + +mkWwBodies tyvars wrap_args body_ty demands + | otherwise + = let + wrap_args_w_demands = zipWithEqual "mkWwBodies" setIdDemandInfo wrap_args demands + in + mkWW wrap_args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) -> + returnUs (\ work_id -> mkLams tyvars $ mkLams wrap_args_w_demands $ + wrap_fn (mkTyApps (Var work_id) (mkTyVarTys tyvars)), + + \ body -> mkLams tyvars $ mkLams work_args_w_demands $ + work_fn body, + + map getIdDemandInfo work_args_w_demands) +\end{code} + + +\begin{code} +mkWW :: [Id] -- Wrapper args; have their demand info on them + -> UniqSM (CoreExpr -> CoreExpr, -- Wrapper body, lacking the inner call to the worker + -- and without its lambdas + [Id], -- Worker args; have their demand info on them + CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function + + + -- Empty case +mkWW [] + = returnUs (\ wrapper_body -> wrapper_body, + [], + \ worker_body -> worker_body) + + +mkWW (arg : ds) + = case getIdDemandInfo arg of + + -- Absent case + WwLazy True -> + mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) -> + returnUs (\ wrapper_body -> wrap_fn wrapper_body, + worker_args, + \ worker_body -> mk_absent_let arg (work_fn worker_body)) + + + -- Unpack case + WwUnpack new_or_data True cs -> + getUniquesUs (length inst_con_arg_tys) `thenUs` \ uniqs -> + let + unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys + unpk_args_w_ds = zipWithEqual "mkWW" setIdDemandInfo unpk_args cs + in + mkWW (unpk_args_w_ds ++ ds) `thenUs` \ (wrap_fn, worker_args, work_fn) -> + returnUs (\ wrapper_body -> mk_unpk_case new_or_data arg unpk_args data_con arg_tycon + (wrap_fn wrapper_body), + worker_args, + \ worker_body -> work_fn (mk_pk_let new_or_data arg data_con + tycon_arg_tys unpk_args worker_body)) + where + inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys + (arg_tycon, tycon_arg_tys, data_con) + = case (splitAlgTyConApp_maybe (idType arg)) of + + Just (arg_tycon, tycon_arg_tys, [data_con]) -> + -- The main event: a single-constructor data type + (arg_tycon, tycon_arg_tys, data_con) + + Just (_, _, data_cons) -> + pprPanic "mk_ww_arg_processing:" + (text "not one constr (interface files not consistent/up to date?)" + $$ (ppr arg <+> ppr (idType arg))) + + Nothing -> + panic "mk_ww_arg_processing: not datatype" + + + -- Other cases + other_demand -> + mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) -> + returnUs (\ wrapper_body -> wrap_fn (App wrapper_body (Var arg)), + arg : worker_args, + work_fn) +\end{code} + + +%************************************************************************ +%* * +\subsection{Utilities} +%* * +%************************************************************************ + + +\begin{code} +mk_absent_let arg body + | not (isUnLiftedType arg_ty) + = Let (NonRec arg (mkTyApps (Var aBSENT_ERROR_ID) [arg_ty])) body + | otherwise + = panic "WwLib: haven't done mk_absent_let for primitives yet" where arg_ty = idType arg - new_max_extra_args - = max_extra_args - + 1 -- We won't pass the original arg now - - nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt +mk_unpk_case NewType arg unpk_args boxing_con boxing_tycon body + -- A newtype! Use a coercion not a case + = ASSERT( null other_args ) + Case (Note (Coerce (idType unpk_arg) (idType arg)) (Var arg)) + unpk_arg + [(DEFAULT,[],body)] + where + (unpk_arg:other_args) = unpk_args + +mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body + -- A data type + = Case (Var arg) arg [(DataCon boxing_con, unpk_args, body)] - mk_unpk_case arg unpk_args boxing_con boxing_tycon body - = Case (Var arg) ( - AlgAlts [(boxing_con, unpk_args, body)] - NoDefault - ) +mk_pk_let NewType arg boxing_con con_tys unpk_args body + = ASSERT( null other_args ) + Let (NonRec arg (Note (Coerce (idType arg) (idType unpk_arg)) (Var unpk_arg))) body + where + (unpk_arg:other_args) = unpk_args + +mk_pk_let DataType arg boxing_con con_tys unpk_args body + = Let (NonRec arg (Con (DataCon boxing_con) con_args)) body + where + con_args = map Type con_tys ++ map Var unpk_args - mk_pk_let arg boxing_con con_tys unpk_args body - = Let (NonRec arg (Con boxing_con - (map TyArg con_tys ++ map VarArg unpk_args))) - body -mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args - | otherwise - = -- For all others at the moment, we just - -- pass them to the worker unchanged. - --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) ( - - -- Finish args to the right... - mk_ww_arg_processing args infos max_extra_args - `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> - - returnUs (Just ( - -- wrapper: - \ hole -> wrap_rest (App hole (VarArg arg)), - - -- worker: - (arg, arg_demand) : work_args_info, - \ hole -> work_rest hole - )) - --) +mk_ww_local uniq ty = mkSysLocal uniq ty \end{code}