cps 変換したものを reorder

Unfortunately, the problem of reordering directed acyclic graphs for optimal register allocation is NP-complete.
だそうなので、10 命令でも 10! 回計算しないといけなさそう。ということで、ヒューリスティックな方法で解きます。

(:FIXH
 ((|:G0| (G0 K0 B1)
   (:RECORD-REF (G0 1) (|sym1|)
    ((:RECORD-REF (|sym1| 5) (EX-G0)
      ((:RECORD-REF (|sym1| 4) (SYM0)
        ((:* (EX-G0 SYM0) (SYM1)
          ((:+ (B1 SYM1) (EX-G1)
            ((:RECORD-REF (K0 0) (|sym2|)
              ((:APP |sym2| (K0 EX-G1)))))))))))))))
  (|:G1| (G1 K2 B2)
   (:RECORD-REF (G1 1) (|sym3|)
    ((:RECORD-REF (|sym3| 3) (EX-G1)
      ((:RECORD-REF (|sym3| 2) (EX-G2)
        ((:RECORD-REF (|sym3| 1) (F0)
          ((:+ (EX-G1 EX-G2) (SYM5)
            ((:RECORD-REF (F0 0) (|sym4|)
              ((:APP |sym4| (F0 SYM5))))))))))))))))
 (:HEAP ((:LABEL :DUMMY) F0 EX-G2 EX-G1 SYM0 EX-G0) (|sym0|)
  ((:HEAP ((:LABEL |:G0|) |sym0|) (G0)
    ((:HEAP ((:LABEL |:G1|) |sym0|) (G1)
      ((:- (EX-C EX-D) (SYM3)
        ((:RECORD-REF (G0 0) (|sym5|) ((:APP |sym5| (G0 EX-K SYM3)))))))))))))

こんな感じのを、ある程度抽出して

(RESULT
 ((:RECORD-REF :SELECTED (G0) (|sym1|)) (:RECORD-REF :SELECTED (|sym1|) (SYM0))
  (:RECORD-REF :SELECTED (|sym1|) (EX-G0)) (:* :SELECTED (EX-G0 SYM0) (SYM1))
  (:RECORD-REF :SELECTED (K0) (|sym2|)) (:+ :SELECTED (B1 SYM1) (EX-G1))
  (:APP :SELECTED (|sym2| K0 EX-G1) NIL)))
(RESULT
 ((:RECORD-REF :SELECTED (G1) (|sym3|)) (:RECORD-REF :SELECTED (|sym3|) (F0))
  (:RECORD-REF :SELECTED (|sym3|) (EX-G2))
  (:RECORD-REF :SELECTED (|sym3|) (EX-G1))
  (:RECORD-REF :SELECTED (F0) (|sym4|)) (:+ :SELECTED (EX-G1 EX-G2) (SYM5))
  (:APP :SELECTED (|sym4| F0 SYM5) NIL)))

とできました。プログラムはもっとすごい（ひどい）ぞ。

(defmethod do-cps-block-analyzer ((parser cps-block-analyzer) env)
  (let* ((top-env (car env))
         (vars-holder (assoc :vars top-env))
         (var-list (cdr vars-holder))
         (insns-holder (assoc :insns top-env))
         (insn-list (cdr insns-holder)))

      ;(print `(env ,env))
      ;(print `(var-list ,var-list))
      ;(print `(insn-list ,insn-list))
      (labels ((do-cps-block-analyzer0 (len rv)
        (if (= 0 len) (nreverse rv)
          (let* ((runnable-list
                  (remove-if #'null
                    (mapcar #'(lambda (insn)
                      (let* ((op (car insn))
                             (info (cdr insn))
                             (stat (car info))
                             (args (cadr info))
                             (result (caddr info)))

                        (case stat
                          (:runnable insn)
                          (:selected nil)
                          (:init
                            (if
                              (reduce #'(lambda (a b) (and a b))
                                      (mapcar #'(lambda (x)
                                        (car (member x var-list :test
                                           #'(lambda (x0 target)
                                               (and (eq (car target) x0)
                                                    (eq (cdr target) :live))))))
                                              args))
                              insn)))))
                            insn-list)))
                 (selected-runnable
                   (if (= 1 (length runnable-list))
                     (car runnable-list)
                     (let* ((depth-list (mapcar #'(lambda (runnable)
                              (multiple-value-bind (n m)
                                (chase-depth parser runnable insn-list var-list)
                                (list n m))) runnable-list))
                            (runnable-depth-list
                             (mapcar #'cons runnable-list depth-list)))
                       ;(print `(depth-list ,depth-list))
                       (car
                         (reduce #'(lambda (a b)
                                   (let* ((depth-a (cdr a))
                                          (depth-a0 (car depth-a))
                                          (depth-b (cdr b))
                                          (depth-b0 (car depth-b))
                                          (a<b?
                                            (cond
                                              ((< depth-a0 depth-b0) t)
                                              ((= depth-a0 depth-b0)
                                               (let ((depth-a1 (cadr depth-a))
                                                     (depth-b1 (cadr depth-b)))
                                                 (< depth-a1 depth-b1)))
                                              (nil nil))))
                                     (if a<b? b a)))
                               runnable-depth-list))))))
            (mapc #'(lambda (insn)
                      (setf (cadr insn) :runnable)) runnable-list)
            (cps-select-runnable parser selected-runnable var-list insn-list)

            ;(setf (cadr selected-runnable) :selected)
            ;(print `(selected-runnable ,selected-runnable))
            ;(print `(runnable-list ,runnable-list))
            ;(print `(insn-list ,insn-list))
            ;(print `(var-list ,var-list))

            (let ((next-len
                    (if (null selected-runnable) len (- len 1)))
                  (next-rv
                    (if (null selected-runnable) rv (cons selected-runnable rv))))
              (do-cps-block-analyzer0 next-len next-rv))))))

        (do-cps-block-analyzer0 (length insn-list) '()))))

let* の使い方が雑だなぁ、、、

デバッグに format は使わない、、、