## improve-mutually-recursive-anormcode-functions.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#
# "Decide which functions are candidates for inlining,
# rewrite curried functions like 'uncurry' did in the
# old optimizer, and break up groups of apparently
# mutually-recursive functions into smaller subgroups.
#
# "Other than introducing loop pre-headers, done in
# 'loopify_anormcode', and deciding which function calls to
# inline and to perform the inlining itself, done in
# 'fcontract', this phase corresponds to the 'expand'
# phase of the old optimizer."
#
# [...]
#
# "The reason to move the actual inlining out of
# 'improve_mutually_recursive_anormcode_functions' and
# into 'fcontract' was so that cascading inlining
# could take place. It also simplified
# 'improve_mutually_recursive_anormcode_functions' slightly.
# Another reason was that 'split' requires that the choice
# of inlining candidates be separate from the inlining itself."
#
# -- Principled Compilation and Scavenging
# Stefan Monnier, 2003 [PhD Thesis, U Montreal]
# http://www.iro.umontreal.ca/~monnier/master.ps.gz
# This module does various MUTUALLY_RECURSIVE_FNS-related transformations:
# - MUTUALLY_RECURSIVE_FNSes are split into their strongly-connected components
# - small non-recursive functions are marked inlinable
# - curried functions are uncurried
### "Good engineering doesn't consist
### of random acts of heroism."
###
### -- Harry Robinson
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkgherein
api Improve_Mutually_Recursive_Anormcode_Functions {
#
improve_mutually_recursive_anormcode_functions
:
acf::Function -> acf::Function;
};
end;
# Maybe later:
# - hoisting of inner functions out of their englobing function
# so that the outer function becomes smaller, giving more opportunity
# for inlining.
# - eta expand escaping functions
# - loop-preheader introduction
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 is = int_red_black_set; # int_red_black_set is from src/lib/src/int-red-black-set.pkg package im = int_red_black_map; # int_red_black_map is from src/lib/src/int-red-black-map.pkg package pp = prettyprint_anormcode; # prettyprint_anormcode is from src/lib/compiler/back/top/anormcode/prettyprint-anormcode.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package ou = opt_utils; # opt_utils is from src/lib/compiler/back/top/improve/optutils.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkgherein
# Improve_Mutually_Recursive_Anormcode_Functions is from src/lib/compiler/back/top/improve/improve-mutually-recursive-anormcode-functions.pkg package improve_mutually_recursive_anormcode_functions: Improve_Mutually_Recursive_Anormcode_Functions {
#
say = control_print::say;
#
fun bug msg
=
error_message::impossible ("improve_mutually_recursive_anormcode_functions: " + msg);
#
fun buglexp (msg, le) = { say "\n"; pp::print_lexp le; say " "; bug msg;};
fun bugval (msg, v) = { say "\n"; pp::print_sval v; say " "; bug msg;};
#
fun assert p
=
if (not p)
bug ("assertion failed");
fi;
#
fun bugsay s
=
say ("!*!*! improve_mutually_recursive_anormcode_functions: " + s + " !*!*!\n");
cplv = tmp::clone_highcode_codetemp;
# To limit the amount of uncurrying:
#
maxargs = asc::maxargs;
package scc_node
=
package {
Key = tmp::Codetemp; # In practice Codetemp == Int.
compare = int::compare;
};
package scc
=
digraph_strongly_connected_components_g(
scc_node
);
Info = FUN Ref( Int )
| ARG (Int, Ref ((Int, Int)))
;
# float_expression: Int REF intmapf -> Lambda_Expression) -> (Int * intset * Lambda_Expression)
# The intmap contains refs to counters. The meaning of the counters
# is slightly overloaded:
# - if the counter is negative, it means the Variable
# is a locally known function and the counter's absolute value denotes
# the number of calls (off by one to make sure it's always negative).
# - else, it indicates that the Variable is a
# function argument and the absolute value is a (fuzzily defined) measure
# of the reduction in code size/speed that would result from knowing
# its value (might be used to decide whether or not duplicating code is
# desirable at a specific call site).
# The three subparts returned are:
# - the size of Lambda_Expression
# - the set of freevariables of Lambda_Expression (plus the ones passed as arguments
# which are assumed to be the freevars of the fate of Lambda_Expression)
# - a new Lambda_Expression with MUTUALLY_RECURSIVE_FNSes rewritten.
#
fun float_expression mf depth lambda_expression
=
{ loop = float_expression mf depth;
#
fun lookup (acf::VAR lv) => im::get (mf, lv);
lookup _ => NULL;
end;
#
fun s_rmv (x, s)
=
is::drop (s, x);
#
fun addv (s, acf::VAR lv) => is::add (s, lv);
addv (s, _ ) => s;
end;
#
fun addvs (s, vs) = fold_forward (\\ (v, s) = addv (s, v)) s vs;
fun rmvs (s, lvs) = fold_forward (\\ (l, s) = s_rmv (l, s)) s lvs;
# Look for free vars in the baseop descriptor.
# This is normally unnecessary since these are special vars anyway
#
fun fpo (fv, (NULL: Null_Or( acf::Dictionary ), po, lambda_type, types))
=>
fv;
fpo (fv, (THE { default, table }, po, lambda_type, types))
=>
addvs (addv (fv, acf::VAR default), map (acf::VAR o #2) table);
end;
# Look for free vars in the
# baseop descriptor.
#
# This is normally unnecessary since
# these are exception vars anyway:
#
fun fdcon (fv, (s, varhome::EXCEPTION (varhome::HIGHCODE_VARIABLE lv), lambda_type))
=>
addv (fv, acf::VAR lv);
fdcon (fv, _)
=>
fv;
end;
# Recognize the curried essence of a function.
# - hd: fkind Null_Or identifies the head of the curried function
# - na: Int gives the number of args still allowed
#
fun curry (hd, na)
(le as acf::MUTUALLY_RECURSIVE_FNS([(fk as { inlining_hint => acf::INLINE_IF_SIZE_SAFE, ... }, f, args, body)], acf::RET [acf::VAR lv]))
=>
if (lv == f and na >= length(args))
#
case (hd, fk)
#
# Recursive functions are only accepted for uncurrying
# if they are the head of the function or if the head
# is already recursive
( (THE { loop_info=>NULL, ... },{ loop_info=>THE _, ... } )
| (THE { call_as=>acf::CALL_AS_GENERIC_PACKAGE, ... },{ call_as=>acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION _), ... } )
| (THE { call_as=>acf::CALL_AS_FUNCTION _, ... },{ call_as=>acf::CALL_AS_GENERIC_PACKAGE, ... } )
)
=>
([], le);
_ =>
{ my (funs, body)
=
curry ( case hd
#
NULL => THE fk;
_ => hd;
esac,
na - (length args)
)
body;
((fk, f, args) ! funs, body);
};
esac;
else
# this "never" occurs, but dead-code removal is not bullet-proof
([], le);
fi;
curry _ le => ([], le);
end;
exception UNCURRYABLE;
# Do the actual uncurrying:
#
fun uncurry (args as (fk, f, fargs) ! _ ! _, body)
=>
{ f' = cplv f; # the new fun name
# Find the rtys of
# the uncurried function:
#
fun getrtypes (( { loop_info=>THE (rtys, _), ... }: acf::Function_Notes, _, _), _)
=>
THE rtys;
getrtypes ((_, _, _), rtys)
=>
null_or::map
#
\\ [lambda_type] => #2 (hcf::ltd_fkfun lambda_type);
_ => bug "strange loop_info";
end
#
rtys;
end;
# Create the new fkinds:
#
ncconv
=
case (.call_as (#1 (head args)))
#
acf::CALL_AS_GENERIC_PACKAGE
=>
acf::CALL_AS_GENERIC_PACKAGE;
_ =>
case (.call_as (#1 (list::last args)))
#
acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION { body_is_raw, ... }) =>
acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION { body_is_raw, arg_is_raw => TRUE });
call_as => call_as;
esac;
esac;
my (nfk, nfk')
=
ou::fk_wrap (fk, fold_forward getrtypes NULL args);
nfk' = { inlining_hint => nfk'.inlining_hint,
loop_info => nfk'.loop_info,
private => nfk'.private,
call_as => ncconv
};
# funarg renaming
#
fun newargs fargs
=
map (\\ (a, t) = (cplv a, t))
fargs;
# Create (curried) wrappers to be inlined
#
fun recurry ([], args)
=>
acf::APPLY (acf::VAR f', map (acf::VAR o #1) args);
recurry (( { inlining_hint, loop_info, private, call_as }, f, fargs) ! rest, args)
=>
{ fk = { inlining_hint => acf::INLINE_WHENEVER_POSSIBLE,
loop_info => NULL,
private,
call_as
};
nfargs = newargs fargs;
g = cplv f';
acf::MUTUALLY_RECURSIVE_FNS([(fk, g, nfargs, recurry (rest, args @ nfargs))],
acf::RET [acf::VAR g]);
};
end;
# Build the new f fundec
#
nfargs = newargs fargs;
nf = (nfk, f, nfargs, recurry (tail args, nfargs));
# Make up the body of the uncurried function (creating
# dummy wrappers for the intermediate functions that are now
# useless).
# Intermediate functions that were not marked as recursive
# cannot appear in the body, so we don't need to build them.
# Note that we can't just rely on dead-code elimination to remove
# them because we may not be able to create them correctly with
# the limited type information gleaned in this phase.
#
fun uncurry' ([], args)
=>
body;
uncurry' ((fk, f, fargs) ! rest, args)
=>
{ le = uncurry'(rest, args @ fargs);
case fk
{ loop_info => THE _,
call_as,
private,
inlining_hint
}
=>
{ nfargs = newargs fargs;
fk = { loop_info => NULL,
inlining_hint => acf::INLINE_WHENEVER_POSSIBLE,
private,
call_as
};
acf::MUTUALLY_RECURSIVE_FNS
( [ ( fk, f, nfargs,
recurry (rest, args @ nfargs)
)
],
le
);
};
_ => le;
esac;
};
end;
# the new f' fundec
#
nfbody' = uncurry' (tail args, fargs);
nf' = (nfk', f', fold_backward (@) [] (map #3 args), nfbody');
(nf, nf');
};
uncurry (_, body)
=>
bug "uncurrying a non-curried function";
end;
case lambda_expression
#
acf::RET vs
=>
(0, addvs (is::empty, vs), lambda_expression);
acf::LET (lvs, body, le)
=>
{ my (s2, fvl, nle ) = loop le;
my (s1, fvb, nbody) = loop body;
( s1 + s2,
is::union (rmvs (fvl, lvs), fvb),
acf::LET (lvs, nbody, nle)
);
};
acf::MUTUALLY_RECURSIVE_FNS (fdecs, le)
=>
{ # Set of funs defined by
# the MUTUALLY_RECURSIVE_FNS
#
funs = is::add_list (is::empty, map #2 fdecs);
# Create call-counters for
# each fun and add them to fm
#
my (fs, mf)
=
fold_forward
(\\ ((fk, f, args, body), (fs, mf))
=
{ c = REF 0;
((fk, f, args, body, c) ! fs,
im::set (mf, f, FUN c));
}
)
([], mf)
fdecs;
# Process each fun:
#
fun ffun (fdec as (fk as { loop_info, ... }: acf::Function_Notes, f, args, body, cf),
(s, fv, funs, m))
=
case (curry (NULL,*maxargs)
(acf::MUTUALLY_RECURSIVE_FNS([(fk, f, args, body)], acf::RET [acf::VAR f]))
)
(args as _ ! _ ! _, body) # Curried function
=>
{ my ((fk, f, fargs, fbody), (fk', f', fargs', fbody'))
=
uncurry (args, body);
# Add the wrapper function:
#
cs = map (\\ _ = REF (0, 0))
fargs;
nm = im::set (m, f,
([f'], 1, fk, fargs, fbody, cf, cs));
# Now retry ffun with the uncurried function:
#
ffun((fk', f', fargs', fbody', REF 1),
(s+1, fv, is::add (funs, f'), nm));
};
_ => # non-curried function
{ newdepth
=
case loop_info
#
THE (_, (acf::TAIL_RECURSIVE_LOOP | acf::PREHEADER_WRAPPED_LOOP))
=>
depth + 1;
_ => depth;
esac;
my (mf, cs)
=
fold_backward
(\\ ((v, t), (m, cs))
=
{ c = REF (0, 0);
(im::set (m, v, ARG (newdepth, c)),
c ! cs);
}
)
(mf,[])
args;
my (fs, ffv, body)
=
float_expression mf newdepth body;
ffv = rmvs (ffv, map #1 args); # fun's freevars
# Set of rec funs REF'ed
#
ifv = is::intersection (ffv, funs);
(fs + s, is::union (ffv, fv), funs,
im::set (m, f,
(is::vals_list ifv, fs, fk, args, body, cf, cs)));
};
esac;
# Process the main lambda_expression and
# make it into a dummy function.
#
# The computation of the freevars
# is a little sloppy since `fv'
# includes freevars of the fate,
# but the uniqueness of varnames ensures
# that is::inter (fv, funs) gives the
# correct result nonetheless.
#
(float_expression mf depth le)
->
(s, fv, le);
lename = tmp::issue_highcode_codetemp ();
m = im::set
( im::empty,
lename,
( is::vals_list (is::intersection (fv, funs)),
0,
{ inlining_hint => acf::INLINE_IF_SIZE_SAFE,
loop_info => NULL,
private => TRUE,
call_as => acf::CALL_AS_GENERIC_PACKAGE
},
[],
le,
REF 0,
[]
) );
# Process the functions,
# collecting them in map m:
#
my (s, fv, funs, m)
=
fold_forward ffun (s, fv, funs, m) fs;
# Find strongly connected components:
#
top
=
scc::topological_order
{ root => lename,
follow => (\\ n = #1 (null_or::the (im::get (m, n))))
}
except
x = { bug "top: follow";
raise exception x;
};
# Turn them back into highcode code:
#
fun scc_simple f (_, s,{ loop_info, call_as, private, inlining_hint }, args, body, cf, cs)
=
{ # Small functions inlining heuristic:
#
ilthreshold = *asc::inline_threshold + (length args);
ilh = if (inlining_hint == acf::INLINE_WHENEVER_POSSIBLE)
#
inlining_hint;
# else if s < ilthreshold then acf::INLINE_WHENEVER_POSSIBLE
else
cs = map
(\\ REF (sp, ti) = sp + ti / 2)
cs;
s' = fold_forward (+) 0 cs;
if (s < 2*s' + ilthreshold)
#
# say((Collect::LVarString f) +
# " { " + (int::to_string *cf) +
# " } = acf::INLINE_MAYBE " +
# (int::to_string (s-ilthreshold)) +
# (fold_forward (\\ (i, s) => s + " " +
# (int::to_string i))
# "" cs) + "\n");
acf::INLINE_MAYBE (s-ilthreshold, cs);
else
inlining_hint;
fi;
fi;
fk = { loop_info=>NULL, inlining_hint=>ilh, private, call_as };
(fk, f, args, body);
};
#
fun scc_rec f (_, s, fk as { loop_info, call_as, private, inlining_hint }, args, body, cf, cs)
=
{ fk' =
# Check for unroll opportunities.
# This heuristic is pretty bad since it doesn't
# take the number of rec-calls into account: XXX BUGGO FIXME
#
case (loop_info, inlining_hint)
#
(THE(_, (acf::PREHEADER_WRAPPED_LOOP|acf::TAIL_RECURSIVE_LOOP)), acf::INLINE_IF_SIZE_SAFE)
=>
if (s < *asc::unroll_threshold)
#
{ inlining_hint => acf::INLINE_ONCE_WITHIN_ITSELF,
loop_info,
call_as,
private
};
else
fk;
fi;
_ => fk;
esac;
(fk, f, args, body);
};
#
fun sccconvert (scc::SIMPLE f, le)
=>
acf::MUTUALLY_RECURSIVE_FNS([scc_simple f (null_or::the (im::get (m, f)))], le);
sccconvert (scc::RECURSIVE fs, le)
=>
acf::MUTUALLY_RECURSIVE_FNS (map (\\ f => scc_rec f (null_or::the (im::get (m, f))); end ) fs, le);
end;
case top
(scc::SIMPLE f) ! sccs
=>
{ if (f != lename) bugsay "f != lename"; fi;
( s,
is::difference (fv, funs),
fold_forward sccconvert le sccs
);
};
(scc::RECURSIVE _) ! _
=>
bug "recursive main body in SCC ?!?!?";
[] =>
bug "SCC going crazy";
esac;
};
acf::APPLY (acf::VAR f, args)
=>
# For known functions, increase
# the counter and make the call
# a bit cheaper:
#
{ scall = case (im::get (mf, f))
#
THE (FUN (fc as REF c))
=>
{ fc := c + 1;
1;
};
THE (ARG (d, ac as REF (sp, ti)))
=>
{ ac := (4 + sp, ou::pow2 (depth - d) * 30 + ti);
5;
};
NULL => 5;
esac;
(scall + (length args), addvs (is::singleton f, args), lambda_expression);
};
acf::TYPEFUN ((tfk, f, args, body), le)
=>
{ my (se, fve, le) = loop le;
my (sb, fvb, body) = loop body;
(sb + se, is::union (s_rmv (f, fve), fvb),
acf::TYPEFUN((tfk, f, args, body), le));
};
acf::APPLY_TYPEFUN (acf::VAR f, args)
=>
# The cost of APPLY_TYPEFUN is kinda hard to estimate.
# It can be very cheap, and just return a function,
# or it might do all kinds of wrapping but we have
# almost no information on which to base our choice.
#
# We opted for cheap here, to try to inline them more
# (they might become cheaper once inlined):
#
(3, is::singleton f, lambda_expression);
acf::SWITCH (v, ac, arms, def)
=>
{ fun farm (valcon as acf::VAL_CASETAG (dc, _, lv), le)
=>
# The naming might end up costly,
# but we count it as 1
#
{ my (s, fv, le) = loop le;
(1+s, fdcon (s_rmv (lv, fv), dc), (valcon, le));
};
farm (dc, le)
=>
{ my (s, fv, le) = loop le;
(s, fv, (dc, le));
};
end;
narms = length arms;
my (s, smax, fv, arms)
=
fold_backward
(\\ ((s1, fv1, arm), (s2, smax, fv2, arms))
=
(s1+s2, int::max (s1, smax), is::union (fv1, fv2), arm ! arms)
)
(narms, 0, is::empty, [])
(map farm arms);
case (lookup v)
#
THE (ARG (d, ac as REF (sp, ti)))
=>
ac := (sp + s - smax + narms, ou::pow2 (depth - d) * 2 + ti);
_ => ();
esac;
case def
#
NULL => (s, fv, acf::SWITCH (v, ac, arms, NULL));
#
THE le
=>
{ my (sd, fvd, le)
=
loop le;
( s + sd,
is::union (fv, fvd),
acf::SWITCH (v, ac, arms, THE le)
);
};
esac;
};
acf::CONSTRUCTOR (dc, types, v, lv, le)
=>
{ my (s, fv, le) = loop le;
(2+s, fdcon (addv (s_rmv (lv, fv), v), dc), acf::CONSTRUCTOR (dc, types, v, lv, le));
};
acf::RECORD (rk, vs, lv, le)
=>
{ (loop le) -> (s, fv, le);
((length vs)+s, addvs (s_rmv (lv, fv), vs), acf::RECORD (rk, vs, lv, le));
};
acf::GET_FIELD (v, i, lv, le)
=>
{ (loop le) -> (s, fv, le);
case (lookup v)
#
THE (ARG (d, ac as REF (sp, ti)))
=>
ac := (sp + 1, ou::pow2 (depth - d) + ti);
_ => ();
esac;
(1+s, addv (s_rmv (lv, fv), v), acf::GET_FIELD (v, i, lv, le));
};
acf::RAISE (acf::VAR v, ltys)
=>
# Artificially high size estimate
# to discourage inlining:
#
(15, is::singleton v, lambda_expression);
acf::EXCEPT (le, v)
=>
{ my (s, fv, le) = loop le;
(2+s, addv (fv, v), acf::EXCEPT (le, v));
};
acf::BRANCH (po, vs, le1, le2)
=>
{ my (s1, fv1, le1) = loop le1;
my (s2, fv2, le2) = loop le2;
(1+s1+s2, fpo (addvs (is::union (fv1, fv2), vs), po),
acf::BRANCH (po, vs, le1, le2));
};
acf::BASEOP (po, vs, lv, le)
=>
{ my (s, fv, le) = loop le;
(1+s, fpo (addvs (s_rmv (lv, fv), vs), po), acf::BASEOP (po, vs, lv, le));
};
acf::APPLY _ => bug "bogus acf::APPLY";
acf::APPLY_TYPEFUN _ => bug "bogus acf::APPLY_TYPEFUN";
acf::RAISE _ => bug "bogus acf::RAISE";
esac;
};
#
fun improve_mutually_recursive_anormcode_functions ((fk, f, args, body): acf::Function)
=
{ (float_expression im::empty 0 body)
->
(s, fv, nbody);
fv = is::difference (fv, is::add_list (is::empty, map #1 args));
# prettyprint_anormcode::printLexp (acf::RET (map acf::VAR (is::members fv)));
assert (is::is_empty fv);
(fk, f, args, nbody);
};
}; # package improve_mutually_recursive_anormcode_functions
end; # stipulate