Implemented an experimental SCC letrec transformation which does not
work yet.
This commit is contained in:
parent
f3c92c9473
commit
4e5121af4e
Binary file not shown.
|
@ -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)]
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
1371
|
1372
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Loading…
Reference in New Issue