Retropikzel
/
scheme-libraries
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Move wasm library forward

This commit is contained in:
retropikzel 2026-05-10 16:01:32 +03:00
parent 4f96a986ef
commit 0dec5b8f37
7 changed files with 190 additions and 153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -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 && COMPILE_R7RS=${SCHEME} CSC_OPIONS="-L -lcurl" compile-r7rs -o test-program -I . test.${SFX}
cd .tmp && ./test-program cd .tmp && ./test-program
test-docker: testfiles test-docker: package testfiles
cd .tmp && \ 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" \ APT_PACKAGES="libcurl4-openssl-dev" \
AKKU_PACKAGES="akku-r7rs" \ AKKU_PACKAGES="akku-r7rs" \
DOCKER_TAG=${DOCKER_TAG} \ DOCKER_TAG=${DOCKER_TAG} \

234
retropikzel/wasm.scm
View File

@ -1,10 +1,27 @@
(define (get-function-names wat) (define (get-data wat)
(filter-map (car
(lambda (item) (filter-map
(if (and (equal? (car item) 'export) (assq 'func item)) (lambda (item)
(cons (cadr (assq 'func item)) (string->symbol (cadr item))) (if (equal? (car item) 'data)
#f)) (let ((bytes
(cdr wat))) (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) (define (get-global-export-names wat)
(filter-map (filter-map
@ -26,14 +43,14 @@
(cdr wat))) (cdr wat)))
#;(define (get-memory-export-names wat) #;(define (get-memory-export-names wat)
(filter-map (filter-map
(lambda (item) (lambda (item)
(if (and (equal? (car item) 'export) (assq 'memory item)) (if (and (equal? (car item) 'export) (assq 'memory item))
(string->symbol (string->symbol
(string-append "memory-" (string-append "memory-"
(symbol->string (cadr (assq 'memory item))))) (symbol->string (cadr (assq 'memory item)))))
#f)) #f))
(cdr wat))) (cdr wat)))
(define (get-memories wat) (define (get-memories wat)
(filter-map (filter-map
@ -41,144 +58,67 @@
(cond (cond
((equal? (car item) 'memory) ((equal? (car item) 'memory)
(let* ((sizes (list-tail item 2)) (let* ((sizes (list-tail item 2))
(size (cond ((= (length sizes) 1) (size (* (cond ((= (length sizes) 1)
(list-ref sizes 0)) (list-ref sizes 0))
(else (list-ref sizes 1))))) (else (list-ref sizes 1)))
`(vector-set! memory-index webassembly-page-size)))
,(string->number `(vector-set! memory-index
(string-copy (symbol->string (list-ref item 1)) ,(string->number
1)) (string-copy (symbol->string (list-ref item 1))
(make-vector ,size 0)))) 1))
(make-bytevector ,size 0))))
(else #f))) (else #f)))
(cdr wat))) (cdr wat)))
(define (symbol-append sym1 sym2) (define (get-function-names wat)
(string->symbol (string-append (symbol->string sym1) (symbol->string sym2)))) (filter-map
(lambda (item)
(define (char-index str c) (if (and (equal? (car item) 'export) (assq 'func item))
(letrec* (cons (cadr (assq 'func item)) (string->symbol (cadr item)))
((looper #f))
(lambda (index) (cdr wat)))
(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-functions function-names wat) (define (get-functions function-names wat)
(filter-map (filter-map
(lambda (item) (lambda (item)
(if (equal? (car item) 'func) (if (equal? (car item) 'func)
(let ((name (if (assq (list-ref item 1) function-names) (let* ((name (if (assq (list-ref item 1) function-names)
(cdr (assq (list-ref item 1) function-names)) (cdr (assq (list-ref item 1) function-names))
(list-ref item 1))) (list-ref item 1)))
(params (filter-map (params (filter-map
(lambda (item) (lambda (item)
(if (and (list? item) (equal? (car item) 'param)) (if (and (list? item) (equal? (car item) 'param))
(list-ref item 1) (list-ref item 1)
#f)) #f))
(cdr item))) (cdr item)))
(return (filter-map (return (filter-map
(lambda (item) (lambda (item)
(if (and (list? item) (if (and (list? item)
(equal? (car item) 'return)) (equal? (car item) 'return))
item item
#f)) #f))
(cdr item))) (cdr item)))
(body (filter-map (body `(call-with-current-continuation
(lambda (item) (lambda (return)
(if (and (list? item) ,@(cdr (filter-map
(equal? (car item) 'param)) (lambda (item)
#f (if (and (list? item)
(body-item->sexp item))) (equal? (car item) 'param))
(cdr item)))) #f
(list-set! item 0 'define) (body-item->sexp item)))
(list-set! item 1 name) (cdr item))))))
`(define ,name (result `(define ,name
(lambda ,params (lambda ,params
(call-with-current-continuation ,body))))
(lambda (return) (if (equal? body '(call-with-current-continuation (lambda (return))))
,@(cdr body)))))) #f
result))
#f)) #f))
(cdr wat))) (cdr wat)))
(define (wat-module->r7rs-library library-name port) (define (wat-module->r7rs-library library-name port)
(let* ((wat (read port)) (let* ((wat (read port))
(data (get-data wat))
(global-export-names (get-global-export-names wat)) (global-export-names (get-global-export-names wat))
(globals (get-globals wat)) (globals (get-globals wat))
;(memory-export-names (get-memory-export-names wat)) ;(memory-export-names (get-memory-export-names wat))
@ -192,10 +132,16 @@
`(define-library `(define-library
,library-name ,library-name
(import (scheme base) (import (scheme base)
(scheme write)
(only (r6rs bytevectors)
endianness
bytevector-s32-set!
bytevector-s32-ref)
(srfi 60)) (srfi 60))
(export ,@exports) (export ,@exports)
(begin (begin
(define memory-index (make-vector 8)) (define memory-index (make-vector 5243936 (make-bytevector 5243936 0)))
,@memories ,@memories
,@globals (bytevector-copy! (vector-ref memory-index 0) ,(car data) ,(cdr data))
,@functions)))) ,@globals
,@functions))))

4
retropikzel/wasm.sld
View File

@ -3,6 +3,8 @@
(import (scheme base) (import (scheme base)
(scheme read) (scheme read)
(scheme write) (scheme write)
(srfi 1)) (srfi 1)
(r6rs bytevectors))
(export wat-module->r7rs-library) (export wat-module->r7rs-library)
(include "wasm/util.scm")
(include "wasm.scm")) (include "wasm.scm"))

5
retropikzel/wasm/plus.c
View File

@ -8,10 +8,11 @@
#define EXTERN #define EXTERN
#endif #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) { EXTERN EMSCRIPTEN_KEEPALIVE int plus(int a, int b) {
return a + b; return a + b + x;
} }
/* /*

5
retropikzel/wasm/test.scm
View File

@ -2,9 +2,8 @@
(define testdir "retropikzel/wasm") (define testdir "retropikzel/wasm")
(define testfile1 (string-append testdir "/" "plus.wat")) (define testfile1 (string-append testdir "/" "plus.wat"))
(define testfile2 (string-append "/tmp/test/tr7.wat")) (define lib (wat-module->r7rs-library '(wasmtestlibrary) (open-input-file testfile1)))
(define lib (wat-module->r7rs-library '(testlibrary) (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") (test-end "wasm")

89
retropikzel/wasm/util.scm Normal file
View File

@ -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)))

2
test-headers.scm
View File

@ -4,8 +4,8 @@
(scheme char) (scheme char)
(scheme file) (scheme file)
(scheme process-context) (scheme process-context)
(scheme show)
(srfi 64) (srfi 64)
(srfi 166)
;(retropikzel mouth) ;(retropikzel mouth)
;(retropikzel ctrf) ;(retropikzel ctrf)
(retropikzel LIBRARY)) (retropikzel LIBRARY))