Various additions and changes to compiler backend for IFs and calls

Branching now exists in a general way (work for tests requiring
multiple branch instructions still needed) that works for both storing
test results and taking branches in code.

De-duplicated arguments to calls now load correctly.

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

@@ -68,6 +68,8 @@
      (cons :address (+ (varvec-index (allocation-details data))
                        +varvec-offset+)))
     (:direct-to-argvec
+     (unless (= (count data (inputs (first (users data)))) 1)
+       (error "Tried to manually dereference reused function argument ~A." data))
      (cons :address (+ (position data (inputs (first (users data))))
                        +argvec-offset+)))
     (:constant
@@ -109,12 +111,19 @@ is the responsibility of the pre-assembly compilation step."
 (define-normal-emitter emit-cmp #xc9 #xc5 #xcd)
 
 (defun emit-store-data (data)
-  (if (or (eql (strategy (allocation-details data)) :not-saved)
+  (if (member (strategy (allocation-details data))
-          (eql (strategy (allocation-details data)) :constant))
+              '(:not-saved :constant :branch))
       (setf *last-instruction* :useless)
       (progn
         (unless (eql (strategy (allocation-details data)) :accumulator)
-          (emit-sta (data-reference data)))
+          (if (and (eql (strategy (allocation-details data)) :direct-to-argvec)
+                   (> (count data (inputs (first (users data)))) 1))
+              (loop :with args := (inputs (first (users data)))
+                    :for index := (position data args)
+                      :then (position data args :start (1+ index))
+                    :until (null index)
+                    :do (emit-sta (cons :address (+ index +argvec-offset+))))
+              (emit-sta (data-reference data))))
         (setf *last-instruction* (list :store data)))))
 
 (defun emit-store-bool (data)
@@ -138,6 +147,8 @@ is the responsibility of the pre-assembly compilation step."
         ((eql (strategy (allocation-details data)) :accumulator)
          (assert (eql (next (definition data)) (last-use data)))
          (setf *last-instruction* :useless))
+        ((eql (strategy (allocation-details data)) :branch)
+         (assert (typep (next (definition data)) 'ir-if)))
         ((eql (strategy (allocation-details data)) :direct-to-argvec)
          ;; TODO: Assert that it actually has been stored
          (setf *last-instruction* :useless))
@@ -205,9 +216,11 @@ is the responsibility of the pre-assembly compilation step."
 (defmethod compile-ir ((inst ir-call))
   (loop :for arg :in (inputs inst)
         :for arg-index :from 0
-        :do (emit-load-data arg)
+        :do (setf *last-instruction* :useless)
         :unless (eql (strategy (allocation-details arg)) :direct-to-argvec)
-          :do (emit-sta (cons :address (+ arg-index +argvec-offset+))))
+          :do (emit-lda (data-reference arg))
+              (emit-sta (cons :address (+ arg-index +argvec-offset+)))
+              (format t "~D. ~A~%" arg-index arg))
   (emit-asm-instruction :opcode #x20 :operand (callee inst) :byte-length 3)
   (emit-store-data (output inst)))
 
@@ -216,8 +229,8 @@ is the responsibility of the pre-assembly compilation step."
                (first (destinations inst)))
     (emit-asm-instruction :opcode #x4C
                           :operand (first (destinations inst))
-                          :byte-length 3))
+                          :byte-length 3)
-  (setf *last-instruction* (list :jump (first (destinations inst)))))
+    (setf *last-instruction* (list :jump (first (destinations inst))))))
 
 (defmethod compile-ir ((inst ir-if))
   (let ((next-iblock (next (iblock inst)))
@@ -228,19 +241,50 @@ is the responsibility of the pre-assembly compilation step."
     ;; 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-load-data (input inst))
-    (emit-asm-instruction :opcode #xD0
+    (let ((prev-is-test-p (eql (strategy (allocation-details (input inst)))
-                          :operand else-iblock
+                               :branch)))
-                          :byte-length 2)
+      (if prev-is-test-p
+          ;; If previous was a test, this instruction will be skipped if the
+          ;; test succeeds and we fall through to the THEN case. If it fails,
+          ;; this instruction executes, which jumps to the ELSE case.
+          (emit-asm-instruction :opcode #x4C
+                                :operand else-iblock
+                                :byte-length 3)
+          ;; If the input is a bool value, we have to actually do some work.
+          (progn
+            ;; BNE +3, if it's Not Equal (zero), then it's true, so we skip...
+            (emit-asm-instruction :opcode #xD0 :operand 3 :byte-length 2)
+            ;; ...the jump to the ELSE case.
+            (emit-asm-instruction :opcode #x4C
+                                  :operand else-iblock
+                                  :byte-length 3))))
     (setf *last-instruction* :branch)))
 
+(defun emit-branch-test-code (inputs output branch-opcode)
+  (let ((branchp (eql (strategy (allocation-details output)) :branch)))
+    (emit-load-data (first inputs))
+    (unless branchp ; If we're *NOT* branching, we're storing a test result.
+      ;; LDX #1. This value will go into A if the test succeeds.
+      (emit-asm-instruction :opcode #xA2 :operand 1 :byte-length 2))
+    (emit-cmp (data-reference (second inputs)))
+    ;; The actual branch instruction for our test.
+    (emit-asm-instruction :opcode branch-opcode :operand 3 :byte-length 2)
+    (unless branchp
+      ;; In the event of no branch -- we're storing the result -- we skip over
+      ;; an LDX #0 instruction if it succeeded, run if if the test failed.
+      (emit-asm-instruction :opcode #xA2 :operand 0 :byte-length 2)
+      ;; And a NOP since the skip is three bytes, since in the even of a branch
+      ;; it will be skipping over a whole JMP.
+      (emit-asm-instruction :opcode #xEA :byte-length 1)
+      ;; Then, regardless if we skipped or not, we put the result we have in X,
+      ;; either 0 or 1, into A by emitting a TXA.
+      (emit-asm-instruction :opcode #x8A :byte-length 1))
+    ;; And regardless, we store the result, if applicable.
+    (emit-store-data output)))
+
 (defmethod compile-ir ((inst ir-test-equal))
-  (emit-load-data (first (inputs inst)))
+  (emit-branch-test-code (inputs inst) (output inst) #xF0))
-  (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)
@@ -277,8 +321,9 @@ is the responsibility of the pre-assembly compilation step."
                    (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)))
+                   (unless (typep (operand asm-obj) '(unsigned-byte 8))
-                     (setf (operand asm-obj) (ldb (byte 8 0) (the (signed-byte 8) offset)))))
+                     (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))