From bea7cfe242f525ff9956049814dc588947686bf2 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 16 Oct 2018 22:52:34 -0400 Subject: [PATCH 001/115] Added (rec-call?) --- scheme/cyclone/cps-optimizations.sld | 29 +++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index e8eae029..543ba69e 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1949,17 +1949,29 @@ exp)) ) +;; Does given symbol refer to a recursive call to given lambda ID? +(define (rec-call? sym lid) + (trace:info `(rec-call? ,sym ,lid)) + (and-let* ((var (adb:get/default sym #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)))) + ;; Find functions that call themselves. This is not as restrictive ;; as finding "direct" calls. (define (analyze:find-recursive-calls exp) - (define (scan exp def-sym) + (define (scan exp def-sym lid) ;(trace:info `(analyze:find-recursive-calls scan ,def-sym ,exp)) (cond ((ast:lambda? exp) (for-each (lambda (e) - (scan e def-sym)) + (scan e def-sym (ast:lambda-id exp))) (ast:lambda-body exp))) ((quote? exp) exp) ((const? exp) exp) @@ -1968,17 +1980,19 @@ ((define? exp) #f) ;; TODO ?? ((set!? exp) #f) ;; TODO ?? ((if? exp) - (scan (if->condition exp) def-sym) - (scan (if->then exp) def-sym) - (scan (if->else exp) def-sym)) + (scan (if->condition exp) def-sym lid) + (scan (if->then exp) def-sym lid) + (scan (if->else exp) def-sym lid)) ((app? exp) - (when (equal? (car exp) def-sym) + (when (or (equal? (car exp) def-sym) + (rec-call? (car exp) lid)) (trace:info `("recursive call" ,exp)) (with-var! def-sym (lambda (var) (adbv:set-self-rec-call! var #t))))) (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) @@ -1987,8 +2001,9 @@ (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)))) + (scan (car (ast:lambda-body (car def-exps))) (define->var exp) id))) exp)) ) From f110c1d219f53047b85ce71baac973860d3529ca Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 17 Oct 2018 13:23:31 -0400 Subject: [PATCH 002/115] WIP --- scheme/cyclone/cps-optimizations.sld | 59 +++++++++++++++++++--------- 1 file changed, 41 insertions(+), 18 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 543ba69e..22cd7b7b 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1951,22 +1951,34 @@ ;; Does given symbol refer to a recursive call to given lambda ID? (define (rec-call? sym lid) - (trace:info `(rec-call? ,sym ,lid)) - (and-let* ((var (adb:get/default sym #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)))) + (cond + ((ref? sym) + (let ((var (adb:get/default sym #f))) + (trace:info `(rec-call? ,sym ,lid + ,(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* (((ref? sym)) + ((var)) + ((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))) ;; Find functions that call themselves. This is not as restrictive ;; as finding "direct" calls. (define (analyze:find-recursive-calls exp) (define (scan exp def-sym lid) - ;(trace:info `(analyze:find-recursive-calls scan ,def-sym ,exp)) + (trace:info `(analyze:find-recursive-calls scan ,def-sym ,exp ,lid)) (cond ((ast:lambda? exp) (for-each @@ -1978,33 +1990,44 @@ ((ref? exp) exp) ((define? exp) #f) ;; TODO ?? - ((set!? 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) + (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-var! def-sym (lambda (var) - (adbv:set-self-rec-call! var #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?) +;TODO: need to address those now, I think we have the support now via (rec-call?) (if (pair? exp) (for-each (lambda (exp) - ;;(write exp) (newline) + (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)) + (scan (car (ast:lambda-body (car def-exps))) (define->var exp) id) + )) + exp)) ) ;; well-known-lambda :: symbol -> Either (AST Lambda | Boolean) From 2d5e75764f5cdf678ed2e9ccf5e3a9c0fd381a1b Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 17 Oct 2018 15:54:14 -0400 Subject: [PATCH 003/115] Added TODO --- scheme/cyclone/cps-optimizations.sld | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 22cd7b7b..cd428d73 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1954,15 +1954,19 @@ (cond ((ref? sym) (let ((var (adb:get/default sym #f))) - (trace:info `(rec-call? ,sym ,lid + (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* (((ref? sym)) - ((var)) + (and-let* ( + ((not (equal? var #f))) ((not (adbv:reassigned? var))) (var-lam (adbv:assigned-value var)) ((ast:lambda? var-lam)) From 95ba4aa554958e8c44a15ff24ee89ad25a8f0b1f Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 17 Oct 2018 17:58:47 -0400 Subject: [PATCH 004/115] WIP --- scheme/cyclone/cps-optimizations.sld | 65 ++++++++++++++++++++++++---- 1 file changed, 57 insertions(+), 8 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index cd428d73..ec076d5b 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1568,6 +1568,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: @@ -1949,6 +1950,49 @@ exp)) ) +;; Find functions that call themselves. This is not as restrictive +;; as finding "direct" calls. +(define (analyze:find-recursive-calls exp) + + (define (scan exp def-sym) + ;(trace:info `(analyze:find-recursive-calls scan ,def-sym ,exp)) + (cond + ((ast:lambda? exp) + (for-each + (lambda (e) + (scan e def-sym)) + (ast:lambda-body exp))) + ((quote? exp) exp) + ((const? exp) exp) + ((ref? exp) + exp) + ((define? exp) #f) ;; TODO ?? + ((set!? exp) #f) ;; TODO ?? + ((if? exp) + (scan (if->condition exp) def-sym) + (scan (if->then exp) def-sym) + (scan (if->else exp) def-sym)) + ((app? exp) + (when (equal? (car exp) def-sym) + (trace:info `("recursive call" ,exp)) + (with-var! def-sym (lambda (var) + (adbv:set-self-rec-call! var #t))))) + (else #f))) + + ;; TODO: probably not good enough, what about recursive functions that are not top-level?? + (if (pair? exp) + (for-each + (lambda (exp) + ;;(write exp) (newline) + (and-let* (((define? exp)) + (def-exps (define->exp exp)) + ((vector? (car def-exps))) + ((ast:lambda? (car def-exps))) + ) + (scan (car (ast:lambda-body (car def-exps))) (define->var exp)))) + exp)) +) + ;; Does given symbol refer to a recursive call to given lambda ID? (define (rec-call? sym lid) (cond @@ -1957,8 +2001,8 @@ (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 + ;; 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)) @@ -1977,12 +2021,18 @@ (else #f))) -;; Find functions that call themselves. This is not as restrictive -;; as finding "direct" calls. -(define (analyze:find-recursive-calls exp) +;; 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-calls scan ,def-sym ,exp ,lid)) + (trace:info `(analyze:find-recursive-calls2 scan ,def-sym ,exp ,lid)) (cond ((ast:lambda? exp) (for-each @@ -2022,7 +2072,7 @@ (if (pair? exp) (for-each (lambda (exp) - (trace:info `(analyze:find-recursive-calls ,exp)) + ;(trace:info `(analyze:find-recursive-calls ,exp)) (and-let* (((define? exp)) (def-exps (define->exp exp)) ((vector? (car def-exps))) @@ -2033,7 +2083,6 @@ )) 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. From 44efba7c6d35f25a8a8a36dd775c1722a6e62165 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 17 Oct 2018 17:27:14 -0400 Subject: [PATCH 005/115] Remove trace statements --- scheme/cyclone/cps-optimizations.sld | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index ec076d5b..ec76a963 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1998,17 +1998,17 @@ (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) - ) - ) + ;(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))) @@ -2016,7 +2016,7 @@ ((ast:lambda? var-lam)) (fnc (adb:get/default lid #f)) ) - (trace:info `(equal? ,lid ,(ast:lambda-id var-lam))) + ;(trace:info `(equal? ,lid ,(ast:lambda-id var-lam))) (equal? lid (ast:lambda-id var-lam))))) (else #f))) @@ -2032,7 +2032,7 @@ (define (analyze:find-recursive-calls2 exp) (define (scan exp def-sym lid) - (trace:info `(analyze:find-recursive-calls2 scan ,def-sym ,exp ,lid)) + ;(trace:info `(analyze:find-recursive-calls2 scan ,def-sym ,exp ,lid)) (cond ((ast:lambda? exp) (for-each @@ -2057,7 +2057,7 @@ ((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)) + ;(trace:info `("recursive call" ,exp)) (with-var! (car exp) (lambda (var) (adbv:set-self-rec-call! var #t)))) (for-each From 5752f6ace59f62b397fd180d8c531ad516ca688e Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 17 Oct 2018 18:48:18 -0400 Subject: [PATCH 006/115] Added alloca_pair --- include/cyclone/types.h | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/include/cyclone/types.h b/include/cyclone/types.h index 06cf71ca..70f0b672 100644 --- a/include/cyclone/types.h +++ b/include/cyclone/types.h @@ -1095,6 +1095,14 @@ typedef pair_type *pair; n.pair_car = a; \ n.pair_cdr = d; +#define alloca_pair(n,a,d) \ + pair_type *n = alloca(sizeof(pair_type)); \ + n->hdr.mark = gc_color_red; \ + n->hdr.grayed = 0; \ + n->tag = pair_tag; \ + n->pair_car = a; \ + n->pair_cdr = d; + #define set_pair(n,a,d) \ n->hdr.mark = gc_color_red; \ n->hdr.grayed = 0; \ From 5f760e4a2c72b62136f27e0a6d61faef99dbad3b Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 18 Oct 2018 13:10:32 -0400 Subject: [PATCH 007/115] Use alloca_pair instead of make_pair for literals --- scheme/cyclone/cgen.sld | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index f7a823bc..3aa70014 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -398,7 +398,7 @@ (create-cons (lambda (cvar a b) (c-code/vars - (string-append "make_pair(" cvar "," (c:body a) "," (c:body b) ");") + (string-append "alloca_pair(" cvar "," (c:body a) "," (c:body b) ");") (append (c:allocs a) (c:allocs b)))) ) (_c-compile-scalars @@ -416,7 +416,7 @@ (_c-compile-scalars (cdr args))))) (set! num-args (+ 1 num-args)) (c-code/vars - (string-append "&" cvar-name) + cvar-name ;; Not needed with alloca - (string-append "&" cvar-name) (append (c:allocs cell) (list (c:body cell)))))))))) From b37cbc3106b3984f50a91e173697237d6af5dcdd Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 18 Oct 2018 17:56:06 -0400 Subject: [PATCH 008/115] Added calls-self to adbf --- scheme/cyclone/cps-optimizations.sld | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index ec76a963..9214f1b1 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -87,6 +87,7 @@ adbf:well-known adbf:set-well-known! adbf:cgen-id adbf:set-cgen-id! adbf:closure-size adbf:set-closure-size! + adbf:calls-self? adbf:set-calls-self! with-fnc with-fnc! ) @@ -224,6 +225,8 @@ side-effects well-known cgen-id + closure-size + calls-self ) adb:function? (simple adbf:simple adbf:set-simple!) @@ -241,6 +244,8 @@ (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!) + ;; Does this function call itself? + (calls-self adbf:calls-self? adbf:set-calls-self!) ) (define (adb:make-fnc) (%adb:make-fnc @@ -252,6 +257,7 @@ #f ;; well-known #f ;; cgen-id -1 ;; closure-size + #f ;; calls-self )) ;; A constant value that cannot be mutated @@ -2058,6 +2064,8 @@ (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 From 23aaae8f051acec5e8a960233662b3c6b9180ee3 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 19 Oct 2018 13:23:18 -0400 Subject: [PATCH 009/115] WIP --- scheme/cyclone/cgen.sld | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 3aa70014..57d74096 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -839,7 +839,7 @@ "\n" cgen-body ;; TODO: (c:body cgen) ;; TODO: re-assign function args, longer-term using temp variables "\n" - "goto loop;"))) + "continue;"))) ) ((prim? fun) @@ -1484,10 +1484,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? @@ -1536,8 +1541,8 @@ (else (string-append (st:->code trace) - ;; TODO: probably needs brackets afterwards... - (if has-loop? "\nloop: {\n" "") + TODO: does not work for calls-self, need to invoke that elsewhere... + (if has-loop? "\n while(1) {\n" "") )))) body) " ") From 88f0db1547c57c85106b9e7275166ad187d5d14f Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 19 Oct 2018 13:33:47 -0400 Subject: [PATCH 010/115] Fix TODO --- scheme/cyclone/cgen.sld | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 57d74096..4f2e0632 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -1537,11 +1537,12 @@ (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: does not work for calls-self, need to invoke that elsewhere... (if has-loop? "\n while(1) {\n" "") )))) body) From c1e8996ddd0fb299adfbcd53353fc6d7fd4d0ac9 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 22 Oct 2018 13:34:16 -0400 Subject: [PATCH 011/115] Added TODO --- scheme/cyclone/cgen.sld | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 4f2e0632..fd5ea0e2 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -921,6 +921,10 @@ (fnc (if wkf (adb:get/default (ast:lambda-id wkf) #f) #f)) ) (cond +;; TODO: check for self-call +;; ((and fnc +;; (adbf:calls-self? fnc) +;; ((and wkf fnc *optimize-well-known-lambdas* (adbf:well-known fnc) ;; not really needed From eb2ab6b74a03e7a250fd7572693254f703c4f6c7 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 22 Oct 2018 13:35:04 -0400 Subject: [PATCH 012/115] Added (self-closure-call? ast self) --- scheme/cyclone/cps-optimizations.sld | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 9214f1b1..d307a0ef 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -90,6 +90,8 @@ adbf:calls-self? adbf:set-calls-self! with-fnc with-fnc! + ;; Helpers + self-closure-call? ) (begin ;; The following two defines allow non-CPS functions to still be considered @@ -1782,6 +1784,20 @@ (list (convert exp #f '())) #f)) +;; Detect closure call of the form: +;; (%closure-ref +;; (cell-get (%closure-ref self$249 1)) +;; 0) +(define (self-closure-call? ast self) + (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))) + ) + #t)) + (define (analyze:find-named-lets exp) (define (scan exp lp) (cond From 8930d9c8dffe05adab5a80987da75dbe222f55f3 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 22 Oct 2018 13:35:33 -0400 Subject: [PATCH 013/115] Added TODO --- scheme/cyclone/cgen.sld | 1 + 1 file changed, 1 insertion(+) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index fd5ea0e2..4619fed0 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -922,6 +922,7 @@ ) (cond ;; TODO: check for self-call +;; TODO: use (self-closure-call? ast self) ;; ((and fnc ;; (adbf:calls-self? fnc) ;; From fb8de77d37db08827655004dafbb9354bd9fd87e Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 22 Oct 2018 17:16:25 -0400 Subject: [PATCH 014/115] Detect actual recursive calls --- scheme/cyclone/cgen.sld | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 4619fed0..65535682 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -919,13 +919,25 @@ (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)) + (ast-fnc (adb:get/default ast-id #f)) ) (cond -;; TODO: check for self-call -;; TODO: use (self-closure-call? ast self) -;; ((and fnc -;; (adbf:calls-self? fnc) -;; + ;; Handle recursive calls via iteration, if possible + ((and ast-fnc + (adbf:calls-self? ast-fnc) + (self-closure-call? fun (car (adbf:all-params ast-fnc))) + ) + (c-code + (string-append + (c:allocs->str (c:allocs cfun) "\n") + (c:allocs->str (c:allocs cargs) "\n") + "/* TODO: call self */ return_closcall" (number->string (c:num-args cargs)) + "(data," + this-cont + (if (> (c:num-args cargs) 0) "," "") + (c:body cargs) + ");"))) + ((and wkf fnc *optimize-well-known-lambdas* (adbf:well-known fnc) ;; not really needed From 870a9a9763b48d69f55465642f1efee6582cb7f7 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 22 Oct 2018 17:28:25 -0400 Subject: [PATCH 015/115] Added TODO --- scheme/cyclone/cgen.sld | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 65535682..3a4c4d55 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -927,6 +927,23 @@ (adbf:calls-self? ast-fnc) (self-closure-call? fun (car (adbf:all-params ast-fnc))) ) +;; TODO: need to emit all of this: +;; GC check (w/fnc args and closure) +;; arg reassignment +;; continue statement +;; +;; example: +;; +;; if (stack_overflow(c_73374, (((gc_thread_data *)data)->stack_limit))) { +;; //printf("starting GC\n"); +;; object buf[3]; buf[0] = k_73154; buf[1] = l_7317_73101;buf[2] = a_7318_73102; +;; GC(data, self_73251, buf, argc); +;; } +;;//return_closcall3(data, car(((closureN)self_73251)->elements[0]), k_73154, Cyc_cddr(data, l_7317_73101), c_73374); +;; // same, no need to reassign: k_73154 = k_73154; +;; l_7317_73101 = Cyc_cddr(data, l_7317_73101); +;; a_7318_73102 = c_73374; +;; continue; (c-code (string-append (c:allocs->str (c:allocs cfun) "\n") From 1989d32664ef1b3961c69d379f37e00c7902f542 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 23 Oct 2018 11:33:05 -0400 Subject: [PATCH 016/115] Added continue_or_gc macros --- scheme/cyclone/cgen.sld | 29 ++++++++++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 3a4c4d55..c6d8c966 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -127,6 +127,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 +155,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")) @@ -928,8 +948,8 @@ (self-closure-call? fun (car (adbf:all-params ast-fnc))) ) ;; TODO: need to emit all of this: -;; GC check (w/fnc args and closure) ;; arg reassignment +;; GC check (w/fnc args and closure) - do after so we can just use args directly ;; continue statement ;; ;; example: @@ -948,12 +968,15 @@ (string-append (c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cargs) "\n") - "/* TODO: call self */ return_closcall" (number->string (c:num-args cargs)) + ;; TODO: reassign args + ;; TODO: consider passing in a "top" instead of always calling alloca in macro below: + "/* TODO: call self */ continue_or_gc" (number->string (c:num-args cargs)) "(data," this-cont (if (> (c:num-args cargs) 0) "," "") (c:body cargs) - ");"))) + ");" + ))) ((and wkf fnc *optimize-well-known-lambdas* From c39183500abeaa84db3631cc51254ee689d9c73b Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 23 Oct 2018 12:03:52 -0400 Subject: [PATCH 017/115] WIP --- scheme/cyclone/cgen.sld | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index c6d8c966..4381ce43 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -964,15 +964,23 @@ ;; l_7317_73101 = Cyc_cddr(data, l_7317_73101); ;; a_7318_73102 = c_73374; ;; continue; + +;; TODO: how to handle varargs (maybe we don't)?? +(for-each + (lambda (param arg) + (trace:error `(JAE ,param = ,arg))) + (cdr (adbf:all-params ast-fnc)) + (string-split (c:body cargs) #\,)) + (c-code (string-append (c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cargs) "\n") ;; TODO: reassign args ;; TODO: consider passing in a "top" instead of always calling alloca in macro below: - "/* TODO: call self */ continue_or_gc" (number->string (c:num-args cargs)) + "continue_or_gc" (number->string (c:num-args cargs)) "(data," - this-cont + (mangle (car (adbf:all-params ast-fnc))) ;; Call back into self after GC (if (> (c:num-args cargs) 0) "," "") (c:body cargs) ");" @@ -1378,7 +1386,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) From d0564e991e909be1700241ed8544972c71188c3d Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 23 Oct 2018 12:16:33 -0400 Subject: [PATCH 018/115] WIP --- scheme/cyclone/cgen.sld | 47 ++++++++++++++++++++--------------------- 1 file changed, 23 insertions(+), 24 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 4381ce43..0ce86a79 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -947,36 +947,34 @@ (adbf:calls-self? ast-fnc) (self-closure-call? fun (car (adbf:all-params ast-fnc))) ) -;; TODO: need to emit all of this: -;; arg reassignment -;; GC check (w/fnc args and closure) - do after so we can just use args directly -;; continue statement -;; -;; example: -;; -;; if (stack_overflow(c_73374, (((gc_thread_data *)data)->stack_limit))) { -;; //printf("starting GC\n"); -;; object buf[3]; buf[0] = k_73154; buf[1] = l_7317_73101;buf[2] = a_7318_73102; -;; GC(data, self_73251, buf, argc); -;; } -;;//return_closcall3(data, car(((closureN)self_73251)->elements[0]), k_73154, Cyc_cddr(data, l_7317_73101), c_73374); -;; // same, no need to reassign: k_73154 = k_73154; -;; l_7317_73101 = Cyc_cddr(data, l_7317_73101); -;; a_7318_73102 = c_73374; -;; continue; - -;; TODO: how to handle varargs (maybe we don't)?? -(for-each - (lambda (param arg) - (trace:error `(JAE ,param = ,arg))) - (cdr (adbf:all-params ast-fnc)) - (string-split (c:body cargs) #\,)) +(let* ((params (map mangle (cdr (adbf:all-params ast-fnc)))) + ;; TODO: doesn't work, arg may contain non-CPS functions which have their own args... + (args (map (lambda (s) + (string-replace-all s " " "")) + (string-split (c:body cargs) #\,))) + (reassignments (apply string-append + (map + (lambda (param arg) + (cond + ((equal? param arg) "") ;; No need to reassign + (else + (string-append + param " = " arg ";\n")))) + params + args)) + )) +;(for-each +; (lambda (param arg) +; (trace:error `(JAE ,param = ,arg))) +; params +; args) (c-code (string-append (c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cargs) "\n") ;; TODO: reassign args + 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," @@ -985,6 +983,7 @@ (c:body cargs) ");" ))) + ) ((and wkf fnc *optimize-well-known-lambdas* From 49c2c093fdd43ff180c879a372950bc7729dc2f4 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 23 Oct 2018 13:31:01 -0400 Subject: [PATCH 019/115] Reassign args when doing C iteration Reassign arguments when optimizing to use C iteration in place of recursive function calls. --- scheme/cyclone/cgen.sld | 73 ++++++++++++++++++++++------------------- 1 file changed, 39 insertions(+), 34 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 0ce86a79..30cc03f2 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -760,6 +760,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 @@ -767,17 +768,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?) @@ -924,6 +934,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?) @@ -947,33 +958,27 @@ (adbf:calls-self? ast-fnc) (self-closure-call? fun (car (adbf:all-params ast-fnc))) ) -(let* ((params (map mangle (cdr (adbf:all-params ast-fnc)))) - ;; TODO: doesn't work, arg may contain non-CPS functions which have their own args... - (args (map (lambda (s) - (string-replace-all s " " "")) - (string-split (c:body cargs) #\,))) - (reassignments (apply string-append - (map - (lambda (param arg) - (cond - ((equal? param arg) "") ;; No need to reassign - (else - (string-append - param " = " arg ";\n")))) - params - args)) - )) -;(for-each -; (lambda (param arg) -; (trace:error `(JAE ,param = ,arg))) -; params -; args) - + (let* ((params (map mangle (cdr (adbf:all-params ast-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)))) (c-code (string-append (c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cargs) "\n") - ;; TODO: reassign args reassignments ;; TODO: consider passing in a "top" instead of always calling alloca in macro below: "continue_or_gc" (number->string (c:num-args cargs)) From b2a981b7e57dffde678ba31f654dbff19e58a090 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 23 Oct 2018 18:09:02 -0400 Subject: [PATCH 020/115] WIP --- scheme/cyclone/cgen.sld | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 30cc03f2..602fccd5 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -649,9 +649,20 @@ (and (> len 0) (equal? end (substring str (- len 1) len))))) +TODO: move this into prim module, integrate with existing function somehow +;;(define (prim->c-func* p use-alloca?) +;; (cond +;; (else +;; (prim->c-func p)))) +TODO: add use-alloca? param to prim:allocates-object? and modify per above + ;; 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* ((ast-fnc (adb:get/default ast-id #f)) + ;; Use alloca for stack allocations? + (use-alloca? (and ast-fnc + (adbf:calls-self? ast-fnc))) + (c-func (if (prim:udf? p) (string-append "((inline_function_type) @@ -874,7 +885,7 @@ ((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)) From be5a5f1c6b58c7171f46b3f6eba68aebfe5a4f32 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 24 Oct 2018 13:17:44 -0400 Subject: [PATCH 021/115] WIP - optionally emit alloca-based prims --- scheme/cyclone/cgen.sld | 17 +++++++++-------- scheme/cyclone/primitives.sld | 21 ++++++++++++++++++--- 2 files changed, 27 insertions(+), 11 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 602fccd5..dc90cc38 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -649,12 +649,12 @@ (and (> len 0) (equal? end (substring str (- len 1) len))))) -TODO: move this into prim module, integrate with existing function somehow -;;(define (prim->c-func* p use-alloca?) -;; (cond -;; (else -;; (prim->c-func p)))) -TODO: add use-alloca? param to prim:allocates-object? and modify per above +;;TODO: move this into prim module, integrate with existing function somehow +;;;;(define (prim->c-func* p use-alloca?) +;;;; (cond +;;;; (else +;;;; (prim->c-func p)))) +;;TODO: add use-alloca? param to prim:allocates-object? and modify per above ;; c-compile-prim : prim-exp -> string -> string (define (c-compile-prim p cont ast-id) @@ -669,7 +669,7 @@ TODO: add use-alloca? param to prim:allocates-object? and modify per above ((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. ;; @@ -750,7 +750,7 @@ TODO: add use-alloca? param to prim:allocates-object? and modify per above ;; (let ((cv-name (mangle (gensym 'c)))) (c-code/vars - (if (prim:allocates-object? p) + (if (prim:allocates-object? p use-alloca?) cv-name ;; Already a pointer (string-append "&" cv-name)) ;; Point to data (list @@ -966,6 +966,7 @@ TODO: add use-alloca? param to prim:allocates-object? and modify per above (cond ;; Handle recursive calls via iteration, if possible ((and ast-fnc + #f ;; TODO: temporarily disabled (adbf:calls-self? ast-fnc) (self-closure-call? fun (car (adbf:all-params ast-fnc))) ) diff --git a/scheme/cyclone/primitives.sld b/scheme/cyclone/primitives.sld index 1a0319dd..154642c0 100644 --- a/scheme/cyclone/primitives.sld +++ b/scheme/cyclone/primitives.sld @@ -457,7 +457,21 @@ (define (prim-call? exp) (and (list? exp) (prim? (car exp)))) - (define (prim->c-func p) + (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") + (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 +890,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 From c10d38e170b16b8231987da242ccf84278812a93 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 24 Oct 2018 13:29:34 -0400 Subject: [PATCH 022/115] Support alloca of basic arithmetic operations --- scheme/cyclone/cgen.sld | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index dc90cc38..166e2c8a 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -692,12 +692,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 From 02df0f9fb2ec02608daeb87fc33a521332e0dcef Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 24 Oct 2018 13:36:31 -0400 Subject: [PATCH 023/115] Re-enable iteration --- scheme/cyclone/cgen.sld | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 166e2c8a..480fb8a0 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -971,7 +971,7 @@ (cond ;; Handle recursive calls via iteration, if possible ((and ast-fnc - #f ;; TODO: temporarily disabled + ;#f ;; TODO: temporarily disabled (adbf:calls-self? ast-fnc) (self-closure-call? fun (car (adbf:all-params ast-fnc))) ) From c914d80e7fc91479c08be0b2274aeb3ee1afaeda Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 24 Oct 2018 17:26:46 -0400 Subject: [PATCH 024/115] Pass params to continue_or_gc since already reassigned --- scheme/cyclone/cgen.sld | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 480fb8a0..312cabaa 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -1002,7 +1002,7 @@ "(data," (mangle (car (adbf:all-params ast-fnc))) ;; Call back into self after GC (if (> (c:num-args cargs) 0) "," "") - (c:body cargs) + (string-join params ", ") ");" ))) ) From 7e6ad07d9fd839b5e910de07be36e591f1201e69 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 24 Oct 2018 18:18:42 -0400 Subject: [PATCH 025/115] Alloc closures as needed --- scheme/cyclone/cgen.sld | 62 +++++++++++++++++++++-------------------- 1 file changed, 32 insertions(+), 30 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 312cabaa..18df0385 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -649,19 +649,15 @@ (and (> len 0) (equal? end (substring str (- len 1) len))))) -;;TODO: move this into prim module, integrate with existing function somehow -;;;;(define (prim->c-func* p use-alloca?) -;;;; (cond -;;;; (else -;;;; (prim->c-func p)))) -;;TODO: add use-alloca? param to prim:allocates-object? and modify per above +;; Use alloca() for stack allocations? +(define (alloca? ast-id) + (let ((ast-fnc (adb:get/default ast-id #f))) + (and ast-fnc + (adbf:calls-self? ast-fnc)))) ;; c-compile-prim : prim-exp -> string -> string (define (c-compile-prim p cont ast-id) - (let* ((ast-fnc (adb:get/default ast-id #f)) - ;; Use alloca for stack allocations? - (use-alloca? (and ast-fnc - (adbf:calls-self? ast-fnc))) + (let* ((use-alloca? (alloca? ast-id)) (c-func (if (prim:udf? p) (string-append @@ -1435,6 +1431,7 @@ ;; (define (c-compile-closure exp append-preamble cont ast-id trace cps?) (let* ((lam (closure->lam exp)) + (use-alloca? (alloca? ast-id)) (free-vars (map (lambda (free-var) @@ -1470,26 +1467,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? From 6f47046be0e0680c4b52fca0e63e84ed3f14fc9e Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 24 Oct 2018 22:43:32 -0400 Subject: [PATCH 026/115] Properly reference closures --- scheme/cyclone/cgen.sld | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 18df0385..9a248391 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -1518,7 +1518,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) From 32b6426318cddcb73a18d33f11ee6c9285256e45 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 25 Oct 2018 13:26:09 -0400 Subject: [PATCH 027/115] Check inner ref --- scheme/cyclone/cps-optimizations.sld | 1 + 1 file changed, 1 insertion(+) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index d307a0ef..39a979b9 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1795,6 +1795,7 @@ ((tagged-list? '%closure-ref inner-cref)) (equal? self (cadr inner-cref)) ((equal? 0 (caddr ast))) + ((equal? 1 (caddr inner-cref))) ) #t)) From f68e335b8a4ed5a707ca71a0c7e71a265fde69b1 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 25 Oct 2018 17:34:12 -0400 Subject: [PATCH 028/115] Export all adbf functions --- scheme/cyclone/cps-optimizations.sld | 1 + 1 file changed, 1 insertion(+) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 39a979b9..a43524fc 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -83,6 +83,7 @@ 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! From a2d877717ef99083733cbe9b00cdb653c2ed0336 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 25 Oct 2018 17:42:35 -0400 Subject: [PATCH 029/115] Added self-closure-index --- scheme/cyclone/cps-optimizations.sld | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index a43524fc..cf187628 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -88,6 +88,7 @@ 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! @@ -229,6 +230,7 @@ well-known cgen-id closure-size + self-closure-index calls-self ) adb:function? @@ -247,6 +249,8 @@ (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!) ) @@ -260,6 +264,7 @@ #f ;; well-known #f ;; cgen-id -1 ;; closure-size + -1 ;; self-closure-index #f ;; calls-self )) From 6577d9d462133977814996e4e76125f78c15e834 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 25 Oct 2018 17:47:41 -0400 Subject: [PATCH 030/115] Added find-closure-assigned-var-index! --- scheme/cyclone/cgen.sld | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 9a248391..74b5b733 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -988,6 +988,7 @@ 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") @@ -1414,6 +1415,24 @@ (string-append "((closureN)" (mangle var) ")->elements[" idx "]")))))) +(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) + ) + (set! index (+ index 1)) + ) + closure-args) + ) + (else #f)))) ;; c-compile-closure : closure-exp (string -> void) -> string ;; @@ -1513,6 +1532,7 @@ cv-name ".num_args = " (number->string (compute-num-args lam)) ";" ))))) ;(trace:info (list 'JAE-DEBUG trace macro?)) + (find-closure-assigned-var-index! lam (cdr exp)) (cond (use-obj-instead-of-closure? (create-object)) From 67698ec9a752d71e45191b9c3a8add37c7c2da6c Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 25 Oct 2018 17:47:49 -0400 Subject: [PATCH 031/115] Added TODO --- scheme/cyclone/cps-optimizations.sld | 1 + 1 file changed, 1 insertion(+) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index cf187628..39974883 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1794,6 +1794,7 @@ ;; (%closure-ref ;; (cell-get (%closure-ref self$249 1)) ;; 0) +TODO: need adbf, only a closure call if inner-cref's index matches adbf:self-closure-index (define (self-closure-call? ast self) (and-let* (((tagged-list? '%closure-ref ast)) ((tagged-list? 'cell-get (cadr ast))) From 8bd87a8ef605ae83055f2ab817475238a190b604 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 25 Oct 2018 17:42:02 -0400 Subject: [PATCH 032/115] Refactoring --- scheme/cyclone/cgen.sld | 25 ++++++++++++++++++++++--- scheme/cyclone/cps-optimizations.sld | 18 ------------------ 2 files changed, 22 insertions(+), 21 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 74b5b733..ac7f8a58 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? @@ -418,7 +420,7 @@ (create-cons (lambda (cvar a b) (c-code/vars - (string-append "alloca_pair(" cvar "," (c:body a) "," (c:body b) ");") + (string-append "make_pair(" cvar "," (c:body a) "," (c:body b) ");") (append (c:allocs a) (c:allocs b)))) ) (_c-compile-scalars @@ -436,7 +438,8 @@ (_c-compile-scalars (cdr args))))) (set! num-args (+ 1 num-args)) (c-code/vars - cvar-name ;; Not needed with alloca - (string-append "&" cvar-name) + ;;cvar-name ;; Not needed with alloca - (string-append "&" cvar-name) + (string-append "&" cvar-name) (append (c:allocs cell) (list (c:body cell)))))))))) @@ -762,6 +765,22 @@ ;; END primitives ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Detect closure call of the form: +;; (%closure-ref +;; (cell-get (%closure-ref self$249 1)) +;; 0) +;;TODO: need adbf, only a closure call if inner-cref's index matches adbf:self-closure-index +(define (self-closure-call? ast self) + (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? 1 (caddr inner-cref))) + ) + #t)) + ; c-compile-ref : ref-exp -> string (define (c-compile-ref exp) (c-code @@ -967,7 +986,7 @@ (cond ;; Handle recursive calls via iteration, if possible ((and ast-fnc - ;#f ;; TODO: temporarily disabled + #f ;; TODO: temporarily disabled (adbf:calls-self? ast-fnc) (self-closure-call? fun (car (adbf:all-params ast-fnc))) ) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 39974883..0d7f4528 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -92,8 +92,6 @@ adbf:calls-self? adbf:set-calls-self! with-fnc with-fnc! - ;; Helpers - self-closure-call? ) (begin ;; The following two defines allow non-CPS functions to still be considered @@ -1790,22 +1788,6 @@ (list (convert exp #f '())) #f)) -;; Detect closure call of the form: -;; (%closure-ref -;; (cell-get (%closure-ref self$249 1)) -;; 0) -TODO: need adbf, only a closure call if inner-cref's index matches adbf:self-closure-index -(define (self-closure-call? ast self) - (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? 1 (caddr inner-cref))) - ) - #t)) - (define (analyze:find-named-lets exp) (define (scan exp lp) (cond From 6bc445e9edc1029cbd0e848a9638557869990b87 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 25 Oct 2018 18:27:14 -0400 Subject: [PATCH 033/115] Cleanup, check for proper index of "self" in clo --- scheme/cyclone/cgen.sld | 46 +++++++++++++++++++++++++++-------------- 1 file changed, 31 insertions(+), 15 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index ac7f8a58..9079e27e 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -654,9 +654,9 @@ ;; Use alloca() for stack allocations? (define (alloca? ast-id) - (let ((ast-fnc (adb:get/default ast-id #f))) - (and ast-fnc - (adbf:calls-self? ast-fnc)))) + (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 ast-id) @@ -765,19 +765,26 @@ ;; END primitives ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Detect closure call of the form: +;; 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) -;;TODO: need adbf, only a closure call if inner-cref's index matches adbf:self-closure-index -(define (self-closure-call? ast self) +;; +;; 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? 1 (caddr inner-cref))) + ((equal? closure-index (caddr inner-cref))) ) #t)) @@ -981,16 +988,20 @@ (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)) - (ast-fnc (adb:get/default ast-id #f)) + (adbf:fnc (adb:get/default ast-id #f)) ) (cond ;; Handle recursive calls via iteration, if possible - ((and ast-fnc - #f ;; TODO: temporarily disabled - (adbf:calls-self? ast-fnc) - (self-closure-call? fun (car (adbf:all-params ast-fnc))) + ((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 ast-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 @@ -1016,7 +1027,7 @@ ;; 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 ast-fnc))) ;; Call back into self after GC + (mangle (car (adbf:all-params adbf:fnc))) ;; Call back into self after GC (if (> (c:num-args cargs) 0) "," "") (string-join params ", ") ");" @@ -1434,6 +1445,10 @@ (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))) @@ -1446,6 +1461,7 @@ (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)) ) @@ -1468,6 +1484,7 @@ ;; 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 @@ -1551,7 +1568,6 @@ cv-name ".num_args = " (number->string (compute-num-args lam)) ";" ))))) ;(trace:info (list 'JAE-DEBUG trace macro?)) - (find-closure-assigned-var-index! lam (cdr exp)) (cond (use-obj-instead-of-closure? (create-object)) From 4824fc50ede054bcca12b3141b0aa5ca93092ed7 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 26 Oct 2018 13:03:54 -0400 Subject: [PATCH 034/115] Increased alloca support --- include/cyclone/types.h | 19 +++++++++++++++++++ scheme/cyclone/primitives.sld | 7 ++++++- 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/include/cyclone/types.h b/include/cyclone/types.h index 70f0b672..44b1d449 100644 --- a/include/cyclone/types.h +++ b/include/cyclone/types.h @@ -1128,11 +1128,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/cyclone/primitives.sld b/scheme/cyclone/primitives.sld index 154642c0..992acef1 100644 --- a/scheme/cyclone/primitives.sld +++ b/scheme/cyclone/primitives.sld @@ -465,7 +465,12 @@ ;; 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 '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 From 149e10257cbd1166f2d43e66922a8ca2efaa2a33 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 26 Oct 2018 13:19:52 -0400 Subject: [PATCH 035/115] Remove debug trace --- scheme/cyclone/cgen.sld | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 9079e27e..d824cb64 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -1018,7 +1018,7 @@ param " = " arg ";\n")))) params args)))) -(trace:error `(JAE ,fun ,ast-id ,params ,args (c:num-args cargs))) +;(trace:error `(JAE ,fun ,ast-id ,params ,args (c:num-args cargs))) (c-code (string-append (c:allocs->str (c:allocs cfun) "\n") From 9d26dc8531b77a4c45d0fb4804b1b9cb5f85910e Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 29 Oct 2018 12:56:16 -0400 Subject: [PATCH 036/115] Remove old test file --- test-eval-compilation.scm | 22 ---------------------- 1 file changed, 22 deletions(-) delete mode 100644 test-eval-compilation.scm 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)) From dd6a5974df5bf31be149f86a97d5e54736021230 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 29 Oct 2018 13:05:53 -0400 Subject: [PATCH 037/115] Adding temporarily for testing purposes --- test-matrix.scm | 877 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 877 insertions(+) create mode 100644 test-matrix.scm diff --git a/test-matrix.scm b/test-matrix.scm new file mode 100644 index 00000000..c98428a2 --- /dev/null +++ b/test-matrix.scm @@ -0,0 +1,877 @@ +;;; 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)))) + +(write (zunda 1 -1)) +; +;(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) From 0113982e875ccb88575e6344f8c572e812dd193b Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 29 Oct 2018 13:11:32 -0400 Subject: [PATCH 038/115] WIP --- test-matrix.scm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/test-matrix.scm b/test-matrix.scm index c98428a2..401719f5 100644 --- a/test-matrix.scm +++ b/test-matrix.scm @@ -116,15 +116,19 @@ (vector-ref vec i)))))) (mat (cdr mat))) -(make-row->func 1 -1) - #;(zebra (first-row-perm 'child) +;(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 _-*- From 2d4a5f0f440945b46ce3832b54556b4bf62d5603 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 29 Oct 2018 18:51:47 -0400 Subject: [PATCH 039/115] WIP - sequencing expressions --- scheme/cyclone/cps-optimizations.sld | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 0d7f4528..87ad180d 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1082,6 +1082,20 @@ ;; 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 (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 From 6f65432c2a5ed17d9fa4437d7ed76733f6555b7b Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 30 Oct 2018 12:06:47 -0400 Subject: [PATCH 040/115] WIP - Cyc-seq --- scheme/cyclone/cps-optimizations.sld | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 87ad180d..e0be5e00 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -353,7 +353,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)) @@ -1679,7 +1680,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 (ast:lambda-formals->list exp))) globals)) (formals (list->lambda-formals (cons new-self-var (ast:lambda-formals->list exp)) @@ -1725,6 +1726,9 @@ (let ((fn (car exp)) (args (map cc (cdr exp)))) (cond + ((tagged-list? 'Cyc-seq exp) + (cons 'Cyc-seq + (map cc (cdr exp)))) ((ast:lambda? fn) (cond ;; If the lambda argument is not used, flag so the C code is @@ -1752,7 +1756,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 (ast:lambda-formals->list fn))) globals)) (new-free-vars? (> (length new-free-vars) 0))) (if new-free-vars? From e8834738859ea4ab7472483c90f46d2251be6b2f Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 30 Oct 2018 13:20:11 -0400 Subject: [PATCH 041/115] Use pre-computed sexp --- scheme/cyclone/cps-optimizations.sld | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index e0be5e00..8b7cb9fe 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1726,9 +1726,8 @@ (let ((fn (car exp)) (args (map cc (cdr exp)))) (cond - ((tagged-list? 'Cyc-seq exp) - (cons 'Cyc-seq - (map cc (cdr exp)))) + ((equal? 'Cyc-seq fn) + `(Cyc-seq ,@args)) ((ast:lambda? fn) (cond ;; If the lambda argument is not used, flag so the C code is From f2390130cc34e865b0914c2f57acf9dd1f5d2a4f Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 30 Oct 2018 17:52:49 -0400 Subject: [PATCH 042/115] Added TODO --- scheme/cyclone/cps-optimizations.sld | 2 ++ 1 file changed, 2 insertions(+) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 8b7cb9fe..2f91947a 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1726,6 +1726,8 @@ (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! ((equal? 'Cyc-seq fn) `(Cyc-seq ,@args)) ((ast:lambda? fn) From 7a5b03edd78fcbbbcb135716b92a8ddd1dcd3518 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 30 Oct 2018 18:09:00 -0400 Subject: [PATCH 043/115] WIP --- scheme/cyclone/cps-optimizations.sld | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 2f91947a..3ebe83a3 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1726,8 +1726,11 @@ (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! + ;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)) ((ast:lambda? fn) From 2a46a8f23521753b40def7f9dcec70d4c561a438 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 30 Oct 2018 18:14:31 -0400 Subject: [PATCH 044/115] WIP --- flatten-seq.scm | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 flatten-seq.scm diff --git a/flatten-seq.scm b/flatten-seq.scm new file mode 100644 index 00000000..1af7490b --- /dev/null +++ b/flatten-seq.scm @@ -0,0 +1,11 @@ +(import (scheme base) (scheme write) (scheme cyclone util)) + +(define sexp + '(Cyc-seq + (set! b '(#f . #f)) + ((Cyc-seq + (set-car! a 1) + ((Cyc-seq + (set-cdr! a '(2)))))))) + +;; TODO: goal is a single cyc-seq containing all expressions as a single list From 9ba8467ba0d1257921c7cba3cf1a349fbe944df5 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 30 Oct 2018 18:35:38 -0400 Subject: [PATCH 045/115] WIP --- flatten-seq.scm | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/flatten-seq.scm b/flatten-seq.scm index 1af7490b..5551a216 100644 --- a/flatten-seq.scm +++ b/flatten-seq.scm @@ -9,3 +9,20 @@ (set-cdr! a '(2)))))))) ;; TODO: goal is a single cyc-seq containing all expressions as a single list +(define (convert sexp) + (define (flat sexp acc) + (write `(flat ,sexp)) (newline) + (cond + ((null? sexp) acc) + ((tagged-list? 'Cyc-seq sexp) + (flat (cdr sexp) acc)) + ((and (app? sexp) + (tagged-list? 'Cyc-seq (car sexp))) + (flat (cdar sexp) acc)) + (else + (flat (cdr sexp) (cons sexp acc)))) + ) + (reverse + (flat sexp '(Cyc-seq)))) + +(write (convert sexp)) From d4e4f3ddf49537b38bf4d2164e64d70e7fa57e5d Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 31 Oct 2018 13:09:14 -0400 Subject: [PATCH 046/115] Working version --- flatten-seq.scm | 44 ++++++++++++++++++++++++++++++-------------- 1 file changed, 30 insertions(+), 14 deletions(-) diff --git a/flatten-seq.scm b/flatten-seq.scm index 5551a216..cf9b6333 100644 --- a/flatten-seq.scm +++ b/flatten-seq.scm @@ -1,4 +1,4 @@ -(import (scheme base) (scheme write) (scheme cyclone util)) +(import (scheme base) (scheme write) (scheme cyclone util) (scheme cyclone pretty-print)) (define sexp '(Cyc-seq @@ -8,21 +8,37 @@ ((Cyc-seq (set-cdr! a '(2)))))))) -;; TODO: goal is a single cyc-seq containing all expressions as a single list -(define (convert sexp) +;; 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))))))) +;; +;; becomes: +;; +;; '(Cyc-seq +;; (set! b '(#f . #f)) +;; (set-car! a 1) +;; (set-cdr! a '(2))) +;; +(define (flatten-subcalls sexp sym) (define (flat sexp acc) - (write `(flat ,sexp)) (newline) (cond - ((null? sexp) acc) - ((tagged-list? 'Cyc-seq sexp) - (flat (cdr sexp) acc)) - ((and (app? sexp) - (tagged-list? 'Cyc-seq (car sexp))) - (flat (cdar sexp) acc)) - (else - (flat (cdr sexp) (cons sexp acc)))) + ((not (pair? sexp)) + acc) + ((and (app? (car sexp)) + (app? (caar sexp)) + (tagged-list? sym (caar sexp))) + (flat (cdaar sexp) acc)) + (else ;;(pair? sexp) + (flat (cdr sexp) (cons (car sexp) acc)))) ) (reverse - (flat sexp '(Cyc-seq)))) + (flat sexp '()))) -(write (convert sexp)) +(pretty-print (flatten-subcalls sexp 'Cyc-seq)) +(pretty-print (flatten-subcalls '(a b c d e (f (g))) 'Cyc-seq)) From 31e749bf5a1af1d2776c876ec66a05d1bf74ece7 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 31 Oct 2018 17:57:30 -0400 Subject: [PATCH 047/115] Flatten nested Cyc-seq expressions. --- scheme/cyclone/transforms.sld | 36 +++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld index 36cf7c3c..931e1087 100644 --- a/scheme/cyclone/transforms.sld +++ b/scheme/cyclone/transforms.sld @@ -776,6 +776,9 @@ ; Application: ((app? exp) + ;; Easy place to clean up nested Cyc-seq expressions + (when (tagged-list? 'Cyc-seq exp) + (set! exp (flatten-subcalls exp 'Cyc-seq))) (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 +809,39 @@ 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))))))) +;; +;; becomes: +;; +;; '(Cyc-seq +;; (set! b '(#f . #f)) +;; (set-car! a 1) +;; (set-cdr! a '(2))) +;; +(define (flatten-subcalls sexp sym) + (define (flat sexp acc) + (cond + ((not (pair? sexp)) + acc) + ((and (app? (car sexp)) + (app? (caar sexp)) + (tagged-list? sym (caar sexp))) + (flat (cdaar sexp) acc)) + (else ;;(pair? sexp) + (flat (cdr sexp) (cons (car sexp) acc)))) + ) + (reverse + (flat sexp '()))) + + ;; Alpha conversion ;; (aka alpha renaming) ;; From 61d265c512b09f9f39c42dd545d1a01d80687968 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 1 Nov 2018 13:09:42 -0400 Subject: [PATCH 048/115] Splice in lambda body of cyc-seq --- scheme/cyclone/cps-optimizations.sld | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 3ebe83a3..086dd52b 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1094,7 +1094,7 @@ (opt:inline-prims `(Cyc-seq ,@(cdr exp) - ,(ast:lambda-body (car exp))) + ,@(ast:lambda-body (car exp))) scope-sym refs)) (else From 5868cd448c4c14661e65077f4f53ef1001e6dbf7 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 1 Nov 2018 13:20:20 -0400 Subject: [PATCH 049/115] Cleaner flattening now that code generation has been fixed --- flatten-seq.scm | 25 +++++++++++++------------ scheme/cyclone/transforms.sld | 18 +++++++++--------- 2 files changed, 22 insertions(+), 21 deletions(-) diff --git a/flatten-seq.scm b/flatten-seq.scm index cf9b6333..e579efef 100644 --- a/flatten-seq.scm +++ b/flatten-seq.scm @@ -3,37 +3,38 @@ (define sexp '(Cyc-seq (set! b '(#f . #f)) - ((Cyc-seq + (Cyc-seq (set-car! a 1) - ((Cyc-seq - (set-cdr! a '(2)))))))) + (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 +;; (Cyc-seq ;; (set-car! a 1) -;; ((Cyc-seq -;; (set-cdr! a '(2))))))) +;; (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))) +;; (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 (app? (car sexp)) - (app? (caar sexp)) - (tagged-list? sym (caar sexp))) - (flat (cdaar sexp) acc)) + ((and (tagged-list? sym (car sexp))) + (flat (cdar sexp) acc)) (else ;;(pair? sexp) (flat (cdr sexp) (cons (car sexp) acc)))) ) diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld index 931e1087..3afca0b0 100644 --- a/scheme/cyclone/transforms.sld +++ b/scheme/cyclone/transforms.sld @@ -814,27 +814,27 @@ ;; ;; '(Cyc-seq ;; (set! b '(#f . #f)) -;; ((Cyc-seq +;; (Cyc-seq ;; (set-car! a 1) -;; ((Cyc-seq -;; (set-cdr! a '(2))))))) +;; (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))) +;; (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 (app? (car sexp)) - (app? (caar sexp)) - (tagged-list? sym (caar sexp))) - (flat (cdaar sexp) acc)) + ((and (tagged-list? sym (car sexp))) + (flat (cdar sexp) acc)) (else ;;(pair? sexp) (flat (cdr sexp) (cons (car sexp) acc)))) ) From 8aac3163afe47aeb40004c1363eb6bf7dde60588 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 1 Nov 2018 13:40:57 -0400 Subject: [PATCH 050/115] Cleanup, remove unused identifiers from sequences --- scheme/cyclone/transforms.sld | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld index 3afca0b0..acddb3af 100644 --- a/scheme/cyclone/transforms.sld +++ b/scheme/cyclone/transforms.sld @@ -778,7 +778,7 @@ ((app? exp) ;; Easy place to clean up nested Cyc-seq expressions (when (tagged-list? 'Cyc-seq exp) - (set! exp (flatten-subcalls exp 'Cyc-seq))) + (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 @@ -828,13 +828,16 @@ ;; (set-cdr! a '(2)) ;; ((fnc a1 a2 a3))) ;; -(define (flatten-subcalls sexp sym) +(define (flatten-sequence sexp) (define (flat sexp acc) (cond - ((not (pair? sexp)) + ((not (pair? sexp)) ;; Stop at end of sexp acc) - ((and (tagged-list? sym (car sexp))) + ((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)))) ) From 6da33671698db4dcf67282d1c9092dca413ab109 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 1 Nov 2018 18:24:43 -0400 Subject: [PATCH 051/115] Do not sequence prims that call into conts --- scheme/cyclone/cps-optimizations.sld | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 086dd52b..2c0fedc0 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1085,6 +1085,11 @@ )) ;; ;; 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) From 7cb714a387503a2bd9429ce0113ddfe7d9675e0a Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 3 Nov 2018 22:27:55 -0400 Subject: [PATCH 052/115] Added notes --- CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 754c2b57..b25bf208 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ ## 0.9.4 - TBD +Features (notes) +- optimize recursive functions using C iteration +- combine lambda functions that are only called for side effects. + Bug Fixes - Prevent GC segmentation fault on ARM platforms (Raspberry Pi 2). From 62a81106478401ae43428e5982b768639d221b6c Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 7 Nov 2018 13:36:25 -0500 Subject: [PATCH 053/115] WIP --- scheme/cyclone/cps-optimizations.sld | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 2c0fedc0..9b87000e 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -581,7 +581,9 @@ ;; 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)) + (not (member (car exp) '(vector-set!))) ;; TODO: experimental + ) (let ((e (cadr exp))) (when (ref? e) (with-var e (lambda (var) @@ -1241,7 +1243,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))) @@ -1277,6 +1279,10 @@ (if (not (ref? e)) (inline-ok? e ivars args arg-used return))) (reverse (cdr exp)))) + TODO: add a new cond here + ;; TODO: if mutates, can we check to see if there are any "safe" params which we + ;; can safely ignore? for example, on vector-set! we know only the vec arg is being mutated, + ;; so ivars in other positions can be ignored (else (for-each (lambda (e) From a12ef1555920291810f42e156a50bd4fc48267c1 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 7 Nov 2018 18:08:09 -0500 Subject: [PATCH 054/115] WIP - smarter inline analysis of vector-set --- scheme/cyclone/cps-optimizations.sld | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 9b87000e..82cdb6b2 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -582,6 +582,7 @@ ;; is what is mutated (cond ((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))) @@ -1279,11 +1280,16 @@ (if (not (ref? e)) (inline-ok? e ivars args arg-used return))) (reverse (cdr exp)))) - TODO: add a new cond here - ;; TODO: if mutates, can we check to see if there are any "safe" params which we - ;; can safely ignore? for example, on vector-set! we know only the vec arg is being mutated, - ;; so ivars in other positions can be ignored - (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)) From 2ff11b1ace0cba8a4bc610fb578a491dbe822375 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 9 Nov 2018 10:57:11 -0500 Subject: [PATCH 055/115] Experimental: remove unnecessary bignum code --- gc.c | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) 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); From b50d7360e0342b0b2e6d76924e88dc004e7ba40a Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 9 Nov 2018 11:01:54 -0500 Subject: [PATCH 056/115] Added opt flag --- Makefile.config | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) 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 From 915ae74fe14f2460f9c994722f127279c62b2147 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 9 Nov 2018 12:53:47 -0500 Subject: [PATCH 057/115] Issue #172 - Allow inline but check for (set!)'s first --- scheme/cyclone/cps-optimizations.sld | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 82cdb6b2..a89571f2 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -54,6 +54,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 @@ -131,6 +133,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 @@ -148,6 +151,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 @@ -205,6 +209,7 @@ #f ; const-value 0 ; ref-count '() ; ref-by + #f ; mutated-by-set #f ; reassigned #f ; assigned-value 0 ; app-fnc-count @@ -556,6 +561,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))) @@ -989,11 +995,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 @@ -1166,7 +1168,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, From 70b1ac2e57701862aa96a0b82ad3c317b88b36a7 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 9 Nov 2018 15:41:55 -0500 Subject: [PATCH 058/115] Revert experimental changes These crash the earley benchmark --- scheme/cyclone/cps-optimizations.sld | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index a89571f2..9fa75a88 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -589,7 +589,7 @@ (cond ((and (prim:mutates? (car exp)) ;; loop3-dev WIP step #1 - do not immediately reject these prims - (not (member (car exp) '(vector-set!))) ;; TODO: experimental + ;(not (member (car exp) '(vector-set!))) ;; TODO: experimental ) (let ((e (cadr exp))) (when (ref? e) @@ -1297,14 +1297,14 @@ (inline-ok? e ivars args arg-used return))) (reverse (cdr exp)))) ;; 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) - ) + ;((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) From f95235f079a5751f475caefe142aa19eea9c40e0 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 9 Nov 2018 17:01:14 -0500 Subject: [PATCH 059/115] Note recent changes --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index b25bf208..81fb05f0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,7 @@ Features (notes) - optimize recursive functions using C iteration - combine lambda functions that are only called for side effects. +- improve inlining of primitives that work with immutable objects. Bug Fixes From f29b482334bf3247699c3747c28cb6a542e5edae Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 9 Nov 2018 17:04:51 -0500 Subject: [PATCH 060/115] Relocated file --- flatten-seq.scm => tests/debug/flatten-seq.scm | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename flatten-seq.scm => tests/debug/flatten-seq.scm (100%) diff --git a/flatten-seq.scm b/tests/debug/flatten-seq.scm similarity index 100% rename from flatten-seq.scm rename to tests/debug/flatten-seq.scm From 5cfcf88a3772f5fcf96e9dda33e4e9c4980803bd Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 9 Nov 2018 17:13:09 -0500 Subject: [PATCH 061/115] Initial file --- test-find-local-vars.scm | 89 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) create mode 100644 test-find-local-vars.scm diff --git a/test-find-local-vars.scm b/test-find-local-vars.scm new file mode 100644 index 00000000..3ef2edd0 --- /dev/null +++ b/test-find-local-vars.scm @@ -0,0 +1,89 @@ +(import (scheme base) (scheme write) (scheme cyclone ast) (scheme cyclone util) (scheme cyclone pretty-print)) + +(define (find-local-vars sexp) + (define (scan exp) + (cond + ((ast:lambda? exp) + (for-each + scan + (ast:lambda-body exp))) + ((quote? exp) exp) + ((const? exp) exp) + ((ref? exp) exp) + ((define? exp) + (for-each + scan + (define->exp exp))) + ((set!? exp) + (for-each + scan + (set!->exp exp))) + ((if? exp) + (scan (if->condition exp)) + (scan (if->then exp)) + (scan (if->else exp))) + ((app? exp) + (cond + ((ast:lambda? (car exp)) +;; TODO: want to find this: +;; ((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)))))))) + 'TODO) + (else + (map scan exp)))) + (else 'todo) + )) + (scan sexp)) + +(define sexp + '(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)))))))) + +;(pretty-print +; (ast:ast->pp-sexp +; (ast:sexp->ast sexp))) + +(find-local-vars (ast:sexp->ast sexp)) From d8b46a019a28e9a376855114cef26a2e096526dc Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 9 Nov 2018 17:28:49 -0500 Subject: [PATCH 062/115] WIP --- test-find-local-vars.scm | 61 ++++++++++++++++++++++++++-------------- 1 file changed, 40 insertions(+), 21 deletions(-) diff --git a/test-find-local-vars.scm b/test-find-local-vars.scm index 3ef2edd0..ee51ce98 100644 --- a/test-find-local-vars.scm +++ b/test-find-local-vars.scm @@ -1,5 +1,37 @@ (import (scheme base) (scheme write) (scheme cyclone ast) (scheme cyclone util) (scheme cyclone pretty-print)) +;; TODO: scan sexp, is sym only called in tail-call position? +(define (local-tail-call-only? sexp sym) + (call/cc + (lambda (return) + (define (scan exp fail?) + (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 + ((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)))) + (define (find-local-vars sexp) (define (scan exp) (cond @@ -24,27 +56,14 @@ (scan (if->else exp))) ((app? exp) (cond - ((ast:lambda? (car exp)) -;; TODO: want to find this: -;; ((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)))))))) + ((and + (ast:lambda? (car exp)) + (equal? (length exp) 2) + (ast:lambda? (cadr exp)) + (local-tail-call-only? + (ast:lambda-body (car exp)) + (car (ast:lambda-args (car exp))))) + (write `(tail-call-only? passed for ,exp)) (newline) 'TODO) (else (map scan exp)))) From 18c8fbf2607da28773a6a462473adda24857f05e Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 9 Nov 2018 17:43:03 -0500 Subject: [PATCH 063/115] Removed limitations --- docs/api/srfi/18.md | 6 ------ 1 file changed, 6 deletions(-) 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) From ef2adcdb11821095d1484559703503d35779980a Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 05:55:49 -0500 Subject: [PATCH 064/115] WIP --- cyclone.scm | 2 ++ test-find-local-vars.scm | 47 ++++++++++++++++++++++++++++++++++++++-- 2 files changed, 47 insertions(+), 2 deletions(-) diff --git a/cyclone.scm b/cyclone.scm index 9e4cd7bd..b277aef6 100644 --- a/cyclone.scm +++ b/cyclone.scm @@ -424,6 +424,8 @@ (trace:info (ast:ast->pp-sexp input-program)) ) +;; TODO: would want to introduce lets right here, at least to start + ;; 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") diff --git a/test-find-local-vars.scm b/test-find-local-vars.scm index ee51ce98..6c0046d8 100644 --- a/test-find-local-vars.scm +++ b/test-find-local-vars.scm @@ -32,6 +32,37 @@ (scan sexp #f) (return #t)))) +(define (tail-calls->values sexp 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... + ((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) + ) + (cadr exp)) + (else + (return #f)))) + (else exp))) + (return + (scan sexp))))) + (define (find-local-vars sexp) (define (scan exp) (cond @@ -60,11 +91,22 @@ (ast:lambda? (car exp)) (equal? (length exp) 2) (ast:lambda? (cadr exp)) + (equal? 1 (length (ast:lambda-args (cadr exp)))) (local-tail-call-only? (ast:lambda-body (car exp)) (car (ast:lambda-args (car exp))))) (write `(tail-call-only? passed for ,exp)) (newline) - 'TODO) + (write `(replace with ,(tail-calls->values + (car (ast:lambda-body (car exp))) + (car (ast:lambda-args (car exp)))))) + (newline) + (let ((value (tail-calls->values + (car (ast:lambda-body (car exp))) + (car (ast:lambda-args (car exp))))) + (var (car (ast:lambda-args (cadr exp)))) + (body (ast:lambda-body (cadr exp)))) + `((let ((,var ,value)) + ,body)))) (else (map scan exp)))) (else 'todo) @@ -105,4 +147,5 @@ ; (ast:ast->pp-sexp ; (ast:sexp->ast sexp))) -(find-local-vars (ast:sexp->ast sexp)) +(pretty-print + (find-local-vars (ast:sexp->ast sexp))) From c70c6f7338698c7b28d5449c5d5bdd7e565364db Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 06:19:54 -0500 Subject: [PATCH 065/115] First working version --- test-find-local-vars.scm | 55 ++++++++++++++++++++++------------------ 1 file changed, 31 insertions(+), 24 deletions(-) diff --git a/test-find-local-vars.scm b/test-find-local-vars.scm index 6c0046d8..b8446216 100644 --- a/test-find-local-vars.scm +++ b/test-find-local-vars.scm @@ -1,6 +1,6 @@ (import (scheme base) (scheme write) (scheme cyclone ast) (scheme cyclone util) (scheme cyclone pretty-print)) -;; TODO: scan sexp, is sym only called in tail-call position? +;; Scan sexp to determine if sym is only called in a tail-call position (define (local-tail-call-only? sexp sym) (call/cc (lambda (return) @@ -32,11 +32,12 @@ (scan sexp #f) (return #t)))) +;; Transform all tail calls of sym in the sexp to just the value passed (define (tail-calls->values sexp sym) (call/cc (lambda (return) (define (scan exp) - (write `(DEBUG scan ,exp)) (newline) + ;;(write `(DEBUG scan ,exp)) (newline) (cond ((ast:lambda? exp) (return #f)) ;; Could be OK if not ref'd... @@ -63,28 +64,33 @@ (return (scan sexp))))) -(define (find-local-vars sexp) +;; 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) (cond ((ast:lambda? exp) - (for-each - scan - (ast:lambda-body 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) - (for-each - scan - (define->exp exp))) + `(define + ,(define->var exp) + ,(map scan (define->exp exp)))) ((set!? exp) - (for-each - scan - (set!->exp exp))) + `(set! + ,(set!->var exp) + ,(set!->exp exp))) ((if? exp) - (scan (if->condition exp)) - (scan (if->then exp)) - (scan (if->else exp))) + `(if ,(scan (if->condition exp)) + ,(scan (if->then exp)) + ,(scan (if->else exp)))) ((app? exp) (cond ((and @@ -95,21 +101,21 @@ (local-tail-call-only? (ast:lambda-body (car exp)) (car (ast:lambda-args (car exp))))) - (write `(tail-call-only? passed for ,exp)) (newline) - (write `(replace with ,(tail-calls->values - (car (ast:lambda-body (car exp))) - (car (ast:lambda-args (car exp)))))) - (newline) + ;;(write `(tail-call-only? passed for ,exp)) (newline) + ;;(write `(replace with ,(tail-calls->values + ;; (car (ast:lambda-body (car exp))) + ;; (car (ast:lambda-args (car exp)))))) + ;;(newline) (let ((value (tail-calls->values (car (ast:lambda-body (car exp))) (car (ast:lambda-args (car exp))))) (var (car (ast:lambda-args (cadr exp)))) (body (ast:lambda-body (cadr exp)))) - `((let ((,var ,value)) - ,body)))) + `(let ((,var ,value)) + ,@body))) (else (map scan exp)))) - (else 'todo) + (else (error "unknown expression type: " exp)) )) (scan sexp)) @@ -148,4 +154,5 @@ ; (ast:sexp->ast sexp))) (pretty-print - (find-local-vars (ast:sexp->ast sexp))) + (ast:ast->pp-sexp + (opt:local-var-reduction (ast:sexp->ast sexp)))) From 7d52c4de35082d8776b22e5972736fde14d10e56 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 06:28:54 -0500 Subject: [PATCH 066/115] Cleanup --- test-find-local-vars.scm | 137 ++++++++++++++++++++------------------- 1 file changed, 70 insertions(+), 67 deletions(-) diff --git a/test-find-local-vars.scm b/test-find-local-vars.scm index b8446216..c7a3e894 100644 --- a/test-find-local-vars.scm +++ b/test-find-local-vars.scm @@ -1,69 +1,6 @@ (import (scheme base) (scheme write) (scheme cyclone ast) (scheme cyclone util) (scheme cyclone pretty-print)) -;; Scan sexp to determine if sym is only called in a tail-call position -(define (local-tail-call-only? sexp sym) - (call/cc - (lambda (return) - (define (scan exp fail?) - (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 - ((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)))) - -;; Transform all tail calls of sym in the sexp to just the value passed -(define (tail-calls->values sexp 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... - ((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) - ) - (cadr exp)) - (else - (return #f)))) - (else exp))) - (return - (scan sexp))))) - +;; 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. @@ -98,15 +35,15 @@ (equal? (length exp) 2) (ast:lambda? (cadr exp)) (equal? 1 (length (ast:lambda-args (cadr exp)))) - (local-tail-call-only? + (lvr:local-tail-call-only? (ast:lambda-body (car exp)) (car (ast:lambda-args (car exp))))) ;;(write `(tail-call-only? passed for ,exp)) (newline) - ;;(write `(replace with ,(tail-calls->values + ;;(write `(replace with ,(lvr:tail-calls->values ;; (car (ast:lambda-body (car exp))) ;; (car (ast:lambda-args (car exp)))))) ;;(newline) - (let ((value (tail-calls->values + (let ((value (lvr:tail-calls->values (car (ast:lambda-body (car exp))) (car (ast:lambda-args (car exp))))) (var (car (ast:lambda-args (cadr exp)))) @@ -119,6 +56,72 @@ )) (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?) + (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 + ((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) + (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... + ((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) + ) + (cadr exp)) + (else + (return #f)))) + (else exp))) + (return + (scan sexp))))) + (define sexp '(lambda (k$1073 i$88$682 first$89$683 row$90$684) From 74e56aeb2fcfdb69f5697c26f7dfc67a096156c7 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 06:39:13 -0500 Subject: [PATCH 067/115] Issue #280 - Cyc-add-feature! --- scheme/base.sld | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) 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*) From 8cbcf821212b5b7493b91a5069a83c1975afbc00 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 06:52:54 -0500 Subject: [PATCH 068/115] Added a special (program) feature --- cyclone.scm | 9 +++-- test-find-local-vars.scm | 85 ++++++++++++++++++++++------------------ 2 files changed, 53 insertions(+), 41 deletions(-) diff --git a/cyclone.scm b/cyclone.scm index b277aef6..7eef0bc1 100644 --- a/cyclone.scm +++ b/cyclone.scm @@ -547,10 +547,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/test-find-local-vars.scm b/test-find-local-vars.scm index c7a3e894..02d66d54 100644 --- a/test-find-local-vars.scm +++ b/test-find-local-vars.scm @@ -1,4 +1,10 @@ -(import (scheme base) (scheme write) (scheme cyclone ast) (scheme cyclone util) (scheme cyclone pretty-print)) +(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 @@ -122,40 +128,43 @@ (return (scan sexp))))) -(define sexp - '(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)))))))) - -;(pretty-print -; (ast:ast->pp-sexp -; (ast:sexp->ast sexp))) - -(pretty-print - (ast:ast->pp-sexp - (opt:local-var-reduction (ast:sexp->ast sexp)))) +(cond-expand + (program + (define sexp + '(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)))))))) + + ;(pretty-print + ; (ast:ast->pp-sexp + ; (ast:sexp->ast sexp))) + + (pretty-print + (ast:ast->pp-sexp + (opt:local-var-reduction (ast:sexp->ast sexp)))) + )) From 925f4d983c0371197932d57949c9f9fd44988b26 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 06:54:17 -0500 Subject: [PATCH 069/115] Issue #280 - Working through how this should operate --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 81fb05f0..49e8c758 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,8 @@ Features (notes) - optimize recursive functions using C iteration - combine lambda functions that are only called for side effects. - improve inlining of primitives that work with immutable objects. +- EXPERIMENTAL - Added a new feature `program` to `cond-expand` that is only defined when compiling a program. TODO: what about icyc? + Bug Fixes From 6f4900c0a0a9c741af875b459fe8713b1fc1eebb Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 07:03:25 -0500 Subject: [PATCH 070/115] Relocated file --- test-find-local-vars.scm => scheme/cyclone/local-var-redux.scm | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename test-find-local-vars.scm => scheme/cyclone/local-var-redux.scm (100%) diff --git a/test-find-local-vars.scm b/scheme/cyclone/local-var-redux.scm similarity index 100% rename from test-find-local-vars.scm rename to scheme/cyclone/local-var-redux.scm From d96314993dad155418986c77d0119d0df0d7a957 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 07:03:37 -0500 Subject: [PATCH 071/115] use new file --- scheme/cyclone/cps-optimizations.sld | 2 ++ 1 file changed, 2 insertions(+) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 9fa75a88..61b1c7a2 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 @@ -95,6 +96,7 @@ with-fnc with-fnc! ) + (include "local-var-redux.scm") (begin ;; The following two defines allow non-CPS functions to still be considered ;; for certain inlining optimizations. From d587397b23eb80b7df5ef64372d39a37a0005cc1 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 07:04:49 -0500 Subject: [PATCH 072/115] Sync new file --- Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile b/Makefile index 8b8fe74b..576eae58 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/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 From 88bec243b870d6ff5f67e35ca3493051da1d0dd7 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 07:06:02 -0500 Subject: [PATCH 073/115] Added TODO --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 49e8c758..dd407278 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,8 @@ Features (notes) - improve inlining of primitives that work with immutable objects. - EXPERIMENTAL - Added a new feature `program` to `cond-expand` that is only defined when compiling a program. TODO: what about icyc? +TODO: make sure to add local-var-redux.scm to cyclone-bootstrap! this has not been done yet!! + Bug Fixes From e34f783224374c7c515215c3ae58a05219468f04 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 07:18:47 -0500 Subject: [PATCH 074/115] Added file header --- scheme/cyclone/local-var-redux.scm | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/scheme/cyclone/local-var-redux.scm b/scheme/cyclone/local-var-redux.scm index 02d66d54..026eeef6 100644 --- a/scheme/cyclone/local-var-redux.scm +++ b/scheme/cyclone/local-var-redux.scm @@ -1,3 +1,12 @@ +;;;; 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) From e5a2969d920ac8a35f09333383fbb49200500dce Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sat, 10 Nov 2018 11:31:15 -0500 Subject: [PATCH 075/115] Update CHANGELOG.md --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index dd407278..99ba2f35 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,7 +9,7 @@ Features (notes) - EXPERIMENTAL - Added a new feature `program` to `cond-expand` that is only defined when compiling a program. TODO: what about icyc? TODO: make sure to add local-var-redux.scm to cyclone-bootstrap! this has not been done yet!! - + may be in a better place now, but consider renaming with a 'opt-' prefix. that way we can organize everything better once there are more of these. also it looks like there are at least 2 .scm test files in the same directory that can be removed. Bug Fixes From 94694fdd9e7095f55a5d72c49485122935f7336f Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 12 Nov 2018 12:02:34 -0500 Subject: [PATCH 076/115] Renamed file --- Makefile | 2 +- .../{local-var-redux.scm => cps-opt-local-var-redux.scm} | 0 scheme/cyclone/cps-optimizations.sld | 2 +- 3 files changed, 2 insertions(+), 2 deletions(-) rename scheme/cyclone/{local-var-redux.scm => cps-opt-local-var-redux.scm} (100%) diff --git a/Makefile b/Makefile index 576eae58..597b82e6 100644 --- a/Makefile +++ b/Makefile @@ -224,7 +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/local-var-redux.scm $(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/scheme/cyclone/local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm similarity index 100% rename from scheme/cyclone/local-var-redux.scm rename to scheme/cyclone/cps-opt-local-var-redux.scm diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 61b1c7a2..91f63451 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -96,7 +96,7 @@ with-fnc with-fnc! ) - (include "local-var-redux.scm") + (include "cps-opt-local-var-redux.scm") (begin ;; The following two defines allow non-CPS functions to still be considered ;; for certain inlining optimizations. From 732535ab2f906d50ce938617df3064e4714fdadf Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 12 Nov 2018 16:19:13 -0500 Subject: [PATCH 077/115] Split in define bodies, enable debug traces --- scheme/cyclone/cps-opt-local-var-redux.scm | 109 ++++++++++++++++++++- 1 file changed, 104 insertions(+), 5 deletions(-) diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm index 026eeef6..80541fd1 100644 --- a/scheme/cyclone/cps-opt-local-var-redux.scm +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -21,6 +21,7 @@ ;; 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 @@ -34,7 +35,7 @@ ((define? exp) `(define ,(define->var exp) - ,(map scan (define->exp exp)))) + ,@(map scan (define->exp exp)))) ((set!? exp) `(set! ,(set!->var exp) @@ -77,6 +78,7 @@ (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... @@ -110,7 +112,7 @@ (call/cc (lambda (return) (define (scan exp) - ;;(write `(DEBUG scan ,exp)) (newline) + (write `(DEBUG scan ,exp)) (newline) (cond ((ast:lambda? exp) (return #f)) ;; Could be OK if not ref'd... @@ -140,7 +142,103 @@ (cond-expand (program (define sexp - '(lambda +'( + (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-cell! + 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))))) + +) + #;(lambda (k$1073 i$88$682 first$89$683 row$90$684) (if (Cyc-fast-eq i$88$682 @@ -167,7 +265,7 @@ k$1073 (Cyc-fast-plus i$88$682 1) (cdr first$89$683) - (cdr row$90$684)))))))) + (cdr row$90$684))))))) ;(pretty-print ; (ast:ast->pp-sexp @@ -175,5 +273,6 @@ (pretty-print (ast:ast->pp-sexp - (opt:local-var-reduction (ast:sexp->ast sexp)))) + (opt:local-var-reduction (ast:sexp->ast sexp))) + ) )) From e31b357f4c26b816608fbd89b8759f223ce272ea Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 12 Nov 2018 16:30:11 -0500 Subject: [PATCH 078/115] WIP --- cyclone.scm | 4 ++- scheme/cyclone/cps-opt-local-var-redux.scm | 39 ++++------------------ scheme/cyclone/cps-optimizations.sld | 2 +- 3 files changed, 10 insertions(+), 35 deletions(-) diff --git a/cyclone.scm b/cyclone.scm index 7eef0bc1..0a8f34a5 100644 --- a/cyclone.scm +++ b/cyclone.scm @@ -424,7 +424,9 @@ (trace:info (ast:ast->pp-sexp input-program)) ) -;; TODO: would want to introduce lets right here, at least to start + (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)) diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm index 80541fd1..9f6f2ff4 100644 --- a/scheme/cyclone/cps-opt-local-var-redux.scm +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -21,7 +21,7 @@ ;; typically be limited to if expressions embedded in other expressions. (define (opt:local-var-reduction sexp) (define (scan exp) - (write `(DEBUG scan ,exp)) (newline) + ;;(write `(DEBUG scan ,exp)) (newline) (cond ((ast:lambda? exp) (ast:%make-lambda @@ -78,7 +78,7 @@ (call/cc (lambda (return) (define (scan exp fail?) - (write `(DEBUG lvr:local-tail-call-only? scan ,exp)) (newline) + ;;(write `(DEBUG lvr:local-tail-call-only? scan ,exp)) (newline) (cond ((ast:lambda? exp) (return #f)) ;; Could be OK if not ref'd... @@ -112,7 +112,7 @@ (call/cc (lambda (return) (define (scan exp) - (write `(DEBUG scan ,exp)) (newline) + ;;(write `(DEBUG scan ,exp)) (newline) (cond ((ast:lambda? exp) (return #f)) ;; Could be OK if not ref'd... @@ -235,38 +235,11 @@ row$78$676)) (make-vector number-of-cols$68$671))))))) (length first-row$65$670))) - 'now))))) + 'now)))) + (define *num-passed* 0) + ) ) - #;(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))))))) - ;(pretty-print ; (ast:ast->pp-sexp ; (ast:sexp->ast sexp))) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 91f63451..02a2292c 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -11,7 +11,7 @@ (define-library (scheme cyclone cps-optimizations) (import (scheme base) (scheme eval) - ;(scheme write) + (scheme write) (scheme cyclone util) (scheme cyclone ast) (scheme cyclone primitives) From 82f99099514c225dc1d166734cd053aa809859b7 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 12 Nov 2018 17:06:35 -0500 Subject: [PATCH 079/115] Fix (set!) --- scheme/cyclone/cps-opt-local-var-redux.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm index 9f6f2ff4..3a83c100 100644 --- a/scheme/cyclone/cps-opt-local-var-redux.scm +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -38,8 +38,8 @@ ,@(map scan (define->exp exp)))) ((set!? exp) `(set! - ,(set!->var exp) - ,(set!->exp exp))) + ,(scan (set!->var exp)) + ,(scan (set!->exp exp)))) ((if? exp) `(if ,(scan (if->condition exp)) ,(scan (if->then exp)) @@ -187,7 +187,7 @@ ((lambda (lp$80$87$681) (Cyc-seq - (set-cell! + (set! lp$80$87$681 (lambda (k$1073 i$88$682 first$89$683 row$90$684) From 78b12779aff351541d532f0491529f9ca74923d3 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 12 Nov 2018 17:07:24 -0500 Subject: [PATCH 080/115] Remove write --- scheme/cyclone/cps-optimizations.sld | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 02a2292c..91f63451 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -11,7 +11,7 @@ (define-library (scheme cyclone cps-optimizations) (import (scheme base) (scheme eval) - (scheme write) + ;(scheme write) (scheme cyclone util) (scheme cyclone ast) (scheme cyclone primitives) From cde576aaa3d6549f7eb16ea1f2c378496b613f0a Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 12 Nov 2018 18:28:49 -0500 Subject: [PATCH 081/115] Keep vars in local let's during closure convert --- scheme/cyclone/cps-optimizations.sld | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 91f63451..e946aac3 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1695,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) @@ -1751,6 +1754,14 @@ ,@(map cc (cdr exp)))) ;; TODO: need to splice? ((set!? exp) `(set! ,(set!->var exp) ,(cc (set!->exp exp)))) + ((tagged-list? 'let exp) ;; Special case now with local var redux + `(let + ,(cadr exp) + ,@(convert + (caddr exp) + self-var + (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)))) From 89e633db2662586863ddf0f89f02fe992009fefb Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 13 Nov 2018 12:57:55 -0500 Subject: [PATCH 082/115] Added clarifying comments --- scheme/cyclone/cps-optimizations.sld | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index e946aac3..dc6e55c1 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1754,12 +1754,15 @@ ,@(map cc (cdr exp)))) ;; TODO: need to splice? ((set!? exp) `(set! ,(set!->var exp) ,(cc (set!->exp exp)))) - ((tagged-list? 'let exp) ;; Special case now with local var redux + ;; Special case now with local var redux + ((tagged-list? 'let exp) `(let ,(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))) From 8c033a7909632d8976e70c1e2b8442837ae0f0b2 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 13 Nov 2018 13:37:03 -0500 Subject: [PATCH 083/115] Added TODO --- scheme/cyclone/cgen.sld | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index d824cb64..a8e8ae53 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -1181,6 +1181,15 @@ (c-code "") args))) exps)) + ((equal? 'let fun) + (let* ((vars/vals (cadr exp)) + (body (caddr exp)) + ) + TODO: foldr over vars/vals + TODO: compile body exp and combine with above + (c-compile-exp body append-preamble cont ast-id trace cps?) + ) + ) (else (error `(Unsupported function application ,exp))))))) From 04a3bb6c60851eaa091fd270139ec2f3647b351b Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 13 Nov 2018 17:17:16 -0500 Subject: [PATCH 084/115] Fix splicing of let body --- scheme/cyclone/cps-optimizations.sld | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index dc6e55c1..87816afb 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1758,7 +1758,7 @@ ((tagged-list? 'let exp) `(let ,(cadr exp) - ,@(convert + ,(convert (caddr exp) self-var ;; Do not closure convert the let's variables because From bad0d194247a200477f65f61f11259bba4512bb9 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 13 Nov 2018 17:17:30 -0500 Subject: [PATCH 085/115] WIP --- scheme/cyclone/cgen.sld | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index a8e8ae53..eb5f4bf1 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -1184,10 +1184,22 @@ ((equal? 'let fun) (let* ((vars/vals (cadr exp)) (body (caddr exp)) - ) - TODO: foldr over vars/vals - TODO: compile body exp and combine with above - (c-compile-exp body append-preamble cont ast-id trace cps?) + (vexps (foldr + (lambda (var/val acc) + ;; Join expressions; based on c:append + (let ((cp1 (c-compile-exp (cadr var/val) append-preamble cont ast-id trace cps?)) + (cp2 acc)) + (c-code/vars + (let ((cp1-body (c:body cp1))) + (string-append cp1-body ";" (c:body cp2))) + (append (list (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 From c4f75486b606741e7053af7f16032ab384e90b44 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 13 Nov 2018 17:57:44 -0500 Subject: [PATCH 086/115] Added TODO --- scheme/cyclone/cps-opt-local-var-redux.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm index 3a83c100..88f8d567 100644 --- a/scheme/cyclone/cps-opt-local-var-redux.scm +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -59,6 +59,8 @@ ;; (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))))) From d40dc538d9f5d885d76fb7f14b6d7da3d34d66ae Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 13 Nov 2018 18:01:54 -0500 Subject: [PATCH 087/115] Closure convert (let) local values --- scheme/cyclone/cps-optimizations.sld | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 87816afb..a63de650 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1757,7 +1757,12 @@ ;; Special case now with local var redux ((tagged-list? 'let exp) `(let - ,(cadr exp) + ,(map + (lambda (var/val) + (let ((var (car var/val)) + (val (cadr var/val))) + `(,var ,(cc val)))) + (cadr exp)) ,(convert (caddr exp) self-var From 67071a176156577c6765618261d629d43e721fa9 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 13 Nov 2018 18:02:12 -0500 Subject: [PATCH 088/115] WIP --- scheme/cyclone/cgen.sld | 14 ++++++++++++-- scheme/cyclone/cps-opt-local-var-redux.scm | 12 +++++++----- 2 files changed, 19 insertions(+), 7 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index eb5f4bf1..96a38f6b 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -1181,6 +1181,13 @@ (c-code "") args))) exps)) + ((equal? 'Cyc-local-set! fun) + (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)) @@ -1192,13 +1199,16 @@ (c-code/vars (let ((cp1-body (c:body cp1))) (string-append cp1-body ";" (c:body cp2))) - (append (list (mangle (car var/val))) (c:allocs cp1) (c:allocs 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)) + ;;(trace:error `(JAE DEBUG body ,body ,vars/vals ,exp)) (c:append vexps body-exp) ) ) diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm index 88f8d567..dc83e47f 100644 --- a/scheme/cyclone/cps-opt-local-var-redux.scm +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -59,11 +59,13 @@ ;; (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... +;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 (car exp))) + (car (ast:lambda-args (cadr exp))) + )) (var (car (ast:lambda-args (cadr exp)))) (body (ast:lambda-body (cadr exp)))) `(let ((,var ,value)) @@ -110,7 +112,7 @@ would need to be able to carry that through to cgen and assign properly over the ;; 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) +(define (lvr:tail-calls->values sexp sym assign-sym) (call/cc (lambda (return) (define (scan exp) @@ -134,7 +136,7 @@ would need to be able to carry that through to cgen and assign properly over the ((and (equal? (car exp) sym) (= (length exp) 2) ) - (cadr exp)) + `(Cyc-local-set! ,assign-sym ,(cadr exp))) (else (return #f)))) (else exp))) From ef647082e6bf56e58b8c24f3655d50724bfcd23d Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 13 Nov 2018 19:05:28 -0500 Subject: [PATCH 089/115] WIP --- scheme/cyclone/cps-optimizations.sld | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index a63de650..10a0636e 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1718,7 +1718,7 @@ (body (ast:lambda-body exp)) (new-free-vars (difference - (difference (free-vars body) (cons 'Cyc-seq (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)) @@ -1787,6 +1787,8 @@ ; 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 @@ -1814,7 +1816,7 @@ (let* ((body (ast:lambda-body fn)) (new-free-vars (difference - (difference (free-vars body) (cons 'Cyc-seq (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? From a06d2793c8de4246118f13ac08eba3e438d0ee20 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 14 Nov 2018 18:22:51 -0500 Subject: [PATCH 090/115] Do not accumulate free vars from our local (let)'s --- scheme/cyclone/transforms.sld | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld index acddb3af..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)))) From 8fa651357113846183cda3f28e35314b2f7e628d Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 14 Nov 2018 19:01:34 -0500 Subject: [PATCH 091/115] Fix parens --- scheme/cyclone/cgen.sld | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 96a38f6b..5b9f9f3f 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -1182,9 +1182,10 @@ 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) ";")) + (string-append (mangle (cadr exp)) " = " (c:body val-exp) ";") (c:allocs val-exp))) ;(c-code (string-append (mangle (cadr exp)) " = " (mangle (caddr exp)) ";")) ) From 4863f0d4d1d05c3d602f68a1fb8c2932820eda40 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 19 Nov 2018 10:32:30 -0500 Subject: [PATCH 092/115] Added a DEBUG line --- scheme/cyclone/cps-opt-local-var-redux.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm index dc83e47f..056388fd 100644 --- a/scheme/cyclone/cps-opt-local-var-redux.scm +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -53,7 +53,9 @@ (equal? 1 (length (ast:lambda-args (cadr exp)))) (lvr:local-tail-call-only? (ast:lambda-body (car exp)) - (car (ast:lambda-args (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))) From 4b0466f37bb5ee1d63144fb1431519ebb7ceeac7 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 19 Nov 2018 17:09:17 -0500 Subject: [PATCH 093/115] Use alloca for any allocations with let/local-vars This prevents situations where local variables are allocated within local scope blocks and then are assigned to pointers. This is necessary as those locals are not guaranteed to remain on the stack once the block ends, so the pointer can easily point to random memory, leading to GC corruption and/or undefined behavior. --- scheme/cyclone/cgen.sld | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 5b9f9f3f..a3c40b0b 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -652,11 +652,17 @@ (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) - (let ((adbf:fnc (adb:get/default ast-id #f))) - (and adbf:fnc - (adbf:calls-self? adbf:fnc)))) + (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 ast-id) @@ -1194,9 +1200,11 @@ (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))) From 435bbb3a95bcf84a78b6f2412d83402f9efc5919 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 19 Nov 2018 17:10:55 -0500 Subject: [PATCH 094/115] Revert debug code --- scheme/cyclone/cps-opt-local-var-redux.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm index 056388fd..067c014a 100644 --- a/scheme/cyclone/cps-opt-local-var-redux.scm +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -54,7 +54,7 @@ (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! + ;(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 From 244f569df0ec49c469429fc4a8657f454909a0c1 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 19 Nov 2018 18:52:11 -0500 Subject: [PATCH 095/115] Properly handle quoted expressions --- scheme/cyclone/cps-opt-local-var-redux.scm | 100 ++++++++++++++++++++- 1 file changed, 97 insertions(+), 3 deletions(-) diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm index 067c014a..bf76e01b 100644 --- a/scheme/cyclone/cps-opt-local-var-redux.scm +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -21,7 +21,7 @@ ;; typically be limited to if expressions embedded in other expressions. (define (opt:local-var-reduction sexp) (define (scan exp) - ;;(write `(DEBUG scan ,exp)) (newline) + ;(write `(DEBUG scan ,exp)) (newline) (cond ((ast:lambda? exp) (ast:%make-lambda @@ -47,6 +47,7 @@ ((app? exp) (cond ((and + (list? exp) (ast:lambda? (car exp)) (equal? (length exp) 2) (ast:lambda? (cadr exp)) @@ -88,8 +89,8 @@ (cond ((ast:lambda? exp) (return #f)) ;; Could be OK if not ref'd... - ;((quote? exp) exp) - ;((const? exp) exp) + ((quote? exp) exp) + ((const? exp) exp) ((ref? exp) (if (equal? exp sym) (return #f))) ;; Assume not a tail call @@ -122,6 +123,8 @@ (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 @@ -243,9 +246,100 @@ (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))))) ) ) + ;(pretty-print ; (ast:ast->pp-sexp ; (ast:sexp->ast sexp))) From 16149d1492eee7294508f8d33e8fea76cd1342e6 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 20 Nov 2018 13:23:10 -0500 Subject: [PATCH 096/115] Added failsafe --- scheme/cyclone/cps-opt-local-var-redux.scm | 59 ++++++++++++++++++++-- 1 file changed, 55 insertions(+), 4 deletions(-) diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm index bf76e01b..57591e6b 100644 --- a/scheme/cyclone/cps-opt-local-var-redux.scm +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -71,8 +71,11 @@ )) (var (car (ast:lambda-args (cadr exp)))) (body (ast:lambda-body (cadr exp)))) - `(let ((,var ,value)) - ,@body))) + (if value + `(let ((,var ,value)) + ,@body) + (map scan exp)) ;; failsafe + )) (else (map scan exp)))) (else (error "unknown expression type: " exp)) @@ -143,10 +146,20 @@ ) `(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))) - (return - (scan sexp))))) + (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 @@ -336,6 +349,44 @@ (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)))) ) ) From 90c0d798875e92558894ffb3d21b272f59996e82 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 20 Nov 2018 17:21:05 -0500 Subject: [PATCH 097/115] Added TODO --- scheme/cyclone/cgen.sld | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index a3c40b0b..bea484da 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -534,12 +534,15 @@ (number->string len) ");"))))) (loop 0 code)))))) +TODO: c-compile-string exp use-alloca +consolidate from below and alloc_string + ;; 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")) From bab9acd49ec2eafb2fe8e7e9168415a7a69b837c Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 20 Nov 2018 18:07:29 -0500 Subject: [PATCH 098/115] Added c-compile-string --- scheme/cyclone/cgen.sld | 58 +++++++++++++++++++++++++++++------------ 1 file changed, 41 insertions(+), 17 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index bea484da..0371fdf3 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -534,15 +534,52 @@ (number->string len) ");"))))) (loop 0 code)))))) -TODO: c-compile-string exp use-alloca -consolidate from below and alloc_string +(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 use-alloca) +(define (c-compile-const exp #;use-alloca) (cond ((null? exp) (c-code "NULL")) @@ -613,20 +650,7 @@ consolidate from below and alloc_string (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 #f)) ;TODO: not good enough, need to store new symbols in a table so they can ;be inserted into the C program ((symbol? exp) From 16e160066203fe9d8b5196e9b83cbbaf60df54b2 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 20 Nov 2018 18:54:47 -0500 Subject: [PATCH 099/115] Propagate use-alloca parameter for constants --- scheme/cyclone/cgen.sld | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 0371fdf3..12ff9003 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -389,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): @@ -410,11 +410,11 @@ ((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 ( (num-args 0) (create-cons @@ -429,12 +429,12 @@ ((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 @@ -447,7 +447,7 @@ (_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)) ;; Generate code for each member of the vector @@ -455,7 +455,7 @@ (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 @@ -490,7 +490,7 @@ (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)) ;; Generate code for each member of the vector @@ -545,18 +545,18 @@ (string-append "" cvar-name) ; Code is just the variable name (list ; Allocate integer on the C stack (string-append - "object " cvar-name ";\\n " + "object " cvar-name ";\n " "alloc_string(data," cvar-name ", " blen ", " (number->string (string-length exp)) - ");\\n" + ");\n" "char " tmp-name "[] = " (->cstr exp) - ";\\n" - "memcpy(((string_type *)" cvar-name ")->str, " tmp-name "," blen ");\\n" + ";\n" + "memcpy(((string_type *)" cvar-name ")->str, " tmp-name "," blen ");\n" "((string_type *)" cvar-name ")->str[" blen "] = '\\0';" ))))) (else @@ -579,16 +579,16 @@ ;; 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 #;use-alloca) +(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 @@ -650,7 +650,7 @@ (c-code (string-append "obj_char2obj(" (number->string (char->integer exp)) ")"))) ((string? exp) - (c-compile-string exp #f)) + (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) From 765f6ffd8d51e011e83a9675133d8b8068250c48 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 21 Nov 2018 13:04:43 -0500 Subject: [PATCH 100/115] Added new alloca macros --- include/cyclone/types.h | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/include/cyclone/types.h b/include/cyclone/types.h index 44b1d449..1b9d0b1b 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; \ @@ -1067,6 +1081,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. * From ab4f9ee7a4b88b864f7f28712ae6a2c2e0fbcaa8 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 21 Nov 2018 13:05:29 -0500 Subject: [PATCH 101/115] WIP - alloca support for literals --- scheme/cyclone/cgen.sld | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 12ff9003..ec3a6ece 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -584,10 +584,13 @@ ((null? exp) (c-code "NULL")) ((pair? exp) +;; TODO: use-alloc support (c-compile-scalars exp use-alloca)) ((vector? exp) +;; TODO: use-alloc support (c-compile-vector exp use-alloca)) ((bytevector? exp) +;; TODO: use-alloc support (c-compile-bytevector exp use-alloca)) ((bignum? exp) (let ((cvar-name (mangle (gensym 'c))) @@ -614,19 +617,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) @@ -637,12 +636,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")))) From b0d599c0de5d3366afc7e9a66393e43632f6b0be Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 21 Nov 2018 18:53:42 -0500 Subject: [PATCH 102/115] Added alloca_empty_vector --- include/cyclone/types.h | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/include/cyclone/types.h b/include/cyclone/types.h index 1b9d0b1b..25f4cf5c 100644 --- a/include/cyclone/types.h +++ b/include/cyclone/types.h @@ -1058,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 * From 03b2dd7181f09a79efec87c88daffad22724ff67 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 21 Nov 2018 18:53:50 -0500 Subject: [PATCH 103/115] WIP --- scheme/cyclone/cgen.sld | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index ec3a6ece..e2a0ce5a 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -493,6 +493,9 @@ (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) @@ -509,7 +512,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 ";")))) )))) @@ -518,19 +521,19 @@ (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)))))) @@ -590,7 +593,6 @@ ;; TODO: use-alloc support (c-compile-vector exp use-alloca)) ((bytevector? exp) -;; TODO: use-alloc support (c-compile-bytevector exp use-alloca)) ((bignum? exp) (let ((cvar-name (mangle (gensym 'c))) From 7a1b28db374c54ff2af647a0bc807776e67be1fb Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 21 Nov 2018 19:08:45 -0500 Subject: [PATCH 104/115] WIP --- scheme/cyclone/cgen.sld | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index e2a0ce5a..16287ef8 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -450,6 +450,9 @@ (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) @@ -467,26 +470,26 @@ (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)))))) @@ -590,8 +593,7 @@ ;; TODO: use-alloc support (c-compile-scalars exp use-alloca)) ((vector? exp) -;; TODO: use-alloc support - (c-compile-vector exp use-alloca)) + (c-compile-vector exp #t)) ;;use-alloca)) ((bytevector? exp) (c-compile-bytevector exp use-alloca)) ((bignum? exp) From e63349b8305074e2c00cfaf74e5d11b58c0ef935 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 21 Nov 2018 19:13:32 -0500 Subject: [PATCH 105/115] Remove debug code --- scheme/cyclone/cgen.sld | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 16287ef8..62b415f3 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -593,7 +593,7 @@ ;; TODO: use-alloc support (c-compile-scalars exp use-alloca)) ((vector? exp) - (c-compile-vector exp #t)) ;;use-alloca)) + (c-compile-vector exp use-alloca)) ((bytevector? exp) (c-compile-bytevector exp use-alloca)) ((bignum? exp) From 1f1b03264123be46f9e5c9e5d7e887c067b37491 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Wed, 21 Nov 2018 19:19:00 -0500 Subject: [PATCH 106/115] Support alloca for all literals --- scheme/cyclone/cgen.sld | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 62b415f3..b96c8b07 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -416,11 +416,14 @@ (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 @@ -438,8 +441,7 @@ (_c-compile-scalars (cdr args))))) (set! num-args (+ 1 num-args)) (c-code/vars - ;;cvar-name ;; Not needed with alloca - (string-append "&" cvar-name) - (string-append "&" cvar-name) + (string-append addr-op cvar-name) (append (c:allocs cell) (list (c:body cell)))))))))) @@ -590,7 +592,6 @@ ((null? exp) (c-code "NULL")) ((pair? exp) -;; TODO: use-alloc support (c-compile-scalars exp use-alloca)) ((vector? exp) (c-compile-vector exp use-alloca)) From b0e6c42eb1bf9ca165f4206f96d1e4a6bf40d26d Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 22 Nov 2018 17:33:06 -0500 Subject: [PATCH 107/115] Added prim->c-func-uses-alloca? --- scheme/cyclone/primitives.sld | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/scheme/cyclone/primitives.sld b/scheme/cyclone/primitives.sld index 992acef1..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,6 +458,18 @@ (define (prim-call? exp) (and (list? exp) (prim? (car exp)))) + (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? From 931b4495795bc5e5413b527487d48b02de9b6ca5 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 22 Nov 2018 17:40:46 -0500 Subject: [PATCH 108/115] Extra cases for prim use-alloca and & operator --- scheme/cyclone/cgen.sld | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index b96c8b07..15ddc2e7 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -751,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) @@ -794,7 +796,8 @@ ;; (let ((cv-name (mangle (gensym 'c)))) (c-code/vars - (if (prim:allocates-object? p use-alloca?) + (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 From 07683bf273cd46d0de7589739f6a9503c043a091 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 22 Nov 2018 18:44:18 -0500 Subject: [PATCH 109/115] Fixup alloca_list macros, we don't want the & ops --- include/cyclone/types.h | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/include/cyclone/types.h b/include/cyclone/types.h index 25f4cf5c..7d882741 100644 --- a/include/cyclone/types.h +++ b/include/cyclone/types.h @@ -1163,18 +1163,18 @@ typedef pair_type *pair; #define alloca_list_2(l, a1, a2) \ alloca_pair(l##__2, a2, NULL); \ - alloca_pair(l, a1, &l##__2); + 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); + 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); + 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. From 729c0d4025c0fdb2d0bbec5e61f1f6dabedbff06 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 22 Nov 2018 23:15:12 -0500 Subject: [PATCH 110/115] Add check for CPS prims --- scheme/cyclone/cps-opt-local-var-redux.scm | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm index 57591e6b..78bcd59b 100644 --- a/scheme/cyclone/cps-opt-local-var-redux.scm +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -107,6 +107,12 @@ (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 From 09f2f0412da1a6f66e9bb5eea669e5206b64f2e4 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 23 Nov 2018 12:06:23 -0500 Subject: [PATCH 111/115] Added a note about let/local-var reductions --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 99ba2f35..d20c45ac 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,8 @@ Features (notes) - improve inlining of primitives that work with immutable objects. - EXPERIMENTAL - Added a new feature `program` to `cond-expand` that is only defined when compiling a program. TODO: what about icyc? +- eliminate functions that are only used to define local variables + TODO: make sure to add local-var-redux.scm to cyclone-bootstrap! this has not been done yet!! may be in a better place now, but consider renaming with a 'opt-' prefix. that way we can organize everything better once there are more of these. also it looks like there are at least 2 .scm test files in the same directory that can be removed. From 1145d1f8e20a99e5051a678dfb61cbc288535b79 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 23 Nov 2018 21:46:51 -0500 Subject: [PATCH 112/115] Only generate a let if local var is used If the variable is not used we will get a warning from the C compiler. So let's not generate a let unless the var is actually used. We may want to revisit this later for a related optimization, maybe via Cyc-seq. --- scheme/cyclone/cps-opt-local-var-redux.scm | 23 ++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/scheme/cyclone/cps-opt-local-var-redux.scm b/scheme/cyclone/cps-opt-local-var-redux.scm index 78bcd59b..a5f516cc 100644 --- a/scheme/cyclone/cps-opt-local-var-redux.scm +++ b/scheme/cyclone/cps-opt-local-var-redux.scm @@ -64,14 +64,21 @@ ;;(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)))) - (if value + (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 From 190c4a63fe6cdaa39c880dddd56f63acd5a449f0 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 23 Nov 2018 22:06:41 -0500 Subject: [PATCH 113/115] Revised 0.9.4 section --- CHANGELOG.md | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d20c45ac..b6c3e2fd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,15 +3,15 @@ ## 0.9.4 - TBD Features (notes) -- optimize recursive functions using C iteration + + code optimizations: +- optimize recursive functions by using C iteration - combine lambda functions that are only called for side effects. - improve inlining of primitives that work with immutable objects. -- EXPERIMENTAL - Added a new feature `program` to `cond-expand` that is only defined when compiling a program. TODO: what about icyc? - - eliminate functions that are only used to define local variables -TODO: make sure to add local-var-redux.scm to cyclone-bootstrap! this has not been done yet!! - may be in a better place now, but consider renaming with a 'opt-' prefix. that way we can organize everything better once there are more of these. also it looks like there are at least 2 .scm test files in the same directory that can be removed. + true features: +- EXPERIMENTAL - Added a new feature `program` to `cond-expand` that is only defined when compiling a program. TODO: what about icyc? Bug Fixes From ba98256ce146ed16758d18f5ce517f0333374bde Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 23 Nov 2018 23:08:26 -0500 Subject: [PATCH 114/115] Completetly revised 0.9.4 section --- CHANGELOG.md | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b6c3e2fd..8326744d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,16 +2,16 @@ ## 0.9.4 - TBD -Features (notes) +Compiler Optimizations - code optimizations: -- optimize recursive functions by using C iteration -- 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 +- Optimize recursive functions by expressing the recursive calls using C iteration. This optimization is more effective when combined with the other functions listed below as those increase the chances that a loop may be compiled down to a single 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. - true features: -- EXPERIMENTAL - Added a new feature `program` to `cond-expand` that is only defined when compiling a program. TODO: what about icyc? +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. Or the same file can be used to import code into a library. This is similar to using the `__main__` scope in a python program. Bug Fixes From 257d4a4aa6ae6f0413adb96a08d86ab2e1a6be37 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 23 Nov 2018 23:35:52 -0500 Subject: [PATCH 115/115] Revisions --- CHANGELOG.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8326744d..4fd43223 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,14 +4,14 @@ Compiler Optimizations -- Optimize recursive functions by expressing the recursive calls using C iteration. This optimization is more effective when combined with the other functions listed below as those increase the chances that a loop may be compiled down to a single 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. +- 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. Or the same file can be used to import code into a library. This is similar to using the `__main__` scope in a python program. +- 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