[Git][ghc/ghc][wip/T24676] Wibbles

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T24676 at Glasgow Haskell Compiler / GHC


Commits:
6f90e5d0 by Simon Peyton Jones at 2024-06-03T17:20:00+01:00
Wibbles

- - - - -


3 changed files:

- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Unify.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -1858,11 +1858,14 @@ which has no free instantiation variables, so we can QL-unify
 
 ---------------------
 qlUnify :: TcType -> TcType -> TcM ()
--- Unify ty1 with ty2, unifying /only/ instantiation variables in delta
--- (it /never/ unifies ordinary unification variables)
--- It never produces errors, even for mis-matched types
--- It may return without having made the types equal, of course;
--- it just makes best efforts.
+-- Unify ty1 with ty2:
+--   * It unifies /only/ instantiation variables;
+--     it /never/ unifies ordinary unification variables
+--   * It never produces errors, even for mis-matched types
+--   * It does not return a coercion (unlike unifyType); it is called
+--     for the sole purpose of unifying instantiation variables
+--   * It may return without having made the argument types equal, of course;
+--     it just makes best efforts.
 qlUnify ty1 ty2
   = go (emptyVarSet,emptyVarSet) ty1 ty2
   where


=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -401,25 +401,38 @@ instCallConstraints orig preds
   = return idHsWrapper
   | otherwise
   = do { evs <- mapM (emitWanted orig) preds
+                -- See Note [Possible fast path for equality constraints]
        ; traceTc "instCallConstraints" (ppr evs)
        ; return (mkWpEvApps evs) }
-{-
--- ToDo: explain why we don't short-cut here; Quick Look
-  where
-    go :: TcPredType -> TcM EvTerm
-    go pred
-     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
-     = do  { co <- unifyType Nothing ty1 ty2
-           ; return (evCoercion co) }
-
-       -- Try short-cut #2
-     | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
-     , tc `hasKey` heqTyConKey
-     = do { co <- unifyType Nothing ty1 ty2
-          ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
 
-     | otherwise
-     = emitWanted orig pred
+{- Note [Possible fast path for equality constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given  f :: forall a b. (a ~ [b]) => a -> b -> blah
+rather than emitting ([W] alpha ~ [beta]) we could imagine calling unifyType
+right here. But note
+
+* Often such constraints look like (F a ~ G b), in which case unification would end up
+  spitting out a wanted-equality anyway.
+
+* So perhaps the main fast-path would be where the LHS or RHS was an instantiation
+  variable. But note that this could, perhaps, impact on Quick Look:
+
+  - The first arg of `f` changes from the naked `a` to the guarded `[b]` (or would do so
+    if we zonked it).  That might affect typing under Quick Look.
+
+  - We might imagine using the let-bound skolems trick:
+         g :: forall a b. (a ~ forall c. c->c) => a -> [a] -> [a]
+    Here we are just using `a` as a local abreviation for (forall c. c->c)
+    See Note [Let-bound skolems] in GHC.Tc.Solver.InertSet.
+
+    If we substitute aggressively (including zonking) that abbreviation could work.  But
+    again it affects what is typeable.
+
+* There is little point in trying to optimise for
+   - (s ~# t), because few functions have primitive equalities in their context
+   - (s ~~ t), becaues heterogeneous equality is rare, and more complicated.
+
+Anyway, for now we don't take advantage of these potential effects.
 -}
 
 instDFunType :: DFunId -> [DFunInstType]


=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -2894,14 +2894,13 @@ simpleUnifyCheck :: Bool   -- True  <=> called from constraint solver
 simpleUnifyCheck called_from_solver lhs_tv rhs
   = go rhs
   where
-    fam_ok = called_from_solver || is_ql_inst_tv
 
     !(occ_in_ty, occ_in_co) = mkOccFolders lhs_tv
 
     lhs_tv_lvl         = tcTyVarLevel lhs_tv
     lhs_tv_is_concrete = isConcreteTyVar lhs_tv
-    is_ql_inst_tv      = isQLInstTyVar lhs_tv
-    forall_ok          = is_ql_inst_tv || isRuntimeUnkTyVar lhs_tv
+    forall_ok          = isRuntimeUnkTyVar lhs_tv
+    fam_ok             = called_from_solver
 
     go (TyVarTy tv)
       | lhs_tv == tv                                    = False



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6f90e5d0f831b99ef47048294ccadf8313988071

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6f90e5d0f831b99ef47048294ccadf8313988071
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240603/778a6ceb/attachment-0001.html>