Move wasm library forward
This commit is contained in:
parent
4f96a986ef
commit
0dec5b8f37
4
Makefile
4
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} \
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -4,8 +4,8 @@
|
|||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(scheme show)
|
||||
(srfi 64)
|
||||
(srfi 166)
|
||||
;(retropikzel mouth)
|
||||
;(retropikzel ctrf)
|
||||
(retropikzel LIBRARY))
|
||||
|
|
|
|||
Loading…
Reference in New Issue