From c7a0b753c9a91680cc977ddc867a28f6e7f02e6b Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Fri, 15 Jun 2018 21:47:18 +0200 Subject: [PATCH 1/6] bytecmp: fix compilation of closures Extract function name for bclosures in guess_environment and signal an error when attempting to compile a cclosure --- contrib/bytecmp/bytecmp.lsp | 16 ++++++++++------ src/c/compiler.d | 4 +++- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/contrib/bytecmp/bytecmp.lsp b/contrib/bytecmp/bytecmp.lsp index 4e51aaa7d..c71b7d8cb 100755 --- a/contrib/bytecmp/bytecmp.lsp +++ b/contrib/bytecmp/bytecmp.lsp @@ -45,9 +45,11 @@ (cond ((functionp definition) (multiple-value-bind (form lexenv) (function-lambda-expression definition) (when form - (if lexenv - (setf definition (si:eval-with-env form lexenv)) - (setf definition (si:eval-with-env form nil nil nil t))))) + (cond ((eq lexenv t) + (warn "COMPILE can not compile C closures") + (return-from bc-compile (values definition t nil))) + (lexenv (setf definition (si:eval-with-env form lexenv))) + (t (setf definition (si:eval-with-env form nil nil nil t)))))) (when name (setf (fdefinition name) definition)) (return-from bc-compile (values (or name definition) nil nil))) ((not (null definition)) @@ -66,9 +68,11 @@ (multiple-value-bind (form lexenv) (function-lambda-expression (fdefinition name)) (when form - (if lexenv - (setf definition (si:eval-with-env form lexenv)) - (setf definition (si:eval-with-env form nil nil nil t))))) + (cond ((eq lexenv t) + (warn "The bytecodes compiler can not compile C closures") + (return-from bc-compile (values definition t nil))) + (lexenv (setf definition (si:eval-with-env form lexenv))) + (t (setf definition (si:eval-with-env form nil nil nil t)))))) (when (null definition) (warn "We have lost the original function definition for ~s." name) (return-from bc-compile (values name t nil))) diff --git a/src/c/compiler.d b/src/c/compiler.d index 7523ca193..9ba87235d 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -501,7 +501,9 @@ guess_environment(cl_env_ptr env, cl_object interpreter_env) { cl_object record = ECL_CONS_CAR(interpreter_env); if (!LISTP(record)) { - c_register_function(env, record); + if (ecl_t_of(record) == t_bclosure) + record = record->bclosure.code; + c_register_function(env, record->bytecodes.name); } else { cl_object record0 = ECL_CONS_CAR(record); cl_object record1 = ECL_CONS_CDR(record); -- GitLab From b0a7684f2f1c858a2def4b80aeb45e25fb36d773 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Wed, 13 Jun 2018 20:48:14 +0200 Subject: [PATCH 2/6] bytecmp: Allow compilation of closures over macros 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. --- src/c/compiler.d | 75 +++++++++++++++++++++-------- src/c/interpreter.d | 55 +++++++++++++++------ src/h/internal.h | 1 + src/h/stacks.h | 17 ------- src/tests/normal-tests/compiler.lsp | 20 +++++--- 5 files changed, 110 insertions(+), 58 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 9ba87235d..bbd0816dd 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -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); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 2baeaf86b..cf4088a6d 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -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} diff --git a/src/h/internal.h b/src/h/internal.h index f27411a09..f069e2724 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -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 */ diff --git a/src/h/stacks.h b/src/h/stacks.h index 3b5c9ecb0..49f83fd53 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -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 *************/ diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 36b0f9d17..e106c03e5 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -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 -- GitLab From d27f1494e144f67cc16df3602d8bf0fe68f08a74 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sat, 23 Jun 2018 20:49:42 +0200 Subject: [PATCH 3/6] cmp: fix compile call for closures Signal an error for compilation of cclosures. Allow for compilation of bclosures over macros, functions and variables. Macros are simply added to the compiler environment. For functions and variables we enclose the definition of the closure in appropiate let/flet forms, e.g. for `(lambda () (fun var))' closing over the function `fun' and variable `var': (let ((var ...)) (flet ((fun (x) ...)) (lambda () (fun var)))) Closures over tags and blocks are not implemented and will signal an error during compilation. --- src/cmp/cmpenv-api.lsp | 53 ++++++++++++++++++++++++++++++++++++++++++ src/cmp/cmpmain.lsp | 28 ++++++++++++++-------- 2 files changed, 71 insertions(+), 10 deletions(-) diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index 1892c4b6e..78d8ae89f 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -25,6 +25,54 @@ that are susceptible to be changed by PROCLAIM." (defun cmp-env-copy (&optional (env *cmp-env*)) (cons (car env) (cdr env))) +(defun set-closure-env (definition lexenv &optional (env *cmp-env*)) + "Set up an environment for compilation of closures: Register closed +over macros in the compiler environment and enclose the definition of +the closure in let/flet forms for variables/functions it closes over." + (loop for record in lexenv + do (cond ((not (listp record)) + (multiple-value-bind (record-def record-lexenv) + (function-lambda-expression record) + (cond ((eql (car record-def) 'LAMBDA) + (setf record-def (cdr record-def))) + ((eql (car record-def) 'EXT:LAMBDA-BLOCK) + (setf record-def (cddr record-def))) + (t + (error "~&;;; Error: Not a valid lambda expression: ~s." record-def))) + ;; allow for closures which close over closures. + ;; (first record-def) is the lambda list, (rest + ;; record-def) the definition of the local function + ;; in record + (setf (rest record-def) + (list (set-closure-env (if (= (length record-def) 2) + (second record-def) + `(progn ,@(rest record-def))) + record-lexenv env))) + (setf definition + `(flet ((,(compiled-function-name record) + ,@record-def)) + ,definition)))) + ((and (listp record) (symbolp (car record))) + (cond ((eq (car record) 'si::macro) + (cmp-env-register-macro (cddr record) (cadr record) env)) + ((eq (car record) 'si::symbol-macro) + (cmp-env-register-symbol-macro-function (cddr record) (cadr record) env)) + (t + (setf definition + `(let ((,(car record) ',(cdr record))) + ,definition))) + )) + ;; ((and (integerp (cdr record)) (= (cdr record) 0)) + ;; Tags: We have lost the information, which tag + ;; corresponds to the lex-env record. If we are + ;; compiling a closure over a tag, we will get an + ;; error later on. + ;; ) + ;; (t + ;; Blocks: Not yet implemented + ) + finally (return definition))) + (defmacro cmp-env-variables (&optional (env '*cmp-env*)) `(car ,env)) @@ -102,6 +150,11 @@ that are susceptible to be changed by PROCLAIM." (cmp-env-variables env)) env) +(defun cmp-env-register-symbol-macro-function (name function &optional (env *cmp-env*)) + (push (list name 'si::symbol-macro function) + (cmp-env-variables env)) + env) + (defun cmp-env-register-block (blk &optional (env *cmp-env*)) (push (list :block (blk-name blk) blk) (cmp-env-variables env)) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 736ab4392..e68d936be 100755 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -734,6 +734,7 @@ compiled successfully, returns the pathname of the compiled file" #+dlopen (defun compile (name &optional (def nil supplied-p) &aux form data-pathname + (lexenv nil) (*suppress-compiler-messages* (or *suppress-compiler-messages* (not *compile-verbose*))) (*compiler-in-use* *compiler-in-use*) @@ -761,7 +762,11 @@ after compilation." (when (functionp def) (unless (function-lambda-expression def) (return-from compile def)) - (setf def (function-lambda-expression def))) + (multiple-value-setq (def lexenv) + (function-lambda-expression def)) + (when (eq lexenv t) + (warn "COMPILE can not compile C closures") + (return-from compile (values def t nil)))) (setq form (if name `(setf (fdefinition ',name) #',def) `(set 'GAZONK #',def)))) @@ -777,17 +782,20 @@ after compilation." (t (setq form `(setf (fdefinition ',name) #',form)))) - (let*((*load-time-values* 'values) ;; Only the value is kept - (tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))) - (data-pathname (first tmp-names)) - (c-pathname (compile-file-pathname data-pathname :type :c)) - (h-pathname (compile-file-pathname data-pathname :type :h)) - (o-pathname (compile-file-pathname data-pathname :type :object)) - (so-pathname (compile-file-pathname data-pathname)) - (init-name (compute-init-name so-pathname :kind :fasl)) - (compiler-conditions nil)) + (let* ((*load-time-values* 'values) ;; Only the value is kept + (tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))) + (data-pathname (first tmp-names)) + (c-pathname (compile-file-pathname data-pathname :type :c)) + (h-pathname (compile-file-pathname data-pathname :type :h)) + (o-pathname (compile-file-pathname data-pathname :type :object)) + (so-pathname (compile-file-pathname data-pathname)) + (init-name (compute-init-name so-pathname :kind :fasl)) + (compiler-conditions nil) + (*permanent-data* t) ; needed for literal objects in closures + (*cmp-env-root* *cmp-env-root*)) (with-compiler-env (compiler-conditions) + (setf form (set-closure-env form lexenv *cmp-env-root*)) (print-compiler-info) (data-init) (t1expr form) -- GitLab From 25a72ff80aef2305e6ca7caa4669e1cd26caa486 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Wed, 13 Jun 2018 20:54:26 +0200 Subject: [PATCH 4/6] cosmetic: indentation fixes and some comments --- src/c/assignment.d | 2 +- src/c/compiler.d | 17 ++++++++++------- src/c/disassembler.d | 2 +- src/clos/method.lsp | 1 + src/cmp/cmpflet.lsp | 4 ++-- src/lsp/defmacro.lsp | 36 ++++++++++++++++++------------------ src/lsp/top.lsp | 6 +++--- 7 files changed, 36 insertions(+), 32 deletions(-) diff --git a/src/c/assignment.d b/src/c/assignment.d index 368c8fbc1..e5cc0bf29 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -114,7 +114,7 @@ ecl_rem_setf_definition(cl_object sym) int type; @ if (Null(cl_functionp(def))) - FEinvalid_function(def); + FEinvalid_function(def); pack = ecl_symbol_package(sym); if (pack != ECL_NIL && pack->pack.locked diff --git a/src/c/compiler.d b/src/c/compiler.d index bbd0816dd..1a2a6e178 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -515,7 +515,9 @@ guess_compiler_environment(cl_env_ptr env, cl_object interpreter_env) else c_register_var(env, record0, FALSE, TRUE); } else if (record1 == ecl_make_fixnum(0)) { - c_register_tags(env, ECL_NIL); + /* We have lost the information, which tag corresponds to + the lex-env record. If we are compiling a closure over a + tag, we will get an error later on. */ } else { c_register_block(env, record1); } @@ -938,11 +940,11 @@ c_call(cl_env_ptr env, cl_object args, int flags) { flags = FLAG_VALUES; } else if (ECL_SYMBOLP(name) && ((flags & FLAG_GLOBAL) || Null(c_tag_ref(env, name, @':function')))) - { - asm_op2(env, OP_CALLG, nargs); - asm_c(env, name); - flags = FLAG_VALUES; - } else { + { + asm_op2(env, OP_CALLG, nargs); + asm_c(env, name); + flags = FLAG_VALUES; + } else { /* Fixme!! We can optimize the case of global functions! */ asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0); asm_op2(env, OP_CALL, nargs); @@ -2464,7 +2466,8 @@ compile_with_load_time_forms(cl_env_ptr env, cl_object form, int flags) */ if (c_env->load_time_forms != ECL_NIL) { cl_index *bytecodes = save_bytecodes(env, handle, current_pc(env)); - /* Make sure the forms are compiled in the right order */ + /* reverse the load time forms list to make sure the forms are + * compiled in the right order */ cl_object p, forms_list = cl_nreverse(c_env->load_time_forms); c_env->load_time_forms = ECL_NIL; p = forms_list; diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 489df7203..fff44b87f 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -429,7 +429,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { Returns from the block whose record in the lexical environment occuppies the n-th position. */ - case OP_RETURN: string = "RETFROM"; + case OP_RETURN: string = "RETFROM\t"; GET_OPARG(n, vector); goto OPARG; diff --git a/src/clos/method.lsp b/src/clos/method.lsp index de3177528..335b0fd5f 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -251,6 +251,7 @@ ;; explicitely the bytecodes compiler with an environment, no ;; stepping, compiler-env-p = t and execute = nil, so that the ;; form does not get executed. + ;; FIXME: Why is execute t then? (si::eval-with-env method-lambda env nil t t))) (values call-next-method-p next-method-p-p diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index e842260e7..6d50babce 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -45,8 +45,8 @@ (cmp-env-register-function fun new-env) (push (cons fun (cdr def)) defs))) - ;; Now we compile the functions, either in an empty environment - ;; in which there are no new functions + ;; Now we compile the functions, either in the current environment + ;; or in an empty environment in which there are no new functions (let ((*cmp-env* (cmp-env-copy (if (eq origin 'FLET) *cmp-env* new-env)))) (dolist (def (nreverse defs)) (let ((fun (first def))) diff --git a/src/lsp/defmacro.lsp b/src/lsp/defmacro.lsp index c306e31c7..35cfe204c 100644 --- a/src/lsp/defmacro.lsp +++ b/src/lsp/defmacro.lsp @@ -348,37 +348,37 @@ environment can be used to bytecompile the functions in MACROLET or SYMBOL-MACRO forms, and also to evaluate other forms." (declare (si::c-local)) (flet ((local-var-error-function (name) - #'(lambda (whole env) - (declare (ignore whole env)) - (error -"In a MACROLET function you tried to access a local variable, ~A, + #'(lambda (whole env) + (declare (ignore whole env)) + (error + "In a MACROLET function you tried to access a local variable, ~A, from the function in which it appears." name))) (local-fun-error-function (name) - #'(lambda (whole env) - (declare (ignore whole env)) - (error -"In a MACROLET function you tried to access a local function, ~A, + #'(lambda (whole env) + (declare (ignore whole env)) + (error + "In a MACROLET function you tried to access a local function, ~A, from the function in which it appears." name)))) (cons (do ((env (car old-env) (cdr env)) (variables '())) ((endp env) (nreverse variables)) (let ((i (car env))) (if (consp i) - (let ((name (first i))) - (if (not (keywordp name)) - (push (if (second i) - i - (list name 'si::symbol-macro (local-var-error-function name))) - variables)))))) + (let ((name (first i))) + (if (not (keywordp name)) + (push (if (second i) + i + (list name 'si::symbol-macro (local-var-error-function name))) + variables)))))) (do ((env (cdr old-env) (cdr env)) (macros '())) ((endp env) (nreverse macros)) (let ((i (car env))) (if (consp i) - (push (if (eq (second i) 'SI::MACRO) - i - (list (first i) 'SI:MACRO (local-fun-error-function (first i)))) - macros))))))) + (push (if (eq (second i) 'SI::MACRO) + i + (list (first i) 'SI:MACRO (local-fun-error-function (first i)))) + macros))))))) (defun macrolet-functions (definitions old-env) (declare (si::c-local)) diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index f8c0b9202..23f397411 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -1334,20 +1334,20 @@ Use special code 0 to cancel this operation.") Use the following functions to directly access ECL stacks. Invocation History Stack: -(sys:IHS-TOP) Returns the index of the TOP of the IHS. +(SYS:IHS-TOP) Returns the index of the TOP of the IHS. (SYS:IHS-FUN i) Returns the function of the i-th entity in IHS. (SYS:IHS-ENV i) (SYS:IHS-PREV i) (SYS:IHS-NEXT i) Frame (catch, block) Stack: -(sys:FRS-TOP) Returns the index of the TOP of the FRS. +(SYS:FRS-TOP) Returns the index of the TOP of the FRS. (SYS:FRS-BDS i) Returns the BDS index of the i-th entity in FRS. (SYS:FRS-IHS i) Returns the IHS index of the i-th entity in FRS. (SYS:FRS-TAG i) Binding Stack: -(sys:BDS-TOP) Returns the index of the TOP of the BDS. +(SYS:BDS-TOP) Returns the index of the TOP of the BDS. (SYS:BDS-VAR i) Returns the symbol of the i-th entity in BDS. (SYS:BDS-VAL i) Returns the value of the i-th entity in BDS. -- GitLab From 3bd980ce43d75111ac3a3bc7f17581f52f113c43 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 24 Jun 2018 15:47:17 +0200 Subject: [PATCH 5/6] bytecmp: improve closure generation for macros Only close around functions and variables when actually needed. Reverse changes to compiler environment, since we need the bytecode and native compiler environemnts to be similar (si::eval-with-env is called in the native compiler with its own compiler environment, so having symbol macros both c_env->variables and c_env->macros could be problematic). --- src/c/compiler.d | 38 ++++++++++++++++++++++++-------------- 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 1a2a6e178..6c603ca28 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -372,7 +372,6 @@ asm_op2c(cl_env_ptr env, int code, cl_object o) { * (:declare declaration-arguments*) * macro-record = (function-name FUNCTION [| function-object]) | * (macro-name si::macro macro-function) | - * (symbol si::symbol-macro macro-function) | * SI:FUNCTION-BOUNDARY | * SI:UNWIND-PROTECT-BOUNDARY * @@ -454,9 +453,7 @@ 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; - 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); + c_env->variables = CONS(cl_list(3, name, @'si::symbol-macro', exp_fun), c_env->variables); } static void @@ -1394,17 +1391,25 @@ c_function(cl_env_ptr env, cl_object args, int flags) { } static cl_object -create_macro_lexenv(cl_object macros) +create_macro_lexenv(cl_compiler_ptr c_env) { /* 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); + cl_object records; + for (records = c_env->macros; !Null(records); records = ECL_CONS_CDR(records)) { + cl_object record = ECL_CONS_CAR(records); 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); + if (CADR(record) == @'si::macro') + lexenv = CONS(CONS(@'si::macro', CONS(CADDR(record), CAR(record))), lexenv); + } + for (records = c_env->variables; !Null(records); records = ECL_CONS_CDR(records)) { + cl_object record = ECL_CONS_CAR(records); + if (ECL_ATOM(record)) + continue; + if (CADR(record) == @'si::symbol-macro') + lexenv = CONS(CONS(@'si::symbol-macro', CONS(CADDR(record), CAR(record))), lexenv); } return lexenv; } @@ -1438,9 +1443,8 @@ asm_function(cl_env_ptr env, cl_object function, int flags) { const cl_compiler_ptr c_env = env->c_env; 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))) { + cl_object macro_lexenv = create_macro_lexenv(c_env); + if (Null(macro_lexenv)) { if (Null(c_env->variables)) { /* No closure */ asm_op2c(env, OP_QUOTE, lambda); @@ -1449,8 +1453,14 @@ asm_function(cl_env_ptr env, cl_object function, int flags) { asm_op2c(env, OP_CLOSE, lambda); } } else { - /* Close around macros, functions and variables */ - asm_op2c(env, OP_CLOSE, ecl_close_around(lambda, macro_lexenv)); + lambda = ecl_close_around(lambda, macro_lexenv); + if (Null(c_env->variables)) { + /* Close only around macros */ + asm_op2c(env, OP_QUOTE, lambda); + } else { + /* Close around macros, functions and variables */ + asm_op2c(env, OP_CLOSE, lambda); + } } return FLAG_REG0; } -- GitLab From b56c9c12bee88dda4d2292fb69910648fd14bae4 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 24 Jun 2018 15:39:57 +0200 Subject: [PATCH 6/6] doc: fix section about the interpreter lexical environment --- .../new-doc/developer-guide/interpreter.txi | 33 ++++++++++++------- src/doc/new-doc/developer-guide/objects.txi | 6 ++-- 2 files changed, 26 insertions(+), 13 deletions(-) diff --git a/src/doc/new-doc/developer-guide/interpreter.txi b/src/doc/new-doc/developer-guide/interpreter.txi index 0ccf101e5..e664448e4 100644 --- a/src/doc/new-doc/developer-guide/interpreter.txi +++ b/src/doc/new-doc/developer-guide/interpreter.txi @@ -1,6 +1,14 @@ @node The interpreter @section The interpreter +@menu +* ECL stacks:: +* Procedure Call Conventions:: +* The lexical environment:: +* The interpreter stack:: +@end menu + +@node ECL stacks @subsection ECL stacks ECL uses the following stacks: @multitable @columnfractions .3 .7 @@ -14,6 +22,7 @@ ECL uses the following stacks: @tab used for arguments/values passing, typed lexical variables, temporary values, and function invocation. @end multitable +@node Procedure Call Conventions @subsection Procedure Call Conventions ECL employs standard C calling conventions to achieve efficiency and interoperability with other languages. Each Lisp function is @@ -69,20 +78,22 @@ instance, the actual source code for @code{cl_cons} in @) @end verbatim +@node The lexical environment @subsection The lexical environment -The ECL interpreter uses two A-lists (Association lists) to represent -lexical environments. - -@itemize -@item One for variable bindings -@item One for local function/macro/tag/block bindings -@end itemize - -When a function closure is created, the current two A-lists are saved -in the closure along with the lambda expression. Later, when the -closure is invoked, the saved A-lists are used to recover the lexical +The ECL interpreter uses a list containing local functions and macros, +variables, tags and blocks to represent the lexical environment. When +a function closure is created, the current lexical environment is +saved in the closure along with the lambda expression. Later, when the +closure is invoked, this list is used to recover the lexical environment. +Note that this list is different from what the Common Lisp standard +calls a lexical environment, which is the content of a +@code{&environment} parameter to @code{defmacro}. For the differences +between this two environments see the comments in +@code{src/c/compiler.d} and @code{src/c/interpreter.d}. + +@node The interpreter stack @subsection The interpreter stack The bytecodes interpreter uses a stack of its own to save and restore diff --git a/src/doc/new-doc/developer-guide/objects.txi b/src/doc/new-doc/developer-guide/objects.txi index c31b89427..1173e0b08 100644 --- a/src/doc/new-doc/developer-guide/objects.txi +++ b/src/doc/new-doc/developer-guide/objects.txi @@ -756,7 +756,9 @@ make_lambda function. @cppindex cl_eval @deftypefun cl_object si_safe_eval (cl_object form, cl_object env, ...) -@code{si_safe_eval} evaluates @code{form} in the lexical environment +@code{si_safe_eval} evaluates @code{form} in the lexical +environment@footnote{Note that @code{env} must be a lexical +environment as used in the interpreter, @xref{The lexical environment}} @code{env}, which can be @var{ECL_NIL}. Before evaluating it, the expression form must be bytecompiled. @@ -769,7 +771,7 @@ compatibility with previous versions. Equivalent of @code{si_safe_eval} (macro define). @end table -@subheading Exmaple +@subheading Example @exindex @code{cl_safe_eval} @example si_object form = c_string_to_object("(print 1)"); -- GitLab