X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWwLib.lhs;h=ac3b6ce4cf3fda814b6d54b39bde6998900c21a0;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=b28b0f995330fb683aa1e756d94cfa6171ffe9ca;hpb=08fb5925c82a5b9b0bf6c2a385c0b7a586b26fd7;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index b28b0f9..ac3b6ce 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -1,11 +1,9 @@ % -% (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(..), @@ -13,26 +11,24 @@ module WwLib ( mkWwBodies, mkWrapper ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CoreSyn -import Id ( idType, mkSysLocal, dataConArgTys, SYN_IE(Id) ) -import IdInfo ( mkStrictnessInfo, {-??nonAbsentArgs,-} Demand(..) ) -import PrelVals ( aBSENT_ERROR_ID, voidId ) -import TysPrim ( voidTy ) -import SrcLoc ( noSrcLoc ) -import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys, - splitForAllTy, splitFunTyExpandingDicts, - maybeAppDataTyConExpandingDicts, - SYN_IE(Type) - ) -import TyVar ( SYN_IE(TyVar) ) -import UniqSupply ( returnUs, thenUs, thenMaybeUs, - getUniques, getUnique, SYN_IE(UniqSM) +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 Util ( zipWithEqual, zipEqual, assertPanic, panic, pprPanic ) -import PprStyle -import Pretty +import BasicTypes ( NewOrData(..) ) +import Var ( TyVar ) +import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, UniqSM ) +import Util ( zipWithEqual ) import Outputable \end{code} @@ -48,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: -- @@ -182,15 +178,15 @@ setUnpackStrategy ds -> [Demand] -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked - go n (WwUnpack _ cs : ds) | n' >= 0 - = WwUnpack True cs' `cons` go n'' ds - | otherwise - = WwUnpack False cs `cons` go n ds - where - n' = n + 1 - nonAbsentArgs cs + 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 + (n'',cs') = go n' cs go n (d:ds) = d `cons` go n ds go n [] = (n,[]) @@ -203,16 +199,19 @@ 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 [] = False -worthSplitting (WwLazy True : ds) = True -- Absent arg -worthSplitting (WwUnpack True _ : ds) = True -- Arg to unpack -worthSplitting (d : ds) = worthSplitting ds +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 allAbsent :: [Demand] -> Bool -allAbsent (WwLazy True : ds) = allAbsent ds -allAbsent (WwUnpack True cs : ds) = allAbsent cs && allAbsent ds -allAbsent (d : ds) = False -allAbsent [] = True +allAbsent ds = all absent ds + where + absent (WwLazy is_absent) = is_absent + absent (WwUnpack _ True cs) = allAbsent cs + absent other = False \end{code} @@ -234,11 +233,19 @@ mkWrapper fun_ty demands = let n_wrap_args = length demands in - getUniques n_wrap_args `thenUs` \ wrap_uniqs -> + getUniquesUs n_wrap_args `thenUs` \ wrap_uniqs -> let - (tyvars, tau_ty) = splitForAllTy fun_ty - (arg_tys, body_ty) = splitFunTyExpandingDicts tau_ty - wrap_args = zipWith mk_ww_local wrap_uniqs arg_tys + (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 @@ -257,7 +264,7 @@ mkWwBodies :: [TyVar] -> [Id] -> Type -- Original fn args and body type mkWwBodies tyvars args body_ty demands | allAbsent demands && - isPrimType body_ty + 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: @@ -265,34 +272,37 @@ mkWwBodies tyvars args body_ty demands -- f = /\abc. \xyz. fw abc void -- fw = /\abc. \v. body -- - getUnique `thenUs` \ void_arg_uniq -> + getUniqueUs `thenUs` \ void_arg_uniq -> let - void_arg = mk_ww_local void_arg_uniq voidTy + void_arg = mk_ww_local void_arg_uniq unitTy in - returnUs (\ work_id -> mkLam tyvars args (App (mkTyApp (Var work_id) (mkTyVarTys tyvars)) (VarArg voidId)), - \ body -> mkLam tyvars [void_arg] body, + 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 args body_ty demands +mkWwBodies tyvars wrap_args body_ty demands | otherwise = let - args_w_demands = zipEqual "mkWwBodies" args demands - in - mkWW args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) -> - let - (work_args, work_demands) = unzip work_args_w_demands + wrap_args_w_demands = zipWithEqual "mkWwBodies" setIdDemandInfo wrap_args demands in - returnUs (\ work_id -> mkLam tyvars args (wrap_fn (mkTyApp (Var work_id) (mkTyVarTys tyvars))), - \ body -> mkLam tyvars work_args (work_fn body), - work_demands) + 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,Demand)] +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,Demand)], -- Worker args and their demand infos + [Id], -- Worker args; have their demand info on them CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function @@ -303,44 +313,54 @@ mkWW [] \ worker_body -> worker_body) +mkWW (arg : ds) + = case getIdDemandInfo arg of + -- Absent case -mkWW ((arg,WwLazy True) : ds) - = 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)) + 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 -mkWW ((arg,WwUnpack True cs) : ds) - = getUniques (length inst_con_arg_tys) `thenUs` \ uniqs -> - let - unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys - unpk_args_w_ds = zipEqual "mkWW" unpk_args cs - in - mkWW (unpk_args_w_ds ++ ds) `thenUs` \ (wrap_fn, worker_args, work_fn) -> - returnUs (\ wrapper_body -> mk_unpk_case arg unpk_args data_con arg_tycon (wrap_fn wrapper_body), - worker_args, - \ worker_body -> work_fn (mk_pk_let 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 (maybeAppDataTyConExpandingDicts (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: not one constr (interface files not consistent/up to date ?)" ((ppr PprDebug arg) <+> (ppr PprDebug (idType arg))) - Nothing -> panic "mk_ww_arg_processing: not datatype" + 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 -mkWW ((arg,other_demand) : ds) - = mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) -> - returnUs (\ wrapper_body -> wrap_fn (App wrapper_body (VarArg arg)), - (arg,other_demand) : worker_args, - work_fn) + 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} @@ -353,24 +373,37 @@ mkWW ((arg,other_demand) : ds) \begin{code} mk_absent_let arg body - | not (isPrimType arg_ty) - = Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) 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 arg unpk_args boxing_con boxing_tycon body - = Case (Var arg) - (AlgAlts [(boxing_con, unpk_args, body)] - NoDefault - ) +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_pk_let arg boxing_con con_tys unpk_args body - = Let (NonRec arg (Con boxing_con con_args)) body +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 - con_args = map TyArg con_tys ++ map VarArg unpk_args + (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_ww_local uniq ty - = mkSysLocal SLIT("ww") uniq ty noSrcLoc +mk_ww_local uniq ty = mkSysLocal uniq ty \end{code}