(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.
;;
(make-let-values src exp
(make-lambda-case src2 req opt rest kw
inits gensyms body #f)))))
- (($ <dynlet> src fluids vals body)
- (let ((body (loop body)))
- (and body
- (make-dynlet src fluids vals body))))
(($ <seq> src head tail)
(let ((tail (loop tail)))
(and tail (make-seq src head tail)))))))
(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))))))
+ (if (var-set? (operand-var op))
+ (values #f #f)
+ (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))))
(else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynlet> src fluids vals body)
- (make-dynlet src (map for-value fluids) (map for-value vals)
- (for-tail body)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
exp)
(($ <toplevel-ref>)
(for-tail (make-let-values src (make-call src producer '())
consumer)))
(($ <primcall> src 'dynamic-wind (w thunk u))
- (define (with-temporaries exps refcount k)
- (let* ((pairs (map (match-lambda
- ((and exp (? constant-expression?))
- (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))))
(for-tail
(with-temporaries
- (list w u) 2
+ src (list w u) 2 constant-expression?
(match-lambda
((w u)
(make-seq
(make-primcall src 'unwind '())
(make-call src u '())))))))))
+ (($ <primcall> 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 '()))))))))
+
(($ <primcall> src 'values exps)
(cond
((null? exps)
(make-primcall src name args))))))
(($ <primcall> src 'thunk? (proc))
- (match (for-value proc)
- (($ <lambda> _ _ ($ <lambda-case> _ req))
- (for-tail (make-const src (null? req))))
- (proc
- (case ctx
- ((effect) (make-void src))
- (else (make-primcall src 'thunk? (list proc)))))))
+ (case ctx
+ ((effect)
+ (for-tail (make-seq src proc (make-void src))))
+ (else
+ (match (for-value proc)
+ (($ <lambda> _ _ ($ <lambda-case> _ req))
+ (for-tail (make-const src (null? req))))
+ (proc
+ (match (find-definition proc 2)
+ (($ <lambda> _ _ ($ <lambda-case> _ req))
+ (for-tail (make-const src (null? req))))
+ (_
+ (make-primcall src 'thunk? (list proc)))))))))
- (($ <primcall> src (? accessor-primitive? name) args)
+ (($ <primcall> src name args)
(match (cons name (map for-value args))
;; FIXME: these for-tail recursions could take place outside
;; an effort counter.
(for-tail (make-seq src k (make-const #f #f))))
(else
(make-primcall src name (list k (make-const #f elts))))))))
- ((name . args)
- (fold-constants src name args ctx))))
-
- (($ <primcall> src (? equality-primitive? name) (a b))
- (let ((val-a (for-value a))
- (val-b (for-value b)))
- (log 'equality-primitive name val-a val-b)
- (cond ((and (lexical-ref? val-a) (lexical-ref? val-b)
- (eq? (lexical-ref-gensym val-a)
- (lexical-ref-gensym val-b)))
- (for-tail (make-const #f #t)))
- (else
- (fold-constants src name (list val-a val-b) ctx)))))
-
- (($ <primcall> src (? effect-free-primitive? name) args)
- (fold-constants src name (map for-value args) ctx))
+ (((? equality-primitive?)
+ ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym))
+ (for-tail (make-const #f #t)))
- (($ <primcall> src name args)
- (make-primcall src name (map for-value args)))
+ (((? effect-free-primitive?) . args)
+ (fold-constants src name args ctx))
+
+ ((name . args)
+ (make-primcall src name args))))
(($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
;; todo: handle the more complex cases
(let* ((nargs (length orig-args))
(nreq (length req))
- (nopt (if opt (length opt) 0))
+ (opt (or opt '()))
+ (rest (if rest (list rest) '()))
+ (nopt (length opt))
(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))
+ (let ((req-vals (list-head orig-args nreq))
+ (opt-vals (let lp ((args (drop orig-args nreq))
+ (inits inits)
+ (out '()))
+ (match inits
+ (() (reverse out))
+ ((init . inits)
+ (match args
+ (()
+ (lp '() inits (cons init out)))
+ ((arg . args)
+ (lp args inits (cons arg out))))))))
+ (rest-vals (cond
+ ((> nargs (+ nreq nopt))
+ (list (make-primcall
+ #f 'list
+ (drop orig-args (+ nreq nopt)))))
+ (rest (list (make-const #f '())))
+ (else '()))))
+ (if (>= nargs (+ nreq nopt))
+ (make-let src
+ (append req opt rest)
+ gensyms
+ (append req-vals opt-vals rest-vals)
+ body)
+ ;; The required argument values are in the scope
+ ;; of the optional argument initializers.
+ (make-let src
+ (append req rest)
+ (append (list-head gensyms nreq)
+ (last-pair gensyms))
+ (append req-vals rest-vals)
+ (make-let src
+ opt
+ (list-head (drop gensyms nreq) nopt)
+ opt-vals
+ body)))))
(cond
((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
(seq-head head)
head)
tail))))
- (($ <prompt> src tag body handler)
+ (($ <prompt> src escape-only? tag body handler)
(define (make-prompt-tag? x)
(match x
(($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
(_ #f)))
(let ((tag (for-value tag))
- (body (for-tail body)))
+ (body (if escape-only? (for-tail body) (for-value body))))
(cond
((find-definition tag 1)
(lambda (val op)
;; for this <prompt>, so we can elide the <prompt>
;; 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)))))
+ (for-tail (if escape-only? body (make-call src body '())))))
(else
- (make-prompt src tag body (for-value handler))))))
+ (let ((handler (for-value handler)))
+ (define (escape-only-handler? handler)
+ (match handler
+ (($ <lambda> _ _
+ ($ <lambda-case> _ (_ . _) _ _ _ _ (k . _) body #f))
+ (not (tree-il-any
+ (match-lambda
+ (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t)
+ (_ #f))
+ body)))
+ (else #f)))
+ (if (and (not escape-only?) (escape-only-handler? handler))
+ ;; Prompt transitioning to escape-only; transition body
+ ;; to be an expression.
+ (for-tail
+ (make-prompt src #t tag (make-call #f body '()) handler))
+ (make-prompt src escape-only? tag body handler)))))))
+
(($ <abort> src tag args tail)
(make-abort src (for-value tag) (map for-value args)
(for-value tail))))))
HCoop / bpt / guile.git / blobdiff