From a06f5e7b2158b57e40ebf255eb9d0b74e9625762 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 21 Nov 2002 11:31:34 +0000
Subject: [PATCH] [project @ 2002-11-21 11:31:34 by simonpj]
 -------------------------------- 	Compile instance
 declarations better 	--------------------------------

This commit makes the type checker build better dictionaries
from instance declarations.  "Better" in the sense that if a
binding in the instance declaration mentions one of the other
methods of the same class, we use that method directly rather
than going via a (recursive) use of the dictionary.

This makes it easier to unravel recursive knots, and that
makes more inlining happen.  There's a long comment in
TcInstDcls.tcMethods

Makes the Monad instance for ST much more inlinable, and that
makes spectral/fibheaps go faster, among other things.
---
 ghc/compiler/typecheck/TcInstDcls.lhs |   40 ++++++++++++++++++++++++---------
 1 file changed, 29 insertions(+), 11 deletions(-)

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 4f670fa..866741e 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -610,19 +610,37 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
     mappM (addErrTc . badMethodErr clas) bad_bndrs	`thenM_`
 
 	-- Make the method bindings
-    mapAndUnzipM do_one op_items			`thenM` \ (meth_ids, meth_binds_s) ->
+    let
+	mk_method_bind = mkMethodBind InstanceDeclOrigin clas inst_tys' monobinds
+    in
+    mapAndUnzipM mk_method_bind  op_items 	`thenM` \ (meth_insts, meth_infos) ->
+
+	-- And type check them
+	-- It's really worth making meth_insts available to the tcMethodBind
+	-- Consider	instance Monad (ST s) where
+	--		  {-# INLINE (>>) #-}
+	--		  (>>) = ...(>>=)...
+	-- If we don't include meth_insts, we end up with bindings like this:
+	--	rec { dict = MkD then bind ...
+	--	      then = inline_me (... (GHC.Base.>>= dict) ...)
+	--	      bind = ... }
+	-- The trouble is that (a) 'then' and 'dict' are mutually recursive, 
+	-- and (b) the inline_me prevents us inlining the >>= selector, which
+	-- would unravel the loop.  Result: (>>) ends up as a loop breaker, and
+	-- is not inlined across modules. Rather ironic since this does not
+	-- happen without the INLINE pragma!  
+	--
+	-- Solution: make meth_insts available, so that 'then' refers directly
+	-- 	     to the local 'bind' rather than going via the dictionary.
+    let
+	all_insts      = avail_insts ++ meth_insts
+	xtve	       = inst_tyvars `zip` inst_tyvars'
+	tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags 
+    in
+    mapM tc_method_bind meth_infos		`thenM` \ meth_binds_s ->
    
-    returnM (meth_ids, andMonoBindList meth_binds_s)
+    returnM (map instToId meth_insts, andMonoBindList meth_binds_s)
 
-  where
-    xtve = inst_tyvars `zip` inst_tyvars'
-    do_one op_item 
-	= mkMethodBind InstanceDeclOrigin clas 
-		       inst_tys' monobinds op_item 	`thenM` \ (meth_inst, meth_info) ->
-	  tcMethodBind xtve inst_tyvars' dfun_theta' 
-		       avail_insts uprags meth_info	`thenM` \ meth_bind ->
-		-- Could add meth_insts to avail_insts, but not worth the bother
-	  returnM (instToId meth_inst, meth_bind)
 
 -- Derived newtype instances
 tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' 
-- 
1.7.10.4