: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
(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)
"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"))
(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
(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)
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."
(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.")
(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
(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
(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))
;; 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)
(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))
;; 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)
(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))))
\f
(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))))
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;
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,
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
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;
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);
}
}
}
- 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
{
&& (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
{
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 ();
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);
projects / emacs.git / commitdiff