diff -uNr a/gbw-signer/library/bit-ops.scm b/gbw-signer/library/bit-ops.scm --- a/gbw-signer/library/bit-ops.scm e1a82272490faa005ebb3ab2785dffa511d6b55e0ed59199da2ff4ff2688d384e6334f5d42139a430062a02e609ac2587e1294a796087be6f10d7e720c6aa4b1 +++ b/gbw-signer/library/bit-ops.scm cb5f64558bef7b03158f894385f962d1ace54c97b596287a9538637db6d26aecd711b0b625996ab4edd01e3014aa9b528a3a91688cb646eaf5405b6647f45464 @@ -47,143 +47,143 @@ (define (word->ufz w) (cons w (repeat 0 (fx-/wrap word-count 1)))) - (define (ufz+/pair a b) - (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))))))) - - ;; !! UNTESTED !! - ;(define (ufz-/pair a b) - ; (let loop ((a a) (b b) (carry 0) (acc '())) - ; (if (null? a) (press-fz acc) - ; (call-with-values - ; (lambda () (fx-/borrow-unsigned (car a) (car b) carry)) - ; (lambda (diff carry) - ; (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 < fz-width . - (define (shift-up-by bits) - ;; XXX slow - maybe provide a simultaneous fixnum quotient/remainder , or precompute a lookup table (0 to (- fz-width 1)) ? - (let ((whole-words (quotient bits *fixnum-width*)) - (bits (remainder 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 - (lambda (a) - (do ((words a (cdr words)) - (carry 0 (fxshift/unsigned (car words) carry-shift)) - (acc (repeat 0 whole-words) - (cons (fxior (fxshift (car words) bits) carry) 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 < fz-width . - (define (shift-down-by/unsigned bits) - ; XXX slow - as above - (let ((whole-words (quotient 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* - (lambda (a) - (do ((words (reverse (list-tail a 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) acc)))))) - - ;; Front-end for unsigned shifts. - ;; Constant time w.r.t. FZ value only (NOT bits). - (define (ufzshift-by bits) - (cond ((zero? bits) (lambda (a) a)) - ((>= (abs bits) fz-width) (lambda (a) (fz0))) - ((fx< 0 bits) (shift-up-by bits)) - (else (shift-down-by/unsigned (fx-/wrap bits))))) - - ;; Bit rotation: signedness doesn't matter. - ;; 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) - (cond ((fx<=/unsigned fz-width bits) ; also catches negatives - (error "fzrot: bits out of range:" bits)) - ((fx= 0 bits) a) - ;; 0 < bits < fz-width - ;; XXX slow due to separate shifts - (else (fzior ((shift-up-by bits) a) - ((shift-down-by/unsigned (fx-/wrap fz-width bits)) - a))))) - - ;; Curried variant allowing arbitrary integer rotations, pre-reduced. Faster than fzrot if you can reuse the returned procedure for a set shift amount. - (define (fzrot-by bits) - (let ((reduced (modulo bits fz-width))) - (if (fx= 0 reduced) - (lambda (a) a) - ;; 0 < reduced < fz-width - ;; XXX slow due to separate shifts - (let ((shift-up (shift-up-by reduced)) - (shift-down (shift-down-by/unsigned - (fx-/wrap fz-width reduced)))) - (lambda (a) - (fzior (shift-up a) - (shift-down a))))))) - - (define (fznot a) - (press-fz (reverse-map1 fxnot a))) - - ;; 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) - (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 (fx+/wrap bit-pos 8)) - (word (fxior word (fxshift byte bit-pos)))) - ;; 8 <= bit-pos <= (+ *fixnum-width* 8) - (if (fx<=/unsigned bit-pos *fixnum-width*) - ;; whole byte fits in current word - (loop bit-pos (fx+/wrap k 1) word acc) - ;; else spill to next word - ;; 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 '())) + (define (ufz+/pair a b) + (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))))))) + + ;; !! UNTESTED !! + ;(define (ufz-/pair a b) + ; (let loop ((a a) (b b) (carry 0) (acc '())) + ; (if (null? a) (press-fz acc) + ; (call-with-values + ; (lambda () (fx-/borrow-unsigned (car a) (car b) carry)) + ; (lambda (diff carry) + ; (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 < fz-width . + (define (shift-up-by bits) + ;; XXX slow - maybe provide a simultaneous fixnum quotient/remainder , or precompute a lookup table (0 to (- fz-width 1)) ? + (let ((whole-words (quotient bits *fixnum-width*)) + (bits (remainder 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 + (lambda (a) + (do ((words a (cdr words)) + (carry 0 (fxshift/unsigned (car words) carry-shift)) + (acc (repeat 0 whole-words) + (cons (fxior (fxshift (car words) bits) carry) 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 < fz-width . + (define (shift-down-by/unsigned bits) + ; XXX slow - as above + (let ((whole-words (quotient 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* + (lambda (a) + (do ((words (reverse (list-tail a 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) acc)))))) + + ;; Front-end for unsigned shifts. + ;; Constant time w.r.t. FZ value only (NOT bits). + (define (ufzshift-by bits) + (cond ((zero? bits) (lambda (a) a)) + ((>= (abs bits) fz-width) (lambda (a) (fz0))) + ((fx< 0 bits) (shift-up-by bits)) + (else (shift-down-by/unsigned (fx-/wrap bits))))) + + ;; Bit rotation: signedness doesn't matter. + ;; 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) + (cond ((fx<=/unsigned fz-width bits) ; also catches negatives + (error "fzrot: bits out of range:" bits)) + ((fx= 0 bits) a) + ;; 0 < bits < fz-width + ;; XXX slow due to separate shifts + (else (fzior ((shift-up-by bits) a) + ((shift-down-by/unsigned (fx-/wrap fz-width bits)) + a))))) + + ;; Curried variant allowing arbitrary integer rotations, pre-reduced. Faster than fzrot if you can reuse the returned procedure for a set shift amount. + (define (fzrot-by bits) + (let ((reduced (modulo bits fz-width))) + (if (fx= 0 reduced) + (lambda (a) a) + ;; 0 < reduced < fz-width + ;; XXX slow due to separate shifts + (let ((shift-up (shift-up-by reduced)) + (shift-down (shift-down-by/unsigned + (fx-/wrap fz-width reduced)))) + (lambda (a) + (fzior (shift-up a) + (shift-down a))))))) + + (define (fznot a) + (press-fz (reverse-map1 fxnot a))) + + ;; 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) + (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 (fx+/wrap bit-pos 8)) + (word (fxior word (fxshift byte bit-pos)))) + ;; 8 <= bit-pos <= (+ *fixnum-width* 8) + (if (fx<=/unsigned bit-pos *fixnum-width*) + ;; whole byte fits in current word + (loop bit-pos (fx+/wrap k 1) word acc) + ;; else spill to next word + ;; 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) + ;; Construct octet string from a multiple-of-8 bit wide FZ. + (define (fz->bytes a big-endian) (define nbytes (fxshift fz-width -3)) (define buf (delay (make-string nbytes))) (define set-byte! @@ -203,17 +203,17 @@ (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 (fx+/wrap k 1) word words)) - ;; else fill in from next word - ;; bit-pos > *fixnum-width* - (let ((word (car 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))))))) + ;; whole byte contained in current word + (begin (set-byte! k byte) + (loop bit-pos (fx+/wrap k 1) word words)) + ;; else fill in from next word + ;; bit-pos > *fixnum-width* + (let ((word (car 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)) @@ -283,17 +283,17 @@ (bytes (make-string len))) (define (loop i j) (if (fx= i len) bytes - (let ((hi (string-ref h j)) - (lo (string-ref h (fx+/wrap j 1)))) - (string-set! bytes i - (integer->char - (fxior (fxshift (hexdigit->integer hi) 4) - (hexdigit->integer lo)))) - (loop (fx+/wrap i 1) (fx+/wrap j 2))))) + (let ((hi (string-ref h j)) + (lo (string-ref h (fx+/wrap j 1)))) + (string-set! bytes i + (integer->char + (fxior (fxshift (hexdigit->integer hi) 4) + (hexdigit->integer lo)))) + (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)))) - (loop 1 1))))) + (begin (string-set! bytes 0 (integer->char (hexdigit->integer + (string-ref h 0)))) + (loop 1 1))))) (define (bytes->hex b) (let* ((len (string-length b)) diff -uNr a/gbw-signer/library/hashes.scm b/gbw-signer/library/hashes.scm --- a/gbw-signer/library/hashes.scm 4683bcb6d89c5c16f0c8e52e4464c806a98060e73227a0b6957ec5570717f57d086b668b319665d3e7a03fa8c744b6f7348889d4ea68122e0d29cef2365184c7 +++ b/gbw-signer/library/hashes.scm 5d2f8e972d0130ec0db51dad5c5efe32cfdeea105ca66720ac3784acfb3b4ae3b638a377298bab543a2c58ea7b2edaca63c2d27c162bfa23e912dbd69c4ae70f @@ -54,12 +54,12 @@ (define fz->bytes32 (ops32 'fz->bytes)) (define hex->fz32 (ops32 'hex->fz)) - ;; Load aligned word from byte string, little/big endian + ;; Load aligned word from byte string, little/big endian (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 + ;; Pack words as byte string, little/big endian (define (pack-words32 words) (apply string-append (map (lambda (w) (fz->bytes32 w #f)) words))) (define (packb-words32 words) @@ -80,7 +80,7 @@ (define shift32/-10 ((ops32 'ufzshift-by) -10)) (define shift32/-3 ((ops32 'ufzshift-by) -3)) - ;; The various "sigma" functions from [SHS] for 256-bit hashes + ;; The various "sigma" functions from [SHS] for 256-bit hashes (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))) @@ -92,137 +92,137 @@ (define (hex->fz32vec . args) (list->vector (map hex->fz32 args))) - (let ((rmd160-iv (append-hex->bytes - "01234567" "89abcdef" "fedcba98" "76543210" "f0e1d2c3")) - ;; First 32 fractional bits of square roots of first 8 primes - (sha256-iv (append-hex->bytes - "6a09e667" "bb67ae85" - "3c6ef372" "a54ff53a" - "510e527f" "9b05688c" - "1f83d9ab" "5be0cd19"))) - - (define rmd160-compress - (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) - (add32 (rot32 (add32 a (F b c d) x) s) e))) - (make-op (lambda (func const) - (let ((k (hex->fz32 const))) - (lambda (a b c d e x s) - (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") - (make-op H "6ed9eba1") - (make-op I "8f1bbcdc") - (make-op J "a953fd4e"))) - (ops2 (vector (make-op J "50a28be6") - (make-op I "5c4dd124") - (make-op H "6d703ef3") - (make-op G "7a6d76e9") - FF)) - (rho (lambda (i) - (vector-ref '#(7 4 13 1 10 6 15 3 12 0 9 5 2 14 11 8) i))) - (pi (lambda (i) (fxand (+ (* 9 i) 5) 15))) - (shifts '#(#(11 14 15 12 5 8 7 9 11 13 14 15 6 7 9 8) - #(12 13 11 15 6 9 9 7 12 15 11 13 7 8 7 7) - #(13 15 14 11 7 7 6 8 13 14 13 12 5 5 6 9) - #(14 11 12 14 8 6 5 5 15 12 15 14 9 9 8 6) - #(15 12 13 13 9 5 8 6 14 11 12 11 8 6 5 5))) - (W1 (make-vector 80)) - (W2 (make-vector 80))) - (do ((t 0 (+ t 1))) ((= t 16)) - (vector-set! W1 t t) - (vector-set! W2 t (pi t))) - (do ((t 16 (+ t 1))) ((= t 80)) - (vector-set! W1 t (rho (vector-ref W1 (- t 16)))) - (vector-set! W2 t (rho (vector-ref W2 (- t 16))))) - + (let ((rmd160-iv (append-hex->bytes + "01234567" "89abcdef" "fedcba98" "76543210" "f0e1d2c3")) + ;; First 32 fractional bits of square roots of first 8 primes + (sha256-iv (append-hex->bytes + "6a09e667" "bb67ae85" + "3c6ef372" "a54ff53a" + "510e527f" "9b05688c" + "1f83d9ab" "5be0cd19"))) + + (define rmd160-compress + (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) + (add32 (rot32 (add32 a (F b c d) x) s) e))) + (make-op (lambda (func const) + (let ((k (hex->fz32 const))) + (lambda (a b c d e x s) + (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") + (make-op H "6ed9eba1") + (make-op I "8f1bbcdc") + (make-op J "a953fd4e"))) + (ops2 (vector (make-op J "50a28be6") + (make-op I "5c4dd124") + (make-op H "6d703ef3") + (make-op G "7a6d76e9") + FF)) + (rho (lambda (i) + (vector-ref '#(7 4 13 1 10 6 15 3 12 0 9 5 2 14 11 8) i))) + (pi (lambda (i) (fxand (+ (* 9 i) 5) 15))) + (shifts '#(#(11 14 15 12 5 8 7 9 11 13 14 15 6 7 9 8) + #(12 13 11 15 6 9 9 7 12 15 11 13 7 8 7 7) + #(13 15 14 11 7 7 6 8 13 14 13 12 5 5 6 9) + #(14 11 12 14 8 6 5 5 15 12 15 14 9 9 8 6) + #(15 12 13 13 9 5 8 6 14 11 12 11 8 6 5 5))) + (W1 (make-vector 80)) + (W2 (make-vector 80))) + (do ((t 0 (+ t 1))) ((= t 16)) + (vector-set! W1 t t) + (vector-set! W2 t (pi t))) + (do ((t 16 (+ t 1))) ((= t 80)) + (vector-set! W1 t (rho (vector-ref W1 (- t 16)))) + (vector-set! W2 t (rho (vector-ref W2 (- t 16))))) + + (lambda (hash block) + (let ((h0 (loadw32 hash 0)) + (h1 (loadw32 hash 1)) + (h2 (loadw32 hash 2)) + (h3 (loadw32 hash 3)) + (h4 (loadw32 hash 4)) + (X (make-vector 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 (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))) + (let ((shifts (vector-ref shifts round)) + (op1 (vector-ref ops1 round)) + (op2 (vector-ref ops2 round)) + (i1 (vector-ref W1 t)) + (i2 (vector-ref W2 t))) + (loop (fx+/wrap t 1) + e1 (op1 a1 b1 c1 d1 e1 (vector-ref X i1) + (vector-ref shifts i1)) + b1 (rot32/10 c1) d1 + e2 (op2 a2 b2 c2 d2 e2 (vector-ref X i2) + (vector-ref shifts i2)) + b2 (rot32/10 c2) d2)))))))))) + + (define sha256-compress + ;; First 32 fractional bits of cube roots of first 64 primes + (let ((K (hex->fz32vec + "428a2f98" "71374491" "b5c0fbcf" "e9b5dba5" + "3956c25b" "59f111f1" "923f82a4" "ab1c5ed5" + "d807aa98" "12835b01" "243185be" "550c7dc3" + "72be5d74" "80deb1fe" "9bdc06a7" "c19bf174" + "e49b69c1" "efbe4786" "0fc19dc6" "240ca1cc" + "2de92c6f" "4a7484aa" "5cb0a9dc" "76f988da" + "983e5152" "a831c66d" "b00327c8" "bf597fc7" + "c6e00bf3" "d5a79147" "06ca6351" "14292967" + "27b70a85" "2e1b2138" "4d2c6dfc" "53380d13" + "650a7354" "766a0abb" "81c2c92e" "92722c85" + "a2bfe8a1" "a81a664b" "c24b8b70" "c76c51a3" + "d192e819" "d6990624" "f40e3585" "106aa070" + "19a4c116" "1e376c08" "2748774c" "34b0bcb5" + "391c0cb3" "4ed8aa4a" "5b9cca4f" "682e6ff3" + "748f82ee" "78a5636f" "84c87814" "8cc70208" + "90befffa" "a4506ceb" "bef9a3f7" "c67178f2"))) (lambda (hash block) - (let ((h0 (loadw32 hash 0)) - (h1 (loadw32 hash 1)) - (h2 (loadw32 hash 2)) - (h3 (loadw32 hash 3)) - (h4 (loadw32 hash 4)) - (X (make-vector 16))) + (let ((W (make-vector 64)) + (h0 (loadbw32 hash 0)) (h1 (loadbw32 hash 1)) + (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 (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 (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))) - (let ((shifts (vector-ref shifts round)) - (op1 (vector-ref ops1 round)) - (op2 (vector-ref ops2 round)) - (i1 (vector-ref W1 t)) - (i2 (vector-ref W2 t))) - (loop (fx+/wrap t 1) - e1 (op1 a1 b1 c1 d1 e1 (vector-ref X i1) - (vector-ref shifts i1)) - b1 (rot32/10 c1) d1 - e2 (op2 a2 b2 c2 d2 e2 (vector-ref X i2) - (vector-ref shifts i2)) - b2 (rot32/10 c2) d2)))))))))) - - (define sha256-compress - ;; First 32 fractional bits of cube roots of first 64 primes - (let ((K (hex->fz32vec - "428a2f98" "71374491" "b5c0fbcf" "e9b5dba5" - "3956c25b" "59f111f1" "923f82a4" "ab1c5ed5" - "d807aa98" "12835b01" "243185be" "550c7dc3" - "72be5d74" "80deb1fe" "9bdc06a7" "c19bf174" - "e49b69c1" "efbe4786" "0fc19dc6" "240ca1cc" - "2de92c6f" "4a7484aa" "5cb0a9dc" "76f988da" - "983e5152" "a831c66d" "b00327c8" "bf597fc7" - "c6e00bf3" "d5a79147" "06ca6351" "14292967" - "27b70a85" "2e1b2138" "4d2c6dfc" "53380d13" - "650a7354" "766a0abb" "81c2c92e" "92722c85" - "a2bfe8a1" "a81a664b" "c24b8b70" "c76c51a3" - "d192e819" "d6990624" "f40e3585" "106aa070" - "19a4c116" "1e376c08" "2748774c" "34b0bcb5" - "391c0cb3" "4ed8aa4a" "5b9cca4f" "682e6ff3" - "748f82ee" "78a5636f" "84c87814" "8cc70208" - "90befffa" "a4506ceb" "bef9a3f7" "c67178f2"))) - (lambda (hash block) - (let ((W (make-vector 64)) - (h0 (loadbw32 hash 0)) (h1 (loadbw32 hash 1)) - (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 (fx+/wrap t 1))) ((fx= t 16)) - (vector-set! W t (loadbw32 block t))) - (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 (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 (add32 (ss1-32 e) - (if32 e f g) - h - (vector-ref K t) - (vector-ref W t))) - (temp2 (add32 (ss0-32 a) - (maj32 a b c) - temp1))) - (loop (fx+/wrap t 1) - temp2 a b c (add32 d temp1) e f g)))))))) - - (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))))) + (vector-set! W t (loadbw32 block t))) + (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 (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 (add32 (ss1-32 e) + (if32 e f g) + h + (vector-ref K t) + (vector-ref W t))) + (temp2 (add32 (ss0-32 a) + (maj32 a b c) + temp1))) + (loop (fx+/wrap t 1) + temp2 a b c (add32 d temp1) e f g)))))))) + + (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 56d65bd8fb8856d2da1d230b2182198ff27a62f947ccc0e4ee3b1551cd780f70cbef27dbeeb103ba4911a1d39b164e15cf444eb2d9bcd3d9507aa3fd9007adaa +++ b/gbw-signer/manifest dd4493b1b03bf16a25c69324ecf2f82e9d130afeae7f4d5d8c53aee07e251c7ba1e6cfbe4ee72c5dc5f9700ccb2df92fa000a2c3b59f4756256df36c7b939afe @@ -2,3 +2,4 @@ 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. 739066 gbw-signer_static_bit_ops_2 jfw Further optimize shifts and rotations as hinted in comments by propagating curried arguments to the internals, allowing precomputed divisions. Total hashing speedup for the series increases to 5x. +739066 gbw-signer_static_bit_ops_reindent jfw Full automated reindent of lisp code affected by this series. This will make for dreadful patch reading; perhaps best to verify it instead by doing your own reindent on the affected files in their prior state, using a suitably-configured editor, and comparing results to the patch output.