Add extremely unfinished 6502 code generator to user-side compiler

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

@@ -0,0 +1,177 @@
+(in-package #:user-side-compiler)
+
+(defclass asm-object ()
+  ((%source :accessor source :initarg :source :initform nil)))
+
+(defclass asm-label (asm-object)
+  ((%name :accessor name :initarg :name)
+   (%address :accessor address :initform nil)))
+
+(defclass asm-instruction (asm-object)
+  ((%opcode :accessor opcode :initarg :opcode)
+   (%operand :accessor operand :initarg :operand :initform nil)
+   (%byte-length :accessor byte-length :initarg :byte-length)))
+
+(defvar *asm-output* '())
+
+(defun emit-asm-object (obj)
+  (check-type obj asm-object)
+  (setf *asm-output* (append *asm-output* (list obj))))
+
+(defun emit-asm-instruction (&rest initargs)
+  (emit-asm-object (apply #'make-instance
+                          'asm-instruction
+                          initargs)))
+
+(defun emit-asm-label (identity)
+  (emit-asm-object (make-instance 'asm-label :name identity)))
+
+(defvar *variable-allocations* (make-hash-table))
+(defvar *last-instruction* '(:nop))
+
+(defun varvec-index-in-zeropage-p (index)
+  ;; TODO: Handle case of too many variables
+  t)
+
+(defun argvec-index-in-zeropage-p (index)
+  ;; TODO: Handle case of too many arguments (? not realistically needed)
+  t)
+
+(defparameter +argvec-offset+ #x00)
+(defparameter +varvec-offset+ #x08)
+
+(defmacro with-variable-allocations (allocations &body body)
+  `(let ((*variable-allocations* (make-hash-table)))
+     (loop :for alloc :in ,allocations
+           :do (setf (gethash (data alloc) *variable-allocations*) alloc))
+     ,@body))
+
+(defun allocation-details (data)
+  (gethash data *variable-allocations*))
+
+(defun data-reference (data)
+  (ecase (strategy (allocation-details data))
+    ((:named-variable :temporary-variable)
+     (+ (varvec-index (allocation-details data))
+        +varvec-offset+))
+    (:direct-to-argvec
+     (+ (position data (inputs (user data)))
+        +argvec-offset+))))
+
+(defmacro define-normal-emitter (name immediate-opcode zeropage-opcode absolute-opcode)
+  `(defun ,name (mode value)
+     (cond ((eql mode :immediate)
+            (emit-asm-instruction :opcode ,immediate-opcode
+                                  :operand (the (unsigned-byte 8) value)
+                                  :byte-length 2))
+           ((and (eql mode :address)
+                 (< value #x100))
+            (emit-asm-instruction :opcode ,zeropage-opcode
+                                  :operand (the (unsigned-byte 8) value)
+                                  :byte-length 2))
+           ((eql mode :address)
+            (emit-asm-instruction :opcode ,absolute-opcode
+                                  :operand (the (unsigned-byte 16) value)
+                                  :byte-length 3))
+           (t
+            (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)
+(define-normal-emitter emit-adc #x69 #x65 #x6d)
+
+(defun emit-store-result (result)
+  (if (or (null (allocation-details result))
+          (member (strategy (allocation-details result))
+                  '(:constant :accumulator)))
+      (setf *last-instruction* '(:useless))
+      (progn
+        (emit-sta :address (data-reference result))
+        (setf *last-instruction* (list :store result)))))
+
+(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)))
+      (setf *last-instruction* '(:useless))
+      (progn
+        (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)))))
+
+(defmethod compile-ir ((inst ir-inst))
+  (warn "Skipped compiling ~A; no COMPILE-IR method" inst))
+
+(defmethod compile-ir ((inst ir-plus))
+  (unless (= (length (inputs inst)) 2)
+    (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
+  (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-result (output inst)))
+
+(defmethod compile-ir ((inst ir-assign))
+  (emit-load-data (input inst))
+  (emit-store-result (output inst)))
+
+(defmethod compile-ir ((inst ir-fetchvar))
+  (emit-load-data (input inst))
+  (emit-store-result (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 :address (+ arg-index +argvec-offset+)))
+  (emit-asm-instruction :opcode #x20 :operand (callee inst) :byte-length 1)
+  (emit-store-result (output inst)))
+
+(defun link-assembly (assembly-list origin-address)
+  (let ((address origin-address))
+    (loop :for asm-obj :in assembly-list
+          :do (cond ((typep asm-obj 'asm-label)
+                     (setf (address asm-obj) address))
+                    ((typep asm-obj 'asm-instruction)
+                     (incf address (byte-length asm-obj)))))
+    ;; TODO: Second pass, replacing labels with their addresses, both for
+    ;; constant labels such as assembly routines and for generated labels.
+    (values assembly-list address)))
+
+(defun quick-and-dirty-test-compile (text &key print-ir-p print-alloc-p make-asm-p)
+  (with-input-from-string (source-stream text)
+    (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)))
+        (do-iblocks (ib rb)
+          (optim-reorder-arguments ib)
+          (optim-direct-variable-use ib)
+          (optim-call-duplicate-args ib)
+          (optim-remove-unused ib))
+        (let ((allocations (allocate-values rb)))
+          (optim-reuse-temporary-slots rb allocations)
+          (when print-ir-p
+            (print-iblocks rb)
+            (terpri))
+          (when print-alloc-p
+            (loop :for allocation :in allocations
+                  :do (format t "~%~A - ~A~{ - ~A~}"
+                              (data allocation)
+                              (strategy allocation)
+                              (unless (null (varvec-index allocation))
+                                (list (varvec-index allocation)))))
+            (terpri))
+          (when make-asm-p
+            (with-variable-allocations allocations
+              (let ((*asm-output* '()))
+                (do-iblocks (ib rb)
+                  (emit-asm-label ib)
+                  (do-instructions (inst ib)
+                    (compile-ir inst)))
+                (link-assembly *asm-output* #x8000)))))))))