(ssa-cnt-gen (funcall #'comp-gen-counter) :type function
:documentation "Counter to create ssa limple vars.")
(has-non-local nil :type boolean
- :documentation "t if non local jumps are present."))
+ :documentation "t if non local jumps are present.")
+ (array-h (make-hash-table) :type hash-table
+ :documentation "array idx -> array length."))
(defun comp-func-reset-generators (func)
"Reset unique id generators for FUNC."
"A meta-variable being a slot in the meta-stack."
(slot nil :type (or fixnum symbol)
:documentation "Slot number if a number or 'scratch' for scratch slot.")
+ (array-idx 0 :type fixnum
+ :documentation "Array index.")
(id nil :type (or null number)
:documentation "SSA number when in SSA form.")
(const-vld nil :type boolean
(type nil
:documentation "When non nil indicates the type when known at compile
time.")
- (ref nil :type boolean
- :documentation "When non nil the m-var is involved in a
- call where is passed by reference.")
(impure nil :type boolean
:documentation "When non nil can't be copied into pure space."))
(comp-byte-frame-size (comp-func-byte-func func))))
(setf (comp-ctxt-top-level-forms comp-ctxt)
(list (make-byte-to-native-function :name function-name)))
+ ;; Create the default array.
+ (puthash 0 (comp-func-frame-size func) (comp-func-array-h func))
(list func))))
(cl-defgeneric comp-spill-lap-function ((filename string))
:args (comp-decrypt-arg-list (aref data 0) name)
:lap (alist-get name byte-to-native-lap)
:frame-size (comp-byte-frame-size data))
- do (comp-log (format "Function %s:\n" name) 1)
+ do
+ ;; Create the default array.
+ (puthash 0 (comp-func-frame-size func) (comp-func-array-h func))
+ (comp-log (format "Function %s:\n" name) 1)
(comp-log lap 1)
collect func))
(comp-emit `(set-par-to-local ,(comp-slot-n 0) 0))
(mapc #'comp-emit-for-top-level (comp-ctxt-top-level-forms comp-ctxt))
(comp-emit `(return ,(make-comp-mvar :constant t)))
+ (puthash 0 (comp-func-frame-size func) (comp-func-array-h func))
(comp-limplify-finalize-function func)))
(defun comp-addr-to-bb-name (addr)
(copy-comp-mvar insn)
insn)))
-(defun comp-basic-const-propagate ()
- "Propagate simple constants for setimm operands.
-This can run just once."
+(defun comp-ref-args-to-array (args)
+ "Given ARGS assign them to a dedicated array."
+ (when (and args
+ ;; Never rename an already renamed array index.
+ (= (comp-mvar-array-idx (car args)) 0))
+ (cl-loop with array-h = (comp-func-array-h comp-func)
+ with arr-idx = (hash-table-count array-h)
+ for i from 0
+ for arg in args
+ initially
+ (puthash arr-idx (length args) array-h)
+ do
+ ;; Just check that all args have zeroed arr-idx.
+ ;; (arrays must be used once).
+ (cl-assert (= (comp-mvar-array-idx arg) 0))
+ (setf (comp-mvar-slot arg) i)
+ (setf (comp-mvar-array-idx arg) arr-idx))))
+
+(defun comp-propagate-once ()
+ "Prologue for the propagate pass.
+Here goes everything that can be done not iteratively (read once).
+- Forward propagate immediate involed in assignments
+- Backward propagate placement into arrays"
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
do (cl-loop
for insn in (comp-block-insns b)
do (pcase insn
+ (`(set ,_lval (,(or 'callref 'direct-callref) ,_f . ,args))
+ (comp-ref-args-to-array args))
+ (`(,(or 'callref 'direct-callref) ,_f . ,args)
+ (comp-ref-args-to-array args))
(`(setimm ,lval ,_ ,v)
(setf (comp-mvar-const-vld lval) t
(comp-mvar-constant lval) v
(_
(comp-mvar-propagate lval rval))))
(`(phi ,lval . ,rest)
- ;; Const prop here.
+ ;; Forward const prop here.
(when-let* ((vld (cl-every #'comp-mvar-const-vld rest))
(consts (mapcar #'comp-mvar-constant rest))
(x (car consts))
(equals (cl-every (lambda (y) (equal x y)) consts)))
(setf (comp-mvar-constant lval) x))
- ;; Type propagation.
+ ;; Forward type propagation.
;; FIXME: checking for type equality is not sufficient cause does not
;; account type hierarchy!
(when-let* ((types (mapcar #'comp-mvar-type rest))
(x (car types))
(eqs (cl-every (lambda (y) (eq x y)) types)))
(setf (comp-mvar-type lval) x))
- ;; Reference propagation.
- (let ((operands (cons lval rest)))
- (when (cl-some #'comp-mvar-ref operands)
- (mapc (lambda (x) (setf (comp-mvar-ref x) t)) operands))))))
+ ;; Backward propagate array index and slot.
+ (let ((arr-idx (comp-mvar-array-idx lval)))
+ (when (> arr-idx 0)
+ (cl-loop with slot = (comp-mvar-slot lval)
+ for arg in rest
+ do
+ (setf (comp-mvar-array-idx arg) arr-idx)
+ (setf (comp-mvar-slot arg) slot)))))))
(defun comp-propagate* ()
"Propagate for set* and phi operands.
;; FIXME remove the following condition when tested.
(unless (comp-func-has-non-local f)
(let ((comp-func f))
- (comp-basic-const-propagate)
+ (comp-propagate-once)
(cl-loop
for i from 1
while (comp-propagate*)
(cl-flet ((fill-args (args total)
;; Fill missing args to reach TOTAL
(append args (cl-loop repeat (- total (length args))
- collect (make-comp-mvar :constant nil))))
- (clean-args-ref (args)
- ;; Clean-up the ref slot in all args
- (mapc (lambda (arg)
- (setf (comp-mvar-ref arg) nil))
- args)
- args))
+ collect (make-comp-mvar :constant nil)))))
(when (and (symbolp callee) ; Do nothing if callee is a byte compiled func.
(not (memq callee comp-never-optimize-functions)))
(let* ((f (symbol-function callee))
(args (if (eq call-type 'callref)
args
(fill-args args maxarg))))
- `(,call-type ,callee ,@(clean-args-ref args))))
+ `(,call-type ,callee ,@args)))
;; Intra compilation unit procedure call optimization.
;; Attention speed 3 triggers that for non self calls too!!
((or (eq callee self)
(args (if (eq call-type 'direct-callref)
args
(fill-args args (comp-args-max func-args)))))
- `(,call-type ,callee ,@(clean-args-ref args))))
+ `(,call-type ,callee ,@args)))
((comp-type-hint-p callee)
`(call ,callee ,@args)))))))
gcc_jit_field *cast_union_as_lisp_obj_ptr;
gcc_jit_function *func; /* Current function being compiled. */
bool func_has_non_local; /* From comp-func has-non-local slot. */
- gcc_jit_block *block; /* Current basic block being compiled. */
- gcc_jit_lvalue **frame; /* Frame for the current function. */
gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */
+ gcc_jit_block *block; /* Current basic block being compiled. */
gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */
+ gcc_jit_lvalue ***arrays; /* Array index -> gcc_jit_lvalue **. */
gcc_jit_rvalue *most_positive_fixnum;
gcc_jit_rvalue *most_negative_fixnum;
gcc_jit_rvalue *one;
}
static gcc_jit_lvalue *
-get_slot (Lisp_Object mvar)
+emit_mvar_access (Lisp_Object mvar)
{
Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar);
"scratch");
return comp.scratch;
}
+
+ EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar));
EMACS_INT slot_n = XFIXNUM (mvar_slot);
- gcc_jit_lvalue **frame =
- /* Disable floating frame for functions with non local jumps.
- This is probably overkill cause we could do it just for blocks
- dominated by push-handler. */
- comp.func_has_non_local
- || (CALL1I (comp-mvar-ref, mvar) || SPEED < 2)
- ? comp.frame : comp.f_frame;
- return frame[slot_n];
+ if (comp.func_has_non_local || !SPEED)
+ return comp.arrays[arr_idx][slot_n];
+ else
+ {
+ if (arr_idx)
+ return comp.arrays[arr_idx][slot_n];
+ else
+ return comp.f_frame[slot_n];
+ }
}
static void
return emit_const_lisp_obj (constant, CALL1I (comp-mvar-impure, mvar));
}
- return gcc_jit_lvalue_as_rvalue (get_slot (mvar));
+ return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar));
}
static void
gcc_jit_block_add_assignment (
comp.block,
NULL,
- get_slot (dst_mvar),
+ emit_mvar_access (dst_mvar),
val);
}
Lisp_Object callee = FIRST (insn);
EMACS_INT nargs = XFIXNUM (Flength (CDR (insn)));
- EMACS_INT base_ptr = 0;
- if (nargs)
- base_ptr = XFIXNUM (CALL1I (comp-mvar-slot, SECOND (insn)));
- return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct);
+
+ if (!nargs)
+ return emit_call_ref (callee,
+ nargs,
+ comp.arrays[0][0],
+ direct);
+
+ Lisp_Object first_arg = SECOND (insn);
+ Lisp_Object arr_idx = CALL1I (comp-mvar-array-idx, first_arg);
+
+ /* Make sure all the arguments are layout-ed into the same array. */
+ Lisp_Object p = XCDR (XCDR (insn));
+ FOR_EACH_TAIL (p)
+ if (!EQ (arr_idx, CALL1I (comp-mvar-array-idx, XCAR (p))))
+ xsignal2 (Qnative_ice, build_string ("incoherent array idx for insn"),
+ insn);
+
+ EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg));
+ return emit_call_ref (callee,
+ nargs,
+ comp.arrays[XFIXNUM (arr_idx)][first_slot],
+ direct);
}
/* Register an handler for a non local exit. */
comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func));
- gcc_jit_lvalue *frame_array =
- gcc_jit_function_new_local (
- comp.func,
- NULL,
- gcc_jit_context_new_array_type (comp.ctxt,
- NULL,
- comp.lisp_obj_type,
- frame_size),
- "local");
- comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame));
- for (EMACS_INT i = 0; i < frame_size; ++i)
- comp.frame[i] =
- gcc_jit_context_new_array_access (
- comp.ctxt,
- NULL,
- gcc_jit_lvalue_as_rvalue (frame_array),
- gcc_jit_context_new_rvalue_from_int (comp.ctxt,
- comp.int_type,
- i));
+ struct Lisp_Hash_Table *array_h =
+ XHASH_TABLE (CALL1I (comp-func-array-h, func));
+ comp.arrays = SAFE_ALLOCA (array_h->count * sizeof (*comp.arrays));
+ for (ptrdiff_t i = 0; i < array_h->count; i++)
+ {
+ EMACS_INT array_len = XFIXNUM (HASH_VALUE (array_h, i));
+ comp.arrays[i] = SAFE_ALLOCA (array_len * sizeof (**comp.arrays));
+
+ gcc_jit_lvalue *arr =
+ gcc_jit_function_new_local (
+ comp.func,
+ NULL,
+ gcc_jit_context_new_array_type (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ array_len),
+ format_string ("arr_%td", i));
+
+ for (ptrdiff_t j = 0; j < array_len; j++)
+ comp.arrays[i][j] =
+ gcc_jit_context_new_array_access (
+ comp.ctxt,
+ NULL,
+ gcc_jit_lvalue_as_rvalue (arr),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.int_type,
+ j));
+ }
/*
- The floating frame is a copy of the normal frame that can be used to store
- locals if the are not going to be used in a nargs call.
- This has two advantages:
- - Enable gcc for better reordering (frame array is clobbered every time is
- passed as parameter being involved into an nargs function call).
- - Allow gcc to trigger other optimizations that are prevented by memory
- referencing.
+ The floating frame is a copy of the normal frame that can be used to store
+ locals if the are not going to be used in a nargs call.
+ This has two advantages:
+ - Enable gcc for better reordering (frame array is clobbered every time is
+ passed as parameter being involved into an nargs function call).
+ - Allow gcc to trigger other optimizations that are prevented by memory
+ referencing.
*/
if (SPEED >= 2)
{
build_string ("failing to compile function"),
CALL1I (comp-func-name, func),
build_string (err));
-
SAFE_FREE ();
}
projects / emacs.git / commitdiff