mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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 ...).
This commit is contained in:
Andy Wingo
parent
f5b1f76af4
commit
ea6b18e82f
10 changed files with 78 additions and 99 deletions
|
|
@ -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_t_uint8 escape_only_p)
|
||||
scm_c_make_prompt (SCM vm, SCM k, SCM handler, 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);
|
||||
|
|
|
|||
|
|
@ -20,14 +20,12 @@
|
|||
#define SCM_CONTROL_H
|
||||
|
||||
|
||||
#define SCM_F_PROMPT_INLINE 0x1
|
||||
#define SCM_F_PROMPT_ESCAPE 0x2
|
||||
#define SCM_F_PROMPT_ESCAPE 0x1
|
||||
|
||||
#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);
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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,13 +1465,12 @@ 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
|
||||
depending on whether the prompt's handler is rendered inline or not.)
|
||||
to the handler.
|
||||
*/
|
||||
CACHE_REGISTER (); /* Really we only need SP. FP and IP should be
|
||||
unmodified. */
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(write-byte inline-handler?) (write-byte escape-only?) (write-break l))
|
||||
((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
|
||||
(else
|
||||
(cond
|
||||
((< (instruction-length inst) 0)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(lp (cons `(prompt ,n0 ,n1 ,(ensure-label rel1 rel2 rel3)) out)))
|
||||
((prompt ,n0 ,rel1 ,rel2 ,rel3)
|
||||
(lp (cons `(prompt ,n0 ,(ensure-label rel1 rel2 rel3)) out)))
|
||||
(else
|
||||
(lp (cons exp out))))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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-label glil-prompt-inline? glil-prompt-escape-only?
|
||||
<glil-prompt> make-glil-prompt glil-prompt? glil-prompt-label 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?)
|
||||
(make-glil-prompt label inline? escape-only?))
|
||||
((prompt ,label ,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?)
|
||||
`(prompt ,label ,inline? escape-only?))))
|
||||
((<glil-prompt> label escape-only?)
|
||||
`(prompt ,label escape-only?))))
|
||||
|
|
|
|||
|
|
@ -514,10 +514,8 @@
|
|||
((<glil-mv-call> nargs ra)
|
||||
(emit-code `((mv-call ,nargs ,ra))))
|
||||
|
||||
((<glil-prompt> label inline? escape-only?)
|
||||
(emit-code `((prompt ,(if inline? 1 0)
|
||||
,(if escape-only? 1 0)
|
||||
,label))))))
|
||||
((<glil-prompt> label escape-only?)
|
||||
(emit-code `((prompt ,(if escape-only? 1 0) ,label))))))
|
||||
|
||||
(define (dump-object x addr)
|
||||
(define (too-long x)
|
||||
|
|
|
|||
|
|
@ -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 #f (make-glil-const #f)) ;; push #f as handler
|
||||
(comp-push handler))
|
||||
(emit-code src (make-glil-prompt H inline? escape-only?))
|
||||
(emit-code src (make-glil-prompt H escape-only?))
|
||||
|
||||
;; Then we compile the body, with its normal return path, unwinding
|
||||
;; before proceeding.
|
||||
|
|
@ -1087,13 +1083,10 @@
|
|||
(emit-code #f (make-glil-call 'unwind 0))
|
||||
(emit-branch #f 'br (or RA POST))))
|
||||
|
||||
;; Now the handler.
|
||||
(emit-label H)
|
||||
(cond
|
||||
(inline?
|
||||
;; The inlined handler. The stack is now made up of the continuation,
|
||||
;; and then the args to the continuation (pushed separately), and
|
||||
;; then the number of args, including the continuation.
|
||||
;; Now the handler. The stack is now made up of the continuation, and
|
||||
;; then the args to the continuation (pushed separately), and then the
|
||||
;; number of args, including the continuation.
|
||||
(record-case handler
|
||||
((<lambda-case> req opt kw rest vars body alternate)
|
||||
(if (or opt kw alternate)
|
||||
|
|
@ -1112,26 +1105,8 @@
|
|||
(,loc (error "badness" x loc))))
|
||||
(reverse vars))
|
||||
(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))))))
|
||||
(emit-code #f (make-glil-unbind))))
|
||||
|
||||
;; The POST label, if necessary.
|
||||
(if (or (eq? context 'push)
|
||||
(and (eq? context 'drop) (not RA)))
|
||||
(emit-label POST))))
|
||||
|
|
|
|||
|
|
@ -110,15 +110,29 @@
|
|||
((<fix> vars body)
|
||||
(if (null? vars) body x))
|
||||
|
||||
((<prompt> src tag body handler)
|
||||
;; If the handler is a simple lambda, inline it.
|
||||
(if (and (lambda? handler)
|
||||
(record-case (lambda-body handler)
|
||||
((<lambda-case> req opt kw rest alternate)
|
||||
(and (pair? req) (not opt) (not kw) (not alternate)))
|
||||
(else #f)))
|
||||
(make-prompt src tag body (lambda-body handler))
|
||||
x))
|
||||
((<lambda-case> req opt rest kw vars body alternate)
|
||||
(let ()
|
||||
(define (args-compatible? args vars)
|
||||
(let lp ((args args) (vars vars))
|
||||
(cond
|
||||
((null? args) (null? vars))
|
||||
((null? vars) #f)
|
||||
((and (lexical-ref? (car args))
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(make-prompt src tag (make-application #f thunk '())
|
||||
handler))
|
||||
((src tag exp handler)
|
||||
(let ((args-sym (gensym)))
|
||||
(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*
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue