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

(use goo)
(use goo/boot)
(use goo/fun)
(use goo/types)
(use eval/ast)
(use eval/ast-linearize)
(use eval/ast-eval)
(use eval/optimize)
(use goo/io/read)

(dm type-union (x|<type> y|<type> => <type>)
  (cond
    ((subtype? x y) y)
    ((subtype? y x) x)
    ((isa? x <union>) 
     (new <union> union-elts (if (isa? y <union>) (cat x y) (pair y x))))
    (#t 
     (new <union> union-elts (if (isa? y <union>) (pair x y) (lst x y))))))

;; TODO: CONSERVATIVE
(dm type-intersection (x|<type> y|<type> => <type>)
  (cond
    ((subtype? x y) x)
    ((subtype? y x) y)
    (#t             <any>)))

(dc <type-state> (<any>))
  (dp type-state-acts (<type-state> => <tab>) (fab <tab> 0))
  (dp type-state-env  (<type-state> => <any>))

(dc <act> (<any>))

(dc <dispatch> (<act>))
  (dp act-sorted (<dispatch> => <lst>))

(dc <know-call> (<act>))

(dc <fold> (<act>))

(dc <fold-if> (<fold>))
  (dp act-test (<fold-if> => <log>))

(dc <fold-call> (<fold>))
  (dp act-val (<fold-call> => <any>))

(dc <prop-access> (<fold>))
  (dp act-off (<prop-access> => <int>))

(dc <inline-call> (<fold>))
  (dp act-val (<inline-call> => <any>))

(dm mem-act (s|<type-state> x act|<act>)
  (set [(type-state-acts s) x] act))

(dm type-infer-check (a t s)
  (def inferred-type (type-infer a s))
  (def type          (type-value (type-infer t s)))
  (post "IT %= T %=\n" inferred-type type)
  (if (subtype? inferred-type type) 
      inferred-type
      type))

(dm type-infer-all (x|<program> r)
  (let ((s (new <type-state> type-state-env r)))
    (type-infer x s)
    (type-state-acts s)))

(dm type-infer (x|<program> s|<type-state>)
  (post "TYPING %= \n" x)
  (def res (opf (program-type x) (type-union _ (do-type-infer x s))))
  (post "TYPING %= => %t\n" x res)
  res)

(dm do-type-infer (x|<program> s|<type-state>)
  (error "NYI %t: %=" (class-of x) x ))

(dm do-type-infer (x|<sequential> s|<type-state>)
  (do (op type-infer _ s) x)
  (program-type (last x)))

(dm do-type-infer (x|<constant> s|<type-state>)
  (case-by (constant-value x) isa?
    ((<log>) (t= (constant-value x)))
    (#t      (class-of (constant-value x)))))

(dm do-type-infer (x|<assignment> s|<type-state>)
  (type-infer (assignment-form x) s))

(dm type-infer-binding (x|<module-binding> s|<type-state>)
  (let ((val (binding-value-or x #f)))
    (case-by val isa?
      ((<fun> <type>)  (t= val))
      (#t              <any>)))) ;; TODO: module-type

(dm type-infer-binding (x|<binding> s|<type-state>)
  ;; TODO: PRETTY LIMITED
  <any>)

(dm type-value (t|<type> => <type>)
  <any>)

(dm type-value (t|<singleton> => <type>)
  (type-object t))

(dm type-infer-binding (x|<local-binding> s|<type-state>)
  ;; (post "LB BV %=\n" (binding-value x))
  (cond ((binding-mutable? x)
         <any>)
        ((binding-value x)
         (t= (binding-value x)))
        (#t
         (binding-inferred-type x))))

(dm do-type-infer (x|<real-reference> s|<type-state>)
  (type-infer-binding (reference-binding x) s))

(dm do-type-infer (x|<bound?> s|<type-state>)
  <log>)

(dm do-type-infer (x|<definition> s|<type-state>)
  (t= #f))

(dm do-type-infer (x|<ast-method> s|<type-state>)
  (for ((b (function-bindings x)))
    (set (binding-inferred-type b) 
         (type-value (type-infer (binding-type b) s))))
  (type-infer (function-body x) s)
  ;; TODO: TIGHTEN UP
  <met>)

(dm do-type-infer (x|<ast-generic> s|<type-state>)
  <gen>)

(dm do-type-infer (x|<alternative> s|<type-state>)
  (def test-type (type-infer (alternative-condition x) s))
  (cond ((type-equiv? test-type (t= #f))
         (mem-act s x (new <fold-if> act-test #f))
         (type-infer (alternative-alternant x) s))
        ((not (potentially-joint? test-type (t= #f)))
         (mem-act s x (new <fold-if> act-test #t))
         (type-infer (alternative-consequent x) s))
        (#t
         (type-union (type-infer (alternative-consequent x) s)
                     (type-infer (alternative-alternant x)  s)))))

(dm do-type-infer (x|<sequential> s|<type-state>)
  (do (op type-infer _ s) x)
  (type-infer (last x) s))

(dm do-type-infer (x|<fix-let> s|<type-state>)
  (for ((binding (fix-let-bindings x))
        (type    (fix-let-types x))
        (arg     (fix-let-arguments x)))
    (unless (binding-mutable? binding)
      (set (binding-inferred-type binding)
           ;; (type-infer arg s)
           (type-infer-check arg (binding-type binding) s))))
  (type-infer (fix-let-body x) s))

;; TODO: the following are incomplete

(dm subtype? (x|<bot> y|<bot> => <log>) #t)

(dm do-type-infer (x|<locals> s|<type-state>)
  (do (op type-infer _ s) (locals-functions x))
  (type-infer (locals-body x) s))

(dm do-type-infer (x|<loop> s|<type-state>)
  (loc ((recurse (arg-types)
          (def param-types
            (map binding-inferred-type (loop-bindings x)))
          (def new-param-types
            (map2 { b a \ (opf (binding-inferred-type b) (type-union _ a)) }
                  (loop-bindings x) arg-types))
          (post "PARAM TYPES %=\n" param-types)
          (post "ARGUM TYPES %=\n" arg-types)
          (post "NEW-PARAM TYPES %=\n" new-param-types)
          (if (all2? type-equiv? param-types new-param-types) ;; fixpoint?
              (program-type x)
              (type-infer (loop-body x) s))))
    (dlet (((loop-continue x) recurse))
      (type-infer (loop-body x) s))))

(dm do-type-infer (x|<loop-application> s|<type-state>)
  (let ((loop (application-loop x)))
    ((loop-continue loop)
     (map2 (fun (a b) (type-infer-check a (binding-type b) s))
           (application-arguments x)
           (loop-bindings loop)))))

(dm do-type-infer (x|<predefined-application> s|<type-state>)
  (do (op type-infer _ s) (application-arguments x))
  <any>)

(dm arity-check? (nary? arity x|<regular-application> s|<type-state> => <log>)
  (def len (len (application-arguments x)))
  (if nary? (>= len arity) (= len arity)))

(dm known-call?
    (nary? arity arg-types fun-types x|<regular-application> s|<type-state> 
     => <log>)
  (if (and (arity-check? nary? arity x s)
           (all2? subtype? arg-types fun-types))
      { (mem-act s x (new <know-call>)) #t }
      #f))

(dm type-known-met-call 
    (x|<regular-application> f|<met> nms|<lst> s|<type-state> => <type>)
  (if (fun-inlineable? f)
      (let ((r  (type-state-env s))
            (fi (dynamic-compute-program
                 (read-from-string (fun-src f)) (type-state-env s)))
            (c  (process-closed-application 
                 fi (application-arguments x) r (application-tail? x))))
        (mem-act s x (new <inline-call> act-val c))
        (type-intersection (type-infer c s) (fun-val f)))
      { (mem-act s x (new <know-call>)) (fun-val f) }))

(dm met-prop (m|<met> => (t? <prop>))
  (%met-env m))

(df prop-offset-in (t|<class> p|<prop> => (t? <int>))
  (pos (class-props t) p))

(dm all-prop-offsets (t|<class> p|<prop> => (t? <int>))
  (def off (prop-offset-in t p))
  (and (all? (op = (prop-offset-in _ p) off) (class-children t)) off)) 

(dm type-prop-access 
    (x|<regular-application> g|<gen> m|<met> s|<type-state> => <type>)
  (post "TYPING PROP-ACCESS\n")
  (def args (application-arguments x))
  (def prop (met-prop m))
  (def type (type-infer (if (= (len args) 1) [args 0] [args 1]) s))
  (def off  (all-prop-offsets type prop))
  (if off
      { (post "CONST-PROP-ACCESS %d\n" off)
        (mem-act s x (new <prop-access> act-off off)) }
      (mem-act s x (new <know-call>)))
  (prop-type prop))

(dm do-type-infer (x|<regular-application> s|<type-state>)
  (def arg-types (map (op type-infer _ s) (application-arguments x)))
  (def fn        (application-function x))
  (def fun-type  (type-infer fn s))
  (if (isa? fun-type <singleton>)
      (let ((f (type-object fun-type)))
        (case-by f isa? 
          ((<gen>) 
           (if (arity-check? (fun-nary? f) (fun-arity f) x s)
               (let (((tup sorted others) 
                      (sorted-applicable-methods-using-types
                       (fun-mets f) arg-types)))
                 (post "APP-METS %= %= %= %=\n" f arg-types sorted others)
                 (if (or (nul? sorted) (not (nul? others)))
                     { (mem-act s x (new <know-call>)) (fun-val f) }
                     (if (and (met-prop (head sorted)) (nul? (tail sorted)))
                         { (type-prop-access x f (head sorted) s) }
                         { (post "KNOWN MET CALL\n")
                           (type-known-met-call
                            x (head sorted) (tail sorted) s) })))
               (fun-val f)))
          ((<ast-method>) 
           (def fun-types
             (map (op type-value (type-infer _ s)) (function-specs f)))
           (if (known-call? 
                (function-nary? f) (function-arity f) arg-types fun-types x s)
               { (mem-act s x (new <know-call>)) 
                 (type-value (type-infer (function-value f) s)) }

               <any>))
          ((<fun>) 
           (if (known-call?
                (fun-nary? f) (fun-arity f) arg-types (fun-specs f) x s)
               (type-known-met-call x f '() s)
               <any>))
          (#t
           <any>)))
      <any>))

(dm do-type-infer (x|<bind-exit> s|<type-state>)
  <any>)

(dm do-type-infer (x|<unwind-protect> s|<type-state>)
  <any>)

(dm do-type-infer (x|<monitor> s|<type-state>)
  <any>)

(export potentially-joint? type-infer)

;;; TYPE-DIRECTED SURGERY

(dm surgery! (o|<program> acts|<tab> r)
  (ast-walk! surgery! o acts r))

(dm do-surgery! (o|<program> act r) o)  ;; default noop

(dm do-surgery! (o|<regular-application> act|<dispatch> r)
  (def mets (act-sorted act))
  (new <method-application>
    application-arguments    (application-arguments o)
    application-function     (new <constant> constant-value (head mets))
    application-next-methods (new <constant> constant-value (tail mets))
    application-tail?        (application-tail? o)))

(dm do-surgery! (o|<regular-application> act|<fold-call> r)
  (objectify-with-subtransaction (act-val act) r #t (application-tail? o)))

(dm do-surgery! (o|<regular-application> act|<prop-access> r)
  (def args (application-arguments o))
  (dynamic-compute-program
   (if (= (len args) 2)
       `(prop-value-at-setter ,@args)
       `(prop-value-at ,@args))
   r))

(dm do-surgery! (o|<regular-application> act|<inline-call> r)
  (act-val act))

(dm do-surgery! (o|<regular-application> act|<know-call> r)
  (set (application-known? o) #t)
  o)

(dm do-surgery! (o|<alternative> act|<fold-if> r)
  (if (act-test act)
      (alternative-consequent o)
      (alternative-alternant o)))

(dm surgery! (o|<regular-application> acts|<tab> r)
  (post "ACTS %=\n" acts)
  (post "VISITING APP %= ACT %=\n" o (elt-or acts o #f))
  (ast-walk! surgery! o acts r)
  (do-surgery! o (elt-or acts o #f) r))

(dm surgery! (o|<alternative> acts|<tab> r)
  (do-surgery! o (elt-or acts o #f) r))

(dv cp #f)

;; (dv cp eval/g2m:asm-compute-program)

(df type-exp (x)
  (let ((r   (runtime-environment 'eval/typist))
        (ast (cp x r))) 
    (type-infer-all ast r)
    ast))

(df type+opt-exp (x)
  (let ((r    (runtime-environment 'eval/typist))
        (ast  (cp x r))
        (acts (type-infer-all ast r)))
    (surgery! ast acts r)))

;;;;
;;;; 
;;;;

(dm dynamic-compute-program (exp env)
  (def ast (objectify-with-subtransaction exp env #t #f))
  (def ana (analyze-calls ast env))
  (def box (insert-box! ana))
  (def lft (lift! box))
  lft)

(dv dync #f)
;; (dv dync eval/top:g2c-eval)
;; (df f (x|<fixnum>) (+ x 1))

(dm optimize-method (m|<met>)
  (def src   (read-from-string (fun-src m)))
  (def srcl  (fun-src-loc m))
  (def mod   (as <sym> (src-loc-file srcl)))
  (def r     (runtime-environment mod))
  ;; TODO: CHANGE TO MET-CODE-SET
  (def patch `(set (%gen-code ,m) (%met-code ,src))) 
  (def ast   (dynamic-compute-program patch r))
  (def acts  (type-infer-all ast))
  (def oast  (surgery! ast acts r))
  (dync oast r)
  oast)
