diff options
Diffstat (limited to 'module/language/tree-il')
| -rw-r--r-- | module/language/tree-il/analyze.scm | 13 | ||||
| -rw-r--r-- | module/language/tree-il/fix-letrec.scm | 153 | ||||
| -rw-r--r-- | module/language/tree-il/inline.scm | 14 | ||||
| -rw-r--r-- | module/language/tree-il/primitives.scm | 35 |
4 files changed, 204 insertions, 11 deletions
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 73ef8ba21..49633aa28 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -319,13 +319,12 @@ ;; the 1+ for this var (max nmax (allocate! body proc (1+ n)))) (else - (let ((v (if (pair? vars) (car vars) vars))) - (let ((v (car vars))) - (hashq-set! - allocation v - (make-hashq proc - `(#t ,(hashq-ref assigned v) . ,n))) - (lp (cdr vars) (1+ n))))))))) + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n)))))))) (else n))) diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index 61504f6f1..0ed7b6bab 100644 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@ -18,12 +18,163 @@ (define-module (language tree-il fix-letrec) #:use-module (system base syntax) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (language tree-il) + #:use-module (language tree-il primitives) #:export (fix-letrec!)) ;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet ;; Efficient Implementation of Scheme’s Recursive Binding Construct", by ;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig. +(define fix-fold + (make-tree-il-folder unref ref set simple lambda complex)) + +(define (simple-expression? x bound-vars) + (record-case x + ((<void>) #t) + ((<const>) #t) + ((<lexical-ref> gensym) + (not (memq gensym bound-vars))) + ((<conditional> test then else) + (and (simple-expression? test bound-vars) + (simple-expression? then bound-vars) + (simple-expression? else bound-vars))) + ((<sequence> exps) + (and-map (lambda (x) (simple-expression? x bound-vars)) + exps)) + ((<application> proc args) + (and (primitive-ref? proc) + (effect-free-primitive? (primitive-ref-name proc)) + (and-map (lambda (x) (simple-expression? x bound-vars)) + args))) + (else #f))) + +(define (partition-vars x) + (let-values + (((unref ref set simple lambda* complex) + (fix-fold x + (lambda (x unref ref set simple lambda* complex) + (record-case x + ((<lexical-ref> gensym) + (values (delq gensym unref) + (lset-adjoin eq? ref gensym) + set + simple + lambda* + complex)) + ((<lexical-set> gensym) + (values unref + ref + (lset-adjoin eq? set gensym) + simple + lambda* + complex)) + ((<letrec> vars) + (values (append vars unref) + ref + set + simple + lambda* + complex)) + (else + (values unref ref set simple lambda* complex)))) + (lambda (x unref ref set simple lambda* complex) + (record-case x + ((<letrec> (orig-vars vars) vals) + (let lp ((vars orig-vars) (vals vals) + (s '()) (l '()) (c '())) + (cond + ((null? vars) + (values unref + ref + set + (append s simple) + (append l lambda*) + (append c complex))) + ((memq (car vars) unref) + (lp (cdr vars) (cdr vals) + s l c)) + ((memq (car vars) set) + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c))) + ((lambda? (car vals)) + (lp (cdr vars) (cdr vals) + s (cons (car vars) l) c)) + ((simple-expression? (car vals) orig-vars) + (lp (cdr vars) (cdr vals) + (cons (car vars) s) l c)) + (else + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c)))))) + (else + (values unref ref set simple lambda* complex)))) + '() + '() + '() + '() + '() + '()))) + (values unref simple lambda* complex))) + (define (fix-letrec! x) - x) + (let-values (((unref simple lambda* complex) (partition-vars x))) + (post-order! + (lambda (x) + (record-case x + + ;; Sets to unreferenced variables may be replaced by their + ;; expression, called for effect. + ((<lexical-set> gensym exp) + (if (memq gensym unref) + (make-sequence #f (list (make-void #f) exp)) + x)) + + ((<letrec> src names vars vals body) + (let ((binds (map list vars names vals))) + (define (lookup set) + (map (lambda (v) (assq v binds)) + (lset-intersection eq? vars set))) + (let ((u (lookup unref)) + (s (lookup simple)) + (l (lookup lambda*)) + (c (lookup complex))) + ;; Bind "simple" bindings, and locations for complex + ;; bindings. + (make-let + src + (append (map cadr s) (map cadr c)) + (append (map car s) (map car c)) + (append (map caddr s) (map (lambda (x) (make-void #f)) c)) + ;; Bind lambdas using the fixpoint operator. + (make-fix + src (map cadr l) (map car l) (map caddr l) + (make-sequence + src + (append + ;; The right-hand-sides of the unreferenced + ;; bindings, for effect. + (map caddr u) + (if (null? c) + ;; No complex bindings, just emit the body. + (list body) + (list + ;; Evaluate the the "complex" bindings, in a `let' to + ;; indicate that order doesn't matter, and bind to + ;; their variables. + (let ((tmps (map (lambda (x) (gensym)) c))) + (make-let + #f (map cadr c) tmps (map caddr c) + (make-sequence + #f + (map (lambda (x tmp) + (make-lexical-set + #f (cadr x) (car x) + (make-lexical-ref #f (cadr x) tmp))) + c tmps)))) + ;; Finally, the body. + body))))))))) + + (else x))) + x))) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index fd3fbc921..adc3f18bd 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -41,7 +41,8 @@ (cond ;; ((lambda () x)) => x - ((and (lambda? proc) (null? args)) + ((and (lambda? proc) (null? (lambda-vars proc)) + (null? args)) (lambda-body proc)) ;; (call-with-values (lambda () foo) (lambda (a b . c) bar)) @@ -66,6 +67,15 @@ (lambda-body consumer)))) (else #f))) - + + ((<let> vars body) + (if (null? vars) body x)) + + ((<letrec> vars body) + (if (null? vars) body x)) + + ((<fix> vars body) + (if (null? vars) body x)) + (else #f))) x)) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 0f58e22fb..24900c64d 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -25,7 +25,7 @@ #:use-module (language tree-il) #:use-module (srfi srfi-16) #:export (resolve-primitives! add-interesting-primitive! - expand-primitives!)) + expand-primitives! effect-free-primitive?)) (define *interesting-primitive-names* '(apply @apply @@ -85,6 +85,39 @@ (for-each add-interesting-primitive! *interesting-primitive-names*) +(define *effect-free-primitives* + '(values + eq? eqv? equal? + = < > <= >= zero? + + * - / 1- 1+ quotient remainder modulo + not + pair? null? list? acons cons cons* + list vector + car cdr + caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + vector-ref + bytevector-u8-ref bytevector-s8-ref + bytevector-u16-ref bytevector-u16-native-ref + bytevector-s16-ref bytevector-s16-native-ref + bytevector-u32-ref bytevector-u32-native-ref + bytevector-s32-ref bytevector-s32-native-ref + bytevector-u64-ref bytevector-u64-native-ref + bytevector-s64-ref bytevector-s64-native-ref + bytevector-ieee-single-ref bytevector-ieee-single-native-ref + bytevector-ieee-double-ref bytevector-ieee-double-native-ref)) + + +(define *effect-free-primitive-table* (make-hash-table)) + +(for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t)) + *effect-free-primitives*) + +(define (effect-free-primitive? prim) + (hashq-ref *effect-free-primitive-table* prim)) + (define (resolve-primitives! x mod) (post-order! (lambda (x) |