Merge pull request #149 from cmsc430/ziggy

Ziggy

This merges the Ziggy branch into main.  There are still problems with Ziggy, but it's time to put them on main.

Author: dvanhorn

.github/workflows/langs.yml

@@ -8,7 +8,7 @@ jobs:
       matrix:
         os: [ubuntu-20.04, ubuntu-22.04]
         racket-variant: ['BC', 'CS']
-        racket-version: ['7.8', '8.0', '8.6', '8.8']
+        racket-version: ['8.6', '8.8']
     name: Test on Racket ${{ matrix.racket-variant }} ${{ matrix.racket-version }} on ${{ matrix.os }}	
     steps:
     - name: Checkout
@@ -31,8 +31,11 @@ jobs:
         nasm --version
         gcc --version
     - name: Install langs package
-      run: raco pkg install langs/
+      run: |
+        raco pkg install --auto ziggy/
+        raco pkg install langs/
     - name: Run tests
       run: |
-        raco test -p langs
+        raco test -p ziggy
+        xvfb-run raco test -p langs
         raco test -c outlaw

langs/a86/ast.rkt

@@ -238,6 +238,8 @@
 (instruct Sal    (dst i)   check:shift)
 (instruct Sar    (dst i)   check:shift)
 (instruct Push   (a1)      check:push)
+(instruct Pushf  ()        check:none)
+(instruct Popf   ()        check:none)
 (instruct Pop    (a1)      check:register)
 (instruct Lea    (dst x)   check:lea)
 (instruct Not    (x)       check:register)
@@ -250,6 +252,8 @@
 (instruct Const  (x)       check:label-symbol)
 
 ;; IMPROVE: do more checking
+(instruct Db (x) (lambda (a x n) (values a x)))
+(instruct Dw (x) (lambda (a x n) (values a x)))
 (instruct Dd (x) (lambda (a x n) (values a x)))
 (instruct Dq (x) (lambda (a x n) (values a x)))
 
@@ -392,3 +396,26 @@
      (unless (member init (map (lambda (i) (match i [(Global l) l]))
                                (filter Global? asm)))
        (error 'prog "initial label undeclared as global: ~v" init))]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbol to Label
+
+;; Symbol -> Label
+;; Produce a symbol that is a valid Nasm label
+;; Guarantees that (eq? s1 s2) <=> (eq? (symbol->label s1) (symbol->label s1))
+(provide symbol->label)
+(define (symbol->label s)
+  (string->symbol
+   (string-append
+    "label_"
+    (list->string
+     (map (λ (c)
+            (if (or (char<=? #\a c #\z)
+                    (char<=? #\A c #\Z)
+                    (char<=? #\0 c #\9)
+                    (memq c '(#\_ #\$ #\# #\@ #\~ #\. #\?)))
+                c
+                #\_))
+         (string->list (symbol->string s))))
+    "_"
+    (number->string (eq-hash-code s) 16))))

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 '()))
@@ -32,10 +39,43 @@
 
 (define fmt (if (eq? (system-type 'os) 'macosx) 'macho64 'elf64))
 
+;; WARNING: The heap is re-used, so make sure you're done with it
+;; before calling asm-interp again
+(define *heap*
+  ; IMPROVE ME: hard-coded heap size
+  (malloc _int64 20000 'raw))
+
+
+;; Integer64 -> String
+(define (int64->binary-string n)
+  (format "#b~a"
+          (~r n #:base 2 #:min-width 64 #:pad-string "0")))
+
+;; Integer64 -> String
+(define (int64->octal-string n)
+  (format "#o~a"
+          (~r n #:base 8 #:min-width 22 #:pad-string "0")))
+
+;; Integer64
+(define (int64->hex-string n)
+  (format "#x~a"
+          (~r n #:base 16 #:min-width 16 #:pad-string "0")))
+
+(define (show-state . 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"))
@@ -46,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)
@@ -69,24 +111,27 @@
     (set-ffi-obj! "error_handler" libt.so _pointer
                   (function-ptr (λ () (raise 'err)) (_fun _-> _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 current-heap #f)
+  (define has-heap? #f)
 
-  ;; allocate a heap
   (when (ffi-obj-ref "heap" libt.so (thunk #f))
-    (set! current-heap (make-c-parameter "heap" libt.so _pointer))
-
-    (if (ffi-obj-ref "from" libt.so (thunk #f))
-        (begin
-          (current-heap
-           ; IMPROVE ME: hard-coded heap size
-           (malloc _int64 20000 'raw))
-          (set-ffi-obj! "from" libt.so _pointer (current-heap))
-          (set-ffi-obj! "to" libt.so _pointer (ptr-add (current-heap) 10000 _int64))
-          (set-ffi-obj! "types" libt.so _pointer (malloc _int32 10000)))
-        (current-heap
-         ; IMPROVE ME: hard-coded heap size
-         (malloc _int64 10000 'raw))))
+    (set! has-heap? #t)
+
+    ;; This is a GC-enabled run-time so set from, to, and types space
+    (when (ffi-obj-ref "from" libt.so (thunk #f))
+      ;; FIXME: leaks types memory
+      (set-ffi-obj! "from" libt.so _pointer *heap*)
+      (set-ffi-obj! "to" libt.so _pointer (ptr-add *heap* 10000 _int64))
+      (set-ffi-obj! "types" libt.so _pointer (malloc _int32 10000))))
 
   (delete-file t.s)
   (delete-file t.o)
@@ -109,15 +154,9 @@
         (current-out (fopen t.out "w"))
 
         (define result
-          (begin0
-            (with-handlers ((symbol? identity))
-              (guard-foreign-escape
-               (if current-heap
-                   (cons (current-heap) (entry (current-heap)))
-                   (entry #f))))
-            #;
-            (when current-heap
-              (free (current-heap)))))
+          (with-handlers ((symbol? identity))
+            (guard-foreign-escape
+             (entry *heap*))))
 
         (fflush (current-out))
         (fclose (current-in))
@@ -128,15 +167,9 @@
         (delete-file t.out)
         (cons result output))
 
-      (begin0
-        (with-handlers ((symbol? identity))
-          (guard-foreign-escape
-           (if current-heap
-               (cons (current-heap) (entry (current-heap)))
-               (entry #f))))
-        #;
-        (when current-heap
-          (free (current-heap))))))
+      (with-handlers ((symbol? identity))
+        (guard-foreign-escape
+         (entry *heap*)))))
 
 
 (define (string-splice xs)
@@ -192,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))))

langs/a86/printer.rkt

@@ -49,6 +49,8 @@
       [(? reg?) (reg->string t)]
       [(Offset (? reg? r) i)
        (string-append "[" (reg->string r) " + " (number->string i) "]")]
+      [(Offset (? label? l) i)
+       (string-append "[" (label-symbol->string l) " + " (number->string i) "]")]
       [_ (label-symbol->string t)]))
 
   ;; Arg -> String
@@ -209,6 +211,10 @@
       [(Push a)
        (string-append tab "push "
                       (arg->string a))]
+      [(Pushf)
+       (string-append tab "pushf")]
+      [(Popf)
+       (string-append tab "popf")]
       [(Pop r)
        (string-append tab "pop "
                       (reg->string r))]
@@ -232,6 +238,12 @@
                       " equ "
                       (number->string c))]
 
+      [(Db (? bytes? bs))
+       (apply string-append tab "db " (add-between (map number->string (bytes->list bs)) ", "))]
+      [(Db x)
+       (string-append tab "db " (arg->string x))]
+      [(Dw x)
+       (string-append tab "dw " (arg->string x))]
       [(Dd x)
        (string-append tab "dd " (arg->string x))]
       [(Dq x)

langs/a86/stepper.rkt

@@ -0,0 +1,42 @@
+#lang racket
+(provide main)
+
+(require redex)
+
+(define-language L)
+
+;; A reduction relation that just relates elements
+;; of the list to their successors
+(define (r ls)
+  (define i 0)
+  (reduction-relation L
+                      (--> any_i
+                           any_j
+                           (where any_j
+                                  ,(begin
+                                     (set! i (add1 i))
+                                     (list-ref ls (min i (sub1 (length ls)))))))))
+
+
+;; reads log file from stdin
+(define (main)
+  (define ls
+    (let loop ()
+      (if (eof-object? (read))
+          '()
+          (cons (read) (loop)))))
+  
+  ;; replace instr indices with their instructions
+  (define ls1
+    (map (λ (s)
+           (map (λ (p)
+                  (match p
+                    [(list 'instr i)
+                     (list 'instr (list-ref (list-ref ls 0)
+                                            (add1 i)))]
+                    [_ p]))
+                s))
+         ls))
+
+  ;; run the stepper
+  (stepper (r (rest ls1)) (first (rest ls1))))

langs/abscond/Makefile

@@ -35,7 +35,8 @@ runtime.o: $(objs)
 	cat $< | racket -t compile-stdin.rkt -m > $@
 
 clean:
-	rm *.o *.s *.run
+	@$(RM) *.o *.s *.run ||:
+	@echo "$(shell basename $(shell pwd)): cleaned!"
 
 %.test: %.run %.rkt
 	@test "$(shell ./$(<))" = "$(shell racket $(word 2,$^))"

langs/abscond/ast.rkt

@@ -1,5 +1,6 @@
 #lang racket
-(provide Int)
+(provide Lit)
 
-;; type Expr = (Int Integer)
-(struct Int (i) #:prefab)
+;; type Expr = (Lit Integer)
+
+(struct Lit (i) #:prefab)