## loopify-anormcode.pkg
## monnier@cs.yale.edu
# 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#
# "Look for functions that call themselves, wrap them
# up in a pre-header, eliminate arguments that stay
# constant through the loop, and check whether all the
# recursive calls are in tail position, in which case
# the loop is marked as being a 'while' loop. The
# corresponding optimization in the old optimizer
# was done in 'expand'."
#
# [...]
#
# "'loopify_anormcode' was moved out of
# 'improve_mutually_recursive_anormcode_functions' because it
# does not need to be run as often, but it requires two
# passes (a first pass that collects information and
# a second that does the code transformation) whereas
# 'improve_mutually_recursive_anormcode_functions' is implemented
# in a single pass."
#
# -- Principled Compilation and Scavenging
# Stefan Monnier, 2003 [PhD Thesis, U Montreal]
# http://www.iro.umontreal.ca/~monnier/master.ps.gz
#
# See also:
#
# Loop Headers in \-calculus or FPS
# Andrew W Appel
# 1994, 6p
# http://citeseer.ist.psu.edu/appel94loop.html
# One reference for src/lib/compiler/back/top/improve-nextcode/do-nextcode-inlining-g.pkg### "There is no monument dedicated
### to the memory of a committee."
###
### -- Lester J. Pourciau
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkgherein
api Loopify_Anormcode {
#
loopify_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 hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.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 no = null_or; # null_or is from src/lib/std/src/null-or.pkg package ou = opt_utils; # opt_utils is from src/lib/compiler/back/top/improve/optutils.pkgherein
package loopify_anormcode
: Loopify_Anormcode # Loopify_Anormcode is from src/lib/compiler/back/top/improve/loopify-anormcode.pkg {
say = control_print::say;
fun bug msg = error_message::impossible ("Loopify_Anormcode: " + msg);
cplv = tmp::clone_highcode_codetemp;
Al = List( List( acf::Value ) );
Info = INFO { tails: Ref( Al ),
calls: Ref( Al ),
icalls: Ref( Al ),
tcp: Ref( Bool ),
parent: tmp::Codetemp
};
exception NOT_FOUND;
fun loopify_anormcode (program as (progkind, progname, progargs, progbody))
=
{ my m: iht::Hashtable( Info )
=
iht::make_hashtable { size_hint => 128, not_found_exception => NOT_FOUND };
# tails: number of tail-recursive calls
# calls: number of other calls
# icalls: non-tail self-recursive subset of `calls'
# tcp: always called in tail-position
# parent: enclosing function
#
fun new (f, known, parent)
=
info
where
info = INFO { tails=>REF [],
calls=>REF [],
icalls=>REF [],
tcp=>REF known,
parent
};
iht::set m (f, info);
end;
fun get f
=
iht::get m f;
# collect tries to determine what calls are tail recursive.
# If a function f is always called in tail position in a function g,
# then all tail calls to g from f are indeed tail recursive.
# tfs: we are currently in tail position relative to those functions
# p: englobing function
fun collect p tfs le
=
{
loop = collect p tfs;
case le
acf::RET _ => ();
acf::LET(_, body, le)
=>
{ collect p is::empty body;
loop le;
};
acf::MUTUALLY_RECURSIVE_FNS([( { loop_info=>(NULL | THE(_, acf::TAIL_RECURSIVE_LOOP)), private, ... }, f, _, body)], le)
=>
{ my INFO { tcp, calls, icalls, ... } = new (f, private, p);
loop le;
necalls = length *calls;
collect f (if *tcp is::add (tfs, f); else is::singleton f;fi) body;
icalls := list::take_n (*calls, length *calls - necalls);
};
acf::MUTUALLY_RECURSIVE_FNS (fdecs, le)
=>
{ # Create the new entries in the map
#
fs = map (\\ (fk as { private, ... }, f, _, body)
=
(fk, f, body, new (f, FALSE, p))
)
fdecs;
fun cfun ( { loop_info, ... }: acf::Function_Notes, f, body, INFO { calls, icalls, ... } )
=
{ necalls = length *calls;
collect f (is::singleton f) body;
icalls := list::take_n (*calls, length *calls - necalls);
};
loop le;
apply cfun fs;
};
acf::APPLY (acf::VAR f, vs)
=>
{ my INFO { tails, calls, tcp, parent, ... } = get f;
if (is::member (tfs, f) )
tails := vs ! *tails;
else
calls := vs ! *calls;
if (not (is::member (tfs, parent))) tcp := FALSE; fi;
fi;
}
except
NOT_FOUND = ();
acf::TYPEFUN((_, _, _, body), le)
=>
{ collect p is::empty body;
loop le;
};
acf::APPLY_TYPEFUN _
=>
();
acf::SWITCH (v, ac, arms, def)
=>
{ fun carm (_, body)
=
loop body;
apply carm arms;
case def
THE le => loop le;
_ => ();
esac;
};
( acf::CONSTRUCTOR(_, _, _, _, le)
| acf::RECORD (_, _, _, le)
| acf::GET_FIELD (_, _, _, le)
| acf::BASEOP (_, _, _, le)
)
=>
loop le;
acf::RAISE _ => ();
acf::EXCEPT (le, v) => collect p is::empty le;
acf::BRANCH(_, _, le1, le2) => { loop le1; loop le2;};
acf::APPLY _ => bug "weird acf::APPLY in collect";
esac;
};
# (intended as a `fold_backward' argument).
# `filt' is the bool list indicating if the arg is kept
# `fn' is the list of arguments for the MUTUALLY_RECURSIVE_FNS
# `call' is the list of arguments for the APPLY
# `free' is the list of resulting free variables
#
fun drop_invariant ((v, t), actuals, (filt, fn, call, free))
=
if (*asc::dropinvariant and list::all (\\ a => acf::VAR v == a; end ) actuals )
#
(FALSE ! filt, fn, call, (v, t) ! free); # Drop the argument: the free list is unchanged.
else
# Keep the argument:
# Create a new var (used in the call)
# which will replace the old
# in the free vars:
#
nv = cplv v;
(TRUE ! filt, (v, t) ! fn, (acf::VAR nv) ! call, (nv, t) ! free);
fi;
# m: intmap( Int ) renaming for function calls
# tf: List( Int, Int ) the current functions (if any) and their tail version
# le: you get the idea
#
fun lambda_expression m tfs le
=
{
loop = lambda_expression m tfs;
case le
acf::RET _
=>
le;
acf::LET (lvs, body, le)
=>
acf::LET (lvs, lambda_expression m [] body, loop le);
acf::MUTUALLY_RECURSIVE_FNS (fdecs, le)
=>
acf::MUTUALLY_RECURSIVE_FNS (map cfun fdecs, loop le)
where
fun cfun
( fk: acf::Function_Notes as { loop_info=>THE (ltys, acf::OTHER_LOOP), call_as, ... },
f,
args,
body
)
=>
{ (get f) -> INFO { tcp=>REF tcp, icalls=>REF icalls, tails=>REF tails, ... };
tfs = if tcp tfs;
else [];
fi;
# optional_nextcode_improvers uses the following condition:
# escape = 0 and *unroll_call > 0
# and (*call - *unroll_call > 1
# or list::exists (\\ t=t) inv)
# `escape = 0': I don't quite see the need for it, though it
# probably won't change much since split_known_escaping_functions should have
# made "everything" known already.
# `!call - *unroll_call > 1 or list::exists (\\ t=t) inv)':
# loopification is only useful if there is more than one
# external call or if there are loop invariants.
# Note that we deal with invariants elsewhere, so it's
# not a good reason to loopify here.
# *** rationale behind the restrictions: ***
# `icallnb = 0': loopification is pointless and will be
# undone by fcontract.
# `c::callnb fi <= icallnb + 1': if there's only one external
# call, loopification will probably (?) not be of much use
# and the same benefit would be had by just moving f.
#
if (null icalls and null tails)
#
(fk, f, args, lambda_expression m tfs body);
else
call_as'
=
case call_as
#
( acf::CALL_AS_GENERIC_PACKAGE
| acf::CALL_AS_FUNCTION hut::FIXED_CALLING_CONVENTION
)
=>
call_as;
acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION { arg_is_raw => f1, body_is_raw => f2 }) =>
acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION { arg_is_raw => TRUE, body_is_raw => f2 });
esac;
# Figure out which arguments of the tail loop
# are invariants and create the corresponding
# function args, call args, filter
# function for the actual calls, ...
#
my (tfs', atfun, atcall, args, ft)
=
if (null tails )
(tfs,[],[], args, f);
else
ft = cplv f;
actuals = ou::transpose tails;
my (fcall, afun, acall, afree) =
paired_lists::fold_backward drop_invariant
([],[],[],[])
(args, actuals);
( (f, ft, fcall) ! tfs,
afun, acall, afree, ft);
fi;
# Do the same for the non-tail loop.
#
my (nm, alfun, alcall, args, fl)
=
if (null icalls )
(m,[],[], args, f);
else
fl = cplv f;
actuals = ou::transpose icalls;
my (fcall, afun, acall, afree)
=
paired_lists::fold_backward drop_invariant
([],[],[],[])
(args, actuals);
(im::set (m, f, (fl, fcall)),
afun, acall, afree, fl);
fi;
# Make the new body:
#
nbody = lambda_expression nm tfs' body;
# Wrap into a tail loop if necessary:
#
nbody
=
if (null tails)
nbody;
else
acf::MUTUALLY_RECURSIVE_FNS([( { loop_info=>THE (ltys, acf::TAIL_RECURSIVE_LOOP),
private=>TRUE, inlining_hint=>acf::INLINE_IF_SIZE_SAFE,
call_as=>call_as'}, ft, atfun,
nbody)],
acf::APPLY (acf::VAR ft, atcall));
fi;
# Wrap into a non-tail
# loop if necessary.
#
nbody
=
if (null icalls)
nbody;
else
acf::MUTUALLY_RECURSIVE_FNS([( { loop_info=>THE (ltys, acf::PREHEADER_WRAPPED_LOOP),
private=>TRUE, inlining_hint=>acf::INLINE_IF_SIZE_SAFE,
call_as=>call_as'}, fl, alfun,
nbody)],
acf::APPLY (acf::VAR fl, alcall));
fi;
(fk, f, args, nbody);
fi;
};
cfun (fk as { inlining_hint=>acf::INLINE_ONCE_WITHIN_ITSELF, loop_info=>THE _, ... }, f, args, body)
=>
{ (get f) -> INFO { tcp=>REF tcp, ... };
#
(fk, f, args, lambda_expression m (if tcp tfs; else [];fi) body);
};
cfun (fk, f, args, body)
=>
{ (get f) -> INFO { tcp=>REF tcp, ... };
#
(fk, f, args, lambda_expression m (if tcp tfs; else [];fi) body);
};
end; # fun cfun
end;
acf::APPLY (acf::VAR f, vs)
=>
case (list::find (\\ (ft, ft', filt) => ft == f; end ) tfs)
THE (ft, ft', filt)
=>
acf::APPLY (acf::VAR ft', ou::filter filt vs);
NULL
=>
case (im::get (m, f) )
THE (fl, filt)
=>
acf::APPLY (acf::VAR fl, ou::filter filt vs);
NULL => le;
esac;
esac;
acf::TYPEFUN((tfk, f, args, body), le)
=>
acf::TYPEFUN((tfk, f, args, loop body), loop le);
acf::APPLY_TYPEFUN (f, types)
=>
le;
acf::SWITCH (v, ac, arms, def)
=>
acf::SWITCH (v, ac, map carm arms, no::map loop def)
where
fun carm (con, le)
=
(con, loop le);
end;
acf::CONSTRUCTOR (dc, types, v, lv, le) => acf::CONSTRUCTOR (dc, types, v, lv, loop le);
acf::RECORD (rk, vs, lv, le) => acf::RECORD (rk, vs, lv, loop le);
acf::GET_FIELD (v, i, lv, le) => acf::GET_FIELD (v, i, lv, loop le);
acf::RAISE (v, ltys) => le;
acf::EXCEPT (le, v) => acf::EXCEPT (lambda_expression m [] le, v);
acf::BRANCH (po, vs, le1, le2) => acf::BRANCH (po, vs, loop le1, loop le2);
acf::BASEOP (po, vs, lv, le) => acf::BASEOP (po, vs, lv, loop le);
acf::APPLY _ => bug "unexpected APPLY";
esac;
}; # fun lambda_expression
collect progname is::empty progbody;
( progkind,
progname,
progargs,
lambda_expression im::empty [] progbody
);
};
};
end;