mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-30 17:10:51 -08:00
Code Issues Projects Releases Wiki Activity

some consistency rework one test +

Browse source
This commit is contained in:
Andrea Corallo 2019-07-13 11:33:15 +02:00 • committed by Andrea Corallo
parent 8f1492c0b7
commit 973a7b149f
2 changed files with 38 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -189,15 +189,19 @@ 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-push-call (src-slot) (defun comp-emit-call (call)
"Push call SRC-SLOT into frame." "Emit CALL."
(cl-assert src-slot) (cl-assert call)
(cl-incf (comp-sp))
(setf (comp-slot) (setf (comp-slot)
(make-comp-mvar :slot (comp-sp) (make-comp-mvar :slot (comp-sp)
:type (alist-get (cadr src-slot) :type (alist-get (cadr call)
comp-known-ret-types))) comp-known-ret-types)))
(push (list 'set (comp-slot) src-slot) comp-limple)) (push (list 'set (comp-slot) call) comp-limple))
(defun comp-push-call (call)
"Push call CALL into frame."
(cl-incf (comp-sp))
(comp-emit-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."
@ -222,7 +226,7 @@ VAL is known at compile time."
:constant val)) :constant val))
(push (list 'setimm (comp-slot) val) comp-limple)) (push (list 'setimm (comp-slot) val) comp-limple))
(defun comp-push-block (bblock) (defun comp-emit-block (bblock)
"Push basic block BBLOCK." "Push basic block BBLOCK."
(push bblock (comp-func-blocks comp-func)) (push bblock (comp-func-blocks comp-func))
;; Every new block we are forced to wipe out all the frame. ;; Every new block we are forced to wipe out all the frame.
@ -237,15 +241,14 @@ VAL is known at compile time."
(defun comp-limplify-listn (n) (defun comp-limplify-listn (n)
"Limplify list N." "Limplify list N."
(comp-pop 1) (comp-emit-call `(call Fcons ,(comp-slot)
(comp-push-call `(call Fcons ,(comp-slot-next)
,(make-comp-mvar :const-vld t ,(make-comp-mvar :const-vld t
:constant nil))) :constant nil)))
(dotimes (_ (1- n)) (dotimes (_ (1- n))
(comp-pop 2) (comp-pop 1)
(comp-push-call `(call Fcons (comp-emit-call `(call Fcons
,(comp-slot-next) ,(comp-slot)
,(comp-slot-n (+ 2 (comp-sp))))))) ,(comp-slot-n (1+ (comp-sp)))))))
(defun comp-limplify-lap-inst (inst) (defun comp-limplify-lap-inst (inst)
"Limplify LAP instruction INST accumulating in `comp-limple'." "Limplify LAP instruction INST accumulating in `comp-limple'."
@ -258,26 +261,25 @@ VAL is known at compile time."
:const-vld t :const-vld t
:constant (cadr inst))))) :constant (cadr inst)))))
;; ('byte-varset ;; ('byte-varset
;; (comp-push-call `(call Fsymbol_value ,(cadr inst)))) ;; (comp-emit-call `(call Fsymbol_value ,(cadr inst))))
('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 2) (comp-pop 1)
(comp-push-call `(callref Fplus 2 ,(comp-sp)))) (comp-emit-call `(callref Fplus 2 ,(comp-sp))))
('byte-cons
(comp-pop 1)
(comp-emit-call `(call Fcons ,(comp-slot) ,(comp-slot-next))))
('byte-car ('byte-car
(comp-pop 1) (comp-emit-call `(call Fcar ,(comp-slot))))
(comp-push-call `(call Fcar ,(comp-slot))))
('byte-cdr ('byte-cdr
(comp-pop 1) (comp-emit-call `(call Fcdr ,(comp-slot))))
(comp-push-call `(call Fcdr ,(comp-slot))))
('byte-car-safe ('byte-car-safe
(comp-pop 1) (comp-emit-call `(call Fcar_safe ,(comp-slot))))
(comp-push-call `(call Fcar_safe ,(comp-slot))))
('byte-cdr-safe ('byte-cdr-safe
(comp-pop 1) (comp-emit-call `(call Fcdr_safe ,(comp-slot))))
(comp-push-call `(call Fcdr_safe ,(comp-slot))))
('byte-list1 ('byte-list1
(comp-limplify-listn 1)) (comp-limplify-listn 1))
('byte-list2 ('byte-list2
@ -300,7 +302,7 @@ VAL is known at compile time."
:frame (comp-limple-frame-new-frame frame-size))) :frame (comp-limple-frame-new-frame frame-size)))
(comp-limple ())) (comp-limple ()))
;; Prologue ;; Prologue
(comp-push-block 'entry) (comp-emit-block 'entry)
(comp-emit-annotation (concat "Lisp function: " (comp-emit-annotation (concat "Lisp function: "
(symbol-name (comp-func-symbol-name func)))) (symbol-name (comp-func-symbol-name func))))
(cl-loop for i below (comp-args-mandatory (comp-func-args func)) (cl-loop for i below (comp-args-mandatory (comp-func-args func))
@ -309,7 +311,7 @@ VAL is known at compile time."
(push `(setpar ,(comp-slot) ,i) comp-limple))) (push `(setpar ,(comp-slot) ,i) comp-limple)))
(push '(jump body) comp-limple) (push '(jump body) comp-limple)
;; Body ;; Body
(comp-push-block 'body) (comp-emit-block 'body)
(mapc #'comp-limplify-lap-inst (comp-func-ir func)) (mapc #'comp-limplify-lap-inst (comp-func-ir func))
(setf (comp-func-ir func) (reverse comp-limple)) (setf (comp-func-ir func) (reverse comp-limple))
;; Prologue block must be first ;; Prologue block must be first

20
test/src/comp-tests.el
View file

@ -82,18 +82,18 @@
(should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2))
(should (null (comp-tests-cdr-safe-f 'a)))) (should (null (comp-tests-cdr-safe-f 'a))))
;; (ert-deftest comp-tests-cons-car-cdr () (ert-deftest comp-tests-cons-car-cdr ()
;; "Testing cons car cdr." "Testing cons car cdr."
;; (defun comp-tests-cons-car-f () (defun comp-tests-cons-car-f ()
;; (car (cons 1 2))) (car (cons 1 2)))
;; (native-compile #'comp-tests-cons-car-f) (native-compile #'comp-tests-cons-car-f)
;; (defun comp-tests-cons-cdr-f (x) (defun comp-tests-cons-cdr-f (x)
;; (cdr (cons 'foo x))) (cdr (cons 'foo x)))
;; (native-compile #'comp-tests-cons-cdr-f) (native-compile #'comp-tests-cons-cdr-f)
;; (should (= (comp-tests-cons-car-f) 1)) (should (= (comp-tests-cons-car-f) 1))
;; (should (= (comp-tests-cons-cdr-f 3) 3))) (should (= (comp-tests-cons-cdr-f 3) 3)))
;; (ert-deftest comp-tests-varset () ;; (ert-deftest comp-tests-varset ()
;; "Testing varset." ;; "Testing varset."