Merge pull request #21 from cmsc430/expr

More complete support for nasm expressions

a86/ast.rkt

@@ -95,8 +95,8 @@
   (λ (a a1 a2 n)
     (unless (or (register? a1) (offset? a1))
       (error n "expects register or offset; given ~v" a1))
-    (unless (or (register? a2) (offset? a2) (exact-integer? a2) (Const? a2) (nasm-label? a2) ($? a2))
-      (error n "expects register, offset, exact integer, or label; given ~v" a2))
+    (unless (or (register? a2) (offset? a2) (Const? a2) (exp? a2))
+      (error n "expects register, offset, or expression; given ~v" a2))
     (when (and (offset? a1) (offset? a2))
       (error n "cannot use two memory locations; given ~v, ~v" a1 a2))
     (when (and (register? a1) (exact-integer? a2) (> (integer-size a2) (register-size a1)))
@@ -107,7 +107,7 @@
       (error n "cannot move between registers of unequal size; given ~v (~v-bit), ~v (~v-bit)"
              a1 (register-size a1)
              a2 (register-size a2)))
-    (values a (exp-normalize a1) (exp-normalize a2))))
+    (values a (arg-normalize a1) (arg-normalize a2))))
 
 (define check:shift
   (λ (a a1 a2 n)
@@ -132,7 +132,7 @@
       (error n "expects register; given ~v" dst))
     (unless (exp? x)
       (error n "expects memory expression; given ~v" x))
-    (values a (exp-normalize dst) (exp-normalize x))))
+    (values a (arg-normalize dst) (arg-normalize x))))
 
 (define check:none
   (λ (a n) (values a)))
@@ -164,24 +164,93 @@
 (struct %%  Comment () #:transparent)
 (struct %%% Comment () #:transparent)
 
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Labels
+;; Expressions
 
-;; See https://github.com/cmsc430/a86/issues/2 for discussion
+(define (arg-normalize a)
+  (if (exp? a)
+      (exp-normalize a)
+      a))
 
-(provide (struct-out $))
+(provide exp?)
+
+(define (exp? x)
+  (match x
+    [(? register?) #t]
+    [(Plus (? exp?) (? exp?)) #t] ; for backwards compatability
+    [(list '? (? exp?) (? exp?) (? exp?)) #t]
+    ['$ #t]
+    ['$$ #t]
+    [(list (? exp-unop?) (? exp?)) #t]
+    [(list (? exp-binop?) (? exp?) (? exp?)) #t]
+    [($ _) #t]
+    [(? nasm-label?) #t]
+    [(? 64-bit-integer?) #t]
+    [_ #f]))
+
+(provide exp)
+
+;; exp is like quasiquote with an implicit unquote at the leaves of the expression
+;; constructors
+(define-syntax exp
+  (λ (stx) ; intentionally non-hygienic
+    (syntax-case* stx (? $ $$) (λ (i1 i2) (eq? (syntax->datum i1) (syntax->datum i2)))
+      [(_ $) #''$]
+      [(_ $$) #''$$]
+      [(_ (b e1))
+       (memq (syntax->datum #'b) exp-unops)
+       #'(list 'b (exp e1))]
+      [(_ (b e1 e2))
+       (memq (syntax->datum #'b) exp-binops)
+       #'(list 'b (exp e1) (exp e2))]
+      [(_ (? e1 e2 e3))
+       #'(list '? (exp e1) (exp e2) (exp e3))]
+      [(_ e) #'e])))
+
+(provide exp-unop?)
+(define (exp-unop? x)
+  (memq x exp-unops))
+
+(provide exp-binop?)
+(define (exp-binop? x)
+  (memq x exp-binops))
+
+(define exp-unops
+  '(- + ~ ! SEG))
+(define-for-syntax exp-unops
+  '(- + ~ ! SEG))
+(define exp-binops
+  '(<<< << < <= < <=> > >= > >> >>> = == != || \| & && ^^ ^ + - * / // % %%))
+(define-for-syntax exp-binops
+  '(<<< << < <= < <=> > >= > >> >>> = == != || \| & && ^^ ^ + - * / // % %%))
 
 ;; Exp -> Exp
 (define (exp-normalize x)
   (match x
-    [($ _) x]
     [(? register?) x]
     [(? nasm-label?) ($ x)]
-    [(? integer? i) i]
-    [(Offset e1) (Offset (exp-normalize e1))]
+    ;[(Offset e1) (Offset (exp-normalize e1))]
     [(Plus e1 e2)
-     (Plus (exp-normalize e1)
-           (exp-normalize e2))]))
+     (list '+
+           (exp-normalize e1)
+           (exp-normalize e2))]
+    [(list '? e1 e2 e3)
+     (list '? (exp-normalize e1) (exp-normalize e2) (exp-normalize e3))]
+    [(list (? exp-unop? o) e1)
+     (list o (exp-normalize e1))]
+    [(list (? exp-binop? o) e1 e2)
+     (list o (exp-normalize e1) (exp-normalize e2))]
+    [_ x]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Labels
+
+;; See https://github.com/cmsc430/a86/issues/2 for discussion
+
+(provide (struct-out $))
+
+
 
 (struct $ (label)
   #:transparent
@@ -226,8 +295,8 @@
 
 (define check:offset
   (λ (m n)
-    (unless (exp? m)
-      (error n "expects a memory expression; given ~v" m))
+    (unless (or (exp? m) (register? m))
+      (error n "expects a memory expression or register; given ~v" m))
      (values (exp-normalize m))))
 
 (struct %offset (m)
@@ -412,7 +481,8 @@
 (provide (struct-out Plus))
 (struct Plus (e1 e2) #:transparent)
 
-(provide exp?)
+#;(provide exp?)
+#;
 (define (exp? x)
   (or (Offset? x)
       (and (Plus? x)
@@ -622,17 +692,31 @@
 ;; Compute all uses of label names
 (define (label-uses i)
   (match i
+    [(? register?) '()]
     [(Label _) '()]  ; declaration, not use
     [(Extern _) '()] ; declaration, not use
     [(Offset m)
      (label-uses m)]
+    [(? exp?)
+     (exp-label-uses i)]
     [(instruction _)
      (append-map label-uses (instruction-args i))]
+    [(cons x y)
+     (append (label-uses x) (label-uses y))]
+    [_ '()]))
+
+;; Exp -> (Listof Symbol)
+(define (exp-label-uses e)
+  (match e
     [($ x) (list x)]
     [(Plus e1 e2)
      (append (label-uses e1) (label-uses e2))]
-    [(cons x y)
-     (append (label-uses x) (label-uses y))]
+    [(list '? e1 e2 e3)
+     (append (label-uses e1) (label-uses e2) (label-uses e3))]
+    [(list (? exp-unop?) e1)
+     (label-uses e1)]
+    [(list (? exp-binop?) e1 e2)
+     (append (label-uses e1) (label-uses e2))]
     [_ '()]))
 
 ;; Asm -> Void

a86/check-nasm.rkt

@@ -1,5 +1,5 @@
 #lang racket
-(provide check-nasm-available)
+(provide check-nasm-available nasm-version nasm-version-2.15+?)
 (require racket/gui/dynamic)
 
 (define nasm-msg
@@ -30,10 +30,33 @@ HERE
 (define (drracket?)
   (gui-available?))
 
+;; -> [Maybe String]
+(define (nasm-version-string)
+  (parameterize ([current-output-port (open-output-string)]
+                 [current-error-port (open-output-string)])
+    (and (system "nasm -v")
+         (get-output-string (current-output-port)))))
+
+(define (nasm-version-2.15+?)
+  (match (nasm-version)
+    [(list maj min) (and (>= maj 2) (>= min 15))]
+    [_ #f]))
+
+;; -> [Maybe (list Natural Natural)]
+(define (nasm-version)
+  (match (nasm-version-string)
+    [#f #f]
+    [(regexp #rx"([0-9]+)\\.([0-9]+)"
+             (list _ (app string->number maj) (app string->number min)))
+     (list maj min)]))
+
+;; -> Void
+;; Errors if nasm is not available, warns if available but below 2.15
 (define (check-nasm-available)
-  (unless (parameterize ([current-output-port (open-output-string)]
-                         [current-error-port (open-output-string)])
-            (system "nasm -v"))
+  (define v (nasm-version))
+  (unless v
     (error (format nasm-msg
                    (getenv "PATH")
-                   (if (and (drracket?) (macos?) (launched-with-finder?))  macosx-msg "")))))
+                   (if (and (drracket?) (macos?) (launched-with-finder?))  macosx-msg ""))))
+  (unless (nasm-version-2.15+?)
+    (eprintf "nasm 2.15 or later is recommended; some faatures may not work as expected.\n")))

a86/printer.rkt

@@ -53,7 +53,7 @@
                    (instruction-name i)
                    (apply string-append
                           (if (empty? as) "" " ")
-                          (add-between (map exp->string as)
+                          (add-between (map arg->string as)
                                        ", ")))))
 ;; Instruction -> String
 (define (fancy-instr->string i)
@@ -64,16 +64,26 @@
             (format "~a ; ~.s" s (instruction-annotation i)))
         s)))
 
+;; Exp ∪ Reg ∪ Offset -> String
+(define (arg->string e)
+  (match e
+    [(? register?) (symbol->string e)]
+    [(Offset e)
+     (string-append "[" (exp->string e) "]")]
+    [_ (exp->string e)]))
+
 ;; Exp -> String
 (define (exp->string e)
   (match e
     [(? register?) (symbol->string e)]
     [(? integer?) (number->string e)]
     [($ x) (label-symbol->string x)]
-    [(Offset e1 e2)
-     (string-append "[" (exp->string e1) " + " (exp->string e2) "]")]
-    [(Plus e1 e2)
-     (string-append "(" (exp->string e1) " + " (exp->string e2) ")")]))
+    [(list '? e1 e2 e3)
+     (string-append "(" (exp->string e1) " ? " (exp->string e2) " : " (exp->string e3) ")")]
+    [(list (? exp-unop? o) e1)
+     (string-append "(" (symbol->string o) " " (exp->string e1) ")")]
+    [(list (? exp-binop? o) e1 e2)
+     (string-append "(" (exp->string e1) " " (symbol->string o) " " (exp->string e2) ")")]))
 
 (define (text-section n)
   (match (system-type 'os)
@@ -96,8 +106,8 @@
     [(Label ($ l))  (string-append (label-symbol->string l) ":")]
     [(Lea d e)
      (string-append tab "lea "
-                    (exp->string d) ", [rel "
-                    (exp->string e) "]")]
+                    (arg->string d) ", [rel "
+                    (arg->string e) "]")]
     [(Equ x c)
      (string-append tab
                     (symbol->string x)

a86/test/expressions.rkt

@@ -0,0 +1,17 @@
+#lang racket
+(require rackunit "../ast.rkt" "../interp.rkt" "../check-nasm.rkt")
+
+(define (ev e)
+  (asm-interp (prog (Global 'entry) (Label 'entry) (Mov 'rax e) (Ret))))
+
+(check-equal? (ev '(<< 1 4)) (arithmetic-shift 1 4))
+(check-equal? (ev '(<< 1 (+ 2 2))) (arithmetic-shift 1 (+ 2 2)))
+(check-equal? (ev '(! 0)) 1)
+(check-equal? (ev '(~ 0)) -1)
+
+(when (nasm-version-2.15+?)
+  (check-equal? (ev '(< 1 2)) 1)
+  (check-equal? (ev '(< 2 1)) 0)
+  (check-equal? (ev '(? 1 2 3)) 2)
+  (check-equal? (ev '(? 0 2 3)) 3)
+  (check-equal? (ev '(? 8 2 3)) 2))