1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S --
9 -- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
10 -- (Version for Alpha OpenVMS) --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 3, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. --
19 -- As a special exception under Section 7 of GPL version 3, you are granted --
20 -- additional permissions described in the GCC Runtime Library Exception, --
21 -- version 3.1, as published by the Free Software Foundation. --
23 -- You should have received a copy of the GNU General Public License and --
24 -- a copy of the GCC Runtime Library Exception along with this program; --
25 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
26 -- <http://www.gnu.org/licenses/>. --
28 -- GNAT was originally developed by the GNAT team at New York University. --
29 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 ------------------------------------------------------------------------------
34 with System.Machine_Code; use System.Machine_Code;
36 package body System.Vax_Float_Operations is
38 -- Ensure this gets compiled with -O to avoid extra (and possibly
39 -- improper) memory stores.
41 pragma Optimize (Time);
43 -- Declare the functions that do the conversions between floating-point
44 -- formats. Call the operands IEEE float so they get passed in
47 function Cvt_G_T (X : T) return T;
48 function Cvt_T_G (X : T) return T;
49 function Cvt_T_F (X : T) return S;
51 pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T");
52 pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G");
53 pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F");
55 -- In each of the conversion routines that are done with OTS calls,
56 -- we define variables of the corresponding IEEE type so that they are
57 -- passed and kept in the proper register class.
59 Debug_String_Buffer : String (1 .. 32);
60 -- Buffer used by all Debug_String_x routines for returning result
66 function D_To_G (X : D) return G is
70 Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X),
72 Asm ("cvtdg %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A),
74 Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B),
83 function F_To_G (X : F) return G is
87 Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X),
89 Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A),
98 function F_To_S (X : F) return S is
103 -- Because converting to a wider FP format is a no-op, we say
104 -- A is 64-bit even though we are loading 32 bits into it.
106 Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X),
109 B := S (Cvt_G_T (A));
117 function G_To_D (X : G) return D is
121 Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X),
123 Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A),
125 Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B),
134 function G_To_F (X : G) return F is
139 Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X),
141 Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A),
143 Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B),
152 function G_To_Q (X : G) return Q is
156 Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X),
158 Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A),
167 function G_To_T (X : G) return T is
170 Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X),
180 function F_To_Q (X : F) return Q is
182 return G_To_Q (F_To_G (X));
189 function Q_To_F (X : Q) return F is
193 Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X),
195 Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A),
204 function Q_To_G (X : Q) return G is
208 Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X),
210 Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A),
219 function S_To_F (X : S) return F is
223 A := Cvt_T_F (T (X));
224 Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A),
233 function T_To_D (X : T) return D is
235 return G_To_D (T_To_G (X));
242 function T_To_G (X : T) return G is
247 Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A),
256 function Abs_F (X : F) return F is
260 Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X),
262 Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A),
264 Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B),
273 function Abs_G (X : G) return G is
277 Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
278 Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A),
280 Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B),
289 function Add_F (X, Y : F) return F is
293 Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
294 Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y),
296 Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R),
297 (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)),
299 Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R),
308 function Add_G (X, Y : G) return G is
312 Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
313 Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y),
315 Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R),
316 (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)),
318 Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R),
327 procedure Debug_Output_D (Arg : D) is
329 System.IO.Put (D'Image (Arg));
336 procedure Debug_Output_F (Arg : F) is
338 System.IO.Put (F'Image (Arg));
345 procedure Debug_Output_G (Arg : G) is
347 System.IO.Put (G'Image (Arg));
354 function Debug_String_D (Arg : D) return System.Address is
355 Image_String : constant String := D'Image (Arg) & ASCII.NUL;
356 Image_Size : constant Integer := Image_String'Length;
358 Debug_String_Buffer (1 .. Image_Size) := Image_String;
359 return Debug_String_Buffer (1)'Address;
366 function Debug_String_F (Arg : F) return System.Address is
367 Image_String : constant String := F'Image (Arg) & ASCII.NUL;
368 Image_Size : constant Integer := Image_String'Length;
370 Debug_String_Buffer (1 .. Image_Size) := Image_String;
371 return Debug_String_Buffer (1)'Address;
378 function Debug_String_G (Arg : G) return System.Address is
379 Image_String : constant String := G'Image (Arg) & ASCII.NUL;
380 Image_Size : constant Integer := Image_String'Length;
382 Debug_String_Buffer (1 .. Image_Size) := Image_String;
383 return Debug_String_Buffer (1)'Address;
390 function Div_F (X, Y : F) return F is
394 Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
395 Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y),
397 Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R),
398 (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)),
400 Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R),
409 function Div_G (X, Y : G) return G is
413 Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
414 Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y),
416 Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R),
417 (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)),
419 Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R),
428 function Eq_F (X, Y : F) return Boolean is
431 Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
432 Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y),
434 Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R),
435 (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)),
444 function Eq_G (X, Y : G) return Boolean is
447 Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
448 Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y),
450 Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R),
451 (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)),
460 function Le_F (X, Y : F) return Boolean is
463 Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
464 Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y),
466 Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R),
467 (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)),
476 function Le_G (X, Y : G) return Boolean is
479 Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
480 Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y),
482 Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R),
483 (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)),
492 function Lt_F (X, Y : F) return Boolean is
495 Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
496 Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y),
498 Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R),
499 (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)),
508 function Lt_G (X, Y : G) return Boolean is
511 Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
512 Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y),
514 Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R),
515 (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)),
524 function Mul_F (X, Y : F) return F is
528 Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
529 Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y),
531 Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R),
532 (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)),
534 Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R),
543 function Mul_G (X, Y : G) return G is
547 Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
548 Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y),
550 Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R),
551 (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)),
553 Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R),
562 function Ne_F (X, Y : F) return Boolean is
565 Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
566 Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y),
568 Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R),
569 (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)),
578 function Ne_G (X, Y : G) return Boolean is
581 Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
582 Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y),
584 Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R),
585 (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)),
594 function Neg_F (X : F) return F is
598 Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
599 Asm ("cpysn %1,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A),
601 Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B),
610 function Neg_G (X : G) return G is
614 Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
615 Asm ("cpysn %1,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A),
617 Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B),
626 procedure pd (Arg : D) is
628 System.IO.Put_Line (D'Image (Arg));
635 procedure pf (Arg : F) is
637 System.IO.Put_Line (F'Image (Arg));
644 procedure pg (Arg : G) is
646 System.IO.Put_Line (G'Image (Arg));
653 function Return_D (X : D) return D is
657 -- The return value is already in $f0 so we need to trick the compiler
658 -- into thinking that we're moving X to $f0.
660 Asm ("cvtdg $f0,$f0", Inputs => D'Asm_Input ("g", X), Clobber => "$f0",
662 Asm ("stg $f0,%0", D'Asm_Output ("=m", R), Volatile => True);
670 function Return_F (X : F) return F is
674 -- The return value is already in $f0 so we need to trick the compiler
675 -- into thinking that we're moving X to $f0.
677 Asm ("stf $f0,%0", F'Asm_Output ("=m", R), F'Asm_Input ("g", X),
678 Clobber => "$f0", Volatile => True);
686 function Return_G (X : G) return G is
690 -- The return value is already in $f0 so we need to trick the compiler
691 -- into thinking that we're moving X to $f0.
693 Asm ("stg $f0,%0", G'Asm_Output ("=m", R), G'Asm_Input ("g", X),
694 Clobber => "$f0", Volatile => True);
702 function Sub_F (X, Y : F) return F is
707 Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
708 Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y),
710 Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R),
711 (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)),
713 Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R),
722 function Sub_G (X, Y : G) return G is
726 Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
727 Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y),
729 Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R),
730 (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)),
732 Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R),
741 -- For now, convert to IEEE and do Valid test on result. This is not quite
742 -- accurate, but is good enough in practice.
744 function Valid_D (Arg : D) return Boolean is
745 Val : constant T := G_To_T (D_To_G (Arg));
754 -- For now, convert to IEEE and do Valid test on result. This is not quite
755 -- accurate, but is good enough in practice.
757 function Valid_F (Arg : F) return Boolean is
758 Val : constant S := F_To_S (Arg);
767 -- For now, convert to IEEE and do Valid test on result. This is not quite
768 -- accurate, but is good enough in practice.
770 function Valid_G (Arg : G) return Boolean is
771 Val : constant T := G_To_T (Arg);
776 end System.Vax_Float_Operations;