From 3811d0a4c235da7113e78403a6daf0aa867d5db1 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Mon, 11 Feb 2008 22:18:32 -0500 Subject: [PATCH] Loops with a single free variable no longer allocate a closure. --- scheme/ikarus.compiler.altcogen.ss | 4 +- scheme/ikarus.compiler.ss | 354 ++++++++++++++++------------- scheme/last-revision | 2 +- scheme/makefile.ss | 9 +- scheme/pass-specify-rep-primops.ss | 8 +- 5 files changed, 218 insertions(+), 159 deletions(-) diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss index 1637ca0..68da371 100644 --- a/scheme/ikarus.compiler.altcogen.ss +++ b/scheme/ikarus.compiler.altcogen.ss @@ -139,8 +139,8 @@ (define (do-fix lhs* rhs* body) (define (handle-closure x) (struct-case x - [(closure code free*) - (make-closure code (map Var free*))])) + [(closure code free* well-known?) + (make-closure code (map Var free*) well-known?)])) (make-fix lhs* (map handle-closure rhs*) body)) (define (Expr x) (struct-case x diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss index 7df0e2c..0c49f1e 100644 --- a/scheme/ikarus.compiler.ss +++ b/scheme/ikarus.compiler.ss @@ -16,7 +16,7 @@ (library (ikarus compiler) (export compile-core-expr-to-port - assembler-output scc-letrec + assembler-output scc-letrec optimize-cp current-primitive-locations eval-core) (import (rnrs hashtables) @@ -25,7 +25,7 @@ (only (ikarus system $codes) $code->closure) (only (ikarus system $structs) $struct-ref $struct/rtd?) (except (ikarus) - fasl-write scc-letrec + fasl-write scc-letrec optimize-cp compile-core-expr-to-port assembler-output current-primitive-locations eval-core) (ikarus fasl write) @@ -127,7 +127,7 @@ (define-struct case-info (label args proper)) (define-struct clambda-case (info body)) (define-struct clambda (label cases cp free name)) -(define-struct closure (code free*)) +(define-struct closure (code free* well-known?)) (define-struct funcall (op rand*)) (define-struct jmpcall (label op rand*)) (define-struct forcall (op rand*)) @@ -375,14 +375,16 @@ [else (cons (E x) ac)])) (cons 'begin (f e0 (f e1 '()))))] [(clambda-case info body) - `(,(E-args (case-info-proper info) (case-info-args info)) + `(label: ,(case-info-label info) + ,(E-args (case-info-proper info) (case-info-args info)) ,(E body))] [(clambda g cls* cp free) - `(,g (case-lambda . ,(map E cls*)))] + `(clambda (label: ,g cp: ,(E cp) ) ;free: ,(map E free)) + ,@(map E cls*))] [(clambda label clauses free) `(code ,label . ,(map E clauses))] - [(closure code free*) - `(closure ,(E code) ,(map E free*))] + [(closure code free* wk?) + `(closure ,@(if wk? '(wk) '()) ,(E code) ,(map E free*))] [(codes list body) `(codes ,(map E list) ,(E body))] @@ -519,7 +521,32 @@ (make-funcall rator rand*)])] [else (make-funcall rator rand*)])] + [(bind lhs* rhs* body) + (if (null? lhs*) + (inline body rand*) + (make-bind lhs* rhs* + (call-expr body rand*)))] + [(recbind lhs* rhs* body) + (if (null? lhs*) + (inline body rand*) + (make-recbind lhs* rhs* + (call-expr body rand*)))] + [(rec*bind lhs* rhs* body) + (if (null? lhs*) + (inline body rand*) + (make-rec*bind lhs* rhs* + (call-expr body rand*)))] [else (make-funcall rator rand*)])) + (define (call-expr x rand*) + (cond + [(clambda? x) (inline x rand*)] + [(and (var? x) (not (var-assigned x))) + ;;; FIXME: did we do the analysis yet? + (make-funcall x rand*)] + [else + (let ([t (unique-var 'tmp)]) + (make-bind (list t) (list x) + (make-funcall t rand*)))])) (define (Expr x) (struct-case x [(constant) x] @@ -552,8 +579,6 @@ (make-forcall rator (map Expr rand*))] [(assign lhs rhs) (make-assign lhs (Expr rhs))] - ;[(library-recbind lhs* loc* rhs* body) - ; (make-library-recbind lhs* loc* (map Expr rhs*) (Expr body))] [else (error who "invalid expression" (unparse x))])) (Expr x)) @@ -1528,18 +1553,32 @@ [(null? lhs*) (k body)] [else (make-bind lhs* rhs* (k body))])]) - (mk-seq (mk-seq eff0 eff1) body)))))) + (mk-seq eff0 (mk-seq eff1 body))))))) (define (do-fix lhs* rhs* body k) - (let-values ([(lhs* rhs* eff*) + (let-values ([(lhs* rhs* eff0) (partition-referenced lhs* rhs*)]) - (cond - [(null? lhs*) (k body)] - [else - (make-fix lhs* (map Value rhs*) (k body))]))) + (let ([rhs* (map Value rhs*)]) + (let-values ([(lhs* rhs* eff1) + (partition/assign-known lhs* rhs*)]) + (let ([body + (cond + [(null? lhs*) (k body)] + [else + (make-fix lhs* rhs* (k body))])]) + (mk-seq (mk-seq eff0 eff1) body)))))) + ;(define (do-fix lhs* rhs* body k) + ; (let-values ([(lhs* rhs* eff*) + ; (partition-referenced lhs* rhs*)]) + ; (cond + ; [(null? lhs*) (k body)] + ; [else + ; (make-fix lhs* (map Value rhs*) (k body))]))) (define (mk-seq e0 e1) ;;; keep e1 seq-free. (cond [(and (primcall? e0) (eq? (primcall-op e0) 'void)) e1] - [(primref? e0) e1] + [(or (primref? e0) (constant? e0)) e1] + ;[(and (primcall? e1) (eq? (primcall-op e1) 'void)) e0] + ;[(or (primref? e1) (constant? e1)) e0] [(seq? e1) (make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))] [else @@ -1699,7 +1738,8 @@ (mk-seq rator (optimize-primcall 'v op (map Value rand*)))] [else - (make-funcall rator (map Value rand*))]))] + (mk-seq rator + (make-funcall v (map Value rand*)))]))] [else (make-funcall rator (map Value rand*))]))] [(forcall rator rand*) (make-forcall rator (map Value rand*))] @@ -2029,63 +2069,8 @@ x)) -(define (get-non-operator-cps x) - (define who 'get-non-operator-cps) - (define-struct loc (seen?)) - (define (do-fix lhs* rhs* body ac) - (for-each (lambda (lhs) (set-var-index! lhs (make-loc #f))) lhs*) - (let ([ac (L* rhs* (E body ac))]) - (for-each (lambda (lhs) (set-var-index! lhs #f)) lhs*) - ac)) - (define (L* ls ac) - (cond - [(null? ls) ac] - [else (L* (cdr ls) (L (car ls) ac))])) - (define (L x ac) - (struct-case x - [(clambda label cls* cp free* name) - (let f ([cls* cls*] [ac ac]) - (cond - [(null? cls*) ac] - [else - (struct-case (car cls*) - [(clambda-case info body) - (f (cdr cls*) (E body ac))])]))] - [else (error who "invalid L" x)])) - (define (E* ls ac) - (cond - [(null? ls) ac] - [else (E* (cdr ls) (E (car ls) ac))])) - (define (E x ac) - (struct-case x - [(constant) ac] - [(var) - (let ([v (var-index x)]) - (cond - [(loc? v) - (if (loc-seen? v) - ac - (begin - (set-loc-seen?! v #t) - (cons x ac)))] - [else ac]))] - [(primref) ac] - [(bind lhs* rhs* body) - (E* rhs* (E body ac))] - [(fix lhs* rhs* body) (do-fix lhs* rhs* body ac)] - [(conditional test conseq altern) - (E test (E conseq (E altern ac)))] - [(seq e0 e1) (E e0 (E e1 ac))] - [(forcall op rand*) (E* rand* ac)] - [(funcall rator rand*) (E rator (E* rand* ac))] - [(jmpcall label rator rand*) - ;;; skip rator - (E* rand* ac)] - [(mvcall p c) - (E p (E c ac))] - [else (error who "invalid expression" (unparse x))])) - (E x '())) +(define optimize-cp (make-parameter #t)) (define (convert-closures prog) (define who 'convert-closures) @@ -2122,12 +2107,15 @@ (values (make-closure (make-clambda g cls* lhs free name) - free) + free + #f) free))])) (define (Expr ex) (struct-case ex [(constant) (values ex '())] - [(var) (values ex (singleton ex))] + [(var) + (set-var-index! ex #f) + (values ex (singleton ex))] [(primref) (values ex '())] [(bind lhs* rhs* body) (let-values ([(rhs* rhs-free) (Expr* rhs*)] @@ -2135,8 +2123,15 @@ (values (make-bind lhs* rhs* body) (union rhs-free (difference body-free lhs*))))] [(fix lhs* rhs* body) + (for-each (lambda (x) (set-var-index! x #t)) lhs*) (let-values ([(rhs* rfree) (do-clambda* lhs* rhs*)] [(body bfree) (Expr body)]) + (for-each + (lambda (lhs rhs) + (when (var-index lhs) + (set-closure-well-known?! rhs #t) + (set-var-index! lhs #f))) + lhs* rhs*) (values (make-fix lhs* rhs* body) (difference (union bfree rfree) lhs*)))] [(conditional test conseq altern) @@ -2158,21 +2153,14 @@ (values (make-funcall rator rand*) (union rat-free rand*-free)))] [(jmpcall label rator rand*) - (let-values ([(rator rat-free) (Expr rator)] + (let-values ([(rator rat-free) + (if (and (optimize-cp) (var? rator)) + (values rator (singleton rator)) + (Expr rator))] [(rand* rand*-free) (Expr* rand*)]) (values (make-jmpcall label rator rand*) (union rat-free rand*-free)))] - [(mvcall p c) - (let-values ([(p p-free) (Expr p)] - [(c c-free) (Expr c)]) - (struct-case c - [(closure code free^) - (values (make-mvcall p code) - (union p-free c-free))] - [else (error who "invalid mvcall consumer" - (unparse c))]))] [else (error who "invalid expression" ex)])) - ;(get-non-operator-cps prog) (let-values ([(prog free) (Expr prog)]) (unless (null? free) (error 'convert-closures "free vars encountered in program" @@ -2184,64 +2172,85 @@ (define (optimize-closures/lift-codes x) (define who 'optimize-closures/lift-codes) (define all-codes '()) - (define (init-non-combinator var) - (set-var-assigned! var #f) - (set-var-referenced! var #f)) - (define (var-combinator var) - (var-referenced var)) - (define (make-combinator-var var combinator) - (set-var-referenced! var combinator)) + (module (unset! set-subst! get-subst copy-subst!) + (define-struct prop (val)) + (define (unset! x) + (unless (var? x) (error 'unset! "not a var" x)) + (set-var-index! x #f)) + (define (set-subst! x v) + (unless (var? x) (error 'set-subst! "not a var" x)) + (set-var-index! x (make-prop v))) + (define (copy-subst! lhs rhs) + (unless (var? lhs) (error 'copy-subst! "not a var" lhs)) + (cond + [(and (var? rhs) (var-index rhs)) => + (lambda (v) + (cond + [(prop? v) (set-var-index! lhs v)] + [else (set-var-index! lhs #f)]))] + [else (set-var-index! lhs #f)])) + (define (get-subst x) + (unless (var? x) (error 'get-subst "not a var" x)) + (struct-case (var-index x) + [(prop v) v] + [else #f]))) (define (combinator? x) (struct-case x [(closure code free*) (null? free*)] [else #f])) - (define (trim/lift-code code free*) + (define (lift-code cp code free*) (struct-case code - [(clambda label cls* cp free*/dropped name) + [(clambda label cls* cp/dropped free*/dropped name) (let ([cls* (map (lambda (x) (struct-case x [(clambda-case info body) - (for-each init-non-combinator - (case-info-args info)) + (for-each unset! (case-info-args info)) (make-clambda-case info (E body))])) cls*)]) (let ([g (make-code-loc label)]) (set! all-codes - (cons (make-clambda label cls* cp free* name) all-codes)) + (cons (make-clambda label cls* cp free* name) + all-codes)) g))])) - (define (optimize-one-closure code free) - (let ([free (trim-vars free)]) - (make-closure (trim/lift-code code free) free))) (define (trim p? ls) (cond [(null? ls) '()] [(p? (car ls)) (trim p? (cdr ls))] [else (cons (car ls) (trim p? (cdr ls)))])) - (define (trim-vars ls) - (trim var-combinator ls)) - (define (trim-combinators ls) - (trim combinator? ls)) (define (do-bind lhs* rhs* body) - (for-each init-non-combinator lhs*) + (for-each unset! lhs*) (let ([rhs* (map E rhs*)]) - (for-each (lambda (x v) - (when (combinator? v) (make-combinator-var x v))) - lhs* rhs*) - (make-bind (trim-vars lhs*) (trim-combinators rhs*) (E body)))) + (for-each copy-subst! lhs* rhs*) + (let ([body (E body)]) + (for-each unset! lhs*) + (make-bind lhs* rhs* body)))) + (define (trim-free ls) + (cond + [(null? ls) '()] + [(get-forward! (car ls)) => + (lambda (what) + (let ([rest (trim-free (cdr ls))]) + (struct-case what + [(closure) rest] + [(var) (if (memq what rest) rest (cons what rest))] + [else (error who "invalid value in trim-free" what)])))] + [else (cons (car ls) (trim-free (cdr ls)))])) (define (do-fix lhs* rhs* body) - (for-each init-non-combinator lhs*) + (for-each unset! lhs*) (let ([free** ;;; trim the free lists first; after init. - (map (lambda (lhs rhs) ;;; remove self also - (trim-vars (remq lhs (closure-free* rhs)))) + (map (lambda (lhs rhs) + ;;; remove self also + (remq lhs (trim-free (closure-free* rhs)))) lhs* rhs*)]) - (define-struct node (name code deps whacked free)) + (define-struct node (name code deps whacked free wk?)) (let ([node* (map (lambda (lhs rhs) - (let ([n (make-node lhs (closure-code rhs) '() #f '())]) - (make-combinator-var lhs n) + (let ([n (make-node lhs (closure-code rhs) '() #f '() + (closure-well-known? rhs))]) + (set-subst! lhs n) n)) lhs* rhs*)]) ;;; if x is free in y, then whenever x becomes a non-combinator, @@ -2251,7 +2260,7 @@ (lambda (my-node free*) (for-each (lambda (fvar) (cond - [(var-combinator fvar) => ;;; one of ours + [(get-subst fvar) => ;;; one of ours (lambda (her-node) (set-node-deps! her-node (cons my-node (node-deps her-node))))] @@ -2265,7 +2274,10 @@ ;;; so we whack it and add it to all of its dependents. (let () (define (process-node x) - (unless (null? (node-free x)) + (when (cond + [(null? (node-free x)) #f] + ;[(and (node-wk? x) (null? (cdr (node-free x)))) #f] + [else #t]) (unless (node-whacked x) (set-node-whacked! x #t) (for-each @@ -2280,59 +2292,97 @@ (let ([rhs* (map (lambda (node) - (let ([free (node-free node)]) - (let ([closure - (make-closure (node-code node) free)]) - (if (null? free) - (make-combinator-var (node-name node) closure) - (init-non-combinator (node-name node))) + (let ([wk? (node-wk? node)] + [name (node-name node)] + [free (node-free node)]) + (let ([closure + (make-closure (node-code node) free wk?)]) + (cond + [(null? free) + (set-subst! name closure)] + [(and (null? (cdr free)) wk?) + (set-subst! name closure)] + [else + (unset! name)]) closure))) node*)]) (for-each - (lambda (x) - (set-closure-code! x - (trim/lift-code - (closure-code x) - (closure-free* x)))) + (lambda (lhs^ closure) + (let* ([lhs (get-forward! lhs^)] + [free + (filter var? + (remq lhs (trim-free (closure-free* closure))))]) + (set-closure-free*! closure free) + (set-closure-code! closure + (lift-code + lhs + (closure-code closure) + (closure-free* closure))))) + lhs* rhs*) - ;;; - (make-fix (trim-vars lhs*) - (trim-combinators rhs*) - (E body)))))) + (let ([body (E body)]) + (let f ([lhs* lhs*] [rhs* rhs*] [l* '()] [r* '()]) + (cond + [(null? lhs*) + (if (null? l*) + body + (make-fix l* r* body))] + [else + (let ([lhs (car lhs*)] [rhs (car rhs*)]) + (cond + [(get-subst lhs) + (unset! lhs) + (f (cdr lhs*) (cdr rhs*) l* r*)] + [else + (f (cdr lhs*) (cdr rhs*) + (cons lhs l*) (cons rhs r*))]))]))))))) + (define (get-forward! x) + (when (eq? x 'q) + (error who "BUG: circular dep")) + (let ([y (get-subst x)]) + (cond + [(not y) x] + [(var? y) + (set-subst! x 'q) + (let ([y (get-forward! y)]) + (set-subst! x y) + y)] + [(closure? y) + (let ([free (closure-free* y)]) + (cond + [(null? free) y] + [(null? (cdr free)) + (set-subst! x 'q) + (let ([y (get-forward! (car free))]) + (set-subst! x y) + y)] + [else y]))] + [else x]))) (define (E x) (struct-case x [(constant) x] - [(var) (or (var-combinator x) x)] + [(var) (get-forward! x)] [(primref) x] [(bind lhs* rhs* body) (do-bind lhs* rhs* body)] [(fix lhs* rhs* body) (do-fix lhs* rhs* body)] [(conditional test conseq altern) (make-conditional (E test) (E conseq) (E altern))] [(seq e0 e1) (make-seq (E e0) (E e1))] - [(closure c free) (optimize-one-closure c free)] [(forcall op rand*) (make-forcall op (map E rand*))] [(funcall rator rand*) (make-funcall (E rator) (map E rand*))] - [(jmpcall label rator rand*) (make-jmpcall label (E rator) (map E rand*))] - [(mvcall p c) - (struct-case c - [(clambda label cases cp free name) - (make-mvcall (E p) - (make-clambda label - (map (lambda (x) - (struct-case x - [(clambda-case info body) - (make-clambda-case info (E body))])) - cases) - cp free name))])] + [(jmpcall label rator rand*) + (make-jmpcall label (E rator) (map E rand*))] [else (error who "invalid expression" (unparse x))])) - ;(when (assembler-output) + ;(when (optimize-cp) ; (printf "BEFORE\n") - ; (pretty-print (unparse x))) + ; (parameterize ([pretty-width 200]) + ; (pretty-print (unparse x)))) (let ([x (E x)]) (let ([v (make-codes all-codes x)]) - ;(when (scc-letrec) - ; (printf "CONVERT-CLOSURE \n") - ; (pretty-print (unparse v))) + ;(when (optimize-cp) + ; (printf "AFTER\n") + ; (parameterize ([pretty-width 200]) + ; (pretty-print (unparse v)))) v))) diff --git a/scheme/last-revision b/scheme/last-revision index 178c2ec..30ed602 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1377 +1378 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index f644941..9649354 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -16,7 +16,7 @@ ;;; vim:syntax=scheme (import (only (ikarus) import)) -(import (except (ikarus) assembler-output scc-letrec)) +(import (except (ikarus) assembler-output scc-letrec optimize-cp)) (import (ikarus compiler)) (import (except (psyntax system $bootstrap) eval-core @@ -41,7 +41,9 @@ ;;; an error (which may lead to the infamous Error: Error: ;;; Error: Error: Error: Error: Error: Error: Error: ...). ;;; - '("ikarus.singular-objects.ss" + '( + + "ikarus.singular-objects.ss" "ikarus.handlers.ss" "ikarus.multiple-values.ss" "ikarus.control.ss" @@ -75,7 +77,9 @@ "ikarus.intel-assembler.ss" "ikarus.trace.ss" "ikarus.fasl.write.ss" +;;; HERE "ikarus.fasl.ss" + "ikarus.compiler.ss" "psyntax.compat.ss" "psyntax.library-manager.ss" @@ -1384,6 +1388,7 @@ [i/o-would-block-port i] [ellipsis-map ] [scc-letrec i] + [optimize-cp i] )) (define (macro-identifier? x) diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss index 88be0cb..41dbd80 100644 --- a/scheme/pass-specify-rep-primops.ss +++ b/scheme/pass-specify-rep-primops.ss @@ -1997,12 +1997,16 @@ [(E x) (nop)]) (define-primop $make-call-with-values-procedure unsafe - [(V) (K (make-closure (make-code-loc (sl-cwv-label)) '()))] + [(V) (K (make-closure + (make-code-loc (sl-cwv-label)) + '() #f))] [(P) (interrupt)] [(E) (interrupt)]) (define-primop $make-values-procedure unsafe - [(V) (K (make-closure (make-code-loc (sl-values-label)) '()))] + [(V) (K (make-closure + (make-code-loc (sl-values-label)) + '() #f))] [(P) (interrupt)] [(E) (interrupt)])