## eliminate-array-bounds-checks-in-anormcode.pkg
#
# "ABCOPT" -- Array Bounds Check Optimization
#
# I can't find the original paper on this,
# but it is probably somewhere in the FLINT papers.
#
# A similar later one is:
#
# ABCD: Eliminating Array Bounds Checks on Demand
# Bodik Gupta Sarkar
# http://cseweb.ucsd.edu/classes/sp00/cse231/ABCD.ps
# Compiled by:
# src/lib/compiler/core.sublib# This is one of the A-Normal Form compiler passes --
# for context see the comments in
#
# src/lib/compiler/back/top/anormcode/anormcode-form.api#
### "The mind is not a vessel to be filled
### but a fire to be kindled."
###
### -- Plutarch
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkgherein
api Eliminate_Array_Bounds_Checks_In_Anormcode {
#
eliminate_array_bounds_checks_in_anormcode
:
acf::Function -> acf::Function;
};
end;
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package asc = anormcode_sequencer_controls; # anormcode_sequencer_controls is from src/lib/compiler/back/top/main/anormcode-sequencer-controls.pkg package hbo = highcode_baseops; # highcode_baseops is from src/lib/compiler/back/top/highcode/highcode-baseops.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package hct = highcode_type; # highcode_type is from src/lib/compiler/back/top/highcode/highcode-type.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package im = int_red_black_map; # int_red_black_map is from src/lib/src/int-red-black-map.pkg package is = int_red_black_set; # int_red_black_set is from src/lib/src/int-red-black-set.pkg package pp = prettyprint_anormcode; # prettyprint_anormcode is from src/lib/compiler/back/top/anormcode/prettyprint-anormcode.pkgherein
package eliminate_array_bounds_checks_in_anormcode
: Eliminate_Array_Bounds_Checks_In_Anormcode # Eliminate_Array_Bounds_Checks_In_Anormcode is from src/lib/compiler/back/top/improve/eliminate-array-bounds-checks-in-anormcode.pkg {
fun bug msg
=
error_message::impossible ("ABCOpt: " + msg);
lvname = *pp::lvar_string;
p_debug = REF FALSE;
say = control_print::say;
fun say_abc s = ();
# (if *ASC::printABC then say s
# else ())
fun debug s = ();
# (if *asc::printABC and *pDebug then
# say s
# else ())
fun print_vals NIL => say "\n";
print_vals (x ! xs) => { pp::print_sval x; say ", "; print_vals xs;};
end;
# We're invoked (only) from:
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg #
fun eliminate_array_bounds_checks_in_anormcode (pgm as (progkind, progname, progargs, progbody))
=
{ lt_len
=
hcf::make_type_uniqtypoid (
hcf::make_arrow_uniqtype (
hcf::fixed_calling_convention,
[hcf::truevoid_uniqtype],
[hcf::int_uniqtype]
)
);
fun cse lmap rmap lambda_expression
=
g lambda_expression
where
fun subst_variable x
=
case (im::get (rmap, x))
#
THE y
=>
{ say_abc ("replacing: " +
(lvname x) +
" with " +
(lvname y) +
"\n");
y;
};
NULL => x;
esac;
fun subst_val (acf::VAR x) => (acf::VAR (subst_variable x));
subst_val x => x;
end;
fun subst_vals vals
=
map subst_val vals;
fun g (acf::BASEOP (p as (d, hbo::VECTOR_LENGTH_IN_SLOTS, lambda_type, types),
[acf::VAR array_variable], dest, body))
=>
case (im::get (lmap, array_variable))
#
THE x => cse lmap (im::set (rmap, dest, x)) body;
#
NULL =>
(acf::BASEOP
(p, [acf::VAR array_variable], dest,
cse (im::set (lmap, array_variable, dest))
rmap body));
esac;
g (acf::RET x)
=>
acf::RET (subst_vals x);
g (acf::LET (vars, lambda_expression, body))
=>
acf::LET (vars, g lambda_expression, g body);
g (acf::MUTUALLY_RECURSIVE_FNS (fundecs, body))
=>
acf::MUTUALLY_RECURSIVE_FNS (map h fundecs, g body);
g (acf::APPLY (v, vs))
=>
acf::APPLY (subst_val v, subst_vals vs);
g (acf::TYPEFUN (tfundec as (tfkind, lv, tvtks, tfnbody), body))
=>
acf::TYPEFUN ((tfkind, lv, tvtks, g tfnbody), g body);
g (acf::APPLY_TYPEFUN (v, types))
=>
acf::APPLY_TYPEFUN (subst_val v, types);
g (acf::SWITCH (v, constructor_api, cel, lexp_opt))
=>
{ fun hh (c, e)
=
(c, g e);
cel' = map hh cel;
fun gg (THE x) => THE (g x);
gg NULL => NULL;
end;
acf::SWITCH (subst_val v, constructor_api, cel', gg lexp_opt);
};
g (acf::CONSTRUCTOR (valcon, types, v, lv, body))
=>
acf::CONSTRUCTOR (valcon, types, subst_val v, lv, g body);
g (acf::RECORD (rk, vals, lv, body))
=>
acf::RECORD (rk, subst_vals vals, lv, g body);
g (acf::GET_FIELD (v, field', lv, body))
=>
acf::GET_FIELD (subst_val v, field', lv, g body);
g (acf::RAISE (v, type))
=>
acf::RAISE (subst_val v, type);
g (acf::EXCEPT (body, v))
=>
acf::EXCEPT (g body, subst_val v);
g (acf::BRANCH (p, vals, body1, body2))
=>
acf::BRANCH (p, subst_vals vals, g body1, g body2);
g (acf::BASEOP (p, vals, lv, body))
=>
acf::BASEOP (p, subst_vals vals, lv, g body);
end
also
fun h (fk, highcode_variable, lvty, body)
=
(fk, highcode_variable, lvty, g body);
end;
fun len_op (src, mm, body)
=
{ say_abc ("hoisting: length of " + (lvname src) + "\n");
case (im::get (mm, src))
#
THE lambda_type
=>
acf::BASEOP((NULL, hbo::VECTOR_LENGTH_IN_SLOTS, lambda_type, []),
[acf::VAR src],
tmp::issue_highcode_codetemp (),
body);
NULL => bug "strange bug!";
esac;
};
agressive_hoist = REF TRUE;
map_union = im::union_with (\\ (a, b) = a);
map_intersect = im::intersect_with (\\ (a, b) = a);
fun remove' (m, k)
=
im::drop (m, k);
fun say_vars NIL => ();
#
say_vars (x ! NIL) => say_abc (lvname x);
say_vars (x ! xs)
=>
{ say_abc (lvname x);
say_abc ", ";
say_vars xs;
};
end;
fun hoist (acf::RET x)
=>
(im::empty, (acf::RET x));
hoist (acf::LET (vars, lambda_expression, body))
=>
{
my (m1, lambda_expression') = hoist lambda_expression;
my (m2, body') = hoist body;
fun ft x = im::contains_key (m2, x);
hlist = list::filter ft vars;
fun h NIL mm b => (mm, b);
h (x ! xs) mm b =>
h xs (remove' (mm, x)) (len_op (x, mm, b));
end;
my (m2', body'') = h hlist m2 body';
(map_union (m1, m2'), acf::LET (vars, lambda_expression', body''));
};
hoist (acf::MUTUALLY_RECURSIVE_FNS (fundecs, body))
=>
{ fun hoist_fundec (fk, lv,
lvtys: List( (tmp::Codetemp, hut::Uniqtypoid) ),
body)
=
{ var_list = map #1 lvtys;
my (m, b) = hoist body;
fun ft x
=
im::contains_key (m, x);
to_hoist = list::filter ft var_list;
fun h mm NIL b
=>
(mm, b);
h mm (v ! vs) b
=>
h (remove' (mm, v)) vs (len_op (v, mm, b));
end;
my (m', body')
=
h m to_hoist b;
/*
sayABC ("List of extern vars in " + (lvname lv) + " (MUTUALLY_RECURSIVE_FNS): [");
sayVars (is::vals_list set);
sayABC ("]\n");
*/
say_abc ("List of hoisted vars in " +
(lvname lv) + " (MUTUALLY_RECURSIVE_FNS): [");
say_vars (to_hoist);
say_abc ("]\n");
(m', (fk, lv, lvtys, body'));
};
# fundec sets and bodys
fsbody = map hoist_fundec fundecs;
fsets = map #1 fsbody;
fbody = map #2 fsbody;
my (bmap, newbody)
=
hoist body;
mmm = fold_forward map_union bmap fsets;
(mmm, acf::MUTUALLY_RECURSIVE_FNS (fbody, newbody));
};
hoist (acf::APPLY x)
=>
(im::empty, acf::APPLY x);
hoist (acf::TYPEFUN (tfundec as (tfkind, lv, tvtks, tfnbody), body))
=>
{ my (mtfn, btfn) = hoist tfnbody;
my (m, b) = hoist body;
(map_union (mtfn, m), acf::TYPEFUN (tfundec, b));
};
hoist (acf::APPLY_TYPEFUN (v, tl))
=>
(im::empty, acf::APPLY_TYPEFUN (v, tl));
# If agressive, use union; otherwise use intersect
# no var defined, so no hoisting
hoist (acf::SWITCH (v, constructor_api, clexps, lambda_expression))
=>
{
lexps = map #2 clexps;
sblist = (map hoist lexps);
maps = map #1 sblist;
bodys = map #2 sblist;
my (def_map, def_body)
=
case lambda_expression
THE l
=>
{ my (m, b) = hoist l;
(THE m, THE b);
};
NULL => (NULL, NULL);
esac;
# Agressive may not always be beneficial
# it's turned off by default
map_oper
=
if *agressive_hoist map_union;
else map_intersect;
fi;
result_set
=
fold_forward
map_oper
(head maps)
(tail maps);
fun helper NIL nil
=>
NIL;
helper ((c, le) ! xs) (le' ! ys)
=>
(c, le') ! (helper xs ys);
helper _ _ => bug "no!!!! help!!!!\n";
end;
result_clexps = helper clexps bodys;
( case def_map
THE m => map_oper (m, result_set);
NULL => result_set;
esac,
acf::SWITCH (v, constructor_api, result_clexps, def_body)
);
};
# There probably isn't anything
# interesting here but:
#
hoist (acf::CONSTRUCTOR (d, tl, v, lv, le))
=>
{ my (m, b) = hoist le;
if (im::contains_key (m, lv))
(remove' (m, lv),
acf::CONSTRUCTOR (d, tl, v, lv, len_op (lv, m, b)));
else
(m, acf::CONSTRUCTOR (d, tl, v, lv, b));
fi;
};
# There probably isn't anything
# interesting here either:
#
hoist (acf::RECORD (rk, vals, lv, le))
=>
{ my (m, b) = hoist le;
if (im::contains_key (m, lv))
(remove' (m, lv),
acf::RECORD (rk, vals, lv, len_op (lv, m, b)));
else
(m, acf::RECORD (rk, vals, lv, b));
fi;
};
hoist (acf::GET_FIELD (v, f, lv, le))
=>
{ (hoist le) -> (m, b);
#
if (im::contains_key (m, lv))
#
(remove' (m, lv),
#
acf::GET_FIELD (v, f, lv, len_op (lv, m, b)));
else
(m, acf::GET_FIELD (v, f, lv, b));
fi;
};
hoist (acf::RAISE (v, ltys))
=>
(im::empty, acf::RAISE (v, ltys));
hoist (acf::EXCEPT (le, v))
=>
{ my (m, b) = hoist le;
(m, acf::EXCEPT (b, v));
};
# We just use the intersection
# of the two branches:
#
hoist (acf::BRANCH (po, vals, le1, le2))
=>
{ my (m1, b1) = hoist le1;
my (m2, b2) = hoist le2;
map_oper
=
*agressive_hoist
?? map_union
:: map_intersect;
/*
sayABC "for this branch: [";
sayVars (is::vals_list (is::union (s1, s2)));
sayABC "]\n";
*/
(map_oper (m1, m2), acf::BRANCH (po, vals, b1, b2));
};
# The use site:
#
hoist (acf::BASEOP (p as (d, hbo::VECTOR_LENGTH_IN_SLOTS, lambda_type, types),
vals, dest, body))
=>
{ my (m, b) = hoist body;
say_abc "got one!\n";
case vals
#
[acf::VAR x]
=>
(im::set (m, x, lambda_type),
acf::BASEOP (p, vals, dest, b));
_ =>
(m, acf::BASEOP (p, vals, dest, b));
esac;
};
# The result of a baseop
# is unlikely to be an rw_vector but:
#
hoist (acf::BASEOP (p, vals, dest, body))
=>
{ my (m, b) = hoist body;
if (im::contains_key (m, dest))
#
(remove' (m, dest),
acf::BASEOP (p, vals, dest, len_op (dest, m, b)));
else
(m, acf::BASEOP (p, vals, dest, b));
fi;
};
end;
fun elim_switches
cmps_vv
cmps_iv
lambda_expression
=
g lambda_expression
where
compare_lambda_types
=
hcf::make_type_uniqtypoid
(hcf::make_arrow_uniqtype (hcf::fixed_calling_convention,
[hcf::int_uniqtype, hcf::int_uniqtype],
[hcf::truevoid_uniqtype]));
fun g (acf::LET ([lv],
br as
(acf::BRANCH (p as (NULL,
hbo::COMPARE { op=>hbo::LTU, kind_and_size=>hbo::UNT 31 },
compare_lambda_types,
NIL),
[val1, val2],
tbr,
# just to make sure it's an ABC
fbr as
(acf::RECORD
(_, _, _,
acf::RECORD
(_, _, _,
acf::BASEOP
((_, hbo::WRAP, _, _), _, _,
acf::BASEOP
((_, hbo::MARK_EXCEPTION_WITH_STRING, _, _), _, _,
acf::RAISE _))))))),
body))
=>
{
fun decide (acf::VAR v1, acf::VAR v2)
=>
{
fun lookup (v1, v2)
=
{ say_abc ("cmp: looking for " + (lvname v1) +
" and " + (lvname v2) + "\n");
case (im::get (cmps_vv, v2))
THE set => is::member (set, v1);
NULL => FALSE;
esac;
};
fun add (v1, v2)
=
{ say_abc ("cmp: entering " + (lvname v1) +
" and " + (lvname v2) + "\n");
case (im::get (cmps_vv, v2))
THE set
=>
im::set (cmps_vv, v2, is::add (set, v1));
NULL
=>
im::set (cmps_vv, v2, is::singleton v1);
esac;
};
if (lookup (v1, v2))
(TRUE, cmps_vv, cmps_iv);
else (FALSE, add (v1, v2), cmps_iv);
fi;
};
decide (acf::INT n, acf::VAR v)
=>
{ fun lookup (n, v)
=
{ say_abc ("looking for (" +
(int::to_string n) + "<" +
(lvname v) + ")\n");
if (n == 0)
TRUE;
else
case (im::get (cmps_iv, v))
THE x => (n <= x);
NULL => FALSE;
esac;
fi;
};
fun add (n, v)
=
im::set (cmps_iv, v, n);
if (lookup (n, v) ) (TRUE, cmps_vv, cmps_iv);
else (FALSE, cmps_vv, add (n, v)); fi;
};
decide _
=>
(FALSE, cmps_vv, cmps_iv);
end;
my (to_elim, new_vv, new_iv)
=
decide (val1, val2);
if to_elim
#
case tbr
#
acf::BASEOP (p, vals, lv1, acf::RET [acf::VAR lv2])
=>
if (lv1 == lv2) acf::BASEOP (p, vals, lv, g body);
else acf::LET ([lv], g tbr, g body);
fi;
_ => acf::LET ([lv], g tbr, g body);
esac;
else
(acf::LET
( [lv],
acf::BRANCH
( p,
[val1, val2],
elim_switches new_vv new_iv tbr,
g fbr
),
elim_switches new_vv new_iv body
)
);
fi;
};
g (acf::RET x)
=>
acf::RET x;
g (acf::LET (vars, lambda_expression, body))
=>
acf::LET (vars, g lambda_expression, g body);
g (acf::MUTUALLY_RECURSIVE_FNS (fundecs, body))
=>
acf::MUTUALLY_RECURSIVE_FNS (map h fundecs, g body);
g (acf::APPLY (v, vs))
=>
acf::APPLY (v, vs);
g (acf::TYPEFUN (tfundec, body))
=>
acf::TYPEFUN (tfundec, g body);
g (acf::APPLY_TYPEFUN (v, types))
=>
acf::APPLY_TYPEFUN (v, types);
g (acf::SWITCH (v, constructor_api, cel, lexpopt))
=>
{ fun hh (c, e) = (c, g e);
cel' = map hh cel;
fun gg (THE x) => THE (g x);
gg NULL => NULL;
end;
acf::SWITCH (v, constructor_api, cel', gg lexpopt);
};
g (acf::CONSTRUCTOR (valcon, types, v, lv, body))
=>
acf::CONSTRUCTOR (valcon, types, v, lv, g body);
g (acf::RECORD (rk, vals, lv, body))
=>
acf::RECORD (rk, vals, lv, g body);
g (acf::GET_FIELD (v, field', lv, body))
=>
acf::GET_FIELD (v, field', lv, g body);
g (acf::RAISE (v, type))
=>
acf::RAISE (v, type);
g (acf::EXCEPT (body, v))
=>
acf::EXCEPT (g body, v);
g (acf::BRANCH (p, vals, body1, body2))
=>
acf::BRANCH (p, vals, g body1, g body2);
g (acf::BASEOP (p, vals, lv, body))
=>
acf::BASEOP (p, vals, lv, g body);
end
also
fun h (fk, highcode_variable, lvty, body)
=
(fk, highcode_variable, lvty, g body);
end;
my (s, hoisted) = hoist progbody;
csed = cse im::empty im::empty hoisted;
elimed = elim_switches im::empty im::empty csed;
# optimized = (progkind, progname, progargs, elimed)
optimized = (progkind, progname, progargs, elimed);
# some advertising stuff!
# if *asc::printABC then
# (say "\nhello! This is ABCOpt!\n";
#
# (say "[Before ABCOpt...]\n\n";
# pp::printProg pgm);
#
# (say "\n[After Hoisting...]\n\n";
# pp::printProg (progkind, progname, progargs, hoisted));
#
# (say "\n[After CSE...]\n\n";
# pp::printProg (progkind, progname, progargs, csed));
#
# (say "\n[After Elim...]\n\n";
# pp::printProg (progkind, progname, progargs, elimed));
#
# say "\nbyebye! i'm done!\n\n")
# fi;
# Can eventually be removed after testing
/*
case (is::vals_list s)
#
NIL => ();
_ => bug "should be NIL!!!";
esac;
*/
optimized;
};
};
end;
### "You know what I like? I like that brief idyllic
### moment between the invention of the flush toilet
### and nuclear armageddon, when civilization seems
### sane and beneficent and eternal."