diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 526833c7..899e6a39 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -15,6 +15,7 @@ (scheme cyclone ast) (scheme cyclone primitives) (scheme cyclone transforms) + (srfi 2) (srfi 69)) (export closure-convert @@ -34,6 +35,7 @@ adb:get-db simple-lambda? one-instance-of-new-mutable-obj? + opt:find-named-lets ;; Analyze variables adb:make-var %adb:make-var @@ -54,6 +56,10 @@ adbv:set-ref-count! adbv:ref-by adbv:set-ref-by! + adbv:def-in-loop? + adbv:set-def-in-loop! + adbv:ref-in-loop? + adbv:set-ref-in-loop! ;; Analyze functions adb:make-fnc %adb:make-fnc @@ -98,7 +104,10 @@ reassigned assigned-value app-fnc-count app-arg-count inlinable mutated-indirectly - cont) + cont + def-in-loop + ref-in-loop + ) adb:variable? (global adbv:global? adbv:set-global!) (defined-by adbv:defined-by adbv:set-defined-by!) @@ -121,6 +130,8 @@ ;; Is the variable mutated indirectly? (EG: set-car! of a cdr) (mutated-indirectly adbv:mutated-indirectly? adbv:set-mutated-indirectly!) (cont adbv:cont? adbv:set-cont!) + (def-in-loop adbv:def-in-loop? adbv:set-def-in-loop!) + (ref-in-loop adbv:ref-in-loop? adbv:set-ref-in-loop!) ) (define (adbv-set-assigned-value-helper! sym var value) @@ -149,7 +160,7 @@ ) (define (adb:make-var) - (%adb:make-var '? '? #f #f #f 0 '() #f #f 0 0 #t #f #f)) + (%adb:make-var '? '? #f #f #f 0 '() #f #f 0 0 #t #f #f #f #f)) (define-record-type (%adb:make-fnc simple unused-params assigned-to-var side-effects) @@ -1606,4 +1617,77 @@ `(lambda () ,(convert exp #f '()))) +(define (opt:find-named-lets exp) + (define (scan exp lp) + (cond + ((ast:lambda? exp) + (let* ((id (ast:lambda-id exp)) + (has-cont (ast:lambda-has-cont exp)) + (sym (string->symbol + (string-append + "lambda-" + (number->string id) + (if has-cont "-cont" "")))) + (args* (ast:lambda-args exp)) + (args (if (null? args*) + '() + (formals->list args*))) + ) + ;; TODO: (when lp + ;; TODO: (for-each + ;; TODO: (lambda (a) + ;; TODO: (write `(,a defined in a loop)) + ;; TODO: (newline)) + ;; TODO: args) + ;; TODO: ) + `(,sym ,(ast:lambda-args exp) + ,@(map (lambda (e) (scan e lp)) (ast:lambda-body exp)))) + ) + ((quote? exp) exp) + ((const? exp) exp) + ((ref? exp) + ;; TODO: (when lp + ;; TODO: (write `(found variable ,exp within a loop)) + ;; TODO: (newline)) + exp) + ((define? exp) + `(define ,(define->var exp) + ,@(scan (define->exp exp) lp))) + ((set!? exp) + `(set! ,(set!->var exp) + ,(scan (set!->exp exp) lp))) + ((if? exp) + `(if ,(scan (if->condition exp) lp) + ,(scan (if->then exp) lp) + ,(scan (if->else exp) lp))) + ((app? exp) + (cond + ((and-let* ( + ;; Find lambda with initial #f assignment + ((ast:lambda? (car exp))) + ((pair? (cdr exp))) + ((not (cadr exp))) + (= 1 (length (ast:lambda-args (car exp)))) + ;; Get information for continuation + (loop-sym (car (ast:lambda-args (car exp)))) + (inner-exp (car (ast:lambda-body (car exp)))) + ((app? inner-exp)) + ((ast:lambda? (car inner-exp))) + ;; Find the set (assumes CPS conversion) + ((pair? (cdr inner-exp))) + ((set!? (cadr inner-exp))) + ((equal? (set!->var (cadr inner-exp)) loop-sym)) + ;; Check the set's continuation + ((app? (car (ast:lambda-body (car inner-exp))))) + ((equal? (caar (ast:lambda-body (car inner-exp))) loop-sym)) + ) + ; TODO: (write `(found named lambda loop ,loop-sym)) + ;; Continue scanning + (map (lambda (e) (scan e #t)) exp) + )) + (else + (map (lambda (e) (scan e lp)) exp)))) + (else exp))) + (scan exp #f)) + ))