module Optimiser(optimise, OptimiserLevel(..)) where

import Data.Either
import Data.Function
import Data.List
import Data.Maybe
import qualified Data.Map.Strict as Map
import Debug.Trace

import Defs
import Intermediate
import Pretty
import ReplaceRefs
import Utils


data OptimiserLevel = Level0 | Level1
  deriving (Show, Eq, Ord)

type Optimisation = IRProgram -> IRProgram
type FuncOptimisation = IRFunc -> IRFunc

optimise :: OptimiserLevel -> IRProgram -> Error IRProgram
optimise optlevel prog =
    let optlist = {-[trace "-- OPT PASS --", \p -> trace (pretty p) p] ++ -} optimisations
        reslist = scanl (flip ($)) prog $ cycle optlist
        passreslist = map fst $ filter (\(_, i) -> i `mod` length optlist == 0) $ zip reslist [0..]
        applyFinalOpts p = foldl (flip ($)) p finaloptimisations
    in return $ applyFinalOpts $ 
            fst $ fromJust $ find (uncurry (==)) $ zip passreslist (tail passreslist)
  where
    optimisations = case optlevel of
        Level0 -> map funcopt [chainJumps, mergeTerminators, looseJumps, removeUnusedBlocks]
        Level1 -> map funcopt
                    [chainJumps, mergeTerminators, looseJumps,
                     removeUnusedBlocks, removeDuplicateBlocks,
                     identityOps,
                     constantPropagate, movPush,
                     arithPush, removeUnusedInstructions,
                     evaluateInstructions, evaluateTerminators]
    finaloptimisations = case optlevel of
        Level0 -> map funcopt [flipJccs]
        Level1 -> map funcopt [reorderBlocks, flipJccs, invertJccs]


funcopt :: FuncOptimisation -> Optimisation
funcopt fo (IRProgram vars funcs) = IRProgram vars (map fo funcs)


chainJumps :: FuncOptimisation
chainJumps (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
  where
    bbs' = snd $ last $ takeWhile fst $ iterate (mergeChain . snd) (True, bbs)
    
    mergeChain :: [BB] -> (Bool, [BB])
    mergeChain [] = (False, [])
    mergeChain bbs2 = case findIndex isSuitable bbs2 of
        Nothing -> (False, bbs2)
        Just idx ->
            let (BB bid1 inss1 (IJmp target), rest) =
                    (bbs2 !! idx, take idx bbs2 ++ drop (idx+1) bbs2)
                [BB _ inss2 term2] = filter (\(BB bid _ _) -> bid == target) rest
                merged = BB bid1 (inss1 ++ inss2) term2
            in (True, merged : rest)
      where
        hasJmpTo :: Id -> BB -> Bool
        hasJmpTo i (BB _ _ (IJmp i')) = i == i'
        hasJmpTo i (BB _ _ (IJcc _ _ _ i1 i2)) = i == i1 || i == i2
        hasJmpTo _ _ = False

        isSuitable :: BB -> Bool
        isSuitable (BB _ _ (IJmp target)) = sum (map (fromEnum . hasJmpTo target) bbs2) == 1
        isSuitable _ = False

mergeTerminators :: FuncOptimisation
mergeTerminators (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
  where
    bbs' = flip map bbs $ \bb@(BB bid inss term) -> case term of
        IJmp i -> case find ((== i) . fst) singles of
            Just (_, t) -> BB bid inss t
            Nothing -> bb
        _ -> bb

    singles = map (\(BB i _ t) -> (i, t)) $ filter (\(BB _ inss _) -> null inss) bbs

looseJumps :: FuncOptimisation
looseJumps (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
  where
    bbs' = flip map bbs $ \bb@(BB bid inss term) -> case term of
        IJmp i -> BB bid inss (IJmp (translate i))
        IJcc ct r1 r2 i j -> BB bid inss (IJcc ct r1 r2 (translate i) (translate j))
        _ -> bb

    translate i = fromMaybe i $ Map.lookup i transmap

    transmap = Map.fromList $ catMaybes $ flip map bbs $ \bb -> case bb of
        BB bid [] (IJmp i) -> Just (bid, i)
        _ -> Nothing

removeUnusedBlocks :: FuncOptimisation
removeUnusedBlocks (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
  where
    bbs' = filter isReachable bbs

    isReachable :: BB -> Bool
    isReachable (BB bid _ _)
        | bid == sid = True
        | otherwise = isJust $ flip find bbs $ \(BB _ _ term) -> case term of
            IJcc _ _ _ i1 i2 -> i1 == bid || i2 == bid
            IJmp i -> i == bid
            _ -> False

removeDuplicateBlocks :: FuncOptimisation
removeDuplicateBlocks (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
  where
    bbs' = let (bbspre, repls) = foldr foldfunc ([], []) bbs
           in foldl (\l (from, to) -> replaceBBIds from to l) bbspre repls

    foldfunc bb@(BB bid inss term) (l, repls) =
        case find (\(BB _ inss' term') -> inss == inss' && term == term') l of
            Nothing -> (bb : l, repls)
            Just (BB bid' _ _) -> (l, (bid, bid') : repls)

    replaceBBIds :: Id -> Id -> [BB] -> [BB]
    replaceBBIds from to = map $ \(BB bid inss term) -> BB bid inss $ case term of
        IJcc ct r1 r2 i1 i2 -> IJcc ct r1 r2 (trans from to i1) (trans from to i2)
        IJmp i -> IJmp (trans from to i)
        IRet -> IRet
        IRetr r -> IRetr r
        IUnreachable -> IUnreachable
        ITermNone -> undefined

    trans :: (Eq a) => a -> a -> a -> a
    trans a b c | a == c = b
                | otherwise = c

identityOps :: FuncOptimisation
identityOps (IRFunc rt name al bbs sid) = IRFunc rt name al (map go bbs) sid
  where
    go :: BB -> BB
    go (BB bid inss term) = BB bid (catMaybes $ map goI inss) term

    goI :: IRIns -> Maybe IRIns
    goI (IAri AAdd d s (Constant _ 0)) = Just $ IMov d s
    goI (IAri AAdd d (Constant _ 0) s) = Just $ IMov d s
    goI (IAri ASub d s (Constant _ 0)) = Just $ IMov d s
    goI (IAri AMul d s (Constant _ 1)) = Just $ IMov d s
    goI (IAri AMul d (Constant _ 1) s) = Just $ IMov d s
    goI (IAri ADiv d s (Constant _ 1)) = Just $ IMov d s
    goI (IMov d s) | d == s = Nothing
    goI i = Just i

constantPropagate :: FuncOptimisation
constantPropagate (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
  where
    alltemps = findAllTempsBBList bbs
    alltempsmuts = Map.fromList $ map (\ref -> (ref, findMutations' bbs ref)) alltemps
    consttemps = catMaybes $ flip map alltemps $ \ref ->
        let locs = fromJust $ Map.lookup ref alltempsmuts
            loc = head locs
            ins = insAt bbs loc
            usedrefs = findAllRefsIns ins
            readlocs = findMentions' bbs ref \\ locs
            readinss = map (insAt' bbs) readlocs
            allimov = all (maybe False isIMov) readinss
        in if length locs == 1 &&  -- check necessary because it shouldn't be 0
                all (maybe True ((<=1) . length) . flip Map.lookup alltempsmuts) usedrefs &&
                (isIMov ins || ((isILoad ins || isIAri ins || isIResize ins) && allimov))
            then Just (loc, ins)
            else Nothing

    bbs' = case consttemps of
                [] -> bbs
                ((loc, IMov ref value) : _) ->
                    replaceRefsBBList ref value (nopifyInsAt bbs loc)
                ((loc, ILoad ref s) : _) ->
                    replaceMovs ref (\r' -> ILoad r' s) (nopifyInsAt bbs loc)
                ((loc, IAri at ref s1 s2) : _) ->
                    replaceMovs ref (\r' -> IAri at r' s1 s2) (nopifyInsAt bbs loc)
                ((loc, IResize ref s) : _) ->
                    replaceMovs ref (\r' -> IResize r' s) (nopifyInsAt bbs loc)
                _ -> undefined

    replaceMovs :: Ref -> (Ref -> IRIns) -> [BB] -> [BB]
    replaceMovs srcref insb = map $ \(BB bid inss term) -> BB bid (map go inss) term
      where
        go :: IRIns -> IRIns
        go (IMov d src) | src == srcref = insb d
        go ins = ins

movPush :: FuncOptimisation
movPush (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
  where
    goBB :: BB -> BB
    goBB (BB bid inss term) =
        let inss' = go inss term
            term' = if null inss' then term else pushT (last inss) term
        in BB bid inss' term'

    go :: [IRIns] -> IRTerm -> [IRIns]
    go [] _ = []
    go (IMov d s : rest) term
        | isJust (find (== d) (findAllRefsInss rest ++ findAllRefsTerm term)) =
            push (d, s) rest term
    go (ins : rest) term = ins : go rest term

    push :: (Ref, Ref) -> [IRIns] -> IRTerm -> [IRIns]
    push (d, s) [] _ = [IMov d s]
    push (d, s) l _ | d == s = l
    push mov@(d, s) (IMov d' s' : rest) term
        | d' == d = if d' == s' then push mov rest term else push (d', s') rest term
        | d' == s = IMov d s : push (d', replaceRef d s s') rest term
        | otherwise = IMov d' (replaceRef d s s') : push mov rest term
    push mov@(d, _) (ILea d' n : rest) term
        | d' == d = ILea d' n : go rest term
        | otherwise = ILea d' n : push mov rest term
    push mov@(d, s) (IResize d' s' : rest) term
        | d' == d = IResize d' (replaceRef d s s') : go rest term
        | d' == s = IMov d s : IResize d' (replaceRef d s s') : go rest term
        | otherwise = IResize d' (replaceRef d s s') : push mov rest term
    push mov@(d, s) (ILoad d' s' : rest) term
        | d' == d = ILoad d' (replaceRef d s s') : go rest term
        | d' == s = IMov d s : ILoad d' (replaceRef d s s') : go rest term
        | otherwise = ILoad d' (replaceRef d s s') : push mov rest term
    push mov@(d, s) (ISet d' n' s' : rest) term
        | d' == d = ISet d' n' (replaceRef d s s') : go rest term
        | d' == s = IMov d s : ISet d' n' s' : go rest term
        | otherwise = ISet d' n' (replaceRef d s s') : push mov rest term
    push mov@(d, s) (IGet d' s' n' : rest) term
        | d' == d = IGet d' (replaceRef d s s') n' : go rest term
        | d' == s = IMov d s : IGet d' s' n' : go rest term
        | otherwise = IGet d' (replaceRef d s s') n' : push mov rest term
    push mov@(d, s) (IAri at d' s1' s2' : rest) term
        | d' == d = IAri at d' (replaceRef d s s1') (replaceRef d s s2') : go rest term
        | d' == s = IMov d s : IAri at d' (replaceRef d s s1') (replaceRef d s s2') : go rest term
        | otherwise = IAri at d' (replaceRef d s s1') (replaceRef d s s2') : push mov rest term
    -- I don't trust going past calls because globals might change. Might be able to
    -- catch that case, but that will go wrong when more stuff gets added.
    -- push mov@(d, s) (ins@(ICallr d' _ _) : rest) term
    --     | d' == d = IMov d s : ins : go rest term
    --     | otherwise = replaceRefsIns d s ins : push mov rest term
    -- push mov@(d, s) (ins@(ICall _ _) : rest) term = replaceRefsIns d s ins : push mov rest term
    push (d, s) l@(ICallr _ _ _ : _) term = IMov d s : go l term
    push (d, s) l@(ICall _ _ : _) term = IMov d s : go l term
    push mov@(d, s) (ins@(IStore _ _) : rest) term = replaceRefsIns d s ins : push mov rest term
    push (d, s) l@(IDebugger : _) term = IMov d s : go l term
    push mov (INop : rest) term = push mov rest term

    pushT :: IRIns -> IRTerm -> IRTerm
    pushT (IMov d s) term = replaceRefsTerm d s term
    pushT _ term = term

arithPush :: FuncOptimisation
arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
  where
    resbbs = foldl (\bbs i -> goBB (blockById i bbs) bbs) allbbs (map blockIdOf allbbs)

    goBB :: BB -> [BB] -> [BB]
    goBB bb@(BB bid _ _) bbs =
        let (mari, (inss', [Right term'])) = fmap (span isLeft) $ go (bbToList bb)
            resbbs1 = replaceBlock bid (BB bid (map (fromLeft undefined) inss') term') bbs
        in case mari of
            Nothing -> resbbs1
            Just ari ->
                let tgs = map (flip blockById bbs) $
                            filter (\b -> length (originBlocks b) == 1) $ jumpTargets term'
                in foldl (\bbs' tg -> propagateContinue ari tg bbs') resbbs1 tgs

    propagateContinue :: IRIns -> BB -> [BB] -> [BB]
    -- propagateContinue ari bb _ | traceShow (ari, bb) False = undefined
    propagateContinue ari@(IAri at d s1 s2) bb@(BB bid _ _) bbs =
        let (cont, (inss', [Right term'])) = fmap (span isLeft) $ propagate (at, d, s1, s2) (bbToList bb)
            resbbs1 = replaceBlock bid (BB bid (map (fromLeft undefined) inss') term') bbs
        in if cont
            then let tgs = map (flip blockById bbs) $
                             filter (\b -> length (originBlocks b) == 1) $ jumpTargets term'
                 in foldl (\bbs' tg -> propagateContinue ari tg bbs') resbbs1 tgs
            else resbbs1
    propagateContinue _ _ _ = undefined

    blockById :: Id -> [BB] -> BB
    blockById i bbs = head $ filter (\(BB bid _ _) -> bid == i) bbs

    originBlocks :: Id -> [BB]
    originBlocks i = filter (\(BB _ _ term) -> i `elem` jumpTargets term) allbbs

    replaceBlock :: Id -> BB -> [BB] -> [BB]
    replaceBlock _ _ [] = []
    replaceBlock bid bb (bb'@(BB bid' _ _) : rest)
        | bid' == bid = bb : rest
        | otherwise = bb' : replaceBlock bid bb rest

    go :: [Either IRIns IRTerm] -> (Maybe IRIns, [Either IRIns IRTerm])
    go [] = (Nothing, [])
    go (Left ari@(IAri at d s1 s2) : rest) = case propagate (at, d, s1, s2) rest of
        (False, res) -> fmap (Left ari :) $ go res
        (True, res) -> (Just ari, Left ari : res)
    go (ins : rest) = fmap (ins :) $ go rest

    bbToList :: BB -> [Either IRIns IRTerm]
    bbToList (BB _ inss term) = map Left inss ++ [Right term]

    propagate :: (ArithType, Ref, Ref, Ref) -> [Either IRIns IRTerm] -> (Bool, [Either IRIns IRTerm])
    propagate _ [] = (True, [])
    propagate ari@(_, d, s1, s2) (Left ins@(IMov md _) : rest)
        | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
        | otherwise = (False, Left ins : rest)
    propagate ari (Left ins@(IStore _ _) : rest) =
        fmap (Left ins :) $ propagate ari rest
    propagate ari@(_, d, s1, s2) (Left ins@(ILoad md _) : rest)
        | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
        | otherwise = (False, Left ins : rest)
    propagate ari@(_, d, s1, s2) (Left ins@(ISet md _ _) : rest)
        | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
        | otherwise = (False, Left ins : rest)
    propagate ari@(_, d, s1, s2) (Left ins@(IGet md _ _) : rest)
        | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
        | otherwise = (False, Left ins : rest)
    propagate ari@(at, d, s1, s2) (Left ins@(IAri mat md ms1 ms2) : rest)
        | d /= md && (at, s1, s2) == (mat, ms1, ms2) = fmap (Left (IMov md d) :) $ propagate ari rest
        | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
        | otherwise = fmap (Left ins :) $ propagate (mat, md, ms1, ms2) rest
    -- I don't trust going past calls because globals might change. Might be able to
    -- catch that case, but that will go wrong when more stuff gets added.
    -- propagate ari@(_, d, s1, s2) (Left ins@(ICall _ mal) : rest)
    --     | null (intersect [d] mal) = fmap (Left ins :) $ propagate ari rest
    --     | otherwise = (False, Left ins : rest)
    -- propagate ari@(_, d, s1, s2) (Left ins@(ICallr md _ mal) : rest)
    --     | null (intersect [d,s1,s2] (md : mal)) = fmap (Left ins :) $ propagate ari rest
    --     | otherwise = (False, Left ins : rest)
    propagate ari@(_, d, s1, s2) (Left ins@(IResize md _) : rest)
        | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
        | otherwise = (False, Left ins : rest)
    propagate ari@(_, d, s1, s2) (Left ins@(ILea md _) : rest)
        | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
        | otherwise = (False, Left ins : rest)
    propagate ari (Left INop : rest) = propagate ari rest
    propagate (at, d, s1, s2) (Right term@(IJcc ct r1 r2 i1 i2) : rest)
        | (r1 == d || r2 == d) &&
          (isConstant r1 || isConstant r2) &&
          at `elem` [AEq, ANeq, AGt, ALt, AGeq, ALeq] =
            let ct' = if isConstant r2 then ct else flipCmpType ct
                conref = if isConstant r2 then r2 else r1
                (ct'', con) = case (ct', conref) of
                    (CEq, Constant _ c) -> (CEq, if c `elem` [0, 1] then c else (-1))
                    (CNeq, Constant _ c) -> (CNeq, if c `elem` [0, 1] then c else (-1))
                    (CGt, Constant _ c) | c < 0 -> (CNeq, (-1))
                                        | c == 0 -> (CEq, 1)
                                        | otherwise -> (CEq, (-1))
                    (CLt, Constant _ c) | c > 1 -> (CNeq, (-1))
                                        | c == 1 -> (CEq, 0)
                                        | otherwise -> (CEq, (-1))
                    (CGeq, Constant _ c) | c <= 0 -> (CNeq, (-1))
                                         | c == 1 -> (CEq, 1)
                                         | otherwise -> (CEq, (-1))
                    (CLeq, Constant _ c) | c >= 1 -> (CNeq, (-1))
                                         | c == 0 -> (CEq, 0)
                                         | otherwise -> (CEq, (-1))
                    _ -> undefined
                resterm = case (ct'', con) of
                    (CEq, 0) -> IJcc (invertCmpType (arithTypeToCmpType at)) s1 s2 i1 i2
                    (CEq, 1) -> IJcc (arithTypeToCmpType at) s1 s2 i1 i2
                    (CEq, _) -> IJmp i2
                    (CNeq, 0) -> IJcc (arithTypeToCmpType at) s1 s2 i1 i2
                    (CNeq, 1) -> IJcc (invertCmpType (arithTypeToCmpType at)) s1 s2 i1 i2
                    (CNeq, _) -> IJmp i1
                    _ -> undefined
            in (True, Right resterm : rest)
        | otherwise = (True, Right term : rest)
    propagate _ l@(Left (ICall _ _) : _) = (False, l)
    propagate _ l@(Left (ICallr _ _ _) : _) = (False, l)
    propagate _ l@(Left IDebugger : _) = (False, l)
    propagate _ l@(Right (IJmp _) : _) = (True, l)
    propagate _ l@(Right IRet : _) = (False, l)
    propagate _ l@(Right (IRetr _) : _) = (False, l)
    propagate _ l@(Right IUnreachable : _) = (False, l)
    propagate _ (Right ITermNone : _) = undefined

flipCmpType :: CmpType -> CmpType
flipCmpType CEq = CEq
flipCmpType CNeq = CNeq
flipCmpType CGt = CLt
flipCmpType CLt = CGt
flipCmpType CGeq = CLeq
flipCmpType CLeq = CGeq
flipCmpType CUGt = CULt
flipCmpType CULt = CUGt
flipCmpType CUGeq = CULeq
flipCmpType CULeq = CUGeq

invertCmpType :: CmpType -> CmpType
invertCmpType CEq = CNeq
invertCmpType CNeq = CEq
invertCmpType CGt = CLeq
invertCmpType CLt = CGeq
invertCmpType CGeq = CLt
invertCmpType CLeq = CGt
invertCmpType CUGt = CULeq
invertCmpType CULt = CUGeq
invertCmpType CUGeq = CULt
invertCmpType CULeq = CUGt

arithTypeToCmpType :: ArithType -> CmpType
arithTypeToCmpType AEq = CEq
arithTypeToCmpType ANeq = CNeq
arithTypeToCmpType AGt = CGt
arithTypeToCmpType ALt = CLt
arithTypeToCmpType AGeq = CGeq
arithTypeToCmpType ALeq = CLeq
arithTypeToCmpType _ = undefined

removeUnusedInstructions :: FuncOptimisation
removeUnusedInstructions (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
  where
    goBB :: BB -> BB
    goBB (BB bid inss term) = BB bid (catMaybes $ map goI inss) term

    goI :: IRIns -> Maybe IRIns
    goI ins@(IMov d _) = pureInstruction d ins
    goI ins@(ILea d _) = pureInstruction d ins
    goI ins@(IStore _ _) = Just ins
    goI ins@(ILoad d _) = pureInstruction d ins
    goI ins@(ISet _ _ _) = Just ins
    goI ins@(IGet d _ _) = pureInstruction d ins
    goI ins@(IAri _ d _ _) = pureInstruction d ins
    goI ins@(ICall _ _) = Just ins
    goI ins@(ICallr d f a) = if length (findMentions' bbs d) == 1 then Just (ICall f a) else Just ins
    goI ins@(IResize d _) = pureInstruction d ins
    goI IDebugger = Just IDebugger
    goI INop = Nothing

    pureInstruction :: Ref -> IRIns -> Maybe IRIns
    pureInstruction d ins = if length (findMentions' bbs d) == 1 then Nothing else Just ins

evaluateInstructions :: FuncOptimisation
evaluateInstructions (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
  where
    goBB :: BB -> BB
    goBB (BB bid inss term) = BB bid (map goI inss) term

    goI :: IRIns -> IRIns
    goI (IAri at ref (Constant _ v1) (Constant _ v2)) =
        IMov ref $ Constant (refSize ref) $ truncValue (refSize ref) $ evaluateArith at v1 v2
    goI (IResize ref (Constant _ v)) =
        IMov ref $ Constant (refSize ref) $ truncValue (refSize ref) v
    goI ins = ins

    truncValue :: Size -> Value -> Value
    truncValue sz v = fromIntegral $ (fromIntegral v :: Integer) `mod` (2 ^ (8 * sz))

evaluateTerminators :: FuncOptimisation
evaluateTerminators (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
  where
    bbs' = map (\(BB bid inss term) -> BB bid inss (go term)) bbs

    go :: IRTerm -> IRTerm
    go term@(IJcc ct (Constant sza a) (Constant szb b) i1 i2)
        | sza /= szb = error $ "Inconsistent sizes in " ++ show term
        | evaluateCmp ct a b = IJmp i1
        | otherwise = IJmp i2
    go term = term

flipJccs :: FuncOptimisation
flipJccs (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
  where
    goBB :: BB -> BB
    goBB (BB bid inss term) = BB bid inss (goT term)

    goT :: IRTerm -> IRTerm
    goT (IJcc ct r1@(Constant _ _) r2 i1 i2) = IJcc (flipCmpType ct) r2 r1 i1 i2
    goT term = term

reorderBlocks :: FuncOptimisation
reorderBlocks (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
  where
    resbbs = buildResult (allChainsFrom allbbs sid) allbbs

    allChains :: [BB] -> [[Id]]
    allChains bbs = concatMap (allChainsFrom bbs . blockIdOf) bbs

    allChainsFrom :: [BB] -> Id -> [[Id]]
    allChainsFrom b start = go b [] start
      where
        go :: [BB] -> [Id] -> Id -> [[Id]]
        go bbs chain at =
            let ((BB _ _ term), rest) = takeBlock at bbs
                chain' = chain ++ [at]
            in case intersect (jumpTargets term) (map blockIdOf rest) of
                   [] -> [chain']
                   tgs -> flip concatMap tgs $ \tg ->
                            if hasUnreachable (fst $ takeBlock tg bbs)
                                then []
                                else go rest chain' tg

    buildResult :: [[Id]] -> [BB] -> [BB]
    buildResult _ [] = []
    buildResult chains bbs =
        let chain = maximumBy (compare `on` length) chains
            (chainbbs', newbbs) = partition ((`elem` chain) . blockIdOf) bbs
            chainbbs = sortBy (compare `on` (\(BB i _ _) -> fromJust $ findIndex (== i) chain)) chainbbs'
            newchains = allChains newbbs
        in chainbbs ++ buildResult newchains newbbs

    takeBlock :: Id -> [BB] -> (BB, [BB])
    takeBlock _ [] = undefined
    takeBlock target (bb@(BB bid _ _) : rest)
        | bid == target = (bb, rest)
        | otherwise = fmap (bb :) $ takeBlock target rest

    hasUnreachable :: BB -> Bool
    hasUnreachable (BB _ _ IUnreachable) = True
    hasUnreachable _ = False

invertJccs :: FuncOptimisation
invertJccs (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
  where
    bbs' = map goBB (zip bbs (tail bbs)) ++ [last bbs]

    goBB :: (BB, BB) -> BB
    goBB (BB bid inss term, BB nextbid _ _) = BB bid inss (goT term nextbid)

    goT :: IRTerm -> Id -> IRTerm
    goT (IJcc ct r1 r2 i1 i2) next | i1 == next = IJcc (invertCmpType ct) r1 r2 i2 i1
    goT term _ = term


insAt :: [BB] -> (Int, Int) -> IRIns
insAt bbs (i, j) =
    let (BB _ inss _) = bbs !! i
    in inss !! j

insAt' :: [BB] -> (Int, Int) -> Maybe IRIns
insAt' bbs (i, j) = do
    (BB _ inss _) <- if i >= length bbs then Nothing else Just (bbs !! i)
    if j >= length inss then Nothing else Just (inss !! j)

nopifyInsAt :: [BB] -> (Int, Int) -> [BB]
nopifyInsAt bbs (i, j) =
    let (pre, BB bid inss term : post) = splitAt i bbs
        (ipre, _ : ipost) = splitAt j inss
    in pre ++ BB bid (ipre ++ INop : ipost) term : post

findMutations :: BB -> Ref -> [Int]
findMutations (BB _ inss _) ref =
    catMaybes $ flip map (zip inss [0..]) $ \(ins, idx) -> case ins of
        (IMov r _) | r == ref -> Just idx
        (ILoad r _) | r == ref -> Just idx
        (ISet r _ _) | r == ref -> Just idx
        (IAri _ r _ _) | r == ref -> Just idx
        (ICallr r _ _) | r == ref -> Just idx
        (IResize r _) | r == ref -> Just idx
        _ -> Nothing

findMutations' :: [BB] -> Ref -> [(Int, Int)]
findMutations' bbs ref =
    [(i, j) | (bb, i) <- zip bbs [0..], j <- findMutations bb ref]

findMentions :: BB -> Ref -> [Int]
findMentions (BB _ inss term) ref = insres ++ termres
  where
    insres = catMaybes $ flip map (zip inss [0..]) $ \(ins, idx) ->
        if ref `elem` findAllRefsIns ins
            then Just idx
            else Nothing
    termres = if ref `elem` findAllRefsTerm term
                then [length inss]
                else []

findMentions' :: [BB] -> Ref -> [(Int, Int)]
findMentions' bbs ref =
    [(i, j) | (bb, i) <- zip bbs [0..], j <- findMentions bb ref]

-- findMentionsIns :: BB -> Ref -> [IRIns]
-- findMentionsIns (BB _ inss term) ref = insres ++ termres
--   where
--     insres = catMaybes $ flip map (zip inss [0..]) $ \(ins, idx) ->
--         if ref `elem` findAllRefsIns ins
--             then Just ins
--             else Nothing
--     termres = if ref `elem` findAllRefsTerm term
--                 then [term]
--                 else []

-- findMentionsIns' :: [BB] -> Ref -> [IRIns]
-- findMentionsIns' bbs ref = concatMap (flip findMentionsIns ref) bbs

findAllTemps :: BB -> [Ref]
findAllTemps bb = flip filter (findAllRefs bb) $ \ref -> case ref of
    (Temp _ _) -> True
    _ -> False

findAllTempsBBList :: [BB] -> [Ref]
findAllTempsBBList = concatMap findAllTemps