procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

let limple support calls with no assignment

Browse source
This commit is contained in:
Andrea Corallo 2019-07-13 16:34:59 +02:00 • committed by Andrea Corallo
parent 73cb29c3fb
commit ba8ca065a7
2 changed files with 70 additions and 75 deletions
Download patch file Download diff file Expand all files Collapse all files

52
lisp/emacs-lisp/comp.el
View file

@ -193,19 +193,23 @@ To be used when ncall-conv is nil.")
"Slot into the meta-stack pointed by sp + 1." "Slot into the meta-stack pointed by sp + 1."
'(comp-slot-n (1+ (comp-sp)))) '(comp-slot-n (1+ (comp-sp))))
(defun comp-emit-call (call) (defun comp-emit (x)
"Emit CALL." "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) (cl-assert call)
(setf (comp-slot) (setf (comp-slot)
(make-comp-mvar :slot (comp-sp) (make-comp-mvar :slot (comp-sp)
:type (alist-get (cadr call) :type (alist-get (cadr call)
comp-known-ret-types))) comp-known-ret-types)))
(push (list 'set (comp-slot) call) comp-limple)) (comp-emit (list 'set (comp-slot) call)))
(defun comp-push-call (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)) (cl-incf (comp-sp))
(comp-emit-call call)) (comp-emit-set-call call))
(defun comp-push-slot-n (n) (defun comp-push-slot-n (n)
"Push slot number N into frame." "Push slot number N into frame."
@ -215,11 +219,11 @@ To be used when ncall-conv is nil.")
(setf (comp-slot) (setf (comp-slot)
(copy-sequence src-slot)) (copy-sequence src-slot))
(setf (comp-mvar-slot (comp-slot)) (comp-sp)) (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) (defun comp-emit-annotation (str)
"Emit annotation STR." "Emit annotation STR."
(push `(comment ,str) comp-limple)) (comp-emit `(comment ,str)))
(defun comp-push-const (val) (defun comp-push-const (val)
"Push VAL into frame. "Push VAL into frame.
@ -228,7 +232,7 @@ VAL is known at compile time."
(setf (comp-slot) (make-comp-mvar :slot (comp-sp) (setf (comp-slot) (make-comp-mvar :slot (comp-sp)
:const-vld t :const-vld t
:constant val)) :constant val))
(push (list 'setimm (comp-slot) val) comp-limple)) (comp-emit (list 'setimm (comp-slot) val)))
(defun comp-emit-block (bblock) (defun comp-emit-block (bblock)
"Push basic block BBLOCK." "Push basic block BBLOCK."
@ -237,7 +241,7 @@ VAL is known at compile time."
;; This will be superseded by proper flow analysis. ;; This will be superseded by proper flow analysis.
(setf (comp-limple-frame-frame comp-frame) (setf (comp-limple-frame-frame comp-frame)
(comp-limple-frame-new-frame (comp-func-frame-size comp-func))) (comp-limple-frame-new-frame (comp-func-frame-size comp-func)))
(push `(block ,bblock) comp-limple)) (comp-emit `(block ,bblock)))
(defun comp-pop (n) (defun comp-pop (n)
"Pop N elements from the meta-stack." "Pop N elements from the meta-stack."
@ -245,12 +249,12 @@ VAL is known at compile time."
(defun comp-limplify-listn (n) (defun comp-limplify-listn (n)
"Limplify list 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 ,(make-comp-mvar :const-vld t
:constant nil))) :constant nil)))
(dotimes (_ (1- n)) (dotimes (_ (1- n))
(comp-pop 1) (comp-pop 1)
(comp-emit-call `(call Fcons (comp-emit-set-call `(call Fcons
,(comp-slot) ,(comp-slot)
,(comp-slot-n (1+ (comp-sp))))))) ,(comp-slot-n (1+ (comp-sp)))))))
@ -265,31 +269,31 @@ VAL is known at compile time."
:const-vld t :const-vld t
:constant (cadr inst))))) :constant (cadr inst)))))
('byte-varset ('byte-varset
(comp-emit-call `(call set_internal (comp-emit `(call set_internal
,(make-comp-mvar ,(make-comp-mvar
:const-vld t :const-vld t
:constant (cadr inst)) :constant (cadr inst))
,(comp-slot)))) ,(comp-slot))))
('byte-constant ('byte-constant
(comp-push-const (cadr inst))) (comp-push-const (cadr inst)))
('byte-stack-ref ('byte-stack-ref
(comp-push-slot-n (- (comp-sp) (cdr inst)))) (comp-push-slot-n (- (comp-sp) (cdr inst))))
('byte-plus ('byte-plus
(comp-pop 1) (comp-pop 1)
(comp-emit-call `(callref Fplus 2 ,(comp-sp)))) (comp-emit-set-call `(callref Fplus 2 ,(comp-sp))))
('byte-cons ('byte-cons
(comp-pop 1) (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 ('byte-car
(comp-emit-call `(call Fcar ,(comp-slot)))) (comp-emit-set-call `(call Fcar ,(comp-slot))))
('byte-cdr ('byte-cdr
(comp-emit-call `(call Fcdr ,(comp-slot)))) (comp-emit-set-call `(call Fcdr ,(comp-slot))))
('byte-car-safe ('byte-car-safe
(comp-emit-call `(call Fcar_safe ,(comp-slot)))) (comp-emit-set-call `(call Fcar_safe ,(comp-slot))))
('byte-cdr-safe ('byte-cdr-safe
(comp-emit-call `(call Fcdr_safe ,(comp-slot)))) (comp-emit-set-call `(call Fcdr_safe ,(comp-slot))))
('byte-length ('byte-length
(comp-emit-call `(call Flength ,(comp-slot)))) (comp-emit-set-call `(call Flength ,(comp-slot))))
('byte-list1 ('byte-list1
(comp-limplify-listn 1)) (comp-limplify-listn 1))
('byte-list2 ('byte-list2
@ -299,7 +303,7 @@ VAL is known at compile time."
('byte-list4 ('byte-list4
(comp-limplify-listn 4)) (comp-limplify-listn 4))
('byte-return ('byte-return
(push (list 'return (comp-slot)) comp-limple) (comp-emit (list 'return (comp-slot)))
`(return ,(comp-slot))) `(return ,(comp-slot)))
(_ (error "Unexpected LAP op %s" (symbol-name op)))))) (_ (error "Unexpected LAP op %s" (symbol-name op))))))

93
src/comp.c
View file

@ -976,12 +976,10 @@ emit_limple_call (Lisp_Object arg1)
if (calle[0] == 'F') if (calle[0] == 'F')
{ {
/* /*
Ex: (= #s(comp-mvar 6 1 nil nil nil) Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil))
(call Fcar #s(comp-mvar 4 0 nil nil nil)))
Ex: (= #s(comp-mvar 5 0 nil nil cons) Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil)
(call Fcons #s(comp-mvar 3 0 t 1 nil) #s(comp-mvar 4 nil t nil nil))
#s(comp-mvar 4 nil t nil nil)))
*/ */
ptrdiff_t nargs = list_length (call_args); ptrdiff_t nargs = list_length (call_args);
@ -994,10 +992,9 @@ emit_limple_call (Lisp_Object arg1)
else if (!strcmp (calle, "set_internal")) else if (!strcmp (calle, "set_internal"))
{ {
/* /*
Ex: (set #s(comp-mvar 8 1 nil nil nil) Ex: (call set_internal
(call set_internal #s(comp-mvar 7 nil t xxx nil)
#s(comp-mvar 7 nil t xxx nil) #s(comp-mvar 6 1 t 3 nil))
#s(comp-mvar 6 1 t 3 nil)))
*/ */
/* TODO: Inline the most common case. */ /* TODO: Inline the most common case. */
eassert (list_length (call_args) == 2); 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, gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
comp.int_type, comp.int_type,
SET_INTERNAL_SET); SET_INTERNAL_SET);
gcc_jit_block_add_eval ( return emit_call ("set_internal", comp.void_type , 4, gcc_args);
comp.block,
NULL,
emit_call ("set_internal", comp.void_type , 4, gcc_args));
return NULL;
} }
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 static void
@ -1032,53 +1041,35 @@ emit_limple_inst (Lisp_Object inst)
} }
else if (EQ (op, Qjump)) else if (EQ (op, Qjump))
{ {
/* Unconditional branch. */ /* Unconditional branch. */
gcc_jit_block *target = retrive_block (arg0); gcc_jit_block *target = retrive_block (arg0);
gcc_jit_block_end_with_jump (comp.block, NULL, target); gcc_jit_block_end_with_jump (comp.block, NULL, target);
comp.block = 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)) else if (EQ (op, Qset))
{ {
EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0));
Lisp_Object arg1 = THIRD (inst); Lisp_Object arg1 = THIRD (inst);
if (EQ (Ftype_of (arg1), Qcomp_mvar)) if (EQ (Ftype_of (arg1), Qcomp_mvar))
{ res = emit_mvar_val (arg1);
/*
Ex: (= #s(comp-mvar 6 2 nil nil nil)
#s(comp-mvar 6 0 nil nil nil)).
*/
res = emit_mvar_val (arg1);
}
else if (EQ (FIRST (arg1), Qcall)) else if (EQ (FIRST (arg1), Qcall))
{ res = emit_limple_call (arg1);
res = emit_limple_call (arg1);
}
else if (EQ (FIRST (arg1), Qcallref)) else if (EQ (FIRST (arg1), Qcallref))
{ res = emit_limple_call_ref (arg1);
/* 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);
}
else else
{ error ("LIMPLE inconsistent arg1 for op =");
error ("LIMPLE inconsistent arg1 for op ="); eassert (res);
} gcc_jit_block_add_assignment (comp.block,
if (res) NULL,
gcc_jit_block_add_assignment (comp.block, comp.frame[slot_n],
NULL, res);
comp.frame[slot_n],
res);
} }
else if (EQ (op, Qsetpar)) else if (EQ (op, Qsetpar))
{ {
@ -1105,7 +1096,7 @@ emit_limple_inst (Lisp_Object inst)
} }
else if (EQ (op, Qcomment)) else if (EQ (op, Qcomment))
{ {
/* Ex: (comment "Function: foo"). */ /* Ex: (comment "Function: foo"). */
emit_comment((char *) SDATA (arg0)); emit_comment((char *) SDATA (arg0));
} }
else if (EQ (op, Qreturn)) else if (EQ (op, Qreturn))