suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add comments

Browse Source
This commit is contained in:
Matthew Flatt 2016-02-19 17:19:59 -07:00
parent 5f7d0317e8
commit 0606228959
11 changed files with 422 additions and 307 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
racket/src/racket/src/compile.c
View File

@ -19,10 +19,14 @@
Boston, MA 02110-1301 USA. Boston, MA 02110-1301 USA.
*/ */
/* This file implements macro expansion and compilation. Instead of /* This file implements macro expansion and front-end compilation.
always fully expanding code and then compiling it, the compiler Instead of always fully expanding code and then compiling it to an
expands as it goes, which enables some shortcuts compared to fully intermediate format, the compiler front-end expands as it goes,
expanding first. which enables some shortcuts compared to fully expanding first.
The intermediate format generated from here accumulates references
to non-local variables in a prefix, and it indicates whether each
local variable is mutatble.
See "eval.c" for an overview of compilation passes. See "eval.c" for an overview of compilation passes.
@ -213,7 +217,7 @@ void scheme_init_compile (Scheme_Env *env)
scheme_lambda_syntax, scheme_lambda_syntax,
env); env);
{ {
/* Graak lambda binding: */ /* Greek lambda binding: */
Scheme_Object *macro, *fn; Scheme_Object *macro, *fn;
fn = scheme_make_prim_w_arity(expand_lam, "\316\273", 1, 1); fn = scheme_make_prim_w_arity(expand_lam, "\316\273", 1, 1);

5
racket/src/racket/src/eval.c
View File

@ -83,9 +83,8 @@
Compilation works in five passes. Compilation works in five passes.
The first pass, called "compile", performs most of the work and The first pass, called "compile", is the expander and compiler
tracks variable usage (including whether a variable is mutated or front-end. See "compile.c", along with "compenv.c" and "module.c".
not). See "compile.c" along with "compenv.c".
The second pass, called "letrec_check", determines which references The second pass, called "letrec_check", determines which references
to `letrec'-bound variables need to be guarded with a run-time to `letrec'-bound variables need to be guarded with a run-time

6
racket/src/racket/src/letrec_check.c
View File

@ -22,7 +22,11 @@
#include "schpriv.h" #include "schpriv.h"
#include "schmach.h" #include "schmach.h"
/* PLAN: /* This file implements the compiler's letrec-check pass.
*
* See "eval.c" for an overview of compilation passes.
*
* PLAN:
* *
* Imagine starting with a simple abstract interpretation: traverse * Imagine starting with a simple abstract interpretation: traverse
* the program in evaluation order, treating `if` like `begin` and * the program in evaluation order, treating `if` like `begin` and

9
racket/src/racket/src/module.c
View File

@ -19,10 +19,11 @@
Boston, MA 02110-1301 USA. Boston, MA 02110-1301 USA.
*/ */
/* This file implements the first-order, top-level module system. An /* This file implements the first-order, top-level module system --
initiantiated module is implemented essentially as a namespace. The both the expander and compiler front-end, as well as run-time
bindings at the top level of a module are namespace top-level support for modules. An initiantiated module is implemented
bindings. */ essentially as a namespace. The bindings at the top level of a
module are namespace top-level bindings. */
#include "schpriv.h" #include "schpriv.h"
#include "schmach.h" #include "schmach.h"

2
racket/src/racket/src/mzmark_resolve.inc
View File

@ -15,7 +15,6 @@ static int mark_resolve_info_MARK(void *p, struct NewGC *gc) {
gcMARK2(i->prefix, gc); gcMARK2(i->prefix, gc);
gcMARK2(i->stx_map, gc); gcMARK2(i->stx_map, gc);
gcMARK2(i->tl_map, gc); gcMARK2(i->tl_map, gc);
gcMARK2(i->old_stx_pos, gc);
gcMARK2(i->redirects, gc); gcMARK2(i->redirects, gc);
gcMARK2(i->lifts, gc); gcMARK2(i->lifts, gc);
gcMARK2(i->next, gc); gcMARK2(i->next, gc);
@ -36,7 +35,6 @@ static int mark_resolve_info_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(i->prefix, gc); gcFIXUP2(i->prefix, gc);
gcFIXUP2(i->stx_map, gc); gcFIXUP2(i->stx_map, gc);
gcFIXUP2(i->tl_map, gc); gcFIXUP2(i->tl_map, gc);
gcFIXUP2(i->old_stx_pos, gc);
gcFIXUP2(i->redirects, gc); gcFIXUP2(i->redirects, gc);
gcFIXUP2(i->lifts, gc); gcFIXUP2(i->lifts, gc);
gcFIXUP2(i->next, gc); gcFIXUP2(i->next, gc);

1
racket/src/racket/src/mzmarksrc.c
View File

@ -1322,7 +1322,6 @@ mark_resolve_info {
gcMARK2(i->prefix, gc); gcMARK2(i->prefix, gc);
gcMARK2(i->stx_map, gc); gcMARK2(i->stx_map, gc);
gcMARK2(i->tl_map, gc); gcMARK2(i->tl_map, gc);
gcMARK2(i->old_stx_pos, gc);
gcMARK2(i->redirects, gc); gcMARK2(i->redirects, gc);
gcMARK2(i->lifts, gc); gcMARK2(i->lifts, gc);
gcMARK2(i->next, gc); gcMARK2(i->next, gc);

458
racket/src/racket/src/optimize.c
View File

@ -31,10 +31,6 @@
#include "schrunst.h" #include "schrunst.h"
#include "schmach.h" #include "schmach.h"
static ROSYM Scheme_Hash_Tree *empty_eq_hash_tree;
#define cons(a,b) scheme_make_pair(a,b)
/* Controls for inlining algorithm: */ /* Controls for inlining algorithm: */
#define OPT_ESTIMATE_FUTURE_SIZES 1 #define OPT_ESTIMATE_FUTURE_SIZES 1
#define OPT_DISCOURAGE_EARLY_INLINE 1 #define OPT_DISCOURAGE_EARLY_INLINE 1
@ -42,10 +38,14 @@ static ROSYM Scheme_Hash_Tree *empty_eq_hash_tree;
#define OPT_BRANCH_ADDS_NO_SIZE 1 #define OPT_BRANCH_ADDS_NO_SIZE 1
#define OPT_DELAY_GROUP_PROPAGATE 0 #define OPT_DELAY_GROUP_PROPAGATE 0
#define MAX_PROC_INLINE_SIZE 256 #define MAX_PROC_INLINE_SIZE 256
#define CROSS_MODULE_INLINE_SIZE 8 #define CROSS_MODULE_INLINE_SIZE 8
#define SCHEME_PRIM_IS_UNSAFE_NONMUTATING (SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_OMITABLE) /* Various kinds of fuel ensure that
the compiler doesn't go into a loop
or take non-linear time */
#define INITIAL_INLINING_FUEL 32
#define INITIAL_FLATTENING_FUEL 16
struct Optimize_Info struct Optimize_Info
{ {
@ -85,18 +85,19 @@ struct Optimize_Info
that single_result and preserves_marks are also 1, and that it's not necessary to that single_result and preserves_marks are also 1, and that it's not necessary to
use optimize_ignored before including the expression. */ use optimize_ignored before including the expression. */
int lambda_depth; int lambda_depth; /* counts nesting depth under `lambda`s */
int used_toplevel; int used_toplevel; /* tracks whether any non-local variables or syntax-object literals are used */
Scheme_Hash_Table *uses; /* used variables, accumulated for closures */
Scheme_IR_Local *transitive_use_var; /* set when optimizing a letrec-bound procedure */ Scheme_IR_Local *transitive_use_var; /* set when optimizing a letrec-bound procedure
struct Optimize_Info *transitive_uses_to; to record variables that were added to `uses` */
struct Optimize_Info *transitive_uses_to; /* points to frame with relevant `transitive_use_var` */
Scheme_Object *context; /* for logging */ Scheme_Object *context; /* for logging */
Scheme_Logger *logger; Scheme_Logger *logger;
Scheme_Hash_Tree *types; /* maps position (from this frame) to predicate */ Scheme_Hash_Tree *types; /* maps position (from this frame) to predicate */
int no_types; int no_types; /* disables use of type info */
Scheme_Hash_Table *uses; /* used variables, accumulated for closures */
}; };
typedef struct Optimize_Info_Sequence { typedef struct Optimize_Info_Sequence {
@ -163,7 +164,7 @@ typedef struct Scheme_Once_Used {
Scheme_Object so; Scheme_Object so;
Scheme_Object *expr; Scheme_Object *expr;
Scheme_IR_Local *var; Scheme_IR_Local *var;
int vclock; int vclock; /* record clocks at binding site */
int aclock; int aclock;
int kclock; int kclock;
int sclock; int sclock;
@ -174,6 +175,8 @@ typedef struct Scheme_Once_Used {
static Scheme_Once_Used *make_once_used(Scheme_Object *val, Scheme_IR_Local *var, static Scheme_Once_Used *make_once_used(Scheme_Object *val, Scheme_IR_Local *var,
int vclock, int aclock, int kclock, int sclock, int spans_k); int vclock, int aclock, int kclock, int sclock, int spans_k);
static ROSYM Scheme_Hash_Tree *empty_eq_hash_tree;
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
static void register_traversers(void); static void register_traversers(void);
#endif #endif
@ -188,6 +191,115 @@ void scheme_init_optimize()
#endif #endif
} }
/*========================================================================*/
/* logging */
/*========================================================================*/
static void note_match(int actual, int expected, Optimize_Info *warn_info)
{
if (!warn_info || (expected == -1))
return;
if (actual != expected) {
scheme_log(warn_info->logger,
SCHEME_LOG_WARNING,
0,
"warning%s: %d values produced when %d expected",
scheme_optimize_context_to_string(warn_info->context),
actual, expected);
}
}
char *scheme_optimize_context_to_string(Scheme_Object *context)
/* Convert a context to a string that is suitable for use in logging */
{
if (context) {
Scheme_Object *mod, *func;
const char *ctx, *prefix, *mctx, *mprefix;
char *all;
int clen, plen, mclen, mplen, len;
if (SCHEME_PAIRP(context)) {
func = SCHEME_CAR(context);
mod = SCHEME_CDR(context);
} else if (SAME_TYPE(SCHEME_TYPE(context), scheme_module_type)) {
func = scheme_false;
mod = context;
} else {
func = context;
mod = scheme_false;
}
if (SAME_TYPE(SCHEME_TYPE(func), scheme_ir_lambda_type)) {
Scheme_Object *name;
name = ((Scheme_Lambda *)func)->name;
if (name) {
if (SCHEME_VECTORP(name)) {
Scheme_Object *port;
int print_width = 1024;
intptr_t plen;
port = scheme_make_byte_string_output_port();
scheme_write_proc_context(port, print_width,
SCHEME_VEC_ELS(name)[0],
SCHEME_VEC_ELS(name)[1], SCHEME_VEC_ELS(name)[2],
SCHEME_VEC_ELS(name)[3], SCHEME_VEC_ELS(name)[4],
SCHEME_TRUEP(SCHEME_VEC_ELS(name)[6]));
ctx = scheme_get_sized_byte_string_output(port, &plen);
prefix = " in: ";
} else {
ctx = scheme_get_proc_name(func, &len, 0);
prefix = " in: ";
}
} else {
ctx = "";
prefix = "";
}
} else {
ctx = "";
prefix = "";
}
if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_type)) {
mctx = scheme_display_to_string(((Scheme_Module *)mod)->modsrc, NULL);
mprefix = " in module: ";
} else {
mctx = "";
mprefix = "";
}
clen = strlen(ctx);
plen = strlen(prefix);
mclen = strlen(mctx);
mplen = strlen(mprefix);
if (!clen && !mclen)
return "";
all = scheme_malloc_atomic(clen + plen + mclen + mplen + 1);
memcpy(all, prefix, plen);
memcpy(all + plen, ctx, clen);
memcpy(all + plen + clen, mprefix, mplen);
memcpy(all + plen + clen + mplen, mctx, mclen);
all[clen + plen + mclen + mplen] = 0;
return all;
} else
return "";
}
char *scheme_optimize_info_context(Optimize_Info *info)
{
return scheme_optimize_context_to_string(info->context);
}
Scheme_Logger *scheme_optimize_info_logger(Optimize_Info *info)
{
return info->logger;
}
/*========================================================================*/ /*========================================================================*/
/* utils */ /* utils */
/*========================================================================*/ /*========================================================================*/
@ -199,8 +311,12 @@ static void set_optimize_mode(Scheme_IR_Local *var)
var->mode = SCHEME_VAR_MODE_OPTIMIZE; var->mode = SCHEME_VAR_MODE_OPTIMIZE;
} }
#define SCHEME_PRIM_IS_UNSAFE_NONMUTATING (SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_OMITABLE)
int scheme_is_functional_nonfailing_primitive(Scheme_Object *rator, int num_args, int expected_vals) int scheme_is_functional_nonfailing_primitive(Scheme_Object *rator, int num_args, int expected_vals)
/* return 2 => results are a constant when arguments are constants */ /* A call to a functional, non-failing primitive (i.e., it accepts any argument)
can be discarded if its results are ignored.
Return 2 => true, and results are a constant when arguments are constants. */
{ {
if (SCHEME_PRIMP(rator) if (SCHEME_PRIMP(rator)
&& (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & (SCHEME_PRIM_IS_OMITABLE_ANY | SCHEME_PRIM_IS_UNSAFE_NONMUTATING)) && (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & (SCHEME_PRIM_IS_OMITABLE_ANY | SCHEME_PRIM_IS_UNSAFE_NONMUTATING))
@ -218,6 +334,7 @@ int scheme_is_functional_nonfailing_primitive(Scheme_Object *rator, int num_args
} }
static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info *info) static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info *info)
/* Determines whether `rator` is known to be a struct accessor, etc. */
{ {
Scheme_Object *c; Scheme_Object *c;
@ -240,6 +357,7 @@ static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info
} }
int scheme_is_struct_functional(Scheme_Object *rator, int num_args, Optimize_Info *info, int vals) int scheme_is_struct_functional(Scheme_Object *rator, int num_args, Optimize_Info *info, int vals)
/* Determines whether `rator` is a functional, non-failing struct operation */
{ {
Scheme_Object *c; Scheme_Object *c;
@ -258,22 +376,8 @@ int scheme_is_struct_functional(Scheme_Object *rator, int num_args, Optimize_Inf
return 0; return 0;
} }
static void note_match(int actual, int expected, Optimize_Info *warn_info)
{
if (!warn_info || (expected == -1))
return;
if (actual != expected) {
scheme_log(warn_info->logger,
SCHEME_LOG_WARNING,
0,
"warning%s: %d values produced when %d expected",
scheme_optimize_context_to_string(warn_info->context),
actual, expected);
}
}
static Scheme_Object *extract_specialized_proc(Scheme_Object *le, Scheme_Object *default_val) static Scheme_Object *extract_specialized_proc(Scheme_Object *le, Scheme_Object *default_val)
/* Look through `(procedure-specialize <e>)` to get `<e>` */
{ {
if (SAME_TYPE(SCHEME_TYPE(le), scheme_application2_type)) { if (SAME_TYPE(SCHEME_TYPE(le), scheme_application2_type)) {
Scheme_App2_Rec *app = (Scheme_App2_Rec *)le; Scheme_App2_Rec *app = (Scheme_App2_Rec *)le;
@ -515,6 +619,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
} }
static Scheme_Object *ensure_single_value(Scheme_Object *e) static Scheme_Object *ensure_single_value(Scheme_Object *e)
/* Wrap `e` so that it either produces a single value or fails */
{ {
Scheme_App2_Rec *app2; Scheme_App2_Rec *app2;
@ -628,7 +733,7 @@ static Scheme_Object *optimize_ignored(Scheme_Object *e, Optimize_Info *info,
int fuel) int fuel)
/* Simplify an expression whose result will be ignored. The /* Simplify an expression whose result will be ignored. The
`expected_vals` is 1 or -1. If `maybe_omittable`, the result can be `expected_vals` is 1 or -1. If `maybe_omittable`, the result can be
NULL to dincate that it can be omitted. */ NULL to indicate that it can be omitted. */
{ {
if (maybe_omittable) { if (maybe_omittable) {
if (scheme_omittable_expr(e, expected_vals, 5, 0, info, NULL)) if (scheme_omittable_expr(e, expected_vals, 5, 0, info, NULL))
@ -725,6 +830,8 @@ static Scheme_Object *make_application_3(Scheme_Object *a, Scheme_Object *b, Sch
} }
static Scheme_Object *replace_tail_inside(Scheme_Object *alt, Scheme_Object *inside, Scheme_Object *orig) static Scheme_Object *replace_tail_inside(Scheme_Object *alt, Scheme_Object *inside, Scheme_Object *orig)
/* Installs a new expression inthe result position of various forms, such as `begin`;
extract_tail_inside() needs to be consistent with this function */
{ {
if (inside) { if (inside) {
switch (SCHEME_TYPE(inside)) { switch (SCHEME_TYPE(inside)) {
@ -749,9 +856,9 @@ static Scheme_Object *replace_tail_inside(Scheme_Object *alt, Scheme_Object *ins
} }
static void extract_tail_inside(Scheme_Object **_t2, Scheme_Object **_inside) static void extract_tail_inside(Scheme_Object **_t2, Scheme_Object **_inside)
/* Looks through various forms, like `begin` to extract a reslt expression;
replace_tail_inside() needs to be consistent with this function */
{ {
/* replace_tail_inside() needs to be consistent with this function */
while (1) { while (1) {
if (SAME_TYPE(SCHEME_TYPE(*_t2), scheme_ir_let_void_type)) { if (SAME_TYPE(SCHEME_TYPE(*_t2), scheme_ir_let_void_type)) {
Scheme_IR_Let_Header *head = (Scheme_IR_Let_Header *)*_t2; Scheme_IR_Let_Header *head = (Scheme_IR_Let_Header *)*_t2;
@ -774,8 +881,12 @@ static void extract_tail_inside(Scheme_Object **_t2, Scheme_Object **_inside)
} }
} }
/*========================================================================*/
/* detecting `make-struct-type` calls and struct shapes */
/*========================================================================*/
static int is_inspector_call(Scheme_Object *a) static int is_inspector_call(Scheme_Object *a)
/* Does `a` produce an inspector? */
{ {
if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) { if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) {
Scheme_App_Rec *app = (Scheme_App_Rec *)a; Scheme_App_Rec *app = (Scheme_App_Rec *)a;
@ -788,6 +899,7 @@ static int is_inspector_call(Scheme_Object *a)
} }
static int is_proc_spec_proc(Scheme_Object *p) static int is_proc_spec_proc(Scheme_Object *p)
/* Does `p` produce a good `prop:procedure` value? */
{ {
Scheme_Type vtype; Scheme_Type vtype;
@ -815,6 +927,9 @@ static int is_proc_spec_proc(Scheme_Object *p)
} }
static int is_local_ref(Scheme_Object *e, int p, int r, Scheme_IR_Local **vars) static int is_local_ref(Scheme_Object *e, int p, int r, Scheme_IR_Local **vars)
/* Does `e` refer to...
In resolved mode: variables at offet `p` though `p+r`?
In optimizer IR mode: variables in `vars`? */
{ {
if (!vars && SAME_TYPE(SCHEME_TYPE(e), scheme_local_type)) { if (!vars && SAME_TYPE(SCHEME_TYPE(e), scheme_local_type)) {
if ((SCHEME_LOCAL_POS(e) >= p) if ((SCHEME_LOCAL_POS(e) >= p)
@ -832,6 +947,7 @@ static int is_local_ref(Scheme_Object *e, int p, int r, Scheme_IR_Local **vars)
} }
static int is_int_list(Scheme_Object *o, int up_to) static int is_int_list(Scheme_Object *o, int up_to)
/* Is `o` a list of distinct integers that are less than `up_to`? */
{ {
if (SCHEME_PAIRP(o)) { if (SCHEME_PAIRP(o)) {
char *s, quick[8]; char *s, quick[8];
@ -858,6 +974,7 @@ static int is_int_list(Scheme_Object *o, int up_to)
static int ok_proc_creator_args(Scheme_Object *rator, Scheme_Object *rand1, Scheme_Object *rand2, Scheme_Object *rand3, static int ok_proc_creator_args(Scheme_Object *rator, Scheme_Object *rand1, Scheme_Object *rand2, Scheme_Object *rand3,
int delta2, int field_count, Scheme_IR_Local **vars) int delta2, int field_count, Scheme_IR_Local **vars)
/* Does `rator` plus `rand1` and `rand2` create a struct accessor or mutator? */
{ {
if ((SAME_OBJ(rator, scheme_make_struct_field_accessor_proc) if ((SAME_OBJ(rator, scheme_make_struct_field_accessor_proc)
&& is_local_ref(rand1, delta2+3, 1, vars)) && is_local_ref(rand1, delta2+3, 1, vars))
@ -877,6 +994,8 @@ static int ok_proc_creator_args(Scheme_Object *rator, Scheme_Object *rand1, Sche
static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved, static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved,
Simple_Stuct_Type_Info *_stinfo, Simple_Stuct_Type_Info *_stinfo,
Scheme_IR_Local **vars) Scheme_IR_Local **vars)
/* Does `e` produce values for a structure type, mutators, and accessors in the
usual order? */
{ {
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
Scheme_App_Rec *app = (Scheme_App_Rec *)e; Scheme_App_Rec *app = (Scheme_App_Rec *)e;
@ -935,6 +1054,8 @@ static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int
} }
static Scheme_Object *skip_clears(Scheme_Object *body) static Scheme_Object *skip_clears(Scheme_Object *body)
/* If `body` is a `begin` form that exists only to clear variables
as installed by the SFS pass, then extract the result form. */
{ {
if (SAME_TYPE(SCHEME_TYPE(body), scheme_sequence_type)) { if (SAME_TYPE(SCHEME_TYPE(body), scheme_sequence_type)) {
Scheme_Sequence *seq = (Scheme_Sequence *)body; Scheme_Sequence *seq = (Scheme_Sequence *)body;
@ -954,6 +1075,7 @@ static int is_constant_super(Scheme_Object *arg,
Scheme_Hash_Table *top_level_table, Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta, Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table) Scheme_Object **symbols, Scheme_Hash_Table *symbol_table)
/* Does `arg` produce another structure type (which can serve as a supertype)? */
{ {
int pos; int pos;
Scheme_Object *v; Scheme_Object *v;
@ -1082,7 +1204,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
&& !SCHEME_SYM_WEIRDP(app->args[7])) && !SCHEME_SYM_WEIRDP(app->args[7]))
|| is_inspector_call(app->args[7])) || is_inspector_call(app->args[7]))
&& ((app->num_args < 8) && ((app->num_args < 8)
/* propcedure property: */ /* procedure property: */
|| SCHEME_FALSEP(app->args[8]) || SCHEME_FALSEP(app->args[8])
|| is_proc_spec_proc(app->args[8])) || is_proc_spec_proc(app->args[8]))
&& ((app->num_args < 9) && ((app->num_args < 9)
@ -1183,6 +1305,9 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
return NULL; return NULL;
} }
/*========================================================================*/
/* more utils */
/*========================================================================*/
intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *stinfo) intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *stinfo)
{ {
@ -1298,8 +1423,9 @@ static int single_valued_noncm_expression(Scheme_Object *expr, int fuel)
} }
static int is_movable_prim(Scheme_Object *rator, int n, int cross_lambda, int cross_k, Optimize_Info *info) static int is_movable_prim(Scheme_Object *rator, int n, int cross_lambda, int cross_k, Optimize_Info *info)
/* A -1 return means that the arguments must be movable without /* Can we move a call to `rator` relative to other function calls?
changing space complexity. */ A -1 return means that the arguments must be movable without
changing space complexity (which is the case for `cons`, for example). */
{ {
if (rator && SCHEME_PRIMP(rator)) { if (rator && SCHEME_PRIMP(rator)) {
if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) { if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) {
@ -1340,7 +1466,7 @@ static int is_movable_prim(Scheme_Object *rator, int n, int cross_lambda, int cr
static int movable_expression(Scheme_Object *expr, Optimize_Info *info, static int movable_expression(Scheme_Object *expr, Optimize_Info *info,
int cross_lambda, int cross_k, int cross_s, int cross_lambda, int cross_k, int cross_s,
int check_space, int fuel) int check_space, int fuel)
/* An expression that can't necessarily be constant-folded, /* A movable expression can't necessarily be constant-folded,
but can be delayed because it has no side-effects (or is unsafe), but can be delayed because it has no side-effects (or is unsafe),
produces a single value, produces a single value,
and is not sensitive to being in tail position */ and is not sensitive to being in tail position */
@ -1444,6 +1570,51 @@ int scheme_is_ir_lambda(Scheme_Object *o, int can_be_closed, int can_be_liftable
return 0; return 0;
} }
XFORM_NONGCING static int small_inline_number(Scheme_Object *o)
{
if (SCHEME_BIGNUMP(o))
return SCHEME_BIGLEN(o) < 32;
else if (SCHEME_COMPLEXP(o))
return (small_inline_number(scheme_complex_real_part(o))
&& small_inline_number(scheme_complex_imaginary_part(o)));
else if (SCHEME_RATIONALP(o))
return (small_inline_number(scheme_rational_numerator(o))
&& small_inline_number(scheme_rational_denominator(o)));
else
return 1;
}
#define STR_INLINE_LIMIT 256
int scheme_ir_duplicate_ok(Scheme_Object *fb, int cross_module)
/* Is the constant a value that we can "copy" in the code? */
{
return (SCHEME_VOIDP(fb)
|| SAME_OBJ(fb, scheme_true)
|| SCHEME_FALSEP(fb)
|| (SCHEME_SYMBOLP(fb)
&& (!cross_module || (!SCHEME_SYM_WEIRDP(fb)
&& (SCHEME_SYM_LEN(fb) < STR_INLINE_LIMIT))))
|| (SCHEME_KEYWORDP(fb)
&& (!cross_module || (SCHEME_KEYWORD_LEN(fb) < STR_INLINE_LIMIT)))
|| SCHEME_EOFP(fb)
|| SCHEME_INTP(fb)
|| SCHEME_NULLP(fb)
|| (!cross_module && SAME_TYPE(SCHEME_TYPE(fb), scheme_ir_local_type))
|| SCHEME_PRIMP(fb)
/* Values that are hashed by the printer and/or interned on
read to avoid duplication: */
|| SCHEME_CHARP(fb)
|| (SCHEME_CHAR_STRINGP(fb)
&& (!cross_module || (SCHEME_CHAR_STRLEN_VAL(fb) < STR_INLINE_LIMIT)))
|| (SCHEME_BYTE_STRINGP(fb)
&& (!cross_module || (SCHEME_BYTE_STRLEN_VAL(fb) < STR_INLINE_LIMIT)))
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_regexp_type)
|| (SCHEME_NUMBERP(fb)
&& (!cross_module || small_inline_number(fb)))
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_ctype_type));
}
/*========================================================================*/ /*========================================================================*/
/* applications, branches, sequences */ /* applications, branches, sequences */
/*========================================================================*/ /*========================================================================*/
@ -1626,9 +1797,10 @@ static Scheme_Object *no_potential_size(Scheme_Object *v)
return v; return v;
} }
static Scheme_Object *apply_inlined(Scheme_Object *p, Optimize_Info *info, static Scheme_Object *apply_inlined(Scheme_Lambda *lam, Optimize_Info *info,
int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3,
int context, Scheme_Object *orig, Scheme_Object *le_prev) int context, Scheme_Object *orig, Scheme_Object *le_prev)
/* Optimize the body of `lam` given the known arguments in `app`, `app2`, or `app3` */
{ {
Scheme_IR_Let_Header *lh; Scheme_IR_Let_Header *lh;
Scheme_IR_Let_Value *lv, *prev = NULL; Scheme_IR_Let_Value *lv, *prev = NULL;
@ -1636,13 +1808,12 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Optimize_Info *info,
int i, expected; int i, expected;
Optimize_Info *sub_info; Optimize_Info *sub_info;
Scheme_IR_Local **vars; Scheme_IR_Local **vars;
Scheme_Lambda *lam = (Scheme_Lambda *)p; Scheme_Object *p = lam->body;
p = lam->body;
expected = lam->num_params; expected = lam->num_params;
if (!expected) { if (!expected) {
/* No arguments, so no need for a `let` wrapper: */
sub_info = optimize_info_add_frame(info, 0, 0, 0); sub_info = optimize_info_add_frame(info, 0, 0, 0);
sub_info->inline_fuel >>= 1; sub_info->inline_fuel >>= 1;
p = scheme_optimize_expr(p, sub_info, context); p = scheme_optimize_expr(p, sub_info, context);
@ -1683,9 +1854,9 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Optimize_Info *info,
else else
val = scheme_false; val = scheme_false;
l = cons(val, l); l = scheme_make_pair(val, l);
} }
l = cons(scheme_list_proc, l); l = scheme_make_pair(scheme_list_proc, l);
val = scheme_make_application(l, info); val = scheme_make_application(l, info);
} else if (app) } else if (app)
val = app->args[i + 1]; val = app->args[i + 1];
@ -1905,7 +2076,7 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
sz, sz,
threshold, threshold,
scheme_optimize_context_to_string(info->context)); scheme_optimize_context_to_string(info->context));
le = apply_inlined(le, sub_info, argc, app, app2, app3, context, le = apply_inlined((Scheme_Lambda *)le, sub_info, argc, app, app2, app3, context,
orig_le, prev); orig_le, prev);
return le; return le;
} else { } else {
@ -1986,12 +2157,16 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
} }
static int is_local_type_expression(Scheme_Object *expr, Optimize_Info *info) static int is_local_type_expression(Scheme_Object *expr, Optimize_Info *info)
/* Get an unboxing type (e.g., flonum) for `expr` */
{ {
return predicate_to_local_type(expr_implies_predicate(expr, info, NULL, 5)); return predicate_to_local_type(expr_implies_predicate(expr, info, NULL, 5));
} }
static void register_local_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, static void register_local_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3,
Optimize_Info *info) Optimize_Info *info)
/* If `rator` is a variable bound to a `lambda`, record the types of actual arguments
provided in a function call. If all calls are consistent with unboxing, then the
procedure will accept unboxed arguments at run time. */
{ {
Scheme_Object *rator, *rand, *le; Scheme_Object *rator, *rand, *le;
int n, i; int n, i;
@ -2051,95 +2226,6 @@ static void register_local_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec *
} }
} }
char *scheme_optimize_context_to_string(Scheme_Object *context)
{
if (context) {
Scheme_Object *mod, *func;
const char *ctx, *prefix, *mctx, *mprefix;
char *all;
int clen, plen, mclen, mplen, len;
if (SCHEME_PAIRP(context)) {
func = SCHEME_CAR(context);
mod = SCHEME_CDR(context);
} else if (SAME_TYPE(SCHEME_TYPE(context), scheme_module_type)) {
func = scheme_false;
mod = context;
} else {
func = context;
mod = scheme_false;
}
if (SAME_TYPE(SCHEME_TYPE(func), scheme_ir_lambda_type)) {
Scheme_Object *name;
name = ((Scheme_Lambda *)func)->name;
if (name) {
if (SCHEME_VECTORP(name)) {
Scheme_Object *port;
int print_width = 1024;
intptr_t plen;
port = scheme_make_byte_string_output_port();
scheme_write_proc_context(port, print_width,
SCHEME_VEC_ELS(name)[0],
SCHEME_VEC_ELS(name)[1], SCHEME_VEC_ELS(name)[2],
SCHEME_VEC_ELS(name)[3], SCHEME_VEC_ELS(name)[4],
SCHEME_TRUEP(SCHEME_VEC_ELS(name)[6]));
ctx = scheme_get_sized_byte_string_output(port, &plen);
prefix = " in: ";
} else {
ctx = scheme_get_proc_name(func, &len, 0);
prefix = " in: ";
}
} else {
ctx = "";
prefix = "";
}
} else {
ctx = "";
prefix = "";
}
if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_type)) {
mctx = scheme_display_to_string(((Scheme_Module *)mod)->modsrc, NULL);
mprefix = " in module: ";
} else {
mctx = "";
mprefix = "";
}
clen = strlen(ctx);
plen = strlen(prefix);
mclen = strlen(mctx);
mplen = strlen(mprefix);
if (!clen && !mclen)
return "";
all = scheme_malloc_atomic(clen + plen + mclen + mplen + 1);
memcpy(all, prefix, plen);
memcpy(all + plen, ctx, clen);
memcpy(all + plen + clen, mprefix, mplen);
memcpy(all + plen + clen + mplen, mctx, mclen);
all[clen + plen + mclen + mplen] = 0;
return all;
} else
return "";
}
char *scheme_optimize_info_context(Optimize_Info *info)
{
return scheme_optimize_context_to_string(info->context);
}
Scheme_Logger *scheme_optimize_info_logger(Optimize_Info *info)
{
return info->logger;
}
static void reset_rator(Scheme_Object *app, Scheme_Object *a) static void reset_rator(Scheme_Object *app, Scheme_Object *a)
{ {
switch (SCHEME_TYPE(app)) { switch (SCHEME_TYPE(app)) {
@ -2535,6 +2621,7 @@ static Scheme_Object *finish_optimize_app(Scheme_Object *o, Optimize_Info *info,
} }
static Scheme_Object *direct_apply(Scheme_Object *expr, Scheme_Object *rator, Scheme_Object *last_rand, Optimize_Info *info) static Scheme_Object *direct_apply(Scheme_Object *expr, Scheme_Object *rator, Scheme_Object *last_rand, Optimize_Info *info)
/* Convert `(apply f arg1 ... (list arg2 ...))` to `(f arg1 ... arg2 ...)` */
{ {
if (SAME_OBJ(rator, scheme_apply_proc)) { if (SAME_OBJ(rator, scheme_apply_proc)) {
switch(SCHEME_TYPE(last_rand)) { switch(SCHEME_TYPE(last_rand)) {
@ -2612,6 +2699,8 @@ static Scheme_Object *call_with_immed_mark(Scheme_Object *rator,
Scheme_Object *rand2, Scheme_Object *rand2,
Scheme_Object *rand3, Scheme_Object *rand3,
Optimize_Info *info) Optimize_Info *info)
/* Convert `(call-with-immediate-continuation-mark (lambda (arg) M))`
to the with-immediate-mark bytecode form. */
{ {
if (SAME_OBJ(rator, scheme_call_with_immed_mark_proc) if (SAME_OBJ(rator, scheme_call_with_immed_mark_proc)
&& SAME_TYPE(SCHEME_TYPE(rand2), scheme_ir_lambda_type) && SAME_TYPE(SCHEME_TYPE(rand2), scheme_ir_lambda_type)
@ -2739,6 +2828,7 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
} }
static int appn_flags(Scheme_Object *rator, Optimize_Info *info) static int appn_flags(Scheme_Object *rator, Optimize_Info *info)
/* Record some properties of an application that are useful to the SFS pass. */
{ {
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_toplevel_type)) { if (SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_toplevel_type)) {
if (info->top_level_consts) { if (info->top_level_consts) {
@ -3808,6 +3898,10 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
info, context); info, context);
} }
/*========================================================================*/
/* the apply-values bytecode form */
/*========================================================================*/
Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e, Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
Optimize_Info *info, Optimize_Info *info,
int e_single_result, int e_single_result,
@ -3888,6 +3982,10 @@ Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
} }
} }
/*========================================================================*/
/* begin and begin0 */
/*========================================================================*/
static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, int context, int sub_opt); static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, int context, int sub_opt);
static Scheme_Object *flatten_sequence(Scheme_Object *o, Optimize_Info *info, int context) static Scheme_Object *flatten_sequence(Scheme_Object *o, Optimize_Info *info, int context)
@ -4078,52 +4176,12 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, i
return flatten_sequence((Scheme_Object *)s, info, context); return flatten_sequence((Scheme_Object *)s, info, context);
} }
XFORM_NONGCING static int small_inline_number(Scheme_Object *o) /*========================================================================*/
{ /* conditionals and types */
if (SCHEME_BIGNUMP(o)) /*========================================================================*/
return SCHEME_BIGLEN(o) < 32;
else if (SCHEME_COMPLEXP(o))
return (small_inline_number(scheme_complex_real_part(o))
&& small_inline_number(scheme_complex_imaginary_part(o)));
else if (SCHEME_RATIONALP(o))
return (small_inline_number(scheme_rational_numerator(o))
&& small_inline_number(scheme_rational_denominator(o)));
else
return 1;
}
#define STR_INLINE_LIMIT 256
int scheme_ir_duplicate_ok(Scheme_Object *fb, int cross_module)
{
return (SCHEME_VOIDP(fb)
|| SAME_OBJ(fb, scheme_true)
|| SCHEME_FALSEP(fb)
|| (SCHEME_SYMBOLP(fb)
&& (!cross_module || (!SCHEME_SYM_WEIRDP(fb)
&& (SCHEME_SYM_LEN(fb) < STR_INLINE_LIMIT))))
|| (SCHEME_KEYWORDP(fb)
&& (!cross_module || (SCHEME_KEYWORD_LEN(fb) < STR_INLINE_LIMIT)))
|| SCHEME_EOFP(fb)
|| SCHEME_INTP(fb)
|| SCHEME_NULLP(fb)
|| (!cross_module && SAME_TYPE(SCHEME_TYPE(fb), scheme_ir_local_type))
|| SCHEME_PRIMP(fb)
/* Values that are hashed by the printer and/or interned on
read to avoid duplication: */
|| SCHEME_CHARP(fb)
|| (SCHEME_CHAR_STRINGP(fb)
&& (!cross_module || (SCHEME_CHAR_STRLEN_VAL(fb) < STR_INLINE_LIMIT)))
|| (SCHEME_BYTE_STRINGP(fb)
&& (!cross_module || (SCHEME_BYTE_STRLEN_VAL(fb) < STR_INLINE_LIMIT)))
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_regexp_type)
|| (SCHEME_NUMBERP(fb)
&& (!cross_module || small_inline_number(fb)))
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_ctype_type));
}
static Scheme_Object *collapse_local(Scheme_Object *var, Optimize_Info *info, int context) static Scheme_Object *collapse_local(Scheme_Object *var, Optimize_Info *info, int context)
/* pos is in new-frame counts */ /* Replace `var` in the given context with a constant, if possible based on its type */
{ {
if (!SCHEME_VAR(var)->mutated) { if (!SCHEME_VAR(var)->mutated) {
Scheme_Object *pred; Scheme_Object *pred;
@ -4584,6 +4642,10 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
return o; return o;
} }
/*========================================================================*/
/* with-continuation-marks */
/*========================================================================*/
static int omittable_key(Scheme_Object *k, Optimize_Info *info) static int omittable_key(Scheme_Object *k, Optimize_Info *info)
{ {
/* A key is not omittable if it might refer to a chaperoned/impersonated /* A key is not omittable if it might refer to a chaperoned/impersonated
@ -5171,6 +5233,7 @@ static Scheme_Object *begin_for_syntax_optimize(Scheme_Object *data, Optimize_In
/*========================================================================*/ /*========================================================================*/
static int is_liftable_prim(Scheme_Object *v, int or_escape) static int is_liftable_prim(Scheme_Object *v, int or_escape)
/* Can we lift a call to `v` out of a `letrec` to a wrapping `let`? */
{ {
if (SCHEME_PRIMP(v)) { if (SCHEME_PRIMP(v)) {
int opt = (((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OPT_MASK); int opt = (((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OPT_MASK);
@ -5189,6 +5252,8 @@ static int is_liftable_prim(Scheme_Object *v, int or_escape)
} }
int scheme_is_liftable(Scheme_Object *o, Scheme_Hash_Tree *exclude_vars, int fuel, int as_rator, int or_escape) int scheme_is_liftable(Scheme_Object *o, Scheme_Hash_Tree *exclude_vars, int fuel, int as_rator, int or_escape)
/* Can we lift `o` out of a `letrec` to a wrapping `let`? Refences
to `exclude_vars` are now allowed, since those are the LHS. */
{ {
Scheme_Type t = SCHEME_TYPE(o); Scheme_Type t = SCHEME_TYPE(o);
@ -5272,6 +5337,7 @@ int scheme_is_liftable(Scheme_Object *o, Scheme_Hash_Tree *exclude_vars, int fue
} }
int scheme_ir_propagate_ok(Scheme_Object *value, Optimize_Info *info) int scheme_ir_propagate_ok(Scheme_Object *value, Optimize_Info *info)
/* Can we constant-propagate the expression `value`? */
{ {
if (scheme_ir_duplicate_ok(value, 0)) if (scheme_ir_duplicate_ok(value, 0))
return 1; return 1;
@ -5338,6 +5404,7 @@ int scheme_ir_propagate_ok(Scheme_Object *value, Optimize_Info *info)
} }
int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info) int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info)
/* Does `value` definitely produce a procedure of a specific shape? */
{ {
while (1) { while (1) {
if (SAME_TYPE(SCHEME_TYPE(value), scheme_ir_lambda_type)) if (SAME_TYPE(SCHEME_TYPE(value), scheme_ir_lambda_type))
@ -5364,6 +5431,8 @@ int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info)
} }
Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e) Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e)
/* Make a record that presents a procedure of a known shape, but
that should not be inlined. */
{ {
Scheme_Object *ni; Scheme_Object *ni;
@ -5383,6 +5452,9 @@ Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e)
} }
static int is_values_apply(Scheme_Object *e, int n, Optimize_Info *info, Scheme_Hash_Tree *except_vars, int fuel) static int is_values_apply(Scheme_Object *e, int n, Optimize_Info *info, Scheme_Hash_Tree *except_vars, int fuel)
/* Is `e` a `(values ...)` form --- or, in the case of `if`, can be be
converted to one, so that we can split apart the results
statically? */
{ {
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
Scheme_App_Rec *app = (Scheme_App_Rec *)e; Scheme_App_Rec *app = (Scheme_App_Rec *)e;
@ -5407,12 +5479,13 @@ static int is_values_apply(Scheme_Object *e, int n, Optimize_Info *info, Scheme_
return 0; return 0;
} }
static int no_mutable_bindings(Scheme_IR_Let_Value *pre_body) static int no_mutable_bindings(Scheme_IR_Let_Value *irlv)
/* Check whether a `let` clause has any mutable bindings */
{ {
int i; int i;
for (i = pre_body->count; i--; ) { for (i = irlv->count; i--; ) {
if (pre_body->vars[i]->mutated) if (irlv->vars[i]->mutated)
return 0; return 0;
} }
@ -5421,6 +5494,7 @@ static int no_mutable_bindings(Scheme_IR_Let_Value *pre_body)
static void update_rhs_value(Scheme_IR_Let_Value *naya, Scheme_Object *e, static void update_rhs_value(Scheme_IR_Let_Value *naya, Scheme_Object *e,
Optimize_Info *info, Scheme_IR_Local *tst) Optimize_Info *info, Scheme_IR_Local *tst)
/* Install an expression from a split `(values ...)` */
{ {
if (tst) { if (tst) {
Scheme_Object *n; Scheme_Object *n;
@ -5447,6 +5521,7 @@ static void update_rhs_value(Scheme_IR_Let_Value *naya, Scheme_Object *e,
static void unpack_values_application(Scheme_Object *e, Scheme_IR_Let_Value *naya, static void unpack_values_application(Scheme_Object *e, Scheme_IR_Let_Value *naya,
Optimize_Info *info, Scheme_IR_Local *branch_test) Optimize_Info *info, Scheme_IR_Local *branch_test)
/* Install the expressions from a split `values` form into new `let` clauses */
{ {
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
Scheme_App_Rec *app = (Scheme_App_Rec *)e; Scheme_App_Rec *app = (Scheme_App_Rec *)e;
@ -5476,6 +5551,8 @@ static void unpack_values_application(Scheme_Object *e, Scheme_IR_Let_Value *nay
static Scheme_Object *make_clones(Scheme_IR_Let_Value *retry_start, static Scheme_Object *make_clones(Scheme_IR_Let_Value *retry_start,
Scheme_IR_Let_Value *pre_body, Scheme_IR_Let_Value *pre_body,
Optimize_Info *body_info) Optimize_Info *body_info)
/* Clone `lambda`s for re-optimization and for a fixpoint computation of
procedure properties */
{ {
Scheme_IR_Let_Value *irlv; Scheme_IR_Let_Value *irlv;
Scheme_Object *value, *clone, *pr; Scheme_Object *value, *clone, *pr;
@ -5508,6 +5585,7 @@ static int set_one_code_flags(Scheme_Object *value, int flags,
Scheme_Object *first, Scheme_Object *second, Scheme_Object *first, Scheme_Object *second,
int set_flags, int mask_flags, int just_tentative, int set_flags, int mask_flags, int just_tentative,
int merge_local_typed) int merge_local_typed)
/* Set, record, or merge procedure-property flags */
{ {
Scheme_Case_Lambda *cl, *cl2, *cl3; Scheme_Case_Lambda *cl, *cl2, *cl3;
Scheme_Lambda *lam, *lam2, *lam3; Scheme_Lambda *lam, *lam2, *lam3;
@ -5557,6 +5635,7 @@ static int set_code_flags(Scheme_IR_Let_Value *retry_start,
Scheme_Object *clones, Scheme_Object *clones,
int set_flags, int mask_flags, int just_tentative, int set_flags, int mask_flags, int just_tentative,
int merge_local_typed) int merge_local_typed)
/* Set, record, or merge procedure-property flags */
{ {
Scheme_IR_Let_Value *irlv; Scheme_IR_Let_Value *irlv;
Scheme_Object *value, *first; Scheme_Object *value, *first;
@ -5692,7 +5771,8 @@ void advance_clocks_for_optimized(Scheme_Object *o,
scheme_signal_error("internal error: optimizer clock tracking has gone wrong"); scheme_signal_error("internal error: optimizer clock tracking has gone wrong");
} }
static int worth_lifting(Scheme_Object *v) static int can_unwrap(Scheme_Object *v)
/* Can `v` be unwrapped from `(let ([x v]) v)`? */
{ {
Scheme_Type lhs; Scheme_Type lhs;
lhs = SCHEME_TYPE(v); lhs = SCHEME_TYPE(v);
@ -5707,6 +5787,7 @@ static int worth_lifting(Scheme_Object *v)
} }
static void flip_transitive(Scheme_Hash_Table *ht, int on) static void flip_transitive(Scheme_Hash_Table *ht, int on)
/* Adjust usage flags based on recorded tentative uses */
{ {
Scheme_IR_Local *tvar; Scheme_IR_Local *tvar;
int j; int j;
@ -5736,6 +5817,9 @@ static void flip_transitive(Scheme_Hash_Table *ht, int on)
} }
static void start_transitive_use_record(Optimize_Info *to_info, Optimize_Info *info, Scheme_IR_Local *var) static void start_transitive_use_record(Optimize_Info *to_info, Optimize_Info *info, Scheme_IR_Local *var)
/* Start recording uses as tentative. Uses in a `lambda` as the RHS of
the binding of `var` will only be used in the end of `var` itself
is used. */
{ {
if (var->optimize_used) if (var->optimize_used)
return; return;
@ -5749,6 +5833,7 @@ static void start_transitive_use_record(Optimize_Info *to_info, Optimize_Info *i
} }
static void end_transitive_use_record(Optimize_Info *info) static void end_transitive_use_record(Optimize_Info *info)
/* Stop recording uses as tentative. */
{ {
Scheme_IR_Local *var = info->transitive_use_var; Scheme_IR_Local *var = info->transitive_use_var;
@ -5763,6 +5848,7 @@ static void end_transitive_use_record(Optimize_Info *info)
Scheme_Object * Scheme_Object *
scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context) scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context)
/* This is the main entry point for optimizing a `let[rec]-values` form. */
{ {
Optimize_Info *body_info, *rhs_info; Optimize_Info *body_info, *rhs_info;
Optimize_Info_Sequence info_seq; Optimize_Info_Sequence info_seq;
@ -5809,7 +5895,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) { if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) {
irlv = (Scheme_IR_Let_Value *)head->body; irlv = (Scheme_IR_Let_Value *)head->body;
if (SAME_OBJ((Scheme_Object *)irlv->vars[0], irlv->body)) { if (SAME_OBJ((Scheme_Object *)irlv->vars[0], irlv->body)) {
if (worth_lifting(irlv->value)) { if (can_unwrap(irlv->value)) {
/* Drop the let */ /* Drop the let */
return scheme_optimize_expr(irlv->value, info, context); return scheme_optimize_expr(irlv->value, info, context);
} }
@ -6485,7 +6571,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
if (!is_rec && (head->count == 1) && (head->num_clauses == 1)) { if (!is_rec && (head->count == 1) && (head->num_clauses == 1)) {
irlv = (Scheme_IR_Let_Value *)head->body; irlv = (Scheme_IR_Let_Value *)head->body;
if (SAME_OBJ(irlv->body, (Scheme_Object *)irlv->vars[0])) { if (SAME_OBJ(irlv->body, (Scheme_Object *)irlv->vars[0])) {
if (worth_lifting(irlv->value)) if (can_unwrap(irlv->value))
return irlv->value; return irlv->value;
} }
} }
@ -6540,7 +6626,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
} }
/*========================================================================*/ /*========================================================================*/
/* closures */ /* lambda */
/*========================================================================*/ /*========================================================================*/
static Scheme_Object * static Scheme_Object *
@ -7983,8 +8069,8 @@ Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, int get_logger)
#ifdef MZTAG_REQUIRED #ifdef MZTAG_REQUIRED
info->type = scheme_rt_optimize_info; info->type = scheme_rt_optimize_info;
#endif #endif
info->inline_fuel = 32; info->inline_fuel = INITIAL_INLINING_FUEL;
info->flatten_fuel = 16; info->flatten_fuel = INITIAL_FLATTENING_FUEL;
info->cp = cp; info->cp = cp;
if (get_logger) { if (get_logger) {

33
racket/src/racket/src/resolve.c
View File

@ -24,13 +24,17 @@
*/ */
/* This file implements the bytecode "resolve" pass, which converts /* This file implements the bytecode "resolve" pass, which converts
the optimization IR to the evaluation IR --- where the main the optimization IR to the evaluation bytecode --- where the main
difference between the IRs is a change in stack addresses. This difference between the representations is to use stack addresses. This
pass is also responsible for closure conversion (in the sense of pass is also responsible for closure conversion (in the sense of
lifting closures that are used only in application positions where lifting closures that are used only in application positions where
all variables captured by the closure can be converted to arguments all variables captured by the closure can be converted to arguments
at all call sites). at all call sites).
The "unresolve" functions convert run-time bytecode back into the
optimizer's IR, which is used for cross-module inlining and for
`compiled-expression-recompile`.
See "eval.c" for an overview of compilation passes. */ See "eval.c" for an overview of compilation passes. */
#include "schpriv.h" #include "schpriv.h"
@ -41,17 +45,24 @@ struct Resolve_Info
{ {
MZTAG_IF_REQUIRED MZTAG_IF_REQUIRED
char use_jit, in_module, in_proc, enforce_const, no_lift; char use_jit, in_module, in_proc, enforce_const, no_lift;
int current_depth; int current_depth; /* tracks the stack depth, so variables can be
int current_lex_depth; resolved relative to it; this depth is reset
int max_let_depth; /* filled in by sub-expressions */ on entry to `lambda` forms */
int current_lex_depth; /* keeps track of the lexical depth, which isn't
reset on entry; this absolute depth is useful
for sorting */
int max_let_depth; /* filled in by sub-expressions to track the maximum
stack depth experienced so far */
Resolve_Prefix *prefix; Resolve_Prefix *prefix;
Scheme_Hash_Table *stx_map; /* compile offset => resolve offset; prunes prefix-recored stxes */ Scheme_Hash_Table *stx_map; /* compile offset => resolve offset; prunes prefix-recored stxes */
mzshort toplevel_pos; mzshort toplevel_pos; /* tracks where the run-time prefix will be, relative
void *tl_map; /* fixnum or bit array (as array of `int's) indicating which globals+lifts in prefix are used */ to the current stack depth */
int stx_count; void *tl_map; /* fixnum or bit array (as array of `int's) indicating which
mzshort *old_stx_pos; /* NULL => consult next; new pos is index in array */ globals+lifts in prefix are used */
Scheme_Hash_Tree *redirects; int stx_count; /* tracks the number of literal syntax objects used */
Scheme_Object *lifts; Scheme_Hash_Tree *redirects; /* maps variables that will be from the closure
to their stack depths for the enclosing `lambda` */
Scheme_Object *lifts; /* tracks functions lifted by closure conversion */
struct Resolve_Info *next; struct Resolve_Info *next;
}; };

22
racket/src/racket/src/schpriv.h
View File

@ -1459,9 +1459,10 @@ Scheme_Object *scheme_top_introduce(Scheme_Object *form, Scheme_Env *genv);
/* syntax run-time structures */ /* syntax run-time structures */
/*========================================================================*/ /*========================================================================*/
/* A Scheme_IR_Local record represents a local variable, /* A Scheme_IR_Local record represents a local variable, where
both the binding and references to that binding. When inlining both the binding and references to that same binding are
of other transformations duplicate a variable, a new instance represented by the same allocated object. When inlining
or other transformations duplicate a variable, a new instance
is allocated to represent a separate variable. Different passes is allocated to represent a separate variable. Different passes
in the comiler store different information about the variable. */ in the comiler store different information about the variable. */
typedef struct Scheme_IR_Local typedef struct Scheme_IR_Local
@ -3178,20 +3179,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
int *_pos, Scheme_Object *rename_rib, int replace_value); int *_pos, Scheme_Object *rename_rib, int replace_value);
int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env); int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
typedef struct SFS_Info { typedef struct SFS_Info SFS_Info;
MZTAG_IF_REQUIRED
int for_mod, pass;
int tail_pos; /* in tail position? */
int depth, stackpos, tlpos; /* stack shape */
int selfpos, selfstart, selflen; /* tracks self calls */
int ip; /* "instruction pointer" --- counts up during traversal of expressions */
int seqn; /* tracks nesting */
int max_nontail; /* ip of last non-tail call in the body */
int min_touch, max_touch; /* tracks range of `macx_used' values changed */
int *max_used; /* maps stack position (i.e., variable) to ip of the variable's last use */
int *max_calls; /* maps stack position to ip of last non-tail call in variable's scope */
Scheme_Object *saved;
} SFS_Info;
SFS_Info *scheme_new_sfs_info(int depth); SFS_Info *scheme_new_sfs_info(int depth);
Scheme_Object *scheme_sfs(Scheme_Object *expr, SFS_Info *info, int max_let_depth); Scheme_Object *scheme_sfs(Scheme_Object *expr, SFS_Info *info, int max_let_depth);

15
racket/src/racket/src/sfs.c
View File

@ -31,6 +31,21 @@
#include "schrunst.h" #include "schrunst.h"
#include "schexpobs.h" #include "schexpobs.h"
struct SFS_Info {
MZTAG_IF_REQUIRED
int for_mod, pass;
int tail_pos; /* in tail position? */
int depth, stackpos, tlpos; /* stack shape */
int selfpos, selfstart, selflen; /* tracks self calls */
int ip; /* "instruction pointer" --- counts up during traversal of expressions */
int seqn; /* tracks nesting */
int max_nontail; /* ip of last non-tail call in the body */
int min_touch, max_touch; /* tracks range of `macx_used' values changed */
int *max_used; /* maps stack position (i.e., variable) to ip of the variable's last use */
int *max_calls; /* maps stack position to ip of last non-tail call in variable's scope */
Scheme_Object *saved;
};
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
static void register_traversers(void); static void register_traversers(void);
#endif #endif

164
racket/src/racket/src/stypes.h
View File

@ -1,7 +1,7 @@
enum { enum {
/* compiled object types: (internal) */ /* Compiled bytecode elements: */
scheme_toplevel_type, /* 0 */ scheme_toplevel_type, /* 0 */
scheme_local_type, /* 1 */ scheme_local_type, /* 1 */
scheme_local_unbox_type, /* 2 */ scheme_local_unbox_type, /* 2 */
@ -33,9 +33,12 @@ enum {
scheme_module_type, /* 27 */ scheme_module_type, /* 27 */
scheme_inline_variant_type, /* 28 */ scheme_inline_variant_type, /* 28 */
_scheme_values_types_, /* All following types are values */ _scheme_values_types_, /* 29 */
/* All following types are values at run time */
/* intermediate compiled variants (as seen by optimizer): */ /* Replacements for some of the above as the
compiler's intermediate representation for
optimization: */
scheme_ir_local_type, /* 30 */ scheme_ir_local_type, /* 30 */
scheme_ir_lambda_type, /* 31 */ scheme_ir_lambda_type, /* 31 */
scheme_ir_let_value_type, /* 32 */ scheme_ir_let_value_type, /* 32 */
@ -45,11 +48,15 @@ enum {
scheme_quote_compilation_type, /* used while writing, only */ scheme_quote_compilation_type, /* used while writing, only */
/* Registered in prefix table: */ /* Generated in the compiler front-end, but
registered in the prefix table instead of
used directly as an "expression": */
scheme_variable_type, /* 37 */ scheme_variable_type, /* 37 */
scheme_module_variable_type, /* link replaces with scheme_variable_type */ scheme_module_variable_type, /* link replaces with scheme_variable_type */
_scheme_ir_values_types_, /* 39 */ _scheme_ir_values_types_, /* 39 */
/* All of the following are literal values from the
perspective of the compiler */
/* procedure types */ /* procedure types */
scheme_prim_type, /* 40 */ scheme_prim_type, /* 40 */
@ -223,84 +230,87 @@ enum {
scheme_ctype_type, /* 199 */ scheme_ctype_type, /* 199 */
scheme_plumber_type, /* 200 */ scheme_plumber_type, /* 200 */
scheme_plumber_handle_type, /* 201 */ scheme_plumber_handle_type, /* 201 */
scheme_deferred_expr_type, /* 202 */
#ifdef MZTAG_REQUIRED #ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 202 */ _scheme_last_normal_type_, /* 203 */
/* The remaining tags exist for GC tracing (in non-conservative
mode), but they are not needed for run-time tag tests */
scheme_rt_weak_array, /* 203 */ scheme_rt_weak_array, /* 204 */
scheme_rt_comp_env, /* 204 */ scheme_rt_comp_env, /* 205 */
scheme_rt_constant_binding, /* 205 */ scheme_rt_constant_binding, /* 206 */
scheme_rt_resolve_info, /* 206 */ scheme_rt_resolve_info, /* 207 */
scheme_rt_unresolve_info, /* 207 */ scheme_rt_unresolve_info, /* 208 */
scheme_rt_optimize_info, /* 208 */ scheme_rt_optimize_info, /* 209 */
scheme_rt_cont_mark, /* 209 */ scheme_rt_cont_mark, /* 210 */
scheme_rt_saved_stack, /* 210 */ scheme_rt_saved_stack, /* 211 */
scheme_rt_reply_item, /* 211 */ scheme_rt_reply_item, /* 212 */
scheme_rt_ir_lambda_info, /* 212 */ scheme_rt_ir_lambda_info, /* 213 */
scheme_rt_overflow, /* 213 */ scheme_rt_overflow, /* 214 */
scheme_rt_overflow_jmp, /* 214 */ scheme_rt_overflow_jmp, /* 215 */
scheme_rt_meta_cont, /* 215 */ scheme_rt_meta_cont, /* 216 */
scheme_rt_dyn_wind_cell, /* 216 */ scheme_rt_dyn_wind_cell, /* 217 */
scheme_rt_dyn_wind_info, /* 217 */ scheme_rt_dyn_wind_info, /* 218 */
scheme_rt_dyn_wind, /* 218 */ scheme_rt_dyn_wind, /* 219 */
scheme_rt_dup_check, /* 219 */ scheme_rt_dup_check, /* 220 */
scheme_rt_thread_memory, /* 220 */ scheme_rt_thread_memory, /* 221 */
scheme_rt_input_file, /* 221 */ scheme_rt_input_file, /* 222 */
scheme_rt_input_fd, /* 222 */ scheme_rt_input_fd, /* 223 */
scheme_rt_oskit_console_input, /* 223 */ scheme_rt_oskit_console_input, /* 224 */
scheme_rt_tested_input_file, /* 224 */ scheme_rt_tested_input_file, /* 225 */
scheme_rt_tested_output_file, /* 225 */ scheme_rt_tested_output_file, /* 226 */
scheme_rt_indexed_string, /* 226 */ scheme_rt_indexed_string, /* 227 */
scheme_rt_output_file, /* 227 */ scheme_rt_output_file, /* 228 */
scheme_rt_load_handler_data, /* 228 */ scheme_rt_load_handler_data, /* 229 */
scheme_rt_pipe, /* 229 */ scheme_rt_pipe, /* 230 */
scheme_rt_beos_process, /* 230 */ scheme_rt_beos_process, /* 231 */
scheme_rt_system_child, /* 231 */ scheme_rt_system_child, /* 232 */
scheme_rt_tcp, /* 232 */ scheme_rt_tcp, /* 233 */
scheme_rt_write_data, /* 233 */ scheme_rt_write_data, /* 234 */
scheme_rt_tcp_select_info, /* 234 */ scheme_rt_tcp_select_info, /* 235 */
scheme_rt_param_data, /* 235 */ scheme_rt_param_data, /* 236 */
scheme_rt_will, /* 236 */ scheme_rt_will, /* 237 */
scheme_rt_linker_name, /* 237 */ scheme_rt_linker_name, /* 238 */
scheme_rt_param_map, /* 238 */ scheme_rt_param_map, /* 239 */
scheme_rt_finalization, /* 239 */ scheme_rt_finalization, /* 240 */
scheme_rt_finalizations, /* 240 */ scheme_rt_finalizations, /* 241 */
scheme_rt_cpp_object, /* 241 */ scheme_rt_cpp_object, /* 242 */
scheme_rt_cpp_array_object, /* 242 */ scheme_rt_cpp_array_object, /* 243 */
scheme_rt_stack_object, /* 243 */ scheme_rt_stack_object, /* 244 */
scheme_rt_preallocated_object, /* 244 */ scheme_rt_preallocated_object, /* 245 */
scheme_thread_hop_type, /* 245 */ scheme_thread_hop_type, /* 246 */
scheme_rt_srcloc, /* 246 */ scheme_rt_srcloc, /* 247 */
scheme_rt_evt, /* 247 */ scheme_rt_evt, /* 248 */
scheme_rt_syncing, /* 248 */ scheme_rt_syncing, /* 249 */
scheme_rt_comp_prefix, /* 249 */ scheme_rt_comp_prefix, /* 250 */
scheme_rt_user_input, /* 250 */ scheme_rt_user_input, /* 251 */
scheme_rt_user_output, /* 251 */ scheme_rt_user_output, /* 252 */
scheme_rt_compact_port, /* 252 */ scheme_rt_compact_port, /* 253 */
scheme_rt_read_special_dw, /* 253 */ scheme_rt_read_special_dw, /* 254 */
scheme_rt_regwork, /* 254 */ scheme_rt_regwork, /* 255 */
scheme_rt_rx_lazy_string, /* 255 */ scheme_rt_rx_lazy_string, /* 256 */
scheme_rt_buf_holder, /* 256 */ scheme_rt_buf_holder, /* 257 */
scheme_rt_parameterization, /* 257 */ scheme_rt_parameterization, /* 258 */
scheme_rt_print_params, /* 258 */ scheme_rt_print_params, /* 259 */
scheme_rt_read_params, /* 259 */ scheme_rt_read_params, /* 260 */
scheme_rt_native_code, /* 260 */ scheme_rt_native_code, /* 261 */
scheme_rt_native_code_plus_case, /* 261 */ scheme_rt_native_code_plus_case, /* 262 */
scheme_rt_jitter_data, /* 262 */ scheme_rt_jitter_data, /* 263 */
scheme_rt_module_exports, /* 263 */ scheme_rt_module_exports, /* 264 */
scheme_rt_delay_load_info, /* 264 */ scheme_rt_delay_load_info, /* 265 */
scheme_rt_marshal_info, /* 265 */ scheme_rt_marshal_info, /* 266 */
scheme_rt_unmarshal_info, /* 266 */ scheme_rt_unmarshal_info, /* 267 */
scheme_rt_runstack, /* 267 */ scheme_rt_runstack, /* 268 */
scheme_rt_sfs_info, /* 268 */ scheme_rt_sfs_info, /* 269 */
scheme_rt_validate_clearing, /* 269 */ scheme_rt_validate_clearing, /* 270 */
scheme_rt_lightweight_cont, /* 270 */ scheme_rt_lightweight_cont, /* 271 */
scheme_rt_export_info, /* 271 */ scheme_rt_export_info, /* 272 */
scheme_rt_cont_jmp, /* 272 */ scheme_rt_cont_jmp, /* 273 */
scheme_rt_letrec_check_frame, /* 273 */ scheme_rt_letrec_check_frame, /* 274 */
#endif #endif
scheme_deferred_expr_type, /* 274 */
_scheme_last_type_ _scheme_last_type_
}; };