home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / float.lisp < prev    next >
Encoding:
Text File  |  1992-02-22  |  12.5 KB  |  422 lines
  1. ;;; -*- Package: MIPS; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: float.lisp,v 1.14 92/02/21 22:02:56 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains floating point support for the MIPS.
  15. ;;;
  16. ;;; Written by Rob MacLachlan
  17. ;;;
  18. (in-package "MIPS")
  19.  
  20.  
  21. ;;;; Move functions:
  22.  
  23. (define-move-function (load-single 1) (vop x y)
  24.   ((single-stack) (single-reg))
  25.   (inst lwc1 y (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
  26.   (inst nop))
  27.  
  28. (define-move-function (store-single 1) (vop x y)
  29.   ((single-reg) (single-stack))
  30.   (inst swc1 x (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes)))
  31.  
  32.  
  33. (define-move-function (load-double 2) (vop x y)
  34.   ((double-stack) (double-reg))
  35.   (let ((nfp (current-nfp-tn vop))
  36.     (offset (* (tn-offset x) vm:word-bytes)))
  37.     (inst lwc1 y nfp offset)
  38.     (inst lwc1-odd y nfp (+ offset vm:word-bytes)))
  39.   (inst nop))
  40.  
  41. (define-move-function (store-double 2) (vop x y)
  42.   ((double-reg) (double-stack))
  43.   (let ((nfp (current-nfp-tn vop))
  44.     (offset (* (tn-offset y) vm:word-bytes)))
  45.     (inst swc1 x nfp offset)
  46.     (inst swc1-odd x nfp (+ offset vm:word-bytes))))
  47.  
  48.  
  49.  
  50. ;;;; Move VOPs:
  51.  
  52. (macrolet ((frob (vop sc format)
  53.          `(progn
  54.         (define-vop (,vop)
  55.           (:args (x :scs (,sc)
  56.                 :target y
  57.                 :load-if (not (location= x y))))
  58.           (:results (y :scs (,sc)
  59.                    :load-if (not (location= x y))))
  60.           (:note "float move")
  61.           (:generator 0
  62.             (unless (location= y x)
  63.               (inst move ,format y x))))
  64.         (define-move-vop ,vop :move (,sc) (,sc)))))
  65.   (frob single-move single-reg :single)
  66.   (frob double-move double-reg :double))
  67.  
  68.  
  69. (define-vop (move-from-float)
  70.   (:args (x :to :save))
  71.   (:results (y))
  72.   (:temporary (:scs (non-descriptor-reg)) ndescr)
  73.   (:variant-vars double-p size type data)
  74.   (:note "float to pointer coercion")
  75.   (:generator 13
  76.     (with-fixed-allocation (y ndescr type size)
  77.       (inst swc1 x y (- (* data vm:word-bytes) vm:other-pointer-type))
  78.       (when double-p
  79.     (inst swc1-odd x y (- (* (1+ data) vm:word-bytes)
  80.                   vm:other-pointer-type))))))
  81.  
  82. (macrolet ((frob (name sc &rest args)
  83.          `(progn
  84.         (define-vop (,name move-from-float)
  85.           (:args (x :scs (,sc) :to :save))
  86.           (:results (y :scs (descriptor-reg)))
  87.           (:variant ,@args))
  88.         (define-move-vop ,name :move (,sc) (descriptor-reg)))))
  89.   (frob move-from-single single-reg
  90.     nil vm:single-float-size vm:single-float-type vm:single-float-value-slot)
  91.   (frob move-from-double double-reg
  92.     t vm:double-float-size vm:double-float-type vm:double-float-value-slot))
  93.  
  94. (macrolet ((frob (name sc double-p value)
  95.          `(progn
  96.         (define-vop (,name)
  97.           (:args (x :scs (descriptor-reg)))
  98.           (:results (y :scs (,sc)))
  99.           (:note "pointer to float coercion")
  100.           (:generator 2
  101.             (inst lwc1 y x (- (* ,value vm:word-bytes)
  102.                       vm:other-pointer-type))
  103.             ,@(when double-p
  104.             `((inst lwc1-odd y x (- (* (1+ ,value) vm:word-bytes)
  105.                         vm:other-pointer-type))))
  106.             (inst nop)))
  107.         (define-move-vop ,name :move (descriptor-reg) (,sc)))))
  108.   (frob move-to-single single-reg nil vm:single-float-value-slot)
  109.   (frob move-to-double double-reg t vm:double-float-value-slot))
  110.  
  111.  
  112. (macrolet ((frob (name sc stack-sc format double-p)
  113.          `(progn
  114.         (define-vop (,name)
  115.           (:args (x :scs (,sc) :target y)
  116.              (nfp :scs (any-reg)
  117.                   :load-if (not (sc-is y ,sc))))
  118.           (:results (y))
  119.           (:note "float argument move")
  120.           (:generator ,(if double-p 2 1)
  121.             (sc-case y
  122.               (,sc
  123.                (unless (location= x y)
  124.              (inst move ,format y x)))
  125.               (,stack-sc
  126.                (let ((offset (* (tn-offset y) vm:word-bytes)))
  127.              (inst swc1 x nfp offset)
  128.              ,@(when double-p
  129.                  '((inst swc1-odd x nfp
  130.                      (+ offset vm:word-bytes)))))))))
  131.         (define-move-vop ,name :move-argument
  132.           (,sc descriptor-reg) (,sc)))))
  133.   (frob move-single-float-argument single-reg single-stack :single nil)
  134.   (frob move-double-float-argument double-reg double-stack :double t))
  135.  
  136.  
  137. (define-move-vop move-argument :move-argument
  138.   (single-reg double-reg) (descriptor-reg))
  139.  
  140.  
  141. ;;;; Arithmetic VOPs:
  142.  
  143. (define-vop (float-op)
  144.   (:args (x) (y))
  145.   (:results (r))
  146.   (:variant-vars format operation)
  147.   (:policy :fast-safe)
  148.   (:note "inline float arithmetic")
  149.   (:vop-var vop)
  150.   (:save-p :compute-only)
  151.   (:generator 0
  152.     (note-this-location vop :internal-error)
  153.     (inst float-op operation format r x y)))
  154.  
  155. (macrolet ((frob (name sc ptype)
  156.          `(define-vop (,name float-op)
  157.         (:args (x :scs (,sc))
  158.                (y :scs (,sc)))
  159.         (:results (r :scs (,sc)))
  160.         (:arg-types ,ptype ,ptype)
  161.         (:result-types ,ptype))))
  162.   (frob single-float-op single-reg single-float)
  163.   (frob double-float-op double-reg double-float))
  164.  
  165. (macrolet ((frob (op sname scost dname dcost)
  166.          `(progn
  167.         (define-vop (,sname single-float-op)
  168.           (:translate ,op)
  169.           (:variant :single ',op)
  170.           (:variant-cost ,scost))
  171.         (define-vop (,dname double-float-op)
  172.           (:translate ,op)
  173.           (:variant :double ',op)
  174.           (:variant-cost ,dcost)))))
  175.   (frob + +/single-float 2 +/double-float 2)
  176.   (frob - -/single-float 2 -/double-float 2)
  177.   (frob * */single-float 4 */double-float 5)
  178.   (frob / //single-float 12 //double-float 19))
  179.  
  180. (macrolet ((frob (name inst translate format sc type)
  181.          `(define-vop (,name)
  182.         (:args (x :scs (,sc)))
  183.         (:results (y :scs (,sc)))
  184.         (:translate ,translate)
  185.         (:policy :fast-safe)
  186.         (:arg-types ,type)
  187.         (:result-types ,type)
  188.         (:note "inline float arithmetic")
  189.         (:vop-var vop)
  190.         (:save-p :compute-only)
  191.         (:generator 1
  192.           (note-this-location vop :internal-error)
  193.           (inst ,inst ,format y x)))))
  194.   (frob abs/single-float fabs abs :single single-reg single-float)
  195.   (frob abs/double-float fabs abs :double double-reg double-float)
  196.   (frob %negate/single-float fneg %negate :single single-reg single-float)
  197.   (frob %negate/double-float fneg %negate :double double-reg double-float))
  198.  
  199.  
  200. ;;;; Comparison:
  201.  
  202. (define-vop (float-compare)
  203.   (:args (x) (y))
  204.   (:conditional)
  205.   (:info target not-p)
  206.   (:variant-vars format operation complement)
  207.   (:policy :fast-safe)
  208.   (:note "inline float comparison")
  209.   (:vop-var vop)
  210.   (:save-p :compute-only)
  211.   (:generator 3
  212.     (note-this-location vop :internal-error)
  213.     (inst fcmp operation format x y)
  214.     (inst nop)
  215.     (if (if complement (not not-p) not-p)
  216.     (inst bc1f target)
  217.     (inst bc1t target))
  218.     (inst nop)))
  219.  
  220. (macrolet ((frob (name sc ptype)
  221.          `(define-vop (,name float-compare)
  222.         (:args (x :scs (,sc))
  223.                (y :scs (,sc)))
  224.         (:arg-types ,ptype ,ptype))))
  225.   (frob single-float-compare single-reg single-float)
  226.   (frob double-float-compare double-reg double-float))
  227.  
  228. (macrolet ((frob (translate op complement sname dname)
  229.          `(progn
  230.         (define-vop (,sname single-float-compare)
  231.           (:translate ,translate)
  232.           (:variant :single ,op ,complement))
  233.         (define-vop (,dname double-float-compare)
  234.           (:translate ,translate)
  235.           (:variant :double ,op ,complement)))))
  236.   (frob < :lt nil </single-float </double-float)
  237.   (frob > :ngt t >/single-float >/double-float)
  238.   (frob eql :seq nil eql/single-float eql/double-float))
  239.  
  240.  
  241. ;;;; Conversion:
  242.  
  243. (macrolet ((frob (name translate
  244.                from-sc from-type from-format
  245.                to-sc to-type to-format)
  246.          (let ((word-p (eq from-format :word)))
  247.            `(define-vop (,name)
  248.           (:args (x :scs (,from-sc)))
  249.           (:results (y :scs (,to-sc)))
  250.           (:arg-types ,from-type)
  251.           (:result-types ,to-type)
  252.           (:policy :fast-safe)
  253.           (:note "inline float coercion")
  254.           (:translate ,translate)
  255.           (:vop-var vop)
  256.           (:save-p :compute-only)
  257.           (:generator ,(if word-p 3 2)
  258.             ,@(if word-p
  259.               `((inst mtc1 y x)
  260.                 (inst nop)
  261.                 (note-this-location vop :internal-error)
  262.                 (inst fcvt ,to-format :word y y))
  263.               `((note-this-location vop :internal-error)
  264.                 (inst fcvt ,to-format ,from-format y x))))))))
  265.   (frob %single-float/signed %single-float
  266.     signed-reg signed-num :word
  267.     single-reg single-float :single)
  268.   (frob %double-float/signed %double-float
  269.     signed-reg signed-num :word
  270.     double-reg double-float :double)
  271.   (frob %single-float/double-float %single-float
  272.     double-reg double-float :double
  273.     single-reg single-float :single)
  274.   (frob %double-float/single-float %double-float
  275.     single-reg single-float :single
  276.     double-reg double-float :double))
  277.  
  278.  
  279. (macrolet ((frob (name from-sc from-type from-format)
  280.          `(define-vop (,name)
  281.         (:args (x :scs (,from-sc)))
  282.         (:results (y :scs (signed-reg)))
  283.         (:temporary (:from (:argument 0) :sc ,from-sc) temp)
  284.         (:arg-types ,from-type)
  285.         (:result-types signed-num)
  286.         (:translate %unary-round)
  287.         (:policy :fast-safe)
  288.         (:note "inline float round")
  289.         (:vop-var vop)
  290.         (:save-p :compute-only)
  291.         (:generator 3
  292.           (note-this-location vop :internal-error)
  293.           (inst fcvt :word ,from-format temp x)
  294.           (inst mfc1 y temp)
  295.           (inst nop)))))
  296.   (frob %unary-round/single-float single-reg single-float :single)
  297.   (frob %unary-round/double-float double-reg double-float :double))
  298.  
  299.  
  300. ;;; These VOPs have to uninterruptibly frob the rounding mode in order to get
  301. ;;; the desired round-to-zero behavior.
  302. ;;;
  303. (macrolet ((frob (name from-sc from-type from-format)
  304.          `(define-vop (,name)
  305.         (:args (x :scs (,from-sc)))
  306.         (:results (y :scs (signed-reg)))
  307.         (:temporary (:from (:argument 0) :sc ,from-sc) temp)
  308.         (:temporary (:sc non-descriptor-reg) status-save new-status)
  309.         (:arg-types ,from-type)
  310.         (:result-types signed-num)
  311.         (:translate %unary-truncate)
  312.         (:policy :fast-safe)
  313.         (:note "inline float truncate")
  314.         (:vop-var vop)
  315.         (:save-p :compute-only)
  316.         (:generator 16
  317.           (pseudo-atomic (status-save)
  318.             (inst cfc1 status-save 31)
  319.             (inst li new-status (lognot 3))
  320.             (inst and new-status status-save)
  321.             (inst or new-status float-round-to-zero)
  322.             (inst ctc1 new-status 31)
  323.  
  324.             ;; These instructions seem to be necessary to ensure that
  325.             ;; the new modes affect the fcvt instruction.
  326.             (inst nop)
  327.             (inst cfc1 new-status 31)
  328.  
  329.             (note-this-location vop :internal-error)
  330.             (inst fcvt :word ,from-format temp x)
  331.             (inst mfc1 y temp)
  332.             (inst nop)
  333.             (inst ctc1 status-save 31))))))
  334.   (frob %unary-truncate/single-float single-reg single-float :single)
  335.   (frob %unary-truncate/double-float double-reg double-float :double))
  336.  
  337.  
  338. (define-vop (make-single-float)
  339.   (:args (bits :scs (signed-reg)))
  340.   (:results (res :scs (single-reg)))
  341.   (:arg-types signed-num)
  342.   (:result-types single-float)
  343.   (:translate make-single-float)
  344.   (:policy :fast-safe)
  345.   (:generator 2
  346.     (inst mtc1 res bits)
  347.     (inst nop)))
  348.  
  349. (define-vop (make-double-float)
  350.   (:args (hi-bits :scs (signed-reg))
  351.      (lo-bits :scs (unsigned-reg)))
  352.   (:results (res :scs (double-reg)))
  353.   (:arg-types signed-num unsigned-num)
  354.   (:result-types double-float)
  355.   (:translate make-double-float)
  356.   (:policy :fast-safe)
  357.   (:generator 2
  358.     (inst mtc1 res lo-bits)
  359.     (inst mtc1-odd res hi-bits)
  360.     (inst nop)))
  361.  
  362. (define-vop (single-float-bits)
  363.   (:args (float :scs (single-reg)))
  364.   (:results (bits :scs (signed-reg)))
  365.   (:arg-types single-float)
  366.   (:result-types signed-num)
  367.   (:translate single-float-bits)
  368.   (:policy :fast-safe)
  369.   (:generator 2
  370.     (inst mfc1 bits float)
  371.     (inst nop)))
  372.  
  373. (define-vop (double-float-high-bits)
  374.   (:args (float :scs (double-reg)))
  375.   (:results (hi-bits :scs (signed-reg)))
  376.   (:arg-types double-float)
  377.   (:result-types signed-num)
  378.   (:translate double-float-high-bits)
  379.   (:policy :fast-safe)
  380.   (:generator 2
  381.     (inst mfc1-odd hi-bits float)
  382.     (inst nop)))
  383.  
  384. (define-vop (double-float-low-bits)
  385.   (:args (float :scs (double-reg)))
  386.   (:results (lo-bits :scs (unsigned-reg)))
  387.   (:arg-types double-float)
  388.   (:result-types unsigned-num)
  389.   (:translate double-float-low-bits)
  390.   (:policy :fast-safe)
  391.   (:generator 2
  392.     (inst mfc1 lo-bits float)
  393.     (inst nop)))
  394.  
  395.  
  396. ;;;; Float mode hackery:
  397.  
  398. (deftype float-modes () '(unsigned-byte 24))
  399. (defknown floating-point-modes () float-modes (flushable))
  400. (defknown ((setf floating-point-modes)) (float-modes)
  401.   float-modes)
  402.  
  403. (define-vop (floating-point-modes)
  404.   (:results (res :scs (unsigned-reg)))
  405.   (:result-types unsigned-num)
  406.   (:translate floating-point-modes)
  407.   (:policy :fast-safe)
  408.   (:generator 3
  409.     (inst cfc1 res 31)
  410.     (inst nop)))
  411.  
  412. (define-vop (set-floating-point-modes)
  413.   (:args (new :scs (unsigned-reg) :target res))
  414.   (:results (res :scs (unsigned-reg)))
  415.   (:arg-types unsigned-num)
  416.   (:result-types unsigned-num)
  417.   (:translate (setf floating-point-modes))
  418.   (:policy :fast-safe)
  419.   (:generator 3
  420.     (inst ctc1 res 31)
  421.     (move res new)))
  422.