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

(use goo)
(use goo/loc)
(use eval/ast)

(dm unconstrained-type? (b|<program> => <log>)
  #f)

(dm unconstrained-type? (b|<module-binding> => <log>)
  (and (== (binding-module-name b) 'goo/boot) (== (binding-name b) '<any>)))

(dm unconstrained-type? (o|<module-binding-reference> => <log>)
  (unconstrained-type? (reference-binding o)))

(export unconstrained-type?)

(dv <arg-seq> <lst>)
(dv <met-seq> <lst>)

(dm sorted-applicable-methods-using-types
    (methods|<met-seq> arg-types|<arg-seq> 
      => (tup sorted|<met-seq> others|<met-seq>))
  (def leading-sorted '())
  (def others         '())
  (loc ((merge-method (m sorted)
          (if (nul? sorted)
              (loc ((after-m? (other-m)
                      (method-precedes? m other-m arg-types)))
                (if (all? after-m? others)
                    (lst m)
                    (seq (pushf others m) '())))
              (let ((lead (head sorted)))
                (case (method-relationship m lead arg-types)
                  (($method1-precedes) 
                   (pair m sorted))
                  (($method2-precedes)
                   (pair lead (merge-method m (tail sorted))))
                  (($methods-unordered)
                   ;; Unordered methods are no use to us, so abandon 
                   ;; everything from here on.
                   (set others (pair m (cat sorted others)))
                   '()))))))
    (for ((m methods))
      (when (arguments-potentially-joint?
             arg-types (fun-specs m) (fun-arity m))
        (opf leading-sorted (merge-method m _)))))
  (tup leading-sorted others))

(export sorted-applicable-methods-using-types)

;; Determine whether there is some guaranteed ordering between the two
;; methods for the given argument type estimates.

(dv $methods-unordered 'unordered)
(dv $method1-precedes  'method1)
(dv $method2-precedes  'method2)

(dm method-precedes? (m1|<met> m2|<met> (arg-types <arg-seq>))
  (== (method-relationship m1 m2 arg-types) $method1-precedes))

;; This is pretty much as per the DRM specification, but using the
;; conservative "xxx" predicates.

(dm method-relationship (m1|<met> m2|<met> arg-types|<arg-seq> => <sym>)
  (def specs1              (fun-specs m1))
  (def specs2              (fun-specs m2))
  (def precedes-somewhere? #f)
  (def follows-somewhere?  #f)
  (for ((arg-type arg-types) (spec1 specs1) (spec2 specs2))
    (cond
      ((== spec1 spec2) #f)
      ((preceding-specializer? spec1 spec2 arg-type)
       (unless (subtype? spec2 spec1) (set precedes-somewhere? #t)))
      ((preceding-specializer? spec2 spec1 arg-type)
       (set follows-somewhere? #t))
      (#t #f)))
  (if precedes-somewhere?
      (if follows-somewhere? $methods-unordered $method1-precedes)
      (if follows-somewhere? $method2-precedes  $methods-unordered)))

(dg preceding-specializer?
    (t1|<type> t2|<type> arg|<type> => <log>))

(dm preceding-specializer? (t1|<type> t2|<type> arg|<type> => <log>)
  (subtype? t1 t2))

(dm arguments-potentially-joint? 
    (arg-types|<arg-seq> domain-types|<arg-seq> max|<int> => <log>)
  (all2? potentially-joint? arg-types domain-types))

(df potentially-joint? (t1|<type> t2|<type> => <log>)
  ;; Not provably DISjoint.
  ;; (not (guaranteed-disjoint? t1 t2))
  (or (subtype? t1 t2) (subtype? t2 t1)))

(dm type-equiv? (x|<type> y|<type> => <log>)
  (and (subtype? x y) (subtype? y x)))

;;; DYNAMIC-EXTENT AND CALL UPGRADE ANALYSIS

(dm do-do-call-analysis! (o|<program> r t f s funs)
  (ast-walk! do-call-analysis! o r t f s funs))

(dm do-call-analysis! (o|<program> r t f s funs)
  (do-do-call-analysis! o r t f s funs))

(df reopt-top! (s t)
  (unless (or (not t) (mem? s t)) (add! s t)))

(dm do-call-analysis! (o|<local-reference> r t f s funs)
  (unless (reference-called-function? o)
    (set (binding-dynamic-extent? (reference-binding o)) #f))
  (def fun? (binding-value (reference-binding o)))
  (if (and fun? (mem? funs fun?)) 
      (if (= (function-ref-count fun?) 1)
          { (reopt-top! s t) 
            (decf (function-ref-count fun?))
            fun? }
          o)
      o))

(dm do-call-analysis! (o|<ast-embodied-function> r t f s funs)
  (do-call-analysis! (function-signature o) r t f s funs)
  (def body (do-call-analysis! (function-body o) r t o s funs))
  (when (and (function-loop o) (not (isa? body <loop>)))
    (set (loop-body (function-loop o)) body)
    (set (function-body o)             (function-loop o)))
  o)

(dm ensure-loop (f|<ast-embodied-function> => <loop>)
  (or/set (function-loop f)
    (new <loop> loop-bindings (function-bindings f))))

(dm do-call-analysis! (o|<regular-application> r t f s funs)
  (do-do-call-analysis! o r t f s funs)
  (def ref (application-function o))
  (case-by ref isa?
    ((<local-reference>)
     (let ((callee (binding-value (reference-binding ref))))
       (if (and (== callee f) (application-tail? o) (not (function-nary? f)))
           (let ((loop (ensure-loop f)))
             (decf (function-ref-count f))
             (reopt-top! s t) 
             (new <loop-application>
               application-loop      loop
               application-arguments (application-arguments o)))
           (if (and (isa? f <ast-function>)
                    (all? (fun (x) (unconstrained-type? (binding-type x)))
                          (function-bindings f))
                    (unconstrained-type? (function-value f))
                    (not (function-nary? f))
                    (= (len (application-arguments o))
                       (len (function-bindings f))))
               (seq (set (application-known? o) #t) o)
               o))))
    ((<ast-embodied-function>)
     (reopt-top! s t) 
     (process-closed-application
      ref (application-arguments o) r (application-tail? o)))
    (#t o)))

(dm do-call-analysis! (o|<locals> r t f s funs)
  (def single?  (= (len (locals-functions o)) 1))
  (def new-funs (if single? (pair (1st (locals-functions o)) funs) funs))
  (def res      (do-do-call-analysis! o r t f s new-funs))
  (if single?
      (if (= (function-ref-count (1st new-funs)) 0)
          { (reopt-top! s t) 
            (set (locals-functions o) (nul <functions>))
            (set (locals-bindings o)  '())
            (locals-body o) }
          res)
      res))

(dm analyze-calls (o r)
  (def s (fab <vec> 0)) ;; reopts
  (def res 
    (if (isa? o <sequential>)
        (map (fun (x) (do-call-analysis! x r x #f s '())) o)
        (do-call-analysis! o r o #f s '())))
  (if (nul? s) ;; no more reopts
      res
      { (do (fun (e) (analyze-calls e r)) s) res }))

(export analyze-calls
        ;; analyze-dynamic-extent
        potentially-joint?
        type-equiv?
        )
