Initial sketch of instruction annotation mechanism.

Author: dvanhorn

langs/a86/ast.rkt

@@ -7,46 +7,46 @@
 ;; with decent error messages.
 
 (define check:label-symbol
-  (λ (x n)
+  (λ (a x n)
     (when (register? x)
       (error n "cannot use register as label name; given ~v" x))
     (unless (symbol? x)
       (error n "expects symbol; given ~v" x))
     (unless (label? x)
       (error n "label names must conform to nasm restrictions"))
-    x))
+    (values a x)))
 
 (define check:label-symbol+integer
-  (λ (x c n)
+  (λ (a x c n)
     (check:label-symbol x n)
     (unless (integer? c)
       (error n "expects integer constant; given ~v" c))
-    (values x c)))
+    (values a x c)))
 
 (define check:target
-  (λ (x n)
+  (λ (a x n)
     (unless (or (symbol? x) (offset? x)); either register or label
       (error n "expects symbol; given ~v" x))
-    x))
+    (values a x)))
 
 (define check:arith  
-  (λ (a1 a2 n)
+  (λ (a a1 a2 n)
     (unless (register? a1)
       (error n "expects register; given ~v" a1))
     (unless (or (exact-integer? a2) (register? a2) (offset? a2))
       (error n "expects exact integer, register, or offset; given ~v" a2))
     (when (and (exact-integer? a2) (> (integer-length a2) 32))
       (error n "literal must not exceed 32-bits; given ~v (~v bits); go through a register instead" a2 (integer-length a2)))
-    (values a1 a2)))
+    (values a a1 a2)))
 
 (define check:register
-  (λ (a1 n)
+  (λ (a a1 n)
     (unless (register? a1)
       (error n "expects register; given ~v" a1))
-    a1))
+    (values a a1)))
 
 (define check:src-dest
-  (λ (a1 a2 n)
+  (λ (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))
@@ -57,10 +57,10 @@
       (error n "literal must not exceed 32-bits; given ~v (~v bits); go through a register instead" a2 (integer-length a2)))
     (when (and (offset? a1) (exact-integer? a2))
       (error n "cannot use a memory locations and literal; given ~v, ~v; go through a register instead" a1 a2))
-    (values a1 a2)))
+    (values a a1 a2)))
 
 (define check:mov
-  (λ (a1 a2 n)
+  (λ (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))
@@ -71,43 +71,43 @@
       (error n "literal must not exceed 64-bits; given ~v (~v bits)" a2 (integer-length a2)))
     (when (and (offset? a1) (exact-integer? a2))
       (error n "cannot use a memory locations and literal; given ~v, ~v; go through a register instead" a1 a2))
-    (values a1 a2)))
+    (values a a1 a2)))
 
 (define check:shift
-  (λ (a1 a2 n)
+  (λ (a a1 a2 n)
     (unless (register? a1)
       (error n "expects register; given ~v" a1))
     (unless (or (and (exact-integer? a2) (<= 0 a2 63))
                 (eq? 'cl a2))
       (error n "expects exact integer in [0,63]; given ~v" a2))
-    (values a1 a2)))      
+    (values a a1 a2)))      
 
 (define check:offset
-  (λ (r i n)
+  (λ (a r i n)
     (unless (or (register? r) (label? r))
       (error n "expects register or label as first argument; given ~v" r))
     (unless (exact-integer? i)
       (error n "expects exact integer as second argument; given ~v" i))
-    (values r i)))
+    (values a r i)))
 
 (define check:push
-  (λ (a1 n)
+  (λ (a a1 n)
     (unless (or (exact-integer? a1) (register? a1))
       (error n "expects exact integer or register; given ~v" a1))
     (when (and (exact-integer? a1) (> (integer-length a1) 32))
       (error n "literal must not exceed 32-bits; given ~v (~v bits); go through a register instead" a1 (integer-length a1)))
-    a1))
+    (values a a1)))
 
 (define check:lea
-  (λ (dst x n)
+  (λ (a dst x n)
     (unless (or (register? dst) (offset? dst))
       (error n "expects register or offset; given ~v" dst))
     (unless (or (label? x) (offset? x) (exp? x))
       (error n "expects label, offset, or expression; given ~v" x))
-    (values dst x)))
+    (values a dst x)))
 
 (define check:none
-  (λ (n) (values)))
+  (λ (a n) (values a)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Comments
@@ -132,12 +132,42 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Instructions
 
-(define-syntax-rule
-  (instruct Name (x ...) guard)
-  (begin (provide (struct-out Name))
-         (struct Name (x ...)
-           #:transparent
-           #:guard guard)))
+(require racket/struct)
+(define current-annotation (make-parameter #f))
+(provide instruction-annotation current-annotation)
+
+(struct instruction (annotation))
+
+(define-syntax (instruct stx)
+  (syntax-case stx ()
+    [(instruct Name (x ...) guard)
+     (with-syntax ([Name? (datum->syntax stx (string->symbol (string-append (symbol->string (syntax->datum #'Name)) "?")))])
+     #'(begin (provide Name Name?)              
+              (define-match-expander Name
+                (lambda (stx)
+                  (syntax-case stx ()
+                    [(_ elts (... ...))
+                     #'(%Name _ elts (... ...))]))
+                (lambda (stx)
+                  (syntax-case stx ()
+                    [m (identifier? #'m) #'(λ (x ...) (%Name (current-annotation) x ...))]
+                    [(m x ...) #'(%Name (current-annotation) x ...)])))
+              (struct %Name instruction (x ...)
+                #:transparent
+                #:guard guard
+                #:methods gen:equal+hash
+                [(define equal-proc (λ (i1 i2 equal?)
+                                      (equal? (struct->vector i1)
+                                              (struct->vector i2))))
+                 (define hash-proc  (λ (i hash) (hash (struct->vector i))))
+                 (define hash2-proc (λ (i hash) (hash (struct->vector i))))]
+                #:methods gen:custom-write
+                [(define write-proc
+                   (make-constructor-style-printer
+                    (lambda (obj) 'Name)        
+                    (lambda (obj)
+                      (rest (rest (vector->list (struct->vector obj)))))))])
+              (define Name? %Name?)))]))
 
 (instruct Text   ()        check:none)
 (instruct Data   ()        check:none)
@@ -167,15 +197,15 @@
 (instruct Lea    (dst x)   check:lea)
 (instruct Div    (den)     check:register)
 
-(instruct Offset (r i)     check:offset)
+(instruct Offset (r i)     check:offset)        ;; May need to make this not an instruction
 (instruct Extern (x)       check:label-symbol)
 
 (instruct Equ    (x v)     check:label-symbol+integer)
 (instruct Const  (x)       check:label-symbol)
 
 ;; IMPROVE: do more checking
-(instruct Dd (x) (lambda (x n) x))
-(instruct Dq (x) (lambda (x n) x))
+(instruct Dd (x) (lambda (a x n) (values a x)))
+(instruct Dq (x) (lambda (a x n) (values a x)))
 
 (provide (struct-out Plus))
 (struct Plus (e1 e2) #:transparent)
@@ -210,6 +240,7 @@
        (nasm-label? x)
        (not (register? x))))
 
+#;
 (define (instruction? x)
   (or (Text? x)
       (Data? x)

langs/a86/printer.rkt

@@ -73,9 +73,19 @@
       [_ (label-symbol->string e)]))
 
   (define tab (make-string 8 #\space))
+
+  ;; Instruction -> String
+  (define (fancy-instr->string i)
+    (let ((s (simple-instr->string i)))
+      (if (instruction-annotation i)
+          (if (< (string-length s) 40)
+              (format "~a~a; ~.a" s (make-string (- 40 (string-length s)) #\space) (instruction-annotation i))
+              (format "~a ; ~.a" s (instruction-annotation i)))
+          s)))
+  
 
   ;; Instruction -> String
-  (define (instr->string i)
+  (define (simple-instr->string i)
     (match i
       [(Text)      (string-append tab "section .text")]
       [(Data)      (string-append tab "section .data align=8")] ; 8-byte aligned data
@@ -180,7 +190,7 @@
       [(%%% s) (string-append ";;; " s)]))
 
   (define (line-comment i s)
-    (let ((i-str (instr->string i)))
+    (let ((i-str (simple-instr->string i)))
       (let ((pad (make-string (max 1 (- 32 (string-length i-str))) #\space)))
         (string-append i-str pad "; " s))))
 
@@ -193,11 +203,11 @@
               (write-char #\newline)
               (instrs-display a))]
       [(cons i (cons (% s) a))
-       (begin (write-string (line-comment i s))
+       (begin (write-string (line-comment i s)) ; a line comment trumps an annotation
               (write-char #\newline)
               (instrs-display a))]
       [(cons i a)
-       (begin (write-string (instr->string i))
+       (begin (write-string (fancy-instr->string i))
               (write-char #\newline)
               (instrs-display a))]))
 

langs/iniquity/compile.rkt

@@ -10,6 +10,8 @@
 
 ;; type CEnv = [Listof Variable]
 
+(current-annotation "top-level")
+  
 ;; Prog -> Asm
 (define (compile p)
   (match p
@@ -43,31 +45,33 @@
 
 ;; Defn -> Asm
 (define (compile-define d)
+  (parameterize ([current-annotation d])
   (match d
     [(Defn f xs e)
      (seq (Label (symbol->label f))
           (compile-e e (reverse xs))
           (Add rsp (* 8 (length xs))) ; pop args
-          (Ret))]))
+          (Ret))])))
 
 ;; Expr CEnv -> Asm
 (define (compile-e e c)
-  (match e
-    [(Int i)            (compile-value i)]
-    [(Bool b)           (compile-value b)]
-    [(Char c)           (compile-value c)]
-    [(Eof)              (compile-value eof)]
-    [(Empty)            (compile-value '())]
-    [(Var x)            (compile-variable x c)]
-    [(Str s)            (compile-string s)]
-    [(Prim0 p)          (compile-prim0 p c)]
-    [(Prim1 p e)        (compile-prim1 p e c)]
-    [(Prim2 p e1 e2)    (compile-prim2 p e1 e2 c)]
-    [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)]
-    [(If e1 e2 e3)      (compile-if e1 e2 e3 c)]
-    [(Begin e1 e2)      (compile-begin e1 e2 c)]
-    [(Let x e1 e2)      (compile-let x e1 e2 c)]
-    [(App f es)         (compile-app f es c)]))
+  (parameterize ([current-annotation e])
+    (match e
+      [(Int i)            (compile-value i)]
+      [(Bool b)           (compile-value b)]
+      [(Char c)           (compile-value c)]
+      [(Eof)              (compile-value eof)]
+      [(Empty)            (compile-value '())]
+      [(Var x)            (compile-variable x c)]
+      [(Str s)            (compile-string s)]
+      [(Prim0 p)          (compile-prim0 p c)]
+      [(Prim1 p e)        (compile-prim1 p e c)]
+      [(Prim2 p e1 e2)    (compile-prim2 p e1 e2 c)]
+      [(Prim3 p e1 e2 e3) (compile-prim3 p e1 e2 e3 c)]
+      [(If e1 e2 e3)      (compile-if e1 e2 e3 c)]
+      [(Begin e1 e2)      (compile-begin e1 e2 c)]
+      [(Let x e1 e2)      (compile-let x e1 e2 c)]
+      [(App f es)         (compile-app f es c)])))
 
 ;; Value -> Asm
 (define (compile-value v)