{-# LANGUAGE Safe #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Process-level cleanups of the block graph, between purify and the
--   machine lint:
--
--   * /Epsilon-block inlining/: a block with no commands whose terminator
--     is a single goto is glue; references to it re-target its successor
--     directly (with the argument substitution applied). A pause target
--     is never inlined away — it is a machine state. Chain-following is
--     fuel-bounded by the block count: the goto-only subgraph is acyclic
--     on guarded input, but the machine lint's guardedness rule is only
--     checked downstream of this pass.
--
--   * /Alpha-equal block merge/ (the retired duplicate-definition merge's
--     structural successor): blocks whose bodies are alpha-equivalent
--     (binders renumbered; labels and cells compared by identity) merge,
--     and references redirect to the survivor. Iterated to a fixpoint:
--     each round of merging can unify the targets of further blocks.
--     This is what keeps the state count minimal — an INLINE-duplicated
--     continuation mints many identical pause targets.
--
--   * /Unreachable-block purge/: purify drops the continuation of a
--     computation that cannot return (an error at monadic type), which
--     orphans the blocks compiled for it. Orphaned pause targets would
--     otherwise mint machine states (and dispatch entries) and mask the
--     never-pauses lint, so blocks unreachable from the entry are removed.
module ReWire.Synolon.Transform (optimizeProc, machineSummary) where

import ReWire.Eidos.Subst (substVars)
import ReWire.Pretty (prettyPrint)
import ReWire.Synolon.Lint (isOperand)
import ReWire.Synolon.Pretty ()
import ReWire.Synolon.Syntax

import Control.Monad.State.Strict (State, evalState, get, put)
import Data.Maybe (fromMaybe)
import Data.Text (Text)

import qualified Data.HashMap.Strict as Map
import qualified Data.IntMap.Strict  as IM
import qualified Data.Text           as T

optimizeProc :: Proc -> Proc
optimizeProc :: Proc -> Proc
optimizeProc = (Proc -> Proc) -> Proc -> Proc
fixpoint (Proc -> Proc
purgeUnreachable (Proc -> Proc) -> (Proc -> Proc) -> Proc -> Proc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proc -> Proc
mergeBlocks (Proc -> Proc) -> (Proc -> Proc) -> Proc -> Proc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proc -> Proc
inlineEpsilon)
      where fixpoint :: (Proc -> Proc) -> Proc -> Proc
            fixpoint :: (Proc -> Proc) -> Proc -> Proc
fixpoint Proc -> Proc
f Proc
pr = let pr' :: Proc
pr' = Proc -> Proc
f Proc
pr in if Proc -> Proc -> Bool
sameShape Proc
pr Proc
pr' then Proc
pr' else (Proc -> Proc) -> Proc -> Proc
fixpoint Proc -> Proc
f Proc
pr'

            sameShape :: Proc -> Proc -> Bool
            sameShape :: Proc -> Proc -> Bool
sameShape Proc
a Proc
b = ((Id, Block) -> Uniq) -> [(Id, Block)] -> [Uniq]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Uniq
idUniq (Id -> Uniq) -> ((Id, Block) -> Id) -> (Id, Block) -> Uniq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Block) -> Id
forall a b. (a, b) -> a
fst) (Proc -> [(Id, Block)]
procBlocks Proc
a) [Uniq] -> [Uniq] -> Bool
forall a. Eq a => a -> a -> Bool
== ((Id, Block) -> Uniq) -> [(Id, Block)] -> [Uniq]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Uniq
idUniq (Id -> Uniq) -> ((Id, Block) -> Id) -> (Id, Block) -> Uniq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Block) -> Id
forall a b. (a, b) -> a
fst) (Proc -> [(Id, Block)]
procBlocks Proc
b)

-- | The machine accounting (doc/synolon.md §7): states are the pause
--   targets plus the entry (reset) state; the tag is their count's bit
--   width. Printed as a verbose diagnostic by ReWire.ModCache.
machineSummary :: Proc -> Text
machineSummary :: Proc -> Text
machineSummary Proc
pr = Text
"proc " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Proc -> Text
procName Proc
pr
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": blocks=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Uniq -> Text
tshow ([(Id, Block)] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length ([(Id, Block)] -> Uniq) -> [(Id, Block)] -> Uniq
forall a b. (a -> b) -> a -> b
$ Proc -> [(Id, Block)]
procBlocks Proc
pr)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", states=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Uniq -> Text
tshow Uniq
nStates Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (+entry)"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", tag=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Uniq -> Text
tshow (Uniq -> Uniq
nbits (Uniq -> Uniq) -> Uniq -> Uniq
forall a b. (a -> b) -> a -> b
$ Uniq
nStates Uniq -> Uniq -> Uniq
forall a. Num a => a -> a -> a
+ Uniq
1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bits"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", cells=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Uniq -> Text
tshow ([Cell] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length ([Cell] -> Uniq) -> [Cell] -> Uniq
forall a b. (a -> b) -> a -> b
$ Proc -> [Cell]
procCells Proc
pr)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", merge-headroom=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Uniq -> Text
tshow Uniq
hBlocks Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Uniq -> Text
tshow Uniq
hStates
      where -- The blocks/states a coarsest-partition (bisimulation-style)
            -- merge would remove beyond the alpha-equal merge: iterated
            -- partition refinement with label occurrences keyed by their
            -- current class.
            hBlocks, hStates :: Int
            (Uniq
hBlocks, Uniq
hStates) = ( [(Id, Block)] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [(Id, Block)]
blocks Uniq -> Uniq -> Uniq
forall a. Num a => a -> a -> a
- IntMap () -> Uniq
forall a. IntMap a -> Uniq
IM.size (IntMap Uniq -> IntMap ()
classesOf IntMap Uniq
final)
                                 , Uniq
nStates Uniq -> Uniq -> Uniq
forall a. Num a => a -> a -> a
- [Uniq] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length ([Uniq] -> [Uniq]
nubClasses [ Uniq -> Uniq -> IntMap Uniq -> Uniq
forall a. a -> Uniq -> IntMap a -> a
IM.findWithDefault (-Uniq
1) Uniq
u IntMap Uniq
final | Block
b <- Proc -> Block
procEntry Proc
pr Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: ((Id, Block) -> Block) -> [(Id, Block)] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Block) -> Block
forall a b. (a, b) -> b
snd [(Id, Block)]
blocks, Uniq
u <- Term -> [Uniq]
pt (Block -> Term
blkTerm Block
b) ])
                                 )

            blocks :: [(Id, Block)]
            blocks :: [(Id, Block)]
blocks = Proc -> [(Id, Block)]
procBlocks Proc
pr

            final :: IM.IntMap Int
            final :: IntMap Uniq
final = IntMap Uniq -> IntMap Uniq
refineTo (IntMap Uniq -> IntMap Uniq) -> IntMap Uniq -> IntMap Uniq
forall a b. (a -> b) -> a -> b
$ (Uniq -> Uniq) -> IntMap Uniq
mkPart (Uniq -> Uniq -> Uniq
forall a b. a -> b -> a
const Uniq
0)

            refineTo :: IM.IntMap Int -> IM.IntMap Int
            refineTo :: IntMap Uniq -> IntMap Uniq
refineTo IntMap Uniq
p = let p' :: IntMap Uniq
p' = (Uniq -> Uniq) -> IntMap Uniq
mkPart (\ Uniq
u -> Uniq -> Uniq -> IntMap Uniq -> Uniq
forall a. a -> Uniq -> IntMap a -> a
IM.findWithDefault (-Uniq
1) Uniq
u IntMap Uniq
p)
                         in if IntMap Uniq
p' IntMap Uniq -> IntMap Uniq -> Bool
forall a. Eq a => a -> a -> Bool
== IntMap Uniq
p then IntMap Uniq
p else IntMap Uniq -> IntMap Uniq
refineTo IntMap Uniq
p'

            -- Partition the blocks by their canonical rendering with each
            -- label occurrence replaced by its class under the previous
            -- partition.
            mkPart :: (Uniq -> Uniq) -> IM.IntMap Int
            mkPart :: (Uniq -> Uniq) -> IntMap Uniq
mkPart Uniq -> Uniq
cls = [(Uniq, Uniq)] -> IntMap Uniq
forall a. [(Uniq, a)] -> IntMap a
IM.fromList
                  [ (Id -> Uniq
idUniq Id
l, Uniq
c)
                  | (Id
l, Block
b) <- [(Id, Block)]
blocks
                  , let c :: Uniq
c = Uniq -> Text -> HashMap Text Uniq -> Uniq
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.findWithDefault Uniq
0 ((Uniq -> Uniq) -> Block -> Text
blockKeyBy Uniq -> Uniq
cls Block
b) HashMap Text Uniq
keyIx ]
                  where keyIx :: Map.HashMap Text Int
                        keyIx :: HashMap Text Uniq
keyIx = [(Text, Uniq)] -> HashMap Text Uniq
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Uniq)] -> HashMap Text Uniq)
-> [(Text, Uniq)] -> HashMap Text Uniq
forall a b. (a -> b) -> a -> b
$ ([Text] -> [Uniq] -> [(Text, Uniq)])
-> [Uniq] -> [Text] -> [(Text, Uniq)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Text] -> [Uniq] -> [(Text, Uniq)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Uniq
0 ..] [ (Uniq -> Uniq) -> Block -> Text
blockKeyBy Uniq -> Uniq
cls Block
b | (Id
_, Block
b) <- [(Id, Block)]
blocks ]

            classesOf :: IM.IntMap Int -> IM.IntMap ()
            classesOf :: IntMap Uniq -> IntMap ()
classesOf IntMap Uniq
p = [(Uniq, ())] -> IntMap ()
forall a. [(Uniq, a)] -> IntMap a
IM.fromList [ (Uniq
c, ()) | Uniq
c <- IntMap Uniq -> [Uniq]
forall a. IntMap a -> [a]
IM.elems IntMap Uniq
p ]

            nubClasses :: [Int] -> [Int]
            nubClasses :: [Uniq] -> [Uniq]
nubClasses = IntMap () -> [Uniq]
forall a. IntMap a -> [Uniq]
IM.keys (IntMap () -> [Uniq]) -> ([Uniq] -> IntMap ()) -> [Uniq] -> [Uniq]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Uniq, ())] -> IntMap ()
forall a. [(Uniq, a)] -> IntMap a
IM.fromList ([(Uniq, ())] -> IntMap ())
-> ([Uniq] -> [(Uniq, ())]) -> [Uniq] -> IntMap ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uniq -> (Uniq, ())) -> [Uniq] -> [(Uniq, ())]
forall a b. (a -> b) -> [a] -> [b]
map (, ())

            nStates :: Int
            nStates :: Uniq
nStates = IntMap () -> Uniq
forall a. IntMap a -> Uniq
IM.size (IntMap () -> Uniq) -> IntMap () -> Uniq
forall a b. (a -> b) -> a -> b
$ [(Uniq, ())] -> IntMap ()
forall a. [(Uniq, a)] -> IntMap a
IM.fromList
                  [ (Uniq
u, ()) | Block
b <- Proc -> Block
procEntry Proc
pr Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: ((Id, Block) -> Block) -> [(Id, Block)] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Block) -> Block
forall a b. (a, b) -> b
snd (Proc -> [(Id, Block)]
procBlocks Proc
pr), Uniq
u <- Term -> [Uniq]
pt (Block -> Term
blkTerm Block
b) ]

            pt :: Term -> [Uniq]
            pt :: Term -> [Uniq]
pt = \ case
                  Pause Annote
_ Exp
_ Id
l [Exp]
_  -> [Id -> Uniq
idUniq Id
l]
                  TCase Annote
_ Exp
_ [TAlt]
alts -> [[Uniq]] -> [Uniq]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Term -> [Uniq]
pt Term
t | TAlt Annote
_ AltCon
_ [Id]
_ Term
t <- [TAlt]
alts ]
                  Term
_              -> []

            nbits :: Int -> Int
            nbits :: Uniq -> Uniq
nbits Uniq
n = [Uniq] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length ([Uniq] -> Uniq) -> [Uniq] -> Uniq
forall a b. (a -> b) -> a -> b
$ (Uniq -> Bool) -> [Uniq] -> [Uniq]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Uniq -> Uniq -> Bool
forall a. Ord a => a -> a -> Bool
< Uniq
n) ([Uniq] -> [Uniq]) -> [Uniq] -> [Uniq]
forall a b. (a -> b) -> a -> b
$ (Uniq -> Uniq) -> Uniq -> [Uniq]
forall a. (a -> a) -> a -> [a]
iterate (Uniq -> Uniq -> Uniq
forall a. Num a => a -> a -> a
* Uniq
2) Uniq
1

            tshow :: Int -> Text
            tshow :: Uniq -> Text
tshow = String -> Text
T.pack (String -> Text) -> (Uniq -> String) -> Uniq -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uniq -> String
forall a. Show a => a -> String
show

---
--- Epsilon-block inlining.
---

inlineEpsilon :: Proc -> Proc
inlineEpsilon :: Proc -> Proc
inlineEpsilon Proc
pr = Proc -> Proc
purgeUnreachable Proc
pr { procEntry  = retermB $ procEntry pr
                                       , procBlocks = [ (l, retermB b) | (l, b) <- procBlocks pr ]
                                       }
      where -- Blocks that pause-resume must survive (they are states).
            pauseTargets :: IM.IntMap ()
            pauseTargets :: IntMap ()
pauseTargets = [(Uniq, ())] -> IntMap ()
forall a. [(Uniq, a)] -> IntMap a
IM.fromList [ (Uniq
u, ()) | Block
b <- Proc -> Block
procEntry Proc
pr Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: ((Id, Block) -> Block) -> [(Id, Block)] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Block) -> Block
forall a b. (a, b) -> b
snd (Proc -> [(Id, Block)]
procBlocks Proc
pr), Uniq
u <- Term -> [Uniq]
pt (Block -> Term
blkTerm Block
b) ]
                  where pt :: Term -> [Uniq]
                        pt :: Term -> [Uniq]
pt = \ case
                              Pause Annote
_ Exp
_ Id
l [Exp]
_  -> [Id -> Uniq
idUniq Id
l]
                              TCase Annote
_ Exp
_ [TAlt]
alts -> [[Uniq]] -> [Uniq]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Term -> [Uniq]
pt Term
t | TAlt Annote
_ AltCon
_ [Id]
_ Term
t <- [TAlt]
alts ]
                              Term
_              -> []

            -- Command-free single-goto blocks, by label unique.
            eps :: IM.IntMap ([Id], Id, [Exp])
            eps :: IntMap ([Id], Id, [Exp])
eps = [(Uniq, ([Id], Id, [Exp]))] -> IntMap ([Id], Id, [Exp])
forall a. [(Uniq, a)] -> IntMap a
IM.fromList [ (Id -> Uniq
idUniq Id
l, (Block -> [Id]
blkParams Block
b, Id
l', [Exp]
as))
                              | (Id
l, Block
b) <- Proc -> [(Id, Block)]
procBlocks Proc
pr
                              , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Uniq -> IntMap () -> Bool
forall a. Uniq -> IntMap a -> Bool
IM.member (Id -> Uniq
idUniq Id
l) IntMap ()
pauseTargets
                              , [Cmd] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Cmd] -> Bool) -> [Cmd] -> Bool
forall a b. (a -> b) -> a -> b
$ Block -> [Cmd]
blkCmds Block
b
                              , Goto Annote
_ Id
l' [Exp]
as <- [Block -> Term
blkTerm Block
b]
                              , Id -> Uniq
idUniq Id
l' Uniq -> Uniq -> Bool
forall a. Eq a => a -> a -> Bool
/= Id -> Uniq
idUniq Id
l ]

            -- Follow (acyclic) epsilon chains from a goto site. Arguments
            -- can be compound (primitive expressions are transparent in
            -- ANF), so the substitution is a full expression substitution,
            -- not an atom swap — and a hop is taken only when the
            -- substituted arguments are still operands of the block normal
            -- form: a parameter can sit where only an atom may (a case
            -- scrutinee or the tail of a lambda body, a literal's
            -- element), and a primitive expression substituted there
            -- would break the form. A block whose hop is refused simply
            -- stays; one whose references were all redirected becomes
            -- unreachable and the purge removes it.
            -- Bounded by the block count: a mutual epsilon cycle (an
            -- unguarded pauseless loop, rejected by the machine lint
            -- downstream) must not hang here first.
            resolve :: Id -> [Exp] -> (Id, [Exp])
            resolve :: Id -> [Exp] -> (Id, [Exp])
resolve = Uniq -> Id -> [Exp] -> (Id, [Exp])
go ([(Id, Block)] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length ([(Id, Block)] -> Uniq) -> [(Id, Block)] -> Uniq
forall a b. (a -> b) -> a -> b
$ Proc -> [(Id, Block)]
procBlocks Proc
pr)
                  where go :: Int -> Id -> [Exp] -> (Id, [Exp])
                        go :: Uniq -> Id -> [Exp] -> (Id, [Exp])
go Uniq
fuel Id
l [Exp]
as
                              | Uniq
fuel Uniq -> Uniq -> Bool
forall a. Ord a => a -> a -> Bool
<= Uniq
0 = (Id
l, [Exp]
as)
                              | Bool
otherwise = case Uniq -> IntMap ([Id], Id, [Exp]) -> Maybe ([Id], Id, [Exp])
forall a. Uniq -> IntMap a -> Maybe a
IM.lookup (Id -> Uniq
idUniq Id
l) IntMap ([Id], Id, [Exp])
eps of
                                    Just ([Id]
ps, Id
l', [Exp]
as')
                                          | let sub :: IntMap Exp
sub  = [(Uniq, Exp)] -> IntMap Exp
forall a. [(Uniq, a)] -> IntMap a
IM.fromList ([(Uniq, Exp)] -> IntMap Exp) -> [(Uniq, Exp)] -> IntMap Exp
forall a b. (a -> b) -> a -> b
$ [Uniq] -> [Exp] -> [(Uniq, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Id -> Uniq) -> [Id] -> [Uniq]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Uniq
idUniq [Id]
ps) [Exp]
as
                                                as'' :: [Exp]
as'' = (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (IntMap Exp -> Exp -> Exp
substVars IntMap Exp
sub) [Exp]
as'
                                          , (Exp -> Bool) -> [Exp] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Exp -> Bool
isOperand [Exp]
as'' -> Uniq -> Id -> [Exp] -> (Id, [Exp])
go (Uniq
fuel Uniq -> Uniq -> Uniq
forall a. Num a => a -> a -> a
- Uniq
1) Id
l' [Exp]
as''
                                    Maybe ([Id], Id, [Exp])
_ -> (Id
l, [Exp]
as)

            retermB :: Block -> Block
            retermB :: Block -> Block
retermB Block
b = Block
b { blkTerm = reterm $ blkTerm b }

            reterm :: Term -> Term
            reterm :: Term -> Term
reterm = \ case
                  Goto Annote
an Id
l [Exp]
as    -> let (Id
l', [Exp]
as') = Id -> [Exp] -> (Id, [Exp])
resolve Id
l [Exp]
as in Annote -> Id -> [Exp] -> Term
Goto Annote
an Id
l' [Exp]
as'
                  TCase Annote
an Exp
a [TAlt]
alts -> Annote -> Exp -> [TAlt] -> Term
TCase Annote
an Exp
a [ Annote -> AltCon -> [Id] -> Term -> TAlt
TAlt Annote
aan AltCon
c [Id]
xs (Term -> Term
reterm Term
t) | TAlt Annote
aan AltCon
c [Id]
xs Term
t <- [TAlt]
alts ]
                  Term
t               -> Term
t

---
--- Unreachable-block purge.
---

purgeUnreachable :: Proc -> Proc
purgeUnreachable :: Proc -> Proc
purgeUnreachable Proc
pr = Proc
pr { procBlocks = [ (l, b) | (l, b) <- procBlocks pr, IM.member (idUniq l) reach ] }
      where ltab :: IM.IntMap Block
            ltab :: IntMap Block
ltab = [(Uniq, Block)] -> IntMap Block
forall a. [(Uniq, a)] -> IntMap a
IM.fromList [ (Id -> Uniq
idUniq Id
l, Block
b) | (Id
l, Block
b) <- Proc -> [(Id, Block)]
procBlocks Proc
pr ]

            reach :: IM.IntMap ()
            reach :: IntMap ()
reach = IntMap () -> [Uniq] -> IntMap ()
go IntMap ()
forall a. Monoid a => a
mempty ([Uniq] -> IntMap ()) -> [Uniq] -> IntMap ()
forall a b. (a -> b) -> a -> b
$ Block -> [Uniq]
succs (Block -> [Uniq]) -> Block -> [Uniq]
forall a b. (a -> b) -> a -> b
$ Proc -> Block
procEntry Proc
pr

            go :: IM.IntMap () -> [Uniq] -> IM.IntMap ()
            go :: IntMap () -> [Uniq] -> IntMap ()
go IntMap ()
seen = \ case
                  []     -> IntMap ()
seen
                  Uniq
u : [Uniq]
us | Uniq -> IntMap () -> Bool
forall a. Uniq -> IntMap a -> Bool
IM.member Uniq
u IntMap ()
seen -> IntMap () -> [Uniq] -> IntMap ()
go IntMap ()
seen [Uniq]
us
                         | Bool
otherwise        -> IntMap () -> [Uniq] -> IntMap ()
go (Uniq -> () -> IntMap () -> IntMap ()
forall a. Uniq -> a -> IntMap a -> IntMap a
IM.insert Uniq
u () IntMap ()
seen)
                                             ([Uniq] -> IntMap ()) -> [Uniq] -> IntMap ()
forall a b. (a -> b) -> a -> b
$ [Uniq] -> (Block -> [Uniq]) -> Maybe Block -> [Uniq]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Uniq]
us (([Uniq] -> [Uniq] -> [Uniq]
forall a. Semigroup a => a -> a -> a
<> [Uniq]
us) ([Uniq] -> [Uniq]) -> (Block -> [Uniq]) -> Block -> [Uniq]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Uniq]
succs) (Maybe Block -> [Uniq]) -> Maybe Block -> [Uniq]
forall a b. (a -> b) -> a -> b
$ Uniq -> IntMap Block -> Maybe Block
forall a. Uniq -> IntMap a -> Maybe a
IM.lookup Uniq
u IntMap Block
ltab

            succs :: Block -> [Uniq]
            succs :: Block -> [Uniq]
succs = Term -> [Uniq]
ts (Term -> [Uniq]) -> (Block -> Term) -> Block -> [Uniq]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Term
blkTerm
                  where ts :: Term -> [Uniq]
                        ts :: Term -> [Uniq]
ts = \ case
                              Pause Annote
_ Exp
_ Id
l [Exp]
_  -> [Id -> Uniq
idUniq Id
l]
                              Goto Annote
_ Id
l [Exp]
_     -> [Id -> Uniq
idUniq Id
l]
                              TCase Annote
_ Exp
_ [TAlt]
alts -> [[Uniq]] -> [Uniq]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Term -> [Uniq]
ts Term
t | TAlt Annote
_ AltCon
_ [Id]
_ Term
t <- [TAlt]
alts ]
                              Halt Annote
_ Exp
_       -> []

---
--- Alpha-equal block merge.
---

mergeBlocks :: Proc -> Proc
mergeBlocks :: Proc -> Proc
mergeBlocks Proc
pr = case [(Uniq, Id)]
dups of
      [] -> Proc
pr
      [(Uniq, Id)]
_  -> Proc
pr { procEntry  = redirB $ procEntry pr
               , procBlocks = [ (l, redirB b) | (l, b) <- procBlocks pr, not $ IM.member (idUniq l) redirect ]
               }
      where keyed :: [(Text, Id)]
            keyed :: [(Text, Id)]
keyed = [ (Block -> Text
blockKey Block
b, Id
l) | (Id
l, Block
b) <- Proc -> [(Id, Block)]
procBlocks Proc
pr ]

            -- For each key, the first label survives; the rest redirect.
            redirect :: IM.IntMap Id
            redirect :: IntMap Id
redirect = [(Uniq, Id)] -> IntMap Id
forall a. [(Uniq, a)] -> IntMap a
IM.fromList [(Uniq, Id)]
dups

            dups :: [(Uniq, Id)]
            dups :: [(Uniq, Id)]
dups = [ (Id -> Uniq
idUniq Id
l, Id
survivor)
                   | (Text
_, Id
survivor : [Id]
rest) <- HashMap Text [Id] -> [(Text, [Id])]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap Text [Id]
grouped, Id
l <- [Id]
rest ]

            grouped :: Map.HashMap Text [Id]
            grouped :: HashMap Text [Id]
grouped = ([Id] -> [Id] -> [Id]) -> [(Text, [Id])] -> HashMap Text [Id]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith (([Id] -> [Id] -> [Id]) -> [Id] -> [Id] -> [Id]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Id] -> [Id] -> [Id]
forall a. Semigroup a => a -> a -> a
(<>)) [ (Text
k, [Id
l]) | (Text
k, Id
l) <- [(Text, Id)]
keyed ]

            redirB :: Block -> Block
            redirB :: Block -> Block
redirB Block
b = Block
b { blkTerm = go $ blkTerm b }
                  where go :: Term -> Term
                        go :: Term -> Term
go = \ case
                              Pause Annote
an Exp
a Id
l [Exp]
as -> Annote -> Exp -> Id -> [Exp] -> Term
Pause Annote
an Exp
a (Id -> Id
re Id
l) [Exp]
as
                              Goto Annote
an Id
l [Exp]
as    -> Annote -> Id -> [Exp] -> Term
Goto Annote
an (Id -> Id
re Id
l) [Exp]
as
                              TCase Annote
an Exp
a [TAlt]
alts -> Annote -> Exp -> [TAlt] -> Term
TCase Annote
an Exp
a [ Annote -> AltCon -> [Id] -> Term -> TAlt
TAlt Annote
aan AltCon
c [Id]
xs (Term -> Term
go Term
t) | TAlt Annote
aan AltCon
c [Id]
xs Term
t <- [TAlt]
alts ]
                              Term
t               -> Term
t

                        re :: Id -> Id
                        re :: Id -> Id
re Id
l = Id -> Maybe Id -> Id
forall a. a -> Maybe a -> a
fromMaybe Id
l (Maybe Id -> Id) -> Maybe Id -> Id
forall a b. (a -> b) -> a -> b
$ Uniq -> IntMap Id -> Maybe Id
forall a. Uniq -> IntMap a -> Maybe a
IM.lookup (Id -> Uniq
idUniq Id
l) IntMap Id
redirect

-- | A canonical rendering of a block: binder uniques renumbered densely
--   from a disjoint range in traversal order; labels and cell names
--   compared by identity (label agreement is what the merge fixpoint
--   converges on).
blockKey :: Block -> Text
blockKey :: Block -> Text
blockKey = (Uniq -> Uniq) -> Block -> Text
blockKeyBy Uniq -> Uniq
forall a. a -> a
id

-- | As 'blockKey', but with label occurrences mapped through the given
--   function first (used by the partition-refinement diagnostic, which
--   keys labels by their current equivalence class).
blockKeyBy :: (Uniq -> Uniq) -> Block -> Text
blockKeyBy :: (Uniq -> Uniq) -> Block -> Text
blockKeyBy Uniq -> Uniq
relab Block
b0 = Block -> Text
forall a. Pretty a => a -> Text
prettyPrint Block
canon
      where canon :: Block
            canon :: Block
canon = State (Uniq, IntMap Uniq) Block -> (Uniq, IntMap Uniq) -> Block
forall s a. State s a -> s -> a
evalState (Block -> State (Uniq, IntMap Uniq) Block
renB Block
b0) (-Uniq
2000000000, IntMap Uniq
forall a. Monoid a => a
mempty)

            renB :: Block -> State (Uniq, IM.IntMap Uniq) Block
            renB :: Block -> State (Uniq, IntMap Uniq) Block
renB (Block Annote
an [Id]
ps [Cmd]
cmds Term
term) = do
                  ps'   <- (Id -> StateT (Uniq, IntMap Uniq) Identity Id)
-> [Id] -> StateT (Uniq, IntMap Uniq) Identity [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> StateT (Uniq, IntMap Uniq) Identity Id
bind' [Id]
ps
                  cmds' <- mapM renC cmds
                  term' <- renT term
                  pure $ Block an ps' cmds' term'

            bind' :: Id -> State (Uniq, IM.IntMap Uniq) Id
            bind' :: Id -> StateT (Uniq, IntMap Uniq) Identity Id
bind' Id
x = do
                  (n, m) <- StateT (Uniq, IntMap Uniq) Identity (Uniq, IntMap Uniq)
forall s (m :: * -> *). MonadState s m => m s
get
                  put (n + 1, IM.insert (idUniq x) n m)
                  pure x { idUniq = n }

            occ' :: Id -> State (Uniq, IM.IntMap Uniq) Id
            occ' :: Id -> StateT (Uniq, IntMap Uniq) Identity Id
occ' Id
x = do
                  (_, m) <- StateT (Uniq, IntMap Uniq) Identity (Uniq, IntMap Uniq)
forall s (m :: * -> *). MonadState s m => m s
get
                  pure $ maybe x (\ Uniq
n -> Id
x { idUniq = n }) $ IM.lookup (idUniq x) m

            renC :: Cmd -> State (Uniq, IM.IntMap Uniq) Cmd
            renC :: Cmd -> StateT (Uniq, IntMap Uniq) Identity Cmd
renC = \ case
                  CmdBind Annote
an Id
x Exp
e -> do
                        e' <- Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
e
                        x' <- bind' x
                        pure $ CmdBind an x' e'
                  CmdGet Annote
an Id
x Text
s  -> do
                        x' <- Id -> StateT (Uniq, IntMap Uniq) Identity Id
bind' Id
x
                        pure $ CmdGet an x' s
                  CmdPut Annote
an Text
s Exp
e  -> Annote -> Text -> Exp -> Cmd
CmdPut Annote
an Text
s (Exp -> Cmd)
-> State (Uniq, IntMap Uniq) Exp
-> StateT (Uniq, IntMap Uniq) Identity Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
e

            renT :: Term -> State (Uniq, IM.IntMap Uniq) Term
            renT :: Term -> State (Uniq, IntMap Uniq) Term
renT = \ case
                  Pause Annote
an Exp
a Id
l [Exp]
as -> Annote -> Exp -> Id -> [Exp] -> Term
Pause Annote
an (Exp -> Id -> [Exp] -> Term)
-> State (Uniq, IntMap Uniq) Exp
-> StateT (Uniq, IntMap Uniq) Identity (Id -> [Exp] -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
a StateT (Uniq, IntMap Uniq) Identity (Id -> [Exp] -> Term)
-> StateT (Uniq, IntMap Uniq) Identity Id
-> StateT (Uniq, IntMap Uniq) Identity ([Exp] -> Term)
forall a b.
StateT (Uniq, IntMap Uniq) Identity (a -> b)
-> StateT (Uniq, IntMap Uniq) Identity a
-> StateT (Uniq, IntMap Uniq) Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Id -> StateT (Uniq, IntMap Uniq) Identity Id
forall a. a -> StateT (Uniq, IntMap Uniq) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> Id
renL Id
l) StateT (Uniq, IntMap Uniq) Identity ([Exp] -> Term)
-> StateT (Uniq, IntMap Uniq) Identity [Exp]
-> State (Uniq, IntMap Uniq) Term
forall a b.
StateT (Uniq, IntMap Uniq) Identity (a -> b)
-> StateT (Uniq, IntMap Uniq) Identity a
-> StateT (Uniq, IntMap Uniq) Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Exp -> State (Uniq, IntMap Uniq) Exp)
-> [Exp] -> StateT (Uniq, IntMap Uniq) Identity [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Exp -> State (Uniq, IntMap Uniq) Exp
renE [Exp]
as
                  Goto Annote
an Id
l [Exp]
as    -> Annote -> Id -> [Exp] -> Term
Goto Annote
an (Id -> Id
renL Id
l) ([Exp] -> Term)
-> StateT (Uniq, IntMap Uniq) Identity [Exp]
-> State (Uniq, IntMap Uniq) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> State (Uniq, IntMap Uniq) Exp)
-> [Exp] -> StateT (Uniq, IntMap Uniq) Identity [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Exp -> State (Uniq, IntMap Uniq) Exp
renE [Exp]
as
                  Halt Annote
an Exp
a       -> Annote -> Exp -> Term
Halt Annote
an (Exp -> Term)
-> State (Uniq, IntMap Uniq) Exp -> State (Uniq, IntMap Uniq) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
a
                  TCase Annote
an Exp
a [TAlt]
alts -> Annote -> Exp -> [TAlt] -> Term
TCase Annote
an (Exp -> [TAlt] -> Term)
-> State (Uniq, IntMap Uniq) Exp
-> StateT (Uniq, IntMap Uniq) Identity ([TAlt] -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
a StateT (Uniq, IntMap Uniq) Identity ([TAlt] -> Term)
-> StateT (Uniq, IntMap Uniq) Identity [TAlt]
-> State (Uniq, IntMap Uniq) Term
forall a b.
StateT (Uniq, IntMap Uniq) Identity (a -> b)
-> StateT (Uniq, IntMap Uniq) Identity a
-> StateT (Uniq, IntMap Uniq) Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TAlt -> StateT (Uniq, IntMap Uniq) Identity TAlt)
-> [TAlt] -> StateT (Uniq, IntMap Uniq) Identity [TAlt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TAlt -> StateT (Uniq, IntMap Uniq) Identity TAlt
renA [TAlt]
alts

            renL :: Id -> Id
            renL :: Id -> Id
renL Id
l = Id
l { idUniq = relab $ idUniq l }

            renA :: TAlt -> State (Uniq, IM.IntMap Uniq) TAlt
            renA :: TAlt -> StateT (Uniq, IntMap Uniq) Identity TAlt
renA (TAlt Annote
an AltCon
c [Id]
xs Term
t) = do
                  xs' <- (Id -> StateT (Uniq, IntMap Uniq) Identity Id)
-> [Id] -> StateT (Uniq, IntMap Uniq) Identity [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> StateT (Uniq, IntMap Uniq) Identity Id
bind' [Id]
xs
                  TAlt an c xs' <$> renT t

            renE :: Exp -> State (Uniq, IM.IntMap Uniq) Exp
            renE :: Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
e = case Exp
e of
                  Var Annote
an Id
x        -> Annote -> Id -> Exp
Var Annote
an (Id -> Exp)
-> StateT (Uniq, IntMap Uniq) Identity Id
-> State (Uniq, IntMap Uniq) Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT (Uniq, IntMap Uniq) Identity Id
occ' Id
x
                  App Annote
an Exp
f Arg
a      -> Annote -> Exp -> Arg -> Exp
App Annote
an (Exp -> Arg -> Exp)
-> State (Uniq, IntMap Uniq) Exp
-> StateT (Uniq, IntMap Uniq) Identity (Arg -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
f StateT (Uniq, IntMap Uniq) Identity (Arg -> Exp)
-> StateT (Uniq, IntMap Uniq) Identity Arg
-> State (Uniq, IntMap Uniq) Exp
forall a b.
StateT (Uniq, IntMap Uniq) Identity (a -> b)
-> StateT (Uniq, IntMap Uniq) Identity a
-> StateT (Uniq, IntMap Uniq) Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg -> StateT (Uniq, IntMap Uniq) Identity Arg
renArg Arg
a
                  Lam Annote
an Id
x Exp
b      -> do
                        b' <- Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
b -- (binders inside expressions are rare in ANF cmds)
                        x' <- bind' x
                        pure $ Lam an x' b'
                  Let Annote
an Bind
bnd Exp
body -> do
                        bnd'  <- Bind -> State (Uniq, IntMap Uniq) Bind
renBnd Bind
bnd
                        body' <- renE body
                        pure $ Let an bnd' body'
                  Jump Annote
an JoinId
j [Exp]
es    -> Annote -> JoinId -> [Exp] -> Exp
Jump Annote
an JoinId
j ([Exp] -> Exp)
-> StateT (Uniq, IntMap Uniq) Identity [Exp]
-> State (Uniq, IntMap Uniq) Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> State (Uniq, IntMap Uniq) Exp)
-> [Exp] -> StateT (Uniq, IntMap Uniq) Identity [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Exp -> State (Uniq, IntMap Uniq) Exp
renE [Exp]
es
                  Case Annote
an Ty
t Exp
s Id
cb [Alt]
alts -> do
                        s'    <- Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
s
                        cb'   <- bind' cb
                        alts' <- mapM (\ (Alt Annote
aan AltCon
c [Id]
xs Exp
bb) -> do
                              xs' <- (Id -> StateT (Uniq, IntMap Uniq) Identity Id)
-> [Id] -> StateT (Uniq, IntMap Uniq) Identity [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> StateT (Uniq, IntMap Uniq) Identity Id
bind' [Id]
xs
                              Alt aan c xs' <$> renE bb) alts
                        pure $ Case an t s' cb' alts'
                  LitList Annote
an Ty
t [Exp]
es -> Annote -> Ty -> [Exp] -> Exp
LitList Annote
an Ty
t ([Exp] -> Exp)
-> StateT (Uniq, IntMap Uniq) Identity [Exp]
-> State (Uniq, IntMap Uniq) Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> State (Uniq, IntMap Uniq) Exp)
-> [Exp] -> StateT (Uniq, IntMap Uniq) Identity [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Exp -> State (Uniq, IntMap Uniq) Exp
renE [Exp]
es
                  LitVec Annote
an Ty
t [Exp]
es  -> Annote -> Ty -> [Exp] -> Exp
LitVec Annote
an Ty
t ([Exp] -> Exp)
-> StateT (Uniq, IntMap Uniq) Identity [Exp]
-> State (Uniq, IntMap Uniq) Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> State (Uniq, IntMap Uniq) Exp)
-> [Exp] -> StateT (Uniq, IntMap Uniq) Identity [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Exp -> State (Uniq, IntMap Uniq) Exp
renE [Exp]
es
                  Exp
_               -> Exp -> State (Uniq, IntMap Uniq) Exp
forall a. a -> StateT (Uniq, IntMap Uniq) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e

            renArg :: Arg -> State (Uniq, IM.IntMap Uniq) Arg
            renArg :: Arg -> StateT (Uniq, IntMap Uniq) Identity Arg
renArg = \ case
                  EArg Exp
e -> Exp -> Arg
EArg (Exp -> Arg)
-> State (Uniq, IntMap Uniq) Exp
-> StateT (Uniq, IntMap Uniq) Identity Arg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
e
                  Arg
t      -> Arg -> StateT (Uniq, IntMap Uniq) Identity Arg
forall a. a -> StateT (Uniq, IntMap Uniq) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Arg
t

            renBnd :: Bind -> State (Uniq, IM.IntMap Uniq) Bind
            renBnd :: Bind -> State (Uniq, IntMap Uniq) Bind
renBnd = \ case
                  NonRec Id
x Exp
rhs -> do
                        rhs' <- Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
rhs
                        x'   <- bind' x
                        pure $ NonRec x' rhs'
                  Rec [(Id, Exp)]
bs       -> [(Id, Exp)] -> Bind
Rec ([(Id, Exp)] -> Bind)
-> StateT (Uniq, IntMap Uniq) Identity [(Id, Exp)]
-> State (Uniq, IntMap Uniq) Bind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Id, Exp) -> StateT (Uniq, IntMap Uniq) Identity (Id, Exp))
-> [(Id, Exp)] -> StateT (Uniq, IntMap Uniq) Identity [(Id, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ (Id
x, Exp
rhs) -> (,) (Id -> Exp -> (Id, Exp))
-> StateT (Uniq, IntMap Uniq) Identity Id
-> StateT (Uniq, IntMap Uniq) Identity (Exp -> (Id, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT (Uniq, IntMap Uniq) Identity Id
bind' Id
x StateT (Uniq, IntMap Uniq) Identity (Exp -> (Id, Exp))
-> State (Uniq, IntMap Uniq) Exp
-> StateT (Uniq, IntMap Uniq) Identity (Id, Exp)
forall a b.
StateT (Uniq, IntMap Uniq) Identity (a -> b)
-> StateT (Uniq, IntMap Uniq) Identity a
-> StateT (Uniq, IntMap Uniq) Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> State (Uniq, IntMap Uniq) Exp
renE Exp
rhs) [(Id, Exp)]
bs
                  Join JoinId
j [Id]
ps Exp
bb -> do
                        ps' <- (Id -> StateT (Uniq, IntMap Uniq) Identity Id)
-> [Id] -> StateT (Uniq, IntMap Uniq) Identity [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> StateT (Uniq, IntMap Uniq) Identity Id
bind' [Id]
ps
                        Join j ps' <$> renE bb