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

@@ -68,8 +68,6 @@
      (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
@@ -111,19 +109,12 @@ is the responsibility of the pre-assembly compilation step."
 (define-normal-emitter emit-cmp #xc9 #xc5 #xcd)
 
 (defun emit-store-data (data)
-  (if (member (strategy (allocation-details data))
-              '(:not-saved :constant :branch))
+  (if (or (eql (strategy (allocation-details data)) :not-saved)
+          (eql (strategy (allocation-details data)) :constant))
       (setf *last-instruction* :useless)
       (progn
         (unless (eql (strategy (allocation-details data)) :accumulator)
-          (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))))
+          (emit-sta (data-reference data)))
         (setf *last-instruction* (list :store data)))))
 
 (defun emit-store-bool (data)
@@ -147,8 +138,6 @@ 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))
@@ -216,11 +205,9 @@ 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 (setf *last-instruction* :useless)
+        :do (emit-load-data arg)
         :unless (eql (strategy (allocation-details arg)) :direct-to-argvec)
-          :do (emit-lda (data-reference arg))
-              (emit-sta (cons :address (+ arg-index +argvec-offset+)))
-              (format t "~D. ~A~%" arg-index arg))
+          :do (emit-sta (cons :address (+ arg-index +argvec-offset+))))
   (emit-asm-instruction :opcode #x20 :operand (callee inst) :byte-length 3)
   (emit-store-data (output inst)))
 
@@ -229,8 +216,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)
-    (setf *last-instruction* (list :jump (first (destinations inst))))))
+                          :byte-length 3))
+  (setf *last-instruction* (list :jump (first (destinations inst)))))
 
 (defmethod compile-ir ((inst ir-if))
   (let ((next-iblock (next (iblock inst)))
@@ -241,50 +228,19 @@ 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-data (input inst))
-    (let ((prev-is-test-p (eql (strategy (allocation-details (input inst)))
-                               :branch)))
-      (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
+    (emit-load-bool (input inst))
+    (emit-asm-instruction :opcode #xD0
                           :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))))
+                          :byte-length 2)
     (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-branch-test-code (inputs inst) (output inst) #xF0))
+  (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)
@@ -321,9 +277,8 @@ 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
-                   (unless (typep (operand asm-obj) '(unsigned-byte 8))
                    (let* ((offset (- (address (operand asm-obj)) (address asm-obj) 2)))
-                       (setf (operand asm-obj) (ldb (byte 8 0) (the (signed-byte 8) offset))))))
+                     (setf (operand asm-obj) (ldb (byte 8 0) (the (signed-byte 8) offset)))))
                   (t
                    (when (typep (operand asm-obj) 'iblock)
                      (resolve-iblock asm-obj))

wip-duuqnd/user-side-compiler/backend/value-allocator.lisp

@@ -6,7 +6,7 @@
 ;;; allocator instead.
 
 (defparameter +accumulator-users+
-  '(or ir-operation ir-assign ir-if))
+  '(or ir-operation ir-assign))
 
 (defun calls-exist-between-p (start end)
   (labels
@@ -50,14 +50,14 @@
             :not-saved)
            ((typep data 'ir-variable)
             :named-variable)
-           ((and (eql (next (definition data)) (last-use data))
-                 (typep (last-use data) 'ir-if)
-                 (typep (definition data) 'ir-comparison))
-            :branch)
            ((and (eql (next (definition data)) (last-use data))
                  (typep (last-use data) +accumulator-users+)
                  (eql data (first (inputs (last-use data)))))
             :accumulator)
+           ((and (eql (next (definition data)) (last-use data))
+                 (typep (last-use data) 'ir-if)
+                 (typep (definition data) 'ir-comparison))
+            :branch)
            ((and (= (length (users data)) 1)
                  (typep (last-use data) 'ir-call)
                  (not (calls-exist-between-p (definition data) (last-use data))))

wip-duuqnd/user-side-compiler/parser.lisp

@@ -145,12 +145,9 @@ parser's debug output.")
   (setf name (match-syntax primary))
   (cond ((and (typep name 'token-name)
               (match-token 'token-open-paren))
-         (cond ((match-token 'token-close-paren)
-                (setf arguments '()))
-               (t
          (setf arguments (match-syntax arglist))
          (consume-token 'token-close-paren
-                               "Close parenthesis ')' is required to end function call argument list.")))
+                        "Close parenthesis ')' is required to end function call argument list.")
          (make-instance 'node-call
                         :source *syntax-source*
                         :comment *token-comment*
@@ -295,7 +292,7 @@ parser's debug output.")
                   (peek-token))))
   (make-instance 'node-conditional
                  :source *syntax-source*
-                 :test test
+                 :test (transform test 'node-expr)
                  :then (transform then 'node)
                  :else (if (null else) nil
                            (transform else 'node))))