WASM: add result type (ok/err) runtime and lowering rules
ober
70e92f9e2e321d2b51ea7c00fb29eb613af7dd5f
--- a/lib/jerboa/wasm/closure.sls +++ b/lib/jerboa/wasm/closure.sls @@ -467,7 +467,10 @@ scheme-list-ref scheme-assq scheme-memq scheme-bytevector-copy intern-symbol string-from-static - to-bool scheme-bool->wasm)] + to-bool scheme-bool->wasm + scheme-ok scheme-err scheme-ok? scheme-err? + scheme-unwrap scheme-unwrap-or + scheme-result-value scheme-map-ok)] [bound-with-runtime (append runtime-names all-bound)] [free-vars (free-variables `(begin ,@body) bound-with-runtime)] ;; Generate lifted function name --- a/lib/jerboa/wasm/scheme-runtime.sls +++ b/lib/jerboa/wasm/scheme-runtime.sls @@ -29,6 +29,7 @@ runtime-equality-forms runtime-conversion-forms runtime-io-forms + runtime-result-forms runtime-all-forms ) @@ -518,6 +519,64 @@ )) ;; ================================================================ + ;; Result type operations (ok/err) + ;; ================================================================ + + ;; Results are represented as pairs: + ;; (ok x) → pair where car = tagged fixnum 1, cdr = x + ;; (err x) → pair where car = tagged fixnum 0, cdr = x + ;; This gives us O(1) construction and access. + + (define RESULT-OK-TAG (bitwise-ior (bitwise-arithmetic-shift-left 1 2) 1)) ;; tagged fixnum 1 = 5 + (define RESULT-ERR-TAG (bitwise-ior (bitwise-arithmetic-shift-left 0 2) 1)) ;; tagged fixnum 0 = 1 + + (define runtime-result-forms + `( + ;; Construct an ok result + (define (scheme-ok val) + (cons-val ,RESULT-OK-TAG val)) + + ;; Construct an err result + (define (scheme-err val) + (cons-val ,RESULT-ERR-TAG val)) + + ;; Check if result is ok (car == tagged 1) + (define (scheme-ok? r) + (if (is-pair r) + (if (= (pair-car r) ,RESULT-OK-TAG) 2 0) ;; 2=#t, 0=#f + 0)) + + ;; Check if result is err (car == tagged 0) + (define (scheme-err? r) + (if (is-pair r) + (if (= (pair-car r) ,RESULT-ERR-TAG) 2 0) + 0)) + + ;; Unwrap an ok result (returns value or traps) + (define (scheme-unwrap r) + (if (= (pair-car r) ,RESULT-OK-TAG) + (pair-cdr r) + (unreachable))) + + ;; Unwrap with default: return value if ok, default if err + (define (scheme-unwrap-or r default-val) + (if (= (pair-car r) ,RESULT-OK-TAG) + (pair-cdr r) + default-val)) + + ;; Map over ok value: (map-ok f result) + ;; If ok, apply f to the value; if err, pass through + (define (scheme-map-ok f-result r) + ;; f-result is the result of applying f — caller must inline the call + ;; This version is for the lowered form where the call is already done + r) + + ;; Extract ok value (for lowering; callers guard with ok?) + (define (scheme-result-value r) + (pair-cdr r)) + )) + + ;; ================================================================ ;; Combined: all runtime forms ;; ================================================================ @@ -530,6 +589,7 @@ runtime-comparison-forms runtime-equality-forms runtime-conversion-forms - runtime-io-forms)) + runtime-io-forms + runtime-result-forms)) ) ;; end library --- a/lib/std/secure/wasm-target.sls +++ b/lib/std/secure/wasm-target.sls @@ -415,6 +415,58 @@ ,(lower-expr (cadr args)) ,(lower-expr (caddr args)))] + ;; ---- Result type operations ---- + [(ok) + `(scheme-ok ,(lower-expr (car args)))] + [(err) + `(scheme-err ,(lower-expr (car args)))] + [(ok?) + `(wasm-bool->scheme (scheme-ok? ,(lower-expr (car args))))] + [(err?) + `(wasm-bool->scheme (scheme-err? ,(lower-expr (car args))))] + [(unwrap) + `(scheme-unwrap ,(lower-expr (car args)))] + [(unwrap-or) + `(scheme-unwrap-or ,(lower-expr (car args)) + ,(lower-expr (cadr args)))] + [(map-ok) + ;; (map-ok f result) → if ok, wrap (f value) in ok; else pass err + (let ([f-expr (lower-expr (car args))] + [r-expr (lower-expr (cadr args))]) + `(let ([__mo_r ,r-expr]) + (if (scheme-ok? __mo_r) + (scheme-ok (,f-expr (scheme-result-value __mo_r))) + __mo_r)))] + [(map-err) + ;; (map-err f result) → if err, wrap (f value) in err; else pass ok + (let ([f-expr (lower-expr (car args))] + [r-expr (lower-expr (cadr args))]) + `(let ([__me_r ,r-expr]) + (if (scheme-err? __me_r) + (scheme-err (,f-expr (scheme-result-value __me_r))) + __me_r)))] + [(and-then) + ;; (and-then result f) → if ok, (f value); else pass err + (let ([r-expr (lower-expr (car args))] + [f-expr (lower-expr (cadr args))]) + `(let ([__at_r ,r-expr]) + (if (scheme-ok? __at_r) + (,f-expr (scheme-result-value __at_r)) + __at_r)))] + [(->?) + ;; (->? result (f) (g)) → thread through ok values + ;; (->? init f1 f2 ...) where each fi takes one arg and returns result + (let loop ([r-expr (lower-expr (car args))] + [fns (cdr args)]) + (if (null? fns) + r-expr + (let ([f-expr (lower-expr (car fns))]) + (loop `(let ([__pipe_r ,r-expr]) + (if (scheme-ok? __pipe_r) + (,f-expr (scheme-result-value __pipe_r)) + __pipe_r)) + (cdr fns)))))] + ;; ---- Higher-order list operations (lowered to while loops) ---- ;; (map f lst) → build result list by calling f on each element --- a/tests/test-slang-wasm.ss +++ b/tests/test-slang-wasm.ss @@ -600,6 +600,54 @@ (check-pred bytevector? wasm) (check (> (bytevector-length wasm) 50) => #t)) +;; ================================================================ +;; Result Type Operations +;; ================================================================ + +(section "Result Type Operations") + +;; runtime-result-forms should be a non-empty list of define forms +(check-pred pair? runtime-result-forms) +(for-each + (lambda (form) + (check (car form) => 'define)) + runtime-result-forms) + +;; Result runtime contains ok, err, ok?, err?, unwrap, unwrap-or +(let ([names (map (lambda (f) + (and (pair? f) (eq? (car f) 'define) (pair? (cadr f)) + (caadr f))) + runtime-result-forms)]) + (check-pred pair? (memq 'scheme-ok names)) + (check-pred pair? (memq 'scheme-err names)) + (check-pred pair? (memq 'scheme-ok? names)) + (check-pred pair? (memq 'scheme-err? names)) + (check-pred pair? (memq 'scheme-unwrap names)) + (check-pred pair? (memq 'scheme-unwrap-or names)) + (check-pred pair? (memq 'scheme-result-value names))) + +;; Result operations compile to valid WASM +(let ([wasm (compile-program + (append + value-memory-forms + value-global-forms + value-tag-forms + value-predicate-forms + value-accessor-forms + gc-all-forms + value-constructor-forms + runtime-all-forms + '((define (test-ok x) + (scheme-ok (tag-fixnum x))) + (define (test-err x) + (scheme-err (tag-fixnum x))) + (define (test-check r) + (if (scheme-ok? r) + (scheme-unwrap r) + (scheme-unwrap-or r (tag-fixnum 0)))))))]) + (check-pred bytevector? wasm) + (check (> (bytevector-length wasm) 100) => #t)) + ;; Full runtime with UTF-8 string-length compiles to valid WASM (let ([wasm (compile-program (append