;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

(use goo/boot)
(use goo)
(use cols/priority-queue)
(use eval/ast)
(use eval/top)

;;; TODO:
;;; x WALK ALL BINDINGS
;;; x NEED LITERALS VECTOR IN GEN -- METS, NXT-METS, TYPES
;;; x NEXT-METHODS TRACKING
;;; x DEPENDENCY TRACKING
;;;     just use current system
;;; o FAST ISA?
;;;     bit matrix algorithm
;;;       class numbering
;;;       fixed vectors
;;;       class vector
;;;     other types
;;;       t< -- straight subclass using bitmatrix
;;;       t= -- code gen
;;;       t+ -- code gen
;;; o COMMON SUBEXPRESSION ELIMINATION
;;;     hoist class-of
;;; o CONSTANT FOLDING
;;;     remove tests against <any>
;;; o INLINING
;;;     inline prop access
;;; o DYNAMIC COMPILATION
;;;     compile expression as in top
;;;     circumvent module system
;;; o OPTIMIZE ISA?
;;;     leaf classes
;;;     tag checks

(df fun-spec (x|<fun> i|<int> => <type>)
  (elt (fun-specs x) i))

;;; how access gen's that aren't in the current module?
;;;   perhaps build mapping table
;;;   could also have gen store mangled binding name
;;;   could also store binding in gen and make that point to real binding

(dm build-decision-tree (g|<gen>)
  (def code   (build-decision-tree* g 0 (len (fun-specs g)) (fun-mets g)))
  (def dname  (cat-sym "d-" (fun-name g) "-dispatch"))
  (def dfun   `(df ,dname (args|...) ,code))
  (def dpatch `(set (%gen-code ,(fun-name g)) (%met-code ,dname)))
  (def top    `(seq ,dfun ,dpatch #t))
  top)

(ds type-case (,val ,@cases)
  (loc ((do-type-case (val cases)
          (if (nul? cases)
              #f
              (match (head cases) 
                ((#t ,@body)    
                 `(seq ,@body))
                (((,@values) ,@body)
                 `(if (or ,@(map (fun (x) `(subtype? ,val ,x)) values))
                      (seq ,@body)
                      ,(do-type-case val (tail cases))))
                (#t
                 (syntax-error "bad type-case %=" (head cases)))))))
    (let ((val-var (gensym)))
      `(let ((,val-var (class-of ,val)))
         ,(do-type-case val-var cases)))))

(dm build-decision-tree* (g|<gen> i|<int> n|<int> mets|<lst>)
  (if (< i n)
      (loc ((test (x y) (subtype?  (fun-spec x i) (fun-spec y i))))
        (def ordered-mets (priority-order test mets))
        (loc ((filter (mets type pos)
                (priority-order test 
                  (pick (fun (met) (subtype? type (fun-spec met pos))) mets)))
              (code-gen-case (m mets)
                (def type (fun-spec m i))
                `((,type)
                  ,(build-decision-tree*
                    g (+ i 1) n (filter mets type i))))
              (code-gen-cases (mets)
                (packing
                  (rep loop ((mets mets))
                    (unless (nul? mets)
                      (pack (code-gen-case (head mets) mets))
                      (loop (tail mets)))))))
          `(type-case (@oelt args ,i) 
             ,@(code-gen-cases ordered-mets)
             (#t (no-app-met ,g args)))))
      `(%raw-met-call ,(head mets) ',(tail mets))))

(dm foo ((x <num>)) (tup x)) 
(dm foo ((x <flo>)) (lst x))
(dm foo ((x <int>)) x)

;; (seq (set goo/io/write:*max-print-depth* 100) (set goo/io/write:*max-print-length* 1000))

(dv d (build-decision-tree foo))

(ds def-tree (,gen) (build-decision-tree gen))

(df time (n) (let ((x 0)) (for ((i (below n))) (set x (+ x i))) x))

;;; (f 2000000)
;;; (build-decision-tree +)
;;; (auto-eval d (runtime-environment 'goo/user))
    
