mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 12:20:26 +02:00
Code Activity

ensure non-escape-only prompts have a thunk application as their body

Browse source 
* module/language/tree-il/inline.scm (inline!): Fix indenting for
  lambda-case. In an amusing turn of events, use the inliner to
  de-inline prompt bodies, if the prompt is not escape-only.
This commit is contained in:
Andy Wingo 2010-02-24 00:32:07 +01:00
parent cee1d22c3c
commit ac644098bf
1 changed files with 47 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

66
module/language/tree-il/inline.scm
View file

@ -111,28 +111,54 @@
(if (null? vars) body x)) (if (null? vars) body x))
((<lambda-case> req opt rest kw vars body alternate) ((<lambda-case> req opt rest kw vars body alternate)
(let () (define (args-compatible? args vars)
(define (args-compatible? args vars) (let lp ((args args) (vars vars))
(let lp ((args args) (vars vars)) (cond
(cond ((null? args) (null? vars))
((null? args) (null? vars)) ((null? vars) #f)
((null? vars) #f) ((and (lexical-ref? (car args))
((and (lexical-ref? (car args)) (eq? (lexical-ref-gensym (car args)) (car vars)))
(eq? (lexical-ref-gensym (car args)) (car vars))) (lp (cdr args) (cdr vars)))
(lp (cdr args) (cdr vars))) (else #f))))
(and (not opt) (not kw) (not alternate)
(record-case body
((<application> proc args)
;; (lambda args (apply (lambda ...) args)) => (lambda ...)
(and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@apply)
(pair? args)
(lambda? (car args))
(args-compatible? (cdr args) vars)
(lambda-body (car args))))
(else #f)))) (else #f))))
(and (not opt) (not kw) (not alternate) ;; Actually the opposite of inlining -- if the prompt cannot be proven to
(record-case body ;; be escape-only, ensure that its body is the application of a thunk.
((<application> proc args) ((<prompt> src tag body handler)
;; (lambda args (apply (lambda ...) args)) => (lambda ...) (define (escape-only? handler)
(and (primitive-ref? proc) (and (pair? (lambda-case-req handler))
(eq? (primitive-ref-name proc) '@apply) (let ((cont (car (lambda-case-vars handler))))
(pair? args) (tree-il-fold (lambda (leaf escape-only?)
(lambda? (car args)) (and escape-only?
(args-compatible? (cdr args) vars) (not
(lambda-body (car args)))) (and (lexical-ref? leaf)
(else #f))))) (eq? (lexical-ref-gensym leaf) cont)))))
(lambda (down escape-only?) escape-only?)
(lambda (up escape-only?) escape-only?)
#t
(lambda-case-body handler)))))
(define (make-thunk body)
(make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f)))
(if (or (and (application? body)
(lambda? (application-proc body))
(null? (application-args body)))
(escape-only? handler))
x
(make-prompt src tag
(make-application #f (make-thunk body) '())
handler)))
(else #f))) (else #f)))
(post-order! inline1 x)) (post-order! inline1 x))