Overhaul (#22)

.github/workflows/docs.yml

@@ -0,0 +1,57 @@
+on:
+  - push
+
+jobs:
+  build-docs:
+    runs-on: ubuntu-22.04
+    name: Build and deploy docs
+    steps:
+    - name: Checkout
+      uses: actions/checkout@main
+    - name: Install nasm
+      run: sudo apt-get install nasm
+    - name: Install pandoc
+      run: |
+        curl -Ls https://github.com/jgm/pandoc/releases/download/2.11.2/pandoc-2.11.2-1-amd64.deb -o pandoc.deb
+        sudo dpkg -i pandoc.deb
+    - name: Install Racket
+      uses: Bogdanp/[email protected]
+      with:
+        architecture: 'x64'
+        distribution: 'full'
+        variant: 'CS'
+        version: '8.14'
+    - name: Version info
+      run: |
+        nasm --version
+        gcc --version
+    - name: Install a86 package
+      run: |
+        raco pkg install -D ../a86/
+    - name: Render documentation
+      run: |
+        find . -name '*scrbl'
+        raco scribble --htmls \
+          ++xref-in setup/xref load-collections-xref \
+          --redirect-main http://docs.racket-lang.org/ \
+          --dest out/ \
+          a86/scribblings/a86.scrbl
+    - name: Archive documentation
+      uses: actions/upload-pages-artifact@v3
+      with:
+        name: github-pages
+        path: out/a86
+  deploy:
+    needs: build-docs
+    runs-on: ubuntu-22.04
+    permissions:
+      pages: write
+      id-token: write
+    environment:
+      name: github-pages
+      url: ${{ steps.deployment.outputs.page_url }}
+    if: github.ref == 'refs/heads/main'
+    steps:
+    - name: Deploy to GitHub pages
+      id: deployment
+      uses: actions/deploy-pages@v4

.github/workflows/push.yml

@@ -15,10 +15,6 @@ jobs:
       uses: actions/checkout@main
     - name: Install nasm
       run: sudo apt-get install nasm
-    - name: Install pandoc
-      run: |
-        curl -Ls https://github.com/jgm/pandoc/releases/download/2.11.2/pandoc-2.11.2-1-amd64.deb -o pandoc.deb
-        sudo dpkg -i pandoc.deb
     - name: Install Racket
       uses: Bogdanp/[email protected]
       with:
@@ -32,7 +28,7 @@ jobs:
         gcc --version
     - name: Install a86 package
       run: |
-        raco pkg install ../a86/
+        raco pkg install -D ../a86/
     - name: Install langs package
       run: |
         # This *should* use the locally installed a86

a86/ast.rkt

@@ -1,4 +1,6 @@
 #lang racket
+(require (only-in "registers.rkt" register? register-size))
+(provide register?)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Guards
@@ -192,7 +194,7 @@
 (provide @)
 
 ;; @ is like quasiquote with an implicit unquote at the leaves of the expression
-;; constructors
+;; constructors and bound identifiers
 (define-syntax @
   (λ (stx) ; intentionally non-hygienic
     (syntax-case* stx (? $ $$) (λ (i1 i2) (eq? (syntax->datum i1) (syntax->datum i2)))
@@ -206,7 +208,12 @@
        #'(list 'b (@ e1) (@ e2))]
       [(_ (? e1 e2 e3))
        #'(list '? (@ e1) (@ e2) (@ e3))]
-      [(_ e) #'e])))
+      [(_ id)
+       (and (identifier? #'id) (not (identifier-binding #'id)))
+       #''id]
+      [(_ e)
+       #'(let ((x e))
+           (if (exp? x) x (error "not an assembly expression" x)))])))
 
 (provide exp-unop?)
 (define (exp-unop? x)
@@ -221,9 +228,9 @@
 (define-for-syntax exp-unops
   '(- + ~ ! SEG))
 (define exp-binops
-  '(<<< << < <= < <=> > >= > >> >>> = == != || \| & && ^^ ^ + - * / // % %%))
+  '(<<< << < <= <=> >= > >> >>> = == != || \| & && ^^ ^ + - * / // % %%))
 (define-for-syntax exp-binops
-  '(<<< << < <= < <=> > >= > >> >>> = == != || \| & && ^^ ^ + - * / // % %%))
+  '(<<< << < <= <=> >= > >> >>> = == != || \| & && ^^ ^ + - * / // % %%))
 
 ;; Exp -> Exp
 (define (exp-normalize x)
@@ -248,9 +255,13 @@
 
 ;; See https://github.com/cmsc430/a86/issues/2 for discussion
 
-(provide (struct-out $))
-
+(provide label?)
+(define (label? x)
+  (and (symbol? x)
+       (nasm-label? x)
+       (not (register? x))))
 
+(provide (struct-out $))
 
 (struct $ (label)
   #:transparent
@@ -406,6 +417,7 @@
 (instruct Mov    (dst src) check:mov)
 (instruct Add    (dst src) check:arith)
 (instruct Sub    (dst src) check:arith)
+(instruct Mul    (src)     check:register)
 (instruct Cmp    (a1 a2)   check:src-dest)
 (instruct Jmp    (x)       check:target)
 (instruct Ja     (x)       check:target)
@@ -493,72 +505,24 @@
       ($? x)
       (integer? x)))
 
-(provide offset? register? label? 64-bit-integer? 32-bit-integer? register-size)
+(provide offset? 64-bit-integer? 32-bit-integer? 16-bit-integer? 8-bit-integer?)
 
 (define offset? Offset?)
 
-(define-syntax-rule
-  (def-registers (group r ...) ...)
-  (begin
-    (begin ; (provide r) ... ; avoid for now
-           (define r 'r) ...
-           (define group
-             (list r ...)))
-    ...))
-
-(def-registers
-  (64-bit-registers     rax rbx rcx rdx rsi  rdi  rbp rsp r8  r9  r10  r11  r12  r13  r14  r15)
-  (32-bit-registers     eax ebx ecx edx esi  edi  ebp esp r8d r9d r10d r11d r12d r13d r14d r15d)
-  (16-bit-registers      ax  bx  cx  dx  si   di  bp  sp  r8w r9w r10w r11w r12w r13w r14w r15w)
-  (8-bit-high-registers  ah  bh  ch  dh)
-  (8-bit-low-registers   al  bl  cl  dl  sil  dil bpl spl r8b r9b r10b r11b r12b r13b r14b r15b))
-
-(define registers
-  (append 64-bit-registers 32-bit-registers 16-bit-registers 8-bit-high-registers 8-bit-low-registers))
-
-(define (make-register-converter group)
-  (define (f x) (or (cdr x) (error "no conversion available")))
-  (lambda (r)
-    (cond
-      [(assq r (map cons 64-bit-registers group)) => f]
-      [(assq r (map cons 32-bit-registers group)) => f]
-      [(assq r (map cons 16-bit-registers group)) => f]
-      [(assq r (map cons 8-bit-low-registers group)) => f]
-      [(assq r (map cons 8-bit-high-registers (take group 4))) => f])))
-
-(provide reg-8-bit-low reg-8-bit-high reg-16-bit reg-32-bit reg-64-bit)
-(define reg-8-bit-low (make-register-converter 8-bit-low-registers))
-(define reg-8-bit-high (make-register-converter (append 8-bit-high-registers (make-list 12 #f))))
-(define reg-16-bit (make-register-converter 16-bit-registers))
-(define reg-32-bit (make-register-converter 32-bit-registers))
-(define reg-64-bit (make-register-converter 64-bit-registers))
-
-(define (register? x)
-  (and (memq x registers)
-       #t))
-
-(define (register-size r)
-  (cond [(memq r 64-bit-registers) 64]
-        [(memq r 32-bit-registers) 32]
-        [(memq r 16-bit-registers) 16]
-        [(memq r  8-bit-high-registers) 8]
-        [(memq r  8-bit-low-registers)  8]))
-
 (define (integer-size x)
-  (integer-length (abs x)))
-
-(define (64-bit-integer? x)
-  (and (exact-integer? x)
-       (<= (integer-size x) 64)))
-
-(define (32-bit-integer? x)
-  (and (exact-integer? x)
-       (<= (integer-size x) 32)))
-
-(define (label? x)
-  (and (symbol? x)
-       (nasm-label? x)
-       (not (register? x))))
+  (if (negative? x)
+      (add1 (integer-length (sub1 (- x))))
+      (integer-length x)))
+
+(define (n-bit-integer n)
+  (λ (x)
+    (and (exact-integer? x)
+         (<= (- (expt 2 (sub1 n))) x (sub1 (expt 2 n))))))
+
+(define 64-bit-integer? (n-bit-integer 64))
+(define 32-bit-integer? (n-bit-integer 32))
+(define 16-bit-integer? (n-bit-integer 16))
+(define 8-bit-integer? (n-bit-integer 8))
 
 (provide (rename-out [a86:instruction? instruction?]))
 (define (a86:instruction? x)

a86/info.rkt

@@ -3,3 +3,4 @@
 (define collection "a86")
 (define deps (list "base" "rackunit" "redex-lib" "redex-gui-lib"))
 (define scribblings '(("scribblings/a86.scrbl")))
+(define test-omit-paths '("scribblings/"))

a86/interp.rkt

@@ -1,7 +1,10 @@
 #lang racket
 (provide/contract
  [current-objs  (parameter/c (listof path-string?))]
- [asm-interp    (-> (listof instruction?) any/c)]
+ [asm-interp    ;(-> (listof instruction?) any/c)
+  (->* () #:rest (or/c (listof instruction?)
+                       (listof (listof instruction?)))
+       any/c)]
  [asm-interp/io (-> (listof instruction?) string? any/c)])
 
 (define-logger a86)
@@ -22,11 +25,11 @@
 (define current-objs
   (make-parameter '()))
 
-;; Asm -> Value
+;; Asm ... -> Value
 ;; Interpret (by assemblying, linking, and loading) x86-64 code
 ;; Assume: entry point is "entry"
-(define (asm-interp a)
-  (asm-interp/io a #f))
+(define (asm-interp . is)
+  (asm-interp/io is #f))
 
 (define fopen
   (get-ffi-obj "fopen" (ffi-lib #f) (_fun _path _string/utf-8 _-> _pointer)))
@@ -69,7 +72,7 @@
                      r8 r9 r10 r11 r12 r13 r14 r15 instr flags)
                regs)))
 
-;; Asm String -> (cons Value String)
+;; 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)
@@ -82,23 +85,44 @@
   (define t.in  (path-replace-extension t.s #".in"))
   (define t.out (path-replace-extension t.s #".out"))
 
+  ;; If the initial label is declared global, jump to that, otherwise
+  ;; generate an initial label at first instruction and jump there
+
+  (define init-label
+    (match (findf Label? a)
+      [(Label ($ l)) l]
+      [_ #f]))
+
+  (define global?
+    (and init-label
+         (ormap (match-lambda
+                  [(Global g) (eq? g init-label)]
+                  [_ #f])
+                a)))
+
+  (define a*
+    (cond
+      [(and init-label global?) (apply prog a)]
+      [else (let ((i (symbol->label (gensym 'init))))
+              (set! init-label i)
+              (apply prog
+                     (Global i)
+                     (Label i)
+                     a))]))
+
   (with-output-to-file t.s
     #:exists 'truncate
     (λ ()
       (parameterize ((current-shared? #t))
         (asm-display (if *debug*?
-                         (debug-transform a)
-                         a)))))
+                         (debug-transform a*)
+                         a*)))))
 
   (nasm t.s t.o)
   (ld t.o t.so)
 
   (define libt.so (ffi-lib t.so))
 
-  (define init-label
-    (match (findf Label? a)
-      [(Label ($ l)) l]
-      [_ (error "no initial label found")]))
 
   (define entry
     (get-ffi-obj init-label libt.so (_fun _pointer _-> _int64)))
@@ -189,7 +213,7 @@
   (raise (exn:nasm (format "~a\n\n~a~a" nasm-msg msg (nasm-offending-line msg))
                    (current-continuation-marks))))
 
-(define (nasm-offending-line msg)  
+(define (nasm-offending-line msg)
   (match (regexp-match
           "(.*):([0-9]+): error: " msg)
     [(list _ (app string->path file) (app string->number line))
@@ -204,7 +228,7 @@
                (loop (read-line) (sub1 i)))))))]
     [_ ""]))
 
-  
+
 ;; run nasm on t.s to create t.o
 (define (nasm t.s t.o)
   (define err-port (open-output-string))

a86/main.rkt

@@ -1,7 +1,9 @@
 #lang racket
 (require "ast.rkt"
+         "registers.rkt"
          "interp.rkt"
          "printer.rkt")
 (provide (all-from-out "ast.rkt"
+                       "registers.rkt"
                        "interp.rkt"
                        "printer.rkt"))