racocs decompile: show machine code or assembly

When the "disassemble" package is installed, use it to disassemble the
machine code in a Racket CS linklet.

pkgs/compiler-lib/compiler/decompile.rkt

@@ -8,8 +8,10 @@
          racket/list
          racket/set
          racket/path
+         ffi/unsafe/vm
          (only-in '#%linklet compiled-position->primitive)
-         "private/deserialize.rkt")
+         "private/deserialize.rkt"
+         "private/chez.rkt")
 
 (provide decompile)
 
@@ -113,6 +115,7 @@
           [(faslable-correlated-linklet? l)
            (compile-linklet (strip-correlated (faslable-correlated-linklet-expr l))
                             (faslable-correlated-linklet-name l))]
+          [(linklet? l) l]
           [else
            (let ([o (open-output-bytes)])
              (zo-marshal-to (linkl-bundle (hasheq 'data l)) o)
@@ -240,7 +243,21 @@
     [(struct faslable-correlated-linklet (expr name))
      (match (strip-correlated expr)
        [`(linklet ,imports ,exports ,body-l ...)
-        body-l])]))
+        body-l])]
+    [(? linklet?)
+     (case (system-type 'vm)
+       [(chez-scheme)
+        (define-values (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)))]
+          [else
+           `(....)])])]))
 
 (define (decompile-data-linklet l)
   (match l

pkgs/compiler-lib/compiler/private/chez.rkt

@@ -0,0 +1,131 @@
+#lang racket/base
+(require ffi/unsafe/vm
+         ffi/unsafe
+         racket/promise)
+
+(provide decompile-chez-procedure)
+
+(define (decompile-chez-procedure p)
+  (unless (procedure? p)
+    (error 'decompile-chez-procedure "not a procedure"))
+  (define seen (make-hasheq))
+  ((vm-primitive 'call-with-system-wind)
+   (lambda ()
+     (define proc ((vm-primitive 'inspect/object) p))
+     (define code (proc 'code))
+     (append
+      (apply
+       append
+       (for/list ([i (in-range (code 'free-count))])
+         (decompile (proc 'ref i) seen)))
+      (decompile-code code seen #:unwrap-body? #t)))))
+
+(define (decompile obj seen)
+  (define type (obj 'type))
+  (cond
+    [(eq? type 'variable)
+     null]
+    [(hash-ref seen (obj 'value) #f)
+     null]
+    [else
+     (hash-set! seen (obj 'value) #t)
+     (case type
+       [(code) (decompile-code obj seen)]
+       [(variable)
+        (decompile (obj 'ref) seen)]
+       [(procedure)
+        (decompile (obj 'code) seen)]
+       [else null])]))
+
+(define (decompile-value v seen)
+  (decompile ((vm-primitive 'inspect/object) v) seen))
+
+(define (decompile-code code seen
+                        #:unwrap-body? [unwrap-body? #f])
+  (define name (code 'name))
+  (define $generation (vm-eval '($primitive $generation)))
+  (define $code? (vm-eval '($primitive $code?)))
+  (append
+   (apply
+    append
+    (for/list ([v (in-list ((code 'reloc) 'value))]
+               #:unless (and ($code? v)
+                             (= 255 ($generation v))))
+      (decompile-value v seen)))
+   (if unwrap-body?
+       (decompile-code-body code)
+       (list
+        `(define ,(let ([name (code 'name)])
+                    (if name
+                        (string->symbol
+                         (if (and ((string-length name) . > . 0)
+                                  (eqv? (string-ref name 0) #\[))
+                             (substring name 1)
+                             name))
+                        '....))
+           (lambda ,(arity-mask->args (code 'arity-mask))
+             ,@(decompile-code-body code)))))))
+
+(define (decompile-code-body code-obj)
+  (define code-pointer-adjust 1)
+  (define code-prefix-words 8)   ; see `code` in "cmacro.ss"
+
+  (define code (code-obj 'value))
+
+  (define bstr
+    (vm-eval
+     `(let ([code ',code]
+            [memcpy ',(lambda (to from len)
+                        (memcpy to (cast from _intptr _pointer) len))])
+        (lock-object code)
+        (let* ([code-p (($primitive $object-address) code ,code-pointer-adjust)]
+               [length (foreign-ref 'uptr code-p (foreign-sizeof 'uptr))]
+               [body-p (+ code-p (* ,code-prefix-words (foreign-sizeof 'uptr)))]
+               [bstr (make-bytevector length)])
+          (memcpy bstr body-p length)
+          (unlock-object code)
+          bstr))))
+
+  (append
+   ;; Show source location, if any:
+   (let ([s (code-obj 'source-object)])
+     (if s
+         (let-values ([(path line col pos)
+                       (vm-eval `(let ([s ',s])
+                                   (values (let ([sfd (source-object-sfd s)])
+                                             (and sfd (source-file-descriptor-path sfd)))
+                                           (source-object-line s)
+                                           (source-object-column s)
+                                           (source-object-bfp s))))])
+           (cond
+             [(not path) null]
+             [(and line col) (list (format "~a:~a:~a" path line col))]
+             [pos (list (format "~a:~a" path pos))]
+             [else (list path)]))
+         null))
+   ;; Show machine/assembly code:
+   (cond
+     [(force disassemble-bytes)
+      => (lambda (disassemble-bytes)
+           (define o (open-output-bytes))
+           (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)))]
+     [else
+      (list (list 'machine-code bstr))])))
+
+(define disassemble-bytes
+  (delay
+    (with-handlers ([exn:fail? (lambda (exn) #f)])
+      (dynamic-require 'disassemble 'disassemble-bytes))))
+
+(define (arity-mask->args mask)
+  (cond
+    [(zero? (bitwise-and mask (sub1 mask)))
+     ;; single bit set
+     (for/list ([i (in-range (sub1 (integer-length mask)))])
+       (string->symbol (format "a~a" i)))]
+    [else
+     ;; multiple bits set
+     'args]))

pkgs/zo-lib/compiler/zo-parse.rkt

@@ -6,7 +6,8 @@
          compiler/zo-structs
          racket/dict
          racket/set
-         racket/fasl)
+         racket/fasl
+         ffi/unsafe/vm)
 
 (provide zo-parse)
 (provide (all-from-out compiler/zo-structs))
@@ -860,9 +861,12 @@
      
      (make-reader-graph (read-compact cp))]
     [(equal? vm #"chez-scheme")
-     (hash
-      'opaque
-      (read-bytes (read-simple-number port) port))]
+     (cond
+       [(eq? 'chez-scheme (system-type 'vm))
+        ((vm-primitive 'read-linklet-bundle-hash) port)]
+       [else
+        (define bstr (read-bytes (read-simple-number port) port))
+        (hash 'opaque bstr)])]
     [else
      (error 'zo-parse "cannot parse for virtual machine: ~s" vm)]))
 

racket/src/cs/linklet.sls

@@ -9,6 +9,7 @@
 
           linklet-import-variables
           linklet-export-variables
+          linklet-fasled-code+arguments ; for tools like `raco decompile`
           
           instance?
           make-instance
@@ -775,11 +776,27 @@
           i)])]))
               
   (define (linklet-import-variables linklet)
+    (unless (linklet? linklet)
+        (raise-argument-error 'linklet-import-variables "linklet?" linklet))
     (linklet-importss linklet))
 
   (define (linklet-export-variables linklet)
+    (unless (linklet? linklet)
+        (raise-argument-error 'linklet-export-variables "linklet?" linklet))
     (map (lambda (e) (if (pair? e) (car e) e)) (linklet-exports linklet)))
 
+  (define (linklet-fasled-code+arguments linklet)
+    (unless (linklet? linklet)
+      (raise-argument-error 'linklet-code "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)]))
+
   ;; ----------------------------------------
 
   ;; A potentially mutable import or definition is accessed through