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.

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 665b898..7d472b1 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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