wip: start working on trivial register allocation

aarch64var.rkt

@@ -1,6 +1,19 @@
 #lang racket
 
-(provide Label Var Reg Imm LMov Add Sub RetDefault Svc Bl)
+(provide 
+ (struct-out Label)
+ (struct-out Var)
+ (struct-out Reg)
+ (struct-out Imm)
+ (struct-out LMov)
+ (struct-out AMOffset)
+ (struct-out Ldr)
+ (struct-out Str)
+ (struct-out Add)
+ (struct-out Sub)
+ (struct-out RetDefault)
+ (struct-out Svc)
+ (struct-out Bl))
 
 (require racket/struct)
 
@@ -10,6 +23,9 @@
 (struct Reg (reg-name) #:transparent)
 (struct Imm (immediate) #:transparent)
 (struct LMov (src dest) #:transparent)
+(struct AMOffset (base-reg offset) #:transparent)
+(struct Ldr (src dest) #:transparent)
+(struct Str (src dest) #:transparent)
 (struct Add (op1 op2 dest) #:transparent)
 (struct Sub (op1 op2 dest) #:transparent)
 (struct RetDefault () #:transparent)
@@ -23,3 +39,4 @@
     x19 x20 x21 x22 x23 x24
     x25 x26 x27 x28 x29 x30
     sp pc xzr))
+

allocate-regs.rkt

@@ -0,0 +1,105 @@
+#lang racket
+
+(require "aarch64var.rkt")
+
+; the allocation strategy is quite trivial:
+; always use stack to store results of operations and retrieve operands
+; use temporary registers starting from x0 to perform the operation
+; note that this separation is necessary because ARM is a load/store ISA
+; x0 is used to store the returned value as per Aarch64 calling convention,
+; this is already handled by instruction selection
+
+
+; allocate-regs-std-instr
+; this procedure should only be applied to: Add, Sub, RetDefault, Svc, Bl etc
+; Use allocate-regs-lmov-instr for LMov
+
+; stack-map is a map with keys being the variables
+; and values the position relative to stack base (frame pointer?)
+
+; stack-top is the offset where an eventual next variable would be
+; allocated into the stack
+; note that this is a virtual offset; sp must by aligned to 16 bytes
+
+; returns the generated instructions
+; the stack-map is modified if needed
+;
+; TODO: does it make sense to use create-stack-bindings on instr-args?
+(define (allocate-regs-std-instr! instr stack-map stack-top)
+   (begin
+     (define instr-dest (AArch64-instr-dest instr))
+     (define instr-args (AArch64-instr-args instr))
+     (create-stack-bindings! (append instr-args instr-dest) stack-map stack-top)
+     (define reg-args (generate-regs 0 (length instr-args)))
+     (define reg-dest (generate-regs (length instr-args) (length instr-dest)))
+     (append (generate-ldr instr-args stack-map)
+             (list (AArch64-instr-from-dest-args instr reg-dest reg-args))
+             (generate-str instr-dest stack-map))))
+
+(define (generate-regs start len)
+  (map (lambda (i)
+           (Reg (string->symbol (string-append "x" (number->string i)))))
+       (range start (+ start len))))
+     
+(define (generate-ldr var-list stack-map)
+  (for/list ([var var-list]
+             [reg (generate-regs 0 (length var-list))])
+     (Ldr (AMOffset 'sp (hash-ref stack-map (Var-var-name var))) reg)))
+
+(define (generate-str var-list stack-map)
+  (list))
+
+
+; generate stack read/writes and allocate registers for
+; a LMov instruction
+;(define (allocate-regs-lmov-instr! instr stack-map))
+
+; create bindings for the operands that are Var
+(define (create-stack-bindings! operand-list stack-map stack-top)
+ (begin
+  (for-each (lambda (op)
+                (match op
+                   [(Var var-name)
+                    (begin
+                     (create-stack-binding! var-name stack-map stack-top))]
+                   [_ '()]))
+       operand-list)))
+
+; modify the stack map if the variable is not there yet
+; only works for 64 bit integers
+(define (create-stack-binding! var-name stack-map stack-top)
+   (begin
+     (hash-update! stack-map
+                   var-name
+                   identity
+                   stack-top)
+     (set! stack-top (- stack-top 8))))
+                 
+(define (AArch64-instr-dest instr)
+  (match instr
+    [(? LMov?) (list (LMov-dest instr))]
+    [(? Add?) (list (Add-dest instr))]
+    [(? Sub?) (list (Sub-dest instr))]
+    [(? RetDefault?) (list)]))
+
+(define (AArch64-instr-args instr)
+  (match instr
+    [(? LMov?) (list (LMov-src instr))]
+    [(Add op1 op2 _) (list op1 op2)]
+    [(Sub op1 op2 _) (list op1 op2)]
+    [(? RetDefault?) (list)]))
+
+(define (AArch64-instr-from-dest-args instr dest args)
+  (let ([constructor-args
+         (match instr
+          [(? LMov?) (append args dest)]
+          [(? Add?) (append args dest)]
+          [(? Sub?) (append args dest)]
+          [(? RetDefault?) (list)])])
+     (construct-new-instr instr constructor-args)))
+
+(define (construct-new-instr instr args)
+   (let*-values ([(struct-type _) (struct-info instr)]
+                 [(constructor) (struct-type-make-constructor struct-type)])
+     (apply constructor args)))
+

tests/all-tests.rkt

@@ -11,6 +11,7 @@
 ;(require "test-explicate-control.rkt")
 (require "test-cvar-to-bril.rkt")
 (require "test-select-instr.rkt")
+(require "test-allocate-regs.rkt")
 
 (define all-tests
   (test-suite
@@ -22,5 +23,6 @@
    ;remove-complex-opera-tests
    ;explicate-control-tests
    cvar-to-bril-tests
-   select-instr-tests))
+   select-instr-tests
+   allocate-regs-tests))
    

tests/test-allocate-regs.rkt

@@ -0,0 +1,34 @@
+#lang racket
+
+(provide allocate-regs-tests)
+
+(require rackunit)
+
+(require "../aarch64var.rkt")
+(require/expose "../allocate-regs.rkt"
+                (allocate-regs-std-instr!))
+
+(define listing-1
+ (list (Label "main")
+       (LMov (Imm 0) (Var "c"))
+       (LMov (Imm 2) (Var "d"))
+       (Add (Var "c") (Var "d") (Var "b"))
+       (LMov (Reg 'x0) (Var "b"))
+       (RetDefault)))
+
+(define allocate-regs-tests
+  (test-suite
+   "Register Allocation"
+   
+   (test-suite
+    "Single instruction allocation"
+    (test-case
+      "Add"
+      (check-equal?
+        (allocate-regs-std-instr! (Add (Var "a") (Var "b") (Var "c"))
+                                  (make-hash (list (cons "a" -0) (cons "b" -8)))
+                                  -16)
+        (list (Ldr (AMOffset 'sp 0) (Reg 'x0))
+              (Ldr (AMOffset 'sp -8) (Reg 'x1))
+              (Add (Reg 'x0) (Reg 'x1) (Reg 'x2))))))))
+