wip-duuqnd/user-side-compiler/asm-function.lisp

@@ -7,8 +7,6 @@
    (%address :accessor address :initarg :address
              :initform #xFEC0)))
 
-(tlk:define-simple-print-object (asm-function %name))
-
 (define-transformation (token (token-name asm-function))
   (multiple-value-bind (asm-function existsp)
       (gethash (name token) *asm-functions*)

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

@@ -40,7 +40,7 @@
     (emit-asm-object label)))
 
 (defvar *variable-allocations* (make-hash-table))
-(defvar *last-instruction* :useless)
+(defvar *last-instruction* '(:nop))
 
 (defun varvec-index-in-zeropage-p (index)
   ;; TODO: Handle case of too many variables
@@ -65,27 +65,14 @@
 (defun data-reference (data)
   (ecase (strategy (allocation-details data))
     ((:named-variable :temporary-variable)
-     (cons :address (+ (varvec-index (allocation-details data))
+     (+ (varvec-index (allocation-details data))
-                       +varvec-offset+)))
+        +varvec-offset+))
     (:direct-to-argvec
-     (cons :address (+ (position data (inputs (first (users data))))
+     (+ (position data (inputs (user data)))
-                       +argvec-offset+)))
+        +argvec-offset+))))
-    (:constant
-     (cons :immediate (ir-constant-value data)))
-    (:accumulator
-     (error "Accumulator-allocated data ~A being dereferenced. Ensuring this does not happen
-is the responsibility of the pre-assembly compilation step."
-            data))
-    (:branch
-     (error "Branch result ~A being dereferenced. This doesn't make much sense." data))
-    (:not-saved
-     (assert (null (users data)))
-     (cons :not-saved nil))))
 
 (defmacro define-normal-emitter (name immediate-opcode zeropage-opcode absolute-opcode)
-  `(defun ,name (data-reference)
+  `(defun ,name (mode value)
-     (destructuring-bind (mode . value)
-         data-reference
      (cond ((eql mode :immediate)
             (emit-asm-instruction :opcode ,immediate-opcode
                                   :operand (the (unsigned-byte 8) value)
@@ -100,7 +87,7 @@ is the responsibility of the pre-assembly compilation step."
                                   :operand (the (unsigned-byte 16) value)
                                   :byte-length 3))
            (t
-              (error "Invalid usage of ~A with arguments (~A ~A)" ',name mode value))))))
+            (error "Invalid usage of ~A with arguments (~A ~A)" ',name mode value)))))
 
 (define-normal-emitter emit-lda #xa9 #xa5 #xad)
 (define-normal-emitter emit-sta (error "STA has no immediate mode.") #x85 #x8d)
@@ -109,20 +96,20 @@ 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 (or (null (allocation-details data))
           (eql (strategy (allocation-details data)) :constant))
-      (setf *last-instruction* :useless)
+      (setf *last-instruction* '(:useless))
       (progn
-        (unless (eql (strategy (allocation-details data)) :accumulator)
+        (emit-sta :address (data-reference data))
-          (emit-sta (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 (member (strategy (allocation-details data))
+  (if (or (null (allocation-details data))
-                  '(:constant :branch :not-saved)))
+          (member (strategy (allocation-details data))
-      (setf *last-instruction* :useless)
+                  '(:constant :flags)))
+      (setf *last-instruction* '(:useless))
       (progn
         (emit-asm-instruction :opcode :php :byte-length 1)
         (emit-asm-instruction :opcode :pla :byte-length 1)
@@ -130,29 +117,24 @@ is the responsibility of the pre-assembly compilation step."
         (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* (list :store-zero-flag data)))))
+        (setf *last-instruction* '(:store-zero-flag data)))))
 
 (defun emit-load-data (data)
-  (cond ((eql (strategy (allocation-details data)) :not-saved)
+  (if (or (eql (strategy (allocation-details data)) :direct-to-argvec)
-         (error "Tried to load unallocated data ~A." data))
+          (equal *last-instruction* (list :store data))
-        ((eql (strategy (allocation-details data)) :accumulator)
-         (assert (eql (next (definition data)) (last-use data)))
-         (setf *last-instruction* :useless))
-        ((eql (strategy (allocation-details data)) :direct-to-argvec)
-         ;; TODO: Assert that it actually has been stored
-         (setf *last-instruction* :useless))
-        ((or (equal *last-instruction* (list :store data))
           (equal *last-instruction* (list :load data)))
-         (setf *last-instruction* :useless))
+      (setf *last-instruction* '(:useless))
-        (t
+      (progn
-         (emit-lda (data-reference data))
+        (if (eql (strategy (allocation-details data)) :constant)
+            (emit-lda :immediate (ir-constant-value data))
+            (emit-lda :address (data-reference data)))
         (setf *last-instruction* (list :load data)))))
 
 (defun emit-load-bool (data)
   (if (or (eql (strategy (allocation-details data)) :flags)
           (equal *last-instruction* (list :store-zero-flag data))
           (equal *last-instruction* (list :load-zero-flag data)))
-      (setf *last-instruction* :useless)
+      (setf *last-instruction* '(:useless))
       (progn
         (if (eql (strategy (allocation-details data)) :constant)
             (progn
@@ -176,7 +158,10 @@ is the responsibility of the pre-assembly compilation step."
     (error "During the final code generation step, IR-PLUS must have exactly 2 operands."))
   (emit-load-data (first (inputs inst)))
   (emit-asm-instruction :opcode #x18 :byte-length 1) ; Clear Carry
-  (emit-adc (data-reference (second (inputs inst))))
+  (if (eql (strategy (allocation-details (second (inputs inst))))
+           :constant)
+      (emit-adc :immediate (ir-constant-value (second (inputs inst))))
+      (emit-adc :address (data-reference (second (inputs inst)))))
   (emit-store-data (output inst)))
 
 (defmethod compile-ir ((inst ir-minus))
@@ -184,30 +169,26 @@ is the responsibility of the pre-assembly compilation step."
     (error "During the final code generation step, IR-MINUS must have exactly 2 operands."))
   (emit-load-data (first (inputs inst)))
   (emit-asm-instruction :opcode #x38 :byte-length 1) ; Set Carry
-  (emit-sbc (data-reference (second (inputs inst))))
+  (if (eql (strategy (allocation-details (second (inputs inst))))
+           :constant)
+      (emit-sbc :immediate (ir-constant-value (second (inputs inst))))
+      (emit-sbc :address (data-reference (second (inputs inst)))))
   (emit-store-data (output inst)))
 
 (defmethod compile-ir ((inst ir-assign))
   (emit-load-data (input inst))
-  (emit-store-data (output inst))
+  (emit-store-data (output inst)))
-  (setf *last-instruction* (list :store (output inst))))
 
 (defmethod compile-ir ((inst ir-fetchvar))
   (emit-load-data (input inst))
-  (emit-store-data (output inst))
+  (emit-store-data (output inst)))
-  (setf *last-instruction* (list :store (output inst))))
-
-(defmethod compile-ir ((inst ir-getconst))
-  (emit-lda (cons :immediate (input inst)))
-  (emit-store-data (output inst))
-  (setf *last-instruction* (list :store (output inst))))
 
 (defmethod compile-ir ((inst ir-call))
   (loop :for arg :in (inputs inst)
         :for arg-index :from 0
         :do (emit-load-data arg)
         :unless (eql (strategy (allocation-details arg)) :direct-to-argvec)
-          :do (emit-sta (cons :address (+ arg-index +argvec-offset+))))
+          :do (emit-sta :address (+ arg-index +argvec-offset+)))
   (emit-asm-instruction :opcode #x20 :operand (callee inst) :byte-length 3)
   (emit-store-data (output inst)))
 
@@ -217,7 +198,7 @@ is the responsibility of the pre-assembly compilation step."
     (emit-asm-instruction :opcode #x4C
                           :operand (first (destinations inst))
                           :byte-length 3))
-  (setf *last-instruction* (list :jump (first (destinations inst)))))
+  (setf *last-instruction* '(:jump)))
 
 (defmethod compile-ir ((inst ir-if))
   (let ((next-iblock (next (iblock inst)))
@@ -232,7 +213,7 @@ is the responsibility of the pre-assembly compilation step."
     (emit-asm-instruction :opcode #xD0
                           :operand else-iblock
                           :byte-length 2)
-    (setf *last-instruction* :branch)))
+    (setf *last-instruction* '(:conditional))))
 
 (defmethod compile-ir ((inst ir-test-equal))
   (emit-load-data (first (inputs inst)))
@@ -309,7 +290,6 @@ is the responsibility of the pre-assembly compilation step."
 
 (defun compiled-bytes (start-instruction)
   (declare (optimize (debug 3)))
-  (check-type start-instruction asm-object)
   (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)))
@@ -328,15 +308,12 @@ is the responsibility of the pre-assembly compilation step."
     (let ((*token-stream* (make-token-stream (tokenize source-stream))))
       (let ((rb (with-compilation-setup (root-block builder)
                   (compile-node (match-syntax program) builder)
-                  root-block))
+                  root-block)))
-            (return-values '()))
         (do-iblocks (ib rb)
-          (optim-prepare-direct-instructions ib)
-          ;;(optim-commutative-constant-folding ib)
           (optim-reorder-arguments ib)
+          (optim-direct-variable-use ib)
           (optim-call-duplicate-args ib)
           (optim-remove-unused ib))
-        (push rb return-values)
         (let ((allocations (allocate-values rb)))
           (optim-reuse-temporary-slots rb allocations)
           (when print-ir-p
@@ -350,8 +327,6 @@ is the responsibility of the pre-assembly compilation step."
                               (unless (null (varvec-index allocation))
                                 (list (varvec-index allocation)))))
             (terpri))
-          (push allocations return-values)
           (when make-asm-p
             (with-variable-allocations allocations
-              (push (compile-iblocks rb) return-values))))
+              (compile-iblocks rb))))))))
-        (values-list (nreverse return-values))))))

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

@@ -5,65 +5,38 @@
 ;;; 6502-related nonsense going on as well, it feels better to call it a value
 ;;; allocator instead.
 
-(defparameter +accumulator-users+
-  '(or ir-operation ir-assign))
-
 (defun calls-exist-between-p (start end)
-  (labels
+  (cond ((eql start end)
-      ((iter (now end)
-         (cond
-           ((eql now end)
          nil)
-           ((typep now 'ir-call)
+        ((typep start 'ir-call)
-            now)
+         start)
-           ((null now)
+        ((null start)
          (error "Calls check crossed iblock boundary. This should not happen."))
         (t
-            (iter (next now) end)))))
+         (calls-exist-between-p (next start) end))))
-    (iter (next start) end)))
 
 (defclass value-allocation ()
   ((%data :accessor data :initarg :data)
    (%strategy :accessor strategy :initform :temporary-variable)
    (%varvec-index :accessor varvec-index :initform nil)))
 
-(defun optim-prepare-direct-instructions (iblock)
-  (do-instructions (inst iblock)
-    (when (typep inst 'ir-operation)
-      (assert (= (length (inputs inst)) 2))
-      (destructuring-bind (accumulator operand)
-          (inputs inst)
-        (when (typep (definition accumulator) '(or ir-fetchvar ir-getconst))
-          (move-instruction-above (definition accumulator) inst))
-        (when (typep (definition operand) '(or ir-fetchvar ir-getconst))
-          (when (typep (definition operand) 'ir-fetchvar)
-            (setf (inputs inst)
-                  (substitute (input (definition operand)) operand
-                              (inputs inst))))
-          (delete-instruction (definition operand)))))))
-
 (defmethod choose-allocation-strategy ((alc value-allocation))
   (setf
    (strategy alc)
    (let ((data (data alc)))
      (cond ((null (users data))
-            :not-saved)
+            :do-not-save)
+           ((typep data 'ir-constant)
+            :constant)
            ((typep data 'ir-variable)
             :named-variable)
            ((and (eql (next (definition data)) (last-use data))
-                 (typep (last-use data) +accumulator-users+)
+                 (typep (last-use data) 'ir-if))
-                 (eql data (first (inputs (last-use data)))))
+            :flags)
-            :accumulator)
+           ((and (not (typep data 'ir-reusable))
-           ((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))))
             :direct-to-argvec)
-           ((typep data 'ir-constant)
-            :constant)
            (t
             :temporary-variable)))))
 
@@ -75,11 +48,6 @@
         (unless (or (null (output inst))
                     (find (output inst) allocations :key #'data))
           (let ((allocation (make-instance 'value-allocation :data (output inst))))
-            (choose-allocation-strategy allocation)
-            (push allocation allocations)))
-        (loop :for input :in (inputs inst)
-              :unless (or (not (typep input 'ir-data)) (find input allocations :key #'data))
-                :do (let ((allocation (make-instance 'value-allocation :data input)))
             (choose-allocation-strategy allocation)
             (push allocation allocations)))))
     (setf allocations (nreverse allocations))
@@ -90,7 +58,7 @@
                          :test-not #'eql :key #'strategy)))
       (loop :for allocation :in (append named temporary)
             :do (setf (varvec-index allocation) (incf counter))))
-    allocations))
+    (remove-if #'null allocations :key (lambda (a) (users (data a))))))
 
 (defun optim-reuse-temporary-slots (start-iblock allocations)
   (let ((free '()))

wip-duuqnd/user-side-compiler/middle/data.lisp

@@ -2,7 +2,7 @@
 
 (defclass ir-data ()
   ((%definition :accessor definition :initarg :definition)
-   (%last-use :accessor last-use :initform nil)))
+   (%last-use :accessor last-use)))
 
 (defclass ir-result (ir-data)
   ((%user :accessor user :initarg :user :initform nil)))

wip-duuqnd/user-side-compiler/middle/instructions.lisp

@@ -80,9 +80,8 @@ solely due to its output being unused."))
 (defclass ir-assign (ir-one-input ir-inst) ())
 
 (defclass ir-operation (ir-inst) ())
-(defclass ir-comparison (ir-operation) ())
 
-(defclass ir-call (ir-inst)
+(defclass ir-call (ir-operation)
   ((%callee :accessor callee :initarg :callee)))
 
 (defmethod effect-used-p ((inst ir-call))
@@ -90,13 +89,6 @@ solely due to its output being unused."))
   t)
 
 ;;; A messy but quick way to define all the very similar arithmetic operations
-(defvar *expr-inst-mappings* '())
-
-(defun get-ir-expr-inst-type (node)
-  (loop :for (node-class . ir-class) :in *expr-inst-mappings*
-        :when (typep node node-class)
-          :return ir-class))
-
 (macrolet ((ops ((&rest superclasses) &rest classes)
              `(progn
                 ,@(loop :for (class-name ignore symbol) :in classes
@@ -105,17 +97,14 @@ solely due to its output being unused."))
                                     (defmethod print-ir-inst ((inst ,class-name))
                                       (format t "  (~A~{ ~A~}) -> ~A~%"
                                               ,symbol (inputs inst) (output inst)))))
-                (setf *expr-inst-mappings*
+                (defun get-ir-expr-inst-type (node)
-                      (append
+                  (typecase node
-                       *expr-inst-mappings*
+                    ,@(loop :for (ir-class node-class ignore) :in classes
-                       ',(loop :for (ir-class node-class ignore) :in classes
                             :unless (null node-class)
-                                 :collect `(,node-class . ,ir-class)))))))
+                              :collect `(,node-class ',ir-class)))))))
-  (setf *expr-inst-mappings* '())
   (ops (ir-operation)               ; NILs indicate TODOs here for now
-       (ir-plus node-expr-plus "+") (ir-minus node-expr-minus "-") (ir-mult node-expr-multiply "*") (ir-div node-expr-divide "/"))
-  (ops (ir-comparison)
        (ir-test-equal node-expr-test-equal "==")
        (ir-test-not-equal node-expr-test-not-equal "!=")
        (ir-test-less nil "<") (ir-test-greater nil ">")
-       (ir-test-less-or-equal nil "<=") (ir-test-greater-or-equal nil ">=")))
+       (ir-test-less-or-equal nil "<=") (ir-test-greater-or-equal nil ">=")
+       (ir-plus node-expr-plus "+") (ir-minus node-expr-minus "-") (ir-mult node-expr-multiply "*") (ir-div node-expr-divide "/")))

wip-duuqnd/user-side-compiler/middle/optimizations.lisp

@@ -118,12 +118,12 @@ No guarantees of success are made, I just hope it's not incorrect."
                           (substitute new old (inputs user)))))))))
 
 (defun optim-reorder-arguments (iblock)
-  "Puts the simpler non-operation arguments right above the call or operation
+  "Puts the simpler non-operation arguments right above the operation that
-that uses them to assist in generating more direct 6502 code."
+uses them to assist in generating more direct 6502 code."
   (do-instructions (inst iblock)
-    (when (typep inst '(or ir-call ir-operation))
+    (when (typep inst 'ir-operation)
       (loop :for input :in (inputs inst)
-            :when (and (not (typep (definition input) '(or ir-operation ir-call)))
+            :when (and (not (typep (definition input) 'ir-operation))
                        (not (typep input 'ir-reusable)))
               :do (move-instruction-above (definition input) inst)))))
 
@@ -169,6 +169,25 @@ though I'm pretty sure it can't anyway.")
           (loop :for (new . old) :in replacements
                 :do (setf (inputs call) (substitute new old (inputs call)))))))))
 
+(defun optim-direct-variable-use (iblock)
+  "Removes unnecessary uses of IR-FETCHVAR.
+Some operations do not require their operands to be copied before use. CPU
+instructions, for example. This optimization pass goes through and removes
+IR-FETCHVAR instructions that would serve no purpose in compiled code."
+  ;; TODO: Add more instructions to the candidates
+  (let ((candidates-type '(or ir-test-equal ir-plus ir-minus))
+        (to-remove '()))
+    (do-instructions (inst iblock)
+      (when (typep inst 'ir-fetchvar)
+        (let ((result (output inst))
+              (src (input inst)))
+          (when (and (not (typep (output inst) 'ir-reusable))
+                     (typep (user result) candidates-type))
+            (let ((user (user (output inst))))
+              (setf (inputs user) (substitute src result (inputs user)))
+              (push inst to-remove))))))
+    (mapc #'delete-instruction to-remove)))
+
 (defun compute-lifetime-knowledge (start-iblock)
   (do-iblocks (iblock start-iblock)
     (do-instructions (inst iblock)