From ea3cabfc45fa77ac41b175f54445ff1942dc4ff7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 20 Nov 2011 08:27:00 -0700 Subject: [PATCH] remove more Racket-to-C compiler leftovers --- collects/compiler/mzc.h | 366 ------- collects/compiler/mzclink.h | 2 - collects/compiler/src2src.rkt | 1807 --------------------------------- collects/compiler/to-core.rkt | 422 -------- 4 files changed, 2597 deletions(-) delete mode 100644 collects/compiler/mzc.h delete mode 100644 collects/compiler/mzclink.h delete mode 100644 collects/compiler/src2src.rkt delete mode 100644 collects/compiler/to-core.rkt diff --git a/collects/compiler/mzc.h b/collects/compiler/mzc.h deleted file mode 100644 index 1f5f1ebfe2..0000000000 --- a/collects/compiler/mzc.h +++ /dev/null @@ -1,366 +0,0 @@ - -#include -#include - -#define GLOBAL_VARREF(x) ((x)->val ? (Scheme_Object *)(x)->val : \ - (scheme_unbound_global(x), (Scheme_Object *)NULL)) -#define CHECK_GLOBAL_BOUND(x) \ - if (!(x)->val) scheme_raise_exn(MZEXN_UNIT, \ - "invoke-unit: cannot link to undefined identifier: %S", \ - (Scheme_Object*)(x)->key); - -#ifdef NO_INLINE_KEYWORD -# define MZC_INLINE /* */ -#else -# define MZC_INLINE MSC_IZE(inline) -#endif - -#define MZC_GLOBAL_PREPARE(vec, pos) (SCHEME_VEC_ELS(vec)[pos] = SCHEME_PTR1_VAL(SCHEME_VEC_ELS(vec)[pos])) -static MZC_INLINE Scheme_Object *MZC_GLOBAL_LOOKUP(Scheme_Object *vec, int pos) { - Scheme_Bucket *bucket = (Scheme_Bucket *)SCHEME_VEC_ELS(vec)[pos]; - Scheme_Object *o = bucket->val; - if (o) - return o; - else { - scheme_unbound_global(bucket); - return NULL; - } -} - -static MZC_INLINE Scheme_Object *MZC_GLOBAL_ASSIGN(Scheme_Object *vec, int pos, Scheme_Object *val) { - Scheme_Bucket *bucket = (Scheme_Bucket *)SCHEME_VEC_ELS(vec)[pos]; - scheme_set_global_bucket("set!", bucket, val, 0); - return scheme_void; -} - -#define MZC_KNOWN_SAFE_VECTOR_REF(vec, pos) (SCHEME_VEC_ELS(vec)[pos]) - -#define MZC_APPLY_MAGIC(val, n) \ - scheme_eval_compiled_sized_string_with_magic(top_level_bytecode_ ## n, sizeof(top_level_bytecode_ ## n), NULL, \ - scheme_intern_symbol(top_level_magic_sym_ ## n), val, 1) - -#define DO_FUEL_POLL ((scheme_fuel_counter-- <= 0) ? (scheme_process_block(0), 0) : 0) - -#define _scheme_direct_apply_primitive_multi_poll(prim, argc, argv) \ - (DO_FUEL_POLL, _scheme_direct_apply_primitive_multi(prim, argc, argv)) -#define _scheme_direct_apply_primitive_poll(prim, argc, argv) \ - (DO_FUEL_POLL, _scheme_direct_apply_primitive(prim, argc, argv)) -#define _scheme_direct_apply_primitive_closure_multi_poll(prim, argc, argv) \ - (DO_FUEL_POLL, _scheme_direct_apply_primitive_closure_multi(prim, argc, argv)) -#define _scheme_direct_apply_primitive_closure_poll(prim, argc, argv) \ - (DO_FUEL_POLL, _scheme_direct_apply_primitive_closure(prim, argc, argv)) - -#ifdef KEEP_CLOSURE_COUNT -static int closure_alloc_cnt; -static void print_closures() -{ - printf("closures allocated in " MZC_SRC_FILE ": %d\n", closure_alloc_cnt); -} -# define CLOSURE_ALLOC_PP closure_alloc_inc(), -static void closure_alloc_inc() -{ - if (!closure_alloc_cnt) - atexit(print_closures); - closure_alloc_cnt++; -} -#else -# define CLOSURE_ALLOC_PP /**/ -#endif - -typedef struct { - Scheme_Primitive_Proc prim; -#ifdef MZ_PRECISE_GC - int count; -#endif -} Scheme_Primitive_Closure_Post; - -# define MZC_INSTALL_DATA_PTR(rec) rec -# define MZC_PARAM_TO_SWITCH(void_param) *(unsigned long *)(((Scheme_Primitive_Closure *)void_param)->val) -# define MZC_ENV_POINTER(t, ct, void_param) (&(((const ct *)void_param)->data)) - - -#ifdef SIXTY_FOUR_BIT_INTEGERS -# define MZ_LOG_WORD_SIZE 4 -#else -# define MZ_LOG_WORD_SIZE 2 -#endif - -#define _scheme_make_c_proc_closure(cfunc, rec, name, amin, amax, flags) \ - (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure_post(((Scheme_Primitive_Closure *)&rec->prim), cfunc, \ - name, amin, amax, flags, \ - sizeof(rec->data)>>MZ_LOG_WORD_SIZE)) - -#define _scheme_make_c_proc_closure_empty(cfunc, rec, name, amin, amax, flags) \ - (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure(&rec->prim, cfunc, name, amin, amax, flags)) - -#define _scheme_make_c_case_proc_closure(cfunc, rec, name, ccnt, cses, flags) \ - (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure_post(((Scheme_Primitive_Closure *)&rec->prim), cfunc, \ - name, ccnt, cses, flags, \ - sizeof(rec->data)>>MZ_LOG_WORD_SIZE)) - -#define _scheme_make_c_case_proc_closure_empty(cfunc, rec, name, ccnt, cses, flags) \ - (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure(&rec->prim, cfunc, name, ccnt, cses, flags)) - -#define NO_MULTIPLE_VALUES(res) \ - if (res == SCHEME_MULTIPLE_VALUES) \ - scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL); -#define CHECK_MULTIPLE_VALUES(res, expected) \ - if (res != SCHEME_MULTIPLE_VALUES || scheme_multiple_count != expected) \ - scheme_wrong_return_arity(NULL, expected, \ - (res == SCHEME_MULTIPLE_VALUES ? scheme_multiple_count : 1), \ - (res == SCHEME_MULTIPLE_VALUES ? scheme_multiple_array : (Scheme_Object**)res), \ - NULL); - -#define SCHEME_DETATCH_MV_BUFFER(mv, pr) if (SAME_OBJ(mv, pr->values_buffer)) pr->values_buffer = NULL - -#define SCHEME_CURRENT_ENV(pr) scheme_get_env(NULL) - -typedef struct { - Scheme_Object * val; - Scheme_Object ** array; - int count; -} _Scheme_Begin0_Rec; - -typedef struct { - Scheme_Cont_Frame_Data cf; - Scheme_Object *val; -} _Scheme_WCM_Rec; - -#define _scheme_apply_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_prim_closure(f, argc, argv) : _scheme_apply(f, argc, argv)) -#define _scheme_apply_multi_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_prim_closure_multi(f, argc, argv) : _scheme_apply_multi(f, argc, argv)) - -#define MZC_EQP(ltp, av, bv) (SAME_OBJ(av, bv)) -#define MZC_EQVP(ltp, av, bv) (SAME_OBJ(av, bv) || scheme_eqv(av, bv)) -#define MZC_EQUALP(ltp, av, bv) scheme_equal(av, bv) -#define MZC_NOTP(p, av) (SCHEME_FALSEP(av)) -#define MZC_NULLP(p, av) (SCHEME_NULLP(av)) -#define MZC_PAIRP(p, av) (SCHEME_PAIRP(av)) -#define MZC_SYMBOLP(p, av) (SCHEME_SYMBOLP(av)) -#define MZC_STRINGP(p, av) (SCHEME_CHAR_STRINGP(av)) -#define MZC_BYTESP(p, av) (SCHEME_BYTE_STRINGP(av)) -#define MZC_VECTORP(p, av) (SCHEME_VECTORP(av)) -#define MZC_NUMBERP(p, av) (SCHEME_NUMBERP(av)) -#define MZC_PROCEDUREP(p, av) (SCHEME_PROCP(av)) -#define MZC_EOFP(p, av) (SCHEME_EOFP(av)) -#define MZC_CHARP(p, av) (SCHEME_CHARP(av)) - -#define MZC_CONS(p, av, bv) scheme_make_pair(av, bv) -#define MZC_LIST1(p, av) scheme_make_pair(av, scheme_null) -#define MZC_LIST2(p, av, bv) scheme_make_pair(av, scheme_make_pair(bv, scheme_null)) -#define MZC_APPEND(p, av, bv) scheme_append(av, bv) - -#define MZC_FOR_SYNTAX_IN_ENV(ignored, proc) scheme_apply_for_syntax_in_env(proc, env) - -#if MZC_UNSAFE -/* Unsafe versions */ -#define MZC_CAR(p, av) SCHEME_CAR(av) -#define MZC_CDR(p, av) SCHEME_CDR(av) -#define MZC_CADR(p, av) SCHEME_CAR(SCHEME_CDR(av)) -#define MZC_CDDR(p, av) SCHEME_CDR(SCHEME_CDR(av)) -#define MZC_CDAR(p, av) SCHEME_CDR(SCHEME_CAR(av)) -#define MZC_CAAR(p, av) SCHEME_CAR(SCHEME_CAR(av)) -#define MZC_CADDR(p, av) SCHEME_CADR(SCHEME_CDR(av)) -#define MZC_SET_CAR(p, av, bv) (SCHEME_CAR(av)=bv, scheme_void) -#define MZC_SET_CDR(p, av, bv) (SCHEME_CDR(av)=bv, scheme_void) - -# define MZC_VECTOR_REF(p, v, i) SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] -# define MZC_VECTOR_SET(p, v, i, x) (SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] = x, scheme_void) - -# define MZC_STRING_REF(p, v, i) scheme_make_character(SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)]) -# define MZC_STRING_SET(p, v, i, x) (SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_CHAR_VAL(x), scheme_void) - -# define MZC_BYTES_REF(p, v, i) scheme_make_integer(SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)]) -# define MZC_BYTES_SET(p, v, i, x) (SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_INT_VAL(x), scheme_void) - -#define MZC_CHAR_TO_INTEGER(p, v) scheme_make_integer((unsigned char)SCHEME_CHAR_VAL(v)) -/* End unsafe versions */ -#else -/* Safe versions */ -#define MZC_CAR(p, av) (SCHEME_PAIRP(av) ? SCHEME_CAR(av) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg))) -#define MZC_CDR(p, av) (SCHEME_PAIRP(av) ? SCHEME_CDR(av) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg))) -#define MZC_CADR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CDR(av))) ? SCHEME_CAR(SCHEME_CDR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg))) -#define MZC_CDDR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CDR(av))) ? SCHEME_CDR(SCHEME_CDR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg))) -#define MZC_CDAR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CAR(av))) ? SCHEME_CDR(SCHEME_CAR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg))) -#define MZC_CAAR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CAR(av))) ? SCHEME_CAR(SCHEME_CAR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg))) -#define MZC_CADDR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CDR(av)) && SCHEME_PAIRP(SCHEME_CDR(SCHEME_CDR(av)))) ? SCHEME_CADR(SCHEME_CDR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg))) -#define MZC_SET_CAR(p, av, bv) (SCHEME_MUTABLE_PAIRP(av) ? (SCHEME_CAR(av)=bv, scheme_void) : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(p, 2, arg))) -#define MZC_SET_CDR(p, av, bv) (SCHEME_MUTABLE_PAIRP(av) ? (SCHEME_CDR(av)=bv, scheme_void) : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(p, 2, arg))) - -#define MZC_CHAR_TO_INTEGER(p, v) (SCHEME_CHARP(v) ? scheme_make_integer((unsigned char)SCHEME_CHAR_VAL(v)) \ - : (arg[0] = v, _scheme_direct_apply_primitive_multi(p, 1, arg))) - -# define MZC_VECTOR_REF(p, v, i) ((SCHEME_INTP(i) && SCHEME_VECTORP(v) && (SCHEME_INT_VAL(i) >= 0) \ - && (SCHEME_INT_VAL(i) < SCHEME_VEC_SIZE(v)) \ - ? SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] \ - : (arg[0] = v, arg[1] = i, _scheme_direct_apply_primitive_multi(p, 2, arg)))) -# define MZC_VECTOR_SET(p, v, i, x) ((SCHEME_INTP(i) && SCHEME_VECTORP(v) && (SCHEME_INT_VAL(i) >= 0) \ - && (SCHEME_INT_VAL(i) < SCHEME_VEC_SIZE(v)) \ - ? (SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] = x, scheme_void) \ - : (arg[0] = v, arg[1] = i, arg[2] = x, _scheme_direct_apply_primitive_multi(p, 3, arg)))) -# define MZC_STRING_REF(p, v, i) ((SCHEME_INTP(i) && SCHEME_CHAR_STRINGP(v) && (SCHEME_INT_VAL(i) >= 0) \ - && (SCHEME_INT_VAL(i) < SCHEME_CHAR_STRLEN_VAL(v)) \ - ? scheme_make_character(SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)]) \ - : (arg[0] = v, arg[1] = i, _scheme_direct_apply_primitive_multi(p, 2, arg)))) -# define MZC_STRING_SET(p, v, i, x) ((SCHEME_INTP(i) && SCHEME_MUTABLE_CHAR_STRINGP(v) && SCHEME_CHARP(x) && (SCHEME_INT_VAL(i) >= 0) \ - && (SCHEME_INT_VAL(i) < SCHEME_CHAR_STRLEN_VAL(v)) \ - ? (SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_CHAR_VAL(x), scheme_void) \ - : (arg[0] = v, arg[1] = i, arg[2] = x, _scheme_direct_apply_primitive_multi(p, 3, arg)))) -# define MZC_BYTES_REF(p, v, i) ((SCHEME_INTP(i) && SCHEME_BYTE_STRINGP(v) && (SCHEME_INT_VAL(i) >= 0) \ - && (SCHEME_INT_VAL(i) < SCHEME_BYTE_STRLEN_VAL(v)) \ - ? scheme_make_integer(SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)]) \ - : (arg[0] = v, arg[1] = i, _scheme_direct_apply_primitive_multi(p, 2, arg)))) -# define MZC_BYTES_SET(p, v, i, x) ((SCHEME_INTP(i) && SCHEME_MUTABLE_BYTE_STRINGP(v) && SCHEME_INTP(x) \ - && (SCHEME_INT_VAL(x) >= 0) && (SCHEME_INT_VAL(x) <= 255) \ - && (SCHEME_INT_VAL(i) >= 0) && (SCHEME_INT_VAL(i) < SCHEME_BYTE_STRLEN_VAL(v)) \ - ? (SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_INT_VAL(x), scheme_void) \ - : (arg[0] = v, arg[1] = i, arg[2] = x, _scheme_direct_apply_primitive_multi(p, 3, arg)))) -/* End safe versions */ -#endif - -#define _MZC_DBLP(obj) SAME_TYPE(_SCHEME_TYPE(obj), scheme_double_type) - -#define MZC_ZEROP(zp, av) (SCHEME_INTP(av) \ - ? (av == scheme_make_integer(0)) \ - : (_MZC_DBLP(av) \ - ? !SCHEME_DBL_VAL(av) \ - : (arg[0] = av, SCHEME_TRUEP(_scheme_direct_apply_primitive_multi(zp, 1, arg))))) - -#define MZC_ARITH_COMPARE(cp, av, bv, compareop) \ - ((SCHEME_INTP(av) && SCHEME_INTP(bv)) \ - ? (SCHEME_INT_VAL(av) compareop SCHEME_INT_VAL(bv)) \ - : ((SCHEME_DBLP(av) && SCHEME_DBLP(bv)) \ - ? (SCHEME_DBL_VAL(av) compareop SCHEME_DBL_VAL(bv)) \ - : (arg[0] = av, arg[1] = bv, SCHEME_TRUEP(_scheme_direct_apply_primitive_multi(cp, 2, arg))))) - -#define MZC_LTP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, <) -#define MZC_GTP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, >) -#define MZC_LTEP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, <=) -#define MZC_GTEP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, >=) -#define MZC_EQLP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, ==) - -#if MZC_FIXNUM -/* Numerically incorrect */ -#define MZC_ADD1(p, av) (SCHEME_INTP(av) \ - ? scheme_make_integer(SCHEME_INT_VAL(av)+1) \ - : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg))) -#define MZC_SUB1(p, av) (SCHEME_INTP(av) \ - ? scheme_make_integer(SCHEME_INT_VAL(av)-1) \ - : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg))) - -#define MZC_ARITH_OP(cp, av, bv, op, revop) \ - ((SCHEME_INTP(av) && SCHEME_INTP(bv)) \ - ? scheme_make_integer(SCHEME_INT_VAL(av) op SCHEME_INT_VAL(bv)) \ - : ((SCHEME_DBLP(av) && SCHEME_DBLP(bv)) \ - ? scheme_make_double(SCHEME_DBL_VAL(av) op SCHEME_DBL_VAL(bv)) \ - : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg)))) - -#define MZC_TIMES2(cp, av, bv) MZC_ARITH_OP(cp, av, bv, *, /) - -/* End numerically incorrect */ -#else -/* Numerically correct */ -#define MZC_ADD1(p, av) ((SCHEME_INTP(av) && (SCHEME_INT_VAL(av) < 0x3FFFFFFF)) \ - ? scheme_make_integer(SCHEME_INT_VAL(av)+1) \ - : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg))) -#define MZC_SUB1(p, av) ((SCHEME_INTP(av) && (SCHEME_INT_VAL(av) > (-0x3FFFFFFF))) \ - ? scheme_make_integer(SCHEME_INT_VAL(av)-1) \ - : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg))) - -#define MZC_ARITH_OP(cp, av, bv, op, revop) \ - ((SCHEME_INTP(av) && SCHEME_INTP(bv) \ - && (((SCHEME_INT_VAL(scheme_make_integer(SCHEME_INT_VAL(av) op SCHEME_INT_VAL(bv))) \ - revop SCHEME_INT_VAL(bv)) \ - == SCHEME_INT_VAL(av)))) \ - ? scheme_make_integer(SCHEME_INT_VAL(av) op SCHEME_INT_VAL(bv)) \ - : ((SCHEME_DBLP(av) && SCHEME_DBLP(bv)) \ - ? scheme_make_double(SCHEME_DBL_VAL(av) op SCHEME_DBL_VAL(bv)) \ - : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg)))) -/* End numerically correct */ -#endif - -#define MZC_PLUS2(cp, av, bv) MZC_ARITH_OP(cp, av, bv, +, -) -#define MZC_MINUS2(cp, av, bv) MZC_ARITH_OP(cp, av, bv, -, +) - -#define MZC_MAXMIN_OP(cp, av, bv, minlt) \ - ((SCHEME_INTP(av) && SCHEME_INTP(bv)) \ - ? ((SCHEME_INT_VAL(av) minlt SCHEME_INT_VAL(bv)) ? av : bv) \ - : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg))) - -#define MZC_MAX2(cp, av, bv) MZC_MAXMIN_OP(cp, av, bv, >) -#define MZC_MIN2(cp, av, bv) MZC_MAXMIN_OP(cp, av, bv, <) - -#define MZC_QUOTIENT(cp, av, bv) \ - ((SCHEME_INTP(av) && SCHEME_INTP(bv) && SCHEME_INT_VAL(bv)) \ - ? scheme_make_integer(SCHEME_INT_VAL(av) / SCHEME_INT_VAL(bv)) \ - : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg))) - -static MSC_IZE(inline) Scheme_Object *mzc_force_value(Scheme_Object *v) -{ - return _scheme_force_value(v); -} - -#define _scheme_direct_apply_primitive_closure_multi_fv(prim, argc, argv) \ - mzc_force_value(_scheme_direct_apply_primitive_closure_multi(prim, argc, argv)) -#define _scheme_direct_apply_primitive_closure_fv(prim, argc, argv) \ - scheme_check_one_value(_scheme_direct_apply_primitive_closure_multi_fv(prim, argc, argv)) - -static int mzc_strlen(const char *c) { - int l; - for (l = 0; c[l]; l++); - return l; -} - -#if 0 -static Scheme_Object *DEBUG_CHECK(Scheme_Object *v) -{ - if ((SCHEME_TYPE(v) < _scheme_values_types_) || (SCHEME_TYPE(v) > _scheme_last_type_ + 5)) { - /* Could be a boxed value ... */ - Scheme_Object *o = *(Scheme_Object **)v; - if ((SCHEME_TYPE(v) < _scheme_values_types_) || (SCHEME_TYPE(v) > _scheme_last_type_ + 5)) { - printf("wrong!\n"); - } - } - return v; -} -#endif - -#ifdef MZ_PRECISE_GC -START_XFORM_SUSPEND; -static MZC_INLINE Scheme_Object * -_mzc_direct_apply_primitive_multi(Scheme_Object *prim, int argc, Scheme_Object **argv) -{ - return _scheme_direct_apply_primitive_multi(prim, argc, argv); -} -static MZC_INLINE Scheme_Object * -_mzc_direct_apply_primitive(Scheme_Object *prim, int argc, Scheme_Object **argv) -{ - return _scheme_direct_apply_primitive(prim, argc, argv); -} -static MZC_INLINE Scheme_Object * -_mzc_direct_apply_primitive_closure_multi(Scheme_Object *prim, int argc, Scheme_Object **argv) -{ - return _scheme_direct_apply_primitive_closure_multi(prim, argc, argv); -} -static MZC_INLINE Scheme_Object * -_mzc_direct_apply_primitive_closure(Scheme_Object *prim, int argc, Scheme_Object **argv) -{ - return _scheme_direct_apply_primitive_closure(prim, argc, argv); -} -END_XFORM_SUSPEND; -#else -# define _mzc_direct_apply_primitive_multi(prim, argc, argv) \ - _scheme_direct_apply_primitive_multi(prim, argc, argv) -# define _mzc_direct_apply_primitive(prim, argc, argv) \ - _scheme_direct_apply_primitive(prim, argc, argv) -# define _mzc_direct_apply_primitive_closure_multi(prim, argc, argv) \ - _scheme_direct_apply_primitive_closure_multi(prim, argc, argv) -# define _mzc_direct_apply_primitive_closure(prim, argc, argv) \ - _scheme_direct_apply_primitive_closure(prim, argc, argv) -#endif - -#define _mzc_apply(r,n,rs) _scheme_apply(r,n,rs) -#define _mzc_apply_multi(r,n,rs) _scheme_apply_multi(r,n,rs) -#define _mzc_apply_known_prim_closure(r,n,rs) _scheme_apply_known_prim_closure(r,n,rs) -#define _mzc_apply_known_prim_closure_multi(r,n,rs) _scheme_apply_known_prim_closure_multi(r,n,rs) - -#define MZC_PRIM_CLS_DATA(prim) (prim) diff --git a/collects/compiler/mzclink.h b/collects/compiler/mzclink.h deleted file mode 100644 index 3d2cd0c874..0000000000 --- a/collects/compiler/mzclink.h +++ /dev/null @@ -1,2 +0,0 @@ - -#define LOCAL_PROC(x) x diff --git a/collects/compiler/src2src.rkt b/collects/compiler/src2src.rkt deleted file mode 100644 index f6d635f772..0000000000 --- a/collects/compiler/src2src.rkt +++ /dev/null @@ -1,1807 +0,0 @@ - -;; Implements a source-to-source optimizer - -;; The src-to-src transformation currently drops -;; properties, which is bad. The 'mzc-cffi, -;; 'method-arity-error, and 'inferred-name properties are -;; specially preserved for `lambda' expressions. - -(module src2src scheme/base - (require mzlib/class - syntax/kerncase - syntax/primitives - mzlib/etc - mzlib/list - (for-syntax scheme/base)) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Optimizer - ;; classes representing syntax with methods for optimization steps - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Maximum number of times to inline while processing a call site - (define max-fuel 0) - (define fuel (make-parameter max-fuel)) - - (define foldable-prims '(void - + - * / arithmetic-shift - < <= = > >= - number? positive? negative? zero? - real? complex? - string-ref)) - - (define effectless-prims '(list list* cons vector)) - - ;; The following primitives either invoke functions, or - ;; install functions that can be used later. - (define (non-valueable-prims) (procedure-calling-prims)) - - (define code-insp (current-code-inspector)) - - (define (keep-mzc-property stx-out stx) - (let ([v (syntax-property stx 'mzc-cffi)] - [v2 (syntax-property stx 'method-arity-error)] - [v3 (syntax-property stx 'inferred-name)]) - (let ([stx-out2 (if v - (syntax-property stx-out 'mzc-cffi v) - stx-out)]) - (let ([stx-out3 (if v2 - (syntax-property stx-out2 'method-arity-error v2) - stx-out2)]) - (if v3 - (syntax-property stx-out3 'inferred-name v3) - stx-out3))))) - - (define-struct context (need indef)) - ;; need = #f => don't need the value - ;; need = 'bool => need bool only - ;; need = 'all => need exact result - - ;; indef = list of binding%s - - (define (need-all ctx) - (if (eq? 'all (context-need ctx)) - ctx - (make-context 'all (context-indef ctx)))) - (define (need-none ctx) - (if (eq? 'none (context-need ctx)) - ctx - (make-context 'none (context-indef ctx)))) - (define (need-bool ctx) - (make-context 'bool (context-indef ctx))) - - (define-struct accessor (make-struct-type-expr position)) - (define-struct mutator (make-struct-type-expr position)) - (define-struct ctor (make-struct-type-expr)) - - (define exp% - (class object% - - (init-field src-stx) - (when (not (syntax? src-stx)) - (printf "~a\n" src-stx) - (error 'stx)) - (init-field [cert-stxes (list src-stx)]) - (field (known-value #f)) - - ;; resets known-value computation, use counts, etc. - (define/public (reset-varflags) - (set! known-value #f) - (for-each (lambda (e) (send e reset-varflags)) (sub-exprs))) - - ;; accumulates known-value mappings, use counts on bindings, etc.; - ;; assumes varflags are reset - (define/public (set-known-values) - (for-each (lambda (e) (send e set-known-values)) (nonbind-sub-exprs))) - - ;; sets `mutable?' flags; set-known-values does that, too, - ;; but this one only sets mutable flags - (define/public (set-mutability) - (for-each (lambda (e) (send e set-mutability)) (nonbind-sub-exprs))) - - ;; for each reference of a binding in the exp, drop one use - (define/public (drop-uses) - (for-each (lambda (e) (send e drop-uses)) (nonbind-sub-exprs))) - - ;; any side-effects might be in this expression? - ;; (return #t if unsure) - (define/public (no-side-effect?) - (andmap (lambda (e) (send e no-side-effect?)) - (nonbind-sub-exprs))) - - ;; arity is a number or 'unknown - (define/public (get-result-arity) 'unknown) - - ;; gets all subexpressions, including binding%s for lambda, etc. - (define/public (sub-exprs) (append (bind-sub-exprs) (nonbind-sub-exprs))) - ;; just the binding%s - (define/public (bind-sub-exprs) null) - ;; all subexpressions that aren't binding%s - (define/public (nonbind-sub-exprs) null) - - ;; some default implementations map over nonbind-sub-exprs, - ;; the install the results with this method - (define/public (set-nonbind-sub-exprs x) (void)) - - ;; valueable means that evaluating the expression can't access - ;; a variable before it is initialized or mutate a - ;; variable. It's used, for example, on the RHSs of a letrec - ;; to determine known bindings. - (define/public (valueable?) - (andmap (lambda (x) (send x valueable?)) (nonbind-sub-exprs))) - - ;; ok to duplicate or move the expression? - ;; (return #f if unsure) - (define/public (can-dup/move?) #f) - - ;; known value is an exp%; usually only binding% objects - ;; get known-value settings - (define/public (set-known-value x) (set! known-value x)) - - ;; finds the most-specific exp% whose value is the - ;; same this this expression's value - (define/public (get-value) (or known-value this)) - - ;; helper: - (define/private (subexp-map! f) - (set-nonbind-sub-exprs (map f (nonbind-sub-exprs))) - this) - - ;; main optimization method: - (define/public (simplify ctx) - (subexp-map! (lambda (x) - (send x simplify (need-all ctx))))) - - (define/public (escape) - (subexp-map! (lambda (x) (send x escape)))) - - (define/public (stack-allocate) - (subexp-map! (lambda (x) (send x stack-allocate)))) - - ;; not an optimizations, but exposes info (epsecially to mzc) - (define/public (reorganize) - (subexp-map! (lambda (x) (send x reorganize)))) - ;; reverses reorganize - (define/public (deorganize) - (subexp-map! (lambda (x) - (send x deorganize)))) - - ;; substitution of lexical refs for global variables - (define/public (global->local env) - (subexp-map! (lambda (x) - (send x global->local env)))) - - ;; substitution of lexical refs for either lex or global vars - (define/public (substitute env) - (subexp-map! (lambda (x) - (send x substitute env)))) - - ;; creates a copy, used for inling; don't try to preserve - ;; analysis, because we'll just re-compute it - (define/public (clone env) - (error 'clone "unimplemented: ~a" this)) - - ;; gets stx object, usually for src info - (define/public (get-stx) src-stx) - - ;; convert back to a syntax object - (define/public (sexpr) src-stx) - - ;; returns cert stxes - (define/public (get-cert-stxes) - cert-stxes) - - ;; merges cert info from another expression - (define/public (merge-certs exp) - (set! cert-stxes - (append (filter (lambda (i) (not (memq i cert-stxes))) - (send exp get-cert-stxes)) - cert-stxes))) - - ;; list of body exprs (avoids redundant `begin', just for - ;; readability) - (define/public (body-sexpr) (list (sexpr))) - - (super-instantiate ()))) - - (define (get-sexpr o) (send o sexpr)) - (define (get-body-sexpr o) (send o body-sexpr)) - - (define-struct bucket (mutated? inited-before-use?) #:mutable) - - (define (global-bucket table stx) - (let ([l (hash-ref table (syntax-e stx) (lambda () null))]) - (let ([s (ormap (lambda (b) - (and (free-identifier=? stx (car b)) - (cdr b))) - l)]) - (if s - s - (let ([s (make-bucket #f #f)]) - (hash-set! table (syntax-e stx) (cons (cons stx s) l)) - s))))) - - (define-struct tables (global-ht et-global-ht)) - - (define global% - (class exp% - (init-field trans? tables needs-top?) - (super-instantiate ()) - (inherit-field src-stx) ;; The identifier - (inherit-field cert-stxes) ;; The identifier - - (define mbind #f) - (define bucket (global-bucket ((if trans? tables-et-global-ht tables-global-ht) tables) src-stx)) - (define/private (get-mbind!) - (unless mbind - (set! mbind ((if trans? - identifier-transformer-binding - identifier-binding) - src-stx)))) - (define/public (orig-name) - (get-mbind!) - (if (pair? mbind) - (cadr mbind) - (syntax-e src-stx))) - - (define/public (is-kernel?) - (get-mbind!) - (and (pair? mbind) - (eq? (car mbind) '#%kernel))) - - (define/public (is-trans?) trans?) - - (define/public (is-mutated?) (bucket-mutated? bucket)) - - (define/override (no-side-effect?) - ;; If not built in, could raise exn - (is-kernel?)) - - (define/override (get-result-arity) 1) - - (define/override (valueable?) (or (bucket-inited-before-use? bucket) - (is-kernel?))) - - (define/override (can-dup/move?) (valueable?)) - - (define/override (clone env) (make-object global% trans? tables needs-top? src-stx cert-stxes)) - - (define/override (global->local env) - (or (ormap (lambda (e) - (and (free-identifier=? (car e) src-stx) - (make-object ref% (cdr e) src-stx cert-stxes))) - env) - this)) - - (define/override (sexpr) - (if needs-top? - (with-syntax ([stx src-stx]) - (syntax (#%top . stx))) - src-stx)) - - (define/public (set-mutated) (set-bucket-mutated?! bucket #t)) - (define/public (set-inited) (set-bucket-inited-before-use?! bucket #t)))) - - (define binding% - (class exp% - (init-field always-inited?) - (super-instantiate ()) - (inherit-field src-stx cert-stxes) - (define value #f) - (define used 0) - (define mutated? #f) - (define inited? always-inited?) - (define escape #f) - - (define/public (is-used?) (positive? used)) - (define/public (is-mutated?) mutated?) - (define/public (is-inited?) inited?) - (define/public (get-use-count) used) - - (define/public (set-mutated) (set! mutated? #t)) - (define/public (set-inited) (set! inited? #t)) - (define/public (set-value v) (set! value v)) - - (define/public (escapes?) escape) - (define/public (set-escapes x) (set! escape #t)) - - (define/public (clone-binder env) - (make-object binding% - always-inited? - (datum->syntax - #f - (gensym (syntax-e src-stx)) - src-stx - cert-stxes))) - - - (define/override (reset-varflags) - (set! used 0) - (set! mutated? #f) - (set! inited? always-inited?)) - (define/override (set-known-values) - (set! used (add1 used)) - (unless inited? - (set! mutated? #t))) - - (define/override (valueable?) (and inited? (not mutated?))) - - (define/override (drop-uses) (set! used (sub1 used))) - - (define/override (get-value) - (and (not mutated?) - value - (send value get-value))) - - (define/override (sexpr) - ;; `(==lexical== ,name ,used ,mutated? ,inited? ,(get-value)) - src-stx) - - (define/public (orig-name) - (syntax-e src-stx)))) - - (define ref% - (class exp% - (init-field binding) - (super-instantiate ()) - (inherit-field src-stx) ;; The identifier - - - (define/public (is-used?) (send binding is-used?)) - (define/public (is-mutated?) (send binding is-mutated?)) - (define/public (is-inited?) (send binding is-inited?)) - - (define/public (get-use-count) (send binding get-use-count)) - - (define/public (set-mutated) (send binding set-mutated)) - (define/public (set-inited) (send binding set-inited)) - (define/public (set-value v) (send binding set-value v)) - - (define/override (set-known-values) (send binding set-known-values)) - - (define/override (valueable?) (send binding valueable?)) - (define/override (can-dup/move?) (valueable?)) - - (define/override (drop-uses) (send binding drop-uses)) - - (define/override (get-result-arity) 1) - - (define/override (get-value) (send binding get-value)) - - (define/override (escape) - (send binding set-escape)) - - (define/override (simplify ctx) - (if (context-need ctx) - (let ([v (get-value)]) - (if (and v (send v can-dup/move?)) - (begin - (drop-uses) - (send v simplify ctx)) - this)) - (begin - (drop-uses) - (make-object void% src-stx)))) - - (define/override (clone env) (lookup-clone binding this env)) - (define/override (substitute env) (lookup-clone binding this env)) - - (define/override (sexpr) - (let ([x (send binding sexpr)]) - (datum->syntax - x - (syntax-e x) - src-stx))) - - (define/public (get-binding) binding) - (define/public (orig-name) (send binding orig-name)))) - - - (define begin% - (class exp% - (init-field subs) - (super-instantiate ()) - (inherit-field src-stx cert-stxes) - (inherit merge-certs) - - (define/override (nonbind-sub-exprs) subs) - (define/override (set-nonbind-sub-exprs s) (set! subs s)) - - (define/override (get-result-arity) - (if (null? subs) - 'unknown - (let loop ([subs subs]) - (if (null? (cdr subs)) - (send (car subs) get-result-arity) - (loop (cdr subs)))))) - - (define/override (simplify ctx) - (set! subs - (let loop ([subs subs]) - (cond - [(null? subs) null] - [(null? (cdr subs)) - (list (send (car subs) simplify ctx))] - [else - (let ([r (send (car subs) simplify (need-none ctx))] - [rest (loop (cdr subs))]) - (cond - [(send r no-side-effect?) - (send r drop-uses) - rest] - [(is-a? r begin%) - (merge-certs r) - (append (send r nonbind-sub-exprs) - rest)] - [else (cons r rest)]))]))) - (if (and (pair? subs) - (null? (cdr subs))) - (let ([v (car subs)]) - (send v merge-certs this) - v) - this)) - - (define/override (clone env) - (make-object begin% - (map (lambda (x) (send x clone env)) - subs) - src-stx - cert-stxes)) - - (define/override (sexpr) - (with-syntax ([(body ...) (body-sexpr)]) - (syntax/loc src-stx (begin body ...)))) - - (define/override (body-sexpr) - (map (lambda (e) (get-sexpr e)) subs)))) - - (define top-def% - (class exp% - (init-field formname varnames expr tables) - (super-instantiate ()) - (inherit-field src-stx cert-stxes) - (define globals #f) - - (define/override (nonbind-sub-exprs) (list expr)) - (define/override (set-nonbind-sub-exprs s) (set! expr (car s))) - - (define/override (get-result-arity) 1) - - (define/override (no-side-effect?) #f) - (define/override (valueable?) #f) - - (define/override (clone env) (make-object top-def% - formname - varnames - (send expr clone env) - tables - src-stx - cert-stxes)) - - (define/override (sexpr) - (with-syntax ([formname formname] - [(varname ...) varnames] - [rhs (get-sexpr expr)]) - (syntax/loc src-stx (formname (varname ...) rhs)))) - - (define/public (get-vars) varnames) - (define/public (get-rhs) expr) - - ;; Like get-vars, but return global% objects, instead. - ;; Useful because the global% object has the global variable bucket info. - (define/public (get-globals) - (unless globals - (set! globals - (map (lambda (v) - (make-object global% #f tables #f v)) - varnames))) - globals))) - - (define variable-def% - (class top-def% - (init varnames expr tables stx) - - (super-instantiate ((quote-syntax define-values) varnames expr tables stx)))) - - (define syntax-def% - (class top-def% - (init varnames expr tables stx) - (super-instantiate ((quote-syntax define-syntaxes) varnames expr tables stx)))) - - (define for-syntax-def% - (class top-def% - (init varnames expr tables stx) - (super-instantiate ((quote-syntax define-values-for-syntax) varnames expr tables stx)))) - - (define (install-values vars expr) - (when (= 1 (length vars)) - (send (car vars) set-value expr))) - - (define constant% - (class exp% - (init-field val) - (super-instantiate ()) - (inherit-field src-stx cert-stxes) - - (define/public (get-const-val) val) - - (define/override (get-value) this) - - (define/override (valueable?) #t) - - (define/override (can-dup/move?) - (or (number? val) - (boolean? val) - (char? val) - (symbol? val) - (void? val))) - - (define/override (get-result-arity) 1) - - (define/override (simplify ctx) - (cond - [(eq? 'bool (context-need ctx)) - (if (boolean? val) - this - (make-object constant% #t src-stx))] - [(context-need ctx) - (cond - [(eq? val (void)) - (make-object void% src-stx)] - [else this])] - [else (make-object void% src-stx)])) - - (define/override (clone env) (make-object constant% val src-stx cert-stxes)) - - (define/override (sexpr) - (let ([vstx (datum->syntax (quote-syntax here) val src-stx)]) - (cond - [(or (number? val) - (string? val) - (boolean? val) - (char? val)) - vstx] - [(syntax? val) - (with-syntax ([vstx vstx]) - (syntax (quote-syntax vstx)))] - [else - (with-syntax ([vstx vstx]) - (syntax (quote vstx)))]))))) - - (define void% - (class constant% - (init stx) - (super-instantiate ((void) stx)) - (inherit-field src-stx cert-stxes) - - (define/override (sexpr) (quote-syntax (#%plain-app void))) - - (define/override (simplify ctx) - (if (eq? 'bool (context-need ctx)) - (make-object constant% #t src-stx) - this)) - - (define/override (clone env) (make-object void% src-stx cert-stxes)))) - - - (define app% - (class exp% - (init-field rator rands tables) - (super-instantiate ()) - (inherit-field src-stx - cert-stxes) - (inherit merge-certs) - - (define known-single-result? #f) - - (inherit set-known-value) - - (define/private (known-single-result v) - (set! known-single-result? #t) - (set-known-value v) - v) - - - (define/override (nonbind-sub-exprs) (cons rator rands)) - (define/override (set-nonbind-sub-exprs s) - (set! rator (car s)) - (set! rands (cdr s))) - - (define/override (no-side-effect?) - ;; Note: get-result-arity assumes #t result => single value - ;; - ;; Some prims are known to be side-effect-free (including no errors) - ;; get-result-arity assumes 1 when this returns #t - (or known-single-result? - (and (rator . is-a? . global%) - (send rator is-kernel?) - (memq (send rator orig-name) effectless-prims) - (andmap (lambda (rand) (send rand no-side-effect?)) - rands)))) - - (define/override (valueable?) - (and (rator . is-a? . global%) - (send rator is-kernel?) - (not (memq (send rator orig-name) - (non-valueable-prims))) - (super valueable?))) - - (define/override (get-result-arity) - (if (or known-single-result? (no-side-effect?)) - 1 - 'unknown)) - - (define/override (escape) - (send rator escape) - (cond - ((bound-identifier=? #'vector-ref (send rator get-stx)) (void)) - ((and (bound-identifier=? #'vector-set! (send rator get-stx)) - (not (null? rands))) - (map (lambda (x) (send x escape)) (cdr rands))) - (else - (map (lambda (x) (send x escape)) rands)))) - - (define/override (simplify ctx) - (super simplify ctx) - (cond - ;; ((lambda (a ...) ...) v ...) => (let ([a v] ...) ...) - [(and (is-a? rator lambda%) - (send rator can-inline?)) - (if (send rator arg-body-exists? (length rands)) - (begin - (send rator drop-other-uses (length rands)) - (let-values ([(vars body) (send rator arg-vars-and-body (length rands))]) - (for-each (lambda (var rand) - (install-values (list var) rand)) - vars rands) - (let ([let-form (make-object let% - (map list vars) - rands - body - src-stx - cert-stxes)]) - (send let-form merge-certs this) - (send let-form merge-certs rator) - (send let-form simplify ctx)))) - (begin - (unless (send rator arg-count-ok? (length rands)) - (warning "immediate procedure called with wrong number of arguments" - this)) - this))] - - ;; constant folding - [(and (is-a? rator global%) - (memq (send rator orig-name) foldable-prims) - (send rator is-kernel?) - (andmap (lambda (x) (is-a? x constant%)) rands)) - (if (eq? (send rator orig-name) 'void) - (make-object void% src-stx) - (let ([vals (map (lambda (x) (send x get-const-val)) rands)] - [f (dynamic-require 'mzscheme (send rator orig-name))]) - (with-handlers ([exn:fail? (lambda (x) - (fprintf (current-error-port) - "constant calculation error: ~a\n" - (exn-message x)) - this)]) - (known-single-result - (send (make-object constant% (apply f vals) src-stx) - simplify ctx)))))] - - ;; (+ x 1) => (add1 x) - [(and (is-a? rator global%) - (send rator is-kernel?) - (eq? (send rator orig-name) '+) - (= 2 (length rands)) - (or (and (is-a? (car rands) constant%) - (eq? 1 (send (car rands) get-const-val))) - (and (is-a? (cadr rands) constant%) - (eq? 1 (send (cadr rands) get-const-val))))) - (make-object app% - (make-object global% (send rator is-trans?) tables #f (quote-syntax add1)) - (list - (if (and (is-a? (car rands) constant%) - (eq? 1 (send (car rands) get-const-val))) - (cadr rands) - (car rands))) - tables - src-stx - cert-stxes)] - ;; (- x 1) => (sub1 x) - [(and (is-a? rator global%) - (send rator is-kernel?) - (eq? (send rator orig-name) '-) - (= 2 (length rands)) - (and (is-a? (cadr rands) constant%) - (eq? 1 (send (cadr rands) get-const-val)))) - (make-object app% - (make-object global% (send rator is-trans?) tables #f (quote-syntax sub1)) - (list (car rands)) - tables - src-stx - cert-stxes)] - - ;; (car x) where x is known to be a list construction - [(and (is-a? rator global%) - (send rator is-kernel?) - (let-values ([(pos len) (case (send rator orig-name) - [(car) (values 0 1)] - [(cadr) (values 1 1)] - [(caddr) (values 2 1)] - [(cadddr) (values 3 1)] - [(list-ref) (values (and (= 2 (length rands)) - (let ([v (send (cadr rands) get-value)]) - (and (v . is-a? . constant%) - (send v get-const-val)))) - 2)] - [else (values #f #f)])]) - (and (number? pos) - (= len (length rands)) - (and ((car rands) . is-a? . ref%) - (let ([val (send (car rands) get-value)]) - (and (val . is-a? . app%) - (send val get-list-ref pos))))))) - => - (lambda (val) - (send (car rands) drop-uses) - (known-single-result val))] - - ;; (memv x '(c ...)) in a boolean context => (if (eq[v]? x 'c) ...) - ;; relevant to the output of `case' - [(and (eq? (context-need ctx) 'bool) - (is-a? rator global%) - (send rator is-kernel?) - (eq? (send rator orig-name) 'memv) - (= 2 (length rands)) - (is-a? (car rands) ref%) - (is-a? (cadr rands) constant%) - (list? (send (cadr rands) get-const-val))) - (let ([xformed - (let ([l (send (cadr rands) get-const-val)] - [l-stx (send (cadr rands) get-stx)] - [false (make-object constant% #f (datum->syntax #f #f))] - [true (make-object constant% #t (datum->syntax #f #t))]) - (if (null? l) - false - (let loop ([l l]) - (let ([test - (make-object app% - (make-object global% - (send rator is-trans?) - tables - #f - (let ([a (car l)]) - (if (or (symbol? a) - (and (number? a) - (exact? a) - (integer? a) - ;; fixnums: - (<= (- (expt 2 29)) - a - (expt 2 29)))) - (quote-syntax eq?) - (quote-syntax eqv?)))) - (list - (car rands) - (make-object constant% - (car l) - l-stx)) - tables - src-stx - cert-stxes)]) - (cond - [(null? (cdr l)) test] - [else (let ([rest (loop (cdr l))]) - ;; increment use count: - (send (car rands) set-known-values) - (make-object if% - test - true - rest - src-stx - cert-stxes))])))))]) - (send xformed merge-certs this) - (send xformed simplify ctx))] - - ;; (values e) where e has result arity 1 - [(and (is-a? rator global%) - (send rator is-kernel?) - (eq? 'values (send rator orig-name)) - (= 1 (length rands)) - (equal? 1 (send (car rands) get-result-arity))) - (send (car rands) merge-certs this) - (known-single-result (car rands))] - - ;; Check arity of other calls to primitives - [(and (is-a? rator global%) - (send rator is-kernel?)) - (let ([f (dynamic-require 'mzscheme (send rator orig-name))]) - (cond - [(not (procedure? f)) - (warning "call of non-procedure" this)] - [(not (procedure-arity-includes? f (length rands))) - (warning "primitive called with wrong number of arguments" this)])) - this] - - ;; inlining - [(and #f ;; disabled! - (> (fuel) 0) - (or (is-a? rator ref%) (is-a? rator global%)) - (is-a? (send rator get-value) lambda%) - (not (send (send rator get-value) get-simplifying-body))) - (let ([f (send (send rator get-value) clone null)]) - (send rator drop-uses) - (set! rator f) - (send f set-known-values) - ;; Now we have ((lambda ...) ...). Go again. - (fuel (sub1 (fuel))) - (if (= (fuel) (sub1 max-fuel)) - (begin0 - (simplify ctx) - (fuel max-fuel)) - (simplify ctx)))] - - ;; Check arity of a call to a known (non-primitive) function - [(and (or (is-a? rator ref%) (is-a? rator global%)) - (is-a? (send rator get-value) lambda%)) - (let ([f (send rator get-value)]) - (unless (send f arg-count-ok? (length rands)) - (warning "procedure called with wrong number of arguments" - this)) - this)] - - [else this])) - - (define/override (clone env) (make-object app% - (send rator clone env) - (map (lambda (rand) - (send rand clone env)) - rands) - tables - src-stx - cert-stxes)) - - (define/override (sexpr) - (keep-mzc-property - (with-syntax ([rator (get-sexpr rator)] - [(rand ...) (map get-sexpr rands)]) - (syntax/loc src-stx (#%plain-app rator rand ...))) - src-stx)) - - ;; Checks whether the expression is an app of `values' - ;; to a particular set of bindings. - (define/public (is-values-of? args) - (and (rator . is-a? . global%) - (send rator is-kernel?) - (eq? (send rator orig-name) 'values) - (= (length rands) (length args)) - (andmap - (lambda (rand arg) - (and (rand . is-a? . ref%) - (eq? arg (send rand get-binding)))) - rands args))) - - ;; If app constructs a list and the nth element can be - ;; safely extracted, then extract it. - (define/public (get-list-ref n) - (and (rator . is-a? . global%) - (send rator is-kernel?) - (eq? 'list (send rator orig-name)) - ((length rands) . > . n) - (let ([i (list-ref rands n)]) - (if (send i can-dup/move?) - i - #f)))))) - - (define lambda% - (class exp% - (init-field varss normal?s bodys) - (super-instantiate ()) - (inherit-field src-stx cert-stxes) - (define simplifying-body #f) - - - (inherit drop-uses) - - - (define/private (multarity-ize l) - (if (null? (cdr l)) - (car l) - (cons (car l) - (multarity-ize (cdr l))))) - - (define/public (get-simplifying-body) simplifying-body) - - (define/public (multi?) (or (null? bodys) - (pair? (cdr bodys)))) - - (define/public (arg-body-exists? n) - (ormap (lambda (vs n?) (and n? (= n (length vs)))) - varss normal?s)) - (define/public (arg-count-ok? n) - (ormap (lambda (vs n?) (or (and n? (= n (length vs))) - (and (not n?) (n . >= . (sub1 (length vs)))))) - varss normal?s)) - (define/public (arg-vars-and-body n) - (let loop ([varss varss][normal?s normal?s][bodys bodys]) - (if (and (car normal?s) - (= (length (car varss)) n)) - (values (car varss) (car bodys)) - (loop (cdr varss) (cdr normal?s) (cdr bodys))))) - - (define/public (drop-other-uses n) - (let loop ([n n][varss varss][normal?s normal?s][bodys bodys]) - (unless (null? varss) - (let ([n (if (and (car normal?s) - (= (length (car varss)) n)) - -1 - (begin - (send (car bodys) drop-uses) - n))]) - (loop n (cdr varss) (cdr normal?s) (cdr bodys)))))) - - (define/public (can-inline?) - (not (syntax-property src-stx 'mzc-cffi))) - - (define/override (bind-sub-exprs) (apply append varss)) - (define/override (nonbind-sub-exprs) bodys) - (define/override (set-nonbind-sub-exprs s) (set! bodys s)) - - (define/override (no-side-effect?) #t) - (define/override (get-result-arity) 1) - - (define/override (valueable?) #t) - - (define/override (simplify ctx) - (if (eq? 'bool (context-need ctx)) - (begin - (drop-uses) - (make-object constant% #t src-stx)) - (begin - (set! simplifying-body #t) - (begin0 - (super simplify ctx) - (set! simplifying-body #f))))) - - (define/override (clone env) - (let ([varss+bodys - (let loop ([varss varss][bodys bodys]) - (if (null? varss) - null - (let* ([vars (car varss)] - [new-vars (map (lambda (v) (send v clone-binder env)) - vars)]) - (cons - (cons new-vars - (send (car bodys) - clone (append (map cons vars new-vars) - env))) - (loop (cdr varss) (cdr bodys))))))]) - (make-object lambda% - (map car varss+bodys) - normal?s - (map cdr varss+bodys) - src-stx - cert-stxes))) - - (define/override (sexpr) - (with-syntax ([(vars ...) - (map (lambda (vars normal?) - (let ([vs (map get-sexpr vars)]) - (if normal? - vs - (multarity-ize vs)))) - varss normal?s)] - [(body ...) - (map (lambda (body) - (get-body-sexpr body)) - bodys)]) - (keep-mzc-property - (if (multi?) - (syntax/loc src-stx - (case-lambda - [vars . body] ...)) - (with-syntax ([body (car (syntax->list (syntax (body ...))))]) - (syntax/loc src-stx - (#%plain-lambda vars ... . body)))) - src-stx))))) - - (define local% - (class exp% - (init-field form varss rhss body) - (super-instantiate ()) - (inherit-field src-stx cert-stxes) - (inherit merge-certs) - - (define/public (get-rhss) rhss) - (define/public (get-varss) varss) - (define/public (get-body) body) - - (define/override (bind-sub-exprs) (apply append varss)) - (define/override (nonbind-sub-exprs) (cons body rhss)) - (define/override (set-nonbind-sub-exprs s) - (set! body (car s)) - (set! rhss (cdr s))) - - (define/override (get-result-arity) (send body get-result-arity)) - - (define/override (simplify ctx) - (set! rhss (map (lambda (rhs vars) - (send rhs simplify - (make-context 'all - (append vars (context-indef ctx))))) - rhss varss)) - (set! body (send body simplify ctx)) - - ;; Drop unused constant bindings - (set!-values (varss rhss) - (let loop ([varss varss][rhss rhss]) - (cond - [(null? varss) (values null null)] - [else (let-values ([(rest-vss rest-rhss) - (loop (cdr varss) (cdr rhss))]) - (if (and (andmap (lambda (var) (not (send var is-used?))) - (car varss)) - (equal? (send (car rhss) get-result-arity) - (length (car varss))) - (send (car rhss) no-side-effect?)) - (begin - (send (car rhss) drop-uses) - (values rest-vss rest-rhss)) - (values (cons (car varss) rest-vss) - (cons (car rhss) rest-rhss))))]))) - - (cond - ;; (let-values ([(x) e]) (if e ... ...)) - ;; is a pattern created by `or' - [(and (is-a? body if%) - (let ([t (send body get-if-test)]) - (and (is-a? t binding%) - (= 1 (length varss)) - (= 1 (length (car varss))) - (eq? (caar varss) t) - (= 1 (send t get-use-count))))) - (make-object if% - (car rhss) - (send body get-if-then) - (send body get-if-else) - src-stx - cert-stxes)] - [(null? varss) - (send body merge-certs this) - (send body simplify ctx)] - ;; (let-values [(x) y] ...) whether y is inited, and - ;; neither x nor y is mutated => replace x by y - [(and (andmap (lambda (vars) (= 1 (length vars))) varss) - (send (caar varss) valueable?) - (andmap (lambda (rhs) (and (or (rhs . is-a? . ref%) - (rhs . is-a? . global%)) - (send rhs valueable?))) - rhss)) - (send body merge-certs this) - (send body substitute - (map (lambda (vars rhs) (cons (car vars) - (if (rhs . is-a? . ref%) - (send rhs get-binding) - rhs))) - varss rhss))] - - [else - this])) - - (define/override (clone env) - (let* ([new-varss - (map (lambda (vs) - (map (lambda (v) (send v clone-binder env)) - vs)) - varss)] - [body-env (append - (map cons - (apply append varss) - (apply append new-varss)) - env)] - [letrec? (eq? form 'letrec-values)]) - (make-object (if letrec? letrec% let%) - new-varss - (map (lambda (rhs) - (send rhs clone (if letrec? body-env env))) - rhss) - (send body clone body-env) - src-stx - cert-stxes))) - - (define/override (get-value) (send body get-value)) - - (define/override (sexpr) - (with-syntax ([form form] - [(vars ...) - (map (lambda (vars) - (map get-sexpr vars)) - varss)] - [(rhs ...) - (map get-sexpr rhss)] - [(body ...) (get-body-sexpr body)]) - (syntax/loc src-stx - (form ([vars rhs] ...) - body ...)))))) - - (define let% - (class local% - (init -varss -rhss -body -stx -cert-stxes) - (inherit get-varss get-rhss get-body) - - (define/override (set-known-values) - (for-each (lambda (vars rhs) (install-values vars rhs)) - (get-varss) (get-rhss)) - (super set-known-values)) - - (super-instantiate ((quote-syntax let-values) -varss -rhss -body -stx -cert-stxes)))) - - (define letrec% - (class local% - (init -varss -rhss -body -stx -cert-stxes) - (inherit get-varss get-rhss) - - (define/override (set-known-values) - (let loop ([varss (get-varss)][rhss (get-rhss)]) - (unless (null? varss) - (when (send (car rhss) valueable?) - (for-each (lambda (var) (send var set-inited)) - (car varss)) - (loop (cdr varss) (cdr rhss))))) - (for-each install-values (get-varss) (get-rhss)) - (super set-known-values)) - - (super-instantiate ((quote-syntax letrec-values) -varss -rhss -body -stx -cert-stxes)))) - - (define set!% - (class exp% - (init-field var val) - (super-instantiate ()) - (inherit-field src-stx cert-stxes) - - (define/override (nonbind-sub-exprs) (list var val)) - (define/override (set-nonbind-sub-exprs s) - (set! var (car s)) - (set! val (cadr s))) - - (define/override (no-side-effect?) #f) - (define/override (valueable?) #f) - (define/override (get-result-arity) 1) - - (define/override (set-known-values) - (send var set-mutated) - (send var set-known-values) ; increments use - (send val set-known-values)) - - (define/override (set-mutability) - (send var set-mutated) - (super set-mutability)) - - (define/override (clone env) - (make-object set!% - (send var clone env) - (send val clone env) - src-stx - cert-stxes)) - - (define/override (sexpr) - (with-syntax ([var (get-sexpr var)] - [val (get-sexpr val)]) - (syntax/loc src-stx - (set! var val)))))) - - (define if% - (class exp% - (init-field test then else) - (super-instantiate ()) - (inherit-field src-stx cert-stxes) - - (define/public (get-if-test) test) - (define/public (get-if-then) then) - (define/public (get-if-else) else) - - (define/override (nonbind-sub-exprs) (list test then else)) - (define/override (set-nonbind-sub-exprs s) - (set! test (car s)) - (set! then (cadr s)) - (set! else (caddr s))) - - (define/override (get-result-arity) - (let ([t (send then get-result-arity)] - [e (send else get-result-arity)]) - (if (equal? t e) - t - 'unknown))) - - (define/override (simplify ctx) - (set! test (send test simplify (need-bool ctx))) - (set! then (send then simplify ctx)) - (set! else (send else simplify ctx)) - - ;; (if xvar xvar y) when need bool - ;; => (if xvar #t y) - (when (and (eq? 'bool (context-need ctx)) - (is-a? test binding%) - (eq? test then)) - (send then drop-uses) - (set! then (make-object constant% #t src-stx))) - (when (and (eq? 'bool (context-need ctx)) - (eq? test else) - (is-a? test binding%)) - (send else drop-uses) - (set! else (make-object constant% #f src-stx))) - - - (cond - ;; Constant switch - [(is-a? test constant%) - (if (eq? (send test get-const-val) #f) - (begin - (send test drop-uses) - (send then drop-uses) - else) - (begin - (send test drop-uses) - (send else drop-uses) - then))] - - ;; (if (if x y #f) a (void)) - ;; => (if x (if y a (void)) (void)) - [(and (is-a? test if%) - (is-a? else void%) - (let ([c (send test get-if-else)]) - (and (is-a? c constant%) - (eq? #f (send c get-const-val))))) - (send - (make-object if% - (send test get-if-test) - (make-object if% - (send test get-if-then) - then - (make-object void% src-stx) - src-stx - cert-stxes) - (make-object void% src-stx) - src-stx - cert-stxes) - simplify ctx)] - - [else this])) - - (define/override (clone env) - (make-object if% - (send test clone env) - (send then clone env) - (send else clone env) - src-stx - cert-stxes)) - - (define/override (sexpr) - (with-syntax ([test (get-sexpr test)] - [then (get-sexpr then)]) - (if (else . is-a? . void%) - (syntax/loc src-stx - (if test then)) - (with-syntax ([else (get-sexpr else)]) - (syntax/loc src-stx - (if test then else)))))))) - - (define begin0% - (class exp% - (init-field first rest) - (super-instantiate ()) - (inherit-field src-stx cert-stxes) - - (define/override (nonbind-sub-exprs) (list first rest)) - (define/override (set-nonbind-sub-exprs s) - (set! first (car s)) - (set! rest (cadr s))) - - (define/override (get-result-arity) (send first get-result-arity)) - - (define/override (simplify ctx) - (set! first (send first simplify ctx)) - (set! rest (send rest simplify (need-none ctx))) - (if (send rest no-side-effect?) - (begin - (send rest drop-uses) - (send first merge-certs this) - first) - this)) - - (define/override (clone env) - (make-object begin0% - (send first clone env) - (send rest clone env) - src-stx - cert-stxes)) - - (define/override (sexpr) - (with-syntax ([first (get-sexpr first)] - [(rest ...) (get-body-sexpr rest)]) - (syntax/loc src-stx - (begin0 first rest ...)))))) - - (define wcm% - (class exp% - (init-field key val body) - (super-instantiate ()) - (inherit-field src-stx cert-stxes) - - (define/override (nonbind-sub-exprs) (list key val body)) - (define/override (set-nonbind-sub-exprs s) - (set! key (car s)) - (set! val (cadr s)) - (set! body (caddr s))) - - (define/override (get-result-arity) (send body get-result-arity)) - - (define/override (clone env) - (make-object wcm% - (send key clone env) - (send val clone env) - (send body clone env) - src-stx - cert-stxes)) - - (define/override (sexpr) - (with-syntax ([key (get-sexpr key)] - [val (get-sexpr val)] - [body (get-sexpr body)]) - (syntax/loc src-stx - (with-continuation-mark key val body)))))) - - (define module% - (class exp% - (init-field body et-body name init-req req-prov tables src-module-begin-stx) - (super-instantiate ()) - (inherit-field src-stx) - - (define/override (reset-varflags) - (for-each (lambda (e) (send e reset-varflags)) body) - (for-each (lambda (e) (send e reset-varflags)) et-body)) - (define/override (set-known-values) - ;; Assumes varflags are reset - (for-each (lambda (e) (send e set-known-values)) (nonbind-sub-exprs))) - - (define/override (drop-uses) - ;; Assumes varflags are reset - (for-each (lambda (e) (send e drop-uses)) (nonbind-sub-exprs))) - - (define/override (no-side-effect?) #f) - (define/override (valueable?) #f) - - (define/override (get-result-arity) 'unknown) - - (define/override (sub-exprs) (append (append et-body body))) - (define/override (bind-sub-exprs) null) - (define/override (nonbind-sub-exprs) (sub-exprs)) - (define/override (set-nonbind-sub-exprs l) - (let-values ([(etb b) - (let loop ([l l][etb et-body][accum null]) - (cond - [(null? etb) - (values (reverse accum) l)] - [else (loop (cdr l) (cdr etb) (cons (car l) - accum))]))]) - (set! body body) - (set! et-body etb))) - - ;; expose known bindings by converting a sequence of top-level - ;; expressions into a letrec: - ;; (define-values (a ...) body) ... - ;; => (define-values (a ... ...) - ;; (letrec-values ([(a ...) body] ...) (values a ... ...))) - (define/override (reorganize) - (let ([-body (map (lambda (x) (send x reorganize)) body)] - [-et-body (map (lambda (x) (send x reorganize)) et-body)]) - (let loop ([l -body][defs null]) - (cond - [(and (pair? l) - ((car l) . is-a? . variable-def%) - (not (ormap (lambda (v) (send v is-mutated?)) - (send (car l) get-globals))) - (send (send (car l) get-rhs) valueable?)) - (for-each (lambda (g) (send g set-inited)) - (send (car l) get-globals)) - (loop (cdr l) - (cons (car l) defs))] - [else - (if (null? defs) - (void) ; no reorganization - (let* ([defs (reverse defs)] - [varss - (map (lambda (def) (send def get-vars)) defs)] - [rhss - (map (lambda (def) (send def get-rhs)) defs)] - [lex-varss (map (lambda (vars) - (map (lambda (var) - (make-object binding% - #t - (datum->syntax - #f - (syntax-e var) - var))) - vars)) - varss)] - [vars (apply append varss)] - [lex-vars (apply append lex-varss)] - [env (map cons vars lex-vars)]) - (set! -body - (cons - (make-object variable-def% - vars - (make-object letrec% - lex-varss - (map (lambda (rhs) - (send rhs global->local env)) - rhss) - (make-object app% - (make-object global% - #f - tables - #f - (quote-syntax values)) - (map (lambda (var lex-var) - (make-object ref% lex-var var)) - vars - lex-vars) - tables - (send (car defs) get-stx)) - (send (car defs) get-stx) - (send (car defs) get-cert-stxes)) - tables - (send (car defs) get-stx)) - l))))]) - (set! body -body) - (set! et-body -et-body))) - this) - - (define/override (deorganize) - ;; Check for - ;; (define-values (a ... ...) - ;; (letrec-values ([(a ...) body] ...) (values a ... ...))) - ;; => (define-values (a ...) body) ... - (when (and (pair? body) - (let ([first (car body)]) - (and (first . is-a? . variable-def%) - (let ([rhs (send first get-rhs)]) - (and (rhs . is-a? . letrec%) - (let ([lbody (send rhs get-body)] - [lvarss (send rhs get-varss)]) - (and (lbody . is-a? . app%) - (send lbody is-values-of? - (apply append lvarss))))))))) - (let ([vars (send (car body) get-vars)] - [bindingss (send (send (car body) get-rhs) get-varss)] - [bodys (send (send (car body) get-rhs) get-rhss)]) - ;; split vars into varss: - (let ([varss (let loop ([bindingss bindingss][vars vars]) - (if (null? bindingss) - null - (let loop2 ([bindings (car bindingss)][vars vars][accum null]) - (if (null? bindings) - (cons (reverse accum) - (loop (cdr bindingss) vars)) - (loop2 (cdr bindings) (cdr vars) (cons (car vars) accum))))))] - [bindings (apply append bindingss)]) - (let ([env (map cons bindings - (map (lambda (var) - (make-object global% #f tables #f var)) - vars))]) - (set! body - (append - (map (lambda (vars body) - (make-object variable-def% - vars - (send body substitute env) - tables - src-stx)) - varss bodys) - (cdr body))))))) - (super deorganize)) - - (define/override (sexpr) - (with-syntax ([name name] - [init-req init-req] - [(body ...) (map get-sexpr body)] - [(et-body ...) (map get-sexpr et-body)] - [(req-prov ...) (map get-sexpr req-prov)]) - (with-syntax ([body #'(#%plain-module-begin - req-prov ... - body ... - et-body ...)]) - (syntax/loc src-stx - (module name init-req body))))) - (define/override (body-sexpr) - (list (sexpr))))) - - ;; requires and provides should really be ignored: - (define require/provide% - (class exp% - - (define/override (valueable?) #f) - (define/override (no-side-effect?) #f) - (super-instantiate ()))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Warning reporting - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (print-warning msg exp) - (let ([stx (send exp get-stx)]) - (when (syntax-source stx) - (fprintf (current-output-port) "~a:" (syntax-source stx)) - (cond - [(syntax-column stx) - (fprintf (current-output-port) "~a:~a:" - (syntax-line stx) - (syntax-column stx))] - [(syntax-position stx) - (fprintf (current-output-port) ":~a:" - (syntax-position stx))]) - (fprintf (current-output-port) " ")) - (fprintf (current-output-port) - "~a: ~.s\n" - msg - (syntax->datum (send exp sexpr))))) - - (define (warning msg exp) - ; (print-warning msg exp) - (void)) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Parser - ;; converts a syntax object to an exp% - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (parse-args env args) - (let-values ([(norm? ids) - (syntax-case args () - [id - (identifier? (syntax id)) - (values #f (list (syntax id)))] - [(id ...) - (values #t (syntax->list args))] - [_else (values #f - (let loop ([args args]) - (syntax-case args () - [id (identifier? args) (list args)] - [(id . rest) - (cons (syntax id) (loop (syntax rest)))])))])]) - (let ([bindings (map (lambda (id) (make-object binding% #t id)) ids)]) - (values - (append (map cons ids bindings) env) - bindings - norm?)))) - - (define (parse-let % rec? stx env loop) - (syntax-case (syntax-disarm stx code-insp) () - [(_ ([vars rhs] ...) . body) - (let* ([varses (syntax->list (syntax (vars ...)))] - [rhses (syntax->list (syntax (rhs ...)))] - [var-objses (map (lambda (vars) - (map (lambda (var) - (make-object binding% (not rec?) var)) - (syntax->list vars))) - varses)] - [body-env (append - (apply - append - (map (lambda (var-objs vars) - (map cons - (syntax->list vars) - var-objs)) - var-objses - varses)) - env)]) - (make-object % - var-objses - (map (lambda (rhs) - (loop rhs (if rec? body-env env))) - rhses) - (loop (syntax (begin . body)) body-env) - stx - (list stx)))])) - - (define (stx-bound-assq ssym l) - (ormap (lambda (p) - (and (bound-identifier=? ssym (car p)) - p)) - l)) - - (define (lookup-clone binding var env) - (let ([s (assq binding env)]) - (if s - (let ([b (cdr s)]) - (if (b . is-a? . binding%) - (make-object ref% b (send var get-stx) (send var get-cert-stxes)) - ;; it's a global%: - b)) - var))) - - (define dummy 'dummy) ; for #%variable-reference - - (define (make-parse top?) - (lambda (stx env trans? in-module? tables) - (kernel-syntax-case (syntax-disarm stx code-insp) trans? - [id - (identifier? stx) - (let ([a (stx-bound-assq stx env)]) - (if a - (make-object ref% (cdr a) stx) - (make-object global% trans? tables #f stx)))] - - [(#%top . id) - (make-object global% trans? tables #t (syntax id))] - - [(#%variable-reference . val) - (make-object constant% (#%variable-reference dummy) stx)] - - [(define-values names rhs) - (make-object variable-def% - (syntax->list (syntax names)) - (parse (syntax rhs) env #f in-module? tables) - tables - stx)] - - [(define-syntaxes names rhs) - (make-object syntax-def% - (syntax->list (syntax names)) - (parse (syntax rhs) env #t in-module? tables) - tables - stx)] - - [(define-values-for-syntax names rhs) - (make-object for-syntax-def% - (syntax->list (syntax names)) - (parse (syntax rhs) env #t in-module? tables) - tables - stx)] - - [(begin . exprs) - (make-object begin% - (map (lambda (e) ((if top? parse-top parse) e env trans? in-module? tables)) - (syntax->list (syntax exprs))) - stx)] - - [(begin0 expr . exprs) - (make-object begin0% - (parse (syntax expr) env trans? in-module? tables) - (parse (syntax (begin . exprs)) env trans? in-module? tables) - stx)] - - [(quote expr) - (make-object constant% (syntax->datum (syntax expr)) stx)] - - [(quote-syntax expr) - (make-object constant% (syntax expr) stx)] - - [(#%plain-lambda args . body) - (let-values ([(env args norm?) (parse-args env (syntax args))]) - (make-object lambda% - (list args) - (list norm?) - (list (parse (syntax (begin . body)) env trans? in-module? tables)) - stx))] - - [(case-lambda [args . body] ...) - (let-values ([(envs argses norm?s) - (let ([es+as+n?s - (map - (lambda (args) - (let-values ([(env args norm?) (parse-args env args)]) - (cons env (cons args norm?)))) - (syntax->list (syntax (args ...))))]) - (values - (map car es+as+n?s) - (map cadr es+as+n?s) - (map cddr es+as+n?s)))]) - (make-object lambda% - argses - norm?s - (map (lambda (env body) - (with-syntax ([body body]) - (parse (syntax (begin . body)) env trans? in-module? tables))) - envs - (syntax->list (syntax (body ...)))) - stx))] - - [(let-values . _) - (parse-let let% #f stx env - (lambda (b env) (parse b env trans? in-module? tables)))] - [(letrec-values . _) - (parse-let letrec% #t stx env - (lambda (b env) (parse b env trans? in-module? tables)))] - - [(set! var rhs) - (make-object set!% - (parse (syntax var) env trans? in-module? tables) - (parse (syntax rhs) env trans? in-module? tables) - stx)] - - [(if test then else) - (make-object if% - (parse (syntax test) env trans? in-module? tables) - (parse (syntax then) env trans? in-module? tables) - (parse (syntax else) env trans? in-module? tables) - stx)] - - [(with-continuation-mark k v body) - (make-object wcm% - (parse (syntax k) env trans? in-module? tables) - (parse (syntax v) env trans? in-module? tables) - (parse (syntax body) env trans? in-module? tables) - stx)] - - [(#%plain-app) - (make-object constant% null stx)] - - [(#%plain-app func . args) - (make-object app% - (parse (syntax func) env trans? in-module? tables) - (map (lambda (v) (parse v env trans? in-module? tables)) (syntax->list (syntax args))) - tables - stx)] - - [(module name init-require (#%plain-module-begin . body)) - (let* ([body (map (lambda (x) - (parse x env #f #t tables)) - (syntax->list (syntax body)))] - [et-body - (filter (lambda (x) (or (x . is-a? . syntax-def%) - (x . is-a? . for-syntax-def%))) - body)] - [rt-body - (filter (lambda (x) (not (or (x . is-a? . syntax-def%) - (x . is-a? . for-syntax-def%) - (x . is-a? . require/provide%)))) - body)] - [req-prov - (filter (lambda (x) (x . is-a? . require/provide%)) - body)]) - (make-object module% - rt-body - et-body - (syntax name) - (syntax init-require) - req-prov - tables - (syntax-case stx () - [(m n ir mb) #'mb]) - stx))] - - [(#%require . i) (make-object require/provide% stx)] - [(#%provide i ...) (make-object require/provide% stx)] - - [(#%expression e) - (parse (syntax e) env trans? in-module? tables)] - - [else - (error 'parse "unknown expression: ~a" (syntax->datum stx))]))) - - (define parse (make-parse #f)) - (define parse-top (make-parse #t)) - - (define (create-tables) - (make-tables (make-hasheq) (make-hasheq))) - - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Optimizer - ;; the driver function - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define optimize - (opt-lambda (e [for-mzc? #f]) - (let ([p (parse-top e null #f #f (create-tables))]) - (send p set-mutability) - (send p reorganize) - (send p set-known-values) - (let ([p (send p simplify (make-context 'all null))]) - (let ([v (get-sexpr (if for-mzc? - p - (send p deorganize)))]) - v))))) - - (provide optimize)) diff --git a/collects/compiler/to-core.rkt b/collects/compiler/to-core.rkt deleted file mode 100644 index 386e2baae0..0000000000 --- a/collects/compiler/to-core.rkt +++ /dev/null @@ -1,422 +0,0 @@ -(module to-core scheme/base - (require syntax/kerncase - syntax/stx - mzlib/list - syntax/boundmap - (for-syntax scheme/base)) - - (provide top-level-to-core) - - ;; `module', `require', and `require-for-syntax' declarations must - ;; not be embedded in a `begin' sequence. For `require' and - ;; `require-for-syntax', it's a timing issue. For `module', it's - ;; because the transformation can only handle a single `module' - ;; declaration. - (define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx - simple-constant? stop-properties) - (syntax-case stx (module begin) - [(module m lang (plain-module-begin decl ...)) - (let-values ([(expr new-decls magic-sym) - (lift-sequence (flatten-decls (syntax->list #'(decl ...))) - lookup-stx set-stx safe-vector-ref-stx extract-stx - #t - simple-constant? stop-properties)]) - (values (expand-syntax expr) - #`(module m lang (#%plain-module-begin #,@new-decls)) - magic-sym))] - [(begin decl ...) - (let-values ([(expr new-decls magic-sym) - (lift-sequence (flatten-decls (syntax->list #'(decl ...))) - lookup-stx set-stx safe-vector-ref-stx extract-stx - #f - simple-constant? stop-properties)]) - (values (expand-syntax expr) - #`(begin #,@new-decls) - magic-sym))] - [else - (top-level-to-core #`(begin #,stx) lookup-stx set-stx safe-vector-ref-stx extract-stx - simple-constant? stop-properties)])) - - (define (flatten-decls l) - (apply append - (map (lambda (stx) - (syntax-case stx (begin) - [(begin . e) - (flatten-decls (syntax->list #'e))] - [else (list stx)])) - l))) - - (define-struct lifted-info ([counter #:mutable] id-map slot-map)) - - (define (make-vars) - (make-lifted-info - 0 - (make-module-identifier-mapping) - (make-hash))) - - (define (is-id-ref? v) - (or (identifier? v) - (and (stx-pair? v) - (identifier? (stx-car v)) - (free-identifier=? #'#%top (stx-car v))))) - - (define (vars-sequence li) - (let loop ([i 0]) - (if (= i (lifted-info-counter li)) - null - (cons (let ([v (hash-ref (lifted-info-slot-map li) i)]) - (if (is-id-ref? v) - #`(#%variable-reference #,v) - v)) - (loop (add1 i)))))) - - (define (extract-vars li vec-id extract-stx) - (let loop ([i 0]) - (if (= i (lifted-info-counter li)) - null - (let ([v (hash-ref (lifted-info-slot-map li) i)]) - (if (is-id-ref? v) - (cons #`(#,extract-stx #,vec-id #,i) - (loop (add1 i))) - (loop (add1 i))))))) - - (define (is-run-time? stx) - (not (and (stx-pair? stx) - (or (free-identifier=? #'define-syntaxes (stx-car stx)) - (free-identifier=? #'define-values-for-syntax (stx-car stx)))))) - - (define (has-symbol? decl magic-sym table) - (cond - [(hash-ref table decl (lambda () #f)) - ;; cycle/graph - #f] - [else - (hash-set! table decl #t) - (cond - [(eq? magic-sym decl) - #t] - [(pair? decl) - (or (has-symbol? (car decl) magic-sym table) - (has-symbol? (cdr decl) magic-sym table))] - [(vector? decl) - (has-symbol? (vector->list decl) magic-sym table)] - [(box? decl) - (has-symbol? (unbox decl) magic-sym table)] - [else - #f])])) - - (define (generate-magic decls) - (let ([magic-sym (string->symbol (format "magic~a~a" - (current-seconds) - (current-milliseconds)))]) - (if (has-symbol? (map syntax->datum decls) magic-sym (make-hasheq)) - (generate-magic decls) - magic-sym))) - - (define (need-thunk? rhs) - (not (and (stx-pair? rhs) - (or (free-identifier=? #'lambda (stx-car rhs)) - (free-identifier=? #'case-lambda (stx-car rhs)))))) - - (define (lift-sequence decls lookup-stx set-stx safe-vector-ref-stx extract-stx - in-module? simple-constant? stop-properties) - (let ([ct-vars (make-vars)] - [rt-vars (make-vars)] - [compile-time (datum->syntax #f (gensym 'compile-time))] - [run-time (datum->syntax #f (gensym 'run-time))] - [magic-sym (generate-magic decls)] - [magic-indirect (gensym)]) - (let ([ct-converted - (map (lambda (stx) - #`(lambda () - #,(syntax-case stx () - [(def ids rhs) - (let ([cvted (convert #'rhs #t - lookup-stx set-stx safe-vector-ref-stx - compile-time ct-vars - in-module? - simple-constant? stop-properties)]) - (if (and (not in-module?) - (free-identifier=? #'def #'define-syntaxes)) - ;; Don't try to name macro procedures, because it - ;; inteferes with the 0-values hack at the top level - cvted - #`(let-values ([ids #,cvted]) - (#%plain-app values . ids))))]))) - (filter (lambda (x) (not (is-run-time? x))) decls))] - [rt-converted - (map (lambda (stx) - (syntax-case stx (define-values - #%provide - #%require) - [(#%provide . _) - #'void] - [(#%require . _) - #'void] - [(define-values ids rhs) - (let ([converted (convert #'rhs #f - lookup-stx set-stx safe-vector-ref-stx - run-time rt-vars - in-module? - simple-constant? stop-properties)]) - (if (need-thunk? #'rhs) - #`(lambda () #,converted) - #`(let-values ([ids #,converted]) - (#%plain-app values . ids))))] - [else - #`(lambda () - #,(convert stx #f - lookup-stx set-stx safe-vector-ref-stx - run-time rt-vars - in-module? - simple-constant? stop-properties))])) - (filter is-run-time? decls))] - [ct-rhs #`(#%plain-app - (let-values ([(magic) (#%plain-app car (#%plain-app cons '#,magic-sym 2))]) - (if (#%plain-app symbol? magic) - (#%plain-lambda (x) - (#%plain-app - vector - #,@(map (lambda (stx) - (syntax-case stx () - [(def (id) . _) - #'void] - [(def (id ...) . _) - (with-syntax ([(v ...) (map (lambda (x) #f) - (syntax->list #'(id ...)))]) - - #`(#%plain-lambda () (#%plain-app values v ...)))])) - (filter (lambda (x) (not (is-run-time? x))) decls)))) - (#%plain-app car magic))) - (#%plain-app vector #,@(vars-sequence ct-vars)))] - [rt-rhs #`(#%plain-app (#%plain-app cdr '#,magic-sym) - (#%plain-app vector #,@(vars-sequence rt-vars)))] - [just-one-ct? (>= 1 (apply + - (map (lambda (decl) - (syntax-case decl (define-syntaxes define-values-for-syntax) - [(define-values-for-syntax . _) 1] - [(define-syntaxes . _) 1] - [_else 0])) - decls)))] - [just-one-rt? (>= 1 (apply + - (map (lambda (decl) - (syntax-case decl (define-values #%provide #%require - define-syntaxes define-values-for-syntax) - [(#%provide . _) 0] - [(#%require . _) 0] - [(define-values-for-syntax . _) 0] - [(define-syntaxes . _) 0] - [_else 1])) - decls)))]) - (values - #`(#%plain-app - cons (#%plain-lambda (#,compile-time) - #,@(extract-vars ct-vars compile-time extract-stx) - (#%plain-app vector #,@ct-converted)) - (#%plain-lambda (#,run-time) - #,@(extract-vars rt-vars run-time extract-stx) - (#%plain-app vector #,@rt-converted))) - #`(;; Lift require and require-for-syntaxes to the front, so they're ready for - ;; variable references - #,@(filter (lambda (decl) - (syntax-case decl (#%require) - [(#%require . _) #t] - [_else #f])) - decls) - ;; Lift define-for-values binding to front, so they can be referenced - ;; in compile-time definition - #,@(let ([ids (apply - append - (map (lambda (stx) - (syntax-case stx (define-values-for-syntax) - [(define-values-for-syntax ids . _) - (syntax->list #'ids)] - [_else null])) - decls))]) - (if (null? ids) - null - #`((define-values-for-syntax #,ids - (values #,@(map (lambda (x) #'#f) ids)))))) - #,@(if just-one-ct? - null - #`((define-values-for-syntax (#,compile-time) #,ct-rhs))) - #,@(if just-one-rt? - null - #`((define-values (#,run-time) #,rt-rhs))) - #,@(let loop ([decls decls][ct-pos 0][rt-pos 0]) - (cond - [(null? decls) null] - [(is-run-time? (car decls)) - (cons (syntax-case (car decls) (define-values #%provide #%require) - [(#%provide . _) - (car decls)] - [(#%require . _) - #'(#%plain-app void)] - [(define-values (id ...) rhs) - #`(define-values (id ...) - #,(let ([lookup #`(#%plain-app vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos)]) - (if (need-thunk? #'rhs) - #`(#%plain-app #,lookup) - lookup)))] - [else - #`(#%plain-app (#%plain-app vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos))]) - (loop (cdr decls) ct-pos (add1 rt-pos)))] - [else - (cons (syntax-case (car decls) (define-syntaxes define-values-for-syntax) - [(define-syntaxes (id ...) . rhs) - #`(define-syntaxes (id ...) - (#%plain-app (#%plain-app vector-ref #,(if just-one-ct? ct-rhs compile-time) #,ct-pos)))] - [(define-values-for-syntax (id ...) . rhs) - #`(define-values-for-syntax () - (begin - (set!-values (id ...) - (#%plain-app - (#%plain-app vector-ref #,(if just-one-ct? ct-rhs compile-time) - #,ct-pos))) - (#%plain-app values)))]) - (loop (cdr decls) (add1 ct-pos) rt-pos))]))) - magic-sym)))) - - (define (local-identifier? stx trans?) - (eq? 'lexical ((if trans? - identifier-transformer-binding - identifier-binding) - stx))) - - (define (simple-identifier stx trans?) - (let ([b ((if trans? - identifier-transformer-binding - identifier-binding) - stx)]) - (cond - [(eq? b 'lexical) stx] - [(and (pair? b) - (eq? '#%kernel (car b))) - ;; Generate a syntax object that has the right run-time binding: - (datum->syntax #'here (cadr b) stx stx)] - [else #f]))) - - (define (add-literal/pos stx li) - (let ([pos (lifted-info-counter li)]) - (hash-set! (lifted-info-slot-map li) pos stx) - (set-lifted-info-counter! li (add1 pos)) - pos)) - - (define (add-literal stx li safe-vector-ref-stx id) - #`(#,safe-vector-ref-stx #,id #,(add-literal/pos stx li))) - - (define (add-identifier/pos stx li trans?) - (if (identifier? stx) - ;; id : - (or (module-identifier-mapping-get (lifted-info-id-map li) - stx - (lambda () #f)) - (let ([pos (add-literal/pos (if (not ((if trans? - identifier-transformer-binding - identifier-binding) - stx)) - #`(#%top . #,stx) - stx) - li)]) - (module-identifier-mapping-put! (lifted-info-id-map li) stx pos) - pos)) - ;; (#%top . id) : - (add-literal/pos stx li))) - - (define (add-identifier stx li trans? lookup-stx id) - #`(#,lookup-stx #,id #,(add-identifier/pos stx li trans?))) - - (define-syntax quasisyntax/loc+props - (syntax-rules () - [(_ stx e) (let ([old-s stx] - [new-s (quasisyntax e)]) - (datum->syntax new-s - (syntax-e new-s) - old-s - old-s))])) - (define code-insp (current-code-inspector)) - - (define (convert stx trans? lookup-stx set-stx safe-vector-ref-stx id li in-module? - simple-constant? stop-properties) - (define (loop stx) - (if (ormap (lambda (prop) - (syntax-property stx prop)) - stop-properties) - stx - (kernel-syntax-case (syntax-disarm stx code-insp) trans? - [_ - (identifier? stx) - (or (simple-identifier stx trans?) - (add-identifier stx li trans? lookup-stx id))] - [(#%provide . _) - stx] - [(#%plain-lambda formals e ...) - (quasisyntax/loc+props - stx - (#%plain-lambda formals #,@(map loop (syntax->list #'(e ...)))))] - [(case-lambda [formals e ...] ...) - (with-syntax ([((e ...) ...) - (map (lambda (l) - (map loop (syntax->list l))) - (syntax->list #'((e ...) ...)))]) - (quasisyntax/loc+props - stx - (case-lambda [formals e ...] ...)))] - [(let-values ([(id ...) rhs] ...) e ...) - (with-syntax ([(rhs ...) - (map loop (syntax->list #'(rhs ...)))]) - (quasisyntax/loc+props - stx - (let-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))] - [(letrec-values ([(id ...) rhs] ...) e ...) - (with-syntax ([(rhs ...) - (map loop (syntax->list #'(rhs ...)))]) - (quasisyntax/loc+props - stx - (letrec-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))] - [(quote e) - (if (simple-constant? #'e) - #'(quote e) - (add-literal stx li safe-vector-ref-stx id))] - [(quote-syntax e) - (add-literal stx li safe-vector-ref-stx id)] - [(#%top . tid) - (let ([target (let ([b ((if trans? - identifier-transformer-binding - identifier-binding) - #'tid)]) - (if (or (eq? b 'lexical) - (and (not in-module?) - b)) - #`(#%top . tid) - #'tid))]) - (add-identifier target li trans? lookup-stx id))] - [(set! x e) - (if (local-identifier? #'x trans?) - (quasisyntax/loc+props stx (set! x #,(loop #'e))) - (quasisyntax/loc+props - stx - (#,set-stx #,id #,(add-identifier/pos #'x li trans?) #,(loop #'e))))] - [(#%variable-reference e) - (add-literal stx li safe-vector-ref-stx id)] - [(if e ...) - (quasisyntax/loc+props - stx - (if #,@(map loop (syntax->list #'(e ...)))))] - [(begin e ...) - (quasisyntax/loc+props - stx - (begin #,@(map loop (syntax->list #'(e ...)))))] - [(begin0 e ...) - (quasisyntax/loc+props - stx - (begin0 #,@(map loop (syntax->list #'(e ...)))))] - [(with-continuation-mark e ...) - (quasisyntax/loc+props - stx - (with-continuation-mark #,@(map loop (syntax->list #'(e ...)))))] - [(#%plain-app e ...) - (quasisyntax/loc+props - stx - (#%plain-app #,@(map loop (syntax->list #'(e ...)))))]))) - (loop stx)))