## convert-free-variables-to-parameters-in-anormcode.pkg "typelift.pkg" in SML/NJ
#
# ``"Lambda lifting" is a well-known transformation which rewrites
# a program into an equivalent one in which no function has
# free variables.''
# -- page 93 of Zhong Shao's PhD thesis,
# Compiling Standard ML for Efficient Execution on Modern Machines
# http://flint.cs.yale.edu/flint/publications/zsh-thesis.html
#
# Which is to say, all values accessed by all functions
# are then passed as parameters:
#
# fun print_sum x = printf "sum %d\n x y;
#
# gets transformed to (say)
#
# fun print_sum (x, y) = printf "sum %d\n x y;
#
#
# For additional background beyond Shao's thesis, read:
#
# Lambda Lifting: Transforming Programs to Recursive Equations
# Thomas Johnsson
# 1985, 15p
# http://citeseer.ist.psu.edu/johnsson85lambda.html
#
# Optimal Type Lifting
# Bratin Saha, Zhong Shao (Yale)
# 1998, 36p
# http://flint.cs.yale.edu/flint/publications/lift-tr.ps.gz
# 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#
### "Never eat more than you can lift."
###
### -- Miss Piggy
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkgherein
api Convert_Free_Variables_To_Parameters_In_Anormcode {
#
convert_free_variables_to_parameters_in_anormcode: acf::Function -> acf::Function; # was called type_lift
anormcode_is_well_formed: acf::Function -> Bool;
};
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 di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-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 vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkgherein
package convert_free_variables_to_parameters_in_anormcode
: (weak) Convert_Free_Variables_To_Parameters_In_Anormcode # Convert_Free_Variables_To_Parameters_In_Anormcode is from src/lib/compiler/back/top/improve/convert-free-variables-to-parameters-in-anormcode.pkg {
# **** Utility functions ****
exception PARTIAL_TYPE_APP;
exception VAR_NOT_FOUND;
exception LIFT_TYPE_UNKNOWN;
exception DO_NOT_LIFT;
exception FTABLE;
exception LIFT_COMPILE_ERROR;
exception VENV;
exception FENV;
exception ABSTRACT;
fun bug s
=
error_message::impossible ("Lift: " + s);
make_var = highcode_codetemp::issue_highcode_codetemp;
wellfixed = REF TRUE;
welltapped = REF TRUE;
tapp_lifted = REF 0;
Depth = Int;
Tdepth = Int;
Num = Int;
Abstract = Bool;
Var = (hut::Uniqtypoid, List(tmp::Codetemp), Depth, Tdepth, Abstract, Num);
Venv = iht::Hashtable( Var );
Freevar = (tmp::Codetemp, hut::Uniqtypoid);
Fenv = List (iht::Hashtable( Freevar ) );
Ltype = TYPE_FUN | TYPEFN_APP;
Header = List( (Ltype, tmp::Codetemp, acf::Expression) );
Dictionary = IENV (Venv, Fenv);
# Utility functions
abs = TRUE;
noabs = FALSE;
fkfct = { loop_info => NULL,
private => FALSE,
inlining_hint => acf::INLINE_IF_SIZE_SAFE,
call_as => acf::CALL_AS_GENERIC_PACKAGE
};
fun adjust (t, ntd, otd)
=
hcf::change_depth_of_uniqtypoid (t, otd, ntd);
fun find_dictionary (v, IENV (venv, fenvs))
=
(iht::get venv v)
except
_ = { print (int::to_string v);
bug "findDict: var not found" ;
};
fun get_variable (v, IENV (venv, fenv ! fenvs), t, td, td')
=>
{ my (v', nt') = (iht::get fenv v);
(v', nt', NIL);
}
except
_ = { v' = make_var();
nt' = adjust (t, td, td');
iht::set fenv (v, (v', nt'));
(v', nt', [v]);
};
get_variable _
=>
bug "unexpected freevariableDict in getVariable";
end;
fun new_variable (v, dictionary, td)
=
expression
where
my (t, vs, td', d', abs, _)
=
find_dictionary (v, dictionary);
expression = if (abs and (d' > 0) and (td' < td))
my (v', t', fv) = get_variable (v, dictionary, t, td, td');
(v', t', fv);
else
(v, adjust (t, td, td'), NIL);
fi;
end;
fun push_fenv (IENV (venv, fenvs))
=
{ nt = iht::make_hashtable { size_hint => 32, not_found_exception => FTABLE };
IENV (venv, nt ! fenvs);
};
fun pop_fenv (IENV (venv, fenv ! fenvs)) => IENV (venv, fenvs);
pop_fenv _ => raise exception LIFT_COMPILE_ERROR;
end;
fun add_dictionary (IENV (venv, fenvs), vs, ts, fvs, td, d, abs)
=
{
fun f (v, t)
=
iht::set venv (v, (t, fvs, td, d, abs, 0));
fun zip ([], [], acc) => acc;
zip (a ! r, a' ! r', acc) => zip (r, r', (a, a') ! acc);
zip _ => raise exception LIFT_COMPILE_ERROR;
end;
map f (zip (vs, ts, NIL));
};
fun rm_dictionary (IENV (venv, fenvs), v)
=
iht::drop venv v;
fun get_free_variable (fvs, IENV (venv, fenv ! fenvs))
=>
map f fvs
where
fun f (v)
=
(iht::get fenv v)
except
_ = bug "freevar not found";
end;
get_free_variable _
=>
bug "unexpected freevariableDict in getFreeVariable";
end;
fun write_lambda ([], expression)
=>
expression;
write_lambda (fvs, expression)
=>
{ fun g (fvs', expression')
=
{ new_var = make_var();
fund = { loop_info => NULL,
call_as => acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION { arg_is_raw => TRUE, body_is_raw => TRUE }),
private => FALSE,
inlining_hint => acf::INLINE_IF_SIZE_SAFE
};
acf::MUTUALLY_RECURSIVE_FNS
( [ (fund, new_var, fvs', expression') ],
acf::RET [acf::VAR new_var]
);
};
if (list::length(fvs) <= 9)
#
g (fvs, expression);
else
fun f (x, e) = ([x], e);
fold_backward (g o f) expression fvs;
fi;
};
end;
fun write_app (v, vs)
=
if (list::length(vs) <= 9)
#
acf::APPLY (v, vs);
else
fun f ([], e)
=>
{ new_var = make_var();
(acf::RET [acf::VAR new_var], new_var);
};
f (v ! vs, e)
=>
{ my (e', v') = f (vs, e);
new_var = make_var();
(acf::LET([v'], acf::APPLY (acf::VAR new_var,[v]), e'), new_var);
};
end;
my (e', v') = f (list::tail vs, acf::RET []);
acf::LET ([v'], acf::APPLY (v, [list::head vs]), e');
fi;
fun write_header (hd, expression)
=
fold_backward f expression hd
where
fun f ((TYPEFN_APP, v, e), e') => acf::LET ([v], e, e');
f ((TYPE_FUN, v, acf::TYPEFUN (e, e')), e'') => acf::TYPEFUN (e, e'');
f _ => bug "unexpected header in writeHeader";
end;
end;
# The way renaming is done is that if rename is TRUE and d > 0
# and td < td' then change var
#
fun init_info_dictionary ()
=
{ my venv: Venv = iht::make_hashtable { size_hint => 32, not_found_exception => VENV };
my fenv = iht::make_hashtable { size_hint => 32, not_found_exception => FENV };
IENV (venv, [fenv]);
};
fun anormcode_is_well_formed (fdec: acf::Function)
=
case fdec
#
(fk as { call_as => acf::CALL_AS_GENERIC_PACKAGE, ... }, v, vts, e)
=>
formed (e, 0)
where
fun formed (acf::RET _, d) => TRUE;
formed (acf::LET (vs, e1, e2), d) => formed (e1, d) and formed (e2, d);
formed (acf::APPLY (v, vs), d) => TRUE;
formed (acf::APPLY_TYPEFUN (v, ts), d)
=>
case d 0 => TRUE;
_ => FALSE;
esac;
formed (acf::RECORD (rk, vs, v, e), d) => formed (e, d);
formed (acf::GET_FIELD (v, i, l, e), d) => formed (e, d);
formed (acf::RAISE _, d) => TRUE;
formed (acf::EXCEPT (e, v), d) => formed (e, d);
formed (acf::BRANCH (pr, vs, e1, e2), d) => formed (e1, d) and formed (e2, d);
formed (acf::BASEOP (pr, vs, l, e), d) => formed (e, d);
formed (acf::SWITCH (v, a, ces, eopt), d)
=>
{ b1 = case eopt NULL => TRUE;
THE e => formed (e, d);
esac;
fun f (c, e) = (e, d);
es = map f ces;
b2 = map formed es;
b = fold_backward (\\ (x, y) = x and y) b1 b2;
b;
};
formed (acf::CONSTRUCTOR (dc, ts, v, l, e), d) => formed (e, d);
formed (acf::TYPEFUN((tfk, l, ts, e1), e2), d)
=>
formed (e1, d) and formed (e2, d);
formed (acf::MUTUALLY_RECURSIVE_FNS (fds, e), d)
=>
{
b1 = formed (e, d);
b2 = case fds
( { call_as => acf::CALL_AS_GENERIC_PACKAGE, ... }, l, vs, e') ! r => map formed [(e', d)];
_ => { fun f (v1, v2, v3, v4) = (v4, d + 1);
es = map f fds;
b' = map formed es;
b';
}; esac;
b = fold_backward (\\ (x, y) = x and y) b1 b2;
b;
};
end;
end;
_ => bug "non GENERIC program in Lift";
esac;
fun lift (e, dictionary, td, d, ad, rename)
=
loope (e, dictionary, d, ad)
where
fun comb ((v, t, fv, hd), (l1, l2, l3, l4))
=
(v ! l1, t ! l2, fv@l3, hd@l4);
fun lt_inst (lt, ts)
=
case (hcf::apply_typeagnostic_type_to_arglist (lt, ts))
#
[x] => x;
_ => bug "unexpected case in ltInst";
esac;
fun arglty (lt, ts)
=
{
my (_, atys, _) = hcf::unpack_arrow_uniqtypoid (lt_inst (lt, ts));
case atys
[x] => x;
_ => bug "unexpected case in arglty";
esac;
};
fun reslty (lt, ts)
=
{ my (_, _, rtys)
=
hcf::unpack_arrow_uniqtypoid (lt_inst (lt, ts));
case rtys
#
[x] => x;
_ => bug "unexpected case in reslty";
esac;
};
fun loopcv dictionary var v
=
{ my (v', t, fv)
=
new_variable (v, dictionary, td); # Not checking for poly
(var v', t, fv, NIL); # Check whether this is t or t'
};
fun loopc dictionary v
=
{ fun c t = (v, t, [], []);
case v
#
acf::VAR v' => loopcv dictionary acf::VAR v';
#
(acf::INT _ | acf::UNT _ ) => c hcf::int_uniqtypoid;
(acf::INT1 _ | acf::UNT1 _) => c hcf::int1_uniqtypoid;
#
acf::FLOAT64 _ => c hcf::float64_uniqtypoid;
acf::STRING _ => c hcf::string_uniqtypoid;
esac;
};
fun lpacc dictionary (vh::HIGHCODE_VARIABLE v)
=>
{ (loopcv dictionary (\\ v = v) v)
->
(v', _, fv, _);
( vh::HIGHCODE_VARIABLE v',
fv
);
};
lpacc dictionary (vh::PATH (a, i))
=>
{ (lpacc dictionary a) -> (a', fvs);
#
(vh::PATH (a', i), fvs);
};
lpacc dictionary a => (a, NIL);
end;
fun lpcon dictionary (vh::EXCEPTION a)
=>
{ (lpacc dictionary a) -> (a', fv);
#
(vh::EXCEPTION (a'), fv);
};
lpcon dictionary (vh::SUSPENSION NULL)
=>
(vh::SUSPENSION(NULL), NIL);
lpcon dictionary (vh::SUSPENSION (THE (a', a'')))
=>
{ (lpacc dictionary a' ) -> (a1, fv1);
(lpacc dictionary a'') -> (a2, fv2);
#
(vh::SUSPENSION (THE (a', a'')), fv1 @ fv2);
};
lpcon dictionary a
=>
(a, NIL);
end;
fun loope (acf::RET vs, dictionary, d, ad)
=>
{ vls = map (loopc dictionary) vs;
my (vs, ts, fvs, hd)
=
fold_backward comb (NIL, NIL, NIL, NIL) vls;
(acf::RET vs, ts, fvs, hd);
};
loope (acf::LET (vs, e1, e2), dictionary, d, ad)
=>
{
my (e', ts, fvs, hd) = loope (e1, dictionary, d, ad);
add_dictionary (dictionary, vs, ts, fvs, td, d, abs);
my (e'', ts', fvs', hd') = loope (e2, dictionary, d, ad);
(acf::LET (vs, e', e''), ts', fvs@fvs', hd@hd');
};
loope (acf::APPLY (v1, vs), dictionary, d, ad)
=>
{ my (v1', t, fvs, hd)
=
loopc dictionary v1;
vls = map (loopc dictionary) vs;
my (vs', ts', fvs', hd')
=
fold_backward comb (NIL, NIL, NIL, NIL) vls;
nt = #2 (hcf::ltd_fkfun t);
(acf::APPLY (v1', vs'), nt, fvs@fvs', hd@hd');
};
loope (e as acf::APPLY_TYPEFUN (v, types), dictionary as IENV (venv, fenvs), d, ad)
=>
{
(loopc dictionary v) -> (v', nt', fv', hd); # fv' and hd are NIL
nt = hcf::apply_typeagnostic_type_to_arglist (nt', types);
len1 = list::length types;
case d
0 => (e, nt, fv', hd);
_ => case v
#
acf::VAR v'' =>
{
my (t', fvs', len2, vd, _, _)
=
(iht::get venv v'')
except
_ = bug "TYPEFN_APP var not found";
if ((len1 == len2) or (vd == 0))
#
new_var = make_var();
hd' = (TYPEFN_APP, new_var, acf::APPLY_TYPEFUN (v, types));
fun f (x) = loopc dictionary (acf::VAR x);
my (expression, fvs)
=
case fvs'
#
[] => (acf::RET([acf::VAR new_var]), NIL);
_ => { fvs'' = map f fvs';
my (r1, r2, r3, r4) = fold_backward comb (NIL, NIL, NIL, NIL) fvs'';
(write_app (acf::VAR new_var, r1), r3);
};
esac;
tapp_lifted := *tapp_lifted + 1;
(expression, nt, fv'@fvs, [hd']);
else
welltapped := FALSE;
tapp_lifted := 0;
raise exception PARTIAL_TYPE_APP ;
fi;
};
_ => (e, nt, fv', hd);
esac;
esac;
};
loope (e as acf::TYPEFUN((tfk, v, tvs, e1), e2), dictionary as IENV (venv, fenvs), d, ad)
=>
case d
#
0 =>
{
(lift (e1, dictionary, di::next td, d, ad, TRUE))
->
(e1', nt', fv', hd');
ks = map (\\ (t, k) = k) tvs;
nt = hcf::make_typeagnostic_uniqtypoid (ks, nt');
# Hack for TYPEFN_APP. Stores the number of tvs instead of td
add_dictionary (dictionary, [v], [nt], fv', (list::length tvs), d, noabs);
(loope (e2, dictionary, d, ad))
->
(e2', nt'', fv'', hd'');
(acf::TYPEFUN((tfk, v, tvs, e1'), e2'), nt'', fv'@fv'', hd'@hd'');
};
_ =>
{
dictionary' = push_fenv (dictionary);
(lift (e1, dictionary', di::next td, d, di::next ad, TRUE))
->
(e1', nt', fvs, hd);
freevars = get_free_variable (fvs, dictionary');
ks = map (\\ (t, k) = k) tvs;
nt = hcf::make_typeagnostic_uniqtypoid (ks, nt');
# Hack for TYPEFN_APP. Stores the number of tvs
add_dictionary (dictionary, [v], [nt], fvs, (list::length tvs), d, noabs);
(loope (e2, dictionary, d, ad))
->
(e2', nt'', fvs', hd');
expression = write_lambda (freevars, e1');
expression' = write_header (hd, expression);
hd = (TYPE_FUN, v, acf::TYPEFUN((tfk, v, tvs, expression'), acf::RET [])) ! hd';
(e2', nt'', fvs', hd);
};
esac;
loope (acf::SWITCH (v, a, cels, eopt), dictionary, d, ad)
=>
{ my (v', nt, fv, hd) = loopc dictionary v;
fun f (c, e)
=
{ case c
#
acf::VAL_CASETAG((_, _, lt), ts, v)
=>
add_dictionary (dictionary, [v], [arglty (lt, ts)], NIL, td, d, abs);
_ => [()];
esac;
(loope (e, dictionary, d, ad))
->
(e', nt', fvs, hds);
((c, e'), nt', fvs, hds);
};
ls = map f cels;
(fold_backward comb (NIL, NIL, NIL, NIL) ls)
->
(cels', nt', fvs', hds');
my (expression, t, f, h)
=
case eopt
#
NULL => (acf::SWITCH (v', a, cels', eopt), list::head nt', fv@fvs', hd@hds');
THE (eopt') =>
{
(loope (eopt', dictionary, d, ad))
->
(eopt'', nt'', fvs'', hd'');
(acf::SWITCH (v', a, cels', THE (eopt'')), list::head nt', fv@fvs'@fvs'', hd@hds'@hd'');
};
esac;
(expression, t, f, h);
};
loope (acf::CONSTRUCTOR (dcons, tcs, vl, v, e), dictionary, d, ad)
=>
{ dcons -> (s, cr, lt);
(lpcon dictionary cr) -> (cr', fv);
nt = reslty (lt, tcs);
(loopc dictionary vl) -> (vl', nt', fvs', hd');
add_dictionary (dictionary, [v], [nt], NIL, td, d, TRUE);
(loope (e, dictionary, d, ad))
->
(e'', nt'', fvs'', hd'');
(acf::CONSTRUCTOR((s, cr', lt), tcs, vl', v, e''), nt'', fv@fvs'@fvs'', hd'@hd'');
};
loope (acf::RECORD (rk, vls, v, e), dictionary, d, ad)
=>
{ ls = map (loopc dictionary) vls;
(fold_backward comb (NIL, NIL, NIL, NIL) ls)
->
(vls', nt', fvs', hd');
nt = hcf::ltc_rkind (rk, nt');
add_dictionary (dictionary, [v], [nt], fvs', td, d, TRUE);
(loope (e, dictionary, d, ad))
->
(e', nt'', fvs'', hd'');
(acf::RECORD (rk, vls', v, e'), nt'', fvs'@fvs'', hd'@hd'');
};
loope (acf::GET_FIELD (v, i, l, e), dictionary, d, ad)
=>
{ (loopc dictionary v)
->
(v', nt', fvs', hd');
nt = hcf::ltd_rkind (nt', i);
add_dictionary (dictionary, [l], [nt], fvs', td, d, TRUE);
(loope (e, dictionary, d, ad))
->
(e', nt'', fvs'', hd'');
(acf::GET_FIELD (v', i, l, e'), nt'', fvs'@fvs'', hd'@hd'');
};
loope (acf::RAISE (v, ls), dictionary, d, ad)
=>
{ (loopc dictionary v) -> (v', nt', fvs', hd');
(acf::RAISE (v', ls), ls, fvs', hd');
};
loope (acf::EXCEPT (e, v), dictionary, d, ad)
=>
{ (loopc dictionary v) -> (v', nt', fvs', hd' );
(loope (e, dictionary, d, ad)) -> (e', nt'', fvs'', hd'');
(acf::EXCEPT (e', v'), nt'', fvs'@fvs'', hd'@hd'');
};
loope (acf::BRANCH (pr, vl, e1, e2), dictionary, d, ad)
=>
{ ls = map (loopc dictionary) vl;
(fold_backward comb (NIL, NIL, NIL, NIL) ls) -> (vls', nt', fvs', hd' );
(loope (e1, dictionary, d, ad)) -> (e1', nt'', fvs'', hd'' );
(loope (e2, dictionary, d, ad)) -> (e2', nt''', fvs''', hd''');
(acf::BRANCH (pr, vls', e1', e2'), nt''', fvs'@fvs''@fvs''', hd'@hd''@hd''');
};
loope (acf::BASEOP (pr, vl, l, e), dictionary, d, ad)
=>
{ ls = map (loopc dictionary) vl;
(fold_backward comb (NIL, NIL, NIL, NIL) ls)
->
(vls', nt', fvs', hd');
pr -> (_, _, lt, ts);
nt = reslty (lt, ts);
add_dictionary (dictionary, [l], [nt], fvs', td, d, abs);
(loope (e, dictionary, d, ad))
->
(e', nt'', fvs'', hd'');
(acf::BASEOP (pr, vls', l, e'), nt'', fvs'@fvs'', hd'@hd'');
};
loope (e as acf::MUTUALLY_RECURSIVE_FNS ( [ ( { call_as => acf::CALL_AS_GENERIC_PACKAGE, ... }, v, lvs, e1)], e2), dictionary, d, ad)
=>
{
vs = map #1 lvs;
ts = map #2 lvs;
if (d > 0) wellfixed := FALSE; fi;
add_dictionary (dictionary, vs, ts, NIL, td, 0, noabs);
(loope (e1, dictionary, 0, di::next ad))
->
(e', nt', fvs', hd');
nt = hcf::ltc_fkfun (fkfct, ts, nt');
add_dictionary (dictionary, [v], [nt], fvs', td, 0, noabs);
(loope (e2, dictionary, d, ad))
->
(e'', nt'', fvs'', hd'');
(acf::MUTUALLY_RECURSIVE_FNS([(fkfct, v, lvs, e')], e''), nt'', fvs'@fvs'', hd'@hd'');
};
loope (e as acf::MUTUALLY_RECURSIVE_FNS([(fk, v, lvs, e1)], e2), dictionary, d, ad)
=>
case fk
#
{ loop_info => NULL,
call_as => acf::CALL_AS_FUNCTION _,
...
}
=>
{
vs = map #1 lvs;
ts = map #2 lvs;
add_dictionary (dictionary, vs, ts, NIL, td, di::next d, abs);
(loope (e1, dictionary, di::next d, di::next ad))
->
(e', nt', fvs', hd');
nt = hcf::ltc_fkfun (fk, ts, nt');
abs = if (d > 0) TRUE;
else FALSE;
fi;
add_dictionary (dictionary, [v], [nt], fvs', td, d, abs);
(loope (e2, dictionary, d, ad))
->
(e'', nt'', fvs'', hd'');
ne' = acf::MUTUALLY_RECURSIVE_FNS([(fk, v, lvs, e')], e'');
my (ne, hd)
=
case d
0 => (write_header (hd'@hd'', ne'), NIL);
_ => (ne', hd'@hd'');
esac;
(ne, nt'', fvs'@fvs'', hd);
};
{ loop_info => THE (rts, _), call_as => acf::CALL_AS_FUNCTION _, ... }
=>
{
vs = map (#1) lvs;
ts = map (#2) lvs;
add_dictionary (dictionary, [v], [hcf::ltc_fkfun (fk, ts, rts)], NIL, td, di::next d, abs);
add_dictionary (dictionary, vs, ts, NIL, td, di::next d, abs);
(loope (e1, dictionary, di::next d, di::next ad))
->
(e', nt', fvs', hd');
# Check to see that the new value is inserted
add_dictionary (dictionary, [v], [hcf::ltc_fkfun (fk, ts, rts)], NIL, td, d, abs);
# The depth is changed for correct behaviour
(loope (e2, dictionary, d, ad))
->
(e'', nt'', fvs'', hd'');
ne' = acf::MUTUALLY_RECURSIVE_FNS([(fk, v, lvs, e')], e'');
my (ne, hd)
=
case d
0 => (write_header (hd'@hd'', ne'), NIL);
_ => (ne', hd'@hd'');
esac;
(ne, nt'', fvs'@fvs'', hd);
};
_ => bug "unexpected Function in main loop";
esac;
loope (e as acf::MUTUALLY_RECURSIVE_FNS (fds, e2), dictionary, d, ad)
=>
{
fun h d' ((fk as { loop_info => THE (rts, _), ... }, f, lvs, e1): acf::Function)
=>
add_dictionary (dictionary, [f], [hcf::ltc_fkfun (fk, map #2 lvs, rts)], NIL, td, d', abs);
h d fk
=>
bug "unexpected non-recursive fkind in loop";
end;
fun g ((fk, f, lvs, e): acf::Function)
=
{ add_dictionary (dictionary, map #1 lvs, map #2 lvs, NIL, td, di::next d, abs);
(loope (e, dictionary, di::next d, di::next ad))
->
(e', nt', fvs', hd');
( (fk, f, lvs, e'), [hcf::ltc_fkfun (fk, map #2 lvs, nt')], fvs', hd');
};
map (h (di::next d)) fds;
rets = map g fds;
(fold_backward comb (NIL, NIL, NIL, NIL) rets)
->
(fds, nts, fvs, hds);
# Check to see that the correct value is inserted
map (h d) fds; # Shouldn't this be 'apply'? XXX BUGGO FIXME
(loope (e2, dictionary, d, ad))
->
(e'', nt'', fvs'', hd'');
ne' = acf::MUTUALLY_RECURSIVE_FNS (fds, e'');
case d
0 => (write_header(hds@hd'', ne'), nt'', fvs@fvs'', NIL);
_ => (ne', nt'', fvs@fvs'', hds@hd'');
esac;
};
end;
end;
fun convert_free_variables_to_parameters_in_anormcode fdec: acf::Function
=
# if *controls::compiler::lifttype then
case fdec
#
(fk as { call_as => acf::CALL_AS_GENERIC_PACKAGE, ... }, v, vts, e)
=>
{
dictionary = init_info_dictionary();
d = 0; # di::top ??
td = 0; # di::top ??
ad = 0; # di::top ??
rename = FALSE;
vs = map #1 vts;
ts = map #2 vts;
add_dictionary (dictionary, vs, ts, NIL, td, d, noabs);
my (ne, _, _, _)
=
( lift (e, dictionary, td, d, ad, rename) )
except
PARTIAL_TYPE_APP
=
{ print "\n*** No Typelifting ";
print " Partial Type Apply ***\n";
(e, NIL, NIL, NIL);
};
if *wellfixed
();
else
(); # print "\n *** generic package at d > 0 *** \n"
fi;
if *asc::saytappinfo
#
print "\n *** No. of TYPEFN_APPs lifted ";
print (" " + (int::to_string *tapp_lifted) + " \n");
fi;
tapp_lifted := 0;
wellfixed := TRUE;
welltapped := TRUE;
(fk, v, vts, ne);
};
_ => bug "non GENERIC program in Lift";
esac;
};
end;