Implemented an experimental SCC letrec transformation which does not

work yet.
This commit is contained in:
Abdulaziz Ghuloum 2008-02-10 03:27:31 -05:00
parent f3c92c9473
commit 4e5121af4e
5 changed files with 276 additions and 30 deletions

Binary file not shown.

View File

@ -16,7 +16,7 @@
(library (ikarus compiler) (library (ikarus compiler)
(export compile-core-expr-to-port (export compile-core-expr-to-port
assembler-output assembler-output scc-letrec
current-primitive-locations eval-core) current-primitive-locations eval-core)
(import (import
(rnrs hashtables) (rnrs hashtables)
@ -25,7 +25,7 @@
(only (ikarus system $codes) $code->closure) (only (ikarus system $codes) $code->closure)
(only (ikarus system $structs) $struct-ref $struct/rtd?) (only (ikarus system $structs) $struct-ref $struct/rtd?)
(except (ikarus) (except (ikarus)
fasl-write fasl-write scc-letrec
compile-core-expr-to-port assembler-output compile-core-expr-to-port assembler-output
current-primitive-locations eval-core) current-primitive-locations eval-core)
(ikarus fasl write) (ikarus fasl write)
@ -562,6 +562,8 @@
;;; FIXME: surely something must go here, no? ;;; FIXME: surely something must go here, no?
'()) '())
(define complex-count 0)
(define (optimize-letrec x) (define (optimize-letrec x)
(define who 'optimize-letrec) (define who 'optimize-letrec)
(define (extend-hash lhs* h ref) (define (extend-hash lhs* h ref)
@ -576,24 +578,6 @@
[else [else
(cons (E (car x*) ref comp) (cons (E (car x*) ref comp)
(E* (cdr x*) ref comp))])) (E* (cdr x*) ref comp))]))
(define (do-rhs*-old i lhs* rhs* ref comp vref vcomp)
(cond
[(null? rhs*) '()]
[else
(let ([h (make-eq-hashtable)])
(let ([ref
(lambda (x)
(unless (hashtable-ref h x #f)
(hashtable-set! h x #t)
(ref x)
(when (memq x lhs*)
(vector-set! vref i #t))))]
[comp
(lambda ()
(vector-set! vcomp i #t)
(comp))])
(cons (E (car rhs*) ref comp)
(do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp))))]))
(define (do-rhs* i lhs* rhs* ref comp vref vcomp) (define (do-rhs* i lhs* rhs* ref comp vref vcomp)
(cond (cond
[(null? rhs*) '()] [(null? rhs*) '()]
@ -639,8 +623,15 @@
(let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)]) (let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)])
(let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*) (let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
(partition-rhs* 0 lhs* rhs* vref vcomp)]) (partition-rhs* 0 lhs* rhs* vref vcomp)])
;(unless (null? clhs*) ;;; (let ([made-complex
; (printf "CLHS* = ~s\n" (map unparse clhs*))) ;;; (filter (lambda (x) (not (var-assigned x)))
;;; clhs*)])
;;; (unless (null? made-complex)
;;; (set! complex-count
;;; (+ complex-count (length made-complex)))
;;; (printf "COMPLEX (~s) = ~s\n"
;;; complex-count
;;; (map unparse made-complex))))
(let ([void* (map (lambda (x) (make-constant (void))) clhs*)]) (let ([void* (map (lambda (x) (make-constant (void))) clhs*)])
(make-bind slhs* srhs* (make-bind slhs* srhs*
(make-bind clhs* void* (make-bind clhs* void*
@ -664,6 +655,7 @@
[(assign lhs rhs) [(assign lhs rhs)
(set-var-assigned! lhs #t) (set-var-assigned! lhs #t)
(ref lhs) (ref lhs)
(comp)
(make-assign lhs (E rhs ref comp))] (make-assign lhs (E rhs ref comp))]
[(primref) x] [(primref) x]
[(bind lhs* rhs* body) [(bind lhs* rhs* body)
@ -711,7 +703,246 @@
(E x (lambda (x) (error who "free var found" x)) (E x (lambda (x) (error who "free var found" x))
void)) void))
#|
(letrec* (bi ...
[x (let ([lhs* rhs*] ...) body)]
bj ...)
body)
===?
(letrec* (bi ...
[tmp* rhs*] ...
[lhs* tmp*] ...
[x body]
bj ...)
body)
|#
(define (optimize-letrec/scc x)
(define who 'optimize-letrec/scc)
(module (get-sccs-in-order)
(define-struct node (data link* lowlink root done collection))
(define (create-graph v* e** data*)
(define h (make-eq-hashtable))
(let ([v*
(let f ([v* v*] [data* data*])
(cond
[(null? v*) '()]
[else
(let ([node (make-node (car data*) '() #f #f #f #f)])
(hashtable-set! h (car v*) node)
(cons node (f (cdr v*) (cdr data*))))]))])
(for-each
(lambda (v e*)
(set-node-link*! v
(map (lambda (f)
(or (hashtable-ref h f #f)
(error who "invalid node" f)))
e*)))
v* e**)
v*))
(define (compute-sccs! v*)
(define all-sccs '())
(define (visit v i)
(set-node-lowlink! v i)
(set-node-root! v v)
(set-node-collection! v '())
(for-each
(lambda (v^)
(unless (node-done v^)
(unless (node-lowlink v^)
(visit v^ (+ i 1)))
(when (< (node-lowlink v^) (node-lowlink v))
(set-node-lowlink! v (node-lowlink v^))
(set-node-root! v (node-root v^)))))
(node-link* v))
(let ([root (node-root v)])
(let ([nodes (cons v (node-collection root))])
(cond
[(eq? v root)
(set! all-sccs (cons nodes all-sccs))
(for-each (lambda (x) (set-node-done! x #t)) nodes)]
[else
(set-node-collection! root
(append (node-collection v) nodes))]))))
(for-each (lambda (v) (unless (node-done v) (visit v 0))) v*)
(reverse all-sccs))
(define (get-sccs-in-order n* e** data*)
(let ([G (create-graph n* e** data*)])
(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 (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))))
(define (mkset!s b* body)
(cond
[(null? b*) body]
[else
(let* ([b (car b*)]
[lhs (binding-lhs b)])
(unless (var-assigned lhs)
(set-var-assigned! lhs #t)
(printf "MADE COMPLEX ~s\n" (unparse lhs)))
(make-seq
(make-assign lhs (binding-rhs b))
(mkset!s (cdr b*) body)))]))
(cond
[(null? (cdr scc))
(let ([b (car scc)])
(cond
[(lambda-binding? b)
(mkfix (list (binding-lhs b))
(list (binding-rhs b))
body)]
[(not (memq b (binding-free* b)))
(mklet (list (binding-lhs b))
(list (binding-rhs b))
body)]
[else
(mklet (list (binding-lhs b))
(list (make-primcall 'void '()))
(mkset!s scc 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))]))
(define (do-recbind lhs* rhs* body bc ordered?)
(define (make-bindings lhs* rhs* bc i)
(cond
[(null? lhs*) '()]
[else
(let ([b (make-binding i (car lhs*) (car rhs*) #f bc '())])
(set-var-index! (car lhs*) b)
(cons b (make-bindings (cdr lhs*) (cdr rhs*) bc (+ i 1))))]))
(define (complex? x)
(or (binding-complex x)
(var-assigned (binding-lhs x))))
(define (insert-order-edges b*)
(define (mark pb b*)
(unless (null? b*)
(let ([b (car b*)])
(if (complex? b)
(let ([free* (binding-free* b)])
(unless (memq pb free*)
(set-binding-free*! b (cons pb free*)))
(mark b (cdr b*)))
(mark pb (cdr b*))))))
(unless (null? b*)
(let ([b (car b*)])
(if (complex? b)
(mark b (cdr b*))
(insert-order-edges (cdr b*))))))
(let ([b* (make-bindings lhs* rhs* bc 0)])
(for-each (lambda (b) (set-binding-rhs! b (E (binding-rhs b) b))) b*)
(for-each (lambda (x) (set-var-index! x #f)) lhs*)
(let ([body (E body bc)])
(when ordered? (insert-order-edges b*))
(let ([scc* (get-sccs-in-order b* (map binding-free* b*) b*)])
(printf "SCCS:\n")
(for-each
(lambda (scc)
(printf " ~s\n"
(map unparse (map binding-lhs scc))))
scc*)
(gen-letrecs scc* ordered? body)))))
(define (sort-bindings ls)
(list-sort
(lambda (x y) (< (binding-serial x) (binding-serial y)))
ls))
(define-struct binding (serial lhs rhs complex prev free*))
(define (mark-complex bc)
(unless (binding-complex bc)
(set-binding-complex! bc #t)
(mark-complex (binding-prev bc))))
(define (mark-free var bc)
(let ([rb (var-index var)])
(when rb
(let ([lb
(let ([pr (binding-prev rb)])
(let f ([bc bc])
(let ([bcp (binding-prev bc)])
(cond
[(eq? bcp pr) bc]
[else (f bcp)]))))])
(let ([free* (binding-free* lb)])
(unless (memq rb free*)
;(printf "MARK FREE ~s in ~s\n"
; (unparse (binding-lhs rb))
; (unparse (binding-lhs lb)))
(set-binding-free*! lb (cons rb free*))))))))
(define (E* x* bc)
(map (lambda (x) (E x bc)) x*))
(define (E x bc)
(struct-case x
[(constant) x]
[(var)
(mark-free x bc)
x]
[(assign lhs rhs)
(set-var-assigned! lhs #t)
(mark-free lhs bc)
(mark-complex bc)
(make-assign lhs (E rhs bc))]
[(primref) x]
[(bind lhs* rhs* body)
(if (null? lhs*)
(E body bc)
(make-bind lhs* (E* rhs* bc) (E body bc)))]
[(recbind lhs* rhs* body)
(if (null? lhs*)
(E body bc)
(do-recbind lhs* rhs* body bc #f))]
[(rec*bind lhs* rhs* body)
(if (null? lhs*)
(E body bc)
(do-recbind lhs* rhs* body bc #t))]
[(conditional e0 e1 e2)
(make-conditional (E e0 bc) (E e1 bc) (E e2 bc))]
[(seq e0 e1) (make-seq (E e0 bc) (E e1 bc))]
[(clambda g cls* cp free name)
(let ([bc (make-binding #f #f #f #t bc '())])
(make-clambda g
(map (lambda (x)
(struct-case x
[(clambda-case info body)
(make-clambda-case info (E body bc))]))
cls*)
cp free name))]
[(funcall rator rand*)
(mark-complex bc)
(make-funcall (E rator bc) (E* rand* bc))]
[(mvcall p c)
(mark-complex bc)
(make-mvcall (E p bc) (E c bc))]
[(forcall rator rand*)
(mark-complex bc)
(make-forcall rator (E* rand* bc))]
[else (error who "invalid expression" (unparse x))]))
(printf "===========================================\n")
(let ([x (E x (make-binding #f #f #f #t #t '()))])
(pretty-print (unparse x))
x))
(define (uncover-assigned/referenced x) (define (uncover-assigned/referenced x)
(define who 'uncover-assigned/referenced) (define who 'uncover-assigned/referenced)
@ -1722,7 +1953,7 @@
(let-values ([(prog free) (Expr prog)]) (let-values ([(prog free) (Expr prog)])
(unless (null? free) (unless (null? free)
(error 'convert-closures "free vars encountered in program" (error 'convert-closures "free vars encountered in program"
free (unparse prog))) (map unparse free) #;(unparse prog)))
prog)) prog))
@ -1877,9 +2108,9 @@
; (pretty-print (unparse x))) ; (pretty-print (unparse x)))
(let ([x (E x)]) (let ([x (E x)])
(let ([v (make-codes all-codes x)]) (let ([v (make-codes all-codes x)])
;(when (assembler-output) (when (scc-letrec)
; (printf "AFTER\n") (printf "CONVERT-CLOSURE \n")
; (pretty-print (unparse v))) (pretty-print (unparse v)))
v))) v)))
@ -2536,11 +2767,15 @@
[else [else
(printf " ~s\n" x)])) (printf " ~s\n" x)]))
(define scc-letrec (make-parameter #f))
(define (compile-core-expr->code p) (define (compile-core-expr->code p)
(let* ([p (recordize p)] (let* ([p (recordize p)]
[p (parameterize ([open-mvcalls #f]) [p (parameterize ([open-mvcalls #f])
(optimize-direct-calls p))] (optimize-direct-calls p))]
[p (optimize-letrec p)] [p (if (scc-letrec)
(optimize-letrec/scc p)
(optimize-letrec p))]
[p (uncover-assigned/referenced p)] [p (uncover-assigned/referenced p)]
[p (copy-propagate p)] [p (copy-propagate p)]
[p (rewrite-assignments p)] [p (rewrite-assignments p)]

View File

@ -44,6 +44,16 @@
(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 intbits (* wordsize 8))
;;;(define fxbits (- intbits fxshift))
(define (fx? x) (define (fx? x)
(and (or (fixnum? x) (bignum? x)) (and (or (fixnum? x) (bignum? x))
(<= (- (expt 2 (- fxbits 1))) (<= (- (expt 2 (- fxbits 1)))

View File

@ -1 +1 @@
1371 1372

View File

@ -16,7 +16,7 @@
;;; vim:syntax=scheme ;;; vim:syntax=scheme
(import (only (ikarus) import)) (import (only (ikarus) import))
(import (except (ikarus) assembler-output)) (import (except (ikarus) assembler-output scc-letrec))
(import (ikarus compiler)) (import (ikarus compiler))
(import (except (psyntax system $bootstrap) (import (except (psyntax system $bootstrap)
eval-core eval-core
@ -1383,6 +1383,7 @@
[i/o-would-block-condition? i] [i/o-would-block-condition? i]
[i/o-would-block-port i] [i/o-would-block-port i]
[ellipsis-map ] [ellipsis-map ]
[scc-letrec i]
)) ))
(define (macro-identifier? x) (define (macro-identifier? x)