diff --git a/retropikzel/leb128.scm b/retropikzel/leb128.scm index 5de4d6c..a94217a 100644 --- a/retropikzel/leb128.scm +++ b/retropikzel/leb128.scm @@ -137,7 +137,7 @@ (define (read-leb128 port) (when (not (binary-port? port)) (error "read-leb128: port must be binary-port" port)) - (cdr (read-leb128-and-length port))) + (car (read-leb128-and-length port))) (define (read-uleb128-and-length port) (when (not (binary-port? port)) @@ -163,4 +163,4 @@ (define (read-uleb128 port) (when (not (binary-port? port)) (error "read-uleb128: port must be binary-port" port)) - (cdr (read-uleb128-and-length port))) + (car (read-uleb128-and-length port))) diff --git a/retropikzel/leb128/VERSION b/retropikzel/leb128/VERSION index 3eefcb9..524cb55 100644 --- a/retropikzel/leb128/VERSION +++ b/retropikzel/leb128/VERSION @@ -1 +1 @@ -1.0.0 +1.1.1 diff --git a/retropikzel/wasm.scm b/retropikzel/wasm.scm index c8401b0..2ab48ef 100644 --- a/retropikzel/wasm.scm +++ b/retropikzel/wasm.scm @@ -1,8 +1,124 @@ -(define (wasm-bytevector? bytes) - (equal? (bytevector-copy bytes 0 4) (bytevector #x0 #x61 #x73 #x6D))) +(define (list-slice l start end) + (vector->list (vector-copy (list->vector l) start end))) -(define (wasm-version bytes) - (bytevector-copy bytes 4 8)) +(define (byte->type byte) + (cond ((= byte 0) 'void) + ;; Number types + ((= byte #x7C) 'f64) + ((= byte #x7D) 'f32) + ((= byte #x7E) 'i64) + ((= byte #x7F) 'i32) + ;; Vector type + ((= byte #x7B) 'V128) + ;; Heap types + ((= byte #x69) 'exn) + ((= byte #x6A) 'array) + ((= byte #x6B) 'struct) + ((= byte #x6C) 'i31) + ((= byte #x6D) 'eq) + ((= byte #x6E) 'any) + ((= byte #x6F) 'extern) + ((= byte #x70) 'func) + ((= byte #x71) 'none) + ((= byte #x72) 'noextern) + ((= byte #x73) 'nofunc) + ((= byte #x74) 'noexn) + (else + (display "byte->type warning: Unknown type ") + (display (bytevector byte)) + (newline) + 'unknown))) + +(define (read-types type-count section-size port result) + (letrec* + ((type-delimiter #x60) + (type-signature-byte->name + (lambda (byte) + (cond ((= byte #x5E) 'array) + ((= byte #x5F) 'struct) + ((= byte #x60) 'func) + (else 'unknown)))) + (type-signature-byte? + (lambda (byte) + (not (symbol=? (type-signature-byte->name byte) 'unknown)))) + (type-bytes->type + (lambda (bytes) + (let* + ((argument-count (list-ref bytes 1)) + (argument-types (map byte->type (list-slice bytes 2 (+ 2 argument-count)))) + (return-type (byte->type (car (reverse bytes))))) + (append + `(,(type-signature-byte->name (list-ref bytes 0)) + ,(if (null? argument-types) '() `(param ,@argument-types)) + ,(if (symbol=? return-type 'void) '() `(result ,return-type))))))) + (read-type + (lambda (type-result) + (cond + ((and (or (eof-object? (peek-u8 port)) + (type-signature-byte? (peek-u8 port)) + (= (+ (apply + (map length result)) + (+ (length type-result) 1)) + section-size)) + (> (length type-result) 0)) + (reverse type-result)) + (else + (read-type (cons (read-u8 port) type-result))))))) + (cond + ((= (length result) type-count) + (map type-bytes->type (reverse result))) + (else (read-types type-count section-size port (cons (read-type '()) result)))))) + +(define (read-import import-count section-size port result) + (if (= (length result) import-count) + result + (letrec* + ((import-kind->type (lambda (type) (cond ((= type 0) 'func) (else 'unknown)))) + (module-name-length (read-u8 port)) + (module-name (utf8->string (read-bytevector module-name-length port))) + (field-name-length (read-u8 port)) + (field-name (utf8->string (read-bytevector field-name-length port))) + (import-kind (read-u8 port)) + (type-index (read-u8 port))) + (display "HERE: ") + (write import-count) + (newline) + (write result) + (newline) + (read-import import-count + section-size + port + (cons `(import (module ,module-name) + (field ,field-name) + (type ,type-index)) + result))))) + +(define (read-functions type-count section-size port result) + `((bytes ,(read-bytevector (- section-size 1) port)))) + +(define (read-tables type-count section-size port result) + `((bytes ,(read-bytevector (- section-size 1) port)))) + +(define (read-memory type-count section-size port result) + `((bytes ,(read-bytevector (- section-size 1) port)))) + +(define (read-global type-count section-size port result) + `((bytes ,(read-bytevector (- section-size 1) port)))) + +(define (read-section name size port) + (list name + (cond + ((symbol=? name 'custom) (read-bytevector size port)) + ((symbol=? name 'type) (read-types (read-u8 port) size port '())) + ((symbol=? name 'import) (read-import (read-u8 port) size port '())) + ((symbol=? name 'function) (read-functions (read-u8 port) size port '())) + ((symbol=? name 'table) (read-tables (read-u8 port) size port '())) + ((symbol=? name 'memory) (read-memory (read-u8 port) size port '())) + ((symbol=? name 'global) (read-global (read-u8 port) size port '())) + ((symbol=? name 'export) (read-bytevector size port)) + ((symbol=? name 'start) (read-bytevector size port)) + ((symbol=? name 'element) (read-bytevector size port)) + ((symbol=? name 'code) (read-bytevector size port)) + ((symbol=? name 'data) (read-bytevector size port))))) (define (section-id->name id) (cond ((= id 0) 'custom) @@ -21,101 +137,26 @@ ((= id 13) 'tag) (else (error "section-id->name: unrecognized section id" id)))) -(define (bytes->type bytes) - (let ((first-byte (bytevector-u8-ref bytes 0))) - (cond - ((equal? first-byte #x7C) 'f64) - ((equal? first-byte #x7D) 'f32) - ((equal? first-byte #x7E) 'f64) - ((equal? first-byte #x7F) 'f32) - (else 'unknown) - ;(else (error "Unsupported type byte" first-byte)) - ))) - -(define (bytes->types bytes) - (letrec* - ((bytes-length (bytevector-length bytes)) - (looper - (lambda (index types) - (if (>= index bytes-length) - types - (looper (+ index 1) (bytes->type (bytevector-copy bytes index))))))) - (looper 0 '()))) - -(define (section-bytes->sexp name bytes) - (let* ((id-and-id-length (leb128->integer-and-length bytes)) - (data-bytes (bytevector-copy bytes (cdr id-and-id-length))) - (data-length (bytevector-length data-bytes)) - ) - (cond - #;((equal? name 'type) - (let* ((number-of-types (leb128->integer-and-length bytes)) - (types (bytes->types (bytevector-copy bytes (cdr number-of-types))))) - (display "TYPE: type, content = ") - (write bytes) - (newline) - `((number-of-types . ,(car number-of-types)) - (types . ,types)))) - ((equal? name 'type) - (let ((number-of-types (bytevector-u8-ref bytes 0))) - (display "TYPE: type ") - (write data-length) - (newline) - (write data-bytes) - (newline) - (write number-of-types) - (newline) - '())) - (else '())))) - -(define (wasm->sexp-old bytes) - (let* ((bytes-length (bytevector-length bytes)) - (magic-bytes (if (> bytes-length 3) (bytevector-copy bytes 0 4) #u8()))) - (when (not (equal? magic-bytes #u8(#x00 #x61 #x73 #x6D))) - (error "Binary is not wasm (missing magic bytes)")) - (letrec* - ((wasm-version (bytevector-copy bytes 4 8)) - (section-data '()) - (index 8) ;; Jump over magic bytes and version - (looper (lambda () - (when (< index bytes-length) - (let* ((id (bytevector-u8-ref bytes index)) - (name (section-id->name id)) - (len (uleb128->integer-and-length bytes (+ index 1) 0 0)) - (data-bytes (bytevector-copy bytes index (+ index (car len))))) - (display "HERE: index ") - (write index) - (newline) - (display "HERE: data-bytes ") - (write data-bytes) - (newline) - (set! section-data - (append section-data - `((id . ,id) - (name . ,name) - (data . ,(section-bytes->sexp name data-bytes))))) - (set! index (+ index 1 (car len) (cdr len))) - (looper) - ))))) - (looper) - section-data))) +(define (wasm->sexp-loop port result) + (let* ((section-id (read-u8 port)) + (section-name (section-id->name section-id)) + (size (read-uleb128 port)) + (section (read-section section-name size port))) + (display "Section name: ") + (display section-name) + (newline) + (display "Section size: ") + (write size) + (newline) + (if (eof-object? (peek-u8 port)) + (reverse result) + (wasm->sexp-loop port (cons section result))))) (define (wasm->sexp port) (let ((magic-bytes (read-bytevector 4 port))) (when (not (equal? magic-bytes #u8(#x00 #x61 #x73 #x6D))) (error "Binary is not wasm (missing magic bytes)")) - (let ((version (read-bytevector 4 port))) - - (display "HERE: ") - (write magic-bytes) - (newline) - (write version) - (newline) - (write (read-uleb128 port)) - (newline) - (write (read-uleb128 port)) - (newline) - - - ))) + (letrec* + ((version (read-bytevector 4 port))) + (wasm->sexp-loop port '())))) diff --git a/retropikzel/wasm/plus.c b/retropikzel/wasm/plus.c index 76fb6af..3df091d 100644 --- a/retropikzel/wasm/plus.c +++ b/retropikzel/wasm/plus.c @@ -1,9 +1,9 @@ -int plus(int a, int b) { +int x = 100; + +extern int plus(int a, int b) { return a + b; } -/* int plus_three(int a, int b, int c) { return a + b + c; } -*/ diff --git a/retropikzel/wasm/test.scm b/retropikzel/wasm/test.scm index a917852..a0aae1f 100644 --- a/retropikzel/wasm/test.scm +++ b/retropikzel/wasm/test.scm @@ -2,13 +2,8 @@ (define testdir "retropikzel/wasm") (define testfile1 (string-append testdir "/" "plus.wasm")) - -;(when (not (file-exists? testfile1)) (error (string-append testfile1 " does not exist"))) - -;(define bytes (with-input-from-file testfile1 (lambda () (read-bytevector 10000)))) - -(define sexp (with-input-from-file testfile1 (lambda () (wasm->sexp (current-input-port))))) -(write sexp) -(newline) +(define testfile2 (string-append "/tmp/tr7/a.out.wasm")) +(define sexp (wasm->sexp (open-binary-input-file testfile2))) +(show #t (pretty sexp)) (test-end "wasm") diff --git a/test-headers.scm b/test-headers.scm index a6fd279..b9ea3d0 100644 --- a/test-headers.scm +++ b/test-headers.scm @@ -5,6 +5,7 @@ (scheme file) (scheme process-context) (srfi 64) + (srfi 166) ;(retropikzel mouth) ;(retropikzel ctrf) (retropikzel LIBRARY))