(($ <conditional> _ test consequent alternate)
(and (singly-valued-expression? consequent)
(singly-valued-expression? alternate)))
- (($ <dynwind> _ winder body unwinder)
- (singly-valued-expression? body))
(else #f)))
(define (truncate-values x)
(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.
;;
($ <toplevel-ref>)
($ <module-ref>)
($ <primitive-ref>)
- ($ <dynref>)
($ <lexical-set>) ; FIXME: these set! expressions
($ <toplevel-set>) ; could return zero values in
($ <toplevel-define>) ; the future
($ <module-set>) ;
- ($ <dynset>) ;
($ <primcall> src (? singly-valued-primitive?)))
(and (<= nmin 1) (or (not nmax) (>= nmax 1))
(make-call src (make-lambda #f '() consumer) (list exp))))
(($ <prompt>) #f)
(($ <abort>) #f)
- ;; Bail on dynwinds, as that would cause the consumer to run in
- ;; the wrong dynamic context.
- (($ <dynwind>) #f)
-
;; Propagate to tail positions.
(($ <let> src names gensyms vals body)
(let ((body (loop body)))
(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)))))))
(names ... rest)
(gensyms ... rest-sym)
(vals ... ($ <primcall> _ 'list rest-args))
- ($ <primcall> asrc (or 'apply '@apply)
+ ($ <primcall> asrc 'apply
(proc args ...
($ <lexical-ref> _
(? (cut eq? <> rest))
(else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynwind> src winder body unwinder)
- (make-dynwind src
- (for-value winder)
- (for-tail body)
- (for-value unwinder)))
- (($ <dynlet> src fluids vals body)
- (make-dynlet src (map for-value fluids) (map for-value vals)
- (for-tail body)))
- (($ <dynref> src fluid)
- (make-dynref src (for-value fluid)))
- (($ <dynset> src fluid exp)
- (make-dynset src (for-value fluid) (for-value exp)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
exp)
(($ <toplevel-ref>)
(simplify-conditional
(make-conditional src c (for-tail subsequent)
(for-tail alternate))))))
- (($ <primcall> src '@call-with-values
+ (($ <primcall> src 'call-with-values
(producer
($ <lambda> _ _
(and consumer
(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
+ 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 '())))))))))
+
+ (($ <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-call src w '())
+ (make-primcall src 'push-fluid (list f v))
(make-begin0 src
- (make-dynwind src w
- (make-call src thunk '())
- u)
- (make-call src u '()))))))))
+ (make-call src thunk '())
+ (make-primcall src 'pop-fluid '()))))))))
(($ <primcall> src 'values exps)
(cond
(for-tail (list->seq src (append (cdr vals) (list (car vals)))))
(make-primcall src 'values vals))))))
- (($ <primcall> src (or 'apply '@apply) (proc args ... tail))
+ (($ <primcall> 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,
(for-tail (make-call src proc (append args args*)))))
(($ <primcall> _ 'cons
((and head (? copyable?)) (and tail (? copyable?))))
- (for-tail (make-primcall src '@apply
+ (for-tail (make-primcall src 'apply
(cons proc
(append args (list head tail))))))
(($ <primcall> _ 'list
(if speculative?
(lp (for-value tail) #f)
(let ((args (append (map for-value args) (list tail*))))
- (make-primcall src '@apply
+ (make-primcall src 'apply
(cons (for-value proc) args))))))))
(($ <primcall> src (? constructor-primitive? name) args)
((name . args)
(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)))))))
+
(($ <primcall> src (? accessor-primitive? name) args)
(match (cons name (map for-value args))
;; FIXME: these for-tail recursions could take place outside
(define (lift-applied-lambda body gensyms)
(and (not opt) rest (not kw)
(match body
- (($ <primcall> _ '@apply
+ (($ <primcall> _ 'apply
(($ <lambda> _ _ (and lcase ($ <lambda-case>)))
($ <lexical-ref> _ _ sym)
...))
HCoop / bpt / guile.git / blobdiff