shark-compiler/compiler.rkt

#lang racket

;; LLIR
;; defs
;; (global x)
;; (const x) ;; TODO
;; (set! x immediate)
;;
;; the only thing that accepts immediates is set!
;; all other ops need globals or consts
;; all globals, constants, and labels share a single namespace.
;; for example, there cannot be a global named helloworld and a label also named helloworld
;;
;; branching
;; (label x)
;; (goto x)
;; (ifeq a b x y)
;;   note: implement ifne by swapping x,y
;; (iflt a b x y)
;;   note: implement ifgt by swapping a,b
;;                   ifle by swapping a,b and x,y
;;                   ifge by swapping x,y
;; (terminate)
;;
;; arithmetic
;; (add! a b) a += b
;; (sub! a b) a -= b
;; (mul! a b) etc
;; (div! a b)
;; (mod! a b)
;; bitwise
;; (and! a b)
;; (or! a b)
;; (xor! a b)
;; (invert! a)
;;
;; target language
;; passes all args to the target assembler
;; (asm! ...)
;; (asmgoto! [x y] ...) ;; impl-defined branching operation
;; (prelude) implementation-defined prelude

;; predicates for opcodes

(define binary-branch-ops (set 'ifeq 'iflt))
(define (binary-branch-op? x)
  (and (symbol? x) (set-member? binary-branch-ops x)))

(define binary-arith-ops
  (set 'add! 'sub! 'mul! 'div! 'mod! 'and! 'or! 'xor!))
(define (binary-arith-op? x)
  (and (symbol? x) (set-member? binary-arith-ops x)))

(define unary-arith-ops (set 'invert!))
(define (unary-arith-op? x)
  (and (symbol? x) (set-member? unary-arith-ops x)))


;; low-level representation of a memory location
(struct mem-loc [value] #:transparent)

;; basic block node
;; contents:
;; - LLIR list with LLIR branch instruction
;; - target contents with struct branch
;; - target contents with list of branch labels
;; - target contents with list of branch numbers
(struct bbnode [contents branch] #:transparent)

;; low-level branch representation, with a target node and optional cleanup sequence
;; the setup and cleanup will get converted into basic blocks and merged such that each bb ends
;; directly with a branch
(struct branch [setup targets cleanups] #:transparent)

;; compiler context
(struct cctx [num-globals] #:transparent)
(define current-cctx (make-parameter #f))


;; validates LLIR for consistency
;; check every used symbol is a defined global or const
;; check every branch points to a valid label
;; validate args on each op
;; check that main label is present, start label is not present
(define (validate src)
  (error "TODO")) ;; lmao


;; LLIR -> LLIR Int
;; assigns each global a number and returns total number of globals
(define (convert-globals src)
  ;; create src without the global declarations
  (define new-src (filter (lambda (x) (not (symbol=? (first x) 'global))) src))
  ;; map globals to memory locations
  (define globals (for/list ([x (in-list src)] #:when (symbol=? (first x) 'global)) (second x)))
  (define global-map
    (for/hash ([i (in-naturals)] [glob (in-list globals)])
      (values glob (mem-loc i))))

  (define (translate x) (hash-ref global-map x))

  (define (update-arg x)
    (if (hash-has-key? global-map x) (translate x) x))

  (define (update-op op)
    (match op
      [(list 'set! target value)
       (list 'set! (translate target)
             (if (symbol? value) (translate value) value))]
      [(list (? binary-branch-op? op) a b x y)
       (list op (translate a) (translate b) x y)]
      [(list (? binary-arith-op? op) a b)
       (list op (translate a) (translate b))]
      [(list (? unary-arith-op? op) a)
       (list op (translate a))]
      [(list 'asm! args ...)
       (cons 'asm! (map update-arg args))]
      [(list 'asmgoto! branches args ...)
       (cons 'asmgoto! (cons branches (map update-arg args)))]
      [any any]))

  (values (map update-op new-src) (length globals)))


;; builds graph of basic blocks
(define (convert-bb src)
  (define graph (make-hash))

  (define (bb-commit! lab blk branch)
    (hash-set! graph lab (bbnode blk branch)))

  (define (convert-step this-label this-block src)
    (match src
      ['() (bb-commit! this-label this-block (list 'terminate))]
      [(cons (list 'label lab) rst)
       (bb-commit! this-label this-block (list 'goto lab))
       (convert-step lab '() rst)]
      [(cons (list 'goto next) rst)
       (bb-commit! this-label this-block (list 'goto next))
       (convert-step (gensym) '() rst)]
      [(cons (list (? binary-branch-op? op) a b x y) rst)
       (bb-commit! this-label this-block (list op a b x y))
       (convert-step (gensym) '() rst)]
      [(cons (cons 'asmgoto! args) rst)
       (bb-commit! this-label this-block (cons 'asmgoto! args))
       (convert-step (gensym) '() rst)]
      [(cons (list 'terminate) rst)
       (bb-commit! this-label this-block (list 'terminate))
       (convert-step (gensym) '() rst)]
      [(cons fst rst)
       (convert-step this-label (append this-block (list fst)) rst)]))

  (define (graph-prune g)
    (define (dfs! g seen label)
      (unless (set-member? seen label)
        (set-add! seen label)
        (match (bbnode-branch (hash-ref g label))
          [(list 'terminate) (void)]
          [(list 'goto next) (dfs! g seen next)]
          [(list (? binary-branch-op? op) _ _ x y)
           (dfs! g seen x)
           (dfs! g seen y)]
          [(list 'asmgoto! branches args)
           (for ([next (in-list branches)])
             (dfs! g seen next))])))
    (define marked (mutable-set))
    (dfs! g marked 'start)
    (for/hash ([(k v) (in-hash g)]
               #:when (set-member? marked k))
      (values k v)))

  ;; generate graph of bb nodes
  ;; insert prelude
  (convert-step 'start '((prelude)) (cons '(goto main) src))

  ;; prune unreachable blocks
  (graph-prune graph))


;; expands and simplifies target-compiled basic blocks
;; numbers each label and returns a vector of numbered blocks
(define (convert-flat graph)
  (define new-graph (make-hash))

  (for ([(k v) (in-hash graph)])
    (match-define (bbnode contents (branch setup targets cleanups)) v)
    (define cleanups-labels (map (lambda (_) (gensym)) cleanups))
    (for ([target (in-list targets)] [cleanup (in-list cleanups)] [label (in-list cleanups-labels)])
      (hash-set! new-graph label (bbnode cleanup (list target))))
    (hash-set! new-graph k (merge-bb
                             (bbnode contents '())
                             (bbnode setup cleanups-labels))))

  ;; simplifies the bb graph to a smaller number of blocks, if possible
  (define (simplify-graph!)
    ;; generate reverse edges map
    (define graph-rev (make-hash))
    (define (update-rev! label called-by)
      (hash-update! graph-rev label (lambda (v) (set-add v called-by)) set))

    (for ([(k v) (in-hash new-graph)])
      (match-define (bbnode _ branches) v)
      (for ([to (in-list branches)])
        (update-rev! to k)))

    ;; for each edge A->B
    ;; if this is the only edge out of A and the only edge into B, then merge A and B
    (define keys (hash-keys new-graph))
    (for ([key (in-list keys)])
      (define rev (hash-ref graph-rev key set))
      (when (= 1 (set-count rev))
        (define from-key (set-first rev))
        (define from-node (hash-ref new-graph from-key))
        (when (= 1 (length (bbnode-branch from-node)))
          ;; call target merge function
          (define new-node (merge-bb from-node (hash-ref new-graph key)))
          ;; update graphs for merge
          (hash-set! new-graph from-key new-node)
          (hash-remove! new-graph key)
          (hash-remove! graph-rev key)
          (for ([next (in-list (bbnode-branch new-node))])
            (hash-update! graph-rev next
                          (lambda (v) (set-map v (lambda (x) (if (equal? x key) from-key x))))
                          set))
          (void)))))

  (simplify-graph!)

  ;; create a vector of keys, ensure that start is at the front
  (define new-keys
    (list->vector
      (let ([tmp (hash-keys new-graph)])
        (cons 'start (filter (lambda (x) (not (symbol=? x 'start))) tmp)))))
  (define keys-map (for/hash ([i (in-naturals)] [e (in-vector new-keys)]) (values e i)))

  ;; replace labels with numbers. now we have a low level representation of the target code ready
  ;; to pass to link-bb
  (for/vector #:length (vector-length new-keys) ([e (in-vector new-keys)])
    (match-define (bbnode contents bl) (hash-ref new-graph e))
    (bbnode contents (map (lambda (x) (hash-ref keys-map x)) bl))))


;; steps:
;; 1. transform globals
;; 2. build bb graph
;; 3. assemble bb contents
;; 4. expand, merge, and flatten graph
;; 5. link

(define (compile prog)
  (define-values (prog-t1 nglobals) (convert-globals prog))
  (parameterize ([current-cctx (cctx nglobals)])
    (define prog-t2 (convert-bb prog-t1))
    (define prog-t3 (for/hash ([(k v) (in-hash prog-t2)]) (values k (assemble-bb v))))
    (define prog-t4 (convert-flat prog-t3))
    (define prog-final (link-bb prog-t4))
    prog-final))


;;;;;;;; targeting
;; target implementation must define
;; - assemble-bb: assembles the contents of one basic block
;; - merge-bb: merges two compiled basic blocks
;; - link-bb: links basic blocks into final output

;; this targets an apparently befunge-inspired lang called laser
;; (https://github.com/Quintec/LaserLang)

(define (chr* c n)
  (apply string (make-list n c)))

(define (mem->scratch loc)
  (string-append
    (chr* #\u (mem-loc-value loc))
    "rs"
    (chr* #\d (mem-loc-value loc))))

(define (scratch->mem loc)
  (string-append
    (chr* #\u (mem-loc-value loc))
    "pUwD"
    (chr* #\d (mem-loc-value loc))))

(define (basic-binary-op op)
  (lambda (a b)
    (string-append "UU" (mem->scratch a) (mem->scratch b) "U" op "D" (scratch->mem a) "DD")))

(define (basic-branch-op op)
  (lambda (a b x y)
    (branch
      (string-append
        "UU" (mem->scratch a) (mem->scratch b) "U" op "⌝")
      (list x y)
      (list "pDDD" "pDDD"))))

(define assemblers
  (hash
    'prelude (lambda ()
               (string-append "IUU" (chr* #\0 (cctx-num-globals (current-cctx))) "DD"))
    'set! (lambda (target value)
            (if (mem-loc? value)
              (string-append "UU" (mem->scratch value) (scratch->mem target) "DD")
              (string-append "UUU'" (number->string value) "'D" (scratch->mem target) "DD")))
    'add! (basic-binary-op "+")
    'sub! (basic-binary-op "-")
    'mul! (basic-binary-op "×")
    'div! (basic-binary-op "÷")
    'mod! (basic-binary-op "%")
    'and! (basic-binary-op "&")
    'or! (basic-binary-op "|")
    'xor! (lambda (a b) (error "unimplemented"))
    'invert! (lambda (a)
               (string-append "UU"
                              (chr* #\u (mem-loc-value a))
                              "~"
                              (chr* #\u (mem-loc-value a))
                              "DD"))
    'asm! (lambda args
            (match args
              ;; support input and output vars
              [(list asm "r" r-vars ... "w" w-var)
               (string-append
                 "UU"
                 (if r-vars
                   (apply string-append (map mem->scratch r-vars))
                   "")
                 "U" asm "D"
                 (if w-var
                   (scratch->mem w-var)
                   "")
                 "DD")]
              [_ (error "invalid asm form")]))
    'asmgoto! (lambda (branches . args) (error "unimplemented"))
    'ifeq (basic-branch-op "=")
    'iflt (basic-branch-op "l")
    'goto (lambda (a) (branch "" (list a) (list "")))
    'terminate (lambda () (branch "U#" '() '()))))

;; export

(define (assemble-bb bb)
  ;; algorithm: maintain the following stacks: input, output, memory, scratch
  ;; LLIR globals get allocated into memory
  ;; scratch is used to implement LLIR ops
  (define (assemble-op op)
    (match (hash-ref assemblers (first op) #f)
      [#f (error "target doesn't implement" op)]
      [func (apply func (rest op))]))
  (match-define (bbnode contents branch) bb)
  (bbnode (string-join (map assemble-op contents) "") (assemble-op branch)))


(define (merge-bb bb1 bb2)
  (bbnode (string-append (bbnode-contents bb1) (bbnode-contents bb2)) (bbnode-branch bb2)))


; takes a vector of basic blocks and renders the result
(define (link-bb bbvec)
  ;; represent as sparse 2d matrix
  (define render (make-hash))
  ;; algorithm
  ;; - each bb gets 3 lines, the first line is the bb, line 2 is normal return, line 3 is
  ;;   branch return (if any)
  ;; - the left side is a switching matrix that links return lines to the next bb
  (for ([i (in-naturals)] [bb (in-vector bbvec)])
    (define line
      (string-append
        (chr* #\space i)
        ">"
        (chr* #\space (- (vector-length bbvec) i 1))
        (bbnode-contents bb)
        "v"))
    ;; render line
    (for ([j (in-naturals)] [c (in-string line)])
      (hash-set! render (cons (* i 3) j) c))
    ;; insert returns
    (hash-set! render (cons (+ (* i 3) 1) (- (string-length line) 1)) #\<)
    (hash-set! render (cons (+ (* i 3) 2) (- (string-length line) 2)) #\<)
    (for ([j (in-naturals)] [target (in-list (bbnode-branch bb))])
      (hash-set! render
                 (cons (+ (* i 3) 1 j)
                       target)
                 (if (> target i) #\v #\^)))
    (void))

  ;; convert matrix to string
  (define w (add1 (apply max (map cdr (hash-keys render)))))
  (define h (add1 (apply max (map car (hash-keys render)))))
  (string-join
    (for/list ([y (in-range h)])
      (list->string
        (for/list ([x (in-range w)])
          (hash-ref render (cons y x) #\space))))
    "\n"))

;;;;;;;; #lang
(define-syntax-rule (llir-module-begin EXPR ...)
  (#%module-begin
   (displayln (compile `(EXPR ...)))))

(provide (except-out (all-from-out racket) #%module-begin) ; probably overkill, w/e
         (rename-out [llir-module-begin #%module-begin]))