Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc

compiler/coreSyn/CoreUtils.lhs

@@ -1456,7 +1456,11 @@ exprStats (Cast e co)     = coStats co `plusCS` exprStats e
 exprStats (Tick _ e)      = exprStats e
 
 altStats :: CoreAlt -> CoreStats
-altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r
+altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r
+
+altBndrStats :: [Var] -> CoreStats
+-- Charge one for the alternative, not for each binder
+altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs
 
 tyStats :: Type -> CoreStats
 tyStats ty = zeroCS { cs_ty = typeSize ty }

compiler/typecheck/TcGenDeriv.lhs

@@ -101,105 +101,94 @@ data DerivStuff     -- Please add this auxiliary stuff
 %*                                                                      *
 %************************************************************************
 
-Here are the heuristics for the code we generate for @Eq@:
-\begin{itemize}
-\item
-  Let's assume we have a data type with some (possibly zero) nullary
-  data constructors and some ordinary, non-nullary ones (the rest,
-  also possibly zero of them).  Here's an example, with both \tr{N}ullary
-  and \tr{O}rdinary data cons.
-\begin{verbatim}
-data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
-\end{verbatim}
+Here are the heuristics for the code we generate for @Eq@. Let's
+assume we have a data type with some (possibly zero) nullary data
+constructors and some ordinary, non-nullary ones (the rest, also
+possibly zero of them).  Here's an example, with both \tr{N}ullary and
+\tr{O}rdinary data cons.
+
+  data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 
-\item
-  For the ordinary constructors (if any), we emit clauses to do The
+* For the ordinary constructors (if any), we emit clauses to do The
   Usual Thing, e.g.,:
 
-\begin{verbatim}
-(==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
-(==) (O2 a1)       (O2 a2)       = a1 == a2
-(==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
-\end{verbatim}
+    (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
+    (==) (O2 a1)       (O2 a2)       = a1 == a2
+    (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
 
-  Note: if we're comparing unlifted things, e.g., if \tr{a1} and
-  \tr{a2} are \tr{Float#}s, then we have to generate
-\begin{verbatim}
-case (a1 `eqFloat#` a2) of
-  r -> r
-\end{verbatim}
+  Note: if we're comparing unlifted things, e.g., if 'a1' and
+  'a2' are Float#s, then we have to generate
+       case (a1 `eqFloat#` a2) of r -> r
   for that particular test.
 
-\item
-  If there are any nullary constructors, we emit a catch-all clause of
-  the form:
+* If there are a lot of (more than en) nullary constructors, we emit a
+  catch-all clause of the form:
 
-\begin{verbatim}
-(==) a b  = case (con2tag_Foo a) of { a# ->
-            case (con2tag_Foo b) of { b# ->
-            case (a# ==# b#)     of {
-              r -> r
-            }}}
-\end{verbatim}
+      (==) a b  = case (con2tag_Foo a) of { a# ->
+                  case (con2tag_Foo b) of { b# ->
+                  case (a# ==# b#)     of {
+                    r -> r }}}
 
-  If there aren't any nullary constructors, we emit a simpler
+  If con2tag gets inlined this leads to join point stuff, so
+  it's better to use regular pattern matching if there aren't too
+  many nullary constructors.  "Ten" is arbitrary, of course
+
+* If there aren't any nullary constructors, we emit a simpler
   catch-all:
-\begin{verbatim}
-(==) a b  = False
-\end{verbatim}
 
-\item
-  For the @(/=)@ method, we normally just use the default method.
+     (==) a b  = False
 
+* For the @(/=)@ method, we normally just use the default method.
   If the type is an enumeration type, we could/may/should? generate
   special code that calls @con2tag_Foo@, much like for @(==)@ shown
   above.
 
-\item
-  We thought about doing this: If we're also deriving @Ord@ for this
-  tycon, we generate:
-\begin{verbatim}
-instance ... Eq (Foo ...) where
-  (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
-  (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
-\begin{verbatim}
-  However, that requires that \tr{Ord <whatever>} was put in the context
-  for the instance decl, which it probably wasn't, so the decls
-  produced don't get through the typechecker.
-\end{itemize}
-
+We thought about doing this: If we're also deriving 'Ord' for this
+tycon, we generate:
+  instance ... Eq (Foo ...) where
+    (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
+    (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
+However, that requires that (Ord <whatever>) was put in the context
+for the instance decl, which it probably wasn't, so the decls
+produced don't get through the typechecker.
 
 \begin{code}
 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Eq_binds loc tycon
   = (method_binds, aux_binds)
   where
-    (nullary_cons, non_nullary_cons)
-       | isNewTyCon tycon = ([], tyConDataCons tycon)
-       | otherwise        = partition isNullarySrcDataCon (tyConDataCons tycon)
+    all_cons = tyConDataCons tycon
+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
 
-    no_nullary_cons = null nullary_cons
+    -- If there are ten or more (arbitrary number) nullary constructors,
+    -- use the con2tag stuff.  For small types it's better to use
+    -- ordinary pattern matching.
+    (tag_match_cons, pat_match_cons)
+       | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)
+       | otherwise                       = ([],           all_cons)
+
+    no_tag_match_cons = null tag_match_cons
 
     fall_through_eqn
-      | no_nullary_cons   -- All constructors have arguments
-      = case non_nullary_cons of
+      | no_tag_match_cons   -- All constructors have arguments
+      = case pat_match_cons of
           []  -> []   -- No constructors; no fall-though case
           [_] -> []   -- One constructor; no fall-though case
           _   ->      -- Two or more constructors; add fall-through of
                       --       (==) _ _ = False
                  [([nlWildPat, nlWildPat], false_Expr)]
 
-      | otherwise -- One or more nullary cons; add fall-through of
+      | otherwise -- One or more tag_match cons; add fall-through of
                   -- extract tags compare for equality
       = [([a_Pat, b_Pat],
          untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
                     (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 
-    aux_binds | no_nullary_cons = emptyBag
-              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
+    aux_binds | no_tag_match_cons = emptyBag
+              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
 
     method_binds = listToBag [eq_bind, ne_bind]
-    eq_bind = mk_FunBind loc eq_RDR (map pats_etc non_nullary_cons ++ fall_through_eqn)
+    eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
     ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
                         nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))