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 35with System.IO; use System.IO; 36with System.Machine_Code; use System.Machine_Code; 37 38package 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 621end System.Vax_Float_Operations; 622