canon.sml

signature CANON =
sig
    val linearize : Tree.stm -> Tree.stm list
    (* From an arbitrary Tree statement, produce a list of cleaned trees
     satisfying the following properties:
        1.  No SEQ's or ESEQ's
        2.  The parent of every CALL is an EXP(..) or a MOVE(TEMP t,..)
     *)

    val basicBlocks : Tree.stm list -> (Tree.stm list list * Tree.label)
    (* From a list of cleaned trees, produce a list of
   basic blocks satisfying the following properties:
        1. and 2. as above;
        3.  Every block begins with a LABEL;
              4.  A LABEL appears only at the beginning of a block;
              5.  Any JUMP or CJUMP is the last stm in a block;
              6.  Every block ends with a JUMP or CJUMP;
           Also produce the "label" to which control will be passed
           upon exit.
     *)

    val traceSchedule : Tree.stm list list * Tree.label -> Tree.stm list
(* From a list of basic blocks satisfying properties 1-6,
            along with an "exit" label,
      produce a list of stms such that:
        1. and 2. as above;
              7. Every CJUMP(_,t,f) is immediately followed by LABEL f.
            The blocks are reordered to satisfy property 7; also
      in this reordering as many JUMP(T.NAME(lab)) statements
            as possible are eliminated by falling through into T.LABEL(lab).
 *)
end

structure Canon : CANON =
struct

structure T = Tree

fun linearize(stm0: T.stm) : T.stm list =
  let
      infix %
      fun (T.EXP(T.CONST _)) % x = x
        | x % (T.EXP(T.CONST _)) = x
        | x % y = T.SEQ(x,y)

      fun commute(T.EXP(T.CONST _), _) = true
        | commute(_, T.NAME _) = true
        | commute(_, T.CONST _) = true
        | commute _ = false

      val nop = T.EXP(T.CONST 0)

      fun reorder ((e as T.CALL _ )::rest) =
        let val t = Temp.newtemp()
        in reorder(T.ESEQ(T.MOVE(T.TEMP t, e), T.TEMP t) :: rest)
        end
        | reorder (a::rest) =
          let val (stms,e) = do_exp a
              val (stms',el) = reorder rest
          in if commute(stms',e)
             then (stms % stms',e::el)
             else let val t = Temp.newtemp()
                  in (stms % T.MOVE(T.TEMP t, e) % stms', T.TEMP t :: el)
                  end
          end
        | reorder nil = (nop,nil)

      and reorder_exp(el,build) = let val (stms,el') = reorder el
                                  in (stms, build el')
                                  end

      and reorder_stm(el,build) = let val (stms,el') = reorder (el)
                                  in stms % build(el')
                                  end

      and do_stm(T.SEQ(a,b)) =
          do_stm a % do_stm b
        | do_stm(T.JUMP(e,labs)) =
          reorder_stm([e],fn [e] => T.JUMP(e,labs))
        | do_stm(T.CJUMP(p,a,b,t,f)) =
          reorder_stm([a,b], fn[a,b]=> T.CJUMP(p,a,b,t,f))
        | do_stm(T.MOVE(T.TEMP t,T.CALL(e,el))) =
          reorder_stm(e::el,fn e::el => T.MOVE(T.TEMP t,T.CALL(e,el)))
        | do_stm(T.MOVE(T.TEMP t,b)) =
          reorder_stm([b],fn[b]=>T.MOVE(T.TEMP t,b))
        | do_stm(T.MOVE(T.MEM e,b)) =
          reorder_stm([e,b],fn[e,b]=>T.MOVE(T.MEM e,b))
        | do_stm(T.MOVE(T.ESEQ(s,e),b)) =
          do_stm(T.SEQ(s,T.MOVE(e,b)))
        | do_stm(T.EXP(T.CALL(e,el))) =
          reorder_stm(e::el,fn e::el => T.EXP(T.CALL(e,el)))
        | do_stm(T.EXP e) =
          reorder_stm([e],fn[e]=>T.EXP e)
        | do_stm s = reorder_stm([],fn[]=>s)

      and do_exp(T.BINOP(p,a,b)) =
          reorder_exp([a,b], fn[a,b]=>T.BINOP(p,a,b))
        | do_exp(T.MEM(a)) =
          reorder_exp([a], fn[a]=>T.MEM(a))
        | do_exp(T.ESEQ(s,e)) =
          let val stms = do_stm s
              val (stms',e) = do_exp e
          in (stms%stms',e)
          end
        | do_exp(T.CALL(e,el)) =
          reorder_exp(e::el, fn e::el => T.CALL(e,el))
        | do_exp e = reorder_exp([],fn[]=>e)

      (* linear gets rid of the top-level SEQ's, producing a list *)
      fun linear(T.SEQ(a,b),l) = linear(a,linear(b,l))
        | linear(s,l) = s::l

  in (* body of linearize *)
      linear(do_stm stm0, nil)
  end

type block = T.stm list

(* Take list of statements and make basic blocks satisfying conditions
       3 and 4 above, in addition to the extra condition that
      every block ends with a JUMP or CJUMP *)

fun basicBlocks stms =
  let val done = Temp.newlabel()
      fun blocks((head as T.LABEL _) :: tail, blist) =
        let fun next((s as (T.JUMP _))::rest, thisblock) =
              endblock(rest, s::thisblock)
              | next((s as (T.CJUMP _))::rest, thisblock) =
                endblock(rest,s::thisblock)
              | next(stms as (T.LABEL lab :: _), thisblock) = (*This only runs when there is no Jump in previous block*)
                next(T.JUMP(T.NAME lab,[lab]) :: stms, thisblock)
              | next(s::rest, thisblock) = next(rest, s::thisblock)
              | next(nil, thisblock) =
                next([T.JUMP(T.NAME done, [done])], thisblock)

            and endblock(stms, thisblock) =
                blocks(stms, rev thisblock :: blist)

        in next(tail, [head])
        end
        | blocks(nil, blist) = rev blist
        | blocks(stms, blist) = blocks(T.LABEL(Temp.newlabel())::stms, blist)
  in (blocks(stms,nil), done)
  end

fun enterblock(b as (T.LABEL s :: _), table) = Symbol.enter(table,s,b)
  | enterblock(_, table) = table

fun splitlast([x]) = (nil,x)
  | splitlast(h::t) = let val (t',last) = splitlast t in (h::t', last) end

fun trace(table,b as (T.LABEL lab :: _),rest) =
  let val table = Symbol.enter(table, lab, nil)
  in case splitlast b
      of (most,T.JUMP(T.NAME lab, _)) =>
         (case Symbol.look(table, lab)
           of SOME(b' as _::_) => most @ trace(table, b', rest)
            | _ => b @ getnext(table,rest))
       | (most,T.CJUMP(opr,x,y,t,f)) =>
         (case (Symbol.look(table,t), Symbol.look(table,f))
           of (_, SOME(b' as _::_)) => b @ trace(table, b', rest)
            | (SOME(b' as _::_), _) =>
              most @ [T.CJUMP(T.notRel opr,x,y,f,t)]
              @ trace(table, b', rest)
            | _ => let val f' = Temp.newlabel()
                   in most @ [T.CJUMP(opr,x,y,t,f'),
                              T.LABEL f', T.JUMP(T.NAME f,[f])]
                      @ getnext(table,rest)
                   end)
       | (most, T.JUMP _) => b @ getnext(table,rest)
  end

and getnext(table,(b as (T.LABEL lab::_))::rest) =
    (case Symbol.look(table, lab)
      of SOME(_::_) => trace(table,b,rest)
       | _ => getnext(table,rest))
  | getnext(table,nil) = nil
  | getnext (_, _) = nil

fun traceSchedule(blocks,done) =
  getnext(foldr enterblock Symbol.empty blocks, blocks)
  @ [T.LABEL done]

end