Infer monomorphic protocol-method return types (#234)

A protocol method whose impls all return the same record type has a monomorphic
return. collect-pm-rets! scans the unit's (register-(inline-)method ..) forms,
infers each impl fn's return type, and joins them per method; call-ret-type then
types a (method recv ..) call as that record, so a field read off the result
bare-indexes — e.g. (:ray (scatter m ..)) reads off a Ray. A disagreeing impl
joins to :any and keeps the generic path.

run-protoret.ss: a method with all-record impls bare-indexes + unboxes the field
read; a mixed-return method (one impl returns a number) stays generic. make test /
shakesmoke green, selfhost holds, 0 new divergences.

Foundation for auto-typing record values that flow through protocol dispatch. Does
not yet move the ray tracer: its scatter returns ScatterResult-or-nil (Metal
absorbs some rays), and the nil widens the join to :any — typing a nullable return
soundly needs flow-sensitive narrowing (a guarded (some? x) proves non-nil), filed
separately.

Co-authored-by: Yogthos <yogthos@gmail.com>

host/chez/run-protoret.ss

@@ -0,0 +1,70 @@
+;; run-protoret.ss — protocol-method return-type inference gate.
+;;
+;; A protocol method whose impls all return the same record type has a monomorphic
+;; return: collect-pm-rets! joins the impl return types, and call-ret-type then types
+;; a (method recv ..) call as that record — so a field read off the result bare-
+;; indexes. This is the ray tracer's (:ray (scatter material ..)): scatter's impls
+;; all return a ScatterResult, so the bounced ray types without a hint.
+;;
+;;   chez --script host/chez/run-protoret.ss
+(import (chezscheme))
+(load "host/chez/rt.ss")
+(set-chez-ns! "clojure.core")
+(load "host/chez/seed/prelude.ss")
+(load "host/chez/post-prelude.ss")
+(set-chez-ns! "user")
+(load "host/chez/host-contract.ss")
+(load "host/chez/seed/image.ss")
+(load "host/chez/compile-eval.ss")
+
+(define analyze (var-deref "jolt.analyzer" "analyze"))
+(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
+(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
+(define wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
+(define run-passes (var-deref "jolt.passes" "run-passes"))
+(define emit (var-deref "jolt.backend-scheme" "emit"))
+(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
+(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
+(define (sub? s t)(let((n(string-length s))(m(string-length t)))(let loop((i 0))(cond((>(+ i m)n)#f)((string=?(substring s i(+ i m))t)#t)(else(loop(+ i 1)))))))
+
+(define fails 0) (define total 0)
+(define (check label actual expected)
+  (set! total (+ total 1))
+  (unless (equal? actual expected)
+    (set! fails (+ fails 1))
+    (printf "  FAIL ~a: got ~s expected ~s\n" label actual expected)))
+
+(evals "(defrecord R [^double k])")
+(evals "(defprotocol P (m [x]))")
+(evals "(defrecord A [v] P (m [x] (->R 1.0)))")
+(evals "(defrecord B [v] P (m [x] (->R 2.0)))")
+(evals "(defprotocol Q (q [x]))")
+(evals "(defrecord C [v] Q (q [x] (->R 3.0)))")
+(evals "(defrecord D [v] Q (q [x] 7)))")     ; one impl returns a number, not R
+(set-record-shapes! (chez-record-shapes-map))
+(set-protocol-methods! (chez-protocol-methods-map))
+(set-optimize! #t)
+
+;; analyze the impl-registering forms + a consumer; the fixpoint collects the
+;; impl return types. (the analyzed defrecord nodes carry register-inline-method.)
+(define na (anode "(defrecord A [v] P (m [x] (->R 1.0)))"))
+(define nb (anode "(defrecord B [v] P (m [x] (->R 2.0)))"))
+(define nc (anode "(defrecord C [v] Q (q [x] (->R 3.0)))"))
+(define nd (anode "(defrecord D [v] Q (q [x] 7))"))
+(define f  (anode "(def f (fn [a] (* (:k (m a)) 2.0)))"))
+(define g  (anode "(def g (fn [a] (:k (q a))))"))
+(wp-infer! (jolt-vector na nb nc nd f g))
+
+;; m's impls all return R -> (:k (m a)) reads off an R -> bare-index + unbox.
+(define fe (emit (run-passes f (make-analyze-ctx "user"))))
+(check "monomorphic protocol return bare-indexes the field read" (sub? fe "jrec-field-at") #t)
+(check "monomorphic protocol return unboxes the ^double field" (sub? fe "fl") #t)
+
+;; q's impls return R and a number -> joined to non-record -> stays generic (sound).
+(define ge (emit (run-passes g (make-analyze-ctx "user"))))
+(check "mixed-return protocol keeps generic jolt-get" (sub? ge "jolt-get") #t)
+(check "mixed-return protocol does not bare-index" (sub? ge "jrec-field-at") #f)
+
+(if (= fails 0)
+    (begin (printf "protoret gate: ~a/~a passed\n" total total) (exit 0))
+    (begin (printf "protoret gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))