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

(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-merge :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 (and (typep (stop-ref node) 'reference-constant)
               (zerop (ref-value (stop-ref node))))
    (let* ((stop-ref-const-p (typep (stop-ref node) 'reference-constant))
           (const-zero (make-instance 'ir-constant))
           (const-stop (if stop-ref-const-p
                           (make-instance 'ir-constant)
                           (make-instance 'ir-result)))
           (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)))
      (unless stop-ref-const-p
        (let ((zero (make-instance 'ir-constant)))
          (build-insert (make-instance 'ir-getconst :input 0 :output zero)
                        builder)
          (build-insert (make-instance
                         'ir-plus
                         :inputs (list (compile-node (stop-ref node) builder)
                                       zero)
                         :output const-stop)
                        builder)))
      (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)
        (when stop-ref-const-p
          (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))))