Make linking and final compile to byte sequence work

wip-duuqnd/user-side-compiler/backend/code-generator.lisp

@@ -2,11 +2,11 @@
 
 (defclass asm-object ()
   ((%source :accessor source :initarg :source :initform nil)
-   (%next :accessor next :initform nil)))
+   (%next :accessor next :initform nil)
+   (%address :accessor address :initform nil)))
 
 (defclass asm-label (asm-object)
-  ((%name :accessor name :initarg :name)
-   (%address :accessor address :initform nil)))
+  ((%name :accessor name :initarg :name)))
 
 (defclass asm-instruction (asm-object)
   ((%opcode :accessor opcode :initarg :opcode)
@@ -92,6 +92,7 @@
 (define-normal-emitter emit-lda #xa9 #xa5 #xad)
 (define-normal-emitter emit-sta (error "STA has no immediate mode.") #x85 #x8d)
 (define-normal-emitter emit-adc #x69 #x65 #x6d)
+(define-normal-emitter emit-cmp #xc9 #xc5 #xcd)
 
 (defun emit-store-data (data)
   (if (or (null (allocation-details data))
@@ -102,11 +103,27 @@
         (emit-sta :address (data-reference data))
         (setf *last-instruction* (list :store data)))))
 
+(defun emit-store-bool (data)
+  "Stores the inverse of the zeroflag to DATA. Inverse so that non-0 is TRUE."
+  ;; The "DATA is stored"-case
+  (if (or (null (allocation-details data))
+          (member (strategy (allocation-details data))
+                  '(:constant :accumulator)))
+      (setf *last-instruction* '(:useless))
+      (progn
+        (emit-asm-instruction :opcode :php :byte-length 1)
+        (emit-asm-instruction :opcode :pla :byte-length 1)
+        (emit-asm-instruction :opcode :and :operand #b00000010 :byte-length 2)
+        (emit-asm-instruction :opcode :lsr-a :byte-length 1)
+        (emit-asm-instruction :opcode :not :operand #b00000001 :byte-length 2)
+        (emit-sta :address (data-reference data))
+        (setf *last-instruction* '(:store-zero-flag data)))))
+
 (defun emit-load-data (data)
   (if (or (member (strategy (allocation-details data))
-                      '(:accumulator :direct-to-argvec))
-              (equal *last-instruction* (list :store data))
-              (equal *last-instruction* (list :load data)))
+                  '(:accumulator :direct-to-argvec))
+          (equal *last-instruction* (list :store data))
+          (equal *last-instruction* (list :load data)))
       (setf *last-instruction* '(:useless))
       (progn
         (if (eql (strategy (allocation-details data)) :constant)
@@ -114,6 +131,24 @@
             (emit-lda :address (data-reference data)))
         (setf *last-instruction* (list :load data)))))
 
+(defun emit-load-bool (data)
+  (if (or (member (strategy (allocation-details data))
+                  '(:accumulator))
+          (equal *last-instruction* (list :store-zero-flag data))
+          (equal *last-instruction* (list :load-zero-flag data)))
+      (setf *last-instruction* '(:useless))
+      (progn
+        (if (eql (strategy (allocation-details data)) :constant)
+            (progn
+              (emit-lda :immediate (ir-constant-value data))
+              (emit-asm-instruction :opcode :and :operand 1 :byte-length 1)
+              (emit-cmp :immediate 1))
+            (progn
+              (emit-lda :address (data-reference data))
+              (emit-asm-instruction :opcode :and :operand 1 :byte-length 1)
+              (emit-cmp :immediate 1)))
+        (setf *last-instruction* (list :load-zero-flag data)))))
+
 (defmethod compile-ir ((inst ir-inst))
   (warn "Skipped compiling ~A; no COMPILE-IR method" inst))
 
@@ -145,26 +180,119 @@
         :do (emit-load-data arg)
         :unless (eql (strategy (allocation-details arg)) :direct-to-argvec)
           :do (emit-sta :address (+ arg-index +argvec-offset+)))
-  (emit-asm-instruction :opcode #x20 :operand (callee inst) :byte-length 1)
+  (emit-asm-instruction :opcode #x20 :operand (callee inst) :byte-length 3)
   (emit-store-result (output inst)))
 
+(defmethod compile-ir ((inst ir-jump))
+  (unless (eql (next (iblock inst))
+               (first (destinations inst)))
+    (emit-asm-instruction :opcode #x4C
+                          :operand (first (destinations inst))
+                          :byte-length 3))
+  (setf *last-instruction* '(:jump)))
+
+(defmethod compile-ir ((inst ir-if))
+  (let ((next-iblock (next (iblock inst)))
+        (then-iblock (first (destinations inst)))
+        (else-iblock (second (destinations inst))))
+    ;; With how the midstage is built, the true case's block comes immediately
+    ;; after the IF, and therefore we should branch on false. This assert
+    ;; ensures that this assumption become false without us noticing.
+    ;; We implicitly fall through to THEN-BLOCK in the event of no branch.
+    (assert (eql next-iblock then-iblock))
+    (emit-load-bool (input inst))
+    (emit-asm-instruction :opcode #xD0
+                          :operand else-iblock
+                          :byte-length 2)
+    (setf *last-instruction* '(:conditional))))
+
+(defmethod compile-ir ((inst ir-test-equal))
+  (emit-load-data (first (inputs inst)))
+  (if (eql (strategy (allocation-details (second (inputs inst))))
+           :constant)
+      (emit-cmp :immediate (ir-constant-value (second (inputs inst))))
+      (emit-cmp :address (data-reference (second (inputs inst)))))
+  (emit-store-bool (output inst)))
+
+(defmacro do-asm-objects ((asm-obj start-asm-obj) &body body)
+  `(loop :for ,asm-obj := ,start-asm-obj :then (next ,asm-obj)
+         :until (null ,asm-obj)
+         :do (progn
+               ,@body)))
+
 (defun link-compute-addresses (start-instruction origin-address)
   "First linking pass, computes the addresses of all labels."
   (let ((address origin-address))
     (loop :for asm-obj := start-instruction :then (next asm-obj)
           :until (null asm-obj)
-          :do (cond ((typep asm-obj 'asm-label)
-                     (setf (address asm-obj) address))
-                    ((typep asm-obj 'asm-instruction)
-                     (incf address (byte-length asm-obj)))))
+          :do (setf (address asm-obj) address)
+          :when (typep asm-obj 'asm-instruction)
+            :do (incf address (byte-length asm-obj)))
     (values start-instruction address)))
 
+(defun link-resolve-references (start-instruction)
+  (flet ((resolve-iblock (asm-obj)
+           (setf (operand asm-obj)
+                 (multiple-value-bind (label existsp)
+                     (gethash (name (operand asm-obj))
+                              *asm-labels*)
+                   (unless existsp
+                     (error "Failed to resolve label ~A"
+                            (name (operand asm-obj))))
+                   label))))
+    (loop :for asm-obj := start-instruction :then (next asm-obj)
+          :until (null asm-obj)
+          :when (typep asm-obj 'asm-instruction)
+            :do (case (opcode asm-obj)
+                  ((#x10 #x30 #x50 #x70 #x90 #xb0 #xd0 #xf0)
+                   ;; Relative branches
+                   (when (typep (operand asm-obj) 'iblock)
+                     (resolve-iblock asm-obj))
+                   ;; - 2 is to offset for the branch instruction's length
+                   (let* ((offset (- (address (operand asm-obj)) (address asm-obj) 2)))
+                     (setf (operand asm-obj) (ldb (byte 8 0) (the (signed-byte 8) offset)))))
+                  (t
+                   (when (typep (operand asm-obj) 'iblock)
+                     (resolve-iblock asm-obj))
+                   (when (typep (operand asm-obj) 'asm-label)
+                     (setf (operand asm-obj) (address (operand asm-obj))))
+                   (when (typep (operand asm-obj) 'asm-function)
+                     (setf (operand asm-obj) (address (operand asm-obj)))))))))
+
 (defun link-assembly (start-instruction origin-address)
   (link-compute-addresses start-instruction origin-address)
-  ;; TODO: Second pass, replacing labels with their addresses, both for
-  ;; constant labels such as assembly routines and for generated labels.
-  ;;(values start-instruction address)
-  )
+  ;; TODO: Branch correction
+  (link-resolve-references start-instruction)
+  start-instruction)
+
+(defun compile-iblock (iblock)
+  (emit-asm-label (unique-name iblock))
+  (do-instructions (inst iblock)
+    (compile-ir inst)))
+
+(defun compile-iblocks (start-iblock)
+  (let ((*asm-head* nil)
+        (*asm-foot* nil)
+        (*asm-labels* (make-hash-table :test #'equal)))
+    (do-iblocks (iblock start-iblock)
+      (compile-iblock iblock))
+    (link-assembly *asm-head* #xC000)
+    *asm-head*))
+
+(defun compiled-bytes (start-instruction)
+  (declare (optimize (debug 3)))
+  (loop :for asm-obj := start-instruction :then (next asm-obj)
+        :do (loop :until (or (null asm-obj) (typep asm-obj 'asm-instruction))
+                  :do (setf asm-obj (next asm-obj)))
+        :until (null asm-obj)
+        :append (list (opcode asm-obj))
+        :when (> (byte-length asm-obj) 1)
+          :append (ecase (byte-length asm-obj)
+                    (2 (list (the (unsigned-byte 8) (operand asm-obj))))
+                    (3 (list (ldb (byte 8 0)
+                                  (the (unsigned-byte 16) (operand asm-obj)))
+                             (ldb (byte 8 8)
+                                  (the (unsigned-byte 16) (operand asm-obj))))))))
 
 (defun quick-and-dirty-test-compile (text &key print-ir-p print-alloc-p make-asm-p)
   (with-input-from-string (source-stream text)
@@ -192,10 +320,4 @@
             (terpri))
           (when make-asm-p
             (with-variable-allocations allocations
-              (let ((*asm-head* nil)
-                    (*asm-foot* nil))
-                (do-iblocks (ib rb)
-                  (emit-asm-label ib)
-                  (do-instructions (inst ib)
-                    (compile-ir inst)))
-                (link-assembly *asm-head* #x8000)))))))))
+              (compile-iblocks rb))))))))