working on comp.el

lisp/emacs-lisp/comp.el

@@ -22,27 +22,156 @@
 
 ;;; Code:
 
-(require 'disass)
+(require 'bytecomp)
 (eval-when-compile (require 'cl-lib))
 
 (defgroup comp nil
   "Emacs Lisp native compiler."
   :group 'lisp)
 
-(defun comp-recuparate-lap (fun)
-  "Compile FUN if necessary and recuparate its LAP rapresentation."
-  (byte-compile-close-variables
-   (byte-compile-top-level (byte-compile-preprocess fun))
-   byte-compile-lap-output))
+(defconst comp-debug t)
 
-(defun comp-compute-blocks (obj)
-  "Split OBJ in basic blocks."
-  obj)
+(defconst comp-passes '(comp-recuparate-lap
+                        comp-limplify)
+  "Passes to be executed in order.")
+
+(cl-defstruct comp-args
+  mandatory nonrest rest)
+
+(cl-defstruct (comp-func (:copier nil))
+  "Internal rapresentation for a function."
+  (symbol-name nil
+   :documentation "Function symbol's name")
+  (func nil
+   :documentation "Original form")
+  (byte-func nil
+   :documentation "Byte compiled version")
+  (ir nil
+      :documentation "Current intermediate rappresentation")
+  (args nil :type 'comp-args))
+
+(cl-defstruct (comp-meta-var (:copier nil))
+  "A frame slot into the meta-stack."
+  (slot nil :type fixnum
+        :documentation "Slot position into the meta-stack")
+  (const-vld nil
+             :documentation "Valid for the following slot")
+  (constant nil
+            :documentation "When const-vld non nil this is used for constant
+ propagation")
+  (type nil
+        :documentation "When non nil is used for type propagation"))
+
+(cl-defstruct (comp-limple-frame (:copier nil))
+  "A LIMPLE func."
+  (sp 0 :type 'fixnum
+      :documentation "Current stack pointer")
+  (frame nil :type 'vector
+         :documentation "Meta-stack used to flat LAP"))
+
+(defun comp-decrypt-lambda-list (x)
+  "Decript lambda list X."
+  (make-comp-args :rest (not (= (logand x 128) 0))
+                  :mandatory (logand x 127)
+                  :nonrest (ash x -8)))
+
+(defun comp-recuparate-lap (ir)
+  "Byte compile and recuparate LAP rapresentation for IR."
+  ;; FIXME block timers here, otherwise we could spill the wrong LAP.
+  (setf (comp-func-byte-func ir)
+        (byte-compile (comp-func-symbol-name ir)))
+  (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)
+
+(defmacro comp-sp ()
+  "Current stack pointer."
+  '(comp-limple-frame-sp frame))
+
+(defmacro comp-slot ()
+  "Current slot into the meta-stack pointed by sp."
+  '(aref (comp-limple-frame-frame frame) (comp-sp)))
+
+(defmacro comp-push (n)
+  "Push slot number N into frame."
+  `(progn
+     (cl-incf (comp-sp))
+     (list '= (comp-slot) ,n)))
+
+(defmacro comp-push-slot (n)
+  "Push slot number N into frame."
+  `(let ((src-slot (aref (comp-limple-frame-frame frame) ,n)))
+     (cl-incf (comp-sp))
+     (setf (comp-slot)
+           (copy-sequence src-slot))
+     (setf (comp-meta-var-slot (comp-slot)) (comp-sp))
+     (list '= (comp-slot) src-slot)))
+
+(defmacro comp-push-const (x)
+  "Push X into frame.
+X value is known at compile time."
+  `(progn
+     (cl-incf (comp-sp))
+     (setf (comp-slot) (make-comp-meta-var :slot (comp-sp)
+                                           :const-vld t
+                                           :constant ,x))
+     (list '= (comp-slot) ,x)))
+
+(defmacro comp-pop (n)
+  "Pop N elements from the meta-stack."
+  `(cl-decf (comp-sp) ,n))
+
+(defun comp-limplify-lap-inst (inst frame)
+  "Limplify LAP instruction INST in current FRAME."
+  (let ((op (car inst)))
+    (pcase op
+      ('byte-varref
+       (comp-push `(call Fsymbol_value ,(second inst))))
+      ('byte-constant
+       (comp-push-const (second inst)))
+      ('byte-stack-ref
+       (comp-push-slot (- (comp-sp) (cdr inst))))
+      ('byte-plus
+       (comp-pop 2)
+       (comp-push `(callref Fplus 2 ,(comp-sp))))
+      ('byte-return
+       `(return ,(comp-sp)))
+      (_ 'xxx))))
+
+(defun comp-limplify (ir)
+  "Take IR and return LIMPLE."
+  (let* ((frame-size (aref (comp-func-byte-func ir) 3))
+         (frame (make-comp-limple-frame
+                 :sp (1- (comp-args-mandatory (comp-func-args ir)))
+                 :frame (let ((v (make-vector frame-size nil)))
+                          (cl-loop for i below frame-size
+                                   do (aset v i (make-comp-meta-var :slot i)))
+                          v)))
+         (limple-ir
+          (cl-loop
+           for inst in (comp-func-ir ir)
+           collect (comp-limplify-lap-inst inst frame))))
+    (setf (comp-func-ir ir) limple-ir)
+    (when comp-debug
+      (cl-prettyprint (comp-func-ir ir)))
+    ir))
 
 (defun native-compile (fun)
   "FUN is the function definition to be compiled to native code."
+  (unless lexical-binding
+    (error "Can't compile a non lexical binded function"))
   (if-let ((f (symbol-function fun)))
-      (comp-recuparate-lap f)
+      (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)
+                 for pass in comp-passes
+                 do (funcall pass ir)
+                 finally return ir))
     (error "Trying to native compile not a function")))
 
 (provide 'comp)