Racket DSL example: Tiny-HDL

tiny-hdl-example-v1.rkt

#lang racket

(require "tiny-hdl-macros.rkt")

(entity half-adder ([input a] [input b] [output s] [output co]))

(entity full-adder ([input a] [input b] [input ci] [output s] [output co]))

(architecture half-adder-arch half-adder
  (assign (port-ref half-adder s)  (xor (port-ref half-adder a) (port-ref half-adder b)))
  (assign (port-ref half-adder co) (and (port-ref half-adder a) (port-ref half-adder b))))

(architecture full-adder-arch full-adder
  (instance h1 half-adder-arch)
  (instance h2 half-adder-arch)
  (assign (port-ref half-adder h1 a) (port-ref full-adder a))
  (assign (port-ref half-adder h1 b) (port-ref full-adder b))
  (assign (port-ref half-adder h2 a) (port-ref half-adder h1 s))
  (assign (port-ref half-adder h2 b) (port-ref full-adder ci))
  (assign (port-ref full-adder s)    (port-ref half-adder h2 s))
  (assign (port-ref full-adder co) (or (port-ref half-adder h1 co) (port-ref half-adder h2 co))))

(instance fa full-adder-arch)

; Simulate and print results ---------------------------------------------------

; Print a row of the truth table of the full adder.
(define-syntax-rule (print-truth-table-row xa xb xci)
  (begin
    (assign (port-ref full-adder fa a)  xa)
    (assign (port-ref full-adder fa b)  xb)
    (assign (port-ref full-adder fa ci) xci)
    (printf "~a ~a ~a -> ~a ~a~n" xa xb xci
      (expression (port-ref full-adder fa s))
      (expression (port-ref full-adder fa co)))))

; Print the truth table of the full adder.
(displayln " a  b ci     s co")
(print-truth-table-row #f #f #f)
(print-truth-table-row #f #f #t)
(print-truth-table-row #f #t #f)
(print-truth-table-row #f #t #t)
(print-truth-table-row #t #f #f)
(print-truth-table-row #t #f #t)
(print-truth-table-row #t #t #f)
(print-truth-table-row #t #t #t)

tiny-hdl-example-v2.rkt

#lang racket

(require
  "tiny-hdl-resolver.rkt"
  "tiny-hdl-macros.rkt")

(begin-tiny-hdl
  (entity half-adder ([input a] [input b] [output s] [output co]))

  (entity full-adder ([input a] [input b] [input ci] [output s] [output co]))

  (architecture half-adder-arch half-adder
    (assign s  (xor a b))
    (assign co (and a b)))

  (architecture full-adder-arch full-adder
    (instance h1 half-adder-arch)
    (instance h2 half-adder-arch)
    (assign (h1 a) a)
    (assign (h1 b) b)
    (assign (h2 a) (h1 s))
    (assign (h2 b) ci)
    (assign s (h2 s))
    (assign co (or (h1 co) (h2 co))))

  (instance fa full-adder-arch))

; Simulate and print results ---------------------------------------------------

; Print a row of the truth table of the full adder.
(define-syntax-rule (print-truth-table-row xa xb xci)
  (begin
    (assign (port-ref full-adder fa a)  xa)
    (assign (port-ref full-adder fa b)  xb)
    (assign (port-ref full-adder fa ci) xci)
    (printf "~a ~a ~a -> ~a ~a~n" xa xb xci
      (expression (port-ref full-adder fa s))
      (expression (port-ref full-adder fa co)))))

; Print the truth table of the full adder.
(displayln " a  b ci     s co")
(print-truth-table-row #f #f #f)
(print-truth-table-row #f #f #t)
(print-truth-table-row #f #t #f)
(print-truth-table-row #f #t #t)
(print-truth-table-row #t #f #f)
(print-truth-table-row #t #f #t)
(print-truth-table-row #t #t #f)
(print-truth-table-row #t #t #t)

tiny-hdl-macros.rkt

#lang racket

(require
  syntax/parse/define
  racket/stxparam
  (for-syntax
    "tiny-hdl-syntax.rkt"
    racket/syntax))

(provide
  entity
  architecture
  instance
  assign
  expression
  port-ref)

(define-for-syntax (constructor-name ent-name)
  (format-id ent-name "make-~a" ent-name))

; Convert an entity declaration into a struct type and a constructor function.
; The struct will contain an empty box for each port.
(define-syntax-parser entity
  [e:entity-decl
   #:with (p:port-decl ...) #'(e.port ...)
   #:with ctor-name (constructor-name (attribute e.name))
   #:with (b ...) (for/list ([q (syntax->list #'(p ...))]) #'(box #f))
   #'(begin
       (struct e.name (p.name ...))
       (define (ctor-name)
         (e.name b ...)))])

; Inside an architecture, this-instance will contain an instance of the current entity.
(define-syntax-parameter this-instance
  (λ (stx)
    (raise-syntax-error (syntax-e stx) "can only be used inside an architecture")))

; Convert an architecture into a function that creates an instance of its entity,
; executes some statements and returns that instance.
(define-syntax-parser architecture
  [c:architecture-decl
   #:with ctor-name (constructor-name (attribute c.ent-name))
   #'(define (c.name)
       (define i (ctor-name))
       (syntax-parameterize ([this-instance (make-rename-transformer #'i)])
         c.body ...)
       i)])

; An instantiation statement calls the function that was generated from an architecture.
; The resulting instance is stored in a variable.
(define-syntax-parser instance
  [i:instantiation-stmt
   #'(define i.name (i.arch-name))])

; An assignment statement assigns an expression to a port.
; The expression will be evaluated when the port is read.
(define-syntax-parser assign
  [a:assignment-stmt
   #'(set-box! a.target (lazy-expression a.value))])

; Convert a port expression into an accessor call.
(define-syntax-parser port-ref
  [(_ ent-name inst-name port-name)
   #:with getter-name (format-id #'port-name "~a-~a" #'ent-name #'port-name)
   #'(getter-name inst-name)]
  [(_ ent-name port-name)
   #'(port-ref ent-name this-instance port-name)])

; Convert an expression into a function for lazy evaluation.
(define-syntax-rule (lazy-expression e)
  (λ () (expression e)))

; Convert an expression into a Racket form.
(define-syntax-parser expression
  [(_ e:operation-expr)
   #'(e.op (expression e.arg) ...)]
  [(_ e:resolved-port-expr)
   #'((unbox e))]
  [(_ e)
   #'e])

tiny-hdl-resolver.rkt

#lang racket

(require
  syntax/parse/define
  "tiny-hdl-macros.rkt"
  (for-syntax
    "tiny-hdl-syntax.rkt"
    syntax/id-table
    syntax/stx
    racket/dict))

(provide begin-tiny-hdl)

(begin-for-syntax
  (define-syntax-class named-item
    (pattern (~or* i:entity-decl
                   i:port-decl
                   i:architecture-decl
                   i:instantiation-stmt)
      #:attr name #'i.name))

  (define current-env (make-parameter (make-immutable-free-id-table)))

  (define (extend-env items)
    (for/fold ([acc (current-env)])
              ([it (syntax->list items)])
      (syntax-parse it
        [n:named-item (dict-set acc #'n.name it)]
        [_            acc])))

  (define (lookup name)
    (dict-ref (current-env) name))

  (define (resolve stx)
    (parameterize ([current-env (extend-env stx)])
      (stx-map resolve-item stx)))

  (define current-arch (make-parameter #f))

  (define (resolve-item stx)
    (syntax-parse stx
      [arch:architecture-decl
       (parameterize ([current-env (extend-env #'(arch.body ...))]
                      [current-arch stx])
         #`(architecture arch.name arch.ent-name
             #,@(stx-map resolve-item #'(arch.body ...))))]

      [stmt:assignment-stmt
       #`(assign #,(resolve-item #'stmt.target) #,(resolve-item #'stmt.value))]

      [expr:operation-expr
       #`(expr.op #,@(stx-map resolve-item #'(expr.arg ...)))]

      [port-name:identifier
       #:with arch:architecture-decl (current-arch)
       #'(port-ref arch.ent-name port-name)]

      [(inst-name:identifier port-name:identifier)
       #:with inst:instantiation-stmt (lookup #'inst-name)
       #:with arch:architecture-decl (lookup #'inst.arch-name)
       #'(port-ref arch.ent-name inst-name port-name)]

      [_ stx])))

(define-syntax-parser begin-tiny-hdl
  [(_ item ...)
   #`(begin
       #,@(resolve #'(item ...)))])

tiny-hdl-syntax.rkt

#lang racket

(require syntax/parse)

(provide (all-defined-out))

; An entity has a name and contains a list of port declarations.
(define-syntax-class entity-decl
  #:datum-literals [entity]
  (pattern (entity name:identifier
             (port:port-decl ...))))

; A port has a name and can be an input or an output.
(define-syntax-class port-decl
  #:datum-literals [input output]
  (pattern (mode:input  name:identifier))
  (pattern (mode:output name:identifier)))

; An architecture has a name, a reference to an existing entity, and a list of statements.
(define-syntax-class architecture-decl
  #:datum-literals [architecture]
  (pattern (architecture name:identifier ent-name:identifier
             body:statement ...)))

; A statement can be either an assignment or an instantiation.
(define-syntax-class statement
  (pattern s:assignment-stmt)
  (pattern s:instantiation-stmt))

; An assignment has a reference to a target port, and a source expression.
(define-syntax-class assignment-stmt
  #:datum-literals [assign]
  (pattern (assign target:port-expr value:expression)))

; An instantiation associates an instance name to an existing architecture name.
(define-syntax-class instantiation-stmt
  #:datum-literals [instance]
  (pattern (instance name:identifier arch-name:identifier)))

; An expression can be a reference to a port, an operation, or a boolean literal.
(define-syntax-class expression
  (pattern e:operation-expr)
  (pattern e:port-expr)
  (pattern e:boolean))

; An operation applies an operator to a list of arguments.
(define-syntax-class operation-expr
  #:datum-literals [or xor and]
  (pattern (op:or  arg:expression ...))
  (pattern (op:xor arg:expression ...))
  (pattern (op:and arg:expression ...)))

; A port expression can reference a port from the entity of the current architecture,
; or a port from the entity of an instance in the current architecture.
(define-syntax-class port-expr
  (pattern e:resolved-port-expr)
  (pattern e:unresolved-port-expr))

; Un unresolved port does not mention the name of the entity that declares that port.
(define-syntax-class unresolved-port-expr
  ; Look-up the port in the entity of the current architecture.
  (pattern port-name:identifier)
  ; Look-up the port in the entity of the architecture instantiated as inst-name.
  (pattern (inst-name:identifier port-name:identifier)))

; A resolved port specifies the name of the entity that declares that port.
(define-syntax-class resolved-port-expr
  ; ent-name is the name of the entity of the current architecture.
  (pattern (port-ref ent-name:identifier port-name:identifier))
  ; ent-name is the name of the entity of the architecture instantiated as inst-name.
  (pattern (port-ref ent-name:identifier inst-name:identifier port-name:identifier)))