[Git][ghc/ghc][wip/T23109] Further improvments

[Simon Peyton Jones (@simonpj)]

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


Commits:
3a586101 by Simon Peyton Jones at 2023-06-15T23:50:39+01:00
Further improvments

- - - - -


2 changed files:

- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Tc/Instance/Class.hs


Changes:

=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1405,6 +1405,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
   | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]
                                                        -- in module Exitify
   | not (one_occ (idOccInfo bndr))           = Nothing
+  | isDFunId bndr                            = Nothing
   | not (isStableUnfolding unf)              = Just $! (extend_subst_with rhs)
 
   -- See Note [Stable unfoldings and preInlineUnconditionally]


=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -30,12 +30,15 @@ import GHC.Builtin.Types.Prim
 import GHC.Builtin.Names
 
 import GHC.Types.FieldLabel
-import GHC.Types.Name.Reader
 import GHC.Types.SafeHaskell
-import GHC.Types.Name   ( Name )
+import GHC.Types.Name   ( Name, getOccName )
+import GHC.Types.Name.Reader
+import GHC.Types.Name.Occurrence( occNameString, mkVarOcc )
 import GHC.Types.Var.Env ( VarEnv )
 import GHC.Types.Id
+import GHC.Types.Id.Info
 import GHC.Types.Var
+import GHC.Types.Basic( dfunInlinePragma )
 
 import GHC.Core.Predicate
 import GHC.Core.Coercion
@@ -45,8 +48,9 @@ import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams )
 import GHC.Core.DataCon
 import GHC.Core.TyCon
 import GHC.Core.Class
+import GHC.Core.Unfold.Make( mkDFunUnfolding )
 
-import GHC.Core ( Expr(Var, App, Cast) )
+import GHC.Core ( Expr(..), Bind(..), mkConApp )
 
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
@@ -387,26 +391,42 @@ makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
 --     The process is mirrored for Symbols:
 --     String    -> SSymbol n
 --     SSymbol n -> KnownSymbol n
-makeLitDict clas ty et
-    | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
-          -- co_dict :: KnownNat n ~ SNat n
-    , [ meth ]   <- classMethods clas
-    , Just tcRep <- tyConAppTyCon_maybe (classMethodTy meth)
-                    -- If the method type is forall n. KnownNat n => SNat n
-                    -- then tcRep is SNat
-    , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
-          -- SNat n ~ Integer
-    , let ev_tm = mkEvCast et (mkSymCo (mkTransCo co_dict co_rep))
-    = return $ OneInst { cir_new_theta   = []
-                       , cir_mk_ev       = \_ -> ev_tm
-                       , cir_coherence   = IsCoherent
-                       , cir_what        = BuiltinInstance }
+makeLitDict clas lit_ty lit_expr
+  | [meth]      <- classMethods clas
+  , Just rep_tc <- tyConAppTyCon_maybe (classMethodTy meth)
+                  -- If the method type is forall n. KnownNat n => SNat n
+                  -- then rep_tc :: TyCon is SNat
+  , [dict_con] <- tyConDataCons (classTyCon clas)
+  , [rep_con]  <- tyConDataCons rep_tc
+  , let pred_ty   = mkClassPred clas [lit_ty]
+        dict_args = [ Type lit_ty, mkConApp rep_con [Type lit_ty, lit_expr] ]
+        dfun_rhs  = mkConApp dict_con dict_args
+        dfun_info = vanillaIdInfo `setUnfoldingInfo`  mkDFunUnfolding [] dict_con dict_args
+                                  `setInlinePragInfo` dfunInlinePragma
+        dfun_occ_str :: String
+          = "$f" ++ occNameString (getOccName clas) ++
+            occNameString (getDFunTyKey lit_ty)
+
+  = do { df_name <- newName (mkVarOcc dfun_occ_str)
+       ; let dfun_id = mkLocalVar (DFunId True) df_name ManyTy pred_ty dfun_info
+             ev_tm   = EvExpr (Let (NonRec dfun_id dfun_rhs) (Var dfun_id))
+       ; return $ OneInst { cir_new_theta   = []
+                          , cir_mk_ev       = \_ -> ev_tm
+                          , cir_coherence   = IsCoherent
+                          , cir_what        = BuiltinInstance } }
 
     | otherwise
     = pprPanic "makeLitDict" $
       text "Unexpected evidence for" <+> ppr (className clas)
       $$ vcat (map (ppr . idType) (classMethods clas))
 
+{- Here is what we are making
+   let $dfKnownNat17 :: KnownNat 17
+       [Unfolding = DFun :DKnownNat @17 (UnsafeSNat @17 17)]
+       $dfKnownNat17 = :DKnownNat @17 (UnsafeSNat @17 17)
+   in $dfKnownNat17
+-}
+
 {- ********************************************************************
 *                                                                     *
                    Class lookup for WithDict



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a586101f411228e35fe9840e988146a8b2a10d0

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a586101f411228e35fe9840e988146a8b2a10d0
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/20230615/f1cfc2ea/attachment-0001.html>