prompt handlers are always inline

* libguile/control.h (SCM_F_PROMPT_INLINE, SCM_PROMPT_INLINE_P): Remove;
  prompts always have "inline" handlers now.
* libguile/control.c (scm_c_make_prompt): Remove inline_handler_p arg.

* libguile/vm-i-system.c (prompt):
* module/language/assembly/decompile-bytecode.scm (decode-load-program):
* module/language/assembly/compile-bytecode.scm (write-bytecode):
 Adapt to prompt changes.

* module/language/glil.scm (make-glil-prompt, glil-prompt-inline?):
  Remove inline? flag.
  (parse-glil, unparse-glil):
* module/language/glil/compile-assembly.scm (glil->assembly): Adapt to
  <glil-prompt> change.

* module/language/tree-il/compile-glil.scm (flatten): Require the
  handler of a <prompt> to be a lambda-case.

* module/language/tree-il/primitives.scm (*primitive-expand-table*):
  Ensure that the handler of a <prompt> is a lambda-case.

* module/language/tree-il/inline.scm (inline!): Simplify a degenerate
  case: (lambda args (apply (lambda ...) args)) => (lambda ...).

libguile/control.c

@@ -49,16 +49,13 @@ SCM_DEFINE (scm_atprompt, "@prompt", 4, 0, 0,
 #undef FUNC_NAME
 
 SCM
-scm_c_make_prompt (SCM vm, SCM k, SCM handler, scm_t_uint8 inline_handler_p,
+scm_c_make_prompt (SCM vm, SCM k, SCM handler, scm_t_uint8 escape_only_p)
-                   scm_t_uint8 escape_only_p)
 {
   scm_t_bits tag;
   SCM ret;
   struct scm_prompt_registers *regs;
 
   tag = scm_tc7_prompt;
-  if (inline_handler_p)
-    tag |= SCM_F_PROMPT_INLINE;
   if (escape_only_p)
     tag |= SCM_F_PROMPT_ESCAPE;
   ret = scm_words (tag, 5);

libguile/control.h

@@ -20,14 +20,12 @@
 #define SCM_CONTROL_H
 
 
-#define SCM_F_PROMPT_INLINE 0x1
+#define SCM_F_PROMPT_ESCAPE 0x1
-#define SCM_F_PROMPT_ESCAPE 0x2
 
 #define SCM_PROMPT_P(x)		(!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_prompt)
 #define SCM_PROMPT_FLAGS(x)	(SCM_CELL_WORD ((x), 0) >> 8)
-#define SCM_PROMPT_INLINE_P(x)	(SCM_PROMPT_FLAGS (x) & SCM_F_PROMPT_INLINE)
 #define SCM_PROMPT_ESCAPE_P(x)	(SCM_PROMPT_FLAGS (x) & SCM_F_PROMPT_ESCAPE)
-#define SCM_PROMPT_TAG(x)	(SCM_CELL_OBJECT ((x), 1)
+#define SCM_PROMPT_TAG(x)	(SCM_CELL_OBJECT ((x), 1))
 #define SCM_PROMPT_REGISTERS(x)	((struct scm_prompt_registers*)SCM_CELL_WORD ((x), 2))
 #define SCM_PROMPT_DYNENV(x)	(SCM_CELL_OBJECT ((x), 3))
 #define SCM_PROMPT_HANDLER(x)	(SCM_CELL_OBJECT ((x), 4))
@@ -44,7 +42,6 @@ struct scm_prompt_registers
 
 
 SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, SCM handler,
-                                    scm_t_uint8 inline_handler_p,
                                     scm_t_uint8 escape_only_p);
 
 

libguile/vm-i-system.c

@@ -1450,13 +1450,12 @@ VM_DEFINE_INSTRUCTION (82, make_symbol, "make-symbol", 0, 1, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 2, 0)
+VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 0)
 {
   scm_t_int32 offset;
-  scm_t_uint8 inline_handler_p, escape_only_p;
+  scm_t_uint8 escape_only_p;
   SCM k, handler, prompt;
 
-  inline_handler_p = FETCH ();
   escape_only_p = FETCH ();
   FETCH_OFFSET (offset);
   POP (handler);
@@ -1466,14 +1465,13 @@ VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 2, 0)
   /* Push the prompt onto the dynamic stack. The setjmp itself has to be local
      to this procedure. */
   /* FIXME: do more error checking */
-  prompt = scm_c_make_prompt (vm, k, handler, inline_handler_p, escape_only_p);
+  prompt = scm_c_make_prompt (vm, k, handler, escape_only_p);
   scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
   if (SCM_PROMPT_SETJMP (prompt))
     {
       /* The prompt exited nonlocally. Cache the regs back from the vp, and go
-         to the handler or post-handler label. (The meaning of the label differs
+         to the handler.
-         depending on whether the prompt's handler is rendered inline or not.)
+      */
-         */
       CACHE_REGISTER (); /* Really we only need SP. FP and IP should be
                             unmodified. */
       ip += offset;

module/language/assembly/compile-bytecode.scm

@@ -119,8 +119,7 @@
         ((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
         ((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
         ((mv-call ,n ,l) (write-byte n) (write-break l))
-        ((prompt ,inline-handler? ,escape-only? ,l)
+        ((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
-         (write-byte inline-handler?) (write-byte escape-only?) (write-break l))
         (else
          (cond
           ((< (instruction-length inst) 0)

module/language/assembly/decompile-bytecode.scm

@@ -90,8 +90,8 @@
                   (lp (cons `(,br ,hi ,lo ,(ensure-label rel1 rel2 rel3)) out)))
                  ((mv-call ,n ,rel1 ,rel2 ,rel3)
                   (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2 rel3)) out)))
-                 ((prompt ,n0 ,n1 ,rel1 ,rel2 ,rel3)
+                 ((prompt ,n0 ,rel1 ,rel2 ,rel3)
-                  (lp (cons `(prompt ,n0 ,n1 ,(ensure-label rel1 rel2 rel3)) out)))
+                  (lp (cons `(prompt ,n0 ,(ensure-label rel1 rel2 rel3)) out)))
                  (else 
                   (lp (cons exp out))))))))))
 

module/language/glil.scm

@@ -75,8 +75,7 @@
    <glil-mv-call> make-glil-mv-call glil-mv-call?
    glil-mv-call-nargs glil-mv-call-ra
 
-   <glil-prompt> make-glil-prompt glil-prompt?
+   <glil-prompt> make-glil-prompt glil-prompt? glil-prompt-label glil-prompt-escape-only?
-   glil-prompt-label glil-prompt-inline? glil-prompt-escape-only?
 
    parse-glil unparse-glil))
 
@@ -105,7 +104,7 @@
   (<glil-branch> inst label)
   (<glil-call> inst nargs)
   (<glil-mv-call> nargs ra)
-  (<glil-prompt> label inline? escape-only?))
+  (<glil-prompt> label escape-only?))
 
 
 
@@ -133,8 +132,8 @@
     ((branch ,inst ,label) (make-glil-branch inst label))
     ((call ,inst ,nargs) (make-glil-call inst nargs))
     ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
-    ((prompt ,label ,inline? ,escape-only?)
+    ((prompt ,label ,escape-only?)
-     (make-glil-prompt label inline? escape-only?))
+     (make-glil-prompt label escape-only?))
     (else (error "invalid glil" x))))
 
 (define (unparse-glil glil)
@@ -167,5 +166,5 @@
     ((<glil-branch> inst label) `(branch ,inst ,label))
     ((<glil-call> inst nargs) `(call ,inst ,nargs))
     ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))
-    ((<glil-prompt> label inline? escape-only?)
+    ((<glil-prompt> label escape-only?)
-     `(prompt ,label ,inline? escape-only?))))
+     `(prompt ,label escape-only?))))

module/language/glil/compile-assembly.scm

@@ -514,10 +514,8 @@
     ((<glil-mv-call> nargs ra)
      (emit-code `((mv-call ,nargs ,ra))))
 
-    ((<glil-prompt> label inline? escape-only?)
+    ((<glil-prompt> label escape-only?)
-     (emit-code `((prompt ,(if inline? 1 0)
+     (emit-code `((prompt ,(if escape-only? 1 0) ,label))))))
-                          ,(if escape-only? 1 0)
-                          ,label))))))
 
 (define (dump-object x addr)
   (define (too-long x)

module/language/tree-il/compile-glil.scm

@@ -1041,14 +1041,10 @@
       ((<prompt> src tag body handler)
        (let ((H (make-label))
              (POST (make-label))
-             (inline? (lambda-case? handler))
              (escape-only? (hashq-ref allocation x)))
          ;; First, set up the prompt.
          (comp-push tag)
-         (if inline?
+         (emit-code src (make-glil-prompt H escape-only?))
-             (emit-code #f (make-glil-const #f)) ;; push #f as handler
-             (comp-push handler))
-         (emit-code src (make-glil-prompt H inline? escape-only?))
 
          ;; Then we compile the body, with its normal return path, unwinding
          ;; before proceeding.
@@ -1087,51 +1083,30 @@
             (emit-code #f (make-glil-call 'unwind 0))
             (emit-branch #f 'br (or RA POST))))
          
-         ;; Now the handler.
          (emit-label H)
-         (cond
+         ;; Now the handler. The stack is now made up of the continuation, and
-          (inline?
+         ;; then the args to the continuation (pushed separately), and then the
-           ;; The inlined handler. The stack is now made up of the continuation,
+         ;; number of args, including the continuation.
-           ;; and then the args to the continuation (pushed separately), and
+         (record-case handler
-           ;; then the number of args, including the continuation.
+           ((<lambda-case> req opt kw rest vars body alternate)
-           (record-case handler
+            (if (or opt kw alternate)
-             ((<lambda-case> req opt kw rest vars body alternate)
+                (error "unexpected lambda-case in prompt" x))
-              (if (or opt kw alternate)
+            (emit-code src (make-glil-mv-bind
-                  (error "unexpected lambda-case in prompt" x))
+                            (vars->bind-list
-              (emit-code src (make-glil-mv-bind
+                             (append req (if rest (list rest) '()))
-                              (vars->bind-list
+                             vars allocation self)
-                               (append req (if rest (list rest) '()))
+                            (and rest #t)))
-                               vars allocation self)
+            (for-each (lambda (v)
-                              (and rest #t)))
+                        (pmatch (hashq-ref (hashq-ref allocation v) self)
-              (for-each (lambda (v)
+                          ((#t #f . ,n)
-                          (pmatch (hashq-ref (hashq-ref allocation v) self)
+                           (emit-code src (make-glil-lexical #t #f 'set n)))
-                            ((#t #f . ,n)
+                          ((#t #t . ,n)
-                             (emit-code src (make-glil-lexical #t #f 'set n)))
+                           (emit-code src (make-glil-lexical #t #t 'box n)))
-                            ((#t #t . ,n)
+                          (,loc (error "badness" x loc))))
-                             (emit-code src (make-glil-lexical #t #t 'box n)))
+                      (reverse vars))
-                            (,loc (error "badness" x loc))))
+            (comp-tail body)
-                        (reverse vars))
+            (emit-code #f (make-glil-unbind))))
-              (comp-tail body)
-              (emit-code #f (make-glil-unbind)))))
-          (else
-           ;; The handler was on the heap, so here we're just processing its
-           ;; return values.
-           (case context
-             ((tail)
-              (emit-code #f (make-glil-call 'return/nvalues 1)))
-             ((push)
-              ;; truncate to one value, leave on stack
-              (emit-code #f (make-glil-mv-bind '(handler-ret) #f))
-              (emit-code #f (make-glil-unbind)))
-             ((vals)
-              (emit-branch #f 'br MVRA))
-             ((drop)
-              ;; truncate to 0 vals
-              (emit-code #f (make-glil-mv-bind '() #f))
-              (emit-code #f (make-glil-unbind))
-              (if RA (emit-branch #f 'br RA))))))
 
-         ;; The POST label, if necessary.
          (if (or (eq? context 'push)
                  (and (eq? context 'drop) (not RA)))
              (emit-label POST))))

module/language/tree-il/inline.scm

@@ -110,15 +110,29 @@
       ((<fix> vars body)
        (if (null? vars) body x))
        
-      ((<prompt> src tag body handler)
+      ((<lambda-case> req opt rest kw vars body alternate)
-       ;; If the handler is a simple lambda, inline it.
+       (let ()
-       (if (and (lambda? handler)
+         (define (args-compatible? args vars)
-                (record-case (lambda-body handler)
+           (let lp ((args args) (vars vars))
-                  ((<lambda-case> req opt kw rest alternate)
+             (cond
-                   (and (pair? req) (not opt) (not kw) (not alternate)))
+              ((null? args) (null? vars))
-                  (else #f)))
+              ((null? vars) #f)
-           (make-prompt src tag body (lambda-body handler))
+              ((and (lexical-ref? (car args))
-           x))
+                    (eq? (lexical-ref-gensym (car args)) (car 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)))
   (post-order! inline1 x))

module/language/tree-il/primitives.scm

@@ -434,19 +434,21 @@
               ((src fluid exp) (make-dynset src fluid exp))
               (else #f)))
 
-(hashq-set! *primitive-expand-table*
-            'prompt
-            (case-lambda
-              ((src tag thunk handler)
-               (make-prompt src tag (make-application #f thunk '())
-                            handler #f))
-              (else #f)))
 (hashq-set! *primitive-expand-table*
             '@prompt
             (case-lambda
-              ((src tag thunk handler)
+              ((src tag exp handler)
-               (make-prompt src tag (make-application #f thunk '())
+               (let ((args-sym (gensym)))
-                            handler))
+                 (make-prompt
+                  src tag exp
+                  ;; 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)))
 
 (hashq-set! *primitive-expand-table*