Merge pull request #188 from jolt-lang/spike/arch-refactor
Architecture refactor + AOT/runtime fixes
This commit is contained in:
Dmitri Sotnikov
GitHub
commit
53b1c79d99
51 changed files with 1825 additions and 1397 deletions
12
CLAUDE.md
12
CLAUDE.md
|
|
@ -109,6 +109,18 @@ Issue tracking and design notes live in beads (`bd prime`, `bd memories`).
|
||||||
forever. Use `jolt.host/ref-get`.
|
forever. Use `jolt.host/ref-get`.
|
||||||
- **Map literals with `:jolt/type` as a key** parse as tagged reader forms —
|
- **Map literals with `:jolt/type` as a key** parse as tagged reader forms —
|
||||||
don't tag overlay value maps in source.
|
don't tag overlay value maps in source.
|
||||||
|
- **The compiler is reached from the runtime by `var-deref` string lookup.** The
|
||||||
|
`.ss` runtime calls into the cross-compiled compiler with
|
||||||
|
`(var-deref "jolt.analyzer" "analyze")` etc., and the compiler resolves its own
|
||||||
|
unqualified `jolt.host/…` refs the same way against `host-contract.ss`. So a
|
||||||
|
public `defn` with no in-Clojure callers may still be a live entry point — don't
|
||||||
|
treat it as dead. Only a private `defn-` with no callers is safe to remove.
|
||||||
|
- **A native `clojure.core` fn is a `(def-var! "clojure.core" "name" …)`** in a
|
||||||
|
`host/chez/*.ss`; the rest of core is the overlay (`jolt-core/clojure/core/*.clj`).
|
||||||
|
A few natives are re-asserted in `post-prelude.ss` so they win over the overlay.
|
||||||
|
See [docs/MODULES.md](docs/MODULES.md) for where a given fn lives, and
|
||||||
|
[docs/seed-overlay-registry.md](docs/seed-overlay-registry.md) for the shadowing
|
||||||
|
rule. Start at [docs/MODULES.md](docs/MODULES.md) to find a feature's files.
|
||||||
- **Fix latent bugs to match Clojure** rather than preserving them, with a
|
- **Fix latent bugs to match Clojure** rather than preserving them, with a
|
||||||
regression case. Match the JVM (or provide a superset); the JVM-sourced corpus
|
regression case. Match the JVM (or provide a superset); the JVM-sourced corpus
|
||||||
is the contract.
|
is the contract.
|
||||||
|
|
|
||||||
97
docs/MODULES.md
Normal file
97
docs/MODULES.md
Normal file
|
|
@ -0,0 +1,97 @@
|
||||||
|
# Module map
|
||||||
|
|
||||||
|
Where things live and what to read before changing them. Start here to answer
|
||||||
|
"where does feature X live?" and "what else do I need to touch?"
|
||||||
|
|
||||||
|
## Areas
|
||||||
|
|
||||||
|
| Area | Directory | Responsibility | Re-mint? |
|
||||||
|
| --- | --- | --- | --- |
|
||||||
|
| Chez runtime | `host/chez/*.ss` | The substrate: value model, persistent collections, seqs, vars/namespaces, host interop, native `clojure.core` shims, regex, FFI, IO, the **reader**. Composed by `rt.ss`. | only `reader.ss` |
|
||||||
|
| Compiler | `jolt-core/jolt/*.clj` | analyzer → IR → backend, the optimization passes, the CLI, the deps resolver, nREPL. Baked into the seed. | **yes** |
|
||||||
|
| `clojure.core` overlay | `jolt-core/clojure/core/NN-*.clj` | Portable `clojure.core` in dependency-ordered tiers (`00-syntax` … `50-io`); the `NN` prefix *is* the load order. | **yes** |
|
||||||
|
| Stdlib | `stdlib/clojure/*.clj` | Lazily-loaded portable namespaces (string/set/walk/edn/pprint/zip/test/data). | no |
|
||||||
|
| Build & tooling | `host/chez/build.ss`, `emit-image.ss`, `compile-eval.ss`, `loader.ss`, `cli.ss`, `bootstrap.ss` | AOT binary build, cross-compile, runtime eval/load, CLI spine, seed mint. | no (except via `reader.ss`) |
|
||||||
|
| Tests & gate | `test/chez/`, `test/conformance/`, `host/chez/run-*.ss`, `Makefile` | Corpus (JVM oracle), unit, per-feature tests. Every `make` target has a comment. | no |
|
||||||
|
|
||||||
|
**The reader is in `host/chez/reader.ss`** (Scheme, a seed source) — *not* in
|
||||||
|
`jolt-core/jolt/` with the rest of the compiler. Re-mint applies to it.
|
||||||
|
|
||||||
|
`rt.ss` is the runtime's load-order manifest: it `(load …)`s every shim in
|
||||||
|
dependency order with a per-file comment. Read it to see how the runtime is
|
||||||
|
composed and where a given `.ss` fits.
|
||||||
|
|
||||||
|
## `host/chez/*.ss` by family
|
||||||
|
|
||||||
|
- **Value model**: `values.ss` (nil/numbers/keywords/symbols), `collections.ss`
|
||||||
|
(persistent vec + HAMT map/set), `seq.ss` + `lazy-bridge.ss` (seqs, lazy-seqs),
|
||||||
|
`transients.ss`, `records.ss` + `records-interop.ss`.
|
||||||
|
- **Native `clojure.core` shims**: `natives-*.ss` (array/coll/format/meta/misc/num/
|
||||||
|
queue/reader/seq/str/transduce), plus `predicates.ss`, `converters.ss`, `printing.ss`.
|
||||||
|
- **Vars / namespaces / dynamics**: `vars.ss`, `ns.ss`, `dyn-binding.ss` (the
|
||||||
|
thread-local binding stack), `dynamic-var-defaults.ss` (a few `*…*` constant defaults),
|
||||||
|
`atoms.ss`, `multimethods.ss`.
|
||||||
|
- **Host interop**: `host-class.ss` (class tokens + method dispatch),
|
||||||
|
`host-static.ss` (interop registry core) + `host-static-methods.ss` (`Class/member`
|
||||||
|
statics) + `host-static-classes.ss` (instantiable object classes), `host-table.ss`,
|
||||||
|
`host-contract.ss` (the `jolt.host` seam the compiler resolves against),
|
||||||
|
`dot-forms.ss`, `records-interop.ss`.
|
||||||
|
- **Scalars / misc**: `regex.ss` (vendored irregex), `math.ss`, `inst-time.ss`,
|
||||||
|
`bigdec.ss`, `syntax-quote.ss`.
|
||||||
|
- **IO / system / concurrency / FFI**: `io.ss`, `png.ss`, `concurrency.ss`,
|
||||||
|
`async.ss`, `ffi.ss`.
|
||||||
|
- **Compiler entry on Chez**: `reader.ss`, `compile-eval.ss`, `emit-image.ss`,
|
||||||
|
`loader.ss`, `cli.ss`, `build.ss`, `bootstrap.ss`.
|
||||||
|
|
||||||
|
## Where is a `clojure.core` fn implemented?
|
||||||
|
|
||||||
|
Two homes, with a defined precedence:
|
||||||
|
|
||||||
|
1. **Native shim** — a `(def-var! "clojure.core" "name" …)` in a `host/chez/*.ss`
|
||||||
|
(hot/representation-coupled fns: `first`, `get`, `=`, the predicates).
|
||||||
|
2. **Overlay** — a `defn` in a `jolt-core/clojure/core/NN-*.clj` tier (most of
|
||||||
|
`clojure.core`, in portable Clojure).
|
||||||
|
3. **`post-prelude.ss`** re-asserts a handful of natives *after* the overlay loads,
|
||||||
|
so the native version wins (the overlay's value-reading versions are wrong for
|
||||||
|
Chez-native chars/atoms/etc.). Each entry there says why.
|
||||||
|
|
||||||
|
`grep 'def-var! "clojure.core" "frequencies"' host/chez` and
|
||||||
|
`grep -rn 'defn frequencies' jolt-core/clojure/core` to find a given fn. See
|
||||||
|
[seed-overlay-registry.md](seed-overlay-registry.md) for the shadowing mechanism.
|
||||||
|
|
||||||
|
## Cross-cutting features — touch points
|
||||||
|
|
||||||
|
A feature's *core* lives in one file; these are the other files you must keep in
|
||||||
|
sync when changing it.
|
||||||
|
|
||||||
|
- **Tree-shaking / DCE** (`--tree-shake`): `emit-image.ss` (the `dce-*` helpers +
|
||||||
|
record producers) and `build.ss` (`bld-shake-all` reachability + the manifest
|
||||||
|
splice in `bld-emit-runtime`); the flag in `main.clj`; validated by
|
||||||
|
`host/chez/tree-shake-smoke.sh` (`make shakesmoke`) and `build-smoke.sh`. See
|
||||||
|
[tools-deps.md](tools-deps.md#tree-shaking).
|
||||||
|
- **Direct-linking** (`--direct-link`): `backend_scheme.clj` (`direct-link?`,
|
||||||
|
`emit-top-form`, the `jv$<fqn>` bindings); `build.ss` turns it on; `main.clj` the
|
||||||
|
flag; `test/chez/directlink-test.ss`.
|
||||||
|
- **Numeric fl*/fx\*** (`^double`/`^long` hints): `jolt-core/jolt/passes/numeric.clj`
|
||||||
|
(the hint-directed pass + loop-counter + `:coerce`); `backend_scheme.clj`
|
||||||
|
(`dbl-ops`/`lng-ops` op strings, `emit-numeric`, entry/return coercion);
|
||||||
|
`analyzer.clj` (`nhint-of`, `:nhints`, `with-ret-nhint`); `host-contract.ss`
|
||||||
|
(`:num-ret` on resolve); `rt.ss` (`jolt->fx`); `test/chez/numeric-test.ss`.
|
||||||
|
- **IR inlining** (under `--opt`): `passes/inline.clj` (splice) + `passes.clj`
|
||||||
|
(stash) + `host-contract.ss` (`inline-ir`/`stash-inline!`); `test/chez/inline-test.ss`.
|
||||||
|
- **Multimethods**: `host/chez/multimethods.ss` (dispatch) + the overlay
|
||||||
|
`defmulti`/`defmethod` macros + `host-contract.ss` late-bind.
|
||||||
|
- **AOT namespace context** (`jolt build`): `build.ss` (`bld-ns-prelude`) emits
|
||||||
|
`(set-chez-ns! ns)` + `chez-register-alias!` per app namespace (both the normal
|
||||||
|
and tree-shake emit paths), matching the loader's per-file ns context;
|
||||||
|
`test/chez/build-app` (`make buildsmoke`).
|
||||||
|
- **Deps resolution**: `jolt-core/jolt/deps.clj` (the only file) + `main.clj`
|
||||||
|
(applies the roots) + `loader.ss` (the `require` path).
|
||||||
|
|
||||||
|
## Conventions you must preserve
|
||||||
|
|
||||||
|
See **CLAUDE.md → "Conventions & Patterns"** for the load-bearing rules: the
|
||||||
|
re-mint trigger, the tier macro-ordering rule, the `get`-on-your-own-wrapper trap,
|
||||||
|
`:jolt/type`-as-a-key parsing, the `var-deref` calling convention (the compiler is
|
||||||
|
reached from the `.ss` runtime by string lookup, so a public `defn` with no
|
||||||
|
in-Clojure callers can still be live), and the writing style.
|
||||||
|
|
@ -16,6 +16,11 @@ Libraries confirmed to load and pass their conformance checks on Jolt
|
||||||
reitit.Trie Java class is mirrored in Clojure by
|
reitit.Trie Java class is mirrored in Clojure by
|
||||||
[jolt-lang/router](https://github.com/jolt-lang/router). Load with
|
[jolt-lang/router](https://github.com/jolt-lang/router). Load with
|
||||||
`JOLT_FEATURES` including `clj`.
|
`JOLT_FEATURES` including `clj`.
|
||||||
|
* [integrant](https://github.com/weavejester/integrant) — data-driven system
|
||||||
|
configuration; `ig/init`/`ig/halt!` build and tear down a component graph wired
|
||||||
|
with `#ig/ref`, on the ring-app example. Loads unmodified with its
|
||||||
|
[dependency](https://github.com/weavejester/dependency) and
|
||||||
|
[meta-merge](https://github.com/weavejester/meta-merge) deps.
|
||||||
* [honeysql](https://github.com/seancorfield/honeysql) — full formatter + helpers
|
* [honeysql](https://github.com/seancorfield/honeysql) — full formatter + helpers
|
||||||
(select/insert/update/delete/joins/:inline), loaded unmodified from git
|
(select/insert/update/delete/joins/:inline), loaded unmodified from git
|
||||||
* [clojure.jdbc](https://github.com/yogthos/clojure.jdbc) — as [jolt-lang/db](https://github.com/jolt-lang/db)'s
|
* [clojure.jdbc](https://github.com/yogthos/clojure.jdbc) — as [jolt-lang/db](https://github.com/jolt-lang/db)'s
|
||||||
|
|
|
||||||
21
docs/rfc/README.md
Normal file
21
docs/rfc/README.md
Normal file
|
|
@ -0,0 +1,21 @@
|
||||||
|
# RFCs
|
||||||
|
|
||||||
|
Design notes for non-obvious language and compiler decisions. An RFC records *why*
|
||||||
|
a thing is built the way it is; the code is the source of truth for *how*.
|
||||||
|
|
||||||
|
| # | Title | Status | Governs |
|
||||||
|
| --- | --- | --- | --- |
|
||||||
|
| [0001](0001-language-specification.md) | A Specification for the Clojure Language | Draft | The conformance target — what "is Clojure" means for jolt. |
|
||||||
|
| [0002](0002-reader-conditional-features.md) | Reader-Conditional Feature Set | Accepted | `#?(...)` feature keys (`:jolt`, `:clj`, `:default`). |
|
||||||
|
| [0003](0003-transients.md) | Transients | Accepted | `transient`/`persistent!` semantics + the Chez mutable backing. |
|
||||||
|
| [0004](0004-type-hints.md) | Type hints + keyword-lookup specialization | Accepted | `^Type`/`^:struct` hints → the bare-`get` fast path. |
|
||||||
|
| [0005](0005-structural-type-inference.md) | Structural collection-type inference | Implemented | The `:struct`/`:vec`/`:set` lattice in `passes/types`. |
|
||||||
|
| [0006](0006-success-type-checking.md) | Success typing (provably-wrong-code detection) | Implemented | The error-domain checker in `passes/types`. |
|
||||||
|
| [0007](0007-compilation-modes-and-binary-output.md) | Compilation modes + binary output | Implemented (doc lags) | `release`/`--opt`/`--dev`, `--direct-link`, `--tree-shake`. |
|
||||||
|
|
||||||
|
RFC 0007's own status line still says "Draft, no code yet" — that is stale:
|
||||||
|
direct-linking and tree-shaking shipped (see [tools-deps.md](../tools-deps.md) and
|
||||||
|
`backend_scheme.clj` / `build.ss`). Two compiler features that grew alongside it —
|
||||||
|
**IR inlining** (`passes/inline.clj`, under `--opt`) and **numeric `fl*`/`fx*`
|
||||||
|
lowering** from `^double`/`^long` hints (`passes/numeric.clj`) — are not yet written
|
||||||
|
up as RFCs; their touch points are in [../MODULES.md](../MODULES.md).
|
||||||
BIN
guestbook.sqlite3
Normal file
BIN
guestbook.sqlite3
Normal file
Binary file not shown.
|
|
@ -61,22 +61,14 @@
|
||||||
(def-var! "clojure.core" "bigdec" jolt-bigdec)
|
(def-var! "clojure.core" "bigdec" jolt-bigdec)
|
||||||
|
|
||||||
;; equality: a bigdec equals only another bigdec, by value (matching (= 3M 3) = false).
|
;; equality: a bigdec equals only another bigdec, by value (matching (= 3M 3) = false).
|
||||||
(define %bd-jolt=2 jolt=2)
|
(register-eq-arm! (lambda (a b) (or (jbigdec? a) (jbigdec? b)))
|
||||||
(set! jolt=2 (lambda (a b)
|
(lambda (a b) (and (jbigdec? a) (jbigdec? b) (jbigdec=? a b))))
|
||||||
(cond ((and (jbigdec? a) (jbigdec? b)) (jbigdec=? a b))
|
|
||||||
((or (jbigdec? a) (jbigdec? b)) #f)
|
|
||||||
(else (%bd-jolt=2 a b)))))
|
|
||||||
|
|
||||||
;; str drops the M; pr/pr-str keep it.
|
;; str drops the M; pr/pr-str keep it.
|
||||||
(register-str-render! jbigdec? jbigdec->string)
|
(register-str-render! jbigdec? jbigdec->string)
|
||||||
(define %bd-pr-str jolt-pr-str)
|
(register-pr-arm! jbigdec? (lambda (x) (string-append (jbigdec->string x) "M")))
|
||||||
(set! jolt-pr-str (lambda (x) (if (jbigdec? x) (string-append (jbigdec->string x) "M") (%bd-pr-str x))))
|
|
||||||
(define %bd-pr-readable jolt-pr-readable)
|
|
||||||
(set! jolt-pr-readable (lambda (x) (if (jbigdec? x) (string-append (jbigdec->string x) "M") (%bd-pr-readable x))))
|
|
||||||
|
|
||||||
;; class / decimal?
|
;; class / decimal?
|
||||||
(define %bd-class jolt-class)
|
(register-class-arm! jbigdec? (lambda (x) "java.math.BigDecimal"))
|
||||||
(set! jolt-class (lambda (x) (if (jbigdec? x) "java.math.BigDecimal" (%bd-class x))))
|
|
||||||
(def-var! "clojure.core" "class" jolt-class)
|
|
||||||
(set! jolt-decimal? (lambda (x) (jbigdec? x)))
|
(set! jolt-decimal? (lambda (x) (jbigdec? x)))
|
||||||
(def-var! "clojure.core" "decimal?" jolt-decimal?)
|
(def-var! "clojure.core" "decimal?" jolt-decimal?)
|
||||||
|
|
|
||||||
|
|
@ -44,7 +44,9 @@ want='embedded resource ok
|
||||||
HELLO FROM A BUILT BINARY!
|
HELLO FROM A BUILT BINARY!
|
||||||
HELLO FROM A BUILT BINARY!
|
HELLO FROM A BUILT BINARY!
|
||||||
args: [alpha bb ccc]
|
args: [alpha bb ccc]
|
||||||
sum: 10'
|
sum: 10
|
||||||
|
greet-default: greet:default
|
||||||
|
greet-loud: greet:loud'
|
||||||
if [ "$got" != "$want" ]; then
|
if [ "$got" != "$want" ]; then
|
||||||
echo " FAIL: binary output mismatch"
|
echo " FAIL: binary output mismatch"
|
||||||
echo "--- want ---"; echo "$want"
|
echo "--- want ---"; echo "$want"
|
||||||
|
|
|
||||||
|
|
@ -18,6 +18,7 @@
|
||||||
;; normal run never pays for it.
|
;; normal run never pays for it.
|
||||||
|
|
||||||
(load "host/chez/emit-image.ss")
|
(load "host/chez/emit-image.ss")
|
||||||
|
(load "host/chez/dce.ss")
|
||||||
|
|
||||||
;; --- shell helpers ----------------------------------------------------------
|
;; --- shell helpers ----------------------------------------------------------
|
||||||
;; Run a command, return its stdout as one trimmed string ("" on no output).
|
;; Run a command, return its stdout as one trimmed string ("" on no output).
|
||||||
|
|
@ -94,21 +95,30 @@
|
||||||
"-llz4 -lz -lncurses -ltinfo -ldl -lm -lpthread -luuid -lrt"))
|
"-llz4 -lz -lncurses -ltinfo -ldl -lm -lpthread -luuid -lrt"))
|
||||||
|
|
||||||
;; --- runtime manifest (mirrors host/chez/cli.ss's load order) ---------------
|
;; --- runtime manifest (mirrors host/chez/cli.ss's load order) ---------------
|
||||||
|
;; A line is either literal Scheme text to inline, or a tag whose emission the build
|
||||||
|
;; controls: 'prelude (the clojure.core blob, replaced by the shaken core under
|
||||||
|
;; tree-shake), 'image + 'compile-eval (the compiler, dropped for a no-eval app).
|
||||||
|
;; Tagging keeps the splice/drop decisions off fragile substring matching.
|
||||||
(define bld-runtime-manifest
|
(define bld-runtime-manifest
|
||||||
(list
|
(list
|
||||||
"(load \"host/chez/rt.ss\")"
|
"(load \"host/chez/rt.ss\")"
|
||||||
"(set-chez-ns! \"clojure.core\")"
|
"(set-chez-ns! \"clojure.core\")"
|
||||||
"(load \"host/chez/seed/prelude.ss\")"
|
'prelude
|
||||||
"(load \"host/chez/post-prelude.ss\")"
|
"(load \"host/chez/post-prelude.ss\")"
|
||||||
"(set-chez-ns! \"user\")"
|
"(set-chez-ns! \"user\")"
|
||||||
"(load \"host/chez/host-contract.ss\")"
|
"(load \"host/chez/host-contract.ss\")"
|
||||||
"(load \"host/chez/seed/image.ss\")"
|
'image
|
||||||
"(load \"host/chez/compile-eval.ss\")"
|
'compile-eval
|
||||||
"(load \"host/chez/png.ss\")"
|
"(load \"host/chez/png.ss\")"
|
||||||
"(load \"host/chez/loader.ss\")"
|
"(load \"host/chez/loader.ss\")"
|
||||||
"(load \"host/chez/ffi.ss\")"
|
"(load \"host/chez/ffi.ss\")"
|
||||||
"(set-source-roots! (list \"jolt-core\" \"stdlib\"))"))
|
"(set-source-roots! (list \"jolt-core\" \"stdlib\"))"))
|
||||||
|
|
||||||
|
(define bld-tagged-loads
|
||||||
|
'((prelude . "(load \"host/chez/seed/prelude.ss\")")
|
||||||
|
(image . "(load \"host/chez/seed/image.ss\")")
|
||||||
|
(compile-eval . "(load \"host/chez/compile-eval.ss\")")))
|
||||||
|
|
||||||
;; A single-line top-level `(load "PATH")` -> PATH, else #f.
|
;; A single-line top-level `(load "PATH")` -> PATH, else #f.
|
||||||
(define (bld-load-path line)
|
(define (bld-load-path line)
|
||||||
(let ((s (let trim ((i 0))
|
(let ((s (let trim ((i 0))
|
||||||
|
|
@ -137,20 +147,22 @@
|
||||||
(for-each (lambda (l) (bld-inline-line l out (+ depth 1))) (bld-file-lines p))
|
(for-each (lambda (l) (bld-inline-line l out (+ depth 1))) (bld-file-lines p))
|
||||||
(begin (put-string out line) (put-string out "\n")))))
|
(begin (put-string out line) (put-string out "\n")))))
|
||||||
|
|
||||||
;; Inline the runtime manifest. When drop-compiler? (a closed AOT app that never
|
;; Inline the runtime manifest, dispatching on the manifest tags. core-strs (the
|
||||||
;; compiles from source at runtime), omit the compiler image + compile-eval shim —
|
;; shaken clojure.core defs, or #f) replaces the 'prelude blob; drop-compiler? (a
|
||||||
|
;; closed AOT app that never compiles from source) omits 'image + 'compile-eval —
|
||||||
;; the analyzer/back end are dead weight in the binary (~0.8MB).
|
;; the analyzer/back end are dead weight in the binary (~0.8MB).
|
||||||
(define (bld-emit-runtime out drop-compiler? core-strs)
|
(define (bld-emit-runtime out drop-compiler? core-strs)
|
||||||
(for-each (lambda (l)
|
(for-each
|
||||||
(cond
|
(lambda (entry)
|
||||||
;; core-shake: emit the shaken clojure.core defs in place of the blob.
|
(cond
|
||||||
((and core-strs (bld-contains? l "seed/prelude.ss"))
|
((eq? entry 'prelude)
|
||||||
(for-each (lambda (s) (put-string out s) (put-string out "\n")) core-strs))
|
(if core-strs
|
||||||
((and drop-compiler?
|
(for-each (lambda (s) (put-string out s) (put-string out "\n")) core-strs)
|
||||||
(or (bld-contains? l "seed/image.ss") (bld-contains? l "compile-eval.ss")))
|
(bld-inline-line (cdr (assq 'prelude bld-tagged-loads)) out 0)))
|
||||||
#f)
|
((memq entry '(image compile-eval))
|
||||||
(else (bld-inline-line l out 0))))
|
(unless drop-compiler? (bld-inline-line (cdr (assq entry bld-tagged-loads)) out 0)))
|
||||||
bld-runtime-manifest))
|
(else (bld-inline-line entry out 0))))
|
||||||
|
bld-runtime-manifest))
|
||||||
|
|
||||||
;; --- app emission -----------------------------------------------------------
|
;; --- app emission -----------------------------------------------------------
|
||||||
;; Re-emit one app namespace to a list of Scheme strings: optimize (run-passes)
|
;; Re-emit one app namespace to a list of Scheme strings: optimize (run-passes)
|
||||||
|
|
@ -158,65 +170,47 @@
|
||||||
;; The loop itself is emit-image's ei-emit-ns* (optimize? #t, guard? #f).
|
;; The loop itself is emit-image's ei-emit-ns* (optimize? #t, guard? #f).
|
||||||
(define (bld-emit-ns ns-name src) (ei-emit-ns* ns-name src #t #f))
|
(define (bld-emit-ns ns-name src) (ei-emit-ns* ns-name src #t #f))
|
||||||
|
|
||||||
;; Tree-shake the whole closed program — the clojure.core prelude (read into records
|
;; Strings emitted before each app ns's forms, replaying what the source loader
|
||||||
;; by dce-blob-records) AND the re-emitted app + library namespaces — over one
|
;; does per file: (1) set chez-current-ns so runtime ns-sensitive setup forms
|
||||||
;; reachability graph: keep every non-def form (side effects), -main, the core fns the
|
;; (defmulti/defmethod resolve their target var through it) land in the right ns;
|
||||||
;; runtime shims need, and every def reachable from those; drop the rest. Bails to
|
;; (2) register the ns's :as aliases so a quoted alias resolves at runtime — a
|
||||||
;; keep-all if reachable code resolves vars by name at runtime (closed-world
|
;; (defmethod ig/foo …) passes 'ig/foo to defmethod-setup, which needs ig -> the
|
||||||
;; violation). Returns (values core-strs app-strs drop-compiler?); core-strs is #f on
|
;; real ns, but the build strips the (ns …) form that would register it.
|
||||||
;; a bail, signalling "inline prelude.ss unshaken".
|
(define (bld-scan-spec! ns-name spec emit!)
|
||||||
(define (bld-shake-all core-records app-records entry-main)
|
(let ((items (cond ((pvec? spec) (seq->list spec))
|
||||||
(let ((all (append core-records app-records))
|
((and (cseq? spec) (cseq-list? spec)) (seq->list spec))
|
||||||
(edges (make-hashtable string-hash string=?))
|
(else '()))))
|
||||||
(roots (cons entry-main dce-runtime-core-roots)))
|
(when (and (pair? items) (symbol-t? (car items)))
|
||||||
(for-each (lambda (r)
|
(let ((target (symbol-t-name (car items))))
|
||||||
(if (vector-ref r 0)
|
(let loop ((xs (cdr items)))
|
||||||
(set! roots (append (vector-ref r 2) roots))
|
(when (and (pair? xs) (pair? (cdr xs)))
|
||||||
(hashtable-set! edges (vector-ref r 1) (vector-ref r 2))))
|
(let ((k (car xs)) (v (cadr xs)))
|
||||||
all)
|
(when (and (keyword? k) (string=? (keyword-t-name k) "as") (symbol-t? v))
|
||||||
(let ((reached (make-hashtable string-hash string=?)))
|
(emit! (string-append "(chez-register-alias! " (ei-str-lit ns-name)
|
||||||
(let bfs ((work roots))
|
" " (ei-str-lit (symbol-t-name v))
|
||||||
(unless (null? work)
|
" " (ei-str-lit target) ")"))))
|
||||||
(let ((fq (car work)))
|
(loop (cddr xs))))))))
|
||||||
(if (hashtable-ref reached fq #f)
|
|
||||||
(bfs (cdr work))
|
(define (bld-ns-prelude ns-name src)
|
||||||
(begin (hashtable-set! reached fq #t)
|
(let ((acc (list (string-append "(set-chez-ns! " (ei-str-lit ns-name) ")")))
|
||||||
(bfs (append (or (hashtable-ref edges fq #f) '()) (cdr work))))))))
|
(nsf (let loop ((fs (ei-read-all src)))
|
||||||
(let ((kept? (lambda (r) (or (vector-ref r 0) (hashtable-ref reached (vector-ref r 1) #f))))
|
(cond ((null? fs) #f)
|
||||||
(refs-any (lambda (r set) (ormap (lambda (b) (and (member b (vector-ref r 2)) #t)) set)))
|
((ei-ns-form? (car fs)) (car fs))
|
||||||
(bail #f) (bail-why '()) (needs-compiler #f))
|
(else (loop (cdr fs)))))))
|
||||||
(for-each (lambda (r)
|
(when nsf
|
||||||
(when (kept? r)
|
(for-each
|
||||||
(for-each (lambda (b)
|
(lambda (clause)
|
||||||
(when (member b (vector-ref r 2))
|
(when (and (cseq? clause) (cseq-list? clause))
|
||||||
(set! bail #t)
|
(let ((citems (seq->list clause)))
|
||||||
(when (< (length bail-why) 6)
|
(when (and (pair? citems) (keyword? (car citems))
|
||||||
(set! bail-why (cons (cons (or (vector-ref r 1) "<form>") b) bail-why)))))
|
(let ((kn (keyword-t-name (car citems))))
|
||||||
dce-bail-refs)
|
(or (string=? kn "require") (string=? kn "use"))))
|
||||||
(when (refs-any r dce-compile-refs) (set! needs-compiler #t))))
|
(for-each (lambda (spec)
|
||||||
all)
|
(bld-scan-spec! ns-name spec
|
||||||
(let ((drop-compiler? (and (not bail) (not needs-compiler)))
|
(lambda (s) (set! acc (cons s acc)))))
|
||||||
;; -> (values strs n-defs n-kept)
|
(cdr citems))))))
|
||||||
(pick (lambda (recs)
|
(seq->list nsf)))
|
||||||
(let loop ((rs recs) (acc '()) (n 0) (k 0))
|
(reverse acc)))
|
||||||
(if (null? rs)
|
|
||||||
(values (reverse acc) n k)
|
|
||||||
(let* ((r (car rs)) (isdef (and (vector-ref r 1) #t)))
|
|
||||||
(if (kept? r)
|
|
||||||
(loop (cdr rs) (cons (vector-ref r 3) acc)
|
|
||||||
(if isdef (+ n 1) n) (if isdef (+ k 1) k))
|
|
||||||
(loop (cdr rs) acc (if isdef (+ n 1) n) k))))))))
|
|
||||||
(if bail
|
|
||||||
(begin (display "jolt build: tree-shake skipped (reachable code resolves vars at runtime):\n")
|
|
||||||
(for-each (lambda (w) (display (string-append " " (car w) " -> " (cdr w) "\n")))
|
|
||||||
(reverse bail-why))
|
|
||||||
(values #f (map (lambda (r) (vector-ref r 3)) app-records) drop-compiler?))
|
|
||||||
(let-values (((core-strs cn ck) (pick core-records))
|
|
||||||
((app-strs an ak) (pick app-records)))
|
|
||||||
(display (string-append "jolt build: tree-shake kept " (number->string (+ ck ak))
|
|
||||||
" of " (number->string (+ cn an)) " defs (core "
|
|
||||||
(number->string ck) "/" (number->string cn) ")\n"))
|
|
||||||
(values core-strs app-strs drop-compiler?))))))))
|
|
||||||
|
|
||||||
;; --- bundling: native libs + resources --------------------------------------
|
;; --- bundling: native libs + resources --------------------------------------
|
||||||
;; A jolt seq of jolt strings -> a Scheme list of Scheme strings.
|
;; A jolt seq of jolt strings -> a Scheme list of Scheme strings.
|
||||||
|
|
@ -305,24 +299,45 @@
|
||||||
;; every mode. The defined-set accumulates across the dependency-ordered
|
;; every mode. The defined-set accumulates across the dependency-ordered
|
||||||
;; namespaces, so a dep's defs are direct-linkable by the time the entry that
|
;; namespaces, so a dep's defs are direct-linkable by the time the entry that
|
||||||
;; calls them is emitted.
|
;; calls them is emitted.
|
||||||
(set-optimize! (string=? mode "optimized"))
|
;; set-optimize!/set-direct-link! are process-global flags in the back end;
|
||||||
(when direct-link?
|
;; dynamic-wind guarantees they revert even if a strict form errors mid-emit
|
||||||
((var-deref "jolt.backend-scheme" "set-direct-link!") #t)
|
;; (a failing form errors the build by design), so the compiler isn't left in
|
||||||
((var-deref "jolt.backend-scheme" "direct-link-reset!")))
|
;; optimize/direct-link mode for a later caller.
|
||||||
(let*-values
|
(let*-values
|
||||||
(((core-strs app-strs drop-compiler?)
|
(((core-strs app-strs drop-compiler?)
|
||||||
(if tree-shake?
|
(dynamic-wind
|
||||||
(bld-shake-all
|
(lambda ()
|
||||||
(dce-blob-records "host/chez/seed/prelude.ss")
|
(set-optimize! (string=? mode "optimized"))
|
||||||
(apply append
|
(when direct-link?
|
||||||
(map (lambda (nf) (ei-emit-ns-records (car nf) (read-file-string (cdr nf)))) ordered))
|
((var-deref "jolt.backend-scheme" "set-direct-link!") #t)
|
||||||
(string-append entry-ns "/-main"))
|
((var-deref "jolt.backend-scheme" "direct-link-reset!"))))
|
||||||
(values #f
|
(lambda ()
|
||||||
(apply append
|
(if tree-shake?
|
||||||
(map (lambda (nf) (bld-emit-ns (car nf) (read-file-string (cdr nf)))) ordered))
|
(dce-shake
|
||||||
#f))))
|
(dce-blob-records "host/chez/seed/prelude.ss")
|
||||||
(set-optimize! #f)
|
(apply append
|
||||||
((var-deref "jolt.backend-scheme" "set-direct-link!") #f)
|
(map (lambda (nf)
|
||||||
|
;; ns-prelude forms (always kept, no fqn/refs) set the
|
||||||
|
;; ns + register aliases before this ns's forms; dce
|
||||||
|
;; keeps original order.
|
||||||
|
(let ((src (read-file-string (cdr nf))))
|
||||||
|
(append
|
||||||
|
(map (lambda (s) (dce-rec #t #f '() s))
|
||||||
|
(bld-ns-prelude (car nf) src))
|
||||||
|
(ei-emit-ns-records (car nf) src))))
|
||||||
|
ordered))
|
||||||
|
(string-append entry-ns "/-main"))
|
||||||
|
(values #f
|
||||||
|
(apply append
|
||||||
|
(map (lambda (nf)
|
||||||
|
(let ((src (read-file-string (cdr nf))))
|
||||||
|
(append (bld-ns-prelude (car nf) src)
|
||||||
|
(bld-emit-ns (car nf) src))))
|
||||||
|
ordered))
|
||||||
|
#f)))
|
||||||
|
(lambda ()
|
||||||
|
(set-optimize! #f)
|
||||||
|
((var-deref "jolt.backend-scheme" "set-direct-link!") #f)))))
|
||||||
(when drop-compiler? (display "jolt build: dropping compiler image (no runtime eval)\n"))
|
(when drop-compiler? (display "jolt build: dropping compiler image (no runtime eval)\n"))
|
||||||
(let* ((builddir (string-append out-path ".build"))
|
(let* ((builddir (string-append out-path ".build"))
|
||||||
(flat-ss (string-append builddir "/flat.ss"))
|
(flat-ss (string-append builddir "/flat.ss"))
|
||||||
|
|
|
||||||
|
|
@ -225,16 +225,28 @@
|
||||||
(fold-left jolt-conj1 jolt-empty-list xs)
|
(fold-left jolt-conj1 jolt-empty-list xs)
|
||||||
(fold-left jolt-conj1 coll xs)))))
|
(fold-left jolt-conj1 coll xs)))))
|
||||||
|
|
||||||
|
;; A host shim registers a type's get via register-get-arm! (handler: (coll k d) ->
|
||||||
|
;; value) instead of set!-wrapping jolt-get — disjoint coll types, checked before the
|
||||||
|
;; base map/set/vec/string cases (cf. register-hash-arm!).
|
||||||
|
(define jolt-get-arms '())
|
||||||
|
(define (register-get-arm! pred handler)
|
||||||
|
(set! jolt-get-arms (cons (cons pred handler) jolt-get-arms)))
|
||||||
|
(define (jolt-get-base coll k d)
|
||||||
|
(cond ((pmap? coll) (pmap-get coll k d))
|
||||||
|
((pset? coll) (if (pset-contains? coll k) k d))
|
||||||
|
((pvec? coll) (pvec-nth-d coll k d))
|
||||||
|
((string? coll) (let ((i (->idx k)))
|
||||||
|
(if (and (fixnum? i) (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d)))
|
||||||
|
(else d)))
|
||||||
|
(define (jolt-get-dispatch coll k d)
|
||||||
|
(let loop ((as jolt-get-arms))
|
||||||
|
(cond ((null? as) (jolt-get-base coll k d))
|
||||||
|
(((caar as) coll) ((cdar as) coll k d))
|
||||||
|
(else (loop (cdr as))))))
|
||||||
(define jolt-get
|
(define jolt-get
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((coll k) (jolt-get coll k jolt-nil))
|
((coll k) (jolt-get-dispatch coll k jolt-nil))
|
||||||
((coll k d)
|
((coll k d) (jolt-get-dispatch coll k d))))
|
||||||
(cond ((pmap? coll) (pmap-get coll k d))
|
|
||||||
((pset? coll) (if (pset-contains? coll k) k d))
|
|
||||||
((pvec? coll) (pvec-nth-d coll k d))
|
|
||||||
((string? coll) (let ((i (->idx k)))
|
|
||||||
(if (and (fixnum? i) (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d)))
|
|
||||||
(else d)))))
|
|
||||||
|
|
||||||
(define jolt-nth
|
(define jolt-nth
|
||||||
(case-lambda
|
(case-lambda
|
||||||
|
|
|
||||||
183
host/chez/dce.ss
Normal file
183
host/chez/dce.ss
Normal file
|
|
@ -0,0 +1,183 @@
|
||||||
|
;; dce.ss — tree-shaking (jolt build --tree-shake): whole-program reachability DCE.
|
||||||
|
;;
|
||||||
|
;; Build one call graph over the re-emitted app + libraries AND the clojure.core
|
||||||
|
;; prelude, keep -main + every side-effecting top-level form + everything reachable
|
||||||
|
;; from those, drop the rest. Bails (keeps everything) if reachable code resolves a
|
||||||
|
;; var by name at runtime (eval/resolve/...), which a static graph can't follow. Per
|
||||||
|
;; Stalin's rule, ANY reference — a call OR a value/#'x — keeps its target live, so a
|
||||||
|
;; fn passed to map or referenced as #'x is never dropped.
|
||||||
|
;;
|
||||||
|
;; Loaded by build.ss after the compiler image (needs jolt.ir/reduce-ir-children).
|
||||||
|
;; The records it consumes come from ei-emit-ns-records (app/libs) + dce-blob-records
|
||||||
|
;; (the prelude); both build the (dce-rec …) shape below.
|
||||||
|
|
||||||
|
;; --- the DCE record ---------------------------------------------------------
|
||||||
|
;; keep?: #t = a non-def form (side effect / registration) — always emitted, and its
|
||||||
|
;; refs are reachability roots. #f = a prunable def emitted only if fqn is reached.
|
||||||
|
;; fqn: "ns/name" of a prunable def, else #f. refs: "ns/name" strings it references.
|
||||||
|
;; str: the Scheme source to emit.
|
||||||
|
(define (dce-rec keep? fqn refs str) (vector keep? fqn refs str))
|
||||||
|
(define (dce-rec-keep? r) (vector-ref r 0))
|
||||||
|
(define (dce-rec-fqn r) (vector-ref r 1))
|
||||||
|
(define (dce-rec-refs r) (vector-ref r 2))
|
||||||
|
(define (dce-rec-str r) (vector-ref r 3))
|
||||||
|
|
||||||
|
;; --- reference extraction from IR -------------------------------------------
|
||||||
|
(define dce-kw-op (keyword #f "op"))
|
||||||
|
(define dce-kw-var (keyword #f "var"))
|
||||||
|
(define dce-kw-the-var (keyword #f "the-var"))
|
||||||
|
(define dce-kw-def (keyword #f "def"))
|
||||||
|
(define dce-kw-ns (keyword #f "ns"))
|
||||||
|
(define dce-kw-name (keyword #f "name"))
|
||||||
|
(define dce-reduce-children (var-deref "jolt.ir" "reduce-ir-children"))
|
||||||
|
|
||||||
|
;; "ns/name" of every var reference anywhere in an IR node, prepended to acc. Counts
|
||||||
|
;; a :var (call head or value) and a :the-var (#'x). Arg order (acc node) matches
|
||||||
|
;; reduce-ir-children's fold fn so it nests directly.
|
||||||
|
(define (dce-collect-refs acc node)
|
||||||
|
(let ((op (jolt-get node dce-kw-op)))
|
||||||
|
(if (or (eq? op dce-kw-var) (eq? op dce-kw-the-var))
|
||||||
|
(cons (string-append (jolt-get node dce-kw-ns) "/" (jolt-get node dce-kw-name)) acc)
|
||||||
|
(dce-reduce-children dce-collect-refs acc node))))
|
||||||
|
|
||||||
|
;; The fqn of a bare top-level def (the only prunable IR form), else #f.
|
||||||
|
(define (dce-def-fqn node)
|
||||||
|
(and (eq? (jolt-get node dce-kw-op) dce-kw-def)
|
||||||
|
(string-append (jolt-get node dce-kw-ns) "/" (jolt-get node dce-kw-name))))
|
||||||
|
|
||||||
|
;; --- reference sets that gate the analysis ----------------------------------
|
||||||
|
;; A reference whose presence in reachable code forces keep-everything (the static
|
||||||
|
;; graph can't follow runtime name resolution).
|
||||||
|
(define dce-bail-refs
|
||||||
|
'("clojure.core/eval" "clojure.core/resolve" "clojure.core/ns-resolve"
|
||||||
|
"clojure.core/requiring-resolve" "clojure.core/find-var" "clojure.core/intern"
|
||||||
|
"clojure.core/load-string" "clojure.core/load-file" "clojure.core/load-reader"
|
||||||
|
"clojure.core/load"))
|
||||||
|
|
||||||
|
;; A reference that needs the analyzer/back end at runtime (compile-from-source). If
|
||||||
|
;; reachable code uses none of these, the compiler image is dropped from the binary —
|
||||||
|
;; an AOT app is fully compiled. (resolve/require don't need it: resolve is a
|
||||||
|
;; var-table lookup; a require of a baked ns no-ops.)
|
||||||
|
(define dce-compile-refs
|
||||||
|
'("clojure.core/eval" "clojure.core/load-string" "clojure.core/load-file"
|
||||||
|
"clojure.core/load-reader" "clojure.core/load"))
|
||||||
|
|
||||||
|
;; clojure.core fns the runtime .ss shims reference by name (via var-deref) — they
|
||||||
|
;; aren't visible in the IR call graph, so seed them as roots. (Found by grepping the
|
||||||
|
;; runtime shims; the smoke harness catches a miss as a diff/crash.)
|
||||||
|
(define dce-runtime-core-roots
|
||||||
|
'("clojure.core/identity" "clojure.core/isa?" "clojure.core/line-seq"
|
||||||
|
"clojure.core/make-hierarchy" "clojure.core/read" "clojure.core/read-string"
|
||||||
|
"clojure.core/read+string" "clojure.core/realized?" "clojure.core/reset!"))
|
||||||
|
|
||||||
|
;; --- reading a minted blob (prelude.ss) into records ------------------------
|
||||||
|
;; The prelude is a flat list of (guard CLAUSE (def-var! "ns" "name" V)) forms (+ the
|
||||||
|
;; occasional side-effecting init). Read each with Chez `read` so it joins the graph
|
||||||
|
;; instead of being baked wholesale: a def-var! is a prunable node whose core->core
|
||||||
|
;; edges are the (var-deref/jolt-var "ns" "name") calls in V; any other form is
|
||||||
|
;; non-prunable (kept, refs are roots).
|
||||||
|
(define (dce-unwrap form)
|
||||||
|
(if (and (pair? form) (eq? (car form) 'guard) (pair? (cddr form))) (caddr form) form))
|
||||||
|
|
||||||
|
(define (dce-sexp-refs form acc)
|
||||||
|
(cond
|
||||||
|
((and (pair? form) (memq (car form) '(var-deref jolt-var))
|
||||||
|
(pair? (cdr form)) (string? (cadr form)) (pair? (cddr form)) (string? (caddr form)))
|
||||||
|
(cons (string-append (cadr form) "/" (caddr form)) acc))
|
||||||
|
((pair? form) (dce-sexp-refs (cdr form) (dce-sexp-refs (car form) acc)))
|
||||||
|
(else acc)))
|
||||||
|
|
||||||
|
;; str re-serializes the read form (compiled identically; comments/whitespace are
|
||||||
|
;; irrelevant).
|
||||||
|
(define (dce-blob-records path)
|
||||||
|
(call-with-input-file path
|
||||||
|
(lambda (p)
|
||||||
|
(let loop ((acc '()))
|
||||||
|
(let ((form (read p)))
|
||||||
|
(if (eof-object? form)
|
||||||
|
(reverse acc)
|
||||||
|
(let ((b (dce-unwrap form))
|
||||||
|
(str (with-output-to-string (lambda () (write form))))
|
||||||
|
(refs (dce-sexp-refs form '())))
|
||||||
|
(loop (cons
|
||||||
|
(if (and (pair? b) (eq? (car b) 'def-var!) (pair? (cdr b)) (string? (cadr b))
|
||||||
|
(pair? (cddr b)) (string? (caddr b)))
|
||||||
|
(dce-rec #f (string-append (cadr b) "/" (caddr b)) refs str)
|
||||||
|
(dce-rec #t #f refs str))
|
||||||
|
acc)))))))))
|
||||||
|
|
||||||
|
;; --- the shake: graph -> reachable -> bail check -> partition ----------------
|
||||||
|
;; edges: fqn -> refs (prunable defs only). roots: -main + the runtime-core roots +
|
||||||
|
;; every non-def form's refs.
|
||||||
|
(define (dce-build-graph records entry-main)
|
||||||
|
(let ((edges (make-hashtable string-hash string=?))
|
||||||
|
(roots (cons entry-main dce-runtime-core-roots)))
|
||||||
|
(for-each (lambda (r)
|
||||||
|
(if (dce-rec-keep? r)
|
||||||
|
(set! roots (append (dce-rec-refs r) roots))
|
||||||
|
(hashtable-set! edges (dce-rec-fqn r) (dce-rec-refs r))))
|
||||||
|
records)
|
||||||
|
(values edges roots)))
|
||||||
|
|
||||||
|
;; Closure of roots over edges -> a reached set (hashtable fqn -> #t).
|
||||||
|
(define (dce-reachable edges roots)
|
||||||
|
(let ((reached (make-hashtable string-hash string=?)))
|
||||||
|
(let bfs ((work roots))
|
||||||
|
(unless (null? work)
|
||||||
|
(let ((fq (car work)))
|
||||||
|
(if (hashtable-ref reached fq #f)
|
||||||
|
(bfs (cdr work))
|
||||||
|
(begin (hashtable-set! reached fq #t)
|
||||||
|
(bfs (append (or (hashtable-ref edges fq #f) '()) (cdr work))))))))
|
||||||
|
reached))
|
||||||
|
|
||||||
|
(define (dce-rec-reached? r reached)
|
||||||
|
(or (dce-rec-keep? r) (hashtable-ref reached (dce-rec-fqn r) #f)))
|
||||||
|
|
||||||
|
;; Scan the KEPT records: does any resolve a var at runtime (bail), and does any need
|
||||||
|
;; the compiler? Returns (values bail? bail-why needs-compiler?). bail-why is up to 6
|
||||||
|
;; (def . bail-ref) pairs for the diagnostic.
|
||||||
|
(define (dce-bail-scan records reached)
|
||||||
|
(let ((bail #f) (why '()) (needs-compiler #f))
|
||||||
|
(for-each
|
||||||
|
(lambda (r)
|
||||||
|
(when (dce-rec-reached? r reached)
|
||||||
|
(for-each (lambda (b)
|
||||||
|
(when (member b (dce-rec-refs r))
|
||||||
|
(set! bail #t)
|
||||||
|
(when (< (length why) 6)
|
||||||
|
(set! why (cons (cons (or (dce-rec-fqn r) "<form>") b) why)))))
|
||||||
|
dce-bail-refs)
|
||||||
|
(when (ormap (lambda (c) (and (member c (dce-rec-refs r)) #t)) dce-compile-refs)
|
||||||
|
(set! needs-compiler #t))))
|
||||||
|
records)
|
||||||
|
(values bail (reverse why) needs-compiler)))
|
||||||
|
|
||||||
|
;; Kept records -> (values kept-strings n-defs n-kept-defs).
|
||||||
|
(define (dce-partition records reached)
|
||||||
|
(let loop ((rs records) (acc '()) (n 0) (k 0))
|
||||||
|
(if (null? rs)
|
||||||
|
(values (reverse acc) n k)
|
||||||
|
(let* ((r (car rs)) (isdef (and (dce-rec-fqn r) #t)))
|
||||||
|
(if (dce-rec-reached? r reached)
|
||||||
|
(loop (cdr rs) (cons (dce-rec-str r) acc) (if isdef (+ n 1) n) (if isdef (+ k 1) k))
|
||||||
|
(loop (cdr rs) acc (if isdef (+ n 1) n) k))))))
|
||||||
|
|
||||||
|
;; Returns (values core-strs app-strs drop-compiler?). core-strs is #f on a bail,
|
||||||
|
;; signalling "inline prelude.ss unshaken" + keep the compiler.
|
||||||
|
(define (dce-shake core-records app-records entry-main)
|
||||||
|
(let-values (((edges roots) (dce-build-graph (append core-records app-records) entry-main)))
|
||||||
|
(let* ((reached (dce-reachable edges roots)))
|
||||||
|
(let-values (((bail why needs-compiler) (dce-bail-scan (append core-records app-records) reached)))
|
||||||
|
(let ((drop-compiler? (and (not bail) (not needs-compiler))))
|
||||||
|
(if bail
|
||||||
|
(begin
|
||||||
|
(display "jolt build: tree-shake skipped (reachable code resolves vars at runtime):\n")
|
||||||
|
(for-each (lambda (w) (display (string-append " " (car w) " -> " (cdr w) "\n"))) why)
|
||||||
|
(values #f (map dce-rec-str app-records) drop-compiler?))
|
||||||
|
(let-values (((core-strs cn ck) (dce-partition core-records reached))
|
||||||
|
((app-strs an ak) (dce-partition app-records reached)))
|
||||||
|
(display (string-append "jolt build: tree-shake kept " (number->string (+ ck ak))
|
||||||
|
" of " (number->string (+ cn an)) " defs (core "
|
||||||
|
(number->string ck) "/" (number->string cn) ")\n"))
|
||||||
|
(values core-strs app-strs drop-compiler?))))))))
|
||||||
|
|
@ -132,12 +132,7 @@
|
||||||
;; var-cell keys hash/compare by ns/name (jolt=2 in vars.ss already compares
|
;; var-cell keys hash/compare by ns/name (jolt=2 in vars.ss already compares
|
||||||
;; ns/name) — stable under root mutation, so a var works as a map key (with-redefs
|
;; ns/name) — stable under root mutation, so a var works as a map key (with-redefs
|
||||||
;; builds (hash-map (var f) v); get-thread-bindings returns a var-keyed map).
|
;; builds (hash-map (var f) v); get-thread-bindings returns a var-keyed map).
|
||||||
(define %dyn-hash jolt-hash)
|
(register-hash-arm! var-cell? (lambda (x) (equal-hash (cons (var-cell-ns x) (var-cell-name x)))))
|
||||||
(set! jolt-hash
|
|
||||||
(lambda (x)
|
|
||||||
(if (var-cell? x)
|
|
||||||
(equal-hash (cons (var-cell-ns x) (var-cell-name x)))
|
|
||||||
(%dyn-hash x))))
|
|
||||||
|
|
||||||
;; --- bind the host seams the overlay references -----------------------------
|
;; --- bind the host seams the overlay references -----------------------------
|
||||||
(def-var! "clojure.core" "push-thread-bindings" jolt-push-thread-bindings)
|
(def-var! "clojure.core" "push-thread-bindings" jolt-push-thread-bindings)
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,8 @@
|
||||||
;; dynamic vars — the handful of clojure.core dynamic vars that aren't emitted into
|
;; dynamic-var-defaults.ss — default values for the handful of clojure.core dynamic
|
||||||
;; the prelude. These two are plain constants; *ns* (a namespace object) needs a
|
;; vars that aren't emitted into the prelude (*clojure-version*, *assert*, …). Plain
|
||||||
;; value type with get-see-through and map?=false and is tracked separately. Loaded
|
;; constant def-var!s; *ns* (a namespace object) needs a value type with
|
||||||
|
;; get-see-through and map?=false and is tracked separately. The binding-stack
|
||||||
|
;; machinery (binding / var-set / thread-bound?) lives in dyn-binding.ss. Loaded
|
||||||
;; from rt.ss after the value model + def-var!.
|
;; from rt.ss after the value model + def-var!.
|
||||||
|
|
||||||
;; *clojure-version* — a map {:major 1 :minor 11 :incremental 0 :qualifier nil}.
|
;; *clojure-version* — a map {:major 1 :minor 11 :incremental 0 :qualifier nil}.
|
||||||
|
|
@ -84,100 +84,13 @@
|
||||||
|
|
||||||
(define (ei-emit-ns ns-name src) (ei-emit-ns* ns-name src #f #t))
|
(define (ei-emit-ns ns-name src) (ei-emit-ns* ns-name src #f #t))
|
||||||
|
|
||||||
;; --- tree-shaking (jolt build --tree-shake) ---------------------------------
|
;; --- DCE record producer ----------------------------------------------------
|
||||||
;; Reachability DCE over the re-emitted app + library forms: keep -main, every
|
;; Cross-compile a namespace's source to tree-shaking records — the app/library
|
||||||
;; side-effecting (non-def) top-level form, and every def reachable from those;
|
;; counterpart to dce-blob-records (the prelude). The shake itself and all dce-*
|
||||||
;; drop the rest (unused library code). Bails (keeps everything) if the app resolves
|
;; helpers live in dce.ss; this stays here because it drives the ei-* compiler. A
|
||||||
;; vars by name at runtime (eval/resolve/...), which static reachability can't
|
;; top-level def becomes a prunable record; any other form a kept (side-effecting)
|
||||||
;; follow. clojure.core / the compiler stay baked (the prelude + image blobs), so
|
;; record whose refs are roots. A macro is prunable — its expander isn't called at
|
||||||
;; only the re-emitted namespaces are shaken.
|
;; runtime in an AOT build.
|
||||||
(define dce-kw-op (keyword #f "op"))
|
|
||||||
(define dce-kw-var (keyword #f "var"))
|
|
||||||
(define dce-kw-the-var (keyword #f "the-var"))
|
|
||||||
(define dce-kw-def (keyword #f "def"))
|
|
||||||
(define dce-kw-ns (keyword #f "ns"))
|
|
||||||
(define dce-kw-name (keyword #f "name"))
|
|
||||||
(define dce-reduce-children (var-deref "jolt.ir" "reduce-ir-children"))
|
|
||||||
|
|
||||||
;; "ns/name" of every var reference anywhere in node, prepended to acc. Counts BOTH
|
|
||||||
;; a :var (call head or value) and a :the-var (#'x / (var x)) — per Stalin's rule,
|
|
||||||
;; any reference (not just a direct call) keeps the target live, so a var passed as a
|
|
||||||
;; value or referenced as #'x is reachable. Arg order (acc node) matches
|
|
||||||
;; reduce-ir-children's fold fn, so it nests directly.
|
|
||||||
(define (dce-collect-refs acc node)
|
|
||||||
(let ((op (jolt-get node dce-kw-op)))
|
|
||||||
(if (or (eq? op dce-kw-var) (eq? op dce-kw-the-var))
|
|
||||||
(cons (string-append (jolt-get node dce-kw-ns) "/" (jolt-get node dce-kw-name)) acc)
|
|
||||||
(dce-reduce-children dce-collect-refs acc node))))
|
|
||||||
|
|
||||||
;; The fqn of a bare top-level def (the only prunable form), else #f.
|
|
||||||
(define (dce-def-fqn node)
|
|
||||||
(and (eq? (jolt-get node dce-kw-op) dce-kw-def)
|
|
||||||
(string-append (jolt-get node dce-kw-ns) "/" (jolt-get node dce-kw-name))))
|
|
||||||
|
|
||||||
;; A reference whose presence forces keep-everything (runtime name resolution).
|
|
||||||
(define dce-bail-refs
|
|
||||||
'("clojure.core/eval" "clojure.core/resolve" "clojure.core/ns-resolve"
|
|
||||||
"clojure.core/requiring-resolve" "clojure.core/find-var" "clojure.core/intern"
|
|
||||||
"clojure.core/load-string" "clojure.core/load-file" "clojure.core/load-reader"
|
|
||||||
"clojure.core/load"))
|
|
||||||
|
|
||||||
;; clojure.core fns the runtime .ss shims reference by name (via var-deref) — they
|
|
||||||
;; aren't visible in the IR call graph, so seed them as roots. (Found by grepping the
|
|
||||||
;; runtime shims; the smoke harness catches a miss as a diff/crash.)
|
|
||||||
(define dce-runtime-core-roots
|
|
||||||
'("clojure.core/identity" "clojure.core/isa?" "clojure.core/line-seq"
|
|
||||||
"clojure.core/make-hierarchy" "clojure.core/read" "clojure.core/read-string"
|
|
||||||
"clojure.core/read+string" "clojure.core/realized?" "clojure.core/reset!"))
|
|
||||||
|
|
||||||
;; --- reading a minted blob (prelude.ss) into DCE records --------------------
|
|
||||||
;; The prelude is a flat list of (guard CLAUSE (def-var! "ns" "name" V)) forms (+ the
|
|
||||||
;; occasional side-effecting init). Read each with Chez `read` so it joins the
|
|
||||||
;; reachability graph instead of being baked wholesale: a def-var! is a prunable node
|
|
||||||
;; whose core->core edges are the (var-deref/jolt-var "ns" "name") calls in V; any
|
|
||||||
;; other form is non-prunable (kept, refs are roots).
|
|
||||||
(define (dce-unwrap form)
|
|
||||||
(if (and (pair? form) (eq? (car form) 'guard) (pair? (cddr form))) (caddr form) form))
|
|
||||||
|
|
||||||
(define (dce-sexp-refs form acc)
|
|
||||||
(cond
|
|
||||||
((and (pair? form) (memq (car form) '(var-deref jolt-var))
|
|
||||||
(pair? (cdr form)) (string? (cadr form)) (pair? (cddr form)) (string? (caddr form)))
|
|
||||||
(cons (string-append (cadr form) "/" (caddr form)) acc))
|
|
||||||
((pair? form) (dce-sexp-refs (cdr form) (dce-sexp-refs (car form) acc)))
|
|
||||||
(else acc)))
|
|
||||||
|
|
||||||
;; Records (same shape as ei-emit-ns-records) for a minted blob file. str re-serializes
|
|
||||||
;; the read form (compiled identically; comments/whitespace are irrelevant).
|
|
||||||
(define (dce-blob-records path)
|
|
||||||
(call-with-input-file path
|
|
||||||
(lambda (p)
|
|
||||||
(let loop ((acc '()))
|
|
||||||
(let ((form (read p)))
|
|
||||||
(if (eof-object? form)
|
|
||||||
(reverse acc)
|
|
||||||
(let ((b (dce-unwrap form))
|
|
||||||
(str (with-output-to-string (lambda () (write form))))
|
|
||||||
(refs (dce-sexp-refs form '())))
|
|
||||||
(loop (cons
|
|
||||||
(if (and (pair? b) (eq? (car b) 'def-var!) (pair? (cdr b)) (string? (cadr b))
|
|
||||||
(pair? (cddr b)) (string? (caddr b)))
|
|
||||||
(vector #f (string-append (cadr b) "/" (caddr b)) refs str)
|
|
||||||
(vector #t #f refs str))
|
|
||||||
acc)))))))))
|
|
||||||
|
|
||||||
;; A reference that needs the analyzer/back end at runtime (compile-from-source). If
|
|
||||||
;; reachable code uses none of these, the compiler image can be dropped from the
|
|
||||||
;; binary — the AOT app is fully compiled. (resolve/require don't need it: resolve is
|
|
||||||
;; a var-table lookup; a require of a baked ns no-ops.)
|
|
||||||
(define dce-compile-refs
|
|
||||||
'("clojure.core/eval" "clojure.core/load-string" "clojure.core/load-file"
|
|
||||||
"clojure.core/load-reader" "clojure.core/load"))
|
|
||||||
|
|
||||||
;; One record per form: (vector keep? fqn refs str). keep? #t = a non-def form,
|
|
||||||
;; always emitted, its refs are reachability roots; #f = a prunable def emitted only
|
|
||||||
;; if fqn is reached. A macro is a prunable def (its expander isn't called at runtime
|
|
||||||
;; in an AOT build). Strict (no guard) like the build's ei-emit-ns* path.
|
|
||||||
(define (ei-emit-ns-records ns-name src)
|
(define (ei-emit-ns-records ns-name src)
|
||||||
(let loop ((forms (ei-read-all src)) (acc '()))
|
(let loop ((forms (ei-read-all src)) (acc '()))
|
||||||
(if (null? forms)
|
(if (null? forms)
|
||||||
|
|
@ -192,7 +105,7 @@
|
||||||
(ir (jolt-ce-run-passes (jolt-ce-analyze ctx fn-form) ctx))
|
(ir (jolt-ce-run-passes (jolt-ce-analyze ctx fn-form) ctx))
|
||||||
(str (ei-macro-string ns-name nm (jolt-ce-emit-top ir) #f))
|
(str (ei-macro-string ns-name nm (jolt-ce-emit-top ir) #f))
|
||||||
(refs (dce-collect-refs '() ir)))
|
(refs (dce-collect-refs '() ir)))
|
||||||
(loop (cdr forms) (cons (vector #f (string-append ns-name "/" nm) refs str) acc)))))
|
(loop (cdr forms) (cons (dce-rec #f (string-append ns-name "/" nm) refs str) acc)))))
|
||||||
(else
|
(else
|
||||||
(let* ((ctx (make-analyze-ctx ns-name))
|
(let* ((ctx (make-analyze-ctx ns-name))
|
||||||
(ir (jolt-ce-run-passes (jolt-ce-analyze ctx f) ctx))
|
(ir (jolt-ce-run-passes (jolt-ce-analyze ctx f) ctx))
|
||||||
|
|
@ -200,7 +113,7 @@
|
||||||
(fqn (dce-def-fqn ir))
|
(fqn (dce-def-fqn ir))
|
||||||
(refs (dce-collect-refs '() ir)))
|
(refs (dce-collect-refs '() ir)))
|
||||||
(loop (cdr forms)
|
(loop (cdr forms)
|
||||||
(cons (if fqn (vector #f fqn refs str) (vector #t #f refs str)) acc)))))))))
|
(cons (if fqn (dce-rec #f fqn refs str) (dce-rec #t #f refs str)) acc)))))))))
|
||||||
|
|
||||||
;; Scheme string literal for a ns/name — uses the runtime's own writer
|
;; Scheme string literal for a ns/name — uses the runtime's own writer
|
||||||
;; (printable ASCII identifiers only here).
|
;; (printable ASCII identifiers only here).
|
||||||
|
|
@ -217,6 +130,7 @@
|
||||||
(cons "jolt.passes.numeric" "jolt-core/jolt/passes/numeric.clj")
|
(cons "jolt.passes.numeric" "jolt-core/jolt/passes/numeric.clj")
|
||||||
(cons "jolt.passes.inline" "jolt-core/jolt/passes/inline.clj")
|
(cons "jolt.passes.inline" "jolt-core/jolt/passes/inline.clj")
|
||||||
(cons "jolt.passes.types.lattice" "jolt-core/jolt/passes/types/lattice.clj")
|
(cons "jolt.passes.types.lattice" "jolt-core/jolt/passes/types/lattice.clj")
|
||||||
|
(cons "jolt.passes.types.check" "jolt-core/jolt/passes/types/check.clj")
|
||||||
(cons "jolt.passes.types" "jolt-core/jolt/passes/types.clj")
|
(cons "jolt.passes.types" "jolt-core/jolt/passes/types.clj")
|
||||||
(cons "jolt.passes" "jolt-core/jolt/passes.clj")))
|
(cons "jolt.passes" "jolt-core/jolt/passes.clj")))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -13,7 +13,13 @@
|
||||||
;; (str (type x)) is the clean host taxonomy and
|
;; (str (type x)) is the clean host taxonomy and
|
||||||
;; is never compared against a class token in the corpus. Records yield their
|
;; is never compared against a class token in the corpus. Records yield their
|
||||||
;; ns-qualified class name (= (str (type x))). Total — never crashes.
|
;; ns-qualified class name (= (str (type x))). Total — never crashes.
|
||||||
(define (jolt-class x)
|
;; A host shim (bigdec, queue, host-table) registers its type's class name via
|
||||||
|
;; register-class-arm! instead of set!-wrapping jolt-class (cf. register-hash-arm!).
|
||||||
|
;; The entry is stable, so the var cell bound below stays current as arms register.
|
||||||
|
(define jolt-class-arms '())
|
||||||
|
(define (register-class-arm! pred handler)
|
||||||
|
(set! jolt-class-arms (cons (cons pred handler) jolt-class-arms)))
|
||||||
|
(define (jolt-class-base x)
|
||||||
(cond
|
(cond
|
||||||
((jolt-nil? x) jolt-nil)
|
((jolt-nil? x) jolt-nil)
|
||||||
((boolean? x) "java.lang.Boolean")
|
((boolean? x) "java.lang.Boolean")
|
||||||
|
|
@ -35,6 +41,11 @@
|
||||||
;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class).
|
;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class).
|
||||||
((ex-info-map? x) (ex-info-class x))
|
((ex-info-map? x) (ex-info-class x))
|
||||||
(else (jolt-str-render-one (jolt-type x)))))
|
(else (jolt-str-render-one (jolt-type x)))))
|
||||||
|
(define (jolt-class x)
|
||||||
|
(let loop ((as jolt-class-arms))
|
||||||
|
(cond ((null? as) (jolt-class-base x))
|
||||||
|
(((caar as) x) ((cdar as) x))
|
||||||
|
(else (loop (cdr as))))))
|
||||||
|
|
||||||
(def-var! "clojure.core" "class" jolt-class)
|
(def-var! "clojure.core" "class" jolt-class)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,8 @@
|
||||||
;; host-static-objects.ss — host object classes (ArrayList, HashMap, the
|
;; host-static-classes.ss — instantiable host object classes: ArrayList, HashMap,
|
||||||
;; String/Reader/Writer/Tokenizer shims, BigInteger/MapEntry ctors, URL codecs)
|
;; the String/Reader/Writer/Tokenizer shims, BigInteger/MapEntry ctors, and URL
|
||||||
;; and the tagged-table method dispatch + pluggable instance? hook. Continues
|
;; codecs. Holds the tagged-table method dispatch (the (.method ...) arm on a jhost)
|
||||||
;; host-static-statics.ss; loaded last of the three.
|
;; and the pluggable instance? hook. Loaded after host-static-methods.ss; the
|
||||||
|
;; `Class/member` static methods live there, the registry core in host-static.ss.
|
||||||
|
|
||||||
;; ---- java.util.ArrayList ----------------------------------------------------
|
;; ---- java.util.ArrayList ----------------------------------------------------
|
||||||
;; A mutable list backed by a growable Scheme vector. State is #(backing count);
|
;; A mutable list backed by a growable Scheme vector. State is #(backing count);
|
||||||
|
|
@ -1,6 +1,8 @@
|
||||||
;; host-static-statics.ss — java.lang / java.util.* static methods and the
|
;; host-static-methods.ss — the `Class/member` static surface: java.lang.Math,
|
||||||
;; NumberFormat / Class registries. Continues host-static.ss (its registries +
|
;; System (properties/env), Thread, the Long/Integer/Double/Character/String static
|
||||||
;; jhost record + coercion helpers); loaded right after it.
|
;; methods, java.text.NumberFormat, and the Class registry. Registers into
|
||||||
|
;; host-static.ss's class-statics table (loaded just before this); instantiable host
|
||||||
|
;; object classes (ArrayList, StringBuilder, …) live in host-static-classes.ss.
|
||||||
|
|
||||||
;; ---- java.lang statics ------------------------------------------------------
|
;; ---- java.lang statics ------------------------------------------------------
|
||||||
;; java.lang.Math: sqrt/pow/floor/ceil/trig/log/exp always return a DOUBLE on the
|
;; java.lang.Math: sqrt/pow/floor/ceil/trig/log/exp always return a DOUBLE on the
|
||||||
|
|
@ -1,4 +1,7 @@
|
||||||
;; host-static.ss — host class statics + constructors on Chez.
|
;; host-static.ss — the host-interop registry core: the class-statics / class-ctors
|
||||||
|
;; / tagged-methods tables, the jhost record, and the coercion helpers. The actual
|
||||||
|
;; entries are registered by host-static-methods.ss (Class/member statics) and
|
||||||
|
;; host-static-classes.ss (instantiable object classes), loaded after this.
|
||||||
;;
|
;;
|
||||||
;; The analyzer lowers `Class/member` to a :host-static node and `(Class. ...)` /
|
;; The analyzer lowers `Class/member` to a :host-static node and `(Class. ...)` /
|
||||||
;; `(new Class ...)` to a :host-new node (jolt-core/jolt/analyzer.clj); the Chez
|
;; `(new Class ...)` to a :host-new node (jolt-core/jolt/analyzer.clj); the Chez
|
||||||
|
|
|
||||||
|
|
@ -72,10 +72,7 @@
|
||||||
(set! jolt-seq (lambda (x) (if (htable-sorted? x) (sc-call x kw-op-seq) (%h-seq x))))
|
(set! jolt-seq (lambda (x) (if (htable-sorted? x) (sc-call x kw-op-seq) (%h-seq x))))
|
||||||
(define %h-count jolt-count)
|
(define %h-count jolt-count)
|
||||||
(set! jolt-count (lambda (coll) (if (htable-sorted? coll) (sc-call coll kw-op-count) (%h-count coll))))
|
(set! jolt-count (lambda (coll) (if (htable-sorted? coll) (sc-call coll kw-op-count) (%h-count coll))))
|
||||||
(define %h-get jolt-get)
|
(register-get-arm! htable-sorted? (lambda (coll k d) (sc-call coll kw-op-get k d)))
|
||||||
(set! jolt-get (case-lambda
|
|
||||||
((coll k) (if (htable-sorted? coll) (sc-call coll kw-op-get k jolt-nil) (%h-get coll k)))
|
|
||||||
((coll k d) (if (htable-sorted? coll) (sc-call coll kw-op-get k d) (%h-get coll k d)))))
|
|
||||||
(define %h-contains? jolt-contains?)
|
(define %h-contains? jolt-contains?)
|
||||||
(set! jolt-contains? (lambda (coll k)
|
(set! jolt-contains? (lambda (coll k)
|
||||||
(if (htable-sorted? coll) (if (jolt-truthy? (sc-call coll kw-op-contains k)) #t #f) (%h-contains? coll k))))
|
(if (htable-sorted? coll) (if (jolt-truthy? (sc-call coll kw-op-contains k)) #t #f) (%h-contains? coll k))))
|
||||||
|
|
@ -131,13 +128,13 @@
|
||||||
(define (sorted-set->pset sc)
|
(define (sorted-set->pset sc)
|
||||||
(fold-left (lambda (s x) (pset-conj s x)) empty-pset (seq->list (sc-call sc kw-op-seq))))
|
(fold-left (lambda (s x) (pset-conj s x)) empty-pset (seq->list (sc-call sc kw-op-seq))))
|
||||||
(define (sorted->plain x) (if (htable-sorted-map? x) (sorted-map->pmap x) (sorted-set->pset x)))
|
(define (sorted->plain x) (if (htable-sorted-map? x) (sorted-map->pmap x) (sorted-set->pset x)))
|
||||||
(define %h-jolt=2 jolt=2)
|
;; a sorted coll compares as its plain equivalent: normalize and re-dispatch (the
|
||||||
(set! jolt=2 (lambda (a b)
|
;; normalized values aren't sorted, so this arm won't re-match — the base compares).
|
||||||
(cond ((htable-sorted? a) (%h-jolt=2 (sorted->plain a) (if (htable-sorted? b) (sorted->plain b) b)))
|
(register-eq-arm! (lambda (a b) (or (htable-sorted? a) (htable-sorted? b)))
|
||||||
((htable-sorted? b) (%h-jolt=2 a (sorted->plain b)))
|
(lambda (a b) (jolt=2 (if (htable-sorted? a) (sorted->plain a) a)
|
||||||
(else (%h-jolt=2 a b)))))
|
(if (htable-sorted? b) (sorted->plain b) b))))
|
||||||
(define %h-jolt-hash jolt-hash)
|
;; a sorted coll hashes as its plain equivalent (jolt-hash recurses through the base).
|
||||||
(set! jolt-hash (lambda (x) (if (htable-sorted? x) (%h-jolt-hash (sorted->plain x)) (%h-jolt-hash x))))
|
(register-hash-arm! htable-sorted? (lambda (x) (jolt-hash (sorted->plain x))))
|
||||||
|
|
||||||
;; --- printing ----------------------------------------------------------------
|
;; --- printing ----------------------------------------------------------------
|
||||||
;; sorted colls render in SORTED order (the value's :seq), not HAMT order — and
|
;; sorted colls render in SORTED order (the value's :seq), not HAMT order — and
|
||||||
|
|
@ -156,10 +153,9 @@
|
||||||
(define (sorted-render x render)
|
(define (sorted-render x render)
|
||||||
(if (htable-sorted-map? x) (sorted-map-render x render) (sorted-set-render x render)))
|
(if (htable-sorted-map? x) (sorted-map-render x render) (sorted-set-render x render)))
|
||||||
|
|
||||||
(define %h-pr-readable jolt-pr-readable)
|
;; sorted colls render in :seq order via the calling printer (str vs readable).
|
||||||
(set! jolt-pr-readable (lambda (x) (if (htable-sorted? x) (sorted-render x jolt-pr-readable) (%h-pr-readable x))))
|
(register-pr-readable-arm! htable-sorted? (lambda (x) (sorted-render x jolt-pr-readable)))
|
||||||
(define %h-pr-str jolt-pr-str)
|
(register-pr-str-arm! htable-sorted? (lambda (x) (sorted-render x jolt-pr-str)))
|
||||||
(set! jolt-pr-str (lambda (x) (if (htable-sorted? x) (sorted-render x jolt-pr-str) (%h-pr-str x))))
|
|
||||||
(register-str-render! htable-sorted? (lambda (x) (sorted-render x jolt-str-render-one)))
|
(register-str-render! htable-sorted? (lambda (x) (sorted-render x jolt-str-render-one)))
|
||||||
|
|
||||||
;; --- protocol dispatch over builtins (extend-protocol Map/Set on sorted) ------
|
;; --- protocol dispatch over builtins (extend-protocol Map/Set on sorted) ------
|
||||||
|
|
@ -177,8 +173,6 @@
|
||||||
;; (class e) on a throwable tagged-table (a library's ex-info envelope carrying a
|
;; (class e) on a throwable tagged-table (a library's ex-info envelope carrying a
|
||||||
;; JVM :class, e.g. jolt-lang/http-client's UnknownHostException) reads that
|
;; JVM :class, e.g. jolt-lang/http-client's UnknownHostException) reads that
|
||||||
;; class name, so clojure.test's (thrown? Class …) / (= Class (class e)) match.
|
;; class name, so clojure.test's (thrown? Class …) / (= Class (class e)) match.
|
||||||
(define %h-class jolt-class)
|
;; an htable carrying a string "class" entry reports it (a host-object class mirror).
|
||||||
(set! jolt-class (lambda (x)
|
(register-class-arm! (lambda (x) (and (htable? x) (string? (hashtable-ref (htable-h x) "class" #f))))
|
||||||
(let ((c (and (htable? x) (hashtable-ref (htable-h x) "class" #f))))
|
(lambda (x) (hashtable-ref (htable-h x) "class" #f)))
|
||||||
(if (and c (string? c)) c (%h-class x)))))
|
|
||||||
(def-var! "clojure.core" "class" jolt-class)
|
|
||||||
|
|
|
||||||
|
|
@ -232,29 +232,19 @@
|
||||||
(define kw-ms (keyword #f "ms"))
|
(define kw-ms (keyword #f "ms"))
|
||||||
(define inst-type-kw (keyword "jolt" "inst"))
|
(define inst-type-kw (keyword "jolt" "inst"))
|
||||||
|
|
||||||
(define %it-get jolt-get)
|
(register-get-arm! jinst?
|
||||||
(set! jolt-get (case-lambda
|
(lambda (coll k d)
|
||||||
((coll k) (jolt-get coll k jolt-nil))
|
(cond ((jolt=2 k kw-jolt-type) inst-type-kw)
|
||||||
((coll k d) (if (jinst? coll)
|
((jolt=2 k kw-ms) (jinst-ms coll))
|
||||||
(cond ((jolt=2 k kw-jolt-type) inst-type-kw)
|
(else d))))
|
||||||
((jolt=2 k kw-ms) (jinst-ms coll))
|
|
||||||
(else d))
|
|
||||||
(%it-get coll k d)))))
|
|
||||||
|
|
||||||
(define %it-=2 jolt=2)
|
(register-eq-arm! (lambda (a b) (or (jinst? a) (jinst? b)))
|
||||||
(set! jolt=2 (lambda (a b)
|
(lambda (a b) (and (jinst? a) (jinst? b) (= (jinst-ms a) (jinst-ms b)))))
|
||||||
(cond ((jinst? a) (and (jinst? b) (= (jinst-ms a) (jinst-ms b))))
|
|
||||||
((jinst? b) #f)
|
|
||||||
(else (%it-=2 a b)))))
|
|
||||||
|
|
||||||
(define %it-hash jolt-hash)
|
(register-hash-arm! jinst? (lambda (x) (jolt-hash (jinst-ms x))))
|
||||||
(set! jolt-hash (lambda (x) (if (jinst? x) (jolt-hash (jinst-ms x)) (%it-hash x))))
|
|
||||||
|
|
||||||
(define (inst-pr i) (string-append "#inst \"" (inst-rfc3339 i) "\""))
|
(define (inst-pr i) (string-append "#inst \"" (inst-rfc3339 i) "\""))
|
||||||
(define %it-pr-str jolt-pr-str)
|
(register-pr-arm! jinst? inst-pr)
|
||||||
(set! jolt-pr-str (lambda (x) (if (jinst? x) (inst-pr x) (%it-pr-str x))))
|
|
||||||
(define %it-pr-readable jolt-pr-readable)
|
|
||||||
(set! jolt-pr-readable (lambda (x) (if (jinst? x) (inst-pr x) (%it-pr-readable x))))
|
|
||||||
(register-str-render! jinst? inst-rfc3339)
|
(register-str-render! jinst? inst-rfc3339)
|
||||||
|
|
||||||
(define %it-type jolt-type)
|
(define %it-type jolt-type)
|
||||||
|
|
|
||||||
|
|
@ -487,17 +487,9 @@
|
||||||
;; str / pr-str of a uri -> its string form.
|
;; str / pr-str of a uri -> its string form.
|
||||||
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
|
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
|
||||||
(lambda (x) (uri-field x 'string)))
|
(lambda (x) (uri-field x 'string)))
|
||||||
(define %uri-pr-readable jolt-pr-readable)
|
(register-pr-readable-arm! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
|
||||||
(set! jolt-pr-readable
|
(lambda (x) (string-append "#object[java.net.URI \"" (uri-field x 'string) "\"]")))
|
||||||
(lambda (x) (if (and (jhost? x) (string=? (jhost-tag x) "uri"))
|
|
||||||
(string-append "#object[java.net.URI \"" (uri-field x 'string) "\"]")
|
|
||||||
(%uri-pr-readable x))))
|
|
||||||
;; class of the host value types defined by now (uri/uuid/file).
|
;; class of the host value types defined by now (uri/uuid/file).
|
||||||
(define %uri-class jolt-class)
|
(register-class-arm! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri"))) (lambda (x) "java.net.URI"))
|
||||||
(set! jolt-class
|
(register-class-arm! juuid? (lambda (x) "java.util.UUID"))
|
||||||
(lambda (x)
|
(register-class-arm! jfile? (lambda (x) "java.io.File"))
|
||||||
(cond ((and (jhost? x) (string=? (jhost-tag x) "uri")) "java.net.URI")
|
|
||||||
((juuid? x) "java.util.UUID")
|
|
||||||
((jfile? x) "java.io.File")
|
|
||||||
(else (%uri-class x)))))
|
|
||||||
(def-var! "clojure.core" "class" jolt-class)
|
|
||||||
|
|
|
||||||
|
|
@ -65,10 +65,9 @@
|
||||||
(set! jolt-nth (case-lambda
|
(set! jolt-nth (case-lambda
|
||||||
((coll i) (if (jolt-lazyseq? coll) (%ls-nth (jolt-seq coll) i) (%ls-nth coll i)))
|
((coll i) (if (jolt-lazyseq? coll) (%ls-nth (jolt-seq coll) i) (%ls-nth coll i)))
|
||||||
((coll i d) (if (jolt-lazyseq? coll) (%ls-nth (jolt-seq coll) i d) (%ls-nth coll i d)))))
|
((coll i d) (if (jolt-lazyseq? coll) (%ls-nth (jolt-seq coll) i d) (%ls-nth coll i d)))))
|
||||||
(define %ls-pr-str jolt-pr-str)
|
;; a lazy seq prints as its realized seq — force, then re-dispatch through the printer.
|
||||||
(set! jolt-pr-str (lambda (x) (if (jolt-lazyseq? x) (%ls-pr-str (jolt-seq x)) (%ls-pr-str x))))
|
(register-pr-str-arm! jolt-lazyseq? (lambda (x) (jolt-pr-str (jolt-seq x))))
|
||||||
(define %ls-pr-readable jolt-pr-readable)
|
(register-pr-readable-arm! jolt-lazyseq? (lambda (x) (jolt-pr-readable (jolt-seq x))))
|
||||||
(set! jolt-pr-readable (lambda (x) (if (jolt-lazyseq? x) (%ls-pr-readable (jolt-seq x)) (%ls-pr-readable x))))
|
|
||||||
(register-str-render! jolt-lazyseq? (lambda (x) (jolt-str-render-one (jolt-seq x))))
|
(register-str-render! jolt-lazyseq? (lambda (x) (jolt-str-render-one (jolt-seq x))))
|
||||||
|
|
||||||
;; seq? — a lazy seq IS a seq (predicates.ss's jolt-seq? predates the lazyseq
|
;; seq? — a lazy seq IS a seq (predicates.ss's jolt-seq? predates the lazyseq
|
||||||
|
|
|
||||||
62
host/chez/natives-format.ss
Normal file
62
host/chez/natives-format.ss
Normal file
|
|
@ -0,0 +1,62 @@
|
||||||
|
;; natives-format.ss — a small %-format engine for clojure.core `format` over the
|
||||||
|
;; all-flonum number model: %d (integer), %s (str), %f / %.Nf (fixed-point), %x/%X
|
||||||
|
;; (hex int), %o (octal), %c (char int), %b (boolean), %% (literal). Enough for the
|
||||||
|
;; corpus, not the full Java Formatter spec. Loaded after natives-misc.ss (uses
|
||||||
|
;; jolt-str-render-one via converters + jolt-truthy?).
|
||||||
|
|
||||||
|
(define (->long x) (exact (truncate x)))
|
||||||
|
(define (pad-left s n c) (if (fx>=? (string-length s) n) s (string-append (make-string (fx- n (string-length s)) c) s)))
|
||||||
|
(define (fmt-float x prec)
|
||||||
|
(let* ((neg (< x 0)) (ax (abs x))
|
||||||
|
(scale (expt 10 prec))
|
||||||
|
(scaled (round (* (inexact ax) scale)))
|
||||||
|
(i (exact (truncate (/ scaled scale))))
|
||||||
|
(frac (exact (truncate (- scaled (* i scale))))))
|
||||||
|
(string-append (if neg "-" "")
|
||||||
|
(number->string i)
|
||||||
|
(if (fx>? prec 0) (string-append "." (pad-left (number->string frac) prec #\0)) ""))))
|
||||||
|
(define (jolt-format fmt . args)
|
||||||
|
(let ((out (open-output-string)))
|
||||||
|
(let loop ((i 0) (as args))
|
||||||
|
(if (fx>=? i (string-length fmt))
|
||||||
|
(get-output-string out)
|
||||||
|
(let ((c (string-ref fmt i)))
|
||||||
|
(if (char=? c #\%)
|
||||||
|
;; parse a directive: %[-][0][width][.prec]conv
|
||||||
|
(let scan ((j (fx+ i 1)) (left #f) (zero #f) (width #f) (prec #f) (seen-dot #f))
|
||||||
|
(let ((d (string-ref fmt j)))
|
||||||
|
(cond
|
||||||
|
((char=? d #\%) (write-char #\% out) (loop (fx+ j 1) as))
|
||||||
|
((and (not seen-dot) (not width) (char=? d #\-))
|
||||||
|
(scan (fx+ j 1) #t zero width prec seen-dot))
|
||||||
|
((and (not seen-dot) (not width) (char=? d #\0))
|
||||||
|
(scan (fx+ j 1) left #t width prec seen-dot))
|
||||||
|
((char=? d #\.) (scan (fx+ j 1) left zero width 0 #t))
|
||||||
|
((and (char>=? d #\0) (char<=? d #\9))
|
||||||
|
(if seen-dot
|
||||||
|
(scan (fx+ j 1) left zero width (fx+ (fx* (or prec 0) 10) (fx- (char->integer d) 48)) seen-dot)
|
||||||
|
(scan (fx+ j 1) left zero (fx+ (fx* (or width 0) 10) (fx- (char->integer d) 48)) prec seen-dot)))
|
||||||
|
(else
|
||||||
|
(let* ((a (if (null? as) jolt-nil (car as)))
|
||||||
|
(rest (if (null? as) '() (cdr as)))
|
||||||
|
(s (case d
|
||||||
|
((#\d) (number->string (->long a)))
|
||||||
|
((#\s) (jolt-str-render-one a))
|
||||||
|
((#\f) (fmt-float a (or prec 6)))
|
||||||
|
((#\x) (number->string (->long a) 16))
|
||||||
|
((#\X) (string-upcase (number->string (->long a) 16)))
|
||||||
|
((#\o) (number->string (->long a) 8))
|
||||||
|
((#\b) (if (jolt-truthy? a) "true" "false"))
|
||||||
|
((#\c) (string (integer->char (->long a))))
|
||||||
|
(else (string #\% d))))
|
||||||
|
;; pad to width: left-justify with spaces, else right-justify
|
||||||
|
;; (zero-pad only a right-justified number).
|
||||||
|
(s (if (and width (fx<? (string-length s) width))
|
||||||
|
(let ((p (fx- width (string-length s))))
|
||||||
|
(if left (string-append s (make-string p #\space))
|
||||||
|
(string-append (make-string p (if (and zero (memv d '(#\d #\f #\x #\X #\o))) #\0 #\space)) s)))
|
||||||
|
s)))
|
||||||
|
(display s out)
|
||||||
|
(loop (fx+ j 1) rest))))))
|
||||||
|
(begin (write-char c out) (loop (fx+ i 1) as))))))))
|
||||||
|
(def-var! "clojure.core" "format" jolt-format)
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
;; misc scalar natives — UUID, format/printf, tagged-literal, bigint.
|
;; misc scalar natives — UUID, tagged-literal, bigint, and the hash API. (format /
|
||||||
|
;; printf moved to natives-format.ss.)
|
||||||
;;
|
;;
|
||||||
;; Loaded after the printers (pr-str of a uuid is #uuid "…") and converters
|
;; Loaded after the printers (pr-str of a uuid is #uuid "…") and converters
|
||||||
;; (jolt-str-render-one for %s / str of a uuid).
|
;; (jolt-str-render-one for %s / str of a uuid).
|
||||||
|
|
@ -53,16 +54,10 @@
|
||||||
;; str of a uuid -> the bare 36-char string; pr-str -> #uuid "…".
|
;; str of a uuid -> the bare 36-char string; pr-str -> #uuid "…".
|
||||||
(register-str-render! juuid? juuid-s)
|
(register-str-render! juuid? juuid-s)
|
||||||
(define (juuid-pr u) (string-append "#uuid \"" (juuid-s u) "\""))
|
(define (juuid-pr u) (string-append "#uuid \"" (juuid-s u) "\""))
|
||||||
(define %m-pr-str jolt-pr-str)
|
(register-pr-arm! juuid? juuid-pr)
|
||||||
(set! jolt-pr-str (lambda (x) (if (juuid? x) (juuid-pr x) (%m-pr-str x))))
|
|
||||||
(define %m-pr-readable jolt-pr-readable)
|
|
||||||
(set! jolt-pr-readable (lambda (x) (if (juuid? x) (juuid-pr x) (%m-pr-readable x))))
|
|
||||||
;; two uuids are = iff same string.
|
;; two uuids are = iff same string.
|
||||||
(define %m-=2 jolt=2)
|
(register-eq-arm! (lambda (a b) (or (juuid? a) (juuid? b)))
|
||||||
(set! jolt=2 (lambda (a b)
|
(lambda (a b) (and (juuid? a) (juuid? b) (string=? (juuid-s a) (juuid-s b)))))
|
||||||
(cond ((juuid? a) (and (juuid? b) (string=? (juuid-s a) (juuid-s b))))
|
|
||||||
((juuid? b) #f)
|
|
||||||
(else (%m-=2 a b)))))
|
|
||||||
|
|
||||||
;; --- bigint / biginteger -----------------------------------------------------
|
;; --- bigint / biginteger -----------------------------------------------------
|
||||||
;; jolt models every number as a double; an integer-valued double prints without
|
;; jolt models every number as a double; an integer-valued double prints without
|
||||||
|
|
@ -80,79 +75,30 @@
|
||||||
(define (jolt-tagged-literal-pred? x) (jtagged? x))
|
(define (jolt-tagged-literal-pred? x) (jtagged? x))
|
||||||
(define kw-tl-tag (keyword #f "tag"))
|
(define kw-tl-tag (keyword #f "tag"))
|
||||||
(define kw-tl-form (keyword #f "form"))
|
(define kw-tl-form (keyword #f "form"))
|
||||||
(define %m-get jolt-get)
|
(register-get-arm! jtagged?
|
||||||
(set! jolt-get (case-lambda
|
(lambda (coll k d)
|
||||||
((coll k) (if (jtagged? coll) (jolt-get coll k jolt-nil) (%m-get coll k)))
|
(cond ((jolt=2 k kw-tl-tag) (jtagged-tag coll))
|
||||||
((coll k d) (if (jtagged? coll)
|
((jolt=2 k kw-tl-form) (jtagged-form coll))
|
||||||
(cond ((jolt=2 k kw-tl-tag) (jtagged-tag coll))
|
(else d))))
|
||||||
((jolt=2 k kw-tl-form) (jtagged-form coll))
|
|
||||||
(else d))
|
|
||||||
(%m-get coll k d)))))
|
|
||||||
(define (jtagged-pr t) (string-append "#" (jolt-pr-str (jtagged-tag t)) " " (jolt-pr-readable (jtagged-form t))))
|
(define (jtagged-pr t) (string-append "#" (jolt-pr-str (jtagged-tag t)) " " (jolt-pr-readable (jtagged-form t))))
|
||||||
(define %m2-pr-str jolt-pr-str)
|
(register-pr-arm! jtagged? jtagged-pr)
|
||||||
(set! jolt-pr-str (lambda (x) (if (jtagged? x) (jtagged-pr x) (%m2-pr-str x))))
|
|
||||||
(define %m2-pr-readable jolt-pr-readable)
|
|
||||||
(set! jolt-pr-readable (lambda (x) (if (jtagged? x) (jtagged-pr x) (%m2-pr-readable x))))
|
|
||||||
(def-var! "clojure.core" "tagged-literal" jolt-tagged-literal)
|
(def-var! "clojure.core" "tagged-literal" jolt-tagged-literal)
|
||||||
;; tagged-literal? is OVERLAY (reads :jolt/type) — asserted in post-prelude.ss.
|
;; tagged-literal? is OVERLAY (reads :jolt/type) — asserted in post-prelude.ss.
|
||||||
|
|
||||||
;; --- format / printf ---------------------------------------------------------
|
;; --- hash family (24-bit masked so int? holds) -------------------------------
|
||||||
;; A small %-format engine over the all-flonum number model: %d (integer), %s
|
;; The public hash API over jolt-hash (values.ss). hash-ordered/-unordered-coll
|
||||||
;; (str), %f / %.Nf (fixed-point), %x/%X (hex int), %o (octal), %c (char int),
|
;; fold the element hashes the way Clojure's IHash mixers do.
|
||||||
;; %b (boolean), %% (literal). Enough for the corpus; not the full Java spec.
|
(define (nm-h24 x) (bitwise-and (jolt-hash x) #xffffff))
|
||||||
(define (->long x) (exact (truncate x)))
|
(define (nm-hash x) (nm-h24 x))
|
||||||
(define (pad-left s n c) (if (fx>=? (string-length s) n) s (string-append (make-string (fx- n (string-length s)) c) s)))
|
(define (nm-hash-combine a b)
|
||||||
(define (fmt-float x prec)
|
(bitwise-and (bitwise-xor (nm-h24 a) (+ (nm-h24 b) #x9e3779)) #xffffff))
|
||||||
(let* ((neg (< x 0)) (ax (abs x))
|
(define (nm-hash-ordered-coll coll)
|
||||||
(scale (expt 10 prec))
|
(let loop ((xs (seq->list (jolt-seq coll))) (h 1))
|
||||||
(scaled (round (* (inexact ax) scale)))
|
(if (null? xs) h (loop (cdr xs) (bitwise-and (+ (* 31 h) (nm-h24 (car xs))) #xffffff)))))
|
||||||
(i (exact (truncate (/ scaled scale))))
|
(define (nm-hash-unordered-coll coll)
|
||||||
(frac (exact (truncate (- scaled (* i scale))))))
|
(let loop ((xs (seq->list (jolt-seq coll))) (h 0))
|
||||||
(string-append (if neg "-" "")
|
(if (null? xs) h (loop (cdr xs) (bitwise-and (+ h (nm-h24 (car xs))) #xffffff)))))
|
||||||
(number->string i)
|
(def-var! "clojure.core" "hash" nm-hash)
|
||||||
(if (fx>? prec 0) (string-append "." (pad-left (number->string frac) prec #\0)) ""))))
|
(def-var! "clojure.core" "hash-combine" nm-hash-combine)
|
||||||
(define (jolt-format fmt . args)
|
(def-var! "clojure.core" "hash-ordered-coll" nm-hash-ordered-coll)
|
||||||
(let ((out (open-output-string)))
|
(def-var! "clojure.core" "hash-unordered-coll" nm-hash-unordered-coll)
|
||||||
(let loop ((i 0) (as args))
|
|
||||||
(if (fx>=? i (string-length fmt))
|
|
||||||
(get-output-string out)
|
|
||||||
(let ((c (string-ref fmt i)))
|
|
||||||
(if (char=? c #\%)
|
|
||||||
;; parse a directive: %[-][0][width][.prec]conv
|
|
||||||
(let scan ((j (fx+ i 1)) (left #f) (zero #f) (width #f) (prec #f) (seen-dot #f))
|
|
||||||
(let ((d (string-ref fmt j)))
|
|
||||||
(cond
|
|
||||||
((char=? d #\%) (write-char #\% out) (loop (fx+ j 1) as))
|
|
||||||
((and (not seen-dot) (not width) (char=? d #\-))
|
|
||||||
(scan (fx+ j 1) #t zero width prec seen-dot))
|
|
||||||
((and (not seen-dot) (not width) (char=? d #\0))
|
|
||||||
(scan (fx+ j 1) left #t width prec seen-dot))
|
|
||||||
((char=? d #\.) (scan (fx+ j 1) left zero width 0 #t))
|
|
||||||
((and (char>=? d #\0) (char<=? d #\9))
|
|
||||||
(if seen-dot
|
|
||||||
(scan (fx+ j 1) left zero width (fx+ (fx* (or prec 0) 10) (fx- (char->integer d) 48)) seen-dot)
|
|
||||||
(scan (fx+ j 1) left zero (fx+ (fx* (or width 0) 10) (fx- (char->integer d) 48)) prec seen-dot)))
|
|
||||||
(else
|
|
||||||
(let* ((a (if (null? as) jolt-nil (car as)))
|
|
||||||
(rest (if (null? as) '() (cdr as)))
|
|
||||||
(s (case d
|
|
||||||
((#\d) (number->string (->long a)))
|
|
||||||
((#\s) (jolt-str-render-one a))
|
|
||||||
((#\f) (fmt-float a (or prec 6)))
|
|
||||||
((#\x) (number->string (->long a) 16))
|
|
||||||
((#\X) (string-upcase (number->string (->long a) 16)))
|
|
||||||
((#\o) (number->string (->long a) 8))
|
|
||||||
((#\b) (if (jolt-truthy? a) "true" "false"))
|
|
||||||
((#\c) (string (integer->char (->long a))))
|
|
||||||
(else (string #\% d))))
|
|
||||||
;; pad to width: left-justify with spaces, else right-justify
|
|
||||||
;; (zero-pad only a right-justified number).
|
|
||||||
(s (if (and width (fx<? (string-length s) width))
|
|
||||||
(let ((p (fx- width (string-length s))))
|
|
||||||
(if left (string-append s (make-string p #\space))
|
|
||||||
(string-append (make-string p (if (and zero (memv d '(#\d #\f #\x #\X #\o))) #\0 #\space)) s)))
|
|
||||||
s)))
|
|
||||||
(display s out)
|
|
||||||
(loop (fx+ j 1) rest))))))
|
|
||||||
(begin (write-char c out) (loop (fx+ i 1) as))))))))
|
|
||||||
(def-var! "clojure.core" "format" jolt-format)
|
|
||||||
|
|
|
||||||
|
|
@ -1,91 +0,0 @@
|
||||||
;; natives-parity.ss — native Chez shims for clojure.core fns. Pure-Chez,
|
|
||||||
;; JVM-matching.
|
|
||||||
;;
|
|
||||||
;; Loaded after host-table.ss (htable-sorted?), transients.ss (jolt-transient?),
|
|
||||||
;; values.ss (jolt-hash), seq.ss (jolt-seq/seq->list/list->cseq/jolt-invoke).
|
|
||||||
|
|
||||||
;; --- hash family (24-bit masked so int? holds) ------
|
|
||||||
(define (np-h24 x) (bitwise-and (jolt-hash x) #xffffff))
|
|
||||||
(define (np-hash x) (np-h24 x))
|
|
||||||
(define (np-hash-combine a b)
|
|
||||||
(bitwise-and (bitwise-xor (np-h24 a) (+ (np-h24 b) #x9e3779)) #xffffff))
|
|
||||||
(define (np-hash-ordered-coll coll)
|
|
||||||
(let loop ((xs (seq->list (jolt-seq coll))) (h 1))
|
|
||||||
(if (null? xs) h (loop (cdr xs) (bitwise-and (+ (* 31 h) (np-h24 (car xs))) #xffffff)))))
|
|
||||||
(define (np-hash-unordered-coll coll)
|
|
||||||
(let loop ((xs (seq->list (jolt-seq coll))) (h 0))
|
|
||||||
(if (null? xs) h (loop (cdr xs) (bitwise-and (+ h (np-h24 (car xs))) #xffffff)))))
|
|
||||||
|
|
||||||
;; --- transient? ---------------------------------------------------------------
|
|
||||||
(define (np-transient? x) (jolt-transient? x))
|
|
||||||
|
|
||||||
;; --- rseq: vectors + sorted colls only (Clojure), reverse of the ascending seq.
|
|
||||||
(define (np-rseq coll)
|
|
||||||
(if (or (pvec? coll) (htable-sorted? coll))
|
|
||||||
(list->cseq (reverse (seq->list (jolt-seq coll))))
|
|
||||||
(jolt-throw (jolt-ex-info "rseq requires a vector or sorted collection" (jolt-hash-map)))))
|
|
||||||
|
|
||||||
;; --- cat transducer: each item of the input
|
|
||||||
;; is itself a collection, concatenated into the downstream reducing fn.
|
|
||||||
(define (np-cat rf)
|
|
||||||
(lambda a
|
|
||||||
(cond
|
|
||||||
((null? a) (jolt-invoke rf))
|
|
||||||
((null? (cdr a)) (jolt-invoke rf (car a)))
|
|
||||||
(else
|
|
||||||
(let loop ((xs (seq->list (jolt-seq (cadr a)))) (acc (car a)))
|
|
||||||
(if (null? xs) acc (loop (cdr xs) (jolt-invoke rf acc (car xs)))))))))
|
|
||||||
|
|
||||||
;; --- reader feature set (for #?() conditionals) — mutable list of name strings,
|
|
||||||
;; default jolt + default. __reader-features returns the strings; -set! replaces.
|
|
||||||
(define np-reader-features (list "jolt" "default"))
|
|
||||||
(define (np-reader-features-get) (list->cseq np-reader-features))
|
|
||||||
(define (np-reader-features-set! names)
|
|
||||||
(set! np-reader-features
|
|
||||||
(map (lambda (n) (cond ((keyword-t? n) (keyword-t-name n)) ((string? n) n) (else (jolt-pr-str n))))
|
|
||||||
(seq->list (jolt-seq names))))
|
|
||||||
jolt-nil)
|
|
||||||
|
|
||||||
;; --- reader-conditional / re-matcher: tagged maps (reader-conditional? + the
|
|
||||||
;; matcher consumers are overlay tagged-value predicates that read :jolt/type).
|
|
||||||
(define np-kw-type (keyword "jolt" "type"))
|
|
||||||
(define np-kw-rc (keyword "jolt" "reader-conditional"))
|
|
||||||
(define np-kw-form (keyword #f "form"))
|
|
||||||
(define np-kw-spl (keyword #f "splicing?"))
|
|
||||||
(define np-kw-mat (keyword "jolt" "matcher"))
|
|
||||||
(define np-kw-re (keyword #f "re"))
|
|
||||||
(define np-kw-s (keyword #f "s"))
|
|
||||||
(define np-kw-pos (keyword #f "pos"))
|
|
||||||
(define (np-reader-conditional form splicing?)
|
|
||||||
(jolt-hash-map np-kw-type np-kw-rc np-kw-form form np-kw-spl splicing?))
|
|
||||||
(define (np-re-matcher re s)
|
|
||||||
(jolt-hash-map np-kw-type np-kw-mat np-kw-re re np-kw-s s np-kw-pos 0.0))
|
|
||||||
|
|
||||||
;; (delay? / make-delay / force live in concurrency.ss with the real delay type.)
|
|
||||||
|
|
||||||
;; --- macroexpand-1 / macroexpand: expand a (quoted) call form via the runtime
|
|
||||||
;; macro table (host-contract hc-macro?/hc-expand-1; forward-referenced, resolved
|
|
||||||
;; at call time after the spine loads). macroexpand loops until the head is no
|
|
||||||
;; longer a macro (subforms are not expanded, matching Clojure).
|
|
||||||
(define (np-macroexpand-1 form)
|
|
||||||
(if (and (cseq? form) (cseq-list? form) (symbol-t? (seq-first form)))
|
|
||||||
(let ((ctx (make-analyze-ctx (chez-current-ns))))
|
|
||||||
(if (hc-macro? ctx (seq-first form)) (hc-expand-1 ctx form) form))
|
|
||||||
form))
|
|
||||||
(define (np-macroexpand form)
|
|
||||||
(let loop ((cur form))
|
|
||||||
(let ((nxt (np-macroexpand-1 cur))) (if (eq? cur nxt) cur (loop nxt)))))
|
|
||||||
|
|
||||||
(def-var! "clojure.core" "hash" np-hash)
|
|
||||||
(def-var! "clojure.core" "hash-combine" np-hash-combine)
|
|
||||||
(def-var! "clojure.core" "hash-ordered-coll" np-hash-ordered-coll)
|
|
||||||
(def-var! "clojure.core" "hash-unordered-coll" np-hash-unordered-coll)
|
|
||||||
(def-var! "clojure.core" "transient?" np-transient?)
|
|
||||||
(def-var! "clojure.core" "rseq" np-rseq)
|
|
||||||
(def-var! "clojure.core" "cat" np-cat)
|
|
||||||
(def-var! "clojure.core" "__reader-features" np-reader-features-get)
|
|
||||||
(def-var! "clojure.core" "__reader-features-set!" np-reader-features-set!)
|
|
||||||
(def-var! "clojure.core" "reader-conditional" np-reader-conditional)
|
|
||||||
(def-var! "clojure.core" "re-matcher" np-re-matcher)
|
|
||||||
(def-var! "clojure.core" "macroexpand-1" np-macroexpand-1)
|
|
||||||
(def-var! "clojure.core" "macroexpand" np-macroexpand)
|
|
||||||
|
|
@ -44,14 +44,11 @@
|
||||||
|
|
||||||
;; printing: render the elements as a parenthesized list (delegate to the seq path).
|
;; printing: render the elements as a parenthesized list (delegate to the seq path).
|
||||||
(define (jolt-seq-or-empty x) (let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-empty-list s)))
|
(define (jolt-seq-or-empty x) (let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-empty-list s)))
|
||||||
(define %q-pr-readable jolt-pr-readable)
|
(register-pr-readable-arm! jolt-queue? (lambda (x) (jolt-pr-readable (jolt-seq-or-empty x))))
|
||||||
(set! jolt-pr-readable (lambda (x) (if (jolt-queue? x) (%q-pr-readable (jolt-seq-or-empty x)) (%q-pr-readable x))))
|
|
||||||
(register-str-render! jolt-queue? (lambda (x) (jolt-str-render-one (jolt-seq-or-empty x))))
|
(register-str-render! jolt-queue? (lambda (x) (jolt-str-render-one (jolt-seq-or-empty x))))
|
||||||
|
|
||||||
;; class / type / instance? recognize a queue.
|
;; class / type / instance? recognize a queue.
|
||||||
(define %q-class jolt-class)
|
(register-class-arm! jolt-queue? (lambda (x) "clojure.lang.PersistentQueue"))
|
||||||
(set! jolt-class (lambda (x) (if (jolt-queue? x) "clojure.lang.PersistentQueue" (%q-class x))))
|
|
||||||
(def-var! "clojure.core" "class" jolt-class)
|
|
||||||
(register-instance-check-arm!
|
(register-instance-check-arm!
|
||||||
(lambda (type-sym val)
|
(lambda (type-sym val)
|
||||||
(if (jolt-queue? val)
|
(if (jolt-queue? val)
|
||||||
|
|
|
||||||
52
host/chez/natives-reader.ss
Normal file
52
host/chez/natives-reader.ss
Normal file
|
|
@ -0,0 +1,52 @@
|
||||||
|
;; natives-reader.ss — reader/macro runtime-support natives: the #?() reader feature
|
||||||
|
;; set, the reader-conditional + re-matcher tagged-map constructors, and macroexpand.
|
||||||
|
;;
|
||||||
|
;; Loaded late (after ns.ss): macroexpand forward-refs the runtime macro table
|
||||||
|
;; (host-contract hc-macro?/hc-expand-1) + the analyzer ctx, resolved at call time
|
||||||
|
;; after the spine loads. The hash / transient? / rseq / cat natives that used to
|
||||||
|
;; live here moved to natives-misc, transients, natives-seq, and natives-transduce.
|
||||||
|
|
||||||
|
;; --- reader feature set (for #?() conditionals) — mutable list of name strings,
|
||||||
|
;; default jolt + default. __reader-features returns the strings; -set! replaces.
|
||||||
|
(define nr-reader-features (list "jolt" "default"))
|
||||||
|
(define (nr-reader-features-get) (list->cseq nr-reader-features))
|
||||||
|
(define (nr-reader-features-set! names)
|
||||||
|
(set! nr-reader-features
|
||||||
|
(map (lambda (n) (cond ((keyword-t? n) (keyword-t-name n)) ((string? n) n) (else (jolt-pr-str n))))
|
||||||
|
(seq->list (jolt-seq names))))
|
||||||
|
jolt-nil)
|
||||||
|
|
||||||
|
;; --- reader-conditional / re-matcher: tagged maps (reader-conditional? + the
|
||||||
|
;; matcher consumers are overlay tagged-value predicates that read :jolt/type).
|
||||||
|
(define nr-kw-type (keyword "jolt" "type"))
|
||||||
|
(define nr-kw-rc (keyword "jolt" "reader-conditional"))
|
||||||
|
(define nr-kw-form (keyword #f "form"))
|
||||||
|
(define nr-kw-spl (keyword #f "splicing?"))
|
||||||
|
(define nr-kw-mat (keyword "jolt" "matcher"))
|
||||||
|
(define nr-kw-re (keyword #f "re"))
|
||||||
|
(define nr-kw-s (keyword #f "s"))
|
||||||
|
(define nr-kw-pos (keyword #f "pos"))
|
||||||
|
(define (nr-reader-conditional form splicing?)
|
||||||
|
(jolt-hash-map nr-kw-type nr-kw-rc nr-kw-form form nr-kw-spl splicing?))
|
||||||
|
(define (nr-re-matcher re s)
|
||||||
|
(jolt-hash-map nr-kw-type nr-kw-mat nr-kw-re re nr-kw-s s nr-kw-pos 0.0))
|
||||||
|
|
||||||
|
;; --- macroexpand-1 / macroexpand: expand a (quoted) call form via the runtime
|
||||||
|
;; macro table (host-contract hc-macro?/hc-expand-1; forward-referenced, resolved
|
||||||
|
;; at call time after the spine loads). macroexpand loops until the head is no
|
||||||
|
;; longer a macro (subforms are not expanded, matching Clojure).
|
||||||
|
(define (nr-macroexpand-1 form)
|
||||||
|
(if (and (cseq? form) (cseq-list? form) (symbol-t? (seq-first form)))
|
||||||
|
(let ((ctx (make-analyze-ctx (chez-current-ns))))
|
||||||
|
(if (hc-macro? ctx (seq-first form)) (hc-expand-1 ctx form) form))
|
||||||
|
form))
|
||||||
|
(define (nr-macroexpand form)
|
||||||
|
(let loop ((cur form))
|
||||||
|
(let ((nxt (nr-macroexpand-1 cur))) (if (eq? cur nxt) cur (loop nxt)))))
|
||||||
|
|
||||||
|
(def-var! "clojure.core" "__reader-features" nr-reader-features-get)
|
||||||
|
(def-var! "clojure.core" "__reader-features-set!" nr-reader-features-set!)
|
||||||
|
(def-var! "clojure.core" "reader-conditional" nr-reader-conditional)
|
||||||
|
(def-var! "clojure.core" "re-matcher" nr-re-matcher)
|
||||||
|
(def-var! "clojure.core" "macroexpand-1" nr-macroexpand-1)
|
||||||
|
(def-var! "clojure.core" "macroexpand" nr-macroexpand)
|
||||||
|
|
@ -213,3 +213,10 @@
|
||||||
(def-var! "clojure.core" "partition" jolt-partition)
|
(def-var! "clojure.core" "partition" jolt-partition)
|
||||||
(def-var! "clojure.core" "sort" jolt-sort)
|
(def-var! "clojure.core" "sort" jolt-sort)
|
||||||
(def-var! "clojure.core" "identical?" jolt-identical?)
|
(def-var! "clojure.core" "identical?" jolt-identical?)
|
||||||
|
|
||||||
|
;; rseq: vectors + sorted colls only (Clojure), the reverse of the ascending seq.
|
||||||
|
(define (jolt-rseq coll)
|
||||||
|
(if (or (pvec? coll) (htable-sorted? coll))
|
||||||
|
(list->cseq (reverse (seq->list (jolt-seq coll))))
|
||||||
|
(jolt-throw (jolt-ex-info "rseq requires a vector or sorted collection" (jolt-hash-map)))))
|
||||||
|
(def-var! "clojure.core" "rseq" jolt-rseq)
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
;; volatiles + sequence / transduce — the transducer application surface.
|
;; natives-transduce.ss — the transducer surface: volatiles, the `cat` transducer,
|
||||||
|
;; and sequence / transduce application.
|
||||||
;;
|
;;
|
||||||
;; `sequence` and `transduce` are seed natives. The stateful transducer arities
|
;; `sequence` and `transduce` are seed natives. The stateful transducer arities
|
||||||
;; (take-nth/map-indexed/partition-by/dedupe/distinct, all overlay) use
|
;; (take-nth/map-indexed/partition-by/dedupe/distinct, all overlay) use
|
||||||
|
|
@ -47,3 +48,16 @@
|
||||||
|
|
||||||
(def-var! "clojure.core" "transduce" jolt-transduce)
|
(def-var! "clojure.core" "transduce" jolt-transduce)
|
||||||
(def-var! "clojure.core" "sequence" jolt-sequence)
|
(def-var! "clojure.core" "sequence" jolt-sequence)
|
||||||
|
|
||||||
|
;; --- cat ---------------------------------------------------------------------
|
||||||
|
;; cat transducer: each input item is itself a collection, concatenated into the
|
||||||
|
;; downstream reducing fn.
|
||||||
|
(define (jolt-cat rf)
|
||||||
|
(lambda a
|
||||||
|
(cond
|
||||||
|
((null? a) (jolt-invoke rf))
|
||||||
|
((null? (cdr a)) (jolt-invoke rf (car a)))
|
||||||
|
(else
|
||||||
|
(let loop ((xs (seq->list (jolt-seq (cadr a)))) (acc (car a)))
|
||||||
|
(if (null? xs) acc (loop (cdr xs) (jolt-invoke rf acc (car xs)))))))))
|
||||||
|
(def-var! "clojure.core" "cat" jolt-cat)
|
||||||
|
|
@ -344,8 +344,5 @@
|
||||||
(def-var! "clojure.core" "*ns*" (intern-ns! "user"))
|
(def-var! "clojure.core" "*ns*" (intern-ns! "user"))
|
||||||
|
|
||||||
;; --- printer patches: a namespace renders as its name (str / pr-str / -e) ----
|
;; --- printer patches: a namespace renders as its name (str / pr-str / -e) ----
|
||||||
(define %ns-pr-str jolt-pr-str)
|
(register-pr-arm! jns? jns-name)
|
||||||
(set! jolt-pr-str (lambda (x) (if (jns? x) (jns-name x) (%ns-pr-str x))))
|
|
||||||
(define %ns-pr-readable jolt-pr-readable)
|
|
||||||
(set! jolt-pr-readable (lambda (x) (if (jns? x) (jns-name x) (%ns-pr-readable x))))
|
|
||||||
(register-str-render! jns? jns-name)
|
(register-str-render! jns? jns-name)
|
||||||
|
|
|
||||||
|
|
@ -18,7 +18,7 @@
|
||||||
(def-var! "clojure.core" "get-validator" jolt-get-validator)
|
(def-var! "clojure.core" "get-validator" jolt-get-validator)
|
||||||
;; volatiles: a Chez volatile is a jvol record, but the overlay vreset!/vswap!/
|
;; volatiles: a Chez volatile is a jvol record, but the overlay vreset!/vswap!/
|
||||||
;; volatile? drive it via jolt.host/ref-put!+get / :jolt/type (tagged-table only).
|
;; volatile? drive it via jolt.host/ref-put!+get / :jolt/type (tagged-table only).
|
||||||
;; Override with the native versions (defined in natives-xform.ss).
|
;; Override with the native versions (defined in natives-transduce.ss).
|
||||||
(def-var! "clojure.core" "vreset!" jolt-vreset!)
|
(def-var! "clojure.core" "vreset!" jolt-vreset!)
|
||||||
(def-var! "clojure.core" "vswap!" jolt-vswap!)
|
(def-var! "clojure.core" "vswap!" jolt-vswap!)
|
||||||
(def-var! "clojure.core" "volatile?" jolt-volatile-pred?)
|
(def-var! "clojure.core" "volatile?" jolt-volatile-pred?)
|
||||||
|
|
|
||||||
|
|
@ -24,7 +24,16 @@
|
||||||
((#\return) (cons #\r (cons #\\ acc)))
|
((#\return) (cons #\r (cons #\\ acc)))
|
||||||
(else (cons c acc))))))))
|
(else (cons c acc))))))))
|
||||||
|
|
||||||
(define (jolt-pr-readable x)
|
;; A host shim registers a type's readable rendering via register-pr-readable-arm!,
|
||||||
|
;; or register-pr-arm! for types whose str and readable forms match (most host types:
|
||||||
|
;; inst, uuid, record, var, …). Disjoint types, checked before the base cases.
|
||||||
|
(define jolt-pr-readable-arms '())
|
||||||
|
(define (register-pr-readable-arm! pred render)
|
||||||
|
(set! jolt-pr-readable-arms (cons (cons pred render) jolt-pr-readable-arms)))
|
||||||
|
(define (register-pr-arm! pred render)
|
||||||
|
(register-pr-str-arm! pred render)
|
||||||
|
(register-pr-readable-arm! pred render))
|
||||||
|
(define (jolt-pr-readable-base x)
|
||||||
(cond
|
(cond
|
||||||
((string? x) (string-append "\"" (jolt-str-escape x) "\""))
|
((string? x) (string-append "\"" (jolt-str-escape x) "\""))
|
||||||
;; pr renders the infinities / NaN in READABLE form (##Inf reads back), unlike
|
;; pr renders the infinities / NaN in READABLE form (##Inf reads back), unlike
|
||||||
|
|
@ -58,6 +67,11 @@
|
||||||
(if (jolt-nil? s) (reverse acc)
|
(if (jolt-nil? s) (reverse acc)
|
||||||
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-readable (seq-first s)) acc))))) ")"))
|
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-readable (seq-first s)) acc))))) ")"))
|
||||||
(else (jolt-pr-str x))))
|
(else (jolt-pr-str x))))
|
||||||
|
(define (jolt-pr-readable x)
|
||||||
|
(let loop ((as jolt-pr-readable-arms))
|
||||||
|
(cond ((null? as) (jolt-pr-readable-base x))
|
||||||
|
(((caar as) x) ((cdar as) x))
|
||||||
|
(else (loop (cdr as))))))
|
||||||
|
|
||||||
;; __pr-str1: render ONE value readably (the overlay's pr-str joins these).
|
;; __pr-str1: render ONE value readably (the overlay's pr-str joins these).
|
||||||
(define (jolt-pr-str1 x) (jolt-pr-readable x))
|
(define (jolt-pr-str1 x) (jolt-pr-readable x))
|
||||||
|
|
@ -71,10 +85,18 @@
|
||||||
(define (jolt-with-out-str thunk)
|
(define (jolt-with-out-str thunk)
|
||||||
(with-output-to-string (lambda () (jolt-invoke thunk))))
|
(with-output-to-string (lambda () (jolt-invoke thunk))))
|
||||||
|
|
||||||
;; __eprint / __eprintf: stderr seams.
|
;; __eprint / __eprintf: stderr seams. Flush each write — like the JVM's
|
||||||
(define (jolt-eprint s) (display s (current-error-port)) jolt-nil)
|
;; auto-flushing System.err — so a long-running process (a server that never
|
||||||
|
;; returns from -main) shows its log lines instead of leaving them in a buffer
|
||||||
|
;; that only drains at exit.
|
||||||
|
(define (jolt-eprint s)
|
||||||
|
(display s (current-error-port))
|
||||||
|
(flush-output-port (current-error-port))
|
||||||
|
jolt-nil)
|
||||||
(define (jolt-eprintf fmt . args)
|
(define (jolt-eprintf fmt . args)
|
||||||
(apply fprintf (current-error-port) fmt args) jolt-nil)
|
(apply fprintf (current-error-port) fmt args)
|
||||||
|
(flush-output-port (current-error-port))
|
||||||
|
jolt-nil)
|
||||||
|
|
||||||
(def-var! "clojure.core" "__pr-str1" jolt-pr-str1)
|
(def-var! "clojure.core" "__pr-str1" jolt-pr-str1)
|
||||||
(def-var! "clojure.core" "__write" jolt-write)
|
(def-var! "clojure.core" "__write" jolt-write)
|
||||||
|
|
|
||||||
|
|
@ -50,7 +50,7 @@
|
||||||
(else (let ((p (assoc c exception-parent))) (loop (and p (cdr p))))))))
|
(else (let ((p (assoc c exception-parent))) (loop (and p (cdr p))))))))
|
||||||
|
|
||||||
;; instance-check: (type-sym val) — type/protocol membership. Host shims loaded
|
;; instance-check: (type-sym val) — type/protocol membership. Host shims loaded
|
||||||
;; later (io, inst-time, natives-array, natives-queue, host-static-objects)
|
;; later (io, inst-time, natives-array, natives-queue, host-static-classes)
|
||||||
;; register an arm with register-instance-check-arm! instead of set!-wrapping
|
;; register an arm with register-instance-check-arm! instead of set!-wrapping
|
||||||
;; instance-check; an arm returns #t/#f to decide or 'pass to defer to the next.
|
;; instance-check; an arm returns #t/#f to decide or 'pass to defer to the next.
|
||||||
;; Newest arm is checked first (matches the old outermost-wins set! order).
|
;; Newest arm is checked first (matches the old outermost-wins set! order).
|
||||||
|
|
|
||||||
|
|
@ -62,17 +62,10 @@
|
||||||
"}"))
|
"}"))
|
||||||
|
|
||||||
;; ---- extend the collection dispatchers with a jrec arm ----------------------
|
;; ---- extend the collection dispatchers with a jrec arm ----------------------
|
||||||
(define %r-jolt=2 jolt=2)
|
(register-eq-arm! (lambda (a b) (or (jrec? a) (jrec? b)))
|
||||||
(set! jolt=2 (lambda (a b)
|
(lambda (a b) (and (jrec? a) (jrec? b) (jrec=? a b))))
|
||||||
(cond ((jrec? a) (and (jrec? b) (jrec=? a b)))
|
(register-hash-arm! jrec? jrec-hash)
|
||||||
((jrec? b) #f)
|
(register-get-arm! jrec? (lambda (coll k d) (jrec-lookup coll k d)))
|
||||||
(else (%r-jolt=2 a b)))))
|
|
||||||
(define %r-jolt-hash jolt-hash)
|
|
||||||
(set! jolt-hash (lambda (x) (if (jrec? x) (jrec-hash x) (%r-jolt-hash x))))
|
|
||||||
(define %r-jolt-get jolt-get)
|
|
||||||
(set! jolt-get (case-lambda
|
|
||||||
((coll k) (if (jrec? coll) (jrec-lookup coll k jolt-nil) (%r-jolt-get coll k)))
|
|
||||||
((coll k d) (if (jrec? coll) (jrec-lookup coll k d) (%r-jolt-get coll k d)))))
|
|
||||||
(define %r-jolt-count jolt-count)
|
(define %r-jolt-count jolt-count)
|
||||||
(set! jolt-count (lambda (coll) (if (jrec? coll) (length (jrec-pairs coll)) (%r-jolt-count coll))))
|
(set! jolt-count (lambda (coll) (if (jrec? coll) (length (jrec-pairs coll)) (%r-jolt-count coll))))
|
||||||
(define %r-jolt-contains? jolt-contains?)
|
(define %r-jolt-contains? jolt-contains?)
|
||||||
|
|
@ -90,10 +83,7 @@
|
||||||
(define %r-jolt-conj1 jolt-conj1)
|
(define %r-jolt-conj1 jolt-conj1)
|
||||||
(set! jolt-conj1 (lambda (coll x)
|
(set! jolt-conj1 (lambda (coll x)
|
||||||
(if (jrec? coll) (jolt-assoc1 coll (jolt-nth x 0) (jolt-nth x 1)) (%r-jolt-conj1 coll x))))
|
(if (jrec? coll) (jolt-assoc1 coll (jolt-nth x 0) (jolt-nth x 1)) (%r-jolt-conj1 coll x))))
|
||||||
(define %r-jolt-pr-str jolt-pr-str)
|
(register-pr-arm! jrec? jrec-pr)
|
||||||
(set! jolt-pr-str (lambda (x) (if (jrec? x) (jrec-pr x) (%r-jolt-pr-str x))))
|
|
||||||
(define %r-jolt-pr-readable jolt-pr-readable)
|
|
||||||
(set! jolt-pr-readable (lambda (x) (if (jrec? x) (jrec-pr x) (%r-jolt-pr-readable x))))
|
|
||||||
|
|
||||||
;; records are map? and coll? (Clojure: a record IS an associative map). The
|
;; records are map? and coll? (Clojure: a record IS an associative map). The
|
||||||
;; predicates.ss vars hold a snapshot, so re-def-var! after extending. record? is
|
;; predicates.ss vars hold a snapshot, so re-def-var! after extending. record? is
|
||||||
|
|
|
||||||
|
|
@ -179,7 +179,13 @@
|
||||||
;; bare nil renders as the empty string (a nil ELEMENT inside a collection still
|
;; bare nil renders as the empty string (a nil ELEMENT inside a collection still
|
||||||
;; prints "nil", which jolt-pr-str handles).
|
;; prints "nil", which jolt-pr-str handles).
|
||||||
(define (jolt-final-str x) (if (jolt-nil? x) "" (jolt-pr-str x)))
|
(define (jolt-final-str x) (if (jolt-nil? x) "" (jolt-pr-str x)))
|
||||||
(define (jolt-pr-str x)
|
;; A host shim registers a type's str-style rendering via register-pr-str-arm! (or
|
||||||
|
;; register-pr-arm! in printing.ss for both printers at once) instead of
|
||||||
|
;; set!-wrapping jolt-pr-str. Disjoint types, checked before the base cases.
|
||||||
|
(define jolt-pr-str-arms '())
|
||||||
|
(define (register-pr-str-arm! pred render)
|
||||||
|
(set! jolt-pr-str-arms (cons (cons pred render) jolt-pr-str-arms)))
|
||||||
|
(define (jolt-pr-str-base x)
|
||||||
(cond
|
(cond
|
||||||
((jolt-nil? x) "nil")
|
((jolt-nil? x) "nil")
|
||||||
((eq? x #t) "true")
|
((eq? x #t) "true")
|
||||||
|
|
@ -206,6 +212,11 @@
|
||||||
(if (jolt-nil? s) (reverse acc)
|
(if (jolt-nil? s) (reverse acc)
|
||||||
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-str (seq-first s)) acc))))) ")"))
|
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-str (seq-first s)) acc))))) ")"))
|
||||||
(else (format "~a" x))))
|
(else (format "~a" x))))
|
||||||
|
(define (jolt-pr-str x)
|
||||||
|
(let loop ((as jolt-pr-str-arms))
|
||||||
|
(cond ((null? as) (jolt-pr-str-base x))
|
||||||
|
(((caar as) x) ((cdar as) x))
|
||||||
|
(else (loop (cdr as))))))
|
||||||
|
|
||||||
;; converters + string ops: str/subs/vec/keyword/symbol/compare/int/
|
;; converters + string ops: str/subs/vec/keyword/symbol/compare/int/
|
||||||
;; double/gensym — host-coupled seed natives def-var!'d into clojure.core. Loaded
|
;; double/gensym — host-coupled seed natives def-var!'d into clojure.core. Loaded
|
||||||
|
|
@ -261,7 +272,7 @@
|
||||||
|
|
||||||
;; dynamic vars: *clojure-version* / *unchecked-math* constants the host
|
;; dynamic vars: *clojure-version* / *unchecked-math* constants the host
|
||||||
;; binds natively. After collections.ss (jolt-hash-map) + def-var!.
|
;; binds natively. After collections.ss (jolt-hash-map) + def-var!.
|
||||||
(load "host/chez/dynamic-vars.ss")
|
(load "host/chez/dynamic-var-defaults.ss")
|
||||||
|
|
||||||
;; host tables + sorted collections: jolt.host/tagged-table/
|
;; host tables + sorted collections: jolt.host/tagged-table/
|
||||||
;; ref-put!/ref-get + the 25-sorted tier's runtime (sorted-map/sorted-set routed
|
;; ref-put!/ref-get + the 25-sorted tier's runtime (sorted-map/sorted-set routed
|
||||||
|
|
@ -275,13 +286,13 @@
|
||||||
;; Loaded LAST so %ls-seq captures the fully-extended (sorted-aware) jolt-seq.
|
;; Loaded LAST so %ls-seq captures the fully-extended (sorted-aware) jolt-seq.
|
||||||
(load "host/chez/lazy-bridge.ss")
|
(load "host/chez/lazy-bridge.ss")
|
||||||
|
|
||||||
;; volatiles + sequence / transduce: native volatile boxes +
|
;; transducer surface: native volatile boxes, cat, +
|
||||||
;; the transduce/sequence entry points over into-xform/reduce-seq. After
|
;; the transduce/sequence entry points over into-xform/reduce-seq. After
|
||||||
;; natives-seq.ss (into-xform), seq.ss (reduce-seq) + atoms.ss (deref).
|
;; natives-seq.ss (into-xform), seq.ss (reduce-seq) + atoms.ss (deref).
|
||||||
(load "host/chez/natives-xform.ss")
|
(load "host/chez/natives-transduce.ss")
|
||||||
|
|
||||||
;; vars as first-class objects: var?/var-get/deref/invoke/=/
|
;; vars as first-class objects: var?/var-get/deref/invoke/=/
|
||||||
;; pr-str over the rt.ss var-cell. After natives-xform.ss (chains deref) + the
|
;; pr-str over the rt.ss var-cell. After natives-transduce.ss (chains deref) + the
|
||||||
;; printers. emit lowers :the-var to (jolt-var ns name).
|
;; printers. emit lowers :the-var to (jolt-var ns name).
|
||||||
(load "host/chez/vars.ss")
|
(load "host/chez/vars.ss")
|
||||||
|
|
||||||
|
|
@ -291,6 +302,10 @@
|
||||||
;; in post-prelude.ss.
|
;; in post-prelude.ss.
|
||||||
(load "host/chez/natives-misc.ss")
|
(load "host/chez/natives-misc.ss")
|
||||||
|
|
||||||
|
;; format / printf: the %-directive engine. After natives-misc.ss + converters.ss
|
||||||
|
;; (jolt-str-render-one).
|
||||||
|
(load "host/chez/natives-format.ss")
|
||||||
|
|
||||||
;; namespaces: the namespace value model — find-ns/ns-name/
|
;; namespaces: the namespace value model — find-ns/ns-name/
|
||||||
;; all-ns/the-ns/create-ns/in-ns/ns-publics/ns-map/ns-interns/ns-aliases/resolve/
|
;; all-ns/the-ns/create-ns/in-ns/ns-publics/ns-map/ns-interns/ns-aliases/resolve/
|
||||||
;; find-var/ns-unmap/*ns*, over the var-table + chez-current-ns. Loaded LAST: needs
|
;; find-var/ns-unmap/*ns*, over the var-table + chez-current-ns. Loaded LAST: needs
|
||||||
|
|
@ -316,8 +331,8 @@
|
||||||
;; record-method-dispatch (records.ss) and reuses natives-str helpers (str-trim,
|
;; record-method-dispatch (records.ss) and reuses natives-str helpers (str-trim,
|
||||||
;; ascii-string-down, re-split, str-split-drop-trailing) + the regex-t accessors.
|
;; ascii-string-down, re-split, str-split-drop-trailing) + the regex-t accessors.
|
||||||
(load "host/chez/host-static.ss") ; registries + jhost + coercion helpers
|
(load "host/chez/host-static.ss") ; registries + jhost + coercion helpers
|
||||||
(load "host/chez/host-static-statics.ss") ; java.lang/util static methods
|
(load "host/chez/host-static-methods.ss") ; Class/member static methods + fields
|
||||||
(load "host/chez/host-static-objects.ss") ; host object classes + instance? hook
|
(load "host/chez/host-static-classes.ss") ; instantiable host object classes
|
||||||
|
|
||||||
;; generic dot-form dispatch: field access + map/vector member access
|
;; generic dot-form dispatch: field access + map/vector member access
|
||||||
;; for the `.` / `.-field` desugar. Loads after host-static.ss so it wraps every
|
;; for the `.` / `.-field` desugar. Loads after host-static.ss so it wraps every
|
||||||
|
|
@ -345,10 +360,10 @@
|
||||||
;; clojure.math ns. Self-contained (only def-var! + Chez math), order-independent.
|
;; clojure.math ns. Self-contained (only def-var! + Chez math), order-independent.
|
||||||
(load "host/chez/math.ss")
|
(load "host/chez/math.ss")
|
||||||
|
|
||||||
;; parity shims: native clojure.core fns not covered by the overlay
|
;; reader/macro runtime support: #?() feature set, reader-conditional + re-matcher
|
||||||
;; (hash family / rseq / cat / transient?). After host-table.ss (sorted),
|
;; tagged-map ctors, macroexpand. After ns.ss; macroexpand call-time-refs the macro
|
||||||
;; transients.ss, values.ss (jolt-hash), seq.ss.
|
;; table (host-contract) + analyzer ctx.
|
||||||
(load "host/chez/natives-parity.ss")
|
(load "host/chez/natives-reader.ss")
|
||||||
|
|
||||||
;; Java-style arrays: object/typed array constructors + a jolt-array
|
;; Java-style arrays: object/typed array constructors + a jolt-array
|
||||||
;; backing; extends count/nth/seq/get/ref-put! so the overlay aget/aset/alength see
|
;; backing; extends count/nth/seq/get/ref-put! so the overlay aget/aset/alength see
|
||||||
|
|
|
||||||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
|
|
@ -169,11 +169,7 @@
|
||||||
|
|
||||||
;; Redefine the native get/count/contains?/nth (captured first) so the existing
|
;; Redefine the native get/count/contains?/nth (captured first) so the existing
|
||||||
;; emit lowerings unwrap a transient; non-transients are untouched.
|
;; emit lowerings unwrap a transient; non-transients are untouched.
|
||||||
(define %prev-jolt-get jolt-get)
|
(register-get-arm! jolt-transient? (lambda (coll k d) (t-get coll k d)))
|
||||||
(set! jolt-get
|
|
||||||
(case-lambda
|
|
||||||
((coll k) (if (jolt-transient? coll) (t-get coll k jolt-nil) (%prev-jolt-get coll k)))
|
|
||||||
((coll k d) (if (jolt-transient? coll) (t-get coll k d) (%prev-jolt-get coll k d)))))
|
|
||||||
(define %prev-jolt-count jolt-count)
|
(define %prev-jolt-count jolt-count)
|
||||||
(set! jolt-count (lambda (coll) (if (jolt-transient? coll) (t-count coll) (%prev-jolt-count coll))))
|
(set! jolt-count (lambda (coll) (if (jolt-transient? coll) (t-count coll) (%prev-jolt-count coll))))
|
||||||
(define %prev-jolt-contains? jolt-contains?)
|
(define %prev-jolt-contains? jolt-contains?)
|
||||||
|
|
@ -196,6 +192,7 @@
|
||||||
(%prev-jolt-nth coll i d)))))
|
(%prev-jolt-nth coll i d)))))
|
||||||
|
|
||||||
(def-var! "clojure.core" "transient" jolt-transient-new)
|
(def-var! "clojure.core" "transient" jolt-transient-new)
|
||||||
|
(def-var! "clojure.core" "transient?" jolt-transient?)
|
||||||
(def-var! "clojure.core" "persistent!" jolt-persistent!)
|
(def-var! "clojure.core" "persistent!" jolt-persistent!)
|
||||||
(def-var! "clojure.core" "conj!" jolt-conj!)
|
(def-var! "clojure.core" "conj!" jolt-conj!)
|
||||||
(def-var! "clojure.core" "assoc!" jolt-assoc!)
|
(def-var! "clojure.core" "assoc!" jolt-assoc!)
|
||||||
|
|
|
||||||
|
|
@ -43,7 +43,15 @@
|
||||||
;; chars/strings: Chez natives (strings treated immutable).
|
;; chars/strings: Chez natives (strings treated immutable).
|
||||||
|
|
||||||
;; --- jolt equality (Clojure =) — scalars + collections ----------------------
|
;; --- jolt equality (Clojure =) — scalars + collections ----------------------
|
||||||
(define (jolt=2 a b)
|
;; A host shim registers a type's equality via register-eq-arm! instead of
|
||||||
|
;; set!-wrapping jolt=2 (cf. register-hash-arm!). An arm is (pred . handler), both
|
||||||
|
;; (a b): the arm applies when pred holds (typically either arg is the type), and
|
||||||
|
;; handler returns the #t/#f result. Arms are checked before the base scalar/coll
|
||||||
|
;; cases; the entry is stable.
|
||||||
|
(define jolt-eq-arms '())
|
||||||
|
(define (register-eq-arm! pred handler)
|
||||||
|
(set! jolt-eq-arms (cons (cons pred handler) jolt-eq-arms)))
|
||||||
|
(define (jolt=2-base a b)
|
||||||
(cond
|
(cond
|
||||||
((and (jolt-nil? a) (jolt-nil? b)) #t)
|
((and (jolt-nil? a) (jolt-nil? b)) #t)
|
||||||
((or (jolt-nil? a) (jolt-nil? b)) #f)
|
((or (jolt-nil? a) (jolt-nil? b)) #f)
|
||||||
|
|
@ -63,6 +71,11 @@
|
||||||
;; other collections (map/set): forward to collections.ss.
|
;; other collections (map/set): forward to collections.ss.
|
||||||
((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b))
|
((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b))
|
||||||
(else (eq? a b))))
|
(else (eq? a b))))
|
||||||
|
(define (jolt=2 a b)
|
||||||
|
(let loop ((as jolt-eq-arms))
|
||||||
|
(cond ((null? as) (jolt=2-base a b))
|
||||||
|
(((caar as) a b) ((cdar as) a b))
|
||||||
|
(else (loop (cdr as))))))
|
||||||
(define (jolt= a . rest)
|
(define (jolt= a . rest)
|
||||||
(let loop ((a a) (rest rest))
|
(let loop ((a a) (rest rest))
|
||||||
(cond ((null? rest) #t)
|
(cond ((null? rest) #t)
|
||||||
|
|
@ -70,7 +83,14 @@
|
||||||
(else #f))))
|
(else #f))))
|
||||||
|
|
||||||
;; --- jolt hash — consistent with jolt= (for the HAMT) -----------------------
|
;; --- jolt hash — consistent with jolt= (for the HAMT) -----------------------
|
||||||
(define (jolt-hash x)
|
;; A host shim (records, host-table, inst-time, …) registers its type's hash via
|
||||||
|
;; register-hash-arm! instead of set!-wrapping jolt-hash — the arms are disjoint
|
||||||
|
;; types, checked before the base cases, so the full behavior is gathered here plus
|
||||||
|
;; the registry rather than scattered across a set! chain (cf. register-str-render!).
|
||||||
|
(define jolt-hash-arms '())
|
||||||
|
(define (register-hash-arm! pred handler)
|
||||||
|
(set! jolt-hash-arms (cons (cons pred handler) jolt-hash-arms)))
|
||||||
|
(define (jolt-hash-base x)
|
||||||
(cond
|
(cond
|
||||||
((jolt-nil? x) 0)
|
((jolt-nil? x) 0)
|
||||||
((keyword-t? x) (keyword-t-khash x))
|
((keyword-t? x) (keyword-t-khash x))
|
||||||
|
|
@ -87,3 +107,8 @@
|
||||||
((jolt-sequential? x) (seq-hash x)) ; vector/list/seq hash alike (forward to seq.ss)
|
((jolt-sequential? x) (seq-hash x)) ; vector/list/seq hash alike (forward to seq.ss)
|
||||||
((jolt-coll? x) (jolt-coll-hash x)) ; map/set; forward to collections.ss
|
((jolt-coll? x) (jolt-coll-hash x)) ; map/set; forward to collections.ss
|
||||||
(else (equal-hash x))))
|
(else (equal-hash x))))
|
||||||
|
(define (jolt-hash x)
|
||||||
|
(let loop ((as jolt-hash-arms))
|
||||||
|
(cond ((null? as) (jolt-hash-base x))
|
||||||
|
(((caar as) x) ((cdar as) x))
|
||||||
|
(else (loop (cdr as))))))
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,7 @@
|
||||||
;; with-redefs) lives in dyn-binding.ss, which chains the var-read paths set up
|
;; with-redefs) lives in dyn-binding.ss, which chains the var-read paths set up
|
||||||
;; here.
|
;; here.
|
||||||
;;
|
;;
|
||||||
;; Loaded LAST (after natives-xform.ss): chains jolt-deref (atom/volatile arms)
|
;; Loaded LAST (after natives-transduce.ss): chains jolt-deref (atom/volatile arms)
|
||||||
;; and the printers.
|
;; and the printers.
|
||||||
|
|
||||||
(define (jolt-var-pred? x) (var-cell? x))
|
(define (jolt-var-pred? x) (var-cell? x))
|
||||||
|
|
@ -31,20 +31,14 @@
|
||||||
(if (var-cell? f) (apply jolt-invoke (var-cell-root f) args) (apply %v-invoke f args))))
|
(if (var-cell? f) (apply jolt-invoke (var-cell-root f) args) (apply %v-invoke f args))))
|
||||||
|
|
||||||
;; two var cells are = iff same ns/name (Clojure var identity).
|
;; two var cells are = iff same ns/name (Clojure var identity).
|
||||||
(define %v-=2 jolt=2)
|
(register-eq-arm! (lambda (a b) (or (var-cell? a) (var-cell? b)))
|
||||||
(set! jolt=2 (lambda (a b)
|
(lambda (a b) (and (var-cell? a) (var-cell? b)
|
||||||
(cond ((var-cell? a) (and (var-cell? b)
|
(string=? (var-cell-ns a) (var-cell-ns b))
|
||||||
(string=? (var-cell-ns a) (var-cell-ns b))
|
(string=? (var-cell-name a) (var-cell-name b)))))
|
||||||
(string=? (var-cell-name a) (var-cell-name b))))
|
|
||||||
((var-cell? b) #f)
|
|
||||||
(else (%v-=2 a b)))))
|
|
||||||
|
|
||||||
;; pr-str / str of a var -> #'ns/name.
|
;; pr-str / str of a var -> #'ns/name.
|
||||||
(define (var->str v) (string-append "#'" (var-cell-ns v) "/" (var-cell-name v)))
|
(define (var->str v) (string-append "#'" (var-cell-ns v) "/" (var-cell-name v)))
|
||||||
(define %v-pr-str jolt-pr-str)
|
(register-pr-arm! var-cell? var->str)
|
||||||
(set! jolt-pr-str (lambda (x) (if (var-cell? x) (var->str x) (%v-pr-str x))))
|
|
||||||
(define %v-pr-readable jolt-pr-readable)
|
|
||||||
(set! jolt-pr-readable (lambda (x) (if (var-cell? x) (var->str x) (%v-pr-readable x))))
|
|
||||||
(register-str-render! var-cell? var->str)
|
(register-str-render! var-cell? var->str)
|
||||||
|
|
||||||
;; bound? — native (the overlay's (get v :root) is nil on a var-cell record).
|
;; bound? — native (the overlay's (get v :root) is nil on a var-cell record).
|
||||||
|
|
|
||||||
|
|
@ -18,7 +18,7 @@
|
||||||
def-node let-node fn-node vector-node map-node set-node
|
def-node let-node fn-node vector-node map-node set-node
|
||||||
quote-node throw-node host-static host-new]]
|
quote-node throw-node host-static host-new]]
|
||||||
[jolt.host :refer [form-sym? form-sym-name form-sym-ns form-list?
|
[jolt.host :refer [form-sym? form-sym-name form-sym-ns form-list?
|
||||||
form-vec? form-map? form-set? form-char?
|
form-vec? form-map? form-set?
|
||||||
form-literal? form-keyword? form-elements form-vec-items
|
form-literal? form-keyword? form-elements form-vec-items
|
||||||
form-map-pairs form-set-items form-special? compile-ns
|
form-map-pairs form-set-items form-special? compile-ns
|
||||||
form-regex? form-regex-source
|
form-regex? form-regex-source
|
||||||
|
|
|
||||||
|
|
@ -80,6 +80,10 @@
|
||||||
;; :num-kind :double|:long when every operand is that kind; these are the Chez
|
;; :num-kind :double|:long when every operand is that kind; these are the Chez
|
||||||
;; flonum/fixnum ops it lowers to — no generic dispatch, fixnums unboxed. fl?/fx?
|
;; flonum/fixnum ops it lowers to — no generic dispatch, fixnums unboxed. fl?/fx?
|
||||||
;; comparisons carry the question mark; fl+/fx+ don't.
|
;; comparisons carry the question mark; fl+/fx+ don't.
|
||||||
|
;;
|
||||||
|
;; CONTRACT: every op name jolt.passes.numeric/dbl-spec (resp. lng-spec) tags must
|
||||||
|
;; have an entry here, or emit-numeric splices a nil op string into the output. Keep
|
||||||
|
;; these tables and those specializers in sync.
|
||||||
(def ^:private dbl-ops
|
(def ^:private dbl-ops
|
||||||
{"+" "fl+" "-" "fl-" "*" "fl*" "/" "fl/" "min" "flmin" "max" "flmax"
|
{"+" "fl+" "-" "fl-" "*" "fl*" "/" "fl/" "min" "flmin" "max" "flmax"
|
||||||
"<" "fl<?" ">" "fl>?" "<=" "fl<=?" ">=" "fl>=?" "=" "fl=?" "==" "fl=?"})
|
"<" "fl<?" ">" "fl>?" "<=" "fl<=?" ">=" "fl>=?" "=" "fl=?" "==" "fl=?"})
|
||||||
|
|
@ -109,7 +113,12 @@
|
||||||
;; set — one defined earlier in emission order (or itself), so the Scheme binding
|
;; set — one defined earlier in emission order (or itself), so the Scheme binding
|
||||||
;; exists by the time the reference runs. Reset per build.
|
;; exists by the time the reference runs. Reset per build.
|
||||||
(def direct-link-defined (atom #{}))
|
(def direct-link-defined (atom #{}))
|
||||||
(defn direct-link-reset! [] (reset! direct-link-defined #{}))
|
;; Of those, the ones whose init is a fn literal — safe to call as a raw Scheme
|
||||||
|
;; application. A def of a non-fn value (a map, set, keyword, …) is invokable in
|
||||||
|
;; Clojure but is not a Scheme procedure, so its calls must still route through
|
||||||
|
;; jolt-invoke even with a direct binding.
|
||||||
|
(def direct-link-fns (atom #{}))
|
||||||
|
(defn direct-link-reset! [] (reset! direct-link-defined #{}) (reset! direct-link-fns #{}))
|
||||||
|
|
||||||
;; A direct-link Scheme binding name for a var. The fqn maps to a unique identifier
|
;; A direct-link Scheme binding name for a var. The fqn maps to a unique identifier
|
||||||
;; jv$<ns>$<name>; chars that break a Scheme identifier or the `$` separator are
|
;; jv$<ns>$<name>; chars that break a Scheme identifier or the `$` separator are
|
||||||
|
|
@ -120,6 +129,10 @@
|
||||||
(defn- dl-fqn [ns nm] (str ns "/" nm))
|
(defn- dl-fqn [ns nm] (str ns "/" nm))
|
||||||
(defn- direct-linkable? [ns nm]
|
(defn- direct-linkable? [ns nm]
|
||||||
(and @direct-link? (contains? @direct-link-defined (dl-fqn ns nm))))
|
(and @direct-link? (contains? @direct-link-defined (dl-fqn ns nm))))
|
||||||
|
;; A direct-linked var whose value is a fn literal — its binding is a Scheme
|
||||||
|
;; procedure, so a call site can apply it directly.
|
||||||
|
(defn- direct-link-fn? [ns nm]
|
||||||
|
(contains? @direct-link-fns (dl-fqn ns nm)))
|
||||||
|
|
||||||
;; recur-target and the set of munged local names known to hold a procedure (a
|
;; recur-target and the set of munged local names known to hold a procedure (a
|
||||||
;; named fn's self-recursion name) are lexically scoped — dynamic vars so the
|
;; named fn's self-recursion name) are lexically scoped — dynamic vars so the
|
||||||
|
|
@ -486,9 +499,13 @@
|
||||||
;; a :local callee that isn't a known procedure -> dynamic IFn dispatch.
|
;; a :local callee that isn't a known procedure -> dynamic IFn dispatch.
|
||||||
(and (= :local (:op fnode)) (not (*known-procs* (munge-name (:name fnode)))))
|
(and (= :local (:op fnode)) (not (*known-procs* (munge-name (:name fnode)))))
|
||||||
(invoke)
|
(invoke)
|
||||||
;; closed-world direct call: the callee var is an app def already emitted with
|
;; closed-world direct call: the callee var is an app fn def already emitted
|
||||||
;; a Scheme binding — call it directly, no var lookup, no jolt-invoke.
|
;; with a Scheme binding — apply it directly, no var lookup, no jolt-invoke.
|
||||||
(and (= :var (:op fnode)) (direct-linkable? (:ns fnode) (:name fnode)))
|
;; Only fn-valued defs qualify; a non-fn invokable value (a map/set/keyword
|
||||||
|
;; held in a var) isn't a Scheme procedure, so it falls through to jolt-invoke
|
||||||
|
;; below (which still uses the direct binding as the invoke target).
|
||||||
|
(and (= :var (:op fnode)) (direct-linkable? (:ns fnode) (:name fnode))
|
||||||
|
(direct-link-fn? (:ns fnode) (:name fnode)))
|
||||||
(order-args (fn [as] (str "(" (dl-name (:ns fnode) (:name fnode))
|
(order-args (fn [as] (str "(" (dl-name (:ns fnode) (:name fnode))
|
||||||
(if (seq as) (str " " (str/join " " as)) "") ")")))
|
(if (seq as) (str " " (str/join " " as)) "") ")")))
|
||||||
;; a late-bound :var call head can hold a procedure OR a non-applicable
|
;; a late-bound :var call head can hold a procedure OR a non-applicable
|
||||||
|
|
@ -636,6 +653,7 @@
|
||||||
(let [ns (:ns node) nm (:name node) b (dl-name ns nm)]
|
(let [ns (:ns node) nm (:name node) b (dl-name ns nm)]
|
||||||
;; register before emitting the init so a self-referential body direct-links.
|
;; register before emitting the init so a self-referential body direct-links.
|
||||||
(swap! direct-link-defined conj (dl-fqn ns nm))
|
(swap! direct-link-defined conj (dl-fqn ns nm))
|
||||||
|
(when (= :fn (:op (:init node))) (swap! direct-link-fns conj (dl-fqn ns nm)))
|
||||||
(let [init (emit (:init node))]
|
(let [init (emit (:init node))]
|
||||||
(if (jmeta-nonempty? (:meta node))
|
(if (jmeta-nonempty? (:meta node))
|
||||||
(str "(begin (define " b " " init ") (def-var-with-meta! "
|
(str "(begin (define " b " " init ") (def-var-with-meta! "
|
||||||
|
|
|
||||||
|
|
@ -73,3 +73,19 @@
|
||||||
(defn scalar-const? [n]
|
(defn scalar-const? [n]
|
||||||
(and (= :const (get n :op))
|
(and (= :const (get n :op))
|
||||||
(let [v (get n :val)] (or (keyword? v) (string? v) (number? v) (boolean? v)))))
|
(let [v (get n :val)] (or (keyword? v) (string? v) (number? v) (boolean? v)))))
|
||||||
|
|
||||||
|
;; The two callee shapes a constant-keyword map lookup takes: a keyword in fn
|
||||||
|
;; position — (:k m) — or clojure.core/get with a const key — (get m :k). The
|
||||||
|
;; inliner (scalar replacement) and the type inferencer both recognize these;
|
||||||
|
;; sharing the head predicates keeps the two from drifting. Each caller still
|
||||||
|
;; imposes its own arity, subject, and key-type constraints.
|
||||||
|
(defn kw-callee?
|
||||||
|
"True if fnode is a constant keyword used as a function head — the (:k m) form."
|
||||||
|
[fnode]
|
||||||
|
(and (= :const (get fnode :op)) (keyword? (get fnode :val))))
|
||||||
|
|
||||||
|
(defn get-callee?
|
||||||
|
"True if fnode is the clojure.core/get (or host get) callee — the (get m k) form."
|
||||||
|
[fnode]
|
||||||
|
(or (and (= :var (get fnode :op)) (= "clojure.core" (get fnode :ns)) (= "get" (get fnode :name)))
|
||||||
|
(and (= :host (get fnode :op)) (= "get" (get fnode :name)))))
|
||||||
|
|
|
||||||
|
|
@ -5,7 +5,7 @@
|
||||||
and the `dirty` fixpoint flag. Portable Clojure (compiler-tier)."
|
and the `dirty` fixpoint flag. Portable Clojure (compiler-tier)."
|
||||||
(:require [jolt.host :refer [inline-ir]]
|
(:require [jolt.host :refer [inline-ir]]
|
||||||
[jolt.ir :refer [map-ir-children reduce-ir-children coerce-node]]
|
[jolt.ir :refer [map-ir-children reduce-ir-children coerce-node]]
|
||||||
[jolt.passes.fold :refer [scalar-const?]]))
|
[jolt.passes.fold :refer [scalar-const? kw-callee? get-callee?]]))
|
||||||
|
|
||||||
;; ---------------------------------------------------------------------------
|
;; ---------------------------------------------------------------------------
|
||||||
;; Shared state: a dirty flag the fixpoint loop reads, and a fresh-name counter
|
;; Shared state: a dirty flag the fixpoint loop reads, and a fresh-name counter
|
||||||
|
|
@ -229,7 +229,7 @@
|
||||||
(defn- pure-fn? [f]
|
(defn- pure-fn? [f]
|
||||||
(let [op (get f :op)]
|
(let [op (get f :op)]
|
||||||
(cond
|
(cond
|
||||||
(and (= op :const) (keyword? (get f :val))) true
|
(kw-callee? f) true
|
||||||
(= op :var) (and (= "clojure.core" (get f :ns)) (contains? pure-fns (get f :name)))
|
(= op :var) (and (= "clojure.core" (get f :ns)) (contains? pure-fns (get f :name)))
|
||||||
(= op :host) (contains? pure-fns (get f :name))
|
(= op :host) (contains? pure-fns (get f :name))
|
||||||
:else false)))
|
:else false)))
|
||||||
|
|
@ -282,13 +282,12 @@
|
||||||
(if (= :invoke (get node :op))
|
(if (= :invoke (get node :op))
|
||||||
(let [f (get node :fn) args (get node :args)]
|
(let [f (get node :fn) args (get node :args)]
|
||||||
(cond
|
(cond
|
||||||
(and (= :const (get f :op)) (keyword? (get f :val))
|
(and (kw-callee? f)
|
||||||
(= 1 (count args))
|
(= 1 (count args))
|
||||||
(= :local (get (nth args 0) :op)) (= nm (get (nth args 0) :name)))
|
(= :local (get (nth args 0) :op)) (= nm (get (nth args 0) :name)))
|
||||||
(get f :val)
|
(get f :val)
|
||||||
|
|
||||||
(and (or (and (= :var (get f :op)) (= "clojure.core" (get f :ns)) (= "get" (get f :name)))
|
(and (get-callee? f)
|
||||||
(and (= :host (get f :op)) (= "get" (get f :name))))
|
|
||||||
(= 2 (count args))
|
(= 2 (count args))
|
||||||
(= :local (get (nth args 0) :op)) (= nm (get (nth args 0) :name))
|
(= :local (get (nth args 0) :op)) (= nm (get (nth args 0) :name))
|
||||||
(scalar-const? (nth args 1)))
|
(scalar-const? (nth args 1)))
|
||||||
|
|
@ -500,7 +499,7 @@
|
||||||
lookup folds only for a declared field."
|
lookup folds only for a declared field."
|
||||||
[node]
|
[node]
|
||||||
(let [f (get node :fn) args (get node :args)]
|
(let [f (get node :fn) args (get node :args)]
|
||||||
(if (and (= :const (get f :op)) (keyword? (get f :val)) (= 1 (count args)))
|
(if (and (kw-callee? f) (= 1 (count args)))
|
||||||
(let [m (nth args 0) k (get f :val)]
|
(let [m (nth args 0) k (get f :val)]
|
||||||
(if (and (= :map (get m :op)) (const-key-map? m) (all-vals-pure? m))
|
(if (and (= :map (get m :op)) (const-key-map? m) (all-vals-pure? m))
|
||||||
(do (mark!) (map-val m k))
|
(do (mark!) (map-val m k))
|
||||||
|
|
|
||||||
|
|
@ -28,6 +28,8 @@
|
||||||
|
|
||||||
;; result kind of a double-specialized op at this name/arity, or nil if N/A.
|
;; result kind of a double-specialized op at this name/arity, or nil if N/A.
|
||||||
;; arithmetic -> :double; comparison -> :bool (operands specialized, result not numeric).
|
;; arithmetic -> :double; comparison -> :bool (operands specialized, result not numeric).
|
||||||
|
;; Every op name dbl-spec / lng-spec returns non-nil for must have a Chez op in
|
||||||
|
;; jolt.backend-scheme/dbl-ops resp. lng-ops, or emit-numeric splices a nil op.
|
||||||
(defn- dbl-spec [nm n]
|
(defn- dbl-spec [nm n]
|
||||||
(cond
|
(cond
|
||||||
(and (>= n 1) (contains? #{"+" "-" "*" "/" "min" "max"} nm)) :double
|
(and (>= n 1) (contains? #{"+" "-" "*" "/" "min" "max"} nm)) :double
|
||||||
|
|
@ -127,7 +129,13 @@
|
||||||
pe (reduce (fn [e p] (assoc e p (get nh p))) tenv (get a :params))]
|
pe (reduce (fn [e p] (assoc e p (get nh p))) tenv (get a :params))]
|
||||||
(if (get a :rest) (assoc pe (get a :rest) nil) pe)))
|
(if (get a :rest) (assoc pe (get a :rest) nil) pe)))
|
||||||
|
|
||||||
(defn- an-invoke [node tenv]
|
(defn- an-invoke
|
||||||
|
"Annotate an :invoke with its numeric kind. An arithmetic core op specializes to
|
||||||
|
the Chez fl*/fx* op only when every operand is the same kind (:double or :long),
|
||||||
|
except an integer literal is :wild — valid in either — so (+ ^double x 2) stays
|
||||||
|
double. A call to a ^double/^long-returning var yields that kind without lowering
|
||||||
|
the call (its body already coerces the return)."
|
||||||
|
[node tenv]
|
||||||
(let [fnode (get node :fn)
|
(let [fnode (get node :fn)
|
||||||
nm (when (and (= :var (get fnode :op)) (= "clojure.core" (get fnode :ns)))
|
nm (when (and (= :var (get fnode :op)) (= "clojure.core" (get fnode :ns)))
|
||||||
(get fnode :name))
|
(get fnode :name))
|
||||||
|
|
|
||||||
|
|
@ -4,8 +4,10 @@
|
||||||
top = :any) that types expressions and reuses the same walk as a loose success
|
top = :any) that types expressions and reuses the same walk as a loose success
|
||||||
checker. Also the inter-procedural driver API the back end calls to
|
checker. Also the inter-procedural driver API the back end calls to
|
||||||
propagate param types across a unit / the whole program. Weakly coupled to the
|
propagate param types across a unit / the whole program. Weakly coupled to the
|
||||||
IR-rewriting passes — shares only the const-shape predicate (jolt.passes.fold)."
|
IR-rewriting passes — shares the const-shape predicates (jolt.passes.fold)."
|
||||||
(:require [jolt.passes.fold :refer [scalar-const?]]
|
(:require [jolt.passes.fold :refer [scalar-const? kw-callee? get-callee?]]
|
||||||
|
[jolt.passes.types.check :refer
|
||||||
|
[not-callable? type-name check-invoke register-user-fn!]]
|
||||||
[jolt.passes.types.lattice :refer
|
[jolt.passes.types.lattice :refer
|
||||||
[velem selem sfields vec-type? set-type? struct-type? mk-vec mk-set
|
[velem selem sfields vec-type? set-type? struct-type? mk-vec mk-set
|
||||||
mk-struct union-cap scalar-t? union-type? umembers union-of merge-fields
|
mk-struct union-cap scalar-t? union-type? umembers union-of merge-fields
|
||||||
|
|
@ -82,8 +84,9 @@
|
||||||
;; result of (rand-nth coll-of-structs) etc. types as the element.
|
;; result of (rand-nth coll-of-structs) etc. types as the element.
|
||||||
(def ^:private elem-fns #{"rand-nth" "first" "peek" "last" "nth" "fnext" "second"})
|
(def ^:private elem-fns #{"rand-nth" "first" "peek" "last" "nth" "fnext" "second"})
|
||||||
|
|
||||||
;; the checker's emission points, defined after infer but referenced from it
|
;; defined after infer but referenced from it (the rest of the checker lives in
|
||||||
(declare check-invoke check-user-call register-user-fn! not-callable? type-name)
|
;; jolt.passes.types.check, required above)
|
||||||
|
(declare check-user-call)
|
||||||
|
|
||||||
(defn- var-key [fnode] (str (get fnode :ns) "/" (get fnode :name)))
|
(defn- var-key [fnode] (str (get fnode :ns) "/" (get fnode :name)))
|
||||||
|
|
||||||
|
|
@ -145,6 +148,12 @@
|
||||||
|
|
||||||
(declare infer)
|
(declare infer)
|
||||||
|
|
||||||
|
;; infer (and infer-fn-seeded) return a [type node'] tuple — the result type plus
|
||||||
|
;; the rewritten subtree. A bare (nth r 0)/(nth r 1) transposes silently and still
|
||||||
|
;; type-checks, so name the projections; the call-pattern code below is dense in them.
|
||||||
|
(defn- ty [r] (nth r 0))
|
||||||
|
(defn- nd [r] (nth r 1))
|
||||||
|
|
||||||
;; HOFs that apply their fn arg to the ELEMENTS of a collection. :epos is which
|
;; HOFs that apply their fn arg to the ELEMENTS of a collection. :epos is which
|
||||||
;; param of the fn receives an element. reduce is
|
;; param of the fn receives an element. reduce is
|
||||||
;; handled separately (its arity changes the coll position, and its closure
|
;; handled separately (its arity changes the coll position, and its closure
|
||||||
|
|
@ -167,11 +176,167 @@
|
||||||
tenv (range (count params)))
|
tenv (range (count params)))
|
||||||
pe (if (get a :rest) (assoc pe (get a :rest) :any) pe)
|
pe (if (get a :rest) (assoc pe (get a :rest) :any) pe)
|
||||||
br (infer (get a :body) pe env)]
|
br (infer (get a :body) pe env)]
|
||||||
[(nth br 0) (assoc a :body (nth br 1))]))
|
[(ty br) (assoc a :body (nd br))]))
|
||||||
(get node :arities))
|
(get node :arities))
|
||||||
rets (mapv (fn [r] (nth r 0)) res)
|
rets (mapv (fn [r] (ty r)) res)
|
||||||
ret (if (empty? rets) :any (reduce join (first rets) (rest rets)))]
|
ret (if (empty? rets) :any (reduce join (first rets) (rest rets)))]
|
||||||
[ret (assoc node :arities (mapv (fn [r] (nth r 1)) res))]))
|
[ret (assoc node :arities (mapv (fn [r] (nd r)) res))]))
|
||||||
|
|
||||||
|
;; --- :invoke call patterns ---------------------------------------------------
|
||||||
|
;; infer's :invoke arm splits the callee/args once, then dispatches by callee
|
||||||
|
;; shape to one of these. Each returns [type node']; all recurse through `infer`.
|
||||||
|
|
||||||
|
(defn- infer-pred-fold
|
||||||
|
"A type predicate over a single side-effect-free arg whose type PROVES the answer
|
||||||
|
folds to a boolean constant — eliminating the call, and (once const-fold runs
|
||||||
|
after inference) collapsing any `if` it gates. Falls back to the normal call path
|
||||||
|
when the answer isn't provable or the arg is impure."
|
||||||
|
[node fnode cn args tenv env]
|
||||||
|
(let [ar (infer (nth args 0) tenv env)
|
||||||
|
v (pred-on cn (ty ar))]
|
||||||
|
(if (and (not (nil? v)) (pure-node? (nd ar)))
|
||||||
|
[:any {:op :const :val v}]
|
||||||
|
[(call-ret-type fnode env) (assoc node :args [(nd ar)])])))
|
||||||
|
|
||||||
|
(defn- infer-kw-lookup
|
||||||
|
"(:k m) / (:k m default): the result is m's field type, and if m is a struct the
|
||||||
|
subject is tagged so the back end drops the guard — this types nested access end
|
||||||
|
to end (RFC 0005)."
|
||||||
|
[node fnode args n tenv env]
|
||||||
|
(let [mr (infer (nth args 0) tenv env)
|
||||||
|
mt (ty mr)
|
||||||
|
msub (if (struct-safe? mt) (mark-struct (nd mr) mt) (nd mr))
|
||||||
|
ft (field-type mt (get fnode :val))
|
||||||
|
dr (when (= n 2) (infer (nth args 1) tenv env))]
|
||||||
|
[(if dr (join ft (ty dr)) ft)
|
||||||
|
(assoc node :args (if dr [msub (nd dr)] [msub]))]))
|
||||||
|
|
||||||
|
(defn- infer-get-lookup
|
||||||
|
"(get m :k [default]): the keyword-lookup result type, when the key is a constant
|
||||||
|
keyword."
|
||||||
|
[node args n tenv env]
|
||||||
|
(let [mr (infer (nth args 0) tenv env)
|
||||||
|
mt (ty mr)
|
||||||
|
msub (if (struct-safe? mt) (mark-struct (nd mr) mt) (nd mr))
|
||||||
|
kr (infer (nth args 1) tenv env)
|
||||||
|
ft (field-type mt (get (nth args 1) :val))
|
||||||
|
dr (when (= n 3) (infer (nth args 2) tenv env))]
|
||||||
|
[(if dr (join ft (ty dr)) ft)
|
||||||
|
(assoc node :args (if dr [msub (nd kr) (nd dr)] [msub (nd kr)]))]))
|
||||||
|
|
||||||
|
(defn- infer-reduce-hof
|
||||||
|
"reduce over a typed vector with a fn-literal: seed the closure's accumulator
|
||||||
|
(param 0) to the init type and its element (param 1) to the vector's element
|
||||||
|
type, so its body — and any calls it makes — see those types."
|
||||||
|
[node args n tenv env]
|
||||||
|
(let [three (>= n 3)
|
||||||
|
coll-r (infer (nth args (if three 2 1)) tenv env)
|
||||||
|
init-r (when three (infer (nth args 1) tenv env))
|
||||||
|
et (let [ct (ty coll-r)] (if (vec-type? ct) (velem ct) :any))
|
||||||
|
init-t (if init-r (ty init-r) :any)
|
||||||
|
fn-r (infer-fn-seeded (nth args 0) {0 init-t 1 et} tenv env)]
|
||||||
|
[(join init-t (ty fn-r))
|
||||||
|
(assoc node :args (if three
|
||||||
|
[(nd fn-r) (nd init-r) (nd coll-r)]
|
||||||
|
[(nd fn-r) (nd coll-r)]))]))
|
||||||
|
|
||||||
|
(defn- infer-seq-hof
|
||||||
|
"map/mapv/filter/... over a typed vector with a fn-literal: seed the fn's element
|
||||||
|
param; mapv/filterv produce a typed vector."
|
||||||
|
[node cn args tenv env]
|
||||||
|
(let [coll-r (infer (nth args 1) tenv env)
|
||||||
|
et (let [ct (ty coll-r)] (if (vec-type? ct) (velem ct) :any))
|
||||||
|
fn-r (infer-fn-seeded (nth args 0) {(get (get hof-table cn) :epos) et} tenv env)
|
||||||
|
rt (cond (= cn "mapv") (mk-vec (ty fn-r))
|
||||||
|
(= cn "filterv") (mk-vec et)
|
||||||
|
:else :any)]
|
||||||
|
[rt (assoc node :args [(nd fn-r) (nd coll-r)])]))
|
||||||
|
|
||||||
|
(defn- infer-conj-into
|
||||||
|
"conj/into: track the element type of a vector being grown."
|
||||||
|
[node fnode cn args n tenv env]
|
||||||
|
(let [ares (mapv (fn [a] (infer a tenv env)) args)
|
||||||
|
base (ty (nth ares 0))
|
||||||
|
rest-ts (mapv (fn [r] (ty r)) (rest ares))
|
||||||
|
rt (cond
|
||||||
|
(and (= cn "conj") (vec-type? base))
|
||||||
|
(mk-vec (reduce join (velem base) rest-ts))
|
||||||
|
(and (= cn "into") (vec-type? base) (= 2 n) (vec-type? (nth rest-ts 0)))
|
||||||
|
(mk-vec (join (velem base) (velem (nth rest-ts 0))))
|
||||||
|
:else (call-ret-type fnode env))]
|
||||||
|
[rt (assoc node :args (mapv (fn [r] (nd r)) ares))]))
|
||||||
|
|
||||||
|
(defn- infer-call
|
||||||
|
"Everything else: type the args, collect the call (var callee) for whole-program
|
||||||
|
inference, run the success-type check, and use the declared/estimated return type.
|
||||||
|
range produces a numeric vector; an element-returning fn over a typed vector
|
||||||
|
yields the element type. A protocol-method call whose receiver (arg 0) is a known
|
||||||
|
record type is annotated [type-tag proto method] for devirtualization — the back
|
||||||
|
end looks up the impl at emit time and calls it directly, skipping the registry
|
||||||
|
dispatch (~19x cheaper)."
|
||||||
|
[node fnode iscall-var cn args n tenv env]
|
||||||
|
(let [fr (when (not iscall-var) (infer fnode tenv env))
|
||||||
|
fnode' (if iscall-var fnode (nd fr))
|
||||||
|
;; the callee's value type: a var's from vtypes (a fn is :truthy, a def
|
||||||
|
;; carries its inferred type), else the inferred type of the callee expr
|
||||||
|
callee-t (if iscall-var (get (get env :vtypes) (var-key fnode)) (ty fr))
|
||||||
|
ares (mapv (fn [a] (infer a tenv env)) args)]
|
||||||
|
(when iscall-var
|
||||||
|
(swap! (get env :calls) conj [(var-key fnode) (mapv (fn [r] (ty r)) ares)]))
|
||||||
|
;; success-type check at this call, reusing the arg types just computed (jolt
|
||||||
|
;; audit): core error domains always, user-fn domains in strict mode.
|
||||||
|
(when (get env :checking?)
|
||||||
|
(let [ats (mapv (fn [r] (ty r)) ares) pos (get node :pos)]
|
||||||
|
(when cn (check-invoke cn args ats pos env))
|
||||||
|
(when (not-callable? callee-t)
|
||||||
|
(swap! (get env :diags) conj
|
||||||
|
{:op :call :type (type-name callee-t) :pos pos
|
||||||
|
:msg (str "cannot call " (type-name callee-t) " as a function")}))
|
||||||
|
(when (and (get env :strict?) iscall-var)
|
||||||
|
(let [k (var-key fnode) usig (get @(get env :user-sigs) k)]
|
||||||
|
(when usig (check-user-call k usig ats pos env))))))
|
||||||
|
(let [pm (and iscall-var (get (get env :protocol-methods) (var-key fnode)))
|
||||||
|
rtype (when (and pm (pos? n)) (get (ty (nth ares 0)) :type))
|
||||||
|
base (assoc node :fn fnode' :args (mapv (fn [r] (nd r)) ares))]
|
||||||
|
[(cond
|
||||||
|
(= cn "range") (mk-vec :num)
|
||||||
|
(and cn (contains? elem-fns cn) (> n 0))
|
||||||
|
(let [a0 (ty (nth ares 0))] (if (vec-type? a0) (velem a0) :any))
|
||||||
|
:else (call-ret-type fnode env))
|
||||||
|
(if rtype
|
||||||
|
(assoc base :devirt-type rtype :devirt-proto (nth pm 0) :devirt-method (nth pm 1))
|
||||||
|
base)])))
|
||||||
|
|
||||||
|
(defn- infer-invoke
|
||||||
|
"Split the callee/args once and dispatch by callee shape to a pattern helper."
|
||||||
|
[node tenv env]
|
||||||
|
(let [fnode (get node :fn)
|
||||||
|
iscall-var (= :var (get fnode :op))
|
||||||
|
cn (when (and iscall-var (= "clojure.core" (get fnode :ns))) (get fnode :name))
|
||||||
|
args (get node :args)
|
||||||
|
n (count args)]
|
||||||
|
(cond
|
||||||
|
(and iscall-var (contains? fold-preds cn) (= n 1))
|
||||||
|
(infer-pred-fold node fnode cn args tenv env)
|
||||||
|
|
||||||
|
(and (kw-callee? fnode) (>= n 1) (<= n 2))
|
||||||
|
(infer-kw-lookup node fnode args n tenv env)
|
||||||
|
|
||||||
|
(and (get-callee? fnode)
|
||||||
|
(>= n 2) (= :const (get (nth args 1) :op)) (keyword? (get (nth args 1) :val)))
|
||||||
|
(infer-get-lookup node args n tenv env)
|
||||||
|
|
||||||
|
(and (= cn "reduce") (>= n 2) (= :fn (get (nth args 0) :op)))
|
||||||
|
(infer-reduce-hof node args n tenv env)
|
||||||
|
|
||||||
|
(and cn (get hof-table cn) (>= n 2) (= :fn (get (nth args 0) :op)))
|
||||||
|
(infer-seq-hof node cn args tenv env)
|
||||||
|
|
||||||
|
(and (or (= cn "conj") (= cn "into")) (>= n 1))
|
||||||
|
(infer-conj-into node fnode cn args n tenv env)
|
||||||
|
|
||||||
|
:else
|
||||||
|
(infer-call node fnode iscall-var cn args n tenv env))))
|
||||||
|
|
||||||
(defn- infer
|
(defn- infer
|
||||||
"Returns [type node'] — the inferred type of node and node with struct-safe
|
"Returns [type node'] — the inferred type of node and node with struct-safe
|
||||||
|
|
@ -242,127 +407,7 @@
|
||||||
;; inferred type); unknown -> :any.
|
;; inferred type); unknown -> :any.
|
||||||
(= op :var) (do (swap! (get env :escapes) conj (var-key node))
|
(= op :var) (do (swap! (get env :escapes) conj (var-key node))
|
||||||
[(let [vt (get (get env :vtypes) (var-key node))] (if vt vt :any)) node])
|
[(let [vt (get (get env :vtypes) (var-key node))] (if vt vt :any)) node])
|
||||||
(= op :invoke)
|
(= op :invoke) (infer-invoke node tenv env)
|
||||||
(let [fnode (get node :fn)
|
|
||||||
iscall-var (= :var (get fnode :op))
|
|
||||||
cn (when (and iscall-var (= "clojure.core" (get fnode :ns))) (get fnode :name))
|
|
||||||
args (get node :args)
|
|
||||||
n (count args)]
|
|
||||||
(cond
|
|
||||||
;; predicate folding: a type predicate over a single,
|
|
||||||
;; side-effect-free argument whose type PROVES the answer becomes a
|
|
||||||
;; boolean constant — eliminating the call, and (once const-fold runs
|
|
||||||
;; after inference) collapsing any `if` it gates. Falls through to the
|
|
||||||
;; normal call path when the answer isn't provable or the arg is impure.
|
|
||||||
(and iscall-var (contains? fold-preds cn) (= n 1))
|
|
||||||
(let [ar (infer (nth args 0) tenv env)
|
|
||||||
v (pred-on cn (nth ar 0))]
|
|
||||||
(if (and (not (nil? v)) (pure-node? (nth ar 1)))
|
|
||||||
[:any {:op :const :val v}]
|
|
||||||
[(call-ret-type fnode env) (assoc node :args [(nth ar 1)])]))
|
|
||||||
;; (:k m) / (:k m default): the result is m's field type, and if m is a
|
|
||||||
;; struct the subject is tagged so the back end drops the guard — this
|
|
||||||
;; types nested access end to end (RFC 0005).
|
|
||||||
(and (= :const (get fnode :op)) (keyword? (get fnode :val)) (>= n 1) (<= n 2))
|
|
||||||
(let [mr (infer (nth args 0) tenv env)
|
|
||||||
mt (nth mr 0)
|
|
||||||
msub (if (struct-safe? mt) (mark-struct (nth mr 1) mt) (nth mr 1))
|
|
||||||
ft (field-type mt (get fnode :val))
|
|
||||||
dr (when (= n 2) (infer (nth args 1) tenv env))]
|
|
||||||
[(if dr (join ft (nth dr 0)) ft)
|
|
||||||
(assoc node :args (if dr [msub (nth dr 1)] [msub]))])
|
|
||||||
;; (get m :k [default]): same, when the key is a constant keyword.
|
|
||||||
(and (or (and (= :var (get fnode :op)) (= "clojure.core" (get fnode :ns)) (= "get" (get fnode :name)))
|
|
||||||
(and (= :host (get fnode :op)) (= "get" (get fnode :name))))
|
|
||||||
(>= n 2) (= :const (get (nth args 1) :op)) (keyword? (get (nth args 1) :val)))
|
|
||||||
(let [mr (infer (nth args 0) tenv env)
|
|
||||||
mt (nth mr 0)
|
|
||||||
msub (if (struct-safe? mt) (mark-struct (nth mr 1) mt) (nth mr 1))
|
|
||||||
kr (infer (nth args 1) tenv env)
|
|
||||||
ft (field-type mt (get (nth args 1) :val))
|
|
||||||
dr (when (= n 3) (infer (nth args 2) tenv env))]
|
|
||||||
[(if dr (join ft (nth dr 0)) ft)
|
|
||||||
(assoc node :args (if dr [msub (nth kr 1) (nth dr 1)] [msub (nth kr 1)]))])
|
|
||||||
;; reduce over a typed vector with a fn-literal: seed the
|
|
||||||
;; closure's accumulator (param 0) to the init type and its element
|
|
||||||
;; (param 1) to the vector's element type, so its body — and any calls
|
|
||||||
;; it makes — see those types.
|
|
||||||
(and (= cn "reduce") (>= n 2) (= :fn (get (nth args 0) :op)))
|
|
||||||
(let [three (>= n 3)
|
|
||||||
coll-r (infer (nth args (if three 2 1)) tenv env)
|
|
||||||
init-r (when three (infer (nth args 1) tenv env))
|
|
||||||
et (let [ct (nth coll-r 0)] (if (vec-type? ct) (velem ct) :any))
|
|
||||||
init-t (if init-r (nth init-r 0) :any)
|
|
||||||
fn-r (infer-fn-seeded (nth args 0) {0 init-t 1 et} tenv env)]
|
|
||||||
[(join init-t (nth fn-r 0))
|
|
||||||
(assoc node :args (if three
|
|
||||||
[(nth fn-r 1) (nth init-r 1) (nth coll-r 1)]
|
|
||||||
[(nth fn-r 1) (nth coll-r 1)]))])
|
|
||||||
;; map/mapv/filter/... over a typed vector with a fn-literal: seed the
|
|
||||||
;; fn's element param; mapv/filterv produce a typed vector.
|
|
||||||
(and cn (get hof-table cn) (>= n 2) (= :fn (get (nth args 0) :op)))
|
|
||||||
(let [coll-r (infer (nth args 1) tenv env)
|
|
||||||
et (let [ct (nth coll-r 0)] (if (vec-type? ct) (velem ct) :any))
|
|
||||||
fn-r (infer-fn-seeded (nth args 0) {(get (get hof-table cn) :epos) et} tenv env)
|
|
||||||
rt (cond (= cn "mapv") (mk-vec (nth fn-r 0))
|
|
||||||
(= cn "filterv") (mk-vec et)
|
|
||||||
:else :any)]
|
|
||||||
[rt (assoc node :args [(nth fn-r 1) (nth coll-r 1)])])
|
|
||||||
;; conj/into: track the element type of a vector being grown.
|
|
||||||
(and (or (= cn "conj") (= cn "into")) (>= n 1))
|
|
||||||
(let [ares (mapv (fn [a] (infer a tenv env)) args)
|
|
||||||
base (nth (nth ares 0) 0)
|
|
||||||
rest-ts (mapv (fn [r] (nth r 0)) (rest ares))
|
|
||||||
rt (cond
|
|
||||||
(and (= cn "conj") (vec-type? base))
|
|
||||||
(mk-vec (reduce join (velem base) rest-ts))
|
|
||||||
(and (= cn "into") (vec-type? base) (= 2 n) (vec-type? (nth rest-ts 0)))
|
|
||||||
(mk-vec (join (velem base) (velem (nth rest-ts 0))))
|
|
||||||
:else (call-ret-type fnode env))]
|
|
||||||
[rt (assoc node :args (mapv (fn [r] (nth r 1)) ares))])
|
|
||||||
;; everything else: type args, collect the call (var callee), use the
|
|
||||||
;; declared/estimated return type. range produces a numeric vector.
|
|
||||||
:else
|
|
||||||
(let [fr (when (not iscall-var) (infer fnode tenv env))
|
|
||||||
fnode' (if iscall-var fnode (nth fr 1))
|
|
||||||
;; the callee's value type: a var's from vtypes (a fn is
|
|
||||||
;; :truthy, a def carries its inferred type), else the inferred
|
|
||||||
;; type of the callee expression
|
|
||||||
callee-t (if iscall-var (get (get env :vtypes) (var-key fnode)) (nth fr 0))
|
|
||||||
ares (mapv (fn [a] (infer a tenv env)) args)]
|
|
||||||
(when iscall-var
|
|
||||||
(swap! (get env :calls) conj [(var-key fnode) (mapv (fn [r] (nth r 0)) ares)]))
|
|
||||||
;; success-type check at this call, reusing the arg types just
|
|
||||||
;; computed (jolt audit): core error domains always, user-fn domains
|
|
||||||
;; in strict mode. The arg subtrees are inferred exactly once.
|
|
||||||
(when (get env :checking?)
|
|
||||||
(let [ats (mapv (fn [r] (nth r 0)) ares) pos (get node :pos)]
|
|
||||||
(when cn (check-invoke cn args ats pos env))
|
|
||||||
;; calling a provably non-function
|
|
||||||
(when (not-callable? callee-t)
|
|
||||||
(swap! (get env :diags) conj
|
|
||||||
{:op :call :type (type-name callee-t) :pos pos
|
|
||||||
:msg (str "cannot call " (type-name callee-t) " as a function")}))
|
|
||||||
(when (and (get env :strict?) iscall-var)
|
|
||||||
(let [k (var-key fnode) usig (get @(get env :user-sigs) k)]
|
|
||||||
(when usig (check-user-call k usig ats pos env))))))
|
|
||||||
;; devirtualization: a protocol-method call whose receiver
|
|
||||||
;; (arg 0) is a known record type resolves to a direct method call.
|
|
||||||
;; Annotate the node with [type-tag proto method]; the back end looks
|
|
||||||
;; up the impl at emit time and calls it directly, skipping the
|
|
||||||
;; registry dispatch (~19x cheaper than protocol-dispatch).
|
|
||||||
(let [pm (and iscall-var (get (get env :protocol-methods) (var-key fnode)))
|
|
||||||
rtype (when (and pm (pos? n)) (get (nth (nth ares 0) 0) :type))
|
|
||||||
base (assoc node :fn fnode' :args (mapv (fn [r] (nth r 1)) ares))]
|
|
||||||
[(cond
|
|
||||||
(= cn "range") (mk-vec :num)
|
|
||||||
;; element-returning fn over a typed vector -> the element type
|
|
||||||
(and cn (contains? elem-fns cn) (> n 0))
|
|
||||||
(let [a0 (nth (nth ares 0) 0)] (if (vec-type? a0) (velem a0) :any))
|
|
||||||
:else (call-ret-type fnode env))
|
|
||||||
(if rtype
|
|
||||||
(assoc base :devirt-type rtype :devirt-proto (nth pm 0) :devirt-method (nth pm 1))
|
|
||||||
base)]))))
|
|
||||||
(= op :let)
|
(= op :let)
|
||||||
(let [res (reduce (fn [acc b]
|
(let [res (reduce (fn [acc b]
|
||||||
(let [te (nth acc 0) binds (nth acc 1)
|
(let [te (nth acc 0) binds (nth acc 1)
|
||||||
|
|
@ -421,81 +466,6 @@
|
||||||
;; there are no false positives. The table is curated to genuinely-throwing
|
;; there are no false positives. The table is curated to genuinely-throwing
|
||||||
;; cases; lenient ops ((get 5 :k) -> nil, (:k 5) -> nil) are NOT listed.
|
;; cases; lenient ops ((get 5 :k) -> nil, (:k 5) -> nil) are NOT listed.
|
||||||
|
|
||||||
;; concrete non-numbers: arithmetic provably throws on these. A union is in the
|
|
||||||
;; error domain only when EVERY member is — if any member is an
|
|
||||||
;; accepted type the call is accepted (no false positive).
|
|
||||||
(defn- not-number? [t]
|
|
||||||
(if (union-type? t)
|
|
||||||
(every? not-number? (umembers t))
|
|
||||||
(or (= t :str) (= t :kw) (= t :phm)
|
|
||||||
(struct-type? t) (vec-type? t) (set-type? t))))
|
|
||||||
|
|
||||||
;; concrete non-seqable scalars: seq/count/first/nth provably throw on these.
|
|
||||||
;; (Strings and collections ARE seqable/countable; :truthy is ambiguous; :nil
|
|
||||||
;; and :any are accepted.) A union throws only when every member does.
|
|
||||||
(defn- not-seqable? [t]
|
|
||||||
(if (union-type? t)
|
|
||||||
(every? not-seqable? (umembers t))
|
|
||||||
(or (= t :num) (= t :kw))))
|
|
||||||
|
|
||||||
;; concrete non-callable values: calling them throws "Cannot call X
|
|
||||||
;; as a function". Only :num and :str — keywords/maps/vectors/sets are IFn,
|
|
||||||
;; :truthy/:any/:nil are ambiguous (accepted). A union is non-callable only when
|
|
||||||
;; every member is.
|
|
||||||
(defn- not-callable? [t]
|
|
||||||
(if (union-type? t)
|
|
||||||
(every? not-callable? (umembers t))
|
|
||||||
(or (= t :num) (= t :str))))
|
|
||||||
|
|
||||||
;; arithmetic / numeric ops: EVERY argument must be a number.
|
|
||||||
(def ^:private num-ops
|
|
||||||
#{"+" "-" "*" "/" "inc" "dec" "mod" "rem" "quot" "min" "max" "abs"
|
|
||||||
"bit-and" "bit-or" "bit-xor" "bit-not" "bit-shift-left" "bit-shift-right"})
|
|
||||||
;; seq/count/index ops: argument 0 must be seqable/countable.
|
|
||||||
(def ^:private seq-ops #{"count" "first" "rest" "next" "seq" "nth"})
|
|
||||||
|
|
||||||
(defn- type-name
|
|
||||||
"Render an inferred type for an error message."
|
|
||||||
[t]
|
|
||||||
(cond (union-type? t)
|
|
||||||
(reduce (fn [s m] (if (= s "") (type-name m) (str s " or " (type-name m))))
|
|
||||||
"" (umembers t))
|
|
||||||
(struct-type? t) "a map"
|
|
||||||
(vec-type? t) "a vector"
|
|
||||||
(set-type? t) "a set"
|
|
||||||
(= t :str) "a string"
|
|
||||||
(= t :kw) "a keyword"
|
|
||||||
(= t :num) "a number"
|
|
||||||
(= t :phm) "a map"
|
|
||||||
:else (str t)))
|
|
||||||
|
|
||||||
(defn- check-invoke
|
|
||||||
"If node is a core-op call whose argument type is provably in the error domain,
|
|
||||||
conj a diagnostic into env's diags cell. arg-types is the vector of inferred
|
|
||||||
argument types; pos is the call form's source offset, carried into each
|
|
||||||
diagnostic."
|
|
||||||
[cn args arg-types pos env]
|
|
||||||
(cond
|
|
||||||
(contains? num-ops cn)
|
|
||||||
(reduce (fn [_ i]
|
|
||||||
(let [t (nth arg-types i)]
|
|
||||||
(when (not-number? t)
|
|
||||||
(swap! (get env :diags) conj
|
|
||||||
{:op cn :argpos i :type (type-name t) :pos pos
|
|
||||||
:msg (str "`" cn "` requires a number, but argument "
|
|
||||||
(inc i) " is " (type-name t))})))
|
|
||||||
nil)
|
|
||||||
nil (range (count args)))
|
|
||||||
(and (contains? seq-ops cn) (> (count args) 0))
|
|
||||||
(let [t (nth arg-types 0)]
|
|
||||||
(when (not-seqable? t)
|
|
||||||
(swap! (get env :diags) conj
|
|
||||||
{:op cn :argpos 0 :type (type-name t) :pos pos
|
|
||||||
:msg (str "`" cn "` requires "
|
|
||||||
(if (= cn "count") "a countable collection" "a seqable")
|
|
||||||
", but argument 1 is " (type-name t))})))
|
|
||||||
:else nil))
|
|
||||||
|
|
||||||
;; --- user-function error domains, opt-in -------------------------------------
|
;; --- user-function error domains, opt-in -------------------------------------
|
||||||
(defn- all-any-env
|
(defn- all-any-env
|
||||||
"tenv binding every param name to :any (the all-ambiguous baseline)."
|
"tenv binding every param name to :any (the all-ambiguous baseline)."
|
||||||
|
|
@ -512,24 +482,6 @@
|
||||||
(infer body tenv sub)
|
(infer body tenv sub)
|
||||||
(count @(get sub :diags))))
|
(count @(get sub :diags))))
|
||||||
|
|
||||||
(defn- register-user-fn!
|
|
||||||
"Record a (def name (fn [params] body)) — single fixed arity, not redefinable —
|
|
||||||
for later user-fn call checking. Redefinable/dynamic and multi/variadic fns are
|
|
||||||
skipped (their body is not a stable requirement)."
|
|
||||||
[node env]
|
|
||||||
(let [init (get node :init)
|
|
||||||
m (get node :meta)
|
|
||||||
redefable (and m (or (get m :redef) (get m :dynamic)))]
|
|
||||||
(when (and (not redefable) (= :fn (get init :op)))
|
|
||||||
(let [arities (get init :arities)]
|
|
||||||
(when (= 1 (count arities))
|
|
||||||
(let [ar (first arities)]
|
|
||||||
(when (not (get ar :rest))
|
|
||||||
(swap! (get env :user-sigs) assoc
|
|
||||||
(str (get node :ns) "/" (get node :name))
|
|
||||||
{:name (get node :name)
|
|
||||||
:params (get ar :params) :body (get ar :body)}))))))))
|
|
||||||
|
|
||||||
(defn- check-user-call
|
(defn- check-user-call
|
||||||
"Strict mode: report a call to a registered user fn that provably throws —
|
"Strict mode: report a call to a registered user fn that provably throws —
|
||||||
either a WRONG ARITY (the registered fn has one fixed arity, so a different
|
either a WRONG ARITY (the registered fn has one fixed arity, so a different
|
||||||
|
|
|
||||||
102
jolt-core/jolt/passes/types/check.clj
Normal file
102
jolt-core/jolt/passes/types/check.clj
Normal file
|
|
@ -0,0 +1,102 @@
|
||||||
|
(ns jolt.passes.types.check
|
||||||
|
"Success-type error domains (RFC 0006): the curated tables of which concrete
|
||||||
|
types each core op provably throws on, the diagnostic emitter, and the user-fn
|
||||||
|
signature registry. Pure over inferred types plus the run's `env` cells — no
|
||||||
|
inference — so the inferencer (jolt.passes.types) and these rules can't perturb
|
||||||
|
each other. The inferencer calls these during its walk; the infer-coupled user
|
||||||
|
call probes (re-inference) stay in the inferencer."
|
||||||
|
(:require [jolt.passes.types.lattice :refer
|
||||||
|
[union-type? umembers struct-type? vec-type? set-type?]]))
|
||||||
|
|
||||||
|
;; concrete non-numbers: arithmetic provably throws on these. A union is in the
|
||||||
|
;; error domain only when EVERY member is — if any member is an
|
||||||
|
;; accepted type the call is accepted (no false positive).
|
||||||
|
(defn- not-number? [t]
|
||||||
|
(if (union-type? t)
|
||||||
|
(every? not-number? (umembers t))
|
||||||
|
(or (= t :str) (= t :kw) (= t :phm)
|
||||||
|
(struct-type? t) (vec-type? t) (set-type? t))))
|
||||||
|
|
||||||
|
;; concrete non-seqable scalars: seq/count/first/nth provably throw on these.
|
||||||
|
;; (Strings and collections ARE seqable/countable; :truthy is ambiguous; :nil
|
||||||
|
;; and :any are accepted.) A union throws only when every member does.
|
||||||
|
(defn- not-seqable? [t]
|
||||||
|
(if (union-type? t)
|
||||||
|
(every? not-seqable? (umembers t))
|
||||||
|
(or (= t :num) (= t :kw))))
|
||||||
|
|
||||||
|
;; concrete non-callable values: calling them throws "Cannot call X
|
||||||
|
;; as a function". Only :num and :str — keywords/maps/vectors/sets are IFn,
|
||||||
|
;; :truthy/:any/:nil are ambiguous (accepted). A union is non-callable only when
|
||||||
|
;; every member is.
|
||||||
|
(defn not-callable? [t]
|
||||||
|
(if (union-type? t)
|
||||||
|
(every? not-callable? (umembers t))
|
||||||
|
(or (= t :num) (= t :str))))
|
||||||
|
|
||||||
|
;; arithmetic / numeric ops: EVERY argument must be a number.
|
||||||
|
(def ^:private num-ops
|
||||||
|
#{"+" "-" "*" "/" "inc" "dec" "mod" "rem" "quot" "min" "max" "abs"
|
||||||
|
"bit-and" "bit-or" "bit-xor" "bit-not" "bit-shift-left" "bit-shift-right"})
|
||||||
|
;; seq/count/index ops: argument 0 must be seqable/countable.
|
||||||
|
(def ^:private seq-ops #{"count" "first" "rest" "next" "seq" "nth"})
|
||||||
|
|
||||||
|
(defn type-name
|
||||||
|
"Render an inferred type for an error message."
|
||||||
|
[t]
|
||||||
|
(cond (union-type? t)
|
||||||
|
(reduce (fn [s m] (if (= s "") (type-name m) (str s " or " (type-name m))))
|
||||||
|
"" (umembers t))
|
||||||
|
(struct-type? t) "a map"
|
||||||
|
(vec-type? t) "a vector"
|
||||||
|
(set-type? t) "a set"
|
||||||
|
(= t :str) "a string"
|
||||||
|
(= t :kw) "a keyword"
|
||||||
|
(= t :num) "a number"
|
||||||
|
(= t :phm) "a map"
|
||||||
|
:else (str t)))
|
||||||
|
|
||||||
|
(defn check-invoke
|
||||||
|
"If node is a core-op call whose argument type is provably in the error domain,
|
||||||
|
conj a diagnostic into env's diags cell. arg-types is the vector of inferred
|
||||||
|
argument types; pos is the call form's source offset, carried into each
|
||||||
|
diagnostic."
|
||||||
|
[cn args arg-types pos env]
|
||||||
|
(cond
|
||||||
|
(contains? num-ops cn)
|
||||||
|
(reduce (fn [_ i]
|
||||||
|
(let [t (nth arg-types i)]
|
||||||
|
(when (not-number? t)
|
||||||
|
(swap! (get env :diags) conj
|
||||||
|
{:op cn :argpos i :type (type-name t) :pos pos
|
||||||
|
:msg (str "`" cn "` requires a number, but argument "
|
||||||
|
(inc i) " is " (type-name t))})))
|
||||||
|
nil)
|
||||||
|
nil (range (count args)))
|
||||||
|
(and (contains? seq-ops cn) (> (count args) 0))
|
||||||
|
(let [t (nth arg-types 0)]
|
||||||
|
(when (not-seqable? t)
|
||||||
|
(swap! (get env :diags) conj
|
||||||
|
{:op cn :argpos 0 :type (type-name t) :pos pos
|
||||||
|
:msg (str "`" cn "` requires "
|
||||||
|
(if (= cn "count") "a countable collection" "a seqable")
|
||||||
|
", but argument 1 is " (type-name t))})))
|
||||||
|
:else nil))
|
||||||
|
|
||||||
|
(defn register-user-fn!
|
||||||
|
"Record a (def name (fn [params] body)) — single fixed arity, not redefinable —
|
||||||
|
for later user-fn call checking. Redefinable/dynamic and multi/variadic fns are
|
||||||
|
skipped (their body is not a stable requirement)."
|
||||||
|
[node env]
|
||||||
|
(let [init (get node :init)
|
||||||
|
m (get node :meta)
|
||||||
|
redefable (and m (or (get m :redef) (get m :dynamic)))]
|
||||||
|
(when (and (not redefable) (= :fn (get init :op)))
|
||||||
|
(let [arities (get init :arities)]
|
||||||
|
(when (= 1 (count arities))
|
||||||
|
(let [ar (first arities)]
|
||||||
|
(when (not (get ar :rest))
|
||||||
|
(swap! (get env :user-sigs) assoc
|
||||||
|
(str (get node :ns) "/" (get node :name))
|
||||||
|
{:name (get node :name)
|
||||||
|
:params (get ar :params) :body (get ar :body)}))))))))
|
||||||
|
|
@ -7,6 +7,11 @@
|
||||||
; vectors/maps first so seq? can't swallow them (a vector is not seq? on
|
; vectors/maps first so seq? can't swallow them (a vector is not seq? on
|
||||||
; jolt, but keep the concrete branches authoritative)
|
; jolt, but keep the concrete branches authoritative)
|
||||||
(vector? form) (outer (vec (map inner form)))
|
(vector? form) (outer (vec (map inner form)))
|
||||||
|
; a record is also map?, but (empty record) yields a plain map — rebuild by
|
||||||
|
; conj-ing the walked entries back onto the original so the record TYPE
|
||||||
|
; survives. Type-dispatched walks depend on it (e.g. integrant resolves
|
||||||
|
; #ig/ref by detecting its Ref record while postwalking the config).
|
||||||
|
(record? form) (outer (reduce (fn [r x] (conj r (inner x))) form form))
|
||||||
(map? form) (outer (into (empty form) (map inner form)))
|
(map? form) (outer (into (empty form) (map inner form)))
|
||||||
; lists rebuild as lists, other seqs (incl. macro/template output: cons/
|
; lists rebuild as lists, other seqs (incl. macro/template output: cons/
|
||||||
; concat/lazy-seq) walk too — without this, postwalk-replace silently no-op'd
|
; concat/lazy-seq) walk too — without this, postwalk-replace silently no-op'd
|
||||||
|
|
|
||||||
|
|
@ -2,10 +2,17 @@
|
||||||
(:require [app.util :as util]
|
(:require [app.util :as util]
|
||||||
[clojure.java.io :as io]))
|
[clojure.java.io :as io]))
|
||||||
|
|
||||||
|
;; An aliased cross-ns defmethod: 'util/greet is passed quoted to defmethod-setup,
|
||||||
|
;; so the AOT build must register the `util` alias for app.core or it resolves to
|
||||||
|
;; ns "util" and never reaches app.util/greet (the dispatch falls to :default).
|
||||||
|
(defmethod util/greet :loud [_] "greet:loud")
|
||||||
|
|
||||||
(defn -main [& args]
|
(defn -main [& args]
|
||||||
;; the resource is baked into the binary (deps.edn :jolt/build :embed), so this
|
;; the resource is baked into the binary (deps.edn :jolt/build :embed), so this
|
||||||
;; resolves with no resources/ dir on disk, run from any cwd.
|
;; resolves with no resources/ dir on disk, run from any cwd.
|
||||||
(println (slurp (io/resource "greeting.txt")))
|
(println (slurp (io/resource "greeting.txt")))
|
||||||
(util/twice (println (util/shout "hello from a built binary")))
|
(util/twice (println (util/shout "hello from a built binary")))
|
||||||
(println "args:" (vec args))
|
(println "args:" (vec args))
|
||||||
(println "sum:" (reduce + (map count args))))
|
(println "sum:" (reduce + (map count args)))
|
||||||
|
(println "greet-default:" (util/greet :unknown))
|
||||||
|
(println "greet-loud:" (util/greet :loud)))
|
||||||
|
|
|
||||||
|
|
@ -6,3 +6,10 @@
|
||||||
|
|
||||||
(defmacro twice [x]
|
(defmacro twice [x]
|
||||||
`(do ~x ~x))
|
`(do ~x ~x))
|
||||||
|
|
||||||
|
;; A multimethod with a :default method. The AOT build must set the per-ns
|
||||||
|
;; current ns before these forms run, or the defmethod registers app.util/greet
|
||||||
|
;; under the wrong ns and a dispatch to :default crashes (not a fn nil). app.core
|
||||||
|
;; adds an aliased method (util/greet :loud) — see there.
|
||||||
|
(defmulti greet (fn [kind] kind))
|
||||||
|
(defmethod greet :default [_] "greet:default")
|
||||||
|
|
|
||||||
|
|
@ -2640,6 +2640,11 @@
|
||||||
{:suite "clojure.walk / lists + seqs" :label "postwalk-replace in a vector" :expected "[:one 2 :one]" :actual "(do (require (quote [clojure.walk :as w])) (w/postwalk-replace {1 :one} [1 2 1]))"}
|
{:suite "clojure.walk / lists + seqs" :label "postwalk-replace in a vector" :expected "[:one 2 :one]" :actual "(do (require (quote [clojure.walk :as w])) (w/postwalk-replace {1 :one} [1 2 1]))"}
|
||||||
{:suite "clojure.walk / lists + seqs" :label "keywordize-keys still works" :expected "{:a 1}" :actual "(do (require (quote [clojure.walk :as w])) (w/keywordize-keys {\"a\" 1}))"}
|
{:suite "clojure.walk / lists + seqs" :label "keywordize-keys still works" :expected "{:a 1}" :actual "(do (require (quote [clojure.walk :as w])) (w/keywordize-keys {\"a\" 1}))"}
|
||||||
{:suite "clojure.walk / lists + seqs" :label "apply-template substitutes" :expected "(quote (+ 1 2))" :actual "(do (require (quote [clojure.template :as t])) (t/apply-template (quote [x y]) (quote (+ x y)) (quote (1 2))))"}
|
{:suite "clojure.walk / lists + seqs" :label "apply-template substitutes" :expected "(quote (+ 1 2))" :actual "(do (require (quote [clojure.template :as t])) (t/apply-template (quote [x y]) (quote (+ x y)) (quote (1 2))))"}
|
||||||
|
{:suite "clojure.walk / records keep their type" :label "postwalk preserves record type" :expected "true" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (record? (w/postwalk identity (->R 1))))"}
|
||||||
|
{:suite "clojure.walk / records keep their type" :label "postwalk still walks record fields" :expected "2" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (:a (w/postwalk (fn [x] (if (number? x) (inc x) x)) (->R 1))))"}
|
||||||
|
{:suite "clojure.walk / records keep their type" :label "instance? survives a walk" :expected "true" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (instance? R (w/postwalk identity (->R 1))))"}
|
||||||
|
{:suite "clojure.walk / records keep their type" :label "a record nested in a map keeps its type" :expected "true" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (record? (:r (w/postwalk identity {:r (->R 1)}))))"}
|
||||||
|
{:suite "clojure.walk / records keep their type" :label "prewalk preserves record type" :expected "true" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (record? (w/prewalk identity (->R 1))))"}
|
||||||
{:suite "conformance / CRITICAL: lazy sequences" :label "self-ref lazy-cat fib" :expected "[0 1 1 2 3 5 8 13 21 34]" :actual "(do (def fib-seq (lazy-cat [0 1] (map + (rest fib-seq) fib-seq))) (take 10 fib-seq))"}
|
{:suite "conformance / CRITICAL: lazy sequences" :label "self-ref lazy-cat fib" :expected "[0 1 1 2 3 5 8 13 21 34]" :actual "(do (def fib-seq (lazy-cat [0 1] (map + (rest fib-seq) fib-seq))) (take 10 fib-seq))"}
|
||||||
{:suite "conformance / CRITICAL: multi-collection map" :label "map two colls" :expected "[11 22 33]" :actual "(map + [1 2 3] [10 20 30])"}
|
{:suite "conformance / CRITICAL: multi-collection map" :label "map two colls" :expected "[11 22 33]" :actual "(map + [1 2 3] [10 20 30])"}
|
||||||
{:suite "conformance / CRITICAL: multi-collection map" :label "map three colls" :expected "[12 24 36]" :actual "(map + [1 2 3] [10 20 30] [1 2 3])"}
|
{:suite "conformance / CRITICAL: multi-collection map" :label "map three colls" :expected "[12 24 36]" :actual "(map + [1 2 3] [10 20 30] [1 2 3])"}
|
||||||
|
|
|
||||||
|
|
@ -44,6 +44,8 @@
|
||||||
(jolt-compile-eval "(def hof (fn* ([] a)))" "app")
|
(jolt-compile-eval "(def hof (fn* ([] a)))" "app")
|
||||||
(jolt-compile-eval "(def ^:dynamic d 5)" "app")
|
(jolt-compile-eval "(def ^:dynamic d 5)" "app")
|
||||||
(jolt-compile-eval "(def usesd (fn* ([] (d))))" "app")
|
(jolt-compile-eval "(def usesd (fn* ([] (d))))" "app")
|
||||||
|
(jolt-compile-eval "(def cfg {:a 1 :b 2})" "app")
|
||||||
|
(jolt-compile-eval "(def usecfg (fn* ([] (cfg :a))))" "app")
|
||||||
|
|
||||||
;; --- direct-link OFF: every reference stays indirect (var-deref) ---
|
;; --- direct-link OFF: every reference stays indirect (var-deref) ---
|
||||||
(let ((eb (emit-form "app" "(def b (fn* ([] (a))))")))
|
(let ((eb (emit-form "app" "(def b (fn* ([] (a))))")))
|
||||||
|
|
@ -72,6 +74,16 @@
|
||||||
(ok "on: a used as a value references the binding directly" (contains? eh " jv$app$a)"))
|
(ok "on: a used as a value references the binding directly" (contains? eh " jv$app$a)"))
|
||||||
(ok "on: value-ref to a is NOT var-deref'd" (not (contains? eh "(var-deref \"app\" \"a\")"))))
|
(ok "on: value-ref to a is NOT var-deref'd" (not (contains? eh "(var-deref \"app\" \"a\")"))))
|
||||||
|
|
||||||
|
;; A map-valued (non-fn) def is invokable in Clojure but is NOT a Scheme procedure;
|
||||||
|
;; a direct-link call to it must route through jolt-invoke, never raw-apply the
|
||||||
|
;; binding (which crashed with "attempt to apply non-procedure" before the fix).
|
||||||
|
(let ((ec (emit-form "app" "(def cfg {:a 1 :b 2})"))) ; registers app/cfg (non-fn) in the set
|
||||||
|
(ok "on: a non-fn def still gets a jv$ binding" (contains? ec "(define jv$app$cfg ")))
|
||||||
|
(let ((eu (emit-form "app" "(def usecfg (fn* ([] (cfg :a))))")))
|
||||||
|
(ok "on: call to a map-valued def routes through jolt-invoke" (contains? eu "(jolt-invoke"))
|
||||||
|
(ok "on: call to a map-valued def still uses the direct binding" (contains? eu "jv$app$cfg"))
|
||||||
|
(ok "on: a map-valued def is NOT raw-applied as a procedure" (not (contains? eu "(jv$app$cfg"))))
|
||||||
|
|
||||||
;; ^:dynamic opts out: no jv$ binding, callers stay indirect.
|
;; ^:dynamic opts out: no jv$ binding, callers stay indirect.
|
||||||
(let ((ed (emit-form "app" "(def ^:dynamic d 5)")))
|
(let ((ed (emit-form "app" "(def ^:dynamic d 5)")))
|
||||||
(ok "on: ^:dynamic def gets no jv$ binding" (not (contains? ed "(define jv$app$d"))))
|
(ok "on: ^:dynamic def gets no jv$ binding" (not (contains? ed "(define jv$app$d"))))
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue