Add bytesquashing (turning instructions etc. into dead bytes)

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

@@ -0,0 +1,11 @@
+(in-package #:user-side-compiler)
+
+(defgeneric bytesquash (object)
+  (:method ((object integer))
+    (typecase object
+      ((unsigned-byte 8) (list object))
+      ((unsigned-byte 16) (list (ldb (byte 8 0) object)
+                                (ldb (byte 8 8) object)))
+      (t (error "Cannot bytesquash integers larger than 16-bit."))))
+  (:method ((object label))
+    (bytesquash (address object))))

wip-duuqnd/user-side-compiler/high-level.lisp

@@ -1,5 +1,8 @@
 (in-package #:user-side-compiler)
 
+(defparameter *varvec* (make-label :name "VARVEC" :address #x8100))
+(defparameter *argvec* (make-label :name "ARGVEC" :address #xF0))
+
 (defvar *instruction-source* nil)
 (defvar *compile-result*)
 
@@ -44,8 +47,7 @@
     (format stream "@~D" (ref-index object))))
 
 (defmethod dereference ((ref reference-variable))
-  (produce-instruction 'inst-ldy-immediate (ref-index ref))
+  (produce-instruction 'inst-lda-absolute (make-offset-label *varvec* (ref-index ref))))
-  (produce-instruction 'inst-lda-absolute-y "VARVEC"))
 
 (defclass node ()
   ((%next :accessor next :accessor normal-next :initform nil)))
@@ -74,7 +76,7 @@
     (loop :for ref :in (arguments node)
           :for index :from 0
           :do (dereference ref)
-          :do (produce-instruction 'inst-sta-absolute (format nil "ARGVEC+~D" index)))
+          :do (produce-instruction 'inst-sta-absolute (make-offset-label *argvec* index)))
     (produce-instruction 'inst-jsr-absolute (callee node))))
 
 (defclass node-branch (node)

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

@@ -32,9 +32,14 @@
                      ""
                      (format nil " ~S" (operand object)))))))
 
-(defclass complete-mixin ()
+(defclass complete-instruction-mixin ()
   ((%opcode :allocation :class :reader opcode :initarg :opcode)))
 
+(defmethod bytesquash ((object complete-instruction-mixin))
+  (append (list (opcode object))
+          (when (> (instruction-length object) 1)
+            (bytesquash (operand object)))))
+
 (defclass immediate-mixin () ())
 (defclass implied-mixin () ())
 (defclass accumulator-mixin () ())
@@ -69,12 +74,12 @@
                    (:indirect-y indirect-y-mixin))))))
 
 (defgeneric instruction-length (object)
-  (:method (immediate-mixin) 1)
+  (:method ((obj immediate-mixin)) 2)
-  (:method (implied-mixin) 1)
+  (:method ((obj implied-mixin)) 1)
-  (:method (accumulator-mixin) 1)
+  (:method ((obj accumulator-mixin)) 1)
-  (:method (zero-page-mixin) 2)
+  (:method ((obj zero-page-mixin)) 2)
-  (:method (relative-mixin) 2)
+  (:method ((obj relative-mixin)) 2)
-  (:method (absolute-mixin) 3))
+  (:method ((obj absolute-mixin)) 3))
 
 (defclass branching-mixin ()
   ((%branch-next :accessor branch-next :initarg :branch-next)))
@@ -85,44 +90,64 @@
     `(progn
        (defclass ,base-name (instruction)
          ((%mnemonic :allocation :class :initform ',mnemonic)))
+       (setf (slot-value (make-instance ',base-name) '%mnemonic) ',mnemonic)
        ,@(loop :for (mode code) :in modes-and-codes
-               :collect `(defclass ,(intern (format nil "INST-~A-~A"
+               :for class-name := (intern (format nil "INST-~A-~A" name mode))
-                                                    name mode))
+               :collect `(progn
-                             ,(append
+                           (defclass ,class-name
-                               `(,base-name
+                               ,(append
-                                 ,(addressing-mode-to-class-name mode)
+                                 `(,base-name
-                                 complete-mixin)
+                                   ,(addressing-mode-to-class-name mode)
-                               (when branching-p
+                                   complete-instruction-mixin)
-                                 '(branching-mixin)))
+                                 (when branching-p
-                           ((%opcode :allocation :class :initform ,code)))))))
+                                   '(branching-mixin)))
+                             ((%opcode :allocation :class :initform ,code)))
+                           (setf (slot-value (allocate-instance (find-class ',class-name)) '%opcode) ,code))))))
 
 (defun fix-label-addresses-in-instruction-list (instruction-list origin)
   (loop :with address := origin
+        :with cell := instruction-list
         :for obj :in instruction-list
         :if (typep obj 'label)
           :do (setf (address obj) address)
         :else
-          :do (incf address (instruction-length obj))))
+          :do (when (typep obj 'instruction)
+                (incf address (instruction-length obj)))
+        :unless (null (rest cell))
+          :do (setf cell (rest cell))
+        :finally (setf (cdr cell)
+                       (list (make-label :name "PROGRAM_END" :address address)))))
+
+(defun bytesquash-instruction-list (instruction-list origin)
+  (let* ((end-label (find "PROGRAM_END" (remove-if-not #'labelp instruction-list)
+                          :key #'name :test #'equalp))
+         (byte-vector (make-array (- (address end-label) origin)
+                                  :element-type '(unsigned-byte 8)
+                                  :fill-pointer 0)))
+    (loop :for thing :in instruction-list
+          :when (typep thing 'instruction)
+            :do (dolist (byte (bytesquash thing))
+                  (vector-push byte byte-vector)))
+    byte-vector))
 
 ;;; Testing
 
-(define-instruction "TXA" nil (:implied 0))
+(define-instruction "TXA" nil (:implied #x8a))
-(define-instruction "PHA" nil (:implied 0))
+(define-instruction "PHA" nil (:implied #x48))
-(define-instruction "PLA" nil (:implied 0))
+(define-instruction "PLA" nil (:implied #x68))
-(define-instruction "TAX" nil (:implied 0))
+(define-instruction "TAX" nil (:implied #xaa))
-(define-instruction "DEX" nil (:implied 0))
+(define-instruction "DEX" nil (:implied #xca))
-(define-instruction "BNE" t (:relative 0))
+(define-instruction "BNE" t (:relative #xd0))
 (define-instruction "LDA" nil
-  (:absolute 0)
+  (:immediate #xa9)
-  (:zero-page 0)
+  (:zero-page #xa5)
-  (:immediate 0)
+  (:absolute #xad)
-  (:absolute-y 0))
+  (:absolute-y #xb9))
 (define-instruction "LDY" nil
-  (:absolute 0)
+  (:immediate #xa0)
-  (:immediate 0))
+  (:absolute #xac))
 (define-instruction "STA" nil
-  (:absolute 0)
+  (:absolute #x8d)
-  (:immediate 0)
+  (:absolute-y #x99))
-  (:absolute-y 0))
 (define-instruction "JSR" nil
-  (:absolute 0))
+  (:absolute #x20))

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

@@ -4,6 +4,9 @@
   ((%name :accessor name :initarg :name)
    (%address :accessor address :initform nil :initarg :address)))
 
+(defun labelp (obj)
+  (typep obj 'label))
+
 (defmethod print-object ((object label) stream)
   (with-accessors ((name name) (address address)) object
     (print-unreadable-object (object stream :type t)
@@ -17,9 +20,28 @@
   (format nil "~A~D" prefix (incf *label-counter*)))
 
 (defun make-label (&key name name-prefix address)
-  (when (null name)
-    (setf name (make-label-name (if (null name-prefix) "L" name-prefix))))
   (when (and (not (null name)) (not (null name-prefix)))
     (warn "MAKE-LABEL with both name (~A) and prefix (~A) specified (useless)."
           name name-prefix))
+  (when (null name)
+    (setf name (make-label-name (if (null name-prefix) "L" name-prefix))))
   (make-instance 'label :name name :address address))
+
+(defclass offset-label (label)
+  ((%offset-from :accessor offset-from :initarg :offset-from)
+   (%offset :accessor offset :initarg :offset)))
+
+(defmethod address ((object offset-label))
+  (+ (address (offset-from object))
+     (offset object)))
+
+(defmethod name ((object offset-label))
+  (format nil "~A~C~D"
+          (name (offset-from object))
+          (if (minusp (offset object))
+              #\-
+              #\+)
+          (offset object)))
+
+(defun make-offset-label (src-label offset)
+  (make-instance 'offset-label :offset-from src-label :offset offset))