summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il/primitives.scm26
1 files changed, 21 insertions, 5 deletions
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index b78339618..f5320db38 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -63,7 +63,7 @@
fluid-ref fluid-set!
- @prompt prompt
+ @prompt prompt abort
struct? struct-vtable make-struct struct-ref struct-set!
@@ -454,13 +454,29 @@
(else #f)))
(hashq-set! *primitive-expand-table*
- 'control
+ 'prompt
(case-lambda
- ((src tag . args)
- (make-abort src tag args))
+ ((src tag thunk handler)
+ ;; Sigh. Until the inliner does its job, manually inline
+ ;; (let ((h (lambda ...))) (prompt k x h))
+ (cond
+ ((lambda? handler)
+ (let ((args-sym (gensym)))
+ (make-prompt
+ src tag (make-application #f thunk '())
+ ;; If handler itself is a lambda, the inliner can do some
+ ;; trickery here.
+ (make-lambda-case
+ (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+ (make-application #f (make-primitive-ref #f 'apply)
+ (list handler
+ (make-lexical-ref #f 'args args-sym)))
+ #f))))
+ (else #f)))
(else #f)))
+
(hashq-set! *primitive-expand-table*
- '@control
+ 'abort
(case-lambda
((src tag . args)
(make-abort src tag args))