mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Prompt-related refactor in compile-cps

Browse source 
* module/language/tree-il/compile-cps.scm (fix-prompts): New procedure.
  Eta-expand prompts before compiling to ensure that they have inline
  handlers.
This commit is contained in:
Andy Wingo 2014-03-28 17:51:37 +01:00
parent cd72929e71
commit ef58442a05
1 changed files with 45 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

81
module/language/tree-il/compile-cps.scm
View file

@ -464,41 +464,6 @@
($continue kbody (tree-il-src body)
($prompt #f tag khargs))))))))))))))
;; Eta-convert prompts without inline handlers.
(($ <prompt> src escape-only? tag body handler)
(let ((h (gensym "h "))
(args (gensym "args ")))
(convert
(make-let
src (list 'h) (list h) (list handler)
(make-seq
src
(make-conditional
src
(make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
(make-void src)
(make-primcall
src 'scm-error
(list
(make-const #f 'wrong-type-arg)
(make-const #f "call-with-prompt")
(make-const #f "Wrong type (expecting procedure): ~S")
(make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
(make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
(make-prompt
src escape-only? tag body
(make-lambda
src '()
(make-lambda-case
src '() #f 'args #f '() (list args)
(make-primcall
src 'apply
(list (make-lexical-ref #f 'h h)
(make-lexical-ref #f 'args args)))
#f)))))
k
subst)))
(($ <abort> src tag args ($ <const> _ ()))
(convert-args (cons tag args)
(lambda (args*)
@ -663,8 +628,52 @@ indicates that the replacement variable is in a box."
(optimize x e opts))
(define (fix-prompts exp)
(post-order
(lambda (exp)
(match exp
(($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
exp)
;; Eta-convert prompts without inline handlers.
(($ <prompt> src escape-only? tag body handler)
(let ((h (gensym "h "))
(args (gensym "args ")))
(make-let
src (list 'h) (list h) (list handler)
(make-seq
src
(make-conditional
src
(make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
(make-void src)
(make-primcall
src 'scm-error
(list
(make-const #f 'wrong-type-arg)
(make-const #f "call-with-prompt")
(make-const #f "Wrong type (expecting procedure): ~S")
(make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
(make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
(make-prompt
src escape-only? tag body
(make-lambda
src '()
(make-lambda-case
src '() #f 'args #f '() (list args)
(make-primcall
src 'apply
(list (make-lexical-ref #f 'h h)
(make-lexical-ref #f 'args args)))
#f)))))))
(_ exp)))
exp))
(define (compile-cps exp env opts)
(values (cps-convert/thunk (optimize-tree-il exp env opts))
(values (cps-convert/thunk
(fix-prompts (optimize-tree-il exp env opts)))
env
env))