## split-nextcode-fns-int-known-vs-escaping-versions-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# "Introduces eta-redexes such that all functions fall
# into one of two categories: Either all of their call
# sites are known or none of their call sites are known.
#
# "I.e., if a function f is not in one of those two categories,
# a new function f' = \x.fx is introduced and all places where
# f "escapes" (i.e., is passed as a higher function argument
# rather than being directly called) are redirected to use f'."
#
# [...]
#
# "The need for etasplit is avoided by using slightly
# different formulations of the relevant optimizations."
#
# -- Principled Compilation and Scavenging
# Stefan Monnier, 2003 [PhD Thesis, U Montreal]
# http://www.iro.umontreal.ca/~monnier/master.ps.gz
# Perform the "eta-split" transformation on nextcode expressions.
# Its purpose is to give two entry points to functions which
# both escape and which are called at known points.
#
# The function is split into two functions:
#
# A known function that is used for calls.
#
# A strictly escaping function used for all
# escaping occurrences of the original function.
#
# The new escaping function simply calls the new known function.
#
# I do not bother to split known functions, or functions that only
# escape. Furthermore, no fates are split. I expect that
# the majority of fates are escaping, except for a few known
# fates that were created for reasons of space complexity (as
# the join of two branches, for example). I doubt there are many
# fates which both escape and have known calls. -- Trevor Jim
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 Split_Nextcode_Fns_Into_Known_Vs_Escaping_Versions {
#
split_nextcode_fns_into_known_vs_escaping_versions
:
{ function: ncf::Function,
table: iht::Hashtable( hut::Uniqtypoid ),
click: String -> Void
}
->
ncf::Function;
};
end;
# We are invoked from:
#
# src/lib/compiler/back/top/improve-nextcode/run-optional-nextcode-improvers-g.pkg # Machine_Properties is from src/lib/compiler/back/low/main/main/machine-properties.apistipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkgherein
generic package split_nextcode_fns_into_known_vs_escaping_versions_g (
# ====================================================
#
machine_properties: Machine_Properties # Typically src/lib/compiler/back/low/main/intel32/machine-properties-intel32.pkg )
: (weak) Split_Nextcode_Fns_Into_Known_Vs_Escaping_Versions # Split_Nextcode_Fns_Into_Known_Vs_Escaping_Versions is from src/lib/compiler/back/top/improve-nextcode/split-nextcode-fns-into-known-vs-escaping-versions-g.pkg {
fun share_name (x, ncf::CODETEMP y) => tmp::share_name (x, y);
share_name _ => ();
end;
fun split_nextcode_fns_into_known_vs_escaping_versions
{
function => (fkind, fvar, fargs, ctyl, cexp),
table => typetable,
click
}
=
{ debug = *global_controls::compiler::debugnextcode; # FALSE
fun debugprint s = if debug global_controls::print::say s; fi;
fun debugflush () = if debug global_controls::print::flush(); fi;
rep_flag = machine_properties::representations;
type_flag = *global_controls::compiler::checknextcode1 and rep_flag;
exception SPLIT1;
fun getty v
=
if type_flag
#
(iht::get typetable v)
except
_ =
{ global_controls::print::say
( "SPLIT1: Can't find the variable "
+ (int::to_string v)
+ " in the typetable ***** \n"
);
raise exception SPLIT1;
};
else
hcf::truevoid_uniqtypoid;
fi;
fun addty (f, t)
=
if type_flag iht::set typetable (f, t); fi;
fun copy_lvar v
=
{ x = tmp::clone_highcode_codetemp (v);
addty (x, getty v);
x;
};
stipulate
exception SPLIT2;
my m: iht::Hashtable( ncf::Value )
=
iht::make_hashtable { size_hint => 32, not_found_exception => SPLIT2 };
herein
fun makealias x
=
{ share_name x;
iht::set m x;
};
fun alias (ncf::CODETEMP v)
=>
(THE (iht::get m v))
except
SPLIT2 = NULL;
alias _ => NULL;
end;
end;
stipulate
exception SPLIT3;
my m: iht::Hashtable { used: Ref( Int ), called: Ref( Int ) }
=
iht::make_hashtable { size_hint => 32, not_found_exception => SPLIT3 };
herein
get = iht::get m;
fun enter_fn (_, f, _, _, _)
=
iht::set m (f,{ used=>REF 0, called=>REF 0 } );
#
# Perhaps I shouldn't bother to enter_fn fates?
fun use (ncf::CODETEMP v)
=>
{ (get v) -> { used, ... };
used := *used + 1;
}
except
SPLIT3 = ();
use _ => ();
end;
fun call (ncf::CODETEMP v)
=>
{ (get v) -> { used, called };
used := *used + 1;
called := *called + 1;
}
except
SPLIT3 = ();
call _ => ();
end;
end;
# Get usage information and
# mark whether or not we will
# be doing any splits.
found_split = REF FALSE;
recursive my pass1
=
\\ ncf::DEFINE_RECORD { fields, next, ... } => { apply (use o #1) fields; pass1 next; };
ncf::GET_FIELD_I { record, next, ... } => { use record; pass1 next; };
ncf::GET_ADDRESS_OF_FIELD_I { record, next, ... } => { use record; pass1 next; };
#
ncf::JUMPTABLE { i, nexts, ... } => { use i; apply pass1 nexts;};
#
ncf::IF_THEN_ELSE { args, then_next, else_next, ... }
=>
{ apply use args;
pass1 then_next;
pass1 else_next;
};
#
ncf::STORE_TO_RAM { args, next, ... } => { apply use args; pass1 next; };
ncf::FETCH_FROM_RAM { args, next, ... } => { apply use args; pass1 next; };
#
ncf::ARITH { args, next, ... } => { apply use args; pass1 next; };
ncf::PURE { args, next, ... } => { apply use args; pass1 next; };
ncf::RAW_C_CALL { args, next, ... } => { apply use args; pass1 next; };
#
ncf::TAIL_CALL { fn, args } => { call fn; apply use args; };
ncf::DEFINE_FUNS { funs, next }
=>
{ # Any changes to dosplit() (below)
# must be reflected here:
#
fun checksplit NIL
=>
();
checksplit ((ncf::FATE_FN, _, _, _, _) ! tl)
=>
checksplit tl;
checksplit ((_, f, _, _, _) ! tl)
=>
{ (get f) -> { used=>REF u, called=>REF c };
if (u!=c and c!=0) found_split := TRUE;
else checksplit tl;
fi;
};
end;
apply enter_fn funs;
apply (\\ (_, _, _, _, body) = pass1 body)
funs;
pass1 next;
if (not *found_split) checksplit funs; fi;
};
end;
recursive my reduce
=
\\ ncf::DEFINE_RECORD { kind, fields, to_temp, next }
=> ncf::DEFINE_RECORD { kind, fields, to_temp, next => reduce next };
#
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=> ncf::GET_FIELD_I { i, record, to_temp, type, next => reduce next };
#
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=> ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next => reduce next };
#
ncf::JUMPTABLE { i, xvar, nexts }
=> ncf::JUMPTABLE { i, xvar, nexts => map reduce nexts };
#
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=> ncf::IF_THEN_ELSE { op, args, xvar, then_next => reduce then_next, else_next => reduce else_next };
#
ncf::ARITH { op, args, to_temp, type, next } => ncf::ARITH { op, args, to_temp, type, next => reduce next };
ncf::PURE { op, args, to_temp, type, next } => ncf::PURE { op, args, to_temp, type, next => reduce next };
#
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next } => ncf::FETCH_FROM_RAM { op, args, to_temp, type, next => reduce next };
ncf::STORE_TO_RAM { op, args, next } => ncf::STORE_TO_RAM { op, args, next => reduce 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 => reduce next };
(e as ncf::TAIL_CALL { fn, args })
=>
case (alias fn)
#
THE fn => ncf::TAIL_CALL { fn, args };
NULL => e;
esac;
ncf::DEFINE_FUNS { funs, next }
=>
{ fun dosplit NIL => NIL;
dosplit ((hd as (ncf::PUBLIC_FN, f, vl, cl, body)) ! tl)
=>
{ (get f) -> { used=>REF u, called=>REF c };
if (u!=c and c!=0)
#
# Function escapes AND
# has known call sites:
#
f' = copy_lvar f;
vl' = map copy_lvar vl;
click "S";
makealias (f, ncf::CODETEMP f');
( (ncf::NO_INLINE_INTO, f, vl', cl, ncf::TAIL_CALL { fn => ncf::CODETEMP f', args => map ncf::CODETEMP vl' })
! (ncf::PUBLIC_FN, f', vl, cl, body)
! (dosplit tl)
);
else hd ! (dosplit tl);
fi;
};
dosplit (hd ! tl) => hd ! (dosplit tl);
end;
funs' = dosplit funs;
# Could check for NO_INLINE_INTO in reduce_body, so
# that we don't reduce in the body of something we've
# just split; but we might be using NO_INLINE_INTO
# for something else (e.g. UNCURRY).
fun reduce_body (fk, f, vl, cl, body)
=
(fk, f, vl, cl, reduce body);
ncf::DEFINE_FUNS { funs => map reduce_body funs',
next => reduce next
};
};
end ;
# Body of split_known_escaping_functions
debugprint "Etasplit: ";
pass1 cexp;
if *found_split (fkind, fvar, fargs, ctyl, reduce cexp);
else (fkind, fvar, fargs, ctyl, cexp);
fi
then
debugprint "\n";
}; # fun split_known_escaping_functions
}; # generic package split_known_escaping_functions_g
end; # stipulate
## Copyright 1996 by Bell Laboratories
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.