working on

lisp/emacs-lisp/comp.el

@@ -35,6 +35,8 @@
                         comp-limplify)
   "Passes to be executed in order.")
 
+(defconst comp-known-ret-types '((Fcons . cons)))
+
 (cl-defstruct comp-args
   mandatory nonrest rest)
 
@@ -50,12 +52,12 @@
       :documentation "Current intermediate rappresentation")
   (args nil :type 'comp-args))
 
-(cl-defstruct (comp-meta-var (:copier nil))
-  "A frame slot into the meta-stack."
+(cl-defstruct (comp-mvar (:copier nil))
+  "A meta-variable being a slot in the meta-stack."
   (slot nil :type fixnum
-        :documentation "Slot position into the meta-stack")
+        :documentation "Slot position")
   (const-vld nil
-             :documentation "Valid for the following slot")
+             :documentation "Valid signal for the following slot")
   (constant nil
             :documentation "When const-vld non nil this is used for constant
  propagation")
@@ -99,11 +101,19 @@
   "Current slot into the meta-stack pointed by sp."
   '(comp-slot-n (comp-sp)))
 
-(defmacro comp-push (x)
-  "Push X into frame."
-  `(progn
+(defmacro comp-slot-next ()
+  "Slot into the meta-stack pointed by sp + 1."
+  '(comp-slot-n (1+ (comp-sp))))
+
+(defmacro comp-push-call (x)
+  "Push call X into frame."
+  `(let ((src-slot ,x))
      (cl-incf (comp-sp))
-     (list '= (comp-slot) ,x)))
+     (setf (comp-slot)
+           (make-comp-mvar :slot (comp-sp)
+                           :type (alist-get (second src-slot)
+                                            comp-known-ret-types)))
+     (push (list '=call (comp-slot) src-slot) ir)))
 
 (defmacro comp-push-slot-n (n)
   "Push slot number N into frame."
@@ -111,44 +121,54 @@
      (cl-incf (comp-sp))
      (setf (comp-slot)
            (copy-sequence src-slot))
-     (setf (comp-meta-var-slot (comp-slot)) (comp-sp))
-     (list '=slot (comp-slot) src-slot)))
+     (setf (comp-mvar-slot (comp-slot)) (comp-sp))
+     (push (list '=slot (comp-slot) src-slot) ir)))
 
 (defmacro comp-push-const (x)
   "Push X into frame.
 X value is known at compile time."
-  `(progn
+  `(let ((val ,x))
      (cl-incf (comp-sp))
-     (setf (comp-slot) (make-comp-meta-var :slot (comp-sp)
+     (setf (comp-slot) (make-comp-mvar :slot (comp-sp)
                                            :const-vld t
-                                           :constant ,x))
-     (list '=const (comp-slot) ,x)))
+                                           :constant val))
+     (push (list '=const (comp-slot) val) ir)))
 
 (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."
+(defun comp-limplify-lap-inst (inst frame ir)
+  "Limplify LAP instruction INST in current FRAME accumulating in IR.
+Return the new head."
   (let ((op (car inst)))
     (pcase op
       ('byte-dup
        (comp-push-slot-n (comp-sp)))
       ('byte-varref
-       (comp-push `(call Fsymbol_value ,(second inst))))
+       (comp-push-call `(call Fsymbol_value ,(second inst))))
       ('byte-constant
        (comp-push-const (second inst)))
       ('byte-stack-ref
        (comp-push-slot-n (- (comp-sp) (cdr inst))))
       ('byte-plus
        (comp-pop 2)
-       (comp-push `(callref Fplus 2 ,(comp-sp))))
+       (comp-push-call `(callref Fplus 2 ,(comp-sp))))
       ('byte-car
        (comp-pop 1)
-       (comp-push `(Fcar ,(comp-sp))))
+       (comp-push-call `(call Fcar ,(comp-sp))))
+      ('byte-list3
+       (comp-pop 1)
+       (comp-push-call `(call Fcons ,(comp-slot-next) nil))
+       (dotimes (_ 1)
+         (comp-pop 2)
+         (comp-push-call `(call Fcons
+                                ,(comp-slot)
+                                ,(comp-slot-next)))))
       ('byte-return
        `(return ,(comp-slot)))
-      (_ 'xxx))))
+      (_ (error "Unexpected LAP op %s" (symbol-name op)))))
+  ir)
 
 (defun comp-limplify (ir)
   "Given IR and return LIMPLE."
@@ -157,7 +177,7 @@ X value is known at compile time."
                  :sp -1
                  :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)))
+                                   do (aset v i (make-comp-mvar :slot i)))
                           v)))
          (limple-ir ()))
     ;; Prologue
@@ -167,8 +187,9 @@ X value is known at compile time."
                   (cl-incf (comp-sp))
                   (push `(=par ,(comp-slot) ,i) limple-ir)))
     (push '(BLOCK body) limple-ir)
-    (cl-loop for inst in (comp-func-ir ir)
-             do (push (comp-limplify-lap-inst inst frame) limple-ir))
+    (mapc (lambda (inst)
+            (setq limple-ir (comp-limplify-lap-inst inst frame limple-ir)))
+          (comp-func-ir ir))
     (setq limple-ir (reverse limple-ir))
     (setf (comp-func-ir ir) limple-ir)
     (when comp-debug