gcc/ada/5vvaflop.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   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          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.15 $
  10 --                                                                          --
  11 --          Copyright (C) 1997-2000 Free Software Foundation, Inc.          --
  12 --                       (Version for Alpha OpenVMS)                        --
  13 --                                                                          --
  14 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  15 -- terms of the  GNU General Public License as published  by the Free Soft- --
  16 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  17 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  18 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  19 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  20 -- for  more details.  You should have  received  a copy of the GNU General --
  21 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  22 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  23 -- MA 02111-1307, USA.                                                      --
  24 --                                                                          --
  25 -- As a special exception,  if other files  instantiate  generics from this --
  26 -- unit, or you link  this unit with other files  to produce an executable, --
  27 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  28 -- covered  by the  GNU  General  Public  License.  This exception does not --
  29 -- however invalidate  any other reasons why  the executable file  might be --
  30 -- covered by the  GNU Public License.                                      --
  31 --                                                                          --
  32 -- GNAT was originally developed  by the GNAT team at  New York University. --
  33 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  34 --                                                                          --
  35 ------------------------------------------------------------------------------
  36
  37 with System.IO;           use System.IO;
  38 with System.Machine_Code; use System.Machine_Code;
  39
  40 package body System.Vax_Float_Operations is
  41
  42    --  Ensure this gets compiled with -O to avoid extra (and possibly
  43    --  improper) memory stores.
  44
  45    pragma Optimize (Time);
  46
  47    --  Declare the functions that do the conversions between floating-point
  48    --  formats.  Call the operands IEEE float so they get passed in
  49    --  FP registers.
  50
  51    function Cvt_G_T (X : T) return T;
  52    function Cvt_T_G (X : T) return T;
  53    function Cvt_T_F (X : T) return S;
  54
  55    pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T");
  56    pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G");
  57    pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F");
  58
  59    --  In each of the conversion routines that are done with OTS calls,
  60    --  we define variables of the corresponding IEEE type so that they are
  61    --  passed and kept in the proper register class.
  62
  63    ------------
  64    -- D_To_G --
  65    ------------
  66
  67    function D_To_G (X : D) return G is
  68       A, B : T;
  69       C : G;
  70
  71    begin
  72       Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X));
  73       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));
  75       return C;
  76    end D_To_G;
  77
  78    ------------
  79    -- F_To_G --
  80    ------------
  81
  82    function F_To_G (X : F) return G is
  83       A : T;
  84       B : G;
  85
  86    begin
  87       Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
  88       Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
  89       return B;
  90    end F_To_G;
  91
  92    ------------
  93    -- F_To_S --
  94    ------------
  95
  96    function F_To_S (X : F) return S is
  97       A : T;
  98       B : S;
  99
 100    begin
 101       --  Because converting to a wider FP format is a no-op, we say
 102       --  A is 64-bit even though we are loading 32 bits into it.
 103       Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
 104
 105       B := S (Cvt_G_T (A));
 106       return B;
 107    end F_To_S;
 108
 109    ------------
 110    -- G_To_D --
 111    ------------
 112
 113    function G_To_D (X : G) return D is
 114       A, B : T;
 115       C : D;
 116
 117    begin
 118       Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
 119       Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
 120       Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B));
 121       return C;
 122    end G_To_D;
 123
 124    ------------
 125    -- G_To_F --
 126    ------------
 127
 128    function G_To_F (X : G) return F is
 129       A : T;
 130       B : S;
 131       C : F;
 132
 133    begin
 134       Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
 135       Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A));
 136       Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
 137       return C;
 138    end G_To_F;
 139
 140    ------------
 141    -- G_To_Q --
 142    ------------
 143
 144    function G_To_Q (X : G) return Q is
 145       A : T;
 146       B : Q;
 147
 148    begin
 149       Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
 150       Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A));
 151       return B;
 152    end G_To_Q;
 153
 154    ------------
 155    -- G_To_T --
 156    ------------
 157
 158    function G_To_T (X : G) return T is
 159       A, B : T;
 160
 161    begin
 162       Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
 163       B := Cvt_G_T (A);
 164       return B;
 165    end G_To_T;
 166
 167    ------------
 168    -- F_To_Q --
 169    ------------
 170
 171    function F_To_Q (X : F) return Q is
 172    begin
 173       return G_To_Q (F_To_G (X));
 174    end F_To_Q;
 175
 176    ------------
 177    -- Q_To_F --
 178    ------------
 179
 180    function Q_To_F (X : Q) return F is
 181       A : S;
 182       B : F;
 183
 184    begin
 185       Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
 186       Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
 187       return B;
 188    end Q_To_F;
 189
 190    ------------
 191    -- Q_To_G --
 192    ------------
 193
 194    function Q_To_G (X : Q) return G is
 195       A : T;
 196       B : G;
 197
 198    begin
 199       Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
 200       Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
 201       return B;
 202    end Q_To_G;
 203
 204    ------------
 205    -- S_To_F --
 206    ------------
 207
 208    function S_To_F (X : S) return F is
 209       A : S;
 210       B : F;
 211
 212    begin
 213       A := Cvt_T_F (T (X));
 214       Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
 215       return B;
 216    end S_To_F;
 217
 218    ------------
 219    -- T_To_D --
 220    ------------
 221
 222    function T_To_D (X : T) return D is
 223    begin
 224       return G_To_D (T_To_G (X));
 225    end T_To_D;
 226
 227    ------------
 228    -- T_To_G --
 229    ------------
 230
 231    function T_To_G (X : T) return G is
 232       A : T;
 233       B : G;
 234
 235    begin
 236       A := Cvt_T_G (X);
 237       Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
 238       return B;
 239    end T_To_G;
 240
 241    -----------
 242    -- Abs_F --
 243    -----------
 244
 245    function Abs_F (X : F) return F is
 246       A, B : S;
 247       C : F;
 248
 249    begin
 250       Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
 251       Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
 252       Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
 253       return C;
 254    end Abs_F;
 255
 256    -----------
 257    -- Abs_G --
 258    -----------
 259
 260    function Abs_G (X : G) return G is
 261       A, B : T;
 262       C : G;
 263
 264    begin
 265       Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
 266       Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
 267       Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
 268       return C;
 269    end Abs_G;
 270
 271    -----------
 272    -- Add_F --
 273    -----------
 274
 275    function Add_F (X, Y : F) return F is
 276       X1, Y1, R : S;
 277       R1 : F;
 278
 279    begin
 280       Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
 281       Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
 282       Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R),
 283            (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
 284       Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
 285       return R1;
 286    end Add_F;
 287
 288    -----------
 289    -- Add_G --
 290    -----------
 291
 292    function Add_G (X, Y : G) return G is
 293       X1, Y1, R : T;
 294       R1 : G;
 295
 296    begin
 297       Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
 298       Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
 299       Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R),
 300            (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
 301       Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
 302       return R1;
 303    end Add_G;
 304
 305    --------------------
 306    -- Debug_Output_D --
 307    --------------------
 308
 309    procedure Debug_Output_D (Arg : D) is
 310    begin
 311       Put (D'Image (Arg));
 312    end Debug_Output_D;
 313
 314    --------------------
 315    -- Debug_Output_F --
 316    --------------------
 317
 318    procedure Debug_Output_F (Arg : F) is
 319    begin
 320       Put (F'Image (Arg));
 321    end Debug_Output_F;
 322
 323    --------------------
 324    -- Debug_Output_G --
 325    --------------------
 326
 327    procedure Debug_Output_G (Arg : G) is
 328    begin
 329       Put (G'Image (Arg));
 330    end Debug_Output_G;
 331
 332    --------------------
 333    -- Debug_String_D --
 334    --------------------
 335
 336    Debug_String_Buffer : String (1 .. 32);
 337    --  Buffer used by all Debug_String_x routines for returning result
 338
 339    function Debug_String_D (Arg : D) return System.Address is
 340       Image_String : constant String := D'Image (Arg) & ASCII.NUL;
 341       Image_Size   : constant Integer := Image_String'Length;
 342
 343    begin
 344       Debug_String_Buffer (1 .. Image_Size) := Image_String;
 345       return Debug_String_Buffer (1)'Address;
 346    end Debug_String_D;
 347
 348    --------------------
 349    -- Debug_String_F --
 350    --------------------
 351
 352    function Debug_String_F (Arg : F) return System.Address is
 353       Image_String : constant String := F'Image (Arg) & ASCII.NUL;
 354       Image_Size   : constant Integer := Image_String'Length;
 355
 356    begin
 357       Debug_String_Buffer (1 .. Image_Size) := Image_String;
 358       return Debug_String_Buffer (1)'Address;
 359    end Debug_String_F;
 360
 361    --------------------
 362    -- Debug_String_G --
 363    --------------------
 364
 365    function Debug_String_G (Arg : G) return System.Address is
 366       Image_String : constant String := G'Image (Arg) & ASCII.NUL;
 367       Image_Size   : constant Integer := Image_String'Length;
 368
 369    begin
 370       Debug_String_Buffer (1 .. Image_Size) := Image_String;
 371       return Debug_String_Buffer (1)'Address;
 372    end Debug_String_G;
 373
 374    -----------
 375    -- Div_F --
 376    -----------
 377
 378    function Div_F (X, Y : F) return F is
 379       X1, Y1, R : S;
 380
 381       R1 : F;
 382    begin
 383       Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
 384       Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
 385       Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R),
 386            (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
 387       Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
 388       return R1;
 389    end Div_F;
 390
 391    -----------
 392    -- Div_G --
 393    -----------
 394
 395    function Div_G (X, Y : G) return G is
 396       X1, Y1, R : T;
 397       R1 : G;
 398
 399    begin
 400       Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
 401       Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
 402       Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R),
 403            (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
 404       Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
 405       return R1;
 406    end Div_G;
 407
 408    ----------
 409    -- Eq_F --
 410    ----------
 411
 412    function Eq_F (X, Y : F) return Boolean is
 413       X1, Y1, R : S;
 414
 415    begin
 416       Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
 417       Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
 418       Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R),
 419            (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
 420       return R /= 0.0;
 421    end Eq_F;
 422
 423    ----------
 424    -- Eq_G --
 425    ----------
 426
 427    function Eq_G (X, Y : G) return Boolean is
 428       X1, Y1, R : T;
 429
 430    begin
 431       Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
 432       Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
 433       Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R),
 434            (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
 435       return R /= 0.0;
 436    end Eq_G;
 437
 438    ----------
 439    -- Le_F --
 440    ----------
 441
 442    function Le_F (X, Y : F) return Boolean is
 443       X1, Y1, R : S;
 444
 445    begin
 446       Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
 447       Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
 448       Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R),
 449            (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
 450       return R /= 0.0;
 451    end Le_F;
 452
 453    ----------
 454    -- Le_G --
 455    ----------
 456
 457    function Le_G (X, Y : G) return Boolean is
 458       X1, Y1, R : T;
 459
 460    begin
 461       Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
 462       Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
 463       Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R),
 464            (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
 465       return R /= 0.0;
 466    end Le_G;
 467
 468    ----------
 469    -- Lt_F --
 470    ----------
 471
 472    function Lt_F (X, Y : F) return Boolean is
 473       X1, Y1, R : S;
 474
 475    begin
 476       Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
 477       Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
 478       Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R),
 479            (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
 480       return R /= 0.0;
 481    end Lt_F;
 482
 483    ----------
 484    -- Lt_G --
 485    ----------
 486
 487    function Lt_G (X, Y : G) return Boolean is
 488       X1, Y1, R : T;
 489
 490    begin
 491       Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
 492       Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
 493       Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R),
 494            (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
 495       return R /= 0.0;
 496    end Lt_G;
 497
 498    -----------
 499    -- Mul_F --
 500    -----------
 501
 502    function Mul_F (X, Y : F) return F is
 503       X1, Y1, R : S;
 504       R1 : F;
 505
 506    begin
 507       Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
 508       Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
 509       Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R),
 510            (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
 511       Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
 512       return R1;
 513    end Mul_F;
 514
 515    -----------
 516    -- Mul_G --
 517    -----------
 518
 519    function Mul_G (X, Y : G) return G is
 520       X1, Y1, R : T;
 521       R1 : G;
 522
 523    begin
 524       Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
 525       Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
 526       Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R),
 527            (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
 528       Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
 529       return R1;
 530    end Mul_G;
 531
 532    -----------
 533    -- Neg_F --
 534    -----------
 535
 536    function Neg_F (X : F) return F is
 537       A, B : S;
 538       C : F;
 539
 540    begin
 541       Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
 542       Asm ("cpysn %1,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
 543       Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
 544       return C;
 545    end Neg_F;
 546
 547    -----------
 548    -- Neg_G --
 549    -----------
 550
 551    function Neg_G (X : G) return G is
 552       A, B : T;
 553       C : G;
 554
 555    begin
 556       Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
 557       Asm ("cpysn %1,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
 558       Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
 559       return C;
 560    end Neg_G;
 561
 562    --------
 563    -- pd --
 564    --------
 565
 566    procedure pd (Arg : D) is
 567    begin
 568       Put_Line (D'Image (Arg));
 569    end pd;
 570
 571    --------
 572    -- pf --
 573    --------
 574
 575    procedure pf (Arg : F) is
 576    begin
 577       Put_Line (F'Image (Arg));
 578    end pf;
 579
 580    --------
 581    -- pg --
 582    --------
 583
 584    procedure pg (Arg : G) is
 585    begin
 586       Put_Line (G'Image (Arg));
 587    end pg;
 588
 589    -----------
 590    -- Sub_F --
 591    -----------
 592
 593    function Sub_F (X, Y : F) return F is
 594       X1, Y1, R : S;
 595       R1 : F;
 596
 597    begin
 598       Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
 599       Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
 600       Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R),
 601            (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
 602       Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
 603       return R1;
 604    end Sub_F;
 605
 606    -----------
 607    -- Sub_G --
 608    -----------
 609
 610    function Sub_G (X, Y : G) return G is
 611       X1, Y1, R : T;
 612       R1 : G;
 613
 614    begin
 615       Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
 616       Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
 617       Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R),
 618            (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
 619       Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
 620       return R1;
 621    end Sub_G;
 622
 623 end System.Vax_Float_Operations;