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

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

@ -33,26 +33,26 @@
(module (wordsize)
(include "ikarus.config.ss"))
(define-syntax fxshift
(identifier-syntax
(case wordsize
[(4) 2]
[(8) 3]
[else (error 'fxshift "invalid wordsize" wordsize)])))
;;; (define-syntax fxshift
;;; (identifier-syntax
;;; (case wordsize
;;; [(4) 2]
;;; [(8) 3]
;;; [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
;;; (case wordsize
;;; [(4) 2]
;;; [(8) 3]
;;; [else (error 'fxshift "invalid wordsize" wordsize)]))
(define fxshift
(case wordsize
[(4) 2]
[(8) 3]
[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)
(and (or (fixnum? x) (bignum? x))

2
scheme/last-revision
View File

@ -1 +1 @@
1374
1375