clash-lib-1.10.3: src/Clash/Rewrite/StrategyDSL/TH.hs
{-|
Copyright : (C) 2026, QBayLogic B.V.
License : BSD2 (see the file LICENSE)
Maintainer : QBayLogic B.V. <devops@qbaylogic.com>
Compile a "Clash.Rewrite.StrategyDSL" strategy into executable dispatch
code. 'compileStrategy' produces the fused fast path: one constructor match
per node drives both the dispatch of the node program and the descent into
the node's children.
-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Clash.Rewrite.StrategyDSL.TH
( compileStrategy
, compileStrategyReference
, dispatchQ
, asRewriteQ
) where
import Data.Char (isAlphaNum)
import Data.Foldable (traverse_)
import Data.List (tails)
import Language.Haskell.TH hiding (Prim)
import Clash.Core.Term
(Bind (..), CoreContext (..), Term (..), bindToList, patIds, primArg)
import Clash.Core.VarEnv (extendInScopeSet, extendInScopeSetList)
import Clash.Rewrite.StrategyDSL
( Constructor (..), Step (..), Strat (..), Transformation (..)
, TransformationWorker (..)
)
import Clash.Rewrite.Types (TransformContext (..))
import Clash.Rewrite.Util (apply, applyWith)
import qualified Clash.Rewrite.Combinators as Comb
import qualified Control.Monad as Monad
import qualified Control.Monad.Writer as Writer
import qualified Data.Monoid as Monoid
-- | The term constructor belonging to a 'Constructor'.
constructorName :: Constructor -> Name
constructorName con = case con of
CVar -> 'Var
CData -> 'Data
CLiteral -> 'Literal
CPrim -> 'Prim
CLam -> 'Lam
CTyLam -> 'TyLam
CApp -> 'App
CTyApp -> 'TyApp
CLet -> 'Let
CCase -> 'Case
CCast -> 'Cast
CTick -> 'Tick
-- | Binder hints for a constructor's fields. Underscore-prefixed because not
-- every generated arm uses every field.
constructorFieldHints :: Constructor -> [String]
constructorFieldHints con = case con of
CVar -> ["_i"]
CData -> ["_dc"]
CLiteral -> ["_lit"]
CPrim -> ["_p"]
CLam -> ["_v", "_e"]
CTyLam -> ["_tv", "_e"]
CApp -> ["_fun", "_arg"]
CTyApp -> ["_fun", "_argTy"]
CLet -> ["_bnd", "_body"]
CCase -> ["_subj", "_altsTy", "_alts"]
CCast -> ["_e", "_fromTy", "_toTy"]
CTick -> ["_tick", "_e"]
constructorFieldNames :: Constructor -> Q [Name]
constructorFieldNames = traverse newName . constructorFieldHints
allConstructors :: [Constructor]
allConstructors = [minBound .. maxBound]
-- | Constructors whose nodes have no subterms to descend into.
isLeafConstructor :: Constructor -> Bool
isLeafConstructor con = con `elem` [CVar, CData, CLiteral, CPrim]
-- | How a bucket member is invoked once the constructor has matched.
data Invoke
= InvokeFields Name -- ^ worker applied to ctx, node, and the node's fields
| InvokeNode Name -- ^ worker applied to ctx and the node only
-- | The member's invocation at this constructor, if it is in the
-- constructor's bucket.
invokeAt :: Constructor -> Transformation -> Maybe Invoke
invokeAt con transformation = go transformation.workers
where
go [] = Nothing
go (FieldWorker con' worker : rest)
| con' == con = Just (InvokeFields worker)
| otherwise = go rest
go (Worker con' worker : rest)
| con' == con = Just (InvokeNode worker)
| otherwise = go rest
go (AnyWorker worker : _) = Just (InvokeNode worker)
invokeE :: Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
invokeE (InvokeFields worker) ctxE nodeE fieldEs =
foldl appE (varE worker) (ctxE : nodeE : fieldEs)
invokeE (InvokeNode worker) ctxE nodeE _fieldEs =
[| $(varE worker) $ctxE $nodeE |]
validateChain :: [Transformation] -> Q ()
validateChain members = do
Monad.when (null members) (fail "compileStrategy: empty chain")
case [name | name : rest <- tails (map (.name) members), name `elem` rest] of
name : _ ->
fail ("compileStrategy: duplicate transformation name in one chain: "
<> show name <> " (alias one occurrence with 'named')")
[] -> pure ()
traverse_ validateTransformation members
-- | A transformation's worker table must be non-empty, register at most one
-- worker per constructor, and not mix 'AnyWorker' with per-constructor
-- workers: a transformation either fires at any constructor or at specific
-- ones, never both.
validateTransformation :: Transformation -> Q ()
validateTransformation transformation
| null workers = failWith "declares no workers"
| any isAnyWorker workers, any (not . isAnyWorker) workers
= failWith "mixes AnyWorker with per-constructor workers"
| length (filter isAnyWorker workers) > 1 = failWith "has a duplicate AnyWorker"
| con : _ <- duplicateConstructors = failWith ("has two workers for " <> show con)
| otherwise = pure ()
where
workers = transformation.workers
failWith reason =
fail ("compileStrategy: transformation " <> show transformation.name
<> " " <> reason)
isAnyWorker AnyWorker{} = True
isAnyWorker _ = False
duplicateConstructors =
[ con
| con : rest <- tails [c | Just c <- map workerConstructor workers]
, con `elem` rest
]
workerConstructor (FieldWorker con _) = Just con
workerConstructor (Worker con _) = Just con
workerConstructor (AnyWorker _) = Nothing
-- | Bind the result and change flag of an action:
-- @do { (t, w) <- Writer.listen action; \<continue t (getAny w)\> }@
withListen :: Q Exp -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
withListen action continue = do
t <- newName "t"
w <- newName "w"
doE
[ bindS (tupP [varP t, varP w]) [| Writer.listen $action |]
, noBindS (continue (varE t) [| Monoid.getAny $(varE w) |])
]
-- | Bind an expression so a continuation can use it more than once.
bindTo :: String -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
bindTo hint bound continue = do
x <- newName hint
letE [valD (varP x) (normalB bound) []] (continue (varE x))
-- | A fresh name for a generated let-binding, derived from a transformation
-- name. Underscore-prefixed: not every generated binding ends up used.
freshBinding :: String -> Q Name
freshBinding hint = newName ('_' : map sanitize hint)
where
sanitize c = if isAlphaNum c then c else '_'
-- | @\\ctx tm -> case tm of { \<arm per constructor with a program\>;
-- _ -> pure tm }@
-- The wildcard is omitted when every constructor has an arm.
nodeCaseExp
:: (Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)) -> Q Exp
nodeCaseExp armFor = do
ctx <- newName "ctx"
tm <- newName "tm"
let arms =
[ do fieldNames <- constructorFieldNames con
match (conP (constructorName con) (map varP fieldNames))
(normalB (armBody (varE ctx) (varE tm) (map varE fieldNames)))
[]
| con <- allConstructors
, Just armBody <- [armFor con]
]
fallthrough
| length arms == length allConstructors = []
| otherwise = [match wildP (normalB [| pure $(varE tm) |]) []]
lamE [varP ctx, varP tm] (caseE (varE tm) (arms <> fallthrough))
-- | A compiled node program. 'known' is the program entered with the
-- node's constructor statically known and its fields in scope; 'Nothing'
-- means the program is the identity at that constructor. 'dispatch'
-- references a generated binding running the program on a term of unknown
-- constructor.
data CompiledStep = CompiledStep
{ decs :: [Q Dec]
, known :: Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
, dispatch :: Q Exp
}
compileStep :: Step -> Q CompiledStep
compileStep step = case step of
Chain members -> compileChain members
SeqS a b -> compileStep2 a b seqKnown seqDispatch
OnChangeS a b -> compileStep2 a b onChangeKnown (combinatorDispatch [| (Comb.!->) |])
OnNoChangeS a b -> compileStep2 a b onNoChangeKnown (combinatorDispatch [| (Comb.>-!) |])
EmbedS strat -> do
embedded <- freshBinding "embedded"
let dec = valD (varP embedded) (normalB (compileStrategy strat)) []
pure CompiledStep
{ decs = [dec]
, known = \_con ->
Just (\ctxE nodeE _fieldEs -> [| $(varE embedded) $ctxE $nodeE |])
, dispatch = varE embedded
}
where
-- These need signatures: without them the record selectors below are
-- inferred as 'HasField' constraints rather than resolved against
-- 'CompiledStep'.
seqKnown, onChangeKnown, onNoChangeKnown
:: CompiledStep -> CompiledStep -> Constructor
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
seqDispatch :: CompiledStep -> CompiledStep -> Q Exp
combinatorDispatch :: Q Exp -> CompiledStep -> CompiledStep -> Q Exp
compileStep2
:: Step -> Step
-> (CompiledStep -> CompiledStep -> Constructor
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> (CompiledStep -> CompiledStep -> Q Exp)
-> Q CompiledStep
seqKnown ca cb con = case (ca.known con, cb.known con) of
(Nothing, Nothing) -> Nothing
(Nothing, Just kb) -> Just kb
(Just ka, Nothing) -> Just $ \ctxE nodeE fieldEs ->
withListen (ka ctxE nodeE fieldEs) $ \tE changedE ->
condE changedE [| $(cb.dispatch) $ctxE $tE |] [| pure $tE |]
(Just ka, Just kb) -> Just $ \ctxE nodeE fieldEs ->
withListen (ka ctxE nodeE fieldEs) $ \tE changedE ->
-- When the left side did not signal change the term is untouched,
-- so the right side can still run on the statically matched fields.
condE changedE [| $(cb.dispatch) $ctxE $tE |] (kb ctxE tE fieldEs)
seqDispatch ca cb =
[| \ctx tm -> $(ca.dispatch) ctx tm >>= $(cb.dispatch) ctx |]
onChangeKnown ca cb con = case ca.known con of
Nothing -> Nothing
Just ka -> Just $ \ctxE nodeE fieldEs ->
withListen (ka ctxE nodeE fieldEs) $ \tE changedE ->
condE changedE [| $(cb.dispatch) $ctxE $tE |] [| pure $tE |]
onNoChangeKnown ca cb con = case (ca.known con, cb.known con) of
(Nothing, kb) -> kb
(Just ka, Nothing) -> Just ka
(Just ka, Just kb) -> Just $ \ctxE nodeE fieldEs ->
withListen (ka ctxE nodeE fieldEs) $ \tE changedE ->
condE changedE [| pure $tE |] (kb ctxE tE fieldEs)
combinatorDispatch op ca cb = [| $op $(ca.dispatch) $(cb.dispatch) |]
compileStep2 a b mkKnown mkDispatch = do
ca <- compileStep a
cb <- compileStep b
dispatch <- freshBinding "dispatch"
let dispatchDec = valD (varP dispatch) (normalB (mkDispatch ca cb)) []
pure CompiledStep
{ decs = ca.decs <> cb.decs <> [dispatchDec]
, known = mkKnown ca cb
, dispatch = varE dispatch
}
compileChain :: [Transformation] -> Q CompiledStep
compileChain members = do
validateChain members
guardNames <- traverse (\member -> freshBinding ("g_" <> member.name)) members
let guardDecs = zipWith memberGuardDec guardNames members
dispatch <- freshBinding "dispatch"
let -- The constructor's bucket, each member paired with the guards of all
-- members after it in the chain (the member's guarded suffix).
bucketAt con =
[ (member, invoke, map snd rest)
| (member, _guardName) : rest <- tails (zip members guardNames)
, Just invoke <- [invokeAt con member]
]
known con = case bucketAt con of
[] -> Nothing
bucket -> Just (chainArm bucket)
dispatchDec = valD (varP dispatch) (normalB (nodeCaseExp known)) []
pure CompiledStep
{ decs = guardDecs <> [dispatchDec]
, known
, dispatch = varE dispatch
}
-- | A bucket entered with the constructor statically known: run the members
-- in order on the original fields; after the first change, hand the term to
-- the remaining chain members' guards.
chainArm
:: [(Transformation, Invoke, [Name])]
-> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
chainArm bucket0 ctxE nodeE0 fieldEs = go nodeE0 bucket0
where
go :: Q Exp -> [(Transformation, Invoke, [Name])] -> Q Exp
go nodeE [] = [| pure $nodeE |]
go nodeE ((member, invoke, suffixGuards) : rest) = do
t <- newName "t"
changed <- newName "changed"
doE
[ bindS (tupP [varP t, varP changed])
[| applyWith $(stringE member.name) $ctxE $nodeE
$(invokeE invoke ctxE nodeE fieldEs) |]
, noBindS $ condE (varE changed)
(guardedSuffix suffixGuards ctxE (varE t))
(go (varE t) rest)
]
-- | @g1 ctx t >>= g2 ctx >>= …@: offer the term to each remaining chain
-- member through its full worker table.
guardedSuffix :: [Name] -> Q Exp -> Q Exp -> Q Exp
guardedSuffix [] _ctxE nodeE = [| pure $nodeE |]
guardedSuffix (g : gs) ctxE nodeE =
foldl (\acc g' -> [| $acc >>= $(varE g') $ctxE |])
[| $(varE g) $ctxE $nodeE |]
gs
-- | One member's guard: match the term against the member's full worker
-- table; run the member instrumented on a match, return the term untouched
-- (without instrumentation) otherwise.
memberGuardDec :: Name -> Transformation -> Q Dec
memberGuardDec guardName transformation =
valD (varP guardName) (normalB (guardExp instrumented transformation)) []
where
instrumented invoke ctxE nodeE fieldEs =
[| fmap fst (applyWith $(stringE transformation.name) $ctxE $nodeE
$(invokeE invoke ctxE nodeE fieldEs)) |]
-- | @\\ctx tm -> case tm of …@ over a transformation's worker table, with the
-- given wrapper around each invocation.
guardExp
:: (Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Transformation
-> Q Exp
guardExp wrap transformation =
nodeCaseExp $ \con -> wrap <$> invokeAt con transformation
{-
Note [NonRec erasure during descent]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Clash.Rewrite.Combinators.allR' matches let-expressions through the 'Letrec'
pattern synonym and rebuilds them with 'Rec' bindings, so any 'NonRec' let a
traversal descends into comes back as a 'Rec' let. The generated descent
replicates that behavior deliberately: preserving 'NonRec' is a real behavior
change (downstream code branches on 'Rec'/'NonRec', and netlist rendering
order can shift) that must be validated on its own, separately from this
dispatch machinery.
-}
-- | The one-level descent for one constructor, replicating
-- 'Clash.Rewrite.Combinators.allR' exactly: same 'CoreContext' pushes, same
-- 'InScopeSet' extensions, and the argument's context computed from the
-- already-rewritten function. The continuation receives the rebuilt node's
-- fields and the rebuilt node itself; descent preserves the constructor, so
-- the continuation may run a statically matched program on the result.
genDescend
:: Constructor
-> Q Exp -- ^ recursion function @:: TransformContext -> Term -> m Term@
-> (Q Exp, Q Exp) -- ^ the context's InScopeSet and CoreContext stack
-> Q Exp -- ^ the node
-> [Q Exp] -- ^ the node's fields
-> ([Q Exp] -> Q Exp -> Q Exp) -- ^ continuation: rebuilt fields, rebuilt node
-> Q Exp
genDescend con go (isE, cE) nodeE fieldEs continue = case (con, fieldEs) of
(CVar, _) -> leaf
(CData, _) -> leaf
(CLiteral, _) -> leaf
(CPrim, _) -> leaf
(CLam, [v, e]) -> do
e' <- newName "e'"
doE
[ bindS (varP e')
[| $go (TransformContext (extendInScopeSet $isE $v) (LamBody $v : $cE)) $e |]
, continueWith [v, varE e'] [| Lam $v $(varE e') |]
]
(CTyLam, [tv, e]) -> do
e' <- newName "e'"
doE
[ bindS (varP e')
[| $go (TransformContext (extendInScopeSet $isE $tv) (TyLamBody $tv : $cE)) $e |]
, continueWith [tv, varE e'] [| TyLam $tv $(varE e') |]
]
(CApp, [fun, arg]) -> do
fun' <- newName "fun'"
arg' <- newName "arg'"
doE
[ bindS (varP fun') [| $go (TransformContext $isE (AppFun : $cE)) $fun |]
-- The argument's context is computed from the already rewritten
-- function, so the function has to be rewritten first.
, bindS (varP arg')
[| $go (TransformContext $isE (AppArg (primArg $(varE fun')) : $cE)) $arg |]
, continueWith [varE fun', varE arg'] [| App $(varE fun') $(varE arg') |]
]
(CTyApp, [fun, argTy]) -> do
fun' <- newName "fun'"
doE
[ bindS (varP fun') [| $go (TransformContext $isE (TyAppC : $cE)) $fun |]
, continueWith [varE fun', argTy] [| TyApp $(varE fun') $argTy |]
]
(CLet, [bnd, body]) -> do
-- See Note [NonRec erasure during descent]
bs <- newName "bs"
bndrs <- newName "bndrs"
is' <- newName "is'"
bs' <- newName "bs'"
body' <- newName "body'"
doE
[ letS
[ valD (varP bs) (normalB [| bindToList $bnd |]) []
, valD (varP bndrs) (normalB [| map fst $(varE bs) |]) []
, valD (varP is') (normalB [| extendInScopeSetList $isE $(varE bndrs) |]) []
]
, bindS (varP bs')
[| traverse
(\(b, rhs) ->
fmap ((,) b)
($go (TransformContext $(varE is')
(LetBinding b $(varE bndrs) : $cE))
rhs))
$(varE bs) |]
, bindS (varP body')
[| $go (TransformContext $(varE is') (LetBody $(varE bs) : $cE)) $body |]
, continueWith [[| Rec $(varE bs') |], varE body']
[| Let (Rec $(varE bs')) $(varE body') |]
]
(CCase, [subj, altsTy, alts]) -> do
subj' <- newName "subj'"
alts' <- newName "alts'"
doE
[ bindS (varP subj') [| $go (TransformContext $isE (CaseScrut : $cE)) $subj |]
, bindS (varP alts')
[| traverse
(\(p, e) ->
let (tvs, ids) = patIds p
isAlt = extendInScopeSetList (extendInScopeSetList $isE tvs) ids
in fmap ((,) p) ($go (TransformContext isAlt (CaseAlt p : $cE)) e))
$alts |]
, continueWith [varE subj', altsTy, varE alts']
[| Case $(varE subj') $altsTy $(varE alts') |]
]
(CCast, [e, fromTy, toTy]) -> do
e' <- newName "e'"
doE
[ bindS (varP e') [| $go (TransformContext $isE (CastBody : $cE)) $e |]
, continueWith [varE e', fromTy, toTy] [| Cast $(varE e') $fromTy $toTy |]
]
(CTick, [tick, e]) -> do
e' <- newName "e'"
doE
[ bindS (varP e') [| $go (TransformContext $isE (TickC $tick : $cE)) $e |]
, continueWith [tick, varE e'] [| Tick $tick $(varE e') |]
]
_ -> fail ("genDescend: field count mismatch for " <> show con)
where
leaf = continue fieldEs nodeE
continueWith fieldEs' rebuiltE = noBindS (continue fieldEs' rebuiltE)
-- | What a traversal does at one node: given the recursion function, the
-- node program for the matched constructor ('Nothing' when the program is the
-- identity there), the context, the node, its fields, and a descent builder,
-- produce the body of @go@'s clause for that constructor.
type NodeArm
= Q Exp -- ^ the traversal's @go@
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Q Exp -- ^ ctx
-> Q Exp -- ^ the node
-> [Q Exp] -- ^ its fields
-> (([Q Exp] -> Q Exp -> Q Exp) -> Q Exp) -- ^ descend with a continuation
-> Q Exp
-- | Generate a fused traversal: a recursive @go@ whose single constructor
-- match drives both the node program and the descent. The recursion
-- structure of each traversal is pinned to its "Clash.Rewrite.Combinators"
-- counterpart, with the node program as @r@:
--
-- * 'TopDown': @'Comb.topdownR' r = 'Comb.repeatR' r '>->' 'Comb.allR' …@. On
-- change, re-enter @go@ at this node (which also re-matches the
-- constructor); otherwise descend. See Note [topdown repeatR] in
-- "Clash.Rewrite.Combinators".
-- * 'BottomUp': descend first, run the program once on the rebuilt node,
-- whose constructor is already known, so no re-match.
-- * 'TopDownSuc': run the program once; when it fired, stop, neither
-- repeating nor descending.
-- * 'InnerMost': bottom-up; when the program fires, re-enter @go@ on the
-- result until the innermost fixpoint is reached.
-- * 'TopDownFix': see 'genTopDownFix'.
genTraversal :: Strat -> Q Exp
genTraversal strat = case strat of
TopDown step -> fused step $ \goE known ctxE tmE fieldEs descend ->
case known of
Nothing -> descend rebuildOnly
Just ka ->
withListen (ka ctxE tmE fieldEs) $ \tE changedE ->
condE changedE [| $goE $ctxE $tE |] (descend rebuildOnly)
TopDownSuc step -> fused step $ \_goE known ctxE tmE fieldEs descend ->
case known of
Nothing -> descend rebuildOnly
Just ka ->
withListen (ka ctxE tmE fieldEs) $ \tE changedE ->
condE changedE [| pure $tE |] (descend rebuildOnly)
BottomUp step -> fused step $ \_goE known ctxE _tmE _fieldEs descend ->
descend $ \fieldEs' rebuiltE ->
case known of
Nothing -> [| pure $rebuiltE |]
Just ka -> bindTo "tm'" rebuiltE $ \tmE' -> ka ctxE tmE' fieldEs'
InnerMost step -> fused step $ \goE known ctxE _tmE _fieldEs descend ->
descend $ \fieldEs' rebuiltE ->
case known of
Nothing -> [| pure $rebuiltE |]
Just ka -> bindTo "tm'" rebuiltE $ \tmE' ->
withListen (ka ctxE tmE' fieldEs') $ \tE changedE ->
condE changedE [| $goE $ctxE $tE |] [| pure $tE |]
TopDownFix step -> do
cs <- compileStep step
genTopDownFix cs
_ -> fail "genTraversal: not a traversal"
where
rebuildOnly :: [Q Exp] -> Q Exp -> Q Exp
rebuildOnly _fieldEs' rebuiltE = [| pure $rebuiltE |]
fused :: Step -> NodeArm -> Q Exp
fused step mkArm = do
cs <- compileStep step
go <- newName "go"
clauses <- traverse (goClause cs (varE go) mkArm) allConstructors
letE (cs.decs <> [pure (FunD go clauses)]) (varE go)
goClause :: CompiledStep -> Q Exp -> NodeArm -> Constructor -> Q Clause
goClause cs goE mkArm con = do
ctx <- newName "_ctx"
is <- newName "_is"
c <- newName "_c"
tm <- newName "_tm"
fieldNames <- constructorFieldNames con
let fieldEs = map varE fieldNames
descend = genDescend con goE (varE is, varE c) (varE tm) fieldEs
body <- mkArm goE (cs.known con) (varE ctx) (varE tm) fieldEs descend
pats <- sequence
[ asP ctx (conP 'TransformContext [varP is, varP c])
, asP tm (conP (constructorName con) (map varP fieldNames))
]
pure (Clause pats (NormalB body) [])
-- | 'Comb.topdownFixR' with the node program as @r@: a local @settle@
-- (@'Comb.repeatR' r@) plus the tryParent\/childChanged\/parentChanged loop
-- from Note [topdownFixR] in "Clash.Rewrite.Combinators", over a generated
-- 'Comb.allR' replica.
genTopDownFix :: CompiledStep -> Q Exp
genTopDownFix cs = do
goFix <- newName "goFix"
settle <- newName "settle"
descendD <- newName "descendD"
descendClauses <- traverse descendClause allConstructors
let settleDec = valD (varP settle) (normalB
[| let loop ctx tm = do
(t1, w) <- Writer.listen ($(cs.dispatch) ctx tm)
if Monoid.getAny w then loop ctx t1 else pure t1
in loop |]) []
descendDec = pure (FunD descendD descendClauses)
goFixDec = valD (varP goFix) (normalB
[| let loop tryParent ctx tm = do
t1 <- if tryParent then $(varE settle) ctx tm else pure tm
(t2, w1) <- Writer.listen
($(varE descendD) (loop True) ctx t1)
if Monoid.getAny w1
then do
(t3, w2) <- Writer.listen ($(varE settle) ctx t2)
if Monoid.getAny w2
then loop False ctx t3
else pure t3
else pure t2
in loop |]) []
letE (cs.decs <> [settleDec, descendDec, goFixDec]) [| $(varE goFix) True |]
where
descendClause con = do
-- Leaf clauses never call the recursion argument; the underscore hint
-- keeps -Wunused-matches quiet there.
rec' <- newName (if isLeafConstructor con then "_rec" else "rec'")
is <- newName "_is"
c <- newName "_c"
tm <- newName "_tm"
fieldNames <- constructorFieldNames con
body <- genDescend con (varE rec') (varE is, varE c) (varE tm)
(map varE fieldNames) (\_fieldEs' rebuiltE -> [| pure $rebuiltE |])
pats <- sequence
[ varP rec'
, conP 'TransformContext [varP is, varP c]
, asP tm (conP (constructorName con) (map varP fieldNames))
]
pure (Clause pats (NormalB body) [])
-- | Compile a strategy into its fused dispatch code. The result is an
-- expression of type @Rewrite extra@, with @extra@ fixed by the workers the
-- spec references.
compileStrategy :: Strat -> Q Exp
compileStrategy strat = case strat of
Seq a b -> [| $(compileStrategy a) Comb.>-> $(compileStrategy b) |]
DeepSeqS a b -> [| $(compileStrategy a) Comb.>-!-> $(compileStrategy b) |]
OnChange a b -> [| $(compileStrategy a) Comb.!-> $(compileStrategy b) |]
OnNoChange a b -> [| $(compileStrategy a) Comb.>-! $(compileStrategy b) |]
Repeat a -> [| Comb.repeatR $(compileStrategy a) |]
Pass name rewriteName -> [| apply $(stringE name) $(varE rewriteName) |]
CallStrategy name -> varE name
TopDown{} -> genTraversal strat
BottomUp{} -> genTraversal strat
TopDownFix{} -> genTraversal strat
TopDownSuc{} -> genTraversal strat
InnerMost{} -> genTraversal strat
-- | Compile a strategy into its unfused reference: the same transformations,
-- run as a plain @apply@ chain through the "Clash.Rewrite.Combinators"
-- traversals. Agrees with 'compileStrategy' on results, transformation
-- counts, and change flags.
compileStrategyReference :: Strat -> Q Exp
compileStrategyReference = goStrat
where
goStrat strat = case strat of
Seq a b -> [| $(goStrat a) Comb.>-> $(goStrat b) |]
DeepSeqS a b -> [| $(goStrat a) Comb.>-!-> $(goStrat b) |]
OnChange a b -> [| $(goStrat a) Comb.!-> $(goStrat b) |]
OnNoChange a b -> [| $(goStrat a) Comb.>-! $(goStrat b) |]
Repeat a -> [| Comb.repeatR $(goStrat a) |]
Pass name rewriteName -> [| apply $(stringE name) $(varE rewriteName) |]
CallStrategy name -> varE name
TopDown step -> [| Comb.topdownR $(goStep step) |]
BottomUp step -> [| Comb.bottomupR $(goStep step) |]
TopDownFix step -> [| Comb.topdownFixR $(goStep step) |]
TopDownSuc step -> [| Comb.topdownSucR $(goStep step) |]
InnerMost step -> [| Comb.innerMost $(goStep step) |]
goStep step = case step of
SeqS a b -> [| $(goStep a) Comb.>-> $(goStep b) |]
OnChangeS a b -> [| $(goStep a) Comb.!-> $(goStep b) |]
OnNoChangeS a b -> [| $(goStep a) Comb.>-! $(goStep b) |]
EmbedS strat -> goStrat strat
Chain members -> do
validateChain members
-- The sequential apply chain over all members, each guarded on its full
-- worker table.
foldr1 (\x y -> [| $x Comb.>-> $y |]) (map memberApplyE members)
memberApplyE member =
[| apply $(stringE member.name) $(asRewriteQ member) |]
-- | A node program as a plain rewrite: match the constructor once and run
-- that constructor's program, without traversing. For composing a 'Step'
-- with plain combinators, and for testing chains in isolation.
dispatchQ :: Step -> Q Exp
dispatchQ step = do
cs <- compileStep step
letE cs.decs cs.dispatch
-- | A transformation as a plain uninstrumented rewrite: match the term
-- against the worker table, run the worker on a match, return the term
-- untouched otherwise. Splice this where a transformation is invoked from
-- inside another transformation (any instrumentation is the caller's).
asRewriteQ :: Transformation -> Q Exp
asRewriteQ transformation = do
validateTransformation transformation
guardExp invokeE transformation