diff --git a/host/chez/compile-eval.ss b/host/chez/compile-eval.ss index c68cd87..0c67bb9 100644 --- a/host/chez/compile-eval.ss +++ b/host/chez/compile-eval.ss @@ -13,6 +13,13 @@ (define jolt-ce-emit (var-deref "jolt.backend-scheme" "emit")) (define jolt-ce-read (var-deref "clojure.core" "read-string")) +;; The zero-Janet spine ALWAYS runs with the full clojure.core prelude loaded, so a +;; clojure.* ref must lower to var-deref (resolved from the prelude), not trip the +;; emitter's "unsupported stdlib fn (no core on Chez yet)" out-of-subset guard — +;; that guard is only for the bare -e subset with no prelude. Turn prelude mode on +;; once, here, so every analyze->emit on this spine sees the full core (jolt-qjr0). +((var-deref "jolt.backend-scheme" "set-prelude-mode!") #t) + ;; Source string -> Scheme source string (read -> analyze -> emit, all on Chez). ;; `ns` is the compile namespace unqualified symbols resolve against. (define (jolt-analyze-emit src ns) diff --git a/host/chez/converters.ss b/host/chez/converters.ss index 5a42b89..425d275 100644 --- a/host/chez/converters.ss +++ b/host/chez/converters.ss @@ -47,7 +47,17 @@ (cond ((jolt-nil? a) jolt-nil) ((keyword? a) a) - ((string? a) (keyword #f a)) + ;; a 1-arg string splits on the FIRST "/" into ns/name, like the seed + ;; (keyword "x/y") => :x/y with ns "x" — destructure's {:keys [x/y]} builds + ;; the key this way, so without the split the namespaced key never matches. + ((string? a) + (let ((si (let loop ((i 0)) + (cond ((>= i (string-length a)) #f) + ((char=? (string-ref a i) #\/) i) + (else (loop (+ i 1))))))) + (if (and si (> si 0) (< si (- (string-length a) 1))) + (keyword (substring a 0 si) (substring a (+ si 1) (string-length a))) + (keyword #f a)))) ((jolt-symbol? a) (let ((ns (symbol-t-ns a))) (keyword (if (or (jolt-nil? ns) (not ns) (eq? ns '())) #f ns) (symbol-t-name a)))) diff --git a/host/chez/driver.janet b/host/chez/driver.janet index d9c2f75..49b67f9 100644 --- a/host/chez/driver.janet +++ b/host/chez/driver.janet @@ -364,6 +364,118 @@ (def code (os/proc-wait proc)) [code (string/trim out) (string/trim err)]) +# --- batched zero-Janet corpus runner (jolt-qjr0, inc7) ----------------------- +# eval-zero-janet spawns a fresh chez per case, each reloading rt.ss + the prelude +# (~282KB) + the compiler image (~89KB) from source — ~0.5s of pure reload per +# case, the entire cost. This runs ALL cases in ONE chez process: load the runtime +# once, then loop. Each case is guarded (errors isolated) and the user namespace is +# reset between cases (var-table keys added by a case are removed, *ns* restored) so +# there is no state leakage vs the per-process path. ~10-30x faster. + +(defn program-corpus-zero-janet + "A Chez program that loads the zero-Janet runtime once, then runs every case in + `cases-tsv` (labelsrc per line) through jolt-compile-eval, printing one + result line per case: PASSlabel | DIVERGElabelvalue | + CRASHlabelmessage." + [prelude-path image-path cases-tsv] + (string + "(import (chezscheme))\n" + "(load \"host/chez/rt.ss\")\n" + "(set-chez-ns! \"clojure.core\")\n" + "(load " (string/format "%j" prelude-path) ")\n" + "(load \"host/chez/post-prelude.ss\")\n" + "(set-chez-ns! \"user\")\n" + "(load \"host/chez/host-contract.ss\")\n" + "(load " (string/format "%j" image-path) ")\n" + "(load \"host/chez/compile-eval.ss\")\n" + # Snapshot mutable global state after setup so each case sees a clean world (as + # if it ran in its own process): (1) var-table keys a case ADDS (its defs) are + # removed; (2) a base cell whose ROOT a case mutated (e.g. in-ns rebinds + # clojure.core/*ns*) is restored; (3) the ns + type registries are pruned back to + # their base keys. Without this, *ns*/find-ns/all-ns/satisfies? leak across cases. + "(define zj-base (let ((h (make-hashtable string-hash string=?)))\n" + " (vector-for-each (lambda (k) (hashtable-set! h k #t)) (hashtable-keys var-table)) h))\n" + "(define zj-roots '())\n" + "(vector-for-each (lambda (k) (let ((c (hashtable-ref var-table k #f)))\n" + " (when c (set! zj-roots (cons (cons c (var-cell-root c)) zj-roots)))))\n" + " (hashtable-keys var-table))\n" + "(define (zj-snap ht) (let ((h (make-hashtable string-hash string=?)))\n" + " (vector-for-each (lambda (k) (hashtable-set! h k #t)) (hashtable-keys ht)) h))\n" + "(define (zj-prune! ht base) (vector-for-each\n" + " (lambda (k) (unless (hashtable-ref base k #f) (hashtable-delete! ht k))) (hashtable-keys ht)))\n" + "(define zj-ns-base (zj-snap ns-registry))\n" + "(define zj-type-base (zj-snap type-registry))\n" + # global-hierarchy is a core atom whose CONTENTS `derive` mutates (its var root + # stays the same atom object, so the root-restore above misses it). Reset its + # contents to a fresh hierarchy each case. + "(define zj-ghier (var-cell-lookup \"clojure.core\" \"global-hierarchy\"))\n" + "(define (zj-reset!)\n" + " (vector-for-each (lambda (k) (unless (hashtable-ref zj-base k #f) (hashtable-delete! var-table k)))\n" + " (hashtable-keys var-table))\n" + " (for-each (lambda (cr) (unless (eq? (var-cell-root (car cr)) (cdr cr))\n" + " (var-cell-root-set! (car cr) (cdr cr)))) zj-roots)\n" + " (zj-prune! ns-registry zj-ns-base)\n" + " (zj-prune! type-registry zj-type-base)\n" + " (when zj-ghier (jolt-invoke (var-deref \"clojure.core\" \"reset!\")\n" + " (var-cell-root zj-ghier) (jolt-invoke (var-deref \"clojure.core\" \"make-hierarchy\"))))\n" + " (set-chez-ns! \"user\"))\n" + "(define kw-message (keyword #f \"message\"))\n" + "(define (zj-err->str e)\n" + " (cond ((and (pmap? e) (string? (jolt-get e kw-message))) (jolt-get e kw-message))\n" + " ((condition? e) (call-with-string-output-port (lambda (p) (display-condition e p))))\n" + " ((string? e) e)\n" + " (else (call-with-string-output-port (lambda (p) (write e p))))))\n" + "(define (zj-clean s)\n" # strip tabs/newlines from a message so it stays one TSV line + " (list->string (map (lambda (c) (if (or (char=? c #\\tab) (char=? c #\\newline)) #\\space c))\n" + " (string->list s))))\n" + "(define (zj-run label src)\n" + " (guard (e (#t (printf \"CRASH\\t~a\\t~a\\n\" label (zj-clean (zj-err->str e)))))\n" + " (let ((v (jolt-compile-eval src \"user\")))\n" + " (if (string=? (jolt-final-str v) \"true\")\n" + " (printf \"PASS\\t~a\\n\" label)\n" + " (printf \"DIVERGE\\t~a\\t~a\\n\" label (zj-clean (jolt-final-str v))))))\n" + " (zj-reset!))\n" + "(let ((p (open-input-file " (string/format "%j" cases-tsv) ")))\n" + " (let loop ()\n" + " (let ((line (get-line p)))\n" + " (unless (eof-object? line)\n" + " (let find ((i 0))\n" + " (cond ((>= i (string-length line)) #f)\n" + " ((char=? (string-ref line i) #\\tab)\n" + " (zj-run (substring line 0 i) (substring line (+ i 1) (string-length line))))\n" + " (else (find (+ i 1)))))\n" + " (loop)))))\n")) + +(defn eval-corpus-zero-janet + "Run all `cases` ([label src] pairs) through the ON-CHEZ analyzer in ONE chez + process. Returns a struct mapping label -> [:pass] | [:diverge value] | + [:crash message]. Vastly faster than per-case eval-zero-janet (single runtime + load); use eval-zero-janet to isolate a single case for debugging." + [prelude-path image-path cases &opt scheme-out cases-out] + (def tsv-path (or cases-out (string "/tmp/jolt-zj-cases-" (os/getpid) ".tsv"))) + (def buf @"") + (each [label src] cases (buffer/push buf label "\t" src "\n")) + (spit tsv-path buf) + (def prog (program-corpus-zero-janet prelude-path image-path tsv-path)) + (def path (or scheme-out (string "/tmp/jolt-zj-runner-" (os/getpid) ".ss"))) + (spit path prog) + (def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe})) + (def out (drain (proc :out))) + (def err (drain (proc :err))) + (def code (os/proc-wait proc)) + (def res @{}) + (each line (string/split "\n" (string/trim out)) + (when (> (length line) 0) + (def parts (string/split "\t" line)) + (def status (in parts 0)) + (def label (get parts 1 "")) + (cond + (= status "PASS") (put res label [:pass]) + (= status "DIVERGE") (put res label [:diverge (get parts 2 "")]) + (= status "CRASH") (put res label [:crash (get parts 2 "")])))) + # If chez died mid-run (e.g. an uncatchable error), surface what we have + stderr. + {:results res :code code :stderr (string/trim err) :count (length res)}) + (defn program-with-prelude "Assemble a runnable Chez program that loads rt.ss, loads the assembled core prelude from `prelude-path` (a file written once), then prints `final-scm`." diff --git a/host/chez/host-contract.ss b/host/chez/host-contract.ss index 0e7b970..ae68a3b 100644 --- a/host/chez/host-contract.ss +++ b/host/chez/host-contract.ss @@ -60,6 +60,7 @@ (define (hc-uuid? x) (hc-tagged-of x hc-kw-uuid)) ;; --- form accessors --------------------------------------------------------- +(define (hc-char-code x) (char->integer x)) ; native Chez char -> codepoint (define (hc-sym-name x) (symbol-t-name x)) ;; The reader stores an unqualified symbol's ns inconsistently (#f, '(), or ;; jolt-nil — see converters.ss). The contract is jolt-nil for unqualified (the @@ -82,10 +83,18 @@ (apply jolt-vector (pset-fold x cons '())) (jolt-get x hc-kw-value))) (define (hc-map-pairs x) - (let loop ((ks (if (jolt-nil? (jolt-seq (jolt-keys x))) '() - (seq->list (jolt-seq (jolt-keys x))))) (acc '())) - (if (null? ks) (apply jolt-vector (reverse acc)) - (loop (cdr ks) (cons (jolt-vector (car ks) (jolt-get x (car ks))) acc))))) + (let ((kv (hashtable-ref rdr-map-order x #f))) + (if kv + ;; reader-built map literal: emit pairs in SOURCE order (kv = k1 v1 k2 v2 …) + ;; so the analyzer evaluates the values left-to-right (jolt-qjr0). + (let loop ((kv kv) (acc '())) + (if (null? kv) (apply jolt-vector (reverse acc)) + (loop (cddr kv) (cons (jolt-vector (car kv) (cadr kv)) acc)))) + ;; a runtime/non-reader map: pmap iteration order + (let loop ((ks (if (jolt-nil? (jolt-seq (jolt-keys x))) '() + (seq->list (jolt-seq (jolt-keys x))))) (acc '())) + (if (null? ks) (apply jolt-vector (reverse acc)) + (loop (cdr ks) (cons (jolt-vector (car ks) (jolt-get x (car ks))) acc))))))) (define (hc-regex-source x) (jolt-get x hc-kw-form)) (define (hc-inst-source x) (jolt-get x hc-kw-form)) (define (hc-uuid-source x) (jolt-get x hc-kw-form)) @@ -158,11 +167,84 @@ (define (hc-intern! ctx ns-name nm) (declare-var! ns-name nm) jolt-nil) -;; syntax-quote lowering + record hints land in later increments (6b+); stub so -;; the contract is complete (not on the macro-free spine). +;; --- syntax-quote lowering (jolt-qjr0, inc7) --------------------------------- +;; Mirrors src/jolt/eval_base.janet syntax-quote-lower/sq-symbol. Lowers a `form +;; to CONSTRUCTION CODE — Chez reader forms calling __sqcat/__sqvec/__sqmap/ +;; __sqset/__sq1 + quote — that the analyzer re-analyzes, so a backtick compiles +;; with zero runtime cost (read -> macroexpand -> compile). Symbols resolve to +;; clojure.core / the compile ns; a foo# auto-gensym is stable within one `. +(define hc-special-symbols + '("quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def" + "defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "var" "eval" + "new" ".")) +(define (hc-special-symbol? nm) (and (member nm hc-special-symbols) #t)) + +(define hc-sq-gensym-counter 0) +(define (hc-sq-gensym base) + (set! hc-sq-gensym-counter (+ hc-sq-gensym-counter 1)) + (jolt-symbol #f (string-append base "__" (number->string hc-sq-gensym-counter) "__auto"))) + +(define (hc-sym nm) (jolt-symbol #f nm)) +;; is `x` a non-empty list FORM whose head is the unqualified symbol `nm`? +(define (hc-head-is? x nm) + (and (cseq? x) (cseq-list? x) + (let ((h (seq-first x))) + (and (symbol-t? h) (jolt-nil? (hc-sym-ns h)) (string=? (symbol-t-name h) nm))))) +(define (hc-second x) (seq-first (jolt-seq (seq-more x)))) + +(define (hc-sq-symbol ctx form gsmap) + (let ((sns (hc-sym-ns form)) (nm (symbol-t-name form))) + (if (jolt-nil? sns) + (cond + ;; foo# -> a stable per-` auto-gensym + ((and (> (string-length nm) 0) + (char=? (string-ref nm (- (string-length nm) 1)) #\#)) + (or (hashtable-ref gsmap nm #f) + (let ((g (hc-sq-gensym (substring nm 0 (- (string-length nm) 1))))) + (hashtable-set! gsmap nm g) g))) + ((hc-special-symbol? nm) form) ; special form: leave bare + ((var-cell-lookup "clojure.core" nm) (jolt-symbol "clojure.core" nm)) + (else (jolt-symbol (chez-actx-cns ctx) nm))) ; else: qualify to compile ns + ;; qualified (a real ns or an alias): ns aliases aren't modeled on the Chez + ;; data layer yet, so leave a qualified symbol as written (jolt-qjr0). + form))) + +(define (hc-sq-lower ctx form gsmap) + (cond + ((hc-head-is? form "unquote") (hc-second form)) + ((hc-head-is? form "unquote-splicing") + (jolt-throw (jolt-ex-info "~@ used outside of a list or vector in syntax-quote" + (jolt-hash-map)))) + ((hc-literal? form) form) + ((symbol-t? form) (jolt-list (hc-sym "quote") (hc-sq-symbol ctx form gsmap))) + ((hc-list? form) + (apply jolt-list (hc-sym "__sqcat") + (map (lambda (it) (hc-sq-lower-part ctx it gsmap)) (seq->list form)))) + ((hc-vec? form) + (apply jolt-list (hc-sym "__sqvec") + (map (lambda (it) (hc-sq-lower-part ctx it gsmap)) (seq->list form)))) + ((hc-set? form) + (apply jolt-list (hc-sym "__sqset") + (map (lambda (it) (hc-sq-lower-part ctx it gsmap)) (seq->list (hc-set-items form))))) + ((hc-map? form) + (apply jolt-list (hc-sym "__sqmap") + (let loop ((pairs (seq->list (hc-map-pairs form))) (acc '())) + (if (null? pairs) (reverse acc) + (let ((p (seq->list (car pairs)))) + (loop (cdr pairs) + (cons (hc-sq-lower ctx (cadr p) gsmap) + (cons (hc-sq-lower ctx (car p) gsmap) acc)))))))) + (else (jolt-list (hc-sym "quote") form)))) ; tagged (char/regex/...) etc. + +;; a list/vector/set element: a ~@ splice passes through (its seq is spliced by +;; __sqcat), any other item is wrapped (__sq1 ) so __sqcat flattens it. +(define (hc-sq-lower-part ctx item gsmap) + (if (hc-head-is? item "unquote-splicing") + (hc-second item) + (jolt-list (hc-sym "__sq1") (hc-sq-lower ctx item gsmap)))) + (define (hc-syntax-quote-lower ctx inner) - (jolt-throw (jolt-ex-info "form-syntax-quote-lower: not on Chez yet (jolt-r8ku)" - (jolt-hash-map)))) + (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) (define (hc-record-shapes ctx) (jolt-hash-map)) @@ -191,6 +273,7 @@ (def-var! "jolt.host" "form-map?" hc-map?) (def-var! "jolt.host" "form-set?" hc-set?) (def-var! "jolt.host" "form-char?" hc-char?) + (def-var! "jolt.host" "form-char-code" hc-char-code) (def-var! "jolt.host" "form-literal?" hc-literal?) (def-var! "jolt.host" "form-regex?" hc-regex?) (def-var! "jolt.host" "form-inst?" hc-inst?) diff --git a/host/chez/reader.ss b/host/chez/reader.ss index b4614a4..c683f9a 100644 --- a/host/chez/reader.ss +++ b/host/chez/reader.ss @@ -83,6 +83,20 @@ (rdr-digit? (string-ref tok start)) (rdr-number-body tok start signed c0)))))) +;; parse DDD in base `radix` (2..36); #f on a bad digit. Scheme string->number only +;; does radix 2/8/10/16, so Clojure's NrDDD (e.g. 36rZ) needs a manual parse. +(define (rdr-parse-radix digits radix) + (let ((len (string-length digits))) + (and (> len 0) + (let loop ((i 0) (acc 0)) + (if (>= i len) + acc + (let* ((c (char-downcase (string-ref digits i))) + (d (cond ((and (char>=? c #\0) (char<=? c #\9)) (- (char->integer c) 48)) + ((and (char>=? c #\a) (char<=? c #\z)) (+ 10 (- (char->integer c) 97))) + (else #f)))) + (and d (< d radix) (loop (+ i 1) (+ (* acc radix) d))))))))) + (define (rdr-number-body tok start signed sign-ch) (let* ((sign (if (and signed (char=? sign-ch #\-)) -1 1)) (len (string-length tok)) @@ -101,6 +115,14 @@ (or (char=? (string-ref body 1) #\x) (char=? (string-ref body 1) #\X))) (let ((h (string->number (substring body 2 blen) 16))) (and h (* sign h)))) + ;; radix NrDDD (Clojure 2r1010 / 16rFF / 36rZ): N in decimal, DDD in base N + ((let ((ri (or (rdr-string-index-char body #\r) (rdr-string-index-char body #\R)))) + (and ri (> ri 0) (< (+ ri 1) blen) ri)) + => (lambda (ri) + (let ((radix (string->number (substring body 0 ri)))) + (and radix (integer? radix) (>= radix 2) (<= radix 36) + (let ((v (rdr-parse-radix (substring body (+ ri 1) blen) radix))) + (and v (* sign v))))))) ;; bigint suffix N ((and (> blen 1) (char=? (string-ref body (- blen 1)) #\N)) (let ((n (string->number (substring body 0 (- blen 1))))) @@ -222,6 +244,16 @@ (loop j acc) ; a #_ discard or close — re-check at j (loop j (cons form acc))))))))) +;; Map literals must preserve SOURCE key order so the analyzer emits the value +;; expressions in source order (Clojure guarantees left-to-right map-literal eval). +;; A pmap is hash-ordered, so record each reader-built map's (k1 v1 k2 v2 ...) form +;; sequence in a weak side-table the host contract's form-map-pairs consults. +(define rdr-map-order (make-weak-eq-hashtable)) +(define (rdr-make-map es) + (let ((m (apply jolt-hash-map es))) + (when (pair? es) (hashtable-set! rdr-map-order m es)) + m)) + (define (rdr-make-set elems) (jolt-hash-map rdr-kw-jolt-type rdr-kw-jolt-set rdr-kw-value (apply jolt-vector elems))) @@ -248,7 +280,11 @@ (if (symbol-t? target) (make-symbol-t (symbol-t-ns target) (symbol-t-name target) (rdr-merge-meta (symbol-t-meta target) meta)) - target)) ; non-symbol meta is dropped (corpus only hints symbols) + ;; non-symbol target (a collection): lower to a runtime (with-meta form meta) + ;; the analyzer compiles like any invoke — same as the Janet reader, so e.g. + ;; (meta ^{:tag :int} [1 2]) and ^:foo {} carry their meta at runtime. The meta + ;; pmap doubles as its own map-literal form. + (jolt-list (jolt-symbol "clojure.core" "with-meta") target meta))) ;; --- # dispatch ------------------------------------------------------------- (define (rdr-read-dispatch s i end) ; i points just past the '#' @@ -268,6 +304,12 @@ ((char=? c #\') ; #'x var-quote -> (var x) (let-values (((form j) (rdr-read-form s (+ i 1) end))) (values (jolt-list (jolt-symbol #f "var") form) j))) + ((char=? c #\^) ; #^meta — deprecated metadata syntax = ^meta + (let-values (((mform j) (rdr-read-form s (+ i 1) end))) + (let-values (((target k) (rdr-read-form s j end))) + (when (rdr-eof? target) + (jolt-throw (jolt-ex-info "EOF after #^meta" (empty-pmap)))) + (values (rdr-attach-meta target (rdr-meta-map mform)) k)))) (else ; #tag form -> tagged {:tag :#tag :form ...} (let-values (((tok j) (rdr-read-token s i end))) (let-values (((form k) (rdr-read-form s j end))) @@ -310,7 +352,7 @@ ((char=? c #\[) (let-values (((es j) (rdr-read-seq s (+ i 1) end #\]))) (values (apply jolt-vector es) j))) ((char=? c #\{) (let-values (((es j) (rdr-read-seq s (+ i 1) end #\}))) - (values (apply jolt-hash-map es) j))) + (values (rdr-make-map es) j))) ((or (char=? c #\)) (char=? c #\]) (char=? c #\})) (values rdr-eof i)) ; unconsumed close — read-seq handles it ((char=? c #\") (rdr-read-string-lit s (+ i 1) end)) @@ -318,7 +360,16 @@ ((char=? c #\:) (rdr-read-keyword s (+ i 1) end)) ((char=? c #\#) (rdr-read-dispatch s (+ i 1) end)) ((char=? c #\') (rdr-wrap s (+ i 1) end (jolt-symbol #f "quote"))) - ((char=? c #\`) (rdr-wrap s (+ i 1) end (jolt-symbol #f "syntax-quote"))) + ;; syntax-quote of a self-evaluating literal collapses to the literal at + ;; READ time (Clojure's reader), so nested backticks over a literal are + ;; inert: ``42 reads as 42, ```"meow" as "meow". + ((char=? c #\`) + (let-values (((form j) (rdr-read-form s (+ i 1) end))) + (when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after `" (empty-pmap)))) + (values (if (rdr-self-eval-literal? form) + form + (jolt-list (jolt-symbol #f "syntax-quote") form)) + j))) ((char=? c #\@) (rdr-wrap s (+ i 1) end (jolt-symbol "clojure.core" "deref"))) ((char=? c #\~) (if (and (< (+ i 1) end) (char=? (string-ref s (+ i 1)) #\@)) @@ -335,6 +386,11 @@ (values (rdr-token->value tok) j)))))))) ;; wrap the next form in a 2-element list (READER-MACRO form) +;; self-evaluating literals (NOT symbols/collections) — syntax-quote passes these +;; through unchanged, collapsed at read time. +(define (rdr-self-eval-literal? x) + (or (jolt-nil? x) (boolean? x) (number? x) (string? x) (keyword? x) (char? x))) + (define (rdr-wrap s i end head) (let-values (((form j) (rdr-read-form s i end))) (when (rdr-eof? form) diff --git a/host/chez/seq.ss b/host/chez/seq.ss index e5e7533..a5aa17d 100644 --- a/host/chez/seq.ss +++ b/host/chez/seq.ss @@ -78,7 +78,11 @@ (if (jolt-nil? s) jolt-empty-list (let ((m (seq-more s))) (if (jolt-nil? m) jolt-empty-list m))))) (define (jolt-next x) ; nil when the rest is empty - (let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-nil (seq-more s)))) + ;; next = (seq (rest x)): the rest must be RE-SEQ'd so an empty tail collapses to + ;; nil. seq-more on a lazy seq (e.g. map's) forces to jolt-empty-list, which is + ;; truthy — returning it raw made (next 1-elem-lazy-seq) non-nil, so butlast and + ;; other (if (next s) ...) loops over a lazy seq ran one step too far. + (let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-nil (jolt-seq (seq-more s))))) ;; Only the HEAD cell carries the list marker — (rest a-list)/(next a-list) return ;; the unmarked tail, so they are seqs and not list?, matching the seed (which ;; makes rest-of-a-list a non-list seq). cons/list/reverse/conj therefore mark diff --git a/jolt-core/jolt/backend_scheme.clj b/jolt-core/jolt/backend_scheme.clj index 42759dd..4cc2ad1 100644 --- a/jolt-core/jolt/backend_scheme.clj +++ b/jolt-core/jolt/backend_scheme.clj @@ -25,7 +25,7 @@ [jolt.host :refer [form-sym? form-sym-name form-sym-ns form-sym-meta form-list? form-vec? form-map? form-set? form-char? form-literal? form-elements form-vec-items - form-map-pairs form-set-items]])) + form-map-pairs form-set-items form-char-code]])) ;; Hot clojure.core primitives lowered to native Scheme, mirroring the Janet ;; backend's native-ops. `=` is the exactness-aware jolt= from values.ss; inc/dec/ @@ -148,10 +148,11 @@ (keyword? v) (if-let [kns (namespace v)] (str "(keyword " (chez-str-lit kns) " " (chez-str-lit (name v)) ")") (str "(keyword #f " (chez-str-lit (name v)) ")")) - ;; jolt char value {:ch :jolt/type :jolt/char}. Use the host - ;; contract form-char? — a :jolt/type-tagged struct is not a plain map? in - ;; jolt, so a native map? test misses it. - (form-char? v) (str "(integer->char " (get v :ch) ")") + ;; char literal -> (integer->char ). Get the codepoint via the host + ;; contract (form-char-code), NOT (get v :ch): on Janet a char is a struct with + ;; a :ch field, but on Chez (the self-hosted spine) it's a native char, so the + ;; struct-field read returns nil and emits (integer->char) with no arg. + (form-char? v) (str "(integer->char " (form-char-code v) ")") :else (throw (ex-info (str "emit-const: unsupported literal " (pr-str v)) {})))) ;; Emit a call `(ctor a0 a1 ...)` with the args evaluated LEFT-TO-RIGHT. Chez's diff --git a/src/jolt/host_iface.janet b/src/jolt/host_iface.janet index f6a6183..89dfcbb 100644 --- a/src/jolt/host_iface.janet +++ b/src/jolt/host_iface.janet @@ -57,6 +57,10 @@ (phm/phm? form))) (defn h-set? [form] (and (struct? form) (= :jolt/set (form :jolt/type)))) (defn h-char? [form] (and (struct? form) (= :jolt/char (form :jolt/type)))) +# Codepoint of a char form. Janet rep is a {:ch :jolt/type :jolt/char} struct; +# the emitter uses this (not a raw :ch read) so the Chez host can answer for its +# native char rep too (form-char-code). +(defn h-char-code [form] (get form :ch)) # A regex literal #"…" reads as a tagged form {:jolt/type :jolt/tagged :tag :regex # :form "source"}. The analyzer lowers it to a :regex IR node (Chez emits a # jolt-regex value; the Janet back end punts to the interpreter, which compiles it @@ -331,7 +335,7 @@ "tagged-table" h-tagged-table "form-sym-meta" h-sym-meta "form-list?" h-list? "form-vec?" h-vector? "form-map?" h-map? - "form-set?" h-set? "form-char?" h-char? "form-literal?" h-literal? + "form-set?" h-set? "form-char?" h-char? "form-char-code" h-char-code "form-literal?" h-literal? "form-regex?" h-regex? "form-regex-source" h-regex-source "form-inst?" h-inst? "form-inst-source" h-inst-source "form-uuid?" h-uuid? "form-uuid-source" h-uuid-source diff --git a/test/chez/run-corpus-zero-janet.janet b/test/chez/run-corpus-zero-janet.janet new file mode 100644 index 0000000..012401e --- /dev/null +++ b/test/chez/run-corpus-zero-janet.janet @@ -0,0 +1,164 @@ +# Phase 3 inc7 (jolt-qjr0) — FULL corpus on the ZERO-JANET spine. +# +# run-corpus-prelude.janet measures RUNTIME parity: it analyzes each case with the +# JANET-hosted analyzer (the oracle) and runs the emitted Scheme on Chez. This +# runner closes the last gap: it analyzes each case with the CHEZ-HOSTED analyzer +# (jolt.analyzer cross-compiled to Scheme, run on Chez over host-contract.ss) — +# read -> analyze -> IR -> emit -> eval, NO Janet in the loop (eval-zero-janet). +# +# So this is the real test of self-hosting: where run-corpus-prelude proves the +# RUNTIME is faithful, this proves the COMPILER-on-Chez is faithful. A case that +# the Janet analyzer compiles but the Chez analyzer can't surfaces here as a crash +# (analyzer/emitter raised) or a divergence (ran, wrong value). The buckets form +# the inc7 punch-list; genuinely host-coupled cases (Java interop, runtime eval) +# are deferred to Phase 4 / jolt-r8ku and allowlisted, like the prelude gate. +# +# JOLT_CHEZ_ZEROJANET_CORPUS=1 janet test/chez/run-corpus-zero-janet.janet +# JOLT_CORPUS_LIMIT=200 … (every-Nth stride, fast iteration) +(import ../../host/chez/driver :as d) +(import ../../host/chez/jolt-chez :as jc) + +(unless (os/getenv "JOLT_CHEZ_ZEROJANET_CORPUS") + (print "skip: set JOLT_CHEZ_ZEROJANET_CORPUS=1 to run the zero-Janet corpus gate") + (os/exit 0)) +(unless (d/chez-available?) + (print "skip: chez not on PATH") + (os/exit 0)) + +(def ctx (d/make-ctx)) +(def prelude-path (jc/ensure-prelude ctx)) + +# Compiler image (jolt.ir + jolt.analyzer + jolt.backend-scheme cross-compiled to +# Scheme), cached by the same source fingerprint the spine-test uses. +(defn- image-fingerprint [] + (string/slice (string (hash (string/join + (map slurp ["jolt-core/jolt/ir.clj" "jolt-core/jolt/analyzer.clj" + "jolt-core/jolt/backend_scheme.clj" "host/chez/host-contract.ss" + "host/chez/compile-eval.ss"])))) 0)) +(def image-path + (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-compiler-image-" (image-fingerprint) ".ss")) +(def t0 (os/clock)) +(d/ensure-compiler-image ctx image-path) +(printf "prelude + compiler image ready (%.1fs)" (- (os/clock) t0)) +(flush) + +(def corpus (parse (slurp "test/chez/corpus.edn"))) +(def cases + (if-let [n (os/getenv "JOLT_CORPUS_LIMIT")] + (let [stride (max 1 (math/floor (/ (length corpus) (scan-number n))))] + (seq [i :range [0 (length corpus) stride]] (in corpus i))) + corpus)) + +# Known divergences/crashes: cases the Chez-hosted compiler can't yet handle that +# are tracked elsewhere (NOT analyzer-faithfulness bugs). Tolerated so the gate +# fails only on a NEW regression. Keyed by label. +# - host interop (Java classes / constructors / .method on host types): Phase 4 +# jolt-cf1q.7. Same family the prelude gate buckets as crashes. +# - eval / load-string / read->eval: the jolt-r8ku tail (runtime compiler entry). +(def known-fail + # Same deferred set the prelude (oracle) gate allowlists — NOT Chez-analyzer + # faithfulness bugs, but runtime gaps tracked elsewhere: + # - print-method multimethod integration: a user (defmethod print-method ...) + # isn't consulted by the Chez printer, so pr-str/prn of an overridden type + # uses the built-in form (Phase 2 deferred). + # - atom?: (instance? clojure.lang.Atom (atom 0)) — host class not mapped on + # Chez (Phase 4 host interop, jolt-cf1q.7). + @{"defmethod overrides a record, top level" true + "defmethod fires nested in a map" true + "defmethod fires through prn" true + "direct builtin override" true + "methods table inspectable" true + "atom override fires nested" true + "atom?" true}) + +(var pass 0) +(def crashes @[]) # nonzero chez exit (analyzer/emitter raised, or runtime gap) +(def diverged @[]) # ran, wrong value (a real Chez-compiler divergence) +(def known-hit @[]) +(def crash-keys @{}) +(defn- bucket [tbl k] (put tbl k (+ 1 (or (get tbl k) 0)))) + +# Group a chez stderr message into a coarse reason for the punch-list. +(defn- crash-reason [m] + (def m (string/trim m)) + (cond + (string/find "unsupported stdlib" m) "emit: unsupported stdlib fn" + (string/find "unsupported host" m) "emit: unsupported host call" + (string/find "host-static" m) "emit: host-static" + (string/find "syntax-quote" m) "form-syntax-quote-lower" + (string/find "uncompil" m) "analyzer: uncompilable" + (string/find "Unknown class" m) "runtime: unknown class" + (string/find "No constructor" m) "runtime: no constructor" + (string/find "No method" m) "runtime: no method" + (string/find "not a fn" m) "runtime: not a fn" + (string/find "not seqable" m) "runtime: not seqable" + (string/find "not a transient" m) "runtime: not a transient" + (string/find "integer->char" m) "runtime: integer->char" + (string/find "non-condition value" m) + (let [i (string/find "non-condition value" m)] + (string "raised: " (string/slice m (+ i 20) (min (length m) (+ i 60))))) + (string/slice m 0 (min 56 (length m))))) + +(def t1 (os/clock)) +(var throws 0) + +# Build the evaluable case list (skip :throws), keyed by index (labels aren't +# unique across suites). idx -> row, idx -> "(= EXPECTED ACTUAL)". +(def rows-by-idx @{}) +(def pairs @[]) +(eachp [i row] cases + (def {:expected e :actual a} row) + (if (= e :throws) + (++ throws) + (let [key (string i)] + (put rows-by-idx key row) + (array/push pairs [key (string "(= " e " " a ")")])))) + +(defn- handle [key verdict] + (def row (get rows-by-idx key)) + (def l (get row :label)) + (case (first verdict) + :pass (++ pass) + :crash (let [k (crash-reason (get verdict 1))] (bucket crash-keys k) (array/push crashes [l k])) + :diverge (if (known-fail l) (array/push known-hit l) + (array/push diverged [l (string "got " (get verdict 1))])))) + +(if (os/getenv "JOLT_ZJ_PERCASE") + # slow per-case path (each case its own chez process) — for isolating a hang/crash + (each [key src] pairs + (def [code out err] (d/eval-zero-janet prelude-path image-path src)) + (handle key (cond (not= code 0) [:crash err] (= out "true") [:pass] [:diverge out]))) + # fast batched path: one chez process loads the runtime once, runs all cases + (let [{:results r :code c :stderr se :count n} (d/eval-corpus-zero-janet prelude-path image-path pairs)] + (when (< n (length pairs)) + (printf "WARNING: batched runner returned %d/%d results (chez exit %d): %s" + n (length pairs) c (string/slice se 0 (min 200 (length se))))) + (each [key _] pairs + (handle key (or (get r key) [:crash (string "no result (batch aborted) " se)]))))) + +(def n-eval (+ pass (length crashes) (length diverged) (length known-hit))) +(printf "\nZero-Janet corpus parity: %d/%d evaluated cases pass (%.1fs)" pass n-eval (- (os/clock) t1)) +(printf " crash: %d NEW divergence: %d known: %d (throws skipped: %d)" + (length crashes) (length diverged) (length known-hit) throws) + +(defn- report [title tbl] + (when (> (length tbl) 0) + (printf "\n%s:" title) + (each k (sort-by (fn [k] (- (get tbl k))) (keys tbl)) + (printf " %4d x %s" (get tbl k) k)))) +(report "crash reasons" crash-keys) +(when (> (length diverged) 0) + (printf "\nNEW divergences (ran, wrong value) — gate FAILS:") + (each [l m] (slice diverged 0 (min 40 (length diverged))) + (printf " [%s] %s" l m))) +(when (> (length known-hit) 0) + (printf "\n%d known (allowlisted) failures tolerated." (length known-hit))) +(flush) + +# Regression floor: raise as the Chez-hosted compiler closes gaps. The gate fails +# on any NEW divergence or if pass drops below the floor. Strided runs scale to 0. +(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_ZJ_FLOOR") "2159"))) +(def floor (if (os/getenv "JOLT_CORPUS_LIMIT") 0 base-floor)) +(when (or (> (length diverged) 0) (< pass floor)) + (printf "REGRESSION: pass %d < floor %d or %d new divergence(s)" pass floor (length diverged))) +(os/exit (if (or (> (length diverged) 0) (< pass floor)) 1 0))