\section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
\begin{code}
-#include "HsVersions.h"
-
module WwLib (
WwBinding(..),
mkWwBodies, mkWrapper
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import CoreSyn
-import Id ( idType, mkSysLocal, dataConArgTys )
-import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
+import MkId ( mkSysLocal )
+import Id ( idType, dataConArgTys, isDataCon, isNewCon, Id )
+import IdInfo ( Demand(..) )
import PrelVals ( aBSENT_ERROR_ID, voidId )
import TysPrim ( voidTy )
import SrcLoc ( noSrcLoc )
-import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
- splitForAllTy, splitFunTyExpandingDicts,
- maybeAppDataTyConExpandingDicts
+import Type ( isUnpointedType, mkTyVarTys, mkFunTys,
+ splitForAllTys, splitFunTys,
+ splitAlgTyConApp_maybe,
+ Type
)
-import UniqSupply ( returnUs, thenUs, thenMaybeUs,
- getUniques, getUnique, SYN_IE(UniqSM)
- )
-import Util ( zipWithEqual, zipEqual, assertPanic, panic )
+import TyCon ( isNewTyCon, isDataTyCon )
+import BasicTypes ( NewOrData(..) )
+import TyVar ( TyVar )
+import UniqSupply ( returnUs, thenUs, getUniques, getUnique, UniqSM )
+import Util ( zipEqual, zipWithEqual )
+import Outputable
\end{code}
%************************************************************************
-> [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,[])
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 (WwUnpack _ True _ : ds) = True -- Arg to unpack
worthSplitting (d : ds) = worthSplitting ds
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 (WwLazy True : ds) = allAbsent ds
+allAbsent (WwUnpack _ True cs : ds) = allAbsent cs && allAbsent ds
+allAbsent (d : ds) = False
+allAbsent [] = True
\end{code}
in
getUniques 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
mkWwBodies tyvars args body_ty demands
| allAbsent demands &&
- isPrimType body_ty
+ isUnpointedType 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:
-- Unpack case
-mkWW ((arg,WwUnpack True cs) : ds)
+mkWW ((arg,WwUnpack new_or_data 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),
+ 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 arg data_con tycon_arg_tys unpk_args worker_body))
+ \ 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 (maybeAppDataTyConExpandingDicts (idType arg)) of
+ = 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) -> panic "mk_ww_arg_processing: not one constr"
+ Just (_, _, data_cons) -> pprPanic "mk_ww_arg_processing: not one constr (interface files not consistent/up to date ?)" ((ppr arg) <+> (ppr (idType arg)))
Nothing -> panic "mk_ww_arg_processing: not datatype"
\begin{code}
mk_absent_let arg body
- | not (isPrimType arg_ty)
+ | not (isUnpointedType arg_ty)
= Let (NonRec arg (mkTyApp (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)
+mk_unpk_case NewType arg unpk_args boxing_con boxing_tycon body
+ -- A newtype! Use a coercion not a case
+ = ASSERT( null other_args && isNewTyCon boxing_tycon )
+ Let (NonRec unpk_arg (Note (Coerce (idType unpk_arg) (idType arg)) (Var arg)))
+ body
+ where
+ (unpk_arg:other_args) = unpk_args
+
+mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body
+ -- A data type
+ = ASSERT( isDataTyCon boxing_tycon )
+ Case (Var arg)
(AlgAlts [(boxing_con, unpk_args, body)]
NoDefault
)
-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 && isNewCon boxing_con )
+ 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
+ = ASSERT( isDataCon boxing_con )
+ Let (NonRec arg (Con boxing_con con_args)) body
where
con_args = map TyArg con_tys ++ map VarArg unpk_args
+
mk_ww_local uniq ty
= mkSysLocal SLIT("ww") uniq ty noSrcLoc
\end{code}
projects / ghc-hetmet.git / blobdiff