diff --git a/pkgs/compiler-lib/compiler/decompile.rkt b/pkgs/compiler-lib/compiler/decompile.rkt index 959708feaf..150d3e2339 100644 --- a/pkgs/compiler-lib/compiler/decompile.rkt +++ b/pkgs/compiler-lib/compiler/decompile.rkt @@ -247,15 +247,22 @@ [(? linklet?) (case (system-type 'vm) [(chez-scheme) - (define-values (code args) ((vm-primitive 'linklet-fasled-code+arguments) l)) + (define-values (fmt code args) ((vm-primitive 'linklet-fasled-code+arguments) l)) (cond [code (define uncompressed-code (if (regexp-match? #rx#"^\0\0\0\0chez" code) code (vm-eval `(bytevector-uncompress ,code)))) - (define proc ((vm-eval `(load-compiled-from-port (open-bytevector-input-port ,uncompressed-code))))) - (decompile-chez-procedure (if (null? args) proc (proc args)))] + (case fmt + [(compile) + (define proc ((vm-eval `(load-compiled-from-port (open-bytevector-input-port ,uncompressed-code))))) + (decompile-chez-procedure (if (null? args) proc (proc args)))] + [(interpret) + (define bytecode (vm-eval `(fasl-read (open-bytevector-input-port ,uncompressed-code)))) + (list `(#%interpret ,(unwrap-chez-interpret-jitified bytecode)))] + [else + '(....)])] [else `(....)])])])) diff --git a/pkgs/compiler-lib/compiler/private/chez.rkt b/pkgs/compiler-lib/compiler/private/chez.rkt index 551468b757..1aa2a89a1f 100644 --- a/pkgs/compiler-lib/compiler/private/chez.rkt +++ b/pkgs/compiler-lib/compiler/private/chez.rkt @@ -3,7 +3,8 @@ ffi/unsafe racket/promise) -(provide decompile-chez-procedure) +(provide decompile-chez-procedure + unwrap-chez-interpret-jitified) (define (decompile-chez-procedure p) (unless (procedure? p) @@ -111,9 +112,9 @@ (parameterize ([current-output-port o]) (disassemble-bytes bstr #:relocations ((code-obj 'reloc+offset) 'value))) (define strs (regexp-split #rx"\n" (get-output-string o))) - (list (cons 'assembly-code strs)))] + (list (cons '#%assembly-code strs)))] [else - (list (list 'machine-code bstr))]))) + (list (list '#%machine-code bstr))]))) (define disassemble-bytes (delay @@ -129,3 +130,24 @@ [else ;; multiple bits set 'args])) + +;; ---------------------------------------- +;; The schemify interpreter's "bytecode" is fairly readable as-is, so +;; just unpack compiled procedures at the leaves + +(define (unwrap-chez-interpret-jitified bc) + (define linklet-interpret-jitified? (vm-primitive 'linklet-interpret-jitified?)) + (define linklet-interpret-jitified-extract (vm-primitive 'linklet-interpret-jitified-extract)) + (let loop ([bc bc]) + (cond + [(linklet-interpret-jitified? bc) + (define proc (linklet-interpret-jitified-extract bc)) + (define proc-obj ((vm-primitive 'inspect/object) proc)) + (define code (proc-obj 'code)) + `(begin . ,(decompile-code code (make-hasheq)))] + [(vector? bc) + (for/vector #:length (vector-length bc) ([bc (in-vector bc)]) + (loop bc))] + [(pair? bc) + (cons (loop (car bc)) (loop (cdr bc)))] + [else bc]))) diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index aecd94351d..c1871fed89 100644 --- a/racket/src/cs/linklet.sls +++ b/racket/src/cs/linklet.sls @@ -9,7 +9,9 @@ linklet-import-variables linklet-export-variables - linklet-fasled-code+arguments ; for tools like `raco decompile` + linklet-fasled-code+arguments ; for tools like `raco decompile` + linklet-interpret-jitified? ; for `raco decompile` + linklet-interpret-jitified-extract ; for `raco decompile` instance? make-instance @@ -787,15 +789,19 @@ (define (linklet-fasled-code+arguments linklet) (unless (linklet? linklet) - (raise-argument-error 'linklet-code "linklet?" linklet)) + (raise-argument-error 'linklet-fasled-code+arguments "linklet?" linklet)) (case (linklet-preparation linklet) [(faslable faslable-strict faslable-unsafe lazy) - (case (linklet-format linklet) - [(compile) - (values (linklet-code linklet) (linklet-paths linklet))] - [else - (values #f #f)])] - [else (values #f #f)])) + (values (linklet-format linklet) (linklet-code linklet) (linklet-paths linklet))] + [else (values #f #f #f)])) + + (define (linklet-interpret-jitified? v) + (wrapped-code? v)) + + (define (linklet-interpret-jitified-extract v) + (unless (wrapped-code? v) + (raise-argument-error 'linklet-interpret-jitified-extract "linklet-interpret-jitified?" v)) + (force-wrapped-code v)) ;; ----------------------------------------