├── .gitignore ├── test ├── info.rkt ├── knox │ ├── circuit │ │ └── use_persistent_reset.rkt │ ├── circuit.rkt │ └── driver │ │ └── interpreter.rkt ├── yosys │ ├── constructor.rkt │ ├── verilog │ │ ├── print-test.rkt │ │ ├── counter.rkt │ │ ├── use_persistent_reset.rkt │ │ ├── ram.rkt │ │ ├── lockbox.rkt │ │ └── multi_port_memory.rkt │ ├── metadata.rkt │ ├── zeroinit.rkt │ ├── uf.rkt │ ├── lib.rkt │ ├── memoize.rkt │ └── basic.rkt └── rosutil │ ├── convenience.rkt │ ├── addressable-struct.rkt │ ├── concretize.rkt │ ├── serialization.rkt │ └── lens.rkt ├── knox ├── spec │ ├── lang │ │ └── reader.rkt │ └── spec-lang.rkt ├── driver │ ├── lang │ │ └── reader.rkt │ ├── lib.rkt │ └── driver-lang.rkt ├── circuit │ ├── lang │ │ └── reader.rkt │ └── circuit-lang.rkt ├── emulator │ ├── lang │ │ └── reader.rkt │ ├── util.rkt │ ├── emulator-lang.rkt │ └── interpreter.rkt ├── security │ ├── lang │ │ └── reader.rkt │ ├── security-lang.rkt │ └── checker.rkt ├── correctness │ ├── lang │ │ └── reader.rkt │ ├── correctness-lang.rkt │ ├── hint.rkt │ └── correctness.rkt ├── emulator.rkt ├── driver.rkt ├── semantics │ ├── lifted.rkt │ ├── shared.rkt │ ├── value.rkt │ ├── environment.rkt │ └── syntax.rkt ├── result.rkt ├── spec.rkt └── circuit.rkt ├── .editorconfig ├── yosys ├── lang │ ├── reader.rkt │ └── configure-runtime.rkt ├── generic.rkt ├── debug │ ├── read │ │ └── lang │ │ │ └── reader.rkt │ ├── expand │ │ └── lang │ │ │ └── reader.rkt │ ├── read.rkt │ └── expand.rkt ├── verilog.rkt ├── main.rkt ├── core.rkt ├── meta.rkt ├── memoize.rkt ├── libopt.rkt ├── parameters.rkt ├── lib.rkt └── reader.rkt ├── info.rkt ├── rosutil ├── main.rkt ├── util.rkt ├── overapproximate.rkt ├── dependence.rkt ├── substitution.rkt ├── concretize.rkt ├── convenience.rkt ├── addressable-struct.rkt ├── serialization.rkt └── lens.rkt ├── .github └── workflows │ └── ci.yml ├── LICENSE.md └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | -------------------------------------------------------------------------------- /test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define compile-omit-paths 'all) 4 | -------------------------------------------------------------------------------- /knox/spec/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | knox/spec/spec-lang 3 | -------------------------------------------------------------------------------- /knox/driver/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | knox/driver/driver-lang 3 | -------------------------------------------------------------------------------- /knox/circuit/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | knox/circuit/circuit-lang 3 | -------------------------------------------------------------------------------- /knox/emulator/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | knox/emulator/emulator-lang 3 | -------------------------------------------------------------------------------- /knox/security/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | knox/security/security-lang 3 | -------------------------------------------------------------------------------- /knox/correctness/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | knox/correctness/correctness-lang 3 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*] 4 | charset = utf-8 5 | end_of_line = lf 6 | indent_style = space 7 | trim_trailing_whitespace = true 8 | insert_final_newline = true 9 | -------------------------------------------------------------------------------- /yosys/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | yosys/verilog 3 | #:read yosys:read 4 | #:read-syntax yosys:read-syntax 5 | 6 | (require (prefix-in yosys: "../reader.rkt")) 7 | -------------------------------------------------------------------------------- /knox/emulator.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | (except-out (struct-out emulator) emulator) 5 | (rename-out [emulator make-emulator])) 6 | 7 | (struct emulator 8 | (bindings)) 9 | -------------------------------------------------------------------------------- /yosys/generic.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/generic) 4 | 5 | (provide gen:yosys-module yosys-module? yosys-module/c) 6 | 7 | ;; just a tag 8 | (define-generics yosys-module) 9 | -------------------------------------------------------------------------------- /yosys/debug/read/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | yosys/debug/read 3 | #:read yosys:read 4 | #:read-syntax yosys:read-syntax 5 | 6 | (require (prefix-in yosys: "../../../reader.rkt")) 7 | -------------------------------------------------------------------------------- /yosys/debug/expand/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | yosys/debug/expand 3 | #:read yosys:read 4 | #:read-syntax yosys:read-syntax 5 | 6 | (require (prefix-in yosys: "../../../reader.rkt")) 7 | -------------------------------------------------------------------------------- /test/knox/circuit/use_persistent_reset.rkt: -------------------------------------------------------------------------------- 1 | #lang knox/circuit 2 | 3 | #:circuit "../../yosys/verilog/use_persistent_reset.rkt" 4 | #:reset nrst #f 5 | #:persistent [count_persistent] 6 | #:init-zeroed [count_persistent] 7 | -------------------------------------------------------------------------------- /yosys/lang/configure-runtime.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (prefix-in yosys: "../reader.rkt")) 4 | 5 | (provide configure-runtime!) 6 | 7 | (define (configure-runtime!) 8 | (current-read-interaction yosys:read-syntax)) 9 | -------------------------------------------------------------------------------- /knox/driver.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | (except-out (struct-out driver) driver) 5 | (rename-out [driver make-driver])) 6 | 7 | (struct driver 8 | (bindings 9 | idle)) ; list of (cons signal-name value) 10 | -------------------------------------------------------------------------------- /yosys/verilog.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "core.rkt" 4 | "lib.rkt" 5 | "yosys.rkt") 6 | 7 | (provide (all-from-out "core.rkt") 8 | (all-from-out "lib.rkt") 9 | (all-from-out "yosys.rkt")) 10 | -------------------------------------------------------------------------------- /yosys/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "parameters.rkt" 4 | "generic.rkt" 5 | "meta.rkt") 6 | 7 | (provide (all-from-out "parameters.rkt") 8 | (all-from-out "generic.rkt") 9 | (all-from-out "meta.rkt")) 10 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '(("racket" #:version "8.1") 6 | "rosette" 7 | "rackunit-lib" 8 | "data-lib" 9 | "base")) 10 | 11 | (define license 'MIT) 12 | -------------------------------------------------------------------------------- /knox/semantics/lifted.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (provide 4 | (rename-out 5 | [$bv bv] 6 | [$bitvector bitvector])) 7 | 8 | (define ($bv val size) 9 | (for*/all ([val val] 10 | [size size]) 11 | (bv val size))) 12 | 13 | (define ($bitvector val) 14 | (for/all ([val val]) 15 | (bitvector val))) 16 | -------------------------------------------------------------------------------- /knox/result.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (provide (struct-out result)) 4 | 5 | ;; ideal functionality functions are curried, and have type 6 | ;; `args ... -> state -> result` 7 | ;; 8 | ;; For example, a lockbox's store op could be defined as 9 | ;; `(define ((store value) state) ...)`, returning a result 10 | (struct result (value state) 11 | #:transparent) 12 | -------------------------------------------------------------------------------- /knox/semantics/shared.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (provide vector-set list->immutable-vector) 4 | 5 | (define (vector-set vec pos value) 6 | (define copy (list->vector (vector->list vec))) 7 | (vector-set! copy pos value) 8 | (vector->immutable-vector copy)) 9 | 10 | (define (list->immutable-vector l) 11 | (vector->immutable-vector (list->vector l))) 12 | -------------------------------------------------------------------------------- /yosys/debug/read.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/pretty 4 | (for-syntax racket/base syntax/parse)) 5 | 6 | (provide (except-out (all-from-out racket/base) #%module-begin) 7 | (rename-out [yosys-debug-read-module-begin #%module-begin])) 8 | 9 | (define-syntax (yosys-debug-read-module-begin stx) 10 | (syntax-parse stx 11 | [(_ form ...) 12 | #'(#%module-begin 13 | (pretty-print 'form (current-output-port) 1) ...)])) 14 | -------------------------------------------------------------------------------- /knox/spec.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | (struct-out argument) 5 | (struct-out method-descriptor) 6 | (except-out (struct-out spec) spec) 7 | (rename-out [spec make-spec])) 8 | 9 | (struct argument (name type)) 10 | 11 | (struct method-descriptor (method name args)) 12 | 13 | (struct spec 14 | (init ; value 15 | new-symbolic ; callable that returns a symbolic value 16 | methods ; list of method-descriptor 17 | leak)) ; #f or method descriptor 18 | -------------------------------------------------------------------------------- /rosutil/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require syntax/parse/define) 4 | 5 | (define-simple-macro (require+provide module-path:str ...) 6 | (begin 7 | (require module-path ...) 8 | (provide (all-from-out module-path) ...))) 9 | 10 | (require+provide 11 | "concretize.rkt" 12 | "convenience.rkt" 13 | "dependence.rkt" 14 | "addressable-struct.rkt" 15 | "lens.rkt" 16 | "subsumption.rkt" 17 | "serialization.rkt" 18 | "overapproximate.rkt" 19 | "substitution.rkt") 20 | -------------------------------------------------------------------------------- /test/yosys/constructor.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require rackunit 4 | (prefix-in counter: "verilog/counter.rkt")) 5 | 6 | (test-case "update-name" 7 | (define s 8 | (counter:update-counter_s 9 | (counter:new-zeroed-counter_s) 10 | [count (bv 1 8)])) 11 | (check-equal? s (counter:counter_s #f #f (bv 1 8) #f #f))) 12 | 13 | (test-case "make-name" 14 | (define s 15 | (counter:make-counter_s 16 | [count (bv 1 8)])) 17 | (check-equal? s (counter:counter_s #f #f (bv 1 8) #f #f))) 18 | -------------------------------------------------------------------------------- /test/yosys/verilog/print-test.rkt: -------------------------------------------------------------------------------- 1 | #lang yosys 2 | 3 | ; a hand-written test case 4 | 5 | ; yosys-smt2-module print_test 6 | 7 | (declare-datatype |print_test_s| ((|print_test_mk| 8 | (|counter_is| Bool) 9 | (|counter#0| Bool) ; \clk 10 | (|counter#1| (_ BitVec 8)) ; \count 11 | (|counter#4| (Array (_ BitVec 2) (_ BitVec 32))) ; \ram 12 | ))) 13 | 14 | (define-fun |print_test_i| ((state |print_test_s|)) Bool true) 15 | 16 | (define-fun |print_test_t| ((state |print_test_s|) (next_state |print_test_s|)) Bool true) 17 | -------------------------------------------------------------------------------- /test/knox/circuit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | rackunit yosys knox/circuit 5 | (prefix-in @ (combine-in rosette/safe rosutil)) 6 | (rename-in "circuit/use_persistent_reset.rkt" [circuit use_persistent_reset])) 7 | 8 | (test-case "crash+power-on-reset syncs persistent state before reset" 9 | (define c0 (@update-field ((meta-new-zeroed (circuit-meta use_persistent_reset))) 'count_persistent (@bv 42 8))) 10 | (define c1 ((crash+power-on-reset use_persistent_reset) c0)) 11 | (check-pred @unsat? (@verify (@assert (@equal? (@get-field c0 'count_persistent) (@get-field c1 'count)))))) 12 | -------------------------------------------------------------------------------- /knox/emulator/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (prefix-in @ rosette/safe) 5 | yosys/meta) 6 | 7 | (provide circuit-with-invariants) 8 | 9 | ;; returns a new circuit that satisfies invariants 10 | ;; and all other state is arbitrary 11 | ;; 12 | ;; (in practice, Rosette will zero it, but that's not guaranteed by the spec of complete-solution) 13 | (define (circuit-with-invariants metadata) 14 | (define ckt-sym ((meta-new-symbolic metadata))) 15 | (define sol (@complete-solution (@solve (@assert ((meta-invariant metadata) ckt-sym))) 16 | (@symbolics ckt-sym))) 17 | (@evaluate ckt-sym sol)) 18 | -------------------------------------------------------------------------------- /test/rosutil/convenience.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require rosutil 4 | rackunit) 5 | 6 | (test-case "fresh-symbolic" 7 | (define x (fresh-symbolic "foo" (bitvector 32))) 8 | (define y (fresh-symbolic "foo" (bitvector 32))) 9 | (check-match (format "~a" x) (regexp #rx"^foo\\$")) 10 | (check-match (format "~a" y) (regexp #rx"^foo\\$")) 11 | (check-not-false (not (eq? x y)))) 12 | 13 | (test-case "concrete-head?" 14 | (define-symbolic* b boolean?) 15 | (check-true (concrete-head? (if b (list 1 2) (list 2 1)))) 16 | (check-false (concrete-head? (if b (list 1 2) (list 3)))) 17 | (check-true (concrete-head? (list 1 (if b 3 4))))) 18 | -------------------------------------------------------------------------------- /knox/semantics/value.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require (only-in "syntax.rkt" string? symbol?)) 4 | 5 | (provide 6 | basic-value? 7 | (struct-out closure)) 8 | 9 | ;; basic-value ::= 10 | ;; | void? 11 | ;; | boolean? 12 | ;; | integer? 13 | ;; | string? 14 | ;; | bv? 15 | ;; | symbol? 16 | ;; | null? 17 | ;; | cons basic-value basic-value 18 | 19 | (define (basic-value? v) 20 | (or (void? v) 21 | (boolean? v) 22 | (integer? v) 23 | (string? v) 24 | (bv? v) 25 | (symbol? v) 26 | (null? v) 27 | (and (cons? v) (basic-value? (car v)) (basic-value? (cdr v))))) 28 | 29 | (struct closure 30 | (expr environment) 31 | #:transparent) 32 | -------------------------------------------------------------------------------- /yosys/core.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (prefix-in @ rosette/safe) 4 | (for-syntax racket/base syntax/parse racket/syntax racket/list) 5 | (only-in "yosys.rkt" yosys-top)) 6 | 7 | (provide (rename-out 8 | [$#%module-begin #%module-begin]) 9 | ; from Rosette 10 | (rename-out 11 | [@#%top-interaction #%top-interaction] 12 | [@#%app #%app] 13 | [@#%datum #%datum] 14 | [@#%top #%top])) 15 | 16 | (define-syntax ($#%module-begin stx) 17 | #`(@#%module-begin 18 | (module configure-runtime racket/base 19 | (require yosys/lang/configure-runtime) 20 | (configure-runtime!)) 21 | #,@(yosys-top stx))) 22 | -------------------------------------------------------------------------------- /test/yosys/metadata.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require rackunit 4 | yosys 5 | "verilog/counter.rkt") 6 | 7 | (test-case "using auto-generated methods" 8 | (define s0 (new-zeroed-counter_s)) 9 | (define i (new-symbolic-input)) 10 | (define s1 (with-input s0 i)) 11 | (define s2 (step s1)) 12 | (define q (equal? (output-count (get-output s2)) 13 | (bvadd (output-count (get-output s0)) (concat (bv 0 7) (if (input-en i) (bv 1 1) (bv 0 1)))))) 14 | (check-pred 15 | unsat? 16 | (verify 17 | (begin 18 | (assume (equal? (input-nrst i) #t)) 19 | (assert q))))) 20 | 21 | (test-case "packaged metadata" 22 | (define s0 (new-zeroed-counter_s)) 23 | (define s1 ((meta-step metadata) s0)) 24 | (check-equal? s1 s0)) 25 | -------------------------------------------------------------------------------- /yosys/debug/expand.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (except-in "../verilog.rkt") 4 | (only-in "../yosys.rkt" yosys-top) 5 | (only-in rosette/safe [#%module-begin @#%module-begin]) 6 | racket/pretty 7 | (for-syntax racket/base syntax/parse)) 8 | 9 | (provide (except-out (all-from-out "../verilog.rkt") #%module-begin) 10 | (rename-out [yosys-debug-expand-module-begin #%module-begin])) 11 | 12 | (define-syntax (yosys-debug-expand-module-begin stx) 13 | (syntax-parse (yosys-top stx) 14 | [(_ form ... final) 15 | #'(@#%module-begin 16 | (let ([expanded (syntax->datum (expand-syntax-once #'form))]) 17 | (unless (equal? expanded '(begin)) 18 | (pretty-print expanded (current-output-port) 1))) ... 19 | (pretty-print 'final (current-output-port) 1))])) 20 | -------------------------------------------------------------------------------- /test/yosys/zeroinit.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require rackunit 4 | (prefix-in counter: "verilog/counter.rkt") 5 | (prefix-in picorv32: "verilog/picorv32.rkt") 6 | (only-in racket/base make-vector)) 7 | 8 | (test-case "zero initialization: new-zeroed-counter_s should create an instance of counter with all fields set to 0" 9 | (define s0 (counter:new-zeroed-counter_s)) 10 | (check-equal? (counter:counter_s-clk s0) #f) 11 | (check-equal? (counter:counter_s-count s0) (bv 0 8)) 12 | (check-equal? (counter:counter_s-en s0) #f) 13 | (check-equal? (counter:counter_s-nrst s0) #f)) 14 | 15 | (test-case "zero initialization: vectors of bitvectors should be zeroed properly" 16 | (define s0 (picorv32:new-zeroed-picorv32_s)) 17 | (check-equal? 18 | (picorv32:picorv32_s-cpuregs s0) 19 | (make-vector 32 (bv 0 32)))) 20 | -------------------------------------------------------------------------------- /yosys/meta.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/function) 4 | 5 | (provide (struct-out meta) 6 | dummy-metadata) 7 | 8 | (struct meta (new-symbolic 9 | new-zeroed 10 | invariant 11 | step 12 | input 13 | new-symbolic-input 14 | input* 15 | input-getters 16 | with-input 17 | output 18 | new-symbolic-output 19 | output* 20 | output-getters 21 | get-input 22 | get-output) 23 | #:transparent) 24 | 25 | (define dummy-metadata 26 | (meta 27 | (thunk #t) 28 | (thunk #t) 29 | (lambda (_) #t) 30 | identity 31 | (thunk #t) 32 | (thunk #t) 33 | (lambda args #t) 34 | '() 35 | (lambda (s i) s) 36 | (thunk #t) 37 | (thunk #t) 38 | (lambda args #t) 39 | '() 40 | (lambda (s) #t) 41 | (lambda (s) #t))) 42 | -------------------------------------------------------------------------------- /rosutil/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (for-syntax racket/base syntax/parse)) 5 | 6 | (provide define/internally-memoizing) 7 | 8 | ; we are not reusing the yosys/memoize stuff because that has a global 9 | ; memoization context (which makes sense for the Yosys stuff, because we 10 | ; want a global context where we do inter-procedural memoization 11 | (define-syntax (define/internally-memoizing stx) 12 | (syntax-parse stx 13 | [(_ (name:id arg:id) body ...) 14 | #'(define (name arg) 15 | (define memo-table (make-hasheq)) 16 | (define (name arg [use-memo-table #t]) 17 | (if use-memo-table 18 | (if (hash-has-key? memo-table arg) 19 | (hash-ref memo-table arg) 20 | (let ([value (name arg #f)]) 21 | (hash-set! memo-table arg value) 22 | value)) 23 | (let () body ...))) 24 | (name arg))])) 25 | -------------------------------------------------------------------------------- /knox/correctness/correctness-lang.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (for-syntax racket/base racket/syntax syntax/parse) 5 | "correctness.rkt") 6 | 7 | (provide 8 | (except-out 9 | (all-from-out racket/base) 10 | #%module-begin) 11 | (rename-out [$#%module-begin #%module-begin])) 12 | 13 | (define-syntax ($#%module-begin stx) 14 | (syntax-parse stx 15 | [(_ 16 | #:spec spec-module 17 | #:circuit circuit-module 18 | #:driver driver-module 19 | (~seq k:keyword v:expr) ... 20 | body ...) 21 | #:with spec (format-id stx "spec") 22 | #:with circuit (format-id stx "circuit") 23 | #:with driver (format-id stx "driver") 24 | #'(#%module-begin 25 | (require 26 | (only-in spec-module spec) 27 | (only-in circuit-module circuit) 28 | (only-in driver-module driver)) 29 | body ... 30 | (verify-correctness 31 | spec 32 | circuit 33 | driver 34 | (~@ k v) ...))])) 35 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | pull_request: 5 | schedule: 6 | - cron: '0 8 * * 6' 7 | jobs: 8 | build: 9 | runs-on: ubuntu-latest 10 | strategy: 11 | matrix: 12 | racket-version: ['8.1'] 13 | racket-variant: ['BC', 'CS'] 14 | allow-failure: [false] 15 | include: 16 | - racket-version: 'stable' 17 | racket-variant: 'CS' 18 | allow-failure: false 19 | - racket-version: 'current' 20 | racket-variant: 'CS' 21 | allow-failure: true 22 | continue-on-error: ${{ matrix.allow-failure }} 23 | name: Racket ${{ matrix.racket-version }} (${{ matrix.racket-variant }}) 24 | steps: 25 | - uses: actions/checkout@v6 26 | - uses: Bogdanp/setup-racket@v1.14 27 | with: 28 | architecture: x64 29 | version: ${{ matrix.racket-version }} 30 | variant: ${{ matrix.racket-variant }} 31 | - run: raco pkg install --auto --no-docs 32 | - run: raco test -j $(nproc) . 33 | -------------------------------------------------------------------------------- /test/yosys/uf.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require rackunit 4 | yosys 5 | "verilog/ram.rkt" 6 | (only-in racket/base parameterize)) 7 | 8 | (test-case "not uninterpreted function by default" 9 | (define s0 (new-symbolic-ram_s)) 10 | (check-pred vector? (|ram_m ram| s0))) 11 | 12 | (test-case "uninterpreted function" 13 | (parameterize ([array-representation-vector #f]) 14 | (define s0 (new-symbolic-ram_s)) 15 | (check-equal? (type-of (|ram_m ram| s0)) (~> (bitvector 8) (bitvector 32))) 16 | ; try writing then reading same address 17 | (define-symbolic* addr din (bitvector 32)) 18 | (define s0-with-inputs 19 | (update-ram_s 20 | s0 21 | [valid #t] 22 | [addr addr] 23 | [din din] 24 | [wstrb (bv #b1111 4)])) 25 | (define s1 (ram_t s0-with-inputs)) 26 | (define s1-with-inputs 27 | (update-ram_s 28 | s1 29 | [valid #t] 30 | [addr addr] 31 | [din (bv 0 32)] 32 | [wstrb (bv #b0000 4)])) 33 | (define dout (|ram_n dout| s1-with-inputs)) 34 | (check-pred unsat? (verify (assert (bveq dout din)))))) 35 | -------------------------------------------------------------------------------- /rosutil/overapproximate.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | "convenience.rkt" 5 | "lens.rkt" 6 | racket/match 7 | (prefix-in @ rosette/safe)) 8 | 9 | (provide overapproximate overapproximate-symbolics) 10 | 11 | (define (overapproximate view) 12 | (if (join? view) 13 | (join (map overapproximate (join-contents view))) 14 | (overapproximate-term view))) 15 | 16 | (define (overapproximate-symbolics view) 17 | (if (join? view) 18 | (join (map overapproximate-symbolics (join-contents view))) 19 | (overapproximate-symbolics-term view))) 20 | 21 | (define (any->datum s) 22 | (if (identifier? s) (syntax-e s) s)) 23 | 24 | (define (overapproximate-term term) 25 | ;; do our best to generate a good name 26 | (fresh-symbolic 27 | (match term 28 | [(@constant id type) 29 | (match id 30 | [(list name (guid idnum)) (any->datum name)] 31 | [(list name _) (any->datum name)] 32 | [name (any->datum name)])] 33 | [else '||]) ; give up 34 | (@type-of term))) 35 | 36 | (define (overapproximate-symbolics-term term) 37 | (if (@concrete? term) 38 | term 39 | (overapproximate-term term))) 40 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | ===================== 3 | 4 | **Copyright (c) Anish Athalye (me@anishathalye.com)** 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy of 7 | this software and associated documentation files (the "Software"), to deal in 8 | the Software without restriction, including without limitation the rights to 9 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 10 | of the Software, and to permit persons to whom the Software is furnished to do 11 | so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | -------------------------------------------------------------------------------- /knox/spec/spec-lang.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require 4 | (only-in rosutil/addressable-struct addressable-struct) 5 | "../result.rkt" 6 | "../spec.rkt" 7 | (for-syntax racket/base racket/syntax syntax/parse)) 8 | 9 | (provide 10 | (except-out (all-from-out rosette/safe) struct #%module-begin) 11 | (rename-out [addressable-struct struct] 12 | [$#%module-begin #%module-begin]) 13 | (all-from-out "../result.rkt")) 14 | 15 | (define-syntax ($#%module-begin stx) 16 | (syntax-parse stx 17 | [(_ 18 | #:init s0 19 | #:symbolic-constructor new-symbolic-state 20 | #:methods 21 | (method [arg-name arg-type] ...) ... 22 | (~optional (~seq #:leak leak) #:defaults ([leak #'#f])) 23 | body ...) 24 | #:with spec (format-id stx "spec") 25 | #'(#%module-begin 26 | body ... 27 | (define spec 28 | (make-spec 29 | s0 30 | new-symbolic-state 31 | (list 32 | (method-descriptor method 'method (list (argument 'arg-name arg-type) ...)) ...) 33 | leak)) 34 | (provide spec))] 35 | [(_ body ...) ; fallback, useful in e.g. submodules (like a test module) 36 | #'(#%module-begin body ...)])) 37 | -------------------------------------------------------------------------------- /knox/driver/lib.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base syntax/parse)) 4 | 5 | ;; we can't use #lang knox/driver because then there will be an import cycle 6 | 7 | (define-syntax collect 8 | (syntax-parser 9 | [(_) #''()] 10 | [(_ (define (fn arg ...) body ...) form ...) 11 | #'(cons (cons 'fn '(lambda (arg ...) body ...)) (collect form ...))] 12 | [(_ (define (fn . arg) body ...) form ...) 13 | #'(cons (cons 'fn '(lambda arg body ...)) (collect form ...))])) 14 | 15 | (define global-exprs 16 | (collect 17 | (define (out* . args) 18 | (let ([current-input (out)]) 19 | (if (empty? args) 20 | (void) 21 | (begin 22 | (out (update-field current-input (car args) (cadr args))) 23 | (apply out* (cddr args)))))) 24 | 25 | (define (collect proc n) 26 | (if (zero? n) 27 | '() 28 | (cons (proc) (collect proc (sub1 n))))) 29 | 30 | (define (map f xs) 31 | (if (null? xs) '() (cons (f (car xs)) (map f (cdr xs))))) 32 | 33 | (define (for-each f xs) 34 | (if (null? xs) 35 | (void) 36 | (begin 37 | (f (car xs)) 38 | (for-each f (cdr xs))))))) 39 | 40 | (provide global-exprs) 41 | -------------------------------------------------------------------------------- /knox/circuit/circuit-lang.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require 4 | (only-in rosutil/addressable-struct addressable-struct) 5 | "../result.rkt" 6 | "../circuit.rkt" 7 | (for-syntax racket/base racket/syntax syntax/parse)) 8 | 9 | (provide 10 | (except-out (all-from-out rosette/safe) struct #%module-begin) 11 | (rename-out [addressable-struct struct] 12 | [$#%module-begin #%module-begin]) 13 | (all-from-out "../result.rkt")) 14 | 15 | (define-syntax ($#%module-begin stx) 16 | (syntax-parse stx 17 | [(_ 18 | #:circuit import-path 19 | #:reset reset-input-name reset-input-signal:boolean 20 | #:persistent [persistent-input ...] 21 | #:init-zeroed [init-zeroed-field ...]) 22 | #:with circuit (format-id stx "circuit") 23 | #:with metadata (format-id stx "metadata") 24 | #'(#%module-begin 25 | (require (only-in import-path metadata)) 26 | (define circuit 27 | (make-circuit 28 | metadata 29 | 'reset-input-name 30 | reset-input-signal 31 | (list 'persistent-input ...) 32 | (list 'init-zeroed-field ...))) 33 | (provide circuit))] 34 | [(_ body ...) ; fallback, useful in e.g. submodules (like a test module) 35 | #'(#%module-begin body ...)])) 36 | -------------------------------------------------------------------------------- /yosys/memoize.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/function racket/match 4 | (for-syntax racket/base syntax/parse) 5 | (prefix-in @ rosette/safe)) 6 | 7 | (provide with-memoization-context define/memoize1) 8 | 9 | (define context (make-parameter #f)) 10 | 11 | (define (with-memoization-context* proc) 12 | (if (context) 13 | (proc) 14 | (parameterize ([context (make-hasheq)]) 15 | (proc)))) 16 | 17 | (define-syntax (with-memoization-context stx) 18 | (syntax-parse stx 19 | [(_ body ...) 20 | #'(with-memoization-context* (thunk body ...))])) 21 | 22 | (define (memoize1 proc) 23 | (define (memoized arg) 24 | (let ([current-context (context)] 25 | [assumes (@vc-assumes (@vc))] 26 | [asserts (@vc-asserts (@vc))]) 27 | (if current-context 28 | (match (hash-ref current-context memoized #f) 29 | [(list (== assumes eq?) (== asserts eq?) (== arg eq?) value) 30 | value] 31 | [else 32 | (let ([value (proc arg)]) 33 | (hash-set! current-context memoized (list assumes asserts arg value)) 34 | value)]) 35 | (proc arg)))) 36 | memoized) 37 | 38 | (define-syntax (define/memoize1 stx) 39 | (syntax-parse stx 40 | [(_ (name:id arg:id) body ...) 41 | #'(define name (memoize1 (lambda (arg) body ...)))])) 42 | -------------------------------------------------------------------------------- /knox/semantics/environment.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require (only-in racket/base error)) 4 | 5 | (provide 6 | make-assoc 7 | assoc-contains 8 | assoc-lookup 9 | assoc-remove 10 | assoc-extend assoc-extend*) 11 | 12 | (define (make-assoc) 13 | '()) ; list of pairs of symbol, value 14 | 15 | (define (assoc-contains env name) 16 | (if (null? env) 17 | #f 18 | (or (equal? name (caar env)) 19 | (assoc-contains (cdr env) name)))) 20 | 21 | (define (assoc-lookup env name) 22 | (if (null? env) 23 | (error 'assoc-lookup "assoc does not contain ~v" name) 24 | (if (equal? name (caar env)) 25 | (cdar env) 26 | (assoc-lookup (cdr env) name)))) 27 | 28 | (define (assoc-remove env name) 29 | (if (null? env) 30 | env 31 | (let ([base (assoc-remove (cdr env) name)] 32 | [binding (car env)]) 33 | (if (equal? name (car binding)) 34 | base 35 | (cons binding base))))) 36 | 37 | (define (assoc-extend env name value) 38 | (cons (cons name value) (assoc-remove env name))) 39 | 40 | (define (assoc-extend* env bindings) 41 | (if (null? bindings) 42 | env 43 | (begin 44 | (let* ([binding (car bindings)] 45 | [name (car binding)] 46 | [value (cdr binding)] 47 | [bindings (cdr bindings)]) 48 | (assoc-extend* (assoc-extend env name value) bindings))))) 49 | -------------------------------------------------------------------------------- /test/knox/driver/interpreter.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | knox/driver/interpreter 5 | rackunit 6 | (prefix-in @ (combine-in rosette/safe rosutil)) 7 | (prefix-in ckt: "../../yosys/verilog/counter.rkt")) 8 | 9 | (test-case "basic concrete" 10 | (define interp (make-interpreter '(+ 1 1) '() (ckt:new-zeroed-counter_s) ckt:metadata)) 11 | (define res (run* interp)) 12 | (check-equal? res 2)) 13 | 14 | (test-case "basic symbolic" 15 | (define x (@fresh-symbolic 'x @integer?)) 16 | (define expr `(+ (+ ,x 1) 1)) 17 | (define interp (make-interpreter expr '() (ckt:new-zeroed-counter_s) ckt:metadata)) 18 | (define res (run* interp)) 19 | (check-equal? res (@+ x 2))) 20 | 21 | ;; this is not supported: 22 | #;(test-case "symbolic branch bitvector result" 23 | (define b (@fresh-symbolic 'b @boolean?)) 24 | (define expr `(if ,b ,(@bv 1 1) ,(@bv 0 1))) 25 | (define interp (make-interpreter expr '() (ckt:new-zeroed-counter_s) ckt:metadata)) 26 | (define res (run* interp)) 27 | (check-equal? res (@if b (@bv 1 1) (@bv 0 1)))) 28 | 29 | ;; a workaround: 30 | (test-case "symbolic branch bitvector result, workaround" 31 | (define b (@fresh-symbolic 'b @boolean?)) 32 | (define expr `(let ([bv1 (bv 1 1)] 33 | [bv0 (bv 0 1)]) 34 | (if ,b bv1 bv0))) 35 | (define interp (make-interpreter expr '() (ckt:new-zeroed-counter_s) ckt:metadata)) 36 | (define res (run* interp)) 37 | (check-equal? res (@if b (@bv 1 1) (@bv 0 1)))) 38 | -------------------------------------------------------------------------------- /test/yosys/lib.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/list 4 | rackunit 5 | (prefix-in @ rosette/safe) 6 | (prefix-in $ yosys/lib)) 7 | 8 | (test-case "if" 9 | (@define-symbolic* a b @boolean?) 10 | (check-true (@vc-assumes (@vc))) 11 | (define t 12 | ($ite a ($ite b 0 ($ite (@&& a b) 1 2)) 3)) 13 | (check-true (@vc-assumes (@vc))) 14 | ; a quick sanity check to make sure we didn't break symbolic evaluation 15 | (check-equal? (@evaluate t (@solve (@assert (@and a b)))) 0) 16 | (check-equal? (@evaluate t (@solve (@assert (@and a (@not b))))) 2)) 17 | 18 | (test-case "xor" 19 | (@define-symbolic* a b c d e f @boolean?) 20 | (define (xor2 x y) 21 | (@! (@<=> x y))) 22 | (define (reference-xor . args) 23 | (@foldl xor2 #f args)) 24 | (check-pred @unsat? (@verify (@assert (@equal? (reference-xor a) ($xor a))))) 25 | (check-pred @unsat? (@verify (@assert (@equal? (reference-xor a b) ($xor a b))))) 26 | (check-pred @unsat? (@verify (@assert (@equal? (reference-xor a b c) ($xor a b c))))) 27 | (check-pred @unsat? (@verify (@assert (@equal? (reference-xor a b c d) ($xor a b c d))))) 28 | (check-pred @unsat? (@verify (@assert (@equal? (reference-xor a b c d e) ($xor a b c d e)))))) 29 | 30 | (test-case "select/store asserts" 31 | (@define-symbolic* i (@bitvector 3)) 32 | (define v (@vector 0 1 2 3 4 5 6 7)) 33 | ($select v i) 34 | (check-true (@vc-asserts (@vc))) 35 | ($store v i -1) 36 | (check-true (@vc-asserts (@vc)))) 37 | -------------------------------------------------------------------------------- /test/rosutil/addressable-struct.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | "../yosys/verilog/counter.rkt" 5 | (prefix-in @ rosette/safe) 6 | rosutil 7 | racket/function racket/port rackunit) 8 | 9 | (addressable-struct person (name age)) 10 | 11 | (test-case "fields" 12 | (check-equal? (fields (person "Alice" 23)) '(name age))) 13 | 14 | (test-case "get-field" 15 | (define p (person "Bob" 33)) 16 | (check-equal? (get-field p 'name) "Bob") 17 | (check-equal? (get-field p 'age) 33)) 18 | 19 | (test-case "for/struct" 20 | (define p (person "Charlie" 24)) 21 | (define p* 22 | (for/struct [(n f) p] 23 | (case n 24 | [(name) f] 25 | [(age) (add1 f)]))) 26 | (check-equal? p* (person "Charlie" 25))) 27 | 28 | (test-case "update-field" 29 | (define p (person "Dan" 11)) 30 | (check-equal? 31 | (update-field p 'name "Daniel") 32 | (person "Daniel" 11))) 33 | 34 | (test-case "show-diff" 35 | (define s0 (new-zeroed-counter_s)) 36 | (define s1 (update-field s0 'count (@bv 3 8))) 37 | (define res (show-diff s0 s1)) 38 | (define expected 39 | #< 13 | value-of-solvable-type/c 14 | (set/c @constant? #:cmp 'eq #:kind 'dont-care) 15 | @solution?)])) 16 | 17 | ; is value fully determined by an assignment of concrete values 18 | ; to the given symbolics? 19 | (define (only-depends-on value constants) 20 | (define value-symbolics (list->seteq (@symbolics value))) 21 | ; okay to depend on these: 22 | (define value-allowed-symbolics (set-intersect value-symbolics constants)) 23 | ; not okay to depend on these: 24 | (define value-rest-symbolics (set-subtract value-symbolics constants)) 25 | (cond 26 | [(set-empty? value-rest-symbolics) 27 | ; fast path 28 | (@unsat)] 29 | [(set-empty? value-allowed-symbolics) 30 | ; fast-ish path when we're trying to show that something 31 | ; is concrete (no dependence on any constants) -- 32 | ; no exists/forall style query required 33 | (concrete value)] 34 | [else 35 | ; need to invoke solver 36 | ; try to show that value doesn't depend on other symbolics 37 | (@define-symbolic* fresh (@type-of value)) 38 | (define res 39 | (@verify 40 | (@assert 41 | (@exists (list fresh) 42 | (@forall (set->list value-rest-symbolics) 43 | (@equal? value fresh)))))) 44 | res])) 45 | -------------------------------------------------------------------------------- /yosys/libopt.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (prefix-in @ (combine-in 5 | rosette/safe 6 | (only-in rosette/base/core/polymorphic ite) 7 | (only-in rosette/base/core/type typed? get-type))) 8 | racket/match) 9 | 10 | (provide rewrite-if rewrite-extract) 11 | 12 | (define rewrite-if 13 | (match-lambda 14 | [(@expression (== @ite) (@expression (== @bveq) (== (@bv 0 1)) x) (== (@bv 0 1)) (== (@bv 1 1))) 15 | x] 16 | [x x])) 17 | 18 | (module+ test 19 | (require rackunit) 20 | 21 | (test-case "rewrite-if" 22 | (@define-symbolic* x (@bitvector 1)) 23 | (define y (@if (@bveq x (@bv 0 1)) (@bv 0 1) (@bv 1 1))) 24 | (check-equal? (rewrite-if y) x))) 25 | 26 | ;; this rewrite rule wouldn't be accepted upstream because it creates extra new terms 27 | ;; 28 | ;; this is not in use right now, but it's here as an example of how to implement something like this 29 | (define rewrite-extract 30 | (match-lambda 31 | [(@expression (== @extract) i j (@expression (== @concat) 32 | (and (? @typed? (app @get-type (@bitvector size-l))) l) 33 | (and (? @typed? (app @get-type (@bitvector size-r))) r))) 34 | #:when (and (>= i size-r) (< j size-r)) 35 | (@concat (@extract (- i size-r) 0 l) 36 | (@extract (sub1 size-r) j r))] 37 | [x x])) 38 | 39 | (module+ test 40 | (test-case "rewrite-extract" 41 | (@define-symbolic* x (@bitvector 8)) 42 | (define y (@extract 7 1 (@concat (@extract 3 3 x) (@bv 0 7)))) 43 | (check-equal? (rewrite-extract y) 44 | (@concat (@extract 3 3 x) (@bv 0 6))))) 45 | -------------------------------------------------------------------------------- /test/yosys/verilog/counter.rkt: -------------------------------------------------------------------------------- 1 | #lang yosys 2 | 3 | ; produced from the following Verilog: 4 | ; 5 | ; module counter( 6 | ; input clk, 7 | ; input nrst, 8 | ; input en, 9 | ; output [7:0] count, 10 | ; ); 11 | ; reg [7:0] count; 12 | ; 13 | ; always @(posedge clk) begin 14 | ; if (!nrst) begin 15 | ; count <= 8'h0; 16 | ; end 17 | ; else if (en) begin 18 | ; count <= count + 1; 19 | ; end 20 | ; end 21 | ; endmodule 22 | 23 | ; by running the command: 24 | ; 25 | ; yosys -p 'read_verilog counter.v' -p 'prep' -p 'write_smt2 -stdt counter.rkt' 26 | 27 | ; SMT-LIBv2 description generated by Yosys 0.9+2406 (git sha1 584780d7, clang 10.0.1 -fPIC -Os) 28 | ; yosys-smt2-stdt 29 | ; yosys-smt2-module counter 30 | (declare-datatype |counter_s| ((|counter_mk| 31 | (|counter_is| Bool) 32 | (|counter#0| Bool) ; \clk 33 | (|counter#1| (_ BitVec 8)) ; \count 34 | (|counter#2| Bool) ; \en 35 | (|counter#3| Bool) ; \nrst 36 | ))) 37 | ; yosys-smt2-input clk 1 38 | ; yosys-smt2-clock clk posedge 39 | (define-fun |counter_n clk| ((state |counter_s|)) Bool (|counter#0| state)) 40 | ; yosys-smt2-output count 8 41 | ; yosys-smt2-register count 8 42 | (define-fun |counter_n count| ((state |counter_s|)) (_ BitVec 8) (|counter#1| state)) 43 | ; yosys-smt2-input en 1 44 | (define-fun |counter_n en| ((state |counter_s|)) Bool (|counter#2| state)) 45 | ; yosys-smt2-input nrst 1 46 | (define-fun |counter_n nrst| ((state |counter_s|)) Bool (|counter#3| state)) 47 | (define-fun |counter#4| ((state |counter_s|)) (_ BitVec 8) (bvadd (|counter#1| state) #b00000001)) ; $add$counter.v:14$3_Y 48 | (define-fun |counter#5| ((state |counter_s|)) (_ BitVec 8) (ite (|counter#2| state) (|counter#4| state) (|counter#1| state))) ; $procmux$4_Y 49 | (define-fun |counter#6| ((state |counter_s|)) (_ BitVec 8) (ite (|counter#3| state) (|counter#5| state) #b00000000)) ; $0\count[7:0] 50 | (define-fun |counter_a| ((state |counter_s|)) Bool true) 51 | (define-fun |counter_u| ((state |counter_s|)) Bool true) 52 | (define-fun |counter_i| ((state |counter_s|)) Bool true) 53 | (define-fun |counter_h| ((state |counter_s|)) Bool true) 54 | (define-fun |counter_t| ((state |counter_s|) (next_state |counter_s|)) Bool 55 | (= (|counter#6| state) (|counter#1| next_state)) ; $procdff$9 \count 56 | ) ; end of module counter 57 | ; yosys-smt2-topmod counter 58 | ; end of yosys output 59 | -------------------------------------------------------------------------------- /knox/circuit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require yosys/meta 4 | rosutil/addressable-struct) 5 | 6 | (provide 7 | (except-out (struct-out circuit) circuit) 8 | (rename-out [circuit make-circuit]) 9 | crash+power-on-reset) 10 | 11 | (struct circuit 12 | (meta ; from #lang yosys circuit 13 | reset-input-name 14 | reset-input-signal ; #t or #f, what the signal should be set to for reset 15 | persistent-fields ; list of field names 16 | init-zeroed-fields)) ; fields that are initially zero 17 | 18 | ;; This function returns a function that produces the 19 | ;; post-crash/power-on-reset version of a circuit; the reason it's structured 20 | ;; this way is that we want to cache the underlying symbolic circuit that's used 21 | ;; as the "base" of the returned havoced circuit, for performance. This means 22 | ;; that the result from this function should *not* be re-used across multiple calls 23 | ;; to crash+power-on-reset (even after some modifications in between); for example, 24 | ;; it can't be used to reason about what happens across multiple crash+power-on-reset 25 | ;; operations, because the underlying symbolic variables will be shared rather than 26 | ;; fresh across the calls. We do not use this function in this incorrect way in the 27 | ;; framework: we either have it be the "initial" call (in verifying init for correctness), 28 | ;; or we use it as the "terminal" call (verifying the crash property in correctness 29 | ;; or security, where we don't re-use the result after checking the property). 30 | (define (crash+power-on-reset circuit) 31 | (let* ([m (circuit-meta circuit)] 32 | [rst (circuit-reset-input-name circuit)] 33 | [rst-signal (circuit-reset-input-signal circuit)] 34 | [new-symbolic-input (meta-new-symbolic-input m)] 35 | [i-rst (update-field (new-symbolic-input) rst rst-signal)] 36 | [i-no-rst (update-field (new-symbolic-input) rst (not rst-signal))] 37 | [with-input (meta-with-input m)] 38 | [step (meta-step m)] 39 | [symbolic ((meta-new-symbolic m))]) 40 | (lambda (c1) 41 | ;; copy over persistent state _before_ reset (rather than after reset), 42 | ;; because reset might depend on persistent state 43 | (let* ([havoced (for/fold ([c symbolic]) 44 | ([field (circuit-persistent-fields circuit)]) 45 | (update-field c field (get-field c1 field)))]) 46 | (with-input (step (with-input havoced i-rst)) i-no-rst))))) 47 | -------------------------------------------------------------------------------- /knox/semantics/syntax.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require 4 | (only-in racket [string? racket/string?] [symbol? racket/symbol?])) 5 | 6 | (provide 7 | string? symbol? 8 | tag 9 | variable? 10 | literal? literal-value 11 | lambda? lambda-formals lambda-body 12 | if? if-condition if-then if-else 13 | and? and-contents 14 | or? or-contents 15 | let? let-bindings let-body 16 | begin? begin-contents 17 | app? app-f app-args 18 | quote? quote-get) 19 | 20 | (define (string? v) 21 | (for/all ([v v]) 22 | (racket/string? v))) 23 | 24 | (define (symbol? v) 25 | (for/all ([v v]) 26 | (racket/symbol? v))) 27 | 28 | (define (tag expr) 29 | (if (not (list? expr)) 30 | #f 31 | (car expr))) 32 | 33 | (define (variable? expr) 34 | (symbol? expr)) 35 | 36 | (define (literal? expr) 37 | (or (boolean? expr) (integer? expr) (string? expr))) 38 | 39 | (define (literal-value expr) 40 | expr) 41 | 42 | (define (lambda? expr) 43 | (equal? (tag expr) 'lambda)) 44 | 45 | (define (lambda-formals expr) 46 | (cadr expr)) 47 | 48 | (define (maybe-wrap-body expr) 49 | (if (null? (cdr expr)) 50 | ;; body is a single expression, return it 51 | (car expr) 52 | ;; body is a sequence, wrap it in sequence 53 | `(begin ,@expr))) 54 | 55 | (define (lambda-body expr) 56 | (maybe-wrap-body (cddr expr))) 57 | 58 | (define (if? expr) 59 | (equal? (tag expr) 'if)) 60 | 61 | (define (if-condition expr) 62 | (cadr expr)) 63 | 64 | (define (if-then expr) 65 | (caddr expr)) 66 | 67 | (define (if-else expr) 68 | (cadddr expr)) 69 | 70 | (define (and? expr) 71 | (equal? (tag expr) 'and)) 72 | 73 | (define (and-contents expr) 74 | (cdr expr)) 75 | 76 | (define (or? expr) 77 | (equal? (tag expr) 'or)) 78 | 79 | (define (or-contents expr) 80 | (cdr expr)) 81 | 82 | (define (let? expr) 83 | (equal? (tag expr) 'let)) 84 | 85 | (define (let-bindings expr) 86 | (cadr expr)) 87 | 88 | (define (let-body expr) 89 | (maybe-wrap-body (cddr expr))) 90 | 91 | (define (begin? expr) 92 | (equal? (tag expr) 'begin)) 93 | 94 | (define (begin-contents expr) 95 | (cdr expr)) 96 | 97 | (define (app? expr) 98 | (list? expr)) 99 | 100 | (define (app-f expr) 101 | (car expr)) 102 | 103 | (define (app-args expr) 104 | (cdr expr)) 105 | 106 | (define (quote? expr) 107 | (equal? (tag expr) 'quote)) 108 | 109 | (define (quote-get expr) 110 | (second expr)) 111 | -------------------------------------------------------------------------------- /yosys/parameters.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract racket/string) 4 | 5 | (provide array-representation-vector 6 | overapproximate-symbolic-store-threshold 7 | overapproximate-symbolic-load-threshold 8 | print-filter) 9 | 10 | ; array representation: 11 | ; #t for vector 12 | ; #f for uninterpreted function 13 | (define array-representation-vector 14 | (make-parameter #t 15 | (lambda (v) 16 | (unless (boolean? v) 17 | (raise-argument-error 'array-representation-vector 18 | "boolean?" 19 | v)) 20 | v))) 21 | 22 | ; overapproximating stores to symbolic addresses: 23 | ; #f for no overapproximation 24 | ; n for overapproximating when the array size is >= n 25 | ; 26 | ; this only has an effect when (array-representation-vector) is #t 27 | (define overapproximate-symbolic-store-threshold 28 | (make-parameter #f 29 | (lambda (v) 30 | (unless (or (not v) 31 | (natural-number/c v)) 32 | (raise-argument-error 'overapproximate-symbolic-store-threshold 33 | "(or/c #f natural-number/c)" 34 | v)) 35 | v))) 36 | 37 | ; overapproximating loads from symbolic addresses: 38 | ; #f for no overapproximation 39 | ; n for overapproximating when the array size is >= n 40 | ; 41 | ; this only has an effect when (array-representation-vector) is #t 42 | (define overapproximate-symbolic-load-threshold 43 | (make-parameter #f 44 | (lambda (v) 45 | (unless (or (not v) 46 | (natural-number/c v)) 47 | (raise-argument-error 'overapproximate-symbolic-load-threshold 48 | "(or/c #f natural-number/c)" 49 | v)) 50 | v))) 51 | 52 | ; filter what fields are included in the printed representation of a struct 53 | (define print-filter 54 | (make-parameter 55 | #t 56 | (lambda (v) 57 | (unless (or (boolean? v) 58 | (symbol? v) 59 | (string? v) 60 | (regexp? v) 61 | ((procedure-arity-includes/c 1) v)) 62 | (raise-argument-error 'field-filter 63 | "(or/c boolean? symbol? string? regexp? (procedure-arity-includes/c 1))" 64 | v)) 65 | v))) 66 | -------------------------------------------------------------------------------- /rosutil/substitution.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | racket/match 6 | (prefix-in @ (combine-in 7 | rosette/safe 8 | (only-in rosette/base/core/bitvector [bv? bv-constant?]) 9 | (only-in rosette/base/core/type typed? get-type type-construct type-deconstruct))) 10 | "util.rkt") 11 | 12 | (provide 13 | (contract-out 14 | [substitute (-> any/c @constant? any/c any)] 15 | [substitute-terms (-> any/c hash? any)])) 16 | 17 | (define (substitute-terms val [var-term-map (hasheq)]) 18 | (define/internally-memoizing (substitute-memo val) 19 | (define (rec children) 20 | (for/list ([child (in-list children)]) 21 | (substitute-memo child))) 22 | (match val 23 | [(or (? boolean?) (? integer?) (? real?) (? string?) (? symbol?) (? @bv-constant?)) val] 24 | [(@constant id type) (hash-ref var-term-map val val)] 25 | [(@union contents) (apply @union (rec contents))] 26 | [(@expression op vs ...) (apply op (rec vs))] 27 | [(list vs ...) (rec vs)] 28 | [(cons x y) (cons (substitute-memo x) (substitute-memo y))] 29 | [(vector vs ...) (let ([v (list->vector (rec vs))]) 30 | (if (immutable? val) 31 | (vector->immutable-vector v) 32 | v))] 33 | [(box v) (box (substitute-memo v))] 34 | [(and (? @typed?) (app @get-type type)) (@type-construct type (rec (@type-deconstruct type val)))] 35 | [_ val])) 36 | (substitute-memo val)) 37 | 38 | (define (substitute val var term) 39 | (substitute-terms val (hasheq var term))) 40 | 41 | (module+ test 42 | (require 43 | "lens.rkt" 44 | "addressable-struct.rkt" 45 | rackunit) 46 | 47 | (test-case "basic" 48 | (@struct foo (bar baz) #:transparent) 49 | (@define-symbolic* w x y z @integer?) 50 | (define v (@list (foo x 3) (@+ x y z))) 51 | (define t (@+ (@+ (@* w w) w) 1)) 52 | (define v* (substitute v x t)) 53 | (check-equal? 54 | v* 55 | (@list (foo t 3) (@+ t y z)))) 56 | 57 | (test-case "lens" 58 | (addressable-struct foo (bar baz)) 59 | (@define-symbolic* x y @integer?) 60 | (define v (list (foo 1 x) y)) 61 | (define v* 62 | (lens-transform 63 | (lens (list (lens car-lens 'baz) (list-ref-lens 1))) 64 | v 65 | (lambda (view) (substitute-terms view (hasheq x 2 y 3))))) 66 | (check-equal? v* (list (foo 1 2) 3))) 67 | 68 | (test-case "mutability" 69 | (@define-symbolic* x @integer?) 70 | (check-true (immutable? (substitute (vector-immutable 1 2 x) x 3))) 71 | (check-false (immutable? (substitute (vector 1 2 x) x 3))))) 72 | -------------------------------------------------------------------------------- /test/yosys/memoize.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | yosys/memoize 5 | rackunit 6 | rosette/safe 7 | rosutil 8 | (prefix-in mpm: "./verilog/multi_port_memory.rkt")) 9 | 10 | (test-case "no context" 11 | (define run-count 0) 12 | (define/memoize1 (f x) 13 | (set! run-count (+ run-count 1)) 14 | (* x 5)) 15 | (check-equal? (f 3) 15) 16 | (check-equal? run-count 1) 17 | (check-equal? (f 3) 15) 18 | (check-equal? run-count 2)) 19 | 20 | (test-case "basic context" 21 | (define run-count 0) 22 | (define/memoize1 (f x) 23 | (set! run-count (+ run-count 1)) 24 | (* x 5)) 25 | (with-memoization-context 26 | (check-equal? (f 3) 15) 27 | (check-equal? run-count 1) 28 | (check-equal? (f 3) 15) 29 | (check-equal? run-count 1))) 30 | 31 | (test-case "multiple values" 32 | (define run-count 0) 33 | (define/memoize1 (f x) 34 | (set! run-count (+ run-count 1)) 35 | (* x 5)) 36 | (with-memoization-context 37 | (check-equal? (f 3) 15) 38 | (check-equal? run-count 1) 39 | (check-equal? (f 4) 20) 40 | (check-equal? run-count 2) 41 | (check-equal? (f 4) 20) 42 | (check-equal? run-count 2) 43 | (check-equal? (f 3) 15) 44 | (check-equal? run-count 3))) 45 | 46 | (test-case "vc-sensitive" 47 | (define-symbolic* b boolean?) 48 | (define/memoize1 (f1 b) 49 | (if b 0 1)) 50 | (define/memoize1 (f2 b) 51 | (if b (+ (f1 b) 10) (+ (f1 b) 20))) 52 | ;; if memoizing f1 is not vc-sensitive, then when f2 is evaluated, 53 | ;; Rosette will first explore the [b = #t] path, and under that path 54 | ;; condition, (f1 b) will evaluate in Rosette to just 0; then, when 55 | ;; exploring the second branch of the conditional in f2, we'd use the 56 | ;; incorrect memoized value 57 | (define res (with-memoization-context (f2 b))) 58 | ;; with buggy (non-vc-sensitive) memoization, res would be (ite b 10 20) 59 | (check-equal? res (if b 10 21))) 60 | 61 | (test-case "multi-port memory (context-sensitive symbolics)" 62 | ;; this is a simplified version of an example that was triggering 63 | ;; buggy behavior in a previous version of #lang yosys 64 | ;; 65 | ;; Yosys synthesizes writes to multi-port memories with a mask, 66 | ;; address, and data bus, and each port updates the memory state as: 67 | ;; 68 | ;; mem_i = if (mask == 0) then 69 | ;; mem_{i-1} 70 | ;; else 71 | ;; store(mem_{i-1}, addr, data & mask | mem_{i-1}[addr] & !mask) 72 | ;; 73 | ;; each port updates the memory in this way; with a 3-port memory, the 74 | ;; calculation of mem_3 calls mem_2, first with the path condition (mask == 0), 75 | ;; and if we memoize mem_2 in a way that's not vc-sensitive, the second call 76 | ;; to mem_2 (in the "else" branch) will return the wrong value 77 | (define-symbolic* resetn boolean?) 78 | (define s 79 | (update-field 80 | (mpm:new-zeroed-multi_port_memory_s) 81 | 'resetn resetn)) 82 | (define m (solve (assert (equal? resetn #t)))) 83 | (check-equal? 84 | (get-field (evaluate (mpm:step s) m) 'data) 85 | (vector-immutable (bv #b01 2) (bv #b10 2)))) 86 | -------------------------------------------------------------------------------- /knox/driver/driver-lang.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/provide 5 | racket/stxparam 6 | (prefix-in @ rosette/safe) 7 | (for-syntax racket/base racket/syntax syntax/parse) 8 | "../driver.rkt" 9 | (only-in "interpreter.rkt" basic-value? closure make-assoc assoc-extend make-interpreter)) 10 | 11 | (provide (rename-out [$#%module-begin #%module-begin]) 12 | #%top-interaction #%app #%datum #%datum #%top 13 | (rename-out [$define define]) 14 | ;; some of the simple builtins from interpreter 15 | void void? 16 | printf println 17 | equal? 18 | cons car cdr null? list? list length reverse 19 | not 20 | + - * quotient modulo zero? add1 sub1 abs max min < <= > >= expt integer? 21 | (filtered-out 22 | (lambda (name) (substring name 1)) 23 | (combine-out 24 | @bv @bv? 25 | @bveq @bvslt @bvult @bvsle @bvule @bvsgt @bvugt @bvsge @bvuge 26 | @bvnot @bvand @bvor @bvxor @bvshl @bvlshr @bvashr 27 | @bvneg @bvadd @bvsub @bvmul @bvsdiv @bvudiv @bvsrem @bvurem @bvsmod 28 | @concat @extract @sign-extend @zero-extend @bitvector->integer @bitvector->natural @integer->bitvector 29 | @bit @lsb @msb @bvzero? @bvadd1 @bvsub1 @bvsmin @bvumin @bvsmax @bvumax @bvrol @bvror @rotate-left @rotate-right @bitvector->bits @bitvector->bool @bool->bitvector))) 30 | 31 | (define-syntax-parameter $define 32 | (lambda (stx) 33 | (raise-syntax-error #f "use of a define outside the top-level" stx))) 34 | 35 | (define-syntax (process-defines stx) 36 | (syntax-parse stx 37 | [(_ global-bindings:id) 38 | #'(begin global-bindings)] 39 | [(_ global-bindings:id ((~literal $define) value-name:id body:expr) form ...) 40 | #'(let* ([value-name body] 41 | [global-bindings (assoc-extend global-bindings 'value-name value-name)]) 42 | (process-defines global-bindings form ...))] 43 | [(_ global-bindings:id ((~literal $define) (value-name:id formals:id ...) body:expr ...+) form ...) 44 | #'(let* ([value-name (closure '(lambda (formals ...) body ...) (make-assoc))] 45 | [global-bindings (assoc-extend global-bindings 'value-name value-name)]) 46 | (process-defines global-bindings form ...))] 47 | [(_ global-bindings:id ((~literal $define) (value-name:id . rest-arg:id) body:expr ...+) form ...) 48 | #'(let* ([value-name (closure '(lambda rest-arg body ...) (make-assoc))] 49 | [global-bindings (assoc-extend global-bindings 'value-name value-name)]) 50 | (process-defines global-bindings form ...))])) 51 | 52 | (define-syntax ($#%module-begin stx) 53 | (syntax-parse stx 54 | [(_ 55 | #:idle [(~seq signal-name:id signal-value:expr) ...] 56 | form ...) 57 | #:with driver (format-id stx "driver") 58 | #'(#%module-begin 59 | (define global-bindings 60 | (let ([global-bindings (make-assoc)]) 61 | (process-defines global-bindings form ...))) 62 | (define driver 63 | (make-driver global-bindings (list (cons 'signal-name signal-value) ...))) 64 | (provide driver))])) 65 | -------------------------------------------------------------------------------- /knox/security/security-lang.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | "checker.rkt" 5 | (only-in racket/class new send) 6 | (prefix-in @ (combine-in rosette/safe rosutil)) 7 | (for-syntax racket/base racket/syntax syntax/parse)) 8 | 9 | (provide 10 | (except-out 11 | (all-from-out racket/base) 12 | #%module-begin) 13 | (rename-out [$#%module-begin #%module-begin]) 14 | (struct-out pairing) 15 | (struct-out set)) 16 | 17 | (define-syntax ($#%module-begin stx) 18 | (syntax-parse stx 19 | [(_ 20 | #:spec spec-module 21 | #:circuit circuit-module 22 | #:emulator emulator-module 23 | #:R R:expr 24 | (~optional (~seq #:skip-final-check skip-final-check:boolean) #:defaults ([skip-final-check #'#f])) 25 | (~seq k:keyword v:expr) ... ;; these are ignored for now 26 | body ...) 27 | #:with spec (format-id stx "spec") 28 | #:with circuit (format-id stx "circuit") 29 | #:with emulator (format-id stx "emulator") 30 | #:with R_ (format-id stx "R") 31 | #:with /... (quote-syntax ...) 32 | (define (wrap proof name [method-name #f]) 33 | #`(define-syntax #,name 34 | (syntax-parser 35 | [(_ arg /...) 36 | #'(send #,proof #,(or method-name name) arg /...)]))) 37 | #`(#%module-begin 38 | (require 39 | (only-in spec-module spec) 40 | (only-in circuit-module circuit) 41 | (only-in emulator-module emulator)) 42 | (@gc-terms!) 43 | (define proof (new checker% 44 | [spec spec] 45 | [circuit circuit] 46 | [emulator emulator] 47 | [R_ R])) 48 | #,@(for/list ([elem 49 | ;; all proof methods exposed here 50 | (list 51 | 'disable-checks! 52 | 'enable-checks! 53 | 'admit! 54 | 'finished? 55 | (cons 'current 'focused) 56 | (cons 'next 'get-next) 57 | (cons 'visited 'get-visited) 58 | (cons 'count 'count-remaining) 59 | 'switch-goal! 60 | 'concretize! 61 | 'overapproximate! 62 | 'overapproximate*! 63 | 'overapproximate-predicate! 64 | 'overapproximate-predicate*! 65 | 'replace! 66 | 'prepare! 67 | 'step! 68 | 'cases! 69 | 'subsumed! 70 | 'remember! 71 | 'remember+! 72 | 'clear! 73 | 'subst!)]) 74 | (if (pair? elem) 75 | (wrap #'proof (format-id stx "~a" (car elem)) (format-id stx "~a" (cdr elem))) 76 | (wrap #'proof (format-id stx "~a" elem) (format-id stx "~a" elem)))) 77 | body ... 78 | (cond 79 | [skip-final-check (eprintf "debug mode: skipping final check")] 80 | [(not (send proof finished?)) (error 'verify-security "proof is not finished")]))])) 81 | -------------------------------------------------------------------------------- /rosutil/concretize.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | "addressable-struct.rkt" 5 | (only-in "lens.rkt" join join? join-contents) 6 | yosys 7 | racket/list racket/contract 8 | (prefix-in @ rosette/safe) 9 | (for-syntax racket/base syntax/parse racket/syntax)) 10 | 11 | (provide 12 | (contract-out 13 | [concrete (-> any/c @solution?)] 14 | [concretize (->* (any/c) 15 | (@boolean? #:piecewise boolean? #:error-on-failure boolean?) 16 | any)] 17 | [all-values (->* (any/c) 18 | (@boolean? #:limit (or/c boolean? natural-number/c)) 19 | list?)] 20 | [concretize-fields (->* (addressable?) 21 | (@boolean?) 22 | addressable?)])) 23 | 24 | ; Note: these functions are not general-purpose -- it is in general, 25 | ; NOT safe to use them in arbitrary Rosette programs. At best, 26 | ; they might _increase_ the size of terms; at worst, they may produce 27 | ; incorrect results. 28 | ; 29 | ; We use these only in conjunction with yosys, where we have a situation 30 | ; where (vc) is empty, and there is no mutation everywhere 31 | ; (it's all pure functional code), so I think this is okay. 32 | 33 | (define (concretize view [predicate #t] #:piecewise [piecewise #f] #:error-on-failure [error-on-failure #f]) 34 | (if (and piecewise (join? view)) 35 | (join (map (lambda (el) (concretize el predicate #:piecewise piecewise #:error-on-failure error-on-failure)) (join-contents view))) 36 | (concretize-term view predicate #:error-on-failure error-on-failure))) 37 | 38 | (define (concrete term [predicate #t]) 39 | (define-values (_ res) (concretize-term* term predicate)) 40 | res) 41 | 42 | (define (concretize-term term predicate #:error-on-failure [error-on-failure #f]) 43 | (define-values (term-concrete res) (concretize-term* term predicate)) 44 | (if (or (@unsat? res) (not error-on-failure)) 45 | term-concrete 46 | (error 'concretize-term "failed to concretize term"))) 47 | 48 | ;; returns (maybe concretized term, model) 49 | (define (concretize-term* term predicate) 50 | (define vars (@symbolics term)) 51 | (cond 52 | [(empty? vars) (values term (@unsat))] ; don't bother checking predicate here 53 | ;; optimize the case where we try to concretize a bare symbolic variable 54 | [(and (@constant? term) (eqv? predicate #t)) (values term (@sat))] 55 | [else 56 | (define model 57 | (if (eqv? predicate #t) 58 | (@sat) ; avoid a solver call, it'll return an empty model in this case anyways 59 | (@solve (@assert predicate)))) 60 | ;; what to do if solver returns unsat? 61 | (unless (@sat? model) 62 | (error 'concretize-term* "non-sat predicate")) 63 | (define term-concrete (@evaluate term (@complete-solution model vars))) 64 | (define res 65 | (@verify 66 | (begin 67 | (@assume predicate) 68 | (@assert 69 | (@equal? term term-concrete))))) 70 | (if (@unsat? res) 71 | (values term-concrete res) 72 | (values term res))])) 73 | 74 | (define (all-values term [predicate #t] #:limit [limit #f]) 75 | (define vars (@symbolics term)) 76 | (let loop ([acc '()] 77 | [neq-rest predicate] 78 | [sofar 0]) 79 | (cond 80 | [(and limit (>= sofar limit)) acc] 81 | [else 82 | (define model (@solve (@assert neq-rest))) 83 | (cond 84 | [(@unsat? model) acc] 85 | [(@unknown? model) acc] ; give up 86 | [else ; sat 87 | (define concrete (@evaluate term (@complete-solution model vars))) 88 | (loop 89 | (cons concrete acc) 90 | (@&& neq-rest (@not (@equal? term concrete))) 91 | (add1 sofar))])]))) 92 | 93 | (define (concretize-fields val [predicate #t]) 94 | (for/struct [(n v) val] 95 | (concretize-term v predicate))) 96 | -------------------------------------------------------------------------------- /rosutil/convenience.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/match racket/contract racket/random 4 | (only-in file/sha1 bytes->hex-string) 5 | (prefix-in @ rosette/safe) 6 | syntax/parse/define 7 | (for-syntax racket/base)) 8 | 9 | (provide 10 | value-of-solvable-type/c 11 | (contract-out 12 | [fresh-symbolic (-> (or/c symbol? string?) 13 | @solvable? 14 | @constant?)] 15 | [fresh-symbolic-like (-> any/c any/c)] 16 | [symbolic-from-id (-> symbol? 17 | bytes? 18 | @solvable? 19 | @constant?)] 20 | [concrete-head? (-> any/c 21 | boolean?)]) 22 | (struct-out guid) 23 | check-no-asserts) 24 | 25 | (define value-of-solvable-type/c 26 | (flat-named-contract 27 | 'value-of-solvable-type? 28 | (lambda (v) (@solvable? (@type-of v))))) 29 | 30 | ;; instantiate a fresh symbolic that prints with the given name 31 | ;; 32 | ;; compare to code in rosette/base/form/define.rkt and rosette/base/core/term.rkt 33 | (define (fresh-symbolic name type) 34 | (define sym-base 35 | (if (symbol? name) 36 | name 37 | (string->symbol name))) 38 | (define id (make-guid)) 39 | (@constant (list sym-base id) type)) 40 | 41 | (define (fresh-symbolic-like value) 42 | (match value 43 | [(app @type-of (and type (? @solvable?))) 44 | (fresh-symbolic '__fresh-symbolic-like type)] 45 | [(@union contents) 46 | (apply @union (for/list ([pair contents]) 47 | (cons (fresh-symbolic '__fresh-symbolic-like_choice @boolean?) 48 | (fresh-symbolic-like (cdr pair)))))] 49 | [(box v) 50 | (box (fresh-symbolic-like v))] 51 | [(? list?) 52 | (for/list ([v (in-list value)]) 53 | (fresh-symbolic-like v))] 54 | [(cons x y) 55 | (cons (fresh-symbolic-like x) (fresh-symbolic-like y))] 56 | [(? vector?) 57 | (define r 58 | (for/vector ([v (in-vector value)]) 59 | (fresh-symbolic-like v))) 60 | (if (immutable? value) (vector->immutable-vector r) r)] 61 | [_ 62 | (error 'fresh-symbolic-like "unsupported value: ~a" value)])) 63 | 64 | (define (symbolic-from-id name id type) 65 | (@constant (list name (guid id)) type)) 66 | 67 | (define id-print-width (make-parameter 3)) 68 | 69 | (define GUID-BYTES 12) 70 | 71 | (define (make-guid) 72 | (guid (crypto-random-bytes GUID-BYTES))) 73 | 74 | (define (guid-print guid port mode) 75 | (let* ([hex (bytes->hex-string (guid-value guid))] 76 | [len (string-length hex)] 77 | [end (min (id-print-width) len)] 78 | [trimmed (substring hex 0 end)]) 79 | (write-string trimmed port) 80 | (when (< end len) 81 | (write-string ".." port)))) 82 | 83 | (struct guid (value) 84 | #:transparent 85 | #:methods gen:custom-write 86 | [(define write-proc guid-print)]) 87 | 88 | (define (concrete-head? expr) 89 | (not (or (@term? expr) (@union? expr)))) 90 | 91 | (define (check-no-asserts* expr-thunk #:assumes [assumes #t] #:discharge-asserts [discharge-asserts #f]) 92 | (when (not (@vc-true? (@vc))) 93 | (error 'check-no-asserts "initial vc must be true, is ~v" (@vc))) 94 | (define res (@with-vc (@begin (@assume assumes) (expr-thunk)))) 95 | (when (not (@normal? res)) 96 | (println res) 97 | (error 'check-no-asserts "evaluation did not terminate normally (all paths infeasible)")) 98 | (define eval-vc (@result-state res)) 99 | (cond 100 | [(eq? (@vc-asserts eval-vc) #t) 101 | (@result-value res)] 102 | [(not discharge-asserts) 103 | (error 'check-no-asserts "evaluation of expression produced asserts")] 104 | [else 105 | (if (@unsat? (@verify (@begin 106 | (@assume assumes) 107 | (@assert (@vc-asserts eval-vc))))) 108 | (@result-value res) 109 | (error 'check-no-asserts "unable to verify absence of assertion failures"))])) 110 | 111 | (define-simple-macro (check-no-asserts expr (~seq k:keyword v:expr) ...) 112 | (check-no-asserts* (lambda () expr) (~@ k v) ...)) 113 | -------------------------------------------------------------------------------- /test/rosutil/concretize.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require rosutil rackunit yosys 4 | (prefix-in ! racket/base)) 5 | 6 | (test-case "concretize: concrete" 7 | (check-equal? (concretize (bv 1337 32)) (bv 1337 32))) 8 | 9 | (test-case "concretize: basic" 10 | (define-symbolic* x (bitvector 8)) 11 | (define term 12 | (bveq (bv -1 32) (concat (bv 0 24) x))) 13 | (check-false (concrete? term)) 14 | (check-not-eq? term #f) 15 | (check-eq? (concretize term) #f)) 16 | 17 | (test-case "concretize: larger" 18 | (define-symbolic* x (bitvector 8)) 19 | (define term 20 | (bveq 21 | (let ([y (concat (extract 4 4 x) (bv 0 1) (extract 1 0 (concat (bv 0 2) (extract 3 3 x))))]) 22 | (extract 3 2 (bvor y (bvshl y (bv 2 4))))) 23 | (extract 4 3 x))) 24 | (check-not-eq? term #t) 25 | (check-eq? (concretize term) #t)) 26 | 27 | (test-case "concretize: failure" 28 | (define-symbolic* x (bitvector 8)) 29 | (define term 30 | (concat (bv 0 6) (extract 1 0 x))) 31 | (check-false (concrete? term)) 32 | (check-equal? (concretize term) term) 33 | (check-exn !exn:fail? (thunk (concretize term #:error-on-failure #t)))) 34 | 35 | (test-case "concretize: non-useful predicate" 36 | (define-symbolic* x (bitvector 8)) 37 | (define term (bvxor (extract 6 4 x) (bv #b101 3))) 38 | (check-equal? (concretize term) term) 39 | (check-equal? (concretize term (bvult x (bv #b00100000 8))) term)) 40 | 41 | (test-case "concretize: predicate" 42 | (define-symbolic* x (bitvector 8)) 43 | (define term (bvxor (extract 7 5 x) (bv #b101 3))) 44 | (check-equal? (concretize term) term) 45 | (check-equal? (concretize term (bvult x (bv #b00100000 8))) (bv #b101 3))) 46 | 47 | (test-case "concrete" 48 | (define-symbolic* x (bitvector 8)) 49 | (define t1 (concat (bv 0 6) (extract 1 0 x))) 50 | (check-pred sat? (concrete t1)) 51 | (define t2 (bveq (bv 0 8) (concat (bv -1 4) (extract 3 0 x)))) 52 | (check-pred unsat? (concrete t2))) 53 | 54 | (addressable-struct foo (bar baz)) 55 | 56 | (test-case "concretize: fields subset" 57 | (define-symbolic* x (bitvector 8)) 58 | (define f (foo (bveq (bv -1 32) (concat (bv 0 24) x)) 59 | (not (bveq (bv -1 32) (concat (bv 0 24) x))))) 60 | (define f* (lens-transform (lens 'bar) f concretize)) 61 | (check-eq? (foo-bar f*) #f) 62 | (check-not-eq? (foo-baz f*) #t)) 63 | 64 | (test-case "concretize: fields all" 65 | (define-symbolic* x (bitvector 8)) 66 | (define f (foo (bveq (bv -1 32) (concat (bv 0 24) x)) 67 | (not (bveq (bv -1 32) (concat (bv 0 24) x))))) 68 | (define f* (lens-transform (lens #t) f concretize)) 69 | (check-eq? (foo-bar f*) #f) 70 | (check-eq? (foo-baz f*) #t)) 71 | 72 | (test-case "concretize: cooperation with lens-transform" 73 | (addressable-struct person (age height)) 74 | (define-symbolic* x y z integer?) 75 | (define t (foo (person x (- y z)) (+ x y))) 76 | (check-equal? (lens-transform (lens 'bar 'height) t (lambda (view) (concretize view (equal? y z)))) 77 | (foo (person x 0) (+ x y))) 78 | (check-equal? (lens-transform (lens (list (lens 'bar (list 'age 'height)) 'baz)) t 79 | (lambda (view) (concretize view (and (equal? y z) (equal? x 1) (equal? z 5))))) 80 | (foo (person 1 0) 6))) 81 | 82 | (test-case "all-values" 83 | (define-symbolic* x (bitvector 8)) 84 | (define t (concat (extract 1 0 x) (bv 0 1))) 85 | (define all (all-values t)) 86 | (check-equal? (!length all) 4) 87 | (check-not-false (!member (bv #b000 3) all)) 88 | (check-not-false (!member (bv #b010 3) all)) 89 | (check-not-false (!member (bv #b100 3) all)) 90 | (check-not-false (!member (bv #b110 3) all))) 91 | 92 | (test-case "all-values limit" 93 | (define-symbolic* x y (bitvector 8)) 94 | (define t (bvxor x y)) 95 | (check-equal? (!length (all-values t #:limit 10)) 10)) 96 | 97 | (test-case "all-values predicate" 98 | (define-symbolic* x (bitvector 8)) 99 | (define term (bvxor (extract 6 4 x) (bv #b101 3))) 100 | (check-equal? (!length (all-values term)) 8) 101 | (define all (all-values term (bvult x (bv #b00100000 8)))) 102 | (check-equal? (!length all) 2) 103 | (check-not-false (!member (bv #b101 3) all)) 104 | (check-not-false (!member (bv #b100 3) all))) 105 | -------------------------------------------------------------------------------- /knox/emulator/emulator-lang.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/provide 5 | racket/stxparam 6 | (prefix-in @ (combine-in rosette/safe rosutil)) 7 | (for-syntax racket/base racket/syntax syntax/parse) 8 | "../emulator.rkt" 9 | (only-in "../semantics/environment.rkt" make-assoc assoc-extend assoc-extend*) 10 | (only-in "../semantics/value.rkt" closure) 11 | (only-in "interpreter.rkt" create-environment interpret raw lift)) 12 | 13 | (provide (rename-out [$#%module-begin #%module-begin]) 14 | #%top-interaction #%app #%datum #%datum #%top 15 | (rename-out [$define define] [$struct struct]) 16 | ;; some of the simple builtins from interpreter 17 | void void? 18 | printf println 19 | equal? 20 | cons car cdr null? list? list length reverse 21 | not 22 | + - * quotient modulo zero? add1 sub1 abs max min < <= > >= expt integer? 23 | (filtered-out 24 | (lambda (name) (substring name 1)) 25 | (combine-out 26 | @bv @bv? 27 | @bveq @bvslt @bvult @bvsle @bvule @bvsgt @bvugt @bvsge @bvuge 28 | @bvnot @bvand @bvor @bvxor @bvshl @bvlshr @bvashr 29 | @bvneg @bvadd @bvsub @bvmul @bvsdiv @bvudiv @bvsrem @bvurem @bvsmod 30 | @concat @extract @sign-extend @zero-extend @bitvector->integer @bitvector->natural @integer->bitvector 31 | @bit @lsb @msb @bvzero? @bvadd1 @bvsub1 @bvsmin @bvumin @bvsmax @bvumax @bvrol @bvror @rotate-left @rotate-right @bitvector->bits @bitvector->bool @bool->bitvector))) 32 | 33 | (define-syntax-parameter $define 34 | (lambda (stx) 35 | (raise-syntax-error #f "use of a define outside the top-level" stx))) 36 | 37 | (define-syntax-parameter $struct 38 | (lambda (stx) 39 | (raise-syntax-error #f "use of a struct outside the top-level" stx))) 40 | 41 | (define-syntax (process-defines stx) 42 | (syntax-parse stx 43 | [(_ global-bindings:id) 44 | #'(begin global-bindings)] 45 | [(_ global-bindings:id ((~literal $define) value-name:id body:expr) form ...) 46 | #'(let* ([value-name body] 47 | [global-bindings (assoc-extend global-bindings 'value-name value-name)]) 48 | (process-defines global-bindings form ...))] 49 | [(_ global-bindings:id ((~literal $define) (value-name:id formals:id ...) body:expr ...+) form ...) 50 | #'(let* ([value-name (closure '(lambda (formals ...) body ...) (make-assoc))] 51 | [global-bindings (assoc-extend global-bindings 'value-name value-name)]) 52 | (process-defines global-bindings form ...))] 53 | [(_ global-bindings:id ((~literal $define) (value-name:id . rest-arg:id) body:expr ...+) form ...) 54 | #'(let* ([value-name (closure '(lambda rest-arg body ...) (make-assoc))] 55 | [global-bindings (assoc-extend global-bindings 'value-name value-name)]) 56 | (process-defines global-bindings form ...))] 57 | ;; struct declaration 58 | [(_ global-bindings:id ((~literal $struct) struct-name:id (fields:id ...)) form ...) 59 | #:with (getter ...) (for/list ([f (syntax->list #'(fields ...))]) 60 | (format-id #'struct-name "~a-~a" #'struct-name f)) 61 | #'(let () 62 | (let ([global-bindings 63 | (assoc-extend* 64 | global-bindings 65 | (list 66 | (cons 'struct-name (raw (lift struct-name))) 67 | (cons 'getter (raw (lift getter))) ...))]) 68 | (process-defines global-bindings form ...)))])) 69 | 70 | (define-syntax process-structs 71 | (syntax-parser 72 | [(_ ((~literal $struct) struct-name:id (fields:id ...)) form ...) 73 | #'(begin 74 | (@addressable-struct struct-name (fields ...)) 75 | (provide (struct-out struct-name)) 76 | (process-structs form ...))] 77 | [(_ _ form ...) 78 | #'(process-structs form ...)] 79 | [(_) 80 | #'(begin)])) 81 | 82 | (define-syntax ($#%module-begin stx) 83 | (syntax-parse stx 84 | [(_ form ...) 85 | #:with emulator (format-id stx "emulator") 86 | #'(#%module-begin 87 | (process-structs form ...) 88 | (define global-bindings 89 | (let ([global-bindings (make-assoc)]) 90 | (process-defines global-bindings form ...))) 91 | (define emulator 92 | (make-emulator global-bindings)) 93 | (provide emulator))])) 94 | -------------------------------------------------------------------------------- /test/yosys/basic.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require rackunit 4 | "verilog/counter.rkt" 5 | (only-in "verilog/print-test.rkt" new-zeroed-print_test_s) 6 | rosutil 7 | yosys 8 | (only-in racket/base string-append parameterize regexp-match)) 9 | 10 | (test-case "basic verification: when enable and reset are not set, value doesn't change" 11 | (define s0 (new-symbolic-counter_s)) 12 | (define s1 (counter_t s0)) 13 | (check-pred 14 | unsat? 15 | (verify 16 | (begin 17 | (assume (equal? (|counter_n en| s0) #f)) 18 | (assume (equal? (|counter_n nrst| s0) #t)) 19 | (assert (equal? (|counter_n count| s0) (|counter_n count| s1))))))) 20 | 21 | (test-case "basic verification: counter wraparound even when no reset" 22 | (define s0 (update-counter_s 23 | (new-symbolic-counter_s) 24 | [nrst #t])) 25 | (define s1 (counter_t s0)) 26 | (define model 27 | (verify 28 | (assert ((|counter_n count| s0) . bvule . (|counter_n count| s1))))) 29 | (check-pred sat? model) 30 | (check-equal? 31 | (evaluate (|counter_n count| s0) model) 32 | (bv #b11111111 8))) 33 | 34 | (test-case "inputs/outputs/registers" 35 | (check-equal? (length inputs) 2) 36 | (check-equal? (length outputs) 1) 37 | (check-equal? (first outputs) (cons 'count |counter_n count|)) 38 | (check-equal? (length registers) 1) 39 | (check-equal? (first registers) (cons 'count |counter_n count|))) 40 | 41 | (test-case "display/write" 42 | (define s0 (new-zeroed-print_test_s)) 43 | (define expected 44 | (apply string-append 45 | '("#(struct:print_test_s" 46 | " #f" 47 | " #f" 48 | " (bv #x00 8)" 49 | " #((bv #x00000000 32) (bv #x00000000 32) (bv #x00000000 32) (bv #x00000000 32))" 50 | ")"))) 51 | (check-equal? (format "~a" s0) expected) ; display 52 | (check-equal? (format "~s" s0) expected)) ; write 53 | 54 | (test-case "print" 55 | (define s0 (new-zeroed-print_test_s)) 56 | (check-equal? (format "~v" s0) #< Knox is a new framework that enables developers to build hardware security 4 | > modules (HSMs) with high assurance through formal verification. The goal is 5 | > to rule out all hardware bugs, software bugs, and timing side channels. 6 | 7 |

8 | Knox workflow 9 |

10 | 11 | > Knox's approach is to relate an implementation's wire-level behavior to a 12 | > functional specification stated in terms of method calls and return values 13 | > with a new definition called *information-preserving refinement (IPR)*. This 14 | > definition captures the notion that the HSM implements its functional 15 | > specification, and that it leaks no additional information through its 16 | > wire-level behavior. The Knox framework provides support for writing 17 | > specifications, importing HSM implementations written in Verilog and C code, 18 | > and proving IPR using a combination of lightweight annotations and 19 | > interactive proofs. 20 | > 21 | > To evaluate the IPR definition and the Knox framework, we verified three 22 | > simple HSMs, including an RFC 6238-compliant TOTP token. The TOTP token is 23 | > written in 2950 lines of Verilog and 360 lines of C and assembly. Its 24 | > behavior is captured in a succinct specification: aside from the definition 25 | > of the TOTP algorithm, the spec is only 10 lines of code. In all three case 26 | > studies, verification covers entire hardware and software stacks and rules 27 | > out hardware/software bugs and timing side channels. 28 | 29 | For more details on Knox and the underlying theory, see our [OSDI'22 paper][paper]. 30 | 31 | ## Organization 32 | 33 | This repository contains the framework code. **For examples of Knox HSMs, see 34 | the [knox-hsm](https://github.com/anishathalye/knox-hsm) repository. It 35 | contains fully-worked examples, including a number of small explanatory 36 | examples along with the three HSMs from the paper.** 37 | 38 | ### rosutil 39 | 40 | This collection contains utility code built on top of [Rosette]. Be careful if 41 | using this outside the context of Knox: some of the code in here assumes 42 | certain preconditions (e.g. immutable arguments) that Knox obeys, but these 43 | preconditions may not be apparent from the code. 44 | 45 | ### yosys 46 | 47 | Lifts [Yosys] SMT2 STDT output into a symbolically-executable representation in 48 | Rosette. 49 | 50 | ### knox 51 | 52 | Note: for brevity, the Knox framework internally uses the names "correctness" 53 | and "security" for functional equivalence and physical equivalence (the latter 54 | are the terms used in the paper). "Correctness" does correspond to functional 55 | correctness; note that "security" proofs are not meaningful on their own unless 56 | accompanied by a functional correctness proof. 57 | 58 | Here are some files/directories of interest, and their overall purpose: 59 | 60 | - `circuit.rkt`: defines a wrapper for circuits; this lets users specify some 61 | additional metadata on top of the Yosys output (e.g. annotating which state 62 | is persistent) 63 | - `circuit/`: defines `#lang knox/circuit` 64 | - `spec.rkt`: defines specifications 65 | - `spec/`: defines `#lang knox/spec` 66 | - `semantics/`: contains common code used to define the semantics of the driver and emulator languages 67 | - `driver.rkt`: defines drivers 68 | - `driver/driver-lang.rkt`: defines `#lang knox/driver`, the DSL for writing drivers 69 | - `driver/interpreter.rkt`: defines the semantics of the driver language as a small-step interpreter written in Rosette 70 | - `emulator.rkt`: defines emulators 71 | - `emulator/emulator-lang.rkt`: defines `#lang knox/emulator`, the DSL for writing emulators 72 | - `emulator/interpreter.rkt`: defines the semantics of the emulator language as a big-step interpreter written in Rosette 73 | - `correctness/`: defines `#lang knox/correctness` and contains tools for verifying correctness 74 | - `security/`: defines `#lang knox/security` and contains tools for verifying security 75 | 76 | [Rosette]: https://emina.github.io/rosette/ 77 | [Yosys]: https://github.com/YosysHQ/yosys 78 | [paper]: https://pdos.csail.mit.edu/papers/knox:osdi22.pdf 79 | 80 | ## Citation 81 | 82 | ```bibtex 83 | @inproceedings{knox:osdi22, 84 | author = {Anish Athalye and M. Frans Kaashoek and Nickolai Zeldovich}, 85 | title = {Verifying Hardware Security Modules with 86 | Information-Preserving Refinement}, 87 | year = 2022, 88 | month = jul, 89 | booktitle = {Proceedings of the 16th USENIX Symposium on Operating 90 | Systems Design and Implementation~(OSDI 2022)}, 91 | address = {Carlsbad, CA}, 92 | } 93 | ``` 94 | -------------------------------------------------------------------------------- /test/rosutil/serialization.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require rackunit 4 | rosutil 5 | racket/match 6 | (only-in racket/base open-input-string) 7 | (only-in racket/port with-output-to-string)) 8 | 9 | (test-case "basic" 10 | (define-symbolic* x integer?) 11 | (define-symbolic* b boolean?) 12 | (define obj (list x (if b x (add1 x)) b)) 13 | (define ser (serialize obj)) 14 | (define des (deserialize ser)) 15 | (check-not-equal? des obj) 16 | (check-pred list? des) 17 | (check-equal? (length des) 3) 18 | (define x* (car des)) 19 | (check-pred constant? x*) 20 | (check-pred integer? x*) 21 | (define b* (caddr des)) 22 | (check-pred constant? b*) 23 | (check-pred boolean? b*) 24 | (check-equal? (cadr des) (if b* x* (add1 x*)))) 25 | 26 | (test-case "reuse vars" 27 | (define x (fresh-symbolic 'x integer?)) 28 | (define b (fresh-symbolic 'b boolean?)) 29 | (define obj (list x (if b x (add1 x)) b)) 30 | (define obj* (deserialize (serialize obj))) 31 | (check-equal? obj* obj)) 32 | 33 | (test-case "custom struct" 34 | (struct person (name age) #:transparent) 35 | (define x (fresh-symbolic 'x integer?)) 36 | (define p (person "Alice" x)) 37 | (check-exn #rx"unsupported type" (lambda () (serialize p))) 38 | (define sr (make-struct-register)) 39 | (register-struct! sr person?) 40 | (check-exn #rx"unknown type person\\?" (lambda () (deserialize (serialize p sr)))) 41 | (check-equal? (deserialize (serialize p sr) sr) p)) 42 | 43 | (test-case "de-dupe objects" 44 | (define x (fresh-symbolic 'x (bitvector 10))) 45 | (define (make-big-tree n) 46 | (cond 47 | [(zero? n) x] 48 | [else 49 | (define next (make-big-tree (sub1 n))) 50 | (cons next next)])) 51 | 52 | ;; we don't want the serialized representation of this thing to be huge 53 | (define big (make-big-tree 100)) 54 | (check-equal? (deserialize (serialize big)) big)) 55 | 56 | (test-case "union" 57 | (define b (fresh-symbolic 'b boolean?)) 58 | (define c (fresh-symbolic 'c boolean?)) 59 | (define v (if c "c" 0)) 60 | (define u (if b (vector v) 4)) 61 | (define s (serialize u)) 62 | (define d (deserialize s)) 63 | (check-equal? d u)) 64 | 65 | (test-case "op" 66 | (define x (fresh-symbolic 'x (bitvector 10))) 67 | (define y (fresh-symbolic 'y (bitvector 10))) 68 | (define obj (list (bvneg x) (bvadd x y) (bvadd x (bv 1 10)))) 69 | (check-equal? (deserialize (serialize obj)) obj)) 70 | 71 | (test-case "string" 72 | (struct person (name age extra) #:transparent) 73 | (define x (fresh-symbolic 'x integer?)) 74 | (define p (person "Alice" x (bv 3 64))) 75 | (define sr (make-struct-register)) 76 | (register-struct! sr person?) 77 | (check-equal? (deserialize (read (open-input-string (with-output-to-string (lambda () (write (serialize p sr)))))) sr) p)) 78 | 79 | (test-case "bitvector type" 80 | (define x (fresh-symbolic 'x (bitvector 16))) 81 | (define v (zero-extend x (bitvector 32))) 82 | (check-equal? (deserialize (serialize v)) v)) 83 | 84 | (test-case "partial canonicalization" 85 | ;; rosette uses the term cache and the id (from current-index) to 86 | ;; impose an ordering on the children of expressions with commutative 87 | ;; operators, and we should make sure serialization preserves this 88 | (define-symbolic* x integer?) 89 | (define-symbolic* y integer?) 90 | (define t (list y x (+ y x))) 91 | ;; the (+ y x) will be canonicalized as (+ x y) 92 | ;; but without careful treatment in serialization, we'll deserialize 93 | ;; y first, so it'll have a smaller ID, and then future computations 94 | ;; doing the same thing won't canonicalize in the same order 95 | (define t* (deserialize (serialize t))) 96 | (define y* (first t*)) 97 | (define x* (second t*)) 98 | (define sum* (third t*)) 99 | (define sum** (+ y* x*)) 100 | (check-true (equal? sum* sum**))) 101 | 102 | (test-case "partial canonicalization: deeper" 103 | (define-symbolic* x integer?) 104 | (define-symbolic* y integer?) 105 | (define t (list (list y) (list x) (+ y x))) 106 | (define t* (deserialize (serialize t))) 107 | (define y* (first (first t*))) 108 | (define x* (first (second t*))) 109 | (define sum* (third t*)) 110 | (define sum** (+ y* x*)) 111 | (check-true (equal? sum* sum**))) 112 | 113 | (test-case "partial canonicalization: deeper, only terms" 114 | (define-symbolic* x integer?) 115 | (define-symbolic* y integer?) 116 | (define t (* (- y) (- x) (+ y x))) 117 | (define t* (deserialize (serialize t))) 118 | ;; grab x and y 119 | (define y* (match t* [(expression _ (expression _ y) _ ...) y])) 120 | (define x* (match t* [(expression _ _ (expression _ x) _ ...) x])) 121 | (define t** (* (- y*) (- x*) (+ y* x*))) 122 | (check-true (equal? t* t**))) 123 | 124 | (test-case "ite* and |- (guard)" 125 | (define p (fresh-symbolic 'p boolean?)) 126 | (define q (fresh-symbolic 'q boolean?)) 127 | (define v (if p 128 | (if q (vector 1) (vector 2)) 129 | (vector 3))) 130 | (define x (vector-ref v 0)) 131 | (define x* (deserialize (serialize x))) 132 | (check-equal? x x*)) 133 | -------------------------------------------------------------------------------- /yosys/lib.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require 4 | (only-in rosette/base/core/bool [@true? true?]) 5 | (only-in rosette/base/core/polymorphic ite) 6 | (for-syntax syntax/parse racket/syntax) 7 | (prefix-in ! (combine-in racket/base racket/match)) 8 | syntax/parse/define 9 | "parameters.rkt" 10 | "libopt.rkt" 11 | rosutil) 12 | 13 | (provide 14 | = distinct _ select store bvxnor 15 | (rename-out [$xor xor] 16 | [$if ite]) 17 | ; exports from Rosette 18 | true false ; constants 19 | (rename-out [! not] [&& and] [|| or]) ; logical 20 | bv ; types 21 | bvult bvslt bvule bvsle bvuge bvsge bvugt bvsgt ; comparison 22 | bvnot bvand bvor bvxor bvshl bvlshr bvashr ; bitwise 23 | bvneg bvadd bvsub bvmul bvudiv bvsdiv bvurem bvsrem bvsmod ; arithmetic 24 | concat) ; conversion 25 | 26 | (define-simple-macro ($if test-expr then-expr else-expr) 27 | (if* test-expr (thunk then-expr) (thunk else-expr))) 28 | 29 | ; this is a workaround for Rosette's `if` statement producing assertions 30 | ; when it's not necessary. `if` eventually calls `eval-assuming` to evaluate 31 | ; the then and else expressions. before doing so, `eval-assuming` augments 32 | ; the verification condition with the guard; sometimes, this immediately 33 | ; results in an exception due to the path being infeasible, and so `if` 34 | ; adds an assertion that the path condition (vc-assumes (vc)) implies that 35 | ; the test must be true or false (depending on which branch failed). this assertion, 36 | ; even though it's useless, sometimes gets added to the vc, 37 | ; because `(&& a b)`, which is used when augmenting the path condition, 38 | ; sometimes results in a concrete Racket value of `#f`, but `(=> a (! b))`, 39 | ; which is used when adding an assertion, does not simplify in Racket to `#t` 40 | ; even though it is provably so. 41 | ; 42 | ; this is an example of such a program: 43 | ; (define-symbolic* a1 a2 boolean?) 44 | ; (if a1 (if a2 0 (if (&& a1 a2) 1 2)) 3) 45 | ; 46 | ; after running this program, the (vc) is: 47 | ; (vc (|| (! a1$0) (|| a2$1 (&& (&& a1$0 (! a2$1)) (! (&& a1$0 a2$1))))) #t) 48 | ; 49 | ; this thin wrapper around Rosette's `if` does this test eagerly, looking 50 | ; at the combination of the verification condition's assumption along 51 | ; with the test, and if it can be determined that the other path is 52 | ; infeasible, it skips evaluating it altogether. 53 | ; 54 | ; this should be safe to use with arbitrary Rosette code (even code 55 | ; e.g. involving mutation). 56 | (define (if* test-expr then-expr else-expr) 57 | (define test (true? test-expr)) 58 | (define assumes (vc-assumes (vc))) 59 | (!cond 60 | [(!or (!eq? test #t) (!not (&& assumes (! test)))) 61 | (then-expr)] 62 | [(!or (!eq? test #f) (!not (&& assumes test))) 63 | (else-expr)] 64 | [else 65 | (rewrite-if (if test (then-expr) (else-expr)))])) 66 | 67 | ; we could implement this with `equal?`, but that is slow. Yosys uses `=` mostly for 68 | ; bitvectors, and only in a few cases for booleans. The boolean cases are: 69 | ; 70 | ; - in the invariant function, when comparing a boolean with the literal 'true' or 'false' 71 | ; - in the transition function (this is a macro anyways, that treats the '=' specially) 72 | (define-syntax (= stx) 73 | (syntax-parse stx 74 | [(_ x:expr (~datum true)) 75 | #'(<=> x true)] 76 | [(_ x:expr (~datum false)) 77 | #'(<=> x false)] 78 | [(_ x:expr y:expr) 79 | #'(bveq x y)])) 80 | 81 | (define (distinct x y) 82 | (not (bveq x y))) 83 | 84 | (define ((extractor i j) x) 85 | (extract i j x)) 86 | 87 | (define-simple-macro (_ (~datum extract) i:expr j:expr) 88 | (extractor i j)) 89 | 90 | (define (select a i) 91 | (if (array-representation-vector) 92 | ; vector representation 93 | (let ([symbolic-index (not (concrete-head? i))] 94 | [thresh (overapproximate-symbolic-load-threshold)]) 95 | (if (and symbolic-index thresh (>= (vector-length a) thresh)) 96 | ; overapproximate, return fresh symbolic value 97 | (fresh-symbolic 'select-overapproximated-value (type-of (vector-ref a 0))) 98 | ; do the indexing into the vector 99 | (vector-ref-bv a i))) 100 | ; UF representation 101 | (a i))) 102 | 103 | (define (vector-update vec pos v) 104 | (define symbolic-index (not (concrete-head? pos))) 105 | (define thresh (overapproximate-symbolic-store-threshold)) 106 | (if (and symbolic-index thresh (>= (vector-length vec) thresh)) 107 | (let ([type (type-of (vector-ref vec 0))]) 108 | (!build-vector (vector-length vec) 109 | (lambda (_) (fresh-symbolic 'overapproximation type)))) 110 | ; XXX this seems inefficient 111 | (let ([vec-copy (list->vector (vector->list vec))]) 112 | (vector-set!-bv vec-copy pos v) 113 | (vector->immutable-vector vec-copy)))) 114 | 115 | (define (store a i v) 116 | (if (array-representation-vector) 117 | ; vector representation 118 | (vector-update a i v) 119 | ; UF representation 120 | (lambda (i*) (if (bveq i i*) v (a i*))))) 121 | 122 | (define (<=>* . args) 123 | (foldl <=> #t args)) 124 | 125 | ; to match SMTLIB's xor, which can take multiple arguments 126 | (define-syntax ($xor stx) 127 | (syntax-parse stx 128 | [(_ (~seq a0 a1) ...) #'(! (<=>* (~@ a0 a1) ...))] 129 | [(_ a (~seq b0 b1) ...) #'(<=>* a (~@ b0 b1) ...)])) 130 | 131 | (define (bvxnor . args) 132 | (bvnot (apply bvxor args))) 133 | -------------------------------------------------------------------------------- /rosutil/addressable-struct.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/generic racket/contract racket/function racket/match racket/format racket/string racket/bool 5 | (for-syntax racket/base syntax/parse racket/syntax) 6 | (prefix-in @ rosette/safe)) 7 | 8 | (provide 9 | gen:addressable addressable? addressable/c 10 | (contract-out 11 | [fields (-> addressable? (listof symbol?))] 12 | [get-field (-> addressable? symbol? any)] 13 | [map-fields (-> addressable? (-> symbol? any/c any) addressable?)] 14 | [update-fields (-> addressable? (listof (cons/c symbol? any/c)) addressable?)] 15 | [update-field (-> addressable? symbol? any/c addressable?)] 16 | [show-diff (-> addressable? addressable? string?)]) 17 | for/struct 18 | addressable-struct 19 | assoc-addressable 20 | field-filter/c 21 | (contract-out 22 | [filter-fields (-> field-filter/c (listof symbol?) (listof symbol?))] 23 | [field-matches? (-> field-filter/c symbol? boolean?)] 24 | [field-filter/not (-> field-filter/c field-filter/c)] 25 | [field-filter/or (->* () #:rest (listof field-filter/c) field-filter/c)])) 26 | 27 | ;; just a tag 28 | (define-generics yosys-module) 29 | 30 | (define-generics addressable 31 | [fields addressable] 32 | [get-field addressable field] 33 | [map-fields addressable fn] 34 | [update-fields addressable assoc] 35 | #:fallbacks 36 | [(define/generic gen-map-fields map-fields) 37 | (define (update-fields x assoc) 38 | (define h (make-immutable-hasheq assoc)) 39 | (gen-map-fields x (lambda (name old-value) (hash-ref h name (lambda () old-value)))))]) 40 | 41 | (define-syntax for/struct 42 | (syntax-parser 43 | [(_ [v:id s] body ...) 44 | #'(for/struct [(_ v) s] body ...)] 45 | [(_ [(k:id v:id) s] body ...) 46 | #'(map-fields s (lambda (k v) body ...))])) 47 | 48 | (define (update-field struct-value field-name new-value) 49 | (update-fields struct-value (list (cons field-name new-value)))) 50 | 51 | (define (show-diff self other) 52 | (define out-string (open-output-string)) 53 | (parameterize ([current-output-port out-string]) 54 | (printf "{~n") 55 | (for ([f (fields self)]) 56 | (when (not (equal? (get-field self f) (get-field other f))) 57 | (define field-name (symbol->string f)) 58 | (cond 59 | ;; recurse when applicable 60 | [(addressable? (get-field self f)) 61 | (define rec-diff (show-diff (get-field self f) (get-field other f))) 62 | ;; fix indentation; XXX inefficient implementation 63 | (define lines (string-split rec-diff "\n")) 64 | (for ([i (in-naturals)] 65 | (line (in-list lines))) 66 | (cond 67 | [(zero? i) (printf " ~a: ~a~n" f line)] 68 | [(< i (sub1 (length lines))) (printf " ~a~n" line)] 69 | [else (printf " ~a // ~a~n" line f)]))] 70 | [(and (vector? (get-field self f)) 71 | (vector? (get-field other f)) 72 | (equal? (vector-length (get-field self f)) (vector-length (get-field other f)))) 73 | (printf " ~a:~n" field-name) 74 | (for ([i (in-range (vector-length (get-field self f)))]) 75 | (define s-i (vector-ref (get-field self f) i)) 76 | (define o-i (vector-ref (get-field other f) i)) 77 | (when (not (equal? s-i o-i)) 78 | (printf " ~a: - ~v~n" i s-i) 79 | (printf " ~a + ~v~n" (~a "" #:width (string-length (~a i))) o-i)))] 80 | [else 81 | ;; diff boolean or bit vector 82 | (printf " ~a: - ~v~n" field-name (get-field self f)) 83 | (printf " ~a + ~v~n" (~a "" #:width (string-length field-name)) (get-field other f))]))) 84 | (printf "}")) 85 | (get-output-string out-string)) 86 | 87 | (define-syntax (addressable-struct stx) 88 | (syntax-parse stx 89 | [(_ name:id (field-name:id ...) struct-option ...) 90 | #:with (getter ...) (for/list ([f (syntax->list #'(field-name ...))]) 91 | (format-id #'name "~a-~a" #'name f)) 92 | #'(@struct name (field-name ...) struct-option ... 93 | #:transparent 94 | #:methods gen:addressable 95 | [(define (fields _) 96 | '(field-name ...)) 97 | (define (get-field x f) 98 | (define v (@case f [(field-name) (getter x)] ...)) 99 | (@if (@void? v) 100 | (error 'get-field "no such field: ~a" f) 101 | v)) 102 | (define (map-fields x f) 103 | (name (f 'field-name (getter x)) ...))])])) 104 | 105 | (struct assoc-addressable (lst) 106 | #:transparent 107 | #:methods gen:addressable 108 | [(define (fields this) 109 | (map car (assoc-addressable-lst this))) 110 | (define (get-field this f) 111 | (let loop ([lst (assoc-addressable-lst this)]) 112 | (if (null? lst) 113 | (error 'get-field "no such field: ~a" f) 114 | (if (equal? (caar lst) f) 115 | (cdar lst) 116 | (loop (cdr lst)))))) 117 | (define (map-fields this f) 118 | (assoc-addressable 119 | (map (lambda (pair) (cons (car pair) (f (car pair) (cdr pair)))) (assoc-addressable-lst this))))]) 120 | 121 | (define field-filter/c 122 | (or/c boolean? symbol? string? regexp? (-> symbol? any))) 123 | 124 | (define (field-filter->function v) 125 | (cond 126 | [(boolean? v) (lambda (s) v)] 127 | [(symbol? v) (lambda (s) (symbol=? s v))] 128 | [(string? v) (lambda (s) (string-contains? (symbol->string s) v))] 129 | [(regexp? v) (lambda (s) (regexp-match? v (symbol->string s)))] 130 | [else v])) 131 | 132 | (define (filter-fields field-filter field-names) 133 | (filter (field-filter->function field-filter) field-names)) 134 | 135 | (define (field-matches? field-filter field-name) 136 | ((field-filter->function field-filter) field-name)) 137 | 138 | (define (field-filter/not filter) 139 | (let ([fn (field-filter->function filter)]) 140 | (lambda (s) (not (fn s))))) 141 | 142 | (define (field-filter/or . filters) 143 | (let ([fns (map field-filter->function filters)]) 144 | (lambda (s) 145 | (for/or ([fn (in-list fns)]) 146 | (fn s))))) 147 | -------------------------------------------------------------------------------- /test/yosys/verilog/ram.rkt: -------------------------------------------------------------------------------- 1 | #lang yosys 2 | 3 | ; produced from the following Verilog: 4 | ; 5 | ; module ram #( 6 | ; parameter ADDR_BITS = 10, 7 | ; ) ( 8 | ; input clk, 9 | ; input valid, 10 | ; input [31:0] addr, 11 | ; input [31:0] din, 12 | ; input [3:0] wstrb, 13 | ; output [31:0] dout, 14 | ; output ready 15 | ; ); 16 | ; 17 | ; wire [ADDR_BITS-3:0] idx = addr[ADDR_BITS-1:2]; 18 | ; reg [31:0] ram [(2**(ADDR_BITS-2))-1:0]; 19 | ; 20 | ; wire [31:0] din_masked = {wstrb[3] ? din[31:24] : ram[idx][31:24], 21 | ; wstrb[2] ? din[23:16] : ram[idx][23:16], 22 | ; wstrb[1] ? din[15:8] : ram[idx][15:8], 23 | ; wstrb[0] ? din[7:0] : ram[idx][7:0]}; 24 | ; 25 | ; always @(posedge clk) begin 26 | ; if (valid && wstrb != 4'b0000) begin 27 | ; ram[idx] <= din_masked; 28 | ; end 29 | ; end 30 | ; 31 | ; assign dout = ram[idx]; 32 | ; assign ready = valid; // always ready 33 | ; 34 | ; endmodule 35 | 36 | ; SMT-LIBv2 description generated by Yosys 0.9+2406 (git sha1 584780d7, clang 10.0.1 -fPIC -Os) 37 | ; yosys-smt2-stdt 38 | ; yosys-smt2-module ram 39 | (declare-datatype |ram_s| ((|ram_mk| 40 | (|ram_is| Bool) 41 | (|ram#0| (_ BitVec 32)) ; \addr 42 | (|ram#1| Bool) ; \clk 43 | (|ram#2| (_ BitVec 32)) ; \din 44 | (|ram#3#0| (Array (_ BitVec 8) (_ BitVec 32))) ; ram 45 | (|ram#5| Bool) ; \valid 46 | (|ram#6| (_ BitVec 4)) ; \wstrb 47 | ))) 48 | ; yosys-smt2-input addr 32 49 | (define-fun |ram_n addr| ((state |ram_s|)) (_ BitVec 32) (|ram#0| state)) 50 | ; yosys-smt2-input clk 1 51 | ; yosys-smt2-clock clk posedge 52 | (define-fun |ram_n clk| ((state |ram_s|)) Bool (|ram#1| state)) 53 | ; yosys-smt2-input din 32 54 | (define-fun |ram_n din| ((state |ram_s|)) (_ BitVec 32) (|ram#2| state)) 55 | ; yosys-smt2-output dout 32 56 | ; yosys-smt2-memory ram 8 32 1 1 sync 57 | (define-fun |ram_m ram| ((state |ram_s|)) (Array (_ BitVec 8) (_ BitVec 32)) (|ram#3#0| state)) 58 | (define-fun |ram_m:R0A ram| ((state |ram_s|)) (_ BitVec 8) ((_ extract 9 2) (|ram#0| state))) ; \addr [9:2] 59 | (define-fun |ram#4| ((state |ram_s|)) (_ BitVec 32) (select (|ram#3#0| state) (|ram_m:R0A ram| state))) ; \dout 60 | (define-fun |ram_m:R0D ram| ((state |ram_s|)) (_ BitVec 32) (|ram#4| state)) 61 | (define-fun |ram_n dout| ((state |ram_s|)) (_ BitVec 32) (|ram#4| state)) 62 | ; yosys-smt2-output ready 1 63 | (define-fun |ram_n ready| ((state |ram_s|)) Bool (|ram#5| state)) 64 | ; yosys-smt2-input valid 1 65 | (define-fun |ram_n valid| ((state |ram_s|)) Bool (|ram#5| state)) 66 | ; yosys-smt2-input wstrb 4 67 | (define-fun |ram_n wstrb| ((state |ram_s|)) (_ BitVec 4) (|ram#6| state)) 68 | (define-fun |ram#7| ((state |ram_s|)) Bool (distinct (|ram#6| state) #b0000)) ; $ne$ram.v:22$14_Y 69 | (define-fun |ram#8| ((state |ram_s|)) Bool (and (or (|ram#5| state) false) (or (|ram#7| state) false))) ; $logic_and$ram.v:22$15_Y 70 | (define-fun |ram#9| ((state |ram_s|)) (_ BitVec 8) (ite (|ram#8| state) ((_ extract 9 2) (|ram#0| state)) #b00000000)) ; $0$memwr$\ram$ram.v:23$5_ADDR[7:0]$11 71 | (define-fun |ram#10| ((state |ram_s|)) (_ BitVec 8) (ite (= ((_ extract 0 0) (|ram#6| state)) #b1) ((_ extract 7 0) (|ram#2| state)) ((_ extract 7 0) (|ram#4| state)))) ; \din_masked [7:0] 72 | (define-fun |ram#11| ((state |ram_s|)) (_ BitVec 8) (ite (= ((_ extract 1 1) (|ram#6| state)) #b1) ((_ extract 15 8) (|ram#2| state)) ((_ extract 15 8) (|ram#4| state)))) ; \din_masked [15:8] 73 | (define-fun |ram#12| ((state |ram_s|)) (_ BitVec 8) (ite (= ((_ extract 2 2) (|ram#6| state)) #b1) ((_ extract 23 16) (|ram#2| state)) ((_ extract 23 16) (|ram#4| state)))) ; \din_masked [23:16] 74 | (define-fun |ram#13| ((state |ram_s|)) (_ BitVec 8) (ite (= ((_ extract 3 3) (|ram#6| state)) #b1) ((_ extract 31 24) (|ram#2| state)) ((_ extract 31 24) (|ram#4| state)))) ; \din_masked [31:24] 75 | (define-fun |ram#14| ((state |ram_s|)) (_ BitVec 32) (ite (|ram#8| state) (concat (|ram#13| state) (concat (|ram#12| state) (concat (|ram#11| state) (|ram#10| state)))) #b00000000000000000000000000000000)) ; $0$memwr$\ram$ram.v:23$5_DATA[31:0]$12 76 | (define-fun |ram#15| ((state |ram_s|)) (_ BitVec 1) (ite (|ram#8| state) #b1 #b0)) ; $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] 77 | (define-fun |ram_m:W0A ram| ((state |ram_s|)) (_ BitVec 8) (|ram#9| state)) ; $0$memwr$\ram$ram.v:23$5_ADDR[7:0]$11 78 | (define-fun |ram_m:W0D ram| ((state |ram_s|)) (_ BitVec 32) (|ram#14| state)) ; $0$memwr$\ram$ram.v:23$5_DATA[31:0]$12 79 | (define-fun |ram_m:W0M ram| ((state |ram_s|)) (_ BitVec 32) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (concat (|ram#15| state) (|ram#15| state))))))))))))))))))))))))))))))))) ; { $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] $0$memwr$\ram$ram.v:23$5_EN[31:0]$13 [31] } 80 | (define-fun |ram#3#1| ((state |ram_s|)) (Array (_ BitVec 8) (_ BitVec 32)) (store (|ram#3#0| state) (|ram_m:W0A ram| state) (bvor (bvand (|ram_m:W0D ram| state) (|ram_m:W0M ram| state)) (bvand (select (|ram#3#0| state) (|ram_m:W0A ram| state)) (bvnot (|ram_m:W0M ram| state)))))) ; ram 81 | (define-fun |ram_a| ((state |ram_s|)) Bool true) 82 | (define-fun |ram_u| ((state |ram_s|)) Bool true) 83 | (define-fun |ram_i| ((state |ram_s|)) Bool true) 84 | (define-fun |ram_h| ((state |ram_s|)) Bool true) 85 | (define-fun |ram_t| ((state |ram_s|) (next_state |ram_s|)) Bool 86 | (= (|ram#3#1| state) (|ram#3#0| next_state)) ; ram 87 | ) ; end of module ram 88 | ; yosys-smt2-topmod ram 89 | ; end of yosys output 90 | -------------------------------------------------------------------------------- /knox/correctness/hint.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/bool 5 | racket/match 6 | (prefix-in @ (combine-in rosette/safe rosutil/lens)) 7 | (for-syntax racket/base syntax/parse) 8 | syntax/parse/define) 9 | 10 | (provide 11 | (struct-out hint) 12 | done 13 | done? 14 | evaluate-to-next-hint 15 | (except-out (struct-out merge!) merge!) 16 | (except-out (struct-out fixpoint) fixpoint) 17 | (except-out (struct-out case-split!) case-split!) 18 | (struct-out debug*) 19 | (except-out (struct-out tactic) tactic) 20 | (except-out (struct-out get-state) get-state) 21 | (except-out (struct-out concretize!) concretize!) 22 | (except-out (struct-out overapproximate!) overapproximate!) 23 | (except-out (struct-out overapproximate-pc!) overapproximate-pc!) 24 | (except-out (struct-out replace!) replace!) 25 | (except-out (struct-out remember!) remember!) 26 | (except-out (struct-out subst!) subst!) 27 | (except-out (struct-out clear!) clear!) 28 | (rename-out 29 | [tactic# tactic] 30 | [get-state# get-state] 31 | [merge!# merge!] 32 | [fixpoint# fixpoint] 33 | [case-split!# case-split!] 34 | [concretize!# concretize!] 35 | [overapproximate!# overapproximate!] 36 | [overapproximate-pc!# overapproximate-pc!] 37 | [replace!# replace!] 38 | [remember!# remember!] 39 | [subst!# subst!] 40 | [clear!# clear!]) 41 | make-hintdb 42 | extend-hintdb) 43 | 44 | (struct hint ()) 45 | 46 | (define-syntax make-hintdb 47 | (syntax-parser 48 | [(_ [name:id hint:expr] ...) 49 | #'(make-immutable-hash (list (cons 'name hint) ...))])) 50 | 51 | (define (hash-extend base pairs) 52 | (for/fold ([tbl base]) 53 | ([pair pairs]) 54 | (hash-set tbl (car pair) (cdr pair)))) 55 | 56 | (define-syntax extend-hintdb 57 | (syntax-parser 58 | [(_ base:expr [name:id hint:expr] ...) 59 | #'(hash-extend base (list (cons 'name hint) ...))])) 60 | 61 | (define done false) 62 | (define done? false?) 63 | 64 | (define hint-evaluation-prompt-tag (make-continuation-prompt-tag)) 65 | 66 | (define-simple-macro (wrap (hint-struct args ...)) 67 | (if (continuation-prompt-available? hint-evaluation-prompt-tag) 68 | (call-with-current-continuation 69 | (lambda (k) 70 | (abort-current-continuation hint-evaluation-prompt-tag (lambda () (hint-struct args ... k)))) 71 | hint-evaluation-prompt-tag) 72 | (hint-struct args ... (lambda _ done)))) 73 | 74 | (define (evaluate-to-next-hint k arg) 75 | (define next (call-with-continuation-prompt (lambda () (k arg)) hint-evaluation-prompt-tag)) 76 | (if (hint? next) ; to handle the case where k returns (void), etc. 77 | next 78 | done)) 79 | 80 | (struct tactic hint (k)) 81 | 82 | (define (tactic-constructor fn) 83 | (tactic fn)) 84 | 85 | (define-match-expander tactic# 86 | (syntax-parser [(_ args ...) #'(tactic args ...)]) 87 | (syntax-parser 88 | ;; take an ignored value so we can call a tactic and a continuation in the same way, 89 | ;; by plugging in a value when applicable, and (void) otherwise, which will be 90 | ;; passed in this case 91 | [(_ args ...) #'(tactic-constructor (lambda (ignored) args ...))])) 92 | 93 | (struct get-state hint (k)) 94 | 95 | (define (get-state-hint) 96 | (wrap (get-state))) 97 | 98 | (define-match-expander get-state# 99 | (syntax-parser [(_ args ...) #'(get-state args ...)]) 100 | (syntax-parser 101 | [(_ args ...) #'(get-state-hint args ...)] 102 | [_ #'get-state-hint])) 103 | 104 | (struct merge! hint (key k)) 105 | 106 | (define (merge!-hint [key (lambda (st) #t)]) 107 | (wrap (merge! key))) 108 | 109 | (define-match-expander merge!# 110 | (syntax-parser [(_ args ...) #'(merge! args ...)]) 111 | (syntax-parser 112 | [(_ args ...) #'(merge!-hint args ...)] 113 | [_ #'merge!-hint])) 114 | 115 | (struct fixpoint (setup-cycles auto-detect cycle-length step-concretize-lens use-pc piecewise step-overapproximate-lens k)) 116 | 117 | (define (fixpoint-constructor setup-cycles auto-detect cycle-length [step-concretize-lens #f] [step-overapproximate-lens #f] [k done] #:use-pc [use-pc #f] #:piecewise [piecewise #f]) 118 | (fixpoint setup-cycles auto-detect cycle-length step-concretize-lens use-pc piecewise step-overapproximate-lens k)) 119 | 120 | (define-match-expander fixpoint# 121 | (syntax-parser [(_ args ...) #'(fixpoint args ...)]) 122 | (syntax-parser 123 | [(_ args ...) #'(fixpoint-constructor args ...)] 124 | [_ #'fixpoint-constructor])) 125 | 126 | (struct case-split! hint (splits use-equalities k)) 127 | 128 | (define (case-split!-hint splits #:use-equalities [use-equalities #f]) 129 | (wrap (case-split! splits use-equalities))) 130 | 131 | (define-match-expander case-split!# 132 | (syntax-parser [(_ args ...) #'(case-split! args ...)]) 133 | (syntax-parser 134 | [(_ args ...) #'(case-split!-hint args ...)] 135 | [_ #'case-split!-hint])) 136 | 137 | ;; for debugging merges: basically acts like a merge! and calls the 138 | ;; callback with all the paths 139 | ;; 140 | ;; return value is not used (unlike other hints, which return another hint 141 | (struct debug* hint (callback)) 142 | 143 | (struct concretize! hint (lens use-pc use-equalities piecewise k)) 144 | 145 | (define (concretize!-hint lens #:piecewise [piecewise #f] #:use-pc [use-pc #f] #:use-equalities [use-equalities #f]) 146 | (wrap (concretize! lens use-pc use-equalities piecewise))) 147 | 148 | (define-match-expander concretize!# 149 | (syntax-parser [(_ args ...) #'(concretize! args ...)]) 150 | (syntax-parser 151 | [(_ args ...) #'(concretize!-hint args ...)] 152 | [_ #'concretize!-hint])) 153 | 154 | (struct overapproximate! hint (lens k)) 155 | 156 | (define (overapproximate!-hint lens) 157 | (wrap (overapproximate! lens))) 158 | 159 | (define-match-expander overapproximate!# 160 | (syntax-parser [(_ args ...) #'(overapproximate! args ...)]) 161 | (syntax-parser 162 | [(_ args ...) #'(overapproximate!-hint args ...)] 163 | [_ #'overapproximate!-hint])) 164 | 165 | (struct overapproximate-pc! hint (pc use-equalities k)) 166 | 167 | (define (overapproximate-pc!-hint pc #:use-equalities [use-equalities #f]) 168 | (wrap (overapproximate-pc! pc use-equalities))) 169 | 170 | (define-match-expander overapproximate-pc!# 171 | (syntax-parser [(_ args ...) #'(overapproximate-pc! args ...)]) 172 | (syntax-parser 173 | [(_ args ...) #'(overapproximate-pc!-hint args ...)] 174 | [_ #'overapproximate-pc!-hint])) 175 | 176 | (struct replace! hint (lens term use-pc use-equalities k)) 177 | 178 | (define (replace!-hint lens term #:use-pc [use-pc #f] #:use-equalities [use-equalities #f]) 179 | (wrap (replace! lens term use-pc use-equalities))) 180 | 181 | (define-match-expander replace!# 182 | (syntax-parser [(_ args ...) #'(replace! args ...)]) 183 | (syntax-parser 184 | [(_ args ...) #'(replace!-hint args ...)] 185 | [_ #'replace!-hint])) 186 | 187 | (struct remember! hint (lens name k)) 188 | 189 | (define (remember!-hint lens [name #f]) 190 | (wrap (remember! lens name))) 191 | 192 | (define-match-expander remember!# 193 | (syntax-parser [(_ args ...) #'(remember! args ...)]) 194 | (syntax-parser 195 | [(_ args ...) #'(remember!-hint args ...)] 196 | [_ #'remember!-hint])) 197 | 198 | (struct subst! hint (lens variable k)) 199 | 200 | (define (subst!-hint lens [variable #f]) 201 | (wrap (subst! lens variable))) 202 | 203 | (define-match-expander subst!# 204 | (syntax-parser [(_ args ...) #'(subst! args ...)]) 205 | (syntax-parser 206 | [(_ args ...) #'(subst!-hint args ...)] 207 | [_ #'subst!-hint])) 208 | 209 | (struct clear! hint (variable k)) 210 | 211 | (define (clear!-hint [variable #f]) 212 | (wrap (clear! variable))) 213 | 214 | (define-match-expander clear!# 215 | (syntax-parser [(_ args ...) #'(clear! args ...)]) 216 | (syntax-parser 217 | [(_ args ...) #'(clear!-hint args ...)] 218 | [_ #'clear!-hint])) 219 | -------------------------------------------------------------------------------- /test/yosys/verilog/lockbox.rkt: -------------------------------------------------------------------------------- 1 | #lang yosys 2 | 3 | #| 4 | module lockbox #( 5 | parameter WIDTH = 128 6 | ) (input clk, input en, input op, input [WIDTH-1:0] secret, input [WIDTH-1:0] password, output [WIDTH-1:0] out, output dummy_out); 7 | 8 | reg [WIDTH-1:0] stored_secret; 9 | reg [WIDTH-1:0] stored_password; 10 | reg [WIDTH-1:0] returned_secret; 11 | reg [63:0] count_cycle; 12 | reg x1; 13 | reg x2; 14 | 15 | initial begin 16 | stored_secret = 0; 17 | stored_password = 0; 18 | returned_secret = 0; 19 | count_cycle = 0; 20 | x1 = 0; 21 | x2 = 1; 22 | end 23 | 24 | always @(posedge clk) begin 25 | count_cycle <= count_cycle + 1; 26 | x1 <= !x1; 27 | x2 <= !x2; 28 | if (en) begin 29 | if (op) begin 30 | // store 31 | stored_secret <= secret; 32 | stored_password <= password; 33 | returned_secret <= 0; 34 | end else begin 35 | // get 36 | if (password == stored_password) begin 37 | returned_secret <= stored_secret; 38 | end else begin 39 | returned_secret <= 0; 40 | end 41 | stored_secret <= 0; 42 | // NOTE: Rosette verification actually caught a bug here; there 43 | // was a typo: 44 | // stored_pasword <= 0; 45 | stored_password <= 0; 46 | end 47 | value <= value + delta; 48 | end else begin 49 | returned_secret <= 0; 50 | end 51 | end 52 | assign out = (x1 != x2) ? returned_secret : 0; 53 | assign dummy_out = count_cycle; 54 | 55 | endmodule 56 | |# 57 | 58 | ; SMT-LIBv2 description generated by Yosys 0.9+3806 (git sha1 d30063ea6, clang 12.0.0 -fPIC -Os) 59 | ; yosys-smt2-stdt 60 | ; yosys-smt2-module lockbox 61 | (declare-datatype |lockbox_s| ((|lockbox_mk| 62 | (|lockbox_is| Bool) 63 | (|lockbox#0| Bool) ; \clk 64 | (|lockbox#1| (_ BitVec 64)) ; \count_cycle 65 | (|lockbox#2| Bool) ; \en 66 | (|lockbox#3| Bool) ; \op 67 | (|lockbox#4| (_ BitVec 128)) ; \returned_secret 68 | (|lockbox#5| (_ BitVec 1)) ; \x1 69 | (|lockbox#6| (_ BitVec 1)) ; \x2 70 | (|lockbox#9| (_ BitVec 128)) ; \password 71 | (|lockbox#10| (_ BitVec 128)) ; \secret 72 | (|lockbox#11| (_ BitVec 128)) ; \stored_password 73 | (|lockbox#12| (_ BitVec 128)) ; \stored_secret 74 | ))) 75 | ; yosys-smt2-input clk 1 76 | ; yosys-smt2-clock clk posedge 77 | (define-fun |lockbox_n clk| ((state |lockbox_s|)) Bool (|lockbox#0| state)) 78 | ; yosys-smt2-register count_cycle 64 79 | (define-fun |lockbox_n count_cycle| ((state |lockbox_s|)) (_ BitVec 64) (|lockbox#1| state)) 80 | ; yosys-smt2-output dummy_out 1 81 | (define-fun |lockbox_n dummy_out| ((state |lockbox_s|)) Bool (= ((_ extract 0 0) (|lockbox#1| state)) #b1)) 82 | ; yosys-smt2-input en 1 83 | (define-fun |lockbox_n en| ((state |lockbox_s|)) Bool (|lockbox#2| state)) 84 | ; yosys-smt2-input op 1 85 | (define-fun |lockbox_n op| ((state |lockbox_s|)) Bool (|lockbox#3| state)) 86 | (define-fun |lockbox#7| ((state |lockbox_s|)) Bool (distinct (|lockbox#5| state) (|lockbox#6| state))) ; $ne$lockbox.v:49$7_Y 87 | (define-fun |lockbox#8| ((state |lockbox_s|)) (_ BitVec 128) (ite (|lockbox#7| state) (|lockbox#4| state) #b00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) ; \out 88 | ; yosys-smt2-output out 128 89 | (define-fun |lockbox_n out| ((state |lockbox_s|)) (_ BitVec 128) (|lockbox#8| state)) 90 | ; yosys-smt2-input password 128 91 | (define-fun |lockbox_n password| ((state |lockbox_s|)) (_ BitVec 128) (|lockbox#9| state)) 92 | ; yosys-smt2-register returned_secret 128 93 | (define-fun |lockbox_n returned_secret| ((state |lockbox_s|)) (_ BitVec 128) (|lockbox#4| state)) 94 | ; yosys-smt2-input secret 128 95 | (define-fun |lockbox_n secret| ((state |lockbox_s|)) (_ BitVec 128) (|lockbox#10| state)) 96 | ; yosys-smt2-register stored_password 128 97 | (define-fun |lockbox_n stored_password| ((state |lockbox_s|)) (_ BitVec 128) (|lockbox#11| state)) 98 | ; yosys-smt2-register stored_secret 128 99 | (define-fun |lockbox_n stored_secret| ((state |lockbox_s|)) (_ BitVec 128) (|lockbox#12| state)) 100 | ; yosys-smt2-register x1 1 101 | (define-fun |lockbox_n x1| ((state |lockbox_s|)) Bool (= ((_ extract 0 0) (|lockbox#5| state)) #b1)) 102 | ; yosys-smt2-register x2 1 103 | (define-fun |lockbox_n x2| ((state |lockbox_s|)) Bool (= ((_ extract 0 0) (|lockbox#6| state)) #b1)) 104 | (define-fun |lockbox#13| ((state |lockbox_s|)) (_ BitVec 128) (ite (|lockbox#3| state) (|lockbox#10| state) #b00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) ; $procmux$31_Y 105 | (define-fun |lockbox#14| ((state |lockbox_s|)) (_ BitVec 128) (ite (|lockbox#2| state) (|lockbox#13| state) (|lockbox#12| state))) ; $0\stored_secret[127:0] 106 | (define-fun |lockbox#15| ((state |lockbox_s|)) (_ BitVec 128) (ite (|lockbox#3| state) (|lockbox#9| state) #b00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) ; $procmux$25_Y 107 | (define-fun |lockbox#16| ((state |lockbox_s|)) (_ BitVec 128) (ite (|lockbox#2| state) (|lockbox#15| state) (|lockbox#11| state))) ; $0\stored_password[127:0] 108 | (define-fun |lockbox#17| ((state |lockbox_s|)) Bool (not (or (= ((_ extract 0 0) (|lockbox#6| state)) #b1) false))) ; $0\x2[0:0] 109 | (define-fun |lockbox#18| ((state |lockbox_s|)) Bool (not (or (= ((_ extract 0 0) (|lockbox#5| state)) #b1) false))) ; $0\x1[0:0] 110 | (define-fun |lockbox#19| ((state |lockbox_s|)) Bool (= (|lockbox#9| state) (|lockbox#11| state))) ; $eq$lockbox.v:33$5_Y 111 | (define-fun |lockbox#20| ((state |lockbox_s|)) (_ BitVec 128) (ite (|lockbox#19| state) (|lockbox#12| state) #b00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) ; $procmux$13_Y 112 | (define-fun |lockbox#21| ((state |lockbox_s|)) (_ BitVec 128) (ite (|lockbox#3| state) #b00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 (|lockbox#20| state))) ; $procmux$16_Y 113 | (define-fun |lockbox#22| ((state |lockbox_s|)) (_ BitVec 128) (ite (|lockbox#2| state) (|lockbox#21| state) #b00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) ; $0\returned_secret[127:0] 114 | (define-fun |lockbox#23| ((state |lockbox_s|)) (_ BitVec 64) (bvadd (|lockbox#1| state) #b0000000000000000000000000000000000000000000000000000000000000001)) ; $0\count_cycle[63:0] 115 | (define-fun |lockbox_a| ((state |lockbox_s|)) Bool true) 116 | (define-fun |lockbox_u| ((state |lockbox_s|)) Bool true) 117 | (define-fun |lockbox_i| ((state |lockbox_s|)) Bool (and 118 | (= (|lockbox#1| state) #b0000000000000000000000000000000000000000000000000000000000000000) ; count_cycle 119 | (= (|lockbox#4| state) #b00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000) ; returned_secret 120 | (= (|lockbox#11| state) #b00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000) ; stored_password 121 | (= (|lockbox#12| state) #b00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000) ; stored_secret 122 | (= (= ((_ extract 0 0) (|lockbox#5| state)) #b1) false) ; x1 123 | (= (= ((_ extract 0 0) (|lockbox#6| state)) #b1) true) ; x2 124 | )) 125 | (define-fun |lockbox_h| ((state |lockbox_s|)) Bool true) 126 | (define-fun |lockbox_t| ((state |lockbox_s|) (next_state |lockbox_s|)) Bool (and 127 | (= (|lockbox#14| state) (|lockbox#12| next_state)) ; $procdff$35 \stored_secret 128 | (= (|lockbox#16| state) (|lockbox#11| next_state)) ; $procdff$36 \stored_password 129 | (= (ite (|lockbox#17| state) #b1 #b0) (|lockbox#6| next_state)) ; $procdff$40 \x2 130 | (= (ite (|lockbox#18| state) #b1 #b0) (|lockbox#5| next_state)) ; $procdff$39 \x1 131 | (= (|lockbox#22| state) (|lockbox#4| next_state)) ; $procdff$37 \returned_secret 132 | (= (|lockbox#23| state) (|lockbox#1| next_state)) ; $procdff$38 \count_cycle 133 | )) ; end of module lockbox 134 | ; yosys-smt2-topmod lockbox 135 | ; end of yosys output 136 | -------------------------------------------------------------------------------- /test/yosys/verilog/multi_port_memory.rkt: -------------------------------------------------------------------------------- 1 | #lang yosys 2 | 3 | #| 4 | module multi_port_memory #( 5 | ) ( 6 | input clk, 7 | input resetn, 8 | input en, 9 | output [1:0] data_out 10 | ); 11 | 12 | reg [1:0] data [1:0]; 13 | reg len; 14 | 15 | always @(posedge clk) begin 16 | if (!resetn) begin 17 | if (en) begin 18 | /* ensures that this remains a memory */ 19 | data[len] <= data[len]; 20 | end 21 | end else begin 22 | /* results in Yosys synthesizing a multi-port memory */ 23 | data[0] <= 2'b01; 24 | data[1] <= 2'b10; 25 | end 26 | end 27 | 28 | always @(*) begin 29 | data_out = data[0]; 30 | end 31 | 32 | endmodule 33 | |# 34 | 35 | ; SMT-LIBv2 description generated by Yosys 0.21 (git sha1 e6d2a900a97, clang 13.1.6 -fPIC -Os) 36 | ; yosys-smt2-stdt 37 | ; yosys-smt2-module multi_port_memory 38 | (declare-datatype |multi_port_memory_s| ((|multi_port_memory_mk| 39 | (|multi_port_memory_is| Bool) 40 | (|multi_port_memory#0| Bool) ; \clk 41 | (|multi_port_memory#1#0| (Array (_ BitVec 1) (_ BitVec 2))) ; data 42 | (|multi_port_memory#3| (_ BitVec 1)) ; \len 43 | (|multi_port_memory#5| Bool) ; \en 44 | (|multi_port_memory#6| Bool) ; \resetn 45 | ))) 46 | ; yosys-smt2-input clk 1 47 | ; yosys-smt2-clock clk posedge 48 | ; yosys-smt2-witness {"offset": 0, "path": ["\\clk"], "smtname": "clk", "type": "posedge", "width": 1} 49 | ; yosys-smt2-witness {"offset": 0, "path": ["\\clk"], "smtname": "clk", "type": "input", "width": 1} 50 | (define-fun |multi_port_memory_n clk| ((state |multi_port_memory_s|)) Bool (|multi_port_memory#0| state)) 51 | ; yosys-smt2-memory data 1 2 2 3 sync 52 | ; yosys-smt2-witness {"path": ["\\data"], "rom": false, "size": 2, "smtname": "data", "statebv": false, "type": "mem", "uninitialized": [{"offset": 0, "width": 4}], "width": 2} 53 | (define-fun |multi_port_memory_m data| ((state |multi_port_memory_s|)) (Array (_ BitVec 1) (_ BitVec 2)) (|multi_port_memory#1#0| state)) 54 | (define-fun |multi_port_memory_m:R0A data| ((state |multi_port_memory_s|)) (_ BitVec 1) #b0) ; 1'0 55 | (define-fun |multi_port_memory#2| ((state |multi_port_memory_s|)) (_ BitVec 2) (select (|multi_port_memory#1#0| state) (|multi_port_memory_m:R0A data| state))) ; \data_out 56 | (define-fun |multi_port_memory_m:R0D data| ((state |multi_port_memory_s|)) (_ BitVec 2) (|multi_port_memory#2| state)) 57 | (define-fun |multi_port_memory_m:R1A data| ((state |multi_port_memory_s|)) (_ BitVec 1) (|multi_port_memory#3| state)) ; \len 58 | (define-fun |multi_port_memory#4| ((state |multi_port_memory_s|)) (_ BitVec 2) (select (|multi_port_memory#1#0| state) (|multi_port_memory_m:R1A data| state))) ; $memrd$\data$multi_port_memory.v:16$19_DATA 59 | (define-fun |multi_port_memory_m:R1D data| ((state |multi_port_memory_s|)) (_ BitVec 2) (|multi_port_memory#4| state)) 60 | ; yosys-smt2-output data_out 2 61 | (define-fun |multi_port_memory_n data_out| ((state |multi_port_memory_s|)) (_ BitVec 2) (|multi_port_memory#2| state)) 62 | ; yosys-smt2-input en 1 63 | ; yosys-smt2-witness {"offset": 0, "path": ["\\en"], "smtname": "en", "type": "input", "width": 1} 64 | (define-fun |multi_port_memory_n en| ((state |multi_port_memory_s|)) Bool (|multi_port_memory#5| state)) 65 | ; yosys-smt2-input resetn 1 66 | ; yosys-smt2-witness {"offset": 0, "path": ["\\resetn"], "smtname": "resetn", "type": "input", "width": 1} 67 | (define-fun |multi_port_memory_n resetn| ((state |multi_port_memory_s|)) Bool (|multi_port_memory#6| state)) 68 | (define-fun |multi_port_memory#7| ((state |multi_port_memory_s|)) (_ BitVec 1) (ite (|multi_port_memory#5| state) (|multi_port_memory#3| state) #b0)) ; $2$memwr$\data$multi_port_memory.v:16$1_ADDR[0:0]$16 69 | (define-fun |multi_port_memory#8| ((state |multi_port_memory_s|)) (_ BitVec 1) (ite (|multi_port_memory#6| state) #b0 (|multi_port_memory#7| state))) ; $0$memwr$\data$multi_port_memory.v:16$1_ADDR[0:0]$5 70 | (define-fun |multi_port_memory#9| ((state |multi_port_memory_s|)) (_ BitVec 2) (ite (|multi_port_memory#5| state) (|multi_port_memory#4| state) #b00)) ; $2$memwr$\data$multi_port_memory.v:16$1_DATA[1:0]$17 71 | (define-fun |multi_port_memory#10| ((state |multi_port_memory_s|)) (_ BitVec 2) (ite (|multi_port_memory#6| state) #b00 (|multi_port_memory#9| state))) ; $0$memwr$\data$multi_port_memory.v:16$1_DATA[1:0]$6 72 | (define-fun |multi_port_memory#11| ((state |multi_port_memory_s|)) (_ BitVec 1) (ite (|multi_port_memory#5| state) #b1 #b0)) ; $2$memwr$\data$multi_port_memory.v:16$1_EN[1:0]$18 [1] 73 | (define-fun |multi_port_memory#12| ((state |multi_port_memory_s|)) (_ BitVec 1) (ite (|multi_port_memory#6| state) #b0 (|multi_port_memory#11| state))) ; $0$memwr$\data$multi_port_memory.v:16$1_EN[1:0]$7 [1] 74 | (define-fun |multi_port_memory_m:W0A data| ((state |multi_port_memory_s|)) (_ BitVec 1) (|multi_port_memory#8| state)) ; $0$memwr$\data$multi_port_memory.v:16$1_ADDR[0:0]$5 75 | (define-fun |multi_port_memory_m:W0D data| ((state |multi_port_memory_s|)) (_ BitVec 2) (|multi_port_memory#10| state)) ; $0$memwr$\data$multi_port_memory.v:16$1_DATA[1:0]$6 76 | (define-fun |multi_port_memory_m:W0M data| ((state |multi_port_memory_s|)) (_ BitVec 2) (concat (|multi_port_memory#12| state) (|multi_port_memory#12| state))) ; { $0$memwr$\data$multi_port_memory.v:16$1_EN[1:0]$7 [1] $0$memwr$\data$multi_port_memory.v:16$1_EN[1:0]$7 [1] } 77 | (define-fun |multi_port_memory#1#1| ((state |multi_port_memory_s|)) (Array (_ BitVec 1) (_ BitVec 2)) (ite (= (|multi_port_memory_m:W0M data| state) #b00) (|multi_port_memory#1#0| state) (store (|multi_port_memory#1#0| state) (|multi_port_memory_m:W0A data| state) (bvor (bvand (|multi_port_memory_m:W0D data| state) (|multi_port_memory_m:W0M data| state)) (bvand (select (|multi_port_memory#1#0| state) (|multi_port_memory_m:W0A data| state)) (bvnot (|multi_port_memory_m:W0M data| state))))))) ; data 78 | (define-fun |multi_port_memory#13| ((state |multi_port_memory_s|)) (_ BitVec 1) (ite (|multi_port_memory#6| state) #b1 #b0)) ; $0$memwr$\data$multi_port_memory.v:20$2_EN[1:0]$8 [1] 79 | (define-fun |multi_port_memory_m:W1A data| ((state |multi_port_memory_s|)) (_ BitVec 1) #b0) ; 1'0 80 | (define-fun |multi_port_memory_m:W1D data| ((state |multi_port_memory_s|)) (_ BitVec 2) #b01) ; 2'01 81 | (define-fun |multi_port_memory_m:W1M data| ((state |multi_port_memory_s|)) (_ BitVec 2) (concat (|multi_port_memory#13| state) (|multi_port_memory#13| state))) ; { $0$memwr$\data$multi_port_memory.v:20$2_EN[1:0]$8 [1] $0$memwr$\data$multi_port_memory.v:20$2_EN[1:0]$8 [1] } 82 | (define-fun |multi_port_memory#1#2| ((state |multi_port_memory_s|)) (Array (_ BitVec 1) (_ BitVec 2)) (ite (= (|multi_port_memory_m:W1M data| state) #b00) (|multi_port_memory#1#1| state) (store (|multi_port_memory#1#1| state) (|multi_port_memory_m:W1A data| state) (bvor (bvand (|multi_port_memory_m:W1D data| state) (|multi_port_memory_m:W1M data| state)) (bvand (select (|multi_port_memory#1#1| state) (|multi_port_memory_m:W1A data| state)) (bvnot (|multi_port_memory_m:W1M data| state))))))) ; data 83 | (define-fun |multi_port_memory_m:W2A data| ((state |multi_port_memory_s|)) (_ BitVec 1) #b1) ; 1'1 84 | (define-fun |multi_port_memory_m:W2D data| ((state |multi_port_memory_s|)) (_ BitVec 2) #b10) ; 2'10 85 | (define-fun |multi_port_memory_m:W2M data| ((state |multi_port_memory_s|)) (_ BitVec 2) (concat (|multi_port_memory#13| state) (|multi_port_memory#13| state))) ; { $0$memwr$\data$multi_port_memory.v:20$2_EN[1:0]$8 [1] $0$memwr$\data$multi_port_memory.v:20$2_EN[1:0]$8 [1] } 86 | (define-fun |multi_port_memory#1#3| ((state |multi_port_memory_s|)) (Array (_ BitVec 1) (_ BitVec 2)) (ite (= (|multi_port_memory_m:W2M data| state) #b00) (|multi_port_memory#1#2| state) (store (|multi_port_memory#1#2| state) (|multi_port_memory_m:W2A data| state) (bvor (bvand (|multi_port_memory_m:W2D data| state) (|multi_port_memory_m:W2M data| state)) (bvand (select (|multi_port_memory#1#2| state) (|multi_port_memory_m:W2A data| state)) (bvnot (|multi_port_memory_m:W2M data| state))))))) ; data 87 | (define-fun |multi_port_memory_a| ((state |multi_port_memory_s|)) Bool true) 88 | (define-fun |multi_port_memory_u| ((state |multi_port_memory_s|)) Bool true) 89 | (define-fun |multi_port_memory_i| ((state |multi_port_memory_s|)) Bool true) 90 | (define-fun |multi_port_memory_h| ((state |multi_port_memory_s|)) Bool true) 91 | (define-fun |multi_port_memory_t| ((state |multi_port_memory_s|) (next_state |multi_port_memory_s|)) Bool 92 | (= (|multi_port_memory#1#3| state) (|multi_port_memory#1#0| next_state)) ; data 93 | ) ; end of module multi_port_memory 94 | ; yosys-smt2-topmod multi_port_memory 95 | ; end of yosys output 96 | -------------------------------------------------------------------------------- /yosys/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/list racket/string racket/match 4 | syntax/readerr) 5 | 6 | (provide (rename-out 7 | [yosys-read read] 8 | [yosys-read-syntax read-syntax])) 9 | 10 | (define (make-yosys-readtable) 11 | (make-readtable (current-readtable) 12 | #\b 'dispatch-macro read-bitvector 13 | #\; 'terminating-macro read-comment)) 14 | 15 | (define (make-yosys-toplevel-readtable) 16 | (make-readtable (make-yosys-readtable) 17 | #\( 'terminating-macro (read-toplevel-paren (current-readtable)))) 18 | 19 | (define (delimiter? c) 20 | (cond 21 | [(char-whitespace? c) #t] 22 | [else (case c 23 | [(#\() #t] 24 | [(#\)) #t] 25 | [(#\[) #t] 26 | [(#\]) #t] 27 | [(#\{) #t] 28 | [(#\}) #t] 29 | [(#\") #t] 30 | [(#\,) #t] 31 | [(#\') #t] 32 | [(#\`) #t] 33 | [(#\;) #t] 34 | [else #f])])) 35 | 36 | (define (read-bitvector match-ch in src init-line init-col init-pos) 37 | (define digits 38 | (let loop ([acc '()]) 39 | (let ([c (peek-char in)]) 40 | (cond 41 | [(eof-object? c) acc] 42 | [(delimiter? c) acc] 43 | [(not (or (char=? c #\0) (char=? c #\1))) 44 | (let-values ([(line col pos) (port-next-location in)]) 45 | (raise-read-error (format "bad digit `~a`" c) src line col pos 1))] 46 | [else 47 | (read-char in) 48 | (loop (cons c acc))])))) 49 | (when (empty? digits) 50 | (raise-read-error "no digits" src init-line init-col init-pos 2)) 51 | (define value 52 | (for/fold ([acc 0]) 53 | ([i (in-list (reverse digits))]) 54 | (+ (* acc 2) (if (char=? i #\0) 0 1)))) 55 | (define width (length digits)) 56 | (datum->syntax #f `(bv ,value ,width) 57 | (and 58 | init-line 59 | (vector src init-line init-col init-pos width)))) 60 | 61 | ; handling newlines the same way as Racket's line comment reader 62 | (define (newline? c) 63 | (case c 64 | [(#\u0a) #t] 65 | [(#\u0d) #t] 66 | [(#\u85) #t] 67 | [(#\u2028) #t] 68 | [(#\u2029) #t] 69 | [else #f])) 70 | 71 | (define (read-until-eol port) 72 | (define chars 73 | (let loop ([acc '()]) 74 | (let ([c (read-char port)]) 75 | (cond 76 | [(eof-object? c) acc] 77 | [(newline? c) acc] 78 | [else (loop (cons c acc))])))) 79 | (apply string-append (map string (reverse chars)))) 80 | 81 | ; Yosys emits certain useful information as comments. We try to 82 | ; recognize all of these useful comments and preserve them, so the 83 | ; expander layer can do something useful with them. 84 | (define (read-comment match-ch in src init-line init-col init-pos) 85 | (define comment (read-until-eol in)) 86 | (define width (string-length comment)) 87 | (define srcloc 88 | (and 89 | init-line 90 | (vector src init-line init-col init-pos width))) 91 | (define trimmed (string-trim comment)) 92 | (match trimmed 93 | [(regexp #px"^yosys-smt2-stdt$") 94 | (datum->syntax #f '(yosys-smt2-stdt) srcloc)] 95 | [(regexp #px"^yosys-smt2-module (.*)$" (list _ module-name)) 96 | (datum->syntax #f `(yosys-smt2-module ,(string->symbol module-name)) srcloc)] 97 | [(regexp #px"^yosys-smt2-topmod (.*)$" (list _ topmod-name)) 98 | (datum->syntax #f `(yosys-smt2-topmod ,(string->symbol topmod-name)) srcloc)] 99 | [(regexp #px"^yosys-smt2-clock (.*) (.*)$" (list _ clock-name clock-edge)) 100 | (datum->syntax #f `(yosys-smt2-clock ,(string->symbol clock-name) ',(string->symbol clock-edge)) srcloc)] 101 | [(regexp #px"^yosys-smt2-input (.*) (\\d+)$" (list _ input-name input-width)) 102 | (datum->syntax #f `(yosys-smt2-input ,(string->symbol input-name) ,(string->number input-width)))] 103 | [(regexp #px"^yosys-smt2-output (.*) (\\d+)$" (list _ output-name output-width)) 104 | (datum->syntax #f `(yosys-smt2-output ,(string->symbol output-name) ,(string->number output-width)))] 105 | [(regexp #px"^yosys-smt2-register (.*) (\\d+)$" (list _ register-name register-width)) 106 | (datum->syntax #f `(yosys-smt2-register ,(string->symbol register-name) ,(string->number register-width)))] 107 | [(regexp #px"^yosys-smt2-memory (.*) (\\d+) (\\d+) (\\d+) (\\d+) (.*)$" 108 | (list _ memory-name memory-bits memory-width memory-read-ports memory-write-ports memory-sync)) 109 | (datum->syntax #f `(yosys-smt2-memory ,(string->symbol memory-name) ,(string->number memory-bits) ,(string->number memory-width) ,(string->number memory-read-ports) ,(string->number memory-write-ports) ',(string->symbol memory-sync)) srcloc)] 110 | [else 111 | (make-special-comment comment)])) 112 | 113 | (define (make-yosys-declare-datatype-readtable) 114 | (make-readtable (current-readtable) 115 | #\; 'terminating-macro read-declare-datatype-comment)) 116 | 117 | (define (read-declare-datatype-comment match-ch in src init-line init-col init-pos) 118 | (define comment (read-until-eol in)) 119 | (define width (string-length comment)) 120 | (define srcloc 121 | (and 122 | init-line 123 | (vector src init-line init-col init-pos width))) 124 | (define trimmed (string-trim comment)) 125 | (match trimmed 126 | [(regexp #px"^\\\\?(.*)$" (list _ name)) 127 | (datum->syntax #f (string->symbol name) srcloc)] 128 | [else 129 | (raise-syntax-error)])) 130 | 131 | (define (port-peek=? port str) 132 | (equal? str (peek-string (string-length str) 0 port))) 133 | 134 | (define (read-toplevel-paren parent-readtable) 135 | (lambda (match-ch in src init-line init-col init-pos) 136 | (parameterize ([current-readtable 137 | (parameterize ([current-readtable parent-readtable]) 138 | (make-yosys-readtable))]) 139 | (if (port-peek=? in "declare-datatype ") 140 | (parameterize ([current-readtable (make-yosys-declare-datatype-readtable)]) 141 | (read-syntax/recursive src in #\()) 142 | (read-syntax/recursive src in #\())))) 143 | 144 | (module+ test 145 | (require rackunit) 146 | 147 | (test-case "basic bitvector" 148 | (check-equal? 149 | (yosys-read (open-input-string "#b0101")) 150 | '(bv 5 4))) 151 | 152 | (test-case "comment unrelated" 153 | (check-equal? 154 | (yosys-read (open-input-string "; unrelated")) 155 | eof)) 156 | 157 | (test-case "comment stdt" 158 | (check-equal? 159 | (yosys-read (open-input-string "; yosys-smt2-stdt")) 160 | '(yosys-smt2-stdt))) 161 | 162 | (test-case "comment module" 163 | (check-equal? 164 | (yosys-read (open-input-string "; yosys-smt2-module modname")) 165 | '(yosys-smt2-module modname))) 166 | 167 | (test-case "comment topmod" 168 | (check-equal? 169 | (yosys-read (open-input-string "; yosys-smt2-topmod modname")) 170 | '(yosys-smt2-topmod modname))) 171 | 172 | (test-case "comment clock" 173 | (check-equal? 174 | (yosys-read (open-input-string "; yosys-smt2-clock clk posedge")) 175 | '(yosys-smt2-clock clk 'posedge))) 176 | 177 | (test-case "comment input" 178 | (check-equal? 179 | (yosys-read (open-input-string "; yosys-smt2-input cpu.mem_rdata 32")) 180 | '(yosys-smt2-input cpu.mem_rdata 32))) 181 | 182 | (test-case "comment output" 183 | (check-equal? 184 | (yosys-read (open-input-string "; yosys-smt2-output cpu.mem_wdata 32")) 185 | '(yosys-smt2-output cpu.mem_wdata 32))) 186 | 187 | (test-case "comment register" 188 | (check-equal? 189 | (yosys-read (open-input-string "; yosys-smt2-register cpu.instr_ori 1")) 190 | '(yosys-smt2-register cpu.instr_ori 1))) 191 | 192 | (test-case "comment memory" 193 | (check-equal? 194 | (yosys-read (open-input-string "; yosys-smt2-memory ram.ram 6 32 1 1 sync")) 195 | '(yosys-smt2-memory ram.ram 6 32 1 1 'sync))) 196 | 197 | (test-case "datatype" 198 | (check-equal? 199 | (yosys-read (open-input-string "(declare-datatype |mod_s| ((|mod_mk| (|mod_is| Bool) (|mod#0| (_ BitVec 5)) ; \\fancy.name\n)))")) 200 | '(declare-datatype mod_s ((mod_mk (mod_is Bool) (mod#0 (_ BitVec 5)) fancy.name)))))) 201 | 202 | (define (yosys-read in) 203 | (parameterize ([current-readtable (make-yosys-toplevel-readtable)]) 204 | (read in))) 205 | 206 | (define (yosys-read-syntax src in) 207 | (parameterize ([current-readtable (make-yosys-toplevel-readtable)]) 208 | (read-syntax src in))) 209 | -------------------------------------------------------------------------------- /knox/correctness/correctness.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | yosys/meta 5 | "../driver.rkt" 6 | "../circuit.rkt" 7 | "../spec.rkt" 8 | "../result.rkt" 9 | "../driver/interpreter.rkt" 10 | "checker.rkt" 11 | "hint.rkt" 12 | (only-in racket/class new send) 13 | (prefix-in @ (combine-in rosette/safe rosutil/addressable-struct rosutil/convenience))) 14 | 15 | (provide verify-correctness) 16 | 17 | (define (verify-correctness 18 | spec 19 | circuit 20 | driver 21 | #:R R 22 | #:hints [hints (lambda (method c1 f1 f-out f2) (make-hintdb))] 23 | #:only [only-method #f] ; method name or 'init or 'idle 24 | #:override-args [override-args #f] 25 | #:override-f1 [override-f1 #f] 26 | #:override-c1 [override-c1 #f] 27 | #:without-crashes [without-crashes #f] 28 | #:without-yield [without-yield #f] 29 | #:verbose [verbose #f]) 30 | (@gc-terms!) 31 | (define crash+por (crash+power-on-reset circuit)) ; so we can re-use it 32 | (when (or (not only-method) (equal? only-method 'invariant)) 33 | (when verbose (printf "verifying invariant...\n")) 34 | (verify-invariant circuit verbose) 35 | (when verbose (printf " done!\n"))) 36 | (when (or (not only-method) (equal? only-method 'init)) 37 | (when verbose (printf "verifying init...\n")) 38 | (verify-init spec circuit crash+por R verbose) 39 | (when verbose (printf " done!\n"))) 40 | (when (or (not only-method) (equal? only-method 'idle)) 41 | (when verbose (printf "verifying idle...\n")) 42 | (verify-idle spec circuit driver R verbose) 43 | (when verbose (printf " done!\n"))) 44 | (for ([method (spec-methods spec)]) 45 | (when (or (not only-method) (equal? only-method (method-descriptor-name method))) 46 | (when verbose (printf "verifying method ~a~a...\n" 47 | (method-descriptor-name method) 48 | (if without-crashes " (without crashes)" ""))) 49 | (verify-method spec circuit crash+por driver R method override-args override-f1 override-c1 without-crashes without-yield hints verbose) 50 | (when verbose (printf " done!\n"))))) 51 | 52 | ;; yosys uses the {module}_i to denote an initializer, not an invariant, 53 | ;; but we only use the initializer to initialize ROMs, and so it's an invariant 54 | ;; 55 | ;; still, here, we double-check that it's indeed an invariant, and that the 56 | ;; user didn't accidentally have other mutable fields be initialized 57 | (define (verify-invariant circuit verbose) 58 | (define m (circuit-meta circuit)) 59 | (define c1 ((meta-new-symbolic m))) 60 | (define c2 ((meta-step m) c1)) 61 | (define inv (meta-invariant m)) 62 | (define res 63 | (@verify 64 | (@begin 65 | (@assume (inv c1)) 66 | (@assert (inv c2))))) 67 | (cond 68 | [(@unsat? res) (void)] ; verified 69 | [(@unknown? res) (error 'verify-invariant "solver timeout")] 70 | [else (error 'verify-invariant "failed to prove invariant: misuse of 'initial' in Verilog?")])) 71 | 72 | (define (verify-init spec circuit crash+por R verbose) 73 | (define f0 (spec-init spec)) 74 | (define m (circuit-meta circuit)) 75 | (define c0 76 | (@update-fields 77 | ((meta-new-symbolic m)) 78 | (let ([c-zeroed ((meta-new-zeroed m))]) 79 | (for/list ([field-name (circuit-init-zeroed-fields circuit)]) 80 | (cons field-name (@get-field c-zeroed field-name)))))) 81 | (define c-init (crash+por c0)) 82 | (define inv (meta-invariant m)) 83 | (define res 84 | (@verify 85 | (@begin 86 | (@assume (inv c0)) 87 | (@assert (R f0 c-init))))) 88 | (cond 89 | [(@unsat? res) (void)] ; verified 90 | [(@unknown? res) (error 'verify-init "solver timeout")] 91 | [verbose 92 | (define sol (@complete-solution res (@symbolics (@list f0 c-init)))) 93 | (eprintf "failed to prove init\n") 94 | (eprintf "c-init = ~v\n" (@evaluate c-init sol)) 95 | (eprintf "f0 = ~v\n" (@evaluate f0 sol)) 96 | (eprintf "(R f0 c-init) = ~v\n" (@evaluate (R f0 c-init) sol)) 97 | ;; finally, raise an error 98 | (error 'verify-init "failed to prove init")] 99 | [else (error 'verify-init "failed to prove init")])) 100 | 101 | (define (verify-idle spec circuit driver R verbose) 102 | (define f1 ((spec-new-symbolic spec))) 103 | (define m (circuit-meta circuit)) 104 | (define idle-input 105 | (@update-field 106 | (@update-fields ((meta-new-symbolic-input (circuit-meta circuit))) 107 | (driver-idle driver)) 108 | (circuit-reset-input-name circuit) 109 | (not (circuit-reset-input-signal circuit)))) 110 | (define c1 ((meta-new-symbolic m))) 111 | (define c2 ((meta-step m) ((meta-with-input m) c1 idle-input))) 112 | (define inv (meta-invariant m)) 113 | (define res 114 | (@verify 115 | (@begin 116 | (@assume (R f1 c1)) 117 | (@assume (inv c1)) 118 | (@assert (R f1 c2))))) 119 | (cond 120 | [(@unsat? res) (void)] ; verified 121 | [(@unknown? res) (error 'verify-idle "solver timeout")] 122 | [verbose 123 | (define sol (@complete-solution res (@symbolics (@list f1 idle-input c1 c2)))) 124 | (eprintf "failed to prove idle\n") 125 | (eprintf "c1 = ~v\n" (@evaluate c1 sol)) 126 | (eprintf "f1 = ~v\n" (@evaluate f1 sol)) 127 | (eprintf "(R f1 c1) = ~v\n" (@evaluate (R f1 c1) sol)) 128 | (eprintf "input = ~v\n" (@evaluate idle-input sol)) 129 | (eprintf "c2 = ~v\n" (@evaluate c2 sol)) 130 | (eprintf "(R f1 c2) = ~v\n" (@evaluate (R f1 c2) sol)) 131 | (error 'verify-idle "failed to prove idle")] 132 | [else (error 'verify-idle "failed to prove idle")])) 133 | 134 | (define (verify-method spec circuit crash+por driver R method override-args override-f1 override-c1 without-crashes without-yield hints verbose) 135 | ;; set up method and arguments 136 | (define method-name (method-descriptor-name method)) 137 | (define spec-fn (method-descriptor-method method)) 138 | (define args 139 | (or override-args 140 | (for/list ([arg (method-descriptor-args method)]) 141 | (define type (argument-type arg)) 142 | (if (list? type) 143 | (for/list ([el type] 144 | [i (in-naturals)]) 145 | (@fresh-symbolic (format "~a[~a]" (symbol->string (argument-name arg)) i) el)) 146 | (@fresh-symbolic (argument-name arg) (argument-type arg)))))) 147 | ;; spec 148 | (define f1 (or override-f1 ((spec-new-symbolic spec)))) 149 | (define f-result (@check-no-asserts ((@apply spec-fn args) f1) #:discharge-asserts #t)) 150 | (define f-out (result-value f-result)) 151 | (define f2 (result-state f-result)) 152 | ;; circuit 153 | (define m (circuit-meta circuit)) 154 | (define c1 (@update-fields (or override-c1 ((meta-new-symbolic m))) 155 | (cons 156 | ;; reset is de-asserted 157 | (cons (circuit-reset-input-name circuit) 158 | (not (circuit-reset-input-signal circuit))) 159 | ;; other inputs are idle 160 | (driver-idle driver)))) 161 | ;; make sure reset line is de-asserted 162 | (define driver-expr (cons method-name (map (lambda (arg) (list 'quote arg)) args))) 163 | (define initial-interpreter-state 164 | (make-interpreter driver-expr (driver-bindings driver) c1 m)) 165 | (define local-hints (hints (cons method-name args) c1 f1 f-out f2)) 166 | (define inv (meta-invariant m)) 167 | (define precondition (@check-no-asserts (@&& (R f1 c1) (inv c1)))) 168 | (define exc (new checker% 169 | [initial-state initial-interpreter-state] 170 | [hint-db local-hints] 171 | [precondition precondition] 172 | [R (if without-crashes #f R)] ; a bit of a hack, to tell exc whether we want to check for crash safety 173 | [without-yield without-yield] 174 | [f1 f1] 175 | [f2 f2] 176 | [crash+power-on-reset crash+por])) 177 | (when verbose (send exc debug!)) 178 | ;; run 179 | (define finished (send exc run!)) 180 | (for ([f finished]) 181 | (define pc (checker-state-pc f)) 182 | (define c-result (checker-state-interpreter f)) 183 | (define c-out (finished-value c-result)) 184 | (define c2 (finished-circuit c-result)) 185 | (define res 186 | (@verify 187 | (@begin 188 | (@assume precondition) ; R and hardware invariant 189 | (@assume pc) 190 | (@assert (@equal? f-out c-out)) 191 | (@assert (R f2 c2))))) 192 | (cond 193 | [(@unsat? res) (void)] ; verified 194 | [(@unknown? res) (error 'verify-method "~a: solver timeout" method-name)] 195 | [verbose 196 | (define sol (@complete-solution res (@symbolics (@list args f1 f-out f2 c1 c-out c2)))) 197 | (eprintf "failed to verify ~a\n" method-name) 198 | (eprintf "c1 = ~v\n" (@evaluate c1 sol)) 199 | (eprintf "f1 = ~v\n" (@evaluate f1 sol)) 200 | (eprintf "args = ~v\n" (@evaluate args sol)) 201 | (eprintf "f2 = ~v\n" (@evaluate f2 sol)) 202 | (eprintf "f-out = ~v\n" (@evaluate f-out sol)) 203 | (eprintf "c-out = ~v\n" (@evaluate c-out sol)) 204 | (eprintf "(R f2 c2) = ~v\n" (@evaluate (R f2 c2) sol)) 205 | (eprintf "c2 = ~v\n" (@evaluate c2 sol)) 206 | ;; finally, raise an error 207 | (error 'verify-method "failed to verify ~a" method-name)] 208 | [else (error 'verify-method "failed to verify ~a" method-name)]))) 209 | -------------------------------------------------------------------------------- /test/rosutil/lens.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require rosutil rackunit 4 | (only-in racket/base symbol->string) 5 | racket/match) 6 | 7 | (test-case "basic" 8 | (define tree '((a . b) c . d)) 9 | (define cdar-lens (lens-compose cdr-lens car-lens)) 10 | (check-equal? (lens-view cdar-lens tree) 'b) 11 | (check-equal? (lens-set cdar-lens tree 'x) '((a . x) c . d)) 12 | (check-equal? (lens-transform cdar-lens tree symbol->string) '((a . "b") c . d))) 13 | 14 | (test-case "symbolic" 15 | (define-symbolic* b boolean?) 16 | (define-symbolic* w x y z integer?) 17 | (define t (if b (cons w x) (cons y z))) 18 | (check-pred unsat? (verify (assert (equal? (lens-view car-lens t) (if b w y))))) 19 | (check-pred unsat? (verify (assert (equal? (lens-transform cdr-lens t add1) (if b (cons w (add1 x)) (cons y (add1 z))))))) 20 | (check-pred unsat? (verify (assert (equal? (lens-set cdr-lens t 3) (cons (if b w y) 3)))))) 21 | 22 | (test-case "union" 23 | (define-symbolic* b boolean?) 24 | (define obj (if b '((a . b) c . d) '((w . x) y . z))) 25 | (define cdar-lens (lens-compose cdr-lens car-lens)) 26 | (check-pred unsat? (verify (assert (equal? (lens-view cdar-lens obj) (if b 'b 'x)))))) 27 | 28 | (test-case "thrush" 29 | (define obj '((1 2) (3) (4 (5 (6 7 8))))) 30 | (define l (lens-thrush (list-ref-lens 2) 31 | cdr-lens 32 | car-lens 33 | cdr-lens 34 | car-lens 35 | (list-ref-lens 1))) 36 | (check-equal? (lens-view l obj) 7) 37 | (check-equal? (lens-transform l obj (lambda (n) (* n 2))) '((1 2) (3) (4 (5 (6 14 8)))))) 38 | 39 | (test-case "join" 40 | (define obj '((1 2) (3) (4 (5 (6 7 8))))) 41 | (define l (lens-join (list-ref-lens 0) 42 | (lens-thrush 43 | (list-ref-lens 2) 44 | car-lens))) 45 | (check-equal? (lens-view l obj) (join '((1 2) 4))) 46 | (check-equal? (lens-set l obj (join '(a b))) '(a (3) (b (5 (6 7 8))))) 47 | (check-equal? (lens-transform l obj (lambda (j) 48 | (let ([prev (join-contents j)]) 49 | (join* (second (first prev)) (+ (first (first prev)) (second prev)))))) 50 | '(2 (3) (5 (5 (6 7 8)))))) 51 | 52 | (test-case "list" 53 | (define obj '((1 2) 3 (4 5) (6 (7)))) 54 | (define l (lens-thrush (list-ref-lens 3) (list-ref-lens 1) (list-ref-lens 0))) 55 | (check-equal? (lens-view l obj) 7) 56 | (check-equal? (lens-set l obj 8) '((1 2) 3 (4 5) (6 (8)))) 57 | (check-equal? (lens-transform l obj sub1) '((1 2) 3 (4 5) (6 (6))))) 58 | 59 | (test-case "vector" 60 | (define l (lens-compose car-lens (vector-ref-lens 3))) 61 | (define v '#(0 1 2 (3 . 4))) 62 | (check-equal? (lens-view l v) 3) 63 | (check-equal? (lens-set l v 8) '#(0 1 2 (8 . 4)))) 64 | 65 | (test-case "struct" 66 | (addressable-struct a (b c)) 67 | (addressable-struct d (e f)) 68 | (define obj (a (list 0 (d 1 2)) 3)) 69 | (define l (lens-thrush (struct-ref-lens 'b) (list-ref-lens 1) (struct-ref-lens 'e))) 70 | (check-equal? (lens-view l obj) 1) 71 | (check-equal? (lens-set l obj 4) (a (list 0 (d 4 2)) 3)) 72 | (check-equal? (lens-transform l obj sub1) (a (list 0 (d 0 2)) 3))) 73 | 74 | (test-case "struct join" 75 | (addressable-struct a (b c d)) 76 | (define obj (a 1 2 3)) 77 | (define l (lens-join (struct-ref-lens 'b) (struct-ref-lens 'c))) 78 | (check-equal? (lens-view l obj) (join '(1 2))) 79 | (check-equal? (lens-set l obj (join '(-1 -2))) (a -1 -2 3)) 80 | (check-equal? (lens-transform l obj (lambda (j) (let ([l (join-contents j)]) (join* (second l) (first l))))) (a 2 1 3))) 81 | 82 | (test-case "struct filter" 83 | (addressable-struct a (uart_div uart_baud cycle_count)) 84 | (define obj (a 0 1 2)) 85 | (define l (struct-filter-lens #rx"^uart.*$")) 86 | (check-equal? (lens-view l obj) (join '(0 1))) 87 | (check-equal? (lens-set l obj (join '(10 11))) (a 10 11 2)) 88 | (check-equal? (lens-transform l obj (lambda (j) (let ([l (join-contents j)]) (join* (second l) (first l))))) (a 1 0 2))) 89 | 90 | (test-case "vector join" 91 | (define obj #(#(0 1 2) #(3 #(4 5)))) 92 | (define l (lens (list (lens 0 (list 0 1)) (lens 1 0)))) 93 | (check-equal? (lens-view l obj) (join* (join* 0 1) 3)) 94 | (check-equal? (lens-set l obj (join* (join* 10 11) 13)) #(#(10 11 2) #(13 #(4 5)))) 95 | (check-equal? (lens-transform l obj (lambda (j) (let ([lst (join-contents j)]) (join* (first lst) (add1 (second lst)))))) 96 | #(#(0 1 2) #(4 #(4 5))))) 97 | 98 | (test-case "struct join" 99 | (addressable-struct foo (a b c d e)) 100 | (define obj (foo 1 2 3 4 #(5 6))) 101 | (define l (lens (list 'a 'b 'd (lens 'e 1)))) 102 | (check-equal? (lens-view l obj) (join* 1 2 4 6)) 103 | (check-equal? (lens-set l obj (join* 1 3 3 7)) (foo 1 3 3 3 #(5 7))) 104 | (check-equal? (lens-transform l obj (lambda (j) (let* ([l (join-contents j)] [s (apply + l)]) (join* s s s s)))) 105 | (foo 13 13 3 13 #(5 13)))) 106 | 107 | (test-case "lens" 108 | (define obj '#(#(1 2) #(3) #(4 #(5 #(6 7 8))))) 109 | (define l (lens 2 1 (list 0 (lens 1 1)))) 110 | (check-equal? (lens-view l obj) (join* 5 7)) 111 | (check-equal? (lens-set l obj (join* 10 20)) '#(#(1 2) #(3) #(4 #(10 #(6 20 8)))))) 112 | 113 | (test-case "lens struct" 114 | (addressable-struct person (name location)) 115 | (addressable-struct location (street city)) 116 | (define obj (vector (person "Bob" (location "123 First Street" "Cambridge")))) 117 | (define l (lens 0 'location 'city)) 118 | (check-equal? (lens-view l obj) "Cambridge") 119 | (check-equal? (lens-set l obj "Boston") (vector (person "Bob" (location "123 First Street" "Boston")))) 120 | (define l2 (lens 0 (list 'name (lens 'location 'street)))) 121 | (check-equal? (lens-view l2 obj) (join* "Bob" "123 First Street")) 122 | (define l3 (lens 0 'location (list 'street 'city))) 123 | (check-equal? (lens-set l3 obj (join* "1 Main Street" "Shrewsbury")) (vector (person "Bob" (location "1 Main Street" "Shrewsbury"))))) 124 | 125 | (test-case "lens filter" 126 | (addressable-struct mod (uart_baud uart_div clk)) 127 | (define obj (mod 1 2 3)) 128 | (define l (lens #rx"uart_.*")) 129 | (check-equal? (lens-view l obj) (join* 1 2))) 130 | 131 | (test-case "join efficiency" 132 | (define counter 0) 133 | (define (inc!) (set! counter (add1 counter))) 134 | (define (reset!) (set! counter 0)) 135 | (define (get) counter) 136 | (struct s (a b c) #:transparent 137 | #:methods gen:addressable 138 | [(define (fields _) '(a b c)) 139 | (define (get-field x f) 140 | ((case f [(a) s-a] [(b) s-b] [(c) s-c]) x)) 141 | (define (map-fields x f) 142 | (inc!) 143 | (s (f 'a (s-a x)) 144 | (f 'b (s-b x)) 145 | (f 'c (s-c x))))]) 146 | (define (inc-all j) (join (map add1 (join-contents j)))) 147 | ;; two field-refs combined into one 148 | (define o1 (s 1 2 3)) 149 | (define l1 (lens (list 'a 'b))) 150 | (check-equal? (lens-transform l1 o1 inc-all) (s 2 3 3)) 151 | (check-equal? (get) 1) 152 | (reset!) 153 | ;; multiple field-refs, including nesting, combined into one 154 | (define o2 (s 1 2 '#(3 4))) 155 | (define l2 (lens (list 'a (lens 'c 0)))) 156 | (check-equal? (lens-transform l2 o2 inc-all) (s 2 2 '#(4 4))) 157 | (check-equal? (get) 1) 158 | (reset!) 159 | ;; combining filter and individual refs 160 | (define o3 o2) 161 | (define l3 (lens (list #rx"^[ab]$" (lens 'c 1)))) 162 | (check-equal? (lens-transform l3 o3 (match-lambda [(join (list (join (list a b)) c)) (join* (join* c b) a)])) 163 | (s 4 2 '#(3 1))) 164 | (check-equal? (get) 1) 165 | (reset!) 166 | ;; more nesting 167 | (define o4 (s 1 2 (s 3 4 5))) 168 | (define l4 (lens (list #rx"a" (lens 'c (list 'a 'b #rx"c"))))) 169 | (check-equal? (lens-transform l4 o4 identity) o4) 170 | (check-equal? (get) 2) 171 | (reset!)) 172 | 173 | (test-case "overlapping field in join" 174 | ;; regression test 175 | (addressable-struct pair (circuit simulator)) 176 | (addressable-struct simulator (auxiliary oracle)) 177 | (define o (pair 0 (simulator 1 2))) 178 | (define l (lens (list (lens 'simulator 'auxiliary) 179 | (lens 'simulator 'oracle)))) 180 | ;; this lens is purposefully written in a weird way; 181 | ;; it should have been written as the following instead: 182 | (define l-ok (lens 'simulator (list 'auxiliary 'oracle))) 183 | (check-exn #rx"simulator" (lambda () (lens-set l o (join '(10 20))))) 184 | (check-equal? (lens-set l-ok o (join '(10 20))) (pair 0 (simulator 10 20)))) 185 | 186 | (test-case "virtual lens" 187 | (addressable-struct executor (interpreter pc equalities)) 188 | (addressable-struct interpreter (globals control environment continuation)) 189 | (addressable-struct globals (circuit meta)) 190 | (define x (executor (interpreter (globals "ckt" "meta") "control" "environment" "continuation") "pc" "equalities")) 191 | (define top (virtual-lens (list 192 | (cons 'circuit (lens 'interpreter 'globals 'circuit)) 193 | (cons 'interpreter (lens 'interpreter (virtual-lens (list 194 | (cons 'control (lens 'control)) 195 | (cons 'environment (lens 'environment)) 196 | (cons 'continuation (lens 'continuation))))))))) 197 | (check-equal? (lens-view (lens top 'interpreter 'control) x) "control")) 198 | -------------------------------------------------------------------------------- /rosutil/serialization.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base syntax/parse racket/syntax)) 4 | 5 | (require 6 | (prefix-in @ (combine-in 7 | rosette/safe 8 | (only-in rosette/base/core/term term-id) 9 | (only-in rosette/base/core/bitvector bv-value bv-type [bv? bv-constant?]) 10 | (only-in rosette/base/core/polymorphic =? ite ite* [⊢ guard]) 11 | (only-in rosette/base/core/type typed? get-type type-name type-construct type-deconstruct))) 12 | (only-in "convenience.rkt" guid fresh-symbolic symbolic-from-id) 13 | racket/match racket/set) 14 | 15 | (provide make-struct-register register-struct! serialize deserialize) 16 | 17 | (define (make-struct-register) (make-hasheq)) 18 | 19 | (define (register-struct! struct-register struct-type [name-override #f]) 20 | (define name (or name-override (@type-name struct-type))) 21 | (hash-set! struct-register struct-type name)) 22 | 23 | (define op->description 24 | (hash 25 | ;; polymorphic 26 | @=? '=? 27 | @ite 'ite 28 | @ite* 'ite* 29 | @guard 'guard 30 | ;; boolean 31 | @! '! 32 | @&& '&& 33 | @|| '|| 34 | @=> '=> 35 | @<=> '<=> 36 | @exists 'exists 37 | @forall 'forall 38 | @distinct? 'distinct? 39 | ;; real 40 | @= '= 41 | @<= '<= 42 | @>= '>= 43 | @< '< 44 | @> '> 45 | @+ '+ 46 | @* '* 47 | @- '- 48 | @abs 'abs 49 | @int? 'int? 50 | @quotient 'quotient 51 | @remainder 'remainder 52 | @modulo 'modulo 53 | @/ '/ 54 | @integer->real 'integer->real 55 | @real->integer 'real->integer 56 | ;; bitvector 57 | @bveq 'bveq 58 | @bvslt 'bvslt 59 | @bvsgt 'bvsgt 60 | @bvsle 'bvsle 61 | @bvsge 'bvsge 62 | @bvult 'bvult 63 | @bvugt 'bvugt 64 | @bvule 'bvule 65 | @bvuge 'bvuge 66 | @bvnot 'bvnot 67 | @bvand 'bvand 68 | @bvor 'bvor 69 | @bvxor 'bvxor 70 | @bvshl 'bvshl 71 | @bvlshr 'bvlshr 72 | @bvashr 'bvashr 73 | @bvneg 'bvneg 74 | @bvadd 'bvadd 75 | @bvsub 'bvsub 76 | @bvmul 'bvmul 77 | @bvsdiv 'bvsdiv 78 | @bvudiv 'bvudiv 79 | @bvsrem 'bvsrem 80 | @bvurem 'bvurem 81 | @bvsmod 'bvsmod 82 | @concat 'concat 83 | @extract 'extract 84 | @sign-extend 'sign-extend 85 | @zero-extend 'zero-extend 86 | @integer->bitvector 'integer->bitvector 87 | @bitvector->integer 'bitvector->integer 88 | @bitvector->natural 'bitvector->natural)) 89 | 90 | (define (any->datum s) 91 | (if (identifier? s) (syntax-e s) s)) 92 | 93 | ;; setting #:hasheq results in faster operation but produces a larger 94 | ;; serialized object (and will make the deserialized version consume more 95 | ;; memory) 96 | ;; 97 | ;; only works on cycle-free objects 98 | (define (serialize val [struct-table (make-struct-register)] #:hasheq [use-hasheq #f]) 99 | (define obj-table (make-hasheqv)) ; num -> repr 100 | ;; the following could also be a hasheq, which would result in faster lookups, but no deduplication 101 | (define obj-numbering (if use-hasheq (make-hasheq) (make-hash))) ; object -> num 102 | (define next-obj-num 0) 103 | (define (alloc-obj-num! repr) 104 | (define n next-obj-num) 105 | (set! next-obj-num (add1 n)) 106 | (hash-set! obj-table n repr) 107 | n) 108 | 109 | ;; we need to make sure that all the terms are allocated object 110 | ;; numbers in an order that corresponds with their term-id 111 | ;; 112 | ;; this is a bit tricky to do; a lazy way to do this is to traverse the entire 113 | ;; object twice, first identifying all the constants and terms (because 114 | ;; terms can only refer to constants and terms), then allocating all of them in term-id order, 115 | ;; and then doing a final pass for allocating the rest of the object 116 | ;; 117 | ;; this might not be the most efficient solution, but it works; if this becomes a bottleneck, 118 | ;; can work on performance-optimizing it 119 | (define constants (mutable-set)) ; all constants seen so far 120 | (define terms (make-hasheqv)) ; id -> term 121 | ;; avoid looking at the same objects more than once, even here 122 | (define seen (if use-hasheq (mutable-seteq) (mutable-set))) 123 | (let rec ([val val]) 124 | (unless (set-member? seen val) 125 | (cond 126 | [(set-member? constants val) (void)] 127 | [(and (@term? val) (hash-has-key? terms (@term-id val))) (void)] 128 | [else 129 | (match val 130 | ;; order matters to some degree (e.g. typed? recognizes bitvector literals), but we have 131 | ;; some flexibility here, so we can order to increase speed 132 | [(or (? boolean?) (? integer?) (? real?) (? string?) (? symbol?) (? @bv-constant?)) 133 | (set-add! constants val)] 134 | [(@union contents) (rec contents)] 135 | [(@constant id type) 136 | (hash-set! terms (@term-id val) val)] 137 | [(@expression op vs ...) 138 | (hash-set! terms (@term-id val) val) 139 | (for ([v vs]) (rec v))] 140 | [(vector vs ...) (for ([v vs]) (rec v))] 141 | [(? list?) (for ([v val]) (rec v))] 142 | [(cons x y) (rec x) (rec y)] 143 | [(box v) (rec v)] 144 | [(@bitvector n) (void)] ; bitvector _type_ 145 | [(and (? @typed?) (app @get-type type)) 146 | (for ([v (@type-deconstruct type val)]) (rec v))] 147 | [_ (error 'serialize "unrecognized type")])]) 148 | (set-add! seen val))) 149 | 150 | (define (process-object val) 151 | (hash-ref! 152 | obj-numbering 153 | val 154 | (lambda () 155 | ;; newly seen object 156 | (alloc-obj-num! 157 | (match val 158 | ;; order matters to some degree (e.g. typed? recognizes bitvector literals), but we have 159 | ;; some flexibility here, so we can order to increase speed 160 | [(or (? boolean?) (? integer?) (? real?) (? string?) (? symbol?)) `(k ,val)] 161 | [(? @bv-constant?) `(k ,(@bv-value val) ,(@bitvector-size (@bv-type val)))] 162 | [(@union contents) `(u ,(process-object contents))] 163 | [(@constant id type) 164 | (define-values (name idnum) 165 | (match id 166 | [(list name (guid idnum)) (values (any->datum name) idnum)] 167 | [(list name _) (values (any->datum name) #f)] 168 | [name (values (any->datum name) #f)])) 169 | (match type 170 | ;; ordering these by likelihood for our examples 171 | [(@bitvector size) `(s ,name ,idnum ,size)] 172 | [(== @boolean?) `(s ,name ,idnum b)] 173 | [(== @integer?) `(s ,name ,idnum i)] 174 | [(== @real?) `(s ,name ,idnum r)] 175 | [_ (error 'serialize "unreachable: constant must be boolean, integer, real, or bitvector")])] 176 | [(@expression op vs ...) `(e ,(hash-ref op->description op) ,@(for/list ([v vs]) (process-object v)))] 177 | [(vector vs ...) `(v ,@(for/list ([v vs]) (process-object v)))] 178 | [(? list?) `(l ,@(for/list ([v val]) (process-object v)))] 179 | [(cons x y) `(c ,(process-object x) ,(process-object y))] 180 | [(box v) `(b ,(process-object v))] 181 | [(@bitvector n) `(B ,n)] ; bitvector _type_ 182 | [(and (? @typed?) (app @get-type type)) 183 | (cond 184 | [(hash-has-key? struct-table type) 185 | `(r ,(hash-ref struct-table type) ,@(for/list ([v (@type-deconstruct type val)]) (process-object v)))] 186 | [else (error 'serialize "unsupported type ~a" type)])] 187 | [_ (error 'serialize "unrecognized type")]))))) 188 | 189 | ;; first, process constants 190 | (for ([k (in-set constants)]) 191 | (process-object k)) 192 | ;; then, process terms, in term order 193 | (for ([id (sort (hash-keys terms) <)]) 194 | (process-object (hash-ref terms id))) 195 | ;; now, traverse the entire object 196 | (process-object val) 197 | 198 | ;; the object we want is always the last allocated object, so we don't need to explicitly return its number 199 | (for/list ([i (in-range next-obj-num)]) (hash-ref obj-table i))) 200 | 201 | (define (invert-hash h) 202 | (for/hash ([(k v) (in-hash h)]) 203 | (values v k))) 204 | 205 | (define description->op (invert-hash op->description)) 206 | 207 | (define (deserialize repr [struct-table (make-struct-register)]) 208 | (define inverse-struct-table (invert-hash struct-table)) 209 | ;; we can proceed left to right in the representation, because 210 | ;; objects never reference "later" objects 211 | (define objects (make-hasheqv)) ; num -> object 212 | (define (ids->objects ids) (for/list ([id ids]) (hash-ref objects id))) 213 | (for ([rep (in-list repr)] 214 | [i (in-naturals)]) 215 | (define obj 216 | (match rep 217 | [`(k ,value ,size) (@bv value size)] 218 | [`(k ,lit) lit] 219 | [`(u ,id) (apply @union (hash-ref objects id))] 220 | [`(s ,name ,idnum ,t) 221 | (define type 222 | (match t 223 | ['b @boolean?] 224 | ['i @integer?] 225 | ['r @real?] 226 | [size (@bitvector size)])) 227 | (if idnum 228 | ;; we want to make sure the type matches if there's anything already in the term cache 229 | ;; (this should never fail unless we're doing something wrong) 230 | ;; 231 | ;; there's no direct way to access the term cache, and we don't want to do (terms) to get a big list 232 | ;; instead, we just create the new constant, and make sure its type is correct 233 | (let ([var (symbolic-from-id name idnum type)]) 234 | (when (not (equal? (@type-of var) type)) 235 | ;; instead of erroring, we could create a fresh variable with the right type, but this is probably 236 | ;; a bug, and it's better to catch early 237 | (error 'deserialize "guid type mismatch")) 238 | var) 239 | (fresh-symbolic name type))] 240 | [`(e ,op ,ids ...) (apply @expression (hash-ref description->op op) (ids->objects ids))] 241 | [`(v ,ids ...) (vector->immutable-vector (list->vector (ids->objects ids)))] 242 | [`(l ,ids ...) (ids->objects ids)] 243 | [`(c ,x ,y) (cons (hash-ref objects x) (hash-ref objects y))] 244 | [`(b ,id) (hash-ref objects id)] 245 | [`(B ,n) (@bitvector n)] 246 | [`(r ,name ,ids ...) (@type-construct (hash-ref inverse-struct-table name (lambda () (error 'deserialize "unknown type ~a" name))) (ids->objects ids))])) 247 | (hash-set! objects i obj)) 248 | (hash-ref objects (sub1 (length repr)))) 249 | -------------------------------------------------------------------------------- /rosutil/lens.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require "addressable-struct.rkt" 4 | racket/contract 5 | (only-in racket/base exact-nonnegative-integer? symbol? string? regexp? procedure-arity-includes? error) 6 | (only-in racket/list check-duplicates) 7 | (for-syntax syntax/parse)) 8 | 9 | (provide 10 | (contract-out 11 | [lens? (-> any/c boolean?)] 12 | [lens-view (-> lens? any/c any)] 13 | [lens-set (-> lens? any/c any/c any)] 14 | [lens-transform (-> lens? any/c (-> any/c any/c) any)] 15 | [lens-compose (->* () #:rest (listof lens?) lens?)] 16 | [lens-thrush (->* () #:rest (listof lens?) lens?)] 17 | [lens-join (->* () #:rest (listof lens?) lens?)] 18 | [car-lens lens?] 19 | [cdr-lens lens?] 20 | [unit-lens lens?] 21 | [identity-lens lens?] 22 | [list-ref-lens (-> exact-nonnegative-integer? lens?)] 23 | [vector-ref-lens (-> exact-nonnegative-integer? lens?)] 24 | [virtual-lens (-> list? lens?)] 25 | [vector-all-elements-lens lens?] 26 | [struct-ref-lens (-> symbol? lens?)] 27 | [struct-filter-lens (-> field-filter/c lens?)] 28 | [as-lens (-> lens-like/c lens?)] 29 | [rename lens* lens (->* () #:rest (listof lens-like/c) lens?)]) 30 | (struct-out join) 31 | (contract-out 32 | [join* (->* () #:rest (listof any/c) join?)])) 33 | 34 | (define-generics lens 35 | [get lens target] 36 | [set lens target view] 37 | [update lens target transformer] 38 | #:fallbacks 39 | [(define/generic gen-get get) 40 | (define/generic gen-set set) 41 | (define (update lens target transformer) 42 | (gen-set lens target (transformer (gen-get lens target))))]) 43 | 44 | (define lens-view get) 45 | 46 | (define lens-set set) 47 | 48 | (define lens-transform update) 49 | 50 | (struct identity-lens-t () 51 | #:methods gen:lens 52 | [(define (get lens target) target) 53 | (define (set lens target view) view)]) 54 | 55 | (define identity-lens (identity-lens-t)) 56 | 57 | (struct unit-lens-t () 58 | #:methods gen:lens 59 | [(define (get lens target) null) 60 | (define (set lens target view) target)]) 61 | 62 | (define unit-lens (unit-lens-t)) 63 | 64 | ;; lens1 should not itself be a composition lens 65 | (struct composition-lens (lens2 lens1) 66 | #:methods gen:lens 67 | [(define (get lens target) 68 | (lens-view (composition-lens-lens2 lens) (lens-view (composition-lens-lens1 lens) target))) 69 | (define (set lens target view) 70 | (lens-transform (composition-lens-lens1 lens) target (lambda (target*) (lens-set (composition-lens-lens2 lens) target* view)))) 71 | (define (update lens target transformer) 72 | (lens-transform (composition-lens-lens1 lens) target (lambda (target*) (lens-transform (composition-lens-lens2 lens) target* transformer))))]) 73 | 74 | ;; ensures that the lens1 of the resulting composition is not itself a composition by applying commutativity 75 | (define (lens-compose2 lens2 lens1) 76 | (cond 77 | [(composition-lens? lens1) 78 | ;; push composition 79 | (let ([lens1-1 (composition-lens-lens1 lens1)] 80 | [lens1-2 (composition-lens-lens2 lens1)]) 81 | (lens-compose2 (lens-compose2 lens2 lens1-2) lens1-1))] 82 | [else (composition-lens lens2 lens1)])) 83 | 84 | (define (lens-compose . lenses) 85 | (cond 86 | [(null? lenses) identity-lens] 87 | [(null? (cdr lenses)) (car lenses)] 88 | [else (foldl (lambda (l acc) (lens-compose2 acc l)) (car lenses) (cdr lenses))])) 89 | 90 | (define (lens-thrush . lenses) 91 | (apply lens-compose (reverse lenses))) 92 | 93 | (struct join (contents) #:transparent) 94 | (define (join* . vs) (join vs)) 95 | 96 | ;; generic join lens 97 | (struct join-lens (lenses) 98 | #:methods gen:lens 99 | [(define (get lens target) 100 | (join (map (lambda (lens) (lens-view lens target)) (join-lens-lenses lens)))) 101 | (define (set lens target view) 102 | (let loop ([obj target] 103 | [lenses (join-lens-lenses lens)] 104 | [views (join-contents view)]) 105 | (if (null? lenses) 106 | obj 107 | (loop 108 | (lens-set (car lenses) obj (car views)) 109 | (cdr lenses) 110 | (cdr views)))))]) 111 | 112 | ;; List lenses 113 | 114 | (struct car-lens-t () 115 | #:methods gen:lens 116 | [(define (get lens target) (car target)) 117 | (define (set lens target view) (cons view (cdr target)))]) 118 | 119 | (define car-lens (car-lens-t)) 120 | 121 | (struct cdr-lens-t () 122 | #:methods gen:lens 123 | [(define (get lens target) (cdr target)) 124 | (define (set lens target view) (cons (car target) view))]) 125 | 126 | (define cdr-lens (cdr-lens-t)) 127 | 128 | (define (list-update lst pos upd) 129 | (cond 130 | [(zero? pos) (cons (upd (car lst)) (cdr lst))] 131 | [else (cons (car lst) (list-update (cdr lst) (sub1 pos) upd))])) 132 | 133 | (struct list-ref-lens (pos) 134 | #:methods gen:lens 135 | [(define (get lens target) (list-ref target (list-ref-lens-pos lens))) 136 | (define (set lens target view) (list-set target (list-ref-lens-pos lens) view)) 137 | (define (update lens target transformer) (list-update target (list-ref-lens-pos lens) transformer))]) 138 | 139 | ;; Vector lenses 140 | 141 | (struct vector-ref-lens (pos) 142 | #:methods gen:lens 143 | [(define (get lens target) (vector-ref target (vector-ref-lens-pos lens))) 144 | (define (set lens target view) 145 | (define copy (list->vector (vector->list target))) 146 | (vector-set! copy (vector-ref-lens-pos lens) view) 147 | (vector->immutable-vector copy))]) 148 | 149 | (struct vector-all-elements-lens-t () 150 | #:methods gen:lens 151 | [(define (get lens target) 152 | (join (vector->list target))) 153 | (define (set lens target view) 154 | (vector->immutable-vector (list->vector (join-contents view))))]) 155 | 156 | (define vector-all-elements-lens (vector-all-elements-lens-t)) 157 | 158 | ;; Struct lenses 159 | 160 | (struct struct-ref-lens (field-name) 161 | #:methods gen:lens 162 | [(define (get lens target) (get-field target (struct-ref-lens-field-name lens))) 163 | (define (set lens target view) 164 | (update-field target (struct-ref-lens-field-name lens) view))]) 165 | 166 | (struct struct-filter-lens (field-filter) 167 | #:methods gen:lens 168 | [(define (get lens target) 169 | (join 170 | (map (lambda (name) (get-field target name)) 171 | (matching-fields (struct-filter-lens-field-filter lens) target)))) 172 | (define (set lens target view) 173 | (update-fields 174 | target 175 | (map cons (matching-fields (struct-filter-lens-field-filter lens) target) (join-contents view))))]) 176 | 177 | (define (matching-fields field-filter target) 178 | (filter (lambda (name) (field-matches? field-filter name)) (fields target))) 179 | 180 | ;; More efficient joining 181 | 182 | ;; lenses are all either struct-ref-lens/struct-filter-lens or a composition (with the lens1 being a struct-ref-lens/struct-filter-lens) 183 | (struct struct-ref/filter-join-lens (lenses) 184 | #:methods gen:lens 185 | [(define (get lens target) 186 | ;; we don't need to do anything special here, we just run all the getters 187 | (join (map (lambda (lens) (lens-view lens target)) (struct-ref/filter-join-lens-lenses lens)))) 188 | (define (set lens target view) 189 | ;; we want to do this with a single call to update-fields, so we only make a single copy of the underlying struct 190 | (define updated-fields 191 | (apply 192 | append 193 | (map 194 | (lambda (lens view) 195 | ;; this may be a struct-ref-lens, or a composition (where the lens1 is a struct-ref-lens) 196 | ;; 197 | ;; we want to figure out the field name and the updated value 198 | (cond 199 | ;; easy case: reference to a single field (and no further decomposition) 200 | [(struct-ref-lens? lens) (list (cons (struct-ref-lens-field-name lens) view))] 201 | ;; filter lens: references to multiple fields 202 | [(struct-filter-lens? lens) 203 | (define matching-fields 204 | (filter (lambda (name) (field-matches? (struct-filter-lens-field-filter lens) name)) (fields target))) 205 | (map cons matching-fields (join-contents view))] 206 | [else 207 | ;; composition; lens1 _must_ be a struct-ref-lens, it is illegal to compose struct-filter-lens with anything else 208 | ;; (no lenses operate on joins) 209 | (define lens1 (composition-lens-lens1 lens)) 210 | (define lens2 (composition-lens-lens2 lens)) 211 | (list (cons (struct-ref-lens-field-name lens1) (lens-set lens2 (lens-view lens1 target) view)))])) 212 | (struct-ref/filter-join-lens-lenses lens) 213 | (join-contents view)))) 214 | ;; error checking: if there are duplicate keys in updated-fields, 215 | ;; the lenses overlap in a bad way 216 | (define dupe (check-duplicates (map car updated-fields))) 217 | (when dupe 218 | (error 'struct-ref/filter-join-lens:set "duplicated field '~a'~n" dupe)) 219 | (update-fields 220 | target 221 | updated-fields))]) 222 | 223 | (struct vector-ref-join-lens (lenses) 224 | #:methods gen:lens 225 | [(define (get lens target) 226 | ;; don't need to do anything special here 227 | (join (map (lambda (lens) (lens-view lens target)) (vector-ref-join-lens-lenses lens)))) 228 | (define (set lens target view) 229 | (define copy (list->vector (vector->list target))) 230 | (for-each 231 | (lambda (lens view) 232 | (cond 233 | ;; easy case 234 | [(vector-ref-lens? lens) (vector-set! copy (vector-ref-lens-pos lens) view)] 235 | ;; composition case 236 | [else 237 | (define lens1 (composition-lens-lens1 lens)) 238 | (define lens2 (composition-lens-lens2 lens)) 239 | (vector-set! copy (vector-ref-lens-pos lens1) (lens-set lens2 (lens-view lens1 target) view))])) 240 | (vector-ref-join-lens-lenses lens) 241 | (join-contents view)) 242 | (vector->immutable-vector copy))]) 243 | 244 | (struct virtual-lens (names-lenses) 245 | #:methods gen:lens 246 | [(define (get lens target) 247 | (assoc-addressable 248 | (map (lambda (pair) (cons (car pair) (lens-view (cdr pair) target))) (virtual-lens-names-lenses lens)))) 249 | (define (set lens target view) 250 | (foldl (lambda (pair acc) (lens-set (cdr pair) acc (get-field view (car pair)))) target (virtual-lens-names-lenses lens)))]) 251 | 252 | ;; works differently based on the types of lenses being joined 253 | ;; together; a generic implementation as a fallback, but more optimized 254 | ;; implementations for special cases 255 | (define (lens-join . lenses) 256 | (if (null? lenses) (join-lens '()) 257 | (let* ([lens0 (car lenses)] 258 | [lens0* (if (composition-lens? lens0) (composition-lens-lens1 lens0) lens0)]) 259 | (cond 260 | ;; special cases for performance 261 | [(or (struct-ref-lens? lens0*) (struct-filter-lens? lens0*)) (struct-ref/filter-join-lens lenses)] 262 | [(vector-ref-lens? lens0*) (vector-ref-join-lens lenses)] 263 | ;; fallback implementation 264 | [else (join-lens lenses)])))) 265 | 266 | ;; Convenience constructors 267 | 268 | (define lens-like/c 269 | (or/c 270 | lens? 271 | symbol? 272 | exact-nonnegative-integer? 273 | (listof (recursive-contract lens-like/c)) 274 | ;; field filter 275 | boolean? 276 | string? 277 | regexp? 278 | (procedure-arity-includes/c 1))) 279 | 280 | (define (as-lens v) 281 | (cond 282 | [(lens? v) v] 283 | [(symbol? v) (struct-ref-lens v)] 284 | [(exact-nonnegative-integer? v) (vector-ref-lens v)] 285 | [(list? v) (apply lens-join (map as-lens v))] 286 | ;; field filter 287 | [(or (boolean? v) 288 | (string? v) 289 | (regexp? v) 290 | (procedure-arity-includes? v 1)) 291 | (struct-filter-lens v)] 292 | [else (error 'as-lens "cannot be coerced to a lens")])) 293 | 294 | (define (lens* . args) 295 | (apply lens-thrush (map as-lens args))) 296 | -------------------------------------------------------------------------------- /knox/emulator/interpreter.rkt: -------------------------------------------------------------------------------- 1 | #lang rosette/safe 2 | 3 | (require 4 | "../semantics/syntax.rkt" "../semantics/value.rkt" "../semantics/environment.rkt" "../semantics/shared.rkt" 5 | "../result.rkt" 6 | "util.rkt" 7 | (prefix-in $ "../semantics/lifted.rkt") 8 | (only-in racket/base error) 9 | syntax/parse/define 10 | rosutil 11 | yosys/meta yosys/generic) 12 | 13 | (provide 14 | (struct-out state) 15 | create-environment 16 | interpret 17 | lift 18 | raw) 19 | 20 | ;; Values 21 | ;; 22 | ;; value ::= 23 | ;; | void? 24 | ;; | boolean? 25 | ;; | integer? 26 | ;; | string? 27 | ;; | bv? 28 | ;; | symbol? 29 | ;; | null? 30 | ;; | cons? 31 | ;; | closure? 32 | ;; | raw? 33 | 34 | (addressable-struct state (auxiliary oracle)) 35 | 36 | (struct raw (procedure) 37 | #:transparent) 38 | 39 | (define (variable-lookup var env globals) 40 | (cond 41 | [(assoc-contains env var) (assoc-lookup env var)] 42 | [(assoc-contains globals var) (assoc-lookup globals var)] 43 | [else (error 'variable-lookup "unbound variable ~v" var)])) 44 | 45 | (define (interpret expr st globals) 46 | (local-eval expr st (make-assoc) globals)) 47 | 48 | ;; fully evaluates the expression, producing a value and a new state 49 | (define (local-eval expr st env globals) 50 | (cond 51 | ;; variable reference? 52 | [(variable? expr) 53 | (result (variable-lookup expr env globals) st)] 54 | ;; value literal? 55 | [(literal? expr) 56 | (result (literal-value expr) st)] 57 | ;; quote? 58 | [(quote? expr) 59 | ;; note: skipping checking that it's actually a value in our 60 | ;; domain; emulator code itself will not use this, just top-level 61 | ;; invocations from verification code 62 | (result (quote-get expr) st)] 63 | ;; lambda? 64 | [(lambda? expr) 65 | (result (closure expr env) st)] 66 | ;; if-then-else? 67 | [(if? expr) 68 | (define eval-condition (local-eval (if-condition expr) st env globals)) 69 | (define next-state (result-state eval-condition)) 70 | (if (result-value eval-condition) 71 | (local-eval (if-then expr) next-state env globals) 72 | (local-eval (if-else expr) next-state env globals))] 73 | ;; and? 74 | [(and? expr) 75 | (define contents (and-contents expr)) 76 | (cond 77 | [(null? contents) (result #t st)] 78 | [else 79 | (let loop ([contents contents] 80 | [st st]) 81 | (define eval-first (local-eval (car contents) st env globals)) 82 | (cond 83 | [(or (null? (cdr contents)) (not (result-value eval-first))) eval-first] 84 | [else (loop (cdr contents) (result-state eval-first))]))])] 85 | ;; or? 86 | [(or? expr) 87 | (define contents (or-contents expr)) 88 | (cond 89 | [(null? contents) (result #f st)] 90 | [else 91 | (let loop ([contents contents] 92 | [st st]) 93 | (define eval-first (local-eval (car contents) st env globals)) 94 | (cond 95 | [(or (null? (cdr contents)) (result-value eval-first)) eval-first] 96 | [else (loop (cdr contents) (result-state eval-first))]))])] 97 | ;; let binding? 98 | [(let? expr) 99 | (define bindings (let-bindings expr)) 100 | (let loop ([bindings bindings] 101 | [st st] 102 | [inner-env env]) 103 | (cond 104 | [(null? bindings) (local-eval (let-body expr) st inner-env globals)] 105 | [else 106 | (define binding (car bindings)) 107 | (define binding-name (car binding)) 108 | (define binding-expr (cadr binding)) 109 | (define eval-binding (local-eval binding-expr st env globals)) 110 | (loop 111 | (cdr bindings) 112 | (result-state eval-binding) 113 | (assoc-extend inner-env binding-name (result-value eval-binding)))]))] 114 | ;; begin? 115 | [(begin? expr) 116 | (define contents (begin-contents expr)) 117 | (cond 118 | [(null? contents) (result (void) st)] 119 | [else 120 | (let loop ([contents contents] 121 | [st st]) 122 | (define eval-first (local-eval (car contents) st env globals)) 123 | (cond 124 | [(null? (cdr contents)) eval-first] 125 | [else (loop (cdr contents) (result-state eval-first))]))])] 126 | ;; function application? (this has to be last, after we're done recognizing keywords) 127 | [(app? expr) 128 | ;; evaluate function and arguments left-to-right, and then call it 129 | (define eval-f (local-eval (app-f expr) st env globals)) 130 | (let loop ([args (app-args expr)] 131 | [st (result-state eval-f)] 132 | [evaled-args '()]) 133 | (cond 134 | [(null? args) (local-apply (result-value eval-f) (reverse evaled-args) st globals)] 135 | [else 136 | (define eval-arg (local-eval (car args) st env globals)) 137 | (loop (cdr args) (result-state eval-arg) (cons (result-value eval-arg) evaled-args))]))] 138 | [else 139 | (error 'local-eval "bad expression: ~v" expr)])) 140 | 141 | (define (local-apply f args st globals) 142 | (cond 143 | [(closure? f) 144 | (define formals (lambda-formals (closure-expr f))) 145 | (define env* 146 | (cond 147 | [(symbol? formals) 148 | ;; var-args lambda 149 | (assoc-extend (closure-environment f) formals args)] 150 | [else 151 | (when (not (equal? (length args) (length formals))) 152 | (error 'local-apply "expected ~a arguments, got ~a" (length formals) (length args))) 153 | (assoc-extend* 154 | (closure-environment f) 155 | (foldl 156 | (lambda (var val acc) (cons (cons var val) acc)) 157 | '() formals args))])) 158 | (local-eval (lambda-body (closure-expr f)) st env* globals)] 159 | [(raw? f) 160 | ((raw-procedure f) args st globals)] 161 | [else 162 | (error 'local-apply "not a function: ~v" f)])) 163 | 164 | (define-simple-macro (pair-symbol-value v:id ...) 165 | (list (cons 'v v) ...)) 166 | 167 | (define simple-builtins 168 | (append 169 | (pair-symbol-value 170 | ;; misc 171 | void void? 172 | ;; utility 173 | printf print println write writeln display displayln 174 | ;; equality 175 | equal? 176 | ;; list 177 | cons car cdr caar cadr cdar cddr null? empty? first second third fourth list? list list-ref length reverse 178 | ;; vector (only immutable) 179 | vector? vector-immutable vector-length vector-ref vector-set vector->list list->immutable-vector 180 | ;; boolean 181 | not ! && || => <=> 182 | ;; integer 183 | + - * quotient modulo zero? add1 sub1 abs max min = < <= > >= expt integer? 184 | ;; bv 185 | bv bv? 186 | ;; comparison operators 187 | bveq bvslt bvult bvsle bvule bvsgt bvugt bvsge bvuge 188 | ;; bitwise operators 189 | bvnot bvand bvor bvxor bvshl bvlshr bvashr 190 | ;; arithmetic operators 191 | bvneg bvadd bvsub bvmul bvsdiv bvudiv bvsrem bvurem bvsmod 192 | ;; conversion operators 193 | concat extract sign-extend zero-extend bitvector->integer bitvector->natural integer->bitvector 194 | ;; additional operators 195 | bit lsb msb bvzero? bvadd1 bvsub1 bvsmin bvumin bvsmax bvumax bvrol bvror rotate-left rotate-right bitvector->bits bitvector->bool bool->bitvector 196 | ;; yosys generic 197 | get-field update-field update-fields) 198 | (list 199 | (cons 'bv $bv) 200 | (cons 'bitvector $bitvector)))) 201 | 202 | (define (builtin-apply args st globals) 203 | (local-apply (car args) (cadr args) st globals)) 204 | 205 | (define (builtin-get args st globals) 206 | (result (state-auxiliary st) st)) 207 | 208 | (define (builtin-set! args st globals) 209 | (result (void) (state (car args) (state-oracle st)))) 210 | 211 | (define (lift f) 212 | (lambda (args st globals) 213 | (result (apply f args) st))) 214 | 215 | (define builtins 216 | (append 217 | (map (lambda (sv) (cons (car sv) (lift (cdr sv)))) simple-builtins) 218 | (list 219 | (cons 'apply builtin-apply) 220 | (cons 'get builtin-get) 221 | (cons 'set! builtin-set!)))) 222 | 223 | (define initial-values 224 | (pair-symbol-value 225 | null 226 | true 227 | false)) 228 | 229 | (define basic-environment 230 | (append 231 | initial-values 232 | (map (lambda (sv) (cons (car sv) (raw (cdr sv)))) builtins))) 233 | 234 | ;; oracle api is a list of pairs, of function name (symbol) and 235 | ;; procedure, where the procedure is a curried function, first taking the 236 | ;; arguments to the oracle, and then taking the oracle state, and returning a result 237 | (define (oracle->environment oracle-api) 238 | (define (lift f) 239 | (lambda (args st globals) 240 | (define oracle-result ((apply f args) (state-oracle st))) 241 | (result (result-value oracle-result) 242 | (state (state-auxiliary st) (result-state oracle-result))))) 243 | (map (lambda (sv) (cons (car sv) (raw (lift (cdr sv))))) oracle-api)) 244 | 245 | (define (meta->environment metadata) 246 | (define (make-op name-f) 247 | (cons (car name-f) (raw (lift (cdr name-f))))) 248 | (append 249 | (list 250 | ;; constructor 251 | (cons 'circuit-new (raw (lift (lambda () (circuit-with-invariants metadata))))) 252 | (cons 'circuit-zeroed (raw (lift (meta-new-zeroed metadata)))) 253 | ;; step 254 | (cons 'circuit-step (raw (lift (meta-step metadata)))) 255 | ;; I/O 256 | (cons 'input (raw (lift (meta-input metadata)))) 257 | (cons 'input* (raw (lift (meta-input* metadata)))) 258 | (cons 'circuit-with-input (raw (lift (meta-with-input metadata)))) 259 | (cons 'circuit-get-input (raw (lift (meta-get-input metadata)))) 260 | (cons 'output (raw (lift (meta-output metadata)))) 261 | (cons 'output* (raw (lift (meta-output* metadata)))) 262 | (cons 'circuit-get-output (raw (lift (meta-get-output metadata))))) 263 | (map make-op (meta-input-getters metadata)) 264 | (map make-op (meta-output-getters metadata)))) 265 | 266 | (define (create-environment oracle-api metadata global-bindings) 267 | (append 268 | basic-environment 269 | (oracle->environment oracle-api) 270 | (meta->environment metadata) 271 | global-bindings)) 272 | 273 | (module+ test 274 | (require 275 | rackunit 276 | (only-in "../../test/yosys/verilog/counter.rkt" [metadata counter:metadata])) 277 | 278 | (test-case "state" 279 | (check-equal? 280 | (local-eval '(begin 281 | (set! (+ (get) 1)) 282 | (set! (+ (get) 1)) 283 | (set! (integer->bitvector (get) (bitvector 10))) 284 | (bvadd (get) (bv 1 10))) 285 | (state 0 #f) 286 | (make-assoc) 287 | basic-environment) 288 | (result (bv 3 10) (state (bv 2 10) #f)))) 289 | 290 | (test-case "oracle" 291 | (struct counter (value) 292 | #:transparent) 293 | (define ((inc!) st) 294 | (result (void) (counter (add1 (counter-value st))))) 295 | (define ((incn! n) st) 296 | (result (void) (counter (+ (counter-value st) n)))) 297 | (define ((rd) st) 298 | (result (counter-value st) st)) 299 | (define api 300 | (pair-symbol-value inc! incn! rd)) 301 | 302 | (check-equal? 303 | (local-eval '(begin 304 | (inc!) 305 | (inc!) 306 | (incn! 5) 307 | (inc!) 308 | (incn! (rd)) 309 | (rd)) 310 | (state #f (counter 0)) 311 | (make-assoc) 312 | (append basic-environment (oracle->environment api))) 313 | (result 16 (state #f (counter 16))))) 314 | 315 | (test-case "circuit" 316 | (check-equal? 317 | (local-eval 318 | '(begin 319 | (let ([c0 (circuit-new)]) 320 | (let ([c1 (circuit-with-input c0 (input* 'nrst #t 'en #t))]) 321 | (let ([c2 (circuit-step (circuit-step c1))]) 322 | (output-count (circuit-get-output c2)))))) 323 | (state #f #f) 324 | (make-assoc) 325 | (append basic-environment (meta->environment counter:metadata))) 326 | (result (bv 2 8) (state #f #f)))) 327 | 328 | (test-case "bv" ; regression test 329 | (define-symbolic* b boolean?) 330 | (check-pred 331 | unsat? 332 | (verify 333 | (local-eval 334 | `(if ,b 335 | (let () (bv 0 1)) 336 | (bv 0 1)) 337 | (state #f #f) 338 | (make-assoc) 339 | basic-environment))))) 340 | -------------------------------------------------------------------------------- /knox/security/checker.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (prefix-in emulator: "../emulator/interpreter.rkt") 5 | "../result.rkt" 6 | (prefix-in @ (combine-in rosette/safe rosutil)) 7 | yosys/meta 8 | "../circuit.rkt" 9 | "../spec.rkt" 10 | "../emulator.rkt" 11 | racket/list racket/class racket/match) 12 | 13 | (provide checker% 14 | (struct-out pairing) 15 | (struct-out set)) 16 | 17 | (@addressable-struct 18 | pairing 19 | (circuit 20 | emulator)) 21 | 22 | (@addressable-struct 23 | set 24 | (term 25 | predicate 26 | equalities 27 | ready-to-step)) 28 | 29 | (define checker% 30 | (class object% 31 | (super-new) 32 | 33 | (init-field spec) 34 | (init-field circuit) 35 | (init-field emulator) 36 | (init-field R) 37 | 38 | (define meta (circuit-meta circuit)) 39 | 40 | (define (new-symbolic-input) 41 | (@update-field 42 | ((meta-new-symbolic-input (circuit-meta circuit))) 43 | (circuit-reset-input-name circuit) 44 | (not (circuit-reset-input-signal circuit)))) 45 | 46 | (define circuit-crash+power-on-reset 47 | (crash+power-on-reset circuit)) 48 | 49 | (define emulator-interpret 50 | (let* ([oracle-api 51 | (for/list ([method (spec-methods spec)]) 52 | (define name 53 | (string->symbol (string-append "spec:" (symbol->string (method-descriptor-name method))))) 54 | (cons name (method-descriptor-method method)))] 55 | [oracle-api (if (spec-leak spec) 56 | (cons (cons 'spec:leak (spec-leak spec)) oracle-api) 57 | oracle-api)] 58 | [global-env (emulator:create-environment 59 | oracle-api 60 | (circuit-meta circuit) 61 | (emulator-bindings emulator))]) 62 | (lambda (expr st pred) (@check-no-asserts (emulator:interpret expr st global-env) 63 | #:assumes pred 64 | #:discharge-asserts #t)))) 65 | 66 | (define visited '()) 67 | (define next 68 | (let* ([c ((meta-new-symbolic meta))] 69 | [f ((spec-new-symbolic spec))] 70 | [p (@&& ((meta-invariant meta) c) (@check-no-asserts (R f c)))] 71 | [emu (result-state (emulator-interpret '(init) (emulator:state #f f) p))]) 72 | (list (set (pairing c emu) p (hasheq) #f)))) 73 | 74 | (define checks-disabled #f) 75 | (define checks-ever-disabled #f) 76 | 77 | (define/public (disable-checks!) 78 | (set! checks-disabled #t) 79 | (set! checks-ever-disabled #t)) 80 | 81 | (define/public (enable-checks!) 82 | (set! checks-disabled #f)) 83 | 84 | (define/public (finished?) 85 | (and (empty? next) (not checks-ever-disabled))) 86 | 87 | (define/public (focused) 88 | (first next)) 89 | 90 | (define/public (count-remaining) 91 | (length next)) 92 | 93 | (define/public (get-next) 94 | next) 95 | (define/public (get-visited) 96 | visited) 97 | 98 | (define/public (switch-goal! num) 99 | (unless (< num 0) 100 | (define-values (h t) (split-at next num)) 101 | (set! next (cons (car t) (append h (cdr t)))))) 102 | 103 | (define (equalities->bool eqt) 104 | (apply @&& (for/list ([(k v) (in-hash eqt)]) (@equal? k v)))) 105 | 106 | (define/public (concretize! lens #:use-equalities [use-equalities #f] #:piecewise [piecewise #f]) 107 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 108 | (define effective-pred (if use-equalities 109 | (@&& focus-pred (equalities->bool focus-eq)) 110 | focus-pred)) 111 | (define focus-term* 112 | (@lens-transform lens focus-term (lambda (view) (@concretize view effective-pred #:piecewise piecewise)))) 113 | (set! next (cons (set focus-term* focus-pred focus-eq focus-ready) (rest next)))) 114 | 115 | (define/public (overapproximate! lens) 116 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 117 | (define focus-term* 118 | (@lens-transform lens focus-term (lambda (view) (@overapproximate view)))) 119 | (set! next (cons (set focus-term* focus-pred focus-eq focus-ready) (rest next)))) 120 | 121 | ;; lets the caller specify what to replace terms with, but we do a subsumption check 122 | (define/public (overapproximate*! lens view) 123 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 124 | (define focus-term* (@lens-set lens focus-term view)) 125 | (define effective-pred (@&& focus-pred (equalities->bool focus-eq))) 126 | (unless (or checks-disabled (@subsumed? #f focus-term effective-pred focus-term* effective-pred)) 127 | (error 'overapproximate*! "subsumption check failed")) 128 | (set! next (cons (set focus-term* focus-pred focus-eq focus-ready) (rest next)))) 129 | 130 | (define/public (overapproximate-predicate! p #:use-equalities [use-equalities #f]) 131 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 132 | (define effective-pred (if use-equalities 133 | (@&& focus-pred (equalities->bool focus-eq)) 134 | focus-pred)) 135 | (unless (or checks-disabled (@unsat? (@verify (@assert (@implies effective-pred p))))) 136 | (error 'overapproximate-predicate! "failed to prove implication of new predicate")) 137 | (set! next (cons (set focus-term p focus-eq focus-ready) (rest next)))) 138 | 139 | ;; proof by subsumption 140 | (define/public (overapproximate-predicate*! p) 141 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 142 | (define effective-pred (@&& focus-pred (equalities->bool focus-eq))) 143 | (define effective-new-pred (@&& p (equalities->bool focus-eq))) 144 | (unless (or checks-disabled (@subsumed? #f focus-term effective-pred focus-term effective-new-pred)) 145 | (error 'overapproximate-predicate*! "subsumption check failed")) 146 | (set! next (cons (set focus-term p focus-eq focus-ready) (rest next)))) 147 | 148 | (define/public (replace! lens view #:use-equalities [use-equalities #f]) 149 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 150 | (define current-view (@lens-view lens focus-term)) 151 | (define effective-pred (if use-equalities 152 | (@&& focus-pred (equalities->bool focus-eq)) 153 | focus-pred)) 154 | (unless (or checks-disabled (@unsat? (@verify (@begin (@assume effective-pred) (@assert (@equal? current-view view)))))) 155 | (error 'replace! "failed to prove equality")) 156 | (define focus-term* (@lens-set lens focus-term view)) 157 | (set! next (cons (set focus-term* focus-pred focus-eq focus-ready) (rest next)))) 158 | 159 | ;; gives circuit/emu new inputs 160 | (define/public (prepare!) 161 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 162 | (define input (new-symbolic-input)) 163 | (define c-with-input ((meta-with-input meta) (pairing-circuit focus-term) input)) 164 | (define emulator-with-input (result-state (emulator-interpret `(with-input ',input) (pairing-emulator focus-term) focus-pred))) 165 | (set! next (cons (set (pairing c-with-input emulator-with-input) focus-pred focus-eq #t) (rest next)))) 166 | 167 | (define/public (step!) 168 | (unless (set-ready-to-step (first next)) 169 | (prepare!)) 170 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 171 | ;; check that outputs match 172 | (match-define (pairing c-with-input emulator-with-input) focus-term) 173 | ;; not making use of focus-eq in assumption 174 | (unless checks-disabled 175 | (define c-out ((meta-get-output meta) c-with-input)) 176 | (match-define (result emulator-out emulator-after-out) (emulator-interpret '(get-output) emulator-with-input focus-pred)) 177 | (set! emulator-with-input emulator-after-out) ; in case the emulator updates state / calls the oracle as part of get-output 178 | (define outputs-equal (@equal? c-out emulator-out)) 179 | (unless (or (eqv? outputs-equal #t) ; avoid solver query when possible 180 | (@unsat? (@verify (@begin 181 | (@assume focus-pred) 182 | (@assert outputs-equal))))) 183 | (error 'step! "output mismatch between circuit and emulator"))) 184 | ;; check crash/reset/recovery 185 | (unless checks-disabled 186 | (define c-reset (circuit-crash+power-on-reset (pairing-circuit focus-term))) 187 | (define f (emulator:state-oracle (pairing-emulator focus-term))) 188 | (define R-post-crash (@check-no-asserts (R f c-reset))) 189 | (define crash-model (if 190 | (eqv? R-post-crash #t) 191 | (@unsat) ; avoid solver query when possible 192 | (@verify (@begin 193 | (@assume focus-pred) 194 | (@assert R-post-crash))))) 195 | (unless (@unsat? crash-model) 196 | (println (@evaluate f crash-model)) 197 | (println (@evaluate c-reset crash-model)) 198 | (error 'step! "recovery condition does not hold"))) 199 | (define stepped 200 | (set 201 | (pairing 202 | ((meta-step meta) c-with-input) 203 | (result-state (emulator-interpret '(step) emulator-with-input focus-pred))) 204 | focus-pred 205 | focus-eq 206 | #f)) 207 | (prepare!) 208 | (set! visited (cons (first next) visited)) 209 | (set! next (cons stepped (rest next)))) 210 | 211 | (define/public (cases! preds #:use-equalities [use-equalities #f]) 212 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 213 | (define preds* (map (lambda (p) (@&& focus-pred p)) preds)) 214 | (define any-split (apply @|| preds*)) 215 | (define effective-pred (if use-equalities 216 | (@&& focus-pred (equalities->bool focus-eq)) 217 | focus-pred)) 218 | (unless (or checks-disabled (@unsat? (@verify (@assert (@implies effective-pred any-split))))) 219 | (error 'cases! "failed to prove exhaustiveness")) 220 | (define new (map (lambda (p) (set focus-term p focus-eq focus-ready)) preds*)) 221 | (set! next (append new (rest next)))) 222 | 223 | (define/public (admit!) 224 | (set! checks-ever-disabled #t) 225 | (set! next (rest next))) 226 | 227 | ;; pos is relative to end 228 | (define/public (subsumed! pos) 229 | (when (set-ready-to-step (first next)) 230 | (error 'subsumed! "cannot do subsumption check without stepping a prepared state")) 231 | ;; we call prepare here because (step!) doesn't replace the inputs with new ones 232 | ;; and our circuit rep includes the inputs (which shouldn't really be compared) 233 | (prepare!) 234 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 235 | (define focus-effective-pred (@&& focus-pred (equalities->bool focus-eq))) 236 | (define idx (- (length visited) pos 1)) 237 | (match-define (set ref-term ref-pred ref-eq ref-ready) (list-ref visited idx)) 238 | (define ref-effective-pred (@&& ref-pred (equalities->bool ref-eq))) 239 | (unless (or checks-disabled (@subsumed? #f focus-term focus-effective-pred ref-term ref-effective-pred)) 240 | (error 'subsumed! "subsumption check failed")) 241 | ;; now, we can just discard the currently focused term 242 | (set! next (rest next))) 243 | 244 | (define/public (remember! lens [name #f]) 245 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 246 | (define current-view (@lens-view lens focus-term)) 247 | (define current-type (@type-of current-view)) 248 | (when (not (@solvable? current-type)) 249 | (error 'remember! "not a solvable type")) 250 | (define new-var (@fresh-symbolic (or name '||) current-type)) 251 | (define focus-term* (@lens-set lens focus-term new-var)) 252 | (define focus-eq* (hash-set focus-eq new-var current-view)) 253 | (set! next (cons (set focus-term* focus-pred focus-eq* focus-ready) (rest next))) 254 | new-var) 255 | 256 | (define/public (remember+! lenses [name #f]) 257 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 258 | (define current-view (@lens-view (first lenses) focus-term)) 259 | (define current-type (@type-of current-view)) 260 | (when (not (@solvable? current-type)) 261 | (error 'remember+! "not a solvable type")) 262 | (for ([l (rest lenses)]) 263 | (define same (@equal? (@lens-view l focus-term) current-view)) 264 | ;; doesn't use pred etc, this is for terms that are equal? 265 | (unless (or checks-disabled (eqv? same #t) (@unsat? (@verify (@assert same)))) 266 | (error 'remember+ "unequal terms"))) 267 | (define new-var (@fresh-symbolic (or name '||) current-type)) 268 | (define focus-term* 269 | (for/fold ([t focus-term]) 270 | ([l lenses]) 271 | (@lens-set l t new-var))) 272 | (define focus-eq* (hash-set focus-eq new-var current-view)) 273 | (set! next (cons (set focus-term* focus-pred focus-eq* focus-ready) (rest next))) 274 | new-var) 275 | 276 | ;; if var is not given, clears everything 277 | (define/public (clear! [var #f]) 278 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 279 | (define focus-eq* (if var 280 | (hash-remove focus-eq var) 281 | (hasheq))) 282 | (set! next (cons (set focus-term focus-pred focus-eq* focus-ready) (rest next)))) 283 | 284 | ;; this only substitutes into the term, not into existing 285 | ;; equalities (though we could add another tactic for that if it's 286 | ;; needed) 287 | ;; 288 | ;; when var is not given, substitutes all equalities 289 | ;; when lens is not given, substitutes in entire term (but not predicate or equalities) 290 | (define/public (subst! [lens @identity-lens] #:var [var #f]) 291 | (match-define (set focus-term focus-pred focus-eq focus-ready) (first next)) 292 | (define focus-term* 293 | (@lens-transform lens focus-term (lambda (view) 294 | (if var 295 | (@substitute view var (hash-ref focus-eq var)) 296 | (@substitute-terms view focus-eq))))) 297 | (set! next (cons (set focus-term* focus-pred focus-eq focus-ready) (rest next)))))) 298 | --------------------------------------------------------------------------------