[2950] | 1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
| 2 | ;;; |
---|
| 3 | ;;; Copyright (C) 2005 Clozure Associates |
---|
| 4 | ;;; This file is part of OpenMCL. |
---|
| 5 | ;;; |
---|
| 6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
| 7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
| 8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
| 9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
| 10 | ;;; conflict, the preamble takes precedence. |
---|
| 11 | ;;; |
---|
| 12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
| 13 | ;;; |
---|
| 14 | ;;; The LLGPL is also available online at |
---|
| 15 | ;;; http://opensource.franz.com/preamble.html |
---|
| 16 | |
---|
| 17 | (in-package "CCL") |
---|
| 18 | |
---|
| 19 | (eval-when (:compile-toplevel :execute) |
---|
| 20 | (require "NUMBER-MACROS") |
---|
| 21 | (require :number-case-macro)) |
---|
| 22 | |
---|
| 23 | |
---|
| 24 | ;;; make a float from hi - high 24 bits mantissa (ignore implied higher bit) |
---|
| 25 | ;;; lo - low 28 bits mantissa |
---|
| 26 | ;;; exp - take low 11 bits |
---|
| 27 | ;;; sign - sign(sign) => result |
---|
| 28 | ;;; hi result - 1 bit sign: 11 bits exp: 20 hi bits of hi arg |
---|
| 29 | ;;; lo result - 4 lo bits of hi arg: 28 lo bits of lo arg |
---|
| 30 | ;;; no error checks, no tweaks, no nuthin |
---|
| 31 | |
---|
[3102] | 32 | ;;; sign is -1, 1, maybe zero |
---|
[2950] | 33 | |
---|
| 34 | |
---|
| 35 | |
---|
[6479] | 36 | (defx86lapfunction %make-float-from-fixnums ((float 16 )(hi 8) #|(ra 0)|#(lo arg_x) (exp arg_y) (sign arg_z)) |
---|
[3102] | 37 | (mov (% sign) (% imm1)) |
---|
| 38 | (sar ($ 63) (% imm1)) |
---|
| 39 | (shl ($ 63) (% imm1)) |
---|
[6479] | 40 | (movq (@ hi (% rsp)) (% imm0)) ;hi |
---|
[4398] | 41 | (andl ($ (ash (1- (ash 1 24)) x8664::fixnumshift)) (%l imm0)) |
---|
[3102] | 42 | (shl ($ (- 28 x8664::fixnumshift)) (% imm0)) |
---|
| 43 | (or (% imm0) (% imm1)) |
---|
| 44 | (unbox-fixnum lo imm0) |
---|
[4398] | 45 | (andl ($ (1- (ash 1 28))) (%l imm0)) |
---|
[3102] | 46 | (or (% imm0) (% imm1)) |
---|
| 47 | (mov (% exp) (% imm0)) |
---|
| 48 | (shl ($ (- ieee-double-float-exponent-offset x8664::fixnumshift)) (% imm0)) |
---|
| 49 | (or (% imm0) (% imm1)) |
---|
[6479] | 50 | (movq (@ float (% rsp)) (% arg_z)) |
---|
[3102] | 51 | (mov (% imm1) (@ x8664::double-float.value (% arg_z))) |
---|
[6479] | 52 | (single-value-return 4)) |
---|
[2950] | 53 | |
---|
| 54 | |
---|
[2970] | 55 | ;;; Maybe we should trap - or something - on NaNs. |
---|
[2950] | 56 | (defx86lapfunction %%double-float-abs! ((n arg_y)(val arg_z)) |
---|
[3064] | 57 | (mov (@ x8664::double-float.value (% n)) (% imm0)) |
---|
| 58 | (btr ($ 63) (% imm0)) |
---|
| 59 | (mov (% imm0) (@ x8664::double-float.value (% val))) |
---|
[3102] | 60 | (single-value-return)) |
---|
[2950] | 61 | |
---|
| 62 | |
---|
| 63 | (defx86lapfunction %short-float-abs ((n arg_z)) |
---|
[3176] | 64 | (btr ($ 63) (% n)) |
---|
[3102] | 65 | (single-value-return)) |
---|
[2950] | 66 | |
---|
| 67 | |
---|
[3157] | 68 | (defx86lapfunction %double-float-negate! ((src arg_y) (res arg_z)) |
---|
[4416] | 69 | (movq (@ x8664::double-float.value (% src)) (% imm0)) |
---|
| 70 | (btcq ($ 63) (% imm0)) |
---|
| 71 | (movq (% imm0) (@ x8664::double-float.value (% res))) |
---|
[3157] | 72 | (single-value-return)) |
---|
[2950] | 73 | |
---|
| 74 | |
---|
[3157] | 75 | (defx86lapfunction %short-float-negate ((src arg_z)) |
---|
[4416] | 76 | (btcq ($ 63) (% arg_z)) |
---|
[3157] | 77 | (single-value-return)) |
---|
| 78 | |
---|
| 79 | |
---|
| 80 | |
---|
[2950] | 81 | (defx86lapfunction dfloat-significand-zeros ((dfloat arg_z)) |
---|
[3117] | 82 | (movq (@ target::double-float.value (% dfloat)) (% imm1)) |
---|
| 83 | (shl ($ (1+ IEEE-double-float-exponent-width)) (% imm1)) |
---|
| 84 | (bsrq (% imm1) (% imm0)) |
---|
| 85 | (xorq ($ (1- target::nbits-in-word)) (% imm0)) |
---|
| 86 | (box-fixnum imm0 arg_z) |
---|
| 87 | (single-value-return)) |
---|
[2950] | 88 | |
---|
[3117] | 89 | ;;; This exploits the fact that the single float is already |
---|
| 90 | ;;; shifted left 32 bits. We don't want to count the tag |
---|
| 91 | ;;; bit as significant, so bash the argument into a fixnum |
---|
| 92 | ;;; first. |
---|
[2950] | 93 | (defx86lapfunction sfloat-significand-zeros ((sfloat arg_z)) |
---|
[3117] | 94 | (xorb (%b sfloat) (%b sfloat)) |
---|
| 95 | (shl ($ (1+ IEEE-single-float-exponent-width)) (% sfloat)) |
---|
[5600] | 96 | (bsrq (% sfloat) (% imm0)) |
---|
[3117] | 97 | (xorq ($ (1- target::nbits-in-word)) (% imm0)) |
---|
| 98 | (box-fixnum imm0 arg_z) |
---|
| 99 | (single-value-return)) |
---|
[2950] | 100 | |
---|
| 101 | (defx86lapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z)) |
---|
[3117] | 102 | (unbox-fixnum int imm0) |
---|
| 103 | (get-double-float float fp1) |
---|
| 104 | (shl ($ IEEE-double-float-exponent-offset) (% imm0)) |
---|
| 105 | (movd (% imm0) (% fp2)) |
---|
| 106 | (mulsd (% fp2) (% fp1)) |
---|
| 107 | (put-double-float fp1 result) |
---|
| 108 | (single-value-return)) |
---|
[2950] | 109 | |
---|
| 110 | (defx86lapfunction %%scale-sfloat! ((float arg_y)(int arg_z)) |
---|
[3117] | 111 | (unbox-fixnum int imm0) |
---|
| 112 | (shl ($ IEEE-double-float-exponent-offset) (% imm0)) |
---|
| 113 | (movd (% imm0) (% fp2)) |
---|
| 114 | (get-single-float float fp1) |
---|
| 115 | (mulss (% fp2) (% fp1)) |
---|
| 116 | (put-single-float fp1 arg_z) |
---|
| 117 | (single-value-return)) |
---|
[2950] | 118 | |
---|
| 119 | (defx86lapfunction %copy-double-float ((f1 arg_y) (f2 arg_z)) |
---|
[2970] | 120 | (get-double-float f1 fp1) |
---|
| 121 | (put-double-float fp1 f2) |
---|
[3102] | 122 | (single-value-return)) |
---|
[2970] | 123 | |
---|
[2950] | 124 | (defx86lapfunction %short-float->double-float ((src arg_y) (result arg_z)) |
---|
[3176] | 125 | (get-single-float src fp1) |
---|
[3102] | 126 | (cvtss2sd (% fp1) (% fp1)) |
---|
[3176] | 127 | (put-double-float fp1 result) |
---|
[3102] | 128 | (single-value-return)) |
---|
[2950] | 129 | |
---|
| 130 | (defx86lapfunction %double-float->short-float ((src arg_z)) |
---|
[3176] | 131 | (get-double-float src fp1) |
---|
[3117] | 132 | (cvtsd2ss (% fp1) (% fp1)) |
---|
[2950] | 133 | (put-single-float fp1 arg_z) |
---|
[3117] | 134 | (single-value-return)) |
---|
[2950] | 135 | |
---|
| 136 | (defx86lapfunction %int-to-sfloat ((int arg_z)) |
---|
[3117] | 137 | (int-to-single int imm0 fp1) |
---|
| 138 | (put-single-float fp1 arg_z) |
---|
| 139 | (single-value-return)) |
---|
[2950] | 140 | |
---|
| 141 | |
---|
| 142 | (defx86lapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z)) |
---|
[3117] | 143 | (int-to-double int imm0 fp1) |
---|
| 144 | (put-double-float fp1 arg_z) |
---|
| 145 | (single-value-return)) |
---|
[2950] | 146 | |
---|
| 147 | |
---|
| 148 | |
---|
[3117] | 149 | ;;; Manipulate the MXCSR. It'll fit in a fixnum, but we have to |
---|
| 150 | ;;; load and store it through memory. On x8664, we can hide the |
---|
| 151 | ;;; 32-bit MXCSR value in a fixnum on the stack; on a 32-bit x86, |
---|
| 152 | ;;; we might need to use a scratch location in the TCR or something. |
---|
[2950] | 153 | |
---|
[3117] | 154 | ;;; Return the MXCSR as a fixnum |
---|
| 155 | (defx86lapfunction %get-mxcsr () |
---|
| 156 | (pushq ($ '0)) |
---|
[3936] | 157 | (stmxcsr (@ 4 (% rsp))) |
---|
[3117] | 158 | (pop (% arg_z)) |
---|
| 159 | (shr ($ (- 32 x8664::fixnumshift)) (% arg_z)) |
---|
| 160 | (single-value-return)) |
---|
[2950] | 161 | |
---|
[3117] | 162 | ;;; Store the fixnum in arg_z in the MXCSR. Just to be |
---|
| 163 | ;;; on the safe side, mask the arg with X86::MXCSR-WRITE-MASK, |
---|
| 164 | ;;; so that only known control and status bits are written to. |
---|
| 165 | (defx86lapfunction %set-mxcsr ((val arg_z)) |
---|
| 166 | (mov (% val) (% temp0)) |
---|
[4181] | 167 | (andl ($ '#.x86::mxcsr-write-mask) (%l temp0)) |
---|
[3117] | 168 | (shl ($ (- 32 x8664::fixnumshift)) (% temp0)) |
---|
| 169 | (push (% temp0)) |
---|
[4165] | 170 | (ldmxcsr (@ 4 (% rsp))) |
---|
[3117] | 171 | (add ($ '1) (% rsp)) |
---|
| 172 | (single-value-return)) |
---|
[2950] | 173 | |
---|
[3117] | 174 | |
---|
| 175 | ;;; Get the bits that contain exception masks and rounding mode. |
---|
| 176 | |
---|
| 177 | (defun %get-mxcsr-control () |
---|
[4181] | 178 | (logand x86::mxcsr-control-and-rounding-mask (the fixnum (%get-mxcsr)))) |
---|
[3117] | 179 | |
---|
| 180 | ;;; Get the bits that describe current exceptions. |
---|
| 181 | (defun %get-mxcsr-status () |
---|
[4181] | 182 | (logand x86::mxcsr-status-mask (the fixnum (%get-mxcsr)))) |
---|
[3117] | 183 | |
---|
| 184 | ;;; Set the bits that describe current exceptions, presumably to clear them. |
---|
| 185 | (defun %set-mxcsr-status (arg) |
---|
[4181] | 186 | (%set-mxcsr |
---|
| 187 | (logior (logand x86::mxcsr-status-mask arg) |
---|
| 188 | (logandc2 (%get-mxcsr) x86::mxcsr-status-mask))) |
---|
| 189 | arg) |
---|
[3117] | 190 | |
---|
| 191 | ;;; Set the bits that mask/unmask exceptions and control rounding. |
---|
| 192 | ;;; Clear the bits which describe current exceptions. |
---|
[3677] | 193 | (defun %set-mxcsr-control (arg) |
---|
[4181] | 194 | (%set-mxcsr (logand x86::mxcsr-control-and-rounding-mask arg))) |
---|
[3117] | 195 | |
---|
| 196 | ;;; Return the MXCSR value in effect after the last ff-call. |
---|
| 197 | (defx86lapfunction %get-post-ffi-mxcsr () |
---|
| 198 | (xor (% arg_z) (% arg_z)) |
---|
[4955] | 199 | (movl (@ (% :rcontext) x8664::tcr.ffi-exception) (%l imm0)) |
---|
| 200 | (movl (%l arg_z) (@ (% :rcontext) x8664::tcr.ffi-exception)) |
---|
[3117] | 201 | (box-fixnum imm0 arg_z) |
---|
| 202 | (single-value-return)) |
---|
| 203 | |
---|
| 204 | ;;; Return the status bits from the last ff-call that represent |
---|
| 205 | ;;; unmasked exceptions |
---|
| 206 | (defun %ffi-exception-status () |
---|
[4181] | 207 | (logior (%get-mxcsr-control) |
---|
| 208 | (logand x86::mxcsr-status-mask (the fixnum (%get-post-ffi-mxcsr))))) |
---|
| 209 | |
---|
| 210 | |
---|
[2950] | 211 | |
---|
| 212 | |
---|
[3117] | 213 | ;;; See if the binary double-float operation OP set any enabled |
---|
| 214 | ;;; exception bits in the mxcsr |
---|
[2950] | 215 | (defun %df-check-exception-2 (operation op0 op1 fp-status) |
---|
[3117] | 216 | (declare (type (unsigned-byte 6) fp-status)) |
---|
| 217 | (unless (zerop fp-status) |
---|
| 218 | (%set-mxcsr-status 0) |
---|
[2950] | 219 | ;; Ensure that operands are heap-consed |
---|
[4429] | 220 | (%fp-error-from-status fp-status |
---|
[2950] | 221 | operation |
---|
| 222 | (%copy-double-float op0 (%make-dfloat)) |
---|
| 223 | (%copy-double-float op1 (%make-dfloat))))) |
---|
| 224 | |
---|
| 225 | (defun %sf-check-exception-2 (operation op0 op1 fp-status) |
---|
[3117] | 226 | (declare (type (unsigned-byte 6) fp-status)) |
---|
| 227 | (unless (zerop fp-status) |
---|
| 228 | (%set-mxcsr-status 0) |
---|
[2950] | 229 | ;; Ensure that operands are heap-consed |
---|
| 230 | (%fp-error-from-status fp-status |
---|
| 231 | operation |
---|
[3117] | 232 | #+32-bit-target |
---|
[2950] | 233 | (%copy-short-float op0 (%make-sfloat)) |
---|
[3117] | 234 | #+64-bit-target op0 |
---|
| 235 | #+32-bit-target |
---|
[2950] | 236 | (%copy-short-float op1 (%make-sfloat)) |
---|
[3117] | 237 | #+64-bit-target op1))) |
---|
[2950] | 238 | |
---|
| 239 | (defun %df-check-exception-1 (operation op0 fp-status) |
---|
| 240 | (declare (fixnum fp-status)) |
---|
[3614] | 241 | (unless (zerop fp-status) |
---|
[3117] | 242 | (%set-mxcsr-status 0) |
---|
[2950] | 243 | ;; Ensure that operands are heap-consed |
---|
| 244 | (%fp-error-from-status fp-status |
---|
[3117] | 245 | operation |
---|
| 246 | (%copy-double-float op0 (%make-dfloat))))) |
---|
[2950] | 247 | |
---|
| 248 | (defun %sf-check-exception-1 (operation op0 fp-status) |
---|
[3117] | 249 | (declare (type (unsigned-byte 6) fp-status)) |
---|
[3614] | 250 | (unless (zerop fp-status) |
---|
[3117] | 251 | (%set-mxcsr-status 0) |
---|
| 252 | ;; Ensure that operands are heap-consed |
---|
[2950] | 253 | (%fp-error-from-status fp-status |
---|
| 254 | operation |
---|
[3117] | 255 | #+32-bit-target |
---|
[2950] | 256 | (%copy-short-float op0 (%make-sfloat)) |
---|
[3117] | 257 | #+64-bit-target op0))) |
---|
[2950] | 258 | |
---|
| 259 | |
---|
[4429] | 260 | (defun fp-condition-from-mxcsr (status-bits control-bits) |
---|
| 261 | (declare (fixnum status-bits control-bits)) |
---|
[2950] | 262 | (cond |
---|
[4429] | 263 | ((and (logbitp x86::mxcsr-ie-bit status-bits) |
---|
| 264 | (not (logbitp x86::mxcsr-im-bit control-bits))) |
---|
[2950] | 265 | 'floating-point-invalid-operation) |
---|
[4429] | 266 | ((and (logbitp x86::mxcsr-oe-bit status-bits) |
---|
| 267 | (not (logbitp x86::mxcsr-om-bit control-bits))) |
---|
[2950] | 268 | 'floating-point-overflow) |
---|
[4429] | 269 | ((and (logbitp x86::mxcsr-ue-bit status-bits) |
---|
| 270 | (not (logbitp x86::mxcsr-um-bit control-bits))) |
---|
[2950] | 271 | 'floating-point-underflow) |
---|
[4429] | 272 | ((and (logbitp x86::mxcsr-ze-bit status-bits) |
---|
| 273 | (not (logbitp x86::mxcsr-zm-bit control-bits))) |
---|
[2950] | 274 | 'division-by-zero) |
---|
[4429] | 275 | ((and (logbitp x86::mxcsr-pe-bit status-bits) |
---|
| 276 | (not (logbitp x86::mxcsr-pm-bit control-bits))) |
---|
[2950] | 277 | 'floating-point-inexact))) |
---|
| 278 | |
---|
[4618] | 279 | (defun %fp-error-from-status (status-bits operation op0 &optional op1) |
---|
[3117] | 280 | (declare (type (unsigned-byte 6) status-bits)) |
---|
[4429] | 281 | (let* ((condition-class (fp-condition-from-mxcsr status-bits (%get-mxcsr-control)))) |
---|
[2950] | 282 | (if condition-class |
---|
[4618] | 283 | (let* ((operands (if op1 (list op0 op1) (list op0)))) |
---|
| 284 | (error (make-instance condition-class |
---|
| 285 | :operation operation |
---|
| 286 | :operands operands)))))) |
---|
[2950] | 287 | |
---|
| 288 | |
---|
[4618] | 289 | |
---|
[2950] | 290 | ;;; Don't we already have about 20 versions of this ? |
---|
| 291 | (defx86lapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z)) |
---|
[3176] | 292 | (macptr-ptr ptr imm0) |
---|
| 293 | (unbox-fixnum byte-offset imm1) |
---|
| 294 | (movsd (@ (% imm0) (% imm1)) (% fp1)) |
---|
[2950] | 295 | (put-double-float fp1 dest) |
---|
[3176] | 296 | (single-value-return)) |
---|
[2950] | 297 | |
---|
| 298 | |
---|
| 299 | (defvar *rounding-mode-alist* |
---|
| 300 | '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3))) |
---|
| 301 | |
---|
| 302 | (defun get-fpu-mode (&optional (mode nil mode-p)) |
---|
[3117] | 303 | (let* ((flags (%get-mxcsr-control))) |
---|
[4181] | 304 | (declare (fixnum flags)) |
---|
[3117] | 305 | (let* ((rounding-mode |
---|
[4181] | 306 | (car (nth (+ (if (logbitp x86::mxcsr-rc0-bit flags) 1 0) |
---|
| 307 | (if (logbitp x86::mxcsr-rc1-bit flags) 2 0)) |
---|
[3117] | 308 | *rounding-mode-alist*))) |
---|
[4181] | 309 | (overflow (not (logbitp x86::mxcsr-om-bit flags))) |
---|
| 310 | (underflow (not (logbitp x86::mxcsr-um-bit flags))) |
---|
| 311 | (division-by-zero (not (logbitp x86::mxcsr-zm-bit flags))) |
---|
| 312 | (invalid (not (logbitp x86::mxcsr-im-bit flags))) |
---|
| 313 | (inexact (not (logbitp x86::mxcsr-pm-bit flags)))) |
---|
[2950] | 314 | (if mode-p |
---|
| 315 | (ecase mode |
---|
[3117] | 316 | (:rounding-mode rounding-mode) |
---|
| 317 | (:overflow overflow) |
---|
| 318 | (:underflow underflow) |
---|
| 319 | (:division-by-zero division-by-zero) |
---|
| 320 | (:invalid invalid) |
---|
[3614] | 321 | (:inexact inexact)) |
---|
[3117] | 322 | `(:rounding-mode ,rounding-mode |
---|
| 323 | :overflow ,overflow |
---|
| 324 | :underflow ,underflow |
---|
| 325 | :division-by-zero ,division-by-zero |
---|
| 326 | :invalid ,invalid |
---|
| 327 | :inexact ,inexact))))) |
---|
[2950] | 328 | |
---|
| 329 | ;;; did we document this? |
---|
| 330 | (defun set-fpu-mode (&key (rounding-mode :nearest rounding-p) |
---|
| 331 | (overflow t overflow-p) |
---|
| 332 | (underflow t underflow-p) |
---|
| 333 | (division-by-zero t zero-p) |
---|
| 334 | (invalid t invalid-p) |
---|
| 335 | (inexact t inexact-p)) |
---|
[4181] | 336 | (let* ((current (%get-mxcsr-control)) |
---|
| 337 | (new current)) |
---|
| 338 | (declare (fixnum current new)) |
---|
| 339 | (when rounding-p |
---|
| 340 | (let* ((rc-bits (or |
---|
| 341 | (cdr (assoc rounding-mode *rounding-mode-alist*)) |
---|
| 342 | (error "Unknown rounding mode: ~s" rounding-mode)))) |
---|
| 343 | (declare (fixnum rc-bits)) |
---|
| 344 | (if (logbitp 0 rc-bits) |
---|
| 345 | (bitsetf x86::mxcsr-rc0-bit new) |
---|
| 346 | (bitclrf x86::mxcsr-rc0-bit new)) |
---|
| 347 | (if (logbitp 1 rc-bits) |
---|
| 348 | (bitsetf x86::mxcsr-rc1-bit new) |
---|
| 349 | (bitclrf x86::mxcsr-rc1-bit new)))) |
---|
| 350 | (when invalid-p |
---|
| 351 | (if invalid |
---|
| 352 | (bitclrf x86::mxcsr-im-bit new) |
---|
| 353 | (bitsetf x86::mxcsr-im-bit new))) |
---|
| 354 | (when overflow-p |
---|
| 355 | (if overflow |
---|
| 356 | (bitclrf x86::mxcsr-om-bit new) |
---|
| 357 | (bitsetf x86::mxcsr-om-bit new))) |
---|
| 358 | (when underflow-p |
---|
| 359 | (if underflow |
---|
| 360 | (bitclrf x86::mxcsr-um-bit new) |
---|
| 361 | (bitsetf x86::mxcsr-um-bit new))) |
---|
| 362 | (when zero-p |
---|
| 363 | (if division-by-zero |
---|
| 364 | (bitclrf x86::mxcsr-zm-bit new) |
---|
| 365 | (bitsetf x86::mxcsr-zm-bit new))) |
---|
| 366 | (when inexact-p |
---|
| 367 | (if inexact |
---|
| 368 | (bitclrf x86::mxcsr-pm-bit new) |
---|
| 369 | (bitsetf x86::mxcsr-pm-bit new))) |
---|
| 370 | (unless (= current new) |
---|
| 371 | (%set-mxcsr-control new)) |
---|
| 372 | (%get-mxcsr))) |
---|
[2950] | 373 | |
---|
| 374 | |
---|
[4181] | 375 | |
---|
[2950] | 376 | ;;; Copy a single float pointed at by the macptr in single |
---|
| 377 | ;;; to a double float pointed at by the macptr in double |
---|
| 378 | |
---|
| 379 | (defx86lapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z)) |
---|
| 380 | (check-nargs 2) |
---|
[3176] | 381 | (macptr-ptr single imm0) |
---|
| 382 | (movss (@ (% imm0)) (% fp1)) |
---|
| 383 | (cvtss2sd (% fp1) (% fp1)) |
---|
| 384 | (macptr-ptr double imm0) |
---|
| 385 | (movsd (% fp1) (@ (% imm0))) |
---|
| 386 | (single-value-return)) |
---|
[2950] | 387 | |
---|
| 388 | ;;; Copy a double float pointed at by the macptr in double |
---|
| 389 | ;;; to a single float pointed at by the macptr in single. |
---|
| 390 | (defx86lapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z)) |
---|
| 391 | (check-nargs 2) |
---|
[3176] | 392 | (macptr-ptr double imm0) |
---|
| 393 | (movsd (@ (% imm0)) (% fp1)) |
---|
| 394 | (cvtsd2ss (% fp1) (% fp1)) |
---|
| 395 | (macptr-ptr single imm0) |
---|
[4406] | 396 | (movss (% fp1) (@ (% imm0))) |
---|
[3176] | 397 | (single-value-return)) |
---|
[2950] | 398 | |
---|
| 399 | |
---|
| 400 | (defx86lapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z)) |
---|
| 401 | (check-nargs 2) |
---|
[3176] | 402 | (macptr-ptr macptr imm0) |
---|
| 403 | (get-double-float src fp1) |
---|
| 404 | (cvtsd2ss (% fp1) (% fp1)) |
---|
| 405 | (movss (% fp1) (@ (% imm0))) |
---|
| 406 | (single-value-return)) |
---|
[2950] | 407 | |
---|
| 408 | (defx86lapfunction host-single-float-from-unsigned-byte-32 ((u32 arg_z)) |
---|
| 409 | (shl ($ (- 32 x8664::fixnumshift)) (% arg_z)) |
---|
| 410 | (movb ($ x8664::subtag-single-float) (% arg_z.b)) |
---|
[3102] | 411 | (single-value-return)) |
---|
[2950] | 412 | |
---|
| 413 | (defx86lapfunction single-float-bits ((f arg_z)) |
---|
| 414 | (shr ($ (- 32 x8664::fixnumshift)) (% f)) |
---|
[3102] | 415 | (single-value-return)) |
---|
[2950] | 416 | |
---|
| 417 | (defun double-float-bits (f) |
---|
| 418 | (values (uvref f target::double-float.val-high-cell) |
---|
| 419 | (uvref f target::double-float.val-low-cell))) |
---|
| 420 | |
---|
| 421 | (defun double-float-from-bits (high low) |
---|
| 422 | (let* ((f (%make-dfloat))) |
---|
[3614] | 423 | (setf (uvref f target::double-float.val-high-cell) high |
---|
[2950] | 424 | (uvref f target::double-float.val-low-cell) low) |
---|
| 425 | f)) |
---|
| 426 | |
---|
| 427 | ;;; Return T if n is negative, else NIL. |
---|
| 428 | (defx86lapfunction %double-float-sign ((n arg_z)) |
---|
| 429 | (movl (@ x8664::double-float.val-high (% n)) (% imm0.l)) |
---|
[2970] | 430 | (testl (% imm0.l) (% imm0.l)) |
---|
| 431 | (movl ($ x8664::t-value) (% imm0.l)) |
---|
[2950] | 432 | (movl ($ x8664::nil-value) (% arg_z.l)) |
---|
| 433 | (cmovlq (% imm0) (% arg_z)) |
---|
[3102] | 434 | (single-value-return)) |
---|
[2950] | 435 | |
---|
[3176] | 436 | |
---|
[2950] | 437 | (defx86lapfunction %short-float-sign ((n arg_z)) |
---|
[3102] | 438 | (testq (% n) (% n)) |
---|
| 439 | (movl ($ x8664::t-value) (% imm0.l)) |
---|
| 440 | (movl ($ x8664::nil-value) (% arg_z.l)) |
---|
| 441 | (cmovlq (% imm0) (% arg_z)) |
---|
| 442 | (single-value-return)) |
---|
[2950] | 443 | |
---|
[5627] | 444 | (defx86lapfunction %double-float-sqrt! ((n arg_y) (result arg_z)) |
---|
| 445 | (get-double-float n fp0) |
---|
| 446 | (sqrtsd (% fp0) (% fp0)) |
---|
| 447 | (put-double-float fp0 result) |
---|
| 448 | (single-value-return)) |
---|
| 449 | |
---|
| 450 | (defx86lapfunction %single-float-sqrt ((n arg_z)) |
---|
| 451 | (get-single-float n fp0) |
---|
| 452 | (sqrtss (% fp0) (% fp0)) |
---|
| 453 | (put-single-float fp0 arg_z) |
---|
| 454 | (single-value-return)) |
---|
| 455 | |
---|
[4165] | 456 | ;;; end of x86-float.lisp |
---|