diff --git a/host/chez/host-contract.ss b/host/chez/host-contract.ss index 3609d23..b01f716 100644 --- a/host/chez/host-contract.ss +++ b/host/chez/host-contract.ss @@ -361,8 +361,19 @@ (define (hc-syntax-quote-lower ctx inner) (hc-sq-lower ctx inner (make-hashtable string-hash string=?))) -(define (hc-record-type? ctx name) #f) -(define (hc-record-ctor-key ctx name) jolt-nil) +;; a ^Type param hint: name is the tag (a symbol, sometimes a string). Resolve it +;; against the record registry (records.ss) so the inference seeds the param as +;; that record — the open-world / cross-ns path where no caller type is inferred. +(define (hc-record-tag-name name) + (cond ((symbol-t? name) (symbol-t-name name)) + ((string? name) name) + (else #f))) +(define (hc-record-type? ctx name) + (let ((nm (hc-record-tag-name name))) + (if (and nm (chez-find-ctor-key nm (chez-current-ns))) #t #f))) +(define (hc-record-ctor-key ctx name) + (let ((nm (hc-record-tag-name name))) + (or (and nm (chez-find-ctor-key nm (chez-current-ns))) jolt-nil))) ;; record + protocol-method shapes for the inference, from the runtime registries ;; (records.ss) populated as deftype/defprotocol forms load. (define (hc-record-shapes ctx) (chez-record-shapes-map)) diff --git a/host/chez/records.ss b/host/chez/records.ss index 95aeb1c..d2b556b 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -100,6 +100,21 @@ ks vs)) out)) +;; resolve a record TYPE name (a ^Type param hint's tag) to the ctor-key +;; "ns/->Name" the inference seeds with. Prefer the ctor in `ns` (the compile ns); +;; else any registered record with that simple name (cross-ns / imported). #f if +;; the name isn't a record type (so a ^double/^String hint resolves to nil). +(define (chez-find-ctor-key name ns) + (let* ((simple (chez-shape-simple-name name)) + (target (string-append "->" simple)) + (preferred (string-append ns "/->" simple))) + (if (hashtable-ref chez-record-shapes-tbl preferred #f) + preferred + (let loop ((ks (vector->list (hashtable-keys chez-record-shapes-tbl)))) + (cond ((null? ks) #f) + ((string=? (chez-shape-simple-name (car ks)) target) (car ks)) + (else (loop (cdr ks)))))))) + ;; materialize chez-protocol-methods-tbl into "ns/method" -> [proto method]. (define (chez-protocol-methods-map) (let ((out (jolt-hash-map))) diff --git a/host/chez/run-fieldnum.ss b/host/chez/run-fieldnum.ss index e51091e..567b5c3 100644 --- a/host/chez/run-fieldnum.ss +++ b/host/chez/run-fieldnum.ss @@ -59,6 +59,15 @@ (check "field-field arithmetic unboxes to fl*" (contains-sub? dot-emit "fl*") #t) (check "field-field arithmetic unboxes to fl+" (contains-sub? dot-emit "fl+") #t) +;; a ^V param hint types the param with no inferable caller (open-world / cross-fn: +;; the receiver isn't a ctor return). This is the record-ctor-key path — without it +;; the hint is dead and the reads fall back to generic jolt-get + boxed arithmetic. +(define hinted (anode "(def hyp (fn [^V v] (+ (* (:x v) (:x v)) (* (:y v) (:y v)))))")) +(define hint-emit (emit (run-passes hinted (make-analyze-ctx "user")))) +(check "^V param hint bare-indexes field reads" (contains-sub? hint-emit "jrec-field-at") #t) +(check "^V param hint unboxes arithmetic" (contains-sub? hint-emit "fl*") #t) +(check "^V param hint leaves no generic jolt-get" (contains-sub? hint-emit "jolt-get") #f) + ;; an UNTAGGED field stays generic — no fl-op (the read is :any, not :double). (evals "(defrecord W [p q])") (define dotw (anode "(def dotw (fn [a b] (* (:p a) (:p b))))"))