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 / mips / rulflo.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  232 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rulflo.scm,v 1.8 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.  
  24. (declare (usual-integrations))
  25.  
  26. (define (flonum-source! register)
  27.   (float-register->fpr (load-alias-register! register 'FLOAT)))
  28.  
  29. (define (flonum-target! pseudo-register)
  30.   (delete-dead-registers!)
  31.   (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT)))
  32.  
  33. (define (flonum-temporary!)
  34.   (float-register->fpr (allocate-temporary-register! 'FLOAT)))
  35.  
  36. (define-rule statement
  37.   ;; convert a floating-point number to a flonum object
  38.   (ASSIGN (REGISTER (? target))
  39.       (FLOAT->OBJECT (REGISTER (? source))))
  40.   (let ((source (fpr->float-register (flonum-source! source))))
  41.     (let ((target (standard-target! target)))
  42.       (LAP
  43.        ; (SW 0 (OFFSET 0 ,regnum:free))    ; make heap parsable forwards
  44.        (ORI ,regnum:free ,regnum:free #b100) ; Align to odd quad byte
  45.        ,@(deposit-type-address (ucode-type flonum) regnum:free target)
  46.        ,@(with-values
  47.          (lambda ()
  48.            (immediate->register
  49.         (make-non-pointer-literal (ucode-type manifest-nm-vector) 2)))
  50.        (lambda (prefix alias)
  51.          (LAP ,@prefix
  52.           (SW ,alias (OFFSET 0 ,regnum:free)))))
  53.        ,@(fp-store-doubleword 4 regnum:free source)
  54.        (ADDI ,regnum:free ,regnum:free 12)))))
  55.  
  56. (define-rule statement
  57.   ;; convert a flonum object to a floating-point number
  58.   (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
  59.   (let ((source (standard-move-to-temporary! source)))
  60.     (let ((target (fpr->float-register (flonum-target! target))))
  61.       (LAP ,@(object->address source source)
  62.        ,@(fp-load-doubleword 4 source target #T)))))
  63.  
  64. ;; Floating-point vector support
  65.  
  66. (define-rule statement
  67.   (ASSIGN (REGISTER (? target))
  68.       (FLOAT-OFFSET (REGISTER (? base))
  69.             (MACHINE-CONSTANT (? offset))))
  70.   (let* ((base (standard-source! base))
  71.      (target (fpr->float-register (flonum-target! target))))
  72.     (fp-load-doubleword (* 8 offset) base target #T)))
  73.  
  74. (define-rule statement
  75.   (ASSIGN (FLOAT-OFFSET (REGISTER (? base))
  76.             (MACHINE-CONSTANT (? offset)))
  77.       (REGISTER (? source)))
  78.   (let ((base (standard-source! base))
  79.     (source (fpr->float-register (flonum-source! source))))
  80.     (fp-store-doubleword (* 8 offset) base source)))
  81.  
  82. (define-rule statement
  83.   (ASSIGN (REGISTER (? target))
  84.       (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index))))
  85.   (with-indexed-address base index 3
  86.     (lambda (address)
  87.       (fp-load-doubleword 0 address
  88.               (fpr->float-register (flonum-target! target)) #T))))
  89.  
  90. (define-rule statement
  91.   (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index)))
  92.       (REGISTER (? source)))
  93.   (with-indexed-address base index 3
  94.     (lambda (address)
  95.       (fp-store-doubleword 0 address
  96.                (fpr->float-register (flonum-source! source))))))
  97.  
  98. (define-rule statement
  99.   (ASSIGN (REGISTER (? target))
  100.       (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
  101.                     (MACHINE-CONSTANT (? w-offset)))
  102.             (MACHINE-CONSTANT (? f-offset))))
  103.   (let* ((base (standard-source! base))
  104.      (target (fpr->float-register (flonum-target! target))))
  105.     (fp-load-doubleword (+ (* 4 w-offset) (* 8 f-offset)) base target #T)))
  106.  
  107. (define-rule statement
  108.   (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
  109.                     (MACHINE-CONSTANT (? w-offset)))
  110.             (MACHINE-CONSTANT (? f-offset)))
  111.       (REGISTER (? source)))
  112.   (let ((base (standard-source! base))
  113.     (source (fpr->float-register (flonum-source! source))))
  114.     (fp-store-doubleword (+ (* 4 w-offset) (* 8 f-offset)) base source)))
  115.  
  116. (define-rule statement
  117.   (ASSIGN (REGISTER (? target))
  118.       (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
  119.                     (MACHINE-CONSTANT (? w-offset)))
  120.             (REGISTER (? index))))
  121.   (with-indexed-address base index 3
  122.     (lambda (address)
  123.       (fp-load-doubleword (* 4 w-offset) address
  124.               (fpr->float-register (flonum-target! target))
  125.               #T))))
  126.  
  127. (define-rule statement
  128.   (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
  129.                     (MACHINE-CONSTANT (? w-offset)))
  130.             (REGISTER (? index)))
  131.       (REGISTER (? source)))
  132.   (with-indexed-address base index 3
  133.     (lambda (address)
  134.       (fp-store-doubleword (* 4 w-offset) address
  135.                (fpr->float-register (flonum-source! source))))))
  136.  
  137. ;;;; Flonum Arithmetic
  138.  
  139. (define-rule statement
  140.   (ASSIGN (REGISTER (? target))
  141.       (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
  142.   overflow?                ;ignore
  143.   (let ((source (flonum-source! source)))
  144.     ((flonum-1-arg/operator operation) (flonum-target! target) source)))
  145.  
  146. (define (flonum-1-arg/operator operation)
  147.   (lookup-arithmetic-method operation flonum-methods/1-arg))
  148.  
  149. (define flonum-methods/1-arg
  150.   (list 'FLONUM-METHODS/1-ARG))
  151.  
  152. ;;; Notice the weird ,', syntax here.
  153. ;;; If LAP changes, this may also have to change.
  154.  
  155. (let-syntax
  156.     ((define-flonum-operation
  157.        (macro (primitive-name opcode)
  158.      `(define-arithmetic-method ',primitive-name flonum-methods/1-arg
  159.         (lambda (target source)
  160.           (LAP (,opcode ,',target ,',source)))))))
  161.   (define-flonum-operation flonum-abs ABS.D)
  162.   (define-flonum-operation flonum-negate NEG.D))
  163.  
  164. (define-rule statement
  165.   (ASSIGN (REGISTER (? target))
  166.       (FLONUM-2-ARGS (? operation)
  167.              (REGISTER (? source1))
  168.              (REGISTER (? source2))
  169.              (? overflow?)))
  170.   overflow?                ;ignore
  171.   (let ((source1 (flonum-source! source1))
  172.     (source2 (flonum-source! source2)))
  173.     ((flonum-2-args/operator operation) (flonum-target! target)
  174.                     source1
  175.                     source2)))
  176.  
  177. (define (flonum-2-args/operator operation)
  178.   (lookup-arithmetic-method operation flonum-methods/2-args))
  179.  
  180. (define flonum-methods/2-args
  181.   (list 'FLONUM-METHODS/2-ARGS))
  182.  
  183. (let-syntax
  184.     ((define-flonum-operation
  185.        (macro (primitive-name opcode)
  186.      `(define-arithmetic-method ',primitive-name flonum-methods/2-args
  187.         (lambda (target source1 source2)
  188.           (LAP (,opcode ,',target ,',source1 ,',source2)))))))
  189.   (define-flonum-operation flonum-add ADD.D)
  190.   (define-flonum-operation flonum-subtract SUB.D)
  191.   (define-flonum-operation flonum-multiply MUL.D)
  192.   (define-flonum-operation flonum-divide DIV.D))
  193.  
  194. ;;;; Flonum Predicates
  195.  
  196. (define-rule predicate
  197.   (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
  198.   ;; No immediate zeros, easy to generate by subtracting from itself
  199.   (let ((temp (flonum-temporary!))
  200.     (source (flonum-source! source)))
  201.     (LAP (MTC1 0 ,temp)
  202.      (MTC1 0 ,(+ temp 1))
  203.      (NOP)
  204.      ,@(flonum-compare
  205.         (case predicate
  206.           ((FLONUM-ZERO?) 'C.EQ.D)
  207.           ((FLONUM-NEGATIVE?) 'C.LT.D)
  208.           ((FLONUM-POSITIVE?) 'C.GT.D)
  209.           (else (error "unknown flonum predicate" predicate)))
  210.         source temp))))
  211.  
  212. (define-rule predicate
  213.   (FLONUM-PRED-2-ARGS (? predicate)
  214.               (REGISTER (? source1))
  215.               (REGISTER (? source2)))
  216.   (flonum-compare (case predicate
  217.             ((FLONUM-EQUAL?) 'C.EQ.D)
  218.             ((FLONUM-LESS?) 'C.LT.D)
  219.             ((FLONUM-GREATER?) 'C.GT.D)
  220.             (else (error "unknown flonum predicate" predicate)))
  221.           (flonum-source! source1)
  222.           (flonum-source! source2)))
  223.  
  224. (define (flonum-compare cc r1 r2)
  225.   (set-current-branches!
  226.    (lambda (label)
  227.      (LAP (BC1T (@PCR ,label)) (NOP)))
  228.    (lambda (label)
  229.      (LAP (BC1F (@PCR ,label)) (NOP))))
  230.   (if (eq? cc 'C.GT.D)
  231.       (LAP (C.LT.D ,r2 ,r1) (NOP))
  232.       (LAP (,cc ,r1 ,r2) (NOP))))