## do-nextcode-inlining-g.pkg
# 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# "General inlining, which decides whether or not
# to inline functions called more than once based
# on a budget and on estimates of code size and
# optimization opportunities that inlining will create.
#
# "This also does loop unrolling, and introduction of
# loop pre-headers [1] which allow loops to be inlined.
#
# -- Principled Compilation and Scavenging
# Stefan Monnier, 2003 [PhD Thesis, U Montreal]
# http://www.iro.umontreal.ca/~monnier/master.ps.gz
#
# [1] Loop Headers in lambda-calculus or nextcode
# Andrew W Appel
# 1994, 6p
# http://citeseer.ist.psu.edu/appel94loop.html
#DO set_control "compiler::trap_int_overflow" "TRUE";
stipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package hct = highcode_type; # highcode_type is from src/lib/compiler/back/top/highcode/highcode-type.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkgherein
api Do_Nextcode_Inlining {
#
do_nextcode_inlining
:
{ function: ncf::Function,
bodysize: Int,
unroll: Bool,
table: iht::Hashtable( hut::Uniqtype ),
after_closure: Bool,
do_headers: Bool,
click: String -> Void
}
->
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 hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkg 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.pkgherein
# This generic is invoked (only) from:
#
# src/lib/compiler/back/top/improve-nextcode/run-optional-nextcode-improvers-g.pkg generic package do_nextcode_inlining_g (
# ======================
#
machine_properties: Machine_Properties # Typically src/lib/compiler/back/low/main/intel32/machine-properties-intel32.pkg )
: (weak) Do_Nextcode_Inlining # Do_Nextcode_Inlining is from src/lib/compiler/back/top/improve-nextcode/do-nextcode-inlining-g.pkg {
fun inc (ri as REF i) = ri := i + 1;
fun dec (ri as REF i) = ri := i - 1;
fun map1 f (a, b)
=
(f a, b);
fun sum f
=
h
where
fun h (a ! r) => f a + h r;
h [] => 0;
end;
end;
fun muldiv (a, b, c) # A*b/c, approximately, but guaranteed no overflow
=
(a*b) / c
except
OVERFLOW
=
if (a > b) muldiv (a / 2, b, c / 2);
else muldiv (a, b / 2, c / 2);
fi;
fun share_name (x, ncf::CODETEMP y) => tmp::share_name (x, y);
share_name (x, ncf::LABEL y) => tmp::share_name (x, y);
share_name _ => ();
end;
Mode = ALL | NO_UNROLL | UNROLL Int | HEADERS;
fun do_nextcode_inlining
{
function => (fkind, fvar, fargs, ctyl, cexp),
unroll,
bodysize,
click,
after_closure,
table=>typtable,
do_headers
}
=
{
clicked_any = REF FALSE;
click = fn z = { click z; clicked_any := TRUE;};
debug = *coc::debugnextcode; # FALSE
debugprint = if debug global_controls::print::say; else fn _ = (); fi;
debugflush = if debug global_controls::print::flush; else fn _ = (); fi;
cginvariant = *coc::invariant;
fun label v
=
after_closure ?? ncf::LABEL v
:: ncf::CODETEMP v;
Data = FUN { escape: Ref( Int ),
call: Ref( Int ),
size: Ref( Int ),
args: List( ncf::Codetemp ),
body: ncf::Instruction,
#
invariant: Ref( List( Bool ) ), # one for each arg
unroll_call: Ref( Int ),
level: Int,
within: Ref( Bool )
}
| ARG { escape: Ref( Int ), savings: Ref( Int ),
record: Ref( List( (Int, ncf::Codetemp) ) ) }
| SEL { savings: Ref( Int ) }
| REC { escape: Ref( Int ), size: Int,
vars: List( (ncf::Value, ncf::Fieldpath) ) }
| REAL
| CONST
| OTHER
;
rep_flag = machine_properties::representations;
type_flag = *global_controls::compiler::checknextcode1
and *global_controls::compiler::checknextcode2
and rep_flag;
stipulate
exception NEXPAND;
fun getty v
=
if type_flag
#
(iht::get typtable v)
except
_ =
{ global_controls::print::say ("NEXPAND: Can't find the variable " +
(int::to_string v) + " in the typtable ***** \n");
raise exception NEXPAND;
};
else
hcf::truevoid_uniqtype;
fi;
fun addty (f, t)
=
iht::set typtable (f, t);
herein
fun make_var (t)
=
{ v = tmp::issue_highcode_codetemp();
if type_flag addty (v, t); fi;
v;
};
fun copy_lvar v
=
{ x = tmp::clone_highcode_codetemp (v);
if type_flag addty (x, getty v); fi;
x;
};
end; # with
stipulate
exception EXPAND;
my m: iht::Hashtable( Data )
=
iht::make_hashtable { size_hint => 128, not_found_exception => EXPAND };
get' = iht::get m;
herein
note = iht::set m;
fun get i
=
get' i
except
EXPAND = OTHER;
fun discard_pass1_info ()
=
iht::clear m;
end;
fun getval (ncf::CODETEMP v) => get v;
getval (ncf::LABEL v) => get v;
getval (ncf::INT _) => CONST;
# getval (ncf::REAL _) => REAL;
getval _ => OTHER;
end;
fun call (v, args)
=
case (getval v)
FUN { call, within=>REF FALSE, ... }
=>
inc call;
FUN { call, within=>REF TRUE, unroll_call, args=>vl, invariant, ... }
=>
{ fun g (ncf::CODETEMP x ! args, x' ! vl, i ! inv) =>
(i and x==x') ! g (args, vl, inv);
g( _ ! args, _ ! vl, i ! inv) =>
FALSE ! g (args, vl, inv);
g _ => NIL; end;
inc call; inc unroll_call;
invariant := g (args, vl,*invariant);
};
ARG { savings, ... } => inc savings;
SEL { savings } => inc savings;
_ => ();
esac;
fun escape v
=
case (getval v)
FUN { escape, ... } => inc escape;
ARG { escape, ... } => inc escape;
REC { escape, ... } => inc escape;
_ => ();
esac;
fun escapeargs v
=
case (getval v)
FUN { escape, ... } => inc escape;
ARG { escape, savings, ... } => { inc escape; inc savings; };
SEL { savings } => inc savings;
REC { escape, ... } => inc escape;
_ => ();
esac;
fun unescapeargs v
=
case (getval v)
FUN { escape, ... } => dec escape;
ARG { escape, savings, ... } => { dec escape; dec savings; };
SEL { savings } => dec savings;
REC { escape, ... } => dec escape;
_ => ();
esac;
fun notearg v = (note (v, ARG { escape=>REF 0, savings=>REF 0, record=>REF [] } ));
fun noteother v = (); # note (v, OTHER)
fun notereal v = noteother v; # note (v, REAL)
fun enter level (_, f, vl, _, e)
=
{ note ( f,
FUN { escape => REF 0,
call => REF 0,
size => REF 0,
args => vl,
body => e,
within => REF FALSE,
unroll_call => REF 0,
invariant => REF (map (fn _ = cginvariant) vl),
level
}
);
apply notearg vl;
};
fun noterec (w, vl, size)
=
note (w, REC { size, escape=>REF 0, vars=>vl } );
fun notesel (i, v, w)
=
{ note (w, SEL { savings=>REF 0 } );
case (getval v)
ARG { savings, record, ... }
=>
{ inc savings;
record := (i, w) ! *record;
};
_ => ();
esac;
};
fun setsize (f, n)
=
case (get f)
FUN { size, ... } => { size := n; n; };
_ => raise exception FAIL "Expand: setsize: not a FUN";
esac;
fun increase_savings (v, k)
=
case (getval v)
ARG { savings, ... } => savings := *savings + k;
SEL { savings } => savings := *savings + k;
_ => ();
esac;
fun setsave (v, k)
=
case (getval v)
ARG { savings, ... } => savings := k;
SEL { savings } => savings := k;
_ => ();
esac;
fun savesofar v
=
case (getval v)
ARG { savings, ... } => *savings;
SEL { savings } => *savings;
_ => 0;
esac;
fun within f func arg
=
case (get f)
FUN { within => w, ... }
=>
{ w := TRUE;
func arg
before
(w := FALSE);
};
_ => raise exception FAIL "Expand: within: f is not a FUN";
esac;
recursive my prim
=
fn (level, vl, e)
=
{ fun vbl (ncf::CODETEMP v)
=>
case (get v)
REC _ => 0;
_ => 1;
esac;
vbl _ => 0;
end;
nonconst = sum vbl vl;
sl = map savesofar vl;
afterwards = pass1 level e;
zl = map savesofar vl;
overhead = length vl + 1;
potential = overhead;
savings = case nonconst
1 => potential;
2 => potential / 4;
_ => 0;
esac;
fun app3 f
=
loop
where
fun loop (a ! b, c ! d, e ! r)
=>
{ f (a, c, e);
loop (b, d, r);
};
loop _ => ();
end;
end;
app3 (fn (v, s, z) = setsave (v, s + savings + (z-s)))
(vl, sl, zl);
overhead+afterwards;
}
also
primreal
=
fn (level, { op => _, args => vl, to_temp => w, type => _, next => e })
=
{ notereal w;
apply (fn v = increase_savings (v, 1)) vl;
2*(length vl + 1) + pass1 level e;
}
# *****************************************************************
# pass1: gather info on code.
# *****************************************************************
also
pass1: Int -> ncf::Instruction -> Int
=
(fn level
=
fn ncf::DEFINE_RECORD { fields, to_temp, next, ... }
=>
{ len = length fields;
apply (escape o #1) fields;
noterec (to_temp, fields, len);
2 + len + pass1 level next;
};
ncf::GET_FIELD_I { i, record, to_temp, next, ... } => { notesel (i, record, to_temp); 1 + pass1 level next;};
ncf::GET_ADDRESS_OF_FIELD_I { to_temp, next, ... } => { noteother to_temp; 1 + pass1 level next;};
ncf::TAIL_CALL { func, args }
=>
{ call (func, args);
apply escapeargs args;
1 + ((length args + 1) / 2);
};
ncf::DEFINE_FUNS { funs, next }
=>
{ apply (enter level) funs;
sum (fn (_, f, _, _, e) = setsize (f, within f (pass1 (level+1)) e)) funs
+ length funs
+ pass1 level next;
};
ncf::JUMPTABLE { i, nexts, ... }
=>
{ len = length nexts;
jumps = 4 + len; # 64-bit issue XXX BUGGO FIXME. Does the '4' need to be '8' on 64-bit machines...?
branches = sum (pass1 level) nexts;
increase_savings (i, muldiv (branches, len - 1, len) + jumps);
jumps+branches;
};
ncf::IF_THEN_ELSE { args => vl, xvar => c, then_next => e1, else_next => e2, ... }
=>
{ fun vbl (ncf::CODETEMP v)
=>
case (get v)
REC _ => 0;
_ => 1;
esac;
vbl _ => 0;
end;
nonconst = sum vbl vl;
sl = map savesofar vl;
branches = pass1 level e1 + pass1 level e2;
zl = map savesofar vl;
overhead = length vl;
potential = overhead + branches / 2;
savings
=
case nonconst
1 => potential;
2 => potential / 4;
_ => 0;
esac;
fun app3 f
=
loop
where
fun loop (a ! b, c ! d, e ! r)
=>
{ f (a, c, e);
loop (b, d, r);
};
loop _ => ();
end;
end;
app3 (fn (v, s, z) = setsave (v, s + savings + (z-s) / 2))
(vl, sl, zl);
overhead+branches;
};
ncf::FETCH_FROM_RAM { args, to_temp, next, ... }
=>
{ noteother to_temp;
prim (level, args, next);
};
ncf::STORE_TO_RAM { args, next, ... }
=>
prim (level, args, next);
ncf::MATH ( args as { op => ncf::p::MATH { kindbits=>ncf::p::FLOAT 64, ... }, ... })
=>
primreal (level, args);
ncf::MATH ( args as { op => ncf::p::ROUND _, ... })
=>
primreal (level, args);
ncf::MATH { args, to_temp, next, ... }
=>
{ noteother to_temp;
prim (level, args, next);
};
ncf::PURE { op => ncf::p::PURE_ARITH { kindbits=>ncf::p::FLOAT 64, ... }, args => [v], to_temp, next, ... }
=>
{ notereal to_temp;
increase_savings (v, 1);
4+(pass1 level next);
};
ncf::PURE { op => ncf::p::CONVERT_FLOAT { to=>ncf::p::FLOAT 64, ... }, args, to_temp, next, ... }
=>
{ notereal to_temp;
prim (level, args, next);
};
ncf::PURE { args, to_temp, next, ... }
=>
{ noteother to_temp;
prim (level, args, next);
};
ncf::RAW_C_CALL { args, to_ttemps, next, ... }
=>
{ apply (noteother o #1) to_ttemps;
#
prim (level, args, next);
};
end
); # fn pass1
# *******************************************************************
# substitute (args, wl, e, alpha) : substitute args for wl in e.
# If alpha=TRUE, also rename all namings.
# *******************************************************************
fun substitute (args, wl, e, alpha)
=
{ exception ALPHA;
my vm: iht::Hashtable( ncf::Value )
=
iht::make_hashtable { size_hint => 16, not_found_exception => ALPHA };
fun get (v, default)
=
the_else (iht::find vm v, default);
enter = iht::set vm;
fun use (v0 as ncf::CODETEMP v) => get (v, v0);
use (v0 as ncf::LABEL v) => get (v, v0);
use x => x;
end;
fun def v
=
if alpha
w = copy_lvar v;
enter (v, ncf::CODETEMP w);
w;
else
v;
fi;
fun defl v
=
if alpha
w = copy_lvar v;
enter (v, label w);
w;
else
v;
fi;
fun bind (a ! args, w ! wl)
=>
{ share_name (w, a);
enter (w, a);
bind (args, wl);
};
bind _ => ();
end;
recursive my g
=
fn ncf::DEFINE_RECORD { kind, fields, to_temp, next }
=>
ncf::DEFINE_RECORD { kind,
fields => map (map1 use) fields,
to_temp => def to_temp,
next => g next
};
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=> ncf::GET_FIELD_I { i, record => use record, to_temp => def to_temp, type, next => g next };
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=> ncf::GET_ADDRESS_OF_FIELD_I { i, record => use record, to_temp => def to_temp, next => g next };
ncf::TAIL_CALL { func, args }
=>
ncf::TAIL_CALL { func => use func,
args => map use args
};
ncf::DEFINE_FUNS { funs, next }
=>
ncf::DEFINE_FUNS { funs => map h2 (map h1 funs),
next => g next
}
where
# Careful: order of evaluation
# is important here:
#
fun h1 (fk, f, vl, cl, e)
=
(fk, defl f, vl, cl, e);
fun h2 (fk, f', vl, cl, e)
=
{ vl' = map def vl;
e'= g e;
(fk, f', vl', cl, e');
};
end;
ncf::JUMPTABLE { i, xvar, nexts } => ncf::JUMPTABLE { i => use i, xvar => def xvar, nexts => map g nexts };
ncf::STORE_TO_RAM { op, args, next } => ncf::STORE_TO_RAM { op, args => map use args, next => g next };
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next } => ncf::FETCH_FROM_RAM { op, args => map use args, to_temp => def to_temp, type, next => g next };
ncf::MATH { op, args, to_temp, type, next } => ncf::MATH { op, args => map use args, to_temp => def to_temp, type, next => g next };
ncf::PURE { op, args, to_temp, type, next } => ncf::PURE { op, args => map use args, to_temp => def to_temp, type, next => g next };
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=> ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args => map use args, to_ttemps => map (fn (w, t) = (def w, t)) to_ttemps, next => g next };
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=>
ncf::IF_THEN_ELSE { op,
args => map use args,
xvar => def xvar,
then_next => g then_next,
else_next => g else_next
};
end ;
bind (args, wl);
g e;
};
fun whatsave (acc, size, (v: ncf::Value) ! vl, a ! al)
=>
if (acc >= size)
acc;
else
case (get a)
#
ARG { escape=>REF esc, savings=>REF save, record=>REF rl }
=>
whatsave (acc+this - muldiv (acc, this, size), size, nvl, nal)
where
my (this, nvl: List( ncf::Value ), nal)
=
case (getval v)
#
FUN { escape=>REF 1, ... }
=>
( esc > 0 ?? save :: 6+save,
vl,
al
);
FUN _ => (save, vl, al);
REC { escape=>REF ex, vars, size }
=>
{ exception CHASE;
fun chasepath (v, ncf::SLOT 0)
=>
v;
chasepath (v, ncf::VIA_SLOT (i, p))
=>
case (getval v)
#
REC { vars, ... }
=>
chasepath (chasepath (list::nth (vars, i)), p);
_ => raise exception CHASE;
esac;
chasepath _ => raise exception CHASE;
end;
fun loop ([], nvl, nal)
=>
( (ex>1 or esc>0) ?? save :: save+size+2,
nvl,
nal
);
loop((i, w) ! rl, nvl, nal)
=>
loop ( rl,
chasepath (list::nth (vars, i)) ! nvl,
w ! nal
);
end;
loop (rl, vl, al)
except
CHASE => (0, vl, al);
(SUBSCRIPT|INDEX_OUT_OF_BOUNDS) => (0, vl, al);
end ;
};
# REAL => (save, vl, al)
CONST => (save, vl, al);
_ => (0, vl, al);
esac;
end;
SEL { savings=>REF save }
=>
whatsave (acc + this - muldiv (acc, this, size), size, vl, al)
where
this = case v
ncf::CODETEMP v' => case (get v')
FUN _ => save;
REC _ => save;
_ => 0;
esac;
_ => save;
esac;
end;
_ => raise exception FAIL "Expand: whatsave: not ARG nor SEL";
esac;
fi;
whatsave (acc, size, _, _)
=>
acc;
end;
################################################################
# Should a function application be inlined?
################################################################
#
fun should_expand
( d, # path length from entry to current function
u, # unroll level
e as ncf::TAIL_CALL { func => v, args => vl },
FUN { escape, call, unroll_call, size=>REF size, args, body,
level, within=>REF within, ... }
)
=>
if (*call + *escape == 1)
#
FALSE;
else
stupidloop # prevent infinite loops at compile time
=
case (v, body)
#
(ncf::CODETEMP vv, ncf::TAIL_CALL { func => ncf::CODETEMP v', ... }) => vv==v';
(ncf::LABEL vv, ncf::TAIL_CALL { func => ncf::LABEL v', ... }) => vv==v';
_ => FALSE;
esac;
calls = case u
UNROLL _ => *unroll_call;
_ => *call;
esac;
small_fun_size
=
case u
UNROLL _ => 0;
_ => 50;
esac;
savings
=
whatsave (0, size, vl, args);
predicted
=
{ real_increase = size-savings-(1+length vl);
real_increase * calls -
# Don't subtract off the original body if
# the original body is huge (because we might
# have guessed wrong and the consequences are
# too nasty for big functions); or if we're
# in unroll mode
#
if (size < small_fun_size) size;
else 0;
fi;
};
depth = 2;
max = 2;
if (FALSE and debug)
prettyprint_nextcode::print_nextcode_expression e;
debugprint (int::to_string predicted); debugprint " ";
debugprint (int::to_string bodysize); debugprint "\n";
fi;
not stupidloop
and case u
UNROLL lev
=>
# Unroll if: the loop body doesn't make function
# calls or "unroll_recursion" is turned on; and
# we are within the definition of the function;
# and it looks like things won't grow too much.
#
(*coc::unroll_recursion or level >= lev)
and within and predicted <= bodysize;
NO_UNROLL
=>
*unroll_call == 0 and
not within and
(predicted <= bodysize
or (*escape==0 and calls == 1));
HEADERS => FALSE; # shouldn't get here
ALL =>
(predicted <= bodysize
or (*escape==0 and calls == 1));
esac;
fi;
should_expand _
=>
raise exception FAIL "Expand: should_expand: unexpected argument";
end;
Decision = YES { formals: List( ncf::Codetemp ),
body: ncf::Instruction
}
| NO Int # How many no's in a row.
;
# There is really no point in
# making decisions a REF.
# This should be changed one day. # XXX BUGGO FIXME
#
my decisions: Ref( List( Decision ) )
= REF NIL;
fun decide_yes x
=
decisions := YES x ! *decisions;
fun decide_no ()
=
decisions := case *decisions
NO n ! rest => NO (n+1) ! rest;
d => NO 1 ! d;
esac;
# *******************************************************************
# pass2: mark function applications to be inlined.
# *******************************************************************
fun pass2
( d, # path length from start of current function
u, # unroll-info
e # expression to traverse
)
=
case e
#
ncf::DEFINE_RECORD { fields, next, ... } => pass2 (d+2+length fields, u, next);
#
ncf::GET_FIELD_I { next, ... } => pass2 (d+1, u, next);
ncf::GET_ADDRESS_OF_FIELD_I { next, ... } => pass2 (d+1, u, next);
#
ncf::TAIL_CALL { func, ... }
=>
case (getval func)
#
info as FUN { args, body, ... }
=>
(should_expand (d, u, e, info))
?? decide_yes { formals=>args, body }
:: decide_no ();
_ => decide_no ();
esac;
ncf::DEFINE_FUNS { funs, next }
=>
{ apply fundef funs;
#
pass2 (d + length(funs), u, next);
}
where
fun fundef (ncf::NO_INLINE_INTO, _, _, _, _)
=>
();
fundef (fk, f, vl, cl, e)
=>
case (get f)
#
FUN { level, within, escape=>REF escape, ... }
=>
{ u' = case u
#
UNROLL _ => UNROLL level;
_ => u;
esac;
fun conform ((ncf::CODETEMP x) ! r, z ! l)
=>
(x==z) and conform (r, l);
conform (_ ! r, _ ! l) => FALSE;
conform ( [], []) => TRUE;
conform _ => FALSE;
end;
within := TRUE;
pass2 (0, u', e)
before
within := FALSE;
};
_ => (); # Cannot happen
esac;
end;
end;
ncf::JUMPTABLE { nexts, ... }
=>
apply (fn e = pass2 (d+2, u, e)) nexts;
( ncf::FETCH_FROM_RAM { next, ... }
| ncf::STORE_TO_RAM { next, ... }
| ncf::MATH { next, ... }
| ncf::PURE { next, ... }
| ncf::RAW_C_CALL { next, ... }
) =>
pass2 (d+2, u, next);
ncf::IF_THEN_ELSE { then_next, else_next, ... }
=>
{ pass2 (d+2, u, then_next);
pass2 (d+2, u, else_next);
};
esac;
recursive my gamma
=
fn ncf::DEFINE_RECORD { kind, fields, to_temp, next }
=> ncf::DEFINE_RECORD { kind, fields, to_temp, next => gamma next };
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=> ncf::GET_FIELD_I { i, record, to_temp, type, next => gamma next };
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=> ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next => gamma next };
#
e as ncf::TAIL_CALL _ => e;
#
ncf::DEFINE_FUNS { funs, next }
=>
ncf::DEFINE_FUNS { funs => map fundef funs, next => gamma next }
where
fun fundef (z as (ncf::NO_INLINE_INTO, _, _, _, _))
=>
z;
fundef (z as (fk, f, vl, cl, e))
=>
case (get f)
#
FUN { escape=>REF escape,
call,
unroll_call,
invariant=>REF inv,
...
}
=>
if (escape == 0 and *unroll_call > 0
and (*call - *unroll_call > 1
or list::exists (fn t=t) inv)
)
f' = copy_lvar f;
vl' = map copy_lvar vl;
fun drop (FALSE ! r, a ! s) => a ! drop (r, s);
drop (TRUE ! r, _ ! s) => drop (r, s);
drop _ => NIL;
end;
newformals
=
label f' ! map ncf::CODETEMP (drop (inv, vl'));
e' =substitute (newformals,
f ! drop (inv, vl),
gamma e,
FALSE);
click "!"; debugprint (int::to_string f);
enter 0 (fk, f', vl', cl, e');
( fk,
f,
vl,
cl,
ncf::DEFINE_FUNS
{
funs => [ (fk, f', vl', cl, e') ],
#
next => ncf::TAIL_CALL { func => label f',
args => map ncf::CODETEMP vl
}
}
);
else
(fk, f, vl, cl, gamma e);
fi;
_ => z; # Cannot happen
esac;
end;
end;
ncf::JUMPTABLE { i, xvar, nexts } => ncf::JUMPTABLE { i, xvar, nexts => map gamma nexts };
ncf::MATH { op, args, to_temp, type, next } => ncf::MATH { op, args, to_temp, type, next => gamma next };
ncf::PURE { op, args, to_temp, type, next } => ncf::PURE { op, args, to_temp, type, next => gamma next };
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next } => ncf::FETCH_FROM_RAM { op, args, to_temp, type, next => gamma next };
ncf::STORE_TO_RAM { op, args, next } => ncf::STORE_TO_RAM { op, args, next => gamma next };
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=> ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next => gamma next };
#
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=> ncf::IF_THEN_ELSE { op, args, xvar, then_next => gamma then_next,
else_next => gamma else_next
};
end ;
recursive my beta
=
fn ncf::DEFINE_RECORD { kind, fields, to_temp, next }
=> ncf::DEFINE_RECORD { kind, fields, to_temp, next => beta next };
#
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=> ncf::GET_FIELD_I { i, record, to_temp, type, next => beta next };
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=> ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next => beta next };
e as ncf::TAIL_CALL { func, args }
=>
case *decisions
#
YES { formals, body } ! rest
=>
{ click "^";
case func
#
ncf::CODETEMP vv => debugprint (int::to_string vv);
_ => ();
esac;
debugflush();
decisions := rest;
substitute (args, formals, body, TRUE);
};
NO 1 ! rest => { decisions := rest; e;};
NO n ! rest => { decisions := NO (n - 1) ! rest; e;};
[] => e; # Cannot happen.
esac;
ncf::DEFINE_FUNS { funs, next }
=>
ncf::DEFINE_FUNS { funs => map fundef funs,
next => beta next
}
where
fun fundef (z as (ncf::NO_INLINE_INTO, _, _, _, _)) => z;
fundef (fk, f, vl, cl, e) => (fk, f, vl, cl, beta e);
end;
end;
ncf::JUMPTABLE { i, xvar, nexts } => ncf::JUMPTABLE { i, xvar, nexts => map beta nexts };
ncf::MATH { op, args, to_temp, type, next } => ncf::MATH { op, args, to_temp, type, next => beta next };
ncf::PURE { op, args, to_temp, type, next } => ncf::PURE { op, args, to_temp, type, next => beta next };
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next } => ncf::FETCH_FROM_RAM { op, args, to_temp, type, next => beta next };
ncf::STORE_TO_RAM { op, args, next } => ncf::STORE_TO_RAM { op, args, next => beta next };
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=> ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next => beta next };
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=> ncf::IF_THEN_ELSE { op, args, xvar, then_next => beta then_next,
else_next => beta else_next
};
end;
fun pass2_beta (mode, e)
=
{ pass2 (0, mode, e);
discard_pass1_info();
debugprint "Expand: finishing pass2\n"; debugflush();
case *decisions
#
[NO _] => { debugprint "No expansions to do.\n";
debugflush();
e;
};
_ => { decisions := reverse *decisions;
debugprint "Beta: ";
beta e
before
{ debugprint "\n";
debugflush();
};
};
esac;
};
gamma
=
fn c
=
{ debugprint "Gamma: ";
gamma c
before
{ debugprint "\n";
debugflush();
};
};
# Body of expand
notearg fvar;
apply notearg fargs;
# if *coc::printit then prettyprint_nextcode::print_nextcode_expression cexp
debugprint("Expand: pass1: ");
debugprint (int::to_string (pass1 0 cexp));
debugprint "\n";
debugflush();
if unroll
#
debugprint(" (unroll)\n");
debugflush();
e' = pass2_beta (UNROLL 0, cexp);
if *clicked_any
#
do_nextcode_inlining
{
function => (fkind, fvar, fargs, ctyl, e'),
table => typtable,
bodysize, click, unroll,
after_closure,
do_headers
};
else
# debugprint("\nExpand\n");
# debugflush();
# (fkind, fvar, fargs, ctyl, pass2_beta (ALL, cexp));
(fkind, fvar, fargs, ctyl, e');
fi;
else
if *coc::unroll
#
debugprint(" (headers)\n");
debugflush();
e' = if do_headers gamma cexp;
else cexp;
fi;
if *clicked_any
#
do_nextcode_inlining
{
function => (fkind, fvar, fargs, ctyl, e'),
table => typtable,
bodysize,
click,
unroll,
after_closure,
do_headers => FALSE
};
else
debugprint(" (non-unroll 1)\n");
debugflush();
(fkind, fvar, fargs, ctyl, pass2_beta (NO_UNROLL, e'));
fi;
else
debugprint(" (non-unroll 2)\n");
debugflush();
(fkind, fvar, fargs, ctyl, pass2_beta (ALL, cexp));
fi;
fi;
}; # fun do_nextcode_inlining
}; # generic package do_nextcode_inlining_g
end;
## Copyright 1996 by Bell Laboratories
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2013,
## released per terms of SMLNJ-COPYRIGHT.