[Git][ghc/ghc][wip/T24359] Work in progress
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Nov 22 17:43:16 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
70ab85ca by Simon Peyton Jones at 2024-11-22T17:42:56+00:00
Work in progress
..won't compile yet
- - - - -
2 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Tc/Gen/Sig.hs
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -820,11 +820,17 @@ dsSpec mb_poly_rhs (SpecPrag poly_id spec_co spec_inl)
-- perhaps with the body of the lambda wrapped in some WpLets
-- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
= dsHsWrapper spec_app $ \core_app ->
- finishSpecPrag mb_poly_rhs
- spec_bndrs (core_app (Var poly_id))
- spec_bndrs (\poly_rhs _ -> core_app poly_rhs)
- spec_inl
+ do { dflags <- getDynFlags
+ ; case decomposeRuleLhs dflags spec_bndrs (core_app (Var poly_id))
+ (mkVarSet spec_bndrs) of {
+ Left msg -> do { diagnosticDs msg; return Nothing } ;
+ Right (rule_bndrs, poly_id, rule_lhs_args) ->
+
+ ; let poly_rhs = specFunBody poly_id mb_poly_rhs
+ ; finishSpecPrag rule_bndrs poly_id rule_lhs_args
+ rule_bndrs (core_app poly_rhs) spec_inl
+{-
dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
, spe_tv_bndrs = tv_bndrs
, spe_id_bndrs = id_bndrs
@@ -869,6 +875,57 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
where
drop_cast (Cast e _) = drop_cast e
drop_cast e = e
+-}
+
+dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
+ , spe_tv_bndrs = tv_bndrs
+ , spe_id_bndrs = id_bndrs
+ , spe_lhs_ev_bndrs = lhs_evs
+ , spe_lhs_binds = lhs_binds
+ , spe_lhs_call = the_call
+ , spe_inl = inl })
+ -- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
+ | isJust (isClassOpId_maybe poly_id)
+ = failBecauseOfClassOp poly_id
+
+ | otherwise
+ = dsTcEvBinds lhs_binds $ \ ds_lhs_binds ->
+ do { dflags <- getDynFlags
+ ; ds_call <- zapUnspecables $
+ -- zapUnspecables: see Note [Desugaring RULE left hand sides]
+ dsLExpr the_call
+ ; tracePm "dsSpec1" (vcat
+ [ ppr poly_id
+ , text "lhs_binds" <+> ppr lhs_binds
+ , text "ds_lhs_binds" <+> ppr ds_lhs_binds
+ , text "ds_call" <+> ppr ds_call ])
+
+ ; let simpl_opts = initSimpleOpts dflags
+ core_call = drop_cast $
+ simpleOptExpr simpl_opts $
+ ds_call
+
+ lhs_id_bndrs = filterOut (`elemVarSet` exprFreeVars core_call) $
+ id_bndrs ++ bindersOfBinds ds_lhs_binds
+ -- All the vars in core_call that should be quantified
+
+ rhs_const_binds :: [CoreBind]
+ rhs_const_binds = get_const_ev_binds lhs_evs ds_lhs_binds
+
+ spec_id_bndrs = filterOut (`elemVarSet` const_bndrs) lhs_id_bndrs
+
+ fn_body = specFunBody poly_id mb_poly_rhs
+
+ spec_body = mkLets rhs_const_binds $
+ mkCoreApps fn_body lhs_args
+
+ ; tracePm "dsSpec1" (vcat [ ppr poly_id $$ ppr ds_call $$ ppr core_call])
+ ; finishSpecPrag mb_poly_rhs
+ (tv_bndrs ++ lhs_id_bndrs) core_call
+ (tv_bndrs ++ spec_id_bndrs) spec_body inl }
+ where
+ drop_cast (Cast e _) = drop_cast e
+ drop_cast e = e
failBecauseOfClassOp :: Id -> DsM (Maybe a)
-- There is no point in trying to specialise a class op
@@ -878,21 +935,11 @@ failBecauseOfClassOp poly_id
= do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)
; return Nothing }
-finishSpecPrag :: Maybe CoreExpr -- See the first param of dsSpec
- -> [Var] -- Binders, over LHS and RHS
- -> CoreExpr -- LHS pattern
- -> [Var] -> (CoreExpr -> [CoreExpr] -> CoreExpr) -- Make spec RHS given function body
- -> InlinePragma
+finishSpecPrag :: [Var] -> Id -> [CoreExpr] -- LHS pattern
+ -> [Var] -> CoreExpr -> InlinePragma -- Specialised form
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-finishSpecPrag mb_poly_rhs
- lhs_bndrs rule_lhs
- spec_bndrs mk_spec_rhs
- spec_inl
- = do { dflags <- getDynFlags
- ; case decomposeRuleLhs dflags lhs_bndrs rule_lhs (mkVarSet lhs_bndrs) of {
- Left msg -> do { diagnosticDs msg; return Nothing } ;
- Right (rule_bndrs, poly_id, rule_lhs_args) ->
-
+finishSpecPrag rule_bndrs poly_id rule_bndrs rhs_lhs_args
+ spec_bndrs spec_body spec_inl
do { this_mod <- getModule
; uniq <- newUnique
; let poly_name = idName poly_id
@@ -914,11 +961,11 @@ finishSpecPrag mb_poly_rhs
rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
poly_id rule_bndrs rule_lhs_args
- (mkVarApps (Var spec_id) lhs_bndrs)
+ (mkVarApps (Var spec_id) spec_bndrs)
- spec_ty = mkLamTypes spec_bndrs (exprType rule_lhs)
- spec_rhs = mkLams spec_bndrs $
- mk_spec_rhs poly_rhs rule_lhs_args
+ rule_lhs_ty = exprType (mkVarApps poly_id rule_lhs_args)
+ spec_ty = mkLamTypes spec_bndrs rule_lhs_ty
+ spec_rhs = mkLams spec_bndrs spec_body
; dsWarnOrphanRule rule
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -929,6 +929,20 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
do { (L loc spec_e', rho) <- tcInferRho spec_e
; return (id_bndrs, L loc spec_e', rho) } }
+ ; (qtkvs, qevs, ev_binds, insol) <- simplifyInfer TopLevel tc_lvl NoRestrictions
+ [] [(nm,rho)] wanted
+
+ ; return [SpecPragE { spe_poly_id = poly_id
+ , spe_tv_bndrs = qtkvs
+ , spe_id_bndrs = id_bndrs
+ , spe_lhs_ev_bndrs = qevs
+ , spe_lhs_binds = ev_binds
+ , spe_lhs_call = spec_e'
+ , spe_rhs_ev_bndrs = []
+ , spe_rhs_binds = emptyTcEvBinds
+ , spe_inl = inl }] }
+
+{-
-- Solve unification constraints
-- c.f. Note [The SimplifyRule Plan] step 1
; cloned_wanted <- cloneWC wanted -- See Note [Simplify cloned constraints]
@@ -978,7 +992,7 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
, spe_rhs_ev_bndrs = rhs_evs
, spe_rhs_binds = rhs_binds
, spe_inl = inl }] }
-
+-}
tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
--------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70ab85cadc6de073566347ec423906a205792bee
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70ab85cadc6de073566347ec423906a205792bee
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/20241122/5b86900b/attachment-0001.html>
More information about the ghc-commits
mailing list