Migrate 4 more .sls files without protocol clauses
ober
9f7ecc6cae419549ef92efea5a2a65ef9635abc3
deleted file mode 100644 --- a/lib/std/effect/multishot.sls +++ /dev/null @@ -1,275 +0,0 @@ -#!chezscheme -;;; (std effect multishot) — Multishot nondeterminism via choice sequences -;;; -;;; Because Chez Scheme's call/1cc continuations (used by (std effect)) are -;;; one-shot, true multishot resumption is achieved via a "choice sequence" -;;; strategy: -;;; -;;; - all-solutions runs thunk multiple times. -;;; - Each run follows a predetermined list of choices. -;;; - When the thunk asks for a choice beyond the end of the list, we -;;; fork: enqueue one run per option (each with the sequence extended -;;; by that option), then abandon the current run. -;;; - Failure (fail) abandons the current run immediately. -;;; -;;; This is equivalent to depth-first backtracking over a lazy search tree. -;;; -;;; The with-multishot-handler form wraps handlers around call/cc so that -;;; the wrapped k objects may be called more than once by user code. -;;; -;;; API: -;;; (choose options) — pick one option (backtracking) -;;; (fail) — backtrack (no result) -;;; (all-solutions thunk) — list of all results -;;; (one-solution thunk) — first result or #f -;;; (sample choices weights) — weighted random pick -;;; (amb e ...) — any-of expression -;;; (amb-all e ...) — all amb choices -;;; (with-multishot-handler ...) — like with-handler but wraps k -;;; (resume/multi k val) — resume a multishot k -;;; multishot-continuation? -;;; defeffect-nondet - -(library (std effect multishot) - (export - with-multishot-handler - resume/multi - defeffect-nondet - choose - fail - all-solutions - one-solution - sample - amb - amb-all - multishot-handler? - multishot-continuation?) - - (import (chezscheme) (std effect)) - - ;; ========== Multishot continuation record ========== - - (define-record-type %multishot-continuation - (fields (immutable proc)) - (sealed #t)) - - (define (multishot-continuation? x) (%multishot-continuation? x)) - (define (multishot-handler? x) #f) ;; frames are just eq-hashtables - - ;; ========== resume/multi ========== - - (define (resume/multi k val) - (if (%multishot-continuation? k) - ((%multishot-continuation-proc k) val) - (k val))) - - ;; ========== with-multishot-handler ========== - ;; - ;; Installs handlers in the regular *effect-handlers* stack, but wraps - ;; each captured continuation in a %multishot-continuation so user code - ;; can identify and potentially store/replay it. - ;; (True multi-invocation still requires call/cc at the site of capture.) - - (define-syntax with-multishot-handler - (lambda (stx) - (define (effect-desc-id eff-name-stx) - (datum->syntax eff-name-stx - (string->symbol - (string-append - (symbol->string (syntax->datum eff-name-stx)) - "::descriptor")))) - - (define (build-op-pair op-clause) - (syntax-case op-clause () - [(op-sym (k arg ...) body ...) - (with-syntax ([k-raw (datum->syntax #'k (gensym "k-raw"))]) - #'(cons 'op-sym - (lambda (k-raw arg ...) - (let ([k (make-%multishot-continuation k-raw)]) - body ...))))])) - - (define (build-effect-entry eff-clause) - (syntax-case eff-clause () - [(eff-name op-clause ...) - (with-syntax ([desc-id (effect-desc-id #'eff-name)] - [(op-pair ...) (map build-op-pair - (syntax->list #'(op-clause ...)))]) - #'(list desc-id op-pair ...))])) - - (syntax-case stx () - [(_ (eff-clause ...) body ...) - (with-syntax ([(entry ...) (map build-effect-entry - (syntax->list #'(eff-clause ...)))] - [frame-id (datum->syntax #'with-multishot-handler - (gensym "mhframe"))]) - #'(let ([frame-id (make-eq-hashtable)]) - (let ([e entry]) - (hashtable-set! frame-id (car e) (cdr e))) - ... - (run-with-handler frame-id (lambda () body ...))))]))) - - ;; ========== Nondeterminism via choice-sequence strategy ========== - - ;; Thread-local hooks installed by all-solutions. - (define *pick-fn* (make-thread-parameter #f)) - (define *fail-fn* (make-thread-parameter #f)) - - ;; Sentinel condition used to abort the current run. - (define-condition-type &ms-exhausted &condition - make-ms-exhausted ms-exhausted?) - - ;; choose: pick one item from options (backtracking if needed). - (define (choose options) - (let ([fn (*pick-fn*)]) - (if fn - (fn options) - ;; Outside all-solutions: just return first option or error - (if (null? options) - (error 'choose "no options available") - (car options))))) - - ;; fail: abandon this branch. - (define fail - (lambda () - (let ([fn (*fail-fn*)]) - (if fn - (fn) - (error 'fail "no backtracking context"))))) - - ;; ========== all-solutions ========== - ;; - ;; Runs thunk with a fresh choice-sequence engine. - - (define (all-solutions thunk) - (let ([pending '()] ;; queue of choice sequences to try - [results '()]) - - ;; Run thunk using a predetermined choices list. - (define (run-with-choices choices) - (let ([idx 0]) - - ;; pick-fn: return the idx-th pre-decided choice, or branch. - (define (pick-fn options) - (if (null? options) - ;; fail immediately - (raise (make-ms-exhausted)) - (let ([my-idx idx]) - (set! idx (+ idx 1)) - (if (>= my-idx (length choices)) - ;; Need to branch: enqueue a run for each option - (begin - (for-each - (lambda (opt) - (set! pending - (append pending - (list (append choices (list opt)))))) - options) - (raise (make-ms-exhausted))) - ;; Use pre-decided choice - (list-ref choices my-idx))))) - - ;; fail-fn: abandon this run. - (define (fail-fn) - (raise (make-ms-exhausted))) - - (parameterize ([*pick-fn* pick-fn] - [*fail-fn* fail-fn]) - (guard (exn [(ms-exhausted? exn) (void)]) - (let ([result (thunk)]) - (set! results (cons result results))))))) - - ;; Seed: one run with empty choice sequence. - (set! pending (list '())) - (let loop () - (unless (null? pending) - (let ([seq (car pending)]) - (set! pending (cdr pending)) - (run-with-choices seq)) - (loop))) - (reverse results))) - - ;; ========== one-solution ========== - ;; - ;; Short-circuits: returns as soon as the first result is found. - ;; Uses an escape continuation to abandon remaining branches. - - (define (one-solution thunk) - (call/cc - (lambda (escape) - (let ([pending '()]) - - (define (run-with-choices choices) - (let ([idx 0]) - - (define (pick-fn options) - (if (null? options) - (raise (make-ms-exhausted)) - (let ([my-idx idx]) - (set! idx (+ idx 1)) - (if (>= my-idx (length choices)) - (begin - ;; Only enqueue; take first immediately - (for-each - (lambda (opt) - (set! pending - (append pending - (list (append choices (list opt)))))) - options) - (raise (make-ms-exhausted))) - (list-ref choices my-idx))))) - - (define (fail-fn) - (raise (make-ms-exhausted))) - - (parameterize ([*pick-fn* pick-fn] - [*fail-fn* fail-fn]) - (guard (exn [(ms-exhausted? exn) (void)]) - (let ([result (thunk)]) - (escape result)))))) - - (set! pending (list '())) - (let loop () - (unless (null? pending) - (let ([seq (car pending)]) - (set! pending (cdr pending)) - (run-with-choices seq)) - (loop))) - #f)))) - - ;; ========== sample ========== - ;; - ;; Weighted random sampling. Weights need not sum to 1. - - (define (sample choices weights) - (when (null? choices) - (error 'sample "empty choices list")) - (let* ([total (apply + weights)] - [target (* (/ (random 1000000) 1000000.0) total)]) - (let loop ([cs choices] [ws weights] [acc 0.0]) - (if (or (null? (cdr cs)) - (< target (+ acc (car ws)))) - (car cs) - (loop (cdr cs) (cdr ws) (+ acc (car ws))))))) - - ;; ========== amb / amb-all macros ========== - - (define-syntax amb - (syntax-rules () - [(_ e ...) - (choose (list e ...))])) - - (define-syntax amb-all - (syntax-rules () - [(_ e ...) - (all-solutions (lambda () (choose (list e ...))))])) - - ;; ========== defeffect-nondet ========== - - (define-syntax defeffect-nondet - (syntax-rules () - [(_ Name) - (defeffect Name - (choose options) - (fail))])) - - ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/effect/multishot.ss @@ -0,0 +1,273 @@ +;;; (std effect multishot) — Multishot nondeterminism via choice sequences +;;; +;;; Because Chez Scheme's call/1cc continuations (used by (std effect)) are +;;; one-shot, true multishot resumption is achieved via a "choice sequence" +;;; strategy: +;;; +;;; - all-solutions runs thunk multiple times. +;;; - Each run follows a predetermined list of choices. +;;; - When the thunk asks for a choice beyond the end of the list, we +;;; fork: enqueue one run per option (each with the sequence extended +;;; by that option), then abandon the current run. +;;; - Failure (fail) abandons the current run immediately. +;;; +;;; This is equivalent to depth-first backtracking over a lazy search tree. +;;; +;;; The with-multishot-handler form wraps handlers around call/cc so that +;;; the wrapped k objects may be called more than once by user code. +;;; +;;; API: +;;; (choose options) — pick one option (backtracking) +;;; (fail) — backtrack (no result) +;;; (all-solutions thunk) — list of all results +;;; (one-solution thunk) — first result or #f +;;; (sample choices weights) — weighted random pick +;;; (amb e ...) — any-of expression +;;; (amb-all e ...) — all amb choices +;;; (with-multishot-handler ...) — like with-handler but wraps k +;;; (resume/multi k val) — resume a multishot k +;;; multishot-continuation? +;;; defeffect-nondet + +(library (std effect multishot) + (export + with-multishot-handler + resume/multi + defeffect-nondet + choose + fail + all-solutions + one-solution + sample + amb + amb-all + multishot-handler? + multishot-continuation?) + + (import (chezscheme) (std effect) + (only (jerboa core) def defstruct)) + + ;; ========== Multishot continuation record ========== + + (defstruct %multishot-continuation (proc)) + + (def (multishot-continuation? x) (%multishot-continuation? x)) + (def (multishot-handler? x) #f) ;; frames are just eq-hashtables + + ;; ========== resume/multi ========== + + (def (resume/multi k val) + (if (%multishot-continuation? k) + ((%multishot-continuation-proc k) val) + (k val))) + + ;; ========== with-multishot-handler ========== + ;; + ;; Installs handlers in the regular *effect-handlers* stack, but wraps + ;; each captured continuation in a %multishot-continuation so user code + ;; can identify and potentially store/replay it. + ;; (True multi-invocation still requires call/cc at the site of capture.) + + (define-syntax with-multishot-handler + (lambda (stx) + (define (effect-desc-id eff-name-stx) + (datum->syntax eff-name-stx + (string->symbol + (string-append + (symbol->string (syntax->datum eff-name-stx)) + "::descriptor")))) + + (define (build-op-pair op-clause) + (syntax-case op-clause () + [(op-sym (k arg ...) body ...) + (with-syntax ([k-raw (datum->syntax #'k (gensym "k-raw"))]) + #'(cons 'op-sym + (lambda (k-raw arg ...) + (let ([k (make-%multishot-continuation k-raw)]) + body ...))))])) + + (define (build-effect-entry eff-clause) + (syntax-case eff-clause () + [(eff-name op-clause ...) + (with-syntax ([desc-id (effect-desc-id #'eff-name)] + [(op-pair ...) (map build-op-pair + (syntax->list #'(op-clause ...)))]) + #'(list desc-id op-pair ...))])) + + (syntax-case stx () + [(_ (eff-clause ...) body ...) + (with-syntax ([(entry ...) (map build-effect-entry + (syntax->list #'(eff-clause ...)))] + [frame-id (datum->syntax #'with-multishot-handler + (gensym "mhframe"))]) + #'(let ([frame-id (make-eq-hashtable)]) + (let ([e entry]) + (hashtable-set! frame-id (car e) (cdr e))) + ... + (run-with-handler frame-id (lambda () body ...))))]))) + + ;; ========== Nondeterminism via choice-sequence strategy ========== + + ;; Thread-local hooks installed by all-solutions. + (def *pick-fn* (make-thread-parameter #f)) + (def *fail-fn* (make-thread-parameter #f)) + + ;; Sentinel condition used to abort the current run. + (define-condition-type &ms-exhausted &condition + make-ms-exhausted ms-exhausted?) + + ;; choose: pick one item from options (backtracking if needed). + (def (choose options) + (let ([fn (*pick-fn*)]) + (if fn + (fn options) + ;; Outside all-solutions: just return first option or error + (if (null? options) + (error 'choose "no options available") + (car options))))) + + ;; fail: abandon this branch. + (def fail + (lambda () + (let ([fn (*fail-fn*)]) + (if fn + (fn) + (error 'fail "no backtracking context"))))) + + ;; ========== all-solutions ========== + ;; + ;; Runs thunk with a fresh choice-sequence engine. + + (def (all-solutions thunk) + (let ([pending '()] ;; queue of choice sequences to try + [results '()]) + + ;; Run thunk using a predetermined choices list. + (define (run-with-choices choices) + (let ([idx 0]) + + ;; pick-fn: return the idx-th pre-decided choice, or branch. + (define (pick-fn options) + (if (null? options) + ;; fail immediately + (raise (make-ms-exhausted)) + (let ([my-idx idx]) + (set! idx (+ idx 1)) + (if (>= my-idx (length choices)) + ;; Need to branch: enqueue a run for each option + (begin + (for-each + (lambda (opt) + (set! pending + (append pending + (list (append choices (list opt)))))) + options) + (raise (make-ms-exhausted))) + ;; Use pre-decided choice + (list-ref choices my-idx))))) + + ;; fail-fn: abandon this run. + (define (fail-fn) + (raise (make-ms-exhausted))) + + (parameterize ([*pick-fn* pick-fn] + [*fail-fn* fail-fn]) + (guard (exn [(ms-exhausted? exn) (void)]) + (let ([result (thunk)]) + (set! results (cons result results))))))) + + ;; Seed: one run with empty choice sequence. + (set! pending (list '())) + (let loop () + (unless (null? pending) + (let ([seq (car pending)]) + (set! pending (cdr pending)) + (run-with-choices seq)) + (loop))) + (reverse results))) + + ;; ========== one-solution ========== + ;; + ;; Short-circuits: returns as soon as the first result is found. + ;; Uses an escape continuation to abandon remaining branches. + + (def (one-solution thunk) + (call/cc + (lambda (escape) + (let ([pending '()]) + + (define (run-with-choices choices) + (let ([idx 0]) + + (define (pick-fn options) + (if (null? options) + (raise (make-ms-exhausted)) + (let ([my-idx idx]) + (set! idx (+ idx 1)) + (if (>= my-idx (length choices)) + (begin + ;; Only enqueue; take first immediately + (for-each + (lambda (opt) + (set! pending + (append pending + (list (append choices (list opt)))))) + options) + (raise (make-ms-exhausted))) + (list-ref choices my-idx))))) + + (define (fail-fn) + (raise (make-ms-exhausted))) + + (parameterize ([*pick-fn* pick-fn] + [*fail-fn* fail-fn]) + (guard (exn [(ms-exhausted? exn) (void)]) + (let ([result (thunk)]) + (escape result)))))) + + (set! pending (list '())) + (let loop () + (unless (null? pending) + (let ([seq (car pending)]) + (set! pending (cdr pending)) + (run-with-choices seq)) + (loop))) + #f)))) + + ;; ========== sample ========== + ;; + ;; Weighted random sampling. Weights need not sum to 1. + + (def (sample choices weights) + (when (null? choices) + (error 'sample "empty choices list")) + (let* ([total (apply + weights)] + [target (* (/ (random 1000000) 1000000.0) total)]) + (let loop ([cs choices] [ws weights] [acc 0.0]) + (if (or (null? (cdr cs)) + (< target (+ acc (car ws)))) + (car cs) + (loop (cdr cs) (cdr ws) (+ acc (car ws))))))) + + ;; ========== amb / amb-all macros ========== + + (define-syntax amb + (syntax-rules () + [(_ e ...) + (choose (list e ...))])) + + (define-syntax amb-all + (syntax-rules () + [(_ e ...) + (all-solutions (lambda () (choose (list e ...))))])) + + ;; ========== defeffect-nondet ========== + + (define-syntax defeffect-nondet + (syntax-rules () + [(_ Name) + (defeffect Name + (choose options) + (fail))])) + + ) ;; end library deleted file mode 100644 --- a/lib/std/effect/scoped.sls +++ /dev/null @@ -1,136 +0,0 @@ -#!chezscheme -;;; (std effect scoped) — Scoped effect handlers (Koka-style) -;;; -;;; Scoped handlers that persist across resumptions and support -;;; multi-shot continuations for nondeterminism. -;;; -;;; API: -;;; (with-scoped-handler clauses body) — scoped handler (re-installs on resume) -;;; (scoped-amb body) — nondeterministic choice via scoped handler -;;; (scoped-state init body) — state threading via scoped handler -;;; (scoped-collect body) — collect all results from nondeterminism - -(library (std effect scoped) - (export with-scoped-handler scoped-perform - scoped-amb scoped-state scoped-collect - scoped-reader) - - (import (chezscheme)) - - ;; ========== Scoped handler via parameter + call/cc ========== - ;; - ;; A scoped handler installs an operation dispatch table as a thread - ;; parameter. Operations look up the current handler to dispatch. - ;; The handler persists across resumes because it's parameter-based. - - (define *scoped-ops* (make-thread-parameter '())) - - (define (scoped-lookup op-name) - (let loop ([ops (*scoped-ops*)]) - (cond - [(null? ops) #f] - [(eq? (caar ops) op-name) (cdar ops)] - [else (loop (cdr ops))]))) - - (define (scoped-perform op-name . args) - (let ([handler (scoped-lookup op-name)]) - (unless handler - (error 'scoped-perform "no handler for operation" op-name)) - (apply handler args))) - - ;; with-scoped-handler: install named operations for the dynamic extent - ;; Each clause: (op-name (args ...) body ...) - (define-syntax with-scoped-handler - (syntax-rules () - [(_ ((op-name (arg ...) body ...) ...) expr ...) - (parameterize ([*scoped-ops* - (append (list (cons 'op-name (lambda (arg ...) body ...)) ...) - (*scoped-ops*))]) - expr ...)])) - - ;; ========== scoped-amb: nondeterministic choice ========== - ;; Uses call/cc for multi-shot: the handler resumes multiple times. - - (define (scoped-amb thunk) - (let ([results '()]) - ;; flip: returns #t and #f in separate branches - (with-scoped-handler - ((flip () - (call/cc - (lambda (k) - ;; First branch: return #t - ;; But also schedule #f branch - (set! results - (append results - (let ([saved results]) - ;; Run the #f branch - (set! results '()) - (k #f) - results))) - #t)))) - ;; This won't work with call/cc naively due to one-shot nature. - ;; Instead use the choice-sequence approach: - (void)) - ;; Simpler approach: use all-solutions from multishot - results)) - - ;; Practical scoped-amb: uses explicit choice list - (define-syntax scoped-collect - (syntax-rules () - [(_ body ...) - (let ([results '()]) - (define (run-with choices) - (let ([idx 0]) - (with-scoped-handler - ((choose (options) - (if (null? options) - (raise 'scoped-fail) - (if (>= idx (length choices)) - ;; Fork: enqueue all options - (begin - (for-each - (lambda (opt) - (set! pending - (append pending - (list (append choices (list opt)))))) - options) - (raise 'scoped-fail)) - ;; Use pre-decided choice - (let ([c (list-ref choices idx)]) - (set! idx (+ idx 1)) - c)))) - (fail () - (raise 'scoped-fail))) - (guard (exn [(eq? exn 'scoped-fail) (void)]) - (let ([r (begin body ...)]) - (set! results (cons r results))))))) - (define pending (list '())) - (let loop () - (unless (null? pending) - (let ([seq (car pending)]) - (set! pending (cdr pending)) - (run-with seq)) - (loop))) - (reverse results))])) - - ;; ========== scoped-state: pure state via scoped handler ========== - - (define-syntax scoped-state - (syntax-rules () - [(_ init body ...) - (let ([state init]) - (with-scoped-handler - ((get () state) - (put (v) (set! state v) (void))) - body ...))])) - - ;; ========== scoped-reader: read-only environment ========== - - (define-syntax scoped-reader - (syntax-rules () - [(_ env-val body ...) - (with-scoped-handler - ((ask () env-val)) - body ...)])) - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/effect/scoped.ss @@ -0,0 +1,102 @@ +;;; (std effect scoped) — Scoped effect handlers (Koka-style) + +(library (std effect scoped) + (export with-scoped-handler scoped-perform + scoped-amb scoped-state scoped-collect + scoped-reader) + + (import (chezscheme) + (only (jerboa core) def)) + + (def *scoped-ops* (make-thread-parameter '())) + + (def (scoped-lookup op-name) + (let loop ([ops (*scoped-ops*)]) + (cond + [(null? ops) #f] + [(eq? (caar ops) op-name) (cdar ops)] + [else (loop (cdr ops))]))) + + (def (scoped-perform op-name . args) + (let ([handler (scoped-lookup op-name)]) + (unless handler + (error 'scoped-perform "no handler for operation" op-name)) + (apply handler args))) + + (define-syntax with-scoped-handler + (syntax-rules () + [(_ ((op-name (arg ...) body ...) ...) expr ...) + (parameterize ([*scoped-ops* + (append (list (cons 'op-name (lambda (arg ...) body ...)) ...) + (*scoped-ops*))]) + expr ...)])) + + (def (scoped-amb thunk) + (let ([results '()]) + (with-scoped-handler + ((flip () + (call/cc + (lambda (k) + (set! results + (append results + (let ([saved results]) + (set! results '()) + (k #f) + results))) + #t)))) + (void)) + results)) + + (define-syntax scoped-collect + (syntax-rules () + [(_ body ...) + (let ([results '()]) + (define (run-with choices) + (let ([idx 0]) + (with-scoped-handler + ((choose (options) + (if (null? options) + (raise 'scoped-fail) + (if (>= idx (length choices)) + (begin + (for-each + (lambda (opt) + (set! pending + (append pending + (list (append choices (list opt)))))) + options) + (raise 'scoped-fail)) + (let ([c (list-ref choices idx)]) + (set! idx (+ idx 1)) + c)))) + (fail () + (raise 'scoped-fail))) + (guard (exn [(eq? exn 'scoped-fail) (void)]) + (let ([r (begin body ...)]) + (set! results (cons r results))))))) + (define pending (list '())) + (let loop () + (unless (null? pending) + (let ([seq (car pending)]) + (set! pending (cdr pending)) + (run-with seq)) + (loop))) + (reverse results))])) + + (define-syntax scoped-state + (syntax-rules () + [(_ init body ...) + (let ([state init]) + (with-scoped-handler + ((get () state) + (put (v) (set! state v) (void))) + body ...))])) + + (define-syntax scoped-reader + (syntax-rules () + [(_ env-val body ...) + (with-scoped-handler + ((ask () env-val)) + body ...)])) + +) deleted file mode 100644 --- a/lib/std/secure/wasm-target.sls +++ /dev/null @@ -1,1446 +0,0 @@ -#!chezscheme -;;; (std secure wasm-target) -- Slang-to-WASM compilation target -;;; -;;; Alternative backend for the Slang compiler that produces a WASM binary -;;; instead of a Chez Scheme .wpo file. The WASM binary runs inside a -;;; Rust wasmi interpreter with host-provided I/O imports. -;;; -;;; Pipeline: -;;; 1. Parse and validate Slang source (reuses (std secure compiler)) -;;; 2. Lambda-lift closures to top-level functions -;;; 3. Lower Slang forms to compile-program's expression language -;;; 4. Prepend runtime (tagged values, allocator, Scheme primitives) -;;; 5. Add host imports for I/O (WASI-like) -;;; 6. Compile to WASM binary via compile-program -;;; -;;; The output is a .wasm file suitable for: -;;; - Loading into wasmi (Rust) with fuel metering -;;; - Loading into the Jerboa WASM runtime for testing -;;; -;;; Architecture: -;;; Host (Rust/wasmi) WASM module -;;; ├─ socket I/O ├─ DNS parsing -;;; ├─ event loop ├─ CDB lookup -;;; ├─ fd management ├─ Response building -;;; └─ OS sandbox └─ Business logic -;;; -;;; The host calls exported WASM functions (init, process_query, etc.) -;;; and the WASM module calls imported host functions (fd_read, fd_write, etc.). - -(library (std secure wasm-target) - (export - ;; Main compilation entry points - slang-compile-wasm ;; source-path -> bytevector (WASM binary) - slang-compile-wasm-file ;; source-path output-path -> void - - ;; Pipeline stages (for testing/debugging) - slang->wasm-forms ;; slang-module -> list of compile-program forms - slang-lower-form ;; single Slang form -> compile-program form(s) - - ;; Host import specifications - wasi-import-forms ;; WASI-compatible host imports - dns-host-import-forms ;; DNS-specific host imports - ) - - (import (except (chezscheme) compile-program) - (std secure compiler) - (jerboa wasm codegen) - (jerboa wasm values) - (jerboa wasm gc) - (jerboa wasm closure)) - - ;; ================================================================ - ;; Host import declarations - ;; ================================================================ - - ;; WASI-compatible imports for basic I/O - (define wasi-import-forms - '(;; fd_read(fd, iovs_ptr, iovs_len, nread_ptr) -> errno - (define-import "wasi_snapshot_preview1" fd_read (i32 i32 i32 i32) (i32)) - ;; fd_write(fd, iovs_ptr, iovs_len, nwritten_ptr) -> errno - (define-import "wasi_snapshot_preview1" fd_write (i32 i32 i32 i32) (i32)) - ;; clock_time_get(clock_id, precision, time_ptr) -> errno - (define-import "wasi_snapshot_preview1" clock_time_get (i32 i64 i32) (i32)) - ;; random_get(buf_ptr, buf_len) -> errno - (define-import "wasi_snapshot_preview1" random_get (i32 i32) (i32)) - ;; proc_exit(code) -> noreturn - (define-import "wasi_snapshot_preview1" proc_exit (i32) ()))) - - ;; DNS-specific host imports (for jerboa-dns) - (define dns-host-import-forms - '(;; recv_packet(buf_ptr, buf_max) -> packet_len (-1 on error) - ;; Host calls recvfrom on the pre-opened UDP socket - (define-import "dns" recv_packet (i32 i32) (i32)) - - ;; send_packet(buf_ptr, buf_len, addr_ptr, addr_len) -> bytes_sent - ;; Host calls sendto to reply to the querying address - (define-import "dns" send_packet (i32 i32 i32 i32) (i32)) - - ;; cdb_open(path_ptr, path_len) -> cdb_handle (-1 on error) - ;; Host opens a CDB file and returns a handle - (define-import "dns" cdb_open (i32 i32) (i32)) - - ;; cdb_find(handle, key_ptr, key_len, val_buf, val_max) -> val_len - ;; Host performs CDB lookup, writes value to val_buf - (define-import "dns" cdb_find (i32 i32 i32 i32 i32) (i32)) - - ;; cdb_close(handle) -> 0 - (define-import "dns" cdb_close (i32) (i32)) - - ;; log_message(level, msg_ptr, msg_len) -> 0 - ;; Host writes log message to stderr/syslog - (define-import "dns" log_message (i32 i32 i32) (i32)) - - ;; get_time_ms() -> milliseconds (i32) - ;; Host returns current monotonic time - (define-import "dns" get_time_ms () (i32)))) - - ;; ================================================================ - ;; Slang form lowering - ;; ================================================================ - - ;; Lower a single Slang top-level form to compile-program forms. - ;; Returns a list of forms (may expand to multiple defines). - (define (slang-lower-form form) - (cond - ;; Import declarations — skip (handled separately) - [(and (pair? form) (eq? (car form) 'import)) - '()] - - ;; slang-module declaration — skip (already parsed) - [(and (pair? form) (eq? (car form) 'slang-module)) - '()] - - ;; Function definition - [(and (pair? form) (eq? (car form) 'define) (pair? (cadr form))) - (let* ([sig (cadr form)] - [name (car sig)] - [params (cdr sig)] - [body (cddr form)]) - ;; Lower the body expressions - (let* ([lowered-body (map lower-expr body)] - ;; Optimize self-recursive tail calls to return-call - [optimized-body (tail-call-optimize name lowered-body)]) - (list `(define (,name ,@(lower-params params)) ,@optimized-body))))] - - ;; Variable definition - [(and (pair? form) (eq? (car form) 'define) (symbol? (cadr form))) - (list `(define (,(gensym-init (cadr form))) - (global.set ,(cadr form) ,(lower-expr (caddr form)))))] - - ;; Top-level expression (wrap in init function) - [(pair? form) - (list `(define (,(gensym-init 'top-level)) - ,(lower-expr form)))] - - [else '()])) - - ;; Generate a unique init function name for top-level expressions - (define init-counter 0) - (define (gensym-init base) - (set! init-counter (+ init-counter 1)) - (string->symbol - (string-append "__init_" - (symbol->string base) "_" - (number->string init-counter)))) - - ;; Lower parameters: strip type annotations, keep names. - ;; Handles dotted lists for rest args: (x y . rest) → (x y . rest) - (define (lower-params params) - (define (strip-param p) - (cond - [(symbol? p) p] - ;; (name type) -> name - [(and (pair? p) (symbol? (car p))) (car p)] - [else p])) - (let loop ([ps params]) - (cond - [(null? ps) '()] - ;; -> return type annotation — stop here - [(and (pair? ps) (eq? (car ps) '->)) '()] - ;; Dotted tail (rest arg): (x . rest) where rest is a symbol - [(symbol? ps) ps] - ;; Normal parameter - [(pair? ps) - (cons (strip-param (car ps)) (loop (cdr ps)))] - [else ps]))) - - ;; ================================================================ - ;; Tail call optimization: self-recursive calls → return-call - ;; ================================================================ - - ;; Transform the last expression in a body: if it's a self-call, emit return-call. - ;; Walks into if/cond/let/begin to find tail positions. - (define (tail-call-optimize fname body) - (if (null? body) - body - ;; Only the last expression is in tail position - (let ([prefix (reverse (cdr (reverse body)))] - [last-expr (car (reverse body))]) - (append prefix (list (tco-expr fname last-expr)))))) - - (define (tco-expr fname expr) - (cond - [(not (pair? expr)) expr] - [else - (let ([head (car expr)] [args (cdr expr)]) - (cond - ;; Self-call in tail position → return-call - [(eq? head fname) - `(return-call ,fname ,@args)] - - ;; if: both branches are tail positions - [(eq? head 'if) - (if (null? (cddr args)) - ;; (if test then) — only then branch - `(if ,(car args) ,(tco-expr fname (cadr args))) - ;; (if test then else) - `(if ,(car args) - ,(tco-expr fname (cadr args)) - ,(tco-expr fname (caddr args))))] - - ;; when: body is tail position - [(eq? head 'when)