mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-22 12:33:39 -08:00
Code Issues Projects Releases Packages Wiki Activity

bytecmp: Allow compilation of closures over macros

Browse source 
Change lexenv to include local macro definitions at the end of the
    lexenv list. If a function is defined in a non-nil macro
    environment, a bclosure is created during compilation which has as
    its lexenv only the macros it closes over. During interpretation,
    ecl_close_around adds to this the variables, functions, blocks
    and tags the function also closes over.
    Also close over symbol macros.
This commit is contained in:
Marius Gerbershagen 2018-06-13 20:48:14 +02:00
parent c7a0b753c9
commit b0a7684f2f
5 changed files with 110 additions and 58 deletions
Download patch file Download diff file Expand all files Collapse all files

75
src/c/compiler.d
View file

@ -371,7 +371,8 @@ asm_op2c(cl_env_ptr env, int code, cl_object o) {
* SI:UNWIND-PROTECT-BOUNDARY
* (:declare declaration-arguments*)
* macro-record = (function-name FUNCTION [| function-object]) |
* (macro-name si::macro macro-function)
* (macro-name si::macro macro-function) |
* (symbol si::symbol-macro macro-function) |
* SI:FUNCTION-BOUNDARY |
* SI:UNWIND-PROTECT-BOUNDARY
*
@ -453,18 +454,17 @@ static void
c_register_symbol_macro(cl_env_ptr env, cl_object name, cl_object exp_fun)
{
const cl_compiler_ptr c_env = env->c_env;
c_env->variables = CONS(cl_list(3, name, @'si::symbol-macro', exp_fun),
c_env->variables);
cl_object record = cl_list(3, name, @'si::symbol-macro', exp_fun);
c_env->variables = CONS(record, c_env->variables);
c_env->macros = CONS(record, c_env->macros);
}
/* UNUSED
static void
c_register_macro(cl_env_ptr env, cl_object name, cl_object exp_fun)
{
const cl_compiler_ptr c_env = env->c_env;
c_env->macros = CONS(cl_list(3, name, @'si::macro', exp_fun), c_env->macros);
}
*/
static void
c_register_macro(cl_env_ptr env, cl_object name, cl_object exp_fun)
{
const cl_compiler_ptr c_env = env->c_env;
c_env->macros = CONS(cl_list(3, name, @'si::macro', exp_fun), c_env->macros);
}
static void
c_register_var(cl_env_ptr env, cl_object var, bool special, bool bound)
@ -486,7 +486,7 @@ c_register_boundary(cl_env_ptr env, cl_object type)
}
static void
guess_environment(cl_env_ptr env, cl_object interpreter_env)
guess_compiler_environment(cl_env_ptr env, cl_object interpreter_env)
{
if (!LISTP(interpreter_env))
return;
@ -508,7 +508,12 @@ guess_environment(cl_env_ptr env, cl_object interpreter_env)
cl_object record0 = ECL_CONS_CAR(record);
cl_object record1 = ECL_CONS_CDR(record);
if (ECL_SYMBOLP(record0)) {
c_register_var(env, record0, FALSE, TRUE);
if (record0 == @'si::macro')
c_register_macro(env, ECL_CONS_CDR(record1), ECL_CONS_CAR(record1));
else if (record0 == @'si::symbol-macro')
c_register_symbol_macro(env, ECL_CONS_CDR(record1), ECL_CONS_CAR(record1));
else
c_register_var(env, record0, FALSE, TRUE);
} else if (record1 == ecl_make_fixnum(0)) {
c_register_tags(env, ECL_NIL);
} else {
@ -1386,6 +1391,22 @@ c_function(cl_env_ptr env, cl_object args, int flags) {
return asm_function(env, function, flags);
}
static cl_object
create_macro_lexenv(cl_object macros)
{
/* Creates a new lexenv out of the macros in the current compiler
* environment */
cl_object lexenv = ECL_NIL;
for (; !Null(macros); macros = ECL_CONS_CDR(macros)) {
cl_object record = ECL_CONS_CAR(macros);
if (ECL_ATOM(record))
continue;
if (CADR(record) == @'si::macro' || CADR(record) == @'si::symbol-macro')
lexenv = CONS(CONS(CADR(record), CONS(CADDR(record), CAR(record))), lexenv);
}
return lexenv;
}
static int /* XXX: here we look for function in cmpenv */
asm_function(cl_env_ptr env, cl_object function, int flags) {
if (!Null(si_valid_function_name_p(function))) {
@ -1414,10 +1435,21 @@ asm_function(cl_env_ptr env, cl_object function, int flags) {
}
const cl_compiler_ptr c_env = env->c_env;
asm_op2c(env,
(Null(c_env->variables) && Null(c_env->macros)) ? OP_QUOTE : OP_CLOSE,
ecl_make_lambda(env, name, body));
cl_object lambda = ecl_make_lambda(env, name, body);
cl_object macro_lexenv;
if (Null(c_env->macros) ||
Null(macro_lexenv = create_macro_lexenv(c_env->macros))) {
if (Null(c_env->variables)) {
/* No closure */
asm_op2c(env, OP_QUOTE, lambda);
} else {
/* Close only around functions and variables */
asm_op2c(env, OP_CLOSE, lambda);
}
} else {
/* Close around macros, functions and variables */
asm_op2c(env, OP_CLOSE, ecl_close_around(lambda, macro_lexenv));
}
return FLAG_REG0;
}
ERROR:
@ -3103,14 +3135,17 @@ si_make_lambda(cl_object name, cl_object rest)
}
old_c_env = the_env->c_env;
c_new_env(the_env, &new_c_env, compiler_env, 0);
guess_environment(the_env, interpreter_env);
new_c_env.lex_env = env;
guess_compiler_environment(the_env, interpreter_env);
if (compiler_env_p == ECL_NIL) {
new_c_env.lex_env = env;
} else {
new_c_env.lex_env = ECL_NIL;
}
new_c_env.stepping = stepping != ECL_NIL;
ECL_UNWIND_PROTECT_BEGIN(the_env) {
if (Null(execute)) {
cl_index handle = asm_begin(the_env);
new_c_env.mode = FLAG_LOAD;
/*cl_print(1,form);*/
compile_with_load_time_forms(the_env, form, FLAG_VALUES);
asm_op(the_env, OP_EXIT);
the_env->values[0] = asm_end(the_env, handle, form);

55
src/c/interpreter.d
View file

@ -164,6 +164,20 @@ ecl_stack_frame_close(cl_object f)
}
/* ------------------------------ LEXICAL ENV. ------------------------------ */
/*
* A lexical environment is a list of pairs, each one containing
* either a variable definition, a tagbody or block tag, or a local
* function or macro definition.
*
* lex_env ---> ( { record }* )
* record = variable | function | block_tag | tagbody_tag | macro
*
* variable = ( var_name[symbol] . value )
* function = function[bytecodes]
* block_tag = ( tag[fixnum] . block_name[symbol] )
* tagbody_tag = ( tag[fixnum] . 0 )
* macro = ( { si::macro | si::symbol-macro } macro_function[bytecodes] . macro_name )
*/
#define bind_var(env, var, val) CONS(CONS(var, val), (env))
#define bind_function(env, name, fun) CONS(fun, (env))
@ -206,16 +220,28 @@ _ecl_bclosure_dispatch_vararg(cl_narg narg, ...)
return output;
}
static cl_object
close_around(cl_object fun, cl_object lex) {
cl_object
ecl_close_around(cl_object fun, cl_object lex) {
cl_object v;
if (Null(lex)) return fun;
if (ecl_t_of(fun) != t_bytecodes)
FEerror("Internal error: close_around should be called on t_bytecodes.", 0);
v = ecl_alloc_object(t_bclosure);
v->bclosure.code = fun;
v->bclosure.lex = lex;
v->bclosure.entry = _ecl_bclosure_dispatch_vararg;
switch (ecl_t_of(fun)) {
case t_bytecodes:
v = ecl_alloc_object(t_bclosure);
v->bclosure.code = fun;
v->bclosure.lex = lex;
v->bclosure.entry = _ecl_bclosure_dispatch_vararg;
break;
case t_bclosure:
v = ecl_alloc_object(t_bclosure);
v->bclosure.code = fun->bclosure.code;
/* Put the predefined macros in fun->bclosure.lex at the end of
the lexenv so that lexenv indices are still valid */
v->bclosure.lex = ecl_append(lex, fun->bclosure.lex);
v->bclosure.entry = fun->bclosure.entry;
break;
default:
FEerror("Internal error: ecl_close_around should be called on t_bytecodes or t_bclosure.", 0);
}
return v;
}
@ -671,7 +697,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
do {
cl_object f;
GET_DATA(f, vector, data);
f = close_around(f, old_lex);
f = ecl_close_around(f, old_lex);
lex_env = bind_function(lex_env, f->bytecodes.name, f);
} while (--nfun);
THREAD_NEXT;
@ -702,7 +728,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
{
cl_object l = lex_env;
do {
ECL_RPLACA(l, close_around(ECL_CONS_CAR(l), lex_env));
ECL_RPLACA(l, ecl_close_around(ECL_CONS_CAR(l), lex_env));
l = ECL_CONS_CDR(l);
} while (--nfun);
}
@ -730,14 +756,13 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
THREAD_NEXT;
}
/* OP_CLOSE name{symbol}
Extracts the function associated to a symbol. The function
may be defined in the global environment or in the local
environment. This last value takes precedence.
/* OP_CLOSE name{symbol}
Creates a closure around the current lexical environment for
the function associated to the given symbol.
*/
CASE(OP_CLOSE); {
GET_DATA(reg0, vector, data);
reg0 = close_around(reg0, lex_env);
reg0 = ecl_close_around(reg0, lex_env);
THREAD_NEXT;
}
/* OP_GO n{arg}, tag-ndx{arg}

1
src/h/internal.h
View file

@ -228,6 +228,7 @@ extern cl_object si_constant_form_value _ECL_ARGS((cl_narg narg, cl_object form,
extern cl_object _ecl_bytecodes_dispatch_vararg(cl_narg narg, ...);
extern cl_object _ecl_bclosure_dispatch_vararg(cl_narg narg, ...);
extern cl_object ecl_close_around(cl_object fun, cl_object env);
/* ffi/backtrace.d */

17
src/h/stacks.h
View file

@ -387,23 +387,6 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje
__ecl_env->nvalues = 3; return __aux1; \
} while (0)
/*****************************
* LEXICAL ENVIRONMENT STACK
*****************************/
/*
* A lexical environment is a list of pairs, each one containing either
* a variable definition, a tagbody or block tag, or a local function
* definition.
*
* lex_env ---> ( { record }* )
* record = variable | function | block_tag | tagbody_tag
*
* variable = ( var_name[symbol] . value )
* function = ( function[bytecodes] . fun_name[symbol] )
* block_tag = ( tag[fixnum] . block_name[symbol] )
* tagbody_tag = ( tag[fixnum] . 0 )
*/
/*************
* LISP STACK
*************/

20
src/tests/normal-tests/compiler.lsp
View file

@ -1359,37 +1359,45 @@
(let ((fun-1 (lambda () :fun-1-nil))
(fun-2 (let ((fun-2-var :var)) (lambda () fun-2-var)))
(fun-3 (flet ((fun-3-fun () :fun)) (lambda () (fun-3-fun))))
(fun-4 (macrolet ((fun-4-mac () :mac)) (lambda () (fun-4-mac)))))
(fun-4 (macrolet ((fun-4-mac () :mac)) (lambda () (fun-4-mac))))
(fun-5 (symbol-macrolet ((fun-5-sym :sym)) (lambda () fun-5-sym))))
(is (eq :fun-1-nil (funcall fun-1)))
(is (eq :var (funcall fun-2)))
(is (eq :fun (funcall fun-3)))
(is (eq :mac (funcall fun-4)))
(is (eq :sym (funcall fun-5)))
(let ((fun-1 (ext::bc-compile nil fun-1))
(fun-2 (ext::bc-compile nil fun-2))
(fun-3 (ext::bc-compile nil fun-3))
(fun-4 (ext::bc-compile nil fun-4)))
(fun-4 (ext::bc-compile nil fun-4))
(fun-5 (ext::bc-compile nil fun-5)))
(is (eq :fun-1-nil (funcall fun-1)))
(is (eq :var (ignore-errors (funcall fun-2))) "fun-2-var from lexenv is not used.")
(is (eq :fun (ignore-errors (funcall fun-3))) "fun-3-fun from lexenv is not used.")
(is (eq :mac (ignore-errors (funcall fun-4))) "fun-4-mac from lexenv is not used."))))
(is (eq :mac (ignore-errors (funcall fun-4))) "fun-4-mac from lexenv is not used.")
(is (eq :sym (ignore-errors (funcall fun-5))) "fun-5-sym from lexenv is not used."))))
(test cmp.0065.cmp-compile-bclosure
(let ((fun-1 (lambda () :fun-1-nil))
(fun-2 (let ((fun-2-var :var)) (lambda () fun-2-var)))
(fun-3 (flet ((fun-3-fun () :fun)) (lambda () (fun-3-fun))))
(fun-4 (macrolet ((fun-4-mac () :mac)) (lambda () (fun-4-mac)))))
(fun-4 (macrolet ((fun-4-mac () :mac)) (lambda () (fun-4-mac))))
(fun-5 (symbol-macrolet ((fun-5-sym :sym)) (lambda () fun-5-sym))))
(is (eq :fun-1-nil (funcall fun-1)))
(is (eq :var (funcall fun-2)))
(is (eq :fun (funcall fun-3)))
(is (eq :mac (funcall fun-4)))
(is (eq :sym (funcall fun-5)))
(let ((fun-1 (compile nil fun-1))
(fun-2 (compile nil fun-2))
(fun-3 (compile nil fun-3))
(fun-4 (compile nil fun-4)))
(fun-4 (compile nil fun-4))
(fun-5 (compile nil fun-5)))
(is (eq :fun-1-nil (funcall fun-1)))
(is (eq :var (ignore-errors (funcall fun-2))) "fun-2-var from lexenv is not used.")
(is (eq :fun (ignore-errors (funcall fun-3))) "fun-3-fun from lexenv is not used.")
(is (eq :mac (ignore-errors (funcall fun-4))) "fun-4-mac from lexenv is not used."))))
(is (eq :mac (ignore-errors (funcall fun-4))) "fun-4-mac from lexenv is not used.")
(is (eq :sym (ignore-errors (funcall fun-5))) "fun-5-sym from lexenv is not used."))))
;;; Date 2018-02-12
;;; Description