mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 06:20:23 +02:00
Code Activity

Remove @prompt memoizer

Browse source 
* libguile/memoize.h:
* libguile/memoize.c (MAKMEMO_CALL_WITH_PROMPT, memoize, unmemoize):
  Remove the @prompt memoizer in favor of recognizing call-with-prompt
  primcalls.  Rename SCM_M_PROMPT to SCM_M_CALL_WITH_PROMPT, and pass a
  thunk instead of an expression so that it has normal applicative
  order.

* libguile/expand.c (PRIMITIVE_REF, PRIMCALL, expand): Produce primcalls
  from forms whose car is a primitive.
  (expand_atat): Recognize (@@ primitive FOO) as being a primitive-ref.

* module/ice-9/boot-9.scm (call-with-prompt): Instead of dispatching to
  the wonky @prompt memoizer, residualize a primcall to
  call-with-prompt.  The memoizer will DTRT to allow call-with-prompt to
  be interpreted correctly without needing an additional binding.

* module/ice-9/eval.scm (primitive-eval): Change the 'prompt clause to a
  call to call-with-prompt.

* module/language/tree-il/primitives.scm: No more need to recognize
  @prompt.

* libguile/eval.c (eval): Adapt to SCM_M_PROMPT renaming to
  SCM_M_CALL_WITH_PROMPT, and apply the thunk.

* libguile/throw.c (pre_init_throw): Adapt to scm_abort_to_prompt_star
  rename.
This commit is contained in:
Andy Wingo 2013-06-25 22:36:08 +02:00
parent 385049949a
commit 1773bc7dd5
8 changed files with 56 additions and 65 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/eval.c
View file

@ -436,7 +436,7 @@ eval (SCM x, SCM env)
return SCM_UNSPECIFIED;
}
case SCM_M_PROMPT:
case SCM_M_CALL_WITH_PROMPT:
{
SCM vm, k, res;
scm_i_jmp_buf registers;
@ -465,7 +465,7 @@ eval (SCM x, SCM env)
goto apply_proc;
}
res = eval (CADR (mx), env);
res = scm_call_0 (eval (CADR (mx), env));
scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}

33
libguile/expand.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -56,8 +56,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
SCM_MAKE_EXPANDED_VOID(src)
#define CONST_(src, exp) \
SCM_MAKE_EXPANDED_CONST(src, exp)
#define PRIMITIVE_REF_TYPE(src, name) \
SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name)
#define PRIMITIVE_REF(src, name) \
SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name)
#define LEXICAL_REF(src, name, gensym) \
SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
#define LEXICAL_SET(src, name, gensym, exp) \
@ -74,6 +74,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
#define CONDITIONAL(src, test, consequent, alternate) \
SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
#define PRIMCALL(src, name, exps) \
SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps)
#define CALL(src, proc, exps) \
SCM_MAKE_EXPANDED_CALL(src, proc, exps)
#define SEQ(src, head, tail) \
@ -195,12 +197,13 @@ SCM_GLOBAL_SYMBOL (scm_sym_let, "let");
SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
SCM_GLOBAL_SYMBOL (scm_sym_at_prompt, "@prompt");
SCM_SYMBOL (sym_call_with_prompt, "call-with-prompt");
SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
SCM_SYMBOL (sym_lambda_star, "lambda*");
SCM_SYMBOL (sym_eval, "eval");
SCM_SYMBOL (sym_load, "load");
SCM_SYMBOL (sym_primitive, "primitive");
SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
@ -356,17 +359,22 @@ expand (SCM exp, SCM env)
{
SCM arg_exps = SCM_EOL;
SCM args = SCM_EOL;
SCM proc = CAR (exp);
SCM proc = expand (CAR (exp), env);
for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
arg_exps = CDR (arg_exps))
args = scm_cons (expand (CAR (arg_exps), env), args);
if (scm_is_null (arg_exps))
return CALL (scm_source_properties (exp),
expand (proc, env),
scm_reverse_x (args, SCM_UNDEFINED));
else
args = scm_reverse_x (args, SCM_UNDEFINED);
if (!scm_is_null (arg_exps))
syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF)
return PRIMCALL (scm_source_properties (exp),
SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
args);
else
return CALL (scm_source_properties (exp), proc, args);
}
}
else if (scm_is_symbol (exp))
@ -423,9 +431,12 @@ static SCM
expand_atat (SCM expr, SCM env SCM_UNUSED)
{
ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
if (scm_is_eq (CADR (expr), sym_primitive))
return PRIMITIVE_REF (scm_source_properties (expr), CADDR (expr));
ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
return MODULE_REF (scm_source_properties (expr),
CADR (expr), CADDR (expr), SCM_BOOL_F);
}

45
libguile/memoize.c
View file

@ -112,8 +112,8 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
#define MAKMEMO_MOD_SET(val, mod, var, public) \
MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public))))
#define MAKMEMO_PROMPT(tag, exp, handler) \
MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler)))
#define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
/* Primitives for the evaluator */
@ -144,7 +144,7 @@ static const char *const memoized_tags[] =
"toplevel-set!",
"module-ref",
"module-set!",
"prompt",
"call-with-prompt",
};
static int
@ -267,16 +267,25 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_PRIMCALL:
{
SCM proc, args;
SCM name, args;
int nargs;
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
proc = MAKMEMO_TOP_REF (REF (exp, PRIMCALL, NAME));
else
proc = MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMCALL, NAME),
SCM_BOOL_F);
name = REF (exp, PRIMCALL, NAME);
args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
nargs = scm_ilength (args);
return MAKMEMO_CALL (proc, scm_ilength (args), args);
if (nargs == 3
&& scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
CADR (args),
CADDR (args));
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
else
return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
SCM_BOOL_F),
nargs,
args);
}
case SCM_EXPANDED_SEQ:
@ -525,13 +534,11 @@ static SCM m_apply (SCM proc, SCM arg, SCM rest);
static SCM m_call_cc (SCM proc);
static SCM m_call_values (SCM prod, SCM cons);
static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
static SCM m_prompt (SCM tag, SCM exp, SCM handler);
SCM_DEFINE_REST_MEMOIZER ("@apply", m_apply, 2);
SCM_DEFINE_MEMOIZER ("@call-with-current-continuation", m_call_cc, 1);
SCM_DEFINE_MEMOIZER ("@call-with-values", m_call_values, 2);
SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
SCM_DEFINE_MEMOIZER ("@prompt", m_prompt, 3);
@ -598,16 +605,6 @@ static SCM m_dynamic_wind (SCM in, SCM expr, SCM out)
}
#undef FUNC_NAME
static SCM m_prompt (SCM tag, SCM exp, SCM handler)
#define FUNC_NAME "@prompt"
{
SCM_VALIDATE_MEMOIZED (1, tag);
SCM_VALIDATE_MEMOIZED (2, exp);
SCM_VALIDATE_MEMOIZED (3, handler);
return MAKMEMO_PROMPT (tag, exp, handler);
}
#undef FUNC_NAME
@ -768,8 +765,8 @@ unmemoize (const SCM expr)
scm_i_finite_list_copy (CADR (args)),
CADDR (args)),
unmemoize (CAR (args)));
case SCM_M_PROMPT:
return scm_list_4 (scm_sym_at_prompt,
case SCM_M_CALL_WITH_PROMPT:
return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
unmemoize (CAR (args)),
unmemoize (CADR (args)),
unmemoize (CDDR (args)));

3
libguile/memoize.h
View file

@ -51,7 +51,6 @@ SCM_API SCM scm_sym_atat;
SCM_API SCM scm_sym_atapply;
SCM_API SCM scm_sym_atcall_cc;
SCM_API SCM scm_sym_at_call_with_values;
SCM_API SCM scm_sym_at_prompt;
SCM_API SCM scm_sym_delay;
SCM_API SCM scm_sym_at_dynamic_wind;
SCM_API SCM scm_sym_eval_when;
@ -90,7 +89,7 @@ enum
SCM_M_TOPLEVEL_SET,
SCM_M_MODULE_REF,
SCM_M_MODULE_SET,
SCM_M_PROMPT
SCM_M_CALL_WITH_PROMPT
};

4
libguile/throw.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -510,7 +510,7 @@ static SCM
pre_init_throw (SCM k, SCM args)
{
if (find_pre_init_catch ())
return scm_at_abort (sym_pre_init_catch_tag, scm_cons (k, args));
return scm_abort_to_prompt_star (sym_pre_init_catch_tag, scm_cons (k, args));
else
{
static int error_printing_error = 0;

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

@ -62,7 +62,7 @@
%default-prompt-tag)))
(define (call-with-prompt tag thunk handler)
(@prompt tag (thunk) handler))
((@@ primitive call-with-prompt) tag thunk handler))
(define (abort-to-prompt tag . args)
(abort-to-prompt* tag args))

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

@ -477,10 +477,11 @@
(with-fluids (((car fluids) (car vals)))
(lp (cdr fluids) (cdr vals)))))))
(('prompt (tag exp . handler))
(@prompt (eval tag env)
(eval exp env)
(eval handler env)))
(('call-with-prompt (tag thunk . handler))
(call-with-prompt
(eval tag env)
(eval thunk env)
(eval handler env)))
(('call/cc proc)
(call/cc (eval proc env)))

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

@ -77,7 +77,7 @@
fluid-ref fluid-set!
@prompt call-with-prompt
call-with-prompt
abort-to-prompt* abort-to-prompt
make-prompt-tag
@ -187,7 +187,7 @@
dynamic-wind
@dynamic-wind
values
@prompt call-with-prompt
call-with-prompt
@abort abort-to-prompt))
;; Procedures that cause a nonlocal, non-resumable abort.
@ -586,23 +586,6 @@
((src fluid exp) (make-dynset src fluid exp))
(else #f)))
(hashq-set! *primitive-expand-table*
'@prompt
(case-lambda
((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-primcall #f 'apply
(list handler
(make-lexical-ref #f 'args args-sym)))
#f))))
(else #f)))
(hashq-set! *primitive-expand-table*
'call-with-prompt
(case-lambda