diff -uNr a/gbw-signer/README b/gbw-signer/README --- a/gbw-signer/README a852363120bda90705cbe8f77cb52ef4d2480f19c1af1d2a6306256ba28feaa0616aca12c61c92c909b42547878ed8c6a9de54fa3efd80318a85e5a8b28b73bd +++ b/gbw-signer/README 55581d8ede59ca7a2de3f7b0210c39b5580a37a5ade835b87d5869502c50952a406d2c447baad4a84c306192ab3c1c297bcfa01d64e68d6fc483485acce1a96d @@ -20,11 +20,11 @@ 1. Create the top-level /package directory if necessary and place the tree at its fully version-qualified path: mkdir -p /package - cp -r /YOUR/PATH/TO/gbw-signer /package/gbw-signer-2 + cp -r /YOUR/PATH/TO/gbw-signer /package/gbw-signer-3 2. Run the install script from the above directory: - cd /package/gbw-signer-2 + cd /package/gbw-signer-3 sh package/install ECC cache generation will take a noticeable time, depending on hardware, though hopefully not so much as to suggest preparing a beverage. diff -uNr a/gbw-signer/command/gbw-signer b/gbw-signer/command/gbw-signer --- a/gbw-signer/command/gbw-signer d87653cc6c0e54b028fd98b7039388d6a96a0bf59ac17dc06cf3d270fa57af7a73a2a574570f4915273350892dac81e00b3177b6ada9a8ef26e182a9a678246e +++ b/gbw-signer/command/gbw-signer 103225e8a2ec39d5f86e1bf0b63ed780daa6c2ad73dc29baabc3c97bb55bb9b7cfcc319726937bfc56060605bd86244c50f9e867ba28ffedf926da88e77dddfe @@ -1,2 +1,2 @@ #!/bin/sh -exec /usr/bin/gscm /package/gbw-signer-2/library/gbw-signer.scm "$@" +exec /usr/bin/gscm /package/gbw-signer-3/library/gbw-signer.scm "$@" diff -uNr a/gbw-signer/library/bit-ops.scm b/gbw-signer/library/bit-ops.scm --- a/gbw-signer/library/bit-ops.scm 57fd97273df8a16fedaf0a49d2265b0171e3f09931476b040383052ee08ac29903a6aa29efa2d163187ccf48993fd13b11326bc7a68ede1363dbaa3d03660414 +++ b/gbw-signer/library/bit-ops.scm 39b52aba0a9ecc2a6c9f386a63b449b408e399ca3fc2b658f59505af1d3835f1c2b742b0965f7792a3e27555592fe40a47360bd307fd2df9f0295a8b4d3bbb4c @@ -1,196 +1,237 @@ (lambda () (define (repeat obj count) - (if (<= count 0) '() - (cons obj (repeat obj (- count 1))))) + (if (fx<= count 0) '() + (cons obj (repeat obj (fx-/wrap count 1))))) (define (fold f init l) (do ((l l (cdr l)) (acc init (f acc (car l)))) ((null? l) acc))) + (define (reverse-map1 f l) + (do ((l l (cdr l)) + (acc '() (cons (f (car l)) acc))) + ((null? l) acc))) + (define (assert err-msg proc . args) (if (not (apply proc args)) (error err-msg args))) - (define fxwidth-1 (- *fixnum-width* 1)) - - ;; A fixed width integer (fz) is represented as a list of fixnum words, least significant first, wrapped in an outer list to track the width in bits. As the desired width might not be a multiple of the system's fixnum width, the low end of the low word is zero padded. (This choice allows the carry output from the high word to work naturally.) + ;; A fixed width integer (fz) is represented as a list of fixnum words, least significant first. The width in bits is given by positive fixnum FZ-WIDTH. When it's not a multiple of the system's fixnum width, the high end of the high word is zero-padded. ;; - ;; Invariant: - ;; (= (+ bits (padding bits)) (* (word-count bits) *fixnum-width*)) - - (define (word-count bits) - (quotient (+ bits fxwidth-1) *fixnum-width*)) + ;; This representation is considered an implementation detail. It is an error to pass an object as FZ argument to any of these operators that is not EQUAL? to an FZ object as returned by one of the operators of the same FZ-WIDTH. It is also an error to mutate the contents of any returned FZ object. + (define (fz-ops fz-width) - (define (padding bits) - (- fxwidth-1 (modulo (- bits 1) *fixnum-width*))) + ;; Number of fixnum words in an FZ (list length) + (define word-count (quotient (+ fz-width *fixnum-width* -1) + *fixnum-width*)) + + ;; Number of padding bits + (define padding (- *fixnum-width* 1 (modulo (- fz-width 1) + *fixnum-width*))) + ;; Invariants (checked below at end of definitions): + ;; (+ fz-width padding) = (* word-count *fixnum-width*) + ;; 0 <= padding < *fixnum-width* + + ;; Mask covering non-pad bits of a word + (define padding-neg-mask (delay (- (expt 2 (- *fixnum-width* padding)) 1))) + + ;; "Press": construct FZ from reverse-accumulated words, zeroing the pad bits + (define (press-fz rev-words) + (reverse (cons (fxand padding-neg-mask (car rev-words)) + (cdr rev-words)))) - ;; Construct a fixed width integer (FZ) - (define (make-fz bit-width words) - (assert "make-fz: bad word count for width" - = (length words) (word-count bit-width)) - (list bit-width words)) - - ;; FZ accessors - (define fz-width car) - (define fz-words cadr) - (define (fz-unpack a consumer) (apply consumer a)) - - ;; "Press": construct FZ from reverse-accumulated words, zeroing the pad bits - (define (press-fz bit-width rev-words) - (let* ((p (padding bit-width)) - (head (fxshift/unsigned (fxshift (car rev-words) p) (- p)))) - (make-fz bit-width (reverse (cons head (cdr rev-words)))))) + (define (fz0) + (repeat 0 word-count)) - (define (fz0 width) - (make-fz width (repeat 0 (word-count width)))) - - (define (word->ufz width w) - (make-fz width (cons w (repeat 0 (- (word-count width) 1))))) + (define (word->ufz w) + (cons w (repeat 0 (fx-/wrap word-count 1)))) (define (ufz+/pair a b) - (let ((width (fz-width a))) - (assert "ufz+: unequal width" = width (fz-width b)) - (let loop ((a (fz-words a)) (b (fz-words b)) (carry 0) (acc '())) - (if (null? a) (press-fz width acc) + (let loop ((a a) (b b) (carry 0) (acc '())) + (if (null? a) (press-fz acc) (call-with-values (lambda () (fx+/carry-unsigned (car a) (car b) carry)) (lambda (sum carry) - (loop (cdr a) (cdr b) carry (cons sum acc)))))))) + (loop (cdr a) (cdr b) carry (cons sum acc))))))) ;; !! UNTESTED !! ;(define (ufz-/pair a b) - ; (let ((width (fz-width a))) - ; (assert "ufz-: unequal width" = width (fz-width b)) - ; (let loop ((a (fz-words a)) (b (fz-words b)) (carry 0) (acc '())) - ; (if (null? a) (press-fz width acc) + ; (let loop ((a a) (b b) (carry 0) (acc '())) + ; (if (null? a) (press-fz acc) ; (call-with-values - ; (lambda () (fx-/carry-unsigned (car a) (car b) carry)) + ; (lambda () (fx-/borrow-unsigned (car a) (car b) carry)) ; (lambda (diff carry) - ; (loop (cdr a) (cdr b) carry (cons diff acc)))))))) + ; (loop (cdr a) (cdr b) carry (cons diff acc))))))) (define (ufz+ a . args) (fold ufz+/pair a args)) ;; Positive (left) shift: signedness doesn't matter. - ;; Assumes 0 < bits < width. + ;; Assumes 0 <= bits < fz-width . ;; Constant time w.r.t. words only (NOT bits). - (define (shift width words bits) + (define (shift-up words bits) + ; XXX slow - maybe provide a fixnum quotient/remainder ? Pass them in from the curried variants ? (let ((whole-words (quotient bits *fixnum-width*)) (bits (remainder bits *fixnum-width*))) - (let ((carry-shift (- bits *fixnum-width*))) + ;; 0 <= whole-words < word-count + ;; 0 <= bits < *fixnum-width* + (let ((carry-shift (fx-/wrap bits *fixnum-width*))) + ;; (-)*fixnum-width* <= carry-shift < 0 (do ((words words (cdr words)) (carry 0 (fxshift/unsigned (car words) carry-shift)) (acc (repeat 0 whole-words) (cons (fxior (fxshift (car words) bits) carry) acc)) - (todo (- (word-count width) whole-words) (- todo 1))) - ((zero? todo) (press-fz width acc)))))) + (todo (fx-/wrap word-count whole-words) (fx-/wrap todo 1))) + ;; 0 <= todo <= word-count + ((fx= 0 todo) (press-fz acc)))))) ;; Negative (right) shift without sign extension. - ;; Assumes 0 < bits < width. + ;; Assumes 0 <= bits < fz-width . ;; Constant time w.r.t. words only (NOT bits). - (define (unshift-unsigned width words bits) + (define (shift-down-unsigned words bits) + ; XXX slow - as above (let ((whole-words (quotient bits *fixnum-width*)) - (bits (- (remainder bits *fixnum-width*)))) - (let ((carry-shift (+ bits *fixnum-width*))) + (bits (fx-/wrap (remainder bits *fixnum-width*)))) + ;; 0 <= whole-words < word-count + ;; (-)*fixnum-width* < bits <= 0 + (let ((carry-shift (fx+/wrap bits *fixnum-width*))) + ;; 0 < carry-shift <= *fixnum-width* (do ((words (reverse (list-tail words whole-words)) (cdr words)) (carry 0 (fxshift (car words) carry-shift)) (acc (repeat 0 whole-words) (cons (fxior (fxshift/unsigned (car words) bits) carry) acc))) - ((null? words) (make-fz width acc)))))) + ((null? words) acc))))) ;; Front-end for unsigned shifts. ;; Constant time w.r.t. FZ value only (NOT bits). - (define (ufzshift a bits) - (fz-unpack - a (lambda (width words) - (cond ((zero? bits) a) - ((>= (abs bits) width) (fz0 width)) - ((positive? bits) (shift width words bits)) - (else (unshift-unsigned width words (- bits))))))) + (define (ufzshift-by bits) + (cond ((zero? bits) (lambda (a) a)) + ((>= (abs bits) fz-width) (lambda (a) (fz0))) + ((positive? bits) (lambda (a) (shift-up a bits))) + (else (lambda (a) (shift-down-unsigned a (- bits)))))) ;; Bit rotation: signedness doesn't matter. - ;; Rotates to the "left" i.e. more-significant, but can take negative bits. + ;; Rotates to the "left" i.e. more-significant. + ;; Requires 0 <= bits < fz-width . ;; Constant time w.r.t. FZ value only (NOT bits). (define (fzrot a bits) - (fz-unpack - a (lambda (width words) - (let ((bits (modulo bits width))) - (if (zero? bits) a - (fzior (shift width words bits) - (unshift-unsigned width words (- width bits)))))))) + (cond ((fx<=/unsigned fz-width bits) ; also catches negatives + (error "fzrot: bits out of range:" bits)) + ((fx= 0 bits) a) + ;; 0 < bits < fz-width + (else (fzior (shift-up a bits) + (shift-down-unsigned a (fx-/wrap fz-width bits)))))) + + ;; Curried variant allowing arbitrary integer rotations, pre-reduced. + (define (fzrot-by bits) + (let* ((reduced (modulo bits fz-width)) + (complement (fx-/wrap fz-width reduced))) + (if (fx= 0 reduced) + (lambda (a) a) + (lambda (a) (fzior (shift-up a reduced) + (shift-down-unsigned a complement)))))) (define (fznot a) - (fz-unpack a (lambda (width a) (press-fz width (reverse (map fxnot a)))))) + (press-fz (reverse-map1 fxnot a))) - ;; Build new FZ by mapping func across corresponding words of each input. - ;; Assumes func preserves zero padding. - (define (fzmap func a . tail) - (let ((width (fz-width a))) - (if (not (apply = width (map fz-width tail))) - (error "fzmap: unequal widths")) - (make-fz width (apply map func (fz-words a) (map fz-words tail))))) - - (define (fzand . args) (apply fzmap fxand args)) - (define (fzior . args) (apply fzmap fxior args)) - (define (fzxor . args) (apply fzmap fxxor args)) - (define (fzif a b c) (fzmap fxif a b c)) - (define (fzmaj a b c) (fzmap fxmaj a b c)) + ;; Functions that preserve the zero-padding can use 'map' directly. + (define (fzand . args) (apply map fxand args)) + (define (fzior . args) (apply map fxior args)) + (define (fzxor . args) (apply map fxxor args)) + (define (fzif a b c) (map fxif a b c)) + (define (fzmaj a b c) (map fxmaj a b c)) ;;; FZ to octet string I/O, big and little endian. ;;; Complicated due to non-aligned fixnum width, but linear time. ;; Construct (* 8 (string-length BUF)) bit wide FZ from the octets in BUF. (define (bytes->fz buf big-endian) - (let* ((nbytes (string-length buf)) - (get-char (if big-endian - (lambda (k) (string-ref buf (- nbytes 1 k))) - (lambda (k) (string-ref buf k))))) - (let loop ((bit-pos 0) (k 0) (word 0) (words '())) - (if (= k nbytes) (make-fz (fxshift nbytes 3) - (reverse (cons word words))) + (define nbytes (string-length buf)) + (define get-char (if big-endian + (lambda (k) (string-ref buf (fx-/wrap nbytes 1 k))) + (lambda (k) (string-ref buf k)))) + (define (loop bit-pos k word acc) + ;; 0 <= bit-pos <= *fixnum-width* + ;; XXX seems sloppy that the upper bound is inclusive, as this allows degenerate shifts + (if (fx= k nbytes) (reverse (cons word acc)) + ;; 0 <= k < nbytes (let ((byte (char->integer (get-char k)))) - (let ((bit-pos (+ bit-pos 8)) - (k (+ k 1)) + (let ((bit-pos (fx+/wrap bit-pos 8)) (word (fxior word (fxshift byte bit-pos)))) - (if (<= bit-pos *fixnum-width*) + ;; 8 <= bit-pos <= (+ *fixnum-width* 8) + (if (fx<=/unsigned bit-pos *fixnum-width*) ;; whole byte fits in current word - (loop bit-pos k word words) + (loop bit-pos (fx+/wrap k 1) word acc) ;; else spill to next word - (let ((carry-bits (- bit-pos *fixnum-width*))) - (loop carry-bits k (fxshift/unsigned byte (- carry-bits 8)) - (cons word words)))))))))) - - (define (lsb->char word) - (integer->char (fxand word 255))) + ;; bit-pos > *fixnum-width* + (let ((carry-bits (fx-/wrap bit-pos *fixnum-width*))) + ;; 0 < carry-bits <= 8 + (loop carry-bits (fx+/wrap k 1) + (fxshift/unsigned byte (fx-/wrap carry-bits 8)) + (cons word acc)))))))) + (if (not (fx= (fxshift nbytes 3) fz-width)) + (error "bytes->fz: word size doesn't match string bit length:" + (list (fxshift nbytes 3) fz-width))) + (loop 0 0 0 '())) ;; Construct octet string from a multiple-of-8 bit wide FZ. (define (fz->bytes a big-endian) - (fz-unpack - a (lambda (width words) - (if (not (zero? (fxand width 7))) - (error "fz->bytes: width not divisible by 8:" width)) - (let* ((nbytes (fxshift width -3)) - (buf (make-string nbytes)) - (set-byte! - (if big-endian - (lambda (k b) (string-set! buf (- nbytes 1 k) - (lsb->char b))) - (lambda (k b) (string-set! buf k (lsb->char b)))))) - (let loop ((bit-pos 0) (k 0) (word (car words)) - (words (cdr words))) - (if (= k nbytes) buf - (let ((byte (fxshift/unsigned word (- bit-pos))) - (bit-pos (+ bit-pos 8))) - (if (<= bit-pos *fixnum-width*) + (define nbytes (fxshift fz-width -3)) + (define buf (delay (make-string nbytes))) + (define set-byte! + (if big-endian + (lambda (k b) + (string-set! buf (fx-/wrap nbytes 1 k) + (integer->char (fxand b 255)))) + (lambda (k b) + (string-set! buf k (integer->char (fxand b 255)))))) + (define (loop bit-pos k word words) + ;; 0 <= bit-pos <= *fixnum-width* + ;; XXX upper bound seems sloppy (as above) + (if (fx= k nbytes) buf + ;; 0 <= k < nbytes + (let ((byte (fxshift/unsigned word (fx-/wrap bit-pos))) + ;; ^ not pre-masked + (bit-pos (fx+/wrap bit-pos 8))) + ;; 8 <= bit-pos <= (+ 8 *fixnum-width*) + (if (fx<=/unsigned bit-pos *fixnum-width*) ;; whole byte contained in current word (begin (set-byte! k byte) - (loop bit-pos (+ k 1) word words)) + (loop bit-pos (fx+/wrap k 1) word words)) ;; else fill in from next word + ;; bit-pos > *fixnum-width* (let ((word (car words)) - (peek (- bit-pos *fixnum-width*))) - (set-byte! k (fxior byte (fxshift word (- 8 peek)))) - (loop peek (+ k 1) word (cdr words))))))))))) + (peek-bits (fx-/wrap bit-pos *fixnum-width*))) + ;; 0 < peek-bits <= 8 + (set-byte! k (fxior byte + (fxshift word (fx-/wrap 8 peek-bits)))) + (loop peek-bits (fx+/wrap k 1) word (cdr words))))))) + (if (fxbytes: width not divisible by 8:" fz-width)) + (set! buf (force buf)) + (loop 0 0 (car a) (cdr a))) + + ;; Shortcuts, favoring big-endianism as the conventional digit order in writing and in the intrabyte order of hex encoding. + (define (hex->fz a) (bytes->fz (hex->bytes a) #t)) + (define (fz->hex a) (bytes->hex (fz->bytes a #t))) + + (set! padding-neg-mask (force padding-neg-mask)) + (assert "invalid fz-width" + fx< 0 fz-width) + (assert "width + padding != total word bits" + = (+ fz-width padding) (* word-count *fixnum-width*)) + (assert "padding lower bound" + <= 0 padding) + (assert "padding upper bound" + < padding *fixnum-width*) + + (export fz0 word->ufz + ufz+ + ufzshift-by fzrot fzrot-by + fznot fzand fzior fzxor fzif fzmaj + bytes->fz fz->bytes hex->fz fz->hex)) + ;; end of fz-ops ;;; Constant time word comparison predicates, returning 0 or 1 @@ -198,12 +239,6 @@ (call-with-values (lambda () (fx-/borrow-unsigned a b)) (lambda (diff carry) carry))) - (define (uword<=? a b) - (fxxor 1 (uwordchar (fxior (fxshift (hexdigit->integer hi) 4) (hexdigit->integer lo)))) - (loop (+ i 1) (+ j 2))))) + (loop (fx+/wrap i 1) (fx+/wrap j 2))))) (if (even? (string-length h)) (loop 0 0) (begin (string-set! bytes 0 (integer->char (hexdigit->integer (string-ref h 0)))) @@ -255,16 +291,11 @@ (define (bytes->hex b) (let* ((len (string-length b)) (h (make-string (* 2 len)))) - (do ((i 0 (+ i 1)) - (j 0 (+ j 2))) ((= i len) h) + (do ((i 0 (fx+/wrap i 1)) + (j 0 (fx+/wrap j 2))) ((fx= i len) h) (let ((byte (char->integer (string-ref b i)))) (string-set! h j (integer->hexdigit (fxshift/unsigned byte -4))) - (string-set! h (+ j 1) (integer->hexdigit (fxand byte 15))))))) + (string-set! h (fx+/wrap j 1) + (integer->hexdigit (fxand byte 15))))))) - ;; Shortcuts, favoring big-endianism as the conventional digit order in writing and in the intrabyte order of hex encoding. - (define (fz->hex a) (bytes->hex (fz->bytes a #t))) - (define (hex->fz a) (bytes->fz (hex->bytes a) #t)) - - (export fz0 word->ufz ufz+ ufzshift fzrot fznot fzand fzior fzxor fzif - fzmaj bytes->fz fz->bytes hexdigit->integer hex->bytes bytes->hex - fz->hex hex->fz)) + (export fz-ops hexdigit->integer hex->bytes bytes->hex)) diff -uNr a/gbw-signer/library/gbw-signer.scm b/gbw-signer/library/gbw-signer.scm --- a/gbw-signer/library/gbw-signer.scm 4b5987fbe68471ad921cae3ddbd5905bae73c7a31fe1592ecd30e0d63828386281e83bbcb026c00664b9c3c1a5cfc92edddcf56fae0adca7e9924c399aa6cddf +++ b/gbw-signer/library/gbw-signer.scm 28cd962b6acc4468b5ebecbdcce4a39f85407572f85e7027b07f27c377a48b55430363d231dfd0a6b15b07346b85d371f675dfee74455e1af8e9ce06a3091b3d @@ -3,7 +3,7 @@ ;;; Knobs -(define *install-path* "/package/gbw-signer-2") +(define *install-path* "/package/gbw-signer-3") (define *rng-port* (delay (open-input-file "/dev/urandom"))) diff -uNr a/gbw-signer/library/hashes.scm b/gbw-signer/library/hashes.scm --- a/gbw-signer/library/hashes.scm d32220767f92fa0e43b85afb33f9910456bc334e351946bb67bf814b54221e5b2b07d765a912d19e81478962c3946845998388245c78ec9b032c87f7d0524554 +++ b/gbw-signer/library/hashes.scm 4683bcb6d89c5c16f0c8e52e4464c806a98060e73227a0b6957ec5570717f57d086b668b319665d3e7a03fa8c744b6f7348889d4ea68122e0d29cef2365184c7 @@ -2,20 +2,9 @@ ;;; J. Welsh, November 2017 - May 2018 ;;; Trimmed for gbw, March 2020 -(lambda (fz-ops) - (define word->ufz (fz-ops 'word->ufz)) - (define ufz+ (fz-ops 'ufz+)) - (define ufzshift (fz-ops 'ufzshift)) - (define fzrot (fz-ops 'fzrot)) - (define fznot (fz-ops 'fznot)) - (define fzior (fz-ops 'fzior)) - (define fzxor (fz-ops 'fzxor)) - (define fzif (fz-ops 'fzif)) - (define fzmaj (fz-ops 'fzmaj)) - (define bytes->fz (fz-ops 'bytes->fz)) - (define fz->bytes (fz-ops 'fz->bytes)) - (define hex->bytes (fz-ops 'hex->bytes)) - (define hex->fz (fz-ops 'hex->fz)) +(lambda (bit-ops) + (define hex->bytes (bit-ops 'hex->bytes)) + (define fz-ops (bit-ops 'fz-ops)) (define (compose f g) (lambda (x) (f (g x)))) @@ -23,7 +12,11 @@ (define initial-padding (string (integer->char 128))) ;; The Merkle-Damgard construction: turns a fixed size compression function into an arbitrary size hash function, by blockwise iteration with padding and length hardening. For simplicity, this implementation requires the full message to fit in a string. - (define (merkle-damgard block-size length-bits big-endian compress offset iv) + (define (merkle-damgard block-size length-ops big-endian compress offset iv) + (define fz->bytes (length-ops 'fz->bytes)) + (define shift/3 ((length-ops 'ufzshift-by) 3)) + (define ufz+ (length-ops 'ufz+)) + (define word->ufz (length-ops 'word->ufz)) (define (finish hash tail packed-bit-length) (let ((length-size (string-length packed-bit-length)) (space (- block-size (string-length tail)))) @@ -43,32 +36,61 @@ ((> next len) (finish hash (string-append (substring msg pos len) initial-padding) - (fz->bytes (ufzshift (ufz+ (word->ufz length-bits len) - (word->ufz length-bits offset)) - 3) + (fz->bytes (shift/3 (ufz+ (word->ufz len) + (word->ufz offset))) big-endian))))))) - (define (append-hex->bytes . args) - (apply string-append (map hex->bytes args))) - (define (hex->fz-vec . args) - (list->vector (map hex->fz args))) + (let ((ops32 (fz-ops 32)) + (ops64 (fz-ops 64))) + + (define not32 (ops32 'fznot)) + (define add32 (ops32 'ufz+)) + (define ior32 (ops32 'fzior)) + (define xor32 (ops32 'fzxor)) + (define if32 (ops32 'fzif)) + (define maj32 (ops32 'fzmaj)) + (define rot32 (ops32 'fzrot)) + (define bytes->fz32 (ops32 'bytes->fz)) + (define fz->bytes32 (ops32 'fz->bytes)) + (define hex->fz32 (ops32 'hex->fz)) ;; Load aligned word from byte string, little/big endian - (define (slice s k len) (substring s k (+ k len))) - (define (loadw32 s k) (bytes->fz (slice s (fxshift k 2) 4) #f)) - (define (loadbw32 s k) (bytes->fz (slice s (fxshift k 2) 4) #t)) + (define (slice s k len) (substring s k (fx+/wrap k len))) + (define (loadw32 s k) (bytes->fz32 (slice s (fxshift k 2) 4) #f)) + (define (loadbw32 s k) (bytes->fz32 (slice s (fxshift k 2) 4) #t)) ;; Pack words as byte string, little/big endian - (define (pack-words w) - (apply string-append (map (lambda (w) (fz->bytes w #f)) w))) - (define (packb-words w) - (apply string-append (map (lambda (w) (fz->bytes w #t)) w))) + (define (pack-words32 words) + (apply string-append (map (lambda (w) (fz->bytes32 w #f)) words))) + (define (packb-words32 words) + (apply string-append (map (lambda (w) (fz->bytes32 w #t)) words))) + + (define rot32/-25 ((ops32 'fzrot-by) -25)) + (define rot32/-22 ((ops32 'fzrot-by) -22)) + (define rot32/-19 ((ops32 'fzrot-by) -19)) + (define rot32/-18 ((ops32 'fzrot-by) -18)) + (define rot32/-17 ((ops32 'fzrot-by) -17)) + (define rot32/-13 ((ops32 'fzrot-by) -13)) + (define rot32/-11 ((ops32 'fzrot-by) -11)) + (define rot32/-7 ((ops32 'fzrot-by) -7)) + (define rot32/-6 ((ops32 'fzrot-by) -6)) + (define rot32/-2 ((ops32 'fzrot-by) -2)) + (define rot32/10 ((ops32 'fzrot-by) 10)) + + (define shift32/-10 ((ops32 'ufzshift-by) -10)) + (define shift32/-3 ((ops32 'ufzshift-by) -3)) ;; The various "sigma" functions from [SHS] for 256-bit hashes - (define (ss0-32 x) (fzxor (fzrot x -2) (fzrot x -13) (fzrot x -22))) - (define (ss1-32 x) (fzxor (fzrot x -6) (fzrot x -11) (fzrot x -25))) - (define (s0-32 x) (fzxor (fzrot x -7) (fzrot x -18) (ufzshift x -3))) - (define (s1-32 x) (fzxor (fzrot x -17) (fzrot x -19) (ufzshift x -10))) + (define (ss0-32 x) (xor32 (rot32/-2 x) (rot32/-13 x) (rot32/-22 x))) + (define (ss1-32 x) (xor32 (rot32/-6 x) (rot32/-11 x) (rot32/-25 x))) + (define (s0-32 x) (xor32 (rot32/-7 x) (rot32/-18 x) (shift32/-3 x))) + (define (s1-32 x) (xor32 (rot32/-17 x) (rot32/-19 x) (shift32/-10 x))) + + (define (append-hex->bytes . args) + (apply string-append (map hex->bytes args))) + + (define (hex->fz32vec . args) + (list->vector (map hex->fz32 args))) (let ((rmd160-iv (append-hex->bytes "01234567" "89abcdef" "fedcba98" "76543210" "f0e1d2c3")) @@ -80,17 +102,18 @@ "1f83d9ab" "5be0cd19"))) (define rmd160-compress - (letrec ((F fzxor) - (G fzif) - (H (lambda (x y z) (fzxor (fzior (fznot y) x) z))) + (letrec ((F xor32) + (G if32) + (H (lambda (x y z) (xor32 (ior32 (not32 y) x) z))) (I (lambda (x y z) (G z x y))) (J (lambda (x y z) (H y z x))) (FF (lambda (a b c d e x s) - (ufz+ (fzrot (ufz+ a (F b c d) x) s) e))) + (add32 (rot32 (add32 a (F b c d) x) s) e))) (make-op (lambda (func const) - (let ((k (hex->fz const))) + (let ((k (hex->fz32 const))) (lambda (a b c d e x s) - (ufz+ (fzrot (ufz+ a (func b c d) x k) s) e)))))) + (add32 (rot32 (add32 a (func b c d) x k) s) + e)))))) ;; Floor of 2^30 times square and cube roots of (2 3 5 7) (let ((ops1 (vector FF (make-op G "5a827999") @@ -126,12 +149,13 @@ (h3 (loadw32 hash 3)) (h4 (loadw32 hash 4)) (X (make-vector 16))) - (do ((t 0 (+ t 1))) ((= t 16)) + (do ((t 0 (fx+/wrap t 1))) ((fx= t 16)) (vector-set! X t (loadw32 block t))) (let loop ((t 0) (a1 h0) (b1 h1) (c1 h2) (d1 h3) (e1 h4) (a2 h0) (b2 h1) (c2 h2) (d2 h3) (e2 h4)) - (if (= t 80) - (pack-words (map ufz+ (list h1 h2 h3 h4 h0) + (if (fx= t 80) + (pack-words32 (map add32 + (list h1 h2 h3 h4 h0) (list c1 d1 e1 a1 b1) (list d2 e2 a2 b2 c2))) (let ((round (fxshift/unsigned t -4))) @@ -140,17 +164,17 @@ (op2 (vector-ref ops2 round)) (i1 (vector-ref W1 t)) (i2 (vector-ref W2 t))) - (loop (+ t 1) + (loop (fx+/wrap t 1) e1 (op1 a1 b1 c1 d1 e1 (vector-ref X i1) (vector-ref shifts i1)) - b1 (fzrot c1 10) d1 + b1 (rot32/10 c1) d1 e2 (op2 a2 b2 c2 d2 e2 (vector-ref X i2) (vector-ref shifts i2)) - b2 (fzrot c2 10) d2)))))))))) + b2 (rot32/10 c2) d2)))))))))) (define sha256-compress ;; First 32 fractional bits of cube roots of first 64 primes - (let ((K (hex->fz-vec + (let ((K (hex->fz32vec "428a2f98" "71374491" "b5c0fbcf" "e9b5dba5" "3956c25b" "59f111f1" "923f82a4" "ab1c5ed5" "d807aa98" "12835b01" "243185be" "550c7dc3" @@ -173,31 +197,32 @@ (h2 (loadbw32 hash 2)) (h3 (loadbw32 hash 3)) (h4 (loadbw32 hash 4)) (h5 (loadbw32 hash 5)) (h6 (loadbw32 hash 6)) (h7 (loadbw32 hash 7))) - (do ((t 0 (+ t 1))) ((= t 16)) + (do ((t 0 (fx+/wrap t 1))) ((fx= t 16)) (vector-set! W t (loadbw32 block t))) - (do ((t 16 (+ t 1))) ((= t 64)) - (vector-set! W t (ufz+ (s1-32 (vector-ref W (- t 2))) - (vector-ref W (- t 7)) - (s0-32 (vector-ref W (- t 15))) - (vector-ref W (- t 16))))) + (do ((t 16 (fx+/wrap t 1))) ((fx= t 64)) + (vector-set! W t (add32 (s1-32 (vector-ref W (fx-/wrap t 2))) + (vector-ref W (fx-/wrap t 7)) + (s0-32 (vector-ref W (fx-/wrap t 15))) + (vector-ref W (fx-/wrap t 16))))) (let loop ((t 0) (a h0) (b h1) (c h2) (d h3) (e h4) (f h5) (g h6) (h h7)) - (if (= t 64) - (packb-words (map ufz+ (list a b c d e f g h) + (if (fx= t 64) + (packb-words32 (map add32 (list a b c d e f g h) (list h0 h1 h2 h3 h4 h5 h6 h7))) - (let* ((temp1 (ufz+ (ss1-32 e) - (fzif e f g) + (let* ((temp1 (add32 (ss1-32 e) + (if32 e f g) h (vector-ref K t) (vector-ref W t))) - (temp2 (ufz+ (ss0-32 a) - (fzmaj a b c) + (temp2 (add32 (ss0-32 a) + (maj32 a b c) temp1))) - (loop (+ t 1) temp2 a b c (ufz+ d temp1) e f g)))))))) + (loop (fx+/wrap t 1) + temp2 a b c (add32 d temp1) e f g)))))))) - (let ((ripemd160 (merkle-damgard 64 64 #f rmd160-compress 0 rmd160-iv)) - (sha256 (merkle-damgard 64 64 #t sha256-compress 0 sha256-iv))) - (export ripemd160 sha256)))) + (let ((ripemd160 (merkle-damgard 64 ops64 #f rmd160-compress 0 rmd160-iv)) + (sha256 (merkle-damgard 64 ops64 #t sha256-compress 0 sha256-iv))) + (export ripemd160 sha256))))) ;;; References diff -uNr a/gbw-signer/manifest b/gbw-signer/manifest --- a/gbw-signer/manifest f831eb0f6a06a7497c504b8d961096daa03c68cdfc74ebb044e3636774639a91d5c27d56693b5401602798aa849066288d852501c6f2746c853ac94b1634aeb4 +++ b/gbw-signer/manifest 7b44f92a54e02a27aa8dd3d7e333e7828bd393e5eba6cf501ada221ff6b49dc5e3055cb004f0d5064c490e1db7819853f05c5e40909c4423f4610f1033236539 @@ -1,2 +1,3 @@ 711740 gbw-signer_subdir_genesis jfw Offline signer component of gbw, the Gales Bitcoin Wallet. Reissued to follow various conventions: top-level project subdir, lowercase manifest filename, README at project level. (File renaming only; pending content changes are to follow.) 711740 gbw-signer_usrbin jfw Change command symlink from /command/gbw-signer to /usr/bin/gbw-signer and likewise for the referenced gscm binary. Formalize the installed command list at package/commands. Update README and bump version to reflect the packaging changes. +739066 gbw-signer_static_bit_ops_1 jfw Restructure the library of arithmetic and bitwise operators on fixed-width integers to be separately instantiated for given bit widths, rather than tracking the width dynamically in the operand objects (reindenting deliberately suppressed for patch readability). This saves substantial redundant runtime computations, data wrangling and checking, at a cost of less helpful error reporting and slightly more setup for callers. Correct an ass-backwards comment as to which bits are padding; expand comments generally, mainly to note variable ranges. Replace much generic arithmetic with with faster fixnum arithmetic where applicable. Move toward curried forms of bit shift and rotation operators to allow pre-analysis of shift size. Update hash function library for the changes. Bump version and fix "check" script to find the code by relative path rather than globally active version. Hashing speedup on my machine (x86_64, gscm 0.40.6) is around 4x. diff -uNr a/gbw-signer/package/check b/gbw-signer/package/check --- a/gbw-signer/package/check 1eb5af89535307dd9a15c0ea5364082c0b527c4ab1d29d11fb18b1ce196ab5074ffb1ac75f4a5b54ee80ae8e946e87eee54dcbf1d7b4e868c348aef89e769392 +++ b/gbw-signer/package/check 50facd3553c7cb1dfe1fdcf44687f38103d28f1975c8e4408af513e358d26b37179f617a94d823f1c7229efe7a639b4a2663c49fd9e1bdc66f7a63874567aa62 @@ -1,2 +1,2 @@ #!/bin/sh -/usr/bin/gbw-signer test +./command/gbw-signer test diff -uNr a/gbw-signer/package/install b/gbw-signer/package/install --- a/gbw-signer/package/install 9cc58827e8d27d59c7ddddfc262a1237158b76ea90fbdbd1c36be90f3f38c293a884168f3fb71917072e2fc99a7a70df4329bc43601480acd9c01cce759cf5e6 +++ b/gbw-signer/package/install 317db1eab91df4649c6be0554773da917cc7ae33040d0c688d6b973b22cb09ab8ebc7ecd99bc4f94e890e99ad3caa2fa2ea32111365a6081d8e2007d26a47107 @@ -2,7 +2,7 @@ set -e P=gbw-signer -V=2 +V=3 cd /package/$P-$V # Versioned path duplicated in: