X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWwLib.lhs;h=ac3b6ce4cf3fda814b6d54b39bde6998900c21a0;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=5367ecff625c53a9c7e6b3bbf3adb2250bbb499e;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 5367ecf..ac3b6ce 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -1,53 +1,35 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (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, - - -- our friendly worker/wrapper monad: - WwM(..), - returnWw, thenWw, mapWw, - getUniqueWw, uniqSMtoWwM, - - -- and to make the interface self-sufficient... - GlobalSwitch, CoreBinding, CoreExpr, PlainCoreBinding(..), - PlainCoreExpr(..), Id, Demand, MaybeErr, - TyVar, UniType, Unique, SplitUniqSupply, SUniqSM(..) - - IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA getSUnique) - IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily) + worthSplitting, setUnpackStrategy, + mkWwBodies, mkWrapper ) where -IMPORT_Trace -import Outputable -- ToDo: rm (debugging) -import Pretty +#include "HsVersions.h" -import AbsPrel ( aBSENT_ERROR_ID, mkFunTy ) -import AbsUniType ( mkTyVarTy, isPrimType, getUniDataTyCon_maybe, - quantifyTy, TyVarTemplate +import CoreSyn +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 CmdLineOpts ( GlobalSwitch(..) ) -import Id ( mkWorkerId, mkSysLocal, getIdUniType, - getInstantiatedDataConSig, getIdInfo, - replaceIdInfo, addIdStrictness, DataCon(..) - ) -import IdInfo -- lots of things -import Maybes ( maybeToBool, Maybe(..), MaybeErr ) -import PlainCore -import SaLib -import SrcLoc ( mkUnknownSrcLoc ) -import SplitUniq -import Unique -import Util - -infixr 9 `thenWw` +import BasicTypes ( NewOrData(..) ) +import Var ( TyVar ) +import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, UniqSM ) +import Util ( zipWithEqual ) +import Outputable \end{code} %************************************************************************ @@ -62,8 +44,8 @@ an ``intermediate form'' that can later be turned into a \tr{let} or \begin{code} data WwBinding - = WwLet [PlainCoreBinding] - | WwCase (PlainCoreExpr -> PlainCoreExpr) + = WwLet [CoreBind] + | WwCase (CoreExpr -> CoreExpr) -- the "case" will be a "strict let" of the form: -- -- case rhs of @@ -177,294 +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 - :: UniType -- 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 - - -> SUniqSM (Maybe -- Nothing iff (a) no interesting split possible - -- (b) any unpack on abstract type - (Id -> PlainCoreExpr, -- Wrapper expr w/ - -- hole for worker id - PlainCoreExpr -> PlainCoreExpr, -- Worker expr w/ hole - -- for original fn body - StrictnessInfo, -- Worker strictness info - UniType -> UniType) -- 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 returnSUs Nothing - - else -- the rest... - mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos) - `thenUsMaybe` \ (wrap_frag, work_args_info, work_frag) -> - let - (work_args, wrkr_demands) = unzip work_args_info - - wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker... - - wrapper_w_hole = \ worker_id -> - mkCoTyLam tyvars ( - mkCoLam args ( - wrap_frag ( - mkCoTyApps (CoVar worker_id) (map mkTyVarTy tyvars) - ))) - - worker_w_hole = \ orig_body -> - mkCoTyLam tyvars ( - mkCoLam work_args ( - work_frag orig_body - )) - - worker_ty_w_hole = \ body_ty -> - snd (quantifyTy tyvars ( - foldr mkFunTy body_ty (map getIdUniType work_args) - )) - in - returnSUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole)) +allAbsent :: [Demand] -> Bool +allAbsent ds = all absent ds 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 + absent (WwLazy is_absent) = is_absent + absent (WwUnpack _ True cs) = allAbsent cs + absent other = False \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. +%************************************************************************ +%* * +\subsection{The worker wrapper core} +%* * +%************************************************************************ + +@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). \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. - - -> SUniqSM (Maybe -- Nothing iff any unpack on abstract type - (PlainCoreExpr -> PlainCoreExpr, -- Wrapper expr w/ - -- hole for worker id - -- applied to types - [(Id,Demand)], -- Worker's args - -- and their strictness info - PlainCoreExpr -> PlainCoreExpr) -- Worker body expr w/ hole - ) -- for original fn body - -mk_ww_arg_processing [] _ _ = returnSUs (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) ( +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 + getUniquesUs n_wrap_args `thenUs` \ wrap_uniqs -> let - arg_ty = getIdUniType arg + (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 - mk_ww_arg_processing args infos max_extra_args - -- we've already discounted for absent args, - -- so we don't change max_extra_args - `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) -> - - -- wrapper doesn't pass this arg to worker: - returnSUs (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 - CoLet (CoNonRec arg (mkCoTyApp (CoVar 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 getUniDataTyCon_maybe 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 - returnSUs 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,_) - = getInstantiatedDataConSig data_con tycon_arg_tys - in - getSUniques (length inst_con_arg_tys) `thenSUs` \ uniqs -> - - let unpk_args = zipWith (\ 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 - `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) -> - - returnSUs (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) - )) - --) - where - arg_ty = getIdUniType 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 + mkWwBodies tyvars wrap_args final_body_ty demands `thenUs` \ (wrap_fn, _, _) -> + returnUs wrap_fn +\end{code} - mk_unpk_case arg unpk_args boxing_con boxing_tycon body - = CoCase (CoVar arg) ( - CoAlgAlts [(boxing_con, unpk_args, body)] - CoNoDefault - ) +@mkWwBodies@ is called when doing the worker/wrapper split inside a module. - mk_pk_let arg boxing_con con_tys unpk_args body - = CoLet (CoNonRec arg (CoCon boxing_con con_tys [CoVarAtom a | a <- unpk_args])) - body +\begin{code} +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 + void_arg = mk_ww_local void_arg_uniq unitTy + in + 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]) -mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args +mkWwBodies tyvars wrap_args body_ty demands | 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 - `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) -> - - returnSUs (Just ( - -- wrapper: - \ hole -> wrap_rest (CoApp hole (CoVarAtom arg)), - - -- worker: - (arg, arg_demand) : work_args_info, - \ hole -> work_rest hole - )) - --) + = 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[monad-WwLib]{Simple monad for worker/wrapper} +\subsection{Utilities} %* * %************************************************************************ -In this monad, we thread a @UniqueSupply@, and we carry a -@GlobalSwitch@-lookup function downwards. \begin{code} -type WwM result - = SplitUniqSupply - -> (GlobalSwitch -> Bool) - -> result - -#ifdef __GLASGOW_HASKELL__ -{-# INLINE thenWw #-} -{-# INLINE returnWw #-} -#endif - -returnWw :: a -> WwM a -thenWw :: WwM a -> (a -> WwM b) -> WwM b -mapWw :: (a -> WwM b) -> [a] -> WwM [b] - -returnWw expr ns sw = expr - -thenWw m k us sw_chk - = case splitUniqSupply us of { (s1, s2) -> - case (m s1 sw_chk) of { m_res -> - k m_res s2 sw_chk }} - -mapWw f [] = returnWw [] -mapWw f (x:xs) - = f x `thenWw` \ x' -> - mapWw f xs `thenWw` \ xs' -> - returnWw (x':xs') -\end{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 + +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 -\begin{code} -getUniqueWw :: WwM Unique -uniqSMtoWwM :: SUniqSM a -> WwM a +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)] -getUniqueWw us sw_chk = getSUnique us +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 -uniqSMtoWwM u_obj us sw_chk = u_obj us -thenUsMaybe :: SUniqSM (Maybe a) -> (a -> SUniqSM (Maybe b)) -> SUniqSM (Maybe b) -thenUsMaybe m k - = m `thenSUs` \ result -> - case result of - Nothing -> returnSUs Nothing - Just x -> k x +mk_ww_local uniq ty = mkSysLocal uniq ty \end{code}