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

call-with-prompt always compiles to CPS $prompt

Browse source 
* module/language/tree-il/compile-cps.scm (convert): For prompts without
  inline handlers, eta-convert the handler.
This commit is contained in:
Andy Wingo 2013-10-14 12:20:58 +02:00
parent 545d776ef6
commit b7f10defe6
1 changed files with 32 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -58,21 +58,7 @@
#:use-module (language cps primitives) #:use-module (language cps primitives)
#:use-module (language tree-il analyze) #:use-module (language tree-il analyze)
#:use-module (language tree-il optimize) #:use-module (language tree-il optimize)
#:use-module ((language tree-il) #:use-module ((language tree-il) #:hide (let-gensyms))
#:select
(<void>
<const> <primitive-ref> <lexical-ref> <lexical-set>
<module-ref> <module-set>
<toplevel-ref> <toplevel-set> <toplevel-define>
<conditional>
<call> <primcall>
<seq>
<lambda> <lambda-case>
<let> <letrec> <fix> <let-values>
<prompt> <abort>
make-conditional make-const make-primcall
tree-il-src
tree-il-fold))
#:export (compile-cps)) #:export (compile-cps))
;;; Guile's semantics are that a toplevel lambda captures a reference on ;;; Guile's semantics are that a toplevel lambda captures a reference on
@ -426,10 +412,37 @@
;; Eta-convert prompts without inline handlers. ;; Eta-convert prompts without inline handlers.
(($ <prompt> src escape-only? tag body handler) (($ <prompt> src escape-only? tag body handler)
(convert-args (list tag body handler) (let-gensyms (h args)
(lambda (args) (convert
(build-cps-term (make-let
($continue k ($primcall 'call-with-prompt args)))))) 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 tail) (($ <abort> src tag args tail)
(convert-args (append (list tag) args (list tail)) (convert-args (append (list tag) args (list tail))