## make-per-function-free-variable-maps.pkg # SML/NJ calls this 'freeclose'
#
###########################################################################
#
# Map the free variables for a function.
# The map includes the functions bound at the
# MUTUALLY_RECURSIVE_FNS, but not the arguments of the function.
#
# Side-effect: all fundefs that are never referenced are removed
#
###########################################################################
# Compiled by:
# src/lib/compiler/core.sublibstipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkgherein
api Make_Per_Function_Free_Variable_Maps {
#
Snum; # "stage_number"
Fvinfo;
make_per_function_free_variable_maps
:
ncf::Function
->
( ( ncf::Function,
(ncf::Codetemp -> Snum),
(ncf::Codetemp -> Fvinfo),
(ncf::Codetemp -> Bool)
)
);
};
end;
stipulate
# include package varhome;
# include package sorted_list;
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkg package sl = sorted_list; # sorted_list is from src/lib/compiler/back/low/library/sorted-list.pkg# package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkg package intset {
#
fun new () = REF int_red_black_set::empty;
fun add set i = set := int_red_black_set::add (*set, i);
fun mem set i = int_red_black_set::member (*set, i);
# fun rmv set i = set := int_red_black_set::drop (*set, i);
};
herein
package make_per_function_free_variable_maps
: (weak) 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 is = int_red_black_set; # int_red_black_set is from src/lib/src/int-red-black-set.pkg package im = int_red_black_map; # int_red_black_map is from src/lib/src/int-red-black-map.pkg package nd {
Key = Int;
compare = int::compare;
};
package scc # "scc" == "strongly connected components"
=
digraph_strongly_connected_components_g( nd );
###########################################################################
# Misc and utility functions
###########################################################################
say = global_controls::print::say;
fun vp codetemp
=
say (tmp::name_of_highcode_codetemp codetemp);
fun addv_l (v, NULL ) => NULL;
addv_l (v, THE l) => THE (sl::enter (v, l));
end;
enter
=
\\ (ncf::CODETEMP x, y) => sl::enter (x, y);
( _, y) => y;
end;
error = error_message::impossible;
fun warn s = (); # Apply say ["WARNING: ", s, "\n"]
fun add_l (v, NULL ) => NULL;
add_l (v, THE l) => THE (enter (v, l));
end;
fun over_l (r, NULL ) => NULL;
over_l (r, THE l) => THE (sl::merge (r, l));
end;
fun merge_l (NULL, r ) => r;
merge_l ( l, NULL ) => l;
merge_l (THE l, THE r ) => THE (sl::merge (l, r));
end;
fun remove_l (vl, NULL ) => NULL;
remove_l (vl, THE r) => THE (sl::remove (vl, r));
end;
fun rmv_l (v, NULL ) => NULL;
rmv_l (v, THE r) => THE (sl::rmv (v, r));
end;
fun clean l
=
vars (NIL, l)
where
fun vars (l, (ncf::CODETEMP x) ! rest) => vars (x ! l, rest);
vars (l, _ ! rest) => vars ( l, rest);
vars (l, NIL) => sl::uniq l;
end;
end;
fun filter p vl
=
f (vl, [])
where
fun f ( [], l) => reverse l;
f (x ! r, l) => p x ?? f (r, x ! l)
:: f (r, l);
end;
end;
fun exists prior l
=
f l
where
fun f [] => FALSE;
f (a ! r) => prior a ?? TRUE
:: f r;
end;
end;
fun partition f l
=
fold_backward
( \\ (e, (a, b))
=
f e ?? (e ! a, b)
:: ( a, e ! b)
)
([], [])
l;
infinity = 1000000000; ### "Only two things are infinite: the universe and human stupidity. And I'm not sure about the former." - Albert Einstein
fun minl l
=
f (infinity, l)
where
fun f (i, NIL) => i;
f (i, j ! r) => i < j ?? f (i, r)
:: f (j, r);
end;
end;
fun bfirst (ncf::p::IS_BOXED | ncf::p::POINTER_NEQ | ncf::p::STRING_NEQ | ncf::p::COMPARE { op => ncf::p::NEQ, ... } ) => TRUE;
bfirst _ => FALSE;
end;
fun bsecond (ncf::p::IS_UNBOXED | ncf::p::POINTER_EQL | ncf::p::STRING_EQL | ncf::p::COMPARE { op => ncf::p::EQL, ... } ) => TRUE;
bsecond _ => FALSE;
end;
# Sumtype used to represent the free variable information:
Vnum = (ncf::Codetemp, Int, Int); # highcode_variable and first-use-sn and last-use-sn
Snum = Int; # "stage_number"
Loopv = Null_Or( List( ncf::Codetemp ) );
Fvinfo
=
{ fv: List( Vnum ), # List of sorted free variables.
lv: Loopv, # List of free variables on the loop path.
size: (Int, Int) # Estimated frame-size of the current fun.
};
fun make_per_function_free_variable_maps fe
=
{ ############################################################################
# Modify the callers_info for each fundef, new callers_info includes,
#
# (1) KNOWN_CONT all-callers-known fate function
# (2) KNOWN_TAIL all-callers-known tail-recursive function
# (3) KNOWN general all-callers-known function
# (4) CONT general fate function
# (5) ESCAPE general may-have-unknown-callers user function
# (6) KNOWN_REC mutually recursive all-callers-known function
#
############################################################################
escapes = intset::new();
escapes_p = intset::mem escapes;
fun escapes_m (ncf::CODETEMP v) => intset::add escapes v;
escapes_m _ => ();
end;
users = intset::new ();
users_p = intset::mem users;
users_m = intset::add users;
known = intset::new ();
known_p = intset::mem known;
known_m = intset::add known;
fun known_k k = (k != ncf::FATE_FN) and (k != ncf::PUBLIC_FN );
fun frmsz_k k = (k == ncf::FATE_FN) or (k == ncf::PRIVATE_TAIL_RECURSIVE_FN);
contset = intset::new();
cont_p = intset::mem contset;
cont_m = intset::add contset;
fun cont_k k = (k == ncf::FATE_FN) or (k == ncf::PRIVATE_FATE_FN); # Fate funs ?
fun econt_k k = (k == ncf::FATE_FN); # Escaping fate funs ?
fun fixkind (fe as (ncf::FATE_FN, f, vl, cl, ce))
=>
if (escapes_p f)
cont_m f; fe;
else known_m f; cont_m f; (ncf::PRIVATE_FATE_FN, f, vl, cl, ce);
fi;
fixkind (fe as (fk, f, vl, cl as (cntt ! _), ce))
=>
if (escapes_p f) users_m f; (ncf::PUBLIC_FN, f, vl, cl, ce);
else known_m f; (ncf::PRIVATE_RECURSIVE_FN, f, vl, cl, ce);
fi;
fixkind (fe as (fk, f, vl, cl, ce))
=>
if (escapes_p f)
#
vp f;
say " ***** \n";
error "escaping-fun has zero fate, make-per-function-free-variable-maps.pkg";
else
known_m f;
(ncf::PRIVATE_TAIL_RECURSIVE_FN, f, vl, cl, ce);
fi;
end;
fun procfix (fk, f, vl, cl, ce)
=
(fk, f, vl, cl, proc ce)
also
fun proc ce
=
case ce
#
ncf::DEFINE_FUNS { funs, next }
=>
{ (proc next) -> next;
(map fixkind (map procfix funs))
->
funs;
# Due to possible eta-splits of next functions,
# since it's always that ncf::FATE_FN funs call KNOWN_FATE funs,
# we split them into two DEFINE_FUNSes, so that each DEFINE_FUNS only
# contains at most one next definition.
(partition (econt_k o #1) funs)
->
(funs1, funs2);
case (funs1, funs2)
#
( [], _) => ncf::DEFINE_FUNS { funs => funs2, next };
( _, []) => ncf::DEFINE_FUNS { funs => funs1, next };
_ => ncf::DEFINE_FUNS { funs => funs2, next => ncf::DEFINE_FUNS { funs => funs1, next } };
esac;
};
ncf::TAIL_CALL { args, ... }
=>
{ apply escapes_m args;
ce;
};
ncf::JUMPTABLE { i, xvar, nexts }
=>
ncf::JUMPTABLE { i, xvar, nexts => map proc nexts };
ncf::DEFINE_RECORD { kind, fields, to_temp, next }
=>
{ apply (escapes_m o #1) fields;
#
ncf::DEFINE_RECORD { kind, fields, to_temp, next => proc next };
};
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=> ncf::GET_FIELD_I { i, record, to_temp, type, next => proc next };
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=> ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next => proc next };
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next }
=>
{ apply escapes_m args;
#
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next => proc next };
};
ncf::ARITH { op, args, to_temp, type, next }
=>
{ apply escapes_m args;
#
ncf::ARITH { op, args, to_temp, type, next => proc next };
};
ncf::PURE { op, args, to_temp, type, next }
=>
{ apply escapes_m args;
#
ncf::PURE { op, args, to_temp, type, next => proc next };
};
ncf::STORE_TO_RAM { op, args, next }
=>
{ apply escapes_m args;
#
ncf::STORE_TO_RAM { op, args, next => proc next };
};
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=>
{ apply escapes_m args;
#
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next => proc next };
};
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=>
{ apply escapes_m args;
#
ncf::IF_THEN_ELSE { op, args, xvar, then_next => proc then_next,
else_next => proc else_next
};
};
esac;
fe' = procfix fe;
# *************************************************************************
# Build the call graph and compute the scc number *
# *************************************************************************
fun kuc x
=
(cont_p x) or
(known_p x) or
(users_p x);
fun make_graph f
=
{ fun comb ((xe, xf), (ye, yf)) = (is::union (xe, ye), xf @ yf);
fun combe ((xe, xf), e) = (is::union (xe, e), xf );
fun combf ((xe, xf), f) = (xe, xf @ f);
fun add_kuc (s, v)
=
if (kuc v ) is::add (s, v);
else s; fi;
fun vl2s_kuc l
=
loop (l, is::empty)
where
fun loop ( [], s) => s;
loop (ncf::CODETEMP v ! r, s) => loop (r, add_kuc (s, v));
loop ( _ ! r, s) => loop (r, s);
end;
end;
fun collect (ncf::JUMPTABLE { nexts, ... })
=>
fold_forward
( \\ (x, a)
=
comb (collect x, a)
)
(is::empty, [])
nexts;
collect (ncf::STORE_TO_RAM { op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER, args, next })
=>
combe (collect next, vl2s_kuc args);
collect ( ncf::DEFINE_RECORD { next, ... }
| ncf::GET_FIELD_I { next, ... }
| ncf::GET_ADDRESS_OF_FIELD_I { next, ... }
| ncf::STORE_TO_RAM { next, ... }
| ncf::FETCH_FROM_RAM { next, ... }
| ncf::ARITH { next, ... }
| ncf::PURE { next, ... }
| ncf::RAW_C_CALL { next, ... }
) =>
collect next;
collect (ncf::IF_THEN_ELSE { then_next, else_next, ... })
=>
comb ( collect then_next,
collect else_next
);
collect (ncf::TAIL_CALL { fn, args })
=>
(vl2s_kuc (fn ! args), []);
collect (ncf::DEFINE_FUNS { funs, next })
=>
combf (collect next, funs);
end;
fun dofun ((_, f, _, _, body), (m, all))
=
{ my (es, fl) = collect body;
m' = im::set (m, f, is::vals_list es);
all' = is::add (all, f);
fold_forward
dofun
(m', all')
fl;
};
my (follow_map, allset)
=
dofun (f, (im::empty, is::empty));
rootedges = is::vals_list allset;
fun follow v
=
the (im::get (follow_map, v));
{ roots => rootedges,
follow
};
};
fun ass_num (scc::SIMPLE v, (i, nm))
=>
( i + 1,
im::set (nm, v, i)
);
ass_num (scc::RECURSIVE vl, (i, nm))
=>
( i + 1,
fold_forward
(\\ (v, nm) = im::set (nm, v, i))
nm
vl
);
end;
number_map
=
#2 (fold_forward ass_num (0, im::empty) (scc::topological_order' (make_graph fe')));
fun sccnum x
=
the (im::get (number_map, x));
# Why is this stuff all commented out? -- CrT XXX BUGGO FIXME
#
# exception Unseen
# type info = { dfsnum: Ref( Int ), sccnum: Ref( Int ), edges: List( Variable ) }
#
# my m: iht::Hashtable( info )
# = iht::make_hashtable { size_hint => 32, not_found_exception => UNSEEN }
#
# lookup = iht::lookup m
# my total: Ref( List( Variable ) ) = REF NIL
#
# fun addinfo (f, vl) =
# (total := (f ! *total);
# iht::set m (f,{ dfsnum=REF -1, sccnum=REF -1, edges=vl } ))
# fun kuc x = (contP x) or (knownP x) or (usersP x)
# # fun ec x = (contP x) or (escapesP x)
#
# fun makenode (_, f, _, _, body)
# =
# let fun edges (ncf::DEFINE_RECORD r) = edges r.next
# | edges (ncf::GET_FIELD_I r) = edges r.next
# | edges (ncf::GET_ADDRESS_OF_FIELD_I r) = edges r.next
# #
# | edges (ncf::ARITH r) = edges r.next
# | edges (ncf::PURE r) = edges r.next
# | edges (ncf::JUMPTABLE r) = foldmerge (map edges r.nexts)
# | edges (ncf::FETCH_FROM_RAM r) = edges r.next
# | edges (ncf::STORE_TO_RAM { op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER, args, next }) = merge (filter kuc (clean args), edges next)
# | edges (ncf::STORE_TO_RAM r) = edges r.next
# #
# | edges (ncf::IF_THEN_ELSE { then_next, else_next, ... }) = merge (edges then_next, edges else_next)
# | edges (ncf::TAIL_CALL { fn, args }) = filter kuc (clean (fn ! args))
# | edges (ncf::DEFINE_FUNS { funs, next }) = (apply makenode funs; edges next)
# in addinfo (f, edges body)
# end
#
# compnums = REF 0 and id = REF 0
# my stack: Ref( List( Int * Ref( Int ) ) ) = REF NIL
# fun scc nodenum =
# let fun newcomp (c, (n, sccnum) ! rest) =
# (sccnum := c;
# if n==nodenum then rest else newcomp (c, rest))
# | newcomp _ = error "newcomp in freeclose in the closure phase"
#
# my info as { dfsnum as REF d, sccnum, edges } = lookup nodenum
#
# in if d >= 0 then if *sccnum >= 0 then infinity else d
# else (let v = *id before (id := *id+1)
# (stack := (nodenum, sccnum) ! *stack;
# dfsnum := v)
# b = minl (map scc edges)
# in if v <= b
# then let c = *compnums before (compnums := *compnums+1)
# (stack := newcomp (c,*stack))
# in infinity # v
# end
# else b
# end)
# end
#
# makenode (fe') # Build the call graph
# apply (\\ x => (scc x; ())) *total # Compute the scc number
# sccnum = ! o .sccnum o lookup
fun samescc (x, n) # "scc" == "strongly connected component"
=
n < 0 ?? FALSE
:: sccnum x == n;
/*** >>
fun plist p l = (apply (\\ v => (say " "; p v)) l; say "\n")
ilist = plist vp
apply (\\ v => (vp v; say " edges: " ;
ilist(.edges (lookup v));
say "**** sccnum is ";
say (int::to_string (sccnum v)); say "\n")) *total
<<***/
# *************************************************************************
# Utility functions for lists of free variable unit. *
# Each unit "vnum" contains three parts: *
# the Variable, *
# the first-use-sn and *
# the last-use-sn *
# *************************************************************************
#
v2l = map h # Given a vnum list, return an Variable List
where
fun h (s: Vnum) = #1 s;
end;
# Add a single Variable used at stage n
#
fun adds_v (ncf::CODETEMP v, n, l)
=>
h (v, l)
where
fun h (v, [])
=>
[ (v, n, n) ];
h (v, l as ((u as (x, a, b)) ! r))
=>
if (x < v) u ! (h (v, r));
elif (x == v) ((x, int::min (a, n), int::max (a, n)) ! r);
else ((v, n, n) ! l);
fi;
end;
end;
adds_v (_, _, l)
=>
l;
end;
# Remove a single Variable:
#
fun rmvs_v (v, [])
=>
[];
rmvs_v (v, l as ((u as (x, _, _)) ! r))
=>
if (x < v) u ! (rmvs_v (v, r));
elif (x == v) r;
else l;
fi;
end;
# Remove a list of lvars:
#
fun remove_v (vl, 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;
# Add a list of lvars used at stage n:
#
fun add_v (vl, n, l)
=
h (vl, l)
where
fun h ( l1 as (x1 ! r1),
l2 as ((u2 as (x2, a2, b2)) ! r2)
)
=>
if (x1 < x2) (x1, n, n) ! (h (r1, l2));
elif (x1 > x2) u2 ! (h (l1, r2));
else (x1, int::min (n, a2), int::max (n, b2)) ! (h (r1, r2));
fi;
h( l1,[]) => map (\\ x = (x, n, n)) l1;
h ([], l2) => l2;
end;
end;
# Merge two lists of free var unit (exclusively)
#
fun merge_pv (n, l1, l2)
=
h (l1, l2)
where
fun h ( l1 as ((x1, a1, b1) ! r1),
l2 as ((x2, a2, b2) ! r2)
)
=>
if (x1 < x2) (x1, n, n) ! (h (r1, l2));
elif (x1 > x2) (x2, n, n) ! (h (l1, r2));
elif (b1 == b2) (x1, int::min (a1, a2), b1) ! (h (r1, r2));
else (x1, n, n) ! (h (r1, r2));
fi;
h (l1, []) => map (\\ (x, _, _) = (x, n, n)) l1;
h ([], l2) => map (\\ (x, _, _) = (x, n, n)) l2;
end;
end;
# Merge two lists of free var unit (with union)
#
fun merge_uv ( 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;
# Fold merge lists of free vars (exclusively)
#
fun fold_uv (l, b)
=
fold_backward merge_uv b l;
# Lay a list of free var unit over
# another list of free var unit:
#
fun over_v (n, l1, l2)
=
h (l1, l2)
where
fun h ( l1 as ((u1 as (x1, _, _)) ! r1),
l2 as ( (x2, _, _) ! r2)
)
=>
if (x1 < x2) u1 ! (h (r1, l2));
elif (x1 > x2) (x2, n, n) ! (h (l1, r2));
else u1 ! (h (r1, r2));
fi;
h (l1, []) => l1;
h ([], l2) => map (\\ (x, _, _) = (x, n, n)) l2;
end;
end;
# **************************************************************************
# Two hashtables (1) highcode_variable to stage number *
# (2) highcode_variable to freevar information *
# **************************************************************************
exception STAGENUM;
my snum: iht::Hashtable( Snum ) # "snum" = "stageNumber"
=
iht::make_hashtable { size_hint => 32, not_found_exception => STAGENUM };
addsn = iht::set snum; # Add the stage number for a fundef.
getsn = iht::get snum; # Get the stage number of a fundef.
fun findsn (v, d, [])
=>
{ warn ( "Fundef "
+ (tmp::name_of_highcode_codetemp v)
+ " unused in freeClose"
);
d;
};
findsn (v, d, (x, _, m) ! r)
=>
if (v > x)
findsn (v, d, r);
else
if (v == x)
m;
else
warn ( "Fundef "
+ (tmp::name_of_highcode_codetemp v)
+ " unused in freeClose"
);
d;
fi;
fi;
end;
fun findsn2 (v, d, [])
=>
d;
findsn2 (v, d, (x, _, m) ! r)
=>
if (v > x) findsn2 (v, d, r);
elif (v == x) m;
else d;
fi;
end;
exception FREEVMAP;
my vars: iht::Hashtable( Fvinfo )
=
iht::make_hashtable { size_hint => 32, not_found_exception => FREEVMAP };
fun add_entry (v, l, x, s)
=
iht::set vars (v, { fv=>l, lv=>x, size=>s } );
free_v = iht::get vars; # Get the freevar info.
loop_v = .lv o free_v; # The free variables on the loop path.
/*** >>
my vars: iht::Hashtable( List( Variable ) * Null_Or( List( Variable ) ) )
= iht::make_hashtable { size_hint => 32, not_found_exception => FREEVMAP }
freeV = iht::lookup vars
fun loopV v = (#2 (freeV v)) except FREEVMAP => error "loopV in closure"
<<***/
# *************************************************************************
# Split the pseudo-mutually-recursive namings, a temporary hack. *
# *
# TODO: need to add code on identify those KNOWN_REC kind functions *
# check the older version of this file for details *
# XXX BUGGO FIXME *
# *************************************************************************
fun known_opt ([], _, _, _, _)
=>
error "knownOpt in closure 4354";
known_opt (flinfo, died, freeb, gszb, fszb)
=>
{ newflinfo
=
{ roots = filter (sl::member died) (v2l freeb);
graph
=
map
( \\ ((_, f, _, _, _), free, _, _)
=
( f,
filter (sl::member died) (v2l free)
)
)
flinfo;
fun loop (old)
=
{ new
=
fold_backward
( \\ ((f, free), total)
=
sl::member old f ?? sl::merge (free, total)
:: total
)
old
graph;
if (length new == length old)
new;
else
loop new;
fi;
};
nroots = loop roots;
filter
(\\ ((_, f, _, _, _), _, _, _) = sl::member nroots f)
flinfo;
};
my (funs, freel, gsz, fsz)
=
fold_backward g ([], [], gszb, fszb) (known' @ other)
where
my (known, other)
=
partition
\\ ((ncf::PRIVATE_RECURSIVE_FN, _, _, _, _), _, _, _) => TRUE;
_ => FALSE;
end
newflinfo;
known'
=
case known
#
u as [ ((_, v, args, cl, body), free, gsz, fsz) ]
=>
if (sl::member (v2l free) v) u;
else [ ((ncf::PRIVATE_FN, v, args, cl, body), free, gsz, fsz) ];
fi;
z => z;
esac;
fun g ( (fe, vn, gsz', fsz'), (fl, vl, gsz, fsz))
=
(fe ! fl, vn ! vl, int::max (gsz', gsz), int::max (fsz', fsz));
end;
header
=
case funs
#
[] => (\\ next = next );
_ => (\\ next = ncf::DEFINE_FUNS { funs, next } );
esac;
( header,
freel,
gsz,
fsz
);
};
end;
# *************************************************************************
# The following procedure does five things: *
# *
# (1) Install a stage number for each function definition *
# (2) Collect the free variable information for each fundef *
# (3) Infer the live range of each free variable at each fundef *
# (4) Infer the set of free variables on the looping path *
# (5) Do the simple branch-prediction transformation *
# *
# TODO: better branch-prediction heuristics will help the merge done *
# at each SWITCH and BRANCH XXX BUGGO FIXME *
# *************************************************************************
# Major gross hack here:
ekfuns = intset::new();
ekfuns_p = intset::mem ekfuns;
ekfuns_m = intset::add ekfuns;
fun freefix
(sn, freeb)
(fk, f, vl, cl, ce)
=
{ my (ce', ul, wl, gsz, fsz)
=
if (cont_k fk)
#
n = findsn (f, sn, freeb);
nn = econt_k fk ?? n+1
:: n;
addsn (f, nn ); freevars (sccnum f, nn, ce);
elif (known_k fk) addsn (f, sn ); freevars (sccnum f, sn, ce);
else addsn (f, sn+1); freevars ( -1, sn+1, ce);
fi;
args = sl::uniq vl;
l = remove_v (args, ul);
z = remove_l (args, wl);
# The following is a gross hack,
# needs more work XXX BUGGO FIXME
#
nl =
if ((findsn2 (f, sn, l)) <= sn)
l;
else
fold_backward
(\\ ((x, i, j), z)
=
{ if (known_p x) ekfuns_m x; fi;
(x, i+1, j+1) ! z;
}
)
[]
l;
fi;
add_entry (f, l, z, (gsz, fsz));
my (gsz', fsz')
=
if (frmsz_k fk) # Only count escap-fate & knowntail funs
gn = length l; # *** NEED MORE WORK HERE XXX BUGGO FIXME ***
( int::max (gn, gsz),
fsz
);
else
(0, 0);
fi;
( (fk, f, vl, cl, ce'),
nl,
gsz',
fsz'
);
}
also
fun freevars (n, sn, ce)
=
case ce
#
ncf::DEFINE_FUNS { funs, next }
=>
{ died = sl::uniq (map #2 funs);
(freevars (n, sn, next))
->
(next, freeb, wl, gszb, fszb);
flinfo = map (freefix (sn, freeb)) funs;
(known_opt (flinfo, died, freeb, gszb, fszb))
->
(header, freel, gsz, fsz);
free = remove_v (died, fold_uv (freel, freeb));
nwl = case wl
#
NULL => NULL;
THE l
=>
( { fun h (x, l)
=
if (sl::member died x)
merge_l (loop_v x, l);
else addv_l (x, l);fi;
remove_l (died, fold_backward h (THE []) l);
}
);
esac;
( header next,
free,
nwl,
gsz,
fsz
);
};
ncf::TAIL_CALL { fn, args }
=>
{ free = clean (fn ! args);
fns = filter kuc free;
wl = exists (\\ x = samescc (x, n)) fns
?? THE free
:: NULL;
freeb = add_v (free, sn,[]);
( ce,
freeb,
wl,
0,
0
);
};
ncf::JUMPTABLE { i, xvar, nexts } # Add branch prediction heauristics in the future XXX BUGGO FIXME
=>
{ (fold_backward freelist ([],[],[], NULL, 0, 0, 0, 0) nexts)
->
(nexts, free1, free2, wl, gsz1, fsz1, gsz2, fsz2);
my (free, gsz, fsz)
=
case wl
#
NULL => ( free2, gsz2, fsz2);
THE _ => (over_v (sn, free1, free2), gsz1, fsz1);
esac;
( ncf::JUMPTABLE { i, xvar, nexts },
adds_v (i, sn, free),
add_l (i, wl),
gsz,
fsz
);
}
where
fun freelist (ce, (el, free1, free2, wl, gsz1, fsz1, gsz2, fsz2))
=
{ my (ce', free', wl', gsz', fsz')
=
freevars (n, sn, ce);
case wl'
NULL
=>
( ce' ! el,
free1,
merge_pv (sn, free', free2),
wl,
gsz1,
fsz1,
int::max (gsz2, gsz'),
int::max (fsz2, fsz')
);
THE _
=>
( ce' ! el,
merge_uv (free', free1),
free2,
merge_l (wl', wl),
int::max (gsz1, gsz'),
int::max (fsz1, fsz'),
gsz2,
fsz2
);
esac;
}; # fun freelist
end;
# | SWITCH (v, c, l) => # XXX BUGGO FIXME add branch prediction heauristics in the future
# let fun freelist (ce, (el, free, wl, gsz, fsz)) =
# let my (ce', free', wl', gsz', fsz') = freevars (n, sn, ce)
# ngsz = int::max (gsz, gsz')
# nfsz = int::max (fsz, fsz')
# in (ce' ! el, mergePV (sn, free', free), mergeL (wl', wl), ngsz, nfsz)
# end
# my (l', freel, wl, gsz, fsz) = fold_backward freelist ([],[], NULL, 0, 0) l
# in (SWITCH (v, c, l'), addsV (v, sn, freel), addL (v, wl), gsz, fsz)
# end
ncf::DEFINE_RECORD { kind, fields, to_temp, next }
=>
{ (freevars (n, sn, next))
->
(next, free, wl, gsz, fsz);
new = clean (map #1 fields);
free' = add_v (new, sn, rmvs_v (to_temp, free));
wl' = over_l (new, rmv_l (to_temp, wl));
( ncf::DEFINE_RECORD { kind, fields, to_temp, next },
free',
wl',
gsz,
fsz
);
};
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=>
{ (freevars (n, sn, next))
->
(next, free, wl, gsz, fsz);
free' = adds_v (record, sn, rmvs_v (to_temp, free));
wl' = add_l (record, rmv_l (to_temp, wl));
( ncf::GET_FIELD_I { i, record, to_temp, type, next },
free',
wl',
gsz,
fsz
);
};
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=>
{ (freevars (n, sn, next))
->
(next, free, wl, gsz, fsz);
free' = adds_v (record, sn, rmvs_v (to_temp, free));
wl' = add_l (record, rmv_l (to_temp, wl));
( ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next },
free',
wl',
gsz,
fsz
);
};
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next }
=>
{ (freevars (n, sn, next))
->
(next, free, wl, gsz, fsz);
new = clean args;
free' = add_v (new, sn, rmvs_v (to_temp, free));
wl' = over_l (new, rmv_l (to_temp, wl));
( ncf::FETCH_FROM_RAM { op, args, to_temp, type, next },
free',
wl',
gsz,
fsz
);
};
ncf::ARITH { op, args, to_temp, type, next }
=>
{ (freevars (n, sn, next))
->
(next, free, wl, gsz, fsz);
new = clean args;
free' = add_v (new, sn, rmvs_v (to_temp, free));
wl' = over_l (new, rmv_l (to_temp, wl));
( ncf::ARITH { op, args, to_temp, type, next },
free',
wl',
gsz,
fsz
);
};
ncf::PURE { op, args, to_temp, type, next }
=>
{ (freevars (n, sn, next))
->
(next, free, wl, gsz, fsz);
new = clean args;
free' = add_v (new, sn, rmvs_v (to_temp, free));
wl' = over_l (new, rmv_l (to_temp, wl));
( ncf::PURE { op, args, to_temp, type, next },
free',
wl',
gsz,
fsz
);
};
ncf::STORE_TO_RAM { op as ncf::p::SET_EXCEPTION_HANDLER_REGISTER, args, next }
=>
{ (freevars (n, sn, next))
->
(next, free, wl, gsz, fsz);
new = clean args;
free' = add_v (new, sn, free);
fns = filter kuc new;
wl' = exists (\\ x = samescc (x, n)) fns
?? merge_l (THE new, wl)
:: over_l (new, wl);
( ncf::STORE_TO_RAM { op, args, next },
free',
wl',
gsz,
fsz
);
};
ncf::STORE_TO_RAM { op, args, next }
=>
{ (freevars (n, sn, next))
->
(next, free, wl, gsz, fsz);
new = clean args;
free' = add_v (new, sn, free);
wl' = over_l (new, wl);
( ncf::STORE_TO_RAM { op, args, next },
free',
wl',
gsz,
fsz
);
};
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=>
{ (freevars (n, sn, next))
->
(next, free, wl, gsz, fsz);
new = clean args;
to_ttemps' = map #1 to_ttemps;
free' = add_v (new, sn, fold_forward rmvs_v free to_ttemps');
wl' = over_l (new, fold_forward rmv_l wl to_ttemps');
( ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next },
free',
wl',
gsz,
fsz
);
};
ncf::IF_THEN_ELSE { op => p, args => vl, xvar => c, then_next => e1, else_next => e2 }
=>
{ my (e1', free1, wl1, gsz1, fsz1) = freevars (n, sn, e1);
my (e2', free2, wl2, gsz2, fsz2) = freevars (n, sn, e2);
new = clean vl;
wl = over_l (new, merge_l (wl1, wl2));
case (wl1, wl2)
#
(NULL, THE _)
=>
{ free = add_v (new, sn, over_v (sn, free2, free1));
( ncf::IF_THEN_ELSE { op => ncf::p::opp p, args => vl, xvar => c, then_next => e2', else_next => e1' },
free,
wl,
gsz2,
fsz2
);
};
(THE _, NULL)
=>
{ free = add_v (new, sn, over_v (sn, free1, free2));
( ncf::IF_THEN_ELSE { op => p, args => vl, xvar => c, then_next => e1', else_next => e2' },
free,
wl,
gsz1,
fsz1
);
};
_ =>
{ free
=
case wl1
THE _
=>
add_v (new, sn, merge_uv (free1, free2));
_ => if (bfirst p) add_v (new, sn, over_v (sn, free1, free2));
elif (bsecond p) add_v (new, sn, over_v (sn, free2, free1));
else add_v (new, sn, merge_pv (sn, free1, free2));
fi;
esac;
gsz = int::max (gsz1, gsz2);
fsz = int::max (fsz1, fsz2);
( ncf::IF_THEN_ELSE { op => p, args => vl, xvar => c, then_next => e1', else_next => e2' },
free,
wl,
gsz,
fsz
);
};
esac;
};
esac;
( #1 (freefix (0, []) fe'),
getsn,
free_v,
ekfuns_p
);
}; # fun make_per_function_free_variable_maps
# my freemapClose
# =
# compile_statistics::do_phase
# (compile_statistics::make_phase "Compiler 079 freemapClose")
# freemapClose
}; # package make_per_function_free_variable_maps
end;