From ba8ca065a7cde2f8221767ddb632b56eeefb29b5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 13 Jul 2019 16:34:59 +0200 Subject: [PATCH] let limple support calls with no assignment --- lisp/emacs-lisp/comp.el | 52 ++++++++++++----------- src/comp.c | 93 +++++++++++++++++++---------------------- 2 files changed, 70 insertions(+), 75 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 05f17e43d64..1094acf1ea3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -193,19 +193,23 @@ To be used when ncall-conv is nil.") "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) -(defun comp-emit-call (call) - "Emit CALL." +(defun comp-emit (x) + "Emit X into current LIMPLE ir.." + (push x comp-limple)) + +(defun comp-emit-set-call (call) + "Emit CALL assigning the result the the current slot frame.." (cl-assert call) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :type (alist-get (cadr call) comp-known-ret-types))) - (push (list 'set (comp-slot) call) comp-limple)) + (comp-emit (list 'set (comp-slot) call))) (defun comp-push-call (call) - "Push call CALL into frame." + "Increase sp and call `comp-emit-set-call' to emit CALL." (cl-incf (comp-sp)) - (comp-emit-call call)) + (comp-emit-set-call call)) (defun comp-push-slot-n (n) "Push slot number N into frame." @@ -215,11 +219,11 @@ To be used when ncall-conv is nil.") (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) - (push (list 'set (comp-slot) src-slot) comp-limple))) + (comp-emit (list 'set (comp-slot) src-slot)))) (defun comp-emit-annotation (str) "Emit annotation STR." - (push `(comment ,str) comp-limple)) + (comp-emit `(comment ,str))) (defun comp-push-const (val) "Push VAL into frame. @@ -228,7 +232,7 @@ VAL is known at compile time." (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t :constant val)) - (push (list 'setimm (comp-slot) val) comp-limple)) + (comp-emit (list 'setimm (comp-slot) val))) (defun comp-emit-block (bblock) "Push basic block BBLOCK." @@ -237,7 +241,7 @@ VAL is known at compile time." ;; This will be superseded by proper flow analysis. (setf (comp-limple-frame-frame comp-frame) (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) - (push `(block ,bblock) comp-limple)) + (comp-emit `(block ,bblock))) (defun comp-pop (n) "Pop N elements from the meta-stack." @@ -245,12 +249,12 @@ VAL is known at compile time." (defun comp-limplify-listn (n) "Limplify list N." - (comp-emit-call `(call Fcons ,(comp-slot) + (comp-emit-set-call `(call Fcons ,(comp-slot) ,(make-comp-mvar :const-vld t :constant nil))) (dotimes (_ (1- n)) (comp-pop 1) - (comp-emit-call `(call Fcons + (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-n (1+ (comp-sp))))))) @@ -265,31 +269,31 @@ VAL is known at compile time." :const-vld t :constant (cadr inst))))) ('byte-varset - (comp-emit-call `(call set_internal - ,(make-comp-mvar - :const-vld t - :constant (cadr inst)) - ,(comp-slot)))) + (comp-emit `(call set_internal + ,(make-comp-mvar + :const-vld t + :constant (cadr inst)) + ,(comp-slot)))) ('byte-constant (comp-push-const (cadr inst))) ('byte-stack-ref (comp-push-slot-n (- (comp-sp) (cdr inst)))) ('byte-plus (comp-pop 1) - (comp-emit-call `(callref Fplus 2 ,(comp-sp)))) + (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) ('byte-cons (comp-pop 1) - (comp-emit-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) + (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) ('byte-car - (comp-emit-call `(call Fcar ,(comp-slot)))) + (comp-emit-set-call `(call Fcar ,(comp-slot)))) ('byte-cdr - (comp-emit-call `(call Fcdr ,(comp-slot)))) + (comp-emit-set-call `(call Fcdr ,(comp-slot)))) ('byte-car-safe - (comp-emit-call `(call Fcar_safe ,(comp-slot)))) + (comp-emit-set-call `(call Fcar_safe ,(comp-slot)))) ('byte-cdr-safe - (comp-emit-call `(call Fcdr_safe ,(comp-slot)))) + (comp-emit-set-call `(call Fcdr_safe ,(comp-slot)))) ('byte-length - (comp-emit-call `(call Flength ,(comp-slot)))) + (comp-emit-set-call `(call Flength ,(comp-slot)))) ('byte-list1 (comp-limplify-listn 1)) ('byte-list2 @@ -299,7 +303,7 @@ VAL is known at compile time." ('byte-list4 (comp-limplify-listn 4)) ('byte-return - (push (list 'return (comp-slot)) comp-limple) + (comp-emit (list 'return (comp-slot))) `(return ,(comp-slot))) (_ (error "Unexpected LAP op %s" (symbol-name op)))))) diff --git a/src/comp.c b/src/comp.c index 25598aa20c1..f164bf892a5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -976,12 +976,10 @@ emit_limple_call (Lisp_Object arg1) if (calle[0] == 'F') { /* - Ex: (= #s(comp-mvar 6 1 nil nil nil) - (call Fcar #s(comp-mvar 4 0 nil nil nil))) + Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) - Ex: (= #s(comp-mvar 5 0 nil nil cons) - (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil))) + Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil)) */ ptrdiff_t nargs = list_length (call_args); @@ -994,10 +992,9 @@ emit_limple_call (Lisp_Object arg1) else if (!strcmp (calle, "set_internal")) { /* - Ex: (set #s(comp-mvar 8 1 nil nil nil) - (call set_internal - #s(comp-mvar 7 nil t xxx nil) - #s(comp-mvar 6 1 t 3 nil))) + Ex: (call set_internal + #s(comp-mvar 7 nil t xxx nil) + #s(comp-mvar 6 1 t 3 nil)) */ /* TODO: Inline the most common case. */ eassert (list_length (call_args) == 2); @@ -1008,14 +1005,26 @@ emit_limple_call (Lisp_Object arg1) gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - gcc_jit_block_add_eval ( - comp.block, - NULL, - emit_call ("set_internal", comp.void_type , 4, gcc_args)); - - return NULL; + return emit_call ("set_internal", comp.void_type , 4, gcc_args); } - error ("LIMPLE inconsiste call"); + error ("LIMPLE call is inconsistet"); +} + +static gcc_jit_rvalue * +emit_limple_call_ref (Lisp_Object arg1) +{ + /* Ex: (callref Fplus 2 0). */ + + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); + EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); + gcc_jit_rvalue *gcc_args[2] = + { gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + nargs), + gcc_jit_lvalue_get_address (comp.frame[base_ptr], NULL) }; + + return emit_call (calle, comp.lisp_obj_type, 2, gcc_args); } static void @@ -1032,53 +1041,35 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qjump)) { - /* Unconditional branch. */ + /* Unconditional branch. */ gcc_jit_block *target = retrive_block (arg0); gcc_jit_block_end_with_jump (comp.block, NULL, target); comp.block = target; } + else if (EQ (op, Qcall)) + { + gcc_jit_block_add_eval (comp.block, + NULL, + emit_limple_call (inst)); + } else if (EQ (op, Qset)) { EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); if (EQ (Ftype_of (arg1), Qcomp_mvar)) - { - /* - Ex: (= #s(comp-mvar 6 2 nil nil nil) - #s(comp-mvar 6 0 nil nil nil)). - */ - res = emit_mvar_val (arg1); - } + res = emit_mvar_val (arg1); else if (EQ (FIRST (arg1), Qcall)) - { - res = emit_limple_call (arg1); - } + res = emit_limple_call (arg1); else if (EQ (FIRST (arg1), Qcallref)) - { - /* Ex: (= #s(comp-mvar 10 1 nil nil nil) (callref Fplus 2 0)). */ - - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); - EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); - gcc_jit_rvalue *gcc_args[2] = - { gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - nargs), - gcc_jit_lvalue_get_address ( - comp.frame[base_ptr], - NULL) }; - res = emit_call (calle, comp.lisp_obj_type, 2, gcc_args); - } + res = emit_limple_call_ref (arg1); else - { - error ("LIMPLE inconsistent arg1 for op ="); - } - if (res) - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + error ("LIMPLE inconsistent arg1 for op ="); + eassert (res); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); } else if (EQ (op, Qsetpar)) { @@ -1105,7 +1096,7 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qcomment)) { - /* Ex: (comment "Function: foo"). */ + /* Ex: (comment "Function: foo"). */ emit_comment((char *) SDATA (arg0)); } else if (EQ (op, Qreturn)) -- 2.39.5