diff --git a/CHANGELOG.md b/CHANGELOG.md index 754c2b57..4fd43223 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,17 @@ ## 0.9.4 - TBD +Compiler Optimizations + +- Optimize recursive functions by expressing the recursive calls using C iteration. This optimization is more effective when combined with the others listed below as they collectively increase the chances that a higher-level Scheme loop may be compiled down to a single C function which can then be "called" repeatedly using a `while` loop which is more efficient at a low level than repeated calls to C functions. +- Combine lambda functions that are only called for side effects. +- Improve inlining of primitives that work with immutable objects. +- Eliminate functions that are only used to define local variables. + +Features + +- Added a new feature `program` to `cond-expand` that is only defined when compiling a program. This allows, for example, a `.scm` file to contain a section of code that can be used to run unit tests when the file is compiled as a program. The same file can then be used in production to import code into a library. This is similar to using the `__main__` scope in a python program. + Bug Fixes - Prevent GC segmentation fault on ARM platforms (Raspberry Pi 2). diff --git a/Makefile b/Makefile index 8b8fe74b..597b82e6 100644 --- a/Makefile +++ b/Makefile @@ -224,6 +224,7 @@ bootstrap : icyc libs cp tests/unit-tests.scm $(BOOTSTRAP_DIR) cp scheme/cyclone/ast.c $(BOOTSTRAP_DIR)/scheme/cyclone cp scheme/cyclone/cps-optimizations.c $(BOOTSTRAP_DIR)/scheme/cyclone + cp scheme/cyclone/cps-opt-local-var-redux.scm $(BOOTSTRAP_DIR)/scheme/cyclone cp scheme/cyclone/libraries.c $(BOOTSTRAP_DIR)/scheme/cyclone cp scheme/cyclone/macros.c $(BOOTSTRAP_DIR)/scheme/cyclone cp scheme/cyclone/match.c $(BOOTSTRAP_DIR)/scheme/cyclone diff --git a/Makefile.config b/Makefile.config index 390eb080..27d62434 100644 --- a/Makefile.config +++ b/Makefile.config @@ -7,6 +7,9 @@ CYC_PROFILING ?= #CYC_PROFILING ?= -pg +CYC_GCC_OPT_FLAGS ?= -O2 +#CYC_GCC_OPT_FLAGS ?= -g + OS ?= $(shell uname) CC ?= cc @@ -17,8 +20,8 @@ LIBS += -ldl endif # Compiler options -CFLAGS ?= $(CYC_PROFILING) -O2 -fPIC -Wall -Iinclude -COMP_CFLAGS ?= $(CYC_PROFILING) -O2 -fPIC -Wall -I$(PREFIX)/include -L$(PREFIX)/lib +CFLAGS ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -Iinclude +COMP_CFLAGS ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -I$(PREFIX)/include -L$(PREFIX)/lib # Use these lines instead for debugging or profiling #CFLAGS = -g -Wall #CFLAGS = -g -pg -Wall diff --git a/cyclone.scm b/cyclone.scm index 9e4cd7bd..0a8f34a5 100644 --- a/cyclone.scm +++ b/cyclone.scm @@ -424,6 +424,10 @@ (trace:info (ast:ast->pp-sexp input-program)) ) + (set! input-program (opt:local-var-reduction input-program)) + (trace:info "---------------- after local variable reduction") + (trace:info (ast:ast->pp-sexp input-program)) + ;; TODO: could do this, but it seems like a bit of a band-aid... (set! input-program (opt:renumber-lambdas! input-program)) (trace:info "---------------- after renumber lambdas") @@ -545,10 +549,13 @@ (in-prog-raw (read-file in-file)) (program? (not (library? (car in-prog-raw)))) (in-prog - (if program? - in-prog-raw + (cond + (program? + (Cyc-add-feature! 'program) ;; Load special feature + in-prog-raw) + (else ;; Account for any cond-expand declarations in the library - (list (lib:cond-expand (car in-prog-raw) expander)))) + (list (lib:cond-expand (car in-prog-raw) expander))))) ;; TODO: expand in-prog, if a library, using lib:cond-expand. (OK, this works now) ;; TODO: will also need to do below in lib:get-all-import-deps, after reading each library (program:imports/code (if program? (import-reduction in-prog expander) '())) diff --git a/docs/api/srfi/18.md b/docs/api/srfi/18.md index 4a48fec2..8800c7b3 100644 --- a/docs/api/srfi/18.md +++ b/docs/api/srfi/18.md @@ -4,12 +4,6 @@ The `(srfi 18)` library provides multithreading support. See the [Multithreading support SRFI documentation](http://srfi.schemers.org/srfi-18/srfi-18.html) for more information. -## Limitations - -Currently, ``thread-join!`` is not provided. While this is not an essential -primitive and can be worked around, code that relies on ``thread-join!`` being -present in this implementation will fail to compile. - - [`thread?`](#thread) - [`make-thread`](#make-thread) - [`thread-name`](#thread-name) diff --git a/gc.c b/gc.c index f1c55afc..b935c124 100644 --- a/gc.c +++ b/gc.c @@ -864,10 +864,11 @@ char *gc_copy_obj(object dest, char *obj, gc_thread_data * thd) bignum_type *hp = dest; mark(hp) = thd->gc_alloc_color; type_of(hp) = bignum_tag; - ((bignum_type *)hp)->bn.used = ((bignum_type *)obj)->bn.used; - ((bignum_type *)hp)->bn.alloc = ((bignum_type *)obj)->bn.alloc; - ((bignum_type *)hp)->bn.sign = ((bignum_type *)obj)->bn.sign; - ((bignum_type *)hp)->bn.dp = ((bignum_type *)obj)->bn.dp; + // Bignums are always heap-allocated so there is nothing to copy + //((bignum_type *)hp)->bn.used = ((bignum_type *)obj)->bn.used; + //((bignum_type *)hp)->bn.alloc = ((bignum_type *)obj)->bn.alloc; + //((bignum_type *)hp)->bn.sign = ((bignum_type *)obj)->bn.sign; + //((bignum_type *)hp)->bn.dp = ((bignum_type *)obj)->bn.dp; return (char *)hp; } case cvar_tag:{ @@ -1282,8 +1283,9 @@ void *gc_alloc_bignum(gc_thread_data *data) int heap_grown, result; bignum_type *bn; bignum_type tmp; - tmp.hdr.mark = gc_color_red; - tmp.hdr.grayed = 0; + // No need to do this since tmp is always local + //tmp.hdr.mark = gc_color_red; + //tmp.hdr.grayed = 0; tmp.tag = bignum_tag; bn = gc_alloc(((gc_thread_data *)data)->heap, sizeof(bignum_type), (char *)(&tmp), (gc_thread_data *)data, &heap_grown); diff --git a/include/cyclone/types.h b/include/cyclone/types.h index 70f0b672..7d882741 100644 --- a/include/cyclone/types.h +++ b/include/cyclone/types.h @@ -748,6 +748,13 @@ typedef struct { n.tag = complex_num_tag; \ n.value = (r + (i * I)); +#define alloca_complex_num(n,r,i) \ + complex_num_type *n = alloca(sizeof(complex_num_type)); \ + n->hdr.mark = gc_color_red; \ + n->hdr.grayed = 0; \ + n->tag = complex_num_tag; \ + n->value = (r + (i * I)); + /** Assign given complex value to the given complex number object pointer */ #define assign_complex_num(pobj,v) \ ((complex_num_type *)pobj)->hdr.mark = gc_color_red; \ @@ -772,6 +779,13 @@ typedef struct { n.tag = double_tag; \ n.value = v; +#define alloca_double(n,v) \ + double_type *n = alloca(sizeof(double_type)); \ + n->hdr.mark = gc_color_red; \ + n->hdr.grayed = 0; \ + n->tag = double_tag; \ + n->value = v; + /** Assign given double value to the given double object pointer */ #define assign_double(pobj,v) \ ((double_type *)pobj)->hdr.mark = gc_color_red; \ @@ -1044,6 +1058,14 @@ typedef vector_type *vector; v.num_elements = 0; \ v.elements = NULL; +#define alloca_empty_vector(v) \ + vector_type *v = alloca(sizeof(vector_type)); \ + v->hdr.mark = gc_color_red; \ + v->hdr.grayed = 0; \ + v->tag = vector_tag; \ + v->num_elements = 0; \ + v->elements = NULL; + /** * @brief Bytevector type * @@ -1067,6 +1089,14 @@ typedef bytevector_type *bytevector; v.len = 0; \ v.data = NULL; +#define alloca_empty_bytevector(v) \ + bytevector_type *v = alloca(sizeof(bytevector_type)); \ + v->hdr.mark = gc_color_red; \ + v->hdr.grayed = 0; \ + v->tag = bytevector_tag; \ + v->len = 0; \ + v->data = NULL; + /** * @brief The pair (cons) type. * @@ -1128,11 +1158,30 @@ typedef pair_type *pair; make_pair(l##__2, a2, &l##__3); \ make_pair(l, a1, &l##__2); +#define alloca_list_1(l, a1) \ + alloca_pair(l, a1, NULL); + +#define alloca_list_2(l, a1, a2) \ + alloca_pair(l##__2, a2, NULL); \ + alloca_pair(l, a1, l##__2); + +#define alloca_list_3(l, a1, a2, a3) \ + alloca_pair(l##__3, a3, NULL); \ + alloca_pair(l##__2, a2, l##__3); \ + alloca_pair(l, a1, l##__2); + +#define alloca_list_4(l, a1, a2, a3, a4) \ + alloca_pair(l##__4, a4, NULL); \ + alloca_pair(l##__3, a3, l##__4); \ + alloca_pair(l##__2, a2, l##__3); \ + alloca_pair(l, a1, l##__2); + /** * Create a pair with a single value. * This is useful to create an object that can be modified. */ #define make_cell(n,a) make_pair(n,a,NULL); +#define alloca_cell(n,a) alloca_pair(n,a,NULL); /** * \defgroup objects_unsafe_cxr Unsafe pair access macros diff --git a/scheme/base.sld b/scheme/base.sld index 5e0be0c8..38a4da51 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -148,6 +148,7 @@ open-input-bytevector open-output-bytevector features + Cyc-add-feature! Cyc-version any every @@ -237,10 +238,17 @@ (cons (string->symbol (string-append "version-" *version-number*)) - '(r7rs - ieee-float - full-unicode - posix)))) + *other-features*))) + + (define *other-features* + '(r7rs + ieee-float + full-unicode + posix)) + + ;; Designed for internal use only, don't call this in user code!! + (define (Cyc-add-feature! sym) + (set! *other-features* (cons sym *other-features*))) (define (Cyc-version) *version-number*) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index f7a823bc..15ddc2e7 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -31,6 +31,8 @@ emits emits* emit-newline + ;; Helpers + self-closure-call? ) (inline global-not-lambda? @@ -127,6 +129,7 @@ (vector-ref *c-call-arity* arity)) (emit (c-macro-closcall arity)) (emit (c-macro-return-closcall arity)) + (emit (c-macro-continue-or-gc arity)) (emit (c-macro-return-direct arity)) (emit (c-macro-return-direct-with-closure arity)) (when *optimize-well-known-lambdas* @@ -154,6 +157,25 @@ " } \\\n" "}\n"))) +;; Generate macros invoke a GC if necessary, otherwise do nothing. +;; This will be used to support C iteration. +(define (c-macro-continue-or-gc num-args) + (let ((args (c-macro-n-prefix num-args ",a")) + (n (number->string num-args)) + (arry-assign (c-macro-array-assign num-args "buf" "a"))) + (string-append + ;"/* Check for GC, then call given continuation closure */\n" + "#define continue_or_gc" n "(td, clo" args ") { \\\n" + " char *top = alloca(sizeof(char)); \\\n" ;; TODO: consider speeding up by passing in a var already allocated + " if (stack_overflow(top, (((gc_thread_data *)data)->stack_limit))) { \\\n" + " object buf[" n "]; " arry-assign "\\\n" + " GC(td, clo, buf, " n "); \\\n" + " return; \\\n" + " } else {\\\n" + " continue;\\\n" + " } \\\n" + "}\n"))) + ;; Generate macros to directly call a lambda function (define (c-macro-return-direct num-args) (let ((args (c-macro-n-prefix num-args ",a")) @@ -367,12 +389,12 @@ trace cps?)) ; Core forms: - ((const? exp) (c-compile-const exp)) + ((const? exp) (c-compile-const exp (alloca? ast-id))) ((prim? exp) ;; TODO: this needs to be more refined, probably w/a lookup table (c-code (string-append "primitive_" (mangle exp)))) ((ref? exp) (c-compile-ref exp)) - ((quote? exp) (c-compile-quote exp)) + ((quote? exp) (c-compile-quote exp (alloca? ast-id))) ((if? exp) (c-compile-if exp append-preamble cont ast-id trace cps?)) ; IR (2): @@ -388,17 +410,20 @@ ((app? exp) (c-compile-app exp append-preamble cont ast-id trace cps?)) (else (error "unknown exp in c-compile-exp: " exp)))) -(define (c-compile-quote qexp) +(define (c-compile-quote qexp use-alloca) (let ((exp (cadr qexp))) - (c-compile-scalars exp))) + (c-compile-scalars exp use-alloca))) -(define (c-compile-scalars args) +(define (c-compile-scalars args use-alloca) (letrec ( + (addr-op (if use-alloca "" "&")) + ;(deref-op (if use-alloca "->" ".")) + (c-make-macro (if use-alloca "alloca_pair" "make_pair")) (num-args 0) (create-cons (lambda (cvar a b) (c-code/vars - (string-append "make_pair(" cvar "," (c:body a) "," (c:body b) ");") + (string-append c-make-macro "(" cvar "," (c:body a) "," (c:body b) ");") (append (c:allocs a) (c:allocs b)))) ) (_c-compile-scalars @@ -407,16 +432,16 @@ ((null? args) (c-code "NULL")) ((not (pair? args)) - (c-compile-const args)) + (c-compile-const args use-alloca)) (else (let* ((cvar-name (mangle (gensym 'c))) (cell (create-cons cvar-name - (c-compile-const (car args)) + (c-compile-const (car args) use-alloca) (_c-compile-scalars (cdr args))))) (set! num-args (+ 1 num-args)) (c-code/vars - (string-append "&" cvar-name) + (string-append addr-op cvar-name) (append (c:allocs cell) (list (c:body cell)))))))))) @@ -424,15 +449,18 @@ (_c-compile-scalars args) num-args))) -(define (c-compile-vector exp) +(define (c-compile-vector exp use-alloca) (letrec ((cvar-name (mangle (gensym 'vec))) (len (vector-length exp)) + (addr-op (if use-alloca "" "&")) + (deref-op (if use-alloca "->" ".")) + (c-make-macro (if use-alloca "alloca_empty_vector" "make_empty_vector")) ;; Generate code for each member of the vector (loop (lambda (i code) (if (= i len) code - (let ((idx-code (c-compile-const (vector-ref exp i)))) + (let ((idx-code (c-compile-const (vector-ref exp i) use-alloca))) (loop (+ i 1) (c-code/vars @@ -444,32 +472,35 @@ (c:allocs idx-code) ;; Member alloc at index i (list ;; Assign this member to vector (string-append - cvar-name ".elements[" (number->string i) "] = " + cvar-name deref-op "elements[" (number->string i) "] = " (c:body idx-code) ";"))))))))) ) (cond ((zero? len) (c-code/vars - (string-append "&" cvar-name) ; Code is just the variable name + (string-append addr-op cvar-name) ; Code is just the variable name (list ; Allocate empty vector (string-append - "make_empty_vector(" cvar-name ");")))) + c-make-macro "(" cvar-name ");")))) (else (let ((code (c-code/vars - (string-append "&" cvar-name) ; Code body is just var name + (string-append addr-op cvar-name) ; Code body is just var name (list ; Allocate the vector (string-append - "make_empty_vector(" cvar-name ");" - cvar-name ".num_elements = " (number->string len) ";" - cvar-name ".elements = (object *)alloca(sizeof(object) * " + c-make-macro "(" cvar-name ");" + cvar-name deref-op "num_elements = " (number->string len) ";" + cvar-name deref-op "elements = (object *)alloca(sizeof(object) * " (number->string len) ");"))))) (loop 0 code)))))) -(define (c-compile-bytevector exp) +(define (c-compile-bytevector exp use-alloca) (letrec ((cvar-name (mangle (gensym 'vec))) (len (bytevector-length exp)) + (addr-op (if use-alloca "" "&")) + (deref-op (if use-alloca "->" ".")) + (c-make-macro (if use-alloca "alloca_empty_bytevector" "make_empty_bytevector")) ;; Generate code for each member of the vector (loop (lambda (i code) @@ -486,7 +517,7 @@ (c:allocs code) ;; Vector alloc (list ;; Assign this member to vector (string-append - cvar-name ".data[" (number->string i) "] = (unsigned char)" + cvar-name deref-op "data[" (number->string i) "] = (unsigned char)" byte-val ";")))) )))) @@ -495,37 +526,77 @@ (cond ((zero? len) (c-code/vars - (string-append "&" cvar-name) ; Code is just the variable name + (string-append addr-op cvar-name) ; Code is just the variable name (list ; Allocate empty vector (string-append - "make_empty_bytevector(" cvar-name ");")))) + c-make-macro "(" cvar-name ");")))) (else (let ((code (c-code/vars - (string-append "&" cvar-name) ; Code body is just var name + (string-append addr-op cvar-name) ; Code body is just var name (list ; Allocate the vector (string-append - "make_empty_bytevector(" cvar-name ");" - cvar-name ".len = " (number->string len) ";" - cvar-name ".data = alloca(sizeof(char) * " + c-make-macro "(" cvar-name ");" + cvar-name deref-op "len = " (number->string len) ";" + cvar-name deref-op "data = alloca(sizeof(char) * " (number->string len) ");"))))) (loop 0 code)))))) +(define (c-compile-string exp use-alloca) + (let ((cvar-name (mangle (gensym 'c)))) + (cond + (use-alloca + (let ((tmp-name (mangle (gensym 'tmp))) + (blen (number->string (string-byte-length exp))) + ) + (c-code/vars + (string-append "" cvar-name) ; Code is just the variable name + (list ; Allocate integer on the C stack + (string-append + "object " cvar-name ";\n " + "alloc_string(data," + cvar-name + ", " + blen + ", " + (number->string (string-length exp)) + ");\n" + "char " tmp-name "[] = " + (->cstr exp) + ";\n" + "memcpy(((string_type *)" cvar-name ")->str, " tmp-name "," blen ");\n" + "((string_type *)" cvar-name ")->str[" blen "] = '\\0';" + ))))) + (else + (c-code/vars + (string-append "&" cvar-name) ; Code is just the variable name + (list ; Allocate integer on the C stack + (string-append + "make_utf8_string_with_len(" + cvar-name + ", " + (->cstr exp) + ", " + (number->string (string-byte-length exp)) + ", " + (number->string (string-length exp)) + ");"))))))) + ;; c-compile-const : const-exp -> c-pair ;; ;; Typically this function is used to compile constant values such as ;; a single number, boolean, etc. However, it can be passed a quoted ;; item such as a list, to compile as a literal. -(define (c-compile-const exp) +(define (c-compile-const exp use-alloca) (cond ((null? exp) (c-code "NULL")) ((pair? exp) - (c-compile-scalars exp)) + (c-compile-scalars exp use-alloca)) ((vector? exp) - (c-compile-vector exp)) + (c-compile-vector exp use-alloca)) ((bytevector? exp) - (c-compile-bytevector exp)) + (c-compile-bytevector exp use-alloca)) ((bignum? exp) (let ((cvar-name (mangle (gensym 'c))) (num2str (cond @@ -551,19 +622,15 @@ (number->string n))))) (rnum (num2str (real-part exp))) (inum (num2str (imag-part exp))) + (addr-op (if use-alloca "" "&")) + (c-make-macro (if use-alloca "alloca_complex_num" "make_complex_num")) ) (c-code/vars - (string-append "&" cvar-name) ; Code is just the variable name + (string-append addr-op cvar-name) ; Code is just the variable name (list ; Allocate on the C stack (string-append - "make_complex_num(" cvar-name ", " rnum ", " inum ");"))))) + c-make-macro "(" cvar-name ", " rnum ", " inum ");"))))) ((integer? exp) -; (let ((cvar-name (mangle (gensym 'c)))) -; (c-code/vars -; (string-append "&" cvar-name) ; Code is just the variable name -; (list ; Allocate integer on the C stack -; (string-append -; "make_int(" cvar-name ", " (number->string exp) ");"))))) (c-code (string-append "obj_int2obj(" (number->string exp) ")"))) ((real? exp) @@ -574,12 +641,15 @@ ((nan? exp) "(0./0.)") ((infinite? exp) "(1./0.)") (else - (number->string exp))))) + (number->string exp)))) + (addr-op (if use-alloca "" "&")) + (c-make-macro (if use-alloca "alloca_double" "make_double")) + ) (c-code/vars - (string-append "&" cvar-name) ; Code is just the variable name + (string-append addr-op cvar-name) ; Code is just the variable name (list ; Allocate on the C stack (string-append - "make_double(" cvar-name ", " num2str ");"))))) + c-make-macro "(" cvar-name ", " num2str ");"))))) ((boolean? exp) (c-code (string-append (if exp "boolean_t" "boolean_f")))) @@ -587,20 +657,7 @@ (c-code (string-append "obj_char2obj(" (number->string (char->integer exp)) ")"))) ((string? exp) - (let ((cvar-name (mangle (gensym 'c)))) - (c-code/vars - (string-append "&" cvar-name) ; Code is just the variable name - (list ; Allocate integer on the C stack - (string-append - "make_utf8_string_with_len(" - cvar-name - ", " - (->cstr exp) - ", " - (number->string (string-byte-length exp)) - ", " - (number->string (string-length exp)) - ");"))))) + (c-compile-string exp use-alloca)) ;TODO: not good enough, need to store new symbols in a table so they can ;be inserted into the C program ((symbol? exp) @@ -629,16 +686,29 @@ (and (> len 0) (equal? end (substring str (- len 1) len))))) +(define *use-alloca* #f) + +(define (set-use-alloca! v) + (set! *use-alloca* v)) + +;; Use alloca() for stack allocations? +(define (alloca? ast-id) + (or *use-alloca* + (let ((adbf:fnc (adb:get/default ast-id #f))) + (and adbf:fnc + (adbf:calls-self? adbf:fnc))))) + ;; c-compile-prim : prim-exp -> string -> string -(define (c-compile-prim p cont) - (let* ((c-func +(define (c-compile-prim p cont ast-id) + (let* ((use-alloca? (alloca? ast-id)) + (c-func (if (prim:udf? p) (string-append "((inline_function_type) ((closure)" (cgen:mangle-global p) ")->fn)") - (prim->c-func p))) + (prim->c-func p use-alloca?))) ;; Following closure defs are only used for prim:cont? to ;; create a new closure for the continuation, if needed. ;; @@ -661,12 +731,17 @@ (else ""))) (tdata-comma (if (> (string-length tdata) 0) "," "")) (tptr-type (prim/c-var-pointer p)) - (tptr-comma (if tptr-type ",&" "")) + (tptr-comma + (cond + ((and tptr-type use-alloca?) ",") + (tptr-type ",&") + (else ""))) (tptr (cond (tptr-type (mangle (gensym 'local))) (else ""))) (tptr-decl (cond + ((and tptr-type use-alloca?) (string-append "object " tptr " = alloca(sizeof(" tptr-type ")); ")) (tptr-type (string-append tptr-type " " tptr "; ")) (else ""))) (c-var-assign @@ -676,7 +751,9 @@ (string-append (if (or (prim:cont? p) (equal? (prim/c-var-assign p) "object") - (prim/c-var-pointer p)) ;; Assume returns object + (prim/c-var-pointer p) ;; Assume returns object + (prim->c-func-uses-alloca? p use-alloca?) + ) "" "&") cv-name) @@ -719,7 +796,8 @@ ;; (let ((cv-name (mangle (gensym 'c)))) (c-code/vars - (if (prim:allocates-object? p) + (if (or (prim:allocates-object? p use-alloca?) + (prim->c-func-uses-alloca? p use-alloca?)) cv-name ;; Already a pointer (string-append "&" cv-name)) ;; Point to data (list @@ -730,6 +808,29 @@ ;; END primitives ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; self-closure-call? :: sexp -> symbol -> integer -> boolean +;; +;; Determine whether we have a closure call of the form: +;; (%closure-ref +;; (cell-get (%closure-ref self$249 1)) +;; 0) +;; +;; Parameters: +;; ast - S-expression to analyze +;; self - Identifier for the function's "self" closure +;; closure-index - Index of the function's "self" closure in outer closure +(define (self-closure-call? ast self closure-index) + ;(trace:error `(JAE self-closure-call? ,ast ,self ,closure-index)) + (and-let* (((tagged-list? '%closure-ref ast)) + ((tagged-list? 'cell-get (cadr ast))) + (inner-cref (cadadr ast)) + ((tagged-list? '%closure-ref inner-cref)) + (equal? self (cadr inner-cref)) + ((equal? 0 (caddr ast))) + ((equal? closure-index (caddr inner-cref))) + ) + #t)) + ; c-compile-ref : ref-exp -> string (define (c-compile-ref exp) (c-code @@ -740,6 +841,7 @@ ; c-compile-args : list[exp] (string -> void) -> string (define (c-compile-args args append-preamble prefix cont ast-id trace cps?) (letrec ((num-args 0) + (cp-lis '()) (_c-compile-args (lambda (args append-preamble prefix cont) (cond @@ -747,17 +849,26 @@ (c-code "")) (else ;(trace:debug `(c-compile-args ,(car args))) - (set! num-args (+ 1 num-args)) - (c:append/prefix - prefix - (c-compile-exp (car args) - append-preamble cont ast-id trace cps?) - (_c-compile-args (cdr args) - append-preamble ", " cont))))))) - (c:tuple/args - (_c-compile-args args - append-preamble prefix cont) - num-args))) + (let ((cp (c-compile-exp (car args) + append-preamble cont ast-id trace cps?))) + (set! num-args (+ 1 num-args)) + (set! cp-lis (cons cp cp-lis)) + (c:append/prefix + prefix + cp + (_c-compile-args (cdr args) + append-preamble ", " cont)))))))) + ;; Pass back a container with: + ;; - Appened body (string) + ;; - Appended allocs (string) + ;; - Number of args (numeric) + ;; - Remaining args - Actual CP objects (lists of body/alloc) from above + (append + (c:tuple/args + (_c-compile-args args + append-preamble prefix cont) + num-args) + (reverse cp-lis)))) ;; c-compile-app : app-exp (string -> void) -> string (define (c-compile-app exp append-preamble cont ast-id trace cps?) @@ -839,12 +950,12 @@ "\n" cgen-body ;; TODO: (c:body cgen) ;; TODO: re-assign function args, longer-term using temp variables "\n" - "goto loop;"))) + "continue;"))) ) ((prim? fun) (let* ((c-fun - (c-compile-prim fun cont)) + (c-compile-prim fun cont ast-id)) (c-args (c-compile-args args append-preamble "" "" ast-id trace cps?)) (num-args (length args)) @@ -904,6 +1015,7 @@ (let* ((cfun (c-compile-args (list (car args)) append-preamble " " cont ast-id trace cps?)) (this-cont (c:body cfun)) (cargs (c-compile-args (cdr args) append-preamble " " this-cont ast-id trace cps?)) + (raw-cargs (cdddr cargs)) ;; Same as above but with lists instead of appended strings (num-cargs (c:num-args cargs))) (cond ((not cps?) @@ -919,8 +1031,52 @@ (set-c-call-arity! (c:num-args cargs)) (let* ((wkf (well-known-lambda (car args))) (fnc (if wkf (adb:get/default (ast:lambda-id wkf) #f) #f)) + (adbf:fnc (adb:get/default ast-id #f)) ) (cond + ;; Handle recursive calls via iteration, if possible + ((and adbf:fnc + ;#f ;; TODO: temporarily disabled + (adbf:calls-self? adbf:fnc) + (self-closure-call? + fun + (car (adbf:all-params adbf:fnc)) + (adbf:self-closure-index adbf:fnc) + ) + ) + (let* ((params (map mangle (cdr (adbf:all-params adbf:fnc)))) + (args (map car raw-cargs)) + (reassignments + ;; TODO: may need to detect cases where an arg is reassigned before + ;; another one is assigned to that arg's old value, for example: + ;; a = 1, b = 2, c = a + ;; In this case the code would need to assign to a temporary variable + (apply string-append + (map + (lambda (param arg) + (cond + ((equal? param arg) "") ;; No need to reassign + (else + (string-append + param " = " arg ";\n")))) + params + args)))) +;(trace:error `(JAE ,fun ,ast-id ,params ,args (c:num-args cargs))) + (c-code + (string-append + (c:allocs->str (c:allocs cfun) "\n") + (c:allocs->str (c:allocs cargs) "\n") + reassignments + ;; TODO: consider passing in a "top" instead of always calling alloca in macro below: + "continue_or_gc" (number->string (c:num-args cargs)) + "(data," + (mangle (car (adbf:all-params adbf:fnc))) ;; Call back into self after GC + (if (> (c:num-args cargs) 0) "," "") + (string-join params ", ") + ");" + ))) + ) + ((and wkf fnc *optimize-well-known-lambdas* (adbf:well-known fnc) ;; not really needed @@ -1068,6 +1224,40 @@ (c-code "") args))) exps)) + ((equal? 'Cyc-local-set! fun) + ;:(trace:error `(JAE DEBUG Cyc-local-set ,exp)) + (let ((val-exp (c-compile-exp (caddr exp) append-preamble cont ast-id trace cps?))) + (c-code/vars + (string-append (mangle (cadr exp)) " = " (c:body val-exp) ";") + (c:allocs val-exp))) + ;(c-code (string-append (mangle (cadr exp)) " = " (mangle (caddr exp)) ";")) + ) + ((equal? 'let fun) + (let* ((vars/vals (cadr exp)) + (body (caddr exp)) + (vexps (foldr + (lambda (var/val acc) + (set-use-alloca! #t) ;; Force alloca to ensure safe c stack allocs + ;; Join expressions; based on c:append + (let ((cp1 (c-compile-exp (cadr var/val) append-preamble cont ast-id trace cps?)) + (cp2 acc)) + (set-use-alloca! #f) ;; Revert flag + (c-code/vars + (let ((cp1-body (c:body cp1))) + (string-append cp1-body ";" (c:body cp2))) + (append + (list (string-append "object " (mangle (car var/val)) ";")) + (c:allocs cp1) + (c:allocs cp2))))) + (c-code "") + vars/vals)) + (body-exp (c-compile-exp + body append-preamble cont ast-id trace cps?)) + ) + ;;(trace:error `(JAE DEBUG body ,body ,vars/vals ,exp)) + (c:append vexps body-exp) + ) + ) (else (error `(Unsupported function application ,exp))))))) @@ -1321,7 +1511,7 @@ ;; Compile a reference to an element of a closure. (define (c-compile-closure-element-ref ast-id var idx) (with-fnc ast-id (lambda (fnc) - (trace:info `(c-compile-closure-element-ref ,ast-id ,var ,idx ,fnc)) + ;(trace:info `(c-compile-closure-element-ref ,ast-id ,var ,idx ,fnc)) (cond ((and *optimize-well-known-lambdas* (adbf:well-known fnc) @@ -1332,6 +1522,29 @@ (string-append "((closureN)" (mangle var) ")->elements[" idx "]")))))) +;; Analyze closure members and assign index of the function's "self" closure, if found +;; Parameters: +;; ast-fnc - Function to check for, in AST lambda form +;; closure-args - Members of the closure to scan +(define (find-closure-assigned-var-index! ast-fnc closure-args) + (let ((index 0) + (fnc (adb:get/default (ast:lambda-id ast-fnc) #f))) + ;(trace:info `(find-closure-assigned-var-index! ,ast-fnc ,fnc ,closure-args)) + (cond + ((and fnc + (pair? (adbf:assigned-to-var fnc))) + (for-each + (lambda (arg) + (when (and (ref? arg) (member arg (adbf:assigned-to-var fnc))) + ;(trace:error `(JAE closure for ,(ast:lambda-id ast-fnc) self ref is index ,index)) + (adbf:set-self-closure-index! fnc index) + (adb:set! (ast:lambda-id ast-fnc) fnc) + ) + (set! index (+ index 1)) + ) + closure-args) + ) + (else #f)))) ;; c-compile-closure : closure-exp (string -> void) -> string ;; @@ -1348,7 +1561,9 @@ ;; to one with the corresponding index so `lambda` can use them. ;; (define (c-compile-closure exp append-preamble cont ast-id trace cps?) + (find-closure-assigned-var-index! (closure->lam exp) (cdr exp)) (let* ((lam (closure->lam exp)) + (use-alloca? (alloca? ast-id)) (free-vars (map (lambda (free-var) @@ -1384,26 +1599,31 @@ (car free-vars) (list)))) (create-nclosure (lambda () - (string-append - "closureN_type " cv-name ";\n" - ;; Not ideal, but one more special case to type check call/cc - (if call/cc? "Cyc_check_proc(data, f);\n" "") - cv-name ".hdr.mark = gc_color_red;\n " - cv-name ".hdr.grayed = 0;\n" - cv-name ".tag = closureN_tag;\n " - cv-name ".fn = (function_type)__lambda_" (number->string lid) ";\n" - cv-name ".num_args = " num-args-str ";\n" - cv-name ".num_elements = " (number->string (length free-vars)) ";\n" - cv-name ".elements = (object *)alloca(sizeof(object) * " - (number->string (length free-vars)) ");\n" - (let loop ((i 0) - (vars free-vars)) - (if (null? vars) - "" - (string-append - cv-name ".elements[" (number->string i) "] = " - (car vars) ";\n" - (loop (+ i 1) (cdr vars)))))))) + (let ((decl (if use-alloca? + (string-append "closureN_type * " cv-name " = alloca(sizeof(closureN_type));\n") + (string-append "closureN_type " cv-name ";\n"))) + (sep (if use-alloca? "->" ".")) + ) + (string-append + decl + ;; Not ideal, but one more special case to type check call/cc + (if call/cc? "Cyc_check_proc(data, f);\n" "") + cv-name sep "hdr.mark = gc_color_red;\n " + cv-name sep "hdr.grayed = 0;\n" + cv-name sep "tag = closureN_tag;\n " + cv-name sep "fn = (function_type)__lambda_" (number->string lid) ";\n" + cv-name sep "num_args = " num-args-str ";\n" + cv-name sep "num_elements = " (number->string (length free-vars)) ";\n" + cv-name sep "elements = (object *)alloca(sizeof(object) * " + (number->string (length free-vars)) ");\n" + (let loop ((i 0) + (vars free-vars)) + (if (null? vars) + "" + (string-append + cv-name sep "elements[" (number->string i) "] = " + (car vars) ";\n" + (loop (+ i 1) (cdr vars))))))))) (create-mclosure (lambda () (let ((prefix (if macro? @@ -1430,7 +1650,10 @@ (create-object)) (else (c-code/vars - (string-append "&" cv-name) + (if (and use-alloca? + (> (length free-vars) 0)) + cv-name + (string-append "&" cv-name)) (list (if (> (length free-vars) 0) (create-nclosure) @@ -1484,10 +1707,15 @@ (> (string-length tmp-ident) 3) (equal? "self" (substring tmp-ident 0 4)))) (has-loop? - (and (not has-closure?) ;; Only top-level functions for now - (pair? trace) - (not (null? (cdr trace))) - (adbv:direct-rec-call? (adb:get (cdr trace))))) + (or + (adbf:calls-self? (adb:get/default (ast:lambda-id exp) (adb:make-fnc))) + ;; Older direct recursive logic + (and (not has-closure?) ;; Only top-level functions for now + (pair? trace) + (not (null? (cdr trace))) + (adbv:direct-rec-call? (adb:get (cdr trace)))) + ) + ) (formals* (string-append (if has-closure? @@ -1532,12 +1760,13 @@ (c-code ;; Only trace when entering initial defined function (cond - (has-closure? "") + (has-closure? + (if has-loop? "\n while(1) {\n" "") + ) (else (string-append (st:->code trace) - ;; TODO: probably needs brackets afterwards... - (if has-loop? "\nloop: {\n" "") + (if has-loop? "\n while(1) {\n" "") )))) body) " ") diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm new file mode 100644 index 00000000..a5f516cc --- /dev/null +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -0,0 +1,415 @@ +;;;; Cyclone Scheme +;;;; https://github.com/justinethier/cyclone +;;;; +;;;; Copyright (c) 2014-2018, Justin Ethier +;;;; All rights reserved. +;;;; +;;;; This file is part of the cps-optimizations module. +;;;; + +(cond-expand + (program + (import (scheme base) + (scheme write) + (scheme cyclone ast) + (scheme cyclone util) + (scheme cyclone pretty-print)))) + +;; Local variable reduction: +;; Reduce given sexp by replacing certain lambda calls with a let containing +;; local variables. Based on the way cyclone transforms code, this will +;; typically be limited to if expressions embedded in other expressions. +(define (opt:local-var-reduction sexp) + (define (scan exp) + ;(write `(DEBUG scan ,exp)) (newline) + (cond + ((ast:lambda? exp) + (ast:%make-lambda + (ast:lambda-id exp) + (ast:lambda-args exp) + (map scan (ast:lambda-body exp)) + (ast:lambda-has-cont exp))) + ((quote? exp) exp) + ((const? exp) exp) + ((ref? exp) exp) + ((define? exp) + `(define + ,(define->var exp) + ,@(map scan (define->exp exp)))) + ((set!? exp) + `(set! + ,(scan (set!->var exp)) + ,(scan (set!->exp exp)))) + ((if? exp) + `(if ,(scan (if->condition exp)) + ,(scan (if->then exp)) + ,(scan (if->else exp)))) + ((app? exp) + (cond + ((and + (list? exp) + (ast:lambda? (car exp)) + (equal? (length exp) 2) + (ast:lambda? (cadr exp)) + (equal? 1 (length (ast:lambda-args (cadr exp)))) + (lvr:local-tail-call-only? + (ast:lambda-body (car exp)) + (car (ast:lambda-args (car exp)))) + ;(tagged-list? 'Cyc-seq (car (ast:lambda-body (cadr exp)))) ;; TODO: DEBUG line, remove this once it works! + ) + ;;(write `(tail-call-only? passed for ,exp)) (newline) + ;;(write `(replace with ,(lvr:tail-calls->values + ;; (car (ast:lambda-body (car exp))) + ;; (car (ast:lambda-args (car exp)))))) + ;;(newline) +;TODO: need to revisit this, may need to replace values with assignments to the "let" variable. +;would need to be able to carry that through to cgen and assign properly over there... + (let* ((value (lvr:tail-calls->values + (car (ast:lambda-body (car exp))) + (car (ast:lambda-args (car exp))) + (car (ast:lambda-args (cadr exp))) + )) + (var (car (ast:lambda-args (cadr exp)))) + (body (ast:lambda-body (cadr exp))) + (av (adb:get/default var #f)) ;; Set to #f if unit testing + (ref-count + (if av + (adbv:ref-count av) + 1)) ;; Dummy value + ) + (if (and (> ref-count 0) ;; 0 ==> local var is never used + value) + `(let ((,var ,value)) + ,@body) + (map scan exp)) ;; failsafe + )) + (else + (map scan exp)))) + (else (error "unknown expression type: " exp)) + )) + (scan sexp)) + +;; Local variable reduction helper: +;; Scan sexp to determine if sym is only called in a tail-call position +(define (lvr:local-tail-call-only? sexp sym) + (call/cc + (lambda (return) + (define (scan exp fail?) + ;;(write `(DEBUG lvr:local-tail-call-only? scan ,exp)) (newline) + (cond + ((ast:lambda? exp) + (return #f)) ;; Could be OK if not ref'd... + ((quote? exp) exp) + ((const? exp) exp) + ((ref? exp) + (if (equal? exp sym) + (return #f))) ;; Assume not a tail call + ((define? exp) + (return #f)) ;; Fail fast + ((set!? exp) + (return #f)) ;; Fail fast + ((if? exp) + (scan (if->condition exp) #t) ;; fail if found under here + (scan (if->then exp) fail?) + (scan (if->else exp) fail?)) + ((app? exp) + (cond +;;; TODO: may need to check for prim:cont? and abort accordingly +;; check out code generated for scheme/cyclone/util.sld WRT symbol->string +;; cannot proceed with this since by definition these functions require CPS + ((and (prim? (car exp)) + (prim:cont? (car exp))) + (return #f)) + ((and (equal? (car exp) sym) + (not fail?)) + (map (lambda (e) (scan e fail?)) (cdr exp))) ;; Sym is OK, skip + (else + (map (lambda (e) (scan e fail?)) exp)))) + (else exp))) + (scan sexp #f) + (return #t)))) + +;; Local variable reduction helper: +;; Transform all tail calls of sym in the sexp to just the value passed +(define (lvr:tail-calls->values sexp sym assign-sym) + (call/cc + (lambda (return) + (define (scan exp) + ;;(write `(DEBUG scan ,exp)) (newline) + (cond + ((ast:lambda? exp) + (return #f)) ;; Could be OK if not ref'd... + ((quote? exp) exp) + ((const? exp) exp) + ((ref? exp) + (if (equal? exp sym) + (return #f))) ;; Assume not a tail call + ((define? exp) + (return #f)) ;; Fail fast + ((set!? exp) + (return #f)) ;; Fail fast + ((if? exp) + `(if ,(if->condition exp) + ,(scan (if->then exp)) + ,(scan (if->else exp)))) + ((app? exp) + (cond + ((and (equal? (car exp) sym) + (= (length exp) 2) + ) + `(Cyc-local-set! ,assign-sym ,(cadr exp))) + (else + ;; TODO: can we be smarter? Consider example from match.scm match-gen-or-step + (return #f)))) + (else exp))) + (cond + ;((or (quote? sexp) + ; (const? sexp)) + ; ;; Special case, set the value directly + ; ;; TODO: this is a bit of a hack, may way to re-think how this + ; ;; whole module works at some point, but for now this works. + ; (return + ; `(Cyc-local-set! ,assign-sym ,sexp))) + (else + (return + (scan sexp))))))) + +(cond-expand + (program + (define sexp +'( + (define zunda + ((lambda + (k$1057 first-row-perm$61$668 mat$62$669) + (first-row-perm$61$668 + (lambda + (first-row$65$670) + ((lambda + (number-of-cols$68$671) + ((lambda + (make-row->func$71$672) + (first-row-perm$61$668 + (lambda + (r$1062) + (make-row->func$71$672 + (lambda + (r$1063) + (make-row->func$71$672 + (lambda + (r$1064) + (zebra k$1057 + r$1062 + r$1063 + r$1064 + (cdr mat$62$669) + number-of-cols$68$671)) + -1 + 1)) + 1 + -1)) + 'child)) + (lambda + (k$1066 if-equal$76$674 if-different$77$675) + (k$1066 + (lambda + (k$1067 row$78$676) + ((lambda + (vec$79$677) + ((lambda + (first$85$679 row$86$680) + ((lambda + (lp$80$87$681) + ((lambda + (lp$80$87$681) + (Cyc-seq + (set! + lp$80$87$681 + (lambda + (k$1073 i$88$682 first$89$683 row$90$684) + (if (Cyc-fast-eq + i$88$682 + number-of-cols$68$671) + (k$1073 + (Cyc-fast-eq + i$88$682 + number-of-cols$68$671)) + ((lambda + (k$1080) + (if (Cyc-fast-eq + + (car first$89$683) + (car row$90$684)) + (k$1080 if-equal$76$674) + (k$1080 if-different$77$675))) + (lambda + (r$1079) + (Cyc-seq + (vector-set! + vec$79$677 + i$88$682 + r$1079) + ((cell-get lp$80$87$681) + k$1073 + (Cyc-fast-plus i$88$682 1) + (cdr first$89$683) + (cdr row$90$684)))))))) + ((cell-get lp$80$87$681) + (lambda + (r$1069) + (k$1067 + (lambda + (k$1070 i$92$686) + (k$1070 + (vector-ref vec$79$677 i$92$686))))) + 0 + first$85$679 + row$86$680))) + (cell lp$80$87$681))) + #f)) + first-row$65$670 + row$78$676)) + (make-vector number-of-cols$68$671))))))) + (length first-row$65$670))) + 'now)))) + (define *num-passed* 0) + (define write-to-string + (lambda + (k$3086 x$892$1775) + (call-with-output-string + k$3086 + (lambda + (k$3088 out$893$1776) + ((lambda + (x$895$1777) + ((lambda + (wr$896$1778) + (Cyc-seq + (set! wr$896$1778 + (lambda + (k$3091 x$897$1779) + (if (pair? x$897$1779) + ((lambda + (k$3112) + (if (symbol? (car x$897$1779)) + (if (pair? (cdr x$897$1779)) + (if (null? (cddr x$897$1779)) + (k$3112 + (assq (car x$897$1779) + '((quote . "'") + (quasiquote . "`") + (unquote . ",") + (unquote-splicing . ",@")))) + (k$3112 #f)) + (k$3112 #f)) + (k$3112 #f))) + (lambda + (tmp$900$902$1780) + (if tmp$900$902$1780 + ((lambda + (s$903$1781) + (display + (lambda + (r$3094) + (wr$896$1778 k$3091 (cadr x$897$1779))) + (cdr s$903$1781) + out$893$1776)) + tmp$900$902$1780) + (display + (lambda + (r$3097) + (wr$896$1778 + (lambda + (r$3098) + ((lambda + (lp$907$1783) + (Cyc-seq + (set! lp$907$1783 + (lambda + (k$3103 ls$908$1784) + (if (pair? ls$908$1784) + (display + (lambda + (r$3105) + (wr$896$1778 + (lambda + (r$3106) + (lp$907$1783 + k$3103 + (cdr ls$908$1784))) + (car ls$908$1784))) + " " + out$893$1776) + (if (null? ls$908$1784) + (k$3103 #f) + (display + (lambda + (r$3110) + (write k$3103 + ls$908$1784 + out$893$1776)) + " . " + out$893$1776))))) + (lp$907$1783 + (lambda + (r$3099) + (display k$3091 ")" out$893$1776)) + (cdr x$897$1779)))) + #f)) + (car x$897$1779))) + "(" + out$893$1776)))) + (write k$3091 x$897$1779 out$893$1776)))) + (wr$896$1778 k$3088 x$895$1777))) + #f)) + x$892$1775))))) + (define match-gen-or-step + (lambda + (k$14021 + expr$3499$3540$3621$9398 + rename$3500$3541$3622$9399 + compare$3501$3542$3623$9400) + ((lambda + (v.1$3507$3599$3659$9436) + ((lambda + (k$14141) + (if (pair? v.1$3507$3599$3659$9436) + (Cyc-seq + (car v.1$3507$3599$3659$9436) + (if (pair? (cdr v.1$3507$3599$3659$9436)) + (if (null? (car (cdr v.1$3507$3599$3659$9436))) + (if (pair? (cdr (cdr v.1$3507$3599$3659$9436))) + (Cyc-seq + (car (cdr (cdr v.1$3507$3599$3659$9436))) + (if (pair? (cdr (cdr (cdr v.1$3507$3599$3659$9436)))) + (Cyc-seq + (car (cdr (cdr (cdr v.1$3507$3599$3659$9436)))) + (if (pair? (cdr (cdr (cdr (cdr v.1$3507$3599$3659$9436))))) + (Cyc-seq + (cdr (cdr (cdr (cdr (cdr v.1$3507$3599$3659$9436))))) + (k$14141 + (cons (car (cdr (cdr (cdr (cdr v.1$3507$3599$3659$9436))))) + #f))) + (k$14141 #f))) + (k$14141 #f))) + (k$14141 #f)) + (k$14141 #f)) + (k$14141 #f))) + (k$14141 #f))) + (lambda + (tmp$3544$3546$3624$9401) + (list + (lambda (r$14022) (k$14021 (car r$14022))))))) + (cdr expr$3499$3540$3621$9398)))) + ) + +) + + ;(pretty-print + ; (ast:ast->pp-sexp + ; (ast:sexp->ast sexp))) + + (pretty-print + (ast:ast->pp-sexp + (opt:local-var-reduction (ast:sexp->ast sexp))) + ) + )) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index e8eae029..10a0636e 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -34,6 +34,7 @@ opt:contract opt:inline-prims opt:beta-expand + opt:local-var-reduction adb:clear! adb:get adb:get/default @@ -54,6 +55,8 @@ adbv:set-global! adbv:defined-by adbv:set-defined-by! + adbv:mutated-by-set? + adbv:set-mutated-by-set! adbv:reassigned? adbv:set-reassigned! adbv:assigned-value @@ -83,13 +86,17 @@ adbf:simple adbf:set-simple! adbf:all-params adbf:set-all-params! adbf:unused-params adbf:set-unused-params! + adbf:assigned-to-var adbf:set-assigned-to-var! adbf:side-effects adbf:set-side-effects! adbf:well-known adbf:set-well-known! adbf:cgen-id adbf:set-cgen-id! adbf:closure-size adbf:set-closure-size! + adbf:self-closure-index adbf:set-self-closure-index! + adbf:calls-self? adbf:set-calls-self! with-fnc with-fnc! ) + (include "cps-opt-local-var-redux.scm") (begin ;; The following two defines allow non-CPS functions to still be considered ;; for certain inlining optimizations. @@ -128,6 +135,7 @@ defines-lambda-id const const-value ref-count ref-by + mutated-by-set reassigned assigned-value app-fnc-count app-arg-count inlinable mutated-indirectly @@ -145,6 +153,7 @@ (const-value adbv:const-value adbv:set-const-value!) (ref-count adbv:ref-count adbv:set-ref-count!) (ref-by adbv:ref-by adbv:set-ref-by!) + (mutated-by-set adbv:mutated-by-set? adbv:set-mutated-by-set!) ;; TODO: need to set reassigned flag if variable is SET, however there is at least ;; one exception for local define's, which are initialized to #f and then assigned ;; a single time via set @@ -202,6 +211,7 @@ #f ; const-value 0 ; ref-count '() ; ref-by + #f ; mutated-by-set #f ; reassigned #f ; assigned-value 0 ; app-fnc-count @@ -224,6 +234,9 @@ side-effects well-known cgen-id + closure-size + self-closure-index + calls-self ) adb:function? (simple adbf:simple adbf:set-simple!) @@ -241,6 +254,10 @@ (cgen-id adbf:cgen-id adbf:set-cgen-id!) ;; Number of elements in the function's closure (closure-size adbf:closure-size adbf:set-closure-size!) + ;; Index of the function in its closure, if applicable + (self-closure-index adbf:self-closure-index adbf:set-self-closure-index!) + ;; Does this function call itself? + (calls-self adbf:calls-self? adbf:set-calls-self!) ) (define (adb:make-fnc) (%adb:make-fnc @@ -252,6 +269,8 @@ #f ;; well-known #f ;; cgen-id -1 ;; closure-size + -1 ;; self-closure-index + #f ;; calls-self )) ;; A constant value that cannot be mutated @@ -341,7 +360,8 @@ (lambda-body (lambda->exp define-body)) (fv (filter (lambda (v) - (not (prim? v))) + (and (not (equal? 'Cyc-seq v)) + (not (prim? v)))) (free-vars expr))) ) ;(trace:error `(JAE DEBUG ,(define->var expr) ,fv)) @@ -543,6 +563,7 @@ (with-var! (set!->var exp) (lambda (var) (if (adbv:assigned-value var) (adbv:set-reassigned! var #t)) + (adbv:set-mutated-by-set! var #t) (adbv-set-assigned-value-helper! (set!->var exp) var (set!->exp exp)) (adbv:set-ref-count! var (+ 1 (adbv:ref-count var))) (adbv:set-ref-by! var (cons lid (adbv:ref-by var))) @@ -568,7 +589,10 @@ ;; Identify indirect mutations. That is, the result of a function call ;; is what is mutated (cond - ((and (prim:mutates? (car exp))) + ((and (prim:mutates? (car exp)) + ;; loop3-dev WIP step #1 - do not immediately reject these prims + ;(not (member (car exp) '(vector-set!))) ;; TODO: experimental + ) (let ((e (cadr exp))) (when (ref? e) (with-var e (lambda (var) @@ -973,11 +997,7 @@ (cdr exp) (ast:lambda-formals->list (car exp))) (or - ; Issue #172 - Cannot assume that just because a primitive - ; deals with immutable objects that it is safe to inline. - ; A (set!) could still mutate variables the primitive is - ; using, causing invalid behavior. - ;(prim-calls-inlinable? (cdr exp)) + (prim-calls-inlinable? (cdr exp)) ;; Testing - every arg only used once ;(and @@ -1070,6 +1090,25 @@ ;; Could not inline (map (lambda (e) (opt:inline-prims e scope-sym refs)) exp))) )) ;; + ;; Lambda with a parameter that is never used; sequence code instead to avoid lambda + ((and (ast:lambda? (car exp)) + (every + (lambda (arg) + (or (not (prim-call? arg)) + (not (prim:cont? (car arg))))) + (cdr exp)) + (every + (lambda (param) + (with-var param (lambda (var) + (null? (adbv:ref-by var))))) + (ast:lambda-formals->list (car exp))) + ) + (opt:inline-prims + `(Cyc-seq + ,@(cdr exp) + ,@(ast:lambda-body (car exp))) + scope-sym + refs)) (else (map (lambda (e) (opt:inline-prims e scope-sym refs)) exp)))) (else @@ -1131,7 +1170,21 @@ (define (prim-calls-inlinable? prim-calls) (every (lambda (prim-call) - (prim:immutable-args/result? (car prim-call))) + (and + (prim:immutable-args/result? (car prim-call)) + ; Issue #172 - Cannot assume that just because a primitive + ; deals with immutable objects that it is safe to inline. + ; A (set!) could still mutate variables the primitive is + ; using, causing invalid behavior. + ; + ; So, make sure none of the args is mutated via (set!) + (every + (lambda (arg) + (or (not (ref? arg)) + (with-var arg (lambda (var) + (not (adbv:mutated-by-set? var)))))) + (cdr prim-call))) + ) prim-calls)) ;; Check each pair of primitive call / corresponding lambda arg, @@ -1209,7 +1262,7 @@ ((member exp args) (set-car! arg-used #t)) ((member exp ivars) - ;;(trace:error `(inline-ok? return #f ,exp ,ivars ,args)) + ;(trace:error `(inline-ok? return #f ,exp ,ivars ,args)) (return #f)) (else #t))) @@ -1245,7 +1298,16 @@ (if (not (ref? e)) (inline-ok? e ivars args arg-used return))) (reverse (cdr exp)))) - (else + ;; loop3-dev WIP step #2 - some args can be safely ignored + ;((and (prim? (car exp)) + ; (prim:mutates? (car exp)) + ; (member (car exp) '(vector-set!)) + ; ) + ; ;; with vector-set, only arg 1 (the vector) is actually mutated + ; ;; TODO: is this always true? do we have problems with self-recursive vecs?? + ; (inline-ok? (cadr exp) ivars args arg-used return) + ;) + (else (for-each (lambda (e) (inline-ok? e ivars args arg-used return)) @@ -1568,6 +1630,7 @@ (analyze exp -1 -1) ;; Top-level is lambda ID -1 (analyze2 exp) ;; Second pass (analyze:find-inlinable-vars exp '()) ;; Identify variables safe to inline + (analyze:find-recursive-calls2 exp) ) ;; NOTES: @@ -1632,6 +1695,9 @@ (else (loop (cdr lst) (+ i 1)))))) +(define (let->vars exp) + (map car (cadr exp))) + (define (closure-convert exp globals . opts) (let ((optimization-level 2)) (if (pair? opts) @@ -1652,7 +1718,7 @@ (body (ast:lambda-body exp)) (new-free-vars (difference - (difference (free-vars body) (ast:lambda-formals->list exp)) + (difference (free-vars body) (cons 'Cyc-seq (cons 'Cyc-local-set! (ast:lambda-formals->list exp)))) globals)) (formals (list->lambda-formals (cons new-self-var (ast:lambda-formals->list exp)) @@ -1688,6 +1754,22 @@ ,@(map cc (cdr exp)))) ;; TODO: need to splice? ((set!? exp) `(set! ,(set!->var exp) ,(cc (set!->exp exp)))) + ;; Special case now with local var redux + ((tagged-list? 'let exp) + `(let + ,(map + (lambda (var/val) + (let ((var (car var/val)) + (val (cadr var/val))) + `(,var ,(cc val)))) + (cadr exp)) + ,(convert + (caddr exp) + self-var + ;; Do not closure convert the let's variables because + ;; the previous code guarantees they are locals + (filter (lambda (v) (not (member v (let->vars exp)))) free-var-lst))) + ) ((lambda? exp) (error `(Unexpected lambda in closure-convert ,exp))) ((if? exp) `(if ,@(map cc (cdr exp)))) ((cell? exp) `(cell ,(cc (cell->value exp)))) @@ -1698,6 +1780,15 @@ (let ((fn (car exp)) (args (map cc (cdr exp)))) (cond + ;TODO: what about application of cyc-seq? does this only occur as a nested form? can we combine here or earlier?? + ; I think that is what is causing cc printing to explode exponentially! + ;((tagged-list? 'Cyc-seq fnc) + ; (foldl (lambda (sexp acc) (cons sexp acc)) '() (reverse '(a b c (cyc-seq 1) (cyc-seq 2 ((cyc-seq 3)))))) + ; TODO: maybe just call a function to 'flatten' seq's + ((equal? 'Cyc-seq fn) + `(Cyc-seq ,@args)) + ((equal? 'Cyc-local-set! fn) + `(Cyc-local-set! ,@args)) ((ast:lambda? fn) (cond ;; If the lambda argument is not used, flag so the C code is @@ -1725,7 +1816,7 @@ (let* ((body (ast:lambda-body fn)) (new-free-vars (difference - (difference (free-vars body) (ast:lambda-formals->list fn)) + (difference (free-vars body) (cons 'Cyc-seq (cons 'Cyc-local-set! (ast:lambda-formals->list fn)))) globals)) (new-free-vars? (> (length new-free-vars) 0))) (if new-free-vars? @@ -1992,6 +2083,98 @@ exp)) ) +;; Does given symbol refer to a recursive call to given lambda ID? +(define (rec-call? sym lid) + (cond + ((ref? sym) + (let ((var (adb:get/default sym #f))) + ;(trace:info + ; `(rec-call? ,sym ,lid + ; ;; TODO: crap, these are not set yet!!! + ; ;; may need to consider keeping out original version of find-recursive-calls and + ; ;; adding a new version that does a deeper analysis + ; ,(if var (not (adbv:reassigned? var)) #f) + ; ,(if var (adbv:assigned-value var) #f) + ; ;,((ast:lambda? var-lam)) + ; ,(adb:get/default lid #f) + ; ) + ; ) + (and-let* ( + ((not (equal? var #f))) + ((not (adbv:reassigned? var))) + (var-lam (adbv:assigned-value var)) + ((ast:lambda? var-lam)) + (fnc (adb:get/default lid #f)) + ) + ;(trace:info `(equal? ,lid ,(ast:lambda-id var-lam))) + (equal? lid (ast:lambda-id var-lam))))) + (else + #f))) + +;; Same as the original function, but this one is called at the end of analysis and +;; uses data that was previously not available. +;; +;; The reason for having two versions of this is that the original is necessary for +;; beta expansion (and must remain, at least for now) and this one will provide useful +;; data for code generation. +;; +;; TODO: is the above true? not so sure anymore, need to verify that, look at optimize-cps +(define (analyze:find-recursive-calls2 exp) + + (define (scan exp def-sym lid) + ;(trace:info `(analyze:find-recursive-calls2 scan ,def-sym ,exp ,lid)) + (cond + ((ast:lambda? exp) + (for-each + (lambda (e) + (scan e def-sym (ast:lambda-id exp))) + (ast:lambda-body exp))) + ((quote? exp) exp) + ((const? exp) exp) + ((ref? exp) + exp) + ((define? exp) #f) ;; TODO ?? + ((set!? exp) + (for-each + (lambda (e) + (scan e def-sym lid)) + (cdr exp)) + ) + ((if? exp) + (scan (if->condition exp) def-sym lid) + (scan (if->then exp) def-sym lid) + (scan (if->else exp) def-sym lid)) + ((app? exp) + (when (or ;(equal? (car exp) def-sym) TODO: def-sym is obsolete, remove it + (rec-call? (car exp) lid)) + ;(trace:info `("recursive call" ,exp)) + (with-fnc! lid (lambda (fnc) + (adbf:set-calls-self! fnc #t))) + (with-var! (car exp) (lambda (var) + (adbv:set-self-rec-call! var #t)))) + (for-each + (lambda (e) + (scan e def-sym lid)) + exp) + ) + (else #f))) + + ;; TODO: probably not good enough, what about recursive functions that are not top-level?? +;TODO: need to address those now, I think we have the support now via (rec-call?) + (if (pair? exp) + (for-each + (lambda (exp) + ;(trace:info `(analyze:find-recursive-calls ,exp)) + (and-let* (((define? exp)) + (def-exps (define->exp exp)) + ((vector? (car def-exps))) + ((ast:lambda? (car def-exps))) + (id (ast:lambda-id (car def-exps))) + ) + (scan (car (ast:lambda-body (car def-exps))) (define->var exp) id) + )) + exp)) +) ;; well-known-lambda :: symbol -> Either (AST Lambda | Boolean) ;; Does the given symbol refer to a well-known lambda? ;; If so the corresponding lambda object is returned, else #f. diff --git a/scheme/cyclone/primitives.sld b/scheme/cyclone/primitives.sld index 1a0319dd..63da05de 100644 --- a/scheme/cyclone/primitives.sld +++ b/scheme/cyclone/primitives.sld @@ -17,6 +17,7 @@ ;; TODO: replace w/list that cannot be precomputed: precompute-prim-app? prim-call? prim->c-func + prim->c-func-uses-alloca? prim/data-arg? prim/c-var-pointer prim/c-var-assign @@ -457,7 +458,38 @@ (define (prim-call? exp) (and (list? exp) (prim? (car exp)))) - (define (prim->c-func p) + (define (prim->c-func-uses-alloca? p use-alloca?) + (and + use-alloca? + (member + p + '(cons + Cyc-fast-list-1 + Cyc-fast-list-2 + Cyc-fast-list-3 + Cyc-fast-list-4 + cell)))) + + (define (prim->c-func p use-alloca?) + (cond + (use-alloca? + ;; Special case, when this flag is set the compiler is requesting a + ;; primitive that will allocate data, so any new objects must be + ;; created via alloca or such, and cannot be declared as stack vars. + ;; This is to support C loops in place of recursion. + (cond + ((eq? p 'cons) "alloca_pair") + ((eq? p 'Cyc-fast-list-1) "alloca_list_1") + ((eq? p 'Cyc-fast-list-2) "alloca_list_2") + ((eq? p 'Cyc-fast-list-3) "alloca_list_3") + ((eq? p 'Cyc-fast-list-4) "alloca_list_4") + ((eq? p 'cell) "alloca_cell") + (else + (_prim->c-func p)))) + (else + (_prim->c-func p)))) + + (define (_prim->c-func p) (cond ((eq? p 'Cyc-global-vars) "Cyc_get_global_variables") ((eq? p 'Cyc-get-cvar) "Cyc_get_cvar") @@ -876,9 +908,10 @@ ;; Does primitive allocate an object? ;; TODO: these are the functions that are defined via macros. This method ;; is obsolete and should be replaced by prim:cont? functions over time. - (define (prim:allocates-object? exp) + (define (prim:allocates-object? exp use-alloca?) (and (prim? exp) - (member exp '()))) + use-alloca? + (member exp '(cons)))) ;; Does the primitive only accept/return immutable objects? ;; This is useful during optimization diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld index 36cf7c3c..f69449b4 100644 --- a/scheme/cyclone/transforms.sld +++ b/scheme/cyclone/transforms.sld @@ -623,6 +623,7 @@ ; free-vars : exp -> sorted-set[var] (define (free-vars ast . opts) + (define let-vars '()) (define bound-only? (and (not (null? opts)) (car opts))) @@ -636,7 +637,10 @@ ((const? exp) '()) ((prim? exp) '()) ((quote? exp) '()) - ((ref? exp) (if bound-only? '() (list exp))) + ((ref? exp) + (if (member exp let-vars) + '() + (if bound-only? '() (list exp)))) ((lambda? exp) (difference (reduce union (map search (lambda->exp exp)) '()) (lambda-formals->list exp))) @@ -648,6 +652,9 @@ ((define-c? exp) (list (define->var exp))) ((set!? exp) (union (list (set!->var exp)) (search (set!->exp exp)))) + ((tagged-list? 'let exp) + (set! let-vars (append (map car (cadr exp)) let-vars)) + (search (cdr exp))) ; Application: ((app? exp) (reduce union (map search exp) '())) (else (error "unknown expression: " exp)))) @@ -776,6 +783,9 @@ ; Application: ((app? exp) + ;; Easy place to clean up nested Cyc-seq expressions + (when (tagged-list? 'Cyc-seq exp) + (set! exp (flatten-sequence exp))) (let ((result (map (lambda (e) (wrap-mutables e globals)) exp))) ;; This code can eliminate a lambda definition. But typically ;; the code that would have such a definition has a recursive @@ -806,6 +816,42 @@ result)) (else (error "unknown expression type: " exp)))) +;; Flatten a list containing subcalls of a given symbol. +;; For example, the expression: +;; +;; '(Cyc-seq +;; (set! b '(#f . #f)) +;; (Cyc-seq +;; (set-car! a 1) +;; (Cyc-seq +;; (set-cdr! a '(2)) +;; ((fnc a1 a2 a3))))) +;; +;; becomes: +;; +;; '(Cyc-seq +;; (set! b '(#f . #f)) +;; (set-car! a 1) +;; (set-cdr! a '(2)) +;; ((fnc a1 a2 a3))) +;; +(define (flatten-sequence sexp) + (define (flat sexp acc) + (cond + ((not (pair? sexp)) ;; Stop at end of sexp + acc) + ((and (tagged-list? 'Cyc-seq (car sexp))) ;; Flatten nexted sequences + (flat (cdar sexp) acc)) + ((and (ref? (car sexp)) ;; Remove unused identifiers + (not (equal? 'Cyc-seq (car sexp)))) + (flat (cdr sexp) acc)) + (else ;;(pair? sexp) + (flat (cdr sexp) (cons (car sexp) acc)))) + ) + (reverse + (flat sexp '()))) + + ;; Alpha conversion ;; (aka alpha renaming) ;; diff --git a/test-eval-compilation.scm b/test-eval-compilation.scm deleted file mode 100644 index 2a64e87d..00000000 --- a/test-eval-compilation.scm +++ /dev/null @@ -1,22 +0,0 @@ -;; A temporary test file -(import (scheme base) (scheme write)) - -(define (analyze . opts) - (write 'test)) - -(define (analyze-if exp a-env rename-env local-renamed) - (let ((pproc (analyze (if-predicate exp) a-env rename-env local-renamed)) - (cproc (analyze (if-consequent exp) a-env rename-env local-renamed)) - (aproc (analyze (if-alternative exp) a-env rename-env local-renamed))) - (lambda (env) - (if (pproc env) - (cproc env) - (aproc env))))) -(define (if-predicate exp) (cadr exp)) -(define (if-consequent exp) (caddr exp)) -(define (if-alternative exp) - (if (not (null? (cdddr exp))) ;; TODO: add (not) support - (cadddr exp) - #f)) - -(write (analyze-if 'a 'b 'c 'd)) diff --git a/test-matrix.scm b/test-matrix.scm new file mode 100644 index 00000000..401719f5 --- /dev/null +++ b/test-matrix.scm @@ -0,0 +1,881 @@ +;;; MATRIX -- Obtained from Andrew Wright. + +(import (scheme base) (scheme read) (scheme write) (scheme time)) + +;;;; We need R6RS div and mod for this benchmark. +; +;(define (div x y) +; (cond ((and (exact-integer? x) +; (exact-integer? y) +; (>= x 0)) +; (quotient x y)) +; ((< y 0) +; ;; x < 0, y < 0 +; (let* ((q (quotient x y)) +; (r (- x (* q y)))) +; (if (= r 0) +; q +; (+ q 1)))) +; (else +; ;; x < 0, y > 0 +; (let* ((q (quotient x y)) +; (r (- x (* q y)))) +; (if (= r 0) +; q +; (- q 1)))))) +; +;(define (mod x y) +; (cond ((and (exact-integer? x) +; (exact-integer? y) +; (>= x 0)) +; (remainder x y)) +; ((< y 0) +; ;; x < 0, y < 0 +; (let* ((q (quotient x y)) +; (r (- x (* q y)))) +; (if (= r 0) +; 0 +; (- r y)))) +; (else +; ;; x < 0, y > 0 +; (let* ((q (quotient x y)) +; (r (- x (* q y)))) +; (if (= r 0) +; 0 +; (+ r y)))))) +; +;;; Chez-Scheme compatibility stuff: +; +;(define (chez-box x) (cons x '())) +;(define (chez-unbox x) (car x)) +;(define (chez-set-box! x y) (set-car! x y)) +; +;;; Test that a matrix with entries in {+1, -1} is maximal among the matricies +;;; obtainable by +;;; re-ordering the rows +;;; re-ordering the columns +;;; negating any subset of the columns +;;; negating any subset of the rows +;;; Where we compare two matricies by lexicographically comparing the first row, +;;; then the next to last, etc., and we compare a row by lexicographically +;;; comparing the first entry, the second entry, etc., and we compare two +;;; entries by +1 > -1. +;;; Note, this scheme obeys the useful fact that if (append mat1 mat2) is +;;; maximal, then so is mat1. Thus, we can build up maximal matricies +;;; row by row. +;;; +;;; Once you have chosen the row re-ordering so that you know which row goes +;;; last, the set of columns to negate is fixed (since the last row must be +;;; all +1's). +;;; +;;; Note, the column ordering is really totally determined as follows: +;;; all columns for which the second row is +1 must come before all +;;; columns for which the second row is -1. +;;; among columns for which the second row is +1, all columns for which +;;; the third row is +1 come before those for which the third is +;;; -1, and similarly for columns in which the second row is -1. +;;; etc +;;; Thus, each succeeding row sorts columns withing refinings equivalence +;;; classes. +;;; +;;; Maximal? assumes that mat has atleast one row, and that the first row +;;; is all +1's. +;(define maximal? +; (lambda (mat) +; (let pick-first-row +; ((first-row-perm +; (gen-perms mat))) +; (if first-row-perm +; (and (zunda first-row-perm mat) +; (pick-first-row (first-row-perm 'brother))) +; #t)))) + +(define zunda + (lambda (first-row-perm mat) + (let* ((first-row + (first-row-perm 'now)) + (number-of-cols + (length first-row)) + (make-row->func + (lambda (if-equal if-different) + (lambda (row) + (let ((vec + (make-vector number-of-cols))) + (do ((i 0 (+ i 1)) + (first first-row + (cdr first)) + (row row + (cdr row))) + ((= i number-of-cols)) + (vector-set! vec + i + (if (= (car first) (car row)) + if-equal + if-different))) + (lambda (i) + (vector-ref vec i)))))) + (mat + (cdr mat))) +;(make-row->func 1 -1) + (zebra (first-row-perm 'child) + (make-row->func 1 -1) + (make-row->func -1 1) + mat + number-of-cols)))) + +;; TODO: with this test code, why is the fast-eq inlined???? +(write (zunda 1 -1)) + +(define zebra + (lambda (row-perm row->func+ row->func- mat number-of-cols) + (write (list row-perm row->func+ row->func- mat number-of-cols)))) +;(define zebra +; (lambda (row-perm row->func+ row->func- mat number-of-cols) +; (let _-*- +; ((row-perm +; row-perm) +; (mat +; mat) +; (partitions +; (list (miota number-of-cols)))) +; (or (not row-perm) +; (and +; (zulu (car mat) +; (row->func+ (row-perm 'now)) +; partitions +; (lambda (new-partitions) +; (_-*- (row-perm 'child) +; (cdr mat) +; new-partitions))) +; (zulu (car mat) +; (row->func- (row-perm 'now)) +; partitions +; (lambda (new-partitions) +; (_-*- (row-perm 'child) +; (cdr mat) +; new-partitions))) +; (let ((new-row-perm +; (row-perm 'brother))) +; (or (not new-row-perm) +; (_-*- new-row-perm +; mat +; partitions)))))))) +; +; +;(define zulu +; (let ((cons-if-not-null +; (lambda (lhs rhs) +; (if (null? lhs) +; rhs +; (cons lhs rhs))))) +; (lambda (old-row new-row-func partitions equal-cont) +; (let _-*- +; ((p-in +; partitions) +; (old-row +; old-row) +; (rev-p-out +; '())) +; (let _-split- +; ((partition +; (car p-in)) +; (old-row +; old-row) +; (plus +; '()) +; (minus +; '())) +; (if (null? partition) +; (let _-minus- +; ((old-row +; old-row) +; (m +; minus)) +; (if (null? m) +; (let ((rev-p-out +; (cons-if-not-null +; minus +; (cons-if-not-null +; plus +; rev-p-out))) +; (p-in +; (cdr p-in))) +; (if (null? p-in) +; (equal-cont (reverse rev-p-out)) +; (_-*- p-in old-row rev-p-out))) +; (or (= 1 (car old-row)) +; (_-minus- (cdr old-row) +; (cdr m))))) +; (let ((next +; (car partition))) +; (case (new-row-func next) +; ((1) +; (and (= 1 (car old-row)) +; (_-split- (cdr partition) +; (cdr old-row) +; (cons next plus) +; minus))) +; ((-1) +; (_-split- (cdr partition) +; old-row +; plus +; (cons next minus))))))))))) +; +;(define all? +; (lambda (ok? lst) +; (let _-*- +; ((lst +; lst)) +; (or (null? lst) +; (and (ok? (car lst)) +; (_-*- (cdr lst))))))) +; +;(define gen-perms +; (lambda (objects) +; (let _-*- +; ((zulu-future +; objects) +; (past +; '())) +; (if (null? zulu-future) +; #f +; (lambda (msg) +; (case msg +; ((now) +; (car zulu-future)) +; ((brother) +; (_-*- (cdr zulu-future) +; (cons (car zulu-future) +; past))) +; ((child) +; (gen-perms +; (fold past cons (cdr zulu-future)))) +; ((puke) +; (cons (car zulu-future) +; (fold past cons (cdr zulu-future)))) +; (else +; (error 'gen-perms "Bad msg: ~a" msg)))))))) +; +;(define fold +; (lambda (lst folder state) +; (let _-*- +; ((lst +; lst) +; (state +; state)) +; (if (null? lst) +; state +; (_-*- (cdr lst) +; (folder (car lst) +; state)))))) +; +;(define miota +; (lambda (len) +; (let _-*- +; ((i 0)) +; (if (= i len) +; '() +; (cons i +; (_-*- (+ i 1))))))) +; +;(define proc->vector +; (lambda (size proc) +; (let ((res +; (make-vector size))) +; (do ((i 0 +; (+ i 1))) +; ((= i size)) +; (vector-set! res +; i +; (proc i))) +; res))) +; +;;; Given a prime number P, return a procedure which, given a `maker' procedure, +;;; calls it on the operations for the field Z/PZ. +;(define make-modular +; (lambda (modulus) +; (let* ((reduce +; (lambda (x) +; (mod x modulus))) +; (coef-zero? +; (lambda (x) +; (zero? (reduce x)))) +; (coef-+ +; (lambda (x y) +; (reduce (+ x y)))) +; (coef-negate +; (lambda (x) +; (reduce (- x)))) +; (coef-* +; (lambda (x y) +; (reduce (* x y)))) +; (coef-recip +; (let ((inverses +; (proc->vector (- modulus 1) +; (lambda (i) +; (extended-gcd (+ i 1) +; modulus +; (lambda (gcd inverse ignore) +; inverse)))))) +; ;; Coef-recip. +; (lambda (x) +; (let ((x +; (reduce x))) +; (vector-ref inverses (- x 1))))))) +; (lambda (maker) +; (maker 0;; coef-zero +; 1;; coef-one +; coef-zero? +; coef-+ +; coef-negate +; coef-* +; coef-recip))))) +; +;;; Extended Euclidean algorithm. +;;; (extended-gcd a b cont) computes the gcd of a and b, and expresses it +;;; as a linear combination of a and b. It returns calling cont via +;;; (cont gcd a-coef b-coef) +;;; where gcd is the GCD and is equal to a-coef * a + b-coef * b. +;(define extended-gcd +; (let ((n->sgn/abs +; (lambda (x cont) +; (if (>= x 0) +; (cont 1 x) +; (cons -1 (- x)))))) +; (lambda (a b cont) +; (n->sgn/abs a +; (lambda (p-a p) +; (n->sgn/abs b +; (lambda (q-b q) +; (let _-*- +; ((p +; p) +; (p-a +; p-a) +; (p-b +; 0) +; (q +; q) +; (q-a +; 0) +; (q-b +; q-b)) +; (if (zero? q) +; (cont p p-a p-b) +; (let ((mult +; (div p q))) +; (_-*- q +; q-a +; q-b +; (- p (* mult q)) +; (- p-a (* mult q-a)) +; (- p-b (* mult q-b))))))))))))) +; +;;; Given elements and operations on the base field, return a procedure which +;;; computes the row-reduced version of a matrix over that field. The result +;;; is a list of rows where the first non-zero entry in each row is a 1 (in +;;; the coefficient field) and occurs to the right of all the leading non-zero +;;; entries of previous rows. In particular, the number of rows is the rank +;;; of the original matrix, and they have the same row-space. +;;; The items related to the base field which are needed are: +;;; coef-zero additive identity +;;; coef-one multiplicative identity +;;; coef-zero? test for additive identity +;;; coef-+ addition (two args) +;;; coef-negate additive inverse +;;; coef-* multiplication (two args) +;;; coef-recip multiplicative inverse +;;; Note, matricies are stored as lists of rows (i.e., lists of lists). +;(define make-row-reduce +; (lambda (coef-zero coef-one coef-zero? coef-+ coef-negate coef-* coef-recip) +; (lambda (mat) +; (let _-*- +; ((mat +; mat)) +; (if (or (null? mat) +; (null? (car mat))) +; '() +; (let _-**- +; ((in +; mat) +; (out +; '())) +; (if (null? in) +; (map +; (lambda (x) +; (cons coef-zero x)) +; (_-*- out)) +; (let* ((prow +; (car in)) +; (pivot +; (car prow)) +; (prest +; (cdr prow)) +; (in +; (cdr in))) +; (if (coef-zero? pivot) +; (_-**- in +; (cons prest out)) +; (let ((zap-row +; (map +; (let ((mult +; (coef-recip pivot))) +; (lambda (x) +; (coef-* mult x))) +; prest))) +; (cons (cons coef-one zap-row) +; (map +; (lambda (x) +; (cons coef-zero x)) +; (_-*- +; (fold in +; (lambda (row mat) +; (cons +; (let ((first-col +; (car row)) +; (rest-row +; (cdr row))) +; (if (coef-zero? first-col) +; rest-row +; (map +; (let ((mult +; (coef-negate first-col))) +; (lambda (f z) +; (coef-+ f +; (coef-* mult z)))) +; rest-row +; zap-row))) +; mat)) +; out)))))))))))))) +; +; +;;; Given elements and operations on the base field, return a procedure which +;;; when given a matrix and a vector tests to see if the vector is in the +;;; row-space of the matrix. This returned function is curried. +;;; The items related to the base field which are needed are: +;;; coef-zero additive identity +;;; coef-one multiplicative identity +;;; coef-zero? test for additive identity +;;; coef-+ addition (two args) +;;; coef-negate additive inverse +;;; coef-* multiplication (two args) +;;; coef-recip multiplicative inverse +;;; Note, matricies are stored as lists of rows (i.e., lists of lists). +;(define make-in-row-space? +; (lambda (coef-zero coef-one coef-zero? coef-+ coef-negate coef-* coef-recip) +; (let ((row-reduce +; (make-row-reduce coef-zero +; coef-one +; coef-zero? +; coef-+ +; coef-negate +; coef-* +; coef-recip))) +; (lambda (mat) +; (let ((mat +; (row-reduce mat))) +; (lambda (row) +; (let _-*- +; ((row +; row) +; (mat +; mat)) +; (if (null? row) +; #t +; (let ((r-first +; (car row)) +; (r-rest +; (cdr row))) +; (cond ((coef-zero? r-first) +; (_-*- r-rest +; (map cdr +; (if (or (null? mat) +; (coef-zero? (caar mat))) +; mat +; (cdr mat))))) +; ((null? mat) +; #f) +; (else +; (let* ((zap-row +; (car mat)) +; (z-first +; (car zap-row)) +; (z-rest +; (cdr zap-row)) +; (mat +; (cdr mat))) +; (if (coef-zero? z-first) +; #f +; (_-*- +; (map +; (let ((mult +; (coef-negate r-first))) +; (lambda (r z) +; (coef-+ r +; (coef-* mult z)))) +; r-rest +; z-rest) +; (map cdr mat))))))))))))))) +; +; +;;; Given a prime number, return a procedure which takes integer matricies +;;; and returns their row-reduced form, modulo the prime. +;(define make-modular-row-reduce +; (lambda (modulus) +; ((make-modular modulus) +; make-row-reduce))) +; +; +;(define make-modular-in-row-space? +; (lambda (modulus) +; ((make-modular modulus) +; make-in-row-space?))) +; +; +; +;;; Usual utilities. +; +; +; +;;; Given a bound, find a prime greater than the bound. +;(define find-prime +; (lambda (bound) +; (let* ((primes +; (list 2)) +; (last +; (chez-box primes)) +; (is-next-prime? +; (lambda (trial) +; (let _-*- +; ((primes +; primes)) +; (or (null? primes) +; (let ((p +; (car primes))) +; (or (< trial (* p p)) +; (and (not (zero? (mod trial p))) +; (_-*- (cdr primes)))))))))) +; (if (> 2 bound) +; 2 +; (let _-*- +; ((trial +; 3)) +; (if (is-next-prime? trial) +; (let ((entry +; (list trial))) +; (set-cdr! (chez-unbox last) entry) +; (chez-set-box! last entry) +; (if (> trial bound) +; trial +; (_-*- (+ trial 2)))) +; (_-*- (+ trial 2)))))))) +; +;;; Given the size of a square matrix consisting only of +1's and -1's, +;;; return an upper bound on the determinant. +;(define det-upper-bound +; (lambda (size) +; (let ((main-part +; (expt size +; (div size 2)))) +; (if (even? size) +; main-part +; (* main-part +; (do ((i 0 (+ i 1))) +; ((>= (* i i) size) +; i))))))) +; +;;; Fold over all maximal matrices. +;(define go +; (lambda (number-of-cols inv-size folder state) +; (let* ((in-row-space? +; (make-modular-in-row-space? +; (find-prime +; (det-upper-bound inv-size)))) +; (make-tester +; (lambda (mat) +; (let ((tests +; (let ((old-mat +; (cdr mat)) +; (new-row +; (car mat))) +; (fold-over-subs-of-size old-mat +; (- inv-size 2) +; (lambda (sub tests) +; (cons +; (in-row-space? +; (cons new-row sub)) +; tests)) +; '())))) +; (lambda (row) +; (let _-*- +; ((tests +; tests)) +; (and (not (null? tests)) +; (or ((car tests) row) +; (_-*- (cdr tests))))))))) +; (all-rows;; all rows starting with +1 in decreasing order +; (fold +; (fold-over-rows (- number-of-cols 1) +; cons +; '()) +; (lambda (row rows) +; (cons (cons 1 row) +; rows)) +; '()))) +; (let _-*- +; ((number-of-rows +; 1) +; (rev-mat +; (list +; (car all-rows))) +; (possible-future +; (cdr all-rows)) +; (state +; state)) +; (let ((zulu-future +; (remove-in-order +; (if (< number-of-rows inv-size) +; (in-row-space? rev-mat) +; (make-tester rev-mat)) +; possible-future))) +; (if (null? zulu-future) +; (folder (reverse rev-mat) +; state) +; (let _-**- +; ((zulu-future +; zulu-future) +; (state +; state)) +; (if (null? zulu-future) +; state +; (let ((rest-of-future +; (cdr zulu-future))) +; (_-**- rest-of-future +; (let* ((first +; (car zulu-future)) +; (new-rev-mat +; (cons first rev-mat))) +; (if (maximal? (reverse new-rev-mat)) +; (_-*- (+ number-of-rows 1) +; new-rev-mat +; rest-of-future +; state) +; state)))))))))))) +; +;(define go-folder +; (lambda (mat bsize.blen.blist) +; (let ((bsize +; (car bsize.blen.blist)) +; (size +; (length mat))) +; (if (< size bsize) +; bsize.blen.blist +; (let ((blen +; (cadr bsize.blen.blist)) +; (blist +; (cddr bsize.blen.blist))) +; (if (= size bsize) +; (let ((blen +; (+ blen 1))) +; ;; (if +; ;; (let _-*- +; ;; ((blen +; ;; blen)) +; ;; (or (< blen 10) +; ;; (and (zero? (mod blen 10)) +; ;; (_-*- (div blen 10))))) +; ;; +; ;; (begin +; ;; (display blen) +; ;; (display " of size ") +; ;; (display bsize) +; ;; (newline))) +; +; (cons bsize +; (cons blen +; (cond ((< blen 3000) +; (cons mat blist)) +; ((= blen 3000) +; (cons "..." blist)) +; (else +; blist))))) +; ;; (begin +; ;; (newline) +; ;; (display "First of size ") +; ;; (display size) +; ;; (display ":") +; ;; (newline) +; ;; (for-each +; ;; (lambda (row) +; ;; (display " ") +; ;; (for-each +; ;; (lambda (e) +; ;; (case e +; ;; ((1) +; ;; (display " 1")) +; ;; ((-1) +; ;; (display " -1")))) +; ;; row) +; ;; (newline)) +; ;; mat) +; +; (list size 1 mat))))))) +; +;(define really-go +; (lambda (number-of-cols inv-size) +; (cddr +; (go number-of-cols +; inv-size +; go-folder +; (list -1 -1))))) +; +;(define remove-in-order +; (lambda (remove? lst) +; (reverse +; (fold lst +; (lambda (e lst) +; (if (remove? e) +; lst +; (cons e lst))) +; '())))) +; +;;; The first fold-over-rows is slower than the second one, but folds +;;; over rows in lexical order (large to small). +;(define fold-over-rows +; (lambda (number-of-cols folder state) +; (if (zero? number-of-cols) +; (folder '() +; state) +; (fold-over-rows (- number-of-cols 1) +; (lambda (tail state) +; (folder (cons -1 tail) +; state)) +; (fold-over-rows (- number-of-cols 1) +; (lambda (tail state) +; (folder (cons 1 tail) +; state)) +; state))))) +; +;;; Fold over subsets of a given size. +;(define fold-over-subs-of-size +; (lambda (universe size folder state) +; (let ((usize +; (length universe))) +; (if (< usize size) +; state +; (let _-*- +; ((size +; size) +; (universe +; universe) +; (folder +; folder) +; (csize +; (- usize size)) +; (state +; state)) +; (cond ((zero? csize) +; (folder universe state)) +; ((zero? size) +; (folder '() state)) +; (else +; (let ((first-u +; (car universe)) +; (rest-u +; (cdr universe))) +; (_-*- size +; rest-u +; folder +; (- csize 1) +; (_-*- (- size 1) +; rest-u +; (lambda (tail state) +; (folder (cons first-u tail) +; state)) +; csize +; state)))))))))) +; +;(define (main) +; (let* ((count (read)) +; (input1 (read)) +; (input2 (read)) +; (output (read)) +; (s3 (number->string count)) +; (s2 (number->string input2)) +; (s1 (number->string input1)) +; (name "matrix")) +; (run-r7rs-benchmark +; (string-append name ":" s1 ":" s2 ":" s3) +; count +; (lambda () (really-go (hide count input1) (hide count input2))) +; (lambda (result) (equal? result output))))) +; +;;;; The following code is appended to all benchmarks. +; +;;;; Given an integer and an object, returns the object +;;;; without making it too easy for compilers to tell +;;;; the object will be returned. +; +;(define (hide r x) +; (call-with-values +; (lambda () +; (values (vector values (lambda (x) x)) +; (if (< r 100) 0 1))) +; (lambda (v i) +; ((vector-ref v i) x)))) +; +;;;; Given the name of a benchmark, +;;;; the number of times it should be executed, +;;;; a thunk that runs the benchmark once, +;;;; and a unary predicate that is true of the +;;;; correct results the thunk may return, +;;;; runs the benchmark for the number of specified iterations. +; +;(define (run-r7rs-benchmark name count thunk ok?) +; +; ;; Rounds to thousandths. +; (define (rounded x) +; (/ (round (* 1000 x)) 1000)) +; +; (display "Running ") +; (display name) +; (newline) +; (flush-output-port (current-output-port)) +; (let* ((j/s (jiffies-per-second)) +; (t0 (current-second)) +; (j0 (current-jiffy))) +; (let loop ((i 0) +; (result #f)) +; (cond ((< i count) +; (loop (+ i 1) (thunk))) +; ((ok? result) +; (let* ((j1 (current-jiffy)) +; (t1 (current-second)) +; (jifs (- j1 j0)) +; (secs (inexact (/ jifs j/s))) +; (secs2 (rounded (- t1 t0)))) +; (display "Elapsed time: ") +; (write secs) +; (display " seconds (") +; (write secs2) +; (display ") for ") +; (display name) +; (newline) +; (display "+!CSVLINE!+") +; (display (this-scheme-implementation-name)) +; (display ",") +; (display name) +; (display ",") +; (display secs) +; (newline) +; (flush-output-port (current-output-port))) +; result) +; (else +; (display "ERROR: returned incorrect result: ") +; (write result) +; (newline) +; (flush-output-port (current-output-port)) +; result))))) +;(define (this-scheme-implementation-name) +; (string-append "cyclone-" (Cyc-version))) +;(main) diff --git a/tests/debug/flatten-seq.scm b/tests/debug/flatten-seq.scm new file mode 100644 index 00000000..e579efef --- /dev/null +++ b/tests/debug/flatten-seq.scm @@ -0,0 +1,45 @@ +(import (scheme base) (scheme write) (scheme cyclone util) (scheme cyclone pretty-print)) + +(define sexp + '(Cyc-seq + (set! b '(#f . #f)) + (Cyc-seq + (set-car! a 1) + (Cyc-seq + (set-cdr! a '(2)) + ((fnc a1 a2 a3)))))) + +;; Flatten a list containing subcalls of a given symbol. +;; For example, the expression: +;; +;; '(Cyc-seq +;; (set! b '(#f . #f)) +;; (Cyc-seq +;; (set-car! a 1) +;; (Cyc-seq +;; (set-cdr! a '(2)) +;; ((fnc a1 a2 a3))))) +;; +;; becomes: +;; +;; '(Cyc-seq +;; (set! b '(#f . #f)) +;; (set-car! a 1) +;; (set-cdr! a '(2)) +;; ((fnc a1 a2 a3))) +;; +(define (flatten-subcalls sexp sym) + (define (flat sexp acc) + (cond + ((not (pair? sexp)) + acc) + ((and (tagged-list? sym (car sexp))) + (flat (cdar sexp) acc)) + (else ;;(pair? sexp) + (flat (cdr sexp) (cons (car sexp) acc)))) + ) + (reverse + (flat sexp '()))) + +(pretty-print (flatten-subcalls sexp 'Cyc-seq)) +(pretty-print (flatten-subcalls '(a b c d e (f (g))) 'Cyc-seq))