From 8107fc6d0ce15f7a3da13df9eb74d63ab00167a7 Mon Sep 17 00:00:00 2001
From: Andrea Corallo <andrea_corallo@yahoo.it>
Date: Mon, 8 Jul 2019 07:56:37 +0200
Subject: [PATCH] add SSA

---
 lisp/emacs-lisp/comp.el |  86 +++++++++++++------------
 test/src/comp-tests.el  | 135 ++++++++++++++--------------------------
 2 files changed, 94 insertions(+), 127 deletions(-)

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 8ed75e0a4b3..a51b993c654 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -59,10 +59,14 @@
    :documentation "Byte compiled version")
   (ir nil
       :documentation "Current intermediate rappresentation")
-  (args nil :type 'comp-args))
+  (args nil :type 'comp-args)
+  (limple-cnt -1 :type 'number
+              :documentation "Counter to create ssa limple vars"))
 
-(cl-defstruct (comp-mvar (:copier nil))
+(cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar))
   "A meta-variable being a slot in the meta-stack."
+  (n nil :type number
+     :documentation "SSA number")
   (slot nil :type fixnum
         :documentation "Slot position")
   (const-vld nil
@@ -73,6 +77,11 @@
   (type nil
         :documentation "When non nil is used for type propagation"))
 
+(cl-defun make-comp-mvar (func &key slot const-vld constant type)
+  (make--comp-mvar :n (cl-incf (comp-func-limple-cnt func))
+                   :slot slot :const-vld const-vld :constant constant
+                   :type type))
+
 (cl-defstruct (comp-limple-frame (:copier nil))
   "A LIMPLE func."
   (sp 0 :type 'fixnum
@@ -86,17 +95,24 @@
                   :mandatory (logand x 127)
                   :nonrest (ash x -8)))
 
-(defun comp-recuparate-lap (ir)
-  "Byte compile and recuparate LAP rapresentation for IR."
+(defun comp-recuparate-lap (func)
+  "Byte compile and recuparate LAP rapresentation for FUNC."
   ;; FIXME block timers here, otherwise we could spill the wrong LAP.
-  (setf (comp-func-byte-func ir)
-        (byte-compile (comp-func-symbol-name ir)))
+  (setf (comp-func-byte-func func)
+        (byte-compile (comp-func-symbol-name func)))
   (when comp-debug
     (cl-prettyprint byte-compile-lap-output))
-  (setf (comp-func-args ir)
-        (comp-decrypt-lambda-list (aref (comp-func-byte-func ir) 0)))
-  (setf (comp-func-ir ir) byte-compile-lap-output)
-  ir)
+  (setf (comp-func-args func)
+        (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0)))
+  (setf (comp-func-ir func) byte-compile-lap-output)
+  func)
+
+;; (defun comp-opt-call (inst)
+;;   "Optimize if possible a side-effect-free call in INST."
+;;   (cl-destructuring-bind (_ f &rest args) inst
+;;     (when (and (member f comp-mostly-pure-funcs)
+;;                (cl-every #'identity (mapcar #'comp-mvar-const-vld args)))
+;;       (apply f (mapcar #'comp-mvar-constant args)))))
 
 (defmacro comp-sp ()
   "Current stack pointer."
@@ -114,19 +130,13 @@
   "Slot into the meta-stack pointed by sp + 1."
   '(comp-slot-n (1+ (comp-sp))))
 
-;; (defun comp-opt-call (inst)
-;;   "Optimize if possible a side-effect-free call in INST."
-;;   (cl-destructuring-bind (_ f &rest args) inst
-;;     (when (and (member f comp-mostly-pure-funcs)
-;;                (cl-every #'identity (mapcar #'comp-mvar-const-vld args)))
-;;       (apply f (mapcar #'comp-mvar-constant args)))))
-
 (defmacro comp-push-call (x)
   "Push call X into frame."
   `(let ((src-slot ,x))
      (cl-incf (comp-sp))
      (setf (comp-slot)
-           (make-comp-mvar :slot (comp-sp)
+           (make-comp-mvar func
+                           :slot (comp-sp)
                            :type (alist-get (second src-slot)
                                             comp-known-ret-types)))
      (push (list '=call (comp-slot) src-slot) ir)))
@@ -145,7 +155,8 @@
 X value is known at compile time."
   `(let ((val ,x))
      (cl-incf (comp-sp))
-     (setf (comp-slot) (make-comp-mvar :slot (comp-sp)
+     (setf (comp-slot) (make-comp-mvar func
+                                       :slot (comp-sp)
                                        :const-vld t
                                        :constant val))
      (push (list '=const (comp-slot) val) ir)))
@@ -154,9 +165,9 @@ X value is known at compile time."
   "Pop N elements from the meta-stack."
   `(cl-decf (comp-sp) ,n))
 
-(defun comp-limplify-lap-inst (inst frame ir)
-  "Limplify LAP instruction INST in current FRAME accumulating in IR.
-Return the new head."
+(defun comp-limplify-lap-inst (inst frame ir func)
+  "Limplify LAP instruction INST in current FRAME accumulating in IR for current
+ FUNC."
   (cl-flet ((do-list (n)
                (comp-pop 1)
                (comp-push-call `(call Fcons ,(comp-slot-next) nil))
@@ -197,31 +208,28 @@ Return the new head."
         (_ (error "Unexpected LAP op %s" (symbol-name op))))))
   ir)
 
-(defun comp-limplify (ir)
-  "Given IR and return LIMPLE."
-  (let* ((frame-size (aref (comp-func-byte-func ir) 3))
+(defun comp-limplify (func)
+  "Given FUNC and return LIMPLE."
+  (let* ((frame-size (aref (comp-func-byte-func func) 3))
          (frame (make-comp-limple-frame
                  :sp -1
-                 :frame (let ((v (make-vector frame-size nil)))
-                          (cl-loop for i below frame-size
-                                   do (aset v i (make-comp-mvar :slot i)))
-                          v)))
+                 :frame (make-vector frame-size nil)))
          (limple-ir ()))
     ;; Prologue
     (push '(BLOCK prologue) limple-ir)
-    (cl-loop for i below (comp-args-mandatory (comp-func-args ir))
+    (cl-loop for i below (comp-args-mandatory (comp-func-args func))
              do (progn
                   (cl-incf (comp-sp))
                   (push `(=par ,(comp-slot) ,i) limple-ir)))
     (push '(BLOCK body) limple-ir)
     (mapc (lambda (inst)
-            (setq limple-ir (comp-limplify-lap-inst inst frame limple-ir)))
-          (comp-func-ir ir))
+            (setq limple-ir (comp-limplify-lap-inst inst frame limple-ir func)))
+          (comp-func-ir func))
     (setq limple-ir (reverse limple-ir))
-    (setf (comp-func-ir ir) limple-ir)
+    (setf (comp-func-ir func) limple-ir)
     (when comp-debug
-      (cl-prettyprint (comp-func-ir ir)))
-    ir))
+      (cl-prettyprint (comp-func-ir func)))
+    func))
 
 (defun native-compile (fun)
   "FUN is the function definition to be compiled to native code."
@@ -231,11 +239,11 @@ Return the new head."
       (progn
         (when (byte-code-function-p f)
           (error "Can't native compile an already bytecompiled function"))
-        (cl-loop with ir = (make-comp-func :symbol-name fun
-                                           :func f)
+        (cl-loop with func = (make-comp-func :symbol-name fun
+                                             :func f)
                  for pass in comp-passes
-                 do (funcall pass ir)
-                 finally return ir))
+                 do (funcall pass func)
+                 finally return func))
     (error "Trying to native compile not a function")))
 
 (provide 'comp)
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index b6a8904347f..421f77008a4 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -31,13 +31,16 @@
 
 (defvar comp-tests-var1 3)
 
+(defun comp-test-compile (f)
+  ;; (byte-compile f)
+  (native-compile f))
+
 (ert-deftest  comp-tests-varref ()
   "Testing varref."
   (defun comp-tests-varref-f ()
     comp-tests-var1)
 
-  (byte-compile #'comp-tests-varref-f)
-  (native-compile #'comp-tests-varref-f)
+  (comp-test-compile #'comp-tests-varref-f)
 
   (should (= (comp-tests-varref-f) 3)))
 
@@ -58,16 +61,11 @@
     ;; Bcdr_safe
     (cdr-safe x))
 
-  (byte-compile #'comp-tests-list-f)
-  (native-compile #'comp-tests-list-f)
-  (byte-compile #'comp-tests-car-f)
-  (native-compile #'comp-tests-car-f)
-  (byte-compile #'comp-tests-cdr-f)
-  (native-compile #'comp-tests-cdr-f)
-  (byte-compile #'comp-tests-car-safe-f)
-  (native-compile #'comp-tests-car-safe-f)
-  (byte-compile #'comp-tests-cdr-safe-f)
-  (native-compile #'comp-tests-cdr-safe-f)
+  (comp-test-compile #'comp-tests-list-f)
+  (comp-test-compile #'comp-tests-car-f)
+  (comp-test-compile #'comp-tests-cdr-f)
+  (comp-test-compile #'comp-tests-car-safe-f)
+  (comp-test-compile #'comp-tests-cdr-safe-f)
 
   (should (equal (comp-tests-list-f) '(1 2 3)))
   (should (= (comp-tests-car-f '(1 . 2)) 1))
@@ -91,13 +89,11 @@
   "Testing cons car cdr."
   (defun comp-tests-cons-car-f ()
     (car (cons 1 2)))
-  (byte-compile #'comp-tests-cons-car-f)
-  (native-compile #'comp-tests-cons-car-f)
+  (comp-test-compile #'comp-tests-cons-car-f)
 
   (defun comp-tests-cons-cdr-f (x)
     (cdr (cons 'foo x)))
-  (byte-compile #'comp-tests-cons-cdr-f)
-  (native-compile #'comp-tests-cons-cdr-f)
+  (comp-test-compile #'comp-tests-cons-cdr-f)
 
   (should (= (comp-tests-cons-car-f) 1))
   (should (= (comp-tests-cons-cdr-f 3) 3)))
@@ -106,8 +102,7 @@
   "Testing varset."
   (defun comp-tests-varset-f ()
       (setq comp-tests-var1 55))
-  (byte-compile #'comp-tests-varset-f)
-  (native-compile #'comp-tests-varset-f)
+  (comp-test-compile #'comp-tests-varset-f)
   (comp-tests-varset-f)
 
   (should (= comp-tests-var1 55)))
@@ -116,8 +111,7 @@
   "Testing length."
   (defun comp-tests-length-f ()
       (length '(1 2 3)))
-  (byte-compile #'comp-tests-length-f)
-  (native-compile #'comp-tests-length-f)
+  (comp-test-compile #'comp-tests-length-f)
 
   (should (= (comp-tests-length-f) 3)))
 
@@ -127,8 +121,7 @@
     (let ((vec [1 2 3]))
       (aset vec 2 100)
       (aref vec 2)))
-  (byte-compile #'comp-tests-aref-aset-f)
-  (native-compile #'comp-tests-aref-aset-f)
+  (comp-test-compile #'comp-tests-aref-aset-f)
 
   (should (= (comp-tests-aref-aset-f) 100)))
 
@@ -137,8 +130,7 @@
   (defvar comp-tests-var2 3)
   (defun comp-tests-symbol-value-f ()
     (symbol-value 'comp-tests-var2))
-  (byte-compile #'comp-tests-symbol-value-f)
-  (native-compile #'comp-tests-symbol-value-f)
+  (comp-test-compile #'comp-tests-symbol-value-f)
 
   (should (= (comp-tests-symbol-value-f) 3)))
 
@@ -147,8 +139,7 @@
   (defun comp-tests-concat-f (x)
     (concat "a" "b" "c" "d"
             (concat "a" "b" "c" (concat "a" "b" (concat "foo" x)))))
-  (byte-compile #'comp-tests-concat-f)
-  (native-compile #'comp-tests-concat-f)
+  (comp-test-compile #'comp-tests-concat-f)
 
   (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar")))
 
@@ -159,15 +150,13 @@
   (defun comp-tests-ffuncall-caller-f ()
     (comp-tests-ffuncall-callee-f 1 2 3))
 
-  (byte-compile #'comp-tests-ffuncall-caller-f)
-  (native-compile #'comp-tests-ffuncall-caller-f)
+  (comp-test-compile #'comp-tests-ffuncall-caller-f)
 
   (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3)))
 
   (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d)
     (list a b c d))
-  (byte-compile #'comp-tests-ffuncall-callee-optional-f)
-  (native-compile #'comp-tests-ffuncall-callee-optional-f)
+  (comp-test-compile #'comp-tests-ffuncall-callee-optional-f)
 
   (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4)))
   (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil)))
@@ -175,8 +164,7 @@
 
   (defun comp-tests-ffuncall-callee-rest-f (a b &rest c)
     (list a b c))
-  (byte-compile #'comp-tests-ffuncall-callee-rest-f)
-  (native-compile #'comp-tests-ffuncall-callee-rest-f)
+  (comp-test-compile #'comp-tests-ffuncall-callee-rest-f)
 
   (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil)))
   (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3))))
@@ -186,8 +174,7 @@
     "Call a primitive with no dedicate op."
     (make-vector 1 nil))
 
-  (byte-compile #'comp-tests-ffuncall-native-f)
-  (native-compile #'comp-tests-ffuncall-native-f)
+  (comp-test-compile #'comp-tests-ffuncall-native-f)
 
   (should (equal (comp-tests-ffuncall-native-f) [nil]))
 
@@ -195,16 +182,14 @@
     "Call a primitive with no dedicate op with &rest."
     (vector 1 2 3))
 
-  (byte-compile #'comp-tests-ffuncall-native-rest-f)
-  (native-compile #'comp-tests-ffuncall-native-rest-f)
+  (comp-test-compile #'comp-tests-ffuncall-native-rest-f)
 
   (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3]))
 
   (defun comp-tests-ffuncall-apply-many-f (x)
     (apply #'list x))
 
-  (byte-compile #'comp-tests-ffuncall-apply-many-f)
-  (native-compile #'comp-tests-ffuncall-apply-many-f)
+  (comp-test-compile #'comp-tests-ffuncall-apply-many-f)
 
   (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3)))
 
@@ -213,8 +198,7 @@
                  (1+ x))))
       (funcall fun x)))
 
-  (byte-compile #'comp-tests-ffuncall-lambda-f)
-  (native-compile #'comp-tests-ffuncall-lambda-f)
+  (comp-test-compile #'comp-tests-ffuncall-lambda-f)
 
   (should (= (comp-tests-ffuncall-lambda-f 1) 2)))
 
@@ -226,8 +210,6 @@
       ('y 'b)
       (_ 'c)))
 
-  (byte-compile #'comp-tests-jump-table-1-f)
-  (byte-compile #'comp-tests-jump-table-1-f)
 
   (should (eq (comp-tests-jump-table-1-f 'x) 'a))
   (should (eq (comp-tests-jump-table-1-f 'y) 'b))
@@ -242,10 +224,8 @@
     ;; Generate goto-if-nil-else-pop
     (when x
         1340))
-  (byte-compile #'comp-tests-conditionals-1-f)
-  (byte-compile #'comp-tests-conditionals-2-f)
-  (native-compile #'comp-tests-conditionals-1-f)
-  (native-compile #'comp-tests-conditionals-2-f)
+  (comp-test-compile #'comp-tests-conditionals-1-f)
+  (comp-test-compile #'comp-tests-conditionals-2-f)
 
   (should (= (comp-tests-conditionals-1-f t) 1))
   (should (= (comp-tests-conditionals-1-f nil) 2))
@@ -264,12 +244,9 @@
     ;; Bnegate
     (- x))
 
-  (byte-compile #'comp-tests-fixnum-1-minus-f)
-  (byte-compile #'comp-tests-fixnum-1-plus-f)
-  (byte-compile #'comp-tests-fixnum-minus-f)
-  (native-compile #'comp-tests-fixnum-1-minus-f)
-  (native-compile #'comp-tests-fixnum-1-plus-f)
-  (native-compile #'comp-tests-fixnum-minus-f)
+  (comp-test-compile #'comp-tests-fixnum-1-minus-f)
+  (comp-test-compile #'comp-tests-fixnum-1-plus-f)
+  (comp-test-compile #'comp-tests-fixnum-minus-f)
 
   (should (= (comp-tests-fixnum-1-minus-f 10) 9))
   (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum)
@@ -311,17 +288,12 @@
     ;; Bgeq
     (>= x y))
 
-  (byte-compile #'comp-tests-eqlsign-f)
-  (byte-compile #'comp-tests-gtr-f)
-  (byte-compile #'comp-tests-lss-f)
-  (byte-compile #'comp-tests-les-f)
-  (byte-compile #'comp-tests-geq-f)
 
-  (native-compile #'comp-tests-eqlsign-f)
-  (native-compile #'comp-tests-gtr-f)
-  (native-compile #'comp-tests-lss-f)
-  (native-compile #'comp-tests-les-f)
-  (native-compile #'comp-tests-geq-f)
+  (comp-test-compile #'comp-tests-eqlsign-f)
+  (comp-test-compile #'comp-tests-gtr-f)
+  (comp-test-compile #'comp-tests-lss-f)
+  (comp-test-compile #'comp-tests-les-f)
+  (comp-test-compile #'comp-tests-geq-f)
 
   (should (eq (comp-tests-eqlsign-f 4 3) nil))
   (should (eq (comp-tests-eqlsign-f 3 3) t))
@@ -348,10 +320,8 @@
     (setcdr x y)
     x)
 
-  (byte-compile #'comp-tests-setcar-f)
-  (byte-compile #'comp-tests-setcdr-f)
-  (native-compile #'comp-tests-setcar-f)
-  (native-compile #'comp-tests-setcdr-f)
+  (comp-test-compile #'comp-tests-setcar-f)
+  (comp-test-compile #'comp-tests-setcdr-f)
 
   (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10)))
   (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3)))
@@ -380,8 +350,7 @@
         (setq i (1- i)))
       list))
 
-  (byte-compile #'comp-bubble-sort-f)
-  (native-compile #'comp-bubble-sort-f)
+  (comp-test-compile #'comp-bubble-sort-f)
 
   (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum)))
          (list2 (copy-sequence list1)))
@@ -397,10 +366,8 @@
     ;; Bsetcar
     (setcar x 3))
 
-  (byte-compile #'comp-tests-consp-f)
-  (native-compile #'comp-tests-consp-f)
-  (byte-compile #'comp-tests-car-f)
-  (native-compile #'comp-tests-car-f)
+  (comp-test-compile #'comp-tests-consp-f)
+  (comp-test-compile #'comp-tests-car-f)
 
   (should (eq (comp-tests-consp-f '(1)) t))
   (should (eq (comp-tests-consp-f 1) nil))
@@ -417,10 +384,8 @@
     ;; Bnumberp
     (numberp x))
 
-  (byte-compile #'comp-tests-integerp-f)
-  (native-compile #'comp-tests-integerp-f)
-  (byte-compile #'comp-tests-numberp-f)
-  (native-compile #'comp-tests-numberp-f)
+  (comp-test-compile #'comp-tests-integerp-f)
+  (comp-test-compile #'comp-tests-numberp-f)
 
   (should (eq (comp-tests-integerp-f 1) t))
   (should (eq (comp-tests-integerp-f '(1)) nil))
@@ -443,10 +408,8 @@
     ;; Binsert
     (insert a b c d))
 
-  (byte-compile #'comp-tests-discardn-f)
-  (native-compile #'comp-tests-discardn-f)
-  (byte-compile #'comp-tests-insertn-f)
-  (native-compile #'comp-tests-insertn-f)
+  (comp-test-compile #'comp-tests-discardn-f)
+  (comp-test-compile #'comp-tests-insertn-f)
 
   (should (= (comp-tests-discardn-f 10) 2))
 
@@ -493,14 +456,10 @@
   (defun comp-tests-throw-f (x)
     (throw 'foo x))
 
-  (byte-compile #'comp-tests-condition-case-0-f)
-  (native-compile #'comp-tests-condition-case-0-f)
-  (byte-compile #'comp-tests-condition-case-1-f)
-  (native-compile #'comp-tests-condition-case-1-f)
-  (byte-compile #'comp-tests-catch-f)
-  (native-compile #'comp-tests-catch-f)
-  (byte-compile #'comp-tests-throw-f)
-  (native-compile #'comp-tests-throw-f)
+  (comp-test-compile #'comp-tests-condition-case-0-f)
+  (comp-test-compile #'comp-tests-condition-case-1-f)
+  (comp-test-compile #'comp-tests-catch-f)
+  (comp-test-compile #'comp-tests-throw-f)
 
   (should (string= (comp-tests-condition-case-0-f)
                    "arith-error Arithmetic error catched"))
-- 
2.39.5