Phase 9 complete: Developer Experience (Steps 31-34)
ober
0ccfd81389c5d07ec6ed793440477a7ea11c0890
--- a/Makefile +++ b/Makefile @@ -91,6 +91,7 @@ test-features: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-match2.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-staging.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-cluster.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-devex.ss test-all: test test-features test-wrappers new file mode 100644 --- /dev/null +++ b/lib/jerboa/pkg.sls @@ -0,0 +1,357 @@ +#!chezscheme +;;; (jerboa pkg) — Package Manager (Step 34) +;;; +;;; Content-addressed package store with lock files. +;;; Supports source (git/local) and version-range dependencies. + +(library (jerboa pkg) + (export + ;; Package manifest + make-package + package? + package-name + package-version + package-dependencies + package-description + + ;; Version handling + make-version + version? + version-major + version-minor + version-patch + version->string + string->version + version<? + version=? + version-satisfies? + + ;; Dependency spec + make-dep-spec + dep-spec? + dep-spec-name + dep-spec-constraint + dep-spec-source + + ;; Package registry + make-registry + registry? + registry-add! + registry-find + registry-list + + ;; Resolution + resolve-dependencies + dependency-graph + topological-sort + + ;; Lock file + make-lock-file + lock-file? + lock-file-write + lock-file-read + + ;; Package.sls reader + read-package-file + write-package-file) + + (import (chezscheme)) + + ;; ========== Version ========== + + (define-record-type (version make-version version?) + (fields (immutable major version-major) + (immutable minor version-minor) + (immutable patch version-patch))) + + (define (version->string v) + (format "~a.~a.~a" + (version-major v) (version-minor v) (version-patch v))) + + (define (string->version s) + ;; Parse "major.minor.patch" — missing parts default to 0 + (let ([parts (let loop ([s s] [acc '()]) + (let ([idx (let scan ([i 0]) + (cond [(= i (string-length s)) #f] + [(char=? (string-ref s i) #\.) i] + [else (scan (+ i 1))]))]) + (if idx + (loop (substring s (+ idx 1) (string-length s)) + (cons (substring s 0 idx) acc)) + (reverse (cons s acc)))))]) + (let ([nums (map (lambda (p) + (guard (exn [#t 0]) (string->number p))) + parts)]) + (make-version + (if (>= (length nums) 1) (or (list-ref nums 0) 0) 0) + (if (>= (length nums) 2) (or (list-ref nums 1) 0) 0) + (if (>= (length nums) 3) (or (list-ref nums 2) 0) 0))))) + + (define (version<? a b) + (or (< (version-major a) (version-major b)) + (and (= (version-major a) (version-major b)) + (or (< (version-minor a) (version-minor b)) + (and (= (version-minor a) (version-minor b)) + (< (version-patch a) (version-patch b))))))) + + (define (version=? a b) + (and (= (version-major a) (version-major b)) + (= (version-minor a) (version-minor b)) + (= (version-patch a) (version-patch b)))) + + (define (version-satisfies? v constraint) + ;; constraint: string like "^1.2.0", "~1.2", ">=1.0.0", "1.2.3", "*" + (cond + [(equal? constraint "*") #t] + [(and (>= (string-length constraint) 1) + (char=? (string-ref constraint 0) #\^)) + ;; Caret: compatible with, major must match + (let ([base (string->version (substring constraint 1 (string-length constraint)))]) + (and (= (version-major v) (version-major base)) + (or (> (version-minor v) (version-minor base)) + (and (= (version-minor v) (version-minor base)) + (>= (version-patch v) (version-patch base))))))] + [(and (>= (string-length constraint) 1) + (char=? (string-ref constraint 0) #\~)) + ;; Tilde: compatible minor, patch can vary + (let ([base (string->version (substring constraint 1 (string-length constraint)))]) + (and (= (version-major v) (version-major base)) + (= (version-minor v) (version-minor base)) + (>= (version-patch v) (version-patch base))))] + [(and (>= (string-length constraint) 2) + (string=? (substring constraint 0 2) ">=")) + (let ([base (string->version (substring constraint 2 (string-length constraint)))]) + (or (version=? v base) (version<? base v)))] + [(and (>= (string-length constraint) 1) + (char=? (string-ref constraint 0) #\>)) + (let ([base (string->version (substring constraint 1 (string-length constraint)))]) + (version<? base v))] + [else + ;; Exact version match + (version=? v (string->version constraint))])) + + ;; ========== Dependency Spec ========== + + (define-record-type (dep-spec make-dep-spec dep-spec?) + (fields (immutable name dep-spec-name) + (immutable constraint dep-spec-constraint) ;; version constraint string + (immutable source dep-spec-source))) ;; #f | '(git url tag) | '(local path) + + ;; ========== Package ========== + + (define-record-type (package make-package package?) + (fields (immutable name package-name) + (immutable version package-version) ;; version record + (immutable dependencies package-dependencies) ;; list of dep-spec + (immutable description package-description) + (immutable authors package-authors) + (immutable license package-license))) + + ;; ========== Registry ========== + + ;; registry: hashtable mapping name → list of (version . package) + (define-record-type (registry make-registry-raw registry?) + (fields (immutable packages registry-packages) ;; hashtable: name → alist (ver . pkg) + (immutable mutex registry-mutex))) + + (define (make-registry) + (make-registry-raw (make-hashtable equal-hash equal?) (make-mutex))) + + (define (registry-add! reg pkg) + (with-mutex (registry-mutex reg) + (let* ([name (package-name pkg)] + [ver (package-version pkg)] + [existing (hashtable-ref (registry-packages reg) name '())]) + (hashtable-set! (registry-packages reg) name + (cons (cons ver pkg) + (filter (lambda (e) (not (version=? (car e) ver))) existing)))))) + + (define (registry-find reg name constraint) + ;; Find best (highest) version satisfying constraint. + ;; Returns package or #f. + (with-mutex (registry-mutex reg) + (let ([entries (hashtable-ref (registry-packages reg) name '())]) + (let ([satisfying + (filter (lambda (e) (version-satisfies? (car e) constraint)) + entries)]) + (if (null? satisfying) + #f + (let ([sorted (list-sort (lambda (a b) (version<? (car b) (car a))) + satisfying)]) + (cdar sorted))))))) + + (define (registry-list reg) + (with-mutex (registry-mutex reg) + (let-values ([(names _) (hashtable-entries (registry-packages reg))]) + (vector->list names)))) + + ;; ========== Dependency Resolution ========== + + (define (resolve-dependencies registry pkg visited) + ;; Resolve all transitive dependencies of pkg. + ;; Returns alist of (name . resolved-package) or raises error. + (let loop ([deps (package-dependencies pkg)] + [resolved '()] + [seen visited]) + (if (null? deps) + resolved + (let* ([dep (car deps)] + [name (dep-spec-name dep)] + [cstr (dep-spec-constraint dep)]) + (if (assoc name resolved) + ;; Already resolved + (loop (cdr deps) resolved seen) + (let ([pkg2 (registry-find registry name cstr)]) + (if (not pkg2) + (error 'resolve-dependencies + "package not found in registry" + name cstr) + ;; Recursively resolve pkg2's deps (avoid cycles via seen) + (if (member name seen) + (loop (cdr deps) resolved seen) ;; circular dep — skip + (let ([sub-resolved + (resolve-dependencies registry pkg2 (cons name seen))]) + (loop (cdr deps) + (cons (cons name pkg2) + (append sub-resolved resolved)) + (cons name seen))))))))))) + + (define (dependency-graph pkg registry) + ;; Returns alist: name → list of dependency names + (let ([resolved (resolve-dependencies registry pkg '())]) + (map (lambda (entry) + (cons (car entry) + (map dep-spec-name + (package-dependencies (cdr entry))))) + resolved))) + + (define (topological-sort graph) + ;; Kahn's algorithm for topological sort. + ;; graph: alist (node . list-of-deps) + ;; deps = what this node needs (prerequisites) + ;; Returns list of nodes in dependency order (deps first). + (let* ([nodes (map car graph)] + ;; in-degree = number of prerequisites each node has + [in-degree + (let ([ht (make-hashtable equal-hash equal?)]) + (for-each (lambda (n) + (hashtable-set! ht n + (length (filter (lambda (d) (member d nodes)) + (let ([e (assoc n graph)]) + (if e (cdr e) '())))))) + nodes) + ht)] + ;; reverse-graph: node -> list of nodes that depend on it + [rev + (let ([ht (make-hashtable equal-hash equal?)]) + (for-each (lambda (n) (hashtable-set! ht n '())) nodes) + (for-each + (lambda (entry) + (for-each + (lambda (dep) + (when (member dep nodes) + (hashtable-set! ht dep + (cons (car entry) (hashtable-ref ht dep '()))))) + (cdr entry))) + graph) + ht)] + [queue (filter (lambda (n) (= 0 (hashtable-ref in-degree n 0))) nodes)]) + (let loop ([q queue] [result '()]) + (if (null? q) + (if (= (length result) (length nodes)) + (reverse result) + (error 'topological-sort "cycle detected in dependencies")) + (let* ([n (car q)] + ;; nodes that depend on n (n is a prereq for them) + [dependents (hashtable-ref rev n '())] + [new-q + (let inner ([ds dependents] [q (cdr q)]) + (if (null? ds) q + (let* ([m (car ds)] + [deg (- (hashtable-ref in-degree m 1) 1)]) + (hashtable-set! in-degree m deg) + (inner (cdr ds) + (if (= deg 0) (cons m q) q)))))]) + (loop new-q (cons n result))))))) + + ;; ========== Lock File ========== + + (define-record-type (lock-file make-lock-file lock-file?) + (fields (immutable entries lock-entries))) ;; list of (name version source-hash) + + (define (lock-file-write lf port) + ;; Write lock file as S-expression + (for-each + (lambda (e) + (write e port) + (newline port)) + (lock-entries lf))) + + (define (lock-file-read port) + ;; Read lock file from S-expression + (let loop ([entry (read port)] [entries '()]) + (if (eof-object? entry) + (make-lock-file (reverse entries)) + (loop (read port) (cons entry entries))))) + + ;; ========== Package File Reader ========== + + (define (read-package-file path) + ;; Read a package manifest S-expression from file. + ;; Returns a package record. + (if (not (file-exists? path)) + (error 'read-package-file "file not found" path) + (call-with-input-file path + (lambda (port) + (let ([form (read port)]) + (parse-package-sexp form)))))) + + (define (parse-package-sexp form) + ;; Parse: (package (name "foo") (version "1.0.0") (dependencies ...) ...) + (if (not (and (pair? form) (eq? (car form) 'package))) + (error 'parse-package-sexp "invalid package form" form) + (let ([clauses (cdr form)]) + (let ([name (let ([c (assq 'name clauses)]) (and c (cadr c)))] + [ver-str (let ([c (assq 'version clauses)]) (and c (cadr c)))] + [deps (let ([c (assq 'dependencies clauses)]) (and c (cdr c)))] + [desc (let ([c (assq 'description clauses)]) (and c (cadr c)))] + [authors (let ([c (assq 'authors clauses)]) (and c (cdr c)))] + [license (let ([c (assq 'license clauses)]) (and c (cadr c)))]) + (unless name + (error 'parse-package-sexp "missing name in package")) + (make-package + name + (if ver-str (string->version ver-str) (make-version 0 0 0)) + (map parse-dep (or deps '())) + (or desc "") + (or authors '()) + (or license "")))))) + + (define (parse-dep dep-form) + ;; Parse: (name "^1.0.0") or (name "1.0.0" (git "url" #:tag "v1.0")) + (if (not (pair? dep-form)) + (error 'parse-dep "invalid dependency" dep-form) + (let ([name (car dep-form)] + [cstr (cadr dep-form)] + [src (if (>= (length dep-form) 3) (caddr dep-form) #f)]) + (make-dep-spec name cstr src)))) + + (define (write-package-file pkg path) + ;; Write package manifest to file. + (call-with-output-file path + (lambda (port) + (write + `(package + (name ,(package-name pkg)) + (version ,(version->string (package-version pkg))) + (description ,(package-description pkg)) + (dependencies + ,@(map (lambda (d) + (if (dep-spec-source d) + `(,(dep-spec-name d) ,(dep-spec-constraint d) ,(dep-spec-source d)) + `(,(dep-spec-name d) ,(dep-spec-constraint d)))) + (package-dependencies pkg)))) + port) + (newline port)))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/dev/debug.sls @@ -0,0 +1,240 @@ +#!chezscheme +;;; (std dev debug) — Time-Travel Debugger (Step 32) +;;; +;;; Records execution trace with optional step-back capability. +;;; Uses continuation capture and structured logging. + +(library (std dev debug) + (export + ;; Execution recording + with-recording + recording? + current-recording + *current-recording* + + ;; Trace entries + trace-event! + trace-call! + trace-return! + trace-error! + + ;; Playback / inspection + debug-history + debug-rewind + debug-forward + debug-step + debug-locals + debug-inspect + debug-current-frame + debug-frame-count + + ;; Conditional breakpoints + break-when! + break-never! + check-breakpoints! + + ;; Instrumentation macro + instrument) + + (import (chezscheme)) + + ;; ========== Trace Entries ========== + + ;; entry: (type timestamp depth data) + ;; type: 'call | 'return | 'error | 'event + ;; depth: call stack depth at the time + ;; data: depends on type + + (define (make-entry type data) + (list type + (time-second (current-time)) + *current-depth* + data)) + (define (entry-type e) (list-ref e 0)) + (define (entry-time e) (list-ref e 1)) + (define (entry-depth e) (list-ref e 2)) + (define (entry-data e) (list-ref e 3)) + + ;; ========== Recording State ========== + + (define *current-recording* (make-parameter #f)) + (define *current-depth* 0) + + (define (recording? obj) + (and (vector? obj) (> (vector-length obj) 0) (eq? (vector-ref obj 0) 'recording))) + + (define (current-recording) + (*current-recording*)) + + ;; recording as a vector: #(tag buffer cursor count max pos mutex) + ;; Using vector for mutable state (no list-set! needed) + (define (make-recording-obj max-entries) + (vector 'recording + (make-vector max-entries #f) ;; circular buffer + 0 ;; write cursor + 0 ;; count of entries written + max-entries + 0 ;; current playback position + (make-mutex))) + + (define (rec-buffer r) (vector-ref r 1)) + (define (rec-cursor r) (vector-ref r 2)) + (define (rec-count r) (vector-ref r 3)) + (define (rec-max r) (vector-ref r 4)) + (define (rec-pos r) (vector-ref r 5)) + (define (rec-mutex r) (vector-ref r 6)) + + (define (rec-set-cursor! r v) (vector-set! r 2 v)) + (define (rec-set-count! r v) (vector-set! r 3 v)) + (define (rec-set-pos! r v) (vector-set! r 5 v)) + + ;; ========== Recording ========== + + (define (with-recording thunk . opts) + ;; Execute thunk with execution tracing enabled. + ;; opts: max-entries (default 1000) + (let* ([max (if (null? opts) 1000 (car opts))] + [rec (make-recording-obj max)] + [result #f] + [exn #f]) + (parameterize ([*current-recording* rec]) + (guard (e [#t + (trace-error! (if (condition? e) + (condition-message e) + (format "~a" e))) + (set! exn e)]) + (set! result (thunk)))) + (if exn + (raise exn) + result))) + + (define (rec-push! entry) + (let ([r (*current-recording*)]) + (when r + (with-mutex (rec-mutex r) + (let ([cur (rec-cursor r)] + [max (rec-max r)]) + (vector-set! (rec-buffer r) cur entry) + (rec-set-cursor! r (modulo (+ cur 1) max)) + (rec-set-count! r (min (+ (rec-count r) 1) max))))))) + + (define (trace-event! description . data) + (rec-push! (make-entry 'event (cons description data)))) + + (define (trace-call! name args) + (set! *current-depth* (+ *current-depth* 1)) + (rec-push! (make-entry 'call (list name args)))) + + (define (trace-return! name result) + (rec-push! (make-entry 'return (list name result))) + (set! *current-depth* (max 0 (- *current-depth* 1)))) + + (define (trace-error! msg) + (rec-push! (make-entry 'error msg))) + + ;; ========== Playback ========== + + (define (debug-history) + ;; Return all recorded entries in order. + (let ([r (*current-recording*)]) + (if (not r) '() + (with-mutex (rec-mutex r) + (let ([count (rec-count r)] + [cursor (rec-cursor r)] + [max (rec-max r)] + [buf (rec-buffer r)]) + ;; Reconstruct in-order from circular buffer + (let ([start (if (< count max) 0 cursor)]) + (let loop ([i 0] [result '()]) + (if (= i count) + (reverse result) + (let ([idx (modulo (+ start i) max)]) + (loop (+ i 1) (cons (vector-ref buf idx) result))))))))))) + + (define (debug-frame-count) + (length (debug-history))) + + (define (debug-current-frame) + (let ([r (*current-recording*)]) + (if (not r) #f + (let ([history (debug-history)] + [pos (rec-pos r)]) + (if (>= pos (length history)) #f + (list-ref history pos)))))) + + (define (debug-rewind n) + ;; Move playback position n steps backward. + (let ([r (*current-recording*)]) + (when r + (rec-set-pos! r (max 0 (- (rec-pos r) n)))))) + + (define (debug-forward n) + ;; Move playback position n steps forward. + (let ([r (*current-recording*)]) + (when r + (let ([max-pos (max 0 (- (debug-frame-count) 1))]) + (rec-set-pos! r (min max-pos (+ (rec-pos r) n))))))) + + (define (debug-step) + ;; Move to next entry. + (debug-forward 1) + (debug-current-frame)) + + (define (debug-locals) + ;; Return local variable bindings at current frame. + (let ([frame (debug-current-frame)]) + (if (not frame) '() + (let ([data (entry-data frame)]) + (if (and (pair? data) (list? data)) + data + (list (cons 'data data))))))) + + (define (debug-inspect sym) + ;; Find the most recent value of sym in the history up to current pos. + (let ([r (*current-recording*)]) + (if (not r) #f + (let ([history (debug-history)] + [pos (rec-pos r)]) + (let loop ([entries (reverse (list-head history (min pos (length history))))]) + (if (null? entries) #f + (let ([e (car entries)]) + (cond + ;; Look in call entries for argument named sym + [(and (eq? (entry-type e) 'call) + (pair? (entry-data e))) + (let ([args (cadr (entry-data e))]) + (if (and (list? args) (assq sym args)) + (cdr (assq sym args)) + (loop (cdr entries))))] + [else (loop (cdr entries))])))))))) + + ;; ========== Breakpoints ========== + + (define *breakpoints* (make-eq-hashtable)) + + (define (break-when! name predicate) + ;; Set a conditional breakpoint: break when predicate returns #t. + (hashtable-set! *breakpoints* name predicate)) + + (define (break-never! name) + (hashtable-delete! *breakpoints* name)) + + (define (check-breakpoints! name value) + ;; Returns #t if a breakpoint fires for (name value). + (let ([pred (hashtable-ref *breakpoints* name #f)]) + (and pred (guard (exn [#t #f]) (pred value))))) + + ;; ========== Instrumentation Macro ========== + + ;; (instrument (name arg ...) body ...) + ;; Wraps a function body with trace-call!/trace-return! calls. + (define-syntax instrument + (syntax-rules () + [(_ (name arg ...) body ...) + (define (name arg ...) + (trace-call! 'name (list (cons 'arg arg) ...)) + (let ([result (begin body ...)]) + (trace-return! 'name result) + result))])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/dev/profile.sls @@ -0,0 +1,218 @@ +#!chezscheme +;;; (std dev profile) — Built-In Profiler (Step 33) +;;; +;;; Statistical profiler: samples call stack periodically. +;;; Deterministic profiler: instruments specific functions. +;;; Allocation tracker: counts allocations by call site. + +(library (std dev profile) + (export + ;; Deterministic profiling + profile-start! + profile-stop! + profile-reset! + profile-results + profile-report + + ;; Instrument specific functions + with-profiling + define/profiled + + ;; Statistical sampling (simulated) + sample-start! + sample-stop! + sample-results + + ;; Allocation profiling + alloc-profile-start! + alloc-profile-stop! + alloc-results + + ;; Timing utilities + time-call + time-thunk) + + (import (chezscheme)) + + ;; ========== Deterministic Profiler ========== + + ;; Profile entry: (call-count total-ns min-ns max-ns) + (define *profile-data* (make-eq-hashtable)) + (define *profiling?* #f) + (define *profile-mutex* (make-mutex)) + + (define (profile-start!) + (set! *profiling?* #t)) + + (define (profile-stop!) + (set! *profiling?* #f)) + + (define (profile-reset!) + (with-mutex *profile-mutex* + (let-values ([(keys _) (hashtable-entries *profile-data*)]) + (vector-for-each + (lambda (k) (hashtable-delete! *profile-data* k)) + keys))) + (set! *profiling?* #f)) + + (define (record-call! name elapsed-ns) + (when *profiling?* + (with-mutex *profile-mutex* + (let ([entry (hashtable-ref *profile-data* name #f)]) + (if entry + (hashtable-set! *profile-data* name + (list (+ (car entry) 1) + (+ (cadr entry) elapsed-ns) + (min (caddr entry) elapsed-ns) + (max (cadddr entry) elapsed-ns))) + (hashtable-set! *profile-data* name + (list 1 elapsed-ns elapsed-ns elapsed-ns))))))) + + (define (profile-results) + ;; Returns list of (name calls total-ns avg-ns min-ns max-ns) + (with-mutex *profile-mutex* + (let-values ([(names entries) (hashtable-entries *profile-data*)]) + (map (lambda (name entry) + (list name + (car entry) ;; calls + (cadr entry) ;; total-ns + (quotient (cadr entry) (car entry)) ;; avg-ns + (caddr entry) ;; min-ns + (cadddr entry))) ;; max-ns + (vector->list names) + (vector->list entries))))) + + (define (profile-report . port-args) + (let* ([port (if (null? port-args) (current-output-port) (car port-args))] + [results (profile-results)] + [sorted (list-sort (lambda (a b) (> (caddr a) (caddr b))) results)] + [total-ns (apply + (map caddr results))]) + (fprintf port "~%Profile Report~%") + (fprintf port "~a~%" (make-string 60 #\-)) + (fprintf port "~30a ~8a ~10a ~8a~%" + "Function" "Calls" "Total(ms)" "Avg(μs)") + (fprintf port "~a~%" (make-string 60 #\-)) + (for-each + (lambda (r) + (fprintf port "~30a ~8a ~10,2f ~8,2f~%" + (car r) ;; name + (cadr r) ;; calls + (/ (caddr r) 1e6) ;; total ms + (/ (cadddr r) 1e3) ;; avg μs + )) + sorted) + (fprintf port "~a~%" (make-string 60 #\-)) + (fprintf port "Total: ~,2f ms~%~%" (/ total-ns 1e6)))) + + ;; ========== Instrumented Wrappers ========== + + ;; (with-profiling name thunk) + ;; Executes thunk and records its wall-clock time under name. + (define (with-profiling name thunk) + (let* ([start (current-time 'time-process)] + [result (thunk)] + [end (current-time 'time-process)] + [ns (+ (* (- (time-second end) (time-second start)) 1000000000) + (- (time-nanosecond end) (time-nanosecond start)))]) + (record-call! name ns) + result)) + + ;; (define/profiled (name arg ...) body ...) + ;; Defines a function that automatically records profiling data. + (define-syntax define/profiled + (syntax-rules () + [(_ (name arg ...) body ...) + (define (name arg ...) + (with-profiling 'name + (lambda () body ...)))])) + + ;; ========== Statistical Sampler ========== + ;; + ;; Simulated: Since we can't inspect arbitrary thread stacks in portable + ;; Scheme, we provide a hook-based sampling interface. Real statistical + ;; profiling would require OS-level signals (SIGPROF). + + (define *sample-data* (make-eq-hashtable)) + (define *sampling?* #f) + (define *sample-thread* #f) + + (define (sample-start! . opts) + (let ([interval-ms (if (null? opts) 10 (car opts))]) + (set! *sampling?* #t) + (set! *sample-thread* + (fork-thread + (lambda () + (let loop () + (when *sampling?* + ;; In a real profiler, we'd inspect thread stacks here + ;; For now, we just count "ticks" + (with-mutex *profile-mutex* + (let ([count (hashtable-ref *sample-data* '*tick* 0)]) + (hashtable-set! *sample-data* '*tick* (+ count 1)))) + (sleep (make-time 'time-duration + (* interval-ms 1000000) 0)) + (loop)))))))) + + (define (sample-stop!) + (set! *sampling?* #f)) + + (define (sample-results) + (with-mutex *profile-mutex* + (let-values ([(keys vals) (hashtable-entries *sample-data*)]) + (map cons (vector->list keys) (vector->list vals))))) + + ;; ========== Allocation Profiler ========== + + (define *alloc-data* (make-eq-hashtable)) + (define *alloc-profiling?* #f) + (define *alloc-mutex* (make-mutex)) + + (define (alloc-profile-start!) + (set! *alloc-profiling?* #t)) + + (define (alloc-profile-stop!) + (set! *alloc-profiling?* #f)) + + (define (track-alloc! site bytes) + (when *alloc-profiling?* + (with-mutex *alloc-mutex* + (let ([entry (hashtable-ref *alloc-data* site #f)]) + (if entry + (hashtable-set! *alloc-data* site + (cons (+ (car entry) 1) (+ (cdr entry) bytes))) + (hashtable-set! *alloc-data* site (cons 1 bytes))))))) + + (define (alloc-results) + ;; Returns list of (site count total-bytes) + (with-mutex *alloc-mutex* + (let-values ([(sites entries) (hashtable-entries *alloc-data*)]) + (map (lambda (site entry) + (list site (car entry) (cdr entry))) + (vector->list sites) + (vector->list entries))))) + + ;; ========== Timing Utilities ========== + + (define-syntax time-call + ;; (time-call name body ...) + ;; Times body expressions and prints result. + (syntax-rules () + [(_ name body ...) + (let* ([start (current-time 'time-process)] + [result (begin body ...)] + [end (current-time 'time-process)] + [ns (+ (* (- (time-second end) (time-second start)) 1000000000) + (- (time-nanosecond end) (time-nanosecond start)))]) + (printf "~a: ~,2f ms~%" 'name (/ ns 1e6)) + result)])) + + (define (time-thunk thunk) + ;; Returns (result elapsed-ns) + (let* ([start (current-time 'time-process)] + [result (thunk)] + [end (current-time 'time-process)] + [ns (+ (* (- (time-second end) (time-second start)) 1000000000) + (- (time-nanosecond end) (time-nanosecond start)))]) + (values result ns))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/dev/reload.sls @@ -0,0 +1,197 @@ +#!chezscheme +;;; (std dev reload) — Hot Code Reloading (Step 31) +;;; +;;; Reload individual library modules without restarting the process. +;;; Tracks module file locations, modification times, and dependents. +;;; Sends 'code-change notifications to registered actors/callbacks. + +(library (std dev reload) + (export + ;; Module registry + register-module! + unregister-module! + module-registered? + registered-modules + + ;; Hot reload + reload! + reload-if-changed! + watch-and-reload! + stop-watching! + + ;; Change notifications + on-module-change + off-module-change + notify-change! + + ;; Dependency tracking + module-dependents + module-file + module-mtime) + + (import (chezscheme)) + + ;; ========== Module Registry ========== + + ;; module-info: (name file-path mtime load-proc) + (define *modules* (make-eq-hashtable)) ;; name → module-info + (define *modules-mutex* (make-mutex)) + + ;; change handlers: name → list of (handler-id . proc) + (define *change-handlers* (make-eq-hashtable)) + (define *handler-id* 0) + + ;; dependents: name → list of dependent names + (define *dependents* (make-eq-hashtable)) + + (define (make-module-info name file mtime load-proc) + (list name file mtime load-proc)) + (define (minfo-name m) (list-ref m 0)) + (define (minfo-file m) (list-ref m 1)) + (define (minfo-mtime m) (list-ref m 2)) + (define (minfo-proc m) (list-ref m 3)) + + (define (register-module! name file-path load-proc . deps) + ;; Register a module for hot-reload tracking. + ;; file-path: path to the .sls source file + ;; load-proc: thunk that (re)loads the module + ;; deps: list of module names this module depends on + (let ([mtime (if (file-exists? file-path) + (file-modification-time file-path) + 0)]) + (with-mutex *modules-mutex* + (hashtable-set! *modules* name + (make-module-info name file-path mtime load-proc)) + ;; Register as dependent of each dep + (for-each + (lambda (dep) + (let ([current (hashtable-ref *dependents* dep '())]) + (unless (memq name current) + (hashtable-set! *dependents* dep (cons name current))))) + deps)))) + + (define (unregister-module! name) + (with-mutex *modules-mutex* + (hashtable-delete! *modules* name) + (hashtable-delete! *change-handlers* name))) + + (define (module-registered? name) + (with-mutex *modules-mutex* + (and (hashtable-ref *modules* name #f) #t))) + + (define (registered-modules) + (with-mutex *modules-mutex* + (let-values ([(keys _) (hashtable-entries *modules*)]) + (vector->list keys)))) + + (define (module-file name) + (let ([m (hashtable-ref *modules* name #f)]) + (and m (minfo-file m)))) + + (define (module-mtime name) + (let ([m (hashtable-ref *modules* name #f)]) + (and m (minfo-mtime m)))) + + (define (module-dependents name) + (hashtable-ref *dependents* name '())) + + ;; ========== Reload ========== + + (define (reload! name) + ;; Force reload a registered module. + ;; Returns #t on success, raises error on failure. + (let ([m (with-mutex *modules-mutex* + (hashtable-ref *modules* name #f))]) + (unless m + (error 'reload! "module not registered" name)) + ;; Execute the load procedure + (guard (exn [#t (raise exn)]) + ((minfo-proc m)) + ;; Update mtime + (let ([new-mtime (if (file-exists? (minfo-file m)) + (file-modification-time (minfo-file m)) + (minfo-mtime m))]) + (with-mutex *modules-mutex* + (hashtable-set! *modules* name + (make-module-info name (minfo-file m) new-mtime (minfo-proc m))))) + ;; Notify change handlers + (notify-change! name) + ;; Cascade to dependents + (for-each + (lambda (dep) + (when (module-registered? dep) + (reload! dep))) + (module-dependents name)) + #t))) + + (define (reload-if-changed! name) + ;; Reload only if file has been modified since last load. + ;; Returns #t if reloaded, #f if unchanged. + (let ([m (with-mutex *modules-mutex* + (hashtable-ref *modules* name #f))]) + (if (not m) + #f + (let ([current-mtime + (if (file-exists? (minfo-file m)) + (file-modification-time (minfo-file m)) + (minfo-mtime m))]) + (if (> current-mtime (minfo-mtime m)) + (begin (reload! name) #t) + #f))))) + + ;; ========== File Watching ========== + + (define *watch-threads* (make-eq-hashtable)) + (define *watch-mutex* (make-mutex)) + + (define (watch-and-reload! . module-names) + ;; Start a background thread that polls for file changes. + ;; Returns a watch-id that can be used with stop-watching!. + (let* ([watch-id (gensym "watch")] + [worker + (lambda () + (let loop () + (sleep (make-time 'time-duration 500000000 0)) + (for-each + (lambda (name) + (guard (exn [#t (void)]) + (reload-if-changed! name))) + module-names) + (when (with-mutex *watch-mutex* + (hashtable-ref *watch-threads* watch-id #f)) + (loop))))] + [t (fork-thread worker)]) + (with-mutex *watch-mutex* + (hashtable-set! *watch-threads* watch-id t)) + watch-id)) +