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 && ./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} \

154
retropikzel/wasm.scm
View File

@ -1,10 +1,27 @@
(define (get-function-names wat)
(define (get-data wat)
(car
(filter-map
(lambda (item)
(if (and (equal? (car item) 'export) (assq 'func item))
(cons (cadr (assq 'func item)) (string->symbol (cadr 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)))
(cdr wat))))
(define (get-global-export-names wat)
(filter-map
@ -41,110 +58,31 @@
(cond
((equal? (car item) 'memory)
(let* ((sizes (list-tail item 2))
(size (cond ((= (length sizes) 1)
(size (* (cond ((= (length sizes) 1)
(list-ref sizes 0))
(else (list-ref sizes 1)))))
(else (list-ref sizes 1)))
webassembly-page-size)))
`(vector-set! memory-index
,(string->number
(string-copy (symbol->string (list-ref item 1))
1))
(make-vector ,size 0))))
(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)
(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
@ -160,25 +98,27 @@
item
#f))
(cdr item)))
(body (filter-map
(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))))
(list-set! item 0 'define)
(list-set! item 1 name)
`(define ,name
(cdr item))))))
(result `(define ,name
(lambda ,params
(call-with-current-continuation
(lambda (return)
,@(cdr body))))))
,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))
(define memory-index (make-vector 5243936 (make-bytevector 5243936 0)))
,@memories
(bytevector-copy! (vector-ref memory-index 0) ,(car data) ,(cdr data))
,@globals
,@functions))))

4
retropikzel/wasm.sld
View File

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

5
retropikzel/wasm/plus.c
View File

@ -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;
}
/*

5
retropikzel/wasm/test.scm
View File

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

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 file)
(scheme process-context)
(scheme show)
(srfi 64)
(srfi 166)
;(retropikzel mouth)
;(retropikzel ctrf)
(retropikzel LIBRARY))