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 / i386 / rulflo.scm < prev    next >
Text File  |  1999-01-02  |  27KB  |  827 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rulflo.scm,v 1.22 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1992-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. ;; ****
  28. ;; Missing: 2 argument operations and predicates with non-trivial
  29. ;; constant arguments.
  30. ;; Also missing with (OBJECT->FLOAT (REGISTER ...)) operands.
  31. ;; ****
  32.  
  33. (define (flonum-source! register)
  34.   (floreg->sti (load-alias-register! register 'FLOAT)))
  35.  
  36. (define (flonum-target! pseudo-register)
  37.   (delete-dead-registers!)
  38.   (floreg->sti (allocate-alias-register! pseudo-register 'FLOAT)))
  39.  
  40. (define (flonum-temporary!)
  41.   (allocate-temporary-register! 'FLOAT))
  42.  
  43. (define-rule statement
  44.   ;; convert a floating-point number to a flonum object
  45.   (ASSIGN (REGISTER (? target))
  46.       (FLOAT->OBJECT (REGISTER (? source))))
  47.   (let* ((source (register-alias source 'FLOAT))
  48.      (target (target-register-reference target)))
  49.     (LAP (MOV W (@R ,regnum:free-pointer)
  50.           (&U ,(make-non-pointer-literal
  51.             (ucode-type manifest-nm-vector)
  52.             2)))
  53.      ,@(if (not source)
  54.            ;; Value is in memory home
  55.            (let ((off (pseudo-register-offset source))
  56.              (temp (temporary-register-reference)))
  57.          (LAP (MOV W ,target
  58.                ,(offset-reference regnum:regs-pointer off))
  59.               (MOV W ,temp
  60.                ,(offset-reference regnum:regs-pointer (1+ off)))
  61.               (MOV W (@RO B ,regnum:free-pointer 4) ,target)
  62.               (MOV W (@RO B ,regnum:free-pointer 8) ,temp)))
  63.            (store-float (floreg->sti source)
  64.                 (INST-EA (@RO B ,regnum:free-pointer 4))))
  65.      (LEA ,target
  66.           (@RO UW ,regnum:free-pointer
  67.            ,(make-non-pointer-literal (ucode-type flonum) 0)))
  68.      (ADD W (R ,regnum:free-pointer) (& 12)))))
  69.  
  70. #|
  71. (define-rule statement
  72.   ;; convert a flonum object to a floating-point number
  73.   (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
  74.   (let* ((source (move-to-temporary-register! source 'GENERAL))
  75.      (target (flonum-target! target)))
  76.     (LAP ,@(object->address (register-reference source))
  77.      ,@(load-float (INST-EA (@RO B ,source 4)) target))))
  78. |#
  79.  
  80. (define-rule statement
  81.   ;; Convert a flonum object to a floating-point number.  Unlike the
  82.   ;; version above which has an implicits OBJECT->ADDRESS, this one
  83.   ;; uses the addressing mode to remove the type-code.  Saves a cycle
  84.   ;; and maybe a register spill if SOURCE is live after instruction.
  85.   (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
  86.   (let* ((source (source-register source))
  87.      (target (flonum-target! target)))
  88.     (object->float source target)))
  89.  
  90. (define (object->float source-register target)
  91.   (let ((untagging+offset
  92.      (- 4 (make-non-pointer-literal (ucode-type flonum) 0))))
  93.     (load-float (INST-EA (@RO W ,source-register ,untagging+offset)) target)))
  94.  
  95. ;;;; Floating-point vector support.
  96.  
  97. (define-rule statement
  98.   (ASSIGN (REGISTER (? target)) (? expression rtl:simple-float-offset?))
  99.   (let* ((source (float-offset->reference! expression))
  100.      (target (flonum-target! target)))
  101.     (load-float source target)))
  102.  
  103. (define-rule statement
  104.   (ASSIGN (? expression rtl:simple-float-offset?) (REGISTER (? source)))
  105.   (let ((source (flonum-source! source))
  106.     (target (float-offset->reference! expression)))
  107.     (store-float source target)))
  108.  
  109. (define-rule statement
  110.   (ASSIGN (REGISTER (? target))
  111.       (? expression rtl:detagged-float-offset?))
  112.   (with-detagged-float-location expression
  113.     (lambda (temp)
  114.       (load-float temp target))))
  115.  
  116. (define-rule statement
  117.   (ASSIGN (? expression rtl:detagged-float-offset?)
  118.       (REGISTER (? source)))
  119.   (with-detagged-float-location expression
  120.     (lambda (temp)
  121.       (store-float (flonum-source! source) temp))))
  122.  
  123. (define (with-detagged-float-location rtl-expression recvr)
  124.   ;; Never needs to protect a register because it is a float register!
  125.   (with-decoded-detagged-float-offset rtl-expression
  126.     (lambda (base index w-offset)
  127.       (with-indexed-address base index 8 (* 4 w-offset) false recvr))))
  128.  
  129. (define (rtl:detagged-float-offset? expression)
  130.   (and (rtl:float-offset? expression)
  131.        (let ((base (rtl:float-offset-base expression))
  132.          (offset (rtl:float-offset-offset expression)))
  133.      (and (rtl:offset-address? base)
  134.           (rtl:machine-constant? (rtl:offset-address-offset base))
  135.           (rtl:detagged-index? (rtl:offset-address-base base)
  136.                    offset)))
  137.        expression))
  138.  
  139. (define (with-decoded-detagged-float-offset expression recvr)
  140.   (let ((base (rtl:float-offset-base expression))
  141.     (index (rtl:float-offset-offset expression)))
  142.     (let ((base* (rtl:offset-address-base base)))
  143.       (recvr (rtl:register-number (if (rtl:register? base*)
  144.                       base*
  145.                       (rtl:object->address-expression base*)))
  146.          (rtl:register-number (if (rtl:register? index)
  147.                       index
  148.                       (rtl:object->datum-expression index)))
  149.          (rtl:machine-constant-value (rtl:offset-address-offset base))))))
  150.  
  151. (define (load-float ea sti)
  152.   (LAP (FLD D ,ea)
  153.        (FSTP (ST ,(1+ sti)))))
  154.  
  155. (define (store-float sti ea)
  156.   (if (zero? sti)
  157.       (LAP (FST D ,ea))
  158.       (LAP (FLD (ST ,sti))
  159.        (FSTP D ,ea))))
  160.  
  161. ;;;; Flonum Arithmetic
  162.  
  163. (define-rule statement
  164.   (ASSIGN (REGISTER (? target))
  165.       (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
  166.   overflow?                ;ignore
  167.   ((flonum-1-arg/operator operation) target source))
  168.  
  169. (define ((flonum-unary-operation/general operate) target source)
  170.   (define (default)
  171.     (let* ((source (flonum-source! source))
  172.        (target (flonum-target! target)))
  173.       (operate target source)))
  174.   ;; Attempt to reuse source for target if it is in ST(0).
  175.   ;; Otherwise we will target ST(0) by sorting the machine registers.
  176.   (cond ((and (pseudo-register? target) (pseudo-register? source)
  177.           (eqv? fr0 (pseudo-register-alias *register-map* 'FLOAT source)))
  178.      (reuse-pseudo-register-alias
  179.       source 'FLOAT
  180.       (lambda (alias)
  181.         (let* ((sti (floreg->sti alias)))
  182.           (delete-register! alias)
  183.           (delete-dead-registers!)
  184.           (add-pseudo-register-alias! target alias)
  185.           (operate sti sti)))
  186.       default))
  187.     (else (default))))
  188.  
  189. '(define ((flonum-unary-operation/general operate) target source)
  190.   (define (default)
  191.     (let* ((source (flonum-source! source))
  192.        (target (flonum-target! target)))
  193.       (operate target source)))
  194.   ;; Attempt to reuse source for target.  This works well when the
  195.   ;; source is ST(0).  We try to arrange this by sorting the registers
  196.   ;; to give allocation preference to ST(0).
  197.   (cond ((pseudo-register? target)
  198.      (reuse-pseudo-register-alias
  199.       source 'FLOAT
  200.       (lambda (alias)
  201.         (let* ((sti (floreg->sti alias)))
  202.           (delete-register! alias)
  203.           (delete-dead-registers!)
  204.           (add-pseudo-register-alias! target alias)
  205.           (operate sti sti)))
  206.       default))
  207.     (else (default))))
  208.  
  209. '(define ((flonum-unary-operation/general operate) target source)
  210.   (define (default)
  211.     (let* ((source (flonum-source! source))
  212.        (target (flonum-target! target)))
  213.       (operate target source)))
  214.   ;; Attempt to reuse source for target.  This works well when the
  215.   ;; source is ST(0).  We try to arrange this by sorting the registers
  216.   ;; to give allocation preference to ST(0).
  217.   (cond ((pseudo-register? target)
  218.      (let ((alias
  219.         (and (dead-register? source)
  220.              (pseudo-register-alias *register-map* 'FLOAT source))))
  221.        (if alias
  222.            (default)))
  223.     
  224.     (reuse-pseudo-register-alias
  225.       source 'FLOAT
  226.       (lambda (alias)
  227.         (let* ((sti (floreg->sti alias)))
  228.         (delete-register! alias)
  229.         (delete-dead-registers!)
  230.         (add-pseudo-register-alias! target alias)
  231.         (operate sti sti)))
  232.       default))
  233.     (else (default))))
  234.  
  235. (define (flonum-1-arg/operator operation)
  236.   (lookup-arithmetic-method operation flonum-methods/1-arg))
  237.  
  238. (define flonum-methods/1-arg
  239.   (list 'FLONUM-METHODS/1-ARG))
  240.  
  241. ;;; Notice the weird ,', syntax here.
  242. ;;; If LAP changes, this may also have to change.
  243.  
  244. (let-syntax
  245.     ((define-flonum-operation
  246.        (macro (primitive-name opcode)
  247.      `(define-arithmetic-method ',primitive-name flonum-methods/1-arg
  248.         (flonum-unary-operation/general
  249.          (lambda (target source)
  250.            (if (and (zero? target) (zero? source))
  251.            (LAP (,opcode))
  252.            (LAP (FLD (ST ,', source))
  253.             (,opcode)
  254.             (FSTP (ST ,',(1+ target)))))))))))
  255.   (define-flonum-operation FLONUM-NEGATE FCHS)
  256.   (define-flonum-operation FLONUM-ABS FABS)
  257.   (define-flonum-operation FLONUM-SIN FSIN)
  258.   (define-flonum-operation FLONUM-COS FCOS)
  259.   (define-flonum-operation FLONUM-SQRT FSQRT)
  260.   (define-flonum-operation FLONUM-ROUND FRNDINT))
  261.  
  262. ;; These (and FLONUM-ROUND above) presume that the default rounding mode
  263. ;; is round-to-nearest/even
  264.  
  265. (define (define-rounding prim-name mode)
  266.   (define-arithmetic-method prim-name flonum-methods/1-arg
  267.     (flonum-unary-operation/general
  268.      (lambda (target source)
  269.        (let ((temp (temporary-register-reference)))
  270.      (LAP (FSTCW (@R ,regnum:free-pointer))
  271.           ,@(if (and (zero? target) (zero? source))
  272.             (LAP)
  273.             (LAP (FLD (ST ,source))))
  274.           (MOV B ,temp (@RO B ,regnum:free-pointer 1))
  275.           (OR B (@RO B ,regnum:free-pointer 1) (&U ,mode))
  276.           (FNLDCW (@R ,regnum:free-pointer))
  277.           (FRNDINT)
  278.           (MOV B (@RO B ,regnum:free-pointer 1) ,temp)
  279.           ,@(if (and (zero? target) (zero? source))
  280.             (LAP)
  281.             (LAP (FSTP (ST ,(1+ target)))))
  282.           (FNLDCW (@R ,regnum:free-pointer))))))))
  283.  
  284. (define-rounding 'FLONUM-CEILING #x08)
  285. (define-rounding 'FLONUM-FLOOR #x04)
  286. (define-rounding 'FLONUM-TRUNCATE #x0c)
  287.  
  288. ;; This is used in order to avoid using two stack locations for
  289. ;; the remainder unary operations.
  290.  
  291. (define ((flonum-unary-operation/stack-top operate) target source)
  292.   (define (finish source->top)
  293.     ;; Perhaps this can be improved?
  294.     (rtl-target:=machine-register! target fr0)
  295.     (LAP ,@source->top
  296.      ,@(operate)))
  297.  
  298.   (if (or (machine-register? source)
  299.       (not (is-alias-for-register? fr0 source))
  300.       (not (dead-register? source)))
  301.       (finish (load-machine-register! source fr0))
  302.       (begin
  303.     (delete-dead-registers!)
  304.     (finish (LAP)))))
  305.  
  306. (define-arithmetic-method 'FLONUM-LOG flonum-methods/1-arg
  307.   (flonum-unary-operation/stack-top
  308.    (lambda ()
  309.      #|
  310.      (LAP (FLDLN2)
  311.       (FLD (ST ,(1+ source)))
  312.       (FYL2X)
  313.       (FSTP (ST ,(1+ target))))
  314.      |#
  315.      (LAP (FLDLN2)
  316.       (FXCH (ST 0) (ST 1))
  317.       (FYL2X)))))
  318.  
  319. (define-arithmetic-method 'FLONUM-EXP flonum-methods/1-arg
  320.   (flonum-unary-operation/stack-top
  321.    (lambda ()
  322.      #|
  323.      (LAP (FLD (ST ,source))
  324.       (FLDL2E)
  325.       (FMULP (ST 1) (ST 0))
  326.       (F2XM1)
  327.       (FLD1)
  328.       (FADDP (ST 1) (ST 0))
  329.       (FSTP (ST ,(1+ target))))
  330.      |#
  331.      (LAP (FLDL2E)
  332.       (FMULP (ST 1) (ST 0))
  333.       (F2XM1)
  334.       (FLD1)
  335.       (FADDP (ST 1) (ST 0))))))
  336.  
  337. (define-arithmetic-method 'FLONUM-TAN flonum-methods/1-arg
  338.   (flonum-unary-operation/stack-top
  339.    (lambda ()
  340.      #|
  341.      (LAP (FLD (ST ,source))
  342.       (FPTAN)
  343.       (FSTP (ST 0))            ; FPOP
  344.       (FSTP (ST ,(1+ target))))
  345.      |#
  346.      (LAP (FPTAN)
  347.       (FSTP (ST 0))            ; FPOP
  348.       ))))
  349.  
  350. (define-arithmetic-method 'FLONUM-ATAN flonum-methods/1-arg
  351.   (flonum-unary-operation/stack-top
  352.    (lambda ()
  353.      #|
  354.      (LAP (FLD (ST ,source))
  355.       (FLD1)
  356.       (FPATAN)
  357.       (FSTP (ST ,(1+ target))))
  358.      |#
  359.      (LAP (FLD1)
  360.       (FPATAN)))))
  361.  
  362. ;; For now, these preserve values in memory
  363. ;; in order to avoid flushing a stack location.
  364.  
  365. (define-arithmetic-method 'FLONUM-ACOS flonum-methods/1-arg
  366.   (flonum-unary-operation/stack-top
  367.    (lambda ()
  368.      #|
  369.      (LAP (FLD (ST ,source))
  370.       (FMUL (ST 0) (ST 0))
  371.       (FLD1)
  372.       (F%SUBP (ST 1) (ST 0))
  373.       (FSQRT)
  374.       (FLD (ST ,(1+ source)))
  375.       (FPATAN)
  376.       (FSTP (ST ,(1+ target))))
  377.      |#
  378.      (LAP (FST D (@R ,regnum:free-pointer))
  379.       (FMUL (ST 0) (ST 0))
  380.       (FLD1)
  381.       (F%SUBP (ST 1) (ST 0))
  382.       (FSQRT)
  383.       (FLD D (@R ,regnum:free-pointer))
  384.       (FPATAN)))))
  385.  
  386. (define-arithmetic-method 'FLONUM-ASIN flonum-methods/1-arg
  387.   (flonum-unary-operation/stack-top
  388.    (lambda ()
  389.      #|
  390.      (LAP (FLD (ST ,source))
  391.       (FMUL (ST 0) (ST 0))
  392.       (FLD1)
  393.       (F%SUBP (ST 1) (ST 0))
  394.       (FSQRT)
  395.       (FLD (ST ,(1+ source)))
  396.       (FXCH (ST 0) (ST 1))
  397.       (FPATAN)
  398.       (FSTP (ST ,(1+ target))))
  399.      |#
  400.      (LAP (FST D (@R ,regnum:free-pointer))
  401.       (FMUL (ST 0) (ST 0))
  402.       (FLD1)
  403.       (F%SUBP (ST 1) (ST 0))
  404.       (FSQRT)
  405.       (FLD D (@R ,regnum:free-pointer))
  406.       (FXCH (ST 0) (ST 1))
  407.       (FPATAN)))))
  408.  
  409. (define-rule statement
  410.   (ASSIGN (REGISTER (? target))
  411.       (FLONUM-2-ARGS (? operation)
  412.              (REGISTER (? source1))
  413.              (REGISTER (? source2))
  414.              (? overflow?)))
  415.   overflow?                ;ignore
  416.   ((flonum-2-args/operator operation) target source1 source2))
  417.  
  418. ;; Binary instructions all use ST(0), and are of the forms
  419. ;;   Fop ST(0),ST(i)
  420. ;;   Fop ST(i),ST(0)
  421. ;;   FopP ST(i),ST(0)
  422. ;;   Fop ST(0),memory
  423. ;;
  424. ;; If possible, we like to target ST(0) since it is likely to be the
  425. ;; source of a subsequent operation.  Failing that, it is good to
  426. ;; reuse one of the source aliases.
  427.  
  428. (define ((flonum-binary-operation operate) target source1 source2)
  429.   (define (default)
  430.     (let* ((sti1 (flonum-source! source1))
  431.        (sti2 (flonum-source! source2)))
  432.       (operate (flonum-target! target) sti1 sti2)))
  433.   (define (try-reuse-1 if-cannot)
  434.     (reuse-pseudo-register-alias
  435.      source1 'FLOAT
  436.      (lambda (alias1)
  437.        (let* ((sti1 (floreg->sti alias1))
  438.           (sti2 (if (= source1 source2)
  439.             sti1
  440.             (flonum-source! source2))))
  441.      (delete-register! alias1)
  442.      (delete-dead-registers!)
  443.      (add-pseudo-register-alias! target alias1)
  444.      (operate sti1 sti1 sti2)))
  445.      if-cannot))
  446.   (define (try-reuse-2 if-cannot)
  447.     (reuse-pseudo-register-alias
  448.      source2 'FLOAT
  449.      (lambda (alias2)
  450.        (let* ((sti2 (floreg->sti alias2))
  451.           (sti1 (if (= source1 source2)
  452.             sti2
  453.             (flonum-source! source1))))
  454.      (delete-register! alias2)
  455.      (delete-dead-registers!)
  456.      (add-pseudo-register-alias! target alias2)
  457.      (operate sti2 sti1 sti2)))
  458.      if-cannot))
  459.   (cond ((pseudo-register? target)
  460.      (if (is-alias-for-register? fr0 source1)
  461.          (try-reuse-1 (lambda () (try-reuse-2 default)))
  462.          (try-reuse-2 (lambda () (try-reuse-1 default)))))
  463.     ((not (eq? (register-type target) 'FLOAT))
  464.      (error "flonum-2-args: Wrong type register"
  465.         target 'FLOAT))
  466.     (else
  467.      (default))))
  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. (define (flonum-1-arg%1/operator operation)
  476.   (lookup-arithmetic-method operation flonum-methods/1-arg%1))
  477.  
  478. (define flonum-methods/1-arg%1
  479.   (list 'FLONUM-METHODS/1-ARG%1))
  480.  
  481. (define (flonum-1%1-arg/operator operation)
  482.   (lookup-arithmetic-method operation flonum-methods/1%1-arg))
  483.  
  484. (define flonum-methods/1%1-arg
  485.   (list 'FLONUM-METHODS/1%1-ARG))
  486.  
  487. (define (binary-flonum-arithmetic? operation)
  488.   (memq operation '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE)))
  489.  
  490. (let-syntax
  491.     ((define-flonum-operation
  492.        (macro (primitive-name op1%2 op1%2p op2%1 op2%1p)
  493.      `(begin
  494.         (define-arithmetic-method ',primitive-name flonum-methods/2-args
  495.           (flonum-binary-operation
  496.            (lambda (target source1 source2)
  497.          (cond ((= target source1)
  498.             (cond ((zero? target)
  499.                    (LAP (,op1%2 (ST 0) (ST ,',source2))))
  500.                   ((zero? source2)
  501.                    (LAP (,op2%1 (ST ,',target) (ST 0))))
  502.                   (else
  503.                    (LAP (FLD (ST ,',source2))
  504.                     (,op2%1p (ST ,',(1+ target)) (ST 0))))))
  505.                ((= target source2)
  506.             (cond ((zero? target)
  507.                    (LAP (,op2%1 (ST 0) (ST ,',source1))))
  508.                   ((zero? source1)
  509.                    (LAP (,op1%2 (ST ,',target) (ST 0))))
  510.                   (else
  511.                    (LAP (FLD (ST ,',source1))
  512.                     (,op1%2p (ST ,',(1+ target)) (ST 0))))))
  513.                (else
  514.             (LAP (FLD (ST ,',source1))
  515.                  (,op1%2 (ST 0) (ST ,',(1+ source2)))
  516.                  (FSTP (ST ,',(1+ target)))))))))
  517.  
  518.         (define-arithmetic-method ',primitive-name flonum-methods/1%1-arg
  519.           (flonum-unary-operation/general
  520.            (lambda (target source)
  521.          (if (= source target)
  522.              (LAP (FLD1)
  523.               (,op1%2p (ST ,',(1+ target)) (ST 0)))
  524.              (LAP (FLD1)
  525.               (,op1%2 (ST 0) (ST ,',(1+ source)))
  526.               (FSTP (ST ,',(1+ target))))))))
  527.  
  528.         (define-arithmetic-method ',primitive-name flonum-methods/1-arg%1
  529.           (flonum-unary-operation/general
  530.            (lambda (target source)
  531.          (if (= source target)
  532.              (LAP (FLD1)
  533.               (,op2%1p (ST ,',(1+ target)) (ST 0)))
  534.              (LAP (FLD1)
  535.               (,op2%1 (ST 0) (ST ,',(1+ source)))
  536.               (FSTP (ST ,',(1+ target))))))))))))
  537.  
  538.   (define-flonum-operation FLONUM-ADD FADD FADDP FADD FADDP)
  539.   (define-flonum-operation FLONUM-SUBTRACT F%SUB F%SUBP F%SUBR F%SUBPR)
  540.   (define-flonum-operation FLONUM-MULTIPLY FMUL FMULP FMUL FMULP)
  541.   (define-flonum-operation FLONUM-DIVIDE F%DIV F%DIVP F%DIVR F%DIVPR))
  542.  
  543. (define-arithmetic-method 'FLONUM-ATAN2 flonum-methods/2-args
  544.   (lambda (target source1 source2)
  545.     (if (and (not (machine-register? source1))
  546.          (is-alias-for-register? fr0 source1)
  547.          (dead-register? source1))
  548.     (let ((source2 (flonum-source! source2)))
  549.       (delete-dead-registers!)
  550.       (rtl-target:=machine-register! target fr0)
  551.       (LAP (FLD (ST ,source2))
  552.            (FPATAN)))
  553.     (begin
  554.       (prefix-instructions! (load-machine-register! source1 fr0))
  555.       (need-register! fr0)
  556.       (let ((source2 (if (= source2 source1)
  557.                  fr0
  558.                  (flonum-source! source2))))
  559.         (delete-dead-registers!)
  560.         (rtl-target:=machine-register! target fr0)
  561.         (LAP (FLD (ST ,source2))
  562.          (FPATAN)))))))
  563.  
  564. (define-arithmetic-method 'FLONUM-REMAINDER flonum-methods/2-args
  565.   (flonum-binary-operation
  566.    (lambda (target source1 source2)
  567.      (if (zero? source2)
  568.      (LAP (FLD (ST ,source1))
  569.           (FPREM1)
  570.           (FSTP (ST ,(1+ target))))
  571.      #|
  572.      ;; This sequence is one cycle shorter than the one below,
  573.      ;; but needs two spare stack locations instead of one.
  574.      ;; Since FPREM1 is a variable, very slow instruction,
  575.      ;; the difference in time will hardly be noticeable
  576.      ;; but the availability of an extra "register" may be.
  577.      (LAP (FLD (ST ,source2))
  578.           (FLD (ST ,source1))
  579.           (FPREM1)
  580.           (FSTP (ST ,(+ target 2)))
  581.           (FSTP (ST 0)))        ; FPOP
  582.      |#
  583.      (LAP (FXCH (ST 0) (ST ,source2))
  584.           (FLD (ST ,(if (zero? source1) source2 source1)))
  585.           (FPREM1)
  586.           (FSTP (ST ,(1+ (if (= target source2)
  587.                  0
  588.                  target))))
  589.           (FXCH (ST 0) (ST ,source2)))))))
  590.  
  591. (define-rule statement
  592.   (ASSIGN (REGISTER (? target))
  593.       (FLONUM-2-ARGS FLONUM-SUBTRACT
  594.              (OBJECT->FLOAT (CONSTANT 0.))
  595.              (REGISTER (? source))
  596.              (? overflow?)))
  597.   overflow?                ;ignore
  598.   ((flonum-unary-operation/general
  599.     (lambda (target source)
  600.       (if (and (zero? target) (zero? source))
  601.       (LAP (FCHS))
  602.       (LAP (FLD (ST ,source))
  603.            (FCHS)
  604.            (FSTP (ST ,(1+ target)))))))
  605.    target source))
  606.  
  607. (define-rule statement
  608.   (ASSIGN (REGISTER (? target))
  609.       (FLONUM-2-ARGS (? operation)
  610.              (REGISTER (? source))
  611.              (OBJECT->FLOAT (CONSTANT 1.))
  612.              (? overflow?)))
  613.   (QUALIFIER (binary-flonum-arithmetic? operation))
  614.   overflow?                ;ignore
  615.   ((flonum-1-arg%1/operator operation) target source))
  616.  
  617. (define-rule statement
  618.   (ASSIGN (REGISTER (? target))
  619.       (FLONUM-2-ARGS (? operation)
  620.              (OBJECT->FLOAT (CONSTANT 1.))
  621.              (REGISTER (? source))
  622.              (? overflow?)))
  623.   (QUALIFIER (binary-flonum-arithmetic? operation))
  624.   overflow?                ;ignore
  625.   ((flonum-1%1-arg/operator operation) target source))
  626.  
  627. ;;;; Flonum Predicates
  628.  
  629. (define-rule predicate
  630.   (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
  631.   (flonum-compare-zero predicate source))
  632.  
  633. (define-rule predicate
  634.   (FLONUM-PRED-2-ARGS (? predicate)
  635.               (REGISTER (? source1))
  636.               (REGISTER (? source2)))
  637.   (let* ((st1 (flonum-source! source1))
  638.      (st2 (flonum-source! source2)))
  639.     (cond ((zero? st1)
  640.        (flonum-branch! predicate
  641.                (LAP (FCOM (ST 0) (ST ,st2)))))
  642.       ((zero? st2)
  643.        (flonum-branch! (commute-flonum-predicate predicate)
  644.                (LAP (FCOM (ST 0) (ST ,st1)))))
  645.       (else
  646.        (flonum-branch! predicate
  647.                (LAP (FLD (ST ,st1))
  648.                 (FCOMP (ST 0) (ST ,(1+ st2)))))))))
  649.  
  650. (define-rule predicate
  651.   (FLONUM-PRED-2-ARGS (? predicate)
  652.               (REGISTER (? source))
  653.               (OBJECT->FLOAT (CONSTANT 0.)))
  654.   (flonum-compare-zero predicate source))
  655.  
  656. (define-rule predicate
  657.   (FLONUM-PRED-2-ARGS (? predicate)
  658.               (OBJECT->FLOAT (CONSTANT 0.))
  659.               (REGISTER (? source)))
  660.   (flonum-compare-zero (commute-flonum-predicate predicate) source))
  661.  
  662. (define-rule predicate
  663.   (FLONUM-PRED-2-ARGS (? predicate)
  664.               (REGISTER (? source))
  665.               (OBJECT->FLOAT (CONSTANT 1.)))
  666.   (flonum-compare-one predicate source))
  667.  
  668. (define-rule predicate
  669.   (FLONUM-PRED-2-ARGS (? predicate)
  670.               (OBJECT->FLOAT (CONSTANT 1.))
  671.               (REGISTER (? source)))
  672.   (flonum-compare-one (commute-flonum-predicate predicate) source))
  673.  
  674. (define (flonum-compare-zero predicate source)
  675.   (let ((sti (flonum-source! source)))
  676.     (if (zero? sti)
  677.     (flonum-branch! predicate
  678.             (LAP (FTST)))
  679.     (flonum-branch! (commute-flonum-predicate predicate)
  680.             (LAP (FLDZ)
  681.                  (FCOMP (ST 0) (ST ,(1+ sti))))))))
  682.  
  683. (define (flonum-compare-one predicate source)
  684.   (let ((sti (flonum-source! source)))
  685.     (flonum-branch! (commute-flonum-predicate predicate)
  686.             (LAP (FLD1)
  687.              (FCOMP (ST 0) (ST ,(1+ sti)))))))
  688.  
  689. (define (commute-flonum-predicate pred)
  690.   (case pred
  691.     ((FLONUM-EQUAL? FLONUM-ZERO?) 'FLONUM-EQUAL?)
  692.     ((FLONUM-LESS? FLONUM-NEGATIVE?) 'FLONUM-GREATER?)
  693.     ((FLONUM-GREATER? FLONUM-POSITIVE?) 'FLONUM-LESS?)
  694.     (else
  695.      (error "commute-flonum-predicate: Unknown predicate" pred))))
  696.  
  697. (define (flonum-branch! predicate prefix)
  698.   (case predicate
  699.     ((FLONUM-EQUAL? FLONUM-ZERO?)
  700.      (set-current-branches! (lambda (label)
  701.                   (let ((unordered (generate-label 'UNORDERED)))
  702.                 (LAP (JP (@PCR ,unordered))
  703.                      (JE (@PCR ,label))
  704.                      (LABEL ,unordered))))
  705.                 (lambda (label)
  706.                   (LAP (JNE (@PCR ,label))
  707.                    (JP (@PCR ,label))))))
  708.     ((FLONUM-LESS? FLONUM-NEGATIVE?)
  709.      (set-current-branches! (lambda (label)
  710.                   (let ((unordered (generate-label 'UNORDERED)))
  711.                 (LAP (JP (@PCR ,unordered))
  712.                      (JB (@PCR ,label))
  713.                      (LABEL ,unordered))))
  714.                 (lambda (label)
  715.                   (LAP (JAE (@PCR ,label))
  716.                    (JP (@PCR ,label))))))
  717.     ((FLONUM-GREATER? FLONUM-POSITIVE?)
  718.      (set-current-branches! (lambda (label)
  719.                   (LAP (JA (@PCR ,label))))
  720.                 (lambda (label)
  721.                   (LAP (JBE (@PCR ,label))))))
  722.     (else
  723.      (error "flonum-branch!: Unknown predicate" predicate)))
  724.   (flush-register! eax)
  725.   (LAP ,@prefix
  726.        (FSTSW (R ,eax))
  727.        (SAHF)))
  728.  
  729. ;; This is endianness dependent!
  730.  
  731. (define (flonum-value->data-decl value)
  732.   (let ((high (make-bit-string 32 false))
  733.     (low (make-bit-string 32 false)))
  734.     (read-bits! value 32 high)
  735.     (read-bits! value 64 low)
  736.     (LAP ,@(lap:comment `(FLOAT ,value))
  737.      (LONG U ,(bit-string->unsigned-integer high))
  738.      (LONG U ,(bit-string->unsigned-integer low)))))
  739.  
  740. (define (flo:32-bit-representation-exact? value)
  741.   ;; Returns unsigned long representation if 32 bit representation
  742.   ;; exists, i.e. if all `1' significant mantissa bits fit in the 32
  743.   ;; bit format and the exponent is within range.
  744.   (let ((mant-diff (make-bit-string (- 52 23) false)))
  745.     (read-bits! value (+ 32 0) mant-diff)
  746.     (and (bit-string-zero? mant-diff)
  747.      (let ((expt64 (make-bit-string 11 false)))
  748.        (read-bits! value (+ 32 52) expt64)
  749.        (let ((expt (- (bit-string->unsigned-integer expt64) 1022)))
  750.          (and (<= -127 expt 127)
  751.           (let ((sign (make-bit-string 1  false))
  752.             (mant32 (make-bit-string 23 false)))
  753.             (read-bits! value (+ 32 52 11) sign)
  754.             (read-bits! value (+ 32 52 -23) mant32)
  755.             (bit-string->unsigned-integer
  756.              (bit-string-append
  757.               (bit-string-append
  758.                mant32
  759.                (unsigned-integer->bit-string 8 (+ 126 expt)))
  760.               sign)))))))))
  761.  
  762. (define (flonum->label value block-name alignment offset data)
  763.   (let* ((block
  764.       (or (find-extra-code-block block-name)
  765.           (let ((block (declare-extra-code-block! block-name
  766.                               'ANYWHERE
  767.                               '())))
  768.         (add-extra-code!
  769.          block
  770.          (LAP (PADDING ,offset ,alignment ,padding-string)))
  771.         block)))
  772.      (pairs (extra-code-block/xtra block))
  773.      (place (assoc value pairs)))
  774.     (if place
  775.     (cdr place)
  776.     (let ((label (generate-label block-name)))
  777.       (set-extra-code-block/xtra!
  778.        block
  779.        (cons (cons value label) pairs))
  780.       (add-extra-code! block
  781.                (LAP (LABEL ,label)
  782.                 ,@data))
  783.       label))))
  784.  
  785. (define (double-flonum->label fp-value)
  786.   (flonum->label fp-value 'DOUBLE-FLOATS 8 0
  787.          (flonum-value->data-decl fp-value)))
  788.  
  789. (define (single-flonum->label fp-value)
  790.   (flonum->label fp-value 'SINGLE-FLOATS 4 0
  791.          (LAP ,@(lap:comment `(SINGLE-FLOAT ,fp-value))
  792.               (LONG U ,(flo:32-bit-representation-exact? fp-value)))))
  793.                      
  794. (define-rule statement
  795.   (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT (? fp-value))))
  796.   (cond ((not (flo:flonum? fp-value))
  797.      (error "OBJECT->FLOAT: Not a floating-point value" fp-value))
  798.     ((flo:= fp-value 0.0)
  799.      (let ((target (flonum-target! target)))
  800.        (LAP (FLDZ)
  801.         (FSTP (ST ,(1+ target))))))
  802.     ((flo:= fp-value 1.0)
  803.      (let ((target (flonum-target! target)))
  804.        (LAP (FLD1)
  805.         (FSTP (ST ,(1+ target))))))
  806.     (compiler:cross-compiling?
  807.      (let* ((temp (allocate-temporary-register! 'GENERAL))
  808.         (target (flonum-target! target)))
  809.        (LAP ,@(load-constant (register-reference temp) fp-value)
  810.         ,@(object->float temp target))))
  811.     (else
  812.      (let ((target (flonum-target! target)))
  813.        (with-pcr-float fp-value
  814.           (lambda (ea size)
  815.         (LAP (FLD ,size ,ea)
  816.              (FSTP (ST ,(1+ target))))))))))
  817.  
  818. (define (with-pcr-float fp-value receiver)
  819.   (define (generate-ea label-expr size)
  820.     (with-pc
  821.      (lambda (pc-label pc-register)
  822.        (receiver (INST-EA (@RO W ,pc-register (- ,label-expr ,pc-label)))
  823.          size))))
  824.   (if (flo:32-bit-representation-exact? fp-value)
  825.       (generate-ea (single-flonum->label fp-value) 'S)
  826.       (generate-ea (double-flonum->label fp-value) 'D)))
  827.