[Git][ghc/ghc][wip/T24359] TH support for new SPECIALISE syntax
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Wed Nov 27 12:17:31 UTC 2024
sheaf pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
f2ed0396 by sheaf at 2024-11-27T13:17:18+01:00
TH support for new SPECIALISE syntax
- - - - -
4 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/ThToHs.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
Changes:
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -75,7 +75,7 @@ templateHaskellNames = [
funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName,
classDName, instanceWithOverlapDName,
standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
- pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
+ pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecEDName, pragSpecInstDName,
pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,
defaultSigDName, defaultDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
@@ -386,7 +386,7 @@ recSName = libFun (fsLit "recS") recSIdKey
-- data Dec = ...
funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,
instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
- pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
+ pragSpecDName, pragSpecEDName, pragSpecInstDName, pragRuleDName,
pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,
standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
@@ -410,7 +410,7 @@ forImpDName = libFun (fsLit "forImpD")
pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
pragOpaqueDName = libFun (fsLit "pragOpaqueD") pragOpaqueDIdKey
pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
-pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
+pragSpecEDName = libFun (fsLit "pragSpecED") pragSpecEDIdKey
pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey
pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey
@@ -955,7 +955,7 @@ recSIdKey = mkPreludeMiscIdUnique 316
-- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
- pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,
+ pragInlDIdKey, pragSpecDIdKey, pragSpecEDIdKey, pragSpecInstDIdKey,
pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,
openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
@@ -975,7 +975,7 @@ sigDIdKey = mkPreludeMiscIdUnique 328
forImpDIdKey = mkPreludeMiscIdUnique 329
pragInlDIdKey = mkPreludeMiscIdUnique 330
pragSpecDIdKey = mkPreludeMiscIdUnique 331
-pragSpecInlDIdKey = mkPreludeMiscIdUnique 332
+pragSpecEDIdKey = mkPreludeMiscIdUnique 332
pragSpecInstDIdKey = mkPreludeMiscIdUnique 333
pragRuleDIdKey = mkPreludeMiscIdUnique 334
pragAnnDIdKey = mkPreludeMiscIdUnique 335
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -800,28 +800,37 @@ repDefD (L loc (DefaultDecl _ _ tys)) = do { tys1 <- repLTys tys
repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRuleD (L loc (HsRule { rd_name = n
, rd_act = act
- , rd_bndrs = RuleBndrs { rb_tyvs = m_ty_bndrs, rb_tmvs = tm_bndrs }
+ , rd_bndrs = bndrs
, rd_lhs = lhs
, rd_rhs = rhs }))
+ = fmap (locA loc, ) <$>
+ repRuleBinders bndrs $ \ ty_bndrs' tm_bndrs' ->
+ do { n' <- coreStringLit $ unLoc n
+ ; act' <- repPhases act
+ ; lhs' <- repLE lhs
+ ; rhs' <- repLE rhs
+ ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
+
+repRuleBinders :: RuleBndrs GhcRn
+ -> (Core (Maybe [M (TH.TyVarBndr ())]) -> Core [M TH.RuleBndr] -> MetaM (Core (M a)))
+ -> MetaM (Core (M a))
+repRuleBinders (RuleBndrs { rb_tyvs = m_ty_bndrs, rb_tmvs = tm_bndrs }) thing_inside
= do { let ty_bndrs = fromMaybe [] m_ty_bndrs
- ; rule <- addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs ->
- do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
- ; ss <- mkGenSyms tm_bndr_names
- ; rule <- addBinds ss $
- do { elt_ty <- wrapName tyVarBndrUnitTyConName
- ; ty_bndrs' <- return $ case m_ty_bndrs of
- Nothing -> coreNothing' (mkListTy elt_ty)
- Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs
- ; tm_bndrs' <- repListM ruleBndrTyConName
- repRuleBndr
- tm_bndrs
- ; n' <- coreStringLit $ unLoc n
- ; act' <- repPhases act
- ; lhs' <- repLE lhs
- ; rhs' <- repLE rhs
- ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
- ; wrapGenSyms ss rule }
- ; return (locA loc, rule) }
+ ; addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs ->
+ do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
+ ; ss <- mkGenSyms tm_bndr_names
+ ; x <- addBinds ss $
+ do { elt_ty <- wrapName tyVarBndrUnitTyConName
+ ; ty_bndrs' <- return $ case m_ty_bndrs of
+ Nothing -> coreNothing' (mkListTy elt_ty)
+ Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs
+ ; tm_bndrs' <- repListM ruleBndrTyConName
+ repRuleBndr
+ tm_bndrs
+ ; thing_inside ty_bndrs' tm_bndrs'
+ }
+ ; wrapGenSyms ss x }
+ }
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]
@@ -992,8 +1001,9 @@ rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d (locA loc) fix_sig
rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc)
rep_sig (L loc (SpecSig _ nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys
-rep_sig (L _ sig@(SpecSigE {}))
- = pprPanic "No TH for SPECIALISE yet" (ppr sig)
+rep_sig (L loc (SpecSigE _nm bndrs expr ispec))
+ = fmap ( \ d -> [(locA loc, d)]) $
+ rep_specialiseE bndrs expr ispec
rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc)
rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas
rep_sig (L loc (SCCFunSig _ nm str)) = rep_sccFun nm str (locA loc)
@@ -1096,23 +1106,39 @@ rep_inline nm ispec loc
; return [(loc, pragma)]
}
+rep_inline_phases :: InlinePragma -> MetaM (Core (Maybe TH.Inline), Core TH.Phases)
+rep_inline_phases (InlinePragma { inl_act = act, inl_inline = inl })
+ = do { phases <- repPhases act
+ ; inl <- if noUserInlineSpec inl
+ -- SPECIALISE
+ then dataCon nothingDataConName
+ -- SPECIALISE INLINE
+ else do { MkC inl1 <- repInline inl
+ ; dataCon' justDataConName [inl1] }
+ ; return (inl, phases) }
+
rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma
-> SrcSpan
-> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_specialise nm ty ispec loc
+ -- Old form SPECIALISE pragmas
= do { nm1 <- lookupLOcc nm
; ty1 <- repHsSigType ty
- ; phases <- repPhases $ inl_act ispec
- ; let inline = inl_inline ispec
- ; pragma <- if noUserInlineSpec inline
- then -- SPECIALISE
- repPragSpec nm1 ty1 phases
- else -- SPECIALISE INLINE
- do { inline1 <- repInline inline
- ; repPragSpecInl nm1 ty1 inline1 phases }
+ ; (inl, phases) <- rep_inline_phases ispec
+ ; pragma <- repPragSpec nm1 ty1 inl phases
; return [(loc, pragma)]
}
+rep_specialiseE :: RuleBndrs GhcRn -> LHsExpr GhcRn -> InlinePragma
+ -> MetaM (Core (M TH.Dec))
+rep_specialiseE bndrs e ispec
+ -- New form SPECIALISE pragmas
+ = repRuleBinders bndrs $ \ ty_bndrs tm_bndrs ->
+ do { (inl, phases) <- rep_inline_phases ispec
+ ; exp <- repLE e
+ ; repPragSpecE ty_bndrs tm_bndrs exp inl phases
+ }
+
rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
-> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_specialiseInst ty loc
@@ -2751,15 +2777,18 @@ repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec))
repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm]
-repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases
+repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core (Maybe (TH.Inline))
+ -> Core TH.Phases
-> MetaM (Core (M TH.Dec))
-repPragSpec (MkC nm) (MkC ty) (MkC phases)
- = rep2 pragSpecDName [nm, ty, phases]
-
-repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline
- -> Core TH.Phases -> MetaM (Core (M TH.Dec))
-repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
- = rep2 pragSpecInlDName [nm, ty, inline, phases]
+repPragSpec (MkC nm) (MkC ty) (MkC inline) (MkC phases)
+ = rep2 pragSpecDName [nm, ty, inline, phases]
+
+repPragSpecE :: Core (Maybe [M (TH.TyVarBndr ())]) -> Core [(M TH.RuleBndr)]
+ -> Core (M TH.Exp)
+ -> Core (Maybe (TH.Inline)) -> Core TH.Phases
+ -> MetaM (Core (M TH.Dec))
+repPragSpecE (MkC ty_bndrs) (MkC tm_bndrs) (MkC expr) (MkC inline) (MkC phases)
+ = rep2 pragSpecEDName [ty_bndrs, tm_bndrs, expr, inline, phases]
repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec))
repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -898,21 +898,7 @@ cvtPragmaD (OpaqueP nm)
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
- ; let src TH.NoInline = fsLit "{-# SPECIALISE NOINLINE"
- src TH.Inline = fsLit "{-# SPECIALISE INLINE"
- src TH.Inlinable = fsLit "{-# SPECIALISE INLINE"
- ; let (inline', dflt, srcText) = case inline of
- Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,
- toSrcTxt inline1)
- Nothing -> (NoUserInlinePrag, AlwaysActive,
- SourceText $ fsLit "{-# SPECIALISE")
- where
- toSrcTxt a = SourceText $ src a
- ; let ip = InlinePragma { inl_src = srcText
- , inl_inline = inline'
- , inl_rule = Hs.FunLike
- , inl_act = cvtPhases phases dflt
- , inl_sat = Nothing }
+ ; let ip = cvtInlinePhases inline phases
; returnJustLA $ Hs.SigD noExtField $ SpecSig noAnn nm' [ty'] ip }
cvtPragmaD (SpecialiseInstP ty)
@@ -920,6 +906,16 @@ cvtPragmaD (SpecialiseInstP ty)
; returnJustLA $ Hs.SigD noExtField $
SpecInstSig (noAnn, (SourceText $ fsLit "{-# SPECIALISE")) ty' }
+cvtPragmaD (SpecialiseEP ty_bndrs tm_bndrs exp inline phases)
+ = do { ty_bndrs' <- traverse cvtTvs ty_bndrs
+ ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
+ ; let ip = cvtInlinePhases inline phases
+ ; exp' <- cvtl exp
+ ; let bndrs' = RuleBndrs { rb_ext = noAnn, rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' }
+ ; returnJustLA $ Hs.SigD noExtField $
+ SpecSigE noAnn bndrs' exp' ip
+ }
+
cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
; rd_name' <- returnLA nm'
@@ -1000,6 +996,24 @@ cvtRuleBndr (TypedRuleVar n ty)
; ty' <- cvtType ty
; returnLA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }
+cvtInlinePhases :: Maybe Inline -> Phases -> InlinePragma
+cvtInlinePhases inline phases =
+ let src TH.NoInline = fsLit "{-# SPECIALISE NOINLINE"
+ src TH.Inline = fsLit "{-# SPECIALISE INLINE"
+ src TH.Inlinable = fsLit "{-# SPECIALISE INLINE"
+ (inline', dflt, srcText) = case inline of
+ Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,
+ toSrcTxt inline1)
+ Nothing -> (NoUserInlinePrag, AlwaysActive,
+ SourceText $ fsLit "{-# SPECIALISE")
+ where
+ toSrcTxt a = SourceText $ src a
+ in InlinePragma { inl_src = srcText
+ , inl_inline = inline'
+ , inl_rule = Hs.FunLike
+ , inl_act = cvtPhases phases dflt
+ , inl_sat = Nothing }
+
---------------------------------------------------
-- Declarations
---------------------------------------------------
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -2164,7 +2164,9 @@ data Pragma = InlineP Name Inline RuleMatch Phases
| OpaqueP Name
-- ^ @{ {\-\# OPAQUE T #-} }@
| SpecialiseP Name Type (Maybe Inline) Phases
- -- ^ @{ {\-\# SPECIALISE [INLINE] [phases] T #-} }@
+ -- ^ @{ {\-\# SPECIALISE [INLINE] [phases] nm :: ty #-} }@
+ | SpecialiseEP (Maybe [TyVarBndr ()]) [RuleBndr] Exp (Maybe Inline) Phases
+ -- ^ @{ {\-\# SPECIALISE [INLINE] [phases] exp #-} }@
| SpecialiseInstP Type
-- ^ @{ {\-\# SPECIALISE instance I #-} }@
| RuleP String (Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2ed0396c6d890b4251cd73ce148eace791df9fb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2ed0396c6d890b4251cd73ce148eace791df9fb
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/20241127/4c88d960/attachment-0001.html>
More information about the ghc-commits
mailing list