testwip/T21229

4 files changed, 51 insertions, 25 deletions

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index b9ca990f3d..660428936e 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -2300,7 +2300,7 @@ lintCoercion the_co@(NthCo r0 n co)
          ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of
          { (Just (tc_s, tys_s), Just (tc_t, tys_t))
              | tc_s == tc_t
-             , isInjectiveTyCon tc_s r
+             , isInjectiveTyCon tc_s r || isClassTyCon tc_s
                  -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep
              , tys_s `equalLength` tys_t
              , tys_s `lengthExceeds` n
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index ab38be413c..9e2bfe1efd 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -37,7 +37,7 @@ import GHC.Core
 import GHC.Core.FVs
 import GHC.Core.Utils
 import GHC.Core.DataCon
-import GHC.Core.TyCon     ( tyConArity )
+import GHC.Core.TyCon
 import GHC.Core.TyCon.RecWalk     ( initRecTc, checkRecTc )
 import GHC.Core.Predicate ( isDictTy, isCallStackPredTy )
 import GHC.Core.Multiplicity
@@ -1812,7 +1812,8 @@ pushCoDataCon dc dc_args co
         -- where S is a type function.  In fact, exprIsConApp
         -- will probably not be called in such circumstances,
         -- but there's nothing wrong with it
-
+  , not (isNewDataCon dc) || isClassTyCon to_tc
+        -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep
   = let
         tc_arity       = tyConArity to_tc
         dc_univ_tyvars = dataConUnivTyVars dc
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 0a733abb6b..be14d1769f 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -615,7 +615,12 @@ specProgram guts@(ModGuts { mg_module = this_mod
 
              go []           = return ([], emptyUDs)
              go (bind:binds) = do (binds', uds) <- go binds
-                                  (bind', uds') <- specBind top_env bind uds
+                                  let env = bringFloatedDictsIntoScope top_env uds
+                                  (bind', uds') <- specBind env bind uds
+                                  -- let db_bndrs = unionVarSets $ map (mkVarSet . filter isLocalId . bindersOf . db_bind) (bagToList (ud_binds uds))
+                                  -- let not_in_scope = db_bndrs `minusVarSet` getInScopeVars (Core.substInScope (se_subst top_env))
+                                  -- massertPpr (isEmptyVarSet not_in_scope)
+                                  --   (text "not in scope above" $$ ppr (bindersOf bind) $$ ppr (ud_binds uds) $$ ppr not_in_scope)
                                   return (bind' ++ binds', uds')
 
              -- Specialise the bindings of this module
@@ -650,7 +655,7 @@ See #10491
 
 {- *********************************************************************
 *                                                                      *
-                   Specialising imported functions
+                     Specialising imported functions
 *                                                                      *
 ********************************************************************* -}
 
@@ -1129,13 +1134,13 @@ specExpr env expr@(App {})
        }
   where
     -- See Note [Specialisation modulo dictionary selectors]
-    rewrite_class_ops :: CoreExpr -> [CoreExpr] -> (CoreExpr, [CoreExpr])
+    rewrite_class_ops :: InExpr -> [OutExpr] -> (InExpr, [OutExpr])
     rewrite_class_ops (Var f) args
       | isClassOpId f -- If we see `op_sel $fCInt`, we rewrite to `$copInt`
       -- , pprTrace "class op" (ppr f <+> ppr args) True
       , Just (rule, expr) <- specLookupRule env f args (idCoreRules f)
       , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target]
-      -- , pprTrace "class op rewritten" (ppr expr <+> ppr rest_args) True
+      , pprTrace "class op rewritten" (ppr f <+> ppr args $$ ppr expr <+> ppr rest_args) True
       , (fun, args) <- collectArgs expr
       = rewrite_class_ops fun (args++rest_args)
     rewrite_class_ops fun args = (fun, args)
@@ -1165,10 +1170,11 @@ specExpr env (Let bind body)
        ; (body', body_uds) <- specExpr body_env body
 
         -- Deal with the bindings
-      ; (binds', uds) <- specBind rhs_env bind' body_uds
+       ; let rhs_env' = bringFloatedDictsIntoScope rhs_env body_uds
+       ; (binds', uds) <- specBind rhs_env' bind' body_uds
 
-        -- All done
-      ; return (foldr Let body' binds', uds) }
+         -- All done
+       ; return (foldr Let body' binds', uds) }
 
 --------------
 specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails)
@@ -1303,6 +1309,14 @@ to substitute sc -> sc_flt in the RHS
 ************************************************************************
 -}
 
+bringFloatedDictsIntoScope :: SpecEnv -> UsageDetails -> SpecEnv
+bringFloatedDictsIntoScope env uds =
+  -- pprTrace "brought into scope" (ppr dx_bndrs) $
+  env{se_subst=subst'}
+  where
+   dx_bndrs = bindersOfBinds (map db_bind (bagToList (ud_binds uds)))
+   subst'   = se_subst env `Core.extendInScopeList` dx_bndrs
+
 specBind :: SpecEnv                     -- Use this for RHSs
          -> CoreBind                    -- Binders are already cloned by cloneBindSM,
                                         -- but RHSs are un-processed
@@ -1496,16 +1510,17 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
              , rule_bndrs, rule_lhs_args
              , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
 
---           ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci
---                                        , text "useful:    " <+> ppr useful
---                                        , text "rule_bndrs:" <+> ppr rule_bndrs
---                                        , text "lhs_args:  " <+> ppr rule_lhs_args
---                                        , text "spec_bndrs:" <+> ppr spec_bndrs1
---                                        , text "spec_args: " <+> ppr spec_args
---                                        , text "dx_binds:  " <+> ppr dx_binds
---                                        , text "rhs_env2:  " <+> ppr (se_subst rhs_env2)
---                                        , ppr dx_binds ]) $
---             return ()
+           ; pprTrace "spec_call" (vcat [ text "fun:       " <+> ppr fn
+                                        , text "call info: " <+> ppr _ci
+                                        , text "useful:    " <+> ppr useful
+                                        , text "rule_bndrs:" <+> ppr rule_bndrs
+                                        , text "lhs_args:  " <+> ppr rule_lhs_args
+                                        , text "spec_bndrs:" <+> ppr spec_bndrs1
+                                        , text "spec_args: " <+> ppr spec_args
+                                        , text "dx_binds:  " <+> ppr dx_binds
+                                        , text "rhs_env2:  " <+> ppr (se_subst rhs_env2)
+                                        , ppr dx_binds ]) $
+             return ()
 
            ; if not useful  -- No useful specialisation
                 || already_covered rules_acc rule_lhs_args
@@ -2458,7 +2473,8 @@ bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })
                                 `Core.extendInScope` dict_id
                           -- See Note [Keep the old dictionaries interesting]
                    , se_interesting = interesting `extendVarSet` dict_id }
-    in (env', Nothing, dict_expr)
+    in -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $
+       (env', Nothing, dict_expr)
 
   | otherwise  -- Non-trivial dictionary arg; make an auxiliary binding
   = let dict_unf       = mkSimpleUnfolding defaultUnfoldingOpts dict_expr
@@ -2466,10 +2482,12 @@ bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })
           -- See Note [Specialisation modulo dictionary selectors] for the unfolding
         dict_bind = mkDB (NonRec fresh_dict_id' dict_expr)
         env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id')
-                                `Core.extendInScope` fresh_dict_id'
+                                `Core.extendInScope`     fresh_dict_id'
+                                `Core.extendInScopeList` exprFreeVarsList dict_expr
                       -- See Note [Make the new dictionaries interesting]
                    , se_interesting = interesting `extendVarSet` fresh_dict_id' }
-    in (env', Just dict_bind, Var fresh_dict_id')
+    in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id' $$ ppr dict_expr $$ ppr (exprFreeVarsList dict_expr)) $
+       (env', Just dict_bind, Var fresh_dict_id')
 
 {-
 Note [Make the new dictionaries interesting]
@@ -2727,7 +2745,7 @@ singleCall id args
         --
         -- We don't include the 'id' itself.
 
-mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails
+mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails
 mkCallUDs env f args
   = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ])
     res
@@ -2757,7 +2775,7 @@ mkCallUDs' env f args
              -- which broadens its applicability, since rules only
              -- fire when saturated
 
-    mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg
+    mk_spec_arg :: OutExpr -> TyCoBinder -> SpecArg
     mk_spec_arg arg (Named bndr)
       |  binderVar bndr `elemVarSet` constrained_tyvars
       = case arg of
@@ -3120,6 +3138,7 @@ cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec
        ; let (subst', bndr') = Core.cloneIdBndr subst us bndr
              interesting' | typeDeterminesValue (idType bndr)
                           , interestingDict env rhs
+                          , pprTrace "cloneBindSM:interesting" (ppr bndr <> arrow <> ppr bndr') True
                           = interesting `extendVarSet` bndr'
                           | otherwise = interesting
        ; return (env, env { se_subst = subst', se_interesting = interesting' }
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 5fa3bbdf14..2a0a34e3a5 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -1098,6 +1098,12 @@ cpeApp top_env expr
             | not (isTyCoArg arg) = True
           has_value_arg (_:rest) = has_value_arg rest
 
+--    cpe_app env (Var f) args
+--      | isClassOpId f
+--      , Just tmpl <- maybeUnfoldingTemplate (idUnfolding f)
+--      , pprTrace "cpe_app:class op" (ppr f $$ ppr tmpl)
+--      = cpe_app env tmpl args
+
     cpe_app env (Var v) args
       = do { v1 <- fiddleCCall v
            ; let e2 = lookupCorePrepEnv env v1