[Git][ghc/ghc][wip/T24359] More
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Nov 21 13:59:47 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
44529c5f by Simon Peyton Jones at 2024-11-21T13:59:34+00:00
More
- - - - -
5 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Sig.hs
- testsuite/tests/typecheck/should_compile/tc212.hs
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -822,7 +822,7 @@ dsSpec mb_poly_rhs (SpecPrag poly_id spec_co spec_inl)
= 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_bndrs (\poly_rhs _ -> core_app poly_rhs)
spec_inl
dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
@@ -845,16 +845,21 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
; 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 = mkLets ds_lhs_binds $
drop_cast $
simpleOptExpr simpl_opts $
ds_call
- mk_spec_call poly_id poly_rhs
- = mkLetNonRec (localiseId poly_id) poly_rhs $
- mkLets ds_rhs_binds $
- core_call
+ mk_spec_call fn_body lhs_args
+ = mkLets ds_rhs_binds $
+ mkCoreApps fn_body lhs_args
; tracePm "dsSpec1" (vcat [ ppr poly_id $$ ppr ds_call $$ ppr core_call])
; finishSpecPrag mb_poly_rhs
@@ -876,7 +881,7 @@ failBecauseOfClassOp poly_id
finishSpecPrag :: Maybe CoreExpr -- See the first param of dsSpec
-> [Var] -- Binders, over LHS and RHS
-> CoreExpr -- LHS pattern
- -> [Var] -> (Id -> CoreExpr -> CoreExpr) -- Make spec RHS given function body
+ -> [Var] -> (CoreExpr -> [CoreExpr] -> CoreExpr) -- Make spec RHS given function body
-> InlinePragma
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
finishSpecPrag mb_poly_rhs
@@ -913,7 +918,7 @@ finishSpecPrag mb_poly_rhs
spec_ty = mkLamTypes spec_bndrs (exprType rule_lhs)
spec_rhs = mkLams spec_bndrs $
- mk_spec_rhs poly_id poly_rhs
+ mk_spec_rhs poly_rhs rule_lhs_args
; dsWarnOrphanRule rule
=====================================
compiler/GHC/HsToCore/Errors/Ppr.hs
=====================================
@@ -109,7 +109,7 @@ instance Diagnostic DsMessage where
, text "is not bound in RULE lhs"])
2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
, text "Orig lhs:" <+> ppr orig_lhs
- , text "optimised lhs:" <+> ppr lhs2 ])
+ , text "Optimised lhs:" <+> ppr lhs2 ])
pp_bndr b
| isTyVar b = text "type variable" <+> quotes (ppr b)
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -896,9 +896,11 @@ mkExport prag_fn residual insoluble qtvs theta
; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty
-- NB: poly_id has a zonked type
- ; poly_id <- addInlinePrags poly_id prag_sigs
- ; spec_prags <- tcSpecPrags poly_id prag_sigs
- -- tcPrags requires a zonked poly_id
+ ; poly_id <- addInlinePrags poly_id prag_sigs
+ ; spec_prags <- tcExtendIdEnv1 poly_name poly_id $
+ tcSpecPrags poly_id prag_sigs
+ -- tcSpecPrags requires a zonked poly_id. It also needs poly_id to
+ -- be in the type env (so we can typecheck the SPECIALISE expression
-- See Note [Impedance matching]
-- NB: we have already done checkValidType, including an ambiguity check,
@@ -1266,27 +1268,6 @@ The impedance matcher can do defaulting: in the above example, we default
to Integer because of Num. See #7173. If we're dealing with a nondefaultable
class, impedance matching can fail. See #23427.
-Note [SPECIALISE pragmas]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-There is no point in a SPECIALISE pragma for a non-overloaded function:
- reverse :: [a] -> [a]
- {-# SPECIALISE reverse :: [Int] -> [Int] #-}
-
-But SPECIALISE INLINE *can* make sense for GADTS:
- data Arr e where
- ArrInt :: !Int -> ByteArray# -> Arr Int
- ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
-
- (!:) :: Arr e -> Int -> e
- {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
- {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
- (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
- (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
-
-When (!:) is specialised it becomes non-recursive, and can usefully
-be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
-for a non-overloaded function.
-
************************************************************************
* *
tcMonoBinds
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -73,7 +73,7 @@ import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Builtin.Names( mkUnboundName )
-import GHC.Unit.Module( getModule )
+import GHC.Unit.Module( Module, getModule )
import GHC.Utils.Misc as Utils ( singleton )
import GHC.Utils.Outputable
@@ -845,6 +845,27 @@ Some wrinkles
regardless of XXX. It's sort of polymorphic in XXX. This is
useful: we use the same wrapper to transform each of the class ops, as
well as the dict. That's what goes on in GHC.Tc.TyCl.Instance.mk_meth_spec_prags
+
+Note [SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+There is no point in a SPECIALISE pragma for a non-overloaded function:
+ reverse :: [a] -> [a]
+ {-# SPECIALISE reverse :: [Int] -> [Int] #-}
+
+But SPECIALISE INLINE *can* make sense for GADTS:
+ data Arr e where
+ ArrInt :: !Int -> ByteArray# -> Arr Int
+ ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
+
+ (!:) :: Arr e -> Int -> e
+ {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
+ {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
+ (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
+ (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
+
+When (!:) is specialised it becomes non-recursive, and can usefully
+be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
+for a non-overloaded function.
-}
tcSpecPrags :: Id -> [LSig GhcRn]
@@ -921,25 +942,21 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
-- Quantify
; let (quant_cts, residual_wanted) = getRuleQuantCts wanted
quant_preds = ctsPreds quant_cts
- (quant_eq_cts, quant_dict_cts) = partitionBag (isEqPred . ctPred) quant_cts
; dvs <- candidateQTyVarsOfTypes (quant_preds ++ seed_tys)
; let grown_tcvs = growThetaTyVars quant_preds (tyCoVarsOfTypes seed_tys)
weeded_dvs = weedOutCandidates (`dVarSetIntersectVarSet` grown_tcvs) dvs
; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars weeded_dvs
-- Left hand side of the RULE
- ; lhs_eq_evs <- mk_quant_evs quant_eq_cts
- ; lhs_dict_evs <- mk_quant_evs quant_dict_cts
- ; let lhs_evs = lhs_eq_evs ++ lhs_dict_evs
+ ; lhs_evs <- mk_quant_evs quant_cts
; (implic1, lhs_binds) <- buildImplicationFor tc_lvl skol_info_anon
qtkvs lhs_evs residual_wanted
-- rhs_binds uses rhs_evs to build `wanted` (NB not just `residual_wanted`)
- ; rhs_dict_evs <- mapM newEvVar (ctsPreds quant_dict_cts)
- ; let rhs_evs = lhs_eq_evs ++ rhs_dict_evs
+ ; rhs_evs <- mapM newEvVar quant_preds
; (implic2, rhs_binds) <- buildImplicationFor tc_lvl skol_info_anon
qtkvs rhs_evs
- (emptyWC { wc_simple = quant_dict_cts })
+ (emptyWC { wc_simple = quant_cts })
; emitImplications (implic1 `unionBags` implic2)
@@ -985,15 +1002,13 @@ tcSpecWrapper ctxt poly_ty spec_ty
tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag]
-- SPECIALISE pragmas for imported things
tcImpPrags prags
- = do { this_mod <- getModule
- ; dflags <- getDynFlags
+ = do { dflags <- getDynFlags
+ ; traceTc "tcImpPrags1" (ppr prags)
; if (not_specialising dflags) then
return []
else do
- { pss <- mapAndRecoverM (wrapLocMA tcImpSpec)
- [L loc (name,prag)
- | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags
- , not (nameIsLocalOrFrom this_mod name) ]
+ { this_mod <- getModule
+ ; pss <- mapAndRecoverM (wrapLocMA (tcImpSpec this_mod)) prags
; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } }
where
-- Ignore SPECIALISE pragmas for imported things
@@ -1003,8 +1018,10 @@ tcImpPrags prags
not_specialising dflags =
not (gopt Opt_Specialise dflags) || not (backendRespectsSpecialise (backend dflags))
-tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
-tcImpSpec (name, prag)
+tcImpSpec :: Module -> Sig GhcRn -> TcM [TcSpecPrag]
+tcImpSpec this_mod prag
+ | Just name <- is_spec_prag prag -- It's a specialisation pragma
+ , not (nameIsLocalOrFrom this_mod name) -- The Id is imported
= do { id <- tcLookupId name
; if hasSomeUnfolding (realIdUnfolding id)
-- See Note [SPECIALISE pragmas for imported Ids]
@@ -1012,6 +1029,12 @@ tcImpSpec (name, prag)
else do { let dia = TcRnSpecialiseNotVisible name
; addDiagnosticTc dia
; return [] } }
+ | otherwise
+ = return []
+ where
+ is_spec_prag (SpecSig _ (L _ nm) _ _) = Just nm
+ is_spec_prag (SpecSigE nm _ _ _) = Just nm
+ is_spec_prag _ = Nothing
{- Note [SPECIALISE pragmas for imported Ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
testsuite/tests/typecheck/should_compile/tc212.hs
=====================================
@@ -4,5 +4,6 @@
module ShouldCompile where
-- A specialise pragma with no type signature
-fac n = fac (n + 1)
+-- fac :: Num a => a -> a
+fac n = n -- fac (n + 1)
{-# SPECIALISE fac :: Int -> Int #-}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44529c5f99b6c6d35523420bf3c57801bcca47e3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44529c5f99b6c6d35523420bf3c57801bcca47e3
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/20241121/a3d642a6/attachment-0001.html>
More information about the ghc-commits
mailing list