conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

SCC-letrec optimization is now online.

This commit is contained in:
Abdulaziz Ghuloum 2008-02-10 05:46:58 -05:00
parent 6df608ccd9
commit 5b904b93c4
4 changed files with 54 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

66
scheme/ikarus.compiler.ss
View File

@ -772,15 +772,17 @@
(let ([sccs (compute-sccs! G)]) (let ([sccs (compute-sccs! G)])
(map (lambda (scc) (map node-data scc)) sccs))))) (map (lambda (scc) (map node-data scc)) sccs)))))
(define (gen-letrecs scc* ordered? body) (define (gen-letrecs scc* ordered? body)
(define (gen-letrec scc ordered? body) (define (mkfix b* body)
(if (null? b*)
body
(make-fix (map binding-lhs b*)
(map binding-rhs b*)
body)))
(define (gen-letrec scc fix* body)
(define (mklet lhs* rhs* body) (define (mklet lhs* rhs* body)
(if (null? lhs*) (if (null? lhs*)
body body
(make-bind lhs* rhs* body))) (make-bind lhs* rhs* body)))
(define (mkfix lhs* rhs* body)
(if (null? lhs*)
body
(make-fix lhs* rhs* body)))
(define (lambda-binding? x) (define (lambda-binding? x)
(and (not (var-assigned (binding-lhs x))) (and (not (var-assigned (binding-lhs x)))
(clambda? (binding-rhs x)))) (clambda? (binding-rhs x))))
@ -801,33 +803,41 @@
(let ([b (car scc)]) (let ([b (car scc)])
(cond (cond
[(lambda-binding? b) [(lambda-binding? b)
(mkfix (list (binding-lhs b)) (values (cons b fix*) body)]
(list (binding-rhs b))
body)]
[(not (memq b (binding-free* b))) [(not (memq b (binding-free* b)))
(mklet (list (binding-lhs b)) (values '()
(list (binding-rhs b)) (mklet (list (binding-lhs b))
body)] (list (binding-rhs b))
(mkfix fix* body)))]
[else [else
(mklet (list (binding-lhs b)) (values '()
(list (make-primcall 'void '())) (mklet (list (binding-lhs b))
(mkset!s scc body))]))] (list (make-primcall 'void '()))
(mkset!s scc
(mkfix fix* body))))]))]
[else [else
(let-values ([(lambda* complex*) (let-values ([(lambda* complex*)
(partition lambda-binding? scc)]) (partition lambda-binding? scc)])
(let ([complex* (cond
(if ordered? (sort-bindings complex*) complex*)]) [(null? complex*)
(mklet (map binding-lhs complex*) (values (append lambda* fix*) body)]
(map (lambda (x) (make-primcall 'void '())) [else
complex*) (let ([complex*
(mkfix (map binding-lhs lambda*) (if ordered? (sort-bindings complex*) complex*)])
(map binding-rhs lambda*) (values '()
(mkset!s complex* body)))))])) (mklet (map binding-lhs complex*)
(cond (map (lambda (x) (make-primcall 'void '()))
[(null? scc*) body] complex*)
[else (mkfix (append lambda* fix*)
(gen-letrec (car scc*) ordered? (mkset!s complex* body)))))]))]))
(gen-letrecs (cdr scc*) ordered? body))])) (let-values ([(fix* body)
(let f ([scc* scc*])
(cond
[(null? scc*) (values '() body)]
[else
(let-values ([(fix* body) (f (cdr scc*))])
(gen-letrec (car scc*) fix* body))]))])
(mkfix fix* body)))
(define (do-recbind lhs* rhs* body bc ordered?) (define (do-recbind lhs* rhs* body bc ordered?)
(define (make-bindings lhs* rhs* bc i) (define (make-bindings lhs* rhs* bc i)
(cond (cond
@ -2859,7 +2869,7 @@
[else [else
(printf " ~s\n" x)])) (printf " ~s\n" x)]))
(define scc-letrec (make-parameter #f)) (define scc-letrec (make-parameter #t))
(define (compile-core-expr->code p) (define (compile-core-expr->code p)
(let* ([p (recordize p)] (let* ([p (recordize p)]

30
scheme/ikarus.fasl.write.ss
View File

@ -33,26 +33,26 @@
(module (wordsize) (module (wordsize)
(include "ikarus.config.ss")) (include "ikarus.config.ss"))
(define-syntax fxshift ;;; (define-syntax fxshift
(identifier-syntax ;;; (identifier-syntax
(case wordsize ;;; (case wordsize
[(4) 2] ;;; [(4) 2]
[(8) 3] ;;; [(8) 3]
[else (error 'fxshift "invalid wordsize" wordsize)]))) ;;; [else (error 'fxshift "invalid wordsize" wordsize)])))
(define-syntax intbits (identifier-syntax (* wordsize 8))) ;;; (define-syntax intbits (identifier-syntax (* wordsize 8)))
(define-syntax fxbits (identifier-syntax (- intbits fxshift))) ;;; (define-syntax fxbits (identifier-syntax (- intbits fxshift)))
;;;(define fxshift (define fxshift
;;; (case wordsize (case wordsize
;;; [(4) 2] [(4) 2]
;;; [(8) 3] [(8) 3]
;;; [else (error 'fxshift "invalid wordsize" wordsize)])) [else (error 'fxshift "invalid wordsize" wordsize)]))
;;;(define intbits (* wordsize 8)) (define intbits (* wordsize 8))
;;;(define fxbits (- intbits fxshift)) (define fxbits (- intbits fxshift))
(define (fx? x) (define (fx? x)
(and (or (fixnum? x) (bignum? x)) (and (or (fixnum? x) (bignum? x))

2
scheme/last-revision
View File

@ -1 +1 @@
1374 1375