mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Remove with-fluids; replaced by with-fluid* and inlined push-fluid primops

Browse source 
* libguile/vm-i-system.c (push-fluid, pop-fluid):
* doc/ref/vm.texi (Dynamic Environment Instructions): Rename wind-fluids
  to push-fluid, and unwind-fluids to pop-fluid.  They now only work on
  one fluid binding at a time.

* module/ice-9/boot-9.scm (with-fluid*): Implement in Scheme in terms of
  primcalls to push-fluid and pop-fluid.
  (custom-throw-handler, catch, with-throw-handler): Use with-fluid*
  instead of with-fluids, as with-fluids is no longer available before
  psyntax is loaded.
  (with-fluids): Define in Scheme in terms of with-fluid*.

* libguile/fluids.c (scm_with_fluid): Rename from scm_with_fluids, and
  don't expose to Scheme.

* libguile/eval.c (eval): Remove SCM_M_WITH_FLUIDS case.
* libguile/expand.c (expand_with_fluids): Remove with-fluids syntax.
  (DYNLET): Remove, no longer defining dynlet in the %expanded-vtables.
* libguile/expand.h: Remove dynlet definitions.
* module/ice-9/eval.scm (primitive-eval): Remove with-fluids case.
* libguile/memoize.c (do_push_fluid, do_pop_fluid): New primitive
  helpers, like wind and unwind.
  (memoize): Memoize wind and unwind primcalls.  Don't memoize dynlet to
  with-fluids.
  (scm_init_memoize): Initialize push_fluid and pop_fluid here.
* libguile/memoize.h (SCM_M_WITH_FLUIDS): Remove definition.

* module/ice-9/psyntax.scm (build-dynlet): Remove; this just supported
  with-fluids, which is now defined in boot-9.
* module/ice-9/psyntax-pp.scm: Regenerate.

* doc/ref/compiler.texi (Tree-IL):
* module/language/tree-il.scm:
* module/language/tree-il/analyze.scm:
* module/language/tree-il/canonicalize.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/cse.scm:
* module/language/tree-il/debug.scm:
* module/language/tree-il/effects.scm: Remove <dynlet>.  Add cases for
  primcalls to push-fluid and pop-fluid in compile-glil.scm and
  effects.scm.

* module/language/tree-il/peval.scm (peval): Factor out
  with-temporaries; probably a bad idea, but works for now.  Factor out
  make-begin0 (a better idea).  Inline primcalls to with-fluid*, and
  remove dynlet cases.

* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
  Add with-fluid*.
This commit is contained in:
Andy Wingo 2013-06-28 19:47:03 +02:00
parent 5e0253f19e
commit c32b7c4cef
24 changed files with 178 additions and 351 deletions
Download patch file Download diff file Expand all files Collapse all files

8
doc/ref/compiler.texi
View file

@ -458,14 +458,6 @@ original binding names, @var{gensyms} are gensyms corresponding to the
A version of @code{<let>} that creates recursive bindings, like
Scheme's @code{letrec}, or @code{letrec*} if @var{in-order?} is true.
@end deftp
@deftp {Scheme Variable} <dynlet> fluids vals body
@deftpx {External Representation} (dynlet @var{fluids} @var{vals} @var{body})
Dynamic binding; the equivalent of Scheme's @code{with-fluids}.
@var{fluids} should be a list of Tree-IL expressions that will
evaluate to fluids, and @var{vals} a corresponding list of expressions
to bind to the fluids during the dynamic extent of the evaluation of
@var{body}.
@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,

13
doc/ref/vm.texi
View file

@ -1120,18 +1120,17 @@ wind/unwind thunk pair. @code{unwind} instructions should be properly
paired with their winding instructions, like @code{wind}.
@end deffn
@deffn Instruction wind-fluids n
Pop off @var{n} values and @var{n} fluids from the stack, in that order.
Set the fluids to the values by creating a with-fluids object and
pushing that object on the dynamic stack. @xref{Fluids and Dynamic
States}.
@deffn Instruction push-fluid
Pop a value and a fluid from the stack, in that order. Set the fluid
to the value by creating a with-fluids object and pushing that object
on the dynamic stack. @xref{Fluids and Dynamic States}.
@end deffn
@deffn Instruction unwind-fluids
@deffn Instruction pop-fluid
Pop a with-fluids object from the dynamic stack, and swap the current
values of its fluids with the saved values of its fluids. In this way,
the dynamic environment is left as it was before the corresponding
@code{wind-fluids} instruction was processed.
@code{wind-fluid} instruction was processed.
@end deffn
@deffn Instruction fluid-ref

23
libguile/eval.c
View file

@ -40,7 +40,6 @@
#include "libguile/eq.h"
#include "libguile/expand.h"
#include "libguile/feature.h"
#include "libguile/fluids.h"
#include "libguile/goops.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
@ -265,28 +264,6 @@ eval (SCM x, SCM env)
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
case SCM_M_WITH_FLUIDS:
{
long i, len;
SCM *fluidv, *valuesv, walk, res;
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
len = scm_ilength (CAR (mx));
fluidv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
fluidv[i] = EVAL1 (CAR (walk), env);
valuesv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
valuesv[i] = EVAL1 (CAR (walk), env);
scm_dynstack_push_fluids (&thread->dynstack, len, fluidv, valuesv,
thread->dynamic_state);
res = eval (CDDR (mx), env);
scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
return res;
}
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);

29
libguile/expand.c
View file

@ -88,8 +88,6 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
#define LETREC(src, in_order_p, names, gensyms, vals, body) \
SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
#define DYNLET(src, fluids, vals, body) \
SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
#define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x)
@ -155,7 +153,6 @@ SCM_SYNTAX ("@", expand_at);
SCM_SYNTAX ("@@", expand_atat);
SCM_SYNTAX ("begin", expand_begin);
SCM_SYNTAX ("define", expand_define);
SCM_SYNTAX ("with-fluids", expand_with_fluids);
SCM_SYNTAX ("eval-when", expand_eval_when);
SCM_SYNTAX ("if", expand_if);
SCM_SYNTAX ("lambda", expand_lambda);
@ -184,7 +181,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_with_fluids, "with-fluids");
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
@ -564,30 +560,6 @@ expand_define (SCM expr, SCM env)
expand (CAR (body), env));
}
static SCM
expand_with_fluids (SCM expr, SCM env)
{
SCM binds, fluids, vals;
ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
binds = CADR (expr);
ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
for (fluids = SCM_EOL, vals = SCM_EOL;
scm_is_pair (binds);
binds = CDR (binds))
{
SCM binding = CAR (binds);
ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
binding, expr);
fluids = scm_cons (expand (CAR (binding), env), fluids);
vals = scm_cons (expand (CADR (binding), env), vals);
}
return DYNLET (scm_source_properties (expr),
scm_reverse_x (fluids, SCM_UNDEFINED),
scm_reverse_x (vals, SCM_UNDEFINED),
expand_sequence (CDDR (expr), env));
}
static SCM
expand_eval_when (SCM expr, SCM env)
{
@ -1262,7 +1234,6 @@ scm_init_expand ()
DEFINE_NAMES (LAMBDA_CASE);
DEFINE_NAMES (LET);
DEFINE_NAMES (LETREC);
DEFINE_NAMES (DYNLET);
scm_exp_vtable_vtable =
scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"),

17
libguile/expand.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_EXPAND_H
#define SCM_EXPAND_H
/* Copyright (C) 2010, 2011
/* Copyright (C) 2010, 2011, 2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -54,7 +54,6 @@ typedef enum
SCM_EXPANDED_LAMBDA_CASE,
SCM_EXPANDED_LET,
SCM_EXPANDED_LETREC,
SCM_EXPANDED_DYNLET,
SCM_NUM_EXPANDED_TYPES,
} scm_t_expanded_type;
@ -331,20 +330,6 @@ enum
#define SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_LETREC], 0, SCM_NUM_EXPANDED_LETREC_FIELDS, SCM_UNPACK (src), SCM_UNPACK (in_order_p), SCM_UNPACK (names), SCM_UNPACK (gensyms), SCM_UNPACK (vals), SCM_UNPACK (body))
#define SCM_EXPANDED_DYNLET_TYPE_NAME "dynlet"
#define SCM_EXPANDED_DYNLET_FIELD_NAMES \
{ "src", "fluids", "vals", "body", }
enum
{
SCM_EXPANDED_DYNLET_SRC,
SCM_EXPANDED_DYNLET_FLUIDS,
SCM_EXPANDED_DYNLET_VALS,
SCM_EXPANDED_DYNLET_BODY,
SCM_NUM_EXPANDED_DYNLET_FIELDS,
};
#define SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_DYNLET], 0, SCM_NUM_EXPANDED_DYNLET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (fluids), SCM_UNPACK (vals), SCM_UNPACK (body))
#endif /* BUILDING_LIBGUILE */

8
libguile/fluids.c
View file

@ -418,16 +418,12 @@ scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
}
#undef FUNC_NAME
SCM_DEFINE (scm_with_fluid, "with-fluid*", 3, 0, 0,
(SCM fluid, SCM value, SCM thunk),
"Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
"@var{thunk} must be a procedure with no argument.")
#define FUNC_NAME s_scm_with_fluid
SCM
scm_with_fluid (SCM fluid, SCM value, SCM thunk)
{
return scm_c_with_fluid (fluid, value,
apply_thunk, (void *) SCM_UNPACK (thunk));
}
#undef FUNC_NAME
SCM
scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)

47
libguile/memoize.c
View file

@ -63,6 +63,8 @@ SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
/* Primitives not exposed to general Scheme. */
static SCM wind;
static SCM unwind;
static SCM push_fluid;
static SCM pop_fluid;
static SCM
do_wind (SCM in, SCM out)
@ -78,6 +80,23 @@ do_unwind (void)
return SCM_UNSPECIFIED;
}
static SCM
do_push_fluid (SCM fluid, SCM val)
{
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_dynstack_push_fluids (&thread->dynstack, 1, &fluid, &val,
thread->dynamic_state);
return SCM_UNSPECIFIED;
}
static SCM
do_pop_fluid (void)
{
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
return SCM_UNSPECIFIED;
}
@ -109,8 +128,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_WITH_FLUIDS(fluids, vals, expr) \
MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
#define MAKMEMO_APPLY(proc, args)\
MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
#define MAKMEMO_CONT(proc) \
@ -146,7 +163,6 @@ static const char *const memoized_tags[] =
"let",
"quote",
"define",
"with-fluids",
"apply",
"call/cc",
"call-with-values",
@ -298,6 +314,12 @@ memoize (SCM exp, SCM env)
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 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
@ -511,11 +533,6 @@ memoize (SCM exp, SCM env)
}
}
case SCM_EXPANDED_DYNLET:
return MAKMEMO_WITH_FLUIDS (memoize_exps (REF (exp, DYNLET, FLUIDS), env),
memoize_exps (REF (exp, DYNLET, VALS), env),
memoize (REF (exp, DYNLET, BODY), env));
default:
abort ();
}
@ -611,18 +628,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_WITH_FLUIDS:
{
SCM binds = SCM_EOL, fluids, vals;
for (fluids = CAR (args), vals = CADR (args); scm_is_pair (fluids);
fluids = CDR (fluids), vals = CDR (vals))
binds = scm_cons (scm_list_2 (unmemoize (CAR (fluids)),
unmemoize (CAR (vals))),
binds);
return scm_list_3 (scm_sym_with_fluids,
scm_reverse_x (binds, SCM_UNDEFINED),
unmemoize (CDDR (args)));
}
case SCM_M_IF:
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
@ -859,6 +864,8 @@ scm_init_memoize ()
wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid);
pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid);
list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
}

2
libguile/memoize.h
View file

@ -44,7 +44,6 @@ SCM_API SCM scm_sym_quote;
SCM_API SCM scm_sym_quasiquote;
SCM_API SCM scm_sym_unquote;
SCM_API SCM scm_sym_uq_splicing;
SCM_API SCM scm_sym_with_fluids;
SCM_API SCM scm_sym_at;
SCM_API SCM scm_sym_atat;
@ -73,7 +72,6 @@ enum
SCM_M_LET,
SCM_M_QUOTE,
SCM_M_DEFINE,
SCM_M_WITH_FLUIDS,
SCM_M_APPLY,
SCM_M_CONT,
SCM_M_CALL_WITH_VALUES,

13
libguile/vm-i-system.c
View file

@ -1490,20 +1490,17 @@ VM_DEFINE_INSTRUCTION (90, unwind, "unwind", 0, 0, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (91, wind_fluids, "wind-fluids", 1, -1, 0)
VM_DEFINE_INSTRUCTION (91, push_fluid, "push-fluid", 0, 2, 0)
{
unsigned n = FETCH ();
SCM fluid, val;
POP2 (val, fluid);
SYNC_REGISTER ();
sp -= 2 * n;
CHECK_UNDERFLOW ();
scm_dynstack_push_fluids (&current_thread->dynstack, n, sp + 1, sp + 1 + n,
scm_dynstack_push_fluids (&current_thread->dynstack, 1, &fluid, &val,
current_thread->dynamic_state);
NULLSTACK (2 * n);
NEXT;
}
VM_DEFINE_INSTRUCTION (92, unwind_fluids, "unwind-fluids", 0, 0, 0)
VM_DEFINE_INSTRUCTION (92, pop_fluid, "pop-fluid", 0, 0, 0)
{
/* This function must not allocate. */
scm_dynstack_unwind_fluids (&current_thread->dynstack,

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

@ -66,6 +66,14 @@
(define (abort-to-prompt tag . args)
(abort-to-prompt* tag args))
(define (with-fluid* fluid val thunk)
"Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.
@var{thunk} must be a procedure of no arguments."
((@@ primitive push-fluid) fluid val)
(call-with-values thunk
(lambda vals
((@@ primitive pop-fluid))
(apply values vals))))
;; Define catch and with-throw-handler, using some common helper routines and a
;; shared fluid. Hide the helpers in a lexical contour.
@ -99,13 +107,14 @@
(lambda (thrown-k . args)
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
(let ((running (fluid-ref %running-exception-handlers)))
(with-fluids ((%running-exception-handlers (cons pre running)))
(if (not (memq pre running))
(apply pre thrown-k args))
;; fall through
(if prompt-tag
(apply abort-to-prompt prompt-tag thrown-k args)
(apply prev thrown-k args))))
(with-fluid* %running-exception-handlers (cons pre running)
(lambda ()
(if (not (memq pre running))
(apply pre thrown-k args))
;; fall through
(if prompt-tag
(apply abort-to-prompt prompt-tag thrown-k args)
(apply prev thrown-k args)))))
(apply prev thrown-k args)))))
(set! catch
@ -151,12 +160,11 @@ non-locally, that exit determines the continuation."
(call-with-prompt
tag
(lambda ()
(with-fluids
((%exception-handler
(if pre-unwind-handler
(custom-throw-handler tag k pre-unwind-handler)
(default-throw-handler tag k))))
(thunk)))
(with-fluid* %exception-handler
(if pre-unwind-handler
(custom-throw-handler tag k pre-unwind-handler)
(default-throw-handler tag k))
thunk))
(lambda (cont k . args)
(apply handler k args))))))
@ -168,9 +176,9 @@ for key @var{k}, then invoke @var{thunk}."
(scm-error 'wrong-type-arg "with-throw-handler"
"Wrong type argument in position ~a: ~a"
(list 1 k) (list k)))
(with-fluids ((%exception-handler
(custom-throw-handler #f k pre-unwind-handler)))
(thunk))))
(with-fluid* %exception-handler
(custom-throw-handler #f k pre-unwind-handler)
thunk)))
(set! throw
(lambda (key . args)
@ -702,6 +710,25 @@ file with the given name already exists, the effect is unspecified."
(define-syntax-rule (delay exp)
(make-promise (lambda () exp)))
(define-syntax with-fluids
(lambda (stx)
(define (emit-with-fluids bindings body)
(syntax-case bindings ()
(()
body)
(((f v) . bindings)
#`(with-fluid* f v
(lambda ()
#,(emit-with-fluids #'bindings body))))))
(syntax-case stx ()
((_ ((fluid val) ...) exp exp* ...)
(with-syntax (((fluid-tmp ...) (generate-temporaries #'(fluid ...)))
((val-tmp ...) (generate-temporaries #'(val ...))))
#`(let ((fluid-tmp fluid) ...)
(let ((val-tmp val) ...)
#,(emit-with-fluids #'((fluid-tmp val-tmp) ...)
#'(begin exp exp* ...)))))))))
(define-syntax current-source-location
(lambda (x)
(syntax-case x ()

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

@ -203,7 +203,6 @@
;;; module-ref: 14468
;;; define: 1259
;;; toplevel-set: 328
;;; with-fluids: 0
;;; call/cc: 0
;;; module-set: 0
;;;
@ -462,15 +461,6 @@
env))))
(eval x env)))
(('with-fluids (fluids vals . exp))
(let* ((fluids (map (lambda (x) (eval x env)) fluids))
(vals (map (lambda (x) (eval x env)) vals)))
(let lp ((fluids fluids) (vals vals))
(if (null? fluids)
(eval exp env)
(with-fluids (((car fluids) (car vals)))
(lp (cdr fluids) (cdr vals)))))))
(('call-with-prompt (tag thunk . handler))
(call-with-prompt
(eval tag env)

43
module/ice-9/psyntax-pp.scm
View file

@ -94,15 +94,6 @@
gensyms
vals
body)))
(make-dynlet
(lambda (src fluids vals body)
(make-struct
(vector-ref %expanded-vtables 18)
0
src
fluids
vals
body)))
(lambda?
(lambda (x)
(and (struct? x)
@ -152,9 +143,6 @@
(build-conditional
(lambda (source test-exp then-exp else-exp)
(make-conditional source test-exp then-exp else-exp)))
(build-dynlet
(lambda (source fluids vals body)
(make-dynlet source fluids vals body)))
(build-lexical-reference
(lambda (type source name var) (make-lexical-ref source name var)))
(build-lexical-assignment
@ -983,11 +971,14 @@
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x s))))))
(with-fluids
((transformer-environment (lambda (k) (k e r w s rib mod))))
(rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod))
(gensym (string-append "m-" (session-id) "-")))))))
(let* ((t-1 transformer-environment) (t (lambda (k) (k e r w s rib mod))))
(with-fluid*
t-1
t
(lambda ()
(rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod))
(gensym (string-append "m-" (session-id) "-")))))))))
(expand-body
(lambda (body outer-form r w mod)
(let* ((r (cons '("placeholder" placeholder) r))
@ -2102,24 +2093,6 @@
#f
"source expression failed to match any pattern"
tmp)))))))
(global-extend
'core
'with-fluids
(lambda (e r w s mod)
(let* ((tmp-1 e)
(tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
(if tmp
(apply (lambda (fluid val b b*)
(build-dynlet
s
(map (lambda (x) (expand x r w mod)) fluid)
(map (lambda (x) (expand x r w mod)) val)
(expand-body (cons b b*) (source-wrap e w s mod) r w mod)))
tmp)
(syntax-violation
#f
"source expression failed to match any pattern"
tmp-1)))))
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())
(global-extend 'define-syntax 'define-syntax '())

15
module/ice-9/psyntax.scm
View file

@ -325,10 +325,6 @@
(lambda (source test-exp then-exp else-exp)
(make-conditional source test-exp then-exp else-exp)))
(define build-dynlet
(lambda (source fluids vals body)
(make-dynlet source fluids vals body)))
(define build-lexical-reference
(lambda (type source name var)
(make-lexical-ref source name var)))
@ -2422,17 +2418,6 @@
(expand #'then r w mod)
(expand #'else r w mod))))))
(global-extend 'core 'with-fluids
(lambda (e r w s mod)
(syntax-case e ()
((_ ((fluid val) ...) b b* ...)
(build-dynlet
s
(map (lambda (x) (expand x r w mod)) #'(fluid ...))
(map (lambda (x) (expand x r w mod)) #'(val ...))
(expand-body #'(b b* ...)
(source-wrap e w s mod) r w mod))))))
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())

21
module/language/elisp/compile-tree-il.scm
View file

@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@ -297,6 +297,25 @@
meta
(make-lambda-case #f req opt rest #f init vars body #f)))
(define (make-dynlet src fluids vals body)
(let ((f (map (lambda (x) (gensym "fluid ")) fluids))
(v (map (lambda (x) (gensym "valud ")) vals)))
(make-let src (map (lambda (_) 'fluid) fluids) f fluids
(make-let src (map (lambda (_) 'val) vals) v vals
(let lp ((f f) (v v))
(if (null? f)
body
(make-primcall
src 'with-fluid*
(list (make-lexical-ref #f 'fluid (car f))
(make-lexical-ref #f 'val (car v))
(make-lambda
src '()
(make-lambda-case
src '() #f #f #f '() '()
(lp (cdr f) (cdr v))
#f))))))))))
(define (compile-lambda loc meta args body)
(receive (valid? req-ids opt-ids rest-id)
(parse-lambda-list args)

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

@ -432,12 +432,6 @@
`(call-with-values (lambda () ,@(recurse-body exp))
,(recurse (make-lambda #f '() body))))
((<dynlet> fluids vals body)
`(with-fluids ,(map list
(map recurse fluids)
(map recurse vals))
,@(recurse-body body)))
((<prompt> tag body handler)
`(call-with-prompt
,(recurse tag)
@ -750,12 +744,6 @@
(primitive 'call-with-values)
(recurse exp) (recurse body))
((<dynlet> fluids vals body)
(primitive 'with-fluids)
(for-each recurse fluids)
(for-each recurse vals)
(recurse body))
((<prompt> tag body handler)
(primitive 'call-with-prompt)
(primitive 'lambda)

16
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
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
@ -128,7 +127,6 @@
;; (<lambda-case> req opt rest kw inits gensyms body alternate)
;; (<let> names gensyms vals body)
;; (<letrec> in-order? names gensyms vals body)
;; (<dynlet> fluids vals body)
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
@ -243,9 +241,6 @@
(('let-values exp body)
(make-let-values loc (retrans exp) (retrans body)))
(('dynlet fluids vals body)
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
(('prompt tag body handler)
(make-prompt loc (retrans tag) (retrans body) (retrans handler)))
@ -324,10 +319,6 @@
(($ <let-values> src exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
(($ <dynlet> src fluids vals body)
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
,(unparse-tree-il body)))
(($ <prompt> src tag body handler)
`(prompt ,(unparse-tree-il tag)
,(unparse-tree-il body)
@ -398,10 +389,6 @@
(($ <let-values> src exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
(($ <dynlet> src fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
(($ <prompt> src tag body handler)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...)))
@ -492,9 +479,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)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map lp fluids) (map lp vals) (lp body)))
(($ <prompt> src tag body handler)
(make-prompt src (lp tag) (lp body) (lp handler)))

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

@ -337,9 +337,6 @@
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
((<dynlet> fluids vals body)
(apply lset-union eq? (step body) (map step (append fluids vals))))
((<prompt> tag body handler)
(lset-union eq? (step tag) (step body) (step-tail handler)))
@ -502,9 +499,6 @@
((<let-values> exp body)
(max (recur exp) (recur body)))
((<dynlet> fluids vals body)
(apply max (recur body) (map recur (append fluids vals))))
((<prompt> tag body handler)
(let ((cont-var (and (lambda-case? handler)
(pair? (lambda-case-gensyms handler))

2
module/language/tree-il/canonicalize.scm
View file

@ -40,8 +40,6 @@
body)
(($ <fix> src () () () body)
body)
(($ <dynlet> src () () body)
body)
(($ <lambda> src meta #f)
;; Give a body to case-lambda with no clauses.
(make-lambda

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

@ -139,6 +139,8 @@
((wind . 2) . wind)
((unwind . 0) . unwind)
((push-fluid . 2) . push-fluid)
((pop-fluid . 0) . pop-fluid)
((bytevector-u8-ref . 2) . bv-u8-ref)
((bytevector-u8-set! . 3) . bv-u8-set)
@ -945,52 +947,6 @@
(clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind))))))
((<dynlet> src fluids vals body)
(for-each comp-push fluids)
(for-each comp-push vals)
(emit-code #f (make-glil-call 'wind-fluids (length fluids)))
(case context
((tail)
(let ((MV (make-label)))
;; NB: in tail case, it is possible to preserve asymptotic tail
;; recursion, via merging unwind-fluids structures -- but we'd need
;; to compile in the body twice (once in tail context, assuming the
;; caller unwinds, and once with this trampoline thing, unwinding
;; ourselves).
(comp-vals body MV)
;; one value: unwind and return
(emit-code #f (make-glil-call 'unwind-fluids 0))
(emit-code #f (make-glil-call 'return 1))
(emit-label MV)
;; multiple values: unwind and return values
(emit-code #f (make-glil-call 'unwind-fluids 0))
(emit-code #f (make-glil-call 'return/nvalues 1))))
((push)
(comp-push body)
(emit-code #f (make-glil-call 'unwind-fluids 0)))
((vals)
(let ((MV (make-label)))
(comp-vals body MV)
;; one value: push 1 and fall through to MV case
(emit-code #f (make-glil-const 1))
(emit-label MV)
;; multiple values: unwind and goto MVRA
(emit-code #f (make-glil-call 'unwind-fluids 0))
(emit-branch #f 'br MVRA)))
((drop)
;; compile body, discarding values. then unwind...
(comp-drop body)
(emit-code #f (make-glil-call 'unwind-fluids 0))
;; and fall through, or goto RA if there is one.
(if RA
(emit-branch #f 'br RA)))))
;; What's the deal here? The deal is that we are compiling the start of a
;; delimited continuation. We try to avoid heap allocation in the normal
;; case; so the body is an expression, not a thunk, and we try to render

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

@ -442,13 +442,6 @@
((consumer db**) (visit consumer (concat db* db) env ctx)))
(return (make-let-values src producer consumer)
(concat db** db*))))
(($ <dynlet> src fluids vals body)
(let*-values (((fluids db*) (parallel-visit fluids db env 'value))
((vals db**) (parallel-visit vals db env 'value))
((body db***) (visit body (concat db** (concat db* db))
env ctx)))
(return (make-dynlet src fluids vals body)
(concat db*** (concat db** db*)))))
(($ <toplevel-ref>)
(return exp vlist-null))
(($ <module-ref>)

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

@ -204,18 +204,6 @@
(error "name should be symbol" exp))
(else
(visit exp env))))
(($ <dynlet> src fluids vals body)
(cond
((not (list? fluids))
(error "fluids should be list" exp))
((not (list? vals))
(error "vals should be list" exp))
((not (= (length fluids) (length vals)))
(error "mismatch in fluids/vals" exp))
(else
(for-each (cut visit <> env) fluids)
(for-each (cut visit <> env) vals)
(visit body env))))
(($ <conditional> src condition subsequent alternate)
(visit condition env)
(visit subsequent env)

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

@ -211,12 +211,6 @@ of an expression."
(logior (compute-effects producer)
(compute-effects consumer)
(cause &type-check)))
(($ <dynlet> _ fluids vals body)
(logior (accumulate-effects fluids)
(accumulate-effects vals)
(cause &type-check)
(cause &fluid)
(compute-effects body)))
(($ <toplevel-ref>)
(logior &toplevel
(cause &type-check)))
@ -284,6 +278,15 @@ of an expression."
(cause &type-check)
(cause &fluid)))
(($ <primcall> _ 'push-fluid (fluid val))
(logior (compute-effects fluid)
(compute-effects val)
(cause &type-check)
(cause &fluid)))
(($ <primcall> _ 'pop-fluid ())
(logior (cause &fluid)))
;; Primitives that are normally effect-free, but which might
;; cause type checks, allocate memory, or access mutable
;; memory. FIXME: expand, to be more precise.

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

@ -433,6 +433,47 @@ top-level bindings from ENV and return the resulting expression."
(define (lexical-refcount sym)
(var-refcount (lookup-var sym)))
(define (with-temporaries src exps refcount can-copy? k)
(let* ((pairs (map (match-lambda
((and exp (? can-copy?))
(cons #f exp))
(exp
(let ((sym (gensym "tmp ")))
(record-new-temporary! 'tmp sym refcount)
(cons sym exp))))
exps))
(tmps (filter car pairs)))
(match tmps
(() (k exps))
(tmps
(make-let src
(make-list (length tmps) 'tmp)
(map car tmps)
(map cdr tmps)
(k (map (match-lambda
((#f . val) val)
((sym . _)
(make-lexical-ref #f 'tmp sym)))
pairs)))))))
(define (make-begin0 src first second)
(make-let-values
src
first
(let ((vals (gensym "vals ")))
(record-new-temporary! 'vals vals 1)
(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))))
;; ORIG has been alpha-renamed to NEW. Analyze NEW and record a link
;; from it to ORIG.
;;
@ -559,10 +600,6 @@ top-level bindings from ENV and return the resulting expression."
(make-let-values src exp
(make-lambda-case src2 req opt rest kw
inits gensyms body #f)))))
(($ <dynlet> src fluids vals body)
(let ((body (loop body)))
(and body
(make-dynlet src fluids vals body))))
(($ <seq> src head tail)
(let ((tail (loop tail)))
(and tail (make-seq src head tail)))))))
@ -994,9 +1031,6 @@ top-level bindings from ENV and return the resulting expression."
(else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
exp)
(($ <toplevel-ref>)
@ -1108,48 +1142,9 @@ top-level bindings from ENV and return the resulting expression."
(for-tail (make-let-values src (make-call src producer '())
consumer)))
(($ <primcall> src 'dynamic-wind (w thunk u))
(define (with-temporaries exps refcount k)
(let* ((pairs (map (match-lambda
((and exp (? constant-expression?))
(cons #f exp))
(exp
(let ((sym (gensym "tmp ")))
(record-new-temporary! 'tmp sym refcount)
(cons sym exp))))
exps))
(tmps (filter car pairs)))
(match tmps
(() (k exps))
(tmps
(make-let src
(make-list (length tmps) 'tmp)
(map car tmps)
(map cdr tmps)
(k (map (match-lambda
((#f . val) val)
((sym . _)
(make-lexical-ref #f 'tmp sym)))
pairs)))))))
(define (make-begin0 src first second)
(make-let-values
src
first
(let ((vals (gensym "vals ")))
(record-new-temporary! 'vals vals 1)
(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))))
(for-tail
(with-temporaries
(list w u) 2
src (list w u) 2 constant-expression?
(match-lambda
((w u)
(make-seq
@ -1176,6 +1171,18 @@ top-level bindings from ENV and return the resulting expression."
(make-primcall src 'unwind '())
(make-call src u '())))))))))
(($ <primcall> src 'with-fluid* (f v thunk))
(for-tail
(with-temporaries
src (list f v thunk) 1 constant-expression?
(match-lambda
((f v thunk)
(make-seq src
(make-primcall src 'push-fluid (list f v))
(make-begin0 src
(make-call src thunk '())
(make-primcall src 'pop-fluid '()))))))))
(($ <primcall> src 'values exps)
(cond
((null? exps)

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

@ -76,7 +76,7 @@
variable-ref variable-set!
variable-bound?
fluid-ref fluid-set!
fluid-ref fluid-set! with-fluid*
call-with-prompt
abort-to-prompt* abort-to-prompt