From 0dec5b8f375e4588502c995b2a2955e7d875a9ce Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 10 May 2026 16:01:32 +0300 Subject: [PATCH] Move wasm library forward --- Makefile | 4 +- retropikzel/wasm.scm | 234 +++++++++++++++----------------------- retropikzel/wasm.sld | 4 +- retropikzel/wasm/plus.c | 5 +- retropikzel/wasm/test.scm | 5 +- retropikzel/wasm/util.scm | 89 +++++++++++++++ test-headers.scm | 2 +- 7 files changed, 190 insertions(+), 153 deletions(-) create mode 100644 retropikzel/wasm/util.scm diff --git a/Makefile b/Makefile index eb7b201..fd15106 100644 --- a/Makefile +++ b/Makefile @@ -49,9 +49,9 @@ test: testfiles cd .tmp && COMPILE_R7RS=${SCHEME} CSC_OPIONS="-L -lcurl" compile-r7rs -o test-program -I . test.${SFX} cd .tmp && ./test-program -test-docker: testfiles +test-docker: package testfiles cd .tmp && \ - SNOW_PACKAGES="srfi.64 srfi.60 srfi.145 srfi.180 retropikzel.mouth ${PKG}" \ + SNOW_PACKAGES="srfi.64 srfi.145 srfi.180 retropikzel.mouth r6rs.bytevectors ${PKG}" \ APT_PACKAGES="libcurl4-openssl-dev" \ AKKU_PACKAGES="akku-r7rs" \ DOCKER_TAG=${DOCKER_TAG} \ diff --git a/retropikzel/wasm.scm b/retropikzel/wasm.scm index 5c23ae8..702de9a 100644 --- a/retropikzel/wasm.scm +++ b/retropikzel/wasm.scm @@ -1,10 +1,27 @@ -(define (get-function-names wat) - (filter-map - (lambda (item) - (if (and (equal? (car item) 'export) (assq 'func item)) - (cons (cadr (assq 'func item)) (string->symbol (cadr item))) - #f)) - (cdr wat))) +(define (get-data wat) + (car + (filter-map + (lambda (item) + (if (equal? (car item) 'data) + (let ((bytes + (filter-map + (lambda (c) + (display "HERE: c ") + (write c) + (newline) + (if (char=? c #\null) + #f + c)) + (string->list (list-ref item 2))))) + (display "HERE: bytes") + (write bytes) + (newline) + (display "HERE: something ") + (write (map (lambda (c) (string->number (string c))) (string->list (list->string bytes)))) + (newline) + (cons (cadr (list-ref item 1)) bytes)) + #f)) + (cdr wat)))) (define (get-global-export-names wat) (filter-map @@ -26,14 +43,14 @@ (cdr wat))) #;(define (get-memory-export-names wat) - (filter-map - (lambda (item) - (if (and (equal? (car item) 'export) (assq 'memory item)) - (string->symbol - (string-append "memory-" - (symbol->string (cadr (assq 'memory item))))) - #f)) - (cdr wat))) +(filter-map + (lambda (item) + (if (and (equal? (car item) 'export) (assq 'memory item)) + (string->symbol + (string-append "memory-" + (symbol->string (cadr (assq 'memory item))))) + #f)) + (cdr wat))) (define (get-memories wat) (filter-map @@ -41,144 +58,67 @@ (cond ((equal? (car item) 'memory) (let* ((sizes (list-tail item 2)) - (size (cond ((= (length sizes) 1) - (list-ref sizes 0)) - (else (list-ref sizes 1))))) - `(vector-set! memory-index - ,(string->number - (string-copy (symbol->string (list-ref item 1)) - 1)) - (make-vector ,size 0)))) + (size (* (cond ((= (length sizes) 1) + (list-ref sizes 0)) + (else (list-ref sizes 1))) + webassembly-page-size))) + `(vector-set! memory-index + ,(string->number + (string-copy (symbol->string (list-ref item 1)) + 1)) + (make-bytevector ,size 0)))) (else #f))) (cdr wat))) -(define (symbol-append sym1 sym2) - (string->symbol (string-append (symbol->string sym1) (symbol->string sym2)))) - -(define (char-index str c) - (letrec* - ((looper - (lambda (index) - (cond ((>= index (string-length str)) -1) - ((char=? c (string-ref str index)) index) - (else (looper (+ index 1))))))) - (looper 0))) - -(define (offset=N->N sym) - (string->number - (string-copy - (symbol->string sym) - (+ (char-index (symbol->string sym) #\=) 1)))) - -(define (symbol-starts-with? sym str) - (if (not (symbol? sym)) - #f - (let ((sym-str (symbol->string sym))) - (and (>= (string-length sym-str) (string-length str)) - (string=? (string-copy sym-str 0 (string-length str)) str))))) - -(define (body-item->sexp item) - (cond ((not (list? item)) item) - ((equal? (car item) 'local) - `(define ,(list-ref item 1) 0)) - ((equal? (car item) 'global.get) - (list-ref item 1)) - ((equal? (car item) 'global.set) - `(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2)))) - ((equal? (car item) 'global.tee) - `(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2)))) - ((equal? (car item) 'local.get) - (list-ref item 1)) - ((equal? (car item) 'local.set) - `(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2)))) - ((equal? (car item) 'local.tee) - `(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2)))) - ((equal? (car item) 'result) - #f) - ((equal? (car item) 'i32.const) - (list-ref item 1)) - ((equal? (car item) 'i32.and) - `(bitwise-and ,@(map body-item->sexp (cdr item)))) - ((equal? (car item) 'i32.add) - `(+ ,@(map body-item->sexp (cdr item)))) - ((equal? (car item) 'i32.sub) - `(- ,@(map body-item->sexp (cdr item)))) - ((equal? (car item) 'i32.store) - `(vector-set! - (vector-ref memory-index - ,(if (list? (list-ref item 2)) - (body-item->sexp (list-ref item 2)) - (list-ref item 2))) - ,(offset=N->N (body-item->sexp (list-ref item 1))) - ,(body-item->sexp (list-ref item 3)))) - ((equal? (car item) 'i32.load) - `(vector-ref - (vector-ref memory-index - ,(if (symbol-starts-with? (list-ref item 1) "offset=") - (offset=N->N (list-ref item 1)) - 0)) - ,(if (symbol-starts-with? (list-ref item 1) "offset=") - (if (list? (list-ref item 2)) - (body-item->sexp (list-ref item 2)) - (body-item->sexp (list-ref item 2))) - (if (list? (list-ref item 1)) - (body-item->sexp (list-ref item 1)) - (body-item->sexp (list-ref item 1)))))) - ((equal? (car item) 'call) - `(,@(map body-item->sexp (cdr item)))) - #;((equal? (car item) 'block) - (display "HERE: block ") - (write (list-tail item 2)) - (newline) - `(call-with-current-continuation - (lambda (,(list-ref item 1)) - ,@(map body-item->sexp (list-tail item 2))))) - #;((or (equal? (car item) 'i32.eqz)) - `(= ,@(map body-item->sexp (cdr item)))) - #;((equal? (car item) 'br_if) - `(when (= 1 ,@(map body-item->sexp (list-tail item 2))) (,(list-ref item 1)))) - (else (map body-item->sexp item))) - ) +(define (get-function-names wat) + (filter-map + (lambda (item) + (if (and (equal? (car item) 'export) (assq 'func item)) + (cons (cadr (assq 'func item)) (string->symbol (cadr item))) + #f)) + (cdr wat))) (define (get-functions function-names wat) (filter-map (lambda (item) (if (equal? (car item) 'func) - (let ((name (if (assq (list-ref item 1) function-names) - (cdr (assq (list-ref item 1) function-names)) - (list-ref item 1))) - (params (filter-map - (lambda (item) - (if (and (list? item) (equal? (car item) 'param)) - (list-ref item 1) - #f)) - (cdr item))) - (return (filter-map - (lambda (item) - (if (and (list? item) - (equal? (car item) 'return)) - item - #f)) - (cdr item))) - (body (filter-map - (lambda (item) - (if (and (list? item) - (equal? (car item) 'param)) - #f - (body-item->sexp item))) - (cdr item)))) - (list-set! item 0 'define) - (list-set! item 1 name) - `(define ,name - (lambda ,params - (call-with-current-continuation - (lambda (return) - ,@(cdr body)))))) + (let* ((name (if (assq (list-ref item 1) function-names) + (cdr (assq (list-ref item 1) function-names)) + (list-ref item 1))) + (params (filter-map + (lambda (item) + (if (and (list? item) (equal? (car item) 'param)) + (list-ref item 1) + #f)) + (cdr item))) + (return (filter-map + (lambda (item) + (if (and (list? item) + (equal? (car item) 'return)) + item + #f)) + (cdr item))) + (body `(call-with-current-continuation + (lambda (return) + ,@(cdr (filter-map + (lambda (item) + (if (and (list? item) + (equal? (car item) 'param)) + #f + (body-item->sexp item))) + (cdr item)))))) + (result `(define ,name + (lambda ,params + ,body)))) + (if (equal? body '(call-with-current-continuation (lambda (return)))) + #f + result)) #f)) (cdr wat))) (define (wat-module->r7rs-library library-name port) (let* ((wat (read port)) + (data (get-data wat)) (global-export-names (get-global-export-names wat)) (globals (get-globals wat)) ;(memory-export-names (get-memory-export-names wat)) @@ -192,10 +132,16 @@ `(define-library ,library-name (import (scheme base) + (scheme write) + (only (r6rs bytevectors) + endianness + bytevector-s32-set! + bytevector-s32-ref) (srfi 60)) (export ,@exports) (begin - (define memory-index (make-vector 8)) - ,@memories - ,@globals - ,@functions)))) + (define memory-index (make-vector 5243936 (make-bytevector 5243936 0))) + ,@memories + (bytevector-copy! (vector-ref memory-index 0) ,(car data) ,(cdr data)) + ,@globals + ,@functions)))) diff --git a/retropikzel/wasm.sld b/retropikzel/wasm.sld index cb7cd6e..203ee62 100644 --- a/retropikzel/wasm.sld +++ b/retropikzel/wasm.sld @@ -3,6 +3,8 @@ (import (scheme base) (scheme read) (scheme write) - (srfi 1)) + (srfi 1) + (r6rs bytevectors)) (export wat-module->r7rs-library) + (include "wasm/util.scm") (include "wasm.scm")) diff --git a/retropikzel/wasm/plus.c b/retropikzel/wasm/plus.c index 3fe07bf..bcde36d 100644 --- a/retropikzel/wasm/plus.c +++ b/retropikzel/wasm/plus.c @@ -8,10 +8,11 @@ #define EXTERN #endif -EXTERN EMSCRIPTEN_KEEPALIVE uint64_t x = 100; +EXTERN EMSCRIPTEN_KEEPALIVE int x = 1; +EXTERN EMSCRIPTEN_KEEPALIVE int y = 50000; EXTERN EMSCRIPTEN_KEEPALIVE int plus(int a, int b) { - return a + b; + return a + b + x; } /* diff --git a/retropikzel/wasm/test.scm b/retropikzel/wasm/test.scm index edbd7a0..aa0e695 100644 --- a/retropikzel/wasm/test.scm +++ b/retropikzel/wasm/test.scm @@ -2,9 +2,8 @@ (define testdir "retropikzel/wasm") (define testfile1 (string-append testdir "/" "plus.wat")) -(define testfile2 (string-append "/tmp/test/tr7.wat")) -(define lib (wat-module->r7rs-library '(testlibrary) (open-input-file testfile1))) +(define lib (wat-module->r7rs-library '(wasmtestlibrary) (open-input-file testfile1))) -(with-output-to-file "/tmp/testwasm/testlibrary.sld" (lambda () (show #t (pretty lib)))) +(with-output-to-file "wasmtestlibrary.sld" (lambda () (show #t (pretty lib)))) (test-end "wasm") diff --git a/retropikzel/wasm/util.scm b/retropikzel/wasm/util.scm new file mode 100644 index 0000000..9a6c654 --- /dev/null +++ b/retropikzel/wasm/util.scm @@ -0,0 +1,89 @@ +(define (body-item->sexp item) + (cond ((not (list? item)) item) + ((equal? (car item) 'local) + `(define ,(list-ref item 1) 0)) + ((equal? (car item) 'global.get) + (list-ref item 1)) + ((equal? (car item) 'global.set) + `(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2)))) + ((equal? (car item) 'global.tee) + `(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2)))) + ((equal? (car item) 'local.get) + (list-ref item 1)) + ((equal? (car item) 'local.set) + `(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2)))) + ((equal? (car item) 'local.tee) + `(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2)))) + ((equal? (car item) 'result) + #f) + ((equal? (car item) 'i32.const) + (list-ref item 1)) + ((equal? (car item) 'i32.and) + `(bitwise-and ,@(map body-item->sexp (cdr item)))) + ((equal? (car item) 'i32.add) + `(+ ,@(map body-item->sexp (cdr item)))) + ((equal? (car item) 'i32.sub) + `(- ,@(map body-item->sexp (cdr item)))) + ((equal? (car item) 'i32.store) + `(bytevector-s32-set! (vector-ref memory-index ,(body-item->sexp (list-ref item 2))) + ,(offset=N->N (list-ref item 1)) + ,(body-item->sexp (list-ref item 3)) + (endianness 'little))) + ((equal? (car item) 'i32.load) + (if (> (length item) 2) + `(bytevector-s32-ref (vector-ref memory-index ,(body-item->sexp (list-ref item 2))) + ,(offset=N->N (list-ref item 1)) + (endianness 'little)) + `(bytevector-s32-ref (vector-ref memory-idex 0) + ,(body-item->sexp (list-ref item 1)) + (endianness 'little)))) + ((equal? (car item) 'call) + `(,@(map body-item->sexp (cdr item)))) + ;((equal? (car item) 'block) (display "HERE: block ") (write (list-tail item 2)) (newline) `(call-with-current-continuation (lambda (,(list-ref item 1)) ,@(map body-item->sexp (list-tail item 2))))) + ;((or (equal? (car item) 'i32.eqz)) `(= ,@(map body-item->sexp (cdr item)))) + ;((equal? (car item) 'br_if) `(when (= 1 ,@(map body-item->sexp (list-tail item 2))) (,(list-ref item 1)))) + (else (map body-item->sexp item)))) + +(define webassembly-page-size 65536) + +(define (symbol-append sym1 sym2) + (string->symbol (string-append (symbol->string sym1) (symbol->string sym2)))) + +(define (char-index str c) + (letrec* + ((looper + (lambda (index) + (cond ((>= index (string-length str)) -1) + ((char=? c (string-ref str index)) index) + (else (looper (+ index 1))))))) + (looper 0))) + +(define (offset=N->N sym) + (string->number + (string-copy + (symbol->string sym) + (+ (char-index (symbol->string sym) #\=) 1)))) + +(define (symbol-starts-with? sym str) + (if (not (symbol? sym)) + #f + (let ((sym-str (symbol->string sym))) + (and (>= (string-length sym-str) (string-length str)) + (string=? (string-copy sym-str 0 (string-length str)) str))))) + +(define string-split + (lambda (str mark) + (let* ((str-l (string->list str)) + (res (list)) + (last-index 0) + (index 0) + (splitter (lambda (c) + (cond ((char=? c mark) + (begin + (set! res (append res (list (string-copy str last-index index)))) + (set! last-index (+ index 1)))) + ((equal? (length str-l) (+ index 1)) + (set! res (append res (list (string-copy str last-index (+ index 1))))))) + (set! index (+ index 1))))) + (for-each splitter str-l) + res))) diff --git a/test-headers.scm b/test-headers.scm index b9ea3d0..ec9db17 100644 --- a/test-headers.scm +++ b/test-headers.scm @@ -4,8 +4,8 @@ (scheme char) (scheme file) (scheme process-context) + (scheme show) (srfi 64) - (srfi 166) ;(retropikzel mouth) ;(retropikzel ctrf) (retropikzel LIBRARY))