Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 714227d7 by Simon Peyton Jones at 2025-06-20T23:50:37+01:00 Wibbles - - - - - 4 changed files: - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/Tc/Solver/Solve.hs - testsuite/tests/simplCore/should_compile/T26115.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -1168,17 +1168,18 @@ dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call is_local v = v `elemVarSet` locals rule_bndrs = scopedSort (exprsSomeFreeVarsList is_local rule_lhs_args) - rn_binds = getRenamings orig_bndrs binds rule_bndrs - spec_binds = pickSpecBinds is_local (mkVarSet rule_bndrs) binds + rn_binds = getRenamings orig_bndrs binds rule_bndrs + known_vars = mkVarSet rule_bndrs `extendVarSetList` bindersOfBinds rn_binds + picked_binds = pickSpecBinds is_local known_vars binds -- Make spec_bndrs, the variables to pass to the specialised -- function, by filtering out the rule_bndrs that aren't needed - spec_binds_bndr_set = mkVarSet (bindersOfBinds spec_binds) + spec_binds_bndr_set = mkVarSet (bindersOfBinds picked_binds) `minusVarSet` exprsFreeVars (rhssOfBinds rn_binds) spec_bndrs = filterOut (`elemVarSet` spec_binds_bndr_set) rule_bndrs - mk_spec_body fn_body = mkLets (rn_binds ++ spec_binds) $ + mk_spec_body fn_body = mkLets (rn_binds ++ picked_binds) $ mkApps fn_body rule_lhs_args -- ToDo: not mkCoreApps! That uses exprType on fun which -- fails in specUnfolding, sigh @@ -1227,7 +1228,7 @@ dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call , text "rule_bndrs" <+> ppr rule_bndrs , text "spec_bndrs" <+> ppr spec_bndrs , text "rn_binds" <+> ppr rn_binds - , text "spec_binds" <+> ppr spec_binds ] + , text "picked_binds" <+> ppr picked_binds ] ; dsWarnOrphanRule rule ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -1301,7 +1301,8 @@ tryInertQCs qc try_inert_qcs :: QCInst -> [QCInst] -> TcS (StopOrContinue ()) try_inert_qcs (QCI { qci_ev = ev_w }) inerts = case mapMaybe matching_inert inerts of - [] -> continueWith () + [] -> do { traceTcS "tryInertQCs:nothing" (ppr ev_w $$ ppr inerts) + ; continueWith () } ev_i:_ -> do { traceTcS "tryInertQCs:KeepInert" (ppr ev_i) ; setEvBindIfWanted ev_w EvCanonical (ctEvTerm ev_i) @@ -1700,108 +1701,3 @@ runTcPluginSolvers solvers all_cts addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of CtGiven {} -> (ct:givens, wanteds) CtWanted {} -> (givens, (ev,ct):wanteds) - --------------------------------------------------------------------------------- - -{- --- | If the mode is 'TcSSpecPrag', attempt to fully solve the Wanted --- constraints that arise from solving 'Ct'. --- --- If not in 'TcSSpecPrag' mode, simply run 'thing_inside'. --- --- See Note [TcSSpecPrag] in GHC.Tc.Solver.Monad. -solveCompletelyIfRequired :: Ct -> TcS (StopOrContinue a) -> TcS (StopOrContinue a) -solveCompletelyIfRequired ct (TcS thing_inside) - = TcS $ \ env@(TcSEnv { tcs_ev_binds = outer_ev_binds_var - , tcs_unified = outer_unified_var - , tcs_unif_lvl = outer_unif_lvl_var - , tcs_inerts = outer_inert_var - , tcs_count = outer_count - , tcs_mode = mode - }) -> - case mode of - TcSSpecPrag -> - do { traceTc "solveCompletelyIfRequired {" empty - -- Create a fresh environment for the inner computation - ; outer_inerts <- TcM.readTcRef outer_inert_var - ; let outer_givens = inertGivens outer_inerts - -- Keep the ambient Given inerts, but drop the Wanteds. - ; new_inert_var <- TcM.newTcRef outer_givens - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; new_ev_binds_var <- TcM.newTcEvBinds - - ; let - inner_env = - TcSEnv - -- KEY part: recur with TcSVanilla - { tcs_mode = TcSVanilla - - -- Use new variables for evidence bindings, inerts; and - -- the work list. We may want to discard all of these if the - -- inner computation doesn't fully solve all the constraints. - , tcs_ev_binds = new_ev_binds_var - , tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var - - -- Inherit the other variables. In particular, inherit the - -- variables to do with unification, as filling metavariables - -- is a side-effect that we are not reverting, even when we - -- discard the result of the inner computation. - , tcs_unif_lvl = outer_unif_lvl_var - , tcs_unified = outer_unified_var - , tcs_count = outer_count - } - - -- Solve the constraint - ; let wc = emptyWC { wc_simple = unitBag ct } - ; traceTc "solveCompletelyIfRequired solveWanteds" $ - vcat [ text "ct:" <+> ppr ct - ] - ; solved_wc <- unTcS (solveWanteds wc) inner_env - -- NB: it would probably make more sense to call 'thing_inside', - -- collecting all constraints that were added to the work list as - -- a result, and calling 'solveWanteds' on that. This would avoid - -- restarting from the top of the solver pipeline. - -- For the time being, we just call 'solveWanteds' on the original - -- constraint, which is simpler - - ; if isSolvedWC solved_wc - then - do { -- The constraint was fully solved. Continue with - -- the inner solver state. - ; traceTc "solveCompletelyIfRequired: fully solved }" $ - vcat [ text "ct:" <+> ppr ct - , text "solved_wc:" <+> ppr solved_wc ] - - -- Add new evidence bindings to the existing ones - ; inner_ev_binds <- TcM.getTcEvBindsMap new_ev_binds_var - ; addTcEvBinds outer_ev_binds_var inner_ev_binds - - -- Keep the outer inert set and work list: the inner work - -- list is empty, and there are no leftover unsolved - -- Wanteds. - -- However, we **must not** drop solved implications, due - -- to Note [Free vars of EvFun] in GHC.Tc.Types.Evidence; - -- so we re-emit them here. - ; let re_emit_implic impl = unTcS ( TcS.emitImplication impl ) env - ; traverse_ re_emit_implic $ wc_impl solved_wc - ; return $ Stop (ctEvidence ct) (text "Fully solved:" <+> ppr ct) - } - else - do { traceTc "solveCompletelyIfRequired: unsolved }" $ - vcat [ text "ct:" <+> ppr ct - , text "solved_wc:" <+> ppr solved_wc ] - -- Failed to fully solve the constraint: - -- - -- - discard the inner solver state, - -- - add the original constraint as an inert. - ; unTcS (updInertIrreds (IrredCt (ctEvidence ct) IrredShapeReason)) env - -- NB: currently we only call 'solveCompletelyIfRequired' - -- from 'solveForAll'; so we just stash the unsolved quantified - -- constraint in the irreds. - - ; return $ Stop (ctEvidence ct) (text "Not fully solved; kept as inert:" <+> ppr ct) - } } - _notFullySolveMode -> - thing_inside env --} ===================================== testsuite/tests/simplCore/should_compile/T26115.stderr ===================================== @@ -1,6 +1,6 @@ [GblId[DFunId], - Unf=DFun: \ (@b_awW) -> + Unf=DFun: \ (@b) -> [GblId[DFunId], - Unf=DFun: \ (@b_aBU) -> + Unf=DFun: \ (@b) -> [GblId[DFunId], - Unf=DFun: \ (@p_awR) (@q_awS) (v_B1 :: C p_awR q_awS) -> + Unf=DFun: \ (@p) (@q) (v :: C p q) -> ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -548,6 +548,6 @@ test('T25965', normal, compile, ['-O']) test('T25703', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings']) test('T25703a', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings']) -test('T26115', [grep_errmsg(r'DFun')], compile, ['-O -ddump-simpl']) +test('T26115', [grep_errmsg(r'DFun')], compile, ['-O -ddump-simpl -dsuppress-uniques']) test('T26116', normal, compile, ['-O -ddump-rules']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/714227d76e78e5db71cfc808d9e52d72... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/714227d76e78e5db71cfc808d9e52d72... You're receiving this email because of your account on gitlab.haskell.org.