diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index a6717e95..6486af2a 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -17,8 +17,8 @@ ; can write initial analyze, but can't get too far without being able ; to uniquely ID each lambda -(define-library (cps-optimizations) -;(define-library (scheme cyclone cps-optimizations) +;(define-library (cps-optimizations) +(define-library (scheme cyclone cps-optimizations) (import (scheme base) (scheme cyclone util) (scheme cyclone ast) @@ -150,6 +150,11 @@ (fnc var) (adb:set! sym var))) + ;; Non-mutating version, returns results of fnc + (define (with-var sym fnc) + (let ((var (adb:get/default sym (adb:make-var)))) + (fnc var))) + (define (with-fnc! id callback) (let ((fnc (adb:get/default id (adb:make-fnc)))) (callback fnc) @@ -417,6 +422,10 @@ (else (error "CPS optimize [1] - Unknown expression" exp)))) + ;; Inline primtives + ;; Uses analysis DB, so must be executed after analysis phase + ;; + ;; TBD: better to enhance CPS conversion to do this?? (define (contract-prims exp . refs*) (let ((refs (if (null? refs*) (make-hash-table) @@ -456,6 +465,19 @@ ;; TODO: check for more than one arg?? (equal? (length (cdr exp)) (length (ast:lambda-formals->list (car exp)))) + ;; Double-check parameter can be optimized-out + (every + (lambda (param) + (with-var param (lambda (var) +;(trace:error `(DEBUG ,param ,(adbv:ref-by var))) + (and + ;; If param is never referenced, then prim is being + ;; called for side effects, possibly on a global + (not (null? (adbv:ref-by var))) + ;; Need to keep variable because it is mutated + (not (adbv:reassigned? var)) + )))) + (ast:lambda-formals->list (car exp))) (every (lambda (arg) (and (prim-call? arg) @@ -540,62 +562,8 @@ (trace:info "---------------- cps analysis db:") (trace:info (adb:get-db)) ;ast ;; DEBUGGING!!! - ;(contract-prims - ; (opt:contract ast)) + (contract-prims + (opt:contract ast)) ) -;; Older code, delete this soon -;;;; TODO: don't think we can assume lambda body is single expr, if we want -;;;; to do optimizations such as inlining -;;(define (cps-optimize-01 exp) -;; exp) ;; Temporarily disabling while this is reworked. -;;; (define (opt-lambda exp) -;;; (let ((body (car (lambda->exp exp)))) ;; Single expr after CPS -;;; ;(trace:error `(DEBUG -;;; ; ,exp -;;; ; ,body -;;; ; ,(if (and (pair? body) (app? body) (lambda? (car body))) -;;; ; (list (app->args body) -;;; ; (lambda->formals exp)) -;;; ; #f))) -;;; (cond -;;; ;; Does the function just call its continuation? -;;; ((and (pair? body) -;;; (app? body) -;;; (lambda? (car body)) -;;; ;; TODO: need to check body length if we allow >1 expr in a body -;;; ;; TODO: not sure this is good enough for all cases -;;; (equal? (app->args body) -;;; ;(lambda->formals (car body)) -;;; (lambda->formals exp) -;;; ) -;;; (> (length (lambda->formals exp)) 0) -;;; ;; TODO: don't do it if args are used in the body -;;; ;; this won't work if we have any num other than 1 arg -;;; (not (member -;;; (car (lambda->formals exp)) -;;; (free-vars (car body)))) -;;; ) -;;; (cps-optimize-01 (car body))) -;;; (else -;;; `(lambda ,(lambda->formals exp) -;;; ,(cps-optimize-01 (car (lambda->exp exp)))) ;; Assume single expr in lambda body, since after CPS phase -;;; )))) -;;; (cond -;;; ; Core forms: -;;; ((const? exp) exp) -;;; ((ref? exp) exp) -;;; ((prim? exp) exp) -;;; ((quote? exp) exp) -;;; ((lambda? exp) (opt-lambda exp)) -;;; ((set!? exp) `(set! -;;; ,(set!->var exp) -;;; ,(cps-optimize-01 (set!->exp exp)))) -;;; ((if? exp) `(if ,(cps-optimize-01 (if->condition exp)) -;;; ,(cps-optimize-01 (if->then exp)) -;;; ,(cps-optimize-01 (if->else exp)))) -;;; ; Application: -;;; ((app? exp) (map (lambda (e) (cps-optimize-01 e)) exp)) -;;; (else (error "CPS optimize unknown expression type: " exp)))) - )) diff --git a/scheme/cyclone/test-cps.scm b/scheme/cyclone/test-cps.scm index 0880b604..2410d410 100644 --- a/scheme/cyclone/test-cps.scm +++ b/scheme/cyclone/test-cps.scm @@ -98,37 +98,96 @@ ; 3)))) ; 0))))) +;(define code +;'(#((record-marker) +; #((record-marker) #f (id args body)) +; #(6 +; () +; ((#((record-marker) +; #((record-marker) #f (id args body)) +; #(5 +; (r$2) +; ((#((record-marker) +; #((record-marker) #f (id args body)) +; #(4 +; (x$3 y$2 z$1) +; ((#((record-marker) +; #((record-marker) #f (id args body)) +; #(3 +; (r$4) +; ((#((record-marker) +; #((record-marker) #f (id args body)) +; #(2 +; (r$3) +; ((write #((record-marker) +; #((record-marker) #f (id args body)) +; #(1 (r$1) ((r$1 %halt)))) +; r$3)))) +; (cons x$3 r$4))))) +; (cons y$2 z$1))))) +; 1 +; 2 +; 3)))) +; 0))))) +;) + (define code -'(#((record-marker) - #((record-marker) #f (id args body)) - #(6 - () - ((#((record-marker) - #((record-marker) #f (id args body)) - #(5 - (r$2) - ((#((record-marker) - #((record-marker) #f (id args body)) - #(4 - (x$3 y$2 z$1) - ((#((record-marker) - #((record-marker) #f (id args body)) - #(3 - (r$4) - ((#((record-marker) - #((record-marker) #f (id args body)) - #(2 - (r$3) - ((write #((record-marker) - #((record-marker) #f (id args body)) - #(1 (r$1) ((r$1 %halt)))) - r$3)))) - (cons x$3 r$4))))) - (cons y$2 z$1))))) - 1 - 2 - 3)))) - 0))))) +'((define reg-port + #((record-marker) + #((record-marker) #f (id args body)) + #(630 + (k$812 fp$262) + ((#((record-marker) + #((record-marker) #f (id args body)) + #(629 + (r$813) + ((#((record-marker) + #((record-marker) #f (id args body)) + #(628 + (r$263) + ((if r$263 + (#((record-marker) + #((record-marker) #f (id args body)) + #(622 () ((k$812 r$263))))) + (#((record-marker) + #((record-marker) #f (id args body)) + #(627 + () + ((list #((record-marker) + #((record-marker) #f (id args body)) + #(626 + (r$817) + ((#((record-marker) + #((record-marker) #f (id args body)) + #(625 + (r$814) + ((#((record-marker) + #((record-marker) + #f + (id args body)) + #(624 + (r$816) + ((#((record-marker) + #((record-marker) + #f + (id args body)) + #(623 + (r$815) + ((k$812 r$263)))) + (set! *in-port-table* + r$816))))) + (cons r$263 *in-port-table*))))) + (set! r$263 r$817))))) + fp$262 + #f + 1 + 0))))))))) + r$813)))) + (assoc fp$262 *in-port-table*))))))) ) + (pretty-print - (contract-prims code)) + (optimize-cps code)) + ;(contract-prims code)) +(write "---------------- cps analysis db:") +(pretty-print (adb:get-db))