X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/0dd7c5407599b65a1a3da4b9bd8feccc715b51f7..26d148066f9cb20e395a7dc4fefdf2e2ef0b2fb0:/module/language/tree-il/peval.scm diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 542ded164..fe637f0a5 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1,6 +1,6 @@ ;;; Tree-IL partial evaluator -;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -285,7 +285,7 @@ ;; TODO: Record value size in operand structure? ;; (define-record-type - (%make-operand var sym visit source visit-count residualize? + (%make-operand var sym visit source visit-count use-count copyable? residual-value constant-value alias-value) operand? (var operand-var) @@ -293,7 +293,7 @@ (visit %operand-visit) (source operand-source) (visit-count operand-visit-count set-operand-visit-count!) - (residualize? operand-residualize? set-operand-residualize?!) + (use-count operand-use-count set-operand-use-count!) (copyable? operand-copyable? set-operand-copyable?!) (residual-value operand-residual-value %set-operand-residual-value!) (constant-value operand-constant-value set-operand-constant-value!) @@ -305,7 +305,7 @@ ;; expression, truncate it to one value. Copy propagation does not ;; work on multiply-valued expressions. (let ((source (and=> source truncate-values))) - (%make-operand var sym visit source 0 #f + (%make-operand var sym visit source 0 0 (and source (not (var-set? var))) #f #f (and (not (var-set? var)) alias)))) @@ -426,11 +426,18 @@ top-level bindings from ENV and return the resulting expression." (define (fresh-gensyms vars) (map (lambda (var) (let ((new (gensym (string-append (symbol->string (var-name var)) - "-")))) + " ")))) (set! store (vhash-consq new var store)) new)) vars)) + (define (fresh-temporaries ls) + (map (lambda (elt) + (let ((new (gensym "tmp "))) + (record-new-temporary! 'tmp new 1) + new)) + ls)) + (define (assigned-lexical? sym) (var-set? (lookup-var sym))) @@ -451,10 +458,19 @@ top-level bindings from ENV and return the resulting expression." (let ((x (vhash-assq new store))) (if x (cdr x) new))) + (define (record-operand-use op) + (set-operand-use-count! op (1+ (operand-use-count op)))) + + (define (unrecord-operand-uses op n) + (let ((count (- (operand-use-count op) n))) + (when (zero? count) + (set-operand-residual-value! op #f)) + (set-operand-use-count! op count))) + (define* (residualize-lexical op #:optional ctx val) (log 'residualize op) - (set-operand-residualize?! op #t) - (if (eq? ctx 'value) + (record-operand-use op) + (if (memq ctx '(value values)) (set-operand-residual-value! op val)) (make-lexical-ref #f (var-name (operand-var op)) (operand-sym op))) @@ -499,7 +515,7 @@ top-level bindings from ENV and return the resulting expression." (else (residualize-call)))) - (define (inline-values exp src names gensyms body) + (define (inline-values src exp nmin nmax consumer) (let loop ((exp exp)) (match exp ;; Some expression types are always singly-valued. @@ -515,17 +531,15 @@ top-level bindings from ENV and return the resulting expression." ($ ) ; could return zero values in ($ ) ; the future ($ ) ; - ($ )) ; - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) - (($ src (? singly-valued-primitive? name)) - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) + ($ ) ; + ($ src (? singly-valued-primitive?))) + (and (<= nmin 1) (or (not nmax) (>= nmax 1)) + (make-call src (make-lambda #f '() consumer) (list exp)))) ;; Statically-known number of values. (($ src 'values vals) - (and (= (length names) (length vals)) - (make-let src names gensyms vals body))) + (and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals))) + (make-call src (make-lambda #f '() consumer) vals))) ;; Not going to copy code into both branches. (($ ) #f) @@ -594,7 +608,8 @@ top-level bindings from ENV and return the resulting expression." ;; marked as needing residualization. Here we hack around this ;; and treat all bindings as referenced if we are in operator ;; context. - (or (eq? ctx 'operator) (operand-residualize? op))) + (or (eq? ctx 'operator) + (not (zero? (operand-use-count op))))) ;; values := (op ...) ;; effects := (op ...) @@ -682,6 +697,49 @@ top-level bindings from ENV and return the resulting expression." ((vhash-assq var env) => cdr) (else (error "unbound var" var)))) + ;; Find a value referenced a specific number of times. This is a hack + ;; that's used for propagating fresh data structures like rest lists and + ;; prompt tags. Usually we wouldn't copy consed data, but we can do so in + ;; some special cases like `apply' or prompts if we can account + ;; for all of its uses. + ;; + ;; You don't want to use this in general because it introduces a slight + ;; nonlinearity by running peval again (though with a small effort and size + ;; counter). + ;; + (define (find-definition x n-aliases) + (cond + ((lexical-ref? x) + (cond + ((lookup (lexical-ref-gensym x)) + => (lambda (op) + (let ((y (or (operand-residual-value op) + (visit-operand op counter 'value 10 10) + (operand-source op)))) + (cond + ((and (lexical-ref? y) + (= (lexical-refcount (lexical-ref-gensym x)) 1)) + ;; X is a simple alias for Y. Recurse, regardless of + ;; the number of aliases we were expecting. + (find-definition y n-aliases)) + ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases) + ;; We found a definition that is aliased the right + ;; number of times. We still recurse in case it is a + ;; lexical. + (values (find-definition y 1) + op)) + (else + ;; We can't account for our aliases. + (values #f #f)))))) + (else + ;; A formal parameter. Can't say anything about that. + (values #f #f)))) + ((= n-aliases 1) + ;; Not a lexical: success, but only if we are looking for an + ;; unaliased value. + (values x #f)) + (else (values #f #f)))) + (define (visit exp ctx) (loop exp env counter ctx)) @@ -808,8 +866,32 @@ top-level bindings from ENV and return the resulting expression." exp (make-seq src exp (make-void #f)))) (begin - (set-operand-residualize?! op #t) + (record-operand-use op) (make-lexical-set src name (operand-sym op) (for-value exp)))))) + (($ src + (names ... rest) + (gensyms ... rest-sym) + (vals ... ($ _ 'list rest-args)) + ($ asrc (or 'apply '@apply) + (proc args ... + ($ _ + (? (cut eq? <> rest)) + (? (lambda (sym) + (and (eq? sym rest-sym) + (= (lexical-refcount sym) 1)))))))) + (let* ((tmps (make-list (length rest-args) 'tmp)) + (tmp-syms (fresh-temporaries tmps))) + (for-tail + (make-let src + (append names tmps) + (append gensyms tmp-syms) + (append vals rest-args) + (make-call + asrc + proc + (append args + (map (cut make-lexical-ref #f <> <>) + tmps tmp-syms))))))) (($ src names gensyms vals body) (define (compute-alias exp) ;; It's very common for macros to introduce something like: @@ -905,11 +987,13 @@ top-level bindings from ENV and return the resulting expression." ;; reconstruct the let-values, pevaling the consumer. (let ((producer (for-values producer))) (or (match consumer - (($ src req #f #f #f () gensyms body #f) - (cond - ((inline-values producer src req gensyms body) - => for-tail) - (else #f))) + (($ src req opt rest #f inits gensyms body #f) + (let* ((nmin (length req)) + (nmax (and (not rest) (+ nmin (if opt (length opt) 0))))) + (cond + ((inline-values lv-src producer nmin nmax consumer) + => for-tail) + (else #f)))) (_ #f)) (make-let-values lv-src producer (for-tail consumer))))) (($ src winder pre body post unwinder) @@ -1091,6 +1175,32 @@ top-level bindings from ENV and return the resulting expression." (for-tail (list->seq src (append (cdr vals) (list (car vals))))) (make-primcall src 'values vals)))))) + (($ src (or 'apply '@apply) (proc args ... tail)) + (let lp ((tail* (find-definition tail 1)) (speculative? #t)) + (define (copyable? x) + ;; Inlining a result from find-definition effectively copies it, + ;; relying on the let-pruning to remove its original binding. We + ;; shouldn't copy non-constant expressions. + (or (not speculative?) (constant-expression? x))) + (match tail* + (($ _ (args* ...)) + (let ((args* (map (cut make-const #f <>) args*))) + (for-tail (make-call src proc (append args args*))))) + (($ _ 'cons + ((and head (? copyable?)) (and tail (? copyable?)))) + (for-tail (make-primcall src '@apply + (cons proc + (append args (list head tail)))))) + (($ _ 'list + (and args* ((? copyable?) ...))) + (for-tail (make-call src proc (append args args*)))) + (tail* + (if speculative? + (lp (for-value tail) #f) + (let ((args (append (map for-value args) (list tail*)))) + (make-primcall src '@apply + (cons (for-value proc) args)))))))) + (($ src (? constructor-primitive? name) args) (cond ((and (memq ctx '(effect test)) @@ -1198,20 +1308,39 @@ top-level bindings from ENV and return the resulting expression." (($ src orig-proc orig-args) ;; todo: augment the global env with specialized functions - (let ((proc (visit orig-proc 'operator))) + (let revisit-proc ((proc (visit orig-proc 'operator))) (match proc (($ _ name) (for-tail (make-primcall src name orig-args))) (($ _ _ - ($ _ req opt #f #f inits gensyms body #f)) - ;; Simple case: no rest, no keyword arguments. + ($ _ req opt rest #f inits gensyms body #f)) + ;; Simple case: no keyword arguments. ;; todo: handle the more complex cases (let* ((nargs (length orig-args)) (nreq (length req)) (nopt (if opt (length opt) 0)) (key (source-expression proc))) + (define (inlined-call) + (make-let src + (append req + (or opt '()) + (if rest (list rest) '())) + gensyms + (if (> nargs (+ nreq nopt)) + (append (list-head orig-args (+ nreq nopt)) + (list + (make-primcall + #f 'list + (drop orig-args (+ nreq nopt))))) + (append orig-args + (drop inits (- nargs nreq)) + (if rest + (list (make-const #f '())) + '()))) + body)) + (cond - ((or (< nargs nreq) (> nargs (+ nreq nopt))) + ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt)))) ;; An error, or effecting arguments. (make-call src (for-call orig-proc) (map for-value orig-args))) ((or (and=> (find-counter key counter) counter-recursive?) @@ -1235,12 +1364,7 @@ top-level bindings from ENV and return the resulting expression." (lp (counter-prev counter))))))) (log 'inline-recurse key) - (loop (make-let src (append req (or opt '())) - gensyms - (append orig-args - (drop inits (- nargs nreq))) - body) - env counter ctx)) + (loop (inlined-call) env counter ctx)) (else ;; An integration at the top-level, the first ;; recursion of a recursive procedure, or a nested @@ -1271,12 +1395,7 @@ top-level bindings from ENV and return the resulting expression." (make-top-counter effort-limit operand-size-limit abort key)))) (define result - (loop (make-let src (append req (or opt '())) - gensyms - (append orig-args - (drop inits (- nargs nreq))) - body) - env new-counter ctx)) + (loop (inlined-call) env new-counter ctx)) (if counter ;; The nested inlining attempt succeeded. @@ -1286,6 +1405,31 @@ top-level bindings from ENV and return the resulting expression." (log 'inline-end result exp) result))))) + (($ _ _ _ vals _) + ;; Attempt to inline `let' in the operator position. + ;; + ;; We have to re-visit the proc in value mode, since the + ;; `let' bindings might have been introduced or renamed, + ;; whereas the lambda (if any) in operator position has not + ;; been renamed. + (if (or (and-map constant-expression? vals) + (and-map constant-expression? orig-args)) + ;; The arguments and the let-bound values commute. + (match (for-value orig-proc) + (($ lsrc names syms vals body) + (log 'inline-let orig-proc) + (for-tail + (make-let lsrc names syms vals + (make-call src body orig-args)))) + ;; It's possible for a `let' to go away after the + ;; visit due to the fact that visiting a procedure in + ;; value context will prune unused bindings, whereas + ;; visiting in operator mode can't because it doesn't + ;; traverse through lambdas. In that case re-visit + ;; the procedure. + (proc (revisit-proc proc))) + (make-call src (for-call orig-proc) + (map for-value orig-args)))) (_ (make-call src (for-call orig-proc) (map for-value orig-args)))))) (($ src meta body) @@ -1295,13 +1439,13 @@ top-level bindings from ENV and return the resulting expression." ((operator) exp) (else (record-source-expression! exp - (make-lambda src meta (for-values body)))))) + (make-lambda src meta (and body (for-values body))))))) (($ src req opt rest kw inits gensyms body alt) (define (lift-applied-lambda body gensyms) (and (not opt) rest (not kw) (match body (($ _ '@apply - (($ _ _ lcase) + (($ _ _ (and lcase ($ ))) ($ _ _ sym) ...)) (and (equal? sym gensyms) @@ -1339,24 +1483,48 @@ top-level bindings from ENV and return the resulting expression." head) tail)))) (($ src tag body handler) - (define (singly-used-definition x) + (define (make-prompt-tag? x) + (match x + (($ _ 'make-prompt-tag (or () ((? constant-expression?)))) + #t) + (_ #f))) + + (let ((tag (for-value tag)) + (body (for-tail body))) (cond - ((and (lexical-ref? x) - ;; Only fetch definitions with single uses. - (= (lexical-refcount (lexical-ref-gensym x)) 1) - (lookup (lexical-ref-gensym x))) - => (lambda (x) - (singly-used-definition (visit-operand x counter 'value 10 10)))) - (else x))) - (match (singly-used-definition tag) - (($ _ 'make-prompt-tag (or () ((? constant-expression?)))) - ;; There is no way that an could know the tag - ;; for this , so we can elide the - ;; entirely. - (for-tail body)) - (_ - (make-prompt src (for-value tag) (for-tail body) - (for-value handler))))) + ((find-definition tag 1) + (lambda (val op) + (make-prompt-tag? val)) + => (lambda (val op) + ;; There is no way that an could know the tag + ;; for this , so we can elide the + ;; entirely. + (unrecord-operand-uses op 1) + body)) + ((find-definition tag 2) + (lambda (val op) + (and (make-prompt-tag? val) + (abort? body) + (tree-il=? (abort-tag body) tag))) + => (lambda (val op) + ;; (let ((t (make-prompt-tag))) + ;; (call-with-prompt t + ;; (lambda () (abort-to-prompt t val ...)) + ;; (lambda (k arg ...) e ...))) + ;; => (let-values (((k arg ...) (values values val ...))) + ;; e ...) + (unrecord-operand-uses op 2) + (for-tail + (make-let-values + src + (make-primcall #f 'apply + `(,(make-primitive-ref #f 'values) + ,(make-primitive-ref #f 'values) + ,@(abort-args body) + ,(abort-tail body))) + (for-value handler))))) + (else + (make-prompt src tag body (for-value handler)))))) (($ src tag args tail) (make-abort src (for-value tag) (map for-value args) (for-value tail))))))