Start of log-based debugger.

Author: dvanhorn

langs/a86/interp.rkt

@@ -4,13 +4,20 @@
  [asm-interp    (-> (listof instruction?) any/c)]
  [asm-interp/io (-> (listof instruction?) string? any/c)])
 
+(define-logger a86)
+
 (require "printer.rkt" "ast.rkt" "callback.rkt" "check-nasm.rkt"
          (rename-in ffi/unsafe [-> _->]))
 (require (submod "printer.rkt" private))
 
 ;; Check NASM availability when required to fail fast.
 (check-nasm-available)
 
+(define *debug*?
+  (let ((r (getenv "PLTSTDERR")))
+    (and r
+         (string=? r "info@a86"))))
+
 ;; Assembly code is linked with object files in this parameter
 (define current-objs
   (make-parameter '()))
@@ -39,29 +46,36 @@
   (malloc _int64 20000 'raw))
 
 
-;; Integer -> String
-(define (number->binary n)
+;; Integer64 -> String
+(define (int64->binary-string n)
   (format "#b~a"
           (~r n #:base 2 #:min-width 64 #:pad-string "0")))
 
-;; Integer -> String
-(define (number->octal n)
+;; Integer64 -> String
+(define (int64->octal-string n)
   (format "#o~a"
           (~r n #:base 8 #:min-width 22 #:pad-string "0")))
 
-(define (number->hex n)
+;; Integer64
+(define (int64->hex-string n)
   (format "#x~a"
           (~r n #:base 16 #:min-width 16 #:pad-string "0")))
 
 (define (show-state . regs)
-  (for-each (lambda (v)
-              (printf "reg: ~a\n" (number->hex v)))
-            regs))
+  (format "\n~a"
+          (map (lambda (r v)
+                 (format "(~a ~a)" r (int64->hex-string v)))
+               '(rax rbx rcx rdx rbp rsp rsi rdi
+                     r8 r9 r10 r11 r12 r13 r14 r15 instr flags)
+               regs)))
 
 ;; Asm String -> (cons Value String)
 ;; Like asm-interp, but uses given string for input and returns
 ;; result with string output
 (define (asm-interp/io a input)
+
+  (log-a86-info (~v a))
+
   (define t.s   (make-temporary-file "nasm~a.s"))
   (define t.o   (path-replace-extension t.s #".o"))
   (define t.so  (path-replace-extension t.s #".so"))
@@ -72,7 +86,9 @@
     #:exists 'truncate
     (λ ()
       (parameterize ((current-shared? #t))
-        (asm-display a))))
+        (asm-display (if *debug*?
+                         (debug-transform a)
+                         a)))))
 
   (nasm t.s t.o)
   (ld t.o t.so)
@@ -95,12 +111,15 @@
     (set-ffi-obj! "error_handler" libt.so _pointer
                   (function-ptr (λ () (raise 'err)) (_fun _-> _void))))
 
-  (when (ffi-obj-ref "place" libt.so (thunk #f))
-    (set-ffi-obj! "place" libt.so _pointer
-                  (function-ptr (λ (n)
-                                  (apply show-state
-                                         (build-list 16 (lambda (i) (ptr-ref n _int64 (add1 i))))))
-                                (_fun _pointer _-> _void))))
+  (when *debug*?
+    (define log (ffi-obj-ref log-label libt.so (thunk #f)))
+    (when log
+      (set-ffi-obj! log-label libt.so _pointer
+                    (function-ptr
+                     (λ () (log-a86-info
+                            (apply show-state
+                                   (build-list 18 (lambda (i) (ptr-ref log _int64 (add1 i)))))))
+                     (_fun _-> _void)))))
 
   (define has-heap? #f)
 
@@ -206,3 +225,69 @@
                (regexp-match #rx"undefined reference to `(.*)'" err-msg)) ; linux
       [(list _ symbol) (ld:undef-symbol symbol)]
       [_ (ld:error (format "unknown link error.\n\n~a" err-msg))])))
+
+
+
+;; Debugging facilities
+
+(define log-label (symbol->label (gensym 'log)))
+
+(define (Log i)
+  (seq (save-registers)
+       (Pushf)
+       (Mov 'rax i)
+       (Mov (Offset log-label (* 8 17)) 'rax)
+       (Mov 'rax (Offset 'rsp 0))
+       (Mov (Offset log-label (* 8 18)) 'rax)
+       (Call (Offset log-label 0))
+       (Popf)
+       (restore-registers)))
+
+(define (instrument is)
+  (for/fold ([ls '()]
+             #:result (reverse ls))
+            ([idx (in-naturals)]
+             [ins (in-list is)])
+    (if (serious-instruction? ins)
+        (seq ins (reverse (Log idx)) ls)
+        (seq ins ls))))
+
+(define (serious-instruction? ins)
+  (match ins
+    [(Label _) #f]
+    [(Global _) #f]
+    [(? Comment?) #f]
+    [_ #t]))
+
+(define (debug-transform is)
+  (seq (instrument is)
+          ;; End of user program
+          (Data)
+          (Global log-label)
+          (Label log-label)
+          (Dq 0) ; callback placeholder
+          (static-alloc-registers)
+          (Dq 0) ; index of instruction
+          (Dq 0) ; flags
+          ))
+
+(define registers
+  '(rax rbx rcx rdx rbp rsp rsi rdi
+        r8 r9 r10 r11 r12 r13 r14 r15))
+
+(define (static-alloc-registers)
+  (apply seq
+         (map (λ (r) (seq (Dq 0) (% (~a r))))
+              registers)))
+
+(define (save-registers)
+  (apply seq
+         (map (λ (r i) (seq (Mov (Offset log-label (* 8 i)) r)))
+              registers
+              (build-list (length registers) add1))))
+
+(define (restore-registers)
+  (apply seq
+         (map (λ (r i) (seq (Mov r (Offset log-label (* 8 i)))))
+              registers
+              (build-list (length registers) add1))))