From 76d1e0ef690b9d64a3a28db713c75ff77c0a2545 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 20 May 2016 12:27:14 -0700 Subject: [PATCH] output bus experiment --- beautiful-racket/br/demo/hdl/Dmux4Way.hdl.rkt | 4 +- beautiful-racket/br/demo/hdl/expander.rkt | 5 +- beautiful-racket/br/demo/hdl/helper.rkt | 228 +++++++++++------- beautiful-racket/br/demo/hdl/parser.rkt | 10 +- 4 files changed, 152 insertions(+), 95 deletions(-) diff --git a/beautiful-racket/br/demo/hdl/Dmux4Way.hdl.rkt b/beautiful-racket/br/demo/hdl/Dmux4Way.hdl.rkt index d49265e..0095b0c 100644 --- a/beautiful-racket/br/demo/hdl/Dmux4Way.hdl.rkt +++ b/beautiful-racket/br/demo/hdl/Dmux4Way.hdl.rkt @@ -19,8 +19,8 @@ CHIP DMux4Way { OUT a, b, c, d; PARTS: - DMux(in=in, sel[0]=sel, a=a, b=b); - DMux(in=in, sel[1]=sel, a=c, b=d); + DMux(in=in, sel=sel[0], a=a, b=b); + DMux(in=in, sel=sel[1], a=c, b=d); /* // the right answer: note that subscripting on right always means "read this bit"; // subscripting on left means "write this bit" diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt index 850fd0b..0f1b4f9 100644 --- a/beautiful-racket/br/demo/hdl/expander.rkt +++ b/beautiful-racket/br/demo/hdl/expander.rkt @@ -1,10 +1,7 @@ #lang br (require "helper.rkt" (for-syntax racket/base racket/syntax "helper.rkt" racket/list racket/require-transform)) -(provide #%top-interaction (rename-out [mb #%module-begin]) #%app #%datum and or (all-defined-out)) +(provide #%top-interaction #%module-begin #%app #%datum and or (all-defined-out)) -(define #'(mb _arg ...) - #'(#%module-begin - _arg ...)) (define #'(chip-program _chipname (in-spec (_input-pin _input-width ...) ...) diff --git a/beautiful-racket/br/demo/hdl/helper.rkt b/beautiful-racket/br/demo/hdl/helper.rkt index 0cd69ef..05a37bd 100644 --- a/beautiful-racket/br/demo/hdl/helper.rkt +++ b/beautiful-racket/br/demo/hdl/helper.rkt @@ -40,11 +40,18 @@ (bitwise-bit-field int i (add1 i))))) (define max-bus-width 16) +(define default-bus-width 1) + (define (check-bit-against-width bus-name bit width) (unless (< bit width) (raise-argument-error bus-name (format "bit less than bus width ~a" width) bit))) +(define (check-val-against-width bus-name val width) + (when (and val (> val (sub1 (expt 2 width)))) + (raise-argument-error bus-name + (format "~a-bit value (0 to ~a inclusive)" width (sub1 (expt 2 width))) val))) + (require sugar/debug) (define (make-input-bus bus-name [width 1]) (impersonate-procedure @@ -53,17 +60,14 @@ [bus-val 0]) (unless (<= bus-width max-bus-width) (raise-argument-error bus-name (format "bus width <= max width ~a" max-bus-width) bus-width)) - (define (check-val-against-width val width) - (when (and val (> val (sub1 (expt 2 width)))) - (raise-argument-error bus-name - (format "~a-bit value (0 to ~a inclusive)" width (sub1 (expt 2 width))) val))) + (define func (case-lambda [() bus-val] [(new-val-in) (define new-val (cond [(boolean? new-val-in) - (if new-val-in (sub1 (expt 2 bus-width)) 0)] + (if new-val-in (sub1 (expt 2 bus-width)) 0)] [(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)] [else new-val-in])) (check-val-against-width new-val bus-width) @@ -73,7 +77,7 @@ (define bit-range-width (add1 (- last-bit first-bit))) (define new-val (cond [(boolean? new-val-in) - (if new-val-in (sub1 (expt 2 bit-range-width)) 0)] + (if new-val-in (sub1 (expt 2 bit-range-width)) 0)] [(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)] [else new-val-in])) (unless (<= first-bit last-bit) @@ -88,94 +92,146 @@ bus-name) #f input-bus #t)) -(define-syntax-rule (define-input-bus id arg ...) - (define id (make-input-bus 'id arg ...))) -(module+ test - (define-input-bus in-bus) - (define other (λ () (+ 2 2))) - (check-true (input-bus? in-bus)) - (check-false (input-bus? other)) - - (define-input-bus ib 4) - (check-exn exn:fail? (λ () (define-input-bus ib 17) ib)) ; exceeds 16-bit width - (check-equal? (ib) 0) - (ib 11) ; set whole value - (check-exn exn:fail? (λ () (ib #b11111))) ; overflow - (ib 2 1) ; set bit - (check-equal? (ib) #b1111) - (ib 0 #b0) ; set bit - (ib 1 #b0) ; set bit - (ib 2 #b0) ; set bit - (check-equal? (ib) #b1000) - (check-exn exn:fail? (λ () (ib 5 1 #b0))) ; last index smaller than first - (check-exn exn:fail? (λ () (ib 1 300 #b0))) ; overlarge bit index - (check-exn exn:fail? (λ () (ib 300 500 #b0))) ; overlarge bit index - (check-exn exn:fail? (λ () (ib 1 #b11111))) ; overflow value - (ib 0) - (ib 1 2 #b11) - (check-equal? (ib) #b0110) - (ib 3 3 #b1) - (ib 0 0 #b1) - (check-equal? (ib) #b1111) - (check-exn exn:fail? (λ () (ib 0 300 #b0))) ; overlarge bit index - (check-exn exn:fail? (λ () (ib 1 1 #b11111))) ; overflow value - (ib 0) - (ib 1 2 #t) ; using #t to fill certain bits - (check-equal? (ib) #b0110) - (ib 2 2 #f) ; using #f to fill certain bits - (check-equal? (ib) #b0010) - (ib 0) - (ib #t) ; using #t to fill all bits - (check-equal? (ib) #b1111) - (ib #f) ; using #f to fill all bits - (check-equal? (ib) #b0000) - (define-input-bus ib2 4) - (check-exn exn:fail? (λ () (ib2 16))) ; overflow value - (ib2 #b1100) - (ib ib2) ; using bus as input value - (check-equal? (ib) (ib2)) - ) +(require (for-syntax racket/base racket/syntax)) +(define-syntax (define-input-bus stx) + (syntax-case stx () + [(macro-name id) + #'(macro-name id void default-bus-width)] + [(macro-name id width) + #'(macro-name id void width)] + [(macro-name id thunk width) + (with-syntax ([id-write (format-id #'id "~a-write" #'id)]) + #'(begin + (define-output-bus id thunk width) + ))])) + +#;(module+ test + (define-input-bus in-bus) + (define other (λ () (+ 2 2))) + (check-true (input-bus? in-bus)) + (check-false (input-bus? other)) + + (define-input-bus ib 4) + (check-exn exn:fail? (λ () (define-input-bus ib 17) ib)) ; exceeds 16-bit width + (check-equal? (ib-read) 0) + (ib-write 11) ; set whole value + (check-exn exn:fail? (λ () (ib-write #b11111))) ; overflow + (ib-write 2 1) ; set bit + (check-equal? (ib) #b1111) + (ib-write 0 #b0) ; set bit + (ib-write 1 #b0) ; set bit + (ib-write 2 #b0) ; set bit + (check-equal? (ib-read) #b1000) + (check-exn exn:fail? (λ () (ib-write 5 1 #b0))) ; last index smaller than first + (check-exn exn:fail? (λ () (ib-write 1 300 #b0))) ; overlarge bit index + (check-exn exn:fail? (λ () (ib-write 300 500 #b0))) ; overlarge bit index + (check-exn exn:fail? (λ () (ib-write 1 #b11111))) ; overflow value + (ib-write 0) + (ib-write 1 2 #b11) + (check-equal? (ib-read) #b0110) + (ib-write 3 3 #b1) + (ib-write 0 0 #b1) + (check-equal? (ib-read) #b1111) + (check-exn exn:fail? (λ () (ib-write 0 300 #b0))) ; overlarge bit index + (check-exn exn:fail? (λ () (ib-write 1 1 #b11111))) ; overflow value + (ib-write 0) + (ib-write 1 2 #t) ; using #t to fill certain bits + (check-equal? (ib-read) #b0110) + (ib-write 2 2 #f) ; using #f to fill certain bits + (check-equal? (ib-read) #b0010) + (ib-write 0) + (ib-write #t) ; using #t to fill all bits + (check-equal? (ib-read) #b1111) + (ib-write #f) ; using #f to fill all bits + (check-equal? (ib-read) #b0000) + (define-input-bus ib2 4) + (check-exn exn:fail? (λ () (ib2-write 16))) ; overflow value + (ib2-write #b1100) + (ib-write (ib2-read)) ; using bus as input value + (check-equal? (ib-read) (ib2)) + ) (define-values (output-bus output-bus? output-bus-get) (make-impersonator-property 'output-bus)) -(define (make-output-bus bus-name thunk [width 1]) - (impersonate-procedure - (procedure-rename - (let ([bus-width width]) - (unless (<= bus-width max-bus-width) - (raise-argument-error bus-name (format "bus width <= max width ~a" max-bus-width) bus-width)) - (define func - (case-lambda - [() (func 0 (sub1 bus-width))] - [(bit) (func bit bit)] - [(first-bit last-bit) - (unless (<= first-bit last-bit) - (raise-argument-error bus-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit)) - (check-bit-against-width bus-name first-bit bus-width) - (check-bit-against-width bus-name last-bit bus-width) - (bitwise-bit-field (thunk) first-bit (add1 last-bit))])) - func) - bus-name) - #f output-bus #t)) +(define (make-read-bus bus-name thunk bus-width) + (unless (<= bus-width max-bus-width) + (raise-argument-error bus-name (format "bus width <= max width ~a" max-bus-width) bus-width)) + (impersonate-procedure (procedure-rename thunk bus-name) #f output-bus #t)) + +(define (make-bus-reader reader-name id-val thunk width) + (define bus-reader-func + (case-lambda + [() (bus-reader-func 0 (sub1 width))] + [(bit) (bus-reader-func bit bit)] + [(first-bit last-bit) + (unless (<= first-bit last-bit) + (raise-argument-error reader-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit)) + (check-bit-against-width reader-name first-bit width) + (check-bit-against-width reader-name last-bit width) + (set! id-val (thunk)) + (bitwise-bit-field id-val first-bit (add1 last-bit))])) + bus-reader-func) + +(define (make-bus-writer writer-name id width) + (define bus-writer-func + (case-lambda + [() (raise-argument-error writer-name "new value" empty)] + [(new-val-in) + (define new-val (cond + [(boolean? new-val-in) + (if new-val-in (sub1 (expt 2 width)) 0)] + [(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)] + [else new-val-in])) + (check-val-against-width 'id new-val width) + (set! id new-val)] + [(bit new-val) (bus-writer-func bit bit new-val)] + [(first-bit last-bit new-val-in) + (define bit-range-width (add1 (- last-bit first-bit))) + (define new-val (cond + [(boolean? new-val-in) + (if new-val-in (sub1 (expt 2 bit-range-width)) 0)] + [(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)] + [else new-val-in])) + (unless (<= first-bit last-bit) + (raise-argument-error writer-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit)) + (check-bit-against-width writer-name first-bit width) + (check-bit-against-width writer-name last-bit width) + (check-val-against-width new-val bit-range-width) + (for ([bit (in-range first-bit (add1 last-bit))] + [new-bit-val (in-list (integer->bitvals new-val bit-range-width))]) + (set! id ((if (= 1 new-bit-val) bitwise-bit-set bitwise-bit-unset) id bit)))])) + bus-writer-func) + +(define-syntax (define-output-bus stx) + (syntax-case stx () + [(macro-name id thunk) + #'(macro-name id thunk default-bus-width)] + [(macro-name id thunk width) + (with-syntax ([id-val (format-id #'id "~a-val" #'id)] + [id-read (format-id #'id "~a-read" #'id)] + [id-write (format-id #'id "~a-write" #'id)]) + #'(begin + (define id-val 0) + (define id-read (make-bus-reader 'id-read id-val thunk width)) + (define id (make-read-bus 'id id-read width)) + (define id-write (make-bus-writer 'id-write id width))))])) -(define-syntax-rule (define-output-bus id thunk arg ...) - (define id (make-output-bus 'id thunk arg ...))) (module+ test (define-output-bus ob (λ () #b0110) 4) - (check-exn exn:fail? (λ () (define-input-bus ob (λ () #b0110) 17) ob)) ; exceeds 16-bit width - (check-equal? (ob) #b0110) - (check-equal? (ob 0) #b0) - (check-equal? (ob 1) #b1) - (check-equal? (ob 2) #b1) - (check-equal? (ob 3) #b0) - (check-exn exn:fail? (λ () (ob 5))) ; exceeds bus width - (check-equal? (ob 0 1) #b10) - (check-equal? (ob 1 2) #b11) - (check-equal? (ob 2 3) #b01) - (check-exn exn:fail? (λ () (ob 3 2))) ; inverted bus spec - (check-exn exn:fail? (λ () (ob 5 10))) ; exceeds bus width + (check-exn exn:fail? (λ () (define-output-bus ob (λ () #b0110) 17) ob)) ; exceeds 16-bit width + (check-equal? (ob-read) #b0110) + (check-equal? (ob-read 0) #b0) + (check-equal? (ob-read 1) #b1) + (check-equal? (ob-read 2) #b1) + (check-equal? (ob-read 3) #b0) + (check-exn exn:fail? (λ () (ob-read 5))) ; exceeds bus width + (check-equal? (ob-read 0 1) #b10) + (check-equal? (ob-read 1 2) #b11) + (check-equal? (ob-read 2 3) #b01) + (check-exn exn:fail? (λ () (ob-read 3 2))) ; inverted bus spec + (check-exn exn:fail? (λ () (ob-read 5 10))) ; exceeds bus width ) diff --git a/beautiful-racket/br/demo/hdl/parser.rkt b/beautiful-racket/br/demo/hdl/parser.rkt index 873e251..23b5fcd 100644 --- a/beautiful-racket/br/demo/hdl/parser.rkt +++ b/beautiful-racket/br/demo/hdl/parser.rkt @@ -18,11 +18,15 @@ part : partname /"(" pin-val-pair [/"," pin-val-pair]* /")" /";" @partname : ID -/pin-val-pair : ID [/"[" bus-range /"]"] /"=" pin-val +/pin-val-pair : pin-range /"=" pin-val -@bus-range : NUMBER [/"." /"." NUMBER] +@bus-range : number [/"." /"." number] -@pin-val : ID [/"[" bus-range /"]"] +@pin-range : ID [/"[" bus-range /"]"] + +@pin-val : pin-range | BINARY-NUMBER | TRUE | FALSE + +@number : BINARY-NUMBER | NUMBER \ No newline at end of file