Add compiler middle stage

The compiler middle stage takes high level nodes and produces code in
an intermediate representation more closely resembling assembly code.

Optimizations and the tools for making those are also included. It's
significantly easier to optimize IR than syntax trees or assembly.

Several things need cleaning up, in particular there are things in
jigs.lisp that really should be documented tools, not
jigs (specifically the compilation setup and finalization).

wip-duuqnd/user-side-compiler/middle/compile-node-to-ir.lisp

@@ -0,0 +1,153 @@
+(in-package #:user-side-compiler)
+
+(defun compile-node-dependencies (deps builder)
+  (let ((results
+          (loop :for dep :in deps
+                :collect (compile-node dep builder))))
+    (assert (every (lambda (r) (typep r 'ir-data)) results))
+    results))
+
+(defmethod compile-node ((node reference-variable) builder)
+  (let ((input (find-variable node (iblock builder)))
+        (output (make-instance 'ir-result)))
+    (build-insert (make-instance 'ir-fetchvar
+                                 :input input
+                                 :output output)
+                  builder)
+    output))
+
+(defmethod compile-node ((node token-name) builder)
+  (compile-node (transform node 'reference-variable) builder))
+
+(defmethod compile-node ((node token-number) builder)
+  (let ((output (make-instance 'ir-constant)))
+    (build-insert (make-instance 'ir-getconst
+                                 :input (value node)
+                                 :output output)
+                  builder)
+    output))
+
+(defmethod compile-node ((node node-block) builder)
+  (dolist (statement (statements node))
+    (compile-node statement builder)))
+
+(defmethod compile-node ((node node-program) builder)
+  (call-next-method)
+  (build-insert-end (make-instance 'ir-return) builder))
+
+(defmethod compile-node ((node node-call) builder)
+  (let* ((inputs (compile-node-dependencies (arguments node) builder))
+         (output (make-instance 'ir-result)))
+    (build-insert (make-instance 'ir-call
+                                 :callee (callee node)
+                                 :inputs inputs
+                                 :output output)
+                  builder)
+    output))
+
+(defmethod compile-node ((node node-standard-expr) builder)
+  (let* ((inputs (compile-node-dependencies (operands node) builder))
+         (output (make-instance 'ir-result)))
+    (build-insert (make-instance (get-ir-expr-inst-type node)
+                                 :inputs inputs
+                                 :output output)
+                  builder)
+    output))
+
+(defmethod compile-node ((node node-expr-grouping) builder)
+  (compile-node (expression node) builder))
+
+(defmethod compile-node ((node node-assignment) builder)
+  (let ((input (compile-node (value node) builder))
+        (output-var (find-variable (dst-variable node) builder))
+        (output (make-instance 'ir-result)))
+    (build-insert (make-instance 'ir-assign :input input :output output-var) builder)
+    ;; This second instruction is so that we can let an assignment return
+    ;; the value that was assigned, as in b = a = 1. If the assignment is not
+    ;; used in this way, dead code elimination will remove this fetch.
+    (build-insert (make-instance 'ir-fetchvar :input output-var :output output) builder)
+    output))
+
+(defmethod compile-node ((node node-conditional) builder)
+  (let* ((test-ir (the ir-result (compile-node (test-node node) builder)))
+         (else-exists-p (not (null (else-node node))))
+         (then-iblock (make-instance 'iblock :name "then"))
+         (else-iblock (make-instance 'iblock :name "else"))
+         (continuation (if else-exists-p
+                           (make-instance 'iblock :name "merge")
+                           else-iblock)))
+    (build-insert-end (make-instance
+                       'ir-if
+                       :input test-ir
+                       :destinations (list then-iblock else-iblock))
+                      builder)
+    (build-begin builder then-iblock)
+    (compile-node (then-node node) builder)
+    (build-insert-end (make-instance 'ir-jump :destinations (list continuation)) builder)
+    (when else-exists-p
+      (build-begin builder else-iblock)
+      (compile-node (else-node node) builder)
+      (build-insert-end (make-instance 'ir-jump :destinations (list continuation)) builder))
+    (build-begin builder continuation)))
+
+(defmethod compile-node ((node node-dotimes) builder)
+  (unless (zerop (ref-value (stop-ref node)))
+    (let ((const-zero (make-instance 'ir-constant))
+          (const-stop (make-instance 'ir-constant))
+          (loop-body (make-instance 'iblock :name "loop"))
+          (continuation (make-instance 'iblock :name "after_loop"))
+          (counter-variable (find-variable (counter-ref node) builder))
+          
+          (test-result (make-instance 'ir-result)))
+      (build-insert (make-instance 'ir-getconst
+                                   :input 0 :output const-zero)
+                    builder)
+      (build-insert (make-instance 'ir-assign
+                                   :input const-zero
+                                   :output counter-variable)
+                    builder)
+      (build-insert-end (make-instance 'ir-jump :destinations (list loop-body)) builder)
+
+      (build-begin builder loop-body)
+      (compile-node (loopee-node node) builder)
+
+      ;; Increment the counter variable
+      (let ((counter-value (make-instance 'ir-result))
+            (increment-value (make-instance 'ir-constant))
+            (new-counter-value (make-instance 'ir-result)))
+        (build-insert (make-instance 'ir-fetchvar
+                                     :input counter-variable
+                                     :output counter-value)
+                      builder)
+        (build-insert (make-instance 'ir-getconst
+                                     :input 1
+                                     :output increment-value)
+                      builder)
+        (build-insert (make-instance 'ir-plus
+                                     :inputs (list counter-value
+                                                   increment-value)
+                                     :output new-counter-value)
+                      builder)
+        (build-insert (make-instance 'ir-assign
+                                     :input new-counter-value
+                                     :output counter-variable)
+                      builder))
+      ;; Check if it's equal to the stop value
+      (let ((counter-value (make-instance 'ir-result)))
+        (build-insert (make-instance 'ir-fetchvar
+                                     :input counter-variable
+                                     :output counter-value)
+                      builder)
+        (build-insert (make-instance 'ir-getconst
+                                     :input (ref-value (stop-ref node))
+                                     :output const-stop)
+                      builder)
+        (build-insert (make-instance 'ir-test-equal
+                                     :inputs (list counter-value const-stop)
+                                     :output test-result)
+                      builder))
+      (build-insert-end (make-instance 'ir-if
+                                       :input test-result
+                                       :destinations (list continuation loop-body))
+                        builder)
+      (build-begin builder continuation))))

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

@@ -0,0 +1,57 @@
+(in-package #:user-side-compiler)
+
+(defclass ir-data ()
+  ((%definition :accessor definition :initarg :definition)))
+
+(defclass ir-result (ir-data)
+  ((%user :accessor user :initarg :user :initform nil)))
+
+(defmethod users ((data ir-result))
+  (if (user data)
+      (list (user data))
+      nil))
+
+(defmethod add-user ((data ir-result) user)
+  (assert (null (user data)))
+  (setf (user data) user))
+
+(defmethod remove-user ((data ir-result) user)
+  (assert (eql user (user data)))
+  (setf (user data) nil))
+
+(defclass ir-reusable (ir-data)
+  ((%users :accessor users :initarg :users :initform '())))
+
+(defmethod add-user ((data ir-reusable) user)
+  (pushnew user (users data)))
+
+(defmethod remove-user ((data ir-reusable) user)
+  (setf (users data) (remove user (users data))))
+
+(defclass ir-variable (ir-reusable)
+  ((%name :accessor name :initarg :name)
+   (%writers :accessor writers :initform '())))
+
+(tlk:define-simple-print-object (ir-variable %name))
+
+(defclass ir-constant (ir-reusable)
+  ((%definition :accessor definition :initarg :definition)
+   (%value :accessor value :initarg :value)))
+
+(defmethod add-user ((data number) user))
+(defmethod remove-user ((data number) user))
+
+(tlk:define-simple-print-object (ir-constant %value))
+
+(defmethod ir-constant-p ((obj ir-data))
+  (typep (definition obj) 'ir-getconst))
+
+(defmethod ir-constant-p ((obj ir-constant))
+  t)
+
+(defmethod ir-constant-value ((obj ir-result))
+  (assert (ir-constant-p obj))
+  (first (inputs (definition obj))))
+
+(defmethod ir-constant-value ((obj ir-constant))
+  (value obj))

wip-duuqnd/user-side-compiler/middle/graph-manipulation.lisp

@@ -0,0 +1,93 @@
+(in-package #:user-side-compiler)
+
+(defclass builder ()
+  ((%iblock :accessor iblock :initarg :iblock)
+   (%insertion-point :accessor insertion-point :initarg :insertion-point)))
+
+(defun insert-instruction-below (new target)
+  (check-type target (and ir-inst (not ir-terminator)))
+  (let ((next-inst (next target)))
+    (setf (next new) next-inst
+          (previous next-inst) new
+          (previous new) target
+          (next target) new
+          (iblock new) (iblock target))))
+
+(defun insert-instruction-above (new target)
+  (let ((prev-inst (previous target))
+        (ib (iblock target)))
+    (setf (next new) target
+          (previous new) prev-inst
+          (previous target) new
+          (iblock new) ib)
+    (if (null prev-inst)
+        (setf (start ib) new)
+        (setf (next prev-inst) new))))
+
+(defun yank-instruction (instruction)
+  "Removes INSTRUCTIONS without cleaning up, allowing it to be put back in."
+  (check-type instruction (and ir-inst (not ir-terminator)))
+  ;; TODO: integrity checks
+  (let ((iblock (iblock instruction))
+        (before (previous instruction))
+        (after (next instruction)))
+    (setf (previous after) before)
+    (unless (null before)
+      (setf (next before) after))
+    (when (eql (start iblock) instruction)
+      (setf (start iblock) after)))
+  (setf (next instruction) nil
+        (previous instruction) nil))
+
+(defun move-instruction-above (moving target)
+  (yank-instruction moving)
+  (insert-instruction-above moving target))
+
+(defun move-instruction-below (moving target)
+  (yank-instruction moving)
+  (insert-instruction-below moving target))
+
+(defun delete-instruction (instruction)
+  "Removes an instruction with the expectation that it's not coming back."
+  (dolist (input (inputs instruction))
+    (when (typep input 'ir-data)
+      (remove-user input instruction)))
+  (yank-instruction instruction))
+
+(defun build-begin (builder iblock)
+  "Start BUILDER on a fresh IBLOCK."
+  (when (slot-boundp builder '%iblock)
+    (setf (program iblock) (program (iblock builder))))
+  (setf (insertion-point builder) nil
+        (iblock builder) iblock))
+
+(defun %build-insert (builder inst)
+  (setf (iblock inst) (iblock builder))
+  (if (null (insertion-point builder))
+      (setf (start (iblock builder)) inst
+            (next inst) nil
+            (previous inst) nil)
+      (setf (next (insertion-point builder)) inst
+            (previous inst) (insertion-point builder)))
+  (setf (insertion-point builder) inst))
+
+(declaim (ftype (function ((and ir-inst (not ir-terminator)) builder) t) build-insert))
+(defun build-insert (instruction builder)
+  "Insert INSTRUCTION into the place being build by BUILDER."
+  (%build-insert builder instruction))
+
+(declaim (ftype (function (ir-terminator builder) t) build-insert-end))
+(defun build-insert-end (instruction builder)
+  "Insert a terminator INSTRUCTION with BUILDER, ending its current iblock."
+  (%build-insert builder instruction)
+  (setf (end (iblock builder)) instruction))
+
+(defmacro do-iblocks ((iblock start-block) &body body)
+  `(loop :for ,iblock := ,start-block :then (next ,iblock)
+         :until (null ,iblock)
+         :do (progn ,@body)))
+
+(defmacro do-instructions ((instruction iblock) &body body)
+  `(loop :for ,instruction := (start ,iblock) :then (next ,instruction)
+         :until (null ,instruction)
+         :do (progn ,@body)))

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

@@ -0,0 +1,110 @@
+(in-package #:user-side-compiler)
+
+(defclass ir-inst ()
+  ((%next :accessor next :initarg :successor)
+   (%previous :accessor previous :initarg :predecessor)
+   (%inputs :accessor inputs :initarg :inputs :initform '())
+   (%output :accessor output :initarg :output :initform nil)
+   (%iblock :accessor iblock :initarg :iblock)
+   (%source :accessor source :initarg :source)))
+
+(defmethod effect-used-p ((inst ir-inst))
+  nil)
+
+(defmethod (setf inputs) ((new-value list) (object ir-inst))
+  (when (slot-boundp object '%inputs)
+    (mapc (lambda (i) (remove-user i object)) (inputs object)))
+  (dolist (data new-value)
+    (add-user data object))
+  (setf (slot-value object '%inputs) new-value))
+
+(defmethod shared-initialize :before
+    ((instance ir-inst) slot-names &rest initargs
+     &key (inputs nil inputsp) (input nil inputp) (output nil outputp)
+     &allow-other-keys)
+  (declare (ignore slot-names initargs))
+  (when outputp
+    (when (slot-boundp instance '%output)
+      (setf (definition (output instance)) nil))
+    (setf (output instance) output
+          (definition output) instance))
+  (assert (not (and inputsp inputp))) ; cannot give both singular and plural
+  (when inputsp
+    (setf (inputs instance) inputs))
+  (when inputp
+    (setf (inputs instance) (list input))))
+
+(defclass ir-one-input (ir-inst)
+  ((%inputs :type (or null (cons t null))))
+  (:documentation "Mixin for instructions that may take only one input."))
+
+(defclass ir-effect-use (ir-inst) ()
+  (:documentation "An instruction used at least in part for its side-effects. May not be deleted
+solely due to its output being unused."))
+
+(defmethod effect-used-p ((inst ir-effect-use))
+  t)
+
+(defclass ir-no-output (ir-effect-use)
+  ((%output :accessor output :type null :initform nil))
+  (:documentation "Mixin forbidding an instruction from having an output."))
+
+(defmethod input ((inst ir-one-input))
+  (first (inputs inst)))
+
+(defclass ir-terminator (ir-inst)
+  ((%destinations :accessor destinations :initarg :destinations)
+   (%next :initform nil :type null))
+  (:documentation "An instruction that ends a basic block."))
+
+(defclass ir-return (ir-terminator)
+  ((%destinations :initform nil :type null)))
+
+(defclass ir-if (ir-terminator ir-one-input) ())
+(defclass ir-jump (ir-terminator) ())
+
+(defclass ir-getconst (ir-one-input ir-inst)
+  ((%inputs :type (or null (cons fixnum null)))))
+
+(tlk:define-simple-print-object (ir-getconst %inputs) :format-string "~{~A~}")
+
+(defmethod shared-initialize :after ((instance ir-getconst) slot-names &rest initargs
+                                     &key &allow-other-keys)
+  (declare (ignore slot-names initargs))
+  (unless (null (output instance))
+    (check-type (output instance) ir-constant)
+    (setf (value (output instance))
+          (input instance))))
+
+(defclass ir-fetchvar (ir-one-input ir-inst) ())
+(defclass ir-assign (ir-one-input ir-inst) ())
+
+(defclass ir-operation (ir-inst) ())
+
+(defclass ir-call (ir-operation)
+  ((%callee :accessor callee :initarg :callee)))
+
+(defmethod effect-used-p ((inst ir-call))
+  ;; TODO: Return the non-pureness of the callee
+  t)
+
+;;; A messy but quick way to define all the very similar arithmetic operations
+(macrolet ((ops ((&rest superclasses) &rest classes)
+             `(progn
+                ,@(loop :for (class-name ignore symbol) :in classes
+                        :collect `(progn
+                                    (defclass ,class-name ,superclasses ())
+                                    (defmethod print-ir-inst ((inst ,class-name))
+                                      (format t "  (~A~{ ~A~}) -> ~A~%"
+                                              ,symbol (inputs inst) (output inst)))))
+                (defun get-ir-expr-inst-type (node)
+                  (typecase node
+                    ,@(loop :for (ir-class node-class ignore) :in classes
+                            :unless (null node-class)
+                              :collect `(,node-class ',ir-class)))))))
+  (ops (ir-operation)               ; NILs indicate TODOs here for now
+       (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-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/jigs.lisp

@@ -0,0 +1,86 @@
+(in-package #:user-side-compiler)
+
+;;; Printing
+
+(defmethod print-ir-inst (inst)
+  (cond ((and (listp (inputs inst))
+              (not (null (output inst))))
+         (format t "  ~A ~A -> ~A~%" (class-name (class-of inst))
+                 (inputs inst) (output inst)))
+        (t
+         (format t "  ~A~%" (class-name (class-of inst))))))
+
+(defmethod print-ir-inst ((inst ir-assign))
+  (format t "  ASSIGN ~A -> ~A~%" (input inst) (output inst)))
+
+(defmethod print-ir-inst ((inst ir-test-equal))
+  (format t "  ~A == ~A -> ~A~%" (first (inputs inst)) (second (inputs inst))
+          (output inst)))
+
+(defmethod print-ir-inst ((inst ir-call))
+  (format t "  IR-CALL ~A ~A -> ~A~%" (callee inst) (inputs inst) (output inst)))
+
+(defmethod print-ir-inst ((inst ir-if))
+  (format t "  ~A ~A ~A~%" (class-name (class-of inst))
+          (first (inputs inst)) (destinations inst)))
+
+(defmethod print-ir-inst ((inst ir-terminator))
+  (format t "  ~A ~A~%" (class-name (class-of inst)) (destinations inst)))
+
+(defun print-iblock (iblock)
+  (format t "~A:~%" (name iblock))
+  (loop :for inst := (start iblock) :then (next inst)
+        :do (print-ir-inst inst)
+        :until (eql inst (end iblock))))
+
+(defun print-iblocks (start-iblock)
+  (loop :for iblock := start-iblock :then (next iblock)
+        :until (null iblock)
+        :do (print-iblock iblock)))
+
+;;; Compilation setup
+
+(defun fix-iblock-flow (iblock)
+  (let ((reached '()))
+    (labels
+        ((fix (iblock prev)
+           (unless (member iblock reached)
+             (push iblock reached)
+             (setf (next iblock)
+                   (first (successors iblock))
+                   (prev iblock) prev)
+             (loop :for prev := iblock :then s
+                   :for s :in (successors iblock)
+                   :do (fix s prev)))))
+      (fix iblock nil))))
+
+(defmacro with-compilation-setup ((iblock builder &key add-return-p) &body body)
+  `(let ((,iblock (make-instance 'iblock :name "toplevel" :program (make-instance 'ir-program)))
+         (,builder (make-instance 'builder)))
+     (build-begin ,builder ,iblock)
+     (prog1
+         (progn
+           ,@body)
+       (when ,add-return-p
+         (build-insert-end (make-instance 'ir-return) ,builder))
+       (fix-iblock-flow ,iblock))))
+
+;;; Some quick example code
+
+#+(or)
+(with-input-from-string (source-stream "for x do 12 times
+if x == 5 then
+pixeldraw(x, x)
+pixeldraw(x, sqrt(5))
+pixeldraw(0, 0)
+end
+end")
+  (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-call-duplicate-args ib)
+        (optim-remove-unused ib))
+      (print-iblocks rb)
+      rb)))

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

@@ -0,0 +1,170 @@
+(in-package #:user-side-compiler)
+
+;;;; This is by far the messiest part and is probably not anywhere near ready.
+;;;; Some optimizations work fine, others should be replaced. All are correct.
+;;;; (unless I made a mistake I didn't catch somewhere)
+
+(defun flatten-operation-inputs (inst)
+  (loop :for input :in (inputs inst)
+        :for definition := (definition input)
+        :if (typep definition (type-of inst))
+          :append (flatten-operation-inputs definition)
+        :else
+          :collect input))
+
+(defun fold-instruction (inst to-remove value)
+  (let ((output (make-instance 'ir-constant))
+        (add-post (null (member (first (inputs inst)) to-remove))))
+    (insert-instruction-above
+     (make-instance 'ir-getconst
+                    :input value
+                    :output output)
+     inst)
+    (setf (inputs inst)
+          (append
+           (when (not add-post)
+             (list output))
+           (remove-if (lambda (i) (member i to-remove))
+                      (inputs inst))
+           (when add-post
+             (list output))))))
+
+(defun optim-commutative-constant-folding (iblock)
+  "Attempts to replace operations with compile-time computed constants."
+  (do-instructions (inst iblock)
+    (when (or (typep inst '(or ir-plus ir-mult)))
+      (let ((new-inputs (flatten-operation-inputs inst)))
+        (unless (equal new-inputs (inputs inst))
+          (dolist (i (remove-if (lambda (d) (typep d 'ir-reusable)) new-inputs))
+            (unless (or (null (user i)) (eql (user i) inst))
+              (delete-instruction (user i))))
+          (setf (inputs inst) new-inputs)))
+      (let* ((to-fold (remove-if-not #'ir-constant-p (inputs inst)))
+             (values (mapcar #'ir-constant-value to-fold)))
+        (typecase inst
+          (ir-plus
+           (fold-instruction inst to-fold (mod (reduce #'+ values) 256))
+           ;; Adding zero has no effect, so remove any zeroes
+           (setf (inputs inst)
+                 (remove-if (lambda (i)
+                              (and (ir-constant-p i)
+                                   (zerop (ir-constant-value i))))
+                            (inputs inst))))
+          (ir-mult
+           ;; Multiplication gets an extra check in case a multiplication by
+           ;; zero occurs and we need to zero out the result.
+           (fold-instruction inst to-fold (mod (reduce #'* values) 256))
+           (let ((zero (find 0 (remove-if-not #'ir-constant-p (inputs inst))
+                             :key #'ir-constant-value)))
+             (unless (null zero)
+               (setf (inputs inst)
+                     (remove-if-not (lambda (i)
+                                      (or (typep (definition i) 'ir-call)
+                                          (eql i zero)))
+                                    (inputs inst)))))))
+        (when (= 1 (length (inputs inst)))
+          (let ((new (first (inputs inst)))
+                (old (output inst)))
+            (setf (inputs inst) '())
+            (loop :for user :in (users (output inst))
+                  :do (setf (inputs user)
+                            (substitute new old (inputs user))))))))))
+
+(defun optim-non-commutative-constant-folding (iblock)
+  ;; BROKEN!!
+  "Attempts to replace operations with compile-time computed constants.
+No guarantees of success are made, I just hope it's not incorrect."
+  (do-instructions (inst iblock)
+    (when (and (typep inst 'ir-operation)
+               (not (typep inst 'ir-call))
+               (or (every #'ir-constant-p (inputs inst))
+                   ;; Division and subtraction can only be properly folded
+                   ;; here if it's only constants being used. That sucks but
+                   ;; I guess that's what we'll have to live with for now.
+                   (and (not (typep inst 'ir-div))
+                        (not (typep inst 'ir-minus)))))
+      ;; Collect a new flattened list of inputs, combining other instructions
+      ;; of the same type. This is used to enable constant folding in
+      ;; situations where there's a variable in the middle.
+      (let ((new-inputs (flatten-operation-inputs inst)))
+        (unless (equal new-inputs (inputs inst))
+          (dolist (i (remove-if (lambda (d) (typep d 'ir-reusable)) new-inputs))
+            (unless (or (null (user i)) (eql (user i) inst))
+              (delete-instruction (user i))))
+          (setf (inputs inst) new-inputs)))
+      ;; Perform the pre-calculation and actual folding.
+      (let* ((to-fold (remove-if-not #'ir-constant-p (inputs inst)))
+             (values (mapcar #'ir-constant-value to-fold)))
+        (typecase inst
+          
+          (ir-minus
+           (setf values (mapcar (lambda (v)
+                                  (if (>= v 128)
+                                      (dpb v (byte 8 0) -1)
+                                      v))
+                                values))
+           (fold-instruction inst to-fold (mod (- (first values)
+                                                  (reduce #'+ (rest values)))
+                                               256)))
+          
+          (ir-div
+           (fold-instruction inst to-fold (reduce #'/ values)))))
+      (when (= 1 (length (inputs inst)))
+        (let ((new (first (inputs inst)))
+              (old (output inst)))
+          (setf (inputs inst) '())
+          (loop :for user :in (users (output inst))
+                :do (setf (inputs user)
+                          (substitute new old (inputs user)))))))))
+
+(defun optim-reorder-arguments (iblock)
+  "Puts the simpler non-operation arguments right above the operation that
+uses them to assist in generating more direct 6502 code."
+  (do-instructions (inst iblock)
+    (when (typep inst 'ir-operation)
+      (loop :for input :in (inputs inst)
+            :when (and (not (typep (definition input) 'ir-operation))
+                       (not (typep input 'ir-reusable)))
+              :do (move-instruction-above (definition input) inst)))))
+
+(defparameter +optim-remove-unused-max-passes+ 25
+  "The maximum number of passes the Remove Unused optimization may run
+before being cut off. This ensures that it can't get stuck forever, even
+though I'm pretty sure it can't anyway.")
+
+(defun optim-remove-unused (iblock)
+  (let ((to-delete '()))
+    (loop :repeat +optim-remove-unused-max-passes+ ; this many times or fewer
+          :do (setf to-delete '())
+              (do-iblocks (ib iblock)
+                (do-instructions (inst ib)
+                  (when (and (not (typep inst 'ir-terminator))
+                             (not (effect-used-p inst))
+                             (null (users (output inst))))
+                    (push inst to-delete))))
+              (mapc 'delete-instruction to-delete)
+          :until (null to-delete))))
+
+(defun optim-call-duplicate-args (iblock)
+  "Attempts to deduplicate call arguments."
+  (let ((calls '()))
+    (do-instructions (inst iblock)
+      (when (typep inst 'ir-call)
+        (push inst calls)))
+    (flet ((arg-duplicates-p (a b)
+             (or (and (ir-constant-p a) (ir-constant-p b)
+                      (eql (ir-constant-value a) (ir-constant-value b)))
+                 (and (typep a 'ir-fetchvar) (typep b 'ir-fetchvar)
+                      (eql (input (definition a)) (input (definition b)))))))
+      (dolist (call calls)
+        (let ((arguments '())
+              (replacements '()))
+          (dolist (input (inputs call))
+            (let ((duplicate (find-if (lambda (i)
+                                        (arg-duplicates-p i input))
+                                      arguments)))
+              (if duplicate
+                  (push (cons duplicate input) replacements)
+                  (push input arguments))))
+          (loop :for (new . old) :in replacements
+                :do (setf (inputs call) (substitute new old (inputs call)))))))))

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

@@ -0,0 +1,38 @@
+(in-package #:user-side-compiler)
+
+(defclass ir-program ()
+  ((%start :accessor start :initarg :start)
+   (%variables :accessor variables :initform (make-hash-table))))
+
+(defclass iblock ()
+  ((%program :accessor program :initarg :program)
+   (%start :accessor start :initarg :start :type ir-inst)
+   (%end :accessor end :initarg :end :type ir-terminator)
+   (%next :accessor next :type (or null iblock) :initform nil)
+   (%prev :accessor prev :type (or null iblock) :initform nil)
+   (%name :accessor name :initarg :name :initform nil)))
+
+(defmethod find-variable (reference (search-from ir-program))
+  (multiple-value-bind (var existsp)
+      (gethash reference (variables search-from))
+    (if existsp
+        var
+        (setf (gethash reference (variables search-from))
+              (make-instance 'ir-variable :name (name reference))))))
+
+(defmethod find-variable (reference (search-from iblock))
+  (find-variable reference (program search-from)))
+
+(defmethod find-variable (reference (search-from ir-inst))
+  (find-variable reference (iblock search-from)))
+
+(defmethod find-variable (reference (search-from builder))
+  (find-variable reference (iblock search-from)))
+
+(defmethod print-object ((object iblock) stream)
+  (print-unreadable-object (object stream :type t :identity t)
+    (unless (null (name object))
+      (format stream "~A" (name object)))))
+
+(defun successors (iblock)
+  (destinations (end iblock)))

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

@@ -1,5 +1,10 @@
 (cl:in-package #:cl-user)
 
+(defpackage #:user-side-compiler/toolkit
+  (:use #:cl)
+  (:export #:define-simple-print-object))
+
 (defpackage #:user-side-compiler
   (:nicknames #:usc)
+  (:local-nicknames (#:tlk #:user-side-compiler/toolkit))
   (:use #:cl))

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

@@ -0,0 +1,12 @@
+(in-package #:user-side-compiler/toolkit)
+
+(defmacro define-simple-print-object ((class &rest slot-names)
+                                      &key (format-string "~A")
+                                        (type t) (identity t))
+  (when (some #'listp slot-names)
+    (error "SLOT-NAMES must be a list of symbols, they may not be quoted."))
+  `(defmethod print-object ((object ,class) stream)
+     (print-unreadable-object (object stream :type ,type :identity ,identity)
+       (when (and ,@(loop :for s :in slot-names :collect `(slot-boundp object ',s)))
+         (format stream ,format-string ,@(loop :for s :in slot-names
+                                               :collect `(slot-value object ',s)))))))

wip-duuqnd/user-side-compiler/user-side-compiler.asd

@@ -5,6 +5,7 @@
   :depends-on (#:closer-mop)
   :components
   ((:file "package")
+   (:file "toolkit")
    (:file "transform")
    (:file "reference")
    (:file "symbol-table")
@@ -14,4 +15,17 @@
    (:file "parser")
    (:file "label")
    (:file "instruction")
-   (:file "s-print")))
+   (:file "s-print")
+   (:module "middle"
+    :depends-on ("package"
+                 "tokenizer"
+                 "high-level"
+                 "parser")
+    :serial t
+    :components ((:file "data")
+                 (:file "instructions")
+                 (:file "graph-manipulation")
+                 (:file "structure")
+                 (:file "compile-node-to-ir")
+                 (:file "optimizations")
+                 (:file "jigs")))))