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}
%************************************************************************
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
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 ->
)
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
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 (
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"
| 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"
-- 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 ->
-- 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
)
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
-- 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:
))
--)
\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}
projects / ghc-hetmet.git / blobdiff