diff --git a/beautiful-racket/br/demo/hdl/Dmux-test.rkt b/beautiful-racket/br/demo/hdl/Dmux-test.rkt index f1dc0dc..d9e330f 100644 --- a/beautiful-racket/br/demo/hdl/Dmux-test.rkt +++ b/beautiful-racket/br/demo/hdl/Dmux-test.rkt @@ -2,22 +2,22 @@ (require "DMux.hdl.rkt") (require rackunit) -(DMux-in 0) -(DMux-sel 0) +(DMux-in-write 0) +(DMux-sel-write 0) (check-equal? (DMux-a) 0) (check-equal? (DMux-b) 0) -(DMux-in 0) -(DMux-sel 1) +(DMux-in-write 0) +(DMux-sel-write 1) (check-equal? (DMux-a) 0) (check-equal? (DMux-b) 0) -(DMux-in 1) -(DMux-sel 0) +(DMux-in-write 1) +(DMux-sel-write 0) (check-equal? (DMux-a) 1) (check-equal? (DMux-b) 0) -(DMux-in 1) -(DMux-sel 1) +(DMux-in-write 1) +(DMux-sel-write 1) (check-equal? (DMux-a) 0) (check-equal? (DMux-b) 1) diff --git a/beautiful-racket/br/demo/hdl/Mux-test.rkt b/beautiful-racket/br/demo/hdl/Mux-test.rkt index c456b4d..866d4ae 100644 --- a/beautiful-racket/br/demo/hdl/Mux-test.rkt +++ b/beautiful-racket/br/demo/hdl/Mux-test.rkt @@ -2,38 +2,38 @@ (require "Mux.hdl.rkt") (require rackunit) -(Mux-sel 0) +(Mux-sel-write 0) -(Mux-a 0) -(Mux-b 0) +(Mux-a-write 0) +(Mux-b-write 0) (check-equal? (Mux-out) (Mux-a)) -(Mux-a 0) -(Mux-b 1) +(Mux-a-write 0) +(Mux-b-write 1) (check-equal? (Mux-out) (Mux-a)) -(Mux-a 1) -(Mux-b 0) +(Mux-a-write 1) +(Mux-b-write 0) (check-equal? (Mux-out) (Mux-a)) -(Mux-a 1) -(Mux-b 1) +(Mux-a-write 1) +(Mux-b-write 1) (check-equal? (Mux-out) (Mux-a)) -(Mux-sel 1) +(Mux-sel-write 1) -(Mux-a 0) -(Mux-b 0) +(Mux-a-write 0) +(Mux-b-write 0) (check-equal? (Mux-out) (Mux-b)) -(Mux-a 0) -(Mux-b 1) +(Mux-a-write 0) +(Mux-b-write 1) (check-equal? (Mux-out) (Mux-b)) -(Mux-a 1) -(Mux-b 0) +(Mux-a-write 1) +(Mux-b-write 0) (check-equal? (Mux-out) (Mux-b)) -(Mux-a 1) -(Mux-b 1) +(Mux-a-write 1) +(Mux-b-write 1) (check-equal? (Mux-out) (Mux-b)) diff --git a/beautiful-racket/br/demo/hdl/Not-sexp.rkt b/beautiful-racket/br/demo/hdl/Not-sexp.rkt index 4032432..d930724 100644 --- a/beautiful-racket/br/demo/hdl/Not-sexp.rkt +++ b/beautiful-racket/br/demo/hdl/Not-sexp.rkt @@ -11,6 +11,7 @@ CHIP Not { |# (chip-program Not - (in-spec (in 8) (a)) - (out-spec (out 8)) - (part Nand (a in) (b in) (out out))) \ No newline at end of file + (in-spec (in)) + (out-spec (out)) + (part Nand (a in) (b in) (out out))) + diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt index 0f1b4f9..056929a 100644 --- a/beautiful-racket/br/demo/hdl/expander.rkt +++ b/beautiful-racket/br/demo/hdl/expander.rkt @@ -8,9 +8,10 @@ (out-spec (_output-pin _output-width ...) ...) _part ...) (with-syntax* ([chip-prefix (format-id #'_chipname "~a-" #'_chipname)] - [(prefixed-output-pin ...) (map (λ(op) (format-id op "~a~a" #'chip-prefix op)) (syntax->list #'(_output-pin ...)))]) + [(in-pin-write ...) (map (λ(iw) (format-id iw "~a-write" iw)) (syntax->list #'(_input-pin ...)))] + [(prefixed-output-pin ...) (map (λ(op) (format-id op "~a~a" #'chip-prefix op)) (syntax->list #'(_output-pin ...)))]) #'(begin - (provide (prefix-out chip-prefix (combine-out _input-pin ... ))) + (provide (prefix-out chip-prefix (combine-out _input-pin ... in-pin-write ...))) (define-input-bus _input-pin _input-width ...) ... _part ... (provide prefixed-output-pin ...) @@ -39,10 +40,11 @@ (define wire-stx (car (syntax->list wirearg-pair-stx))) (input-bus? (syntax-local-eval wire-stx))) (syntax->list #'(_wirearg-pair ...)))]) - (with-syntax ([([in-wire . in-args] ...) in-wire-stxs] - [([out-wire out-arg ... out-bus] ...) out-wire-stxs]) + (with-syntax* ([([in-wire in-arg ...] ...) in-wire-stxs] + [(in-wire-write ...) (map (λ(iw) (format-id iw "~a-write" iw)) (syntax->list #'(in-wire ...)))] + [([out-wire out-arg ... out-bus] ...) out-wire-stxs]) #'(begin (define-output-bus out-bus (λ () - (in-wire . in-args) ... + (in-wire-write (in-arg ...)) ... (out-wire out-arg ...))) ...)))) \ No newline at end of file diff --git a/beautiful-racket/br/demo/hdl/helper.rkt b/beautiful-racket/br/demo/hdl/helper.rkt index 05a37bd..ca93190 100644 --- a/beautiful-racket/br/demo/hdl/helper.rkt +++ b/beautiful-racket/br/demo/hdl/helper.rkt @@ -1,4 +1,5 @@ #lang racket/base +(require (for-syntax racket/base racket/syntax) racket/splicing) (require racket/match racket/list) (provide (all-defined-out)) @@ -32,8 +33,6 @@ (define (bus-range start [finish start]) (range start (add1 finish))) -(define-values (input-bus input-bus? input-bus-get) - (make-impersonator-property 'input-bus)) (define (integer->bitvals int width) (reverse (for/list ([i (in-range width)]) @@ -52,143 +51,34 @@ (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 - (procedure-rename - (let ([bus-width width] - [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 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)] - [(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) - (set! bus-val new-val)] - [(bit new-val) (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 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) - (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! bus-val ((if (= 1 new-bit-val) bitwise-bit-set bitwise-bit-unset) bus-val bit)))])) - func) - bus-name) - #f input-bus #t)) - - -(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-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 (make-bus-reader reader-name width) (define bus-reader-func (case-lambda - [() (bus-reader-func 0 (sub1 width))] - [(bit) (bus-reader-func bit bit)] - [(first-bit last-bit) + [(id-thunk-val) (bus-reader-func id-thunk-val 0 (sub1 width))] + [(id-thunk-val bit) (bus-reader-func id-thunk-val bit bit)] + [(id-thunk-val 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) + (bitwise-bit-field id-thunk-val first-bit (add1 last-bit))])) + (procedure-rename bus-reader-func reader-name)) -(define (make-bus-writer writer-name id width) +(define (make-bus-writer writer-name width) (define bus-writer-func (case-lambda - [() (raise-argument-error writer-name "new value" empty)] - [(new-val-in) + [(id-thunk-val) (raise-argument-error writer-name "new value" empty)] + [(id-thunk-val 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) + (check-val-against-width writer-name new-val width) + new-val] + [(id-thunk-val bit new-val) (bus-writer-func id-thunk-val bit bit new-val)] + [(id-thunk-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) @@ -199,39 +89,167 @@ (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)))])) + (check-val-against-width writer-name new-val bit-range-width) + (define last-val + (for/fold ([val id-thunk-val]) + ([bit (in-range first-bit (add1 last-bit))] + [new-bit-val (in-list (integer->bitvals new-val bit-range-width))]) + ((if (= 1 new-bit-val) bitwise-bit-set bitwise-bit-unset) val bit))) + last-val])) bus-writer-func) -(define-syntax (define-output-bus stx) + +#| + +base bus: ++ can read all, or bits ++ every read invokes a thunk +|# + + +(define-values (bus bus? bus-get) + (make-impersonator-property 'bus)) + +(define-syntax (define-base-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))))])) + [(macro-name id thunk bus-width-in) + (with-syntax ([id-thunk (format-id #'id "~a-val" #'id)]) + #`(splicing-let ([id-thunk thunk] + [bus-width bus-width-in]) + (define id + (begin + (unless (<= bus-width max-bus-width) + (raise-argument-error 'id (format "bus width <= max width ~a" max-bus-width) bus-width)) + (impersonate-procedure + (let ([reader (make-bus-reader 'id bus-width)]) + (λ args (apply reader (id-thunk) args))) + #f #,(or (syntax-property stx 'impersonate) #'bus) #t))) + #,(when (syntax-property stx 'writer) + (with-syntax ([id-write (format-id #'id "~a-write" #'id)]) + #'(define id-write + (let ([writer (make-bus-writer 'id-write bus-width)]) + (λ args + (define result (apply writer (id-thunk) args)) + (set! id-thunk (λ () result)))))))))])) +(module+ test + (define-base-bus bb (λ () #b0110) 4) + (check-true (bus? bb)) + (check-false (input-bus? bb)) + (check-false (output-bus? bb)) + (check-exn exn:fail? (λ () (define-base-bus bb (λ () #b0110) 17) bb)) ; exceeds 16-bit width + (check-equal? (bb) #b0110) + (check-equal? (bb 0) #b0) + (check-equal? (bb 1) #b1) + (check-equal? (bb 2) #b1) + (check-equal? (bb 3) #b0) + (check-exn exn:fail? (λ () (bb 5))) ; exceeds bus width + (check-equal? (bb 0 1) #b10) + (check-equal? (bb 1 2) #b11) + (check-equal? (bb 2 3) #b01) + (check-exn exn:fail? (λ () (bb 3 2))) ; inverted bus spec + (check-exn exn:fail? (λ () (bb 5 10))) ; exceeds bus width + ) + + +#| +output bus: ++ thunk is a runtime computation ++ cannot write +|# + +(define-values (output-bus output-bus? output-bus-get) + (make-impersonator-property 'output-bus)) + +(define-syntax (define-output-bus stx) + (syntax-case stx () + [(_ . args) + (syntax-property #'(define-base-bus . args) 'impersonate #'output-bus)])) + (module+ test (define-output-bus ob (λ () #b0110) 4) - (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 + (check-false (bus? ob)) + (check-false (input-bus? ob)) + (check-true (output-bus? ob)) + (check-exn exn:fail? (λ () (define-base-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 ) + +#| +input bus: ++ thunk returns a constant ++ identifies itself as input bus ++ can write all, or bits +|# + +(define-values (input-bus input-bus? input-bus-get) + (make-impersonator-property 'input-bus)) + +(define-syntax (define-input-bus stx) + (syntax-case stx () + [(macro-name id) + #'(macro-name id default-bus-width)] + [(macro-name id bus-width) + (syntax-property + (syntax-property + #'(define-base-bus id (λ () 0) bus-width) + 'impersonate #'input-bus) + 'writer #t)])) + +(module+ test + (define-input-bus ib 4) + (check-false (bus? ib)) + (check-false (output-bus? ib)) + (check-true (input-bus? ib)) + (check-exn exn:fail? (λ () (define-input-bus ib 17) ib)) ; exceeds 16-bit width + (check-equal? (ib) 0) + (ib-write 11) ; set whole value + (check-equal? (ib) 11) + (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) #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) #b0110) + (ib-write 3 3 #b1) + (ib-write 0 0 #b1) + (check-equal? (ib) #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) #b0110) + (ib-write 2 2 #f) ; using #f to fill certain bits + (check-equal? (ib) #b0010) + (ib-write 0) + (ib-write #t) ; using #t to fill all bits + (check-equal? (ib) #b1111) + (ib-write #f) ; using #f to fill all bits + (check-equal? (ib) #b0000) + (define-input-bus ib2 4) + (check-exn exn:fail? (λ () (ib2-write 16))) ; overflow value + (ib2-write #b1100) + (ib-write (ib2)) ; using bus as input value + (check-equal? (ib) (ib2)) + ) \ No newline at end of file