- msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
-
- dict_bind = VarMonoBind this_dict_id dict_rhs
- method_binds = andMonoBindList method_binds_s
-
- main_bind
- = AbsBinds
- zonked_inst_tyvars
- (map instToId dfun_arg_dicts)
- [(inst_tyvars', local_dfun_id, this_dict_id)]
- inlines
- (lie_binds1 `AndMonoBinds`
- lie_binds2 `AndMonoBinds`
- method_binds `AndMonoBinds`
- dict_bind)
+ msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas)
+
+ dict_bind = noLoc (VarBind this_dict_id dict_rhs)
+ all_binds = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
+
+ main_bind = noLoc $ AbsBinds
+ inst_tyvars'
+ (map instToId dfun_arg_dicts)
+ [(inst_tyvars', dfun_id, this_dict_id,
+ inline_prag ++ prags)]
+ all_binds
+ in
+ showLIE (text "instance") `thenM_`
+ returnM (unitBag main_bind)
+
+
+tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
+ avail_insts op_items (VanillaInst monobinds uprags)
+ = -- Check that all the method bindings come from this class
+ let
+ sel_names = [idName sel_id | (sel_id, _) <- op_items]
+ bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names
+ in
+ mappM (addErrTc . badMethodErr clas) bad_bndrs `thenM_`
+
+ -- Make the method bindings
+ let
+ mk_method_bind = mkMethodBind origin 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.
+ --
+ -- BUT WATCH OUT! If the method type mentions the class variable, then
+ -- this optimisation is not right. Consider
+ -- class C a where
+ -- op :: Eq a => a
+ --
+ -- instance C Int where
+ -- op = op
+ -- The occurrence of 'op' on the rhs gives rise to a constraint
+ -- op at Int
+ -- The trouble is that the 'meth_inst' for op, which is 'available', also
+ -- looks like 'op at Int'. But they are not the same.
+ let
+ prag_fn = mkPragFun uprags
+ all_insts = avail_insts ++ catMaybes meth_insts
+ tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts prag_fn
+ meth_ids = [meth_id | (_,meth_id,_) <- meth_infos]