Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 198 lines (166 sloc) 6.533 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197

(import-for-syntax matchable)
(import-for-syntax srfi-1)

;; convenience constructors (used in pattern match rules)

(define-syntax define-munch-rules
  (lambda (e r c)
    (let ((%let* (r 'let*))
          (%let (r 'let))
          (%if (r 'if))
          (%cond (r 'cond))
          (%else (r 'else))
          (%define (r 'define))
          (%match (r 'match))
          (%gensym (r 'gensym))
          (%block (r 'block))
          (%tree (r 'tree))
          (%t1 (gensym 't))
          (%mc-block-append (r 'mc-block-append))
          (%mc-context-allocate-vreg (r 'mc-context-allocate-vreg))
          (%mc-block-cxt (r 'mc-block-cxt)))
 

    (define renamed '())
    (define (rename name)
      (cond
       ((assq name renamed)
        => cdr)
       (else
        (let ((x (gensym)))
          (set! renamed (cons (cons name x) renamed))
          x))))
  
    ;; select-names
    ;;
    ;; Find names (which are bound to nodes by 'match) which need to be expanded next by the maximal-munch algorithm
    ;;
    ;; (add (i32 x) op2)
    ;; => (op2)

    (define (select-names pat)
      (match pat
        ((? symbol? x)
         (list x))
        ((or ('const _ _) ('mode _) ('op _) ('label _) ('temp _))
         '())
        ((opcode operand* ...)
         (apply append (map select-names operand*)))))

    ;; compile-pattern
    ;;
    ;; Transform high-level patterns into low-level 'match patterns
    ;;
    ;; (add (i32 x) op2)
    ;; => ($ tree-instr 'add ('mode 'i32) (? i32? x) (? symbol? g67))
    ;;
    (define (compile-pattern pat)
      (define (walk pat)
      (match pat

        ;; assign
        (('assign ('temp x) op)
          `($ tree-instr 'assign _ (? symbol? ,x) ,(walk op) _ _ _ _ _))

        ;; binops
        (('add mode op1 op2)
          `($ tree-instr 'add ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
        (('sub mode op1 op2)
          `($ tree-instr 'sub ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
        (('and mode op1 op2)
          `($ tree-instr 'and ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
        (('ior mode op1 op2)
          `($ tree-instr 'ior ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
        (('xor mode op1 op2)
          `($ tree-instr 'xor ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
        (('shl mode op1 op2)
          `($ tree-instr 'shl ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
        (('shr mode op1 op2)
          `($ tree-instr 'shr ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))

        ;; load
        (('load mode addr)
          `($ tree-instr 'load ',(walk mode) ,(walk addr) _ _ _ _ _ _))

        ;; store
        (('store mode value addr)
          `($ tree-instr 'store ',(walk mode) ,(walk value) ,(walk addr) _ _ _ _ _))

        ;; brc
        (('brc cond label1 label2)
          `($ tree-instr 'brc _ ,(walk cond) ,(walk label1) ,(walk label2) _ _ _ _))

        ;; br
        (('br label)
          `($ tree-instr 'br _ ,(walk label) _ _ _ _ _ _))

        ;; cmp
        (('cmp mode ('op test) op1 op2)
          `($ tree-instr 'cmp ',(walk mode) ',test ,(walk op1) ,(walk op2) _ _ _ _))

        ;; atoms
        (('const size x)
         `($ tree-constant ',size ,x))
        (('label x)
         `($ tree-label ,x))
        (('temp x)
         `($ tree-temp ,x))

        ((? symbol? x) (rename x))

        ;; mode
        (('mode x) x)

         ;;(_ (print pat))

        ))
    (walk pat))
 
    (define (gen-bindings arch bindings)
      (let ((function-name (string->symbol (format "munch-~s" arch))))
        (match bindings
          (() '())
          ((expr . rest)
           (cons `(,expr (,function-name ,%block ,(rename expr))) (gen-bindings arch rest))))))

    (define (parse-temp-cls out)
      (match out
        (('temps t* ...) t*)
        (else (assert-not-reached))))

    (define (parse-out-cls out)
      (match out
        (('out x) x)
        (('out) #f)
        (else (assert-not-reached))))

    (define (gen-code arch pat temps out tmpl*)
      (let* ((nodes-to-expand (select-names pat))
             (pat-compiled (compile-pattern pat))
             (bindings
              (append
               ;; Bind names to expanded nodes
                (gen-bindings arch nodes-to-expand)
                (cond
                  ;; bind the name 'out' to a gensym if this production requires a return value (in which case out != #f)
                  ;; AND the user-specified return value is not already listed in nodes-to-expand.
                  ((and out (not (memq out nodes-to-expand)))
                   `((,out (,%mc-context-allocate-vreg (,%mc-block-cxt ,%block) (,%gensym 't)))))
                  (else '()))
               ;; bind temps to unique symbols (remembering not to bind 'out again if it is declared as a temp)
               (map (lambda (temp)
                      `(,temp (,%mc-context-allocate-vreg (,%mc-block-cxt ,%block) (,%gensym 't))))
                    (lset-difference eq? temps (list out))))))

        `(,pat-compiled
          (,%let* ,bindings
            (arch-emit-code ,arch ,%block ,@tmpl*)
            ,out))))

    (define (compile arch rule)
      (match rule
        ((pat temp-cls out-cls (tmpl* ...))
         (gen-code
            arch
            pat
            (parse-temp-cls temp-cls)
            (parse-out-cls out-cls)
            tmpl*))))
    
    (define (compile-rules arch rule*)
      (reverse
        (fold (lambda (rule x)
                (cons (compile arch rule) x))
              '()
              rule*)))

    (match e
      (('define-munch-rules arch rule* ...)
       (let* ((rule-compiled* (compile-rules arch rule*))
              (function-name (string->symbol (format "munch-~s" arch))))

;; (pretty-print
;; `(,%define (,function-name ,%block ,%tree)
;; (,%match ,%tree
;; (($ tree-temp ,%t1)
;; (,%mc-context-allocate-vreg (,%mc-block-cxt ,%block) ,%t1))
;; ,@rule-compiled*
;; (_ (tree-instr-print ,%tree (current-output-port)) (error "no matching pattern")))))

         `(,%define (,function-name ,%block ,%tree)
             (,%match ,%tree
               (($ tree-temp ,%t1)
                (,%mc-context-allocate-vreg (,%mc-block-cxt ,%block) ,%t1))
               ,@rule-compiled*
              (_ (tree-instr-print ,%tree (current-output-port)) (error "no matching pattern"))))))))))

Something went wrong with that request. Please try again.