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.IntSet                as IS
import qualified Data.Map                   as M
import           Data.Semigroup             ((<>))
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))

singleton :: AbsReg -> IS.IntSet
singleton :: AbsReg -> IntSet
singleton = IntSet -> (Int -> IntSet) -> Maybe Int -> IntSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IntSet
IS.empty Int -> IntSet
IS.singleton (Maybe Int -> IntSet) -> (AbsReg -> Maybe Int) -> AbsReg -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsReg -> Maybe Int
toInt

-- | Make sure 8-bit and 64-bit registers have no overlap.
--
-- Also can't be called on abstract registers i.e. 'DataPointer' or 'CArg1'.
-- This is kinda sus but it allows us to use an 'IntSet' for liveness analysis.
toInt :: AbsReg -> Maybe Int
toInt :: AbsReg -> Maybe Int
toInt (AllocReg64 Int
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
toInt (AllocReg8 Int
i)  = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
toInt AbsReg
_              = Maybe Int
forall a. Maybe a
Nothing

fromList :: [AbsReg] -> IS.IntSet
fromList :: [AbsReg] -> IntSet
fromList = (AbsReg -> IntSet) -> [AbsReg] -> IntSet
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap AbsReg -> IntSet
singleton

addrRegs :: Addr AbsReg -> IS.IntSet
addrRegs :: Addr AbsReg -> IntSet
addrRegs (Reg AbsReg
r)              = AbsReg -> IntSet
singleton AbsReg
r
addrRegs (AddrRRPlus AbsReg
r AbsReg
r')    = [AbsReg] -> IntSet
fromList [AbsReg
r, AbsReg
r']
addrRegs (AddrRCPlus AbsReg
r Int64
_)     = AbsReg -> IntSet
singleton AbsReg
r
addrRegs (AddrRCMinus AbsReg
r Int64
_)    = AbsReg -> IntSet
singleton AbsReg
r
addrRegs (AddrRRScale AbsReg
r AbsReg
r' Int64
_) = [AbsReg] -> IntSet
fromList [AbsReg
r, AbsReg
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] -> IntSet -> IntSet -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f []) IntSet
IS.empty IntSet
IS.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] -> IntSet -> IntSet -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) IntSet
IS.empty IntSet
IS.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] -> IntSet -> IntSet -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) IntSet
IS.empty IntSet
IS.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] -> IntSet -> IntSet -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) IntSet
IS.empty IntSet
IS.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] -> IntSet -> IntSet -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) IntSet
IS.empty IntSet
IS.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] -> IntSet -> IntSet -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) IntSet
IS.empty IntSet
IS.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] -> IntSet -> IntSet -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f [Int
l_i]) IntSet
IS.empty IntSet
IS.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] -> IntSet -> IntSet -> ControlAnn
ControlAnn Int
i [Int
l_i] IntSet
IS.empty IntSet
IS.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] -> IntSet -> IntSet -> ControlAnn
ControlAnn Int
i [Int
l_i] IntSet
IS.empty IntSet
IS.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] -> IntSet -> IntSet -> ControlAnn
ControlAnn Int
i [] IntSet
IS.empty IntSet
IS.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] -> IntSet -> IntSet -> ControlAnn
ControlAnn Int
i ([Int] -> [Int]
f []) (X86 AbsReg () -> IntSet
forall ann. X86 AbsReg ann -> IntSet
uses X86 AbsReg ()
asm) (X86 AbsReg () -> IntSet
forall ann. X86 AbsReg ann -> IntSet
defs X86 AbsReg ()
asm)) X86 AbsReg ControlAnn
-> [X86 AbsReg ControlAnn] -> [X86 AbsReg ControlAnn]
forall a. a -> [a] -> [a]
: [X86 AbsReg ControlAnn]
asms')
    }

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

defs :: X86 AbsReg ann -> IS.IntSet
defs :: X86 AbsReg ann -> IntSet
defs (MovRA ann
_ AbsReg
r Addr AbsReg
_)      = AbsReg -> IntSet
singleton AbsReg
r
defs (MovRR ann
_ AbsReg
r AbsReg
_)      = AbsReg -> IntSet
singleton AbsReg
r
defs (MovRC ann
_ AbsReg
r Int64
_)      = AbsReg -> IntSet
singleton AbsReg
r
defs (MovRCBool ann
_ AbsReg
r Word8
_)  = AbsReg -> IntSet
singleton AbsReg
r
defs (MovRCi8 ann
_ AbsReg
r Int8
_)    = AbsReg -> IntSet
singleton AbsReg
r
defs (MovRWord ann
_ AbsReg
r Label
_)   = AbsReg -> IntSet
singleton AbsReg
r
defs (AddRR ann
_ AbsReg
r AbsReg
_)      = AbsReg -> IntSet
singleton AbsReg
r
defs (SubRR ann
_ AbsReg
r AbsReg
_)      = AbsReg -> IntSet
singleton AbsReg
r
defs (ImulRR ann
_ AbsReg
r AbsReg
_)     = AbsReg -> IntSet
singleton AbsReg
r
defs (AddRC ann
_ AbsReg
r Int64
_)      = AbsReg -> IntSet
singleton AbsReg
r
defs (SubRC ann
_ AbsReg
r Int64
_)      = AbsReg -> IntSet
singleton AbsReg
r
defs (XorRR ann
_ AbsReg
r AbsReg
_)      = AbsReg -> IntSet
singleton AbsReg
r
defs (MovRL ann
_ AbsReg
r ByteString
_)      = AbsReg -> IntSet
singleton AbsReg
r
defs (ShiftRRR ann
_ AbsReg
r AbsReg
_)   = AbsReg -> IntSet
singleton AbsReg
r
defs (PopReg ann
_ AbsReg
r)       = AbsReg -> IntSet
singleton AbsReg
r
defs (ShiftLRR ann
_ AbsReg
r AbsReg
_)   = AbsReg -> IntSet
singleton AbsReg
r
defs (AndRR ann
_ AbsReg
r AbsReg
_)      = AbsReg -> IntSet
singleton AbsReg
r
defs (OrRR ann
_ AbsReg
r AbsReg
_)       = AbsReg -> IntSet
singleton AbsReg
r
defs (PopcountRR ann
_ AbsReg
r AbsReg
_) = AbsReg -> IntSet
singleton AbsReg
r
defs (NegR ann
_ AbsReg
r)         = AbsReg -> IntSet
singleton AbsReg
r
defs (MovRCTag ann
_ AbsReg
r Word8
_)   = AbsReg -> IntSet
singleton AbsReg
r
-- defs for IdivR &c.?
defs X86 AbsReg ann
_                  = IntSet
IS.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