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

removing debugging code

Browse Source
This commit is contained in:
Claire Alvis 2014-04-04 09:59:05 -06:00 committed by Matthew Flatt
parent 36cdfcb77a
commit fbb419a9fa
1 changed files with 11 additions and 346 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -32,11 +32,6 @@ void scheme_init_letrec_check()
#endif #endif
} }
#define DEBUG_LEVEL 0
#define DEBUG(stmt) if (DEBUG_LEVEL) { stmt; }
#define VERBOSE_DEBUG(stmt) if (DEBUG_LEVEL > 1) { stmt; }
#define MODNAME_DEBUG(stmt) if (0 || (DEBUG_LEVEL > 1)) { stmt; }
#define LET_RHS_EXPR 0x1 #define LET_RHS_EXPR 0x1
#define LET_BODY_EXPR (0x1 << 1) #define LET_BODY_EXPR (0x1 << 1)
#define LET_NO_EXPR (0x1 << 2) #define LET_NO_EXPR (0x1 << 2)
@ -118,18 +113,6 @@ typedef struct {
} Scheme_Deferred_Expr; } Scheme_Deferred_Expr;
void print_frame(Letrec_Check_Frame *frame)
{
fflush(stdout);
printf("frame: [ ");
while(frame != NULL) {
printf("[%d %d %d] ", frame->frame_type, frame->count, (int)SCHEME_INT_VAL(frame->subexpr));
frame = frame->next;
}
printf("]");
}
/* initializes a Letrec_Check_Frame */ /* initializes a Letrec_Check_Frame */
Letrec_Check_Frame *init_letrec_check_frame(int frame_type, Letrec_Check_Frame *init_letrec_check_frame(int frame_type,
mzshort count, mzshort count,
@ -185,23 +168,6 @@ Letrec_Check_Frame *init_letrec_check_frame(int frame_type,
frame->deferred_with_body_ref = scheme_false; frame->deferred_with_body_ref = scheme_false;
frame->deferred_with_no_ref = scheme_false; frame->deferred_with_no_ref = scheme_false;
if (DEBUG_LEVEL > 1) {
printf("init_letrec_check_frame: type: %d; ", frame->frame_type);
print_frame(frame->next);
printf(" -> ");
print_frame(frame);
printf("\n");
}
#ifdef MZTAG_REQUIRED
if (frame->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("init_letrec_check_frame: frame is not a frame");
}
if ((prev != NULL) && (prev->type != scheme_rt_letrec_check_frame)) {
scheme_signal_error("init_letrec_check_frame: frame is not a frame");
}
#endif
return frame; return frame;
} }
@ -225,12 +191,6 @@ Letrec_Check_Frame *get_nearest_rhs(Letrec_Check_Frame *frame) {
changes pos to be relative to that frame */ changes pos to be relative to that frame */
Letrec_Check_Frame *get_relative_frame(int *pos, Letrec_Check_Frame *frame) Letrec_Check_Frame *get_relative_frame(int *pos, Letrec_Check_Frame *frame)
{ {
if (DEBUG_LEVEL > 1) {
printf("get_relative_frame\n pos_int: %d\n ", *pos);
print_frame(frame);
printf("\n");
}
/* we've gone wrong if pos_int is negative or if the frame has /* we've gone wrong if pos_int is negative or if the frame has
become NULL because pos should have be a valid LHS variable become NULL because pos should have be a valid LHS variable
reference */ reference */
@ -284,15 +244,6 @@ void update_frame(Letrec_Check_Frame *outer, Letrec_Check_Frame *inner,
{ {
Scheme_Object *prev_def; Scheme_Object *prev_def;
DEBUG(printf("deferring closure at position %d\n", position));
if (DEBUG_LEVEL > 1) {
printf(" outer: ");
print_frame(outer);
printf("\n inner: ");
print_frame(inner);
printf("\n");
}
if (position >= outer->count) { if (position >= outer->count) {
scheme_signal_error("update_frame: position exceeds binding count"); scheme_signal_error("update_frame: position exceeds binding count");
} }
@ -317,8 +268,6 @@ Scheme_Object *frame_to_subexpr_ls(Letrec_Check_Frame *frame) {
for (; frame != NULL; frame = frame->next) { for (; frame != NULL; frame = frame->next) {
if (frame->subexpr < 0) { if (frame->subexpr < 0) {
print_frame(frame);
printf("\n");
scheme_signal_error("frame_to_subexpr_ls: frame->subexpr is negative"); scheme_signal_error("frame_to_subexpr_ls: frame->subexpr is negative");
} }
ls = scheme_make_pair(scheme_make_integer(frame->subexpr), ls); ls = scheme_make_pair(scheme_make_integer(frame->subexpr), ls);
@ -377,26 +326,14 @@ void letrec_check_lets_resume(Letrec_Check_Frame *frame)
Scheme_Let_Header *head; Scheme_Let_Header *head;
int was_checked; int was_checked;
DEBUG(printf("letrec_check_lets_resume\n "));
#ifdef MZTAG_REQUIRED
if (frame->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("letrec_check_lets_resume: frame is not a frame");
}
#endif
head = frame->head; head = frame->head;
DEBUG(print_frame(frame));
DEBUG(printf("\n attempting to resume, waiting is %d\n", frame->waiting));
if (frame->waiting != 0) { if (frame->waiting != 0) {
return; return;
} }
frame->subexpr = LET_BODY_EXPR; frame->subexpr = LET_BODY_EXPR;
process_deferred_bindings(frame); process_deferred_bindings(frame);
frame->subexpr = -1;
frame->subexpr = LET_NO_EXPR; frame->subexpr = LET_NO_EXPR;
process_deferred_bindings(frame); process_deferred_bindings(frame);
@ -404,7 +341,6 @@ void letrec_check_lets_resume(Letrec_Check_Frame *frame)
body = head->body; body = head->body;
if (frame->frame_type == FRAME_TYPE_LETREC) { if (frame->frame_type == FRAME_TYPE_LETREC) {
DEBUG(printf("updating flags\n"));
/* loops through every right hand side again to update the flags /* loops through every right hand side again to update the flags
that we have invalidated; i.e., adding check-undefineds around that we have invalidated; i.e., adding check-undefineds around
references means there is one (more) instance where the LHS references means there is one (more) instance where the LHS
@ -417,7 +353,6 @@ void letrec_check_lets_resume(Letrec_Check_Frame *frame)
for (j = 0; j < clv->count; j++) { for (j = 0; j < clv->count; j++) {
was_checked = frame->checked[k + j]; was_checked = frame->checked[k + j];
if (was_checked) { if (was_checked) {
DEBUG(printf("%d had check inserted\n", k));
clv_flags[j] -= (clv_flags[j] & SCHEME_WAS_ONLY_APPLIED); clv_flags[j] -= (clv_flags[j] & SCHEME_WAS_ONLY_APPLIED);
clv_flags[j] -= (clv_flags[j] & SCHEME_WAS_APPLIED_EXCEPT_ONCE); clv_flags[j] -= (clv_flags[j] & SCHEME_WAS_APPLIED_EXCEPT_ONCE);
} }
@ -431,15 +366,6 @@ void letrec_check_lets_resume(Letrec_Check_Frame *frame)
return; return;
} }
void print_vars(Scheme_Object *vars)
{
fflush(stdout);
scheme_display(vars, scheme_orig_stdout_port);
scheme_flush_output(scheme_orig_stdout_port);
return;
}
/* appends two nested lists of variables that are always the same length, e.x. /* appends two nested lists of variables that are always the same length, e.x.
merge_vars( ((1) () (0)) , (() (2) (1)) ) => ((1) (2) (0 1)) */ merge_vars( ((1) () (0)) , (() (2) (1)) ) => ((1) (2) (0 1)) */
@ -482,20 +408,6 @@ void check_inner_vars(Scheme_Object *ls) {
return; return;
} }
void check_vars(Scheme_Object *vars) {
DEBUG(printf("check_vars\n"));
while(!SCHEME_NULLP(vars)) {
if (!SCHEME_PAIRP(vars)) {
scheme_signal_error("check_vars: vars is not a list");
}
check_inner_vars(SCHEME_CAR(vars));
vars = SCHEME_CDR(vars);
}
return;
}
/* looks up an absolute position in a nested list of vars, where we /* looks up an absolute position in a nested list of vars, where we
only care about the outermost dimension; e.x.: only care about the outermost dimension; e.x.:
@ -507,21 +419,11 @@ int lookup_var(int position, Scheme_Object *vars, Letrec_Check_Frame *frame)
{ {
Scheme_Object *vars_car, *caar; Scheme_Object *vars_car, *caar;
check_vars(vars);
if (frame == NULL) { if (frame == NULL) {
scheme_signal_error("lookup_var: frame == NULL"); scheme_signal_error("lookup_var: frame == NULL");
return 0; return 0;
} }
if (DEBUG_LEVEL > 1) {
printf("lookup_var: %d in ", position);
print_vars(vars);
printf(" and ");
print_frame(frame);
printf("\n");
}
if (SCHEME_NULLP(vars)) { if (SCHEME_NULLP(vars)) {
return 0; return 0;
} }
@ -557,7 +459,6 @@ int lookup_var(int position, Scheme_Object *vars, Letrec_Check_Frame *frame)
if (frame->frame_type == FRAME_TYPE_LETREC) { if (frame->frame_type == FRAME_TYPE_LETREC) {
if (frame->subexpr & LET_BODY_EXPR) { if (frame->subexpr & LET_BODY_EXPR) {
VERBOSE_DEBUG(printf(" didn't find %d in vars\n", position));
return 0; return 0;
} }
@ -571,14 +472,12 @@ int lookup_var(int position, Scheme_Object *vars, Letrec_Check_Frame *frame)
while(!SCHEME_NULLP(vars_car)) { while(!SCHEME_NULLP(vars_car)) {
caar = SCHEME_CAR(vars_car); caar = SCHEME_CAR(vars_car);
if (SCHEME_INT_VAL(caar) == position) { if (SCHEME_INT_VAL(caar) == position) {
VERBOSE_DEBUG(printf(" found %d in vars\n", position));
return 1; return 1;
} }
vars_car = SCHEME_CDR(vars_car); vars_car = SCHEME_CDR(vars_car);
} }
} }
VERBOSE_DEBUG(printf(" didn't find %d in vars\n", position));
return 0; return 0;
} }
@ -589,12 +488,9 @@ void record_ref(Scheme_Local *loc, Letrec_Check_Frame *frame)
Letrec_Check_Frame *inner; Letrec_Check_Frame *inner;
int position = SCHEME_LOCAL_POS(loc); int position = SCHEME_LOCAL_POS(loc);
DEBUG(printf("recording reference for %d\n", position));
inner = frame; inner = frame;
frame = get_relative_frame(&position, frame); frame = get_relative_frame(&position, frame);
DEBUG(printf(" checking for LET_NO_EXPR\n"));
for(; inner != frame; inner = inner->next) { for(; inner != frame; inner = inner->next) {
if (inner->subexpr < 0) { if (inner->subexpr < 0) {
scheme_signal_error("record_ref: subexpr is negative"); scheme_signal_error("record_ref: subexpr is negative");
@ -615,8 +511,6 @@ void record_ref(Scheme_Local *loc, Letrec_Check_Frame *frame)
!SCHEME_FALSEP(deferred_with_body_ref)) { !SCHEME_FALSEP(deferred_with_body_ref)) {
Scheme_Object **def, *defls, *tmp; Scheme_Object **def, *defls, *tmp;
DEBUG(printf("record_ref: adding something to a frame deferred list\n"));
def = frame->def; def = frame->def;
defls = def[position]; defls = def[position];
@ -629,9 +523,6 @@ void record_ref(Scheme_Local *loc, Letrec_Check_Frame *frame)
frame->deferred_with_body_ref = tmp; frame->deferred_with_body_ref = tmp;
} }
DEBUG(printf("adding %d existing deferred expression(s) to deferred list\n",
scheme_list_length(def[position])));
(frame->def)[position] = scheme_null; (frame->def)[position] = scheme_null;
} }
@ -645,16 +536,8 @@ Scheme_Object *record_checked(Scheme_Local *loc, Letrec_Check_Frame *frame)
Scheme_Object *obj; Scheme_Object *obj;
frame = get_relative_frame(&position, frame); frame = get_relative_frame(&position, frame);
DEBUG(printf("recording check for (relative position) %d\n", position));
DEBUG(print_frame(frame));
DEBUG(printf("\n"));
DEBUG(printf(" old value: %d\n", (frame->checked)[position]));
(frame->checked)[position] = 1; (frame->checked)[position] = 1;
DEBUG(printf(" new value: %d\n", (frame->checked)[position]));
obj = frame->head->body; obj = frame->head->body;
k = frame->head->count; k = frame->head->count;
@ -682,7 +565,6 @@ Scheme_Object *record_checked(Scheme_Local *loc, Letrec_Check_Frame *frame)
Scheme_Object *rem_vars(Scheme_Object *vars) Scheme_Object *rem_vars(Scheme_Object *vars)
{ {
Scheme_Object *tmp, *new; Scheme_Object *tmp, *new;
DEBUG(printf("rem_vars: removing vars from a list of vars\n"));
new = scheme_null; new = scheme_null;
tmp = vars; tmp = vars;
@ -704,20 +586,8 @@ Scheme_Object *letrec_check_local(Scheme_Object *o, Letrec_Check_Frame *frame,
Scheme_Local *loc = (Scheme_Local *)o; Scheme_Local *loc = (Scheme_Local *)o;
int position; int position;
DEBUG(printf("letrec_check_local\n"));
position = SCHEME_LOCAL_POS(loc); position = SCHEME_LOCAL_POS(loc);
if (DEBUG_LEVEL > 1) {
printf(" position: %d\n ", position);
print_frame(frame);
printf("\n uvars: ");
print_vars(uvars);
printf("\n pvars: ");
print_vars(pvars);
printf("\n");
}
/* record that we saw this local in the frame, so later we know to /* record that we saw this local in the frame, so later we know to
process its deferred bindings if there are any */ process its deferred bindings if there are any */
record_ref(loc, frame); record_ref(loc, frame);
@ -732,7 +602,6 @@ Scheme_Object *letrec_check_local(Scheme_Object *o, Letrec_Check_Frame *frame,
Scheme_App3_Rec *app3; Scheme_App3_Rec *app3;
Scheme_Object *name; Scheme_Object *name;
DEBUG(printf("adding a check around this reference because loc is %d\n", position));
name = record_checked(loc, frame); name = record_checked(loc, frame);
app3 = MALLOC_ONE_TAGGED(Scheme_App3_Rec); app3 = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
@ -745,7 +614,6 @@ Scheme_Object *letrec_check_local(Scheme_Object *o, Letrec_Check_Frame *frame,
} }
/* our reference is protected, so we're fine */ /* our reference is protected, so we're fine */
DEBUG(printf("local was neither unprotected nor protectable\n"));
return o; return o;
} }
@ -896,15 +764,6 @@ Scheme_Object *letrec_check_closure_compilation(Scheme_Object *o, Letrec_Check_F
num_params = data->num_params; num_params = data->num_params;
new_frame = init_letrec_check_frame(FRAME_TYPE_CLOSURE, num_params, frame, NULL); new_frame = init_letrec_check_frame(FRAME_TYPE_CLOSURE, num_params, frame, NULL);
#ifdef MZTAG_REQUIRED
if ((frame != NULL) && (frame->type != scheme_rt_letrec_check_frame)) {
scheme_signal_error("letrec_check_closure_compilation: frame is not a frame");
}
if (new_frame->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("letrec_check_closure_compilation: frame is not a frame");
}
#endif
if (num_params < 0) { if (num_params < 0) {
scheme_signal_error("lambda has negative arguments what do"); scheme_signal_error("lambda has negative arguments what do");
} }
@ -912,13 +771,6 @@ Scheme_Object *letrec_check_closure_compilation(Scheme_Object *o, Letrec_Check_F
pvars = new_pvars; pvars = new_pvars;
val = letrec_check_expr(data->code, new_frame, uvars, pvars, pos); val = letrec_check_expr(data->code, new_frame, uvars, pvars, pos);
data->code = val; data->code = val;
if (DEBUG_LEVEL > 1) {
printf("letrec_check_closure_compilation: ");
print_frame(new_frame);
printf(" <- ");
print_frame(frame);
printf("\n");
}
} }
else { else {
@ -934,7 +786,7 @@ Scheme_Object *letrec_check_closure_compilation(Scheme_Object *o, Letrec_Check_F
int position = SCHEME_INT_VAL(pos); int position = SCHEME_INT_VAL(pos);
clos = make_deferred_expr_closure(data, frame, position, uvars, pvars); clos = make_deferred_expr_closure(data, frame, position, uvars, pvars);
/* get the correct frame and stick it up there */ /* get the correct frame and stick the deferred_expr_closure up there */
outer_frame = get_nearest_rhs(frame); outer_frame = get_nearest_rhs(frame);
update_frame(outer_frame, frame, position, clos); update_frame(outer_frame, frame, position, clos);
@ -967,20 +819,11 @@ void letrec_check_deferred_expr(Scheme_Object *o, Letrec_Check_Frame *outer, int
subexpr_ls_to_frame(subexpr_ls, inner); subexpr_ls_to_frame(subexpr_ls, inner);
#ifdef MZTAG_REQUIRED
if (outer->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("letrec_check_deferred_expr: frame is not a frame");
}
#endif
if (scheme_proper_list_length(uvars) != if (scheme_proper_list_length(uvars) !=
scheme_proper_list_length(pvars)) { scheme_proper_list_length(pvars)) {
scheme_signal_error("letrec_check_deferred_expr: vars different lengths"); scheme_signal_error("letrec_check_deferred_expr: vars different lengths");
} }
DEBUG(printf(" preparing to process deferred expression for %d in subexpr %d\n",
position, outer->subexpr));
after_i = scheme_null; after_i = scheme_null;
for (i = position - 1; i >= 0; i--) { for (i = position - 1; i >= 0; i--) {
i_wrapped = scheme_make_integer(i); i_wrapped = scheme_make_integer(i);
@ -998,11 +841,9 @@ void letrec_check_deferred_expr(Scheme_Object *o, Letrec_Check_Frame *outer, int
} }
if (type & LET_NO_EXPR) { if (type & LET_NO_EXPR) {
/* otherwise, it is not referenced anywhere in an unsafe context, /* variable is not referenced anywhere in an unsafe
so we're pretty much good. still have to check it for letrecs context, so we're pretty much good. still have to
in its sub-expressions */ check for troublesome letrecs in its sub-expressions */
DEBUG(printf(" building NO environment\n"));
deferred_uvars = scheme_make_pair(scheme_null, SCHEME_CDR(uvars)); deferred_uvars = scheme_make_pair(scheme_null, SCHEME_CDR(uvars));
tmp = rem_vars(SCHEME_CDR(pvars)); tmp = rem_vars(SCHEME_CDR(pvars));
deferred_pvars = scheme_make_pair(scheme_null, tmp); deferred_pvars = scheme_make_pair(scheme_null, tmp);
@ -1015,10 +856,8 @@ void letrec_check_deferred_expr(Scheme_Object *o, Letrec_Check_Frame *outer, int
we treat 1 thru i as protected, because this reference must we treat 1 thru i as protected, because this reference must
occur in a binding after i (and therefore 1 thru i have occur in a binding after i (and therefore 1 thru i have
values). the rest of the LHS variables and those LHS values). the rest of the LHS variables and those LHS
variables from outer letrecs are considered unprotected. variables from outer letrecs are unprotected.
*/ */
DEBUG(printf(" building RHS environment\n"));
deferred_uvars = merge_vars(uvars, pvars); deferred_uvars = merge_vars(uvars, pvars);
tmp = scheme_make_pair(after_i, SCHEME_CDR(deferred_uvars)); tmp = scheme_make_pair(after_i, SCHEME_CDR(deferred_uvars));
deferred_uvars = tmp; deferred_uvars = tmp;
@ -1030,11 +869,10 @@ void letrec_check_deferred_expr(Scheme_Object *o, Letrec_Check_Frame *outer, int
is referenced during the body, where a variable from an is referenced during the body, where a variable from an
outer letrec might appear. outer letrec might appear.
all LHS variables of the current letrec are protected, but all LHS variables of the current letrec are protected
the LHS variables from outer letrecs are unprotected. (since we got through the RHS okay already), but the
LHS variables from outer letrecs are unprotected.
*/ */
DEBUG(printf(" building BODY environment\n"));
tmp = scheme_make_pair(scheme_null, SCHEME_CDR(uvars)); tmp = scheme_make_pair(scheme_null, SCHEME_CDR(uvars));
deferred_uvars = tmp; deferred_uvars = tmp;
@ -1066,7 +904,8 @@ void letrec_check_deferred_expr(Scheme_Object *o, Letrec_Check_Frame *outer, int
until (and including) it's own LHS variables, and then we until (and including) it's own LHS variables, and then we
switch over to the deferred expression's environment. so, we switch over to the deferred expression's environment. so, we
compute the length difference of the two lists and chop off compute the length difference of the two lists and chop off
what we need to */ what we need to from the uvars/pvars we currently have, then
append the lists together */
length_diff = scheme_list_length(uvars) - scheme_list_length(deferred_uvars); length_diff = scheme_list_length(uvars) - scheme_list_length(deferred_uvars);
tmp_uvars = scheme_null; tmp_uvars = scheme_null;
@ -1086,28 +925,14 @@ void letrec_check_deferred_expr(Scheme_Object *o, Letrec_Check_Frame *outer, int
uvars = scheme_append(tmp_uvars, deferred_uvars); uvars = scheme_append(tmp_uvars, deferred_uvars);
pvars = scheme_append(tmp_pvars, deferred_pvars); pvars = scheme_append(tmp_pvars, deferred_pvars);
DEBUG(printf(" calculated: uvars: "));
DEBUG(print_vars(uvars);)
DEBUG(printf(" pvars: "));
DEBUG(print_vars(pvars);)
DEBUG(printf("\n"));
/* establish that we actually get a lambda back */ /* establish that we actually get a lambda back */
if (SCHEME_TYPE(data) != scheme_compiled_unclosed_procedure_type) { if (SCHEME_TYPE(data) != scheme_compiled_unclosed_procedure_type) {
printf("SCHEME_TYPE(data): %d\n", SCHEME_TYPE(data));
scheme_signal_error("deferred expression does not contain a lambda"); scheme_signal_error("deferred expression does not contain a lambda");
} }
/* hopefully we know how to deal with this lambda */
num_params = data->num_params; num_params = data->num_params;
if (num_params < 0) {
scheme_signal_error("process_deferred_bindings: lambda has negative arguments");
}
if (outer->subexpr < 0) { if ((outer->subexpr < 0) || (inner->subexpr < 0)) {
scheme_signal_error("letrec_check_deferred_expr: subexpr is negative");
}
if (inner->subexpr < 0) {
scheme_signal_error("letrec_check_deferred_expr: subexpr is negative"); scheme_signal_error("letrec_check_deferred_expr: subexpr is negative");
} }
@ -1119,53 +944,18 @@ void letrec_check_deferred_expr(Scheme_Object *o, Letrec_Check_Frame *outer, int
new_frame->subexpr |= LET_NO_EXPR; new_frame->subexpr |= LET_NO_EXPR;
} }
#ifdef MZTAG_REQUIRED
if (new_frame->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("letrec_check_deferred_expr: frame is not a frame");
}
if (inner->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("letrec_check_deferred_expr: frame is not a frame");
}
#endif
val = letrec_check_expr(data->code, new_frame, uvars, pvars, scheme_false); val = letrec_check_expr(data->code, new_frame, uvars, pvars, scheme_false);
data->code = val; data->code = val;
outer->subexpr = old_subexpr; outer->subexpr = old_subexpr;
#ifdef MZTAG_REQUIRED
if (outer->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("letrec_check_deferred_expr: frame is not a frame");
}
if (new_frame->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("letrec_check_deferred_expr: frame is not a frame");
}
#endif
/* decrement the waiting count between the current frame and the /* decrement the waiting count between the current frame and the
outer frame */ outer frame */
DEBUG(printf(" expression processed, checking between %p and %p\n", outer, inner));
for (; outer != inner; inner = inner->next) { for (; outer != inner; inner = inner->next) {
DEBUG(printf(" %p decrementing waiting and resuming letrecs\n", inner));
if (inner == NULL) {
scheme_signal_error("letrec_check_deferred_expr: inner is null");
}
if (outer == NULL) {
scheme_signal_error("letrec_check_deferred_expr: outer is null");
}
#ifdef MZTAG_REQUIRED
if (inner->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("letrec_check_deferred_expr: frame is not a frame");
}
if (outer->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("letrec_check_deferred_expr: frame is not a frame");
}
#endif
(inner->waiting)--; (inner->waiting)--;
letrec_check_lets_resume(inner); letrec_check_lets_resume(inner);
} }
DEBUG(printf("done waking things up\n"));
return; return;
} }
@ -1220,45 +1010,27 @@ void process_deferred_bindings_rhs(Letrec_Check_Frame *frame) {
def = frame->def; def = frame->def;
for (i = 0; i < count; i++) { for (i = 0; i < count; i++) {
if (!SCHEME_NULLP(def[i]) && pos_has_ref(i, frame, subexpr)) { if (!SCHEME_NULLP(def[i]) && pos_has_ref(i, frame, subexpr)) {
DEBUG(printf(" adding bindings for %d\n", i));
tmp = scheme_append(def[i], frame->deferred_with_rhs_ref); tmp = scheme_append(def[i], frame->deferred_with_rhs_ref);
frame->def[i] = scheme_null; frame->def[i] = scheme_null;
frame->deferred_with_rhs_ref = tmp; frame->deferred_with_rhs_ref = tmp;
} }
else if (SCHEME_NULLP(def[i])) { else if (SCHEME_NULLP(def[i])) {
DEBUG(printf(" bindings for %d are null\n", i));
} }
else if (!(pos_has_ref(i, frame, subexpr))) { else if (!(pos_has_ref(i, frame, subexpr))) {
DEBUG(printf(" no ref to %d\n", i));
} }
} }
VERBOSE_DEBUG(printf(" %d expressions to be processed initially\n",
scheme_list_length(frame->deferred_with_rhs_ref)));
while (!SCHEME_NULLP(frame->deferred_with_rhs_ref)) { while (!SCHEME_NULLP(frame->deferred_with_rhs_ref)) {
DEBUG(printf(" checking one expr\n"));
if (!SCHEME_PAIRP(frame->deferred_with_rhs_ref)) { if (!SCHEME_PAIRP(frame->deferred_with_rhs_ref)) {
scheme_signal_error("process_deferred_bindings_rhs: ls is not a ls"); scheme_signal_error("process_deferred_bindings_rhs: ls is not a ls");
} }
tmp = SCHEME_CAR(frame->deferred_with_rhs_ref); tmp = SCHEME_CAR(frame->deferred_with_rhs_ref);
frame->deferred_with_rhs_ref = SCHEME_CDR(frame->deferred_with_rhs_ref); frame->deferred_with_rhs_ref = SCHEME_CDR(frame->deferred_with_rhs_ref);
VERBOSE_DEBUG(printf(" popping one expression (%d left to be processed)\n",
scheme_list_length(frame->deferred_with_rhs_ref)));
letrec_check_deferred_expr(tmp, frame, subexpr); letrec_check_deferred_expr(tmp, frame, subexpr);
} }
DEBUG(printf(" putting ls to false\n"));
#ifdef MZTAG_REQUIRED
if (frame->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("process_deferred_bindings_rhs: frame is not a frame");
}
#endif
/* put the accumulator back to false before leaving */ /* put the accumulator back to false before leaving */
frame->deferred_with_rhs_ref = scheme_false; frame->deferred_with_rhs_ref = scheme_false;
DEBUG(printf(" done processing deferred bindings\n"));
return; return;
} }
@ -1277,47 +1049,23 @@ void process_deferred_bindings_body(Letrec_Check_Frame *frame) {
def = frame->def; def = frame->def;
for (i = 0; i < count; i++) { for (i = 0; i < count; i++) {
if (!SCHEME_NULLP(def[i]) && pos_has_ref(i, frame, subexpr)) { if (!SCHEME_NULLP(def[i]) && pos_has_ref(i, frame, subexpr)) {
DEBUG(printf(" adding bindings for %d\n", i));
tmp = scheme_append(def[i], frame->deferred_with_body_ref); tmp = scheme_append(def[i], frame->deferred_with_body_ref);
frame->def[i] = scheme_null; frame->def[i] = scheme_null;
frame->deferred_with_body_ref = tmp; frame->deferred_with_body_ref = tmp;
} }
else if (SCHEME_NULLP(def[i])) {
DEBUG(printf(" bindings for %d are null\n", i));
} }
else if (!(pos_has_ref(i, frame, subexpr))) {
DEBUG(printf(" no ref to %d\n", i));
}
}
VERBOSE_DEBUG(printf(" %d expressions to be processed initially\n",
scheme_list_length(frame->deferred_with_body_ref)));
while (!SCHEME_NULLP(frame->deferred_with_body_ref)) { while (!SCHEME_NULLP(frame->deferred_with_body_ref)) {
DEBUG(printf(" checking one expr\n"));
DEBUG(print_frame(frame));
DEBUG(printf("\n"));
if (!SCHEME_PAIRP(frame->deferred_with_body_ref)) { if (!SCHEME_PAIRP(frame->deferred_with_body_ref)) {
scheme_signal_error("process_deferred_bindings_body: ls is not a ls"); scheme_signal_error("process_deferred_bindings_body: ls is not a ls");
} }
tmp = SCHEME_CAR(frame->deferred_with_body_ref); tmp = SCHEME_CAR(frame->deferred_with_body_ref);
frame->deferred_with_body_ref = SCHEME_CDR(frame->deferred_with_body_ref); frame->deferred_with_body_ref = SCHEME_CDR(frame->deferred_with_body_ref);
VERBOSE_DEBUG(printf(" popping one expression (%d left to be processed)\n",
scheme_list_length(frame->deferred_with_body_ref)));
letrec_check_deferred_expr(tmp, frame, subexpr); letrec_check_deferred_expr(tmp, frame, subexpr);
} }
DEBUG(printf(" putting ls to false\n"));
#ifdef MZTAG_REQUIRED
if (frame->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("process_deferred_bindings_body: frame is not a frame");
}
#endif
/* put the accumulator back to false before leaving */ /* put the accumulator back to false before leaving */
frame->deferred_with_body_ref = scheme_false; frame->deferred_with_body_ref = scheme_false;
DEBUG(printf(" done processing deferred bindings\n"));
return; return;
} }
@ -1336,72 +1084,38 @@ void process_deferred_bindings_no(Letrec_Check_Frame *frame) {
def = frame->def; def = frame->def;
for (i = 0; i < count; i++) { for (i = 0; i < count; i++) {
if (!SCHEME_NULLP(def[i]) && pos_has_ref(i, frame, subexpr)) { if (!SCHEME_NULLP(def[i]) && pos_has_ref(i, frame, subexpr)) {
DEBUG(printf(" adding bindings for %d\n", i));
tmp = scheme_append(def[i], frame->deferred_with_no_ref); tmp = scheme_append(def[i], frame->deferred_with_no_ref);
frame->def[i] = scheme_null; frame->def[i] = scheme_null;
frame->deferred_with_no_ref = tmp; frame->deferred_with_no_ref = tmp;
} }
else if (SCHEME_NULLP(def[i])) {
DEBUG(printf(" bindings for %d are null\n", i));
} }
else if (!(pos_has_ref(i, frame, subexpr))) {
DEBUG(printf(" no ref to %d\n", i));
}
}
VERBOSE_DEBUG(printf(" %d expressions to be processed initially\n",
scheme_list_length(frame->deferred_with_no_ref)));
while (!SCHEME_NULLP(frame->deferred_with_no_ref)) { while (!SCHEME_NULLP(frame->deferred_with_no_ref)) {
DEBUG(printf(" checking one expr\n"));
if (!SCHEME_PAIRP(frame->deferred_with_no_ref)) { if (!SCHEME_PAIRP(frame->deferred_with_no_ref)) {
scheme_signal_error("process_deferred_bindings_no: ls is not a ls"); scheme_signal_error("process_deferred_bindings_no: ls is not a ls");
} }
tmp = SCHEME_CAR(frame->deferred_with_no_ref); tmp = SCHEME_CAR(frame->deferred_with_no_ref);
frame->deferred_with_no_ref = SCHEME_CDR(frame->deferred_with_no_ref); frame->deferred_with_no_ref = SCHEME_CDR(frame->deferred_with_no_ref);
VERBOSE_DEBUG(printf(" popping one expression (%d left to be processed)\n",
scheme_list_length(frame->deferred_with_no_ref)));
letrec_check_deferred_expr(tmp, frame, subexpr); letrec_check_deferred_expr(tmp, frame, subexpr);
} }
DEBUG(printf(" putting ls to false\n"));
#ifdef MZTAG_REQUIRED
if (frame->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("process_deferred_bindings_no: frame is not a frame");
}
#endif
/* put the accumulator back to false before leaving */ /* put the accumulator back to false before leaving */
frame->deferred_with_no_ref = scheme_false; frame->deferred_with_no_ref = scheme_false;
DEBUG(printf(" done processing deferred bindings\n"));
return; return;
} }
void process_deferred_bindings(Letrec_Check_Frame *frame) { void process_deferred_bindings(Letrec_Check_Frame *frame) {
int subexpr; int subexpr;
DEBUG(printf("processing deferred bindings\n"));
if (DEBUG_LEVEL > 1) {
printf(" ");
print_frame(frame);
printf("\n");
}
subexpr = frame->subexpr; subexpr = frame->subexpr;
VERBOSE_DEBUG(printf(" subexpr: %d\n", subexpr));
if (subexpr & LET_NO_EXPR) { if (subexpr & LET_NO_EXPR) {
VERBOSE_DEBUG(printf(" checking deferred bindings with NO reference\n"));
return process_deferred_bindings_no(frame); return process_deferred_bindings_no(frame);
} }
else if (subexpr & LET_RHS_EXPR) { else if (subexpr & LET_RHS_EXPR) {
VERBOSE_DEBUG(printf(" checking deferred bindings with RHS reference\n"));
return process_deferred_bindings_rhs(frame); return process_deferred_bindings_rhs(frame);
} }
else if (subexpr & LET_BODY_EXPR) { else if (subexpr & LET_BODY_EXPR) {
VERBOSE_DEBUG(printf(" checking deferred bindings with BODY reference\n"));
return process_deferred_bindings_body(frame); return process_deferred_bindings_body(frame);
} }
else { else {
@ -1441,15 +1155,12 @@ Scheme_Object *letrec_check_lets(Scheme_Object *o, Letrec_Check_Frame *old_frame
/* compute and record the type, either let let* or letrec */ /* compute and record the type, either let let* or letrec */
if (header_flags & SCHEME_LET_RECURSIVE) { if (header_flags & SCHEME_LET_RECURSIVE) {
DEBUG(printf("LETREC_CHECK_LETREC\n"));
frame_type = FRAME_TYPE_LETREC; frame_type = FRAME_TYPE_LETREC;
} }
else if (header_flags & SCHEME_LET_STAR) { else if (header_flags & SCHEME_LET_STAR) {
DEBUG(printf("LETREC_CHECK_LETSTAR\n"));
frame_type = FRAME_TYPE_LETSTAR; frame_type = FRAME_TYPE_LETSTAR;
} }
else { else {
DEBUG(printf("LETREC_CHECK_LET\n"));
frame_type = FRAME_TYPE_LET; frame_type = FRAME_TYPE_LET;
} }
@ -1457,14 +1168,6 @@ Scheme_Object *letrec_check_lets(Scheme_Object *o, Letrec_Check_Frame *old_frame
this is ok because get_relative_frame knows how to look up this is ok because get_relative_frame knows how to look up
variables properly given the subexpr */ variables properly given the subexpr */
frame = init_letrec_check_frame(frame_type, count, old_frame, head); frame = init_letrec_check_frame(frame_type, count, old_frame, head);
#ifdef MZTAG_REQUIRED
if (frame->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("letrec_check_lets: frame is not a frame");
}
if ((old_frame != NULL) && (old_frame->type != scheme_rt_letrec_check_frame)) {
scheme_signal_error("letrec_check_lets: frame is not a frame");
}
#endif
/* add a new level to our uvars and pvars if this is a letrec */ /* add a new level to our uvars and pvars if this is a letrec */
if (frame_type == FRAME_TYPE_LETREC) { if (frame_type == FRAME_TYPE_LETREC) {
@ -1543,7 +1246,6 @@ Scheme_Object *letrec_check_lets(Scheme_Object *o, Letrec_Check_Frame *old_frame
/* body is already the right value thanks to the for */ /* body is already the right value thanks to the for */
frame->subexpr = LET_BODY_EXPR; frame->subexpr = LET_BODY_EXPR;
DEBUG(printf("processing let body\n"));
val = letrec_check_expr(body, frame, uvars, pvars, pos); val = letrec_check_expr(body, frame, uvars, pvars, pos);
/* put the new body in the right place: after the last RHS if the /* put the new body in the right place: after the last RHS if the
@ -1552,20 +1254,8 @@ Scheme_Object *letrec_check_lets(Scheme_Object *o, Letrec_Check_Frame *old_frame
if (num_clauses > 0) clv->body = val; if (num_clauses > 0) clv->body = val;
else head->body = val; else head->body = val;
#ifdef MZTAG_REQUIRED
if (frame->type != scheme_rt_letrec_check_frame) {
scheme_signal_error("letrec_check_lets: frame is not a frame");
}
#endif
letrec_check_lets_resume(frame); letrec_check_lets_resume(frame);
DEBUG(printf("letrec_check_lets: "));
DEBUG(print_frame(old_frame));
DEBUG(printf(" <- "));
DEBUG(print_frame(frame));
DEBUG(printf("\n"));
return o; return o;
} }
@ -1581,20 +1271,7 @@ Scheme_Object *letrec_check_define_values(Scheme_Object *data, Letrec_Check_Fram
else { else {
Scheme_Object *vars = SCHEME_VEC_ELS(data)[0]; Scheme_Object *vars = SCHEME_VEC_ELS(data)[0];
Scheme_Object *val = SCHEME_VEC_ELS(data)[1]; Scheme_Object *val = SCHEME_VEC_ELS(data)[1];
DEBUG(printf("letrec_check_define_values\n"));
DEBUG(printf(" size: %d\n position 0: ", (int)SCHEME_VEC_SIZE(data)));
DEBUG(fflush(stdout));
DEBUG(scheme_display(vars, scheme_orig_stdout_port));
DEBUG(scheme_flush_output(scheme_orig_stdout_port));
DEBUG(printf("\n position 1: "));
DEBUG(fflush(stdout));
DEBUG(scheme_display(val, scheme_orig_stdout_port));
DEBUG(scheme_flush_output(scheme_orig_stdout_port));
DEBUG(printf("\n"));
if(!SCHEME_PAIRP(vars) && !SCHEME_NULLP(vars)) { if(!SCHEME_PAIRP(vars) && !SCHEME_NULLP(vars)) {
printf("vars: %d, val: %d\n", SCHEME_TYPE(vars), SCHEME_TYPE(val));
scheme_signal_error("letrec_check_define_values: processing resolved code"); scheme_signal_error("letrec_check_define_values: processing resolved code");
} }
@ -1724,12 +1401,6 @@ Scheme_Object *letrec_check_module(Scheme_Object *o, Letrec_Check_Frame *frame,
return (Scheme_Object *)m; return (Scheme_Object *)m;
} }
DEBUG(printf("letrec_check_module:\n "));
MODNAME_DEBUG(fflush(stdout));
MODNAME_DEBUG(scheme_display(m->modname, scheme_orig_stdout_port));
MODNAME_DEBUG(scheme_flush_output(scheme_orig_stdout_port));
MODNAME_DEBUG(printf("\n"));
cnt = SCHEME_VEC_SIZE(m->bodies[0]); cnt = SCHEME_VEC_SIZE(m->bodies[0]);
for(i = 0; i < cnt; i++) { for(i = 0; i < cnt; i++) {
val = SCHEME_VEC_ELS(m->bodies[0])[i]; val = SCHEME_VEC_ELS(m->bodies[0])[i];
@ -1763,8 +1434,6 @@ Scheme_Object *letrec_check_expr(Scheme_Object *expr, Letrec_Check_Frame *frame,
SCHEME_USE_FUEL(1); SCHEME_USE_FUEL(1);
VERBOSE_DEBUG(printf ("letrec_check_expr: type %d\n", type));
switch (type) { switch (type) {
case scheme_local_type: case scheme_local_type:
return letrec_check_local(expr, frame, uvars, pvars, pos); return letrec_check_local(expr, frame, uvars, pvars, pos);
@ -1825,11 +1494,7 @@ Scheme_Object *scheme_letrec_check_expr(Scheme_Object *expr)
Scheme_Object *init_pvars = scheme_null; Scheme_Object *init_pvars = scheme_null;
Scheme_Object *init_pos = scheme_false; Scheme_Object *init_pos = scheme_false;
DEBUG(printf("Entry\n"));
val = letrec_check_expr(expr, NULL, init_uvars, init_pvars, init_pos); val = letrec_check_expr(expr, NULL, init_uvars, init_pvars, init_pos);
DEBUG(printf("Exit\n"));
DEBUG(fflush(stdout));
return val; return val;
} }