http://t3x.org/s9fes/disassemble.scm.html (light|dark)
Location: lib, 175 Lines
; Scheme 9 from Empty Space, Function Library ; By Nils M Holm, 2018, 2025 ; In the public domain ; ; (disassemble* procedure) ==> list ; (disassemble procedure) ==> unspecific ; ; (load-from-library "disassemble.scm") ; ; DISASSEMBLE disassembles the bytecode of the compilation ; unit containing the definition of the given PROCEDURE. ; The compilation block typically contains not only the ; code for the procedure itself, but also instructions for ; jumping over the body of the procecure, setting up its ; closure, and binding it to a location in the environment. ; When multiple procedures are defined in the same BEGIN ; block, all procedures contained in the block will be ; disassembled. ; ; The only specification of the Scheme 9 bytecode at the ; present moment is the source code of the compiler and ; abstract machine, so the output of these procedures will ; only make sense to those who are familiar with the ; internal mechanisms of Scheme 9. An incomplete summary ; can be found below. ; ; DISASSEMBLE* returns a list containing instructions and ; DISASSEMBLE pretty-prints code to the current output port. ; ; Scheme 9 Abstract Machine Summary ; ; The Scheme 9 abstract machine is an SECD-like machine with ; a unified return and data stack, a top of stack cache called ; the "accumulator", and vectors as environments. ; ; Single-operand instructions expect their arguments in the ; accumulator (A), two-operand instructions expect argument #1 in ; the accumulator and argument #2 on the top of the stack (S0), ; and three-argument instructions expect #1 in A, #2 in S0 and ; #3 in S1 (the stack element beneath S0). All instructions ; remove their operands from the stack and return their result ; in A. ; ; Many instructions resemble Scheme procedures. For instance, ; the OP:CONS instruction implements CONS and the OP_SUBSTRING ; instruction implements SUBSTRING. There are no variadic ; instructions. The expression (+ a b c), for instance, would ; compile to A PUSH B PLUS PUSH C PLUS. ; ; Here is a summary of the instructions that DO NOT resemble ; built-in Scheme procedures: ; ; OP:APPLIS | A=procedure S0=list --> object ; OP:TAIL-APPLIS | A=procedure S0=list --> object ; Apply A to arguments in S0. ; OP:TAIL-APPLIS performs a tail call. ; ; OP:APPLY | A=procedure S0...Sn=objects --> object ; OP:TAILAPPLY | A=procedure S0...Sn=objects --> object ; Apply A to arguments on the stack. ; OP:TAIL-APPLY performs a tail call. ; ; OP:QUOTE x | --> object ; Load A with x. ; ; OP:ARG n | --> object ; Retrieve N'th procedure argument. ; ; OP:REF n sym | --> object ; Retrieve the value from the N'th environment slot. ; SYM is the name of the symbol bound to the slot. ; ; OP:MAKE-ENV n | --> vector ; OP:PROP-ENV | --> vector ; Create an empty environment vector with N slots. ; OP:PROP-ENV propagates (re-uses) the parent environment. ; ; OP:COPY-ARG n m | --> ; Copy the N'th procedure argument to slot M of the new ; environment. ; ; OP:COPY-REF | n m --> ; Copy envirnment slot N of the parent environment to ; slot M of the new environment. ; ; OP:CLOSURE n | --> procedure ; Create a procedure (closure) with entry point N. Fetch ; the new environment from A. ; ; OP:DEF-MACRO sym | procedure --> ; Bind A to SYM in the macro symbol table. ; ; OP:ENTER n | --> ; Enter procedure. When there are not exactly N arguments on ; the stack, signal an error. ; ; OP:ENTER-COLL n | --> ; Enter procedure collecting arguments. When there are less ; than n arguments on the stack, signal an error. Collect ; excess arguments (>N) in a list and place them in the last ; argument. ; ; OP:RETURN | --> ; Return from procedure. ; ; OP:HALT | --> ; Halt program execution. ; ; OP:JMP k | --> ; Transfer control to address K. ; ; OP:JMP-FALSE | boolean --> ; Transfer control to address K, if A equals #F. ; ; OP:JMP-TRUE | boolean --> ; Transfer control to address K, if A does not equal #F. ; ; OP:POP | --> object ; Load S0 into A. ; ; OP:PUSH-BOX | object --> ; Push A to the stack in a box. ; ; OP:PUSH-LIT x | --> object ; Push object x to the stack. ; ; OP:PUSH-VAL n | --> object ; Push integer N to the stack. ; ; OP:SET-ARG n | object --> ; Set the N'th argument to A. ; ; OP:SET-REF n | object --> ; Set the N'th environment slot to A. ; ; (Example:) No example given. (load-from-library "iota.scm") (load-from-library "bitops.scm") (define-syntax (enum syms . body) (let* ((k (length syms)) (ns (iota 0 (- k 1)))) `((lambda ,syms . ,body) . ,ns))) (define (disassemble* p) (enum (op:applis op:apply op:arg op:copy-arg op:closure op:copy-ref op:def-macro op:enter op:enter-coll op:halt op:jmp op:jmp-false op:jmp-true op:make-env op:prop:env op:pop op:push-box op:push-lit op:push-val op:quote op:ref op:return op:set-arg op:set-ref op:tail-applis op:tail-apply op:abs op:append op:assq op:assv op:bit-op op:boolean-p op:caaaar op:caaadr op:caaar op:caadar op:caaddr op:caadr op:caar op:cadaar op:cadadr op:cadar op:caddar op:cadddr op:caddr op:cadr op:call-cc op:car op:catch op:catch-tag-p op:cdaaar op:cdaadr op:cdaar op:cdadar op:cdaddr op:cdadr op:cdar op:cddaar op:cddadr op:cddar op:cdddar op:cddddr op:cdddr op:cddr op:cdr op:ceiling op:char-alphabetic-p op:char-ci-equal-p op:char-ci-grtr-p op:char-ci-gteq-p op:char-ci-less-p op:char-ci-lteq-p op:char-downcase op:char-equal-p op:char-grtr-p op:char-gteq-p op:char-less-p op:char-lower-case-p op:char-lteq-p op:char-numeric-p op:char-p op:char-to-integer op:char-upcase op:char-upper-case-p op:char-whitespace-p op:close-input-port op:close-output-port op:command-line op:cons op:current-error-port op:current-input-port op:current-output-port op:delete-file op:display op:divide op:dump-image op:environment-variable op:eof-object-p op:equal op:eqv-p op:eq-p op:error op:error2 op:eval op:even-p op:exact-p op:exact-to-inexact op:exponent op:expt op:file-exists-p op:fix-exactness op:floor op:gensym op:grtr op:gteq op:inexact-p op:inexact-to-exact op:input-port-p op:integer-p op:integer-to-char op:length op:less op:list op:list-ref op:list-tail op:list-to-string op:list-to-vector op:load op:lteq op:macro-expand op:macro-expand-1 op:make-string op:make-vector op:mantissa op:max op:memq op:memv op:min op:minus op:negate op:negative-p op:not op:null-p op:odd-p op:open-append-file op:open-input-file op:open-output-file op:output-port-p op:pair-p op:peek-char op:plus op:positive-p op:procedure-p op:quit op:quotient op:read op:read-char op:real-p op:remainder op:reverse op:reverse-b op:s9-bytecode op:s9-object op:set-car-b op:set-cdr-b op:set-input-port-b op:set-output-port-b op:stats op:string-append op:string-copy op:string-equal-p op:string-fill-b op:string-grtr-p op:string-gteq-p op:string-length op:string-less-p op:string-lteq-p op:string-p op:string-ref op:string-set-b op:string-ci-equal-p op:string-ci-grtr-p op:string-ci-gteq-p op:string-ci-less-p op:string-ci-lteq-p op:string-to-list op:string-to-symbol op:substring op:symbols op:symbol-p op:symbol-to-string op:system-command op:throw op:times op:truncate op:vector op:vector-append op:vector-copy op:vector-fill-b op:vector-length op:vector-p op:vector-ref op:vector-set-b op:vector-to-list op:write op:write-char op:zero-p) (define mnemos #(applis apply arg copy-arg closure copy-ref def-macro enter enter-coll halt jmp jmp-false jmp-true make-env prop-env pop push-box push-lit push-val quote ref return set-arg set-ref tail-applis tail-apply abs append assq assv bit-op boolean? caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call/cc car catch catch-tag? cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char-alphabetic? char-ci=? char-ci>? char-ci>=? char-ci<? char-ci<=? char-downcase char=? char>? char>=? char<? char-lower-case? char<=? char-numeric? char? char->integer char-upcase char-upper-case? char-whitespace? close-input-port close-output-port command-line cons current-error-port current-input-port current-output-port delete-file display divide dump-image environment-variable eof-object? equal eqv? eq? error error2 eval even? exact? exact->inexact exponent expt file-exists? fix-exactness floor gensym grtr gteq inexact? inexact->exact input-port? integer? integer->char length less list list-ref list-tail list->string list->vector load lteq macro-expand macro-expand-1 make-string make-vector mantissa max memq memv min minus negate negative? not null? odd? open-append-file open-input-file open-output-file output-port? pair? peek-char plus positive? procedure? quit quotient read read-char real? remainder reverse reverse-b s9:bytecode s9:object set-car! set-cdr! set-input-port! set-output-port! stats string-append string-copy string=? string-fill! string>? string>=? string-length string<? string<=? string? string-ref string-set! string-ci=? string-ci>? string-ci>=? string-ci<? string-ci<=? string->list string->symbol substring symbols symbol? symbol->string system-command throw times truncate vector vector-append vector-copy vector-fill! vector-length vector? vector-ref vector-set! vector->list write write-char zero?)) (define group2 (list op:quote op:arg op:closure op:push-lit op:push-val op:jmp op:jmp-false op:jmp-true op:make-env op:enter op:enter-coll op:set-arg op:set-ref op:def-macro)) (define group3 (list op:ref op:copy-arg op:copy-ref)) (define (mnemo op) (vector-ref mnemos op)) (let loop ((bc (s9:bytecode p)) (dis '())) (cond ((null? bc) (reverse! dis)) ((memv (car bc) group3) (loop (list-tail bc 9) (cons (list (mnemo (car bc)) (cadr bc) (caddr bc) (cadddr bc) (cadddr (cdr bc)) (cadddr (cddr bc)) (cadddr (cdddr bc)) (cadddr (cddddr bc)) (cadddr (cddddr (cdr bc))) ) dis))) ((memv (car bc) group2) (loop (list-tail bc 5) (cons (list (mnemo (car bc)) (cadr bc) (caddr bc) (cadddr bc) (cadddr (cdr bc))) dis))) (else (loop (cdr bc) (cons (list (mnemo (car bc))) dis))))))) (define (disassemble p) (define (numlen x) (string-length (number->string x))) (define (symlen x) (string-length (symbol->string x))) (define (spaces n) (cond ((positive? n) (display #\space) (spaces (- n 1))))) (define (word a) (let ((n (+ (car a) (* (cadr a) 256) (* (caddr a) 256 256) (* (cadddr a) 256 256 256)))) (if (> n #x7fffffff) (- n #x100000000) n))) (let* ((d (disassemble* p)) (k (+ 1 (fold-left max 0 (map symlen (map car d))))) (a 0)) (for-each (lambda (x) (spaces (- 5 (numlen a))) (display a) (display #\space) (display (car x)) (cond ((pair? (cdr x)) (spaces (- k (symlen (car x)))) (display (word (cdr x))) (cond ((pair? (list-tail x 5)) (display #\space) (display (word (list-tail x 5))))))) (case (car x) ((quote) (spaces 1) (write (s9:object (word (cdr x))))) ((ref) (spaces 1) (write (s9:object (word (list-tail x 5)))))) (newline) (set! a (+ a (length x)))) d)))