mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

dynamic-wind in terms of wind and unwind; remove <dynwind>, @dynamic-wind

Browse source 
* doc/ref/compiler.texi: Remove mention of <dynwind>.
* libguile/eval.c (eval): Remove SCM_M_DYNWIND case.
* libguile/expand.c: Remove scm_sym_at_dynamic_wind.
* libguile/memoize.c (do_wind, do_unwind): A couple of hacky subrs.  If
  we see a wind or unwind primcall, we expand to a call of a quoted subr
  value.  It works and removes a kind of memoized value from the
  interpreter.  For the compiler,primcalls to wind and unwind are
  handled specially.
  (MAKMEMO_DYNWIND): Remove.
  (scm_tc16_memoizer): Remove.  Yay!
  (memoize): Remove speculative lookup for toplevels to see if they are
  memoizers: there are no more memoizers.  Memoize calls to the wind and
  unwind primitives.
  (m_dynamic_wind): Remove.
  (unmemoize): Remove dynwind case.
  (scm_init_memoize): Add wind and unwind local definitions.

* module/ice-9/boot-9.scm (dynamic-wind): Reimplement in terms of "wind"
  and "unwind" primitives.  These primitives are not exposed to other
  modules.

* module/ice-9/eval.scm (primitive-eval): Remove dynwind case.
* module/language/scheme/decompile-tree-il.scm (do-decompile):
  (choose-output-names): Remove dynwind cases.

* module/language/tree-il.scm: Remove <dynwind>.  Yaaay!

* module/language/tree-il/analyze.scm (analyze-lexicals): Remove dynwind
  cases.

* module/language/tree-il/compile-glil.scm (*primcall-ops*): Add wind
  and unwind.
  (flatten-lambda-case): Remove dynwind case.  Yay!

* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/debug.scm (verify-tree-il):
* module/language/tree-il/effects.scm (make-effects-analyzer):
* module/language/tree-il/peval.scm (singly-valued-expression?, peval):
  Remove <dywind> cases.  Inline primcalls to dynamic-wind.  Add
  constant folding for thunk?.

* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
  Remove @dynamic-wind, and add procedure? and thunk?.
  (*effect+exception-free-primitives*): Add procedure? and thunk?.
  (*multiply-valued-primitives*): Remove @dynamic-wind.
  Remove @dynamic-wind expander.

* test-suite/tests/peval.test ("partial evaluation"): Update tests for
  dynwind desugaring.
This commit is contained in:
Andy Wingo 2013-06-27 18:49:21 +02:00
parent 0fcc39a0a9
commit bb97e4abd4
17 changed files with 108 additions and 280 deletions
Download patch file Download diff file Expand all files Collapse all files

10
doc/ref/compiler.texi
View file

@ -476,16 +476,6 @@ expression evaluating to a fluid.
A dynamic variable set. @var{fluid}, a Tree-IL expression evaluating
to a fluid, will be set to the result of evaluating @var{exp}.
@end deftp
@deftp {Scheme Variable} <dynwind> winder pre body post unwinder
@deftpx {External Representation} (dynwind @var{winder} @var{pre} @var{body} @var{post} @var{unwinder})
A @code{dynamic-wind}. @var{winder} and @var{unwinder} should both
evaluate to thunks. Ensure that the winder and the unwinder are called
before entering and after leaving @var{body}. Note that @var{body} is
an expression, without a thunk wrapper. Guile actually inlines the
bodies of @var{winder} and @var{unwinder} for the case of normal control
flow, compiling the expressions in @var{pre} and @var{post},
respectively.
@end deftp
@deftp {Scheme Variable} <prompt> tag body handler
@deftpx {External Representation} (prompt @var{tag} @var{body} @var{handler})
A dynamic prompt. Instates a prompt named @var{tag}, an expression,

14
libguile/eval.c
View file

@ -265,20 +265,6 @@ eval (SCM x, SCM env)
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
case SCM_M_DYNWIND:
{
SCM in, out, res;
scm_i_thread *t = SCM_I_CURRENT_THREAD;
in = EVAL1 (CAR (mx), env);
out = EVAL1 (CDDR (mx), env);
scm_call_0 (in);
scm_dynstack_push_dynwind (&t->dynstack, in, out);
res = eval (CADR (mx), env);
scm_dynstack_pop (&t->dynstack);
scm_call_0 (out);
return res;
}
case SCM_M_WITH_FLUIDS:
{
long i, len;

1
libguile/expand.c
View file

@ -184,7 +184,6 @@ SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind, "@dynamic-wind");
SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");

83
libguile/memoize.c
View file

@ -60,6 +60,27 @@ SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
/* Primitives not exposed to general Scheme. */
static SCM wind;
static SCM unwind;
static SCM
do_wind (SCM in, SCM out)
{
scm_dynstack_push_dynwind (&SCM_I_CURRENT_THREAD->dynstack, in, out);
return SCM_UNSPECIFIED;
}
static SCM
do_unwind (void)
{
scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return SCM_UNSPECIFIED;
}
/* {Evaluator memoized expressions}
*/
@ -88,8 +109,6 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_QUOTE, exp)
#define MAKMEMO_DEFINE(var, val) \
MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
#define MAKMEMO_DYNWIND(in, expr, out) \
MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
#define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
#define MAKMEMO_APPLY(proc, args)\
@ -116,11 +135,6 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
/* Primitives for the evaluator */
scm_t_bits scm_tc16_memoizer;
#define SCM_MEMOIZER_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoizer, (x)))
#define SCM_MEMOIZER(M) (SCM_SMOB_OBJECT_1 (M))
/* This table must agree with the list of M_ constants in memoize.h */
@ -132,7 +146,6 @@ static const char *const memoized_tags[] =
"let",
"quote",
"define",
"dynwind",
"with-fluids",
"apply",
"call/cc",
@ -250,18 +263,6 @@ memoize (SCM exp, SCM env)
proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, CALL, ARGS), env);
if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_TOPLEVEL_REF)
{
SCM var = scm_module_variable (scm_current_module (),
REF (proc, TOPLEVEL_REF, NAME));
if (SCM_VARIABLEP (var))
{
SCM val = SCM_VARIABLE_REF (var);
if (SCM_MEMOIZER_P (val))
return scm_apply (SCM_SMOB_OBJECT_1 (val), args, SCM_EOL);
}
}
/* otherwise we all fall down here */
return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
}
@ -291,6 +292,12 @@ memoize (SCM exp, SCM env)
&& scm_is_eq (name,
scm_from_latin1_symbol ("call-with-values")))
return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("wind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
else
@ -528,32 +535,6 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
#undef FUNC_NAME
#define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N) \
(scm_cell (scm_tc16_memoizer, \
SCM_UNPACK (scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
#define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N) \
SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
static SCM m_dynamic_wind (SCM in, SCM expr, SCM out)
#define FUNC_NAME "memoize-dynwind"
{
SCM_VALIDATE_MEMOIZED (1, in);
SCM_VALIDATE_MEMOIZED (2, expr);
SCM_VALIDATE_MEMOIZED (3, out);
return MAKMEMO_DYNWIND (in, expr, out);
}
#undef FUNC_NAME
SCM_SYMBOL (sym_placeholder, "_");
@ -630,11 +611,6 @@ unmemoize (const SCM expr)
unmemoize (CAR (args)), unmemoize (CDR (args)));
case SCM_M_DEFINE:
return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
case SCM_M_DYNWIND:
return scm_list_4 (scm_sym_at_dynamic_wind,
unmemoize (CAR (args)),
unmemoize (CADR (args)),
unmemoize (CDDR (args)));
case SCM_M_WITH_FLUIDS:
{
SCM binds = SCM_EOL, fluids, vals;
@ -879,10 +855,11 @@ scm_init_memoize ()
scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0);
#include "libguile/memoize.x"
wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
}

2
libguile/memoize.h
View file

@ -49,7 +49,6 @@ SCM_API SCM scm_sym_with_fluids;
SCM_API SCM scm_sym_at;
SCM_API SCM scm_sym_atat;
SCM_API SCM scm_sym_delay;
SCM_API SCM scm_sym_at_dynamic_wind;
SCM_API SCM scm_sym_eval_when;
SCM_API SCM scm_sym_arrow;
SCM_API SCM scm_sym_else;
@ -74,7 +73,6 @@ enum
SCM_M_LET,
SCM_M_QUOTE,
SCM_M_DEFINE,
SCM_M_DYNWIND,
SCM_M_WITH_FLUIDS,
SCM_M_APPLY,
SCM_M_CONT,

11
module/ice-9/boot-9.scm
View file

@ -266,7 +266,16 @@ x
a-cont
@result{} special-binding
@end lisp"
(@dynamic-wind in (thunk) out))
(if (thunk? out)
(in)
(scm-error 'wrong-type-arg "dynamic-wind" "Not a thunk: ~S"
(list out) #f))
((@@ primitive wind) in out)
(call-with-values thunk
(lambda vals
((@@ primitive unwind))
(out)
(apply values vals))))

6
module/ice-9/eval.scm
View file

@ -203,7 +203,6 @@
;;; module-ref: 14468
;;; define: 1259
;;; toplevel-set: 328
;;; dynwind: 162
;;; with-fluids: 0
;;; call/cc: 0
;;; module-set: 0
@ -463,11 +462,6 @@
env))))
(eval x env)))
(('dynwind (in exp . out))
(dynamic-wind (eval in env)
(lambda () (eval exp env))
(eval out env)))
(('with-fluids (fluids vals . exp))
(let* ((fluids (map (lambda (x) (eval x env)) fluids))
(vals (map (lambda (x) (eval x env)) vals)))

9
module/language/scheme/decompile-tree-il.scm
View file

@ -432,11 +432,6 @@
`(call-with-values (lambda () ,@(recurse-body exp))
,(recurse (make-lambda #f '() body))))
((<dynwind> body winder unwinder)
`(dynamic-wind ,(recurse winder)
(lambda () ,@(recurse-body body))
,(recurse unwinder)))
((<dynlet> fluids vals body)
`(with-fluids ,(map list
(map recurse fluids)
@ -761,10 +756,6 @@
(primitive 'call-with-values)
(recurse exp) (recurse body))
((<dynwind> winder body unwinder)
(primitive 'dynamic-wind)
(recurse winder) (recurse body) (recurse unwinder))
((<dynlet> fluids vals body)
(primitive 'with-fluids)
(for-each recurse fluids)

17
module/language/tree-il.scm
View file

@ -46,7 +46,6 @@
<letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
<dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
<dynref> dynref? make-dynref dynref-src dynref-fluid
<dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
@ -136,7 +135,6 @@
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
(<let-values> exp body)
(<dynwind> winder body unwinder)
(<dynref> fluid)
(<dynset> fluid exp)
(<prompt> tag body handler)
@ -249,9 +247,6 @@
(('let-values exp body)
(make-let-values loc (retrans exp) (retrans body)))
(('dynwind winder body unwinder)
(make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
(('dynlet fluids vals body)
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
@ -339,11 +334,6 @@
(($ <let-values> src exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
(($ <dynwind> src winder body unwinder)
`(dynwind ,(unparse-tree-il winder)
,(unparse-tree-il body)
,(unparse-tree-il unwinder)))
(($ <dynlet> src fluids vals body)
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
,(unparse-tree-il body)))
@ -424,10 +414,6 @@
(($ <let-values> src exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
(($ <dynwind> src winder body unwinder)
(let*-values (((seed ...) (foldts winder seed ...))
((seed ...) (foldts unwinder seed ...)))
(foldts body seed ...)))
(($ <dynlet> src fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
((seed ...) (fold-values foldts vals seed ...)))
@ -527,9 +513,6 @@ This is an implementation of `foldts' as described by Andy Wingo in
(($ <let-values> src exp body)
(make-let-values src (lp exp) (lp body)))
(($ <dynwind> src winder body unwinder)
(make-dynwind src (lp winder) (lp body) (lp unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map lp fluids) (map lp vals) (lp body)))

6
module/language/tree-il/analyze.scm
View file

@ -337,9 +337,6 @@
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
((<dynwind> winder body unwinder)
(lset-union eq? (step winder) (step body) (step unwinder)))
((<dynlet> fluids vals body)
(apply lset-union eq? (step body) (map step (append fluids vals))))
@ -511,9 +508,6 @@
((<let-values> exp body)
(max (recur exp) (recur body)))
((<dynwind> winder body unwinder)
(max (recur winder) (recur body) (recur unwinder)))
((<dynlet> fluids vals body)
(apply max (recur body) (map recur (append fluids vals))))

71
module/language/tree-il/compile-glil.scm
View file

@ -135,6 +135,9 @@
;; hack for lua
(return/values . return/values)
((wind . 2) . wind)
((unwind . 0) . unwind)
((bytevector-u8-ref . 2) . bv-u8-ref)
((bytevector-u8-set! . 3) . bv-u8-set)
((bytevector-s8-ref . 2) . bv-s8-ref)
@ -940,74 +943,6 @@
(clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind))))))
((<dynwind> src winder body unwinder)
(define (thunk? x)
(and (lambda? x)
(null? (lambda-case-gensyms (lambda-body x)))))
(define (make-wrong-type-arg x)
(make-primcall src 'scm-error
(list
(make-const #f 'wrong-type-arg)
(make-const #f "dynamic-wind")
(make-const #f "Wrong type (expecting thunk): ~S")
(make-primcall #f 'list (list x))
(make-primcall #f 'list (list x)))))
(define (emit-thunk-check x)
(comp-drop (make-conditional
src
(make-primcall src 'thunk? (list x))
(make-void #f)
(make-wrong-type-arg x))))
;; The `winder' and `unwinder' of a dynwind are constant
;; expressions and can be duplicated.
(if (not (thunk? winder))
(emit-thunk-check winder))
(comp-push winder)
(if (not (thunk? unwinder))
(emit-thunk-check unwinder))
(comp-push unwinder)
(emit-code #f (make-glil-call 'wind 2))
(case context
((tail)
(let ((MV (make-label)))
(comp-vals body MV)
;; One value. Unwind and return the value.
(emit-code #f (make-glil-call 'unwind 0))
(emit-code #f (make-glil-call 'return 1))
(emit-label MV)
;; Multiple values. Unwind and return the values.
(emit-code #f (make-glil-call 'unwind 0))
(emit-code #f (make-glil-call 'return/nvalues 1))))
((push)
;; We only want one value, so ask for one value and then
;; unwind, leaving the value on the stack.
(comp-push body)
(emit-code #f (make-glil-call 'unwind 0)))
((vals)
(let ((MV (make-label)))
(comp-vals body MV)
;; Transform a singly-valued return to a multiple-value
;; return and fall through to MV case.
(emit-code #f (make-glil-const 1))
(emit-label MV)
;; Multiple values: unwind and go to the MVRA.
(emit-code #f (make-glil-call 'unwind 0))
(emit-branch #f 'br MVRA)))
((drop)
;; Compile body, discarding values. Then unwind and fall
;; through, or goto RA if there is one.
(comp-drop body)
(emit-code #f (make-glil-call 'unwind 0))
(if RA
(emit-branch #f 'br RA)))))
((<dynlet> src fluids vals body)
(for-each comp-push fluids)
(for-each comp-push vals)

9
module/language/tree-il/cse.scm
View file

@ -442,15 +442,6 @@
((consumer db**) (visit consumer (concat db* db) env ctx)))
(return (make-let-values src producer consumer)
(concat db** db*))))
(($ <dynwind> src winder body unwinder)
(let*-values (((winder db*) (visit winder db env 'value))
((db**) db*)
((unwinder db*) (visit unwinder db env 'value))
((db**) (concat db* db**))
((body db*) (visit body (concat db** db) env ctx))
((db**) (concat db* db**)))
(return (make-dynwind src winder body unwinder)
db**)))
(($ <dynlet> src fluids vals body)
(let*-values (((fluids db*) (parallel-visit fluids db env 'value))
((vals db**) (parallel-visit vals db env 'value))

4
module/language/tree-il/debug.scm
View file

@ -216,10 +216,6 @@
(for-each (cut visit <> env) fluids)
(for-each (cut visit <> env) vals)
(visit body env))))
(($ <dynwind> src winder body unwinder)
(visit winder env)
(visit body env)
(visit unwinder env))
(($ <dynref> src fluid)
(visit fluid env))
(($ <dynset> src fluid exp)

4
module/language/tree-il/effects.scm
View file

@ -211,10 +211,6 @@ of an expression."
(logior (compute-effects producer)
(compute-effects consumer)
(cause &type-check)))
(($ <dynwind> _ winder body unwinder)
(logior (compute-effects winder)
(compute-effects body)
(compute-effects unwinder)))
(($ <dynlet> _ fluids vals body)
(logior (accumulate-effects fluids)
(accumulate-effects vals)

44
module/language/tree-il/peval.scm
View file

@ -104,8 +104,6 @@
(($ <conditional> _ test consequent alternate)
(and (singly-valued-expression? consequent)
(singly-valued-expression? alternate)))
(($ <dynwind> _ winder body unwinder)
(singly-valued-expression? body))
(else #f)))
(define (truncate-values x)
@ -543,10 +541,6 @@ top-level bindings from ENV and return the resulting expression."
(($ <prompt>) #f)
(($ <abort>) #f)
;; Bail on dynwinds, as that would cause the consumer to run in
;; the wrong dynamic context.
(($ <dynwind>) #f)
;; Propagate to tail positions.
(($ <let> src names gensyms vals body)
(let ((body (loop body)))
@ -1002,11 +996,6 @@ top-level bindings from ENV and return the resulting expression."
(else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
(($ <dynwind> src winder body unwinder)
(make-dynwind src
(for-value winder)
(for-tail body)
(for-value unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
@ -1169,13 +1158,29 @@ top-level bindings from ENV and return the resulting expression."
(list w u) 2
(match-lambda
((w u)
(make-seq src
(make-seq
src
(make-seq
src
(make-conditional
src
;; fixme: introduce logic to fold thunk?
(make-primcall src 'thunk? (list u))
(make-call src w '())
(make-primcall
src 'scm-error
(list
(make-const #f 'wrong-type-arg)
(make-const #f "dynamic-wind")
(make-const #f "Wrong type (expecting thunk): ~S")
(make-primcall #f 'list (list u))
(make-primcall #f 'list (list u)))))
(make-primcall src 'wind (list w u)))
(make-begin0 src
(make-dynwind src w
(make-call src thunk '())
u)
(make-call src u '()))))))))
(make-seq src
(make-primcall src 'unwind '())
(make-call src u '())))))))))
(($ <primcall> src 'values exps)
(cond
@ -1244,6 +1249,15 @@ top-level bindings from ENV and return the resulting expression."
((name . args)
(make-primcall src name args))))))
(($ <primcall> src 'thunk? (proc))
(match (for-value proc)
(($ <lambda> _ _ ($ <lambda-case> _ req))
(for-tail (make-const src (null? req))))
(proc
(case ctx
((effect) (make-void src))
(else (make-primcall src 'thunk? (list proc)))))))
(($ <primcall> src (? accessor-primitive? name) args)
(match (cons name (map for-value args))
;; FIXME: these for-tail recursions could take place outside

37
module/language/tree-il/primitives.scm
View file

@ -41,7 +41,6 @@
call-with-current-continuation
call/cc
dynamic-wind
@dynamic-wind
values
eq? eqv? equal?
memq memv
@ -51,6 +50,8 @@
not
pair? null? list? symbol? vector? string? struct? number? char? nil?
procedure? thunk?
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
char<? char<=? char>=? char>?
@ -176,6 +177,7 @@
eq? eqv? equal?
not
pair? null? list? symbol? vector? struct? string? number? char?
procedure? thunk?
acons cons cons* list vector))
;; Primitives that don't always return one value.
@ -185,7 +187,6 @@
call-with-current-continuation
call/cc
dynamic-wind
@dynamic-wind
values
call-with-prompt
@abort abort-to-prompt))
@ -533,38 +534,6 @@
(hashq-set! *primitive-expand-table* 'eqv? maybe-simplify-to-eq)
(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
(hashq-set! *primitive-expand-table*
'@dynamic-wind
(case-lambda
((src pre expr post)
(let* ((PRE (gensym "pre-"))
(POST (gensym "post-"))
(winder (make-lexical-ref #f 'winder PRE))
(unwinder (make-lexical-ref #f 'unwinder POST)))
(define (make-begin0 src first second)
(make-let-values
src
first
(let ((vals (gensym "vals ")))
(make-lambda-case
#f
'() #f 'vals #f '() (list vals)
(make-seq
src
second
(make-primcall #f 'apply
(list
(make-primitive-ref #f 'values)
(make-lexical-ref #f 'vals vals))))
#f))))
(make-let src '(pre post) (list PRE POST) (list pre post)
(make-seq src
(make-call src winder '())
(make-begin0
src
(make-dynwind src winder expr unwinder)
(make-call src unwinder '()))))))))
(hashq-set! *primitive-expand-table*
'fluid-ref
(case-lambda

40
test-suite/tests/peval.test
View file

@ -1070,42 +1070,48 @@
;; the dynwind; alack.
(dynamic-wind foo (lambda () bar) baz)
(let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
(seq (call (lexical tmp _))
(let (tmp) (_) ((dynwind (lexical tmp _)
(toplevel bar)
(lexical tmp _)))
(seq (call (lexical tmp _))
(seq (seq (if (primcall thunk? (lexical tmp _))
(call (lexical tmp _))
(primcall scm-error . _))
(primcall wind (lexical tmp _) (lexical tmp _)))
(let (tmp) (_) ((toplevel bar))
(seq (seq (primcall unwind)
(call (lexical tmp _)))
(lexical tmp _))))))
(pass-if-peval
;; Constant guards don't need lexical bindings.
;; Constant guards don't need lexical bindings or thunk? checks.
(dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
(seq (toplevel foo)
(let (tmp) (_) ((dynwind (lambda ()
(seq (seq (toplevel foo)
(primcall wind
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel foo))))
(toplevel bar)
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel baz))))))
(seq (toplevel baz)
(let (tmp) (_) ((toplevel bar))
(seq (seq (primcall unwind)
(toplevel baz))
(lexical tmp _)))))
(pass-if-peval
;; Dynwind bodies that return an unknown number of values need a
;; let-values.
(dynamic-wind (lambda () foo) (lambda () (bar)) (lambda () baz))
(seq (toplevel foo)
(let-values (dynwind (lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel foo))))
(call (toplevel bar))
(seq (seq (toplevel foo)
(primcall wind
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel baz)))))
((() #f #f #f () ()) (toplevel foo))))
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel baz))))))
(let-values (call (toplevel bar))
(lambda-case
((() #f vals #f () (_))
(seq (toplevel baz)
(seq (seq (primcall unwind)
(toplevel baz))
(primcall apply (primitive values) (lexical vals _))))))))
(pass-if-peval