## inline-nextcode-buckpass-calls.pkg
#
# A function call like
#
# fun f x = g x;
#
# does nothing useful; it simply passes the
# buck to 'g'. Consequently we can replace
# (f x) by (g x) everywhere in the code
# and save the overhead of one function call.
#
# Doing that (properly!) is our job here.
#
# In the lambda calculus this is called "eta conversion".
# Compiled by:
# src/lib/compiler/core.sublib# This file implements one of the nextcode transforms.
# For context, see the comments in
#
# src/lib/compiler/back/top/highcode/highcode-form.api# "Elimination of eta-redexes: Replaces all expressions of the form
# \x.fx with f. Because this tends to undo the work of etasplit and
# because it is rarely beneficial, this phase is used only at the
# very beginning to clean up the output of the nextcode conversion,
# and at the end when eta-redexes are not beneficial any more."
#
# [...]
#
# "It seemed easy and harmless to move eta-elimination into
# 'fcontract', and with similar benefits as above. In retrospect,
# it took a long time to debug, which, I later learned, was the
# main reason why it was a separate phase [...]"
#
#
# -- Principled Compilation and Scavenging
# Stefan Monnier, 2003 [PhD Thesis, U Montreal]
# http://www.iro.umontreal.ca/~monnier/master.ps.gz
# *********************************************************************
#
# The function eta is an eta reducer for nextcode expressions. It is
# guaranteed to reach an eta normal form in at most two passes. A
# high-level description of the algorithm follows.
#
# eta essentially takes two arguments, a nextcode expression and an
# dictionary mapping variables to values. (In practice, the
# dictionary is a global variable.) The dictionary is used to
# keep track of the eta reductions performed. The algorithm can be
# explained by the two key clauses below (written in pseudo-nextcode
# notation):
#
# [MUTUALLY_RECURSIVE_FNS] eta (dictionary, *let* f[x1, ..., xN] = M1
# *in* M2)
#
# --> let M1' = eta (dictionary, M1)
# in if M1' == g[x1, ..., xN]
# then eta (dictionary[f := g], M2)
# else *let* f[x1, ..., xN] = M1'
# *in* eta (dictionary, M2)
# end
#
# [APPLY] eta (dictionary, f[v1, ..., vN])
#
# --> dictionary (f)[dictionary (v1), ..., dictionary (vN)]
#
# In the [MUTUALLY_RECURSIVE_FNS] case of function definition, we first eta reduce the
# body M1 of the function f, then see if f is itself an eta
# redex f[x1, ..., xN] = g[x1, ..., xN]. If so, we will use g for f
# elsewhere in the nextcode expression.
#
# The [APPLY] case shows where we must rename variables.
#
# This would get all eta redexes in one pass, except for the
# following problem. Consider the nextcode code below:
#
# *let* f[x1, ..., xN] = M1
# *and* g[y1, ..., yN] = f[x1, ..., xN]
# *in* M2
#
# Suppose M1 does not reduce to an application h[x1, ..., xN].
# If we naively reduce the expression as above, first reducing
# the body M1 of f, then the body of g, then M2, we would get:
#
# let M1' = eta (dictionary, M1)
# in *let* f[x1, ..., xN] = M1'
# *in* eta (dictionary[g := f], M2)
# end
#
# The problem with this is that M1 might have contained occurrences
# of g. Thus g may appear in M1'. There are a number of ways to
# handle this:
#
# 1) Once we perform an eta reduction on any function in a
# MUTUALLY_RECURSIVE_FNS, we must go back and re-reduce
# any other functions of the MUTUALLY_RECURSIVE_FNS
# that we previously reduced;
# 2) We do not go back to other functions in the
# MUTUALLY_RECURSIVE_FNS, but instead make a second pass over the output of eta.
#
# As (1) can lead to quadratic behaviour, we implemented (2).
#
#
# A final note: we recognize more than just
# f[x1, ..., xN] = g[x1, ..., xN]
# as an eta reduction. We regard the function definition
# f[x1, ..., xN] = SELECT[1, v, g, g[x1, ..., xN]]
# as an eta redex as well, and so we reduce
# eta (dictionary,*let* f[x1, ..., xN] = SELECT[i, v, g, g[x1, ..., xN]]
# *in* M1)
# --> SELECT (i, v, g, eta (dictionary[f := g], M1))
# This is implemented with the selectapp function below.
#
# *********************************************************************
stipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkgherein
api Inline_Nextcode_Buckpass_Calls {
#
inline_nextcode_buckpass_calls
:
{ function: ncf::Function,
click: String -> Void
}
->
ncf::Function;
};
end;
stipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.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 intset {
Intset = Ref( int_red_black_set::Set );
fun new () = REF int_red_black_set::empty;
fun add set i = set := int_red_black_set::add (*set, i);
fun mem set i = int_red_black_set::member(*set, i);
# fun rmv set i = set := int_red_black_set::drop(*set, i);
};
herein
package inline_nextcode_buckpass_calls
: (weak) Inline_Nextcode_Buckpass_Calls # Inline_Nextcode_Buckpass_Calls is from src/lib/compiler/back/top/improve-nextcode/inline-nextcode-buckpass-calls.pkg {
fun inline_nextcode_buckpass_calls
{
function => (fkind, fvar, fargs, ctyl, cexp),
click
}
=
{
debug = *global_controls::compiler::debugnextcode; # FALSE
fun debugprint s = if debug global_controls::print::say s; fi;
fun debugflush () = if debug global_controls::print::flush(); fi;
fun map1 f (a, b)
=
(f a, b);
fun member (i: Int, a ! b) => i == a or member (i, b);
member (i,[]) => FALSE;
end;
fun same (v ! vl, (ncf::CODETEMP w) ! wl) => v == w and same (vl, wl);
same (NIL, NIL) => TRUE;
same _ => FALSE;
end;
fun share_name (x, ncf::CODETEMP y) => tmp::share_name (x, y);
share_name (x, ncf::LABEL y) => tmp::share_name (x, y);
share_name _ => ();
end;
exception M_TWO;
my m: iht::Hashtable( ncf::Value )
=
iht::make_hashtable { size_hint => 32, not_found_exception => M_TWO };
name = iht::get m;
fun rename (v0 as ncf::CODETEMP v) => (rename (name v) except M_TWO = v0);
rename (v0 as ncf::LABEL v) => (rename (name v) except M_TWO = v0);
rename x => x;
end;
fun newname x
=
{ share_name x;
iht::set m x;
};
stipulate
km = intset::new (): intset::Intset;
herein
fun addvt (v, ncf::typ::FATE) => intset::add km v;
addvt _ => ();
end;
fun addft (ncf::FATE_FN, v, _, _, _) => intset::add km v;
addft _ => ();
end;
fun is_cont v
=
intset::mem km v;
end;
id = (\\ x = x);
do_again = REF FALSE;
recursive my pass2
=
\\ ncf::DEFINE_RECORD { kind, to_temp, fields, next }
=> ncf::DEFINE_RECORD { kind, to_temp, fields => map (map1 rename) fields, next => pass2 next };
#
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=> ncf::GET_FIELD_I { i, record, to_temp, type, next => pass2 next };
#
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=> ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next => pass2 next };
#
ncf::ARITH { op, args, to_temp, type, next } => ncf::ARITH { op, args => map rename args, to_temp, type, next => pass2 next };
ncf::PURE { op, args, to_temp, type, next } => ncf::PURE { op, args => map rename args, to_temp, type, next => pass2 next };
#
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next } => ncf::FETCH_FROM_RAM { op, args => map rename args, to_temp, type, next => pass2 next };
ncf::STORE_TO_RAM { op, args, next } => ncf::STORE_TO_RAM { op, args => map rename args, next => pass2 next };
#
ncf::TAIL_CALL { fn, args } => ncf::TAIL_CALL { fn => rename fn, args => map rename args };
ncf::JUMPTABLE { i, xvar, nexts } => ncf::JUMPTABLE { i, xvar, nexts => map pass2 nexts };
#
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=> ncf::IF_THEN_ELSE { op, args => map rename args, xvar, then_next => pass2 then_next, else_next => pass2 else_next };
#
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=> ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args => map rename args, to_ttemps, next => pass2 next };
#
ncf::DEFINE_FUNS { funs, next }
=>
ncf::DEFINE_FUNS { funs => map (\\ (fk, f, vl, cl, body) = (fk, f, vl, cl, pass2 body)) funs,
next => pass2 next
};
end;
recursive my reduce
=
\\ ncf::DEFINE_RECORD { kind, to_temp, fields, next }
=> ncf::DEFINE_RECORD { kind, to_temp, fields => map (map1 rename) fields, next => reduce next };
#
ncf::GET_FIELD_I { i, record, to_temp, type, next } => { addvt (to_temp, type); ncf::GET_FIELD_I { i, record, to_temp, type, next => reduce next };};
#
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=> ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next => reduce next };
#
ncf::ARITH { op, args, to_temp, type, next } => { addvt (to_temp, type); ncf::ARITH { op, args => map rename args, to_temp, type, next => reduce next }; };
ncf::PURE { op, args, to_temp, type, next } => { addvt (to_temp, type); ncf::PURE { op, args => map rename args, to_temp, type, next => reduce next }; };
#
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next } => { addvt (to_temp, type); ncf::FETCH_FROM_RAM { op, args => map rename args, to_temp, type, next => reduce next }; };
ncf::STORE_TO_RAM { op, args, next } => ncf::STORE_TO_RAM { op, args => map rename args, next => reduce next };
#
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=>
{ apply addvt to_ttemps;
#
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args => map rename args, to_ttemps, next => reduce next };
};
#
ncf::TAIL_CALL { fn, args } => ncf::TAIL_CALL { fn => rename fn, args => map rename args };
ncf::JUMPTABLE { i, xvar, nexts } => ncf::JUMPTABLE { i, xvar, nexts => map reduce nexts };
#
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=>
ncf::IF_THEN_ELSE
{ op,
args => map rename args,
xvar,
then_next => reduce then_next,
else_next => reduce else_next
};
#
ncf::DEFINE_FUNS { funs, next }
=>
case (eta_elim funs)
#
([], h, _) => h (reduce next);
(funs, h, _) => h (ncf::DEFINE_FUNS { funs, next => reduce next });
esac
where
apply addft funs;
fun eta_elim NIL
=>
(NIL, id, FALSE);
eta_elim((fk as ncf::NO_INLINE_INTO, f, vl, cl, body) ! r)
=>
{ my (r', h, leftover) = eta_elim r;
body' = reduce body;
((fk, f, vl, cl, body') ! r', h, TRUE);
};
eta_elim((fk, f, vl, cl, body) ! r)
=>
{ my (r', h, leftover) = eta_elim r;
fun right_kind (ncf::CODETEMP v | ncf::LABEL v)
=>
((fk == ncf::FATE_FN) == (is_cont v));
right_kind _
=>
FALSE;
end;
fun selectapp (ncf::GET_FIELD_I { i, record => ncf::CODETEMP w, to_temp => v, type => t, next => e })
=>
case (selectapp e )
#
NULL => NULL;
THE (h', u)
=>
if (not (member (w, f ! vl))) THE (\\ ce = ncf::GET_FIELD_I { i, record => ncf::CODETEMP w, to_temp => v, type => t, next => h' ce }, u);
else NULL;
fi;
esac;
selectapp (ncf::TAIL_CALL { fn => g, args => wl })
=>
{ g' = rename g;
z = case g' ncf::CODETEMP x => member (x, f ! vl);
ncf::LABEL x => member (x, f ! vl);
_ => FALSE;
esac;
if (((not z) and (same (vl, wl)))
and (right_kind g'))
THE (\\ ce = ce, g');
else NULL;
fi;
};
selectapp _ => NULL;
end;
paired_lists::apply addvt (vl, cl);
body' = reduce body;
case (selectapp body')
#
NULL => ((fk, f, vl, cl, body') ! r', h, TRUE);
THE (h', u)
=>
{ if leftover do_again := TRUE; fi;
click "e";
newname (f, u);
(r', h' o h, leftover);
};
esac;
};
end; # fun eta_elim
end;
end;
# Body of eta:
#
debugprint "Eta: ";
debugflush();
cexp' = reduce cexp;
debugprint "\n";
debugflush ();
if (not *do_again)
#
(fkind, fvar, fargs, ctyl, cexp');
else
debugprint "Eta: needed second pass\n";
debugflush ();
(fkind, fvar, fargs, ctyl, pass2 cexp');
fi;
}; # fun inline_nextcode_buckpass_calls
}; # package inline_nextcode_buckpass_calls
end; # toplevel stipulate