## make-nextcode-closures-g.pkg
#
# Closures in Mythryl correspond to stackframes in C;
# they hold the parameters and temporaries needed by
# a function while it is executing.
#
# One major difference between our closures and
# C stackframes is that our closures are conceptually
# allocated on the heap and then garbage-collected.
# Among other advantages, this makes tail recursion
# and concurrent programming via 'call/cc' very
# simple to implement and quick to execute.
#
# Allocating closures on the heap is potentially
# much slower than conventional stack allocation.
# Modern multi-generation garbage collection
# largely solves this problem. (For an extended
# discussion of this topic see Chapter 5 of
# Zhong Shao's 1994 PhD thesis, cited below.)
#
# We can also reduce the cost of "heap"-allocated
# closures by a variety of compiler-centric
# strategies such as allocating all or part of
# a given closure in registers or sharing a single
# closure between multiple function calls.
#
# Our job in this file is to implement such
# closure-representation optimizations.
#
# For background, see:
#
# src/A.CLOSURE.OVERVIEW
# 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############################################################################
#
# ASSUMPTIONS: (1) Five possible combinations of bindings in the same
# ncf::DEFINE_FUNS:
# private,
# escape,
# next,
# private-next,
# private+escape;
#
# (2) 'next' (==fate) function is never recursive;
# there is at most ONE 'next' function definition
# per ncf::DEFINE_FUNS.
#
# (3) The outermost function is always a non-recursive
# escaping function.
#
############################################################################
stipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkgherein
api Make_Nextcode_Closures {
#
make_nextcode_closures: ncf::Function -> ncf::Function;
};
end;
# Machine_Properties is from src/lib/compiler/back/low/main/main/machine-properties.apistipulate
#
package coc = global_controls::compiler; # global_controls is from src/lib/compiler/toplevel/main/global-controls.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkg package lms = list_mergesort; # list_mergesort is from src/lib/src/list-mergesort.pkg package mfv = make_per_function_free_variable_maps; # make_per_function_free_variable_maps is from src/lib/compiler/back/top/closures/make-per-function-free-variable-maps.pkg package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg include package allot_prof;
include package sorted_list;
remember_highcode_codetemp_names = tmp::remember_highcode_codetemp_names;
clone_highcode_codetemp = tmp::clone_highcode_codetemp;
issue_highcode_codetemp = tmp::issue_highcode_codetemp;
offp0 = ncf::SLOT 0;
dumcs = NULL; # Dummy callee-save reg contents
zip = paired_lists::zip;
pr = global_controls::print::say;
#
fun inc (ri as REF i)
=
ri := i+1;
herein
generic package make_nextcode_closures_g (
# ========================
#
machine_properties: Machine_Properties # Typically src/lib/compiler/back/low/main/intel32/machine-properties-intel32.pkg #
)
: (weak) Make_Nextcode_Closures # Make_Nextcode_Closures is from src/lib/compiler/back/top/closures/make-nextcode-closures-g.pkg {
# This generic is (only) invoked from:
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg package mp = machine_properties; # Local synonym.
package sprof
=
static_closure_size_profiling_g ( mp ); # static_closure_size_profiling_g is from src/lib/compiler/back/top/closures/static-closure-size-profiling-g.pkg #
fun bug s
=
error_message::impossible ("Closure: " + s);
# **************************************************************************
# MISC UTILITY FUNCTIONS *
# **************************************************************************
#
fun partition f l
=
fold_backward
(\\ (e, (a, b))
=
f e ?? (e ! a, b)
:: ( a, e ! b)
)
([], [])
l;
#
fun sublist test
=
subl
where
fun subl arg
=
s (arg, NIL)
where
fun s (a ! r, l)
=>
test a ?? s (r, a ! l)
:: s (r, l);
s (NIL, l)
=>
reverse l;
end;
end;
end;
#
fun formap f
=
iter o (\\ l = (l, 0))
where
fun iter (NIL, _) => NIL;
iter (hd ! tl, i) => f (hd, i) ! iter (tl, i+1);
end;
end;
#
fun clean l # Clean reverses the order of the argument list.
=
vars (NIL, l)
where
fun vars (l, ncf::CODETEMP x ! rest) => vars (x ! l, rest);
vars (l, _ ! rest) => vars ( l, rest);
vars (l, NIL ) => l;
end;
end;
#
fun uniqvar l
=
uniq (clean l);
#
fun entervar (ncf::CODETEMP v, l) => enter (v, l);
entervar (_, l) => l;
end;
#
fun member l (v: Int)
=
f l
where
fun f [] => FALSE;
f (a ! r) => a < v ?? f r
:: v == a;
end;
end;
#
fun member3 l (v: Int)
=
h l
where
fun h [] => FALSE;
h ((a, _, _) ! rest)
=>
a < v ?? h rest
:: a == v;
end;
end;
#
fun merge_v (l1: List( (ncf::Codetemp, Int, Int) ), l2)
=
h (l1, l2)
where
fun h ( l1 as ((u1 as (x1, a1, b1)) ! r1),
l2 as ((u2 as (x2, a2, b2)) ! r2)
)
=>
if (x1 < x2) u1 ! (h (r1, l2));
elif (x1 > x2) u2 ! (h (l1, r2));
else (x1, int::min (a1, a2), int::max (b1, b2)) ! (h (r1, r2));
fi;
h (l1,[]) => l1;
h([], l2) => l2;
end;
end;
#
fun add_v (vl, m, n, l)
=
merge_v (map (\\ x = (x, m, n)) vl, l);
#
fun uniq_v z
=
h (z, [])
where
fun h ( [], l) => l;
h (a ! r, l) => h (r, merge_v([a], l));
end;
end;
#
fun remove_v (vl: List( ncf::Codetemp ), l)
=
h (vl, l)
where
fun h (l1 as (x1 ! r1), l2 as ((u2 as (x2, _, _)) ! r2))
=>
if (x2 < x1) u2 ! (h (l1, r2));
elif (x2 > x1) h (r1, l2);
else h (r1, r2);
fi;
h ([], l2) => l2;
h (l1, []) => [];
end;
end;
#
fun accum_v ([], _)
=>
([], 1000000, 0, 0);
accum_v (vl, free)
=>
fold_backward h ([], 1000000, 0, 0) free
where
fun h ( (v, m, n), (z, i, j, k) )
=
if (member vl v)
(v ! z, int::min (m, i), int::max (n, j), k+1);
else
(z, i, j, k);
fi;
end;
end;
#
fun partition_namings fl
=
h (fl,[],[],[],[],[])
where
fun h ((fe as (ncf::PUBLIC_FN, _, _, _, _)) ! r, el, kl, rl, cl, jl) => h (r, fe ! el, kl, rl, cl, jl);
h ((fe as (ncf::PRIVATE_FN, _, _, _, _)) ! r, el, kl, rl, cl, jl) => h (r, el, fe ! kl, rl, cl, jl);
h ((fe as (ncf::PRIVATE_RECURSIVE_FN, _, _, _, _)) ! r, el, kl, rl, cl, jl) => h (r, el, fe ! kl, fe ! rl, cl, jl);
h ((fe as (ncf::FATE_FN, _, _, _, _)) ! r, el, kl, rl, cl, jl) => h (r, el, kl, rl, fe ! cl, jl);
h ((fe as (ncf::PRIVATE_FATE_FN, _, _, _, _)) ! r, el, kl, rl, cl, jl) => h (r, el, kl, rl, fe ! cl, fe ! jl);
h ((fe as (ncf::PRIVATE_TAIL_RECURSIVE_FN, _, _, _, _)) ! r, el, kl, rl, cl, jl) => h (r, el, fe ! kl, rl, cl, jl);
h (_ ! r, el, kl, rl, cl, jl) => bug "partition_namings in closure phase 231";
h ([], el, kl, rl, cl, jl) => (el, kl, rl, cl, jl);
end;
end;
make_closure_codetemp
=
{ save = *remember_highcode_codetemp_names
then
remember_highcode_codetemp_names := TRUE;
closure = tmp::issue_named_highcode_codetemp (sy::make_value_symbol "closure");
remember_highcode_codetemp_names := save;
\\ () = clone_highcode_codetemp closure;
};
# Build a list of k dummy cells:
#
fun extra_dummy (k)
=
ec (k, [])
where
fun ec (k, l)
=
k <= 0 ?? l
:: ec (k - 1, dumcs ! l);
end;
#
fun extra_lvar (k, t)
=
h (k,[],[])
where
fun h (n, l, z)
=
n < 1 ?? (reverse l, z)
:: h (n - 1, (issue_highcode_codetemp() ! l), t ! z);
end;
#
fun cuthead (n,[]) # Cut out the first n elements from a list.
=>
[];
cuthead (n, l as (_ ! r))
=>
n <= 0 ?? l
:: cuthead (n - 1, r);
end;
#
fun cuttail (n, l) # Cut out the last n elements from a list.
=
reverse (cuthead (n, reverse l));
#
fun sortlud0 x # Sort according to each variable's life time etc.
=
lms::sort_list
#
(\\ ((_, _, i: Int), (_, _, j))
=
i > j
)
#
x;
#
fun sortlud1 x
=
lms::sort_list ludfud1 x
where
fun ludfud1 ((_, m: Int, i: Int), (_, n, j))
=
(i > j) or
(i == j and m > n);
end;
#
fun sortlud2 (l, vl)
=
{ fun h (v, m, i)
=
member vl v ?? i*1000 + m*10
:: i*1000 + m*10 + 1;
#
fun ludfud2 ((_, m, v), (_, n, w))
=
(m > n) or
(m == n and v < w);
nl = map (\\ (u as (v, _, _)) = (u, h u, v))
l;
map #1 (lms::sort_list ludfud2 nl);
};
#
fun partvnum (l, n) # Cut out the first n elements, returning both the header and the rest.
=
h ([], l, n)
where
fun h (vl, [], n)
=>
(vl,[]);
h (vl, s as ((a, _, _) ! r), n)
=>
n <= 0 ?? (vl, s)
:: h (enter (a, vl), r, n - 1);
end;
end;
#
fun spill_free (free, n, vbase, sbase) # Spill (into sbase) if too many free variables (>n).
=
{ len = length free;
#
if (len < n)
#
( merge (map #1 free, vbase),
sbase
);
else
(partvnum (sortlud1 free, n))
->
(nfree, nspill);
( merge (nfree, vbase),
uniq_v (nspill @ sbase)
);
fi;
};
#
fun get_vn ([], v)
=>
NULL;
get_vn((a, m, n) ! r, v: ncf::Codetemp)
=>
if (v > a) get_vn (r, v);
elif (v == a) THE (m, n);
else NULL;
fi;
end;
#
fun subset (x, y) # See if x is a subset of y. x and y must be sorted lists.
=
case (difference (x, y))
#
[] => TRUE;
_ => FALSE;
esac;
#
fun small_chunk (ncf::typ::FLOAT64 | ncf::typ::INT) => TRUE; # See if a nextcode type is a small constant size chunk.
small_chunk _ => FALSE;
end;
#
fun sharable ((ncf::rk::FATE_FN|ncf::rk::FLOAT64_FATE_FN), (ncf::PUBLIC_FN|ncf::PRIVATE_FN)) # See if a record_kind is sharable by a function with given callers_info.
=>
not mp::quasi_stack;
sharable _ => TRUE;
end;
# Given a callers_info return the appropriate unboxed closure kind.
# "need runtime support for ncf::rk::FLOAT64_FATE_FN (new tags etc.)" -- This comment may be dated(?) since the compiler generates both
# FLOAT64_FATE_FN and FLOAT64_BLOCK results here without apparent problem. -- 2011-08-21 CrT
# (Or possibly the note is suggesting that the generated code could be improved with better support?)
fun unboxed_float_kind ncf::FATE_FN => ncf::rk::FLOAT64_FATE_FN;
unboxed_float_kind ncf::PRIVATE_FATE_FN => ncf::rk::FLOAT64_FATE_FN;
#
unboxed_float_kind _ => ncf::rk::FLOAT64_BLOCK;
end;
# Given a fix kind return the
# appropriate boxed closure kind
#
fun boxed_kind (ncf::FATE_FN | ncf::PRIVATE_FATE_FN) => ncf::rk::FATE_FN;
boxed_kind ncf::PRIVATE_FN => ncf::rk::PRIVATE_FN;
boxed_kind _ => ncf::rk::PUBLIC_FN;
end;
#
fun comment f
=
if *coc::comment
f();
();
fi;
# **************************************************************************
# CLOSURE REPRESENTATIONS *
# **************************************************************************
Csregs = Null_Or( (List( ncf::Value ), List( ncf::Value )) );
Closure_Rep = CLOSURE_REP { offset: Int, closure: Closure }
withtype
Closure = { functions: List( (ncf::Codetemp, ncf::Codetemp) ),
values: List( ncf::Codetemp ),
closures: List( (ncf::Codetemp, Closure_Rep) ),
#
kind: ncf::Record_Kind,
core: List( ncf::Codetemp ),
free: List( ncf::Codetemp ),
#
stamp: ncf::Codetemp
};
Knownfun_Rep
=
{ label: ncf::Codetemp,
gpfree: List( ncf::Codetemp ),
fpfree: List( ncf::Codetemp ),
csdef: Null_Or( (List( ncf::Value ), List( ncf::Value )) )
};
Callee_Rep
=
(ncf::Value, List( ncf::Value ), List( ncf::Value ));
Chunk = VALUE ncf::Type
| CALLEE Callee_Rep
| CLOSURE Closure_Rep
| FUNCTION Knownfun_Rep
;
Access = DIRECT
| PATH (ncf::Codetemp, ncf::Fieldpath, List ((ncf::Codetemp, Closure_Rep)))
;
# **************************************************************************
# UTILITY FUNCTIONS FOR ELIMINATING THE CLOSURE OFFSET *
# **************************************************************************
# Should we adjust the offset
#
fun adj_off (i, off)
=
if (i > 0) 1;
elif (off == 0) 0;
else bug "unexpected case in adj_off";
fi;
# Should we treat the mutually recursive functions specially
#
fun mutually_recursive [] => FALSE;
mutually_recursive [_] => FALSE;
mutually_recursive _ => TRUE;
end;
# If no_offset is FALSE, use the following versions:
#
# fun adjOff (i, off) = i - off
# fun mutRec _ = FALSE
# ************************************************************************
# SYMBOL TABLE *
# ************************************************************************
stipulate # Start of abstype-replacement recipe -- see http://successor-ml.org/index.php?title=Degrade_abstype_to_derived_form
Dictionary = DICTIONARY ( List( ncf::Codetemp ), # Values
List( (ncf::Codetemp, Closure_Rep) ), # Closures
List( ncf::Codetemp ), # Disposable cells
iht::Hashtable( Chunk ) # What map
); #
herein #
Dictionary = Dictionary; # End of abstype-replacement recipe.
# *************************************************************************
# Dictionary Initializations and Augmentations *
# *************************************************************************
exception NOT_BOUND;
#
fun empty_dictionary ()
=
DICTIONARY ([],[],[], iht::make_hashtable { size_hint => 32, not_found_exception => NOT_BOUND });
# Add a new chunk to a dictionary:
#
fun augment (m as (v, chunk), e as DICTIONARY (value_l, closure_l, disp_l, what_map))
=
{ iht::set what_map m;
#
case chunk
#
VALUE _ => DICTIONARY (v ! value_l, closure_l, disp_l, what_map);
CLOSURE cr => DICTIONARY ( value_l, (v, cr) ! closure_l, disp_l, what_map);
_ => e;
esac;
};
# Add a simple program variable "v" with type t into dictionary
#
fun aug_value (v, t, dictionary)
=
augment ((v, VALUE t), dictionary);
# Add a list of value variables into dictionary
#
fun faug_value ([],[], dictionary) => dictionary;
faug_value (a ! r, t ! z, dictionary) => faug_value (r, z, aug_value (a, t, dictionary));
faug_value _ => bug "faugValue in closure.249";
end;
# Add a callee-save fate chunk into dictionary
#
fun aug_callee (v, c, csg, csf, dictionary)
=
augment ( (v, CALLEE (c, csg, csf)), dictionary);
# Add a known fate function chunk into dictionary:
#
fun aug_kcont (v, l, gfree, ffree, csg, csf, dictionary)
=
{ kchunk = FUNCTION { label => l,
gpfree => gfree,
fpfree => ffree,
csdef => THE (csg, csf)
};
augment ( (v, kchunk), dictionary);
};
# Add a general known function chunk into dictionary
#
fun aug_known (v, l, gfree, ffree, dictionary)
=
{ kchunk = FUNCTION { label => l,
gpfree => gfree,
fpfree => ffree,
csdef => NULL
};
augment ( (v, kchunk), dictionary);
};
# Add a public-function chunk into dictionary:
#
fun aug_esc_fun (v, i, CLOSURE_REP { offset, closure }, dictionary)
=
{ clo = CLOSURE (CLOSURE_REP { offset => offset+i, closure });
#
augment ( (v, clo), dictionary);
};
###########################################################################
# Dictionary Printing (for debugging)
###########################################################################
im = int::to_string: Int -> String;
vp = pr o tmp::name_of_highcode_codetemp;
#
fun vp' (v, m, n)
=
{ vp v;
pr " fd=";
pr (im m);
pr " ld=";
pr (im n);
};
#
fun ifkind ncf::PRIVATE_TAIL_RECURSIVE_FN => pr " PRIVATE_TAIL_RECURSIVE_FN ";
ifkind ncf::PRIVATE_FN => pr " PRIVATE_FN ";
ifkind ncf::PRIVATE_RECURSIVE_FN => pr " PRIVATE_RECURSIVE_FN ";
#
ifkind ncf::PUBLIC_FN => pr " PUBLIC_FN ";
ifkind ncf::FATE_FN => pr " FATE_FN ";
ifkind ncf::PRIVATE_FATE_FN => pr " PRIVATE_FATE_FN ";
#
ifkind _ => pr " STRANGE_KIND ";
end;
#
fun plist p l
=
{ apply (\\ v = { pr " "; p v; })
l;
pr "\n";
};
ilist = plist vp;
i_vlist = plist vp';
i_klist = plist ifkind;
#
fun sayv (ncf::CODETEMP v) => vp v;
sayv (ncf::LABEL v) => { pr "(L)"; vp v;};
sayv (ncf::INT i) => { pr "(I)"; pr (int::to_string i);};
sayv (ncf::INT1 i) => { pr "(I32)"; pr (one_word_unt::to_string i);};
sayv (ncf::FLOAT64 r) => pr r;
sayv (ncf::STRING s) => { pr "\""; pr s; pr "\"";};
sayv (ncf::CHUNK _) => pr "**CHUNK**";
sayv (ncf::TRUEVOID ) => pr "**TRUEVOID**";
end;
vallist = plist sayv;
#
fun print_dictionary (DICTIONARY (value_l, closure_l, disp_l, what_map))
=
{ fun ip (i: Int)
=
pr (int::to_string i);
tlist = plist (\\ (a, b) = { vp a; pr "/"; sayv (ncf::LABEL b);});
#
fun fp (v, FUNCTION { label, gpfree, fpfree, ... } )
=>
{ vp v;
pr "/known ";
sayv (ncf::LABEL label);
pr " -";
ilist (gpfree@fpfree);
};
fp _ => ();
end;
#
fun cp (v, CALLEE (v', gl, fl))
=>
{ vp v;
pr "/callee (G) ";
sayv v';
pr " -";
vallist gl;
vp v;
pr "/callee (F) ";
sayv v';
pr " -";
vallist fl;
};
cp _ => ();
end;
#
fun p (indent, l, seen)
=
apply c l
where
fun c (v, CLOSURE_REP { offset, closure => { functions, values, closures, stamp, kind, ... } } )
=
{ indent();
pr "Closure ";
vp v;
pr "/";
ip stamp;
pr "@_";
ip offset;
if (member seen stamp)
pr "(seen)\n";
else
pr ":\n";
case functions
NIL => ();
_ => { indent(); pr " Funs:"; tlist functions;};
esac;
case values
NIL => ();
_ => { indent(); pr " Vals:"; ilist values; };
esac;
p ( \\() = { indent();
pr " ";
},
closures,
enter (stamp, seen)
);
fi;
};
end;
pr "Values:"; ilist value_l;
pr "Closures:\n"; p (\\ () = (), closure_l, NIL);
pr "Disposable records:\n"; ilist disp_l;
pr "Known function mapping:\n"; iht::keyed_apply fp what_map;
pr "Callee-save fate mapping:\n";
iht::keyed_apply cp what_map;
};
##########################################################################
# Dictionary Lookup (whatIs, returning chunk type)
##########################################################################
exception LOOKUP (ncf::Codetemp, Dictionary);
#
fun what_is (dictionary as DICTIONARY (_, _, _, what_map), v)
=
iht::get what_map v
except
NOT_BOUND = raise exception LOOKUP (v, dictionary);
# Add v to the access dictionary.
# v must be in what_map already:
#
fun augvar (v, e as DICTIONARY (value_l, closure_l, disp_l, what_map))
=
case (what_is (e, v))
#
VALUE _ => DICTIONARY (v ! value_l, closure_l, disp_l, what_map);
CLOSURE cr => DICTIONARY (value_l, (v, cr) ! closure_l, disp_l, what_map);
_ => bug "augvar in nextcode/make-nextcode-closures-g.pkg:77";
esac;
##########################################################################
# Dictionary Access (where_is, returning chunk access path)
#
fun where_is (dictionary as DICTIONARY (value_l, closure_l, _, what_map), target)
=
{ fun bfs (NIL, NIL) => raise exception LOOKUP (target, dictionary);
bfs (NIL, next) => bfs (next, NIL);
bfs ((h, ox as (_, CLOSURE_REP { offset, closure => { functions, values, closures, stamp, ... } })) ! m, next)
=>
{ fun cls (NIL, _, next)
=>
bfs (m, next);
cls ((u as (v, cr)) ! t, i, next)
=>
if (target == v)
#
h (ncf::VIA_SLOT (i, ncf::SLOT 0), []);
else
nh = \\ (p, z) = h (ncf::VIA_SLOT (i, p), u ! z);
#
cls (t, i+1, (nh, u) ! next);
fi;
end;
#
fun vls (NIL, i)
=>
cls (closures, i, next);
vls (v ! t, i)
=>
if (target == v)
#
h (ncf::VIA_SLOT (i, ncf::SLOT 0), []);
else
vls (t, i+1);
fi;
end;
#
fun fns (NIL, i)
=>
vls (values, adj_off (i, offset));
fns ((v, l) ! t, i)
=>
if (target == v)
#
i == offset ?? h (ncf::SLOT 0, [])
:: h (ncf::SLOT (i-offset),[ox]);
else
fns (t, i+1);
fi;
end;
if (target == stamp)
#
offset == 0 ?? h (ncf::SLOT 0, [])
:: h (ncf::SLOT(-offset), [ox]);
else
fns (functions, 0);
fi;
};
end;
#
fun search closures
=
{ s = map (\\ x = (\\ (p, z) = (#1 x, p, z), x))
closures;
PATH (bfs (s, NIL));
};
#
fun with_tgt (v, CLOSURE_REP { closure, ... })
=
member closure.free target;
#
fun get_c ((v, cr) ! tl)
=>
if (target == v)
#
DIRECT;
else
case cr
#
CLOSURE_REP { closure => { functions => [], ... }, ... }
=>
get_c tl;
#
CLOSURE_REP { offset, closure => { functions, ... } }
=>
{ my (y, _) = list::nth (functions, offset);
if ((target==y)) PATH (v, ncf::SLOT 0, []);
else get_c tl;
fi;
};
esac;
fi;
get_c NIL
=>
search (sublist with_tgt closure_l);
end;
#
fun get_v (v ! tl)
=>
target == v ?? DIRECT
:: get_v tl;
get_v NIL => search closure_l;
end;
case (what_is (dictionary, target))
#
FUNCTION _ => DIRECT;
CALLEE _ => DIRECT;
CLOSURE _ => get_c closure_l;
VALUE _ => get_v value_l;
esac;
};
##########################################################################
# Dictionary Filtering (get the set of current reusable closures)
##########################################################################
# Extract all closures at
# top n levels, containing
# duplicates.
#
fun extract_closures (l, n, base)
=
s (h (n, l, l@base), [], [])
where
fun g (_, CLOSURE_REP { closure => { closures, ... }, ... })
=
closures;
#
fun h (k, r as _ ! _, z)
=>
if (k <= 0)
#
z;
else
nl = list::cat (map g r);
h (k - 1, nl, nl @ z);
fi;
h (k,[], z) => z;
end;
#
fun s ((u as (v, _)) ! z, vl, r)
=>
member vl v ?? s (z, vl, r)
:: s (z, enter (v, vl), u ! r);
s ([], vl, r) => r;
end;
end;
# Fetch all free variables
# residing above level n
# in the closure cr:
#
fun fetch_free (v, CLOSURE_REP { closure => { closures, functions, values, ... }, ... }, n)
=
if (n <= 0)
#
[v];
else
fold_backward g (uniq (v ! values@(map #1 functions))) closures
where
fun g ((x, cr), z)
=
merge (fetch_free (x, cr, n - 1), z);
end;
fi;
# Filter out all closures in
# the current dictionary that are
# safe to reuse:
#
fun fetch_closures (dictionary as DICTIONARY (_, closure_l, _, _), lives, fkind)
=
{ my (closlist, lives)
=
fold_backward
( \\ (v, (z, l))
=
case (what_is (dictionary, v) )
#
(CLOSURE (cr as (CLOSURE_REP { closure, ... })))
=>
((v, cr) ! z, merge (closure.free, l));
_ => (z, l);
esac
)
([], lives)
lives;
#
fun reusable (v, CLOSURE_REP { closure, ... })
=
( (sharable (closure.kind, fkind))
and
( (subset (closure.core, lives))
or
(member lives v)
)
);
#
fun reusable2 (_, CLOSURE_REP { closure, ... })
=
sharable (closure.kind, fkind);
#
fun fblock (_, CLOSURE_REP { closure => { kind => ncf::rk::FLOAT64_BLOCK, ... }, ... }) => TRUE;
fblock (_, CLOSURE_REP { closure => { kind => ncf::rk::FLOAT64_FATE_FN, ... }, ... }) => TRUE;
#
fblock _ => FALSE;
end;
level = 4; # Should be made adjustable in the future XXX BUGGO FIXME
closlist = extract_closures (closure_l, level, closlist);
(partition fblock closlist)
->
(fclist, gclist);
( sublist reusable gclist,
sublist reusable2 fclist
);
};
# Return the immediately enclosing
# closure, if any. This is a hack:
#
fun get_immed_closure (DICTIONARY (_, closure_l, _, _))
=
getc closure_l
where
fun getc ([z]) => THE z;
getc (_ ! tl) => getc tl;
getc NIL => NULL;
end;
end;
##########################################################################
# Fate Frames Book-keeping (in support of quasi-stack frames) *
##########################################################################
# vl is a list of fate frames
# that were reused along this path
#
fun recover_frames (vl, DICTIONARY (value_l, closure_l, disp_l, what_map))
=
DICTIONARY (value_l, closure_l, ndisp_l, what_map)
where
fun h (a, l)
=
if (member vl a) l;
else a ! l;
fi;
ndisp_l = fold_backward h [] disp_l;
end;
# Save the fate closure
# "v" and its descendants:
#
fun save_frames (v, CLOSURE_REP { closure => { free, kind => (ncf::rk::FATE_FN | ncf::rk::FLOAT64_FATE_FN), ... }, ... }, dictionary)
=>
recover_frames (free, dictionary);
save_frames (_, _, dictionary) => dictionary;
end;
# Install the set of live frames at
# the entrance of this fate:
#
fun install_frames (newd, dictionary as DICTIONARY (value_l, closure_l, disp_l, what_map))
=
DICTIONARY (value_l, closure_l, newd @ disp_l, what_map);
# Split the current disposable frame
# list into two based on the context:
#
fun split_dictionary (DICTIONARY (value_l, closure_l, disp_l, w), inherit)
=
{ (partition inherit disp_l) -> (d1, d2);
#
( DICTIONARY ([], [], d1, w),
DICTIONARY (value_l, closure_l, d2, w)
);
};
# Return the set of disposable frames:
#
fun dead_frames (DICTIONARY (_, _, disp_l, _))
=
disp_l;
end; # Abstype dictionary
Frags = List ( ( ncf::Callers_Info, # If all callers are known, calling convention can be customized for space and time efficiency.
ncf::Codetemp, # fun_id -- an Int uniquely identifying the function.
List( ncf::Codetemp ), # fun_parameters.
List( ncf::Type ), # fun_parameter_types.
ncf::Instruction, # fun_body.
Dictionary,
Int,
List( ncf::Value ),
List( ncf::Value ),
Null_Or( ncf::Codetemp )
)
);
##########################################################################
# UTILITY FUNCTIONS FOR CALLEE-SAVE REGISTERS
##########################################################################
# It doesnot take the looping freevar
# into account, NEEDS MORE WORK. XXX BUGGO FIXME
#
fun fetch_csregs (c, m, n, dictionary)
=
case (what_is (dictionary, c) )
#
CALLEE (_, csg, csf)
=>
( cuthead (m, csg),
cuthead (n, csf)
);
#
FUNCTION { csdef => THE (csg, csf), ... }
=>
( cuthead (m, csg),
cuthead (n, csf)
);
_ => ([], []);
esac;
# Fetch m csgpregs and n csfpgregs
# from the default fate c:
#
fun fetch_csvars (c, m, n, dictionary)
=
{ (fetch_csregs (c, m, n, dictionary))
->
(gpregs, fpregs);
( uniqvar gpregs,
uniqvar fpregs
);
};
# Fill the empty csgpregs
# with the closure:
#
fun fill_csregs (csg, c)
=
h (csg, [], c)
where
fun g ( [], l) => l;
g (a ! r, l) => g (r, a ! l);
end;
#
fun h (NULL ! r, x, c) => g (x, c ! r);
h ( u ! r, x, c) => h (r, u ! x, c);
h ( [], x, c) => bug "no empty slot in fillCSregs in make-nextcode-closures-g.pkg";
end;
end;
# Fill the empty cs formals
# with new variables,
# augment the dictionary:
#
fun fill_csformals (gpbase, fpbase, dictionary, ft)
=
fold_backward h (fold_backward g (dictionary,[],[]) fpbase) gpbase
where
fun h (THE v, (e, a, c))
=>
(augvar (v, e), v ! a, (ft v) ! c);
h (NULL, (e, a, c))
=>
{ v = issue_highcode_codetemp ();
#
(aug_value (v, ncf::bogus_pointer_type, e), v ! a, ncf::bogus_pointer_type ! c);
};
end;
#
fun g (THE v, (e, a, c))
=>
(augvar (v, e), v ! a, ncf::typ::FLOAT64 ! c);
g (NULL, (e, a, c))
=>
{ v = issue_highcode_codetemp ();
#
(aug_value (v, ncf::typ::FLOAT64, e), v ! a, ncf::typ::FLOAT64 ! c);
};
end;
end;
# Get all free variables in cs regs,
# augment the dictionary:
#
fun vars_csregs (gpbase, fpbase, dictionary)
=
(gfree, ffree, dictionary)
where
fun h (NULL, (e, l)) => (e, l);
h (THE v, (e, l)) => (augvar (v, e), enter (v, l));
end;
(fold_backward h (dictionary,[]) gpbase) -> (dictionary, gfree);
(fold_backward h (dictionary,[]) fpbase) -> (dictionary, ffree);
end;
# Get all free variables
# covered by the cs regs
#
fun freev_csregs (gpbase, dictionary)
=
fold_backward h [] gpbase
where
fun h (THE v, l)
=>
case (what_is (dictionary, v) )
#
(CLOSURE (CLOSURE_REP { closure => { free, kind => (ncf::rk::FATE_FN | ncf::rk::FLOAT64_FATE_FN), ... }, ... }))
=>
(merge (free, l));
#
_ => l;
esac;
h (NULL, l) => l;
end;
end;
# Partnull cuts out the head
# of csregs till the first
# empty position:
#
fun partition_to_null l
=
h (l, [])
where
fun h ( [], r) => bug "partitionToNull. no empty position in closure 343";
h (NULL ! z, r) => (reverse (NULL ! r), z);
h ( u ! z, r) => h (z, u ! r);
end;
end;
# Create a template of the
# base callee-save registers
# (n: extra cs regs)
#
fun make_base (regs, free, n)
=
fold_backward h (extra_dummy (n), []) regs
where
fun h (ncf::CODETEMP v, (r, z))
=>
member free v ?? ((THE v) ! r, enter (v, z))
:: ( dumcs ! r, z );
h (_, (r, z))
=>
(dumcs ! r, z);
end;
end;
# Modify the base, retain only
# those variables in free:
#
fun modify_base (base, free, n)
=
fold_backward h ([], free, n) base
where
fun h (s as (THE v), (r, z, m))
=>
if (member free v)
#
(s ! r, rmv (v, z), m);
else
if (m > 0)
#
( s ! r, z, m - 1);
else
(dumcs ! r, z, m );
fi;
fi;
h (NULL, (r, z, m))
=>
(NULL ! r, z, m);
end;
end;
# Fill the empty callee-save registers,
# assuming newv can be put in base:
#
fun fill_base (base, newv)
=
h (base, [], newv)
where
fun g ( [], s) => s;
g (a ! r, s) => g (r, a ! s);
end;
#
fun h ( s, l, []) => g (l, s);
h ( NULL ! z, l, a ! r) => h (z, (THE a) ! l, r);
h ((u as (THE _)) ! z, l, r) => h (z, u ! l, r);
h ( [], l, _) => bug "no enough slots: fillBase 398 in make-nextcode-closures-g.pkg";
end;
end;
##########################################################################
# VARIABLE ACCESS PATH LOOKUP
##########################################################################
# Simulating the OFFSET operation
# by reconstructing the closures:
#
fun offset ( (z, CLOSURE_REP { offset => n, closure => { functions, values, closures, ... } }), i, u, x, dictionary)
=
{ # Invariant: length functions > 1
(list::nth (functions, n+i))
->
(_, l);
case u
#
ncf::CODETEMP z'
=>
if (z != z') bug "unexpected case in offset 1"; fi;
_ => bug "unexpected case in offset 2";
esac;
label = (ncf::LABEL l, offp0);
vl = case (closures, values)
#
(([(v, _)], []) | ([], [v])) => [label, (ncf::CODETEMP v, offp0)];
([], []) => [label];
_ => bug "unexpected case in offset 3";
esac;
(record_elements (ncf::rk::PUBLIC_FN, vl, x, dictionary))
->
(header, dictionary);
(header, dictionary);
}
# If no_offset is FALSE, use this version
#
# fun offset (_, i, record, to_temp, dictionary)
# =
# { header = \\ next = ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next };
# (header, dictionary);
# };
# Build the header by partially
# following an access path:
also
fun pfollow (p, dictionary, header)
=
case p
#
(v, np as ((ncf::SLOT 0) | (ncf::VIA_SLOT(_, ncf::SLOT 0))), [])
=>
((ncf::CODETEMP v, np), dictionary, header);
(v, np as (ncf::SLOT i), [c as (_, cr as CLOSURE_REP { offset => n, closure })])
=>
{ w = make_closure_codetemp ();
my (nh, dictionary) = offset (c, i, ncf::CODETEMP v, w, dictionary);
dictionary = augment ((w, CLOSURE (CLOSURE_REP { offset => n+i, closure })), dictionary);
((ncf::CODETEMP w, ncf::SLOT 0), dictionary, header o nh);
};
(v, ncf::VIA_SLOT (i, np), (to_temp, cr) ! z)
=>
{ dictionary = augment ((to_temp, CLOSURE cr), dictionary);
nhdr = \\ next = ncf::GET_FIELD_I { i, record => ncf::CODETEMP v, to_temp, type => ncf::bogus_pointer_type, next };
#
pfollow ((to_temp, np, z), dictionary, header o nhdr);
};
_ => bug "pfollow on an inconsistent path";
esac
# Build the header by
# following an access path:
also
fun follow (rootvar, type)
=
g
where
#
fun g ((v, ncf::SLOT 0, []), dictionary, h)
=>
(dictionary, h o (\\ next = ncf::GET_ADDRESS_OF_FIELD_I { i => 0, record => ncf::CODETEMP v, to_temp => rootvar, next }));
g ((v, ncf::SLOT i, [c]), dictionary, h)
=>
{ my (nh, dictionary) = offset (c, i, ncf::CODETEMP v, rootvar, dictionary);
# Dictionary is updated by the client of "follow"
(dictionary, h o nh);
};
g ((v, ncf::VIA_SLOT (i, ncf::SLOT 0), []), dictionary, h)
=>
(dictionary, h o (\\ next = ncf::GET_FIELD_I { i, record => ncf::CODETEMP v, to_temp => rootvar, type, next }));
g ((v, ncf::VIA_SLOT (i, p), (to_temp, cr) ! z), dictionary, h)
=>
{ dictionary = augment ((to_temp, CLOSURE cr), dictionary);
#
g ( (to_temp, p, z),
dictionary,
h o (\\ next = ncf::GET_FIELD_I { i, record => ncf::CODETEMP v, to_temp, type => ncf::bogus_pointer_type, next })
);
};
g _ => bug "follow on an inconsistent path";
end;
end
##########################################################################
# record_elements finds the complete access paths for elements of a record.
# It returns a header for profiling purposes if needed.
##########################################################################
also
fun record_elements (kind, l, to_temp, dictionary)
=
{ fun g (u as (ncf::CODETEMP v, ncf::SLOT 0), (l, cl, header, dictionary))
=>
{ dictionary = case (what_is (dictionary, v)) # May be unnecessary
#
CLOSURE cr => save_frames (v, cr, dictionary);
_ => dictionary;
esac;
my (m, cost, nhdr, dictionary)
=
case (where_is (dictionary, v))
#
DIRECT => (u, 0, header, dictionary);
#
PATH (np as (start, path, _))
=>
{ n = ncf::lenp path;
#
nhdr = if *coc::static_closure_size_profiling
#
sprof::incln n;
header o (\\ next = ncf::STORE_TO_RAM { op => ncf::p::ACCLINK,
args => [ncf::INT n, ncf::CODETEMP start],
next
}
);
else
header;
fi;
my (u, dictionary, nhdr)
=
if (*coc::sharepath)
#
pfollow (np, dictionary, nhdr);
else
((ncf::CODETEMP start, path), dictionary, nhdr);
fi;
(u, n, nhdr, dictionary);
};
esac;
(m ! l, cost ! cl, nhdr, dictionary);
};
g (u as (ncf::CODETEMP _, _), _) => bug "unexpected case in recordEl";
g (u, (l, cl, header, dictionary)) => (u ! l, 0 ! cl, header, dictionary);
end;
(fold_backward g (NIL, NIL, \\ ce = ce, dictionary) l)
->
(fields, cl, header, dictionary);
header = if (*coc::allocprof) header o (prof_rec_links cl);
else header;
fi;
nhdr = \\ next = header (ncf::DEFINE_RECORD { kind, fields, to_temp, next });
(nhdr, dictionary);
};
############################################################################
# fix_access finds the access path to a variable. A header to select the
# variable from the dictionary is returned, along with a new dictionary
# that reflects the actions of the header (this last implements a "lazy
# display"). fix_access actually causes renamings -- the variable
# requested is rebound if it is not immediately available in the
# dictionary, these renamings are later eliminated by an "unrebind" pass
# which basically does the alpha convertions.
#
fun fix_access (args, dictionary)
=
fold_backward access (dictionary, \\ x => x; end ) args
where
#
fun access (ncf::CODETEMP rootvar, (dictionary, header))
=>
{ what = what_is (dictionary, rootvar);
#
my (dictionary, t)
=
case what
#
VALUE x => (dictionary, x);
CLOSURE cr => (save_frames (rootvar, cr, dictionary), ncf::bogus_pointer_type);
_ => bug "Callee or Known in fixAccess closure";
esac;
case (where_is (dictionary, rootvar))
#
DIRECT => (dictionary, header);
#
PATH (p as (_, path, _))
=>
{ my (dictionary, header)
=
follow (rootvar, t) (p, dictionary, header);
dictionary = augment ((rootvar, what), dictionary);
#
fun prof_l (n)
=
if (not *coc::allocprof)
#
if (n > 0 and *coc::static_closure_size_profiling)
#
sprof::incln (n);
\\ next = ncf::STORE_TO_RAM { op => ncf::p::ACCLINK,
args => [ncf::INT n, ncf::CODETEMP rootvar],
next
};
else
\\ ce = ce;
fi;
else
prof_links n;
fi;
( dictionary,
header o prof_l (ncf::lenp path)
);
};
esac;
};
access (_, y) => y;
end;
end;
##########################################################################
# fix_args is a slightly modified version of fix_access. It's used to find
# the access path of function arguments in the APPLY expressions
#
fun fix_args (args, dictionary)
=
fold_backward access ([], dictionary, \\ x = x) args
where
fun access (z as (ncf::CODETEMP rootvar), (result, dictionary, h))
=>
{ what = what_is (dictionary, rootvar);
#
my (dictionary, t)
=
case what
#
VALUE x => (dictionary, x);
CLOSURE cr => (save_frames (rootvar, cr, dictionary), ncf::bogus_pointer_type);
_ => (dictionary, ncf::bogus_pointer_type);
esac;
case what
#
FUNCTION _ => bug "Known in fixArgs make-nextcode-closures-g.pkg";
CALLEE (l, csg, csf)
=>
{ nargs = (l ! csg) @ csf @ result;
#
(fix_access (nargs, dictionary))
->
(dictionary, header);
(nargs, dictionary, h o header);
};
_ => case (where_is (dictionary, rootvar))
#
DIRECT => (z ! result, dictionary, h);
#
PATH (p as (_, path, _))
=>
{ (follow (rootvar, t) (p, dictionary, h))
->
(dictionary, header);
dictionary = augment ((rootvar, what), dictionary);
fun prof_l (n)
=
if (not *coc::allocprof)
#
if (n > 0 and *coc::static_closure_size_profiling)
#
sprof::incln (n);
\\ next = ncf::STORE_TO_RAM { op => ncf::p::ACCLINK,
args => [ncf::INT n, ncf::CODETEMP rootvar],
next
};
else
\\ ce = ce;
fi;
else
prof_links n;
fi;
(z ! result, dictionary, header o prof_l (ncf::lenp path));
};
esac;
esac;
};
access (z, (result, dictionary, h))
=>
(z ! result, dictionary, h);
end;
end;
##########################################################################
# CLOSURE DISPOSAL
##########################################################################
# Dispose the set of dead fate closures
#
fun dispose_frames (dictionary)
=
if mp::quasi_stack
#
vl = dead_frames (dictionary);
(fix_access (map ncf::CODETEMP vl, dictionary))
->
(dictionary, header);
#
fun g (v ! r, h)
=>
g (r, h o (\\ next = ncf::STORE_TO_RAM { op => ncf::p::FREE,
args => [ncf::CODETEMP v],
next
}
) );
g ([], h)
=>
if (*coc::allocprof) ((prof_ref_cell (length vl)) o header o h);
else header o h;
fi;
end;
(dictionary, g (vl, header));
else
(dictionary, \\ ce = ce);
fi;
##########################################################################
# CLOSURE STRATEGIES
##########################################################################
# Produce the nextcode header and
# modify the dictionary for
# the new closure:
#
fun make_closure (cname, contents, cr, record_kind, fkind, dictionary)
=
{ if *coc::static_closure_size_profiling
#
sprof::incfk (fkind, length contents);
fi;
l = map (\\ v = (v, offp0)) contents;
(record_elements (record_kind, l, cname, dictionary))
->
(header, dictionary);
nhdr = if *coc::allocprof
#
prof = case fkind
ncf::PRIVATE_FN => prof_kclosure;
ncf::PUBLIC_FN => prof_closure;
_ => prof_cclosure;
esac;
(prof (length contents)) o header;
else
header;
fi;
dictionary = augment ((cname, CLOSURE cr), dictionary);
case fkind
#
(ncf::FATE_FN|ncf::PRIVATE_FATE_FN) => (nhdr, dictionary, [cname]);
_ => (nhdr, dictionary, [ ]);
esac;
};
# Build an unboxed closure,
# currently not disposable even if fkind==next_fn.
# Place one_word_int's after floats for proper alignment
#
fun closure_ub_fn (cn, free, rk, fk, dictionary)
=
{ nfree = map (\\ (v, _, _) = v) free;
#
ul = map ncf::CODETEMP nfree;
cr = CLOSURE_REP
{
offset => 0,
closure => { functions => [],
closures => [],
values => nfree,
core => [],
free => enter (cn, nfree),
kind => rk,
stamp => cn
}
};
( make_closure (cn, ul, cr, rk, fk, dictionary),
cr
);
};
#
fun closure_unboxed (cn, int1free, otherfree, fk, dictionary)
=
case (int1free, otherfree)
#
([], []) => bug "unexpected case in closureUnboxed 333";
([], _)
=>
{ rk = unboxed_float_kind fk;
#
#1 (closure_ub_fn (cn, otherfree, rk, fk, dictionary));
};
(_, [])
=>
{ rk = ncf::rk::INT1_BLOCK;
#
#1 (closure_ub_fn (cn, int1free, rk, fk, dictionary));
};
_
=>
{ rk1 = unboxed_float_kind fk;
#
cn1 = make_closure_codetemp ();
(closure_ub_fn (cn1, otherfree, rk1, fk, dictionary))
->
((nh1, dictionary, nf1), cr1);
rk2 = ncf::rk::INT1_BLOCK;
cn2 = make_closure_codetemp ();
(closure_ub_fn (cn2, int1free, rk2, fk, dictionary))
->
((nh2, dictionary, nf2), cr2);
rk = boxed_kind fk;
nfree = map (\\ (v, _, _) = v) (int1free@otherfree);
nfs = [cn1, cn2];
ncs = [(cn1, cr1), (cn2, cr2)];
ul = map ncf::CODETEMP nfs;
cr = CLOSURE_REP
{
offset => 0,
closure => { functions => [],
closures => ncs,
values => [],
core => [],
free => enter (cn, nfs @ nfree),
kind => rk,
stamp => cn
}
};
(make_closure (cn, ul, cr, rk, fk, dictionary))
->
(nh, dictionary, nfs);
(nh1 o nh2 o nh, dictionary, nfs);
};
esac;
# old code
#
# let nfree = map (\\ (v, _, _) => v) (otherfree @ int1free)
# ul = map ncf::CODETEMP nfree
# rk = unboxedKind (fk)
# rk = case (int1free, otherfree)
# of ([], _) => rk
# | (_,[]) => ncf::rk::INT1_BLOCK
# | _ => bug "unimplemented one_word_int + float (nclosure.1)"
# cr = CLOSURE_REP { offset => 0, closure => { functions=>[], closures=>[], values=>nfree, core=>[], free=>enter (cn, nfree), kind=rk, stamp=cn } }
# in make_closure (cn, ul, cr, rk, fk, dictionary)
# end
# Partition a set of free variables
# into small frames:
#
fun partition_by_frame (free)
=
if (not (mp::quasi_stack))
#
(free, []);
else
size = mp::quasi_frame_size;
#
fun h ([ ], n, t) => (t,[]);
h ([v], n, t) => (v ! t,[]);
h (z as (v ! r), n, t)
=>
if (n <= 1)
#
my (nb, nt)
=
h (z, size, []);
cn = make_closure_codetemp ();
(cn ! t, (cn, nb) ! nt);
else
h (r, n - 1, v ! t);
fi;
end;
h (free, size, []);
fi;
# Partition the free variables into
# closures and non-closures:
#
fun partition_by_kind (cfree, dictionary)
=
fold_backward g (NIL, NIL, NIL, NIL) cfree
where
fun g (v, (vls, cls, fv, cv))
=
{ chunk = what_is (dictionary, v);
#
case chunk
#
VALUE t
=>
( v ! vls,
cls,
enter (v, fv),
(small_chunk t) ?? cv :: enter (v, cv)
);
CLOSURE (cr as CLOSURE_REP { closure => { free, core, ... }, ... })
=>
( vls,
(v, cr) ! cls,
merge (free, fv),
merge (core, cv)
);
_ => bug "unexpected chunk in kind in nextcode/make-nextcode-closures-g.pkg";
esac;
};
end;
# Closure strategy: flat
#
fun flat (dictionary, cfree, rk, fk)
=
{ my (topfv, clist)
=
case rk
#
(ncf::rk::FATE_FN | ncf::rk::FLOAT64_FATE_FN)
=>
partition_by_frame cfree;
_ => (cfree, []);
esac;
#
fun g ((cn, free), (dictionary, header, nf))
=
{ (partition_by_kind (free, dictionary))
->
(vls, cls, fvs, cvs);
cr = CLOSURE_REP
{
offset => 0,
closure => { functions => [],
values => vls,
closures => cls,
kind => rk,
stamp => cn,
core => cvs,
free => enter (cn, fvs)
}
};
ul = (map ncf::CODETEMP vls) @ (map (ncf::CODETEMP o #1) cls);
(make_closure (cn, ul, cr, rk, fk, dictionary))
->
(nh, dictionary, nf2);
( dictionary,
header o nh,
nf2 @ nf
);
};
(fold_backward g (dictionary, \\ ce => ce; end, []) clist)
->
(dictionary, header, frames);
(partition_by_kind (topfv, dictionary))
->
(values, closures, fvars, cvars);
(closures, values, header, dictionary, fvars, cvars, frames);
};
# Closure strategy: linked
#
fun link (dictionary, cfree, rk, fk)
=
case (get_immed_closure dictionary)
#
NULL => flat (dictionary, cfree, rk, fk);
#
THE (z, CLOSURE_REP { closure => { free, ... }, ... })
=>
{ not_in = sublist (not o (member free)) cfree;
if (length (not_in) == length (cfree)) flat (dictionary, cfree, rk, fk);
else flat (dictionary, enter (z, cfree), rk, fk);
fi;
};
esac;
# Partition a set of free variables
# into layered groups based on their
# lud:
#
fun partition_into_layers (free, ccl)
=
{ fun find (r, (v, all) ! z)
=>
if (subset (r, all)) THE v;
else find (r, z);
fi;
find (r, []) => NULL;
end;
# Current limit of a new layer: 3
#
fun m ([], t, b) => bug "unexpected case in partitionIntoLayers in closure";
m ([v], t, b) => (enter (v, t), b);
m ([v, w], t, b) => (enter (v, enter (w, t)), b);
m (r, t, b)
=>
case (find (r, ccl))
#
NULL =>
{ nc = make_closure_codetemp ();
( enter (nc, t),
(nc, r) ! b
);
};
THE v =>
(enter(v,t), b);
esac;
end;
# Process the rest groups in free:
#
fun h ([], i: Int, r, t, b)
=>
m (r, t, b);
h ((v, _, j) ! z, i, r, t, b)
=>
if (j == i)
#
h (z, i, enter (v, r), t, b);
else
my (nt, nb) = m (r, t, b);
h (z, j, [v], nt, nb);
fi;
end;
# Cut out the top group and
# then process the rest:
#
fun g ((v, _, i) ! z, j, t)
=>
if (i == j) g (z, j, enter (v, t));
else h (z, i, [v], t, []);
fi;
g ( [], j, t)
=>
(t, []);
end;
my (topfv, botclos)
=
case (sortlud0 free)
#
[] => ([], []);
(u as ((_, _, j) ! _))
=>
g (u, j, []);
esac;
(topfv, botclos);
}; # fun partition_into_layers
# Closure strategy: layered
#
fun layer (dictionary, cfree, rk, fk, ccl)
=
{ (partition_into_layers (cfree, ccl))
->
(topfv, clist);
#
fun g ((cn, vfree), (bh, dictionary, nf))
=
{ (flat (dictionary, vfree, rk, fk))
->
(cls, vls, nh1, dictionary, fvs, cvs, nf1);
cr = CLOSURE_REP
{
offset => 0,
closure => { functions => [],
values => vls,
closures => cls,
kind => rk,
stamp => cn,
core => cvs,
free => enter (cn, fvs)
}
};
ul = (map ncf::CODETEMP vls) @ (map (ncf::CODETEMP o #1) cls);
(make_closure (cn, ul, cr, rk, fk, dictionary))
->
(nh2, dictionary, nf2);
( bh o nh1 o nh2,
dictionary,
nf2 @ nf1 @ nf
);
};
(fold_backward g (\\ ce = ce, dictionary, []) clist)
->
(header, dictionary, frames);
(flat (dictionary, topfv, rk, fk))
->
(cls, vls, nh, dictionary, fvs, cvs, nfr);
(cls, vls, header o nh, dictionary, fvs, cvs, nfr @ frames);
}; # fun layer
# Build a general closure,
# cg_options::closure_strategy matters:
#
fun closure_boxed (cn, fns, free, fk, ccl, dictionary)
=
{ rk = boxed_kind fk;
#
my (closures, values, header, dictionary, fvs, cvs, frames)
=
case *coc::closure_strategy
#
(4|3) => link (dictionary, map #1 free, rk, fk);
(2|1) => flat (dictionary, map #1 free, rk, fk);
_ => layer (dictionary, free, rk, fk, ccl);
esac;
my (closures, values, header, dictionary, fvs, cvs, frames, labels)
=
if (mutually_recursive fns) # Invariants length fns > 1
#
nlabs = [ ncf::LABEL (#2 (head fns)) ]; # No sharing.
case (closures, values)
#
(([],[_]) | ([_],[]) | ([],[]))
=>
(closures, values, header, dictionary, fvs, cvs, frames, nlabs);
_ => { nv = make_closure_codetemp();
ul = (map ncf::CODETEMP values) @ (map (ncf::CODETEMP o #1) closures);
nfvs = enter (nv, fvs);
cr = CLOSURE_REP
{
offset => 0,
closure => { functions => [],
values,
closures,
kind => rk,
stamp => nv,
core => cvs,
free => nfvs
}
};
(make_closure (nv, ul, cr, rk, fk, dictionary))
->
(nh, nenv, nf);
( [(nv, cr)],
[],
header o nh,
nenv,
nfvs,
cvs,
nf @ frames,
nlabs
);
};
esac;
else
(closures, values, header, dictionary, fvs, cvs, frames, map (ncf::LABEL o #2) fns);
fi;
nfvs = fold_backward enter (enter (cn, fvs)) (map #1 fns);
cr = CLOSURE_REP
{
offset => 0,
#
closure => { functions => fns,
values,
closures,
kind => rk,
stamp => cn,
core => cvs,
free => nfvs
}
};
ul = labels @ (map ncf::CODETEMP values) @ (map (ncf::CODETEMP o #1) closures);
(make_closure (cn, ul, cr, rk, fk, dictionary))
->
(nh, nenv, nf);
( header o nh,
nenv,
cr,
nf @ frames
);
}; # function closure_boxed
##########################################################################
# CLOSURE SHARING VIA THINNING
##########################################################################
# Check if some free variables
# are really not necessary:
#
fun shorten_free ([], [], _)
=>
([], []);
shorten_free (gpfree, fpfree, cclist)
=>
{ fun g ((v, free), l)
=
member3 gpfree v ?? merge (rmv (v, free), l)
:: l;
all = fold_backward g [] cclist;
( remove_v (all, gpfree),
remove_v (all, fpfree)
);
};
end;
# Check if ok to share with
# some closures in the
# enclosing dictionary:
#
fun thin_free (vfree, vlen, closlist, limit)
=
{ fun g (v, (l, m, n))
=
if (member3 vfree v ) (v ! l, m+1, n);
else ( l, m, n+1);
fi;
#
fun h ((v, cr as CLOSURE_REP { closure => { free, ... }, ... }), x)
=
{ (fold_backward g ([], 0, 0) free)
->
(zl, m, n);
if (m < limit) x;
else (v, zl, m*10000-n) ! x;
fi;
};
#
fun worse ((_, _, i), (_, _, j))
=
i < j;
#
fun m ([], s, r, k)
=>
(s, r);
m((v, x, _) ! y, s, r, k)
=>
if (k < limit)
#
(s, r);
else
my (nx, i, n, len)
=
accum_v (x, r);
if (len < limit)
#
m (y, s, r, k);
else
m ( y,
add_v ([v], i, n, s),
remove_v (nx, r),
k - len
);
fi;
fi;
end;
clist = lms::sort_list worse (fold_backward h [] closlist);
m (clist, [], vfree, vlen);
};
#
fun thin_fp_free (free, closlist)
=
thin_free (free, length free, closlist, 1);
#
fun thin_gp_free (free, closlist)
=
{ len = length free;
#
my (spill, free)
=
if (len <= 1) ([], free);
else thin_free (free, len, closlist, int::min (3, len));
fi;
merge_v (spill, free);
};
# Check if there is a closure
# containing all the free variables:
#
fun thin_all ( [], _, _) => [];
thin_all (free as [v], _, _) => free;
thin_all (free, cclist, n)
=>
{ vfree = map (\\ (v, _, _) = v) free;
#
fun g ((v, nfree), (x, y))
=
if (not (subset (vfree, nfree)))
#
(x, y);
else
len = length (difference (nfree, vfree));
len < y ?? (THE v, len)
:: (x, y);
fi;
my (result, _)
=
fold_backward g (NULL, 100000) cclist;
case result
#
NULL => free;
THE u => [(u, n, n)];
esac;
};
end;
##########################################################################
# Generating the true free variables (freeAnalysis), each knownfunc is
# replaced by its free variables and each fate by its callee-save
# registers. Finally, if two free variables are functions from the same
# closure, just one of them is sufficient to access both.
##########################################################################
#
fun same_closure_opt (free, dictionary)
=
case *coc::closure_strategy
#
1 => free; # Flat without aliasing.
3 => free; # Linked without aliasing.
#
_ => map #1 (uniq (map g free)) # All others have aliasing.
where
fun g (v as (z, _, _))
=
(v, what_is (dictionary, z));
#
fun uniq ((hd as (v, CLOSURE (CLOSURE_REP { closure => { stamp => s1, ... }, ... }))) ! tl)
=>
{ m' = uniq tl;
#
fun h (_, CLOSURE (CLOSURE_REP { closure => { stamp => s2, ... }, ... }))
=>
s1 == s2;
h _ => FALSE;
end;
list::exists h m' ?? m'
:: (hd ! m');
};
uniq (hd ! tl) => hd ! uniq tl;
uniq NIL => NIL;
end;
end;
esac;
#
fun free_analysis (gfree, ffree, dictionary)
=
{ fun g (w as (v, m, n), (x, y))
=
case (what_is (dictionary, v))
#
CALLEE (u, csg, csf)
=>
{ gv = add_v (entervar (u, uniqvar csg), m, n, x);
fv = add_v (uniqvar csf, m, n, y);
(gv, fv);
};
FUNCTION { gpfree, fpfree, ... }
=>
( add_v (gpfree, m, n, x),
add_v (fpfree, m, n, y)
);
_ => (merge_v ([w], x), y);
esac;
(fold_backward g ([], ffree) gfree)
->
(ngfree, nffree);
( same_closure_opt (ngfree, dictionary),
nffree
);
};
##########################################################################
# MAIN FUNCTION
#
# This fun is called (only) from
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg #
# where it constitutes one of the phases.
#
fun make_nextcode_closures (fk, f, vl, cl, ce)
=
{
# **************************************************************************
# utility functions that depends on register configurations *
# **************************************************************************
# Get the current register configuration:
#
maxgpregs = mp::num_int_regs;
maxfpregs = mp::num_float_regs - 2; # need 1 or 2 temps
num_csgpregs = mp::num_callee_saves;
num_csfpregs = mp::num_float_callee_saves;
unboxedfloat = mp::unboxed_floats;
untaggedint = mp::untagged_int;
# Check the validity of the callee-save configurations:
#
my (num_csgpregs, num_csfpregs)
=
if (num_csgpregs <= 0)
#
if (num_csfpregs > 0) bug "Wrong CS config 434 - make-nextcode-closures-g.pkg";
else (0, 0);
fi;
else
if (num_csfpregs >= 0) (num_csgpregs, num_csfpregs);
else (num_csgpregs, 0);
fi;
fi;
base_dictionary = empty_dictionary (); # Initialize the base dictionary.
# Find out the nextcode type of an arbitrary program variable
#
fun get_cty v # So "cty" == "nextcode type"? -- CrT
=
case (what_is (base_dictionary, v))
#
VALUE t => t;
_ => ncf::bogus_pointer_type;
esac;
# Check if a variable is a float number:
#
is_flt = if unboxedfloat
#
\\ v = case (get_cty v)
#
ncf::typ::FLOAT64 => TRUE;
_ => FALSE;
esac;
else
\\ _ = FALSE;
fi;
#
fun is_flt3 (v, _, _)
=
is_flt v;
# Check if a variable is of boxed type --- no longer used!
#
# isBoxed3 =
# if untaggedint then
# (\\ (v, _, _) =>
# (case (get_cty v)
# of ncf::typ::FLOAT64 => bug "isBoxed never applied to floats in make-nextcode-closures-g.pkg"
# | ncf::typ::INT => FALSE
# | _ => TRUE))
# else
# (\\ (v, _, _) =>
# ((case (get_cty v)
# of INT1t => FALSE
# | _ => TRUE) except _ => TRUE))
# Check if a variable is an one_word_int:
#
fun is_int1 (v, _, _)
=
case (get_cty v)
#
ncf::typ::INT1 => TRUE;
_ => FALSE;
esac;
# Count the number of GP and FP
# registers needed for a
# list of lvars:
#
fun is_flt_cty ncf::typ::FLOAT64 => unboxedfloat;
is_flt_cty _ => FALSE;
end;
#
fun numgp (m, ncf::typ::FATE ! z) => numgp (m-num_csgpregs - 1, z);
#
numgp (m, x ! z) => if (is_flt_cty x) numgp (m, z);
else numgp (m - 1, z);
fi;
numgp (m, []) => m;
end;
#
fun numfp (m, ncf::typ::FATE ! z) => numfp (m-num_csfpregs, z);
#
numfp (m, x ! z) => if (is_flt_cty x) numfp (m - 1, z);
else numfp (m, z);
fi;
numfp (m, []) => m;
end;
################################################################
# Check the formal arguments of a function and replace the
# fate variable with a set of variables representing
# its callee- save register dictionary variables.
################################################################
adjust_args
=
{ fun adjust1 (args, l, dictionary)
=
fold_backward g (NIL, NIL, NIL, NIL, NULL, dictionary) (zip (args, l))
where
fun g ((a, t), (al, cl, cg, cf, rt, dictionary))
=
if (t == ncf::typ::FATE)
#
w = clone_highcode_codetemp a;
my (csg, clg) = extra_lvar (num_csgpregs, ncf::bogus_pointer_type);
my (csf, clf) = extra_lvar (num_csfpregs, ncf::typ::FLOAT64);
csgv = map ncf::CODETEMP csg;
csfv = map ncf::CODETEMP csf;
dictionary = aug_callee (a, ncf::CODETEMP w, csgv, csfv, dictionary);
nargs = w ! (csg @ csf);
ncl = ncf::typ::FATE ! (clg @ clf);
dictionary = faug_value (nargs, ncl, dictionary);
case rt
NULL => (nargs @ al, ncl @ cl, csgv, csfv, THE a, dictionary);
THE _ => bug "closure/adjustArgs: >1 fate";
esac;
else
( a ! al,
t ! cl,
cg,
cf,
rt,
aug_value (a, t, dictionary)
);
fi;
end;
#
fun adjust2 (args, l, dictionary)
=
fold_backward g (NIL, NIL, NIL, NIL, NULL, dictionary) (zip (args, l))
where
fun g ((a, t), (al, cl, cg, cf, rt, dictionary))
=
( a ! al,
t ! cl,
cg,
cf,
rt,
aug_value (a, t, dictionary)
);
end;
num_csgpregs > 0 ?? adjust1
:: adjust2;
};
#############################################################################
# Calculate the set of free variables and their
# live range for each function naming. # See: src/lib/compiler/back/top/closures/make-per-function-free-variable-maps.pkg #############################################################################
(mfv::make_per_function_free_variable_maps (fk, f, vl, cl, ce))
->
((fk, f, vl, cl, ce), snum, nfreevars, ekfuns);
# old freevars code, now obsolete, but left here for debugging
# my (ofreevars, _, _) = FreeMap::freemapClose ce
#############################################################################
# makenv: create the dictionaries for functions in a ncf::DEFINE_FUNS.
# here bcsg and bcsf are the current contents of callee-save registers
# bret is the default return fates, sn is the stage number of
# the enclosing function, initDict has the same "whatIs" table as the
# the base_dictionary, however it has the different "whereIs" table.
#############################################################################
#
fun makenv (init_dictionary, namings, bsn, bcsg, bcsf, bret)
=
{
/*** >
#
fun checkfree (v) =
let free = ofreevars v
my { fv=nfree, lv=loopv, size=_} = nfreevars v
nfree = map #1 nfree
if (free != nfree)
then (pr "^^^^ wrong free variable subset ^^^^ \n";
pr "OFree in "; vp v; pr ":"; ilist free;
pr "NFree in "; vp v; pr ":"; ilist nfree;
pr "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ \n")
else ()
case loopv
of NULL => ()
| THE sfree =>
(if subset (sfree, nfree) then ()
else (pr "****wrong free variable subset*** \n";
pr "Free in "; vp v; pr ":"; ilist nfree;
pr "SubFree in "; vp v; pr ":";ilist sfree;
pr "*************************** \n"))
in ()
end
apply checkfree (map #2 namings)
<***/
/*** >
comment (\\() => (pr "BEGINNING MAKENV.\nFunctions: ";
ilist (map #2 namings); pr "Initial dictionary:\n";
printDict initDict; pr "\n"))
comment (\\() => (pr "BASE CALLEE SAVE REGISTERS: ";
vallist bcsg; vallist bcsf; pr "\n"))
<***/
# Partition the function namings
# into different callers_info flavors:
(partition_namings namings)
->
(escape_b, known_b, rec_b, callee_b, kcont_b);
# For the "numCSgpregs = 0" case,
# treat kcontB and calleeB as escapeB:
my (escape_b, callee_b, kcont_b)
=
num_csgpregs > 0 ?? (escape_b, callee_b, kcont_b)
:: (escape_b @ callee_b, [], [] );
escape_v = uniq (map #2 escape_b);
known_v = uniq (map #2 known_b );
#
fun knownlvar3 (v, _, _)
=
member known_v v;
# Check whether the basic
# closure assumptions are
# valid or not:
my (fix_kind, nret)
=
case (escape_b, known_b, callee_b, rec_b, kcont_b) # "escape"=="public"; "known"=="private".
#
([], _,[ ], _,[ ]) => (ncf::PRIVATE_FN, bret );
([],[],[v],[],[_]) => (ncf::PRIVATE_FATE_FN, THE(#2 v));
([],[],[v],[],[ ]) => (ncf::FATE_FN, THE(#2 v));
( _, _,[ ], _,[ ]) => (ncf::PUBLIC_FN, bret );
_ => { pr "^^^ Assumption No.2 is violated in closure phase ^^^\n";
pr "KNOWN namings: "; ilist (map #2 known_b);
pr "ESCAPE namings: "; ilist (map #2 escape_b);
pr "FATE namings: "; ilist (map #2 callee_b);
pr "KNOWN_FATE namings: "; ilist (map #2 kcont_b);
pr "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ \n";
bug "Violating basic closure conventions make-nextcode-closures-g.pkg";
};
esac;
############################################################################
# Initial processing of known functions
############################################################################
/*** >
comment (\\() => (pr "Known functions:"; ilist (map #2 knownB);
pr " "; iKlist (map #1 knownB)))
<***/
/* Get the call graph of all
* known functions in this ncf::DEFINE_FUNS:
*/
known_b
=
map ( \\ (fe as (_, v, _, _, _))
=
{ (nfreevars v) -> { fv=>vn, lv=>lpv, size=>s };
#
(partition knownlvar3 vn) -> (fns, other);
( { v,
fe,
other,
fsz => s,
lpv
},
length fns,
fns
);
}
)
known_b;
# Compute the closure of the call
# graph of the known functions:
#
known_b
=
close_call_graph known_b
where
fun close_call_graph g
=
{ fun get_neighbors l
=
fold_backward
(\\ (( { v, fe, other, fsz, lpv }, _, nbrs), n)
=
if (member3 l v) merge_v (nbrs, n);
else n;
fi
)
l
g;
#
fun traverse ((x, len, nbrs), (l, change))
=
{ nbrs' = get_neighbors nbrs;
len' = length nbrs';
((x, len', nbrs') ! l, change or len!=len');
};
(fold_backward traverse (NIL, FALSE) g)
->
(g', change);
change ?? close_call_graph g'
:: g';
};
end;
# Compute the closure of the
# set of free variables:
#
known_b
=
{ fun gather_nbrs l init
=
fold_backward
(\\ (( { v, other, ... }, _, _), free)
=
case (get_vn (l, v))
#
NULL => free;
THE (m, n)
=>
merge_v (map ( \\ (z, i, j)
=>
( z,
int::min (i, m),
int::max (n, j)
); end
)
other,
free
);
esac
)
init
known_b;
map (\\ ( { v, fe => (k, _, args, cl, body), other, fsz, lpv }, _, fns)
=
{ v,
kind => k,
args,
cl,
body,
lpv,
fsz,
other => gather_nbrs fns other,
fns
}
)
known_b;
};
# See which known function requires a closure, pass 1.
#
my (known_b, recursive_flag)
=
fold_backward
(\\ ((x as { v, kind, args, cl, other, fns, fsz, lpv, body } ), (zz, flag))
=
{ free = remove_v (escape_v, other);
#
callc = (length other) != (length free); # Calls escaping-funs
# If its arguments do not contain
# a return fate, supply one:
#
def_cont
=
case (kind, bret)
#
(ncf::PRIVATE_TAIL_RECURSIVE_FN, THE z)
=>
member3 free z ?? bret
:: NULL; # Issue warnings.
_ => NULL;
esac;
# Find out the true set
# of free variables:
my (fpfree, gpfree) = partition is_flt3 free;
my (gpfree, fpfree) = free_analysis (gpfree, fpfree, init_dictionary);
/*** >
comment (\\() => (pr "*** Current Known Free Variables: ";
iVlist gpfree; pr "\n"))
<***/
# Some free variables must stay
# in registers for ncf::KNOWN_TAIL:
my (rcsg, rcsf) = case def_cont
NULL => ([],[]);
THE k => fetch_csvars (k, #1 fsz, #2 fsz, init_dictionary);
esac;
gpfree = remove_v (rcsg, gpfree);
fpfree = remove_v (rcsf, fpfree);
# The stage number of
# the current function:
sn = snum v;
#
fun deep1 (_, _, n) = (n > sn);
fun deep2 (_, m, n) = (m > sn);
/*** >
comment (\\() => (pr "*** Current Stage number and fun kind: ";
ilist [sn]; ifkind kind; pr "\n"))
<***/
# For recursive functions, always
# spill deeper level free variables:
#
my ((gp_spill, gpfree), (fp_spill, fpfree), nflag)
=
case lpv
#
THE _
=>
{ fun h ((v, _, _), l)
=
case (what_is (init_dictionary, v))
#
(CLOSURE (CLOSURE_REP { closure, ... }))
=>
merge (rmv (v, closure.free), l);
_ => l;
esac;
gpfree = remove_v (fold_backward h [] gpfree, gpfree);
gpfree_part
=
if (length gpfree < num_csgpregs) ([], gpfree);
else partition deep1 gpfree;
fi;
( gpfree_part,
partition deep1 fpfree,
TRUE
);
};
NULL
=>
if (ekfuns v) ( (gpfree, []),
(fpfree, []),
flag
);
else ( partition deep2 gpfree,
partition deep2 fpfree,
flag
);
fi;
esac;
/*** >
comment (\\() => (pr "*** Current Spilled Known Free Variables: ";
iVlist gp_spill; pr "\n"))
<***/
# Find out the register limit for this known function:
gpnmax = maxgpregs;
fpnmax = maxfpregs; # reglimit v
# Does the set of free variables
# fit into FP registers?
#
n = int::min (numfp (maxfpregs - 1, cl), fpnmax) - length (rcsf);
(spill_free (fpfree, n, rcsf, fp_spill))
->
(fpfree, fp_spill);
# Does the set of free variables
# fit into GP registers?
#
m = int::min (numgp (maxgpregs - 1, cl), gpnmax) - length (rcsg);
(spill_free (gpfree, m, rcsg, gp_spill))
->
(gpfree, gp_spill);
( case (gp_spill, fp_spill)
([], [])
=>
(x, gpfree, fpfree, [], [], callc, sn, fns) ! zz;
/*
| ([(z, _, _)],[])
=>
if callc
then
( (x, gpfree, fpfree, gp_spill, [], callc, sn, fns) ! zz)
else ( (x, enter (z, gpfree), fpfree, [],[], FALSE, sn, fns) ! zz)
*/
_ => ( (x, gpfree, fpfree, gp_spill, fp_spill, TRUE, sn, fns) ! zz);
esac,
nflag
);
}
) # fn
([], FALSE)
known_b;
# See which known functions require a closure, pass 2.
my (known_b, gpcollected, fpcollected)
=
fold_backward g ([],[],[]) known_b
where
fun check_nbrs l init
=
fold_backward
(\\ (( { v, ... }, _, _, _, _, callc, _, _), c)
=
c or (callc and (member3 l v))
)
init
known_b;
#
fun g ( ( { kind, v, args, cl, body, fns, fsz, lpv, other },
gpfree,
fpfree,
gp_spill,
fp_spill,
callc,
sn,
zfns
),
(z, gv, fv)
)
=
{ callc = check_nbrs zfns callc;
l = clone_highcode_codetemp v;
( { kind, sn, v, l, args, cl, body, gpfree, fpfree, callc }
!
z,
merge_v (gp_spill, gv),
merge_v (fp_spill, fv)
);
};
end;
############################################################################
# Initial processing of escaping functions
############################################################################
/*** >
comment (\\() => (pr "Escaping functions:"; ilist (map #2 escapeB)))
<***/
# Get the set of free variables
# for escaping functions:
my (escape_b, escape_free)
=
fold_backward g ([],[]) escape_b
where
fun g ((k, v, a, cl, b), (z, c))
=
{ free = .fv (nfreevars v);
l = clone_highcode_codetemp v;
( { kind => k,
v,
l,
args => a,
cl,
body => b
}
!
z,
merge_v (free, c)
);
};
end;
# Get the true set of free variables
# for escaping functions:
#
my (gpfree, fpfree)
=
free_analysis (gpfree, fpfree, init_dictionary)
where
(partition knownlvar3 (remove_v (escape_v, escape_free)))
->
(fns, other);
(partition is_flt3 other)
->
(fpfree, gpfree);
my (gpfree, fpfree)
=
fold_backward
(\\ ( { v, gpfree=>gv, fpfree=>fv, ... }, (x, y))
=
case (get_vn (fns, v))
NULL => (x, y);
THE (m, n)
=>
( add_v (gv, m, n, x),
add_v (fv, m, n, y)
);
esac
)
(gpfree, fpfree)
known_b;
end;
# Here are all free variables that
# ought to be put in the closure:
gp_free = merge_v (gpfree, gpcollected);
fp_free = merge_v (fpfree, fpcollected);
###########################################################################
# Initial processing of callee-save fate functions
###########################################################################
/*** >
comment (\\() => (pr "CS fates:"; ilist (map #2 calleeB);
pr " "; iKlist (map #1 calleeB)))
<***/
# Get the set of free variables
# for fate functions:
my (callee_b, callee_free, gpn, fpn, p_f)
=
{ fun g ( (k, v, a, cl, b), (z, c, gx, fx, pf))
=
{ (nfreevars v)
->
{ fv=>free, lv=>_, size=>(gsz, fsz) };
l = clone_highcode_codetemp v;
sn = snum v;
my (gpn, fpn, pflag)
=
case k
#
ncf::PRIVATE_FATE_FN
=>
if (gsz > 0)
#
(0, 0, FALSE); # A temporary gross hack XXX BUGGO FIXME.
else
x = numgp (maxgpregs - 1, ncf::typ::FATE ! cl);
y = numfp (maxfpregs - 1, ncf::typ::FATE ! cl);
( int::min (x, gx),
int::min (y, fx),
FALSE
);
fi;
_ => (0, 0, sn == bsn+1);
esac;
( { kind => k,
sn,
v,
l,
args => a,
cl,
body => b
}
!
z,
merge_v (free, c),
int::min (gpn, gx),
int::min (fpn, fx),
pflag
);
};
case callee_b
#
[] => ([],[], 0, 0, TRUE);
_ => fold_backward g ([],[], maxgpregs, maxfpregs, TRUE) callee_b;
esac;
};
# Get the true set of free variables
# for fate functions:
#
my (fpcallee, gpcallee) = partition is_flt3 callee_free;
my (gpcallee, fpcallee) = free_analysis (gpcallee, fpcallee, init_dictionary);
# Get all sharable closures from
# the enclosing dictionary:
#
my (gpclist, fpclist)
=
fetch_closures (init_dictionary, lives, fix_kind)
where
lives = merge ( map #1 gpcallee,
map #1 gp_free
);
lives = case (known_b, escape_b)
#
( [ { gpfree => gv, ... } ], [])
=>
merge (gv, lives);
_ => lives;
esac;
end;
# Initialize the callee-save register default:
#
safev = merge ( uniq (map #1 gpclist),
uniq (map #1 fpclist)
);
my (gpbase, gp_src) = make_base (bcsg, merge (safev, map #1 gpcallee), gpn);
my (fpbase, fp_src) = make_base (bcsf, map #1 fpcallee, fpn);
# Thinning the set of free variables
# based on each's contents:
my cclist # For user function, be more conservative
=
case callee_b
#
[] => map (\\ (v, cr) = (v, fetch_free (v, cr, 2))) (fpclist @ gpclist);
_ => map (\\ (v, CLOSURE_REP { closure => { free, ... }, ... }) = (v, free)) (fpclist @ gpclist);
esac;
my (gpcallee, fpcallee)
=
shorten_free (gpcallee, fpcallee, cclist);
my (gp_free, fp_free)
=
recursive_flag ?? (gp_free, fp_free)
:: shorten_free (gp_free, fp_free, cclist);
###########################################################################
# Targeting callee-save registers for fate functions
###########################################################################
# Decide which variables to put
# into FP callee-save registers:
my (gp_spill, fp_spill, fpbase)
=
{ numv = length fpcallee;
numr = num_csfpregs + fpn;
if (numv <= numr)
#
fpv = map #1 fpcallee;
p = if p_f numr-numv; else 0;fi;
my (fpbase, fpv, _) = modify_base (fpbase, fpv, p);
nbase = fill_base (fpbase, fpv);
([], [], nbase);
else
# Need spill:
my (gpfree, fpcallee) = thin_fp_free (fpcallee, fpclist);
numv = length fpcallee;
if (numv <= numr)
#
fpv = map #1 fpcallee;
p = if p_f numr-numv; else 0;fi;
my (fpbase, fpv, _) = modify_base (fpbase, fpv, p);
nbase = fill_base (fpbase, fpv);
(gpfree, [], nbase);
else
fpfree = sortlud2 (fpcallee, fp_src);
my (cand, rest) = partvnum (fpfree, numr);
my (nbase, ncand, _) = modify_base (fpbase, cand, 0);
nbase = fill_base (nbase, ncand);
(gpfree, uniq_v rest, nbase);
fi;
fi;
};
# INT1: here is a place to filter out all the variables with INT1 types,
# they have to be put into closure (gp_spill), because by default, callee-save
# registers always contain pointer values.
(partition is_int1 gpcallee) -> (i32gpcallee, gpcallee);
(partition is_int1 gp_free ) -> (i32gp_free, gp_free);
# Collect all the FP free variables and
# build a closure if necessary:
allfp_free = merge_v (fp_spill, fp_free);
my (gp_spill, gp_free, fpc_info)
=
case allfp_free
#
[] => (gp_spill, gp_free, NULL);
#
_ => { my (gpextra, ufree) = thin_fp_free (allfp_free, fpclist);
my (gpextra, fpc)
=
case ufree
#
[] => (gpextra, NULL);
#
((_, m, n) ! r)
=>
{ fun h ((_, x, y), (i, j))
=
(int::min (x, i), int::max (y, j));
my (m, n) = fold_backward h (m, n) r;
cname = make_closure_codetemp ();
gpextra
=
merge_v ( [ (cname, m, n) ], gpextra);
( gpextra,
THE (cname, ufree)
);
};
esac;
case fix_kind
#
(ncf::FATE_FN | ncf::PRIVATE_FATE_FN)
=>
( merge_v (gpextra, gp_spill),
gp_free,
fpc
);
_ => ( gp_spill,
merge_v (gpextra, gp_free),
fpc
);
esac;
};
esac;
# Here are free variables that should be
# put in GP callee-save registers by
# convention: gp_spill must not contain
# any one_word_int variables !
gpcallee = merge_v (gp_spill, gpcallee);
my (gpcallee, fpc_info)
=
case (i32gpcallee, fpc_info)
#
([], _)
=>
(gpcallee, fpc_info);
#
((_, m, n) ! r, NULL)
=>
{ fun h ((_, x, y), (i, j))
=
(int::min (x, i), int::max (y, j));
my (m, n) = fold_backward h (m, n) r;
cname = make_closure_codetemp();
( merge_v ( [ (cname, m, n) ],
gpcallee
),
THE (cname, i32gpcallee)
);
};
#
(vs, THE (cname, ufree))
=>
( gpcallee,
THE (cname, merge_v (vs, ufree))
);
esac;
/*
| (_, THE (cname, ufree))
=>
bug "unimplemented one_word_int + float (nclosure.2)"
*/
# If gp_spill is not null,
# there must be an empty
# position in gpbase:
my (gp_spill, gpbase)
=
{ numv = length gpcallee;
numr = num_csgpregs + gpn;
if (numv <= numr)
#
gpv = map #1 gpcallee;
p = if p_f numr - numv;
else 0;fi;
(modify_base (gpbase, gpv, p))
->
(gpbase, gpv, _);
nbase = fill_base (gpbase, gpv);
([], nbase);
else
gpcallee = thin_gp_free (gpcallee, gpclist);
numv = length gpcallee;
if (numv <= numr)
#
gpv = map #1 gpcallee;
p = if p_f numr - numv;
else 0;
fi;
(modify_base (gpbase, gpv, p))
->
(gpbase, gpv, _);
nbase = fill_base (gpbase, gpv);
([], nbase);
else
gpfree = sortlud2 (gpcallee, gp_src);
(partvnum (gpfree, numr - 1))
->
(cand, rest);
(modify_base (gpbase, cand, 0))
->
(nbase, ncand, _);
(partition_to_null nbase)
->
(nbhd, nbtl);
nbtl = fill_base (nbtl, ncand);
(uniq_v rest, nbhd @ nbtl);
fi;
fi;
};
###########################################################################
# Building the closures for all namings in this ncf::DEFINE_FUNS
###########################################################################
# Collect all GP free variables that should be put in closures.
# Assumption: gp_spill does not contain any Int1s; they should
# not be put into gpcallee anyway.
allgp_free = merge_v (gp_spill, gp_free);
unboxed_free = i32gp_free;
# Filter out all unboxed-values.
# INT1: here is the place to filter out all 32-bit integers,
# put them into unboxedFree, then you have to find a way to put both
# 32-bit integers and unboxed float numbers in the same record.
# Currently, I use ncf::rk::FLOAT64_BLOCK to denote this kind of record_kind,
# you might want to put all floats ahead of all 32-bit ints.
# my (allgpFree, unboxedFree) = partition isBoxed3 allgpFree
my (allgp_free, fpc_info)
=
case (fpc_info, unboxed_free)
#
(NULL, []) => (allgp_free, fpc_info);
#
(NULL, (_, m, n) ! r)
=>
{ c = make_closure_codetemp();
#
fun h ((_, x, y), (i, j))
=
(int::min (x, i), int::max (y, j));
my (m, n) = fold_backward h (m, n) r;
( merge_v ( [ (c, m, n) ], allgp_free ),
THE (c, unboxed_free)
);
};
(THE (c, a), r)
=>
(allgp_free, THE (c, merge_v (a, r)));
esac;
# Actually building the closure for unboxed values:
#
my (fphdr, dictionary, nframes)
=
case fpc_info
#
NULL => (\\ ce = ce, init_dictionary,[]);
#
THE (c, a)
=>
{ (partition is_int1 a)
->
(int1a, a);
#
closure_unboxed (c, int1a, a, fix_kind, init_dictionary);
};
esac;
# Sharing with the enclosing closures if possible:
#
my (allgp_free, ccl) # For recursive function, be more conservative
=
if recursive_flag (thin_all (allgp_free, cclist, bsn), cclist);
else (thin_gp_free (allgp_free, gpclist), []);
fi;
# Actually building the closure for all GP (or boxed) values:
#
my (closure_info, closure_name, dictionary, gphdr, nframes)
=
case (escape_b, allgp_free)
#
([], [])
=>
(NULL, NULL, dictionary, fphdr, nframes);
([], [ (v, _, _) ])
=>
(NULL, THE v, dictionary, fphdr, nframes);
_ =>
{ fns = map (\\ { v, l, ... } = (v, l)) escape_b;
cn = make_closure_codetemp ();
(closure_boxed (cn, fns, allgp_free, fix_kind, ccl, dictionary))
->
(header, dictionary, cr, nf);
( THE cr,
THE cn,
dictionary,
fphdr o header,
nf @ nframes
);
};
esac;
###########################################################################
# Final construction of the dictionary for each known function:
###########################################################################
# Add new known functions to the dictionary (side-efffect)
nenv
=
case closure_name
#
NULL
=>
fold_backward
(\\ ( { v, l, gpfree, fpfree, ... }, dictionary)
=
aug_known (v, l, gpfree, fpfree, dictionary)
)
dictionary
known_b;
#
THE cname
=>
fold_backward
(\\ ( { v, l, gpfree, fpfree, callc, ... }, dictionary)
=
if callc aug_known (v, l, enter (cname, gpfree), fpfree, dictionary);
else aug_known (v, l, gpfree, fpfree, dictionary);
fi
)
dictionary
known_b;
esac;
my known_frags: Frags
=
fold_backward g [] known_b
where
fun g ( { kind, sn, v, l, args, cl, body, gpfree, fpfree, callc }, z)
=
{ dictionary = base_dictionary; # Empty whereIs map but same whatMap as nenv
dictionary = fold_backward augvar dictionary gpfree;
dictionary = fold_backward augvar dictionary fpfree;
my (ngpfree, dictionary)
=
case (callc, closure_name)
#
(FALSE, _)
=>
{ inc coc::known_function;
(gpfree, dictionary);
};
#
(TRUE, THE cn)
=>
{ inc coc::known_cl_function;
( enter (cn, gpfree),
augvar (cn, dictionary)
);
};
#
(TRUE, NULL)
=>
bug "unexpected 23324 in closure";
esac;
(adjust_args (args, cl, dictionary))
->
(nargs, ncl, ncsg, ncsf, nret, dictionary);
nargs = nargs @ ngpfree @ fpfree;
ncl = ncl @ (map get_cty ngpfree) @ (map get_cty fpfree);
/*** >
comment (\\ () => (pr "\nDictionary in known ";
vp v; pr ":\n"; printDict dictionary))
<***/
case nret
#
NULL => ((ncf::PRIVATE_FN, l, nargs, ncl, body, dictionary, sn, bcsg, bcsf, bret) ! z);
THE _ => ((ncf::PRIVATE_FN, l, nargs, ncl, body, dictionary, sn, ncsg, ncsf, nret) ! z);
esac;
};
end;
###########################################################################
# Final construction of the dictionary for each escaping function
###########################################################################
# The what_map in nenv is side-effected
# with new escape namings:
#
my escape_frags: Frags
=
case (closure_info, escape_b)
#
(_, []) => [];
#
(NULL, _) => bug "unexpected 23422 in closure";
#
(THE cr, _)
=>
formap f escape_b
where
dictionary = base_dictionary; # Empty whereIs map but same whatMap as nenv
#
fun f ( { kind, v, l, args, cl, body }, i)
=
{ my_cname = v; # My closure name
dictionary = aug_esc_fun (my_cname, i, cr, dictionary);
(adjust_args (args, cl, dictionary))
->
(nargs, ncl, ncsg, ncsf, nret, dictionary);
nargs = issue_highcode_codetemp() ! my_cname ! nargs;
ncl = ncf::bogus_pointer_type ! ncf::bogus_pointer_type ! ncl;
sn = snum v;
/*** >
comment (\\ () => (pr "\nDictionary in escaping ";
vp v; pr ":\n";printDict dictionary))
<***/
inc coc::escape_function; # nret must not be NULL
case nret
#
THE _ => (kind, l, nargs, ncl, body, dictionary, sn, ncsg, ncsf, nret);
NULL => bug "no fate in escapefun in make-nextcode-closures-g.pkg";
esac;
};
end;
esac;
###########################################################################
# Final construction of the dictionary for each callee-save fate
###########################################################################
# The what_map in nenv is side-effected
# with new callee namings:
#
my (nenv, callee_frags: Frags)
=
case callee_b
#
[] => (nenv, []);
#
_ =>
{ gpbase
=
case closure_name
#
NULL => gpbase;
THE _ => fill_csregs (gpbase, closure_name);
esac;
ncsg = map (\\ (THE v) => ncf::CODETEMP v; NULL => ncf::INT 0; end) gpbase;
ncsf = map (\\ (THE v) => ncf::CODETEMP v; NULL => ncf::TRUEVOID ; end) fpbase; # This is the only place in the codebase where ncf::TRUEVOID is introduced.
(split_dictionary (nenv, member (freev_csregs (gpbase, nenv))))
->
(benv, nenv);
#
fun g ( { kind, sn, v, l, args, cl, body }, z)
=
{ dictionary = install_frames (nframes, benv);
my (nk, dictionary, nargs, ncl, csg, csf)
=
case kind
#
ncf::FATE_FN
=>
{ dictionary = aug_callee (v, ncf::LABEL l, ncsg, ncsf, dictionary);
(fill_csformals (gpbase, fpbase, dictionary, get_cty))
->
(dictionary, a, c);
( ncf::FATE_FN,
dictionary,
(issue_highcode_codetemp ()) ! (a @ args),
ncf::bogus_pointer_type ! (c @ cl),
ncsg,
ncsf
);
};
ncf::PRIVATE_FATE_FN
=>
{ (vars_csregs (gpbase, fpbase, dictionary))
->
(gfv, ffv, dictionary);
csg = cuttail (gpn, ncsg);
csf = cuttail (fpn, ncsf);
dictionary = aug_kcont (v, l, gfv, ffv, csg, csf, dictionary);
gcl = map get_cty gfv;
fcl = map (\\ _ = ncf::typ::FLOAT64) ffv;
( ncf::PRIVATE_FN,
dictionary,
args @ gfv @ ffv,
cl @ gcl @ fcl,
csg,
csf
);
};
_ => bug "callee_frags in make-nextcode-closures-g.pkg 748";
esac;
dictionary = faug_value (args, cl, dictionary);
/*** >
comment (\\ () =>
(pr "\nDictionary in callee-save fate ";
vp v; pr ":\n"; printDict dictionary))
<***/
inc coc::callee_function;
( nk,
l,
nargs,
ncl,
body,
dictionary,
sn,
csg,
csf,
bret
)
!
z;
}; # fun g
( nenv,
fold_backward g [] callee_b
);
};
esac;
frags = escape_frags @ known_frags @ callee_frags;
/*** >
comment (\\ () => (pr "\nDictionary after ncf::DEFINE_FUNS:\n";
printDict nenv; pr "MAKENV DONE.\n\n"));
<***/
( gphdr,
frags,
nenv,
nret
);
}; # function makenv
###########################################################################
# MAIN LOOP (closefix and close)
###########################################################################
#
fun closefix (
fk,
f,
vl,
cl,
ce,
dictionary,
sn,
csg,
csf,
ret
)
=
( fk,
f,
vl,
cl,
close (
ce,
dictionary,
sn,
csg,
csf,
ret
)
)
except
LOOKUP (v, dictionary)
=
{ pr "LOOKUP FAILS on ";
vp v;
pr "\nin dictionary:\n";
print_dictionary dictionary;
pr "\nin function:\n";
prettyprint_nextcode::print_nextcode_expression ce;
bug "Lookup failure in nextcode/make-nextcode-closures-g.pkg";
}
also
fun close (ce, dictionary, sn, csg, csf, ret)
=
case ce
#
ncf::DEFINE_FUNS { funs, next }
=>
{ (makenv (dictionary, funs, sn, csg, csf, ret))
->
(header, frags, nenv, nret);
ncf::DEFINE_FUNS
{
funs => map closefix frags,
next => header (close (next, nenv, sn, csg, csf, nret))
};
};
ncf::TAIL_CALL { fn, args }
=>
{ chunk
=
case fn
ncf::CODETEMP v => what_is (dictionary, v);
_ => VALUE ncf::bogus_pointer_type;
esac;
case chunk
#
CLOSURE (CLOSURE_REP { offset, closure => { functions, ... } })
=>
{ (fix_access ( [fn], dictionary)) -> (dictionary, h);
(fix_args (args, dictionary)) -> (nargs, dictionary, nh);
(dispose_frames dictionary ) -> (dictionary, dh);
(list::nth (functions, offset)) -> (_, label);
call = ncf::TAIL_CALL
{
fn => ncf::LABEL label,
args => ncf::LABEL label ! fn ! nargs
};
if (not *coc::allocprof)
#
h (nh (dh call));
else
h (nh (dh case args
[_] => prof_cntk_call call;
_ => prof_stdk_call call;
esac
)
);
fi;
};
FUNCTION { label, gpfree, fpfree, csdef }
=>
{ (map ncf::CODETEMP (gpfree @ fpfree)) -> free;
(fix_args (args @ free, dictionary)) -> (args, dictionary, h);
(dispose_frames dictionary) -> (dictionary, nh);
(ncf::TAIL_CALL { fn => ncf::LABEL(label), args }) -> call;
if (not *coc::allocprof)
#
h (nh call);
else
case csdef
#
NULL => h (nh (prof_known_call call));
_ => h (nh (prof_cscntk_call call));
esac;
fi;
};
CALLEE (label, ncsg, ncsf)
=>
{ (ncsg @ ncsf @ args) -> nargs;
(fix_access (label ! nargs, dictionary)) -> (dictionary, h);
(dispose_frames dictionary) -> (dictionary, nh);
(ncf::TAIL_CALL { fn => label,
args => label ! nargs }) -> call;
if (not *coc::allocprof)
#
h (nh call);
else
case label
#
ncf::LABEL _ => h (nh (prof_cscntk_call call));
_ => h (nh (prof_cscnt_call call));
esac;
fi;
};
VALUE t
=>
{ (fix_access ([fn], dictionary)) -> (dictionary, h);
(fix_args (args, dictionary)) -> (nargs, dictionary, nh);
(dispose_frames dictionary) -> (dictionary, dh);
l = issue_highcode_codetemp ();
call = ncf::GET_FIELD_I
{
i => 0,
record => fn,
to_temp => l,
type => t,
next => (ncf::TAIL_CALL { fn => ncf::CODETEMP(l),
args => ncf::CODETEMP(l) ! fn ! nargs
}
)
};
if (not *coc::allocprof) h (nh (dh ( call)));
else h (nh (dh (prof_std_call call)));
fi;
};
esac;
};
ncf::JUMPTABLE { i, xvar, nexts }
=>
{ (fix_access ([i], dictionary))
->
(dictionary, header);
header (
ncf::JUMPTABLE {
i,
xvar,
nexts => map (\\ c = close (c, dictionary, sn, csg, csf, ret)) nexts
}
);
};
ncf::DEFINE_RECORD { kind as ncf::rk::FLOAT64_BLOCK, fields, to_temp, next }
=>
{ (fix_access (map #1 fields, dictionary))
->
(dictionary, header);
dictionary = aug_value (to_temp, ncf::bogus_pointer_type, dictionary);
header (
ncf::DEFINE_RECORD {
kind,
fields,
to_temp,
next => close (next, dictionary, sn, csg, csf, ret)
}
);
};
ncf::DEFINE_RECORD { kind, fields, to_temp, next }
=>
{ (record_elements (kind, fields, to_temp, dictionary))
->
(header, dictionary);
nc = header (
close (
next,
aug_value (to_temp, ncf::bogus_pointer_type, dictionary),
sn,
csg,
csf,
ret
)
);
if (not *coc::allocprof) nc;
else prof_record (length fields) nc;
fi;
};
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=>
{ (fix_access ([record], dictionary))
->
(dictionary, header);
next = close ( next,
aug_value (to_temp, type, dictionary),
sn,
csg,
csf,
ret
);
header (ncf::GET_FIELD_I { i, record, to_temp, type, next });
};
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=>
bug "GET_ADDRESS_OF_FIELD_I in pre-closure in nextcode/make-nextcode-closures-g.pkg";
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=>
{ (fix_access (args, dictionary)) -> (dictionary, header);
then_next = close (then_next, dictionary, sn, csg, csf, ret);
else_next = close (else_next, dictionary, sn, csg, csf, ret);
header (ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next });
};
ncf::STORE_TO_RAM { op, args, next }
=>
{ (fix_access (args, dictionary))
->
(dictionary, header);
next = close (next, dictionary, sn, csg, csf, ret);
header (ncf::STORE_TO_RAM { op, args, next });
};
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next }
=>
{ (fix_access (args, dictionary))
->
(dictionary, header);
next = close (
next,
aug_value (to_temp, type, dictionary),
sn,
csg,
csf,
ret
);
header (ncf::FETCH_FROM_RAM { op, args, to_temp, type, next });
};
ncf::ARITH { op, args, to_temp, type, next }
=>
{ (fix_access (args, dictionary))
->
(dictionary, header);
next = close (
next,
aug_value (to_temp, type, dictionary),
sn,
csg,
csf,
ret
);
header (ncf::ARITH { op, args, to_temp, type, next });
};
ncf::PURE { op, args, to_temp, type, next }
=>
{ (fix_access (args, dictionary))
->
(dictionary, header);
next = close (
next,
aug_value (to_temp, type, dictionary),
sn,
csg,
csf,
ret
);
header (ncf::PURE { op, args, to_temp, type, next });
};
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=>
{ (fix_access (args, dictionary))
->
(dictionary, header);
next = close (
next,
fold_forward
(\\ ((w, t), dictionary)
=
aug_value (w, t, dictionary)
)
dictionary
to_ttemps,
sn,
csg,
csf,
ret
);
header (ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next });
};
esac;
############################################################################
# Calling the "close" on the nextcode expression with proper initializations
#
nfe = { if *coc::static_closure_size_profiling sprof::initfk (); fi;
#
(adjust_args (vl, cl, base_dictionary))
->
(nvl, ncl, csg, csf, ret, dictionary);
dictionary = aug_value (f, ncf::bogus_pointer_type, dictionary);
nce = close (
ce,
dictionary,
snum f,
csg,
csf,
ret
);
( fk,
issue_highcode_codetemp (),
issue_highcode_codetemp () ! f ! nvl,
ncf::bogus_pointer_type ! ncf::bogus_pointer_type ! ncl,
nce
);
};
# Temporary hack: measuring static XXX BUGGO FIXME
# allocation sizes of closures.
# Previous calls to incfk and initfk
# are also part of this hack.
#
if *coc::static_closure_size_profiling
#
sprof::reportfk ();
fi;
un_rebind::unrebind nfe;
}; # fun make_nextcode_closures
}; # generic package make_nextcode_closures_g
end; # stipulate