Improve typechecking of instance defaults
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 23 Jun 2016 13:51:22 +0000 (14:51 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 24 Jun 2016 10:04:21 +0000 (11:04 +0100)
In an instance declaration when you don't specify the code for a
method, GHC fills in from the default binding in the class.
The type of the default method can legitmiately be ambiguous ---
see Note [Default methods in instances] in TcInstDcls --- so
typechecking it can be tricky.

Trac #12220 showed that although we were dealing with that ambiguity
for /vanilla/ default methods, we were not doing so for /generic/
default methods.  Moreover we were dealing with it clumsily, by
generating post-typechecked code.

This patch fixes the bug AND deletes code!  We now use the same code
path for both vanilla and generic default methods; and generate
/pre-typechecked/ code in both cases.  The key trick is that we can use
Visible Type Application to deal with the ambiguity, which wasn't
possible before.  Hooray.

There is a small hit to performance in compiler/perf/T1969 which
consists of nothing BUT instance declarations with several default
methods to fill, which we now have to typecheck. The actual hit is
from 724 -> 756 or 4% in that extreme example.  Real world programs
have vastly fewer instance decls.

compiler/coreSyn/TrieMap.hs
compiler/iface/IfaceType.hs
compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcInstDcls.hs
testsuite/tests/generics/GShow/GShow.hs
testsuite/tests/generics/GenDerivOutput.stderr
testsuite/tests/generics/T10604/T10604_deriving.stderr
testsuite/tests/generics/T12220.hs [new file with mode: 0755]
testsuite/tests/generics/all.T
testsuite/tests/perf/compiler/all.T

index a37758c..c6b9f8e 100644 (file)
@@ -837,7 +837,8 @@ instance Eq (DeBruijn Type) where
             -> True
         _ -> False
 
-instance Outputable a => Outputable (TypeMapG a) where
+instance {-# OVERLAPPING #-}
+         Outputable a => Outputable (TypeMapG a) where
   ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m [])
 
 emptyT :: TypeMapX a
index 5a4e036..5f30042 100644 (file)
@@ -691,9 +691,6 @@ ppr_iface_sigma_type show_foralls_unconditionally ty
     (tvs, theta, tau) = splitIfaceSigmaTy ty
 
 -------------------
-instance Outputable IfaceForAllBndr where
-  ppr = pprIfaceForAllBndr
-
 pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfaceType] -> SDoc -> SDoc
 pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part False tvs ctxt sdoc
 
index d0978fb..6e112a2 100644 (file)
@@ -199,7 +199,7 @@ tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
 
 tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
           (sel_id, Just (dm_name, dm_spec))
-  | Just (L bind_loc dm_bind, bndr_loc) <- findMethodBind sel_name binds_in
+  | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn
   = do { -- First look up the default method -- It should be there!
          global_dm_id  <- tcLookupId dm_name
        ; global_dm_id  <- addInlinePrags global_dm_id prags
@@ -266,7 +266,6 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
   | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
   where
     sel_name = idName sel_id
-    prags    = lookupPragEnv prag_fn sel_name
     no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;
                                 -- they are all for meth_id
 
@@ -326,17 +325,21 @@ lookupHsSig :: HsSigFun -> Name -> Maybe (LHsSigType Name)
 lookupHsSig = lookupNameEnv
 
 ---------------------------
-findMethodBind  :: Name                 -- Selector name
+findMethodBind  :: Name                 -- Selector
                 -> LHsBinds Name        -- A group of bindings
-                -> Maybe (LHsBind Name, SrcSpan)
-                -- Returns the binding, and the binding
-                -- site of the method binder
-findMethodBind sel_name binds
+                -> TcPragEnv
+                -> Maybe (LHsBind Name, SrcSpan, [LSig Name])
+                -- Returns the binding, the binding
+                -- site of the method binder, and any inline or
+                -- specialisation pragmas
+findMethodBind sel_name binds prag_fn
   = foldlBag mplus Nothing (mapBag f binds)
   where
+    prags    = lookupPragEnv prag_fn sel_name
+
     f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
       | op_name == sel_name
-             = Just (bind, bndr_loc)
+             = Just (bind, bndr_loc, prags)
     f _other = Nothing
 
 ---------------------------
index 511a9a6..b736735 100644 (file)
@@ -731,16 +731,15 @@ tcInstDecls2 tycl_decls inst_decls
         ; let dm_ids = collectHsBindsBinders dm_binds
               -- Add the default method Ids (again)
               -- (they were arready added in TcTyDecls.tcAddImplicits)
-              -- See Note [Default methods and instances]
+              -- See Note [Default methods in the type environment]
         ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $
                           mapM tcInstDecl2 inst_decls
 
           -- Done
         ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
 
-{-
-See Note [Default methods and instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Default methods in the type environment]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The default method Ids are already in the type environment (see Note
 [Default method Ids and Template Haskell] in TcTyDcls), BUT they
 don't have their InlinePragmas yet.  Usually that would not matter,
@@ -1224,7 +1223,7 @@ tcMethods :: DFunId -> Class
         -- The returned inst_meth_ids all have types starting
         --      forall tvs. theta => ...
 tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
-                  dfun_ev_binds prags@(spec_inst_prags,_) op_items
+                  dfun_ev_binds (spec_inst_prags, prag_fn) op_items
                   (InstBindings { ib_binds      = binds
                                 , ib_tyvars     = lexical_tvs
                                 , ib_pragmas    = sigs
@@ -1247,9 +1246,10 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
     ----------------------
     tc_item :: ClassOpItem -> TcM (Id, LHsBind Id, Maybe Implication)
     tc_item (sel_id, dm_info)
-      | Just (user_bind, bndr_loc) <- findMethodBind (idName sel_id) binds
+      | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn
       = tcMethodBody clas tyvars dfun_ev_vars inst_tys
-                              dfun_ev_binds is_derived hs_sig_fn prags
+                              dfun_ev_binds is_derived hs_sig_fn
+                              spec_inst_prags prags
                               sel_id user_bind bndr_loc
       | otherwise
       = do { traceTc "tc_def" (ppr sel_id)
@@ -1258,11 +1258,12 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
     ----------------------
     tc_default :: Id -> DefMethInfo -> TcM (TcId, LHsBind Id, Maybe Implication)
 
-    tc_default sel_id (Just (dm_name, GenericDM {}))
-      = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
+    tc_default sel_id (Just (dm_name, _))
+      = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name
            ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
-                                  dfun_ev_binds is_derived hs_sig_fn prags
-                                  sel_id meth_bind inst_loc }
+                          dfun_ev_binds is_derived hs_sig_fn
+                          spec_inst_prags inline_prags
+                          sel_id meth_bind inst_loc }
 
     tc_default sel_id Nothing     -- No default method at all
       = do { traceTc "tc_def: warn" (ppr sel_id)
@@ -1286,65 +1287,24 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                               (hcat [ppr inst_loc, vbar, ppr sel_id ])
         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
 
-    tc_default sel_id (Just (dm_name, VanillaDM)) -- A polymorphic default method
-      = do {     -- Build the typechecked version directly,
-                 -- without calling typecheck_method;
-                 -- see Note [Default methods in instances]
-                 -- Generate   /\as.\ds. let self = df as ds
-                 --                      in $dm inst_tys self
-                 -- The 'let' is necessary only because HsSyn doesn't allow
-                 -- you to apply a function to a dictionary *expression*.
-
-           ; self_dict <- newDict clas inst_tys
-           ; let ev_term = EvDFunApp dfun_id (mkTyVarTys tyvars)
-                                     (map EvId dfun_ev_vars)
-                 self_ev_bind = mkWantedEvBind self_dict ev_term
-
-           ; (meth_id, local_meth_id)
-                   <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
-           ; dm_id <- tcLookupId dm_name
-           ; let dm_inline_prag = idInlinePragma dm_id
-                 rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
-                       HsVar (noLoc dm_id)
-
-                 meth_bind = mkVarBind local_meth_id (L inst_loc rhs)
-                 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
-                        -- Copy the inline pragma (if any) from the default
-                        -- method to this version. Note [INLINE and default methods]
-
-                 export = ABE { abe_wrap = idHsWrapper
-                              , abe_poly = meth_id1
-                              , abe_mono = local_meth_id
-                              , abe_prags = mk_meth_spec_prags meth_id1 spec_inst_prags [] }
-                 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
-                                 , abs_exports = [export]
-                                 , abs_ev_binds = [EvBinds (unitBag self_ev_bind)]
-                                 , abs_binds    = unitBag meth_bind }
-             -- Default methods in an instance declaration can't have their own
-             -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
-             -- currently they are rejected with
-             --           "INLINE pragma lacks an accompanying binding"
-
-           ; return (meth_id1, L inst_loc bind, Nothing) }
-
     ----------------------
     -- Check if one of the minimal complete definitions is satisfied
     checkMinimalDefinition
       = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
-          warnUnsatisfiedMinimalDefinition
-      where
-      methodExists meth = isJust (findMethodBind meth binds)
+        warnUnsatisfiedMinimalDefinition
+
+    methodExists meth = isJust (findMethodBind meth binds prag_fn)
 
 ------------------------
 tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
              -> TcEvBinds -> Bool
              -> HsSigFun
-             -> ([LTcSpecPrag], TcPragEnv)
+             -> [LTcSpecPrag] -> [LSig Name]
              -> Id -> LHsBind Name -> SrcSpan
              -> TcM (TcId, LHsBind Id, Maybe Implication)
 tcMethodBody clas tyvars dfun_ev_vars inst_tys
                      dfun_ev_binds is_derived
-                     sig_fn (spec_inst_prags, prag_fn)
+                     sig_fn spec_inst_prags prags
                      sel_id (L bind_loc meth_bind) bndr_loc
   = add_meth_ctxt $
     do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)
@@ -1352,8 +1312,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
                                             mkMethIds clas tyvars dfun_ev_vars
                                                       inst_tys sel_id
 
-       ; let prags   = lookupPragEnv prag_fn (idName sel_id)
-             lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
+       ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
                        -- Substitute the local_meth_name for the binder
                        -- NB: the binding is always a FunBind
 
@@ -1553,21 +1512,41 @@ mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
          | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
 
 
-mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
-mkGenericDefMethBind clas inst_tys sel_id dm_name
-  =     -- A generic default method
-        -- If the method is defined generically, we only have to call the
-        -- dm_name.
-    do  { dflags <- getDynFlags
+mkDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name, [LSig Name])
+-- The is a default method (vanailla or generic) defined in the class
+-- So make a binding   op = $dmop @t1 @t2
+-- where $dmop is the name of the default method in the class,
+-- and t1,t2 are the instace types.
+-- See Note [Default methods in instances] for why we use
+-- visible type application here
+mkDefMethBind clas inst_tys sel_id dm_name
+  = do  { dflags <- getDynFlags
+        ; dm_id <- tcLookupId dm_name
+        ; let inline_prag = idInlinePragma dm_id
+              inline_prags | isAnyInlinePragma inline_prag
+                           = [noLoc (InlineSig fn inline_prag)]
+                           | otherwise
+                           = []
+                 -- Copy the inline pragma (if any) from the default method
+                 -- to this version. Note [INLINE and default methods]
+
+              fn   = noLoc (idName sel_id)
+              visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
+                                      , tyConBinderVisibility tcb /= Invisible ]
+              rhs  = foldl mk_vta (nlHsVar dm_name) visible_inst_tys
+              bind = noLoc $ mkTopFunBind Generated fn $
+                             [mkSimpleMatch (FunRhs fn Prefix) [] rhs]
+
         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
                    (vcat [ppr clas <+> ppr inst_tys,
                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 
-        ; let fn = noLoc (idName sel_id)
-        ; return (noLoc $ mkTopFunBind Generated fn
-                                    [mkSimpleMatch (FunRhs fn Prefix) [] rhs]) }
+       ; return (bind, inline_prags) }
   where
-    rhs = nlHsVar dm_name
+    mk_vta :: LHsExpr Name -> Type -> LHsExpr Name
+    mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs $ noLoc $ HsCoreTy ty))
+       -- NB: use visible type application
+       -- See Note [Default methods in instances]
 
 ----------------------
 derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
@@ -1614,16 +1593,19 @@ From the class decl we get
    $dmfoo :: forall v x. Baz v x => x -> x
    $dmfoo y = <blah>
 
-Notice that the type is ambiguous.  That's fine, though. The instance
-decl generates
+Notice that the type is ambiguous.  So we use Visible Type Application
+to disambiguate:
 
    $dBazIntInt = MkBaz fooIntInt
-   fooIntInt = $dmfoo Int Int $dBazIntInt
+   fooIntInt = $dmfoo @Int @Int
+
+Lacking VTA we'd get ambiguity errors involving the default method.  This applies
+equally to vanilla default methods (Trac #1061) and generic default methods
+(Trac #12220).
 
-BUT this does mean we must generate the dictionary translation of
-fooIntInt directly, rather than generating source-code and
-type-checking it.  That was the bug in Trac #1061. In any case it's
-less work to generate the translated version!
+Historical note: before we had VTA we had to generate
+post-type-checked code, which took a lot more code, and didn't work for
+generic default methods.
 
 Note [INLINE and default methods]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index cfe0230..24c1959 100644 (file)
@@ -119,7 +119,8 @@ instance GShow Char   where gshowsPrec = showsPrec
 instance GShow Double where gshowsPrec = showsPrec
 instance GShow Int    where gshowsPrec = showsPrec
 instance GShow Float  where gshowsPrec = showsPrec
-instance GShow String where gshowsPrec = showsPrec
+instance {-# OVERLAPPING #-}
+         GShow String where gshowsPrec = showsPrec
 instance GShow Word   where gshowsPrec = showsPrec
 instance GShow Bool   where gshowsPrec = showsPrec
 
index 2226783..1b573f2 100644 (file)
@@ -224,3 +224,9 @@ GHC.Generics representation types:
                                                                                                              GenDerivOutput.Rose)))
 
 
+
+==================== Filling in method body ====================
+GHC.Base.Functor [GenDerivOutput.List]
+  GHC.Base.<$ = GHC.Base.$dm<$ @GenDerivOutput.List
+
+
index cbaba8d..04c87ff 100644 (file)
@@ -541,3 +541,9 @@ GHC.Generics representation types:
                                                                    * GHC.Types.Int))))
 
 
+
+==================== Filling in method body ====================
+GHC.Base.Functor [T10604_deriving.Proxy *]
+  GHC.Base.<$ = GHC.Base.$dm<$ @T10604_deriving.Proxy *
+
+
diff --git a/testsuite/tests/generics/T12220.hs b/testsuite/tests/generics/T12220.hs
new file mode 100755 (executable)
index 0000000..70f8b58
--- /dev/null
@@ -0,0 +1,37 @@
+{-#LANGUAGE TypeApplications#-}
+{-#LANGUAGE MultiParamTypeClasses #-}
+{-#LANGUAGE AllowAmbiguousTypes #-}
+{-#LANGUAGE FlexibleInstances #-}
+{-#LANGUAGE ScopedTypeVariables #-}
+{-#LANGUAGE DefaultSignatures #-}
+module T12220 where
+
+-- | Type a is only used for
+-- type application.
+class ToUse a where
+    toUse :: Int -> Int
+
+-- | The type used for
+-- type application
+data Default
+
+
+-- | The instance using Default as type application.
+-- To call use:
+-- > toUse @Default
+instance ToUse Default where
+    toUse a = 3*a
+
+-- | Typeclass whose methods work
+-- only with type application.
+class Uses a b where
+    uses :: b -> [b]
+    -- | Default Signature, which generates the problem.
+    -- It is the same as the normal one
+    -- Comment it to 'fix' the bug.
+    default uses :: b -> [b]
+    uses v = [v]
+
+-- | But this one doesn't.
+-- Unless you comment the default signature.
+instance (Uses t a, Uses t b, Uses t c) => Uses t (a,b,c)
index cae975c..6bf949f 100644 (file)
@@ -45,3 +45,4 @@ test('T10030', normal, compile_and_run, [''])
 test('T10361a', normal, compile, [''])
 test('T10361b', normal, compile, [''])
 test('T11358', normal, compile_and_run, [''])
+test('T12220', normal, compile, [''])
index 230cff5..386040c 100644 (file)
@@ -91,7 +91,7 @@ test('T1969',
              # 2014-06-29 303300692 (x86/Linux)
              # 2015-07-11 288699104 (x86/Linux, 64-bit machine) use +RTS -G1
              # 2016-04-06 344730660 (x86/Linux, 64-bit machine)
-           (wordsize(64), 695430728, 5)]),
+           (wordsize(64), 756138176, 5)]),
              # 17/11/2009 434845560 (amd64/Linux)
              # 08/12/2009 459776680 (amd64/Linux)
              # 17/05/2010 519377728 (amd64/Linux)
@@ -111,6 +111,7 @@ test('T1969',
              # 10/09/2014 630299456 (x86_64/Linux) post-AMP-cleanup
              # 03/06/2015 581460896 (x86_64/Linux) use +RTS -G1
              # 28/10/2015 695430728 (x86_64/Linux) emit Typeable at definition site
+             # 28/10/2015 756138176 (x86_64/Linux) inst-decl defaults go via typechecker (#12220)
       only_ways(['normal']),
 
       extra_hc_opts('-dcore-lint -static'),