module Kempe.Asm.X86.ControlFlow ( mkControlFlow
                                 , ControlAnn (..)
                                 ) where

-- seems to pretty clearly be faster
import           Control.Monad.State.Strict (State, evalState, gets, modify)
import           Data.Bifunctor             (first, second)
import           Data.Functor               (($>))
import qualified Data.Map                   as M
import qualified Data.Set                   as S
import           Kempe.Asm.X86.Type

-- map of labels by node
type FreshM = State (Int, M.Map Label Int) -- TODO: map int to asm

runFreshM :: FreshM a -> a
runFreshM :: FreshM a -> a
runFreshM = (FreshM a -> (Int, Map Label Int) -> a)
-> (Int, Map Label Int) -> FreshM a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip FreshM a -> (Int, Map Label Int) -> a
forall s a. State s a -> s -> a
evalState (Int
0, Map Label Int
forall a. Monoid a => a
mempty)

mkControlFlow :: [X86 AbsReg ()] -> [X86 AbsReg ControlAnn]
mkControlFlow :: [X86 AbsReg ()] -> [X86 AbsReg ControlAnn]
mkControlFlow [X86 AbsReg ()]
instrs = FreshM [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. FreshM a -> a
runFreshM ([X86 AbsReg ()] -> FreshM [X86 AbsReg ()]
forall reg. [X86 reg ()] -> FreshM [X86 reg ()]
broadcasts [X86 AbsReg ()]
instrs FreshM [X86 AbsReg ()]
-> FreshM [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [X86 AbsReg ()] -> FreshM [X86 AbsReg ControlAnn]
addControlFlow [X86 AbsReg ()]
instrs)

getFresh :: FreshM Int
getFresh :: FreshM Int
getFresh = ((Int, Map Label Int) -> Int) -> FreshM Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Int, Map Label Int) -> Int
forall a b. (a, b) -> a
fst FreshM Int -> StateT (Int, Map Label Int) Identity () -> FreshM Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ((Int, Map Label Int) -> (Int, Map Label Int))
-> StateT (Int, Map Label Int) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Int -> Int) -> (Int, Map Label Int) -> (Int, Map Label Int)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))

lookupLabel :: Label -> FreshM Int
lookupLabel :: Label -> FreshM Int
lookupLabel Label
l = ((Int, Map Label Int) -> Int) -> FreshM Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Int -> Label -> Map Label Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error in control-flow graph: node label not in map.") Label
l (Map Label Int -> Int)
-> ((Int, Map Label Int) -> Map Label Int)
-> (Int, Map Label Int)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Map Label Int) -> Map Label Int
forall a b. (a, b) -> b
snd)

broadcast :: Int -> Label -> FreshM ()
broadcast :: Int -> Label -> StateT (Int, Map Label Int) Identity ()
broadcast Int
i Label
l = ((Int, Map Label Int) -> (Int, Map Label Int))
-> StateT (Int, Map Label Int) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map Label Int -> Map Label Int)
-> (Int, Map Label Int) -> (Int, Map Label Int)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Label -> Int -> Map Label Int -> Map Label Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Label
l Int
i))

addrRegs :: Ord reg => Addr reg -> S.Set reg
addrRegs :: Addr reg -> Set reg
addrRegs (Reg reg
r)              = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
addrRegs (AddrRRPlus reg
r reg
r')    = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg
r, reg
r']
addrRegs (AddrRCPlus reg
r Int64
_)     = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
addrRegs (AddrRCMinus reg
r Int64
_)    = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
addrRegs (AddrRRScale reg
r reg
r' Int64
_) = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg
r, reg
r']

-- | Annotate instructions with a unique node name and a list of all possible
-- destinations.
addControlFlow :: [X86 AbsReg ()] -> FreshM [X86 AbsReg ControlAnn]
addControlFlow :: [X86 AbsReg ()] -> FreshM [X86 AbsReg ControlAnn]
addControlFlow [] = [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
addControlFlow ((Label ()
_ Label
l):[X86 AbsReg ()]
asms) = do
    { Int
i <- Label -> FreshM Int
lookupLabel Label
l
    ; ([Int] -> [Int]
f, [X86 AbsReg ControlAnn]
asms') <- [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
next [X86 AbsReg ()]
asms
    ; [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ControlAnn -> Label -> X86 AbsReg ControlAnn
forall reg a. a -> Label -> X86 reg a
Label (Int -> [Int] -> Set AbsReg -> Set AbsReg -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f []) Set AbsReg
forall a. Set a
S.empty Set AbsReg
forall a. Set a
S.empty) Label
l X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
asms')
    }
addControlFlow ((Je ()
_ Label
l):[X86 AbsReg ()]
asms) = do
    { Int
i <- FreshM Int
getFresh
    ; ([Int] -> [Int]
f, [X86 AbsReg ControlAnn]
asms') <- [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
next [X86 AbsReg ()]
asms
    ; Int
l_i <- Label -> FreshM Int
lookupLabel Label
l -- TODO: is this what's wanted?
    ; [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ControlAnn -> Label -> X86 AbsReg ControlAnn
forall reg a. a -> Label -> X86 reg a
Je (Int -> [Int] -> Set AbsReg -> Set AbsReg -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) Set AbsReg
forall a. Set a
S.empty Set AbsReg
forall a. Set a
S.empty) Label
l X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
asms')
    }
addControlFlow ((Jl ()
_ Label
l):[X86 AbsReg ()]
asms) = do
    { Int
i <- FreshM Int
getFresh
    ; ([Int] -> [Int]
f, [X86 AbsReg ControlAnn]
asms') <- [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
next [X86 AbsReg ()]
asms
    ; Int
l_i <- Label -> FreshM Int
lookupLabel Label
l
    ; [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ControlAnn -> Label -> X86 AbsReg ControlAnn
forall reg a. a -> Label -> X86 reg a
Jl (Int -> [Int] -> Set AbsReg -> Set AbsReg -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) Set AbsReg
forall a. Set a
S.empty Set AbsReg
forall a. Set a
S.empty) Label
l X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
asms')
    }
addControlFlow ((Jle ()
_ Label
l):[X86 AbsReg ()]
asms) = do
    { Int
i <- FreshM Int
getFresh
    ; ([Int] -> [Int]
f, [X86 AbsReg ControlAnn]
asms') <- [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
next [X86 AbsReg ()]
asms
    ; Int
l_i <- Label -> FreshM Int
lookupLabel Label
l
    ; [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ControlAnn -> Label -> X86 AbsReg ControlAnn
forall reg a. a -> Label -> X86 reg a
Jle (Int -> [Int] -> Set AbsReg -> Set AbsReg -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) Set AbsReg
forall a. Set a
S.empty Set AbsReg
forall a. Set a
S.empty) Label
l X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
asms')
    }
addControlFlow ((Jne ()
_ Label
l):[X86 AbsReg ()]
asms) = do
    { Int
i <- FreshM Int
getFresh
    ; ([Int] -> [Int]
f, [X86 AbsReg ControlAnn]
asms') <- [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
next [X86 AbsReg ()]
asms
    ; Int
l_i <- Label -> FreshM Int
lookupLabel Label
l
    ; [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ControlAnn -> Label -> X86 AbsReg ControlAnn
forall reg a. a -> Label -> X86 reg a
Jne (Int -> [Int] -> Set AbsReg -> Set AbsReg -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) Set AbsReg
forall a. Set a
S.empty Set AbsReg
forall a. Set a
S.empty) Label
l X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
asms')
    }
addControlFlow ((Jge ()
_ Label
l):[X86 AbsReg ()]
asms) = do
    { Int
i <- FreshM Int
getFresh
    ; ([Int] -> [Int]
f, [X86 AbsReg ControlAnn]
asms') <- [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
next [X86 AbsReg ()]
asms
    ; Int
l_i <- Label -> FreshM Int
lookupLabel Label
l
    ; [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ControlAnn -> Label -> X86 AbsReg ControlAnn
forall reg a. a -> Label -> X86 reg a
Jge (Int -> [Int] -> Set AbsReg -> Set AbsReg -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) Set AbsReg
forall a. Set a
S.empty Set AbsReg
forall a. Set a
S.empty) Label
l X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
asms')
    }
addControlFlow ((Jg ()
_ Label
l):[X86 AbsReg ()]
asms) = do
    { Int
i <- FreshM Int
getFresh
    ; ([Int] -> [Int]
f, [X86 AbsReg ControlAnn]
asms') <- [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
next [X86 AbsReg ()]
asms
    ; Int
l_i <- Label -> FreshM Int
lookupLabel Label
l
    ; [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ControlAnn -> Label -> X86 AbsReg ControlAnn
forall reg a. a -> Label -> X86 reg a
Jg (Int -> [Int] -> Set AbsReg -> Set AbsReg -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) Set AbsReg
forall a. Set a
S.empty Set AbsReg
forall a. Set a
S.empty) Label
l X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
asms')
    }
addControlFlow ((Jump ()
_ Label
l):[X86 AbsReg ()]
asms) = do
    { Int
i <- FreshM Int
getFresh
    ; [X86 AbsReg ControlAnn]
nextAsms <- [X86 AbsReg ()] -> FreshM [X86 AbsReg ControlAnn]
addControlFlow [X86 AbsReg ()]
asms
    ; Int
l_i <- Label -> FreshM Int
lookupLabel Label
l
    ; [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ControlAnn -> Label -> X86 AbsReg ControlAnn
forall reg a. a -> Label -> X86 reg a
Jump (Int -> [Int] -> Set AbsReg -> Set AbsReg -> ControlAnn
ControlAnn Int
i [Int
l_i] Set AbsReg
forall a. Set a
S.empty Set AbsReg
forall a. Set a
S.empty) Label
l X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
nextAsms)
    }
addControlFlow ((Call ()
_ Label
l):[X86 AbsReg ()]
asms) = do
    { Int
i <- FreshM Int
getFresh
    ; [X86 AbsReg ControlAnn]
nextAsms <- [X86 AbsReg ()] -> FreshM [X86 AbsReg ControlAnn]
addControlFlow [X86 AbsReg ()]
asms
    ; Int
l_i <- Label -> FreshM Int
lookupLabel Label
l
    ; [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ControlAnn -> Label -> X86 AbsReg ControlAnn
forall reg a. a -> Label -> X86 reg a
Call (Int -> [Int] -> Set AbsReg -> Set AbsReg -> ControlAnn
ControlAnn Int
i [Int
l_i] Set AbsReg
forall a. Set a
S.empty Set AbsReg
forall a. Set a
S.empty) Label
l X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
nextAsms)
    }
addControlFlow (Ret{}:[X86 AbsReg ()]
asms) = do
    { Int
i <- FreshM Int
getFresh
    ; [X86 AbsReg ControlAnn]
nextAsms <- [X86 AbsReg ()] -> FreshM [X86 AbsReg ControlAnn]
addControlFlow [X86 AbsReg ()]
asms
    ; [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ControlAnn -> X86 AbsReg ControlAnn
forall reg a. a -> X86 reg a
Ret (Int -> [Int] -> Set AbsReg -> Set AbsReg -> ControlAnn
ControlAnn Int
i [] Set AbsReg
forall a. Set a
S.empty Set AbsReg
forall a. Set a
S.empty) X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
nextAsms)
    }
addControlFlow (X86 AbsReg ()
asm:[X86 AbsReg ()]
asms) = do
    { Int
i <- FreshM Int
getFresh
    ; ([Int] -> [Int]
f, [X86 AbsReg ControlAnn]
asms') <- [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
next [X86 AbsReg ()]
asms
    ; [X86 AbsReg ControlAnn] -> FreshM [X86 AbsReg ControlAnn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((X86 AbsReg ()
asm X86 AbsReg () -> ControlAnn -> X86 AbsReg ControlAnn
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int -> [Int] -> Set AbsReg -> Set AbsReg -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f []) (X86 AbsReg () -> Set AbsReg
forall reg ann. Ord reg => X86 reg ann -> Set reg
uses X86 AbsReg ()
asm) (X86 AbsReg () -> Set AbsReg
forall reg ann. X86 reg ann -> Set reg
defs X86 AbsReg ()
asm)) X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
asms')
    }

uses :: Ord reg => X86 reg ann -> S.Set reg
uses :: X86 reg ann -> Set reg
uses (PushReg ann
_ reg
r)       = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
uses (PushMem ann
_ Addr reg
a)       = Addr reg -> Set reg
forall reg. Ord reg => Addr reg -> Set reg
addrRegs Addr reg
a
uses (PopMem ann
_ Addr reg
a)        = Addr reg -> Set reg
forall reg. Ord reg => Addr reg -> Set reg
addrRegs Addr reg
a
uses (MovRA ann
_ reg
_ Addr reg
a)       = Addr reg -> Set reg
forall reg. Ord reg => Addr reg -> Set reg
addrRegs Addr reg
a
uses (MovAR ann
_ Addr reg
a reg
r)       = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r Set reg -> Set reg -> Set reg
forall a. Semigroup a => a -> a -> a
<> Addr reg -> Set reg
forall reg. Ord reg => Addr reg -> Set reg
addrRegs Addr reg
a
uses (MovRR ann
_ reg
_ reg
r)       = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
uses (AddRR ann
_ reg
r reg
r')      = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg
r, reg
r']
uses (SubRR ann
_ reg
r reg
r')      = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg
r, reg
r']
uses (ImulRR ann
_ reg
r reg
r')     = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg
r, reg
r']
uses (AddRC ann
_ reg
r Int64
_)       = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
uses (SubRC ann
_ reg
r Int64
_)       = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
uses (AddAC ann
_ Addr reg
a Int64
_)       = Addr reg -> Set reg
forall reg. Ord reg => Addr reg -> Set reg
addrRegs Addr reg
a
uses (MovABool ann
_ Addr reg
a Word8
_)    = Addr reg -> Set reg
forall reg. Ord reg => Addr reg -> Set reg
addrRegs Addr reg
a
uses (MovAC  ann
_ Addr reg
a Int64
_)      = Addr reg -> Set reg
forall reg. Ord reg => Addr reg -> Set reg
addrRegs Addr reg
a
uses (MovACi8 ann
_ Addr reg
a Int8
_)     = Addr reg -> Set reg
forall reg. Ord reg => Addr reg -> Set reg
addrRegs Addr reg
a
uses (XorRR ann
_ reg
r reg
r')      = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg
r, reg
r']
uses (CmpAddrReg ann
_ Addr reg
a reg
r)  = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r Set reg -> Set reg -> Set reg
forall a. Semigroup a => a -> a -> a
<> Addr reg -> Set reg
forall reg. Ord reg => Addr reg -> Set reg
addrRegs Addr reg
a
uses (CmpRegReg ann
_ reg
r reg
r')  = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg
r, reg
r']
uses (CmpRegBool ann
_ reg
r Word8
_)  = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
uses (CmpAddrBool ann
_ Addr reg
a Word8
_) = Addr reg -> Set reg
forall reg. Ord reg => Addr reg -> Set reg
addrRegs Addr reg
a
uses (ShiftLRR ann
_ reg
r reg
r')   = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg
r, reg
r']
uses (ShiftRRR ann
_ reg
r reg
r')   = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg
r, reg
r']
uses (MovRCi8 ann
_ reg
r Int8
_)     = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
uses (MovACTag ann
_ Addr reg
a Word8
_)    = Addr reg -> Set reg
forall reg. Ord reg => Addr reg -> Set reg
addrRegs Addr reg
a
uses (IdivR ann
_ reg
r)         = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
uses (DivR ann
_ reg
r)          = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
uses Cqo{}               = Set reg
forall a. Set a
S.empty -- TODO?
uses (AndRR ann
_ reg
r reg
r')      = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg
r, reg
r']
uses (OrRR ann
_ reg
r reg
r')       = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg
r, reg
r']
uses (PopcountRR ann
_ reg
_ reg
r') = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r'
uses (NegR ann
_ reg
r)          = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
uses X86 reg ann
_                   = Set reg
forall a. Set a
S.empty

defs :: X86 reg ann -> S.Set reg
defs :: X86 reg ann -> Set reg
defs (MovRA ann
_ reg
r Addr reg
_)      = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (MovRR ann
_ reg
r reg
_)      = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (MovRC ann
_ reg
r Int64
_)      = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (MovRCBool ann
_ reg
r Word8
_)  = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (MovRCi8 ann
_ reg
r Int8
_)    = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (MovRWord ann
_ reg
r Label
_)   = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (AddRR ann
_ reg
r reg
_)      = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (SubRR ann
_ reg
r reg
_)      = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (ImulRR ann
_ reg
r reg
_)     = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (AddRC ann
_ reg
r Int64
_)      = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (SubRC ann
_ reg
r Int64
_)      = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (XorRR ann
_ reg
r reg
_)      = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (MovRL ann
_ reg
r ByteString
_)      = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (ShiftRRR ann
_ reg
r reg
_)   = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (PopReg ann
_ reg
r)       = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (ShiftLRR ann
_ reg
r reg
_)   = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (AndRR ann
_ reg
r reg
_)      = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (OrRR ann
_ reg
r reg
_)       = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (PopcountRR ann
_ reg
r reg
_) = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (NegR ann
_ reg
r)         = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
defs (MovRCTag ann
_ reg
r Word8
_)   = reg -> Set reg
forall a. a -> Set a
S.singleton reg
r
-- defs for IdivR &c.?
defs X86 reg ann
_                  = Set reg
forall a. Set a
S.empty

next :: [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
next :: [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
next [X86 AbsReg ()]
asms = do
    [X86 AbsReg ControlAnn]
nextAsms <- [X86 AbsReg ()] -> FreshM [X86 AbsReg ControlAnn]
addControlFlow [X86 AbsReg ()]
asms
    case [X86 AbsReg ControlAnn]
nextAsms of
        []      -> ([Int] -> [Int], [X86 AbsReg ControlAnn])
-> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int] -> [Int]
forall a. a -> a
id, [])
        (X86 AbsReg ControlAnn
asm:[X86 AbsReg ControlAnn]
_) -> ([Int] -> [Int], [X86 AbsReg ControlAnn])
-> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ControlAnn -> Int
node (X86 AbsReg ControlAnn -> ControlAnn
forall reg a. X86 reg a -> a
ann X86 AbsReg ControlAnn
asm) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:), [X86 AbsReg ControlAnn]
nextAsms)

-- | Construct map assigning labels to their node name.
broadcasts :: [X86 reg ()] -> FreshM [X86 reg ()]
broadcasts :: [X86 reg ()] -> FreshM [X86 reg ()]
broadcasts [] = [X86 reg ()] -> FreshM [X86 reg ()]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
broadcasts (asm :: X86 reg ()
asm@(Label ()
_ Label
l):[X86 reg ()]
asms) = do
    { Int
i <- FreshM Int
getFresh
    ; Int -> Label -> StateT (Int, Map Label Int) Identity ()
broadcast Int
i Label
l
    ; (X86 reg ()
asm X86 reg () -> [X86 reg ()] -> [X86 reg ()]
forall a. a -> [a] -> [a]
:) ([X86 reg ()] -> [X86 reg ()])
-> FreshM [X86 reg ()] -> FreshM [X86 reg ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [X86 reg ()] -> FreshM [X86 reg ()]
forall reg. [X86 reg ()] -> FreshM [X86 reg ()]
broadcasts [X86 reg ()]
asms
    }
broadcasts (X86 reg ()
asm:[X86 reg ()]
asms) = (X86 reg ()
asm X86 reg () -> [X86 reg ()] -> [X86 reg ()]
forall a. a -> [a] -> [a]
:) ([X86 reg ()] -> [X86 reg ()])
-> FreshM [X86 reg ()] -> FreshM [X86 reg ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [X86 reg ()] -> FreshM [X86 reg ()]
forall reg. [X86 reg ()] -> FreshM [X86 reg ()]
broadcasts [X86 reg ()]
asms