[Git][ghc/ghc][wip/T20264] Mostly working now

[Simon Peyton Jones (@simonpj)]

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


Commits:
69f83064 by Simon Peyton Jones at 2024-10-30T23:24:08+00:00
Mostly working now

- - - - -


2 changed files:

- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Opt/SpecConstr.hs


Changes:

=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -672,20 +672,20 @@ freeVarsBind (NonRec binder rhs) body_fvs
   = ( AnnNonRec binder rhs2
     , freeVarsOf rhs2 `unionFVs` body_fvs2 )
     where
-      rhs2      = freeVarsRhs rhs
+      rhs2      = freeVarsRhs (binder, rhs)
       body_fvs2 = binder `delBinderFV` body_fvs
 
 freeVarsBind (Rec binds) body_fvs
   = ( AnnRec (binders `zip` rhss2)
     , delBindersFV binders all_fvs )
   where
-    (binders, rhss) = unzip binds
-    rhss2           = map freeVarsRhs rhss
-    all_fvs         = foldr (unionFVs . freeVarsOf) body_fvs rhss2
+    binders = map fst binds
+    rhss2   = map freeVarsRhs binds
+    all_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
             -- The "delBinderFV" happens after adding the idSpecVars,
             -- since the latter may add some of the binders as fvs
 
-freeVarsRhs :: Var -> CoreExpr -> CoreExprWithFVs
+freeVarsRhs :: (Var, CoreExpr) -> CoreExprWithFVs
 -- Decorate the RHS with its free vars,
 -- PLUS the free vars of:
 --    - rules
@@ -693,7 +693,7 @@ freeVarsRhs :: Var -> CoreExpr -> CoreExprWithFVs
 --    - type
 -- The free vars of the type matters because of type-lets;
 -- they may be free in the RHS itself
-freeVarsRhs bndr rhs
+freeVarsRhs (bndr, rhs)
   = (rhs_fvs `unionFVs` extra_fvs, rhs')
   where
     (rhs_fvs, rhs') = freeVars rhs


=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -55,6 +55,7 @@ import GHC.Unit.Module.ModGuts
 import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..))
 import GHC.Types.Literal ( litIsLifted )
 import GHC.Types.Id
+import GHC.Types.Var     ( setTyVarUnfolding )
 import GHC.Types.Id.Info ( IdDetails(..) )
 import GHC.Types.Id.Make ( voidArgId, voidPrimId )
 import GHC.Types.Var.Env
@@ -1411,9 +1412,14 @@ scBind :: TopLevelFlag -> ScEnv -> InBind
        -> (ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning]))   -- Specialise the scope of the binding
        -> UniqSM (ScUsage, [OutBind], a, [SpecFailWarning])
 scBind top_lvl env (NonRec bndr rhs) do_body
-  | isTyVar bndr         -- Type-lets may be created by doBeta
-  = do { (final_usage, body', warnings) <- do_body (extendScSubst env bndr rhs)
-       ; return (final_usage, [], body', warnings) }
+  | Type rhs_ty <- rhs
+  = assertPpr (isTyVar bndr) (ppr bndr) $
+    do { let (body_env, bndr') = extendBndr env bndr
+             !(MkSolo rhs_ty') = scSubstTy env rhs_ty
+             bndr'' = setTyVarUnfolding bndr' rhs_ty'
+             body_env' = extendScSubst body_env bndr (Type (mkTyVarTy bndr''))
+       ; (final_usage, body', warnings) <- do_body body_env'
+       ; return (final_usage, [NonRec bndr'' (Type rhs_ty')], body', warnings) }
 
   | not (isTopLevel top_lvl)  -- Nested non-recursive value binding
     -- See Note [Specialising local let bindings]



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69f830646817c8292ccb8d2c473ac66b24dd266f

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69f830646817c8292ccb8d2c473ac66b24dd266f
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/20241030/30f67556/attachment-0001.html>