functor LOOPOPT(F:FlowSig) :
sig 
   structure OF: FlowSig
   val loopOpt : F.G.Graph -> OF.G.Graph
end
=
struct

exception Lookup
fun lookup ((k,e) :: t) k' = if k = k' then e else lookup t k'
  | lookup [] _ = raise Lookup

fun remove ((k,e)::t) k' = if k = k' then t else (k,e) :: remove t k'
  | remove [] _ = []

fun enter ((k,e),d) = (k,e) :: remove d k

fun member (h :: t) x = x = h orelse member t x
  | member [] _ = false

fun swap(x,y) = (y,x)

structure OF =
struct
   structure B = F.B
   structure C = F.C
   structure G =
   struct
      type Vertex = int
      datatype Graph = 
         FG of( Vertex 
                * ( Vertex list * (B.Block * C.Cond) )
              ) list

      fun vertices (FG g) = map #1 g
      fun adj  (FG g) v   = #1(lookup g v)
   end
   fun data (G.FG g) v        = #2(lookup g v)
end

open F.B

fun splitBlock (Block b) =
let val changed = map #1 b

    val final = map swap b

    fun isInv (Lit _)   = true
      | isInv (Id x)    = not(member changed x)
      | isInv (x *** y) = isInv x andalso isInv y
      | isInv (x --- y) = isInv x andalso isInv y
      | isInv (x +++ y) = isInv x andalso isInv y
      | isInv (x /// y) = isInv x andalso isInv y

    fun lv n = "!"^Prelude.stringOfInt n

    fun factorInv pre t e = (* pre = precomputed, t = temporary, e = expression *)
        case e of Lit _ => (pre, t, e) 
        | Id _ => (pre, t, e)
        | _ =>
        if isInv e then (pre, t, Id(lookup pre e))
           handle Lookup => 
          (enter((e, lv t), pre), t+1, Id(lv t))
        else let fun preComp x f y = 
                 let val (pre',  t',  ex) = factorInv pre  t  x
                     val (pre'', t'', ey) = factorInv pre' t' y
                 in
                     (pre'', t'', f(ex, ey))
                 end
        in case e of 
           (x *** y ) => preComp x op*** y
         | (x +++ y ) => preComp x op+++ y
         | (x --- y ) => preComp x op--- y
         | (x /// y ) => preComp x op/// y
        end handle Match => (pre, t, e)

    fun splitList (pre, t, (s, e) :: ss, loop) =
        let val (pre', t', e') = factorInv pre t e
        in  splitList(pre', t', ss, (s, e') :: loop) end
      | splitList (pre, _, [], loop) = (Block (map swap pre), Block loop)
in
    splitList ([], 0, b, [])
end

fun loopOpt fg =
let fun optimise [] = []
      | optimise (h :: t) =
    if member (F.G.adj fg h) h then
       let val (b,c) = F.data fg h
           val h' = ~(h+1)
           fun knot [] = []
             | knot (x :: y) = (if x=h then h' else x) :: knot y
           val a = knot( F.G.adj fg h )
           val (n,l) = splitBlock b
        in
           (h, ([h'], (n, F.C.TRUE))) ::
           (h', (a, (l, c))) ::
            optimise t 
       end
    else (h, (F.G.adj fg h, F.data fg h)) :: optimise t
in
    OF.G.FG( optimise (F.G.vertices fg) )
end
    
end