X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=74879f39b01b736d24758b14162cd4dd26992a92;hb=3d638f1b7b665c0e67e4e20827ad98cf307ff381;hp=3048174bef78e3bf9cb418f074e07a495e595715;hpb=79a6f3fa318020567566f92740ba6b9eb542f73f;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 3048174..74879f3 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -138,7 +138,7 @@ Running example:
   inline df_i in it, and that in turn means that (since it'll be a
   loop-breaker because df_i isn't), op1_i will ironically never be 
   inlined.  We need to fix this somehow -- perhaps allowing inlining
-  of INLINE funcitons inside other INLINE functions.
+  of INLINE functions inside other INLINE functions.
 
 Note [Subtle interaction of recursion and overlap]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -321,14 +321,15 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
 
        ; let { (local_info,
                 at_tycons_s)   = unzip local_info_tycons
-             ; at_idx_tycon    = concat at_tycons_s ++ idx_tycons
+             ; at_idx_tycons   = concat at_tycons_s ++ idx_tycons
              ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls
-             ; implicit_things = concatMap implicitTyThings at_idx_tycon
+             ; implicit_things = concatMap implicitTyThings at_idx_tycons
+	     ; aux_binds       = mkAuxBinds at_idx_tycons
              }
 
                 -- (2) Add the tycons of indexed types and their implicit
                 --     tythings to the global environment
-       ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
+       ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
 
                 -- (3) Instances from generic class declarations
        ; generic_inst_info <- getGenericInstances clas_decls
@@ -340,7 +341,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                 --   c) local family instance decls
        ; addInsts local_info         $ do {
        ; addInsts generic_inst_info  $ do {
-       ; addFamInsts at_idx_tycon    $ do {
+       ; addFamInsts at_idx_tycons   $ do {
 
                 -- (4) Compute instances from "deriving" clauses;
                 -- This stuff computes a context for the derived instance
@@ -352,13 +353,11 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
 				-- more errors still
        ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls
                                                       deriv_decls
-       ; addInsts deriv_inst_info   $ do {
-
-       ; gbl_env <- getGblEnv
+       ; gbl_env <- addInsts deriv_inst_info getGblEnv
        ; return (gbl_env,
                   generic_inst_info ++ deriv_inst_info ++ local_info,
-                  deriv_binds)
-    }}}}}}
+                  aux_binds `plusHsValBinds` deriv_binds)
+    }}}}}
   where
     -- Make sure that toplevel type instance are not for associated types.
     -- !!!TODO: Need to perform this check for the TyThing of type functions,
@@ -638,8 +637,8 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi)
         ; sc_dicts   <- newDictBndrs sc_loc sc_theta'
         ; inst_loc   <- getInstLoc origin
         ; dfun_dicts <- newDictBndrs inst_loc theta
-        ; this_dict  <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
         ; rep_dict   <- newDictBndr inst_loc rep_pred
+        ; this_dict  <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
 
         -- Figure out bindings for the superclass context from dfun_dicts
         -- Don't include this_dict in the 'givens', else
@@ -717,11 +716,12 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags)
             origin    = SigOrigin rigid_info
 
          -- Create dictionary Ids from the specified instance contexts.
-       ; sc_loc      <- getInstLoc InstScOrigin
-       ; sc_dicts    <- newDictOccs sc_loc sc_theta'		-- These are wanted
-       ; inst_loc    <- getInstLoc origin
-       ; dfun_dicts  <- newDictBndrs inst_loc dfun_theta'	-- Includes equalities
-       ; this_dict   <- newDictBndr inst_loc (mkClassPred clas inst_tys')
+       ; sc_loc     <- getInstLoc InstScOrigin
+       ; sc_dicts   <- newDictOccs sc_loc sc_theta'		-- These are wanted
+       ; inst_loc   <- getInstLoc origin
+       ; dfun_dicts <- newDictBndrs inst_loc dfun_theta'	-- Includes equalities
+       ; this_dict  <- newDictBndr inst_loc (mkClassPred clas inst_tys')
+
                 -- Default-method Ids may be mentioned in synthesised RHSs,
                 -- but they'll already be in the environment.
 
@@ -755,7 +755,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags)
        -- Create the result bindings
        ; let dict_constr   = classDataCon clas
              inline_prag | null dfun_dicts  = []
-                         | otherwise        = [L loc (InlinePrag (Inline AlwaysActive True))]
+                         | otherwise        = [L loc (InlinePrag (alwaysInlineSpec FunLike))]
                      -- Always inline the dfun; this is an experimental decision
                      -- because it makes a big performance difference sometimes.
                      -- Often it means we can do the method selection, and then