Coverage report: /home/ellis/comp/ext/ironclad/src/digests/sha512.lisp

Kind	Covered	All	%
expression	2	317	0.6
branch	0	4	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; sha512.lisp -- implementation of SHA-384/512 from NIST

2

(in-package :crypto)

3

(in-ironclad-readtable)

4

5

(define-digest-registers (sha384 :endian :big :size 8 :digest-registers 6)

6

(a #xCBBB9D5DC1059ED8)

7

(b #x629A292A367CD507)

8

(c #x9159015A3070DD17)

9

(d #x152FECD8F70E5939)

10

(e #x67332667FFC00B31)

11

(f #x8EB44A8768581511)

12

(g #xDB0C2E0D64F98FA7)

13

(h #x47B5481DBEFA4FA4))

14

15

(defconst +pristine-sha384-registers+ (initial-sha384-regs))

16

17

(define-digest-registers (sha512 :endian :big :size 8)

18

(a #x6A09E667F3BCC908)

19

(b #xBB67AE8584CAA73B)

20

(c #x3C6EF372FE94F82B)

21

(d #xA54FF53A5F1D36F1)

22

(e #x510E527FADE682D1)

23

(f #x9B05688C2B3E6C1F)

24

(g #x1F83D9ABFB41BD6B)

25

(h #x5BE0CD19137E2179))

26

27

(defconst +pristine-sha512-registers+ (initial-sha512-regs))

28

29

(defconst +sha512-round-constants+

30

#64@(#x428A2F98D728AE22 #x7137449123EF65CD #xB5C0FBCFEC4D3B2F #xE9B5DBA58189DBBC

31

#x3956C25BF348B538 #x59F111F1B605D019 #x923F82A4AF194F9B #xAB1C5ED5DA6D8118

32

#xD807AA98A3030242 #x12835B0145706FBE #x243185BE4EE4B28C #x550C7DC3D5FFB4E2

33

#x72BE5D74F27B896F #x80DEB1FE3B1696B1 #x9BDC06A725C71235 #xC19BF174CF692694

34

#xE49B69C19EF14AD2 #xEFBE4786384F25E3 #x0FC19DC68B8CD5B5 #x240CA1CC77AC9C65

35

#x2DE92C6F592B0275 #x4A7484AA6EA6E483 #x5CB0A9DCBD41FBD4 #x76F988DA831153B5

36

#x983E5152EE66DFAB #xA831C66D2DB43210 #xB00327C898FB213F #xBF597FC7BEEF0EE4

37

#xC6E00BF33DA88FC2 #xD5A79147930AA725 #x06CA6351E003826F #x142929670A0E6E70

38

#x27B70A8546D22FFC #x2E1B21385C26C926 #x4D2C6DFC5AC42AED #x53380D139D95B3DF

39

#x650A73548BAF63DE #x766A0ABB3C77B2A8 #x81C2C92E47EDAEE6 #x92722C851482353B

40

#xA2BFE8A14CF10364 #xA81A664BBC423001 #xC24B8B70D0F89791 #xC76C51A30654BE30

41

#xD192E819D6EF5218 #xD69906245565A910 #xF40E35855771202A #x106AA07032BBD1B8

42

#x19A4C116B8D2D0C8 #x1E376C085141AB53 #x2748774CDF8EEB99 #x34B0BCB5E19B48A8

43

#x391C0CB3C5C95A63 #x4ED8AA4AE3418ACB #x5B9CCA4F7763E373 #x682E6FF3D6B2B8A3

44

#x748F82EE5DEFB2FC #x78A5636F43172F60 #x84C87814A1F0AB72 #x8CC702081A6439EC

45

#x90BEFFFA23631E28 #xA4506CEBDE82BDE9 #xBEF9A3F7B2C67915 #xC67178F2E372532B

46

#xCA273ECEEA26619C #xD186B8C721C0C207 #xEADA7DD6CDE0EB1E #xF57D4F7FEE6ED178

47

#x06F067AA72176FBA #x0A637DC5A2C898A6 #x113F9804BEF90DAE #x1B710B35131C471B

48

#x28DB77F523047D84 #x32CAAB7B40C72493 #x3C9EBE0A15C9BEBC #x431D67C49C100D4C

49

#x4CC5D4BECB3E42B6 #x597F299CFC657E2A #x5FCB6FAB3AD6FAEC #x6C44198C4A475817))

50

51

(defun update-sha512-block (regs block)

52

(declare (type sha512-regs regs))

53

(declare (type (simple-array (unsigned-byte 64) (80)) block)

54

#.(burn-baby-burn))

55

(let ((a (sha512-regs-a regs)) (b (sha512-regs-b regs))

56

(c (sha512-regs-c regs)) (d (sha512-regs-d regs))

57

(e (sha512-regs-e regs)) (f (sha512-regs-f regs))

58

(g (sha512-regs-g regs)) (h (sha512-regs-h regs)))

59

(flet ((rho (x r1 r2 r3)

60

(logxor (ror64 x r1) (ror64 x r2) (ror64 x r3))))

61

;; FIXME: Implement inline 64-bit rotates for x86-64 SBCL.

62

;; #+ironclad-fast-mod64-arithmetic

63

;; (declare (inline rho))

64

(macrolet ((sha512-round (i a b c d e f g h)

65

`(let ((x (mod64+ (rho ,e 14 18 41)

66

(mod64+ (logxor (logand ,e ,f)

67

                                                      (logandc1 ,e ,g))

68

(mod64+ (aref block ,i)

69

                                                      (aref +sha512-round-constants+ ,i))))))

70

(setf ,d (mod64+ ,d (mod64+ ,h x))

71

,h (mod64+ ,h

72

                                        (mod64+ x (mod64+ (rho ,a 28 34 39)

73

                                                          (logxor (logand ,a ,b)

74

                                                                  (logand ,a ,c)

75

                                                                  (logand ,b ,c)))))))))

76

#.(let ((xvars (make-circular-list 'a 'b 'c 'd 'e 'f 'g 'h)))

77

(loop for i from 0 below 80

78

for vars on xvars by #'(lambda (x) (nthcdr 7 x))

79

collect `(sha512-round ,i ,@(circular-list-subseq vars 0 8)) into forms

80

finally (return `(progn ,@forms))))

81

#.(loop for slot in '(a b c d e f g h)

82

collect (let ((regs-accessor (symbolicate '#:sha512-regs- slot)))

83

`(setf (,regs-accessor regs)

84

(mod64+ (,regs-accessor regs) ,slot))) into forms

85

finally (return `(progn ,@forms)))))))

86

87

(defun sha512-expand-block (block)

88

(declare (type (simple-array (unsigned-byte 64) (80)) block)

89

#.(burn-baby-burn))

90

(flet ((sigma (x r1 r2 r3)

91

(logxor (ror64 x r1) (ror64 x r2) (ash x (- r3)))))

92

#+ironclad-fast-mod64-arithmetic (declare (inline sigma))

93

(loop for i from 16 below 80 do

94

(setf (aref block i)

95

(mod64+ (sigma (aref block (- i 2)) 19 61 6)

96

(mod64+ (aref block (- i 7))

97

(mod64+ (sigma (aref block (- i 15)) 1 8 7)

98

(aref block (- i 16)))))))

99

(values)))

100

101

;;; mid-level

102

(defstruct (sha512

103

(:constructor %make-sha512-digest

104

(&aux (buffer (make-array 128 :element-type '(unsigned-byte 8)))))

105

(:copier nil)

106

(:include mdx))

107

(regs (initial-sha512-regs) :type sha512-regs :read-only t)

108

(block (make-array 80 :element-type '(unsigned-byte 64)) :read-only t

109

:type (simple-array (unsigned-byte 64) (80))))

110

111

(defstruct (sha384

112

(:include sha512)

113

(:constructor %make-sha384-digest

114

(&aux (regs (initial-sha384-regs))

115

(buffer (make-array 128 :element-type '(unsigned-byte 8)))))

116

(:copier nil)))

117

118

(defmethod reinitialize-instance ((state sha512) &rest initargs)

119

(declare (ignore initargs))

120

;; Some versions of Clozure CCL have a bug where the elements of

121

;; +PRISTINE-SHA512-REGISTERS+ are considered to be negative. Force

122

;; the compiler to see them as positive.

123

(replace (sha512-regs state) +pristine-sha512-registers+)

124

(setf (sha512-amount state) 0

125

(sha512-buffer-index state) 0)

126

state)

127

128

(defmethod reinitialize-instance ((state sha384) &rest initargs)

129

(declare (ignore initargs))

130

;; Some versions of Clozure CCL have a bug where the elements of

131

;; +PRISTINE-SHA384-REGISTERS+ are considered to be negative. Force

132

;; the compiler to see them as positive.

133

(replace (sha384-regs state) +pristine-sha384-registers+)

134

(setf (sha384-amount state) 0

135

(sha384-buffer-index state) 0)

136

state)

137

138

(defmethod copy-digest ((state sha512) &optional copy)

139

(check-type copy (or null sha512))

140

(let ((copy (if copy

141

copy

142

(etypecase state

143

(sha384 (%make-sha384-digest))

144

(sha512 (%make-sha512-digest))))))

145

(declare (type sha512 copy))

146

(replace (sha512-regs copy) (sha512-regs state))

147

(replace (sha512-buffer copy) (sha512-buffer state))

148

(setf (sha512-amount copy) (sha512-amount state)

149

(sha512-buffer-index copy) (sha512-buffer-index state))

150

copy))

151

152

(define-digest-updater sha512

153

(flet ((compress (state sequence offset)

154

(let ((block (sha512-block state)))

155

(fill-block-ub8-be/64 block sequence offset)

156

(sha512-expand-block block)

157

(update-sha512-block (sha512-regs state) block))))

158

(declare (dynamic-extent #'compress))

159

(declare (notinline mdx-updater))

160

(mdx-updater state #'compress sequence start end)))

161

162

(define-digest-finalizer ((sha512 64) (sha384 48))

163

(let ((regs (sha512-regs state))

164

(block (sha512-block state))

165

(buffer (sha512-buffer state))

166

(buffer-index (sha512-buffer-index state))

167

(total-length (* 8 (sha512-amount state))))

168

(declare (type sha512-regs regs)

169

(type (integer 0 127) buffer-index)

170

(type (simple-array (unsigned-byte 64) (80)) block)

171

(type (simple-array (unsigned-byte 8) (128)) buffer))

172

(setf (aref buffer buffer-index) #x80)

173

(when (> buffer-index 111)

174

(loop for index of-type (integer 0 128)

175

from (1+ buffer-index) below 128

176

do (setf (aref buffer index) #x00))

177

(fill-block-ub8-be/64 block buffer 0)

178

(sha512-expand-block block)

179

(update-sha512-block regs block)

180

(loop for index of-type (integer 0 16)

181

from 0 below 16

182

do (setf (aref block index) #x00000000)))

183

(when (<= buffer-index 111)

184

(loop for index of-type (integer 0 128)

185

from (1+ buffer-index) below 128

186

do (setf (aref buffer index) #x00))

187

;; copy the data to BLOCK prematurely

188

(fill-block-ub8-be/64 block buffer 0))

189

;; fill in the remaining block data

190

(setf (aref block 15) total-length)

191

(sha512-expand-block block)

192

(update-sha512-block regs block)

193

(finalize-registers state regs)))

194

195

(defdigest sha512 :digest-length 64 :block-length 128)

196

(defdigest sha384 :digest-length 48 :block-length 128)