1-- Mcode back-end for ortho - Expressions and control handling. 2-- Copyright (C) 2006 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16with Ada.Text_IO; 17with Ada.Unchecked_Deallocation; 18with Tables; 19with Ortho_Code.Types; use Ortho_Code.Types; 20with Ortho_Code.Consts; use Ortho_Code.Consts; 21with Ortho_Code.Decls; use Ortho_Code.Decls; 22with Ortho_Code.Debug; use Ortho_Code.Debug; 23with Ortho_Code.Abi; use Ortho_Code.Abi; 24with Ortho_Code.Disps; 25with Ortho_Code.Opts; 26with Ortho_Code.Flags; 27 28package body Ortho_Code.Exprs is 29 30 type Enode_Pad is mod 256; 31 32 type Enode_Common is record 33 Kind : OE_Kind; -- about 1 byte (6 bits) 34 Reg : O_Reg; -- 1 byte 35 Mode : Mode_Type; -- 4 bits 36 Ref : Boolean; 37 Flag1 : Boolean; 38 Flag2 : Boolean; 39 Flag3 : Boolean; 40 Pad : Enode_Pad; 41 Arg1 : O_Enode; 42 Arg2 : O_Enode; 43 Info : Int32; 44 end record; 45 pragma Pack (Enode_Common); 46 for Enode_Common'Size use 4*32; 47 for Enode_Common'Alignment use 4; 48 49 package Enodes is new Tables 50 (Table_Component_Type => Enode_Common, 51 Table_Index_Type => O_Enode, 52 Table_Low_Bound => 2, 53 Table_Initial => 1024); 54 55 function Get_Expr_Kind (Enode : O_Enode) return OE_Kind is 56 begin 57 return Enodes.Table (Enode).Kind; 58 end Get_Expr_Kind; 59 60 function Get_Expr_Mode (Enode : O_Enode) return Mode_Type is 61 begin 62 return Enodes.Table (Enode).Mode; 63 end Get_Expr_Mode; 64 65 function Get_Enode_Type (Enode : O_Enode) return O_Tnode is 66 begin 67 return O_Tnode (Enodes.Table (Enode).Info); 68 end Get_Enode_Type; 69 70 function Get_Expr_Reg (Enode : O_Enode) return O_Reg is 71 begin 72 return Enodes.Table (Enode).Reg; 73 end Get_Expr_Reg; 74 75 procedure Set_Expr_Reg (Enode : O_Enode; Reg : O_Reg) is 76 begin 77 Enodes.Table (Enode).Reg := Reg; 78 end Set_Expr_Reg; 79 80 function Get_Expr_Operand (Enode : O_Enode) return O_Enode is 81 begin 82 return Enodes.Table (Enode).Arg1; 83 end Get_Expr_Operand; 84 85 procedure Set_Expr_Operand (Enode : O_Enode; Val : O_Enode) is 86 begin 87 Enodes.Table (Enode).Arg1 := Val; 88 end Set_Expr_Operand; 89 90 function Get_Expr_Left (Enode : O_Enode) return O_Enode is 91 begin 92 return Enodes.Table (Enode).Arg1; 93 end Get_Expr_Left; 94 95 function Get_Expr_Right (Enode : O_Enode) return O_Enode is 96 begin 97 return Enodes.Table (Enode).Arg2; 98 end Get_Expr_Right; 99 100 procedure Set_Expr_Left (Enode : O_Enode; Val : O_Enode) is 101 begin 102 Enodes.Table (Enode).Arg1 := Val; 103 end Set_Expr_Left; 104 105 procedure Set_Expr_Right (Enode : O_Enode; Val : O_Enode) is 106 begin 107 Enodes.Table (Enode).Arg2 := Val; 108 end Set_Expr_Right; 109 110 function Get_Expr_Low (Cst : O_Enode) return Uns32 is 111 begin 112 return To_Uns32 (Int32 (Enodes.Table (Cst).Arg1)); 113 end Get_Expr_Low; 114 115 function Get_Expr_High (Cst : O_Enode) return Uns32 is 116 begin 117 return To_Uns32 (Int32 (Enodes.Table (Cst).Arg2)); 118 end Get_Expr_High; 119 120 function Get_Assign_Target (Enode : O_Enode) return O_Enode is 121 begin 122 return Enodes.Table (Enode).Arg2; 123 end Get_Assign_Target; 124 125 procedure Set_Assign_Target (Enode : O_Enode; Targ : O_Enode) is 126 begin 127 Enodes.Table (Enode).Arg2 := Targ; 128 end Set_Assign_Target; 129 130 function Get_Expr_Lit (Lit : O_Enode) return O_Cnode is 131 begin 132 return O_Cnode (Enodes.Table (Lit).Arg1); 133 end Get_Expr_Lit; 134 135 function Get_Conv_Type (Enode : O_Enode) return O_Tnode is 136 begin 137 return O_Tnode (Enodes.Table (Enode).Arg2); 138 end Get_Conv_Type; 139 140 -- Leave node corresponding to the entry. 141 function Get_Entry_Leave (Enode : O_Enode) return O_Enode is 142 begin 143 return Enodes.Table (Enode).Arg1; 144 end Get_Entry_Leave; 145 146 procedure Set_Entry_Leave (Enode : O_Enode; Leave : O_Enode) is 147 begin 148 Enodes.Table (Enode).Arg1 := Leave; 149 end Set_Entry_Leave; 150 151 function Get_Jump_Label (Enode : O_Enode) return O_Enode is 152 begin 153 return Enodes.Table (Enode).Arg2; 154 end Get_Jump_Label; 155 156 procedure Set_Jump_Label (Enode : O_Enode; Label : O_Enode) is 157 begin 158 Enodes.Table (Enode).Arg2 := Label; 159 end Set_Jump_Label; 160 161 function Get_Addr_Object (Enode : O_Enode) return O_Lnode is 162 begin 163 return O_Lnode (Enodes.Table (Enode).Arg1); 164 end Get_Addr_Object; 165 166 function Get_Addr_Decl (Enode : O_Enode) return O_Dnode is 167 begin 168 return O_Dnode (Enodes.Table (Enode).Arg1); 169 end Get_Addr_Decl; 170 171 function Get_Addrl_Frame (Enode : O_Enode) return O_Enode is 172 begin 173 return Enodes.Table (Enode).Arg2; 174 end Get_Addrl_Frame; 175 176 procedure Set_Addrl_Frame (Enode : O_Enode; Frame : O_Enode) is 177 begin 178 Enodes.Table (Enode).Arg2 := Frame; 179 end Set_Addrl_Frame; 180 181 function Get_Call_Subprg (Enode : O_Enode) return O_Dnode is 182 begin 183 return O_Dnode (Enodes.Table (Enode).Arg1); 184 end Get_Call_Subprg; 185 186 function Get_Stack_Adjust (Enode : O_Enode) return Int32 is 187 begin 188 return Int32 (Enodes.Table (Enode).Arg1); 189 end Get_Stack_Adjust; 190 191 procedure Set_Stack_Adjust (Enode : O_Enode; Off : Int32) is 192 begin 193 Enodes.Table (Enode).Arg1 := O_Enode (Off); 194 end Set_Stack_Adjust; 195 196 function Get_Arg_Link (Enode : O_Enode) return O_Enode is 197 begin 198 return Enodes.Table (Enode).Arg2; 199 end Get_Arg_Link; 200 201 function Get_Block_Decls (Blk : O_Enode) return O_Dnode is 202 begin 203 return O_Dnode (Enodes.Table (Blk).Arg2); 204 end Get_Block_Decls; 205 206 function Get_Block_Parent (Blk : O_Enode) return O_Enode is 207 begin 208 return Enodes.Table (Blk).Arg1; 209 end Get_Block_Parent; 210 211 function Get_Block_Has_Alloca (Blk : O_Enode) return Boolean is 212 begin 213 return Enodes.Table (Blk).Flag1; 214 end Get_Block_Has_Alloca; 215 216 procedure Set_Block_Has_Alloca (Blk : O_Enode; Flag : Boolean) is 217 begin 218 Enodes.Table (Blk).Flag1 := Flag; 219 end Set_Block_Has_Alloca; 220 221 function Get_End_Beg (Blk : O_Enode) return O_Enode is 222 begin 223 return Enodes.Table (Blk).Arg1; 224 end Get_End_Beg; 225 226 function Get_Label_Info (Label : O_Enode) return Int32 is 227 begin 228 return Int32 (Enodes.Table (Label).Arg2); 229 end Get_Label_Info; 230 231 procedure Set_Label_Info (Label : O_Enode; Info : Int32) is 232 begin 233 Enodes.Table (Label).Arg2 := O_Enode (Info); 234 end Set_Label_Info; 235 236 function Get_Label_Block (Label : O_Enode) return O_Enode is 237 begin 238 return Enodes.Table (Label).Arg1; 239 end Get_Label_Block; 240 241 function Get_Spill_Info (Spill : O_Enode) return Int32 is 242 begin 243 return Int32 (Enodes.Table (Spill).Arg2); 244 end Get_Spill_Info; 245 246 procedure Set_Spill_Info (Spill : O_Enode; Info : Int32) is 247 begin 248 Enodes.Table (Spill).Arg2 := O_Enode (Info); 249 end Set_Spill_Info; 250 251 -- Get the statement link. 252 function Get_Stmt_Link (Stmt : O_Enode) return O_Enode is 253 begin 254 return O_Enode (Enodes.Table (Stmt).Info); 255 end Get_Stmt_Link; 256 257 procedure Set_Stmt_Link (Stmt : O_Enode; Next : O_Enode) is 258 begin 259 Enodes.Table (Stmt).Info := Int32 (Next); 260 end Set_Stmt_Link; 261 262 function Get_BB_Next (Stmt : O_Enode) return O_Enode is 263 begin 264 return Enodes.Table (Stmt).Arg1; 265 end Get_BB_Next; 266 pragma Unreferenced (Get_BB_Next); 267 268 procedure Set_BB_Next (Stmt : O_Enode; Next : O_Enode) is 269 begin 270 Enodes.Table (Stmt).Arg1 := Next; 271 end Set_BB_Next; 272 273 function Get_BB_Number (Stmt : O_Enode) return Int32 is 274 begin 275 return Int32 (Enodes.Table (Stmt).Arg2); 276 end Get_BB_Number; 277 278 function Get_Loop_Level (Stmt : O_Enode) return Int32 is 279 begin 280 return Int32 (Enodes.Table (Stmt).Arg1); 281 end Get_Loop_Level; 282 283 procedure Set_Loop_Level (Stmt : O_Enode; Level : Int32) is 284 begin 285 Enodes.Table (Stmt).Arg1 := O_Enode (Level); 286 end Set_Loop_Level; 287 288 procedure Set_Case_Branch (C : O_Enode; Branch : O_Enode) is 289 begin 290 Enodes.Table (C).Arg2 := Branch; 291 end Set_Case_Branch; 292 293 procedure Set_Case_Branch_Choice (Branch : O_Enode; Choice : O_Enode) is 294 begin 295 Enodes.Table (Branch).Arg1 := Choice; 296 end Set_Case_Branch_Choice; 297 298 function Get_Case_Branch_Choice (Branch : O_Enode) return O_Enode is 299 begin 300 return Enodes.Table (Branch).Arg1; 301 end Get_Case_Branch_Choice; 302 303 procedure Set_Case_Choice_Link (Choice : O_Enode; N_Choice : O_Enode) is 304 begin 305 Enodes.Table (Choice).Info := Int32 (N_Choice); 306 end Set_Case_Choice_Link; 307 308 function Get_Case_Choice_Link (Choice : O_Enode) return O_Enode is 309 begin 310 return O_Enode (Enodes.Table (Choice).Info); 311 end Get_Case_Choice_Link; 312 313 function Get_Ref_Field (Ref : O_Enode) return O_Fnode is 314 begin 315 return O_Fnode (Enodes.Table (Ref).Arg2); 316 end Get_Ref_Field; 317 318 function Get_Ref_Index (Ref : O_Enode) return O_Enode is 319 begin 320 return Enodes.Table (Ref).Arg2; 321 end Get_Ref_Index; 322 323 function Get_Expr_Line_Number (Stmt : O_Enode) return Int32 is 324 begin 325 return Int32 (Enodes.Table (Stmt).Arg1); 326 end Get_Expr_Line_Number; 327 328 function Get_Intrinsic_Operation (Stmt : O_Enode) return Int32 is 329 begin 330 return Int32 (Enodes.Table (Stmt).Arg1); 331 end Get_Intrinsic_Operation; 332 333 Last_Stmt : O_Enode := O_Enode_Null; 334 335 procedure Link_Stmt (Stmt : O_Enode) is 336 begin 337 -- Expect a real statement. 338 pragma Assert (Stmt /= O_Enode_Null); 339 340 -- Must be withint a subprogram. 341 pragma Assert (Last_Stmt /= O_Enode_Null); 342 343 Set_Stmt_Link (Last_Stmt, Stmt); 344 Last_Stmt := Stmt; 345 end Link_Stmt; 346 347 function New_Enode (Kind : OE_Kind; 348 Rtype : O_Tnode; 349 Arg1 : O_Enode; 350 Arg2 : O_Enode) return O_Enode 351 is 352 Mode : Mode_Type; 353 begin 354 Mode := Get_Type_Mode (Rtype); 355 Enodes.Append (Enode_Common'(Kind => Kind, 356 Reg => 0, 357 Mode => Mode, 358 Ref => False, 359 Flag1 => False, 360 Flag2 => False, 361 Flag3 => False, 362 Pad => 0, 363 Arg1 => Arg1, 364 Arg2 => Arg2, 365 Info => Int32 (Rtype))); 366 return Enodes.Last; 367 end New_Enode; 368 369 function New_Enode (Kind : OE_Kind; 370 Mode : Mode_Type; 371 Rtype : O_Tnode; 372 Arg1 : O_Enode; 373 Arg2 : O_Enode) return O_Enode 374 is 375 begin 376 Enodes.Append (Enode_Common'(Kind => Kind, 377 Reg => 0, 378 Mode => Mode, 379 Ref => False, 380 Flag1 => False, 381 Flag2 => False, 382 Flag3 => False, 383 Pad => 0, 384 Arg1 => Arg1, 385 Arg2 => Arg2, 386 Info => Int32 (Rtype))); 387 return Enodes.Last; 388 end New_Enode; 389 390 procedure New_Enode_Stmt (Kind : OE_Kind; Arg1 : O_Enode; Arg2 : O_Enode) 391 is 392 begin 393 Enodes.Append (Enode_Common'(Kind => Kind, 394 Reg => 0, 395 Mode => Mode_Nil, 396 Ref => False, 397 Flag1 => False, 398 Flag2 => False, 399 Flag3 => False, 400 Pad => 0, 401 Arg1 => Arg1, 402 Arg2 => Arg2, 403 Info => 0)); 404 Link_Stmt (Enodes.Last); 405 end New_Enode_Stmt; 406 407 procedure New_Enode_Stmt 408 (Kind : OE_Kind; Mode : Mode_Type; Arg1 : O_Enode; Arg2 : O_Enode) 409 is 410 begin 411 Enodes.Append (Enode_Common'(Kind => Kind, 412 Reg => 0, 413 Mode => Mode, 414 Ref => False, 415 Flag1 => False, 416 Flag2 => False, 417 Flag3 => False, 418 Pad => 0, 419 Arg1 => Arg1, 420 Arg2 => Arg2, 421 Info => 0)); 422 Link_Stmt (Enodes.Last); 423 end New_Enode_Stmt; 424 425 Bb_Num : Int32 := 0; 426 Last_Bb : O_Enode := O_Enode_Null; 427 428 procedure Create_BB is 429 begin 430 New_Enode_Stmt (OE_BB, Mode_Nil, O_Enode_Null, O_Enode (Bb_Num)); 431 if Last_Bb /= O_Enode_Null then 432 Set_BB_Next (Last_Bb, Enodes.Last); 433 end if; 434 Last_Bb := Enodes.Last; 435 Bb_Num := Bb_Num + 1; 436 end Create_BB; 437 438 procedure Start_BB is 439 begin 440 if Flags.Flag_Opt_BB then 441 Create_BB; 442 end if; 443 end Start_BB; 444 pragma Inline (Start_BB); 445 446 procedure Check_Ref (E : O_Enode) is 447 begin 448 if Enodes.Table (E).Ref then 449 raise Syntax_Error; 450 end if; 451 Enodes.Table (E).Ref := True; 452 end Check_Ref; 453 454 procedure Check_Ref (E : O_Lnode) is 455 begin 456 Check_Ref (O_Enode (E)); 457 end Check_Ref; 458 459 procedure Check_Value_Type (Val : O_Enode; Vtype : O_Tnode) is 460 begin 461 if Get_Enode_Type (Val) /= Vtype then 462 raise Syntax_Error; 463 end if; 464 end Check_Value_Type; 465 466 function New_Const_U32 (Val : Uns32; Vtype : O_Tnode) return O_Enode 467 is 468 begin 469 return New_Enode (OE_Const, Vtype, 470 O_Enode (To_Int32 (Val)), O_Enode_Null); 471 end New_Const_U32; 472 473 Last_Decl : O_Dnode := 2; 474 Cur_Block : O_Enode := O_Enode_Null; 475 476 procedure Start_Declare_Stmt 477 is 478 Res : O_Enode; 479 begin 480 New_Enode_Stmt (OE_Beg, Cur_Block, O_Enode_Null); 481 Res := Enodes.Last; 482 Enodes.Table (Res).Arg2 := O_Enode 483 (Ortho_Code.Decls.Start_Declare_Stmt); 484 Cur_Block := Res; 485 end Start_Declare_Stmt; 486 487 function New_Stack (Rtype : O_Tnode) return O_Enode is 488 begin 489 return New_Enode (OE_Get_Stack, Rtype, O_Enode_Null, O_Enode_Null); 490 end New_Stack; 491 492 procedure New_Stack_Restore (Blk : O_Enode) 493 is 494 Save_Asgn : O_Enode; 495 Save_Var : O_Dnode; 496 begin 497 Save_Asgn := Get_Stmt_Link (Blk); 498 Save_Var := Get_Addr_Decl (Get_Assign_Target (Save_Asgn)); 499 New_Enode_Stmt (OE_Set_Stack, New_Value (New_Obj (Save_Var)), 500 O_Enode_Null); 501 end New_Stack_Restore; 502 503 procedure Finish_Declare_Stmt 504 is 505 Parent : O_Dnode; 506 begin 507 if Get_Block_Has_Alloca (Cur_Block) then 508 New_Stack_Restore (Cur_Block); 509 end if; 510 New_Enode_Stmt (OE_End, Cur_Block, O_Enode_Null); 511 Cur_Block := Get_Block_Parent (Cur_Block); 512 if Cur_Block = O_Enode_Null then 513 Parent := O_Dnode_Null; 514 else 515 Parent := Get_Block_Decls (Cur_Block); 516 end if; 517 Ortho_Code.Decls.Finish_Declare_Stmt (Parent); 518 end Finish_Declare_Stmt; 519 520 function New_Label return O_Enode is 521 begin 522 return New_Enode (OE_Label, Mode_Nil, O_Tnode_Null, 523 Cur_Block, O_Enode_Null); 524 end New_Label; 525 526 procedure Start_Subprogram_Body (Func : O_Dnode) 527 is 528 Start : O_Enode; 529 D_Body : O_Dnode; 530 Data : Subprogram_Data_Acc; 531 begin 532 if Cur_Subprg = null then 533 Abi.Start_Body (Func); 534 end if; 535 536 Start := New_Enode (OE_Entry, Mode_Nil, O_Tnode_Null, 537 Last_Stmt, O_Enode_Null); 538 D_Body := Decls.Start_Subprogram_Body (Func, Start); 539 540 -- Create the corresponding decl. 541 Enodes.Table (Start).Arg2 := O_Enode (D_Body); 542 543 -- Create the data record. 544 Data := new Subprogram_Data'(Parent => Cur_Subprg, 545 First_Child => null, 546 Last_Child => null, 547 Brother => null, 548 Depth => Get_Decl_Depth (Func), 549 D_Decl => Func, 550 E_Entry => Start, 551 D_Body => D_Body, 552 Exit_Label => O_Enode_Null, 553 Last_Stmt => O_Enode_Null, 554 Stack_Max => 0, 555 Target => (others => <>)); 556 557 if not Flag_Debug_Hli then 558 Data.Exit_Label := New_Label; 559 end if; 560 561 -- Link the record. 562 if Cur_Subprg = null then 563 -- A top-level subprogram. 564 if First_Subprg = null then 565 First_Subprg := Data; 566 else 567 Last_Subprg.Brother := Data; 568 end if; 569 Last_Subprg := Data; 570 else 571 -- A nested subprogram. 572 if Cur_Subprg.First_Child = null then 573 Cur_Subprg.First_Child := Data; 574 else 575 Cur_Subprg.Last_Child.Brother := Data; 576 end if; 577 Cur_Subprg.Last_Child := Data; 578 579 -- Also save last_stmt. 580 Cur_Subprg.Last_Stmt := Last_Stmt; 581 end if; 582 583 Cur_Subprg := Data; 584 Last_Stmt := Start; 585 586 Start_Declare_Stmt; 587 588 -- Create a basic block for the beginning of the subprogram. 589 Start_BB; 590 591 -- Disp declarations. 592 if Cur_Subprg.Parent = null then 593 if Ortho_Code.Debug.Flag_Debug_Code then 594 while Last_Decl <= D_Body loop 595 case Get_Decl_Kind (Last_Decl) is 596 when OD_Block => 597 -- Skip blocks. 598 Disp_Decl (1, Last_Decl); 599 Last_Decl := Get_Block_Last (Last_Decl) + 1; 600 when others => 601 Disp_Decl (1, Last_Decl); 602 Last_Decl := Last_Decl + 1; 603 end case; 604 end loop; 605 end if; 606 end if; 607 end Start_Subprogram_Body; 608 609 procedure Finish_Subprogram_Body 610 is 611 Parent : Subprogram_Data_Acc; 612 begin 613 Finish_Declare_Stmt; 614 615 -- Create a new basic block for the epilog. 616 Start_BB; 617 618 if not Flag_Debug_Hli then 619 Link_Stmt (Cur_Subprg.Exit_Label); 620 end if; 621 622 New_Enode_Stmt (OE_Leave, O_Enode_Null, O_Enode_Null); 623 624 -- Save last statement. 625 Cur_Subprg.Last_Stmt := Enodes.Last; 626 -- Set Leave of Entry. 627 Set_Entry_Leave (Cur_Subprg.E_Entry, Enodes.Last); 628 629 Decls.Finish_Subprogram_Body; 630 631 Parent := Cur_Subprg.Parent; 632 633 if Flags.Flag_Optimize then 634 Opts.Optimize_Subprg (Cur_Subprg); 635 end if; 636 637 if Parent = null then 638 -- This is a top-level subprogram. 639 if Ortho_Code.Debug.Flag_Disp_Code then 640 Disps.Disp_Subprg (Cur_Subprg); 641 end if; 642 if Ortho_Code.Debug.Flag_Dump_Code then 643 Disp_Subprg_Body (1, Cur_Subprg.E_Entry); 644 end if; 645 if not Ortho_Code.Debug.Flag_Debug_Dump then 646 Abi.Finish_Body; 647 end if; 648 end if; 649 650 -- Restore Cur_Subprg. 651 Cur_Subprg := Parent; 652 653 -- Restore Last_Stmt. 654 if Cur_Subprg = null then 655 Last_Stmt := O_Enode_Null; 656 else 657 Last_Stmt := Cur_Subprg.Last_Stmt; 658 end if; 659 end Finish_Subprogram_Body; 660 661 function Get_Inner_Alloca (Label : O_Enode) return O_Enode 662 is 663 Res : O_Enode := O_Enode_Null; 664 Blk : O_Enode; 665 Last_Blk : constant O_Enode := Get_Label_Block (Label); 666 begin 667 Blk := Cur_Block; 668 while Blk /= Last_Blk loop 669 if Get_Block_Has_Alloca (Blk) then 670 Res := Blk; 671 end if; 672 Blk := Get_Block_Parent (Blk); 673 end loop; 674 return Res; 675 end Get_Inner_Alloca; 676 677 procedure Emit_Jmp (Code : OE_Kind; Expr : O_Enode; Label : O_Enode) 678 is 679 begin 680 -- Discard jump after jump. 681 if Code /= OE_Jump or else Get_Expr_Kind (Last_Stmt) /= OE_Jump then 682 New_Enode_Stmt (Code, Expr, Label); 683 end if; 684 end Emit_Jmp; 685 686 687 -- If there is stack allocated memory to be freed, free it. 688 -- Then jump to LABEL. 689 procedure New_Allocb_Jump (Label : O_Enode) 690 is 691 Inner_Alloca : O_Enode; 692 begin 693 Inner_Alloca := Get_Inner_Alloca (Label); 694 if Inner_Alloca /= O_Enode_Null then 695 New_Stack_Restore (Inner_Alloca); 696 end if; 697 Emit_Jmp (OE_Jump, O_Enode_Null, Label); 698 end New_Allocb_Jump; 699 700 function New_Lit (Lit : O_Cnode) return O_Enode 701 is 702 L_Type : constant O_Tnode := Get_Const_Type (Lit); 703 begin 704 if Flag_Debug_Hli then 705 return New_Enode (OE_Lit, L_Type, O_Enode (Lit), O_Enode_Null); 706 else 707 case Get_Const_Kind (Lit) is 708 when OC_Signed 709 | OC_Unsigned 710 | OC_Float 711 | OC_Null 712 | OC_Lit => 713 declare 714 H, L : Uns32; 715 begin 716 Get_Const_Bytes (Lit, H, L); 717 return New_Enode 718 (OE_Const, L_Type, 719 O_Enode (To_Int32 (L)), O_Enode (To_Int32 (H))); 720 end; 721 when OC_Address => 722 raise Syntax_Error; 723 when OC_Subprg_Address => 724 return New_Enode (OE_Addrd, L_Type, 725 O_Enode (Get_Const_Decl (Lit)), O_Enode_Null); 726 when OC_Array 727 | OC_Record 728 | OC_Record_Sizeof 729 | OC_Union 730 | OC_Sizeof 731 | OC_Alignof 732 | OC_Zero => 733 raise Syntax_Error; 734 end case; 735 end if; 736 end New_Lit; 737 738 function Is_Expr_S32 (Cst : O_Enode) return Boolean is 739 begin 740 pragma Assert (Get_Expr_Kind (Cst) = OE_Const); 741 return Shift_Right_Arithmetic (Get_Expr_Low (Cst), 32) 742 = Get_Expr_High (Cst); 743 end Is_Expr_S32; 744 745 function Get_Static_Chain (Depth : O_Depth) return O_Enode 746 is 747 Cur_Depth : O_Depth := Cur_Subprg.Depth; 748 Subprg : Subprogram_Data_Acc; 749 Res : O_Enode; 750 begin 751 if Depth = Cur_Depth then 752 return New_Enode (OE_Get_Frame, Abi.Mode_Ptr, O_Tnode_Ptr, 753 O_Enode_Null, O_Enode_Null); 754 else 755 Subprg := Cur_Subprg; 756 Res := O_Enode_Null; 757 loop 758 -- The static chain is the first interface of the subprogram. 759 Res := New_Enode (OE_Addrl, Abi.Mode_Ptr, O_Tnode_Ptr, 760 O_Enode (Get_Subprg_Interfaces (Subprg.D_Decl)), 761 Res); 762 Res := New_Enode (OE_Indir, O_Tnode_Ptr, Res, O_Enode_Null); 763 Cur_Depth := Cur_Depth - 1; 764 if Cur_Depth = Depth then 765 return Res; 766 end if; 767 Subprg := Subprg.Parent; 768 end loop; 769 end if; 770 end Get_Static_Chain; 771 772 function New_Obj (Obj : O_Dnode) return O_Lnode 773 is 774 O_Type : O_Tnode; 775 Kind : OE_Kind; 776 Chain : O_Enode; 777 Depth : O_Depth; 778 begin 779 O_Type := Get_Decl_Type (Obj); 780 case Get_Decl_Kind (Obj) is 781 when OD_Local 782 | OD_Interface => 783 Kind := OE_Addrl; 784 -- Local declarations are 1 deeper than their subprogram. 785 Depth := Get_Decl_Depth (Obj) - 1; 786 if Depth /= Cur_Subprg.Depth then 787 Chain := Get_Static_Chain (Depth); 788 else 789 Chain := O_Enode_Null; 790 end if; 791 when OD_Var 792 | OD_Const => 793 Kind := OE_Addrd; 794 Chain := O_Enode_Null; 795 when others => 796 raise Program_Error; 797 end case; 798 return O_Lnode (New_Enode (Kind, Abi.Mode_Ptr, O_Type, 799 O_Enode (Obj), Chain)); 800 end New_Obj; 801 802 function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) 803 return O_Enode 804 is 805 L_Type : O_Tnode; 806 begin 807 L_Type := Get_Enode_Type (Left); 808 if Flag_Debug_Assert then 809 if L_Type /= Get_Enode_Type (Right) then 810 raise Syntax_Error; 811 end if; 812 if Get_Type_Mode (L_Type) = Mode_Blk then 813 raise Syntax_Error; 814 end if; 815 Check_Ref (Left); 816 Check_Ref (Right); 817 end if; 818 819 return New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), 820 L_Type, Left, Right); 821 end New_Dyadic_Op; 822 823 function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) 824 return O_Enode 825 is 826 O_Type : O_Tnode; 827 begin 828 O_Type := Get_Enode_Type (Operand); 829 830 if Flag_Debug_Assert then 831 if Get_Type_Mode (O_Type) = Mode_Blk then 832 raise Syntax_Error; 833 end if; 834 Check_Ref (Operand); 835 end if; 836 837 return New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), O_Type, 838 Operand, O_Enode_Null); 839 end New_Monadic_Op; 840 841 function New_Compare_Op 842 (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) 843 return O_Enode 844 is 845 Res : O_Enode; 846 begin 847 if Flag_Debug_Assert then 848 if Get_Enode_Type (Left) /= Get_Enode_Type (Right) then 849 raise Syntax_Error; 850 end if; 851 if Get_Expr_Mode (Left) = Mode_Blk then 852 raise Syntax_Error; 853 end if; 854 if Get_Type_Kind (Ntype) /= OT_Boolean then 855 raise Syntax_Error; 856 end if; 857 Check_Ref (Left); 858 Check_Ref (Right); 859 end if; 860 861 Res := New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), Ntype, 862 Left, Right); 863 if Flag_Debug_Hli then 864 return New_Enode (OE_Typed, Ntype, Res, O_Enode (Ntype)); 865 else 866 return Res; 867 end if; 868 end New_Compare_Op; 869 870 function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Enode is 871 begin 872 return New_Const_U32 (Get_Type_Size (Atype), Rtype); 873 end New_Sizeof; 874 875 function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Enode is 876 begin 877 return New_Const_U32 (Get_Field_Offset (Field), Rtype); 878 end New_Offsetof; 879 880 function Is_Pow2 (V : Uns32) return Boolean is 881 begin 882 return (V and -V) = V; 883 end Is_Pow2; 884 885 function Extract_Pow2 (V : Uns32) return Uns32 is 886 begin 887 for I in Natural range 0 .. 31 loop 888 if V = Shift_Left (1, I) then 889 return Uns32 (I); 890 end if; 891 end loop; 892 raise Program_Error; 893 end Extract_Pow2; 894 895 function New_Index_Slice_Element 896 (Arr : O_Lnode; Index : O_Enode; Res_Type : O_Tnode) 897 return O_Lnode 898 is 899 El_Type : O_Tnode; 900 In_Type : O_Tnode; 901 Sz : O_Enode; 902 El_Size : Uns32; 903 begin 904 El_Type := Get_Type_Array_Element (Get_Enode_Type (O_Enode (Arr))); 905 In_Type := Get_Enode_Type (Index); 906 907 if Flag_Debug_Assert then 908 Check_Ref (Index); 909 Check_Ref (Arr); 910 end if; 911 912 -- result := arr + index * sizeof (element). 913 El_Size := Get_Type_Size (El_Type); 914 if El_Size = 1 then 915 Sz := Index; 916 elsif Get_Expr_Kind (Index) = OE_Const then 917 -- FIXME: may recycle previous index? 918 Sz := New_Const_U32 (Get_Expr_Low (Index) * El_Size, In_Type); 919 else 920 if Is_Pow2 (El_Size) and then El_Size /= 0 then 921 Sz := New_Const_U32 (Extract_Pow2 (El_Size), In_Type); 922 Sz := New_Enode (OE_Shl, In_Type, Index, Sz); 923 else 924 Sz := New_Const_U32 (El_Size, In_Type); 925 Sz := New_Enode (OE_Mul, In_Type, Index, Sz); 926 end if; 927 end if; 928 return O_Lnode (New_Enode (OE_Add, Abi.Mode_Ptr, Res_Type, 929 O_Enode (Arr), Sz)); 930 end New_Index_Slice_Element; 931 932 function New_Hli_Index_Slice 933 (Kind : OE_Kind; Res_Type : O_Tnode; Arr : O_Lnode; Index : O_Enode) 934 return O_Lnode 935 is 936 begin 937 if Flag_Debug_Assert then 938 Check_Ref (Index); 939 Check_Ref (Arr); 940 end if; 941 return O_Lnode (New_Enode (Kind, Res_Type, O_Enode (Arr), Index)); 942 end New_Hli_Index_Slice; 943 944 -- Get an element of an array. 945 -- INDEX must be of the type of the array index. 946 function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) 947 return O_Lnode 948 is 949 El_Type : O_Tnode; 950 begin 951 El_Type := Get_Type_Array_Element (Get_Enode_Type (O_Enode (Arr))); 952 953 if Flag_Debug_Hli then 954 return New_Hli_Index_Slice (OE_Index_Ref, El_Type, Arr, Index); 955 else 956 return New_Index_Slice_Element (Arr, Index, El_Type); 957 end if; 958 end New_Indexed_Element; 959 960 -- Get a slice of an array; this is equivalent to a conversion between 961 -- an array or an array subtype and an array subtype. 962 -- RES_TYPE must be an array_sub_type whose base type is the same as the 963 -- base type of ARR. 964 -- INDEX must be of the type of the array index. 965 function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) 966 return O_Lnode 967 is 968 begin 969 if Flag_Debug_Hli then 970 return New_Hli_Index_Slice (OE_Slice_Ref, Res_Type, Arr, Index); 971 else 972 return New_Index_Slice_Element (Arr, Index, Res_Type); 973 end if; 974 end New_Slice; 975 976 function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) 977 return O_Lnode 978 is 979 Offset : Uns32; 980 Off : O_Enode; 981 Res_Type : O_Tnode; 982 begin 983 if Flag_Debug_Assert then 984 Check_Ref (Rec); 985 end if; 986 987 Res_Type := Get_Field_Type (El); 988 if Flag_Debug_Hli then 989 return O_Lnode (New_Enode (OE_Record_Ref, Res_Type, 990 O_Enode (Rec), O_Enode (El))); 991 else 992 Offset := Get_Field_Offset (El); 993 if Offset = 0 then 994 return O_Lnode (New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Res_Type, 995 O_Enode (Rec), O_Enode (Res_Type))); 996 else 997 Off := New_Enode (OE_Const, Mode_U32, O_Tnode_Null, 998 O_Enode (Offset), O_Enode_Null); 999 1000 return O_Lnode (New_Enode (OE_Add, Abi.Mode_Ptr, Res_Type, 1001 O_Enode (Rec), Off)); 1002 end if; 1003 end if; 1004 end New_Selected_Element; 1005 1006 function New_Access_Element (Acc : O_Enode) return O_Lnode 1007 is 1008 Acc_Type : O_Tnode; 1009 Res_Type : O_Tnode; 1010 begin 1011 Acc_Type := Get_Enode_Type (Acc); 1012 1013 if Flag_Debug_Assert then 1014 if Get_Type_Kind (Acc_Type) /= OT_Access then 1015 raise Syntax_Error; 1016 end if; 1017 Check_Ref (Acc); 1018 end if; 1019 1020 Res_Type := Get_Type_Access_Type (Acc_Type); 1021 if Flag_Debug_Hli then 1022 return O_Lnode (New_Enode (OE_Access_Ref, Abi.Mode_Ptr, Res_Type, 1023 Acc, O_Enode_Null)); 1024 else 1025 return O_Lnode (New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Res_Type, 1026 Acc, O_Enode (Res_Type))); 1027 end if; 1028 end New_Access_Element; 1029 1030 function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is 1031 begin 1032 if Flag_Debug_Assert then 1033 Check_Ref (Val); 1034 end if; 1035 1036 return New_Enode (OE_Conv_Ov, Rtype, Val, O_Enode (Rtype)); 1037 end New_Convert_Ov; 1038 1039 function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode is 1040 begin 1041 if Flag_Debug_Assert then 1042 Check_Ref (Val); 1043 end if; 1044 1045 return New_Enode (OE_Conv, Rtype, Val, O_Enode (Rtype)); 1046 end New_Convert; 1047 1048 function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) 1049 return O_Enode is 1050 begin 1051 if Flag_Debug_Assert then 1052 if Get_Type_Kind (Atype) /= OT_Access then 1053 raise Syntax_Error; 1054 end if; 1055 Check_Ref (Lvalue); 1056 end if; 1057 1058 return New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Atype, 1059 O_Enode (Lvalue), O_Enode (Atype)); 1060 end New_Unchecked_Address; 1061 1062 function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is 1063 begin 1064 if Flag_Debug_Assert then 1065 if Get_Type_Kind (Atype) /= OT_Access then 1066 raise Syntax_Error; 1067 end if; 1068 if Get_Base_Type (Get_Enode_Type (O_Enode (Lvalue))) 1069 /= Get_Base_Type (Get_Type_Access_Type (Atype)) 1070 then 1071 raise Syntax_Error; 1072 end if; 1073 Check_Ref (Lvalue); 1074 end if; 1075 1076 return New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Atype, 1077 O_Enode (Lvalue), O_Enode (Atype)); 1078 end New_Address; 1079 1080 function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) 1081 return O_Enode is 1082 begin 1083 raise Program_Error; 1084 return O_Enode_Null; 1085 end New_Subprogram_Address; 1086 1087 function New_Value (Lvalue : O_Lnode) return O_Enode 1088 is 1089 V_Type : O_Tnode; 1090 begin 1091 V_Type := Get_Enode_Type (O_Enode (Lvalue)); 1092 1093 if Flag_Debug_Assert then 1094 Check_Ref (Lvalue); 1095 end if; 1096 1097 return New_Enode (OE_Indir, V_Type, O_Enode (Lvalue), O_Enode_Null); 1098 end New_Value; 1099 1100 function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode 1101 is 1102 Save_Var : O_Dnode; 1103 Stmt : O_Enode; 1104 St_Type : O_Tnode; 1105 begin 1106 if Flag_Debug_Assert then 1107 Check_Ref (Size); 1108 if Get_Type_Kind (Rtype) /= OT_Access then 1109 raise Syntax_Error; 1110 end if; 1111 if Get_Type_Kind (Get_Enode_Type (Size)) /= OT_Unsigned then 1112 raise Syntax_Error; 1113 end if; 1114 end if; 1115 1116 if not Get_Block_Has_Alloca (Cur_Block) then 1117 Set_Block_Has_Alloca (Cur_Block, True); 1118 if Stack_Ptr_Type /= O_Tnode_Null then 1119 St_Type := Stack_Ptr_Type; 1120 else 1121 St_Type := Rtype; 1122 end if; 1123 -- Add a decl. 1124 New_Var_Decl (Save_Var, O_Ident_Nul, O_Storage_Local, St_Type); 1125 -- Add insn to save stack ptr. 1126 Stmt := New_Enode (OE_Asgn, St_Type, 1127 New_Stack (St_Type), 1128 O_Enode (New_Obj (Save_Var))); 1129 if Cur_Block = Last_Stmt then 1130 Set_Stmt_Link (Last_Stmt, Stmt); 1131 Last_Stmt := Stmt; 1132 else 1133 Set_Stmt_Link (Stmt, Get_Stmt_Link (Cur_Block)); 1134 Set_Stmt_Link (Cur_Block, Stmt); 1135 end if; 1136 end if; 1137 1138 return New_Enode (OE_Alloca, Rtype, Size, O_Enode (Rtype)); 1139 end New_Alloca; 1140 1141 procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) 1142 is 1143 Depth : O_Depth; 1144 Arg : O_Enode; 1145 First_Inter : O_Dnode; 1146 begin 1147 First_Inter := Get_Subprg_Interfaces (Subprg); 1148 if Get_Decl_Storage (Subprg) = O_Storage_Local then 1149 Depth := Get_Decl_Depth (Subprg); 1150 Arg := New_Enode (OE_Arg, Abi.Mode_Ptr, O_Tnode_Ptr, 1151 Get_Static_Chain (Depth - 1), O_Enode_Null); 1152 First_Inter := Get_Interface_Chain (First_Inter); 1153 else 1154 Arg := O_Enode_Null; 1155 end if; 1156 Assocs := (Subprg => Subprg, 1157 First_Arg => Arg, 1158 Last_Arg => Arg, 1159 Next_Inter => First_Inter); 1160 end Start_Association; 1161 1162 procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) 1163 is 1164 V_Type : O_Tnode; 1165 Mode : Mode_Type; 1166 N_Mode : Mode_Type; 1167 Res : O_Enode; 1168 begin 1169 V_Type := Get_Enode_Type (Val); 1170 1171 if Flag_Debug_Assert then 1172 if Assocs.Next_Inter = O_Dnode_Null then 1173 -- More assocs than interfaces. 1174 raise Syntax_Error; 1175 end if; 1176 Check_Value_Type (Val, Get_Decl_Type (Assocs.Next_Inter)); 1177 Check_Ref (Val); 1178 end if; 1179 1180 -- Follow the C convention call: no parameters shorter than int. 1181 Mode := Get_Type_Mode (V_Type); 1182 case Mode is 1183 when Mode_B2 1184 | Mode_U8 1185 | Mode_U16 => 1186 N_Mode := Mode_U32; 1187 when Mode_I8 1188 | Mode_I16 => 1189 N_Mode := Mode_I32; 1190 when Mode_P32 1191 | Mode_U32 1192 | Mode_I32 1193 | Mode_U64 1194 | Mode_I64 1195 | Mode_P64 1196 | Mode_F32 1197 | Mode_F64 => 1198 N_Mode := Mode; 1199 when Mode_Blk 1200 | Mode_Nil 1201 | Mode_X1 => 1202 raise Program_Error; 1203 end case; 1204 if N_Mode /= Mode and not Flag_Debug_Hli then 1205 Res := New_Enode (OE_Conv_Ov, N_Mode, V_Type, Val, O_Enode (V_Type)); 1206 else 1207 Res := Val; 1208 end if; 1209 Res := New_Enode (OE_Arg, N_Mode, V_Type, Res, O_Enode_Null); 1210 if Assocs.Last_Arg /= O_Enode_Null then 1211 Enodes.Table (Assocs.Last_Arg).Arg2 := Res; 1212 else 1213 Assocs.First_Arg := Res; 1214 end if; 1215 Assocs.Last_Arg := Res; 1216 Assocs.Next_Inter := Get_Interface_Chain (Assocs.Next_Inter); 1217 end New_Association; 1218 1219 function New_Function_Call (Assocs : O_Assoc_List) return O_Enode 1220 is 1221 F_Type : O_Tnode; 1222 begin 1223 if Flag_Debug_Assert then 1224 if Assocs.Next_Inter /= O_Dnode_Null then 1225 -- Not enough assocs. 1226 raise Syntax_Error; 1227 end if; 1228 end if; 1229 1230 F_Type := Get_Decl_Type (Assocs.Subprg); 1231 return New_Enode (OE_Call, F_Type, 1232 O_Enode (Assocs.Subprg), Assocs.First_Arg); 1233 end New_Function_Call; 1234 1235 procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is 1236 begin 1237 if Flag_Debug_Assert then 1238 if Assocs.Next_Inter /= O_Dnode_Null then 1239 -- Not enough assocs. 1240 raise Syntax_Error; 1241 end if; 1242 end if; 1243 New_Enode_Stmt (OE_Call, O_Enode (Assocs.Subprg), Assocs.First_Arg); 1244 end New_Procedure_Call; 1245 1246 procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) 1247 is 1248 V_Type : O_Tnode; 1249 begin 1250 V_Type := Get_Enode_Type (Value); 1251 1252 if Flag_Debug_Assert then 1253 Check_Value_Type (Value, Get_Enode_Type (O_Enode (Target))); 1254 Check_Ref (Value); 1255 Check_Ref (Target); 1256 end if; 1257 1258 New_Enode_Stmt (OE_Asgn, Get_Type_Mode (V_Type), 1259 Value, O_Enode (Target)); 1260 end New_Assign_Stmt; 1261 1262 procedure New_Return_Stmt (Value : O_Enode) 1263 is 1264 V_Type : O_Tnode; 1265 begin 1266 V_Type := Get_Enode_Type (Value); 1267 1268 if Flag_Debug_Assert then 1269 Check_Ref (Value); 1270 Check_Value_Type (Value, Get_Decl_Type (Cur_Subprg.D_Decl)); 1271 end if; 1272 1273 New_Enode_Stmt (OE_Ret, Get_Type_Mode (V_Type), Value, O_Enode_Null); 1274 if not Flag_Debug_Hli then 1275 New_Allocb_Jump (Cur_Subprg.Exit_Label); 1276 end if; 1277 end New_Return_Stmt; 1278 1279 procedure New_Return_Stmt is 1280 begin 1281 if Flag_Debug_Assert then 1282 if Get_Decl_Kind (Cur_Subprg.D_Decl) /= OD_Procedure then 1283 raise Syntax_Error; 1284 end if; 1285 end if; 1286 1287 if not Flag_Debug_Hli then 1288 New_Allocb_Jump (Cur_Subprg.Exit_Label); 1289 else 1290 New_Enode_Stmt (OE_Ret, Mode_Nil, O_Enode_Null, O_Enode_Null); 1291 end if; 1292 end New_Return_Stmt; 1293 1294 1295 procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode) is 1296 begin 1297 if Flag_Debug_Assert then 1298 if Get_Expr_Mode (Cond) /= Mode_B2 then 1299 -- COND must be a boolean. 1300 raise Syntax_Error; 1301 end if; 1302 Check_Ref (Cond); 1303 end if; 1304 1305 if not Flag_Lower_Stmt then 1306 New_Enode_Stmt (OE_If, Cond, O_Enode_Null); 1307 Block := (Label_End => O_Enode_Null, 1308 Label_Next => Last_Stmt); 1309 else 1310 Block := (Label_End => O_Enode_Null, 1311 Label_Next => New_Label); 1312 Emit_Jmp (OE_Jump_F, Cond, Block.Label_Next); 1313 Start_BB; 1314 end if; 1315 end Start_If_Stmt; 1316 1317 procedure New_Else_Stmt (Block : in out O_If_Block) is 1318 begin 1319 if not Flag_Lower_Stmt then 1320 New_Enode_Stmt (OE_Else, O_Enode_Null, O_Enode_Null); 1321 else 1322 if Block.Label_End = O_Enode_Null then 1323 Block.Label_End := New_Label; 1324 end if; 1325 Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End); 1326 Start_BB; 1327 Link_Stmt (Block.Label_Next); 1328 Block.Label_Next := O_Enode_Null; 1329 end if; 1330 end New_Else_Stmt; 1331 1332 procedure Finish_If_Stmt (Block : in out O_If_Block) is 1333 begin 1334 if not Flag_Lower_Stmt then 1335 New_Enode_Stmt (OE_Endif, O_Enode_Null, O_Enode_Null); 1336 else 1337 -- Create a badic-block after the IF. 1338 Start_BB; 1339 if Block.Label_Next /= O_Enode_Null then 1340 Link_Stmt (Block.Label_Next); 1341 end if; 1342 if Block.Label_End /= O_Enode_Null then 1343 Link_Stmt (Block.Label_End); 1344 end if; 1345 end if; 1346 end Finish_If_Stmt; 1347 1348 procedure Start_Loop_Stmt (Label : out O_Snode) is 1349 begin 1350 if not Flag_Lower_Stmt then 1351 New_Enode_Stmt (OE_Loop, O_Enode_Null, O_Enode_Null); 1352 Label := (Label_Start => Last_Stmt, 1353 Label_End => O_Enode_Null); 1354 else 1355 -- Create a basic-block at the beginning of the loop. 1356 Start_BB; 1357 Label.Label_Start := New_Label; 1358 Link_Stmt (Label.Label_Start); 1359 Label.Label_End := New_Label; 1360 end if; 1361 end Start_Loop_Stmt; 1362 1363 procedure Finish_Loop_Stmt (Label : in out O_Snode) 1364 is 1365 begin 1366 if not Flag_Lower_Stmt then 1367 New_Enode_Stmt (OE_Eloop, Label.Label_Start, O_Enode_Null); 1368 else 1369 Emit_Jmp (OE_Jump, O_Enode_Null, Label.Label_Start); 1370 Start_BB; 1371 Link_Stmt (Label.Label_End); 1372 end if; 1373 end Finish_Loop_Stmt; 1374 1375 procedure New_Exit_Stmt (L : O_Snode) 1376 is 1377 begin 1378 if not Flag_Lower_Stmt then 1379 New_Enode_Stmt (OE_Exit, O_Enode_Null, L.Label_Start); 1380 else 1381 New_Allocb_Jump (L.Label_End); 1382 end if; 1383 end New_Exit_Stmt; 1384 1385 procedure New_Next_Stmt (L : O_Snode) 1386 is 1387 begin 1388 if not Flag_Lower_Stmt then 1389 New_Enode_Stmt (OE_Next, O_Enode_Null, L.Label_Start); 1390 else 1391 New_Allocb_Jump (L.Label_Start); 1392 end if; 1393 end New_Next_Stmt; 1394 1395 procedure Start_Case_Stmt (Block : out O_Case_Block; Value : O_Enode) 1396 is 1397 V_Type : O_Tnode; 1398 Mode : Mode_Type; 1399 Start : O_Enode; 1400 begin 1401 V_Type := Get_Enode_Type (Value); 1402 Mode := Get_Type_Mode (V_Type); 1403 1404 if Flag_Debug_Assert then 1405 Check_Ref (Value); 1406 case Mode is 1407 when Mode_U8 .. Mode_U64 1408 | Mode_I8 .. Mode_I64 1409 | Mode_B2 => 1410 null; 1411 when others => 1412 raise Syntax_Error; 1413 end case; 1414 end if; 1415 1416 New_Enode_Stmt (OE_Case, Mode, Value, O_Enode_Null); 1417 Start := Enodes.Last; 1418 if Flag_Debug_Hli then 1419 Block := (Expr => Start, 1420 Expr_Type => V_Type, 1421 Last_Node => O_Enode_Null, 1422 Label_End => O_Enode_Null, 1423 Label_Branch => Start); 1424 else 1425 Block := (Expr => Start, 1426 Expr_Type => V_Type, 1427 Last_Node => Start, 1428 Label_End => New_Label, 1429 Label_Branch => O_Enode_Null); 1430 end if; 1431 end Start_Case_Stmt; 1432 1433 procedure Start_Choice (Block : in out O_Case_Block) 1434 is 1435 B : O_Enode; 1436 begin 1437 if Flag_Debug_Hli then 1438 B := New_Enode (OE_Case_Branch, Mode_Nil, O_Tnode_Null, 1439 O_Enode_Null, O_Enode_Null); 1440 Link_Stmt (B); 1441 -- Link it. 1442 Set_Case_Branch (Block.Label_Branch, B); 1443 Block.Label_Branch := B; 1444 else 1445 -- Jump to the end of the case statement. 1446 -- If there is already a branch open, this is ok 1447 -- (do not fall-through). 1448 -- If there is no branch open, then this is the default choice 1449 -- (nothing to do). 1450 Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End); 1451 1452 -- Create a label for the code of this branch. 1453 Block.Label_Branch := New_Label; 1454 end if; 1455 end Start_Choice; 1456 1457 procedure Insert_Choice_Stmt (Block : in out O_Case_Block; Stmt : O_Enode) 1458 is 1459 Prev : O_Enode; 1460 begin 1461 Prev := Get_Stmt_Link (Block.Last_Node); 1462 Set_Stmt_Link (Block.Last_Node, Stmt); 1463 Block.Last_Node := Stmt; 1464 if Prev = O_Enode_Null then 1465 Last_Stmt := Stmt; 1466 else 1467 Set_Stmt_Link (Stmt, Prev); 1468 end if; 1469 end Insert_Choice_Stmt; 1470 1471 procedure Emit_Choice_Jmp (Block : in out O_Case_Block; 1472 Code : OE_Kind; Expr : O_Enode; Label : O_Enode) 1473 is 1474 Jmp : O_Enode; 1475 begin 1476 Jmp := New_Enode (Code, Mode_Nil, O_Tnode_Null, Expr, Label); 1477 Insert_Choice_Stmt (Block, Jmp); 1478 end Emit_Choice_Jmp; 1479 1480 -- Create a node containing the value of the case expression. 1481 function New_Case_Expr (Block : O_Case_Block) return O_Enode is 1482 begin 1483 return New_Enode (OE_Case_Expr, Block.Expr_Type, 1484 Block.Expr, O_Enode_Null); 1485 end New_Case_Expr; 1486 1487 procedure New_Hli_Choice (Block : in out O_Case_Block; 1488 Hi, Lo : O_Enode) 1489 is 1490 Res : O_Enode; 1491 begin 1492 Res := New_Enode (OE_Case_Choice, Mode_Nil, O_Tnode_Null, Hi, Lo); 1493 if Block.Label_End = O_Enode_Null then 1494 Set_Case_Branch_Choice (Block.Label_Branch, Res); 1495 else 1496 Set_Case_Choice_Link (Block.Label_End, Res); 1497 end if; 1498 Block.Label_End := Res; 1499 end New_Hli_Choice; 1500 1501 procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) 1502 is 1503 Res : O_Enode; 1504 begin 1505 if Flag_Debug_Hli then 1506 New_Hli_Choice (Block, New_Lit (Expr), O_Enode_Null); 1507 else 1508 Res := New_Enode (OE_Eq, Mode_B2, O_Tnode_Null, 1509 New_Case_Expr (Block), New_Lit (Expr)); 1510 Emit_Choice_Jmp (Block, OE_Jump_T, Res, Block.Label_Branch); 1511 end if; 1512 end New_Expr_Choice; 1513 1514 procedure New_Range_Choice (Block : in out O_Case_Block; 1515 Low, High : O_Cnode) 1516 is 1517 E1 : O_Enode; 1518 E2 : O_Enode; 1519 Label : O_Enode; 1520 begin 1521 if Flag_Debug_Hli then 1522 New_Hli_Choice (Block, New_Lit (Low), New_Lit (High)); 1523 else 1524 -- Internal label. 1525 Label := New_Label; 1526 E1 := New_Enode (OE_Lt, Mode_B2, O_Tnode_Null, 1527 New_Case_Expr (Block), New_Lit (Low)); 1528 Emit_Choice_Jmp (Block, OE_Jump_T, E1, Label); 1529 E2 := New_Enode (OE_Le, Mode_B2, O_Tnode_Null, 1530 New_Case_Expr (Block), New_Lit (High)); 1531 Emit_Choice_Jmp (Block, OE_Jump_T, E2, Block.Label_Branch); 1532 Insert_Choice_Stmt (Block, Label); 1533 end if; 1534 end New_Range_Choice; 1535 1536 procedure New_Default_Choice (Block : in out O_Case_Block) is 1537 begin 1538 if Flag_Debug_Hli then 1539 New_Hli_Choice (Block, O_Enode_Null, O_Enode_Null); 1540 else 1541 -- Jump to the code. 1542 Emit_Choice_Jmp (Block, OE_Jump, O_Enode_Null, Block.Label_Branch); 1543 end if; 1544 end New_Default_Choice; 1545 1546 procedure Finish_Choice (Block : in out O_Case_Block) is 1547 begin 1548 if Flag_Debug_Hli then 1549 Block.Label_End := O_Enode_Null; 1550 else 1551 -- Put the label of the branch. 1552 Start_BB; 1553 Link_Stmt (Block.Label_Branch); 1554 end if; 1555 end Finish_Choice; 1556 1557 procedure Finish_Case_Stmt (Block : in out O_Case_Block) is 1558 begin 1559 if Flag_Debug_Hli then 1560 New_Enode_Stmt (OE_Case_End, O_Enode_Null, O_Enode_Null); 1561 else 1562 -- Jump to the end of the case statement. 1563 -- Note: this is not required, since the next instruction is the 1564 -- label. 1565 -- Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End); 1566 1567 -- Put the label of the end of the case. 1568 Start_BB; 1569 Link_Stmt (Block.Label_End); 1570 Block.Label_End := O_Enode_Null; 1571 end if; 1572 end Finish_Case_Stmt; 1573 1574 procedure New_Debug_Line_Stmt (Line : Natural) is 1575 begin 1576 New_Enode_Stmt (OE_Line, O_Enode (Line), O_Enode_Null); 1577 end New_Debug_Line_Stmt; 1578 1579 procedure Debug_Expr (N : O_Enode) 1580 is 1581 use Ada.Text_IO; 1582 use Ortho_Code.Debug.Int32_IO; 1583 Indent : constant Count := Col; 1584 begin 1585 Put (Int32 (N), 0); 1586 Set_Col (Indent + 7); 1587 Disp_Mode (Get_Expr_Mode (N)); 1588 Put (" "); 1589 Put (OE_Kind'Image (Get_Expr_Kind (N))); 1590 Set_Col (Indent + 28); 1591-- Put (Abi.Image_Insn (Get_Expr_Insn (N))); 1592-- Put (" "); 1593 Put (Abi.Image_Reg (Get_Expr_Reg (N))); 1594 Put (" "); 1595 Put (Int32 (Enodes.Table (N).Arg1), 7); 1596 Put (Int32 (Enodes.Table (N).Arg2), 7); 1597 Put (Enodes.Table (N).Info, 7); 1598 New_Line; 1599 end Debug_Expr; 1600 1601 procedure Disp_Subprg_Body (Indent : Natural; Subprg : O_Enode) 1602 is 1603 use Ada.Text_IO; 1604 N : O_Enode; 1605 N_Indent : Natural; 1606 begin 1607 N := Subprg; 1608 if Get_Expr_Kind (N) /= OE_Entry then 1609 raise Program_Error; 1610 end if; 1611 -- Display the entry. 1612 Set_Col (Count (Indent)); 1613 Debug_Expr (N); 1614 -- Display the subprogram, binding. 1615 N_Indent := Indent;-- + 1; 1616 N := N + 1; 1617 loop 1618 case Get_Expr_Kind (N) is 1619 when OE_Entry => 1620 N := Get_Entry_Leave (N) + 1; 1621 when OE_Leave => 1622 Set_Col (Count (Indent)); 1623 Debug_Expr (N); 1624 exit; 1625 when others => 1626 Set_Col (Count (N_Indent)); 1627 Debug_Expr (N); 1628 case Get_Expr_Kind (N) is 1629 when OE_Beg => 1630 Disp_Block (N_Indent + 2, 1631 O_Dnode (Enodes.Table (N).Arg2)); 1632 N_Indent := N_Indent + 1; 1633 when OE_End => 1634 N_Indent := N_Indent - 1; 1635 when others => 1636 null; 1637 end case; 1638 N := N + 1; 1639 end case; 1640 end loop; 1641 end Disp_Subprg_Body; 1642 1643 procedure Disp_All_Enode is 1644 begin 1645 for I in Enodes.First .. Enodes.Last loop 1646 Debug_Expr (I); 1647 end loop; 1648 end Disp_All_Enode; 1649 1650 Max_Enode : O_Enode := O_Enode_Null; 1651 1652 procedure Mark (M : out Mark_Type) is 1653 begin 1654 M.Enode := Enodes.Last; 1655 end Mark; 1656 1657 procedure Release (M : Mark_Type) is 1658 begin 1659 Max_Enode := O_Enode'Max (Max_Enode, Enodes.Last); 1660 Enodes.Set_Last (M.Enode); 1661 end Release; 1662 1663 procedure Disp_Stats 1664 is 1665 use Ada.Text_IO; 1666 begin 1667 Max_Enode := O_Enode'Max (Max_Enode, Enodes.Last); 1668 Put ("Number of Enodes:" & O_Enode'Image (Enodes.Last)); 1669 Put (", max:" & O_Enode'Image (Max_Enode)); 1670 New_Line; 1671 end Disp_Stats; 1672 1673 procedure Free_Subprogram_Data (Data : in out Subprogram_Data_Acc) 1674 is 1675 procedure Free is new Ada.Unchecked_Deallocation 1676 (Subprogram_Data, Subprogram_Data_Acc); 1677 Ch, N_Ch : Subprogram_Data_Acc; 1678 begin 1679 Ch := Data.First_Child; 1680 while Ch /= null loop 1681 N_Ch := Ch.Brother; 1682 Free_Subprogram_Data (Ch); 1683 Ch := N_Ch; 1684 end loop; 1685 Free (Data); 1686 end Free_Subprogram_Data; 1687 1688 procedure Finish is 1689 begin 1690 Enodes.Free; 1691 Free_Subprogram_Data (First_Subprg); 1692 end Finish; 1693end Ortho_Code.Exprs; 1694