 Timestamp:
 Jul 24, 2010, 11:35:30 PM (9 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

branches/arm/level0/ARM/armfloat.lisp
r13998 r14037 269 269 270 270 (defarmlapfunction %ffiexceptionstatus () 271 (mov arg_z (:$ 0)) ;for now 271 (ldr imm1 (:@ rcontext (:$ arm::tcr.lispfpscr))) 272 (fmrx imm2 fpscr) 273 (and imm0 imm2 (:$ #xff)) 274 (ands imm0 imm0 (:lsr imm1 (:$ 8))) 275 (moveq arg_z 'nil) 276 (bxeq lr) 277 (mov arg_z (:lsl imm0 (:$ arm::fixnumshift))) 278 (bic imm0 imm2 (:$ #xff)) 279 (fmxr fpscr imm0) 272 280 (bx lr)) 273 281 274 282 (defun %sfcheckexception1 (operation op0 fpstatus) 275 (declare (ignore operation op0 fpstatus))) 283 (when fpstatus 284 (let* ((conditionname (fpconditionnamefromfpscrstatus fpstatus))) 285 (error (makeinstance (or conditionname 'arithmeticerror) 286 :operation operation 287 :operands (list (%copyshortfloat op0 (%makesfloat)))))))) 288 289 (defun %sfcheckexception2 (operation op0 op1 fpstatus) 290 (when fpstatus 291 (let* ((conditionname (fpconditionnamefromfpscrstatus fpstatus))) 292 (error (makeinstance (or conditionname 'arithmeticerror) 293 :operation operation 294 :operands (list (%copyshortfloat op0 (%makesfloat)) 295 (%copyshortfloat op1 (%makesfloat)))))))) 296 276 297 277 298 (defun %dfcheckexception1 (operation op0 fpstatus) 278 (declare (ignore operation op0 fpstatus))) 299 (when fpstatus 300 (let* ((conditionname (fpconditionnamefromfpscrstatus fpstatus))) 301 (error (makeinstance (or conditionname 'arithmeticerror) 302 :operation operation 303 :operands (list (%copydoublefloat op0 (%makedfloat)))))))) 304 305 ; See if the binary doublefloat operation OP set any enabled 306 ; exception bits in the fpscr 307 (defun %dfcheckexception2 (operation op0 op1 fpstatus) 308 (when fpstatus 309 (let* ((conditionname (fpconditionnamefromfpscrstatus fpstatus))) 310 (error (makeinstance (or conditionname 'arithmeticerror) 311 :operation operation 312 :operands (list (%copydoublefloat op0 (%makedfloat)) 313 (%copydoublefloat op1 (%makedfloat)))))))) 279 314 280 315 (defvar *roundingmodealist* … … 414 449 415 450 416 #+notyet417 (progn418 419 ; See if the binary doublefloat operation OP set any enabled420 ; exception bits in the fpscr421 (defun %dfcheckexception2 (operation op0 op1 fpstatus)422 (declare (type (unsignedbyte 24) fpstatus))423 (when (logbitp ( 23 ppc::fpscrfexbit) fpstatus)424 (%setfpscrstatus 0)425 ;; Ensure that operands are heapconsed426 (%fperrorfromstatus fpstatus427 (%getfpscrcontrol)428 operation429 (%copydoublefloat op0 (%makedfloat))430 (%copydoublefloat op1 (%makedfloat)))))431 432 (defun %sfcheckexception2 (operation op0 op1 fpstatus)433 (declare (type (unsignedbyte 24) fpstatus))434 (when (logbitp ( 23 ppc::fpscrfexbit) fpstatus)435 (%setfpscrstatus 0)436 ;; Ensure that operands are heapconsed437 (%fperrorfromstatus fpstatus438 (%getfpscrcontrol)439 operation440 441 (%copyshortfloat op0 (%makesfloat))442 443 (%copyshortfloat op1 (%makesfloat)))))444 445 (defun %dfcheckexception1 (operation op0 fpstatus)446 (declare (fixnum fpstatus))447 (when (logbitp ( 23 ppc::fpscrfexbit) fpstatus)448 (%setfpscrstatus 0)449 ;; Ensure that operands are heapconsed450 (%fperrorfromstatus fpstatus451 (%getfpscrcontrol)452 operation453 (%copydoublefloat op0 (%makedfloat)))))454 455 (defun %sfcheckexception1 (operation op0 fpstatus)456 (declare (type (unsignedbyte 24) fpstatus))457 (when (logbitp ( 23 ppc::fpscrfexbit) fpstatus)458 (%setfpscrstatus 0)459 ; Ensure that operands are heapconsed460 (%fperrorfromstatus fpstatus461 (%getfpscrcontrol)462 operation463 464 (%copyshortfloat op0 (%makesfloat)))))465 466 467 (defun fpconditionfromfpscr (statusbits controlbits)468 (declare (fixnum statusbits controlbits))469 (cond470 ((and (logbitp ( 23 ppc::fpscrvxbit) statusbits)471 (logbitp ( 31 ppc::fpscrvebit) controlbits))472 'floatingpointinvalidoperation)473 ((and (logbitp ( 23 ppc::fpscroxbit) statusbits)474 (logbitp ( 31 ppc::fpscroebit) controlbits))475 'floatingpointoverflow)476 ((and (logbitp ( 23 ppc::fpscruxbit) statusbits)477 (logbitp ( 31 ppc::fpscruebit) controlbits))478 'floatingpointunderflow)479 ((and (logbitp ( 23 ppc::fpscrzxbit) statusbits)480 (logbitp ( 31 ppc::fpscrzebit) controlbits))481 'divisionbyzero)482 ((and (logbitp ( 23 ppc::fpscrxxbit) statusbits)483 (logbitp ( 31 ppc::fpscrxebit) controlbits))484 'floatingpointinexact)))485 486 ;;; This assumes that the FEX and one of {VX OX UX ZX XX} is set.487 (defun %fperrorfromstatus (statusbits controlbits operation &rest operands)488 (declare (type (unsignedbyte 16) statusbits))489 (case operation490 (sqrt (setq operands (cdr operands))))491 (let* ((conditionclass (fpconditionfromfpscr statusbits controlbits)))492 (if conditionclass493 (error (makeinstance conditionclass494 :operation operation495 :operands operands)))))496 497 (defun fpminoropcodeoperation (minoropcode)498 (case minoropcode499 (25 '*)500 (18 '/)501 (20 ')502 (21 '+)503 (22 'sqrt)504 (t 'unknown)))505 506 );#+notyet507 508 451 ;;; Don't we already have about 20 versions of this ? 509 452 (defarmlapfunction %doublefloatfrommacptr! ((ptr arg_x) (byteoffset arg_y) (dest arg_z)) … … 513 456 (strd imm0 (:@ dest (:$ arm::doublefloat.value))) 514 457 (bx lr)) 515 516 517 #+notyet518 (progn519 (defvar *roundingmodealist*520 '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3)))521 522 (defun getfpumode (&optional (mode nil modep))523 (let* ((flags (%getfpscrcontrol)))524 (declare (type (unsignedbyte 8) flags))525 (if modep526 (ecase mode527 (:roundingmode (car (nth (logand flags 3) *roundingmodealist*)))528 (:overflow (logbitp ( 31 ppc::fpscroebit) flags))529 (:underflow (logbitp ( 31 ppc::fpscruebit) flags))530 (:divisionbyzero (logbitp ( 31 ppc::fpscrzebit) flags))531 (:invalid (logbitp ( 31 ppc::fpscrvebit) flags))532 (:inexact (logbitp ( 31 ppc::fpscrxebit) flags)))533 `(:roundingmode ,(car (nth (logand flags 3) *roundingmodealist*))534 :overflow ,(logbitp ( 31 ppc::fpscroebit) flags)535 :underflow ,(logbitp ( 31 ppc::fpscruebit) flags)536 :divisionbyzero ,(logbitp ( 31 ppc::fpscrzebit) flags)537 :invalid ,(logbitp ( 31 ppc::fpscrvebit) flags)538 :inexact ,(logbitp ( 31 ppc::fpscrxebit) flags)))))539 540 ;;; did we document this?541 (defun setfpumode (&key (roundingmode :nearest roundingp)542 (overflow t overflowp)543 (underflow t underflowp)544 (divisionbyzero t zerop)545 (invalid t invalidp)546 (inexact t inexactp))547 (let* ((mask (logior (if roundingp #x03 #x00)548 (if invalidp549 (ash 1 ( 31 ppc::fpscrvebit))550 #x00)551 (if overflowp552 (ash 1 ( 31 ppc::fpscroebit))553 #x00)554 (if underflowp555 (ash 1 ( 31 ppc::fpscruebit))556 #x00)557 (if zerop558 (ash 1 ( 31 ppc::fpscrzebit))559 #x00)560 (if inexactp561 (ash 1 ( 31 ppc::fpscrxebit))562 #x00)))563 (new (logior (or (cdr (assoc roundingmode *roundingmodealist*))564 (error "Unknown rounding mode: ~s" roundingmode))565 (if invalid (ash 1 ( 31 ppc::fpscrvebit)) 0)566 (if overflow (ash 1 ( 31 ppc::fpscroebit)) 0)567 (if underflow (ash 1 ( 31 ppc::fpscruebit)) 0)568 (if divisionbyzero (ash 1 ( 31 ppc::fpscrzebit)) 0)569 (if inexact (ash 1 ( 31 ppc::fpscrxebit)) 0))))570 (declare (type (unsignedbyte 8) new mask))571 (%setfpscrcontrol (logior (logand new mask)572 (logandc2 (%getfpscrcontrol) mask)))))573 )574 458 575 459 … … 646 530 647 531 (defarmlapfunction %singlefloatsqrt! ((src arg_y) (dest arg_z)) 532 (buildlispframe) 648 533 (getsinglefloat s0 src imm0) 534 (fmrx imm0 fpscr) 535 (bic imm0 imm0 (:$ #xff)) 536 (fmxr fpscr imm0) 649 537 (fsqrts s1 s0) 538 (bl .SPcheckfpuexception) 650 539 (putsinglefloat s1 dest imm0) 651 ( bx lr))540 (returnlispframe)) 652 541 653 542 654 543 655 544 (defarmlapfunction %doublefloatsqrt! ((src arg_y) (dest arg_z)) 545 (buildlispframe) 656 546 (getdoublefloat d0 src) 547 (fmrx imm0 fpscr) 548 (bic imm0 imm0 (:$ #xff)) 549 (fmxr fpscr imm0) 657 550 (fsqrtd d1 d0) 551 (bl .SPcheckfpuexception) 658 552 (putdoublefloat d1 dest) 659 ( bx lr))660 661 553 (returnlispframe)) 554 555
Note: See TracChangeset
for help on using the changeset viewer.