使用Racket的语法参数在编译时注入语法?

时间:2018-04-26 15:56:18

标签: syntax macros racket

我正在尝试使用语法参数,以便在需要注入时注入新语法。然后在其他语法中使用此结果。 但是,它没有像我期望的那样工作。这是一个最小的工作示例:

#lang racket

(require (for-syntax racket/contract))
(require racket/stxparam)


;; A list for holding the instructions
(define instructions-db
  '())

;===================================
; MACRO FOR DEFINING AN INSTRUCTION
;===================================

(provide define-instruction)
(define-syntax (define-instruction stx)
  (syntax-case stx ()
    [(_ id (attrs ...))
     ;; Insert instruction into database
     #'(set! instructions-db (append instructions-db '(id (attrs ...))))]))


;=============================================================
; MACRO TO MIMIC 'FOR' BUT TO BE USED WITH DEFINE-INSTRUCTION
;=============================================================

(begin-for-syntax
  ; Gets the head of each list within the given list of syntax lists. If any of
  ; the lists are empty, an empty list is returned.
  (define/contract (stx-heads ls)
    ((listof (syntax/c list?)) . -> . (listof (syntax/c any/c)))
    (let loop ([ls ls]
               [hs '()])
      (if (null? ls)
          hs
          (let ([l (syntax-e (car ls))])
            (if (null? l)
                '()
                (loop (cdr ls) (append hs (list (car l)))))))))

  ; Gets the tail of each list within the given list of syntax lists. If any of
  ; the lists are empty, an empty list is returned.
  (define/contract (stx-tails ls)
    ((listof (syntax/c list?)) . -> . (listof (syntax/c list?)))
    (let loop ([ls ls]
               [ts '()])
      (if (null? ls)
          ts
          (let* ([stx-l (car ls)]
                 [l (syntax-e stx-l)])
            (if (null? l)
                '()
                (loop (cdr ls) (append ts (list
                                           (datum->syntax stx-l
                                                          (cdr l)
                                                          stx-l
                                                          stx-l)))))))))

  (define (define-instruction-stx? stx)
    (if (syntax? stx)
        (let ([e (syntax-e stx)])
          (and (pair? e)
               (syntax? (car e))
               (equal? (syntax-e (car e)) 'define-instruction)))
        #f))

  ;; Given a syntax object, an identifier, and a replacement value, construct a
  ;; new syntax object where any occurrence of the identifier is substituted for
  ;; the value.
  (define (stx-id-substitute id replacement stx)
    (let loop ([e stx])
      (cond [(and (identifier? e)
                  (bound-identifier=? e id))
             replacement]
            [(syntax? e)
             (datum->syntax e (loop (syntax-e e)) e e)]
            [(pair? e)
             (cons (loop (car e)) (loop (cdr e)))]
            [else e])))

  ;; Given a 'define-instruction' syntax object, extends its ID with the given
  ;; string. If any other object is given, it is left intact and returned.
  (define (extend-id-of-define-instruction-stx suffix stx)
    (if (define-instruction-stx? stx)
        (let* ([e (syntax-e stx)]
               [stx-construct (car e)]
               [stx-id (cadr e)]
               [new-stx-id
                (datum->syntax stx-id
                               (string->symbol
                                (format "~a~a"
                                        (symbol->string (syntax-e stx-id))
                                        suffix))
                               stx-id
                               stx-id)]
               [stx-attrs (caddr e)])
          (datum->syntax stx
                         `(,stx-construct ,new-stx-id ,stx-attrs)
                         stx
                         stx))
        stx))

  ;; Given a list of variable-value pairs and define-instruction body, construct
  ;; a new body where all varible occurrences have been replaced with its
  ;; values.
  (define (instr-for-body-args-sub var-val-pairs stx-body)
    (let loop ([var-val-pairs var-val-pairs]
               [stx-body stx-body])
      (if (null? var-val-pairs)
          stx-body
          (let* ([var-val-p (car var-val-pairs)]
                 [var (car var-val-p)]
                 [val (cdr var-val-p)]
                 [new-stx-body (stx-id-substitute var val stx-body)]
                 [rest-var-val-pairs (cdr var-val-pairs)])
            (loop rest-var-val-pairs new-stx-body)))))

  ;; Given a list of variable-value pairs and define-instruction body, construct
  ;; a new body where all varible occurrences have been replaced with its
  ;; values. Also, an index is appended to the identifier of the new
  ;; define-instruction body.
  (define (instr-for-body-args var-val-pairs instr-index stx-body0)
    (let* ([stx-body1 (instr-for-body-args-sub var-val-pairs stx-body0)]
           [stx-body2 (let loop ([e stx-body1])
                        (cond [(define-instruction-stx? e)
                               (extend-id-of-define-instruction-stx
                                (format ":~a" instr-index)
                                e)]
                              [(syntax? e)
                               (datum->syntax e (loop (syntax-e e)) e e)]
                              [(pair? e)
                               (cons (loop (car e)) (loop (cdr e)))]
                              [else e]))])
      stx-body2))

  ;; Given a list of iteration arguments and an define-instruction body,
  ;; construct a list of define-instruction bodies.
  (define (instr-for-body stx-args stx-body)
    (let ([stx-vars (stx-heads (syntax-e stx-args))])
      (let loop ([stx-val-lists (stx-heads (stx-tails (syntax-e stx-args)))]
                 [instr-index 0])
        (if (null? stx-val-lists)
            '() ;; No more values to iterate over
            (let ([stx-vals (stx-heads stx-val-lists)])
              (if (null? stx-vals)
                  '() ;; At least one arg list has no more values
                  (let ([stx-arg-val-pairs (map cons stx-vars stx-vals)])
                    (cons (instr-for-body-args stx-arg-val-pairs
                                               instr-index
                                               stx-body)
                          (loop (stx-tails stx-val-lists)
                                (+ instr-index 1)))))))))))

(provide instr-for)
(define-syntax (instr-for stx)
  (syntax-case stx ()
    [(_ args body ...)
     (with-syntax ([(replaced-body ...)
                    (foldl
                     (lambda (stx-body replaced-stx-bodies)
                       (append (instr-for-body #'args stx-body)
                               replaced-stx-bodies))
                     '()
                     (syntax-e #'(body ...)))])
                  #'(begin replaced-body ...))]))


;===============================================
; MACROS TO SIMPLIFY DEFINITION OF INSTRUCTIONS
;===============================================

(define-syntax-parameter mem-op-addr
  (lambda (stx)
    (raise-syntax-error
     (syntax-e stx)
     "can only be used inside define-modrm-mem-op-instruction")))

(provide define-complex-addr-mode-instructions)
(define-syntax (define-complex-addr-mode-instructions stx)
  (syntax-case stx ()
    [(_ id (attrs ...))
     #'(begin
         (instr-for ([addr (#'reg1
                            #'[inttoptr 32 offset 32]
                            #'[inttoptr 32 (add 32 rbase rindex) 32]
                            #'[inttoptr 32 (add 32
                            #'                  rbase
                            #'                  (add 32 rindex offset))
                            #'          32])])
           (let ([_addr (syntax->datum addr)])
             (syntax-parameterize ([mem-op-addr
                                    (make-rename-transformer #'_addr)])
               (define-instruction id (attrs ...))))))]))

此代码用于定义指令并将其放入数据库的位置。然后,该数据库的指令的语义将用于生成代码。

现在说我要宣布一条指令。这样做如下:

(define-instruction ADD:0
  ((semantics (add 8 reg0 reg1))))

(displayln instructions-db)

产生:

(ADD:0 ((semantics (add 8 reg0 reg1))

要处理不同的位宽,我们可以这样做:

(define-instruction ADD:0
  ((semantics (add 8 reg0 reg1))))
(define-instruction ADD:1
  ((semantics (add 16 reg0 reg1))))
(define-instruction ADD:2
  ((semantics (add 32 reg0 reg1))))

(displayln instructions-db)

或只是使用我的instr-for宏:

(instr-for ([i (8 16 32)])
  (define-instruction ADD
    ((semantics (add i reg0 reg1)))))

(displayln instructions-db)

给出与上面相同的结果:

([ADD:0 ((semantics (add 8 reg0 reg1)))]
 [ADD:1 ((semantics (add 16 reg0 reg1)))]
 [ADD:2 ((semantics (add 32 reg0 reg1)))])

现在,一些指令具有复杂的寻址模式,这些模式出现在多个指令中。例如:

; some ADD instructions
(define-instruction ADD:0
  ((semantics
    (add 32 reg0 (load-mem 32 reg1)))))
(define-instruction ADD:1
  ((semantics
    (add 32 reg0 (load-mem 32 [inttoptr 32 offset 32])))))
(define-instruction ADD:2
  ((semantics
    (add 32 reg0 (load-mem 32 [inttoptr 32 (add 32 rbase rindex) 32])))))
(define-instruction ADD:3
  ((semantics
    (add 32 reg0 (load-mem 32 [inttoptr 32 (add 32
                                                rbase
                                                (add 32 rindex offset))
                                        32])))))

; some SUB instructions, with the same addressing modes
(define-instruction SUB:0
  ((semantics
    (sub 32 reg0 (load-mem 32 reg1)))))
(define-instruction SUB:1
  ((semantics
    (sub 32 reg0 (load-mem 32 [inttoptr 32 offset 32])))))
(define-instruction SUB:2
  ((semantics
    (sub 32 reg0 (load-mem 32 [inttoptr 32 (add 32 rbase rindex) 32])))))
(define-instruction SUB:3
  ((semantics
    (sub 32 reg0 (load-mem 32 [inttoptr 32 (add 32
                                                rbase
                                                (add 32 rindex offset))
                                        32])))))

为了避免复制粘贴,我定义了一个新的宏define-complex-addr-mode-instructions,以便我们只需使用以下内容声明与上述相同的指令:

(define-complex-addr-mode-instructions ADD
  ((semantics (add 32 reg0 (load-mem 32 mem-op-addr)))))
(define-complex-addr-mode-instructions SUB
  ((semantics (add 32 reg0 (load-mem 32 mem-op-addr)))))

(displayln instructions-db)

但是,这会产生:

([ADD:0 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
 [ADD:1 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
 [ADD:2 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
 [ADD:3 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
 [SUB:0 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
 [SUB:1 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
 [SUB:2 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
 [SUB:3 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))])

阅读Greg Hendershott的guide on macros,我尝试使用语法参数实现define-complex-addr-mode-instructions,因为使用syntax->datum尝试执行此操作显然很糟糕。我是否误解了语法参数的工作原理,还是我需要使用datum->syntax的情况?我注意到,如果我将bound-identifier=?中的instr-for替换为free-identifier=?,它会有效,但我怀疑这不是正确的方法。

0 个答案:

没有答案