X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWwLib.lhs;h=a7dd9e3eba4bfe83b926c2081f2b80ab5d7ca27e;hb=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9;hp=b87bd4c61c3b5e3805fe9bc22606524e6b9729dd;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index b87bd4c..a7dd9e3 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -9,38 +9,23 @@ 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... + mkWwBodies, mAX_WORKER_ARGS ) where import Ubiq{-uitous-} +import CoreSyn +import Id ( idType, mkSysLocal, dataConArgTys ) +import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) ) import PrelInfo ( aBSENT_ERROR_ID ) -{- -import Id ( mkWorkerId, mkSysLocal, idType, - getInstantiatedDataConSig, getIdInfo, - replaceIdInfo, addIdStrictness, DataCon(..) - ) -import IdInfo -- lots of things -import Maybes ( maybeToBool, Maybe(..), MaybeErr ) -import SaLib import SrcLoc ( mkUnknownSrcLoc ) -import Type ( mkTyVarTy, mkFunTys, isPrimType, - maybeDataTyCon, quantifyTy +import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys, + maybeAppDataTyCon ) -import UniqSupply --} -import Util ( panic ) - -infixr 9 `thenWw` - -quantifyTy = panic "WwLib.quantifyTy" +import UniqSupply ( returnUs, thenUs, thenMaybeUs, + getUniques, UniqSM(..) + ) +import Util ( zipWithEqual, assertPanic, panic ) \end{code} %************************************************************************ @@ -221,7 +206,7 @@ mkWwBodies body_ty tyvars args arg_infos else -- the rest... mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos) - `thenUsMaybe` \ (wrap_frag, work_args_info, work_frag) -> + `thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) -> let (work_args, wrkr_demands) = unzip work_args_info @@ -230,7 +215,7 @@ mkWwBodies body_ty tyvars args arg_infos wrapper_w_hole = \ worker_id -> mkLam tyvars args ( wrap_frag ( - mkCoTyApps (Var worker_id) (map mkTyVarTy tyvars) + mkTyApp (Var worker_id) (mkTyVarTys tyvars) )) worker_w_hole = \ orig_body -> @@ -239,9 +224,8 @@ mkWwBodies body_ty tyvars args arg_infos ) worker_ty_w_hole = \ body_ty -> - snd (quantifyTy tyvars ( + mkForAllTys tyvars $ mkFunTys (map idType work_args) body_ty - )) in returnUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole)) where @@ -302,7 +286,7 @@ mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args 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) -> + `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> -- wrapper doesn't pass this arg to worker: returnUs (Just ( @@ -317,7 +301,7 @@ mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args where mk_absent_let arg arg_ty body = if not (isPrimType arg_ty) then - Let (NonRec arg (mkCoTyApp (Var aBSENT_ERROR_ID) arg_ty)) body + 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" @@ -326,7 +310,7 @@ 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 maybeDataTyCon arg_ty of + case maybeAppDataTyCon arg_ty of Nothing -> -- Not a data type panic "mk_ww_arg_processing: not datatype" @@ -341,8 +325,7 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args -- The main event: a single-constructor data type let - (_,inst_con_arg_tys,_) - = getInstantiatedDataConSig data_con tycon_arg_tys + inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys in getUniques (length inst_con_arg_tys) `thenUs` \ uniqs -> @@ -354,7 +337,7 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args -- 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) -> + `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> returnUs (Just ( -- wrapper: unpack the value @@ -383,7 +366,8 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args ) mk_pk_let arg boxing_con con_tys unpk_args body - = Let (NonRec arg (Con boxing_con con_tys [VarArg a | a <- unpk_args])) + = 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 @@ -394,7 +378,7 @@ mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args -- Finish args to the right... mk_ww_arg_processing args infos max_extra_args - `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) -> + `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> returnUs (Just ( -- wrapper: @@ -406,55 +390,3 @@ mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args )) --) \end{code} - -%************************************************************************ -%* * -\subsection[monad-WwLib]{Simple monad for worker/wrapper} -%* * -%************************************************************************ - -In this monad, we thread a @UniqueSupply@, and we carry a -@GlobalSwitch@-lookup function downwards. - -\begin{code} -type WwM result - = UniqSupply - -> (GlobalSwitch -> Bool) - -> result - -{-# INLINE thenWw #-} -{-# INLINE returnWw #-} - -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} - -\begin{code} -getUniqueWw :: WwM Unique -uniqSMtoWwM :: UniqSM a -> WwM a - -getUniqueWw us sw_chk = getUnique us - -uniqSMtoWwM u_obj us sw_chk = u_obj us - -thenUsMaybe :: UniqSM (Maybe a) -> (a -> UniqSM (Maybe b)) -> UniqSM (Maybe b) -thenUsMaybe m k - = m `thenUs` \ result -> - case result of - Nothing -> returnUs Nothing - Just x -> k x -\end{code}