refactor: extract host/chez/dce.ss; tag the runtime manifest (tier 1)
Tree-shaking was split across emit-image.ss (the dce-* helpers + record producer)
and build.ss (bld-shake-all + the manifest splice), with the DCE record accessed by
raw (vector-ref r 0..3) in ~10 places and the manifest splice/drop driven by
substring-matching (load "…prelude.ss").
- New host/chez/dce.ss owns the whole DCE concern: a named record API
(dce-rec/-keep?/-fqn/-refs/-str — no more positional vector indexing), the ref
extraction + ref-set constants, dce-blob-records, and dce-shake decomposed into
dce-build-graph / dce-reachable / dce-bail-scan / dce-partition (was one 50-line
bld-shake-all doing five jobs with shared mutable state).
- emit-image.ss keeps only ei-emit-ns-records (it drives the ei-* compiler) and uses
the dce-rec constructor.
- The runtime manifest is now tagged ('prelude/'image/'compile-eval); bld-emit-runtime
dispatches on the tag instead of substring-matching file paths, so the core-splice
and compiler-drop can't silently break on a rename/reorder.
Behaviour-preserving (runtime .ss, no re-mint): build-app shakes identically
(56/460, 8.12MB), make test green, make shakesmoke green (4 git-lib apps
byte-identical, same sizes).
This commit is contained in:
Yogthos
parent
d84c88f830
commit
e313e02c9d
3 changed files with 220 additions and 172 deletions
|
|
@ -18,6 +18,7 @@
|
|||
;; normal run never pays for it.
|
||||
|
||||
(load "host/chez/emit-image.ss")
|
||||
(load "host/chez/dce.ss")
|
||||
|
||||
;; --- shell helpers ----------------------------------------------------------
|
||||
;; 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"))
|
||||
|
||||
;; --- 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
|
||||
(list
|
||||
"(load \"host/chez/rt.ss\")"
|
||||
"(set-chez-ns! \"clojure.core\")"
|
||||
"(load \"host/chez/seed/prelude.ss\")"
|
||||
'prelude
|
||||
"(load \"host/chez/post-prelude.ss\")"
|
||||
"(set-chez-ns! \"user\")"
|
||||
"(load \"host/chez/host-contract.ss\")"
|
||||
"(load \"host/chez/seed/image.ss\")"
|
||||
"(load \"host/chez/compile-eval.ss\")"
|
||||
'image
|
||||
'compile-eval
|
||||
"(load \"host/chez/png.ss\")"
|
||||
"(load \"host/chez/loader.ss\")"
|
||||
"(load \"host/chez/ffi.ss\")"
|
||||
"(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.
|
||||
(define (bld-load-path line)
|
||||
(let ((s (let trim ((i 0))
|
||||
|
|
@ -137,19 +147,21 @@
|
|||
(for-each (lambda (l) (bld-inline-line l out (+ depth 1))) (bld-file-lines p))
|
||||
(begin (put-string out line) (put-string out "\n")))))
|
||||
|
||||
;; Inline the runtime manifest. When drop-compiler? (a closed AOT app that never
|
||||
;; compiles from source at runtime), omit the compiler image + compile-eval shim —
|
||||
;; Inline the runtime manifest, dispatching on the manifest tags. core-strs (the
|
||||
;; 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).
|
||||
(define (bld-emit-runtime out drop-compiler? core-strs)
|
||||
(for-each (lambda (l)
|
||||
(for-each
|
||||
(lambda (entry)
|
||||
(cond
|
||||
;; core-shake: emit the shaken clojure.core defs in place of the blob.
|
||||
((and core-strs (bld-contains? l "seed/prelude.ss"))
|
||||
(for-each (lambda (s) (put-string out s) (put-string out "\n")) core-strs))
|
||||
((and drop-compiler?
|
||||
(or (bld-contains? l "seed/image.ss") (bld-contains? l "compile-eval.ss")))
|
||||
#f)
|
||||
(else (bld-inline-line l out 0))))
|
||||
((eq? entry 'prelude)
|
||||
(if core-strs
|
||||
(for-each (lambda (s) (put-string out s) (put-string out "\n")) core-strs)
|
||||
(bld-inline-line (cdr (assq 'prelude bld-tagged-loads)) out 0)))
|
||||
((memq entry '(image compile-eval))
|
||||
(unless drop-compiler? (bld-inline-line (cdr (assq entry bld-tagged-loads)) out 0)))
|
||||
(else (bld-inline-line entry out 0))))
|
||||
bld-runtime-manifest))
|
||||
|
||||
;; --- app emission -----------------------------------------------------------
|
||||
|
|
@ -158,66 +170,6 @@
|
|||
;; 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))
|
||||
|
||||
;; Tree-shake the whole closed program — the clojure.core prelude (read into records
|
||||
;; by dce-blob-records) AND the re-emitted app + library namespaces — over one
|
||||
;; reachability graph: keep every non-def form (side effects), -main, the core fns the
|
||||
;; runtime shims need, and every def reachable from those; drop the rest. Bails to
|
||||
;; keep-all if reachable code resolves vars by name at runtime (closed-world
|
||||
;; violation). Returns (values core-strs app-strs drop-compiler?); core-strs is #f on
|
||||
;; a bail, signalling "inline prelude.ss unshaken".
|
||||
(define (bld-shake-all core-records app-records entry-main)
|
||||
(let ((all (append core-records app-records))
|
||||
(edges (make-hashtable string-hash string=?))
|
||||
(roots (cons entry-main dce-runtime-core-roots)))
|
||||
(for-each (lambda (r)
|
||||
(if (vector-ref r 0)
|
||||
(set! roots (append (vector-ref r 2) roots))
|
||||
(hashtable-set! edges (vector-ref r 1) (vector-ref r 2))))
|
||||
all)
|
||||
(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))))))))
|
||||
(let ((kept? (lambda (r) (or (vector-ref r 0) (hashtable-ref reached (vector-ref r 1) #f))))
|
||||
(refs-any (lambda (r set) (ormap (lambda (b) (and (member b (vector-ref r 2)) #t)) set)))
|
||||
(bail #f) (bail-why '()) (needs-compiler #f))
|
||||
(for-each (lambda (r)
|
||||
(when (kept? r)
|
||||
(for-each (lambda (b)
|
||||
(when (member b (vector-ref r 2))
|
||||
(set! bail #t)
|
||||
(when (< (length bail-why) 6)
|
||||
(set! bail-why (cons (cons (or (vector-ref r 1) "<form>") b) bail-why)))))
|
||||
dce-bail-refs)
|
||||
(when (refs-any r dce-compile-refs) (set! needs-compiler #t))))
|
||||
all)
|
||||
(let ((drop-compiler? (and (not bail) (not needs-compiler)))
|
||||
;; -> (values strs n-defs n-kept)
|
||||
(pick (lambda (recs)
|
||||
(let loop ((rs recs) (acc '()) (n 0) (k 0))
|
||||
(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 --------------------------------------
|
||||
;; A jolt seq of jolt strings -> a Scheme list of Scheme strings.
|
||||
(define (bld-strs x) (map jolt-str-render-one (seq->list x)))
|
||||
|
|
@ -312,7 +264,7 @@
|
|||
(let*-values
|
||||
(((core-strs app-strs drop-compiler?)
|
||||
(if tree-shake?
|
||||
(bld-shake-all
|
||||
(dce-shake
|
||||
(dce-blob-records "host/chez/seed/prelude.ss")
|
||||
(apply append
|
||||
(map (lambda (nf) (ei-emit-ns-records (car nf) (read-file-string (cdr nf)))) ordered))
|
||||
|
|
|
|||
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?))))))))
|
||||
|
|
@ -84,100 +84,13 @@
|
|||
|
||||
(define (ei-emit-ns ns-name src) (ei-emit-ns* ns-name src #f #t))
|
||||
|
||||
;; --- tree-shaking (jolt build --tree-shake) ---------------------------------
|
||||
;; Reachability DCE over the re-emitted app + library forms: keep -main, every
|
||||
;; side-effecting (non-def) top-level form, and every def reachable from those;
|
||||
;; drop the rest (unused library code). Bails (keeps everything) if the app resolves
|
||||
;; vars by name at runtime (eval/resolve/...), which static reachability can't
|
||||
;; follow. clojure.core / the compiler stay baked (the prelude + image blobs), so
|
||||
;; only the re-emitted namespaces are shaken.
|
||||
(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.
|
||||
;; --- DCE record producer ----------------------------------------------------
|
||||
;; Cross-compile a namespace's source to tree-shaking records — the app/library
|
||||
;; counterpart to dce-blob-records (the prelude). The shake itself and all dce-*
|
||||
;; helpers live in dce.ss; this stays here because it drives the ei-* compiler. A
|
||||
;; top-level def becomes a prunable record; any other form a kept (side-effecting)
|
||||
;; record whose refs are roots. A macro is prunable — its expander isn't called at
|
||||
;; runtime in an AOT build.
|
||||
(define (ei-emit-ns-records ns-name src)
|
||||
(let loop ((forms (ei-read-all src)) (acc '()))
|
||||
(if (null? forms)
|
||||
|
|
@ -192,7 +105,7 @@
|
|||
(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))
|
||||
(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
|
||||
(let* ((ctx (make-analyze-ctx ns-name))
|
||||
(ir (jolt-ce-run-passes (jolt-ce-analyze ctx f) ctx))
|
||||
|
|
@ -200,7 +113,7 @@
|
|||
(fqn (dce-def-fqn ir))
|
||||
(refs (dce-collect-refs '() ir)))
|
||||
(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
|
||||
;; (printable ASCII identifiers only here).
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue