[Git][ghc/ghc][wip/T24359] Improvements
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Nov 20 23:55:37 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
ce734a61 by Simon Peyton Jones at 2024-11-20T23:55:13+00:00
Improvements
- - - - -
5 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/Tc/Gen/Sig.hs
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -75,7 +75,6 @@ import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.Graph.Directed
import GHC.Data.Bag
-import qualified Data.Set as S
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
@@ -857,6 +856,7 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
mkLets ds_rhs_binds $
core_call
+ ; tracePm "dsSpec1" (vcat [ ppr poly_id $$ ppr ds_call $$ ppr core_call])
; finishSpecPrag mb_poly_rhs
(tv_bndrs ++ lhs_evs ++ id_bndrs) core_call
(tv_bndrs ++ rhs_evs ++ id_bndrs) mk_spec_call
@@ -1443,29 +1443,34 @@ dsEvBinds ev_binds thing_inside
thing_inside (core_bind:core_binds) }
go [] thing_inside = thing_inside []
- ds_component unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables)
+ ds_component mb_unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables)
where
((v, rhs), (this_canonical, deps)) = unpack_node node
- transitively_unspecable = is_unspecable this_canonical || any is_unspecable_dep deps
- is_unspecable_dep dep = dep `S.member` unspecables
- new_unspecables
- | transitively_unspecable = S.singleton v
- | otherwise = mempty
- ds_component unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables)
+ new_unspecables = case mb_unspecables of
+ Nothing -> []
+ Just unspecs | transitively_unspecable -> [v]
+ | otherwise -> []
+ where
+ transitively_unspecable = is_unspecable this_canonical
+ || any (`elemVarSet` unspecs) deps
+
+ ds_component mb_unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables)
where
(pairs, direct_canonicity) = unzip $ map unpack_node nodes
- is_unspecable_remote dep = dep `S.member` unspecables
- transitively_unspecable = or [ is_unspecable this_canonical || any is_unspecable_remote deps
- | (this_canonical, deps) <- direct_canonicity ]
+ new_unspecables = case mb_unspecables of
+ Nothing -> []
+ Just unspecs | transitively_unspecable -> map fst pairs
+ | otherwise -> []
+ where
+ transitively_unspecable
+ = or [ is_unspecable this_canonical
+ || any (`elemVarSet` unspecs) deps
+ | (this_canonical, deps) <- direct_canonicity ]
-- Bindings from a given SCC are transitively specialisable if
-- all are specialisable and all their remote dependencies are
-- also specialisable; see Note [Desugaring non-canonical evidence]
- new_unspecables
- | transitively_unspecable = S.fromList [ v | (v, _) <- pairs]
- | otherwise = mempty
-
unpack_node DigraphNode { node_key = v, node_payload = (canonical, rhs), node_dependencies = deps }
= ((v, rhs), (canonical, deps))
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -62,6 +62,7 @@ import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Id.Make
import GHC.Types.Var( isInvisibleAnonPiTyBinder )
+import GHC.Types.Var.Set( isEmptyVarSet, elemVarSet )
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Tickish
@@ -76,7 +77,6 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import Control.Monad
-import qualified Data.Set as S
{-
************************************************************************
@@ -793,15 +793,15 @@ ds_app_finish :: Id -> [CoreExpr] -> DsM CoreExpr
-- See Note [nospecId magic] in GHC.Types.Id.Make for what `nospec` does.
-- See Note [Desugaring non-canonical evidence]
ds_app_finish fun_id core_args
- = do { unspecables <- getUnspecables
+ = do { mb_unspecables <- getUnspecables
; let fun_ty = idType fun_id
free_dicts = exprsFreeVarsList
[ e | (e,pi_bndr) <- core_args `zip` fst (splitPiTys fun_ty)
, isInvisibleAnonPiTyBinder pi_bndr ]
- is_unspecable_var v = v `S.member` unspecables
- fun | not (S.null unspecables) -- Fast path
- , any (is_unspecable_var) free_dicts
+ fun | Just unspecables <- mb_unspecables
+ , not (isEmptyVarSet unspecables) -- Fast path
+ , any (`elemVarSet` unspecables) free_dicts
= Var nospecId `App` Type fun_ty `App` Var fun_id
| otherwise
= Var fun_id
@@ -958,7 +958,8 @@ Wrinkle:
We definitely can't desugar that LHS into this!
nospec (f @Int d1) d2
- This is done by zapping the unspecables in `dsRule`.
+ This is done by zapping the unspecables in `dsRule` to Nothing. That `Nothing`
+ says not to collet unspecables at all.
Note [Desugaring explicit lists]
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -94,7 +94,8 @@ import GHC.Unit.Module.ModGuts
import GHC.Types.Name.Reader
import GHC.Types.SourceFile
import GHC.Types.Id
-import GHC.Types.Var (EvId)
+import GHC.Types.Var (EvVar)
+import GHC.Types.Var.Set( VarSet, emptyVarSet, extendVarSetList )
import GHC.Types.SrcLoc
import GHC.Types.TypeEnv
import GHC.Types.Unique.Supply
@@ -117,7 +118,6 @@ import qualified GHC.Data.Strict as Strict
import Data.IORef
import GHC.Driver.Env.KnotVars
-import qualified Data.Set as S
import GHC.IO.Unsafe (unsafeInterleaveIO)
{-
@@ -406,7 +406,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span
, dsl_nablas = initNablas
- , dsl_unspecables = mempty
+ , dsl_unspecables = Just emptyVarSet
}
in (gbl_env, lcl_env)
@@ -469,13 +469,17 @@ getPmNablas = do { env <- getLclEnv; return (dsl_nablas env) }
updPmNablas :: Nablas -> DsM a -> DsM a
updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas })
-addUnspecables :: S.Set EvId -> DsM a -> DsM a
-addUnspecables unspecables = updLclEnv (\env -> env{ dsl_unspecables = unspecables `mappend` dsl_unspecables env })
+addUnspecables :: [EvVar] -> DsM a -> DsM a
+addUnspecables new_unspecables
+ = updLclEnv (\env -> case dsl_unspecables env of
+ Nothing -> env
+ Just us -> env { dsl_unspecables
+ = Just (us `extendVarSetList` new_unspecables) })
zapUnspecables :: DsM a -> DsM a
-zapUnspecables = updLclEnv (\env -> env{ dsl_unspecables = mempty })
+zapUnspecables = updLclEnv (\env -> env{ dsl_unspecables = Nothing })
-getUnspecables :: DsM (S.Set EvId)
+getUnspecables :: DsM (Maybe VarSet)
getUnspecables = dsl_unspecables <$> getLclEnv
getSrcSpanDs :: DsM SrcSpan
=====================================
compiler/GHC/HsToCore/Types.hs
=====================================
@@ -14,27 +14,34 @@ module GHC.HsToCore.Types (
import GHC.Prelude (Int)
import Data.IORef
-import qualified Data.Set as S
import GHC.Types.CostCentre.State
import GHC.Types.Error
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Types.Var
+import GHC.Types.Var.Set
import GHC.Types.Name.Reader (GlobalRdrEnv)
+
import GHC.Hs (LForeignDecl, HsExpr, GhcTc)
+
import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv)
+
import GHC.HsToCore.Pmc.Types (Nablas)
import GHC.HsToCore.Errors.Types
+
import GHC.Core (CoreExpr)
import GHC.Core.FamInstEnv
import GHC.Utils.Outputable as Outputable
import GHC.Unit.Module
import GHC.Driver.Hooks (DsForeignsHook)
import GHC.Data.OrdList (OrdList)
+
import GHC.Types.ForeignStubs (ForeignStubs)
import GHC.Types.CompleteMatch
+import Data.Maybe( Maybe )
+
{-
************************************************************************
* *
@@ -80,9 +87,11 @@ data DsLclEnv
-- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc".
-- The set of reaching values Nablas is augmented as we walk inwards, refined
-- through each pattern match in turn
- , dsl_unspecables :: S.Set EvVar
- -- ^ See Note [Desugaring non-canonical evidence]: this field collects
- -- all un-specialisable evidence variables in scope.
+
+ , dsl_unspecables :: Maybe VarSet
+ -- ^ See Note [Desugaring non-canonical evidence]
+ -- This field collects all un-specialisable evidence variables in scope.
+ -- Nothing <=> don't collect this info (used for the LHS of Rules)
}
-- Inside [| |] brackets, the desugarer looks
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -898,6 +898,7 @@ tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
= do { -- Typecheck the expression, spec_e, capturing its constraints
let skol_info_anon = SpecESkol nm
+ ; traceTc "tcSpecPrag: specSigE1" (ppr nm $$ ppr spec_e)
; skol_info <- mkSkolemInfo skol_info_anon
; (tc_lvl, wanted, (id_bndrs, spec_e', rho))
<- pushLevelAndCaptureConstraints $
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce734a61c8e8cbdb4b004daa86658ee8d2184365
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce734a61c8e8cbdb4b004daa86658ee8d2184365
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/20241120/bcfbdfcb/attachment-0001.html>
More information about the ghc-commits
mailing list