183 lines
6.2 KiB
Standard ML
183 lines
6.2 KiB
Standard ML
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) =
|
|
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
|
|
|
|
fun traceSchedule(blocks,done) =
|
|
getnext(foldr enterblock Symbol.empty blocks, blocks)
|
|
@ [T.LABEL done]
|
|
|
|
end
|