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