| [13075] | 1 | ;;; Copyright 2009 Clozure Associates
|
|---|
| 2 | ;;; This file is part of Clozure CL.
|
|---|
| 3 | ;;;
|
|---|
| 4 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU
|
|---|
| 5 | ;;; Public License , known as the LLGPL and distributed with Clozure
|
|---|
| 6 | ;;; CL as the file "LICENSE". The LLGPL consists of a preamble and
|
|---|
| 7 | ;;; the LGPL, which is distributed with Clozure CL as the file "LGPL".
|
|---|
| 8 | ;;; Where these conflict, the preamble takes precedence.
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY."
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; The LLGPL is also available online at
|
|---|
| 13 | ;;; http://opensource.franz.com/preamble.html
|
|---|
| 14 |
|
|---|
| [7984] | 15 | (in-package "CCL")
|
|---|
| 16 |
|
|---|
| 17 | (eval-when (:compile-toplevel :execute)
|
|---|
| 18 | (require "NUMBER-MACROS")
|
|---|
| 19 | (require "NUMBER-CASE-MACRO"))
|
|---|
| 20 |
|
|---|
| 21 | ;;; make a float from hi - high 24 bits mantissa (ignore implied higher bit)
|
|---|
| 22 | ;;; lo - low 28 bits mantissa
|
|---|
| 23 | ;;; exp - take low 11 bits
|
|---|
| 24 | ;;; sign - sign(sign) => result
|
|---|
| 25 | ;;; hi result - 1 bit sign: 11 bits exp: 20 hi bits of hi arg
|
|---|
| 26 | ;;; lo result - 4 lo bits of hi arg: 28 lo bits of lo arg
|
|---|
| 27 | ;;; no error checks, no tweaks, no nuthin
|
|---|
| 28 |
|
|---|
| 29 | ;;; sign is -1, 1, maybe zero
|
|---|
| 30 |
|
|---|
| 31 | (defx8632lapfunction %make-float-from-fixnums ((dfloat 12) (hi 8) (lo 4) #|(ra 0)|# (exp arg_y) (sign arg_z))
|
|---|
| 32 | (mov (% sign) (% imm0))
|
|---|
| 33 | (movl (@ dfloat (% esp)) (% arg_z))
|
|---|
| 34 | (sar ($ 31) (% imm0))
|
|---|
| 35 | (shl ($ 31) (% imm0)) ;insert sign
|
|---|
| 36 | (shl ($ (- 20 x8632::fixnumshift)) (% exp))
|
|---|
| 37 | (orl (% exp) (% imm0)) ;insert biased exponent
|
|---|
| [7985] | 38 | (movl (% imm0) (@ x8632::double-float.val-high (% arg_z)))
|
|---|
| [7984] | 39 | (movl (@ hi (% esp)) (% arg_y))
|
|---|
| 40 | (andl ($ (ash (1- (ash 1 24)) x8632::fixnumshift)) (% arg_y))
|
|---|
| 41 | (movl (% arg_y) (% imm0))
|
|---|
| 42 | (shrl ($ (+ 4 x8632::fixnumshift)) (% imm0)) ;top 20 bits of hi
|
|---|
| 43 | (orl (% imm0) (@ x8632::double-float.val-high (% arg_z))) ; into high word
|
|---|
| 44 | ;; do low half
|
|---|
| 45 | (movl (@ lo (% esp)) (% imm0))
|
|---|
| 46 | (sar ($ x8632::fixnumshift) (% imm0))
|
|---|
| 47 | (andl ($ (1- (ash 1 28))) (% imm0))
|
|---|
| 48 | (shl ($ (- 28 x8632::fixnumshift)) (% arg_y)) ;position low 4 bits of hi
|
|---|
| 49 | (orl (% arg_y) (% imm0))
|
|---|
| 50 | (movl (% imm0) (@ x8632::double-float.value (% arg_z)))
|
|---|
| 51 | (single-value-return 5))
|
|---|
| 52 |
|
|---|
| 53 | (defx8632lapfunction %make-short-float-from-fixnums ((sfloat 8) (significand 4) #|(ra 0)|# (biased-exp arg_y) (sign arg_z))
|
|---|
| 54 | (movl (% sign) (% imm0))
|
|---|
| 55 | (movl (@ sfloat (% esp)) (% arg_z))
|
|---|
| 56 | (sarl ($ 31) (% imm0))
|
|---|
| 57 | (shll ($ 31) (% imm0)) ;insert sign
|
|---|
| 58 | (shll ($ (- ieee-single-float-exponent-offset x8632::fixnumshift)) (% biased-exp))
|
|---|
| 59 | (or (% biased-exp) (% imm0)) ;insert biased exponent
|
|---|
| 60 | (movl (% imm0) (@ x8632::single-float.value (% arg_z)))
|
|---|
| 61 | (movl (@ significand (% esp)) (% imm0))
|
|---|
| 62 | (sar ($ x8632::fixnumshift) (% imm0))
|
|---|
| 63 | (andl ($ (1- (ash 1 ieee-single-float-hidden-bit))) (% imm0))
|
|---|
| 64 | (or (% imm0) (@ x8632::single-float.value (% arg_z)))
|
|---|
| 65 | (single-value-return 4))
|
|---|
| 66 |
|
|---|
| 67 | ;;; Maybe we should trap - or something - on NaNs.
|
|---|
| 68 | (defx8632lapfunction %%double-float-abs! ((n arg_y) (val arg_z))
|
|---|
| 69 | (get-double-float n fp1)
|
|---|
| 70 | (put-double-float fp1 val)
|
|---|
| 71 | (btrl ($ 31) (@ x8632::double-float.val-high (% val)))
|
|---|
| 72 | (single-value-return))
|
|---|
| 73 |
|
|---|
| 74 | (defx8632lapfunction %%short-float-abs! ((n arg_y) (val arg_z))
|
|---|
| 75 | (movl (@ x8632::single-float.value (% n)) (% imm0))
|
|---|
| 76 | (btr ($ 31) (% imm0))
|
|---|
| 77 | (movl (% imm0) (@ x8632::single-float.value (% val)))
|
|---|
| 78 | (single-value-return))
|
|---|
| 79 |
|
|---|
| 80 | (defx8632lapfunction %double-float-negate! ((src arg_y) (res arg_z))
|
|---|
| 81 | (get-double-float src fp1)
|
|---|
| 82 | (put-double-float fp1 res)
|
|---|
| 83 | (btcl ($ 31) (@ x8632::double-float.val-high (% res)))
|
|---|
| 84 | (single-value-return))
|
|---|
| 85 |
|
|---|
| 86 | (defx8632lapfunction %short-float-negate! ((src arg_y) (res arg_z))
|
|---|
| 87 | (movl (@ x8632::single-float.value (% src)) (% imm0))
|
|---|
| 88 | (btcl ($ 31) (% imm0))
|
|---|
| [7985] | 89 | (movl (% imm0) (@ x8632::single-float.value (% res)))
|
|---|
| [7984] | 90 | (single-value-return))
|
|---|
| 91 |
|
|---|
| 92 | ;;; return hi (25 bits) lo (28 bits) exp sign
|
|---|
| 93 | (defx8632lapfunction %integer-decode-double-float ((n arg_z))
|
|---|
| 94 | (mark-as-imm temp0)
|
|---|
| 95 | (let ((imm1 temp0)
|
|---|
| 96 | (sign 0)
|
|---|
| 97 | (exp 4)
|
|---|
| 98 | (lo 8)
|
|---|
| 99 | (hi 12))
|
|---|
| 100 | (pushl ($ 0)) ;hi
|
|---|
| 101 | (pushl ($ 0)) ;lo
|
|---|
| 102 | (pushl ($ 0)) ;exp
|
|---|
| 103 | (pushl ($ 0)) ;sign
|
|---|
| 104 |
|
|---|
| 105 | (movl (@ x8632::double-float.val-high (% n)) (% imm1))
|
|---|
| [9482] | 106 | (movl ($ '1) (% arg_y))
|
|---|
| 107 | (movl ($ '-1) (% imm0))
|
|---|
| 108 | (btl ($ 31) (% imm1))
|
|---|
| 109 | (cmovcl (% imm0) (% arg_y))
|
|---|
| [7984] | 110 | (movl (% arg_y) (@ sign (% esp)))
|
|---|
| 111 |
|
|---|
| 112 | (movl (% imm1) (% imm0))
|
|---|
| 113 | (andl ($ #x7ff00000) (% imm0)) ;exponent
|
|---|
| [9482] | 114 | (shrl ($ (- 20 x8632::fixnumshift)) (% imm0))
|
|---|
| [7984] | 115 | (movl (% imm0) (@ exp (% esp)))
|
|---|
| 116 |
|
|---|
| 117 | (movl (@ x8632::double-float.value (% n)) (% imm0))
|
|---|
| 118 | (andl ($ #x000fffff) (% imm1)) ;high 20 bits of fraction
|
|---|
| 119 | (shldl ($ 4) (% imm0) (% imm1)) ;shift in 4 bits from low word
|
|---|
| [9482] | 120 | (cmpl ($ 0) (@ exp (% esp)))
|
|---|
| 121 | (je @denorm)
|
|---|
| 122 | (or ($ (ash 1 (- ieee-double-float-hidden-bit 28))) (% imm1))
|
|---|
| [7984] | 123 | @denorm
|
|---|
| 124 | (box-fixnum imm1 arg_y)
|
|---|
| 125 | (movl (% arg_y) (@ hi (% esp)))
|
|---|
| 126 |
|
|---|
| 127 | (shll ($ 4) (% imm0)) ;shift out bits included in hi
|
|---|
| [9482] | 128 | (shrl ($ x8632::fixnumshift) (% imm0)) ;and box 28 low bits
|
|---|
| [7984] | 129 | (movl (% imm0) (@ lo (% esp))))
|
|---|
| 130 | (mark-as-node temp0)
|
|---|
| 131 | (set-nargs 4)
|
|---|
| 132 | (leal (@ '4 (% esp)) (% temp0))
|
|---|
| 133 | (jmp-subprim .SPvalues))
|
|---|
| 134 |
|
|---|
| 135 | ;;; hi is 25 bits lo is 28 bits
|
|---|
| 136 | ;;; big is 32 lo, 21 hi right justified
|
|---|
| 137 | (defx8632lapfunction make-big-53 ((hi 4) #|(ra 0)|# (lo arg_y) (big arg_z))
|
|---|
| 138 | (mark-as-imm temp0)
|
|---|
| 139 | (let ((imm1 temp0))
|
|---|
| 140 | (movl (@ hi (% esp)) (% temp1))
|
|---|
| 141 | (movl (% temp1) (% imm0))
|
|---|
| 142 | (shll ($ (- 28 x8632::fixnumshift)) (% imm0))
|
|---|
| 143 | (unbox-fixnum lo imm1)
|
|---|
| 144 | (orl (% imm0) (% imm1))
|
|---|
| [7985] | 145 | (movl (% imm1) (@ x8632::misc-data-offset (% big))) ;low 32 bits
|
|---|
| [7984] | 146 | (movl (% temp1) (% imm0))
|
|---|
| 147 | (sarl ($ (+ 4 x8632::fixnumshift)) (% imm0))
|
|---|
| [7985] | 148 | (movl (% imm0) (@ (+ 4 x8632::misc-data-offset) (% big)))) ;high 21 bits
|
|---|
| [7984] | 149 | (mark-as-node temp0)
|
|---|
| 150 | (single-value-return 3))
|
|---|
| 151 |
|
|---|
| 152 | ;;; dfloat must be non-zero
|
|---|
| 153 | (defx8632lapfunction dfloat-significand-zeros ((dfloat arg_z))
|
|---|
| 154 | (mark-as-imm temp0)
|
|---|
| 155 | (let ((imm1 temp0))
|
|---|
| 156 | (movl (@ x8632::double-float.value (% dfloat)) (% imm0))
|
|---|
| 157 | (movl (@ x8632::double-float.val-high (% dfloat)) (% imm1))
|
|---|
| 158 | ;; shift imm1 left by count, shifting bits from imm0 in from the right
|
|---|
| 159 | (shldl ($ (1+ ieee-double-float-exponent-width)) (% imm0) (% imm1))
|
|---|
| 160 | (testl (% imm1) (% imm1))
|
|---|
| 161 | (jz @low)
|
|---|
| 162 | (bsrl (% imm1) (% imm0))
|
|---|
| 163 | (xorl ($ (1- x8632::nbits-in-word)) (% imm0))
|
|---|
| 164 | (jmp @done)
|
|---|
| 165 | @low
|
|---|
| 166 | (bsrl (% imm0) (% imm0))
|
|---|
| 167 | (xorl ($ (1- x8632::nbits-in-word)) (% imm0))
|
|---|
| 168 | ;; if we're here, the upper part of the fraction was all zeros,
|
|---|
| 169 | ;; so add the count for those in.
|
|---|
| 170 | (add ($ (- ieee-double-float-mantissa-width 32)) (% imm0))
|
|---|
| 171 | @done
|
|---|
| 172 | (box-fixnum imm0 arg_z))
|
|---|
| 173 | (mark-as-node temp0)
|
|---|
| 174 | (single-value-return))
|
|---|
| 175 |
|
|---|
| 176 | ;;; sfloat must be non-zero
|
|---|
| 177 | (defx8632lapfunction sfloat-significand-zeros ((sfloat arg_z))
|
|---|
| 178 | (movl (@ x8632::single-float.value (% sfloat)) (% imm0))
|
|---|
| 179 | (shl ($ (1+ IEEE-single-float-exponent-width)) (% imm0))
|
|---|
| 180 | (bsrl (% imm0) (% imm0))
|
|---|
| 181 | (xorl ($ (1- x8632::nbits-in-word)) (% imm0))
|
|---|
| 182 | (box-fixnum imm0 arg_z)
|
|---|
| 183 | (single-value-return))
|
|---|
| 184 |
|
|---|
| 185 | (defx8632lapfunction %%scale-dfloat! ((dfloat 4) #|(ra 0)|# (int arg_y) (result arg_z))
|
|---|
| 186 | (unbox-fixnum int imm0)
|
|---|
| 187 | (movl (@ dfloat (% esp)) (% temp0))
|
|---|
| 188 | (get-double-float temp0 fp1)
|
|---|
| 189 | (shl ($ (- ieee-double-float-exponent-offset 32)) (% imm0))
|
|---|
| 190 | (movl ($ 0) (@ x8632::double-float.value (% result)))
|
|---|
| 191 | (movl (% imm0) (@ x8632::double-float.val-high (% result)))
|
|---|
| 192 | (get-double-float result fp2)
|
|---|
| 193 | (mulsd (% fp2) (% fp1))
|
|---|
| 194 | (put-double-float fp1 result)
|
|---|
| 195 | (single-value-return 3))
|
|---|
| 196 |
|
|---|
| 197 | (defx8632lapfunction %%scale-sfloat! ((sfloat 4) #|(ra 0)|# (int arg_y) (result arg_z))
|
|---|
| 198 | (unbox-fixnum int imm0)
|
|---|
| 199 | (movl (@ sfloat (% esp)) (% temp0))
|
|---|
| 200 | (get-single-float temp0 fp1)
|
|---|
| 201 | (shl ($ ieee-single-float-exponent-offset) (% imm0))
|
|---|
| 202 | (movd (% imm0) (% fp2))
|
|---|
| 203 | (mulss (% fp2) (% fp1))
|
|---|
| 204 | (put-single-float fp1 arg_z)
|
|---|
| 205 | (single-value-return 3))
|
|---|
| 206 |
|
|---|
| 207 | (defx8632lapfunction %copy-double-float ((f1 arg_y) (f2 arg_z))
|
|---|
| 208 | (get-double-float f1 fp1)
|
|---|
| 209 | (put-double-float fp1 f2)
|
|---|
| 210 | (single-value-return))
|
|---|
| 211 |
|
|---|
| 212 | (defx8632lapfunction %copy-short-float ((f1 arg_y) (f2 arg_z))
|
|---|
| 213 | (get-single-float f1 fp1)
|
|---|
| 214 | (put-single-float fp1 f2)
|
|---|
| 215 | (single-value-return))
|
|---|
| 216 |
|
|---|
| 217 | (defx8632lapfunction %double-float-exp ((n arg_z))
|
|---|
| 218 | (movl (@ x8632::double-float.val-high (% n)) (% imm0))
|
|---|
| 219 | (shll ($ 1) (% imm0))
|
|---|
| 220 | (shrl ($ (1+ (- ieee-double-float-exponent-offset 32))) (% imm0))
|
|---|
| [7985] | 221 | (box-fixnum imm0 arg_z)
|
|---|
| 222 | (single-value-return))
|
|---|
| [7984] | 223 |
|
|---|
| 224 | (defx8632lapfunction set-%double-float-exp ((dfloat arg_y) (exp arg_z))
|
|---|
| 225 | (movl (% exp) (% temp0))
|
|---|
| 226 | (shll ($ (1+ (- 20 x8632::fixnumshift))) (% temp0))
|
|---|
| 227 | (shrl ($ 1) (% temp0))
|
|---|
| 228 | (movl (@ x8632::double-float.val-high (% dfloat)) (% imm0))
|
|---|
| 229 | (andl ($ #x800fffff) (% imm0))
|
|---|
| 230 | (orl (% temp0) (% imm0))
|
|---|
| 231 | (movl (% imm0) (@ x8632::double-float.val-high (% dfloat)))
|
|---|
| 232 | (single-value-return))
|
|---|
| 233 |
|
|---|
| 234 | (defx8632lapfunction %short-float-exp ((n arg_z))
|
|---|
| 235 | (movl (@ x8632::single-float.value (% n)) (% imm0))
|
|---|
| 236 | (shll ($ 1) (% imm0))
|
|---|
| 237 | (shrl ($ (1+ ieee-single-float-exponent-offset)) (% imm0))
|
|---|
| [7985] | 238 | (box-fixnum imm0 arg_z)
|
|---|
| 239 | (single-value-return))
|
|---|
| [7984] | 240 |
|
|---|
| 241 | (defx8632lapfunction set-%short-float-exp ((sfloat arg_y) (exp arg_z))
|
|---|
| 242 | (movl (% exp) (% temp0))
|
|---|
| 243 | (shll ($ (1+ (- ieee-single-float-exponent-offset x8632::fixnumshift))) (% temp0))
|
|---|
| 244 | (shrl ($ 1) (% temp0))
|
|---|
| 245 | (movl (@ x8632::single-float.value (% sfloat)) (% imm0))
|
|---|
| 246 | (andl ($ #x807fffff) (% imm0))
|
|---|
| 247 | (orl (% temp0) (% imm0))
|
|---|
| [7985] | 248 | (movl (% imm0) (@ x8632::single-float.value (% sfloat)))
|
|---|
| 249 | (single-value-return))
|
|---|
| [7984] | 250 |
|
|---|
| 251 | (defx8632lapfunction %short-float->double-float ((src arg_y) (result arg_z))
|
|---|
| 252 | (get-single-float src fp1)
|
|---|
| 253 | (cvtss2sd (% fp1) (% fp1))
|
|---|
| 254 | (put-double-float fp1 result)
|
|---|
| 255 | (single-value-return))
|
|---|
| 256 |
|
|---|
| [9482] | 257 | (defx8632lapfunction %double-float->short-float ((src arg_y) (result arg_z))
|
|---|
| [7984] | 258 | (get-double-float src fp1)
|
|---|
| 259 | (cvtsd2ss (% fp1) (% fp1))
|
|---|
| [9482] | 260 | (put-single-float fp1 result)
|
|---|
| [7984] | 261 | (single-value-return))
|
|---|
| 262 |
|
|---|
| 263 | (defx8632lapfunction %int-to-sfloat! ((int arg_y) (sfloat arg_z))
|
|---|
| 264 | (int-to-single int imm0 fp1)
|
|---|
| 265 | (put-single-float fp1 arg_z)
|
|---|
| 266 | (single-value-return))
|
|---|
| 267 |
|
|---|
| [8214] | 268 | (defx8632lapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z))
|
|---|
| [7984] | 269 | (int-to-double int imm0 fp1)
|
|---|
| 270 | (put-double-float fp1 arg_z)
|
|---|
| 271 | (single-value-return))
|
|---|
| 272 |
|
|---|
| 273 | |
|---|
| 274 |
|
|---|
| [7988] | 275 |
|
|---|
| 276 | ;;; Manipulate the MXCSR. It'll fit in a fixnum, but we have to
|
|---|
| 277 | ;;; load and store it through memory. On x8664, we can hide the
|
|---|
| 278 | ;;; 32-bit MXCSR value in a fixnum on the stack; on a 32-bit x86,
|
|---|
| [7984] | 279 | ;;; we might need to use a scratch location in the TCR or something.
|
|---|
| 280 |
|
|---|
| 281 | ;;; Return the MXCSR as a fixnum
|
|---|
| [10575] | 282 | (defx8632lapfunction %get-mxcsr ()
|
|---|
| 283 | (stmxcsr (:rcontext x8632::tcr.scratch-mxcsr))
|
|---|
| [7984] | 284 | (movl (:rcontext x8632::tcr.scratch-mxcsr) (% imm0))
|
|---|
| 285 | (box-fixnum imm0 arg_z)
|
|---|
| 286 | (single-value-return))
|
|---|
| 287 |
|
|---|
| 288 | ;;; Store the fixnum in arg_z in the MXCSR. Just to be
|
|---|
| 289 | ;;; on the safe side, mask the arg with X86::MXCSR-WRITE-MASK,
|
|---|
| [8214] | 290 | ;;; so that only known control and status bits are written to.
|
|---|
| [7988] | 291 | (defx8632lapfunction %set-mxcsr ((val arg_z))
|
|---|
| [7985] | 292 | (unbox-fixnum val imm0)
|
|---|
| [10575] | 293 | (andl ($ x86::mxcsr-write-mask) (% imm0))
|
|---|
| 294 | (movl (% imm0) (:rcontext x8632::tcr.scratch-mxcsr))
|
|---|
| [7984] | 295 | (ldmxcsr (:rcontext x8632::tcr.scratch-mxcsr))
|
|---|
| 296 | (single-value-return))
|
|---|
| 297 |
|
|---|
| 298 |
|
|---|
| 299 | ;;; Get the bits that contain exception masks and rounding mode.
|
|---|
| 300 |
|
|---|
| 301 | (defun %get-mxcsr-control ()
|
|---|
| 302 | (logand x86::mxcsr-control-and-rounding-mask (the fixnum (%get-mxcsr))))
|
|---|
| 303 |
|
|---|
| 304 | ;;; Get the bits that describe current exceptions.
|
|---|
| 305 | (defun %get-mxcsr-status ()
|
|---|
| 306 | (logand x86::mxcsr-status-mask (the fixnum (%get-mxcsr))))
|
|---|
| 307 |
|
|---|
| 308 | ;;; Set the bits that describe current exceptions, presumably to clear them.
|
|---|
| 309 | (defun %set-mxcsr-status (arg)
|
|---|
| 310 | (%set-mxcsr
|
|---|
| 311 | (logior (logand x86::mxcsr-status-mask arg)
|
|---|
| 312 | (logandc2 (%get-mxcsr) x86::mxcsr-status-mask)))
|
|---|
| 313 | arg)
|
|---|
| 314 |
|
|---|
| 315 | ;;; Set the bits that mask/unmask exceptions and control rounding.
|
|---|
| 316 | ;;; Clear the bits which describe current exceptions.
|
|---|
| 317 | (defun %set-mxcsr-control (arg)
|
|---|
| 318 | (%set-mxcsr (logand x86::mxcsr-control-and-rounding-mask arg)))
|
|---|
| 319 |
|
|---|
| [8214] | 320 | ;;; Return the MXCSR value in effect after the last ff-call.
|
|---|
| [7984] | 321 | (defx8632lapfunction %get-post-ffi-mxcsr ()
|
|---|
| [10575] | 322 | (xor (% arg_z) (% arg_z))
|
|---|
| 323 | (movl (:rcontext x8632::tcr.ffi-exception) (%l imm0))
|
|---|
| [7984] | 324 | (movl (%l arg_z) (:rcontext x8632::tcr.ffi-exception))
|
|---|
| 325 | (box-fixnum imm0 arg_z)
|
|---|
| 326 | (single-value-return))
|
|---|
| 327 |
|
|---|
| 328 | ;;; The next several defuns are copied verbatim from x8664-float.lisp.
|
|---|
| 329 | ;;; It will probably be desirable to factor this code out into a new
|
|---|
| 330 | ;;; x86-float.lisp, perhaps conditionalized via #+sse2 or something.
|
|---|
| 331 | ;;; (Some day we may want to support x87 fp and we'll need
|
|---|
| 332 | ;;; x87-specific versions of these functions.)
|
|---|
| 333 |
|
|---|
| 334 | ;;; start duplicated code
|
|---|
| 335 |
|
|---|
| 336 | ;;; Return the status bits from the last ff-call that represent
|
|---|
| 337 | ;;; unmasked exceptions
|
|---|
| 338 | (defun %ffi-exception-status ()
|
|---|
| 339 | (logior (%get-mxcsr-control)
|
|---|
| 340 | (logand x86::mxcsr-status-mask (the fixnum (%get-post-ffi-mxcsr)))))
|
|---|
| 341 |
|
|---|
| 342 | ;;; See if the binary double-float operation OP set any enabled
|
|---|
| 343 | ;;; exception bits in the mxcsr
|
|---|
| 344 | (defun %df-check-exception-2 (operation op0 op1 fp-status)
|
|---|
| 345 | (declare (type (unsigned-byte 6) fp-status))
|
|---|
| 346 | (unless (zerop fp-status)
|
|---|
| 347 | (%set-mxcsr-status 0)
|
|---|
| 348 | ;; Ensure that operands are heap-consed
|
|---|
| 349 | (%fp-error-from-status fp-status
|
|---|
| 350 | operation
|
|---|
| 351 | (%copy-double-float op0 (%make-dfloat))
|
|---|
| 352 | (%copy-double-float op1 (%make-dfloat)))))
|
|---|
| 353 |
|
|---|
| 354 | (defun %sf-check-exception-2 (operation op0 op1 fp-status)
|
|---|
| 355 | (declare (type (unsigned-byte 6) fp-status))
|
|---|
| 356 | (unless (zerop fp-status)
|
|---|
| 357 | (%set-mxcsr-status 0)
|
|---|
| 358 | ;; Ensure that operands are heap-consed
|
|---|
| 359 | (%fp-error-from-status fp-status
|
|---|
| 360 | operation
|
|---|
| 361 | #+32-bit-target
|
|---|
| 362 | (%copy-short-float op0 (%make-sfloat))
|
|---|
| 363 | #+64-bit-target op0
|
|---|
| 364 | #+32-bit-target
|
|---|
| 365 | (%copy-short-float op1 (%make-sfloat))
|
|---|
| 366 | #+64-bit-target op1)))
|
|---|
| 367 |
|
|---|
| 368 | (defun %df-check-exception-1 (operation op0 fp-status)
|
|---|
| 369 | (declare (fixnum fp-status))
|
|---|
| 370 | (unless (zerop fp-status)
|
|---|
| 371 | (%set-mxcsr-status 0)
|
|---|
| 372 | ;; Ensure that operands are heap-consed
|
|---|
| 373 | (%fp-error-from-status fp-status
|
|---|
| 374 | operation
|
|---|
| 375 | (%copy-double-float op0 (%make-dfloat)))))
|
|---|
| 376 |
|
|---|
| 377 | (defun %sf-check-exception-1 (operation op0 fp-status)
|
|---|
| 378 | (declare (type (unsigned-byte 6) fp-status))
|
|---|
| 379 | (unless (zerop fp-status)
|
|---|
| 380 | (%set-mxcsr-status 0)
|
|---|
| 381 | ;; Ensure that operands are heap-consed
|
|---|
| 382 | (%fp-error-from-status fp-status
|
|---|
| 383 | operation
|
|---|
| 384 | #+32-bit-target
|
|---|
| 385 | (%copy-short-float op0 (%make-sfloat))
|
|---|
| 386 | #+64-bit-target op0)))
|
|---|
| 387 |
|
|---|
| 388 |
|
|---|
| 389 | (defun fp-condition-from-mxcsr (status-bits control-bits)
|
|---|
| 390 | (declare (fixnum status-bits control-bits))
|
|---|
| 391 | (cond
|
|---|
| 392 | ((and (logbitp x86::mxcsr-ie-bit status-bits)
|
|---|
| 393 | (not (logbitp x86::mxcsr-im-bit control-bits)))
|
|---|
| 394 | 'floating-point-invalid-operation)
|
|---|
| 395 | ((and (logbitp x86::mxcsr-oe-bit status-bits)
|
|---|
| 396 | (not (logbitp x86::mxcsr-om-bit control-bits)))
|
|---|
| 397 | 'floating-point-overflow)
|
|---|
| 398 | ((and (logbitp x86::mxcsr-ue-bit status-bits)
|
|---|
| 399 | (not (logbitp x86::mxcsr-um-bit control-bits)))
|
|---|
| 400 | 'floating-point-underflow)
|
|---|
| 401 | ((and (logbitp x86::mxcsr-ze-bit status-bits)
|
|---|
| 402 | (not (logbitp x86::mxcsr-zm-bit control-bits)))
|
|---|
| 403 | 'division-by-zero)
|
|---|
| 404 | ((and (logbitp x86::mxcsr-pe-bit status-bits)
|
|---|
| 405 | (not (logbitp x86::mxcsr-pm-bit control-bits)))
|
|---|
| 406 | 'floating-point-inexact)))
|
|---|
| 407 |
|
|---|
| 408 | (defun %fp-error-from-status (status-bits operation op0 &optional op1)
|
|---|
| 409 | (declare (type (unsigned-byte 6) status-bits))
|
|---|
| 410 | (let* ((condition-class (fp-condition-from-mxcsr status-bits (%get-mxcsr-control))))
|
|---|
| 411 | (if condition-class
|
|---|
| 412 | (let* ((operands (if op1 (list op0 op1) (list op0))))
|
|---|
| 413 | (error (make-instance condition-class
|
|---|
| 414 | :operation operation
|
|---|
| 415 | :operands operands))))))
|
|---|
| [9476] | 416 |
|
|---|
| 417 | (defvar *rounding-mode-alist*
|
|---|
| 418 | '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3)))
|
|---|
| 419 |
|
|---|
| 420 | (defun get-fpu-mode (&optional (mode nil mode-p))
|
|---|
| 421 | (let* ((flags (%get-mxcsr-control)))
|
|---|
| 422 | (declare (fixnum flags))
|
|---|
| 423 | (let* ((rounding-mode
|
|---|
| 424 | (car (nth (+ (if (logbitp x86::mxcsr-rc0-bit flags) 1 0)
|
|---|
| 425 | (if (logbitp x86::mxcsr-rc1-bit flags) 2 0))
|
|---|
| 426 | *rounding-mode-alist*)))
|
|---|
| 427 | (overflow (not (logbitp x86::mxcsr-om-bit flags)))
|
|---|
| 428 | (underflow (not (logbitp x86::mxcsr-um-bit flags)))
|
|---|
| 429 | (division-by-zero (not (logbitp x86::mxcsr-zm-bit flags)))
|
|---|
| 430 | (invalid (not (logbitp x86::mxcsr-im-bit flags)))
|
|---|
| 431 | (inexact (not (logbitp x86::mxcsr-pm-bit flags))))
|
|---|
| 432 | (if mode-p
|
|---|
| 433 | (ecase mode
|
|---|
| 434 | (:rounding-mode rounding-mode)
|
|---|
| 435 | (:overflow overflow)
|
|---|
| 436 | (:underflow underflow)
|
|---|
| 437 | (:division-by-zero division-by-zero)
|
|---|
| 438 | (:invalid invalid)
|
|---|
| 439 | (:inexact inexact))
|
|---|
| 440 | `(:rounding-mode ,rounding-mode
|
|---|
| 441 | :overflow ,overflow
|
|---|
| 442 | :underflow ,underflow
|
|---|
| 443 | :division-by-zero ,division-by-zero
|
|---|
| 444 | :invalid ,invalid
|
|---|
| 445 | :inexact ,inexact)))))
|
|---|
| 446 |
|
|---|
| 447 | ;;; did we document this?
|
|---|
| 448 | (defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
|
|---|
| 449 | (overflow t overflow-p)
|
|---|
| 450 | (underflow t underflow-p)
|
|---|
| 451 | (division-by-zero t zero-p)
|
|---|
| 452 | (invalid t invalid-p)
|
|---|
| 453 | (inexact t inexact-p))
|
|---|
| 454 | (let* ((current (%get-mxcsr-control))
|
|---|
| 455 | (new current))
|
|---|
| 456 | (declare (fixnum current new))
|
|---|
| 457 | (when rounding-p
|
|---|
| 458 | (let* ((rc-bits (or
|
|---|
| 459 | (cdr (assoc rounding-mode *rounding-mode-alist*))
|
|---|
| 460 | (error "Unknown rounding mode: ~s" rounding-mode))))
|
|---|
| 461 | (declare (fixnum rc-bits))
|
|---|
| 462 | (if (logbitp 0 rc-bits)
|
|---|
| 463 | (bitsetf x86::mxcsr-rc0-bit new)
|
|---|
| 464 | (bitclrf x86::mxcsr-rc0-bit new))
|
|---|
| 465 | (if (logbitp 1 rc-bits)
|
|---|
| 466 | (bitsetf x86::mxcsr-rc1-bit new)
|
|---|
| 467 | (bitclrf x86::mxcsr-rc1-bit new))))
|
|---|
| 468 | (when invalid-p
|
|---|
| 469 | (if invalid
|
|---|
| 470 | (bitclrf x86::mxcsr-im-bit new)
|
|---|
| 471 | (bitsetf x86::mxcsr-im-bit new)))
|
|---|
| 472 | (when overflow-p
|
|---|
| 473 | (if overflow
|
|---|
| 474 | (bitclrf x86::mxcsr-om-bit new)
|
|---|
| 475 | (bitsetf x86::mxcsr-om-bit new)))
|
|---|
| 476 | (when underflow-p
|
|---|
| 477 | (if underflow
|
|---|
| 478 | (bitclrf x86::mxcsr-um-bit new)
|
|---|
| 479 | (bitsetf x86::mxcsr-um-bit new)))
|
|---|
| 480 | (when zero-p
|
|---|
| 481 | (if division-by-zero
|
|---|
| 482 | (bitclrf x86::mxcsr-zm-bit new)
|
|---|
| 483 | (bitsetf x86::mxcsr-zm-bit new)))
|
|---|
| 484 | (when inexact-p
|
|---|
| 485 | (if inexact
|
|---|
| 486 | (bitclrf x86::mxcsr-pm-bit new)
|
|---|
| 487 | (bitsetf x86::mxcsr-pm-bit new)))
|
|---|
| 488 | (unless (= current new)
|
|---|
| 489 | (%set-mxcsr-control new))
|
|---|
| 490 | (%get-mxcsr)))
|
|---|
| [7984] | 491 |
|
|---|
| 492 | ;;; end duplicated code
|
|---|
| 493 |
|
|---|
| 494 | ;;; Don't we already have about 20 versions of this ?
|
|---|
| 495 | (defx8632lapfunction %double-float-from-macptr! ((ptr 4) #|(ra 0)|# (byte-offset arg_y) (dest arg_z))
|
|---|
| 496 | (mark-as-imm temp0)
|
|---|
| 497 | (let ((imm1 temp0))
|
|---|
| 498 | (movl (@ ptr (% esp)) (% temp1))
|
|---|
| 499 | (macptr-ptr temp1 imm0)
|
|---|
| 500 | (unbox-fixnum byte-offset imm1)
|
|---|
| 501 | (movsd (@ (% imm0) (% imm1)) (% fp1))
|
|---|
| 502 | (put-double-float fp1 dest))
|
|---|
| 503 | (mark-as-node temp0)
|
|---|
| 504 | (single-value-return 3))
|
|---|
| 505 |
|
|---|
| 506 | ;;; Copy a single float pointed at by the macptr in single
|
|---|
| 507 | ;;; to a double float pointed at by the macptr in double
|
|---|
| 508 | (defx8632lapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z))
|
|---|
| 509 | (check-nargs 2)
|
|---|
| 510 | (macptr-ptr single imm0)
|
|---|
| 511 | (movss (@ (% imm0)) (% fp1))
|
|---|
| 512 | (cvtss2sd (% fp1) (% fp1))
|
|---|
| 513 | (macptr-ptr double imm0)
|
|---|
| 514 | (movsd (% fp1) (@ (% imm0)))
|
|---|
| 515 | (single-value-return))
|
|---|
| 516 |
|
|---|
| 517 | ;;; Copy a double float pointed at by the macptr in double
|
|---|
| 518 | ;;; to a single float pointed at by the macptr in single.
|
|---|
| 519 | (defx8632lapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z))
|
|---|
| 520 | (check-nargs 2)
|
|---|
| 521 | (macptr-ptr double imm0)
|
|---|
| 522 | (movsd (@ (% imm0)) (% fp1))
|
|---|
| 523 | (cvtsd2ss (% fp1) (% fp1))
|
|---|
| 524 | (macptr-ptr single imm0)
|
|---|
| 525 | (movss (% fp1) (@ (% imm0)))
|
|---|
| 526 | (single-value-return))
|
|---|
| 527 |
|
|---|
| 528 | (defx8632lapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z))
|
|---|
| 529 | (check-nargs 2)
|
|---|
| 530 | (macptr-ptr macptr imm0)
|
|---|
| 531 | (get-double-float src fp1)
|
|---|
| 532 | (cvtsd2ss (% fp1) (% fp1))
|
|---|
| 533 | (movss (% fp1) (@ (% imm0)))
|
|---|
| 534 | (single-value-return))
|
|---|
| 535 |
|
|---|
| 536 | (defun host-single-float-from-unsigned-byte-32 (u32)
|
|---|
| 537 | (let* ((f (%make-sfloat)))
|
|---|
| 538 | (setf (uvref f x8632::single-float.value-cell) u32)
|
|---|
| 539 | f))
|
|---|
| 540 |
|
|---|
| 541 | (defun single-float-bits (f)
|
|---|
| 542 | (uvref f x8632::single-float.value-cell))
|
|---|
| 543 |
|
|---|
| 544 | (defun double-float-bits (f)
|
|---|
| 545 | (values (uvref f target::double-float.val-high-cell)
|
|---|
| 546 | (uvref f target::double-float.value-cell)))
|
|---|
| 547 |
|
|---|
| 548 | (defun double-float-from-bits (high low)
|
|---|
| 549 | (let* ((f (%make-dfloat)))
|
|---|
| 550 | (setf (uvref f target::double-float.val-high-cell) high
|
|---|
| 551 | (uvref f target::double-float.value-cell) low)
|
|---|
| 552 | f))
|
|---|
| 553 |
|
|---|
| 554 | ;;; Return T if n is negative, else NIL.
|
|---|
| 555 | (defx8632lapfunction %double-float-sign ((n arg_z))
|
|---|
| 556 | (movl (@ x8632::double-float.val-high (% n)) (% imm0))
|
|---|
| [10959] | 557 | (testl (% imm0) (% imm0))
|
|---|
| 558 | (movl ($ (target-t-value)) (% imm0))
|
|---|
| [7984] | 559 | (movl ($ (target-nil-value)) (% arg_z))
|
|---|
| 560 | (cmovll (% imm0) (% arg_z))
|
|---|
| 561 | (single-value-return))
|
|---|
| 562 |
|
|---|
| 563 | (defx8632lapfunction %short-float-sign ((n arg_z))
|
|---|
| 564 | (movl (@ x8632::single-float.value (% n)) (% imm0))
|
|---|
| [10959] | 565 | (testl (% imm0) (% imm0))
|
|---|
| 566 | (movl ($ (target-t-value)) (% imm0))
|
|---|
| [7984] | 567 | (movl ($ (target-nil-value)) (% arg_z))
|
|---|
| 568 | (cmovll (% imm0) (% arg_z))
|
|---|
| 569 | (single-value-return))
|
|---|
| 570 |
|
|---|
| 571 | (defx8632lapfunction %double-float-sqrt! ((n arg_y) (result arg_z))
|
|---|
| 572 | (get-double-float n fp0)
|
|---|
| 573 | (sqrtsd (% fp0) (% fp0))
|
|---|
| 574 | (put-double-float fp0 result)
|
|---|
| 575 | (single-value-return))
|
|---|
| 576 |
|
|---|
| 577 | (defx8632lapfunction %single-float-sqrt! ((n arg_y) (result arg_z))
|
|---|
| 578 | (get-single-float n fp0)
|
|---|
| 579 | (sqrtss (% fp0) (% fp0))
|
|---|
| 580 | (put-single-float fp0 arg_z)
|
|---|
| 581 | (single-value-return))
|
|---|
| 582 |
|
|---|
| 583 |
|
|---|
| 584 |
|
|---|
