home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / machines / spectrum / rulflo.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  19.0 KB  |  571 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rulflo.scm,v 4.40 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1989-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; LAP Generation Rules: Flonum rules
  23. ;; Package: (compiler lap-syntaxer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (flonum-source! register)
  28.   (float-register->fpr (load-alias-register! register 'FLOAT)))
  29.  
  30. (define (flonum-target! pseudo-register)
  31.   (delete-dead-registers!)
  32.   (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT)))
  33.  
  34. (define (flonum-temporary!)
  35.   (float-register->fpr (allocate-temporary-register! 'FLOAT)))
  36.  
  37. (define-rule statement
  38.   ;; convert a floating-point number to a flonum object
  39.   (ASSIGN (REGISTER (? target))
  40.       (FLOAT->OBJECT (REGISTER (? source))))
  41.   (let ((source (flonum-source! source))
  42.     (temp (standard-temporary!)))
  43.     (let ((target (standard-target! target)))
  44.       (LAP
  45.        ;; make heap parsable forwards
  46.        ;; (STW () 0 (OFFSET 0 0 ,regnum:free-pointer))    
  47.        (DEPI () #b100 31 3 ,regnum:free-pointer)        ; quad align
  48.        (COPY () ,regnum:free-pointer ,target)
  49.        ,@(deposit-type (ucode-type flonum) target)
  50.        ,@(load-non-pointer (ucode-type manifest-nm-vector) 2 temp)
  51.        (STWS (MA C) ,temp (OFFSET 4 0 ,regnum:free-pointer))
  52.        (FSTDS (MA) ,source (OFFSET 8 0 ,regnum:free-pointer))))))
  53.  
  54. (define-rule statement
  55.   ;; convert a flonum object to a floating-point number
  56.   (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
  57.   (let ((source (standard-move-to-temporary! source)))
  58.     (LAP ,@(object->address source)
  59.      (FLDDS () (OFFSET 4 0 ,source) ,(flonum-target! target)))))
  60.  
  61. ;; This is endianness dependent!
  62.  
  63. (define (flonum-value->data-decl value)
  64.   (let ((high (make-bit-string 32 false))
  65.     (low (make-bit-string 32 false)))
  66.     (read-bits! value 32 high)
  67.     (read-bits! value 64 low)
  68.     (LAP ,@(lap:comment `(FLOAT ,value))
  69.      (UWORD () ,(bit-string->unsigned-integer high))
  70.      (UWORD () ,(bit-string->unsigned-integer low)))))
  71.  
  72. (define (flonum->label value)
  73.   (let* ((block
  74.       (or (find-extra-code-block 'FLOATING-CONSTANTS)
  75.           (let ((block (declare-extra-code-block! 'FLOATING-CONSTANTS
  76.                               'ANYWHERE
  77.                               '())))
  78.         (add-extra-code!
  79.          block
  80.          (LAP (PADDING ,(- 0 *initial-dword-offset*) 8)))
  81.         block)))
  82.      (pairs (extra-code-block/xtra block))
  83.      (place (assoc value pairs)))
  84.     (if place
  85.     (cdr place)
  86.     (let ((label (generate-label)))
  87.       (set-extra-code-block/xtra!
  88.        block
  89.        (cons (cons value label) pairs))
  90.       (add-extra-code! block
  91.                (LAP (LABEL ,label)
  92.                 ,@(flonum-value->data-decl value)))
  93.       label))))     
  94.                      
  95. #|
  96. (define-rule statement
  97.   (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT 0.)))
  98.   (LAP (FCPY (DBL) 0 ,(flonum-target! target))))
  99. |#
  100.  
  101. (define-rule statement
  102.   (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT (? fp-value))))
  103.   (cond ((not (flo:flonum? fp-value))
  104.      (error "OBJECT->FLOAT: Not a floating-point value" fp-value))
  105.     (compiler:cross-compiling?
  106.      (let ((temp (standard-temporary!)))
  107.        (LAP ,@(load-constant fp-value temp)
  108.         ,@(object->address temp)
  109.         (FLDDS () (OFFSET 4 0 ,temp) ,(flonum-target! target)))))
  110.     ((flo:= fp-value 0.0)
  111.      (LAP (FCPY (DBL) 0 ,(flonum-target! target))))
  112.     (else
  113.      (let* ((temp (standard-temporary!))
  114.         (target (flonum-target! target)))
  115.        (LAP ,@(load-pc-relative-address (flonum->label fp-value)
  116.                         temp
  117.                         'CONSTANT)
  118.         (FLDDS () (OFFSET 0 0 ,temp) ,target))))))  
  119.  
  120. (define-rule statement
  121.   (ASSIGN (REGISTER (? target))
  122.       (FLOAT-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))))
  123.   (float-load/offset target base (* 8 offset)))
  124.  
  125. (define-rule statement
  126.   (ASSIGN (REGISTER (? target))
  127.       (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
  128.                     (MACHINE-CONSTANT (? w-offset)))
  129.             (MACHINE-CONSTANT (? f-offset))))
  130.   (float-load/offset target base (+ (* 4 w-offset) (* 8 f-offset))))      
  131.  
  132. (define-rule statement
  133.   (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
  134.       (REGISTER (? source)))
  135.   (float-store/offset base (* 8 offset) source))
  136.  
  137. (define-rule statement
  138.   (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
  139.                     (MACHINE-CONSTANT (? w-offset)))
  140.             (MACHINE-CONSTANT (? f-offset)))
  141.       (REGISTER (? source)))
  142.   (float-store/offset base (+ (* 4 w-offset) (* 8 f-offset)) source))
  143.  
  144. (define-rule statement
  145.   (ASSIGN (REGISTER (? target))
  146.       (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index))))
  147.   (let* ((base (standard-source! base))
  148.      (index (standard-source! index))
  149.      (target (flonum-target! target)))
  150.     (LAP (FLDDX (S) (INDEX ,index 0 ,base) ,target))))
  151.  
  152. (define-rule statement
  153.   (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index)))
  154.       (REGISTER (? source)))
  155.   (let ((source (flonum-source! source))
  156.     (base (standard-source! base))
  157.     (index (standard-source! index)))
  158.     (LAP (FSTDX (S) ,source (INDEX ,index 0 ,base)))))
  159.  
  160. (define (float-load/offset target base offset)
  161.   (let ((base (standard-source! base)))
  162.     (%float-load/offset (flonum-target! target)
  163.             base
  164.             offset)))
  165.  
  166. (define (float-store/offset base offset source)
  167.   (%float-store/offset (standard-source! base)
  168.                offset
  169.                (flonum-source! source)))
  170.  
  171. (define (%float-load/offset target base offset)
  172.   (if (<= -16 offset 15)
  173.       (LAP (FLDDS () (OFFSET ,offset 0 ,base) ,target))
  174.       (let ((base* (standard-temporary!)))
  175.     (LAP (LDO () (OFFSET ,offset 0 ,base) ,base*)
  176.          (FLDDS () (OFFSET 0 0 ,base*) ,target)))))
  177.  
  178. (define (%float-store/offset base offset source)
  179.   (if (<= -16 offset 15)
  180.       (LAP (FSTDS () ,source (OFFSET ,offset 0 ,base)))
  181.       (let ((base* (standard-temporary!)))
  182.     (LAP (LDO () (OFFSET ,offset 0 ,base) ,base*)
  183.          (FSTDS () ,source (OFFSET 0 0 ,base*))))))
  184.  
  185. ;;;; Optimized floating-point references
  186.  
  187. (define-rule statement
  188.   (ASSIGN (REGISTER (? target))
  189.       (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
  190.                     (MACHINE-CONSTANT (? w-offset)))
  191.             (MACHINE-CONSTANT (? f-offset))))
  192.   (let ((b-offset (+ (* 4 w-offset) (* 8 f-offset))))
  193.     (reuse-pseudo-register-alias!
  194.      base 'GENERAL
  195.      (lambda (base)
  196.        (let ((target (flonum-target! target)))
  197.      (LAP ,@(object->address base)
  198.           ,@(%float-load/offset target base b-offset))))
  199.      (lambda ()
  200.        (let* ((base (standard-source! base))
  201.           (base* (standard-temporary!))
  202.           (target (flonum-target! target)))
  203.      (LAP (LDO () (OFFSET ,b-offset 0 ,base) ,base*)
  204.           ,@(object->address base*)
  205.           (FLDDS () (OFFSET 0 0 ,base*) ,target)))))))
  206.  
  207. (define-rule statement
  208.   (ASSIGN (REGISTER (? target))
  209.       (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
  210.                     (MACHINE-CONSTANT (? offset)))
  211.             (OBJECT->DATUM (REGISTER (? index)))))
  212.   (let ((base (standard-source! base))
  213.     (index (standard-source! index))
  214.     (temp (standard-temporary!)))
  215.     (let ((target (flonum-target! target)))
  216.       (LAP (SH3ADDL () ,index ,base ,temp)
  217.        ,@(object->address temp)
  218.        ,@(%float-load/offset target temp (* 4 offset))))))
  219.  
  220. (define-rule statement
  221.   (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
  222.                     (MACHINE-CONSTANT (? offset)))
  223.             (OBJECT->DATUM (REGISTER (? index))))
  224.       (REGISTER (? source)))
  225.   (let ((source (flonum-source! source))
  226.     (base (standard-source! base))
  227.     (index (standard-source! index))
  228.     (temp (standard-temporary!)))
  229.     (LAP (SH3ADDL () ,index ,base ,temp)
  230.      ,@(object->address temp)
  231.      ,@(%float-store/offset temp (* 4 offset) source))))
  232.  
  233. ;;;; Intermediate rules needed to generate the above.
  234.  
  235. (define-rule statement
  236.   (ASSIGN (REGISTER (? target))
  237.       (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
  238.               (MACHINE-CONSTANT (? offset))))
  239.   (let* ((base (standard-source! base))
  240.      (target (standard-target! target)))
  241.     (LAP (LDO () (OFFSET ,(* 4 offset) 0 ,base) ,target)
  242.      ,@(object->address target))))    
  243.  
  244. (define-rule statement
  245.   (ASSIGN (REGISTER (? target))
  246.       (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
  247.                     (MACHINE-CONSTANT (? offset)))
  248.             (OBJECT->DATUM (REGISTER (? index)))))
  249.   (let ((base (standard-source! base))
  250.     (index (standard-source! index))
  251.     (temp (standard-temporary!)))
  252.     (let ((target (flonum-target! target)))
  253.       (LAP ,@(object->datum index temp)
  254.        (SH3ADDL () ,temp ,base ,temp)
  255.        ,@(%float-load/offset target temp (* 4 offset))))))
  256.  
  257. (define-rule statement
  258.   (ASSIGN (REGISTER (? target))
  259.       (FLOAT-OFFSET (REGISTER (? base))
  260.             (OBJECT->DATUM (REGISTER (? index)))))
  261.   (let ((base (standard-source! base))
  262.     (index (standard-source! index))
  263.     (temp (standard-temporary!)))
  264.     (let ((target (flonum-target! target)))
  265.       (LAP ,@(object->datum index temp)
  266.        (FLDDX (S) (INDEX ,temp 0 ,base) ,target)))))
  267.  
  268. (define-rule statement
  269.   (ASSIGN (REGISTER (? target))
  270.       (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
  271.                     (MACHINE-CONSTANT (? offset)))
  272.             (REGISTER (? index))))
  273.   (let ((base (standard-source! base))
  274.     (index (standard-source! index))
  275.     (temp (standard-temporary!)))
  276.     (let ((target (flonum-target! target)))
  277.       (LAP (SH3ADDL () ,index ,base ,temp)
  278.        ,@(%float-load/offset target temp (* 4 offset))))))
  279.  
  280. (define-rule statement
  281.   (ASSIGN (REGISTER (? target))
  282.       (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
  283.                     (MACHINE-CONSTANT (? offset)))
  284.             (REGISTER (? index))))
  285.   (let ((base (standard-source! base))
  286.     (index (standard-source! index))
  287.     (temp (standard-temporary!)))
  288.     (let ((target (flonum-target! target)))
  289.       (LAP (SH3ADDL () ,index ,base ,temp)
  290.        ,@(object->address temp)
  291.        ,@(%float-load/offset target temp (* 4 offset))))))
  292.  
  293. (define-rule statement
  294.   (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
  295.                     (MACHINE-CONSTANT (? offset)))
  296.             (OBJECT->DATUM (REGISTER (? index))))
  297.       (REGISTER (? source)))
  298.   (let ((base (standard-source! base))
  299.     (index (standard-source! index))
  300.     (temp (standard-temporary!))
  301.     (source (flonum-source! source)))
  302.     (LAP ,@(object->datum index temp)
  303.      (SH3ADDL () ,temp ,base ,temp)
  304.      ,@(%float-store/offset temp (* 4 offset) source))))
  305.  
  306. (define-rule statement
  307.   (ASSIGN (FLOAT-OFFSET (REGISTER (? base))
  308.             (OBJECT->DATUM (REGISTER (? index))))
  309.       (REGISTER (? source)))
  310.   (let ((base (standard-source! base))
  311.     (index (standard-source! index))
  312.     (temp (standard-temporary!))
  313.     (source (flonum-source! source)))
  314.     (LAP ,@(object->datum index temp)
  315.      (FSTDX (S) ,source (INDEX ,temp 0 ,base)))))
  316.  
  317. (define-rule statement
  318.   (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
  319.                     (MACHINE-CONSTANT (? offset)))
  320.             (REGISTER (? index)))
  321.       (REGISTER (? source)))
  322.   (let ((base (standard-source! base))
  323.     (index (standard-source! index))
  324.     (temp (standard-temporary!))
  325.     (source (flonum-source! source)))
  326.     (LAP (SH3ADDL () ,index ,base ,temp)
  327.      ,@(%float-store/offset temp (* 4 offset) source))))
  328.  
  329. (define-rule statement
  330.   (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
  331.                     (MACHINE-CONSTANT (? offset)))
  332.             (REGISTER (? index)))
  333.       (REGISTER (? source)))
  334.   (let ((base (standard-source! base))
  335.     (index (standard-source! index))
  336.     (temp (standard-temporary!))
  337.     (source (flonum-source! source)))
  338.     (LAP (SH3ADDL () ,index ,base ,temp)
  339.      ,@(object->address temp)
  340.      ,@(%float-store/offset temp (* 4 offset) source))))
  341.  
  342. ;;;; Flonum Arithmetic
  343.  
  344. (define-rule statement
  345.   (ASSIGN (REGISTER (? target))
  346.       (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
  347.   (QUALIFIER (arithmetic-method? operation flonum-methods/1-arg))
  348.   overflow?                ;ignore
  349.   (let ((source (flonum-source! source)))
  350.     ((flonum-1-arg/operator operation) (flonum-target! target) source)))
  351.  
  352. (define (flonum-1-arg/operator operation)
  353.   (lookup-arithmetic-method operation flonum-methods/1-arg))
  354.  
  355. (define flonum-methods/1-arg
  356.   (list 'FLONUM-METHODS/1-ARG))
  357.  
  358. ;;; Notice the weird ,', syntax here.
  359. ;;; If LAP changes, this may also have to change.
  360.  
  361. (let-syntax
  362.     ((define-flonum-operation
  363.        (macro (primitive-name opcode)
  364.      `(define-arithmetic-method ',primitive-name flonum-methods/1-arg
  365.         (lambda (target source)
  366.           (LAP (,opcode (DBL) ,',source ,',target)))))))
  367.   (define-flonum-operation FLONUM-ABS FABS)
  368.   (define-flonum-operation FLONUM-SQRT FSQRT)
  369.   (define-flonum-operation FLONUM-ROUND FRND))
  370.  
  371. (define-arithmetic-method 'FLONUM-NEGATE flonum-methods/1-arg
  372.   (lambda (target source)
  373.     ;; The status register (fr0) reads as 0 for non-store instructions.
  374.     (LAP (FSUB (DBL) 0 ,source ,target))))
  375.  
  376. (define-rule statement
  377.   (ASSIGN (REGISTER (? target))
  378.       (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
  379.   (QUALIFIER (arithmetic-method? operation flonum-methods/1-arg/special))
  380.   overflow?                ;ignore
  381.   (flonum/1-arg/special
  382.    (lookup-arithmetic-method operation flonum-methods/1-arg/special)
  383.    target source))
  384.  
  385. (define flonum-methods/1-arg/special
  386.   (list 'FLONUM-METHODS/1-ARG/SPECIAL))
  387.  
  388. (let-syntax ((define-out-of-line
  389.            (macro (name)
  390.          `(define-arithmetic-method ',name flonum-methods/1-arg/special
  391.             ,(symbol-append 'HOOK:COMPILER- name)))))
  392.   (define-out-of-line FLONUM-SIN)
  393.   (define-out-of-line FLONUM-COS)
  394.   (define-out-of-line FLONUM-TAN)
  395.   (define-out-of-line FLONUM-ASIN)
  396.   (define-out-of-line FLONUM-ACOS)
  397.   (define-out-of-line FLONUM-ATAN)
  398.   (define-out-of-line FLONUM-EXP)
  399.   (define-out-of-line FLONUM-LOG)
  400.   (define-out-of-line FLONUM-TRUNCATE)
  401.   (define-out-of-line FLONUM-CEILING)
  402.   (define-out-of-line FLONUM-FLOOR))
  403.  
  404. (define caller-saves-registers
  405.   (list
  406.    ;; g1 g19 g20 g21 g22        ; Not available for allocation
  407.    g23 g24 g25 g26 g28 g29 g31
  408.    ;; fp0 fp1 fp2 fp3            ; Not real registers
  409.    fp4 fp5 fp6 fp7 fp8 fp9 fp10 fp11))
  410.  
  411. (define registers-to-preserve-around-special-calls
  412.   (append (list g15 g16 g17 g18)
  413.       caller-saves-registers))
  414.  
  415. (define (flonum/1-arg/special hook target source)
  416.   (let ((load-arg (->machine-register source fp5)))
  417.     (delete-register! target)
  418.     (delete-dead-registers!)
  419.     (let ((clear-regs
  420.        (apply clear-registers!
  421.           registers-to-preserve-around-special-calls)))
  422.       (add-pseudo-register-alias! target fp4)
  423.       (LAP ,@load-arg
  424.        ,@clear-regs
  425.        ,@(invoke-hook hook)))))
  426.  
  427. ;; Missing operations
  428.  
  429. #|
  430. ;; Return integers
  431. (define-out-of-line FLONUM-ROUND->EXACT)
  432. (define-out-of-line FLONUM-TRUNCATE->EXACT)
  433. (define-out-of-line FLONUM-FLOOR->EXACT)
  434. (define-out-of-line FLONUM-CEILING->EXACT)
  435.  
  436. ;; Returns a pair
  437. (define-out-of-line FLONUM-NORMALIZE)
  438.  
  439. ;; Two arguments
  440. (define-out-of-line FLONUM-DENORMALIZE) ; flo*int
  441. |#
  442.  
  443. ;;;; Two arg operations
  444.  
  445. (define-rule statement
  446.   (ASSIGN (REGISTER (? target))
  447.       (FLONUM-2-ARGS FLONUM-SUBTRACT
  448.              (OBJECT->FLOAT (CONSTANT 0.))
  449.              (REGISTER (? source))
  450.              (? overflow?)))
  451.   overflow?                ; ignore
  452.   (let ((source (flonum-source! source)))
  453.     (LAP (FSUB (DBL) 0 ,source ,(flonum-target! target)))))
  454.  
  455. (define-rule statement
  456.   (ASSIGN (REGISTER (? target))
  457.       (FLONUM-2-ARGS (? operation)
  458.              (REGISTER (? source1))
  459.              (REGISTER (? source2))
  460.              (? overflow?)))
  461.   (QUALIFIER (arithmetic-method? operation flonum-methods/2-args))
  462.   overflow?                ;ignore
  463.   (let ((source1 (flonum-source! source1))
  464.     (source2 (flonum-source! source2)))
  465.     ((flonum-2-args/operator operation) (flonum-target! target)
  466.                     source1
  467.                     source2)))
  468.  
  469. (define (flonum-2-args/operator operation)
  470.   (lookup-arithmetic-method operation flonum-methods/2-args))
  471.  
  472. (define flonum-methods/2-args
  473.   (list 'FLONUM-METHODS/2-ARGS))
  474.  
  475. (let-syntax
  476.     ((define-flonum-operation
  477.        (macro (primitive-name opcode)
  478.      `(define-arithmetic-method ',primitive-name flonum-methods/2-args
  479.         (lambda (target source1 source2)
  480.           (LAP (,opcode (DBL) ,',source1 ,',source2 ,',target)))))))
  481.   (define-flonum-operation flonum-add fadd)
  482.   (define-flonum-operation flonum-subtract fsub)
  483.   (define-flonum-operation flonum-multiply fmpy)
  484.   (define-flonum-operation flonum-divide fdiv)
  485.   (define-flonum-operation flonum-remainder frem))
  486.  
  487. (define-rule statement
  488.   (ASSIGN (REGISTER (? target))
  489.       (FLONUM-2-ARGS FLONUM-ATAN2
  490.              (REGISTER (? source1))
  491.              (REGISTER (? source2))
  492.              (? overflow?)))
  493.   overflow?                ;ignore
  494.   (let* ((load-arg-1 (->machine-register source1 fp5))
  495.      (load-arg-2 (->machine-register source2 fp7)))
  496.     (delete-register! target)
  497.     (delete-dead-registers!)
  498.     (let ((clear-regs
  499.        (apply clear-registers!
  500.           registers-to-preserve-around-special-calls)))
  501.       (add-pseudo-register-alias! target fp4)
  502.       (LAP ,@load-arg-1
  503.        ,@load-arg-2
  504.        ,@clear-regs
  505.        ,@(invoke-hook hook:compiler-flonum-atan2)))))
  506.  
  507. ;;;; Flonum Predicates
  508.  
  509. (define-rule predicate
  510.   (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
  511.   #|
  512.   ;; No immediate zeros, easy to generate by subtracting from itself
  513.   (let ((temp (flonum-temporary!)))
  514.     (LAP (FSUB (DBL) ,temp ,temp ,temp)
  515.      ,@(flonum-compare
  516.         (case predicate
  517.           ((FLONUM-ZERO?) '=)
  518.           ((FLONUM-NEGATIVE?) '<)
  519.           ((FLONUM-POSITIVE?) '>)
  520.           (else (error "unknown flonum predicate" predicate)))
  521.         (flonum-source! source)
  522.         temp)))
  523.   |#
  524.   ;; The status register (fr0) reads as 0 for non-store instructions.
  525.   (flonum-compare (case predicate
  526.             ((FLONUM-ZERO?) '=)
  527.             ((FLONUM-NEGATIVE?) '<)
  528.             ((FLONUM-POSITIVE?) '>)
  529.             (else (error "unknown flonum predicate" predicate)))
  530.           (flonum-source! source)
  531.           0))
  532.  
  533. (define-rule predicate
  534.   (FLONUM-PRED-2-ARGS (? predicate)
  535.               (REGISTER (? source1))
  536.               (REGISTER (? source2)))
  537.   (flonum-compare (case predicate
  538.             ((FLONUM-EQUAL?) '=)
  539.             ((FLONUM-LESS?) '<)
  540.             ((FLONUM-GREATER?) '>)
  541.             (else (error "unknown flonum predicate" predicate)))
  542.           (flonum-source! source1)
  543.           (flonum-source! source2)))
  544.  
  545. (define (flonum-compare cc r1 r2)
  546.   (set-current-branches!
  547.    (lambda (true-label)
  548.      (LAP (FCMP (,(invert-float-condition cc) DBL) ,r1 ,r2)
  549.       (FTEST ())
  550.       (B (N) (@PCR ,true-label))))
  551.    (lambda (false-label)
  552.      (LAP (FCMP (,cc DBL) ,r1 ,r2)
  553.       (FTEST ())
  554.       (B (N) (@PCR ,false-label)))))
  555.   (LAP))
  556.  
  557. ;; invert-float-condition makes sure that NaNs are taken care of
  558. ;; correctly.
  559.  
  560. (define (invert-float-condition cc)
  561.   (let ((place (assq cc float-inversion-table)))
  562.     (if (not place)
  563.     (error "invert-float-condition: Unknown condition"
  564.            cc)
  565.     (cadr place))))
  566.  
  567. (define float-inversion-table
  568.   ;; There are many others, but only these are used here.
  569.   '((> !>)
  570.     (< !<)
  571.     (= !=)))