From c37b5446d1f8e567f97f5708008b14a80b6c6d65 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 1 Jun 2020 12:47:29 +0100 Subject: [PATCH] Add native compiler dynamic scope support Add an initial implementation to support dynamic scope. Arg parsing/binding it's done using the existing code in use for bytecode (no ad-hoc code is synthetized for that). * src/lisp.h (struct Lisp_Subr): Add lambda_list field. (SUBR_NATIVE_COMPILED_DYNP): New inliner. * src/alloc.c (mark_object): Update for Add lambda_list field. * src/eval.c (eval_sub, Ffuncall, funcall_lambda): Handle native compiled dynamic scope * src/comp.c (declare_lex_function): Rename from declare_function and rework. (declare_function): New function. (make_subr): Handle daynamic scope * src/pdumper.c (dump_subr): Update for lambda_list field. * lisp/emacs-lisp/comp.el (comp-func): Remove args slot. (comp-func-l, comp-func-d): New classes deriving from `comp-func'. (comp-spill-lap-function): Rework. (comp-prepare-args-for-top-level): New function. (comp-emit-for-top-level, comp-emit-lambda-for-top-level): Make use of `comp-prepare-args-for-top-level'. (comp-limplify-top-level): Use `comp-func-l'. (comp-limplify-function): Emit arg prologue only for dynamic scoped functions. (comp-call-optim-form-call): Use `comp-func-l'. (comp-call-optim, comp-tco): Do not optimize dynamic scoped code. --- lisp/emacs-lisp/comp.el | 146 +++++++++++++++++++++++----------------- src/alloc.c | 1 + src/comp.c | 63 +++++++++++------ src/eval.c | 24 +++++-- src/lisp.h | 13 ++++ src/pdumper.c | 5 +- 6 files changed, 162 insertions(+), 90 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5027d1da088..e7bd0690727 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -354,7 +354,6 @@ into it.") :documentation "SSA status either: 'nil', 'dirty' or 't'. Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") - (args nil :type comp-args-base) (frame-size nil :type number) (blocks (make-hash-table) :type hash-table :documentation "Key is the basic block symbol value is a comp-block @@ -372,6 +371,16 @@ structure.") (array-h (make-hash-table) :type hash-table :documentation "array idx -> array length.")) +(cl-defstruct (comp-func-l (:include comp-func)) + "Lexical scoped function." + (args nil :type comp-args-base + :documentation "Argument specification of the function")) + +(cl-defstruct (comp-func-d (:include comp-func)) + "Dynamic scoped function." + (lambda-list nil :type list + :documentation "Original lambda-list.")) + (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (id nil :type (or null number) @@ -600,10 +609,10 @@ Put PREFIX in front of it." "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) - (func (make-comp-func :name function-name - :c-name c-name - :doc (documentation f) - :int-spec (interactive-form f)))) + (func (make-comp-func-l :name function-name + :c-name c-name + :doc (documentation f) + :int-spec (interactive-form f)))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) @@ -615,7 +624,7 @@ Put PREFIX in front of it." (cl-assert lap) (comp-log lap 2) (let ((arg-list (aref (comp-func-byte-func func) 0))) - (setf (comp-func-args func) + (setf (comp-func-l-args func) (comp-decrypt-arg-list arg-list function-name) (comp-func-lap func) lap @@ -631,8 +640,7 @@ Put PREFIX in front of it." (defun comp-intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda' create a function in `comp-ctxt'." (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) - (let* ((byte-func (byte-to-native-lambda-byte-func obj)) - (lap (byte-to-native-lambda-lap obj)) + (let* ((lap (byte-to-native-lambda-lap obj)) (top-l-form (cl-loop for form in (comp-ctxt-top-level-forms comp-ctxt) when (and (byte-to-native-func-def-p form) @@ -640,31 +648,32 @@ Put PREFIX in front of it." byte-func)) return form)) (name (when top-l-form - (byte-to-native-func-def-name top-l-form)))) - ;; Do not refuse to compile if a dynamic byte-compiled lambda - ;; leaks here (advice). - (when (or name (comp-lex-byte-func-p byte-func)) - (let* ((c-name (comp-c-func-name (or name "anonymous-lambda") "F")) - (func (make-comp-func :name name - :byte-func byte-func - :doc (documentation byte-func) - :int-spec (interactive-form byte-func) - :c-name c-name - :args (comp-decrypt-arg-list (aref byte-func 0) - name) - :lap lap - :frame-size (comp-byte-frame-size byte-func)))) - ;; Store the c-name to have it retrivable from - ;; `comp-ctxt-top-level-forms'. - (when top-l-form - (setf (byte-to-native-func-def-c-name top-l-form) c-name)) - (unless name - (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (comp-add-func-to-ctxt func) - (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1)))))) + (byte-to-native-func-def-name top-l-form))) + (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) + (func (if (comp-lex-byte-func-p byte-func) + (make-comp-func-l + :args (comp-decrypt-arg-list (aref byte-func 0) + name)) + (make-comp-func-d :lambda-list (aref byte-func 0))))) + (setf (comp-func-name func) name + (comp-func-byte-func func) byte-func + (comp-func-doc func) (documentation byte-func) + (comp-func-int-spec func) (interactive-form byte-func) + (comp-func-c-name func) c-name + (comp-func-lap func) lap + (comp-func-frame-size func) (comp-byte-frame-size byte-func)) + + ;; Store the c-name to have it retrivable from + ;; `comp-ctxt-top-level-forms'. + (when top-l-form + (setf (byte-to-native-func-def-c-name top-l-form) c-name)) + (unless name + (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func) + (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1)))) (cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." @@ -1321,6 +1330,17 @@ the annotation emission." (comp-log-func func 2) func) +(defun comp-prepare-args-for-top-level (function) + "Given FUNCTION return the two args arguments for comp--register-..." + (if (comp-func-l-p function) + (let ((args (comp-func-l-args function))) + (cons (comp-args-base-min args) + (if (comp-args-p args) + (comp-args-max args) + 'many))) + (cons (func-arity (comp-func-byte-func function)) + (comp-func-d-lambda-list function)))) + (cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") @@ -1329,16 +1349,14 @@ the annotation emission." (let* ((name (byte-to-native-func-def-name form)) (c-name (byte-to-native-func-def-c-name form)) (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) - (args (comp-func-args f))) + (args (comp-prepare-args-for-top-level f))) (cl-assert (and name f)) (comp-emit (comp-call (if for-late-load 'comp--late-register-subr 'comp--register-subr) (make-comp-mvar :constant name) - (make-comp-mvar :constant (comp-args-base-min args)) - (make-comp-mvar :constant (if (comp-args-p args) - (comp-args-max args) - 'many)) + (make-comp-mvar :constant (car args)) + (make-comp-mvar :constant (cdr args)) (make-comp-mvar :constant c-name) (make-comp-mvar :constant @@ -1364,7 +1382,7 @@ the annotation emission." (defun comp-emit-lambda-for-top-level (func) "Emit the creation of subrs for lambda FUNC. These are stored in the reloc data array." - (let ((args (comp-func-args func))) + (let ((args (comp-prepare-args-for-top-level func))) (let ((comp-curr-allocation-class 'd-impure)) (comp-add-const-to-relocs (comp-func-byte-func func))) (comp-emit @@ -1376,10 +1394,8 @@ These are stored in the reloc data array." (puthash (comp-func-byte-func func) (make-comp-mvar :constant nil) (comp-ctxt-lambda-fixups-h comp-ctxt))) - (make-comp-mvar :constant (comp-args-base-min args)) - (make-comp-mvar :constant (if (comp-args-p args) - (comp-args-max args) - 'many)) + (make-comp-mvar :constant (car args)) + (make-comp-mvar :constant (cdr args)) (make-comp-mvar :constant (comp-func-c-name func)) (make-comp-mvar :constant (let* ((h (comp-ctxt-function-docs comp-ctxt)) @@ -1404,14 +1420,14 @@ into the C code forwarding the compilation unit." ;; reasons to be execute ever again. Therefore all objects can be ;; just ephemeral. (let* ((comp-curr-allocation-class 'd-ephemeral) - (func (make-comp-func :name (if for-late-load - 'late-top-level-run - 'top-level-run) - :c-name (if for-late-load - "late_top_level_run" - "top_level_run") - :args (make-comp-args :min 1 :max 1) - :frame-size 1)) + (func (make-comp-func-l :name (if for-late-load + 'late-top-level-run + 'top-level-run) + :c-name (if for-late-load + "late_top_level_run" + "top_level_run") + :args (make-comp-args :min 1 :max 1) + :frame-size 1)) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) @@ -1475,20 +1491,22 @@ into the C code forwarding the compilation unit." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-pass (make-comp-limplify - :frame (comp-new-frame frame-size))) - (args (comp-func-args func))) + :frame (comp-new-frame frame-size)))) (comp-fill-label-h) ;; Prologue (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-name func)))) - (if (comp-args-p args) - (cl-loop for i below (comp-args-max args) - do (cl-incf (comp-sp)) - (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (comp-emit-narg-prologue (comp-args-base-min args) - (comp-nargs-nonrest args) - (comp-nargs-rest args))) + ;; Dynamic functions have parameters bound by the trampoline. + (when (comp-func-l-p func) + (let ((args (comp-func-l-args func))) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) + do (cl-incf (comp-sp)) + (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (comp-emit-narg-prologue (comp-args-base-min args) + (comp-nargs-nonrest args) + (comp-nargs-rest args))))) (comp-emit '(jump bb_0)) ;; Body (comp-bb-maybe-add 0 (comp-sp)) @@ -2096,7 +2114,7 @@ FUNCTION can be a function-name or byte compiled function." ;; Anonymous lambdas can't be redefined so are ;; always safe to optimize. (byte-code-function-p callee)))) - (let* ((func-args (comp-func-args comp-func-callee)) + (let* ((func-args (comp-func-l-args comp-func-callee)) (nargs (comp-nargs-p func-args)) (call-type (if nargs 'direct-callref 'direct-call)) (args (if (eq call-type 'direct-callref) @@ -2128,7 +2146,8 @@ FUNCTION can be a function-name or byte compiled function." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) - (comp-call-optim-func))) + (when (comp-func-l-p f) + (comp-call-optim-func)))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -2234,7 +2253,8 @@ Return the list of m-var ids nuked." (when (>= comp-speed 3) (maphash (lambda (_ f) (let ((comp-func f)) - (unless (comp-func-has-non-local comp-func) + (when (and (comp-func-l-p f) + (not (comp-func-has-non-local comp-func))) (comp-tco-func) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) diff --git a/src/alloc.c b/src/alloc.c index 42a53276bc8..a31b4a045e2 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6723,6 +6723,7 @@ mark_object (Lisp_Object arg) struct Lisp_Subr *subr = XSUBR (obj); mark_object (subr->native_intspec); mark_object (subr->native_comp_u[0]); + mark_object (subr->lambda_list[0]); } break; diff --git a/src/comp.c b/src/comp.c index 24d69b2b1ef..781ad3e08e4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3655,14 +3655,12 @@ define_bool_to_lisp_obj (void) emit_lisp_obj_rval (Qnil)); } -/* Declare a function being compiled and add it to comp.exported_funcs_h. */ - -static void -declare_function (Lisp_Object func) +static gcc_jit_function * +declare_lex_function (Lisp_Object func) { - gcc_jit_function *gcc_func; + gcc_jit_function *res; char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); - Lisp_Object args = CALL1I (comp-func-args, func); + Lisp_Object args = CALL1I (comp-func-l-args, func); bool nargs = !NILP (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; @@ -3673,23 +3671,23 @@ declare_function (Lisp_Object func) for (ptrdiff_t i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; - gcc_jit_param **param = SAFE_ALLOCA (max_args * sizeof (*param)); + gcc_jit_param **params = SAFE_ALLOCA (max_args * sizeof (*params)); for (int i = 0; i < max_args; ++i) - param[i] = gcc_jit_context_new_param (comp.ctxt, + params[i] = gcc_jit_context_new_param (comp.ctxt, NULL, type[i], format_string ("par_%d", i)); - gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.lisp_obj_type, - c_name, - max_args, - param, - 0); + res = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, + max_args, + params, + 0); } else { - gcc_jit_param *param[] = + gcc_jit_param *params[] = { gcc_jit_context_new_param (comp.ctxt, NULL, comp.ptrdiff_type, @@ -3698,19 +3696,34 @@ declare_function (Lisp_Object func) NULL, comp.lisp_obj_ptr_type, "args") }; - gcc_func = + res = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_EXPORTED, comp.lisp_obj_type, - c_name, 2, param, 0); + c_name, ARRAYELTS (params), params, 0); } + SAFE_FREE (); + return res; +} + +/* Declare a function being compiled and add it to comp.exported_funcs_h. */ +static void +declare_function (Lisp_Object func) +{ + gcc_jit_function *gcc_func = + !NILP (CALL1I (comp-func-l-p, func)) + ? declare_lex_function (func) + : gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + SSDATA (CALL1I (comp-func-c-name, func)), + 0, NULL, 0); Fputhash (CALL1I (comp-func-c-name, func), make_mint_ptr (gcc_func), comp.exported_funcs_h); - - SAFE_FREE (); } static void @@ -4685,12 +4698,20 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); - union Aligned_Lisp_Subr *x = (union Aligned_Lisp_Subr *) allocate_pseudovector ( VECSIZE (union Aligned_Lisp_Subr), 0, VECSIZE (union Aligned_Lisp_Subr), PVEC_SUBR); + if (CONSP (minarg)) + { + /* Dynamic code. */ + x->s.lambda_list[0] = maxarg; + maxarg = XCDR (minarg); + minarg = XCAR (minarg); + } + else + x->s.lambda_list[0] = Qnil; x->s.function.a0 = func; x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; diff --git a/src/eval.c b/src/eval.c index 9e86a185908..f2a85691b42 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2275,7 +2275,7 @@ eval_sub (Lisp_Object form) else if (!NILP (fun) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun))) fun = indirect_function (fun); - if (SUBRP (fun)) + if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) { Lisp_Object args_left = original_args; ptrdiff_t numargs = list_length (args_left); @@ -2378,7 +2378,9 @@ eval_sub (Lisp_Object form) } } } - else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun)) + else if (COMPILEDP (fun) + || SUBR_NATIVE_COMPILED_DYNP (fun) + || MODULE_FUNCTIONP (fun)) return apply_lambda (fun, original_args, count); else { @@ -2854,9 +2856,11 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun))) fun = indirect_function (fun); - if (SUBRP (fun)) + if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) val = funcall_subr (XSUBR (fun), numargs, args + 1); - else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun)) + else if (COMPILEDP (fun) + || SUBR_NATIVE_COMPILED_DYNP (fun) + || MODULE_FUNCTIONP (fun)) val = funcall_lambda (fun, numargs, args + 1); else { @@ -3066,6 +3070,11 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, else if (MODULE_FUNCTIONP (fun)) return funcall_module (fun, nargs, arg_vector); #endif + else if (SUBR_NATIVE_COMPILED_DYNP (fun)) + { + syms_left = XSUBR (fun)->lambda_list[0]; + lexenv = Qnil; + } else emacs_abort (); @@ -3126,6 +3135,13 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, if (CONSP (fun)) val = Fprogn (XCDR (XCDR (fun))); + else if (SUBR_NATIVE_COMPILEDP (fun)) + { + eassert (SUBR_NATIVE_COMPILED_DYNP (fun)); + /* No need to use funcall_subr as we have zero arguments by + construction. */ + val = XSUBR (fun)->function.a0 (); + } else val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL); diff --git a/src/lisp.h b/src/lisp.h index bef2e8079e1..70ef7db8ee4 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2096,6 +2096,7 @@ struct Lisp_Subr EMACS_INT doc; Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; char *native_c_name[NATIVE_COMP_FLAG]; + Lisp_Object lambda_list[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -4759,6 +4760,12 @@ SUBR_NATIVE_COMPILEDP (Lisp_Object a) return SUBRP (a) && !NILP (XSUBR (a)->native_comp_u[0]); } +INLINE bool +SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a) +{ + return SUBR_NATIVE_COMPILEDP (a) && !NILP (XSUBR (a)->lambda_list[0]); +} + INLINE struct Lisp_Native_Comp_Unit * allocate_native_comp_unit (void) { @@ -4772,6 +4779,12 @@ SUBR_NATIVE_COMPILEDP (Lisp_Object a) return false; } +INLINE bool +SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a) +{ + return false; +} + #endif /* Defined in lastfile.c. */ diff --git a/src/pdumper.c b/src/pdumper.c index e6c877cbbe2..2bda3a85cd1 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2937,7 +2937,7 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_92BED44D81) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_35CE99B716) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2968,8 +2968,9 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); if (!NILP (subr->native_comp_u[0])) dump_field_fixup_later (ctx, &out, subr, &subr->native_c_name[0]); - } + dump_field_lv (ctx, &out, subr, &subr->lambda_list[0], WEIGHT_NORMAL); + } dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); if (NATIVE_COMP_FLAG && ctx->flags.dump_object_contents -- 2.39.5