## generalized-sethi-ullman-reordering.pkg
# Compiled by:
# src/lib/compiler/core.sublib# Sethi-Ullman reordering of expression trees to minimize register usage
#
# See: Andrew W. Appel and Kenneth J. Supowit,
# Generalizations of the Sethi-Ullman algorithm for register allocation,
# Software---Practice & Experience 17 (6):417-421, 1987.
#
# In the expression (M, N) or (M N) it may be that N requires more
# registers to compute than M, in which case it will be better
# to compute let n=N and m=M in (M, N) end instead.
#
# This is no good if both M and N have side effects (read or write).
# And it's not safe for space if N is the last use of some large
# chunk, and M contains a function call that might allot an
# arbitrarily large amount.
#
# What does "last use" mean?
# 1. SELECT (0, r) where the other fields of r might now be dead.
# 2. boxed (r) where all the fields of r might now be dead.
# 3. etc.
# This is ONLY important if r is potentially of unbounded size.
# Thus it doesn't apply to (for example) boxed floats, which are small.
#
# The property "possible read or write side effect" is called "side."
# The property of "possible last use of some large chunk" is called "fetch."
# The property of "possible unbounded allocation" is called "allot."
### "Your work isn't a high stakes,
### nail-biting professional challenge.
###
### "It's a form of play.
###
### "Lighten up and have fun with it."
###
### -- Sol LeWitt
api Generalized_Sethi_Ullman_Reordering {
#
reorder_via_generalized_sethi_ullman
:
lambdacode::Lambda_Expression
-> lambdacode::Lambda_Expression;
};
stipulate
include package access;
include package lambdacode;
#
package hbo = highcode_baseops;
herein
# This package is nowhere referenced:
#
package generalized_sethi_ullman_reordering
: (weak) Generalized_Sethi_Ullman_Reordering # Generalized_Sethi_Ullman_Reordering is from src/lib/compiler/back/top/lambdacode/generalized-sethi-ullman-reordering.pkg {
fun bug s = error_message::impossible ("Reorder: " $ s);
/*
enum info X = I of { expression:X, # The expression itself
regs: Int, /* how many registers needed for the
evaluation of this expression */
side: Bool, /* Does this expression read or write a REF
(conservative approximation) */
fetch: Bool, # See explanation above
allot: Bool /* Might this expression allot
more than a constant number of cells? */
}
fun swap (I { side=TRUE, ... }, I { side=TRUE, ... } ) = FALSE
# Don't interchange side effects
| swap (I { fetch=TRUE, ... }, I { allot=TRUE, ... } ) = FALSE
/* Don't move a SELECT(_, r) to the right of a big allocation,
as this is not safe for space: If r is otherwise dead, we want
its other fields to be garbage collected before allocating a lot */
| swap (I { regs=ra, ... }, I { regs=rb, ... } ) = ra < rb
/* Evaluate the expression requiring more registers first,
then hold its value in one register while evaluating the
other expression. Minimizes max register usage.
*/
fun inorder (a . (rest as b . _)) = if swap (a, b) then FALSE else inorder rest
| inorder _ = TRUE
fun insert (a as (_, _), b . c) = if swap(#1 a, #1 b) then b . insert (a, c)
else a . insert (b, c)
| insert (a, NIL) = a . NIL
fun cost ((I { regs, ... }, _) . rest) = int::max (regs, 1+cost rest)
| cost NIL = 0
fun anyside ((I { side=TRUE, ... }, _) . rest) = TRUE
| anyside (_ . rest) = anyside rest
| anyside NIL = FALSE
fun anyfetch ((I { fetch=TRUE, ... }, _) . rest) = TRUE
| anyfetch (_ . rest) = anyfetch rest
| anyfetch NIL = FALSE
fun anyalloc ((I { allot=TRUE, ... }, _) . rest) = TRUE
| anyalloc (_ . rest) = anyalloc rest
| anyalloc NIL = FALSE
fun combine (l, do_it) =
let fun g (I { expression=e1, side=s1, regs=r1, fetch=f1, allot=a1 } . rest, e, s, r, f, a) =
g (rest, e1 . e, s1 or s, int::max (1+r, r1), f1 or f, a1 or a)
| g (NIL, e, s, r, f, a) = I { expression=do_it e, side=s, regs=r, fetch=f, allot=a }
in g (reverse l, NIL, FALSE, 0, FALSE, FALSE)
end
fun getexp (I { expression, ... } ) = expression
fun fetchprim hbo::IS_BOXED = TRUE
| fetchprim hbo::IS_UNBOXED = TRUE
| fetchprim hbo::VECTOR_LENGTH_IN_SLOTS = TRUE
| fetchprim hbo::HEAPCHUNK_LENGTH_IN_WORDS = TRUE
| fetchprim hbo::SET_REFCELL = TRUE
| fetchprim hbo::GET_REFCELL_CONTENTS = FALSE /* The old REF cell might now be dead,
but not its contents! */
| fetchprim hbo::RW_VECTOR_SET = TRUE /* The "last use" in question is the OLD contents of the rw_vector slot stored into */
| fetchprim hbo::RW_VECTOR_SET_WITH_BOUNDSCHECK = TRUE
| fetchprim hbo::SET_VECSLOT_TO_BOXED_VALUE = TRUE
| fetchprim hbo::SET_VECSLOT_TO_TAGGED_INT_VALUE = TRUE
| fetchprim hbo::RW_VECTOR_GET = TRUE
| fetchprim hbo::RW_VECTOR_GET_WITH_BOUNDSCHECK = TRUE
| fetchprim hbo::RO_VECTOR_GET = TRUE
| fetchprim (hbo::GET_VECSLOT_NUMERIC_CONTENTS _) = TRUE
| fetchprim (hbo::SET_VECSLOT_TO_NUMERIC_VALUE _) = TRUE
| fetchprim hbo::GET_BATAG_FROM_TAGWORD = TRUE
| fetchprim hbo::GET_STATE_OF_WEAK_POINTER_OR_SUSPENSION = TRUE
| fetchprim hbo::USELVAR = TRUE
| fetchprim _ = FALSE
fun sort (do_it, l) = if inorder l
then combine (l, do_it)
else let fun somevar (I { expression=VAR _, ... } ) = NULL
| somevar (I { expression=INT _, ... } ) = NULL
| somevar (I { expression=REAL _, ... } ) = NULL
| somevar (I { expression=STRING _, ... } ) = NULL
| somevar _ = THE (highcode_codetemp::make_lambda_variable())
l' = map (\\ x => (x, somevar x)) l
l'' = fold_backward insert [] l'
fun rename (_, THE v) = VAR v
| rename (I { expression, ... }, NULL) = expression
fun bind ((_, NULL), e) = e
| bind ((I { expression, ... }, THE v), e) = LET (v, SVAL expression, e)
in I { regs= cost l'',
side = anyside l'',
fetch = anyfetch l'',
allot = anyalloc l'',
expression = fold_backward bind (do_it (map rename l')) l''
}
end
many = 12 # how many regs to charge a function call
my rec lpsv: value -> info( value ) =
\\ e as VAR _ => I { regs=0, side=FALSE, expression=e, fetch=FALSE, allot=FALSE }
| e as INT _ => I { regs=0, side=FALSE, fetch=FALSE, allot=FALSE, expression=e }
| e as WORD _ => I { regs=0, side=FALSE, fetch=FALSE, allot=FALSE, expression=e }
| e as INT1 _ => I { regs=0, side=FALSE, fetch=FALSE, allot=FALSE, expression=e }
| e as WORD32 _ => I { regs=0, side=FALSE, fetch=FALSE, allot=FALSE, expression=e }
| e as REAL _ => I { regs=0, side=FALSE, fetch=FALSE, allot=FALSE, expression=e }
| e as STRING _ => I { regs=0, side=FALSE, fetch=FALSE, allot=FALSE, expression=e }
| e as PRIM (i, t, _) => I { regs=0, side=FALSE, fetch=FALSE, allot=FALSE, expression=e }
| _ => bug "unexpected case in lpsv"
and loop: Lambda_Expression -> info( Lambda_Expression ) =
\\ e as SVAL sv =>
let my I { regs, side, expression, fetch, allot } = lpsv sv
in I { regs=regs, side=side, expression=SVAL expression, fetch=fetch, allot=alloc }
end
| e as EXCEPTION_TAG _ => I { regs=1, side=TRUE, fetch=FALSE, allot=TRUE, expression=e }
| FN (v, t, e) => I { regs=1, side=FALSE, fetch=FALSE, allot=FALSE,
expression= FN (v, t, getexp (loop e)) }
| FIX (vl, t, el, e) =>
let my I { regs, side, expression, fetch, allot } = loop e
in I { regs=regs+1, side=side, fetch=fetch, allot=alloc,
expression=FIX (vl, t, el, expression) }
end
| APPLY (p as PRIM (i, t, _), b) =>
let my I { regs, side, fetch, allot, expression=e1 } = lpsv b
in I { regs=int::max (1, regs), side=not (hbo::purePrimop i),
allot=FALSE, fetch=fetchprim i, expression=APPLY (p, e1) }
end
| LET (v, b, a) =>
let my I { regs=ra, side=sa, expression=ea, fetch=fa, allot=aa } =loop a
my I { regs=rb, side=sb, expression=eb, fetch=fb, allot=ab } =loop b
in I { regs=int::max (rb, 1+ra), side=sa or sb,
fetch= fa or fb, allot=aa or ab,
expression=LET (v, eb, ea) }
end
| APPLY (a, b) =>
let my I { expression=e1, ... } =
sort (\\ [x, y]=>APPLY (x, y), map lpsv [a, b])
in I { regs=many, side=TRUE, expression=e1, fetch=TRUE, allot=TRUE }
end
| SWITCH (v0, sign, l, d) =>
let my I { regs, side, expression, fetch, allot } = lpsv v0
fun combine ((c, e), (r, s, f, a, el)) =
let my I { regs, side, expression, fetch, allot } =loop e
in (int::max (r, regs), s or side, f or fetch,
a or allot, (c, expression) . el)
end
my (lr, ls, lf, la, l') = fold_backward combine (regs, side, fetch, allot,[]) l
in case d
of THE d' =>
let my (lr, ls, lf, la,[((), de)]) =
combine(((), d'), (lr, ls, lf, la, NIL))
in I { regs=lr, side=ls, fetch=lf, allot=la,
expression=SWITCH (expression, sign, l', THE de) }
end
| NULL => I { regs=lr, side=ls, fetch=lf, allot=la,
expression=SWITCH (expression, sign, l', NULL) }
end
| CON (c, ts, v) => let my I { regs, side, expression, fetch, allot } = lpsv v
in I { regs=int::max (1, regs), side=side, fetch=fetch, allot=alloc,
expression=CON (c, ts, expression) } # Close enuf
end
| DECON (c, ts, v) => let my I { regs, side, expression, fetch, allot } = lpsv v
in I { regs=int::max (regs, 1), side=side, fetch=TRUE, allot=alloc,
expression=DECON (c, ts, expression) }
end
| RECORD l => sort (\\ x => RECORD x, map lpsv l)
| PACKAGE_RECORD l => sort (\\ x => PACKAGE_RECORD x, map lpsv l)
| VECTOR (l, t) => sort (\\ x => VECTOR (x, t), map lpsv l)
| SELECT (i, e) => let my I { regs, side, expression, fetch, allot } = lpsv e
in I { regs=int::max (1, regs), side=side, fetch=TRUE, allot=alloc,
expression=SELECT (i, expression) }
end
| RAISE (e, t) => let my I { regs, side, expression, fetch, allot } = lpsv e
in I { regs=int::max (1, regs), side=TRUE, fetch=fetch, allot=alloc,
expression=RAISE (expression, t) }
end
| EXCEPT (a, b) => let my I { regs=ra, side=sa, expression=ea, fetch=fa, allot=aa } =
loop a
my I { regs=rb, side=sb, expression=eb, fetch=fb, allot=ab } =
lpsv b
in I { regs=ra, side=sa or sb,
fetch=fa or fb, allot = aa or ab,
expression=EXCEPT (ea, eb) }
end
| WRAP (t, c, e) => let my I { regs, side, expression, fetch, allot } = lpsv e
in I { regs=regs, side=side, fetch=TRUE, allot=alloc,
expression=WRAP (t, c, expression) }
end
| UNWRAP (t, c, e) => let my I { regs, side, expression, fetch, allot } = lpsv e
in I { regs=regs, side=side, fetch=TRUE, allot=alloc,
expression=UNWRAP (t, c, expression) }
end
| _ => bug "unsupported lambda expression in loop"
*/
reorder_via_generalized_sethi_ullman = \\ x = bug "reorder not implemented"; # getexp (loop x)
}; # package generalized_sethi_ullman_reordering
end; # toplevel stipulate