X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/5da51ad78d08c71083b70e6a9205ce937f5438ba..c32b7c4cef1c63a677a1c447a0386e90ab2ecd42:/module/language/tree-il/peval.scm diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 5ae691ddd..5b9852b01 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (ice-9 control) #:export (peval)) ;;; @@ -73,23 +74,11 @@ (newline) (values))) -(define-syntax-rule (let/ec k e e* ...) - (let ((tag (make-prompt-tag))) - (call-with-prompt - tag - (lambda () - (let ((k (lambda args (apply abort-to-prompt tag args)))) - e e* ...)) - (lambda (_ res) res)))) - (define (tree-il-any proc exp) (let/ec k (tree-il-fold (lambda (exp res) (let ((res (proc exp))) (if res (k res) #f))) - (lambda (exp res) - (let ((res (proc exp))) - (if res (k res) #f))) (lambda (exp res) #f) #f exp))) @@ -112,6 +101,9 @@ (($ _ (? singly-valued-primitive?)) #t) (($ _ 'values (val)) #t) (($ ) #t) + (($ _ test consequent alternate) + (and (singly-valued-expression? consequent) + (singly-valued-expression? alternate))) (else #f))) (define (truncate-values x) @@ -140,9 +132,6 @@ (let ((var (cdr (vhash-assq gensym res)))) (set-var-refcount! var (1+ (var-refcount var))) res)) - (_ res))) - (lambda (exp res) - (match exp (($ src req opt rest kw init gensyms body alt) (fold (lambda (name sym res) (vhash-consq sym (make-var name sym 0 #f) res)) @@ -431,12 +420,60 @@ top-level bindings from ENV and return the resulting expression." 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))) (define (lexical-refcount sym) (var-refcount (lookup-var sym))) + (define (with-temporaries src exps refcount can-copy? k) + (let* ((pairs (map (match-lambda + ((and exp (? can-copy?)) + (cons #f exp)) + (exp + (let ((sym (gensym "tmp "))) + (record-new-temporary! 'tmp sym refcount) + (cons sym exp)))) + exps)) + (tmps (filter car pairs))) + (match tmps + (() (k exps)) + (tmps + (make-let src + (make-list (length tmps) 'tmp) + (map car tmps) + (map cdr tmps) + (k (map (match-lambda + ((#f . val) val) + ((sym . _) + (make-lexical-ref #f 'tmp sym))) + pairs))))))) + + (define (make-begin0 src first second) + (make-let-values + src + first + (let ((vals (gensym "vals "))) + (record-new-temporary! 'vals vals 1) + (make-lambda-case + #f + '() #f 'vals #f '() (list vals) + (make-seq + src + second + (make-primcall #f 'apply + (list + (make-primitive-ref #f 'values) + (make-lexical-ref #f 'vals vals)))) + #f)))) + ;; ORIG has been alpha-renamed to NEW. Analyze NEW and record a link ;; from it to ORIG. ;; @@ -508,7 +545,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. @@ -519,22 +556,18 @@ top-level bindings from ENV and return the resulting expression." ($ ) ($ ) ($ ) - ($ ) ($ ) ; FIXME: these set! expressions ($ ) ; 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) @@ -567,14 +600,6 @@ top-level bindings from ENV and return the resulting expression." (make-let-values src exp (make-lambda-case src2 req opt rest kw inits gensyms body #f))))) - (($ src winder pre body post unwinder) - (let ((body (loop body))) - (and body - (make-dynwind src winder pre body post unwinder)))) - (($ src fluids vals body) - (let ((body (loop body))) - (and body - (make-dynlet src fluids vals body)))) (($ src head tail) (let ((tail (loop tail))) (and tail (make-seq src head tail))))))) @@ -669,8 +694,6 @@ top-level bindings from ENV and return the resulting expression." (define (small-expression? x limit) (let/ec k (tree-il-fold - (lambda (x res) ; leaf - (1+ res)) (lambda (x res) ; down (1+ res)) (lambda (x res) ; up @@ -692,6 +715,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)) @@ -820,6 +886,30 @@ top-level bindings from ENV and return the resulting expression." (begin (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 '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: @@ -915,24 +1005,32 @@ 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-name) #f #f #f () (req-sym) body #f) + (for-tail + (make-let src (list req-name) (list req-sym) (list producer) + body))) + ((and ($ src () #f rest #f () (rest-sym) body #f) + (? (lambda _ (singly-valued-expression? producer)))) + (let ((tmp (gensym "tmp "))) + (record-new-temporary! 'tmp tmp 1) + (for-tail + (make-let + src (list 'tmp) (list tmp) (list producer) + (make-let + src (list rest) (list rest-sym) + (list + (make-primcall #f 'list + (list (make-lexical-ref #f 'tmp tmp)))) + body))))) + (($ 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) - (make-dynwind src (for-value winder) (for-effect pre) - (for-tail body) - (for-effect post) (for-value unwinder))) - (($ src fluids vals body) - (make-dynlet src (map for-value fluids) (map for-value vals) - (for-tail body))) - (($ src fluid) - (make-dynref src (for-value fluid))) - (($ src fluid exp) - (make-dynset src (for-value fluid) (for-value exp))) (($ src (? effect-free-primitive? name)) exp) (($ ) @@ -1034,7 +1132,7 @@ top-level bindings from ENV and return the resulting expression." (simplify-conditional (make-conditional src c (for-tail subsequent) (for-tail alternate)))))) - (($ src '@call-with-values + (($ src 'call-with-values (producer ($ _ _ (and consumer @@ -1045,46 +1143,45 @@ top-level bindings from ENV and return the resulting expression." consumer))) (($ src 'dynamic-wind (w thunk u)) (for-tail - (cond - ((not (constant-expression? w)) - (cond - ((not (constant-expression? u)) - (let ((w-sym (gensym "w ")) (u-sym (gensym "u "))) - (record-new-temporary! 'w w-sym 2) - (record-new-temporary! 'u u-sym 2) - (make-let src '(w u) (list w-sym u-sym) (list w u) - (make-dynwind - src - (make-lexical-ref #f 'w w-sym) - (make-call #f (make-lexical-ref #f 'w w-sym) '()) - (make-call #f thunk '()) - (make-call #f (make-lexical-ref #f 'u u-sym) '()) - (make-lexical-ref #f 'u u-sym))))) - (else - (let ((w-sym (gensym "w "))) - (record-new-temporary! 'w w-sym 2) - (make-let src '(w) (list w-sym) (list w) - (make-dynwind - src - (make-lexical-ref #f 'w w-sym) - (make-call #f (make-lexical-ref #f 'w w-sym) '()) - (make-call #f thunk '()) - (make-call #f u '()) - u)))))) - ((not (constant-expression? u)) - (let ((u-sym (gensym "u "))) - (record-new-temporary! 'u u-sym 2) - (make-let src '(u) (list u-sym) (list u) - (make-dynwind - src - w - (make-call #f w '()) - (make-call #f thunk '()) - (make-call #f (make-lexical-ref #f 'u u-sym) '()) - (make-lexical-ref #f 'u u-sym))))) - (else - (make-dynwind src w (make-call #f w '()) (make-call #f thunk '()) - (make-call #f u '()) u))))) + (with-temporaries + src (list w u) 2 constant-expression? + (match-lambda + ((w u) + (make-seq + src + (make-seq + src + (make-conditional + src + ;; fixme: introduce logic to fold thunk? + (make-primcall src 'thunk? (list u)) + (make-call src w '()) + (make-primcall + src 'scm-error + (list + (make-const #f 'wrong-type-arg) + (make-const #f "dynamic-wind") + (make-const #f "Wrong type (expecting thunk): ~S") + (make-primcall #f 'list (list u)) + (make-primcall #f 'list (list u))))) + (make-primcall src 'wind (list w u))) + (make-begin0 src + (make-call src thunk '()) + (make-seq src + (make-primcall src 'unwind '()) + (make-call src u '()))))))))) + + (($ src 'with-fluid* (f v thunk)) + (for-tail + (with-temporaries + src (list f v thunk) 1 constant-expression? + (match-lambda + ((f v thunk) + (make-seq src + (make-primcall src 'push-fluid (list f v)) + (make-begin0 src + (make-call src thunk '()) + (make-primcall src 'pop-fluid '())))))))) (($ src 'values exps) (cond @@ -1101,16 +1198,31 @@ 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)) - (match (for-value tail) - (($ _ (args* ...)) - (let ((args* (map (lambda (x) (make-const #f x)) args*))) - (for-tail (make-call src proc (append args args*))))) - (($ _ 'list args*) - (for-tail (make-call src proc (append args args*)))) - (tail - (let ((args (append (map for-value args) (list tail)))) - (make-primcall src '@apply (cons (for-value proc) args)))))) + (($ src '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 @@ -1138,6 +1250,15 @@ top-level bindings from ENV and return the resulting expression." ((name . args) (make-primcall src name args)))))) + (($ src 'thunk? (proc)) + (match (for-value proc) + (($ _ _ ($ _ req)) + (for-tail (make-const src (null? req)))) + (proc + (case ctx + ((effect) (make-void src)) + (else (make-primcall src 'thunk? (list proc))))))) + (($ src (? accessor-primitive? name) args) (match (cons name (map for-value args)) ;; FIXME: these for-tail recursions could take place outside @@ -1219,20 +1340,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?) @@ -1256,12 +1396,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 @@ -1292,12 +1427,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. @@ -1307,6 +1437,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) @@ -1316,13 +1471,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) + (($ _ 'apply + (($ _ _ (and lcase ($ ))) ($ _ _ sym) ...)) (and (equal? sym gensyms) @@ -1365,37 +1520,6 @@ top-level bindings from ENV and return the resulting expression." (($ _ 'make-prompt-tag (or () ((? constant-expression?)))) #t) (_ #f))) - (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)))) - (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)))) (let ((tag (for-value tag)) (body (for-tail body)))