home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / sparc / float.lisp < prev    next >
Encoding:
Text File  |  1992-12-09  |  15.9 KB  |  521 lines
  1. ;;; -*- Package: SPARC -*-
  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.10 92/10/20 03:10:34 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains floating point support for the MIPS.
  15. ;;;
  16. ;;; Written by Rob MacLachlan
  17. ;;; Sparc conversion by William Lott.
  18. ;;;
  19. (in-package "SPARC")
  20.  
  21.  
  22. ;;;; Move functions:
  23.  
  24. (define-move-function (load-single 1) (vop x y)
  25.   ((single-stack) (single-reg))
  26.   (inst ldf y (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes)))
  27.  
  28. (define-move-function (store-single 1) (vop x y)
  29.   ((single-reg) (single-stack))
  30.   (inst stf 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 lddf y nfp offset)))
  38.  
  39. (define-move-function (store-double 2) (vop x y)
  40.   ((double-reg) (double-stack))
  41.   (let ((nfp (current-nfp-tn vop))
  42.     (offset (* (tn-offset y) vm:word-bytes)))
  43.     (inst stdf x nfp offset)))
  44.  
  45.  
  46.  
  47. ;;;; Move VOPs:
  48.  
  49. (macrolet ((frob (vop sc double-p)
  50.          `(progn
  51.         (define-vop (,vop)
  52.           (:args (x :scs (,sc)
  53.                 :target y
  54.                 :load-if (not (location= x y))))
  55.           (:results (y :scs (,sc)
  56.                    :load-if (not (location= x y))))
  57.           (:note "float move")
  58.           (:generator 0
  59.             (unless (location= y x)
  60.               (inst fmovs y x)
  61.               ,@(when double-p
  62.               '((inst fmovs-odd y x))))))
  63.         (define-move-vop ,vop :move (,sc) (,sc)))))
  64.   (frob single-move single-reg nil)
  65.   (frob double-move double-reg t))
  66.  
  67.  
  68. (define-vop (move-from-float)
  69.   (:args (x :to :save))
  70.   (:results (y))
  71.   (:note "float to pointer coercion")
  72.   (:temporary (:scs (non-descriptor-reg)) ndescr)
  73.   (:variant-vars double-p size type data)
  74.   (:generator 13
  75.     (with-fixed-allocation (y ndescr type size))
  76.     (if double-p
  77.     (inst stdf x y (- (* data vm:word-bytes) vm:other-pointer-type))
  78.     (inst stf x y (- (* data vm:word-bytes) vm:other-pointer-type)))))
  79.  
  80. (macrolet ((frob (name sc &rest args)
  81.          `(progn
  82.         (define-vop (,name move-from-float)
  83.           (:args (x :scs (,sc) :to :save))
  84.           (:results (y :scs (descriptor-reg)))
  85.           (:variant ,@args))
  86.         (define-move-vop ,name :move (,sc) (descriptor-reg)))))
  87.   (frob move-from-single single-reg
  88.     nil vm:single-float-size vm:single-float-type vm:single-float-value-slot)
  89.   (frob move-from-double double-reg
  90.     t vm:double-float-size vm:double-float-type vm:double-float-value-slot))
  91.  
  92. (macrolet ((frob (name sc double-p value)
  93.          `(progn
  94.         (define-vop (,name)
  95.           (:args (x :scs (descriptor-reg)))
  96.           (:results (y :scs (,sc)))
  97.           (:note "pointer to float coercion")
  98.           (:generator 2
  99.             (inst ,(if double-p 'lddf 'ldf) y x
  100.               (- (* ,value vm:word-bytes) vm:other-pointer-type))))
  101.         (define-move-vop ,name :move (descriptor-reg) (,sc)))))
  102.   (frob move-to-single single-reg nil vm:single-float-value-slot)
  103.   (frob move-to-double double-reg t vm:double-float-value-slot))
  104.  
  105.  
  106. (macrolet ((frob (name sc stack-sc double-p)
  107.          `(progn
  108.         (define-vop (,name)
  109.           (:args (x :scs (,sc) :target y)
  110.              (nfp :scs (any-reg)
  111.                   :load-if (not (sc-is y ,sc))))
  112.           (:results (y))
  113.           (:note "float argument move")
  114.           (:generator ,(if double-p 2 1)
  115.             (sc-case y
  116.               (,sc
  117.                (unless (location= x y)
  118.              (inst fmovs y x)
  119.              ,@(when double-p
  120.                  '((inst fmovs-odd y x)))))
  121.               (,stack-sc
  122.                (let ((offset (* (tn-offset y) vm:word-bytes)))
  123.              (inst ,(if double-p 'stdf 'stf) x nfp offset))))))
  124.         (define-move-vop ,name :move-argument
  125.           (,sc descriptor-reg) (,sc)))))
  126.   (frob move-single-float-argument single-reg single-stack nil)
  127.   (frob move-double-float-argument double-reg double-stack t))
  128.  
  129.  
  130. (define-move-vop move-argument :move-argument
  131.   (single-reg double-reg) (descriptor-reg))
  132.  
  133.  
  134. ;;;; Arithmetic VOPs:
  135.  
  136. (define-vop (float-op)
  137.   (:args (x) (y))
  138.   (:results (r))
  139.   (:policy :fast-safe)
  140.   (:note "inline float arithmetic")
  141.   (:vop-var vop)
  142.   (:save-p :compute-only))
  143.  
  144. (macrolet ((frob (name sc ptype)
  145.          `(define-vop (,name float-op)
  146.         (:args (x :scs (,sc))
  147.                (y :scs (,sc)))
  148.         (:results (r :scs (,sc)))
  149.         (:arg-types ,ptype ,ptype)
  150.         (:result-types ,ptype))))
  151.   (frob single-float-op single-reg single-float)
  152.   (frob double-float-op double-reg double-float))
  153.  
  154. (macrolet ((frob (op sinst sname scost dinst dname dcost)
  155.          `(progn
  156.         (define-vop (,sname single-float-op)
  157.           (:translate ,op)
  158.           (:generator ,scost
  159.             (inst ,sinst r x y)))
  160.         (define-vop (,dname double-float-op)
  161.           (:translate ,op)
  162.           (:generator ,dcost
  163.             (inst ,dinst r x y))))))
  164.   (frob + fadds +/single-float 2 faddd +/double-float 2)
  165.   (frob - fsubs -/single-float 2 fsubd -/double-float 2)
  166.   (frob * fmuls */single-float 4 fmuld */double-float 5)
  167.   (frob / fdivs //single-float 12 fdivd //double-float 19))
  168.  
  169. (macrolet ((frob (name inst translate double-p sc type)
  170.          `(define-vop (,name)
  171.         (:args (x :scs (,sc)))
  172.         (:results (y :scs (,sc)))
  173.         (:translate ,translate)
  174.         (:policy :fast-safe)
  175.         (:arg-types ,type)
  176.         (:result-types ,type)
  177.         (:note "inline float arithmetic")
  178.         (:vop-var vop)
  179.         (:save-p :compute-only)
  180.         (:generator 1
  181.           (note-this-location vop :internal-error)
  182.           (inst ,inst y x)
  183.           ,@(when double-p
  184.               '((inst fmovs-odd y x)))))))
  185.   (frob abs/single-float fabss abs nil single-reg single-float)
  186.   (frob abs/double-float fabss abs t double-reg double-float)
  187.   (frob %negate/single-float fnegs %negate nil single-reg single-float)
  188.   (frob %negate/double-float fnegs %negate t double-reg double-float))
  189.  
  190.  
  191. ;;;; Comparison:
  192.  
  193. (define-vop (float-compare)
  194.   (:args (x) (y))
  195.   (:conditional)
  196.   (:info target not-p)
  197.   (:variant-vars format yep nope)
  198.   (:policy :fast-safe)
  199.   (:note "inline float comparison")
  200.   (:vop-var vop)
  201.   (:save-p :compute-only)
  202.   (:generator 3
  203.     (note-this-location vop :internal-error)
  204.     (ecase format
  205.       (:single (inst fcmps x y))
  206.       (:double (inst fcmpd x y)))
  207.     (inst nop)
  208.     (inst fb (if not-p nope yep) target)
  209.     (inst nop)))
  210.  
  211. (macrolet ((frob (name sc ptype)
  212.          `(define-vop (,name float-compare)
  213.         (:args (x :scs (,sc))
  214.                (y :scs (,sc)))
  215.         (:arg-types ,ptype ,ptype))))
  216.   (frob single-float-compare single-reg single-float)
  217.   (frob double-float-compare double-reg double-float))
  218.  
  219. (macrolet ((frob (translate yep nope sname dname)
  220.          `(progn
  221.         (define-vop (,sname single-float-compare)
  222.           (:translate ,translate)
  223.           (:variant :single ,yep ,nope))
  224.         (define-vop (,dname double-float-compare)
  225.           (:translate ,translate)
  226.           (:variant :double ,yep ,nope)))))
  227.   (frob < :l :ge </single-float </double-float)
  228.   (frob > :g :le >/single-float >/double-float)
  229.   (frob eql :eq :ne eql/single-float eql/double-float))
  230.  
  231.  
  232. ;;;; Conversion:
  233.  
  234. (macrolet ((frob (name translate inst to-sc to-type)
  235.          `(define-vop (,name)
  236.         (:args (x :scs (signed-reg) :target temp
  237.               :load-if (not (sc-is x signed-stack))))
  238.         (:temporary (:scs (single-stack)) temp)
  239.         (:results (y :scs (,to-sc)))
  240.         (:arg-types signed-num)
  241.         (:result-types ,to-type)
  242.         (:policy :fast-safe)
  243.         (:note "inline float coercion")
  244.         (:translate ,translate)
  245.         (:vop-var vop)
  246.         (:save-p :compute-only)
  247.         (:generator 5
  248.           (let ((stack-tn
  249.              (sc-case x
  250.                (signed-reg
  251.                 (inst st x
  252.                   (current-nfp-tn vop)
  253.                   (* (tn-offset temp) vm:word-bytes))
  254.                 temp)
  255.                (signed-stack
  256.                 x))))
  257.             (inst ldf y
  258.               (current-nfp-tn vop)
  259.               (* (tn-offset stack-tn) vm:word-bytes))
  260.             (note-this-location vop :internal-error)
  261.             (inst ,inst y y))))))
  262.   (frob %single-float/signed %single-float fitos single-reg single-float)
  263.   (frob %double-float/signed %double-float fitod double-reg double-float))
  264.  
  265. (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
  266.          `(define-vop (,name)
  267.         (:args (x :scs (,from-sc)))
  268.         (:results (y :scs (,to-sc)))
  269.         (:arg-types ,from-type)
  270.         (:result-types ,to-type)
  271.         (:policy :fast-safe)
  272.         (:note "inline float coercion")
  273.         (:translate ,translate)
  274.         (:vop-var vop)
  275.         (:save-p :compute-only)
  276.         (:generator 2
  277.           (note-this-location vop :internal-error)
  278.           (inst ,inst y x)))))
  279.   (frob %single-float/double-float %single-float fdtos
  280.     double-reg double-float single-reg single-float)
  281.   (frob %double-float/single-float %double-float fstod
  282.     single-reg single-float double-reg double-float))
  283.  
  284. (macrolet ((frob (trans from-sc from-type inst)
  285.          `(define-vop (,(symbolicate trans "/" from-type))
  286.         (:args (x :scs (,from-sc) :target temp))
  287.         (:temporary (:from (:argument 0) :sc single-reg) temp)
  288.         (:temporary (:scs (signed-stack)) stack-temp)
  289.         (:results (y :scs (signed-reg)
  290.                  :load-if (not (sc-is y signed-stack))))
  291.         (:arg-types ,from-type)
  292.         (:result-types signed-num)
  293.         (:translate ,trans)
  294.         (:policy :fast-safe)
  295.         (:note "inline float truncate")
  296.         (:vop-var vop)
  297.         (:save-p :compute-only)
  298.         (:generator 5
  299.           (note-this-location vop :internal-error)
  300.           (inst ,inst temp x)
  301.           (sc-case y
  302.             (signed-stack
  303.              (inst stf temp (current-nfp-tn vop)
  304.                (* (tn-offset y) vm:word-bytes)))
  305.             (signed-reg
  306.              (inst stf temp (current-nfp-tn vop)
  307.                (* (tn-offset stack-temp) vm:word-bytes))
  308.              (inst ld y (current-nfp-tn vop)
  309.                (* (tn-offset stack-temp) vm:word-bytes))))))))
  310.   (frob %unary-truncate single-reg single-float fstoi)
  311.   (frob %unary-truncate double-reg double-float fdtoi)
  312.   #-sun4
  313.   (frob %unary-round single-reg single-float fstoir)
  314.   #-sun4
  315.   (frob %unary-round double-reg double-float fdtoir))
  316.  
  317. #+sun4
  318. (deftransform %unary-round ((x) (float) (signed-byte 32))
  319.   '(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x)))
  320.       (extra (- x trunc))
  321.       (absx (abs extra))
  322.       (one-half (float 1/2 x)))
  323.      (if (if (oddp trunc)
  324.          (>= absx one-half)
  325.          (> absx one-half))
  326.      (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
  327.      trunc)))
  328.  
  329. (define-vop (make-single-float)
  330.   (:args (bits :scs (signed-reg) :target res
  331.            :load-if (not (sc-is bits signed-stack))))
  332.   (:results (res :scs (single-reg)
  333.          :load-if (not (sc-is res single-stack))))
  334.   (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
  335.   (:temporary (:scs (signed-stack)) stack-temp)
  336.   (:arg-types signed-num)
  337.   (:result-types single-float)
  338.   (:translate make-single-float)
  339.   (:policy :fast-safe)
  340.   (:vop-var vop)
  341.   (:generator 4
  342.     (sc-case bits
  343.       (signed-reg
  344.        (sc-case res
  345.      (single-reg
  346.       (inst st bits (current-nfp-tn vop)
  347.         (* (tn-offset stack-temp) vm:word-bytes))
  348.       (inst ldf res (current-nfp-tn vop)
  349.         (* (tn-offset stack-temp) vm:word-bytes)))
  350.      (single-stack
  351.       (inst st bits (current-nfp-tn vop)
  352.         (* (tn-offset res) vm:word-bytes)))))
  353.       (signed-stack
  354.        (sc-case res
  355.      (single-reg
  356.       (inst ldf res (current-nfp-tn vop)
  357.         (* (tn-offset bits) vm:word-bytes)))
  358.      (single-stack
  359.       (unless (location= bits res)
  360.         (inst ld temp (current-nfp-tn vop)
  361.           (* (tn-offset bits) vm:word-bytes))
  362.         (inst st temp (current-nfp-tn vop)
  363.           (* (tn-offset res) vm:word-bytes)))))))))
  364.  
  365. (define-vop (make-double-float)
  366.   (:args (hi-bits :scs (signed-reg))
  367.      (lo-bits :scs (unsigned-reg)))
  368.   (:results (res :scs (double-reg)
  369.          :load-if (not (sc-is res double-stack))))
  370.   (:temporary (:scs (double-stack)) temp)
  371.   (:arg-types signed-num unsigned-num)
  372.   (:result-types double-float)
  373.   (:translate make-double-float)
  374.   (:policy :fast-safe)
  375.   (:vop-var vop)
  376.   (:generator 2
  377.     (let ((stack-tn (sc-case res
  378.               (double-stack res)
  379.               (double-reg temp))))
  380.       (inst st hi-bits (current-nfp-tn vop)
  381.         (* (tn-offset stack-tn) vm:word-bytes))
  382.       (inst st lo-bits (current-nfp-tn vop)
  383.         (* (1+ (tn-offset stack-tn)) vm:word-bytes)))
  384.     (when (sc-is res double-reg)
  385.       (inst lddf res (current-nfp-tn vop)
  386.         (* (tn-offset temp) vm:word-bytes)))))
  387.  
  388. (define-vop (single-float-bits)
  389.   (:args (float :scs (single-reg descriptor-reg)
  390.         :load-if (not (sc-is float single-stack))))
  391.   (:results (bits :scs (signed-reg)
  392.           :load-if (or (sc-is float descriptor-reg single-stack)
  393.                    (not (sc-is bits signed-stack)))))
  394.   (:temporary (:scs (signed-stack)) stack-temp)
  395.   (:arg-types single-float)
  396.   (:result-types signed-num)
  397.   (:translate single-float-bits)
  398.   (:policy :fast-safe)
  399.   (:vop-var vop)
  400.   (:generator 4
  401.     (sc-case bits
  402.       (signed-reg
  403.        (sc-case float
  404.      (single-reg
  405.       (inst stf float (current-nfp-tn vop)
  406.         (* (tn-offset stack-temp) vm:word-bytes))
  407.       (inst ld bits (current-nfp-tn vop)
  408.         (* (tn-offset stack-temp) vm:word-bytes)))
  409.      (single-stack
  410.       (inst ld bits (current-nfp-tn vop)
  411.         (* (tn-offset float) vm:word-bytes)))
  412.      (descriptor-reg
  413.       (loadw bits float vm:single-float-value-slot vm:other-pointer-type))))
  414.       (signed-stack
  415.        (sc-case float
  416.      (single-reg
  417.       (inst stf float (current-nfp-tn vop)
  418.         (* (tn-offset bits) vm:word-bytes))))))))
  419.  
  420. (define-vop (double-float-high-bits)
  421.   (:args (float :scs (double-reg descriptor-reg)
  422.         :load-if (not (sc-is float double-stack))))
  423.   (:results (hi-bits :scs (signed-reg)
  424.              :load-if (or (sc-is float descriptor-reg double-stack)
  425.                   (not (sc-is hi-bits signed-stack)))))
  426.   (:temporary (:scs (signed-stack)) stack-temp)
  427.   (:arg-types double-float)
  428.   (:result-types signed-num)
  429.   (:translate double-float-high-bits)
  430.   (:policy :fast-safe)
  431.   (:vop-var vop)
  432.   (:generator 5
  433.     (sc-case hi-bits
  434.       (signed-reg
  435.        (sc-case float
  436.      (double-reg
  437.       (inst stf float (current-nfp-tn vop)
  438.         (* (tn-offset stack-temp) vm:word-bytes))
  439.       (inst ld hi-bits (current-nfp-tn vop)
  440.         (* (tn-offset stack-temp) vm:word-bytes)))
  441.      (double-stack
  442.       (inst ld hi-bits (current-nfp-tn vop)
  443.         (* (tn-offset float) vm:word-bytes)))
  444.      (descriptor-reg
  445.       (loadw hi-bits float vm:double-float-value-slot
  446.          vm:other-pointer-type))))
  447.       (signed-stack
  448.        (sc-case float
  449.      (double-reg
  450.       (inst stf float (current-nfp-tn vop)
  451.         (* (tn-offset hi-bits) vm:word-bytes))))))))
  452.  
  453. (define-vop (double-float-low-bits)
  454.   (:args (float :scs (double-reg descriptor-reg)
  455.         :load-if (not (sc-is float double-stack))))
  456.   (:results (lo-bits :scs (unsigned-reg)
  457.              :load-if (or (sc-is float descriptor-reg double-stack)
  458.                   (not (sc-is lo-bits unsigned-stack)))))
  459.   (:temporary (:scs (unsigned-stack)) stack-temp)
  460.   (:arg-types double-float)
  461.   (:result-types unsigned-num)
  462.   (:translate double-float-low-bits)
  463.   (:policy :fast-safe)
  464.   (:vop-var vop)
  465.   (:generator 5
  466.     (sc-case lo-bits
  467.       (unsigned-reg
  468.        (sc-case float
  469.      (double-reg
  470.       (inst stf-odd float (current-nfp-tn vop)
  471.         (* (tn-offset stack-temp) vm:word-bytes))
  472.       (inst ld lo-bits (current-nfp-tn vop)
  473.         (* (tn-offset stack-temp) vm:word-bytes)))
  474.      (double-stack
  475.       (inst ld lo-bits (current-nfp-tn vop)
  476.         (* (1+ (tn-offset float)) vm:word-bytes)))
  477.      (descriptor-reg
  478.       (loadw lo-bits float (1+ vm:double-float-value-slot)
  479.          vm:other-pointer-type))))
  480.       (unsigned-stack
  481.        (sc-case float
  482.      (double-reg
  483.       (inst stf-odd float (current-nfp-tn vop)
  484.         (* (tn-offset lo-bits) vm:word-bytes))))))))
  485.  
  486.  
  487. ;;;; Float mode hackery:
  488.  
  489. (deftype float-modes () '(unsigned-byte 32))
  490. (defknown floating-point-modes () float-modes (flushable))
  491. (defknown ((setf floating-point-modes)) (float-modes)
  492.   float-modes)
  493.  
  494. (define-vop (floating-point-modes)
  495.   (:results (res :scs (unsigned-reg)))
  496.   (:result-types unsigned-num)
  497.   (:translate floating-point-modes)
  498.   (:policy :fast-safe)
  499.   (:vop-var vop)
  500.   (:temporary (:sc unsigned-stack) temp)
  501.   (:generator 3
  502.     (let ((nfp (current-nfp-tn vop)))
  503.       (inst stfsr nfp (* word-bytes (tn-offset temp)))
  504.       (loadw res nfp (tn-offset temp))
  505.       (inst nop))))
  506.  
  507. (define-vop (set-floating-point-modes)
  508.   (:args (new :scs (unsigned-reg) :target res))
  509.   (:results (res :scs (unsigned-reg)))
  510.   (:arg-types unsigned-num)
  511.   (:result-types unsigned-num)
  512.   (:translate (setf floating-point-modes))
  513.   (:policy :fast-safe)
  514.   (:temporary (:sc unsigned-stack) temp)
  515.   (:vop-var vop)
  516.   (:generator 3
  517.     (let ((nfp (current-nfp-tn vop)))
  518.       (storew new nfp (tn-offset temp))
  519.       (inst ldfsr nfp (* word-bytes (tn-offset temp)))
  520.       (move res new))))
  521.