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