From 74d5597ec6069dab0aacb0b7c23d68b54d0f3bb4 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 6 Mar 2008 13:50:26 +0000 Subject: [PATCH] Don't expose the unfolding of dictionary selectors without -O When compiling without -O we were getting code like this f x = case GHC.Base.$f20 of :DEq eq neq -> eq x x But because of the -O the $f20 dictionary is not available, so exposing the dictionary selector was useless. Yet it makes the code bigger! Better to get f x = GHC.Base.== GHC.Bsae.$f20 x x This patch suppresses the implicit unfolding for dictionary selectors when compiling without -O. We could do the same for other implicit Ids, but this will do for now. There should be no effect when compiling with -O. Programs should be smaller without -O and may run a tiny bit slower. --- compiler/basicTypes/MkId.lhs | 10 +++++++--- compiler/iface/BuildTyCl.lhs | 11 +++++++---- compiler/iface/TcIface.lhs | 2 +- compiler/typecheck/TcTyClsDecls.lhs | 3 ++- 4 files changed, 17 insertions(+), 9 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 665b898..7d472b1 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -827,8 +827,11 @@ at the outside. When dealing with classes it's very convenient to recover the original type signature from the class op selector. \begin{code} -mkDictSelId :: Name -> Class -> Id -mkDictSelId name clas +mkDictSelId :: Bool -- True <=> don't include the unfolding + -- Little point on imports without -O, because the + -- dictionary itself won't be visible + -> Name -> Class -> Id +mkDictSelId no_unf name clas = mkGlobalId (ClassOpId clas) name sel_ty info where sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id)) @@ -840,8 +843,9 @@ mkDictSelId name clas info = noCafIdInfo `setArityInfo` 1 - `setUnfoldingInfo` mkTopUnfolding rhs `setAllStrictnessInfo` Just strict_sig + `setUnfoldingInfo` (if no_unf then noUnfolding + else mkTopUnfolding rhs) -- We no longer use 'must-inline' on record selectors. They'll -- inline like crazy if they scrutinise a constructor diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 66cb645..fbf6dfd 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -242,14 +242,17 @@ mkTyConSelIds tycon rhs ------------------------------------------------------ \begin{code} -buildClass :: Name -> [TyVar] -> ThetaType +buildClass :: Bool -- True <=> do not include unfoldings + -- on dict selectors + -- Used when importing a class without -O + -> Name -> [TyVar] -> ThetaType -> [FunDep TyVar] -- Functional dependencies -> [TyThing] -- Associated types -> [(Name, DefMeth, Type)] -- Method info -> RecFlag -- Info for type constructor -> TcRnIf m n Class -buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec +buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec = do { traceIf (text "buildClass") ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc @@ -261,7 +264,7 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec let { rec_tycon = classTyCon rec_clas ; op_tys = [ty | (_,_,ty) <- sig_stuff] - ; op_items = [ (mkDictSelId op_name rec_clas, dm_info) + ; op_items = [ (mkDictSelId no_unf op_name rec_clas, dm_info) | (op_name, dm_info, _) <- sig_stuff ] } -- Build the selector id and default method id @@ -283,7 +286,7 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec -- D_sc1, D_sc2 -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - ; let sc_sel_ids = [mkDictSelId sc_name rec_clas | sc_name <- sc_sel_names] + ; let sc_sel_ids = [mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names] -- Use a newtype if the class constructor has exactly one field: -- i.e. exactly one operation or superclass taken together diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 339eb60..f352faf 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -423,7 +423,7 @@ tcIfaceDecl ignore_prags ; fds <- mapM tc_fd rdr_fds ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats) - ; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec + ; cls <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec ; return (AClass cls) } where tc_sig (IfaceClassOp occ dm rdr_ty) diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 6657e16..054f58b 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -776,7 +776,8 @@ tcTyClDecl1 calc_isrec tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name in - buildClass class_name tvs' ctxt' fds' ats' + buildClass False {- Must include unfoldings for selectors -} + class_name tvs' ctxt' fds' ats' sig_stuff tc_isrec) ; return (AClass clas : ats') -- NB: Order is important due to the call to `mkGlobalThings' when -- 1.7.10.4