1-- LLVM back-end for ortho. 2-- Copyright (C) 2014 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>. 16 17with Ada.Unchecked_Conversion; 18with Ada.Unchecked_Deallocation; 19with LLVM.Target; use LLVM.Target; 20with GNAT.Directory_Operations; 21 22package body Ortho_LLVM is 23 -- The current function for LLVM (needed to add new basic blocks). 24 Cur_Func : ValueRef; 25 26 -- The current function node (needed for return type). 27 Cur_Func_Decl : O_Dnode; 28 29 -- Whether the code is currently unreachable. LLVM doesn't accept basic 30 -- blocks that cannot be reached (using trivial rules). So we need to 31 -- discard instructions after a return, a next or an exit statement. 32 Unreach : Boolean; 33 34 -- Builder for statements. 35 Builder : BuilderRef; 36 37 -- Builder for declarations (local variables). 38 Decl_Builder : BuilderRef; 39 40 -- Temporary builder. 41 Extra_Builder : BuilderRef; 42 43 -- Declaration of llvm.dbg.declare 44 Llvm_Dbg_Declare : ValueRef; 45 46 Debug_ID : unsigned; 47 48 Current_Directory : constant String := 49 GNAT.Directory_Operations.Get_Current_Dir; 50 51 -- Additional data for declare blocks. 52 type Declare_Block_Type; 53 type Declare_Block_Acc is access Declare_Block_Type; 54 55 type Declare_Block_Type is record 56 -- First basic block of the declare. 57 Stmt_Bb : BasicBlockRef; 58 59 -- Stack pointer at entry of the block. This value has to be restore 60 -- when leaving the block (either normally or via exit/next). Set only 61 -- if New_Alloca was used. 62 -- FIXME: TODO: restore stack pointer on exit/next stmts. 63 Stack_Value : ValueRef; 64 65 -- Debug data for the scope of the declare block. 66 Dbg_Scope : ValueRef; 67 68 -- Previous element in the stack. 69 Prev : Declare_Block_Acc; 70 end record; 71 72 -- Current declare block. 73 Cur_Declare_Block : Declare_Block_Acc; 74 75 -- Chain of unused blocks to be recycled. 76 Old_Declare_Block : Declare_Block_Acc; 77 78 Stacksave_Fun : ValueRef; 79 Stacksave_Name : constant String := "llvm.stacksave" & ASCII.NUL; 80 Stackrestore_Fun : ValueRef; 81 Stackrestore_Name : constant String := "llvm.stackrestore" & ASCII.NUL; 82 Copysign_Fun : ValueRef; 83 Copysign_Name : constant String := "llvm.copysign.f64" & ASCII.NUL; 84 Fp_0_5 : ValueRef; 85 86 -- For debugging 87 88 DW_Version : constant := 16#c_0000#; 89 DW_TAG_Array_Type : constant := DW_Version + 16#01#; 90 DW_TAG_Enumeration_Type : constant := DW_Version + 16#04#; 91 DW_TAG_Lexical_Block : constant := DW_Version + 16#0b#; 92 DW_TAG_Member : constant := DW_Version + 16#0d#; 93 DW_TAG_Pointer_Type : constant := DW_Version + 16#0f#; 94 DW_TAG_Compile_Unit : constant := DW_Version + 16#11#; 95 DW_TAG_Structure_Type : constant := DW_Version + 16#13#; 96 DW_TAG_Subroutine_Type : constant := DW_Version + 16#15#; 97 DW_TAG_Union_Type : constant := DW_Version + 16#17#; 98 DW_TAG_Subrange_Type : constant := DW_Version + 16#21#; 99 DW_TAG_Base_Type : constant := DW_Version + 16#24#; 100 DW_TAG_Enumerator : constant := DW_Version + 16#28#; 101 DW_TAG_File_Type : constant := DW_Version + 16#29#; 102 DW_TAG_Subprogram : constant := DW_Version + 16#2e#; 103 DW_TAG_Variable : constant := DW_Version + 16#34#; 104 105 DW_TAG_Auto_Variable : constant := DW_Version + 16#100#; 106 DW_TAG_Arg_Variable : constant := DW_Version + 16#101#; 107 108 DW_ATE_address : constant := 16#01#; 109 DW_ATE_boolean : constant := 16#02#; 110 DW_ATE_float : constant := 16#04#; 111 DW_ATE_signed : constant := 16#05#; 112 DW_ATE_unsigned : constant := 16#07#; 113 pragma Unreferenced (DW_ATE_address, DW_ATE_boolean); 114 115 -- File + Dir metadata 116 Dbg_Current_Filedir : ValueRef; 117 Dbg_Current_File : ValueRef; -- The DW_TAG_File_Type 118 119 Dbg_Current_Line : unsigned := 0; 120 121 Dbg_Current_Scope : ValueRef := Null_ValueRef; 122 Scope_Uniq_Id : Unsigned_64 := 0; 123 124 -- Metadata for the instruction 125 Dbg_Insn_MD : ValueRef; 126 Dbg_Insn_MD_Line : unsigned := 0; 127 128 procedure Free is new Ada.Unchecked_Deallocation 129 (ValueRefArray, ValueRefArray_Acc); 130 131 package Dbg_Utils is 132 type Dyn_MDNode is private; 133 134 procedure Append (D : in out Dyn_MDNode; Val : ValueRef); 135 function Get_Value (D : Dyn_MDNode) return ValueRef; 136 137 -- Reset D. FIXME: should be done automatically within Get_Value. 138 procedure Clear (D : out Dyn_MDNode); 139 private 140 Chunk_Length : constant unsigned := 32; 141 type MD_Chunk; 142 type MD_Chunk_Acc is access MD_Chunk; 143 144 type MD_Chunk is record 145 Vals : ValueRefArray (1 .. Chunk_Length); 146 Next : MD_Chunk_Acc; 147 end record; 148 149 type Dyn_MDNode is record 150 First : MD_Chunk_Acc; 151 Last : MD_Chunk_Acc; 152 Nbr : unsigned := 0; 153 end record; 154 end Dbg_Utils; 155 156 package body Dbg_Utils is 157 procedure Append (D : in out Dyn_MDNode; Val : ValueRef) is 158 Chunk : MD_Chunk_Acc; 159 Pos : constant unsigned := D.Nbr rem Chunk_Length; 160 begin 161 if Pos = 0 then 162 Chunk := new MD_Chunk; 163 if D.First = null then 164 D.First := Chunk; 165 else 166 D.Last.Next := Chunk; 167 end if; 168 D.Last := Chunk; 169 else 170 Chunk := D.Last; 171 end if; 172 Chunk.Vals (Pos + 1) := Val; 173 D.Nbr := D.Nbr + 1; 174 end Append; 175 176 procedure Free is new Ada.Unchecked_Deallocation 177 (MD_Chunk, MD_Chunk_Acc); 178 179 function Get_Value (D : Dyn_MDNode) return ValueRef 180 is 181 Vals : ValueRefArray (1 .. D.Nbr); 182 Pos : unsigned; 183 Chunk : MD_Chunk_Acc := D.First; 184 Next_Chunk : MD_Chunk_Acc; 185 Nbr : constant unsigned := D.Nbr; 186 begin 187 Pos := 0; 188 -- Copy by chunks 189 while Pos + Chunk_Length < Nbr loop 190 Vals (Pos + 1 .. Pos + Chunk_Length) := Chunk.Vals; 191 Pos := Pos + Chunk_Length; 192 Next_Chunk := Chunk.Next; 193 Free (Chunk); 194 Chunk := Next_Chunk; 195 end loop; 196 -- Last chunk 197 if Pos < Nbr then 198 Vals (Pos + 1 .. Pos + Nbr - Pos) := Chunk.Vals (1 .. Nbr - Pos); 199 Free (Chunk); 200 end if; 201 return MDNode (Vals, Vals'Length); 202 end Get_Value; 203 204 procedure Clear (D : out Dyn_MDNode) is 205 begin 206 D := (null, null, 0); 207 end Clear; 208 end Dbg_Utils; 209 210 use Dbg_Utils; 211 212 -- List of debug info for subprograms. 213 Subprg_Nodes: Dyn_MDNode; 214 215 -- List of literals for enumerated type 216 Enum_Nodes : Dyn_MDNode; 217 218 -- List of global variables 219 Global_Nodes : Dyn_MDNode; 220 221 -- Create a MDString from an Ada string. 222 function MDString (Str : String) return ValueRef is 223 begin 224 return MDString (Str'Address, Str'Length); 225 end MDString; 226 227 function MDString (Id : O_Ident) return ValueRef is 228 begin 229 return MDString (Get_Cstring (Id), unsigned (Get_String_Length (Id))); 230 end MDString; 231 232 function Dbg_Size (Atype : TypeRef) return ValueRef is 233 begin 234 return ConstInt (Int64Type, 8 * ABISizeOfType (Target_Data, Atype), 0); 235 end Dbg_Size; 236 237 function Dbg_Align (Atype : TypeRef) return ValueRef is 238 begin 239 return ConstInt 240 (Int64Type, 241 Unsigned_64 (8 * ABIAlignmentOfType (Target_Data, Atype)), 0); 242 end Dbg_Align; 243 244 function Dbg_Line return ValueRef is 245 begin 246 return ConstInt (Int32Type, Unsigned_64 (Dbg_Current_Line), 0); 247 end Dbg_Line; 248 249 -- Set debug metadata on instruction INSN. 250 -- FIXME: check if INSN is really an instruction 251 procedure Set_Insn_Dbg (Insn : ValueRef) is 252 begin 253 if Flag_Debug_Line and then IsAInstruction (Insn) /= Null_ValueRef then 254 if Dbg_Current_Line /= Dbg_Insn_MD_Line then 255 declare 256 Vals : ValueRefArray (0 .. 3); 257 begin 258 Vals := (Dbg_Line, 259 ConstInt (Int32Type, 0, 0), -- col 260 Dbg_Current_Scope, -- context 261 Null_ValueRef); -- inline 262 Dbg_Insn_MD := MDNode (Vals, Vals'Length); 263 Dbg_Insn_MD_Line := Dbg_Current_Line; 264 end; 265 end if; 266 SetMetadata (Insn, Debug_ID, Dbg_Insn_MD); 267 end if; 268 end Set_Insn_Dbg; 269 270 procedure Dbg_Create_Variable (Tag : Unsigned_32; 271 Ident : O_Ident; 272 Vtype : O_Tnode; 273 Argno : Natural; 274 Addr : ValueRef) 275 is 276 Vals : ValueRefArray (0 .. 7); 277 Str : constant ValueRef := MDString (Ident); 278 Call_Vals : ValueRefArray (0 .. 1); 279 Call : ValueRef; 280 begin 281 Vals := (ConstInt (Int32Type, Unsigned_64 (Tag), 0), 282 Dbg_Current_Scope, 283 Str, 284 Dbg_Current_File, 285 ConstInt (Int32Type, 286 Unsigned_64 (Dbg_Current_Line) 287 + Unsigned_64 (Argno) * 2 ** 24, 0), 288 Vtype.Dbg, 289 ConstInt (Int32Type, 0, 0), -- flags 290 ConstInt (Int32Type, 0, 0)); 291 292 Call_Vals := (MDNode ((0 => Addr), 1), 293 MDNode (Vals, Vals'Length)); 294 Call := BuildCall (Decl_Builder, Llvm_Dbg_Declare, 295 Call_Vals, Call_Vals'Length, Empty_Cstring); 296 Set_Insn_Dbg (Call); 297 end Dbg_Create_Variable; 298 299 procedure Create_Declare_Block 300 is 301 Res : Declare_Block_Acc; 302 begin 303 -- Try to recycle an unused record. 304 if Old_Declare_Block /= null then 305 Res := Old_Declare_Block; 306 Old_Declare_Block := Res.Prev; 307 else 308 -- Create a new one if no unused records. 309 Res := new Declare_Block_Type; 310 end if; 311 312 -- Chain. 313 Res.all := (Stmt_Bb => Null_BasicBlockRef, 314 Stack_Value => Null_ValueRef, 315 Dbg_Scope => Null_ValueRef, 316 Prev => Cur_Declare_Block); 317 Cur_Declare_Block := Res; 318 319 if not Unreach then 320 Res.Stmt_Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); 321 end if; 322 end Create_Declare_Block; 323 324 procedure Destroy_Declare_Block 325 is 326 Blk : constant Declare_Block_Acc := Cur_Declare_Block; 327 begin 328 -- Unchain. 329 Cur_Declare_Block := Blk.Prev; 330 331 -- Put on the recyle list. 332 Blk.Prev := Old_Declare_Block; 333 Old_Declare_Block := Blk; 334 end Destroy_Declare_Block; 335 336 ----------------------- 337 -- Start_Record_Type -- 338 ----------------------- 339 340 procedure Start_Record_Type (Elements : out O_Element_List) is 341 begin 342 Elements := (Kind => OF_Record, 343 Nbr_Elements => 0, 344 Rec_Type => O_Tnode_Null, 345 Size => 0, 346 Align => 0, 347 Align_Type => Null_TypeRef, 348 First_Elem => null, 349 Last_Elem => null); 350 end Start_Record_Type; 351 352 ---------------------- 353 -- New_Record_Field -- 354 ---------------------- 355 356 procedure Add_Field 357 (Elements : in out O_Element_List; Ident : O_Ident; Etype : O_Tnode) 358 is 359 O_El : O_Element_Acc; 360 begin 361 Elements.Nbr_Elements := Elements.Nbr_Elements + 1; 362 O_El := new O_Element'(Next => null, 363 Etype => Etype, 364 Ident => Ident); 365 if Elements.First_Elem = null then 366 Elements.First_Elem := O_El; 367 else 368 Elements.Last_Elem.Next := O_El; 369 end if; 370 Elements.Last_Elem := O_El; 371 end Add_Field; 372 373 procedure New_Record_Field 374 (Elements : in out O_Element_List; 375 El : out O_Fnode; 376 Ident : O_Ident; 377 Etype : O_Tnode) is 378 begin 379 El := (Kind => OF_Record, 380 Index => Elements.Nbr_Elements, 381 Ftype => Etype); 382 Add_Field (Elements, Ident, Etype); 383 end New_Record_Field; 384 385 ------------------------ 386 -- Finish_Record_Type -- 387 ------------------------ 388 389 procedure Add_Dbg_Fields 390 (Elements : in out O_Element_List; Res : O_Tnode) 391 is 392 Count : constant unsigned := unsigned (Elements.Nbr_Elements); 393 Fields : ValueRefArray (1 .. Count); 394 Vals : ValueRefArray (0 .. 9); 395 Ftype : TypeRef; 396 Fields_Arr : ValueRef; 397 Off : Unsigned_64; 398 El : O_Element_Acc; 399 begin 400 El := Elements.First_Elem; 401 for I in Fields'Range loop 402 Ftype := Get_LLVM_Type (El.Etype); 403 case Elements.Kind is 404 when OF_Record => 405 Off := 8 * OffsetOfElement (Target_Data, 406 Res.LLVM, Unsigned_32 (I - 1)); 407 when OF_Union => 408 Off := 0; 409 when OF_None => 410 raise Program_Error; 411 end case; 412 Vals := 413 (ConstInt (Int32Type, DW_TAG_Member, 0), 414 Dbg_Current_File, 415 Null_ValueRef, 416 MDString (El.Ident), 417 ConstInt (Int32Type, 0, 0), -- linenum 418 Dbg_Size (Ftype), 419 Dbg_Align (Ftype), 420 ConstInt (Int32Type, Off, 0), 421 ConstInt (Int32Type, 0, 0), -- Flags 422 El.Etype.Dbg); 423 Fields (I) := MDNode (Vals, Vals'Length); 424 El := El.Next; 425 end loop; 426 Fields_Arr := MDNode (Fields, Fields'Length); 427 if Elements.Rec_Type /= null then 428 -- Completion 429 MDNodeReplaceOperandWith (Res.Dbg, 10, Fields_Arr); 430 MDNodeReplaceOperandWith (Res.Dbg, 5, Dbg_Size (Res.LLVM)); 431 MDNodeReplaceOperandWith (Res.Dbg, 6, Dbg_Align (Res.LLVM)); 432 else 433 -- Temporary borrowed. 434 Res.Dbg := Fields_Arr; 435 end if; 436 end Add_Dbg_Fields; 437 438 procedure Free_Elements (Elements : in out O_Element_List) 439 is 440 procedure Free is new Ada.Unchecked_Deallocation 441 (O_Element, O_Element_Acc); 442 El : O_Element_Acc; 443 Next_El : O_Element_Acc; 444 begin 445 -- Free elements 446 El := Elements.First_Elem; 447 while El /= null loop 448 Next_El := El.Next; 449 Free (El); 450 El := Next_El; 451 end loop; 452 Elements.First_Elem := null; 453 Elements.Last_Elem := null; 454 end Free_Elements; 455 456 procedure Finish_Record_Type 457 (Elements : in out O_Element_List; Res : out O_Tnode) 458 is 459 Count : constant unsigned := unsigned (Elements.Nbr_Elements); 460 El : O_Element_Acc; 461 Types : TypeRefArray (1 .. Count); 462 begin 463 El := Elements.First_Elem; 464 for I in Types'Range loop 465 Types (I) := Get_LLVM_Type (El.Etype); 466 El := El.Next; 467 end loop; 468 469 if Elements.Rec_Type /= null then 470 -- Completion 471 StructSetBody (Elements.Rec_Type.LLVM, Types, Count, 0); 472 Res := Elements.Rec_Type; 473 else 474 Res := new O_Tnode_Type'(Kind => ON_Record_Type, 475 LLVM => StructType (Types, Count, 0), 476 Dbg => Null_ValueRef); 477 end if; 478 479 if Flag_Debug then 480 Add_Dbg_Fields (Elements, Res); 481 end if; 482 483 Free_Elements (Elements); 484 end Finish_Record_Type; 485 486 -------------------------------- 487 -- New_Uncomplete_Record_Type -- 488 -------------------------------- 489 490 procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is 491 begin 492 -- LLVM type will be created when the type is declared, as the name 493 -- is required (for unification). 494 Res := new O_Tnode_Type'(Kind => ON_Incomplete_Record_Type, 495 LLVM => Null_TypeRef, 496 Dbg => Null_ValueRef); 497 end New_Uncomplete_Record_Type; 498 499 ---------------------------------- 500 -- Start_Uncomplete_Record_Type -- 501 ---------------------------------- 502 503 procedure Start_Uncomplete_Record_Type 504 (Res : O_Tnode; 505 Elements : out O_Element_List) 506 is 507 begin 508 if Res.Kind /= ON_Incomplete_Record_Type then 509 raise Program_Error; 510 end if; 511 Elements := (Kind => OF_Record, 512 Nbr_Elements => 0, 513 Rec_Type => Res, 514 Size => 0, 515 Align => 0, 516 Align_Type => Null_TypeRef, 517 First_Elem => null, 518 Last_Elem => null); 519 end Start_Uncomplete_Record_Type; 520 521 ---------------------- 522 -- Start_Union_Type -- 523 ---------------------- 524 525 procedure Start_Union_Type (Elements : out O_Element_List) is 526 begin 527 Elements := (Kind => OF_Union, 528 Nbr_Elements => 0, 529 Rec_Type => O_Tnode_Null, 530 Size => 0, 531 Align => 0, 532 Align_Type => Null_TypeRef, 533 First_Elem => null, 534 Last_Elem => null); 535 end Start_Union_Type; 536 537 --------------------- 538 -- New_Union_Field -- 539 --------------------- 540 541 procedure New_Union_Field 542 (Elements : in out O_Element_List; 543 El : out O_Fnode; 544 Ident : O_Ident; 545 Etype : O_Tnode) 546 is 547 El_Type : constant TypeRef := Get_LLVM_Type (Etype); 548 Size : constant unsigned := 549 unsigned (ABISizeOfType (Target_Data, El_Type)); 550 Align : constant Unsigned_32 := 551 ABIAlignmentOfType (Target_Data, El_Type); 552 begin 553 El := (Kind => OF_Union, 554 Ftype => Etype, 555 Utype => El_Type, 556 Ptr_Type => PointerType (El_Type)); 557 if Size > Elements.Size then 558 Elements.Size := Size; 559 end if; 560 if Elements.Align_Type = Null_TypeRef or else Align > Elements.Align then 561 Elements.Align := Align; 562 Elements.Align_Type := El_Type; 563 end if; 564 Add_Field (Elements, Ident, Etype); 565 end New_Union_Field; 566 567 ----------------------- 568 -- Finish_Union_Type -- 569 ----------------------- 570 571 procedure Finish_Union_Type 572 (Elements : in out O_Element_List; 573 Res : out O_Tnode) 574 is 575 Count : unsigned; 576 Types : TypeRefArray (1 .. 2); 577 Pad : unsigned; 578 begin 579 if Elements.Align_Type = Null_TypeRef then 580 -- An empty union. Is it allowed ? 581 Count := 0; 582 else 583 -- The first element is the field with the biggest alignment 584 Types (1) := Elements.Align_Type; 585 -- Possibly complete with an array of bytes. 586 Pad := Elements.Size 587 - unsigned (ABISizeOfType (Target_Data, Elements.Align_Type)); 588 if Pad /= 0 then 589 Types (2) := ArrayType (Int8Type, Pad); 590 Count := 2; 591 else 592 Count := 1; 593 end if; 594 end if; 595 Res := new O_Tnode_Type'(Kind => ON_Union_Type, 596 LLVM => StructType (Types, Count, 0), 597 Dbg => Null_ValueRef, 598 Un_Size => Elements.Size, 599 Un_Main_Field => Elements.Align_Type); 600 601 if Flag_Debug then 602 Add_Dbg_Fields (Elements, Res); 603 end if; 604 Free_Elements (Elements); 605 end Finish_Union_Type; 606 607 --------------------- 608 -- New_Access_Type -- 609 --------------------- 610 611 function New_Access_Type (Dtype : O_Tnode) return O_Tnode is 612 begin 613 if Dtype = O_Tnode_Null then 614 -- LLVM type will be built by New_Type_Decl, so that the name 615 -- can be used for the structure. 616 return new O_Tnode_Type'(Kind => ON_Incomplete_Access_Type, 617 LLVM => Null_TypeRef, 618 Dbg => Null_ValueRef, 619 Acc_Type => O_Tnode_Null); 620 else 621 return new O_Tnode_Type'(Kind => ON_Access_Type, 622 LLVM => PointerType (Get_LLVM_Type (Dtype)), 623 Dbg => Null_ValueRef, 624 Acc_Type => Dtype); 625 end if; 626 end New_Access_Type; 627 628 ------------------------ 629 -- Finish_Access_Type -- 630 ------------------------ 631 632 procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) 633 is 634 Types : TypeRefArray (1 .. 1); 635 begin 636 if Atype.Kind /= ON_Incomplete_Access_Type then 637 -- Not an incomplete access type. 638 raise Program_Error; 639 end if; 640 if Atype.Acc_Type /= O_Tnode_Null then 641 -- Already completed. 642 raise Program_Error; 643 end if; 644 -- Completion 645 Types (1) := Get_LLVM_Type (Dtype); 646 StructSetBody (GetElementType (Atype.LLVM), Types, Types'Length, 0); 647 Atype.Acc_Type := Dtype; 648 649 -- Debug. 650 if Atype.Dbg /= Null_ValueRef then 651 pragma Assert (GetMDNodeNumOperands (Atype.Dbg) = 10); 652 MDNodeReplaceOperandWith (Atype.Dbg, 9, Dtype.Dbg); 653 end if; 654 end Finish_Access_Type; 655 656 -------------------- 657 -- New_Array_Type -- 658 -------------------- 659 660 function Dbg_Array (El_Type : O_Tnode; Len : ValueRef; Atype : O_Tnode) 661 return ValueRef 662 is 663 Rng : ValueRefArray (0 .. 2); 664 Rng_Arr : ValueRefArray (0 .. 0); 665 Vals : ValueRefArray (0 .. 14); 666 begin 667 Rng := (ConstInt (Int32Type, DW_TAG_Subrange_Type, 0), 668 ConstInt (Int64Type, 0, 0), -- Lo 669 Len); -- Count 670 Rng_Arr := (0 => MDNode (Rng, Rng'Length)); 671 Vals := (ConstInt (Int32Type, DW_TAG_Array_Type, 0), 672 Null_ValueRef, 673 Null_ValueRef, -- context 674 Null_ValueRef, 675 ConstInt (Int32Type, 0, 0), -- line 676 Dbg_Size (Atype.LLVM), 677 Dbg_Align (Atype.LLVM), 678 ConstInt (Int32Type, 0, 0), -- Offset 679 ConstInt (Int32Type, 0, 0), -- Flags 680 El_Type.Dbg, -- element type 681 MDNode (Rng_Arr, Rng_Arr'Length), -- subscript 682 ConstInt (Int32Type, 0, 0), 683 Null_ValueRef, 684 Null_ValueRef, 685 Null_ValueRef); -- Runtime lang 686 return MDNode (Vals, Vals'Length); 687 end Dbg_Array; 688 689 function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) 690 return O_Tnode 691 is 692 pragma Unreferenced (Index_Type); 693 Res : O_Tnode; 694 begin 695 Res := new O_Tnode_Type' 696 (Kind => ON_Array_Type, 697 LLVM => ArrayType (Get_LLVM_Type (El_Type), 0), 698 Dbg => Null_ValueRef, 699 Arr_El_Type => El_Type); 700 701 if Flag_Debug then 702 Res.Dbg := Dbg_Array 703 (El_Type, ConstInt (Int64Type, Unsigned_64'Last, 1), Res); 704 end if; 705 706 return Res; 707 end New_Array_Type; 708 709 -------------------------------- 710 -- New_Constrained_Array_Type -- 711 -------------------------------- 712 713 function New_Constrained_Array_Type 714 (Atype : O_Tnode; Length : O_Cnode) return O_Tnode 715 is 716 Res : O_Tnode; 717 Len : constant unsigned := unsigned (ConstIntGetZExtValue (Length.LLVM)); 718 begin 719 Res := new O_Tnode_Type' 720 (Kind => ON_Array_Sub_Type, 721 LLVM => ArrayType (GetElementType (Get_LLVM_Type (Atype)), Len), 722 Dbg => Null_ValueRef, 723 Arr_El_Type => Atype.Arr_El_Type); 724 725 if Flag_Debug then 726 Res.Dbg := Dbg_Array 727 (Atype.Arr_El_Type, 728 ConstInt (Int64Type, Unsigned_64 (Len), 0), Res); 729 end if; 730 731 return Res; 732 end New_Constrained_Array_Type; 733 734 ----------------------- 735 -- New_Unsigned_Type -- 736 ----------------------- 737 738 function Size_To_Llvm (Size : Natural) return TypeRef is 739 Llvm : TypeRef; 740 begin 741 case Size is 742 when 8 => 743 Llvm := Int8Type; 744 when 32 => 745 Llvm := Int32Type; 746 when 64 => 747 Llvm := Int64Type; 748 when others => 749 raise Program_Error; 750 end case; 751 return Llvm; 752 end Size_To_Llvm; 753 754 function New_Unsigned_Type (Size : Natural) return O_Tnode is 755 begin 756 return new O_Tnode_Type'(Kind => ON_Unsigned_Type, 757 LLVM => Size_To_Llvm (Size), 758 Dbg => Null_ValueRef, 759 Scal_Size => Size); 760 end New_Unsigned_Type; 761 762 --------------------- 763 -- New_Signed_Type -- 764 --------------------- 765 766 function New_Signed_Type (Size : Natural) return O_Tnode is 767 begin 768 return new O_Tnode_Type'(Kind => ON_Signed_Type, 769 LLVM => Size_To_Llvm (Size), 770 Dbg => Null_ValueRef, 771 Scal_Size => Size); 772 end New_Signed_Type; 773 774 -------------------- 775 -- New_Float_Type -- 776 -------------------- 777 778 function New_Float_Type return O_Tnode is 779 begin 780 return new O_Tnode_Type'(Kind => ON_Float_Type, 781 LLVM => DoubleType, 782 Dbg => Null_ValueRef, 783 Scal_Size => 64); 784 end New_Float_Type; 785 786 procedure Dbg_Add_Enumeration (Id : O_Ident; Val : Unsigned_64) is 787 Vals : ValueRefArray (0 .. 2); 788 begin 789 Vals := (ConstInt (Int32Type, DW_TAG_Enumerator, 0), 790 MDString (Id), 791 ConstInt (Int64Type, Val, 0)); 792 -- FIXME: make it local to List ? 793 Append (Enum_Nodes, MDNode (Vals, Vals'Length)); 794 end Dbg_Add_Enumeration; 795 796 ---------------------- 797 -- New_Boolean_Type -- 798 ---------------------- 799 800 procedure New_Boolean_Type 801 (Res : out O_Tnode; 802 False_Id : O_Ident; False_E : out O_Cnode; 803 True_Id : O_Ident; True_E : out O_Cnode) 804 is 805 begin 806 Res := new O_Tnode_Type'(Kind => ON_Boolean_Type, 807 LLVM => Int1Type, 808 Dbg => Null_ValueRef, 809 Scal_Size => 1); 810 False_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 0, 0), 811 Ctype => Res); 812 True_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 1, 0), 813 Ctype => Res); 814 if Flag_Debug then 815 Dbg_Add_Enumeration (False_Id, 0); 816 Dbg_Add_Enumeration (True_Id, 1); 817 end if; 818 end New_Boolean_Type; 819 820 --------------------- 821 -- Start_Enum_Type -- 822 --------------------- 823 824 procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) 825 is 826 LLVM : constant TypeRef := Size_To_Llvm (Size); 827 begin 828 List := (LLVM => LLVM, 829 Num => 0, 830 Etype => new O_Tnode_Type'(Kind => ON_Enum_Type, 831 LLVM => LLVM, 832 Scal_Size => Size, 833 Dbg => Null_ValueRef)); 834 835 end Start_Enum_Type; 836 837 ---------------------- 838 -- New_Enum_Literal -- 839 ---------------------- 840 841 procedure New_Enum_Literal 842 (List : in out O_Enum_List; Ident : O_Ident; Res : out O_Cnode) 843 is 844 begin 845 Res := O_Cnode'(LLVM => ConstInt (List.LLVM, Unsigned_64 (List.Num), 0), 846 Ctype => List.Etype); 847 if Flag_Debug then 848 Dbg_Add_Enumeration (Ident, Unsigned_64 (List.Num)); 849 end if; 850 851 List.Num := List.Num + 1; 852 end New_Enum_Literal; 853 854 ---------------------- 855 -- Finish_Enum_Type -- 856 ---------------------- 857 858 procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is 859 begin 860 Res := List.Etype; 861 end Finish_Enum_Type; 862 863 ------------------------ 864 -- New_Signed_Literal -- 865 ------------------------ 866 867 function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) 868 return O_Cnode 869 is 870 function To_Unsigned_64 is new Ada.Unchecked_Conversion 871 (Integer_64, Unsigned_64); 872 begin 873 return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype), 874 To_Unsigned_64 (Value), 1), 875 Ctype => Ltype); 876 end New_Signed_Literal; 877 878 -------------------------- 879 -- New_Unsigned_Literal -- 880 -------------------------- 881 882 function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) 883 return O_Cnode is 884 begin 885 return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype), Value, 0), 886 Ctype => Ltype); 887 end New_Unsigned_Literal; 888 889 ----------------------- 890 -- New_Float_Literal -- 891 ----------------------- 892 893 function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) 894 return O_Cnode is 895 begin 896 return O_Cnode'(LLVM => ConstReal (Get_LLVM_Type (Ltype), 897 Interfaces.C.double (Value)), 898 Ctype => Ltype); 899 end New_Float_Literal; 900 901 --------------------- 902 -- New_Null_Access -- 903 --------------------- 904 905 function New_Null_Access (Ltype : O_Tnode) return O_Cnode is 906 begin 907 return O_Cnode'(LLVM => ConstNull (Get_LLVM_Type (Ltype)), 908 Ctype => Ltype); 909 end New_Null_Access; 910 911 ----------------------- 912 -- Start_Record_Aggr -- 913 ----------------------- 914 915 procedure Start_Record_Aggr 916 (List : out O_Record_Aggr_List; 917 Atype : O_Tnode) 918 is 919 Llvm : constant TypeRef := Get_LLVM_Type (Atype); 920 begin 921 List := 922 (Len => 0, 923 Vals => new ValueRefArray (1 .. CountStructElementTypes (Llvm)), 924 Atype => Atype); 925 end Start_Record_Aggr; 926 927 ------------------------ 928 -- New_Record_Aggr_El -- 929 ------------------------ 930 931 procedure New_Record_Aggr_El 932 (List : in out O_Record_Aggr_List; Value : O_Cnode) 933 is 934 begin 935 List.Len := List.Len + 1; 936 List.Vals (List.Len) := Value.LLVM; 937 end New_Record_Aggr_El; 938 939 ------------------------ 940 -- Finish_Record_Aggr -- 941 ------------------------ 942 943 procedure Finish_Record_Aggr 944 (List : in out O_Record_Aggr_List; 945 Res : out O_Cnode) 946 is 947 V : ValueRef; 948 begin 949 if List.Atype.Kind = ON_Incomplete_Record_Type then 950 V := ConstNamedStruct (Get_LLVM_Type (List.Atype), 951 List.Vals.all, List.Len); 952 else 953 V := ConstStruct (List.Vals.all, List.Len, 0); 954 end if; 955 Res := (LLVM => V, Ctype => List.Atype); 956 Free (List.Vals); 957 end Finish_Record_Aggr; 958 959 ---------------------- 960 -- Start_Array_Aggr -- 961 ---------------------- 962 963 procedure Start_Array_Aggr 964 (List : out O_Array_Aggr_List; Atype : O_Tnode; Len : Unsigned_32) 965 is 966 Llvm : constant TypeRef := Get_LLVM_Type (Atype); 967 begin 968 List := (Len => 0, 969 Vals => new ValueRefArray (1 .. unsigned (Len)), 970 El_Type => GetElementType (Llvm), 971 Atype => Atype); 972 end Start_Array_Aggr; 973 974 ----------------------- 975 -- New_Array_Aggr_El -- 976 ----------------------- 977 978 procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; 979 Value : O_Cnode) 980 is 981 begin 982 List.Len := List.Len + 1; 983 List.Vals (List.Len) := Value.LLVM; 984 end New_Array_Aggr_El; 985 986 ----------------------- 987 -- Finish_Array_Aggr -- 988 ----------------------- 989 990 procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; 991 Res : out O_Cnode) 992 is 993 begin 994 Res := (LLVM => ConstArray (List.El_Type, 995 List.Vals.all, List.Len), 996 Ctype => List.Atype); 997 Free (List.Vals); 998 end Finish_Array_Aggr; 999 1000 -------------------- 1001 -- New_Union_Aggr -- 1002 -------------------- 1003 1004 function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) 1005 return O_Cnode 1006 is 1007 Values : ValueRefArray (1 .. 2); 1008 Count : unsigned; 1009 Size : constant unsigned := 1010 unsigned (ABISizeOfType (Target_Data, Field.Utype)); 1011 1012 begin 1013 Values (1) := Value.LLVM; 1014 if Size < Atype.Un_Size then 1015 Values (2) := GetUndef (ArrayType (Int8Type, Atype.Un_Size - Size)); 1016 Count := 2; 1017 else 1018 Count := 1; 1019 end if; 1020 1021 -- If `FIELD` is the main field of the union, create a struct using 1022 -- the same type as the union (and possibly pad). 1023 if Field.Utype = Atype.Un_Main_Field then 1024 return O_Cnode' 1025 (LLVM => ConstNamedStruct (Atype.LLVM, Values, Count), 1026 Ctype => Atype); 1027 else 1028 -- Create an on-the-fly record. 1029 return O_Cnode'(LLVM => ConstStruct (Values, Count, 0), 1030 Ctype => Atype); 1031 end if; 1032 end New_Union_Aggr; 1033 1034 ----------------------- 1035 -- New_Default_Value -- 1036 ----------------------- 1037 1038 function New_Default_Value (Ltype : O_Tnode) return O_Cnode is 1039 begin 1040 return O_Cnode'(LLVM => ConstNull (Ltype.LLVM), 1041 Ctype => Ltype); 1042 end New_Default_Value; 1043 1044 ---------------- 1045 -- New_Sizeof -- 1046 ---------------- 1047 1048 -- Return VAL with type RTYPE (either unsigned or access) 1049 function Const_To_Cnode (Rtype : O_Tnode; Val : Unsigned_64) return O_Cnode 1050 is 1051 Tmp : ValueRef; 1052 begin 1053 case Rtype.Kind is 1054 when ON_Scalar_Types => 1055 -- Well, unsigned in fact. 1056 return O_Cnode'(LLVM => ConstInt (Rtype.LLVM, Val, 0), 1057 Ctype => Rtype); 1058 when ON_Access_Type => 1059 Tmp := ConstInt (Int64Type, Val, 0); 1060 return O_Cnode'(LLVM => ConstIntToPtr (Tmp, Rtype.LLVM), 1061 Ctype => Rtype); 1062 when others => 1063 raise Program_Error; 1064 end case; 1065 end Const_To_Cnode; 1066 1067 function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is 1068 begin 1069 return Const_To_Cnode 1070 (Rtype, ABISizeOfType (Target_Data, Get_LLVM_Type (Atype))); 1071 end New_Sizeof; 1072 1073 ----------------- 1074 -- New_Alignof -- 1075 ----------------- 1076 1077 function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is 1078 begin 1079 return Const_To_Cnode 1080 (Rtype, 1081 Unsigned_64 1082 (ABIAlignmentOfType (Target_Data, Get_LLVM_Type (Atype)))); 1083 end New_Alignof; 1084 1085 ------------------ 1086 -- New_Offsetof -- 1087 ------------------ 1088 1089 function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) 1090 return O_Cnode is 1091 begin 1092 return Const_To_Cnode 1093 (Rtype, 1094 OffsetOfElement (Target_Data, 1095 Get_LLVM_Type (Atype), 1096 Unsigned_32 (Field.Index))); 1097 end New_Offsetof; 1098 1099 ---------------------------- 1100 -- New_Subprogram_Address -- 1101 ---------------------------- 1102 1103 function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) 1104 return O_Cnode is 1105 begin 1106 return O_Cnode' 1107 (LLVM => ConstBitCast (Subprg.LLVM, Get_LLVM_Type (Atype)), 1108 Ctype => Atype); 1109 end New_Subprogram_Address; 1110 1111 ------------------------ 1112 -- New_Global_Address -- 1113 ------------------------ 1114 1115 function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) 1116 return O_Cnode is 1117 begin 1118 return New_Global_Unchecked_Address (Lvalue, Atype); 1119 end New_Global_Address; 1120 1121 ---------------------------------- 1122 -- New_Global_Unchecked_Address -- 1123 ---------------------------------- 1124 1125 function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) 1126 return O_Cnode is 1127 begin 1128 return O_Cnode'(LLVM => ConstBitCast (Lvalue.LLVM, 1129 Get_LLVM_Type (Atype)), 1130 Ctype => Atype); 1131 end New_Global_Unchecked_Address; 1132 1133 ------------- 1134 -- New_Lit -- 1135 ------------- 1136 1137 function New_Lit (Lit : O_Cnode) return O_Enode is 1138 begin 1139 return O_Enode'(LLVM => Lit.LLVM, 1140 Etype => Lit.Ctype); 1141 end New_Lit; 1142 1143 ---------------- 1144 -- New_Global -- 1145 ---------------- 1146 1147 function New_Global (Decl : O_Dnode) return O_Gnode is 1148 begin 1149 -- Can be used to build global objects, even when Unreach is set. 1150 -- As this doesn't generate code, this is ok. 1151 case Decl.Kind is 1152 when ON_Const_Decl 1153 | ON_Var_Decl => 1154 return O_Gnode'(LLVM => Decl.LLVM, 1155 Ltype => Decl.Dtype); 1156 when others => 1157 raise Program_Error; 1158 end case; 1159 end New_Global; 1160 1161 ------------------- 1162 -- New_Dyadic_Op -- 1163 ------------------- 1164 1165 function New_Smod (L, R : ValueRef; Res_Type : TypeRef) 1166 return ValueRef 1167 is 1168 Cond : ValueRef; 1169 Br : ValueRef; 1170 pragma Unreferenced (Br); 1171 1172 -- The result of 'L rem R'. 1173 Rm : ValueRef; 1174 1175 -- Rm + R 1176 Rm_Plus_R : ValueRef; 1177 1178 -- The result of 'L xor R'. 1179 R_Xor : ValueRef; 1180 1181 Adj : ValueRef; 1182 Phi : ValueRef; 1183 1184 -- Basic basic for the non-overflow branch 1185 Normal_Bb : constant BasicBlockRef := 1186 AppendBasicBlock (Cur_Func, Empty_Cstring); 1187 1188 Adjust_Bb : constant BasicBlockRef := 1189 AppendBasicBlock (Cur_Func, Empty_Cstring); 1190 1191 -- Basic block after the result 1192 Next_Bb : constant BasicBlockRef := 1193 AppendBasicBlock (Cur_Func, Empty_Cstring); 1194 1195 Vals : ValueRefArray (1 .. 3); 1196 BBs : BasicBlockRefArray (1 .. 3); 1197 begin 1198 -- Avoid overflow with -1: 1199 -- if R = -1 then 1200 -- result := 0; 1201 -- else 1202 -- ... 1203 Cond := BuildICmp 1204 (Builder, IntEQ, R, ConstAllOnes (Res_Type), Empty_Cstring); 1205 Br := BuildCondBr (Builder, Cond, Next_Bb, Normal_Bb); 1206 Vals (1) := ConstNull (Res_Type); 1207 BBs (1) := GetInsertBlock (Builder); 1208 1209 -- Rm := Left rem Right 1210 PositionBuilderAtEnd (Builder, Normal_Bb); 1211 Rm := BuildSRem (Builder, L, R, Empty_Cstring); 1212 1213 -- if Rm = 0 then 1214 -- result := 0 1215 -- else 1216 Cond := BuildICmp 1217 (Builder, IntEQ, Rm, ConstNull (Res_Type), Empty_Cstring); 1218 Br := BuildCondBr (Builder, Cond, Next_Bb, Adjust_Bb); 1219 Vals (2) := ConstNull (Res_Type); 1220 BBs (2) := Normal_Bb; 1221 1222 -- if (L xor R) < 0 then 1223 -- result := Rm + R 1224 -- else 1225 -- result := Rm; 1226 -- end if; 1227 PositionBuilderAtEnd (Builder, Adjust_Bb); 1228 R_Xor := BuildXor (Builder, L, R, Empty_Cstring); 1229 Cond := BuildICmp 1230 (Builder, IntSLT, R_Xor, ConstNull (Res_Type), Empty_Cstring); 1231 Rm_Plus_R := BuildAdd (Builder, Rm, R, Empty_Cstring); 1232 Adj := BuildSelect (Builder, Cond, Rm_Plus_R, Rm, Empty_Cstring); 1233 Br := BuildBr (Builder, Next_Bb); 1234 Vals (3) := Adj; 1235 BBs (3) := Adjust_Bb; 1236 1237 -- The Phi node 1238 PositionBuilderAtEnd (Builder, Next_Bb); 1239 Phi := BuildPhi (Builder, Res_Type, Empty_Cstring); 1240 AddIncoming (Phi, Vals, BBs, Vals'Length); 1241 1242 return Phi; 1243 end New_Smod; 1244 1245 type Dyadic_Builder_Acc is access 1246 function (Builder : BuilderRef; 1247 LHS : ValueRef; RHS : ValueRef; Name : Cstring) 1248 return ValueRef; 1249 pragma Convention (C, Dyadic_Builder_Acc); 1250 1251 function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) 1252 return O_Enode 1253 is 1254 Build : Dyadic_Builder_Acc := null; 1255 Res : ValueRef := Null_ValueRef; 1256 begin 1257 if Unreach then 1258 return O_Enode'(LLVM => Null_ValueRef, Etype => Left.Etype); 1259 end if; 1260 1261 case Left.Etype.Kind is 1262 when ON_Integer_Types => 1263 case Kind is 1264 when ON_And => 1265 Build := BuildAnd'Access; 1266 when ON_Or => 1267 Build := BuildOr'Access; 1268 when ON_Xor => 1269 Build := BuildXor'Access; 1270 1271 when ON_Add_Ov => 1272 Build := BuildAdd'Access; 1273 when ON_Sub_Ov => 1274 Build := BuildSub'Access; 1275 when ON_Mul_Ov => 1276 Build := BuildMul'Access; 1277 1278 when ON_Div_Ov => 1279 case Left.Etype.Kind is 1280 when ON_Unsigned_Type => 1281 Build := BuildUDiv'Access; 1282 when ON_Signed_Type => 1283 Build := BuildSDiv'Access; 1284 when others => 1285 null; 1286 end case; 1287 1288 when ON_Mod_Ov 1289 | ON_Rem_Ov => -- FIXME... 1290 case Left.Etype.Kind is 1291 when ON_Unsigned_Type => 1292 Build := BuildURem'Access; 1293 when ON_Signed_Type => 1294 if Kind = ON_Rem_Ov then 1295 Build := BuildSRem'Access; 1296 else 1297 Res := New_Smod 1298 (Left.LLVM, Right.LLVM, Left.Etype.LLVM); 1299 end if; 1300 when others => 1301 null; 1302 end case; 1303 end case; 1304 1305 when ON_Float_Type => 1306 case Kind is 1307 when ON_Add_Ov => 1308 Build := BuildFAdd'Access; 1309 when ON_Sub_Ov => 1310 Build := BuildFSub'Access; 1311 when ON_Mul_Ov => 1312 Build := BuildFMul'Access; 1313 when ON_Div_Ov => 1314 Build := BuildFDiv'Access; 1315 1316 when others => 1317 null; 1318 end case; 1319 1320 when others => 1321 null; 1322 end case; 1323 1324 if Build /= null then 1325 pragma Assert (Res = Null_ValueRef); 1326 Res := Build.all (Builder, Left.LLVM, Right.LLVM, Empty_Cstring); 1327 end if; 1328 1329 if Res = Null_ValueRef then 1330 raise Program_Error with "Unimplemented New_Dyadic_Op " 1331 & ON_Dyadic_Op_Kind'Image (Kind) 1332 & " for type " 1333 & ON_Type_Kind'Image (Left.Etype.Kind); 1334 end if; 1335 1336 Set_Insn_Dbg (Res); 1337 1338 return O_Enode'(LLVM => Res, Etype => Left.Etype); 1339 end New_Dyadic_Op; 1340 1341 -------------------- 1342 -- New_Monadic_Op -- 1343 -------------------- 1344 1345 function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) 1346 return O_Enode 1347 is 1348 Res : ValueRef; 1349 begin 1350 if Unreach then 1351 return O_Enode'(LLVM => Null_ValueRef, Etype => Operand.Etype); 1352 end if; 1353 1354 case Operand.Etype.Kind is 1355 when ON_Integer_Types => 1356 case Kind is 1357 when ON_Not => 1358 Res := BuildNot (Builder, Operand.LLVM, Empty_Cstring); 1359 when ON_Neg_Ov => 1360 Res := BuildNeg (Builder, Operand.LLVM, Empty_Cstring); 1361 when ON_Abs_Ov => 1362 Res := BuildSelect 1363 (Builder, 1364 BuildICmp (Builder, IntSLT, 1365 Operand.LLVM, 1366 ConstInt (Get_LLVM_Type (Operand.Etype), 0, 0), 1367 Empty_Cstring), 1368 BuildNeg (Builder, Operand.LLVM, Empty_Cstring), 1369 Operand.LLVM, 1370 Empty_Cstring); 1371 end case; 1372 when ON_Float_Type => 1373 case Kind is 1374 when ON_Not => 1375 raise Program_Error; 1376 when ON_Neg_Ov => 1377 Res := BuildFNeg (Builder, Operand.LLVM, Empty_Cstring); 1378 when ON_Abs_Ov => 1379 Res := BuildSelect 1380 (Builder, 1381 BuildFCmp (Builder, RealOLT, 1382 Operand.LLVM, 1383 ConstReal (Get_LLVM_Type (Operand.Etype), 0.0), 1384 Empty_Cstring), 1385 BuildFNeg (Builder, Operand.LLVM, Empty_Cstring), 1386 Operand.LLVM, 1387 Empty_Cstring); 1388 end case; 1389 when others => 1390 raise Program_Error; 1391 end case; 1392 1393 if IsAInstruction (Res) /= Null_ValueRef then 1394 Set_Insn_Dbg (Res); 1395 end if; 1396 1397 return O_Enode'(LLVM => Res, Etype => Operand.Etype); 1398 end New_Monadic_Op; 1399 1400 -------------------- 1401 -- New_Compare_Op -- 1402 -------------------- 1403 1404 type Compare_Op_Entry is record 1405 Signed_Pred : IntPredicate; 1406 Unsigned_Pred : IntPredicate; 1407 Real_Pred : RealPredicate; 1408 end record; 1409 1410 type Compare_Op_Table_Type is array (ON_Compare_Op_Kind) of 1411 Compare_Op_Entry; 1412 1413 Compare_Op_Table : constant Compare_Op_Table_Type := 1414 (ON_Eq => (IntEQ, IntEQ, RealOEQ), 1415 ON_Neq => (IntNE, IntNE, RealONE), 1416 ON_Le => (IntSLE, IntULE, RealOLE), 1417 ON_Lt => (IntSLT, IntULT, RealOLT), 1418 ON_Ge => (IntSGE, IntUGE, RealOGE), 1419 ON_Gt => (IntSGT, IntUGT, RealOGT)); 1420 1421 function New_Compare_Op 1422 (Kind : ON_Compare_Op_Kind; 1423 Left, Right : O_Enode; 1424 Ntype : O_Tnode) 1425 return O_Enode 1426 is 1427 Res : ValueRef; 1428 begin 1429 if Unreach then 1430 return O_Enode'(LLVM => Null_ValueRef, Etype => Ntype); 1431 end if; 1432 1433 case Left.Etype.Kind is 1434 when ON_Unsigned_Type 1435 | ON_Boolean_Type 1436 | ON_Enum_Type 1437 | ON_Access_Type 1438 | ON_Incomplete_Access_Type => 1439 Res := BuildICmp (Builder, Compare_Op_Table (Kind).Unsigned_Pred, 1440 Left.LLVM, Right.LLVM, Empty_Cstring); 1441 when ON_Signed_Type => 1442 Res := BuildICmp (Builder, Compare_Op_Table (Kind).Signed_Pred, 1443 Left.LLVM, Right.LLVM, Empty_Cstring); 1444 when ON_Float_Type => 1445 Res := BuildFCmp (Builder, Compare_Op_Table (Kind).Real_Pred, 1446 Left.LLVM, Right.LLVM, Empty_Cstring); 1447 when ON_Array_Type 1448 | ON_Array_Sub_Type 1449 | ON_Record_Type 1450 | ON_Incomplete_Record_Type 1451 | ON_Union_Type 1452 | ON_No_Type => 1453 raise Program_Error; 1454 end case; 1455 Set_Insn_Dbg (Res); 1456 return O_Enode'(LLVM => Res, Etype => Ntype); 1457 end New_Compare_Op; 1458 1459 ------------------------- 1460 -- New_Indexed_Element -- 1461 ------------------------- 1462 1463 function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) return O_Lnode 1464 is 1465 Idx : constant ValueRefArray (1 .. 2) := 1466 (ConstInt (Int32Type, 0, 0), 1467 Index.LLVM); 1468 Tmp : ValueRef; 1469 begin 1470 if Unreach then 1471 Tmp := Null_ValueRef; 1472 else 1473 Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring); 1474 end if; 1475 return O_Lnode'(Direct => False, 1476 LLVM => Tmp, 1477 Ltype => Arr.Ltype.Arr_El_Type); 1478 end New_Indexed_Element; 1479 1480 --------------- 1481 -- New_Slice -- 1482 --------------- 1483 1484 function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) 1485 return O_Lnode 1486 is 1487 Idx : constant ValueRefArray (1 .. 2) := 1488 (ConstInt (Int32Type, 0, 0), 1489 Index.LLVM); 1490 Tmp : ValueRef; 1491 begin 1492 if Unreach then 1493 Tmp := Null_ValueRef; 1494 else 1495 Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring); 1496 Tmp := BuildBitCast 1497 (Builder, Tmp, PointerType (Get_LLVM_Type (Res_Type)), 1498 Empty_Cstring); 1499 end if; 1500 return O_Lnode'(Direct => False, LLVM => Tmp, Ltype => Res_Type); 1501 end New_Slice; 1502 1503 -------------------------- 1504 -- New_Selected_Element -- 1505 -------------------------- 1506 1507 function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) 1508 return O_Lnode 1509 is 1510 Res : ValueRef; 1511 begin 1512 if Unreach then 1513 Res := Null_ValueRef; 1514 else 1515 case El.Kind is 1516 when OF_Record => 1517 declare 1518 Idx : constant ValueRefArray (1 .. 2) := 1519 (ConstInt (Int32Type, 0, 0), 1520 ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); 1521 begin 1522 Res := BuildGEP (Builder, Rec.LLVM, Idx, 2, Empty_Cstring); 1523 end; 1524 when OF_Union => 1525 Res := BuildBitCast (Builder, 1526 Rec.LLVM, El.Ptr_Type, Empty_Cstring); 1527 when OF_None => 1528 raise Program_Error; 1529 end case; 1530 end if; 1531 return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); 1532 end New_Selected_Element; 1533 1534 function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) 1535 return O_Gnode 1536 is 1537 Res : ValueRef; 1538 begin 1539 case El.Kind is 1540 when OF_Record => 1541 declare 1542 Idx : constant ValueRefArray (1 .. 2) := 1543 (ConstInt (Int32Type, 0, 0), 1544 ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); 1545 begin 1546 Res := ConstGEP (Rec.LLVM, Idx, 2); 1547 end; 1548 when OF_Union => 1549 Res := ConstBitCast (Rec.LLVM, El.Ptr_Type); 1550 when OF_None => 1551 raise Program_Error; 1552 end case; 1553 return O_Gnode'(LLVM => Res, Ltype => El.Ftype); 1554 end New_Global_Selected_Element; 1555 1556 ------------------------ 1557 -- New_Access_Element -- 1558 ------------------------ 1559 1560 function New_Access_Element (Acc : O_Enode) return O_Lnode 1561 is 1562 Res : ValueRef; 1563 begin 1564 case Acc.Etype.Kind is 1565 when ON_Access_Type => 1566 Res := Acc.LLVM; 1567 when ON_Incomplete_Access_Type => 1568 -- Unwrap the structure 1569 declare 1570 Idx : constant ValueRefArray (1 .. 2) := 1571 (ConstInt (Int32Type, 0, 0), ConstInt (Int32Type, 0, 0)); 1572 begin 1573 Res := BuildGEP (Builder, Acc.LLVM, Idx, 2, Empty_Cstring); 1574 end; 1575 when others => 1576 raise Program_Error; 1577 end case; 1578 return O_Lnode'(Direct => False, 1579 LLVM => Res, 1580 Ltype => Acc.Etype.Acc_Type); 1581 end New_Access_Element; 1582 1583 -------------------- 1584 -- New_Convert_Ov -- 1585 -------------------- 1586 1587 function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode 1588 is 1589 Res : ValueRef := Null_ValueRef; 1590 begin 1591 if Rtype = Val.Etype then 1592 -- Convertion to itself: nothing to do. 1593 return Val; 1594 end if; 1595 if Rtype.LLVM = Val.Etype.LLVM then 1596 -- Same underlying LLVM type: no conversion but keep new type in 1597 -- case of change of sign. 1598 return O_Enode'(LLVM => Val.LLVM, Etype => Rtype); 1599 end if; 1600 if Unreach then 1601 return O_Enode'(LLVM => Val.LLVM, Etype => Rtype); 1602 end if; 1603 1604 case Rtype.Kind is 1605 when ON_Integer_Types => 1606 case Val.Etype.Kind is 1607 when ON_Integer_Types => 1608 -- Int to Int 1609 if Val.Etype.Scal_Size > Rtype.Scal_Size then 1610 -- Truncate 1611 Res := BuildTrunc 1612 (Builder, Val.LLVM, Get_LLVM_Type (Rtype), 1613 Empty_Cstring); 1614 elsif Val.Etype.Scal_Size < Rtype.Scal_Size then 1615 if Val.Etype.Kind = ON_Signed_Type then 1616 Res := BuildSExt 1617 (Builder, Val.LLVM, Get_LLVM_Type (Rtype), 1618 Empty_Cstring); 1619 else 1620 -- Unsigned, enum 1621 Res := BuildZExt 1622 (Builder, Val.LLVM, Get_LLVM_Type (Rtype), 1623 Empty_Cstring); 1624 end if; 1625 else 1626 Res := BuildBitCast 1627 (Builder, Val.LLVM, Get_LLVM_Type (Rtype), 1628 Empty_Cstring); 1629 end if; 1630 1631 when ON_Float_Type => 1632 -- Float to Int 1633 if Rtype.Kind = ON_Signed_Type then 1634 -- FPtoSI rounds toward zero, so we need to add 1635 -- copysign (0.5, x). 1636 declare 1637 V : ValueRef; 1638 begin 1639 V := BuildCall (Builder, Copysign_Fun, 1640 (Fp_0_5, Val.LLVM), 2, Empty_Cstring); 1641 V := BuildFAdd (Builder, Val.LLVM, V, Empty_Cstring); 1642 Res := BuildFPToSI 1643 (Builder, V, Get_LLVM_Type (Rtype), Empty_Cstring); 1644 end; 1645 end if; 1646 1647 when others => 1648 null; 1649 end case; 1650 1651 when ON_Float_Type => 1652 if Val.Etype.Kind = ON_Signed_Type then 1653 Res := BuildSIToFP 1654 (Builder, Val.LLVM, Get_LLVM_Type (Rtype), 1655 Empty_Cstring); 1656 elsif Val.Etype.Kind = ON_Unsigned_Type then 1657 Res := BuildUIToFP 1658 (Builder, Val.LLVM, Get_LLVM_Type (Rtype), 1659 Empty_Cstring); 1660 end if; 1661 1662 when ON_Access_Type 1663 | ON_Incomplete_Access_Type => 1664 if GetTypeKind (TypeOf (Val.LLVM)) /= PointerTypeKind then 1665 raise Program_Error; 1666 end if; 1667 Res := BuildBitCast (Builder, Val.LLVM, Get_LLVM_Type (Rtype), 1668 Empty_Cstring); 1669 1670 when others => 1671 null; 1672 end case; 1673 if Res /= Null_ValueRef then 1674 -- FIXME: only if insn was generated 1675 -- Set_Insn_Dbg (Res); 1676 return O_Enode'(LLVM => Res, Etype => Rtype); 1677 else 1678 raise Program_Error with "New_Convert: not implemented for " 1679 & ON_Type_Kind'Image (Val.Etype.Kind) 1680 & " -> " 1681 & ON_Type_Kind'Image (Rtype.Kind); 1682 end if; 1683 end New_Convert; 1684 1685 function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is 1686 begin 1687 return New_Convert (Val, Rtype); 1688 end New_Convert_Ov; 1689 1690 ----------------- 1691 -- New_Address -- 1692 ----------------- 1693 1694 function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is 1695 begin 1696 return New_Unchecked_Address (Lvalue, Atype); 1697 end New_Address; 1698 1699 --------------------------- 1700 -- New_Unchecked_Address -- 1701 --------------------------- 1702 1703 function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) 1704 return O_Enode 1705 is 1706 Res : ValueRef; 1707 begin 1708 if Unreach then 1709 Res := Null_ValueRef; 1710 else 1711 Res := BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype), 1712 Empty_Cstring); 1713 end if; 1714 return O_Enode'(LLVM => Res, Etype => Atype); 1715 end New_Unchecked_Address; 1716 1717 --------------- 1718 -- New_Value -- 1719 --------------- 1720 1721 function New_Value (Lvalue : O_Lnode) return O_Enode 1722 is 1723 Res : ValueRef; 1724 begin 1725 if Unreach then 1726 Res := Null_ValueRef; 1727 else 1728 Res := Lvalue.LLVM; 1729 if not Lvalue.Direct then 1730 Res := BuildLoad (Builder, Res, Empty_Cstring); 1731 Set_Insn_Dbg (Res); 1732 end if; 1733 end if; 1734 return O_Enode'(LLVM => Res, Etype => Lvalue.Ltype); 1735 end New_Value; 1736 1737 ------------------- 1738 -- New_Obj_Value -- 1739 ------------------- 1740 1741 function New_Obj_Value (Obj : O_Dnode) return O_Enode is 1742 begin 1743 return New_Value (New_Obj (Obj)); 1744 end New_Obj_Value; 1745 1746 ------------- 1747 -- New_Obj -- 1748 ------------- 1749 1750 function New_Obj (Obj : O_Dnode) return O_Lnode is 1751 begin 1752 -- Can be used to build global objects, even when Unreach is set. 1753 -- As this doesn't generate code, this is ok. 1754 case Obj.Kind is 1755 when ON_Const_Decl 1756 | ON_Var_Decl 1757 | ON_Local_Decl => 1758 return O_Lnode'(Direct => False, 1759 LLVM => Obj.LLVM, 1760 Ltype => Obj.Dtype); 1761 1762 when ON_Interface_Decl => 1763 if Flag_Debug then 1764 -- The argument was allocated. 1765 return O_Lnode'(Direct => False, 1766 LLVM => Obj.Inter.Ival, 1767 Ltype => Obj.Dtype); 1768 else 1769 return O_Lnode'(Direct => True, 1770 LLVM => Obj.Inter.Ival, 1771 Ltype => Obj.Dtype); 1772 end if; 1773 1774 when ON_Type_Decl 1775 | ON_Completed_Type_Decl 1776 | ON_Subprg_Decl 1777 | ON_No_Decl => 1778 raise Program_Error; 1779 end case; 1780 end New_Obj; 1781 1782 ---------------- 1783 -- New_Alloca -- 1784 ---------------- 1785 1786 function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode 1787 is 1788 Res : ValueRef; 1789 begin 1790 if Unreach then 1791 Res := Null_ValueRef; 1792 else 1793 if Cur_Declare_Block.Stack_Value = Null_ValueRef 1794 and then Cur_Declare_Block.Prev /= null 1795 then 1796 -- Save stack pointer at entry of block 1797 declare 1798 First_Insn : ValueRef; 1799 Bld : BuilderRef; 1800 begin 1801 First_Insn := GetFirstInstruction (Cur_Declare_Block.Stmt_Bb); 1802 if First_Insn = Null_ValueRef then 1803 -- Alloca is the first instruction, save the stack now. 1804 Bld := Builder; 1805 else 1806 -- There are instructions before alloca, insert the save 1807 -- at the beginning. 1808 PositionBuilderBefore (Extra_Builder, First_Insn); 1809 Bld := Extra_Builder; 1810 end if; 1811 1812 Cur_Declare_Block.Stack_Value := 1813 BuildCall (Bld, Stacksave_Fun, 1814 (1 .. 0 => Null_ValueRef), 0, Empty_Cstring); 1815 end; 1816 end if; 1817 1818 Res := BuildArrayAlloca 1819 (Builder, Int8Type, Size.LLVM, Empty_Cstring); 1820 Set_Insn_Dbg (Res); 1821 1822 Res := BuildBitCast 1823 (Builder, Res, Get_LLVM_Type (Rtype), Empty_Cstring); 1824 Set_Insn_Dbg (Res); 1825 end if; 1826 1827 return O_Enode'(LLVM => Res, Etype => Rtype); 1828 end New_Alloca; 1829 1830 ------------------- 1831 -- New_Type_Decl -- 1832 ------------------- 1833 1834 function Add_Dbg_Basic_Type (Id : O_Ident; Btype : O_Tnode; Enc : Natural) 1835 return ValueRef 1836 is 1837 Vals : ValueRefArray (0 .. 9); 1838 begin 1839 Vals := (ConstInt (Int32Type, DW_TAG_Base_Type, 0), 1840 Null_ValueRef, 1841 Null_ValueRef, 1842 MDString (Id), 1843 ConstInt (Int32Type, 0, 0), -- linenum 1844 Dbg_Size (Btype.LLVM), 1845 Dbg_Align (Btype.LLVM), 1846 ConstInt (Int32Type, 0, 0), -- Offset 1847 ConstInt (Int32Type, 0, 0), -- Flags 1848 ConstInt (Int32Type, Unsigned_64 (Enc), 0)); -- Encoding 1849 return MDNode (Vals, Vals'Length); 1850 end Add_Dbg_Basic_Type; 1851 1852 function Add_Dbg_Enum_Type (Id : O_Ident; Etype : O_Tnode) return ValueRef 1853 is 1854 Vals : ValueRefArray (0 .. 14); 1855 begin 1856 Vals := (ConstInt (Int32Type, DW_TAG_Enumeration_Type, 0), 1857 Dbg_Current_Filedir, 1858 Null_ValueRef, -- context 1859 MDString (Id), 1860 Dbg_Line, 1861 Dbg_Size (Etype.LLVM), 1862 Dbg_Align (Etype.LLVM), 1863 ConstInt (Int32Type, 0, 0), -- Offset 1864 ConstInt (Int32Type, 0, 0), -- Flags 1865 Null_ValueRef, 1866 Get_Value (Enum_Nodes), 1867 ConstInt (Int32Type, 0, 0), 1868 Null_ValueRef, 1869 Null_ValueRef, 1870 Null_ValueRef); -- Runtime lang 1871 Clear (Enum_Nodes); 1872 return MDNode (Vals, Vals'Length); 1873 end Add_Dbg_Enum_Type; 1874 1875 function Add_Dbg_Pointer_Type 1876 (Id : O_Ident; Ptype : O_Tnode; Designated_Dbg : ValueRef) 1877 return ValueRef 1878 is 1879 Vals : ValueRefArray (0 .. 9); 1880 begin 1881 Vals := (ConstInt (Int32Type, DW_TAG_Pointer_Type, 0), 1882 Dbg_Current_Filedir, 1883 Null_ValueRef, -- context 1884 MDString (Id), 1885 Dbg_Line, 1886 Dbg_Size (Ptype.LLVM), 1887 Dbg_Align (Ptype.LLVM), 1888 ConstInt (Int32Type, 0, 0), -- Offset 1889 ConstInt (Int32Type, 1024, 0), -- Flags 1890 Designated_Dbg); 1891 return MDNode (Vals, Vals'Length); 1892 end Add_Dbg_Pointer_Type; 1893 1894 function Add_Dbg_Pointer_Type (Id : O_Ident; Ptype : O_Tnode) 1895 return ValueRef is 1896 begin 1897 pragma Assert (Ptype.Acc_Type /= null); 1898 pragma Assert (Ptype.Acc_Type.Dbg /= Null_ValueRef); 1899 return Add_Dbg_Pointer_Type (Id, Ptype, Ptype.Acc_Type.Dbg); 1900 end Add_Dbg_Pointer_Type; 1901 1902 function Add_Dbg_Incomplete_Pointer_Type (Id : O_Ident; Ptype : O_Tnode) 1903 return ValueRef is 1904 begin 1905 return Add_Dbg_Pointer_Type (Id, Ptype, Null_ValueRef); 1906 end Add_Dbg_Incomplete_Pointer_Type; 1907 1908 function Add_Dbg_Record_Type 1909 (Id : O_Ident; Rtype : O_Tnode; Tag : Unsigned_64) return ValueRef 1910 is 1911 Vals : ValueRefArray (0 .. 14); 1912 begin 1913 Vals := (ConstInt (Int32Type, Tag, 0), 1914 Dbg_Current_Filedir, 1915 Null_ValueRef, -- context 1916 MDString (Id), 1917 Dbg_Line, 1918 Null_ValueRef, -- 5: Size 1919 Null_ValueRef, -- 6: Align 1920 ConstInt (Int32Type, 0, 0), -- Offset 1921 ConstInt (Int32Type, 1024, 0), -- Flags 1922 Null_ValueRef, 1923 Null_ValueRef, -- 10 1924 ConstInt (Int32Type, 0, 0), -- Runtime lang 1925 Null_ValueRef, -- Vtable Holder 1926 Null_ValueRef, -- ? 1927 Null_ValueRef); -- Uniq Id 1928 if Rtype /= O_Tnode_Null then 1929 Vals (5) := Dbg_Size (Rtype.LLVM); 1930 Vals (6) := Dbg_Align (Rtype.LLVM); 1931 Vals (10) := Rtype.Dbg; 1932 end if; 1933 1934 return MDNode (Vals, Vals'Length); 1935 end Add_Dbg_Record_Type; 1936 1937 procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is 1938 begin 1939 -- Create the incomplete structure. This is the only way in LLVM to 1940 -- build recursive types. 1941 case Atype.Kind is 1942 when ON_Incomplete_Record_Type => 1943 Atype.LLVM := 1944 StructCreateNamed (GetGlobalContext, Get_Cstring (Ident)); 1945 when ON_Incomplete_Access_Type => 1946 Atype.LLVM := PointerType 1947 (StructCreateNamed (GetGlobalContext, Get_Cstring (Ident))); 1948 when others => 1949 null; 1950 end case; 1951 1952 -- Emit debug info. 1953 if Flag_Debug then 1954 case Atype.Kind is 1955 when ON_Unsigned_Type => 1956 Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_unsigned); 1957 when ON_Signed_Type => 1958 Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_signed); 1959 when ON_Float_Type => 1960 Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_float); 1961 when ON_Enum_Type => 1962 Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype); 1963 when ON_Boolean_Type => 1964 Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype); 1965 when ON_Access_Type => 1966 Atype.Dbg := Add_Dbg_Pointer_Type (Ident, Atype); 1967 when ON_Incomplete_Access_Type => 1968 Atype.Dbg := Add_Dbg_Incomplete_Pointer_Type (Ident, Atype); 1969 when ON_Record_Type => 1970 Atype.Dbg := Add_Dbg_Record_Type 1971 (Ident, Atype, DW_TAG_Structure_Type); 1972 when ON_Incomplete_Record_Type => 1973 Atype.Dbg := Add_Dbg_Record_Type 1974 (Ident, O_Tnode_Null, DW_TAG_Structure_Type); 1975 when ON_Array_Type 1976 | ON_Array_Sub_Type => 1977 -- FIXME: typedef 1978 null; 1979 when ON_Union_Type => 1980 Atype.Dbg := Add_Dbg_Record_Type 1981 (Ident, Atype, DW_TAG_Union_Type); 1982 when ON_No_Type => 1983 raise Program_Error; 1984 end case; 1985 end if; 1986 end New_Type_Decl; 1987 1988 ----------------------------- 1989 -- New_Debug_Filename_Decl -- 1990 ----------------------------- 1991 1992 procedure New_Debug_Filename_Decl (Filename : String) is 1993 Vals : ValueRefArray (1 .. 2); 1994 begin 1995 if Flag_Debug_Line then 1996 Vals := (MDString (Filename), 1997 MDString (Current_Directory)); 1998 Dbg_Current_Filedir := MDNode (Vals, 2); 1999 2000 Vals := (ConstInt (Int32Type, DW_TAG_File_Type, 0), 2001 Dbg_Current_Filedir); 2002 Dbg_Current_File := MDNode (Vals, 2); 2003 end if; 2004 end New_Debug_Filename_Decl; 2005 2006 ------------------------- 2007 -- New_Debug_Line_Decl -- 2008 ------------------------- 2009 2010 procedure New_Debug_Line_Decl (Line : Natural) is 2011 begin 2012 Dbg_Current_Line := unsigned (Line); 2013 end New_Debug_Line_Decl; 2014 2015 ---------------------------- 2016 -- New_Debug_Comment_Decl -- 2017 ---------------------------- 2018 2019 procedure New_Debug_Comment_Decl (Comment : String) is 2020 begin 2021 null; 2022 end New_Debug_Comment_Decl; 2023 2024 -------------------- 2025 -- New_Const_Decl -- 2026 -------------------- 2027 2028 procedure Dbg_Add_Global_Var (Id : O_Ident; 2029 Atype : O_Tnode; 2030 Storage : O_Storage; 2031 Decl : O_Dnode) 2032 is 2033 pragma Assert (Atype.Dbg /= Null_ValueRef); 2034 Vals : ValueRefArray (0 .. 12); 2035 Name : constant ValueRef := MDString (Id); 2036 Is_Local : constant Boolean := Storage = O_Storage_Private; 2037 Is_Def : constant Boolean := Storage /= O_Storage_External; 2038 begin 2039 Vals := 2040 (ConstInt (Int32Type, DW_TAG_Variable, 0), 2041 Null_ValueRef, 2042 Null_ValueRef, -- context 2043 Name, 2044 Name, 2045 Null_ValueRef, -- linkageName 2046 Dbg_Current_File, 2047 Dbg_Line, 2048 Atype.Dbg, 2049 ConstInt (Int1Type, Boolean'Pos (Is_Local), 0), -- isLocal 2050 ConstInt (Int1Type, Boolean'Pos (Is_Def), 0), -- isDef 2051 Decl.LLVM, 2052 Null_ValueRef); 2053 Append (Global_Nodes, MDNode (Vals, Vals'Length)); 2054 end Dbg_Add_Global_Var; 2055 2056 procedure New_Const_Decl 2057 (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) 2058 is 2059 Decl : ValueRef; 2060 begin 2061 if Storage = O_Storage_External then 2062 Decl := GetNamedGlobal (Module, Get_Cstring (Ident)); 2063 else 2064 Decl := Null_ValueRef; 2065 end if; 2066 if Decl = Null_ValueRef then 2067 Decl := AddGlobal 2068 (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident)); 2069 end if; 2070 2071 Res := (Kind => ON_Const_Decl, LLVM => Decl, Dtype => Atype); 2072 SetGlobalConstant (Res.LLVM, 1); 2073 if Storage = O_Storage_Private then 2074 SetLinkage (Res.LLVM, InternalLinkage); 2075 end if; 2076 if Flag_Debug then 2077 Dbg_Add_Global_Var (Ident, Atype, Storage, Res); 2078 end if; 2079 end New_Const_Decl; 2080 2081 ----------------------- 2082 -- Start_Init_Value -- 2083 ----------------------- 2084 2085 procedure Start_Init_Value (Decl : in out O_Dnode) is 2086 begin 2087 null; 2088 end Start_Init_Value; 2089 2090 ------------------------ 2091 -- Finish_Init_Value -- 2092 ------------------------ 2093 2094 procedure Finish_Init_Value (Decl : in out O_Dnode; Val : O_Cnode) is 2095 begin 2096 SetInitializer (Decl.LLVM, Val.LLVM); 2097 end Finish_Init_Value; 2098 2099 ------------------ 2100 -- New_Var_Decl -- 2101 ------------------ 2102 2103 procedure New_Var_Decl 2104 (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) 2105 is 2106 Decl : ValueRef; 2107 begin 2108 if Storage = O_Storage_Local then 2109 Res := (Kind => ON_Local_Decl, 2110 LLVM => BuildAlloca 2111 (Decl_Builder, Get_LLVM_Type (Atype), Get_Cstring (Ident)), 2112 Dtype => Atype); 2113 if Flag_Debug then 2114 Dbg_Create_Variable (DW_TAG_Auto_Variable, 2115 Ident, Atype, 0, Res.LLVM); 2116 end if; 2117 else 2118 if Storage = O_Storage_External then 2119 Decl := GetNamedGlobal (Module, Get_Cstring (Ident)); 2120 else 2121 Decl := Null_ValueRef; 2122 end if; 2123 if Decl = Null_ValueRef then 2124 Decl := AddGlobal 2125 (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident)); 2126 end if; 2127 2128 Res := (Kind => ON_Var_Decl, LLVM => Decl, Dtype => Atype); 2129 2130 -- Set linkage. 2131 case Storage is 2132 when O_Storage_Private => 2133 SetLinkage (Res.LLVM, InternalLinkage); 2134 when O_Storage_Public 2135 | O_Storage_External => 2136 null; 2137 when O_Storage_Local => 2138 raise Program_Error; 2139 end case; 2140 2141 -- Set initializer. 2142 case Storage is 2143 when O_Storage_Private 2144 | O_Storage_Public => 2145 SetInitializer (Res.LLVM, ConstNull (Get_LLVM_Type (Atype))); 2146 when O_Storage_External => 2147 null; 2148 when O_Storage_Local => 2149 raise Program_Error; 2150 end case; 2151 2152 if Flag_Debug then 2153 Dbg_Add_Global_Var (Ident, Atype, Storage, Res); 2154 end if; 2155 end if; 2156 end New_Var_Decl; 2157 2158 ------------------------- 2159 -- Start_Function_Decl -- 2160 ------------------------- 2161 2162 procedure Start_Function_Decl 2163 (Interfaces : out O_Inter_List; 2164 Ident : O_Ident; 2165 Storage : O_Storage; 2166 Rtype : O_Tnode) 2167 is 2168 begin 2169 Interfaces := (Ident => Ident, 2170 Storage => Storage, 2171 Res_Type => Rtype, 2172 Nbr_Inter => 0, 2173 First_Inter => null, 2174 Last_Inter => null); 2175 end Start_Function_Decl; 2176 2177 -------------------------- 2178 -- Start_Procedure_Decl -- 2179 -------------------------- 2180 2181 procedure Start_Procedure_Decl 2182 (Interfaces : out O_Inter_List; 2183 Ident : O_Ident; 2184 Storage : O_Storage) 2185 is 2186 begin 2187 Interfaces := (Ident => Ident, 2188 Storage => Storage, 2189 Res_Type => O_Tnode_Null, 2190 Nbr_Inter => 0, 2191 First_Inter => null, 2192 Last_Inter => null); 2193 end Start_Procedure_Decl; 2194 2195 ------------------------ 2196 -- New_Interface_Decl -- 2197 ------------------------ 2198 2199 procedure New_Interface_Decl 2200 (Interfaces : in out O_Inter_List; 2201 Res : out O_Dnode; 2202 Ident : O_Ident; 2203 Atype : O_Tnode) 2204 is 2205 Inter : constant O_Inter_Acc := new O_Inter'(Itype => Atype, 2206 Ival => Null_ValueRef, 2207 Ident => Ident, 2208 Next => null); 2209 begin 2210 Res := (Kind => ON_Interface_Decl, 2211 Dtype => Atype, 2212 LLVM => Null_ValueRef, 2213 Inter => Inter); 2214 Interfaces.Nbr_Inter := Interfaces.Nbr_Inter + 1; 2215 if Interfaces.First_Inter = null then 2216 Interfaces.First_Inter := Inter; 2217 else 2218 Interfaces.Last_Inter.Next := Inter; 2219 end if; 2220 Interfaces.Last_Inter := Inter; 2221 end New_Interface_Decl; 2222 2223 ---------------------------- 2224 -- Finish_Subprogram_Decl -- 2225 ---------------------------- 2226 2227 procedure Finish_Subprogram_Decl 2228 (Interfaces : in out O_Inter_List; 2229 Res : out O_Dnode) 2230 is 2231 Count : constant unsigned := unsigned (Interfaces.Nbr_Inter); 2232 Inter : O_Inter_Acc; 2233 Types : TypeRefArray (1 .. Count); 2234 Ftype : TypeRef; 2235 Rtype : TypeRef; 2236 Decl : ValueRef; 2237 Id : constant Cstring := Get_Cstring (Interfaces.Ident); 2238 begin 2239 -- Fill Types (from interfaces list) 2240 Inter := Interfaces.First_Inter; 2241 for I in 1 .. Count loop 2242 Types (I) := Inter.Itype.LLVM; 2243 Inter := Inter.Next; 2244 end loop; 2245 2246 -- Build function type. 2247 if Interfaces.Res_Type = O_Tnode_Null then 2248 Rtype := VoidType; 2249 else 2250 Rtype := Interfaces.Res_Type.LLVM; 2251 end if; 2252 Ftype := FunctionType (Rtype, Types, Count, 0); 2253 2254 if Interfaces.Storage = O_Storage_External then 2255 Decl := GetNamedFunction (Module, Id); 2256 else 2257 Decl := Null_ValueRef; 2258 end if; 2259 if Decl = Null_ValueRef then 2260 Decl := AddFunction (Module, Id, Ftype); 2261 AddFunctionAttr (Decl, NoUnwindAttribute + UWTable); 2262 end if; 2263 2264 Res := (Kind => ON_Subprg_Decl, 2265 Dtype => Interfaces.Res_Type, 2266 Subprg_Id => Interfaces.Ident, 2267 Nbr_Args => Count, 2268 Subprg_Inters => Interfaces.First_Inter, 2269 LLVM => Decl); 2270 SetFunctionCallConv (Res.LLVM, CCallConv); 2271 2272 -- Translate interfaces. 2273 Inter := Interfaces.First_Inter; 2274 for I in 1 .. Count loop 2275 Inter.Ival := GetParam (Res.LLVM, I - 1); 2276 SetValueName (Inter.Ival, Get_Cstring (Inter.Ident)); 2277 Inter := Inter.Next; 2278 end loop; 2279 end Finish_Subprogram_Decl; 2280 2281 --------------------------- 2282 -- Start_Subprogram_Body -- 2283 --------------------------- 2284 2285 procedure Start_Subprogram_Body (Func : O_Dnode) 2286 is 2287 -- Basic block at function entry that contains all the declarations. 2288 Decl_BB : BasicBlockRef; 2289 begin 2290 if Cur_Func /= Null_ValueRef then 2291 -- No support for nested subprograms. 2292 raise Program_Error; 2293 end if; 2294 2295 Cur_Func := Func.LLVM; 2296 Cur_Func_Decl := Func; 2297 2298 pragma Assert (not Unreach); 2299 2300 Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring); 2301 PositionBuilderAtEnd (Decl_Builder, Decl_BB); 2302 2303 Create_Declare_Block; 2304 2305 PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb); 2306 2307 if Flag_Debug_Line then 2308 declare 2309 Type_Vals : ValueRefArray (0 .. Func.Nbr_Args); 2310 Types : ValueRef; 2311 Vals : ValueRefArray (0 .. 14); 2312 Arg : O_Inter_Acc; 2313 Subprg_Type : ValueRef; 2314 2315 Subprg_Vals : ValueRefArray (0 .. 19); 2316 Name : ValueRef; 2317 begin 2318 if Flag_Debug then 2319 -- Create a full subroutine_type. 2320 Arg := Func.Subprg_Inters; 2321 if Func.Dtype /= O_Tnode_Null then 2322 Type_Vals (0) := Func.Dtype.Dbg; 2323 else 2324 -- Void 2325 Type_Vals (0) := Null_ValueRef; 2326 end if; 2327 for I in 1 .. Type_Vals'Last loop 2328 Type_Vals (I) := Arg.Itype.Dbg; 2329 Arg := Arg.Next; 2330 end loop; 2331 Types := MDNode (Type_Vals, Type_Vals'Length); 2332 else 2333 -- Create a dummy subroutine_type. 2334 -- FIXME: create only one subroutine_type ? 2335 Type_Vals (0) := ConstInt (Int32Type, 0, 0); 2336 Types := MDNode (Type_Vals, 1); 2337 end if; 2338 2339 Vals := 2340 (ConstInt (Int32Type, DW_TAG_Subroutine_Type, 0), 2341 ConstInt (Int32Type, 0, 0), -- 1 ?? 2342 Null_ValueRef, -- 2 Context 2343 MDString (Empty_Cstring, 0), -- 3 name 2344 ConstInt (Int32Type, 0, 0), -- 4 linenum 2345 ConstInt (Int64Type, 0, 0), -- 5 size 2346 ConstInt (Int64Type, 0, 0), -- 6 align 2347 ConstInt (Int64Type, 0, 0), -- 7 offset 2348 ConstInt (Int32Type, 0, 0), -- 8 flags 2349 Null_ValueRef, -- 9 derived from 2350 Types, -- 10 type 2351 ConstInt (Int32Type, 0, 0), -- 11 runtime lang 2352 Null_ValueRef, -- 12 containing type 2353 Null_ValueRef, -- 13 template params 2354 Null_ValueRef); -- 14 ?? 2355 Subprg_Type := MDNode (Vals, Vals'Length); 2356 2357 -- Create TAG_subprogram. 2358 Name := MDString (Func.Subprg_Id); 2359 2360 Subprg_Vals := 2361 (ConstInt (Int32Type, DW_TAG_Subprogram, 0), 2362 Dbg_Current_Filedir, -- 1 loc 2363 Dbg_Current_File, -- 2 context 2364 Name, -- 3 name 2365 Name, -- 4 display name 2366 Null_ValueRef, -- 5 linkage name 2367 Dbg_Line, -- 6 line num 2368 Subprg_Type, -- 7 type 2369 ConstInt (Int1Type, 0, 0), -- 8 islocal (FIXME) 2370 ConstInt (Int1Type, 1, 0), -- 9 isdef (FIXME) 2371 ConstInt (Int32Type, 0, 0), -- 10 virtuality 2372 ConstInt (Int32Type, 0, 0), -- 11 virtual index 2373 Null_ValueRef, -- 12 containing type 2374 ConstInt (Int32Type, 256, 0), -- 13 flags: prototyped 2375 ConstInt (Int1Type, 0, 0), -- 14 isOpt (FIXME) 2376 Cur_Func, -- 15 function 2377 Null_ValueRef, -- 16 template param 2378 Null_ValueRef, -- 17 function decl 2379 Null_ValueRef, -- 18 variables ??? 2380 Dbg_Line); -- 19 scope ln 2381 Cur_Declare_Block.Dbg_Scope := 2382 MDNode (Subprg_Vals, Subprg_Vals'Length); 2383 Append (Subprg_Nodes, Cur_Declare_Block.Dbg_Scope); 2384 Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; 2385 2386 -- Kill current debug metadata, as it is not upto date. 2387 Dbg_Insn_MD := Null_ValueRef; 2388 end; 2389 end if; 2390 2391 if Flag_Debug then 2392 -- Create local variables for arguments. 2393 declare 2394 Arg : O_Inter_Acc; 2395 Tmp : ValueRef; 2396 St : ValueRef; 2397 pragma Unreferenced (St); 2398 Argno : Natural; 2399 begin 2400 Arg := Func.Subprg_Inters; 2401 Argno := 1; 2402 while Arg /= null loop 2403 Tmp := BuildAlloca (Decl_Builder, Get_LLVM_Type (Arg.Itype), 2404 Empty_Cstring); 2405 Dbg_Create_Variable (DW_TAG_Arg_Variable, 2406 Arg.Ident, Arg.Itype, Argno, Tmp); 2407 St := BuildStore (Decl_Builder, Arg.Ival, Tmp); 2408 Arg.Ival := Tmp; 2409 2410 Arg := Arg.Next; 2411 Argno := Argno + 1; 2412 end loop; 2413 end; 2414 end if; 2415 end Start_Subprogram_Body; 2416 2417 ---------------------------- 2418 -- Finish_Subprogram_Body -- 2419 ---------------------------- 2420 2421 procedure Finish_Subprogram_Body is 2422 Ret : ValueRef; 2423 pragma Unreferenced (Ret); 2424 begin 2425 -- Add a jump from the declare basic block to the first statement BB. 2426 Ret := BuildBr (Decl_Builder, Cur_Declare_Block.Stmt_Bb); 2427 2428 -- Terminate the statement BB. 2429 if not Unreach then 2430 if Cur_Func_Decl.Dtype = O_Tnode_Null then 2431 Ret := BuildRetVoid (Builder); 2432 else 2433 Ret := BuildUnreachable (Builder); 2434 end if; 2435 end if; 2436 2437 Destroy_Declare_Block; 2438 2439 Cur_Func := Null_ValueRef; 2440 2441 Unreach := False; 2442 2443 Dbg_Current_Scope := Null_ValueRef; 2444 Dbg_Insn_MD := Null_ValueRef; 2445 end Finish_Subprogram_Body; 2446 2447 ------------------------- 2448 -- New_Debug_Line_Stmt -- 2449 ------------------------- 2450 2451 procedure New_Debug_Line_Stmt (Line : Natural) is 2452 begin 2453 Dbg_Current_Line := unsigned (Line); 2454 end New_Debug_Line_Stmt; 2455 2456 ---------------------------- 2457 -- New_Debug_Comment_Stmt -- 2458 ---------------------------- 2459 2460 procedure New_Debug_Comment_Stmt (Comment : String) is 2461 begin 2462 null; 2463 end New_Debug_Comment_Stmt; 2464 2465 ------------------------ 2466 -- Start_Declare_Stmt -- 2467 ------------------------ 2468 2469 procedure Start_Declare_Stmt 2470 is 2471 Br : ValueRef; 2472 pragma Unreferenced (Br); 2473 begin 2474 Create_Declare_Block; 2475 2476 if Unreach then 2477 return; 2478 end if; 2479 2480 -- Add a jump to the new BB. 2481 Br := BuildBr (Builder, Cur_Declare_Block.Stmt_Bb); 2482 2483 PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb); 2484 2485 if Flag_Debug then 2486 declare 2487 Vals : ValueRefArray (0 .. 5); 2488 begin 2489 Vals := 2490 (ConstInt (Int32Type, DW_TAG_Lexical_Block, 0), 2491 Dbg_Current_Filedir, -- 1 loc 2492 Dbg_Current_Scope, -- 2 context 2493 Dbg_Line, -- 3 line num 2494 ConstInt (Int32Type, 0, 0), -- 4 col 2495 ConstInt (Int32Type, Scope_Uniq_Id, 0)); 2496 Cur_Declare_Block.Dbg_Scope := MDNode (Vals, Vals'Length); 2497 Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; 2498 Scope_Uniq_Id := Scope_Uniq_Id + 1; 2499 end; 2500 end if; 2501 end Start_Declare_Stmt; 2502 2503 ------------------------- 2504 -- Finish_Declare_Stmt -- 2505 ------------------------- 2506 2507 procedure Finish_Declare_Stmt 2508 is 2509 Bb : BasicBlockRef; 2510 Br : ValueRef; 2511 Tmp : ValueRef; 2512 pragma Unreferenced (Br, Tmp); 2513 begin 2514 if not Unreach then 2515 -- Create a basic block for the statements after the declare. 2516 Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); 2517 2518 if Cur_Declare_Block.Stack_Value /= Null_ValueRef then 2519 -- Restore stack pointer. 2520 Tmp := BuildCall (Builder, Stackrestore_Fun, 2521 (1 .. 1 => Cur_Declare_Block.Stack_Value), 1, 2522 Empty_Cstring); 2523 end if; 2524 2525 -- Execution will continue on the next statement 2526 Br := BuildBr (Builder, Bb); 2527 2528 PositionBuilderAtEnd (Builder, Bb); 2529 end if; 2530 2531 -- Do not reset Unread. 2532 2533 Destroy_Declare_Block; 2534 2535 Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; 2536 end Finish_Declare_Stmt; 2537 2538 ----------------------- 2539 -- Start_Association -- 2540 ----------------------- 2541 2542 procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) 2543 is 2544 begin 2545 Assocs := (Subprg => Subprg, 2546 Idx => 0, 2547 Vals => new ValueRefArray (1 .. Subprg.Nbr_Args)); 2548 end Start_Association; 2549 2550 --------------------- 2551 -- New_Association -- 2552 --------------------- 2553 2554 procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is 2555 begin 2556 Assocs.Idx := Assocs.Idx + 1; 2557 Assocs.Vals (Assocs.Idx) := Val.LLVM; 2558 end New_Association; 2559 2560 ----------------------- 2561 -- New_Function_Call -- 2562 ----------------------- 2563 2564 function New_Function_Call (Assocs : O_Assoc_List) return O_Enode 2565 is 2566 Res : ValueRef; 2567 Old_Vals : ValueRefArray_Acc; 2568 begin 2569 if not Unreach then 2570 Res := BuildCall (Builder, Assocs.Subprg.LLVM, 2571 Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); 2572 Old_Vals := Assocs.Vals; 2573 Free (Old_Vals); 2574 Set_Insn_Dbg (Res); 2575 else 2576 Res := Null_ValueRef; 2577 end if; 2578 return O_Enode'(LLVM => Res, Etype => Assocs.Subprg.Dtype); 2579 end New_Function_Call; 2580 2581 ------------------------ 2582 -- New_Procedure_Call -- 2583 ------------------------ 2584 2585 procedure New_Procedure_Call (Assocs : in out O_Assoc_List) 2586 is 2587 Res : ValueRef; 2588 begin 2589 if not Unreach then 2590 Res := BuildCall (Builder, Assocs.Subprg.LLVM, 2591 Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); 2592 Set_Insn_Dbg (Res); 2593 end if; 2594 Free (Assocs.Vals); 2595 end New_Procedure_Call; 2596 2597 --------------------- 2598 -- New_Assign_Stmt -- 2599 --------------------- 2600 2601 procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) 2602 is 2603 Res : ValueRef; 2604 begin 2605 if Target.Direct then 2606 raise Program_Error; 2607 end if; 2608 if not Unreach then 2609 Res := BuildStore (Builder, Value.LLVM, Target.LLVM); 2610 Set_Insn_Dbg (Res); 2611 end if; 2612 end New_Assign_Stmt; 2613 2614 --------------------- 2615 -- New_Return_Stmt -- 2616 --------------------- 2617 2618 procedure New_Return_Stmt (Value : O_Enode) is 2619 Res : ValueRef; 2620 begin 2621 if Unreach then 2622 return; 2623 end if; 2624 Res := BuildRet (Builder, Value.LLVM); 2625 Set_Insn_Dbg (Res); 2626 Unreach := True; 2627 end New_Return_Stmt; 2628 2629 --------------------- 2630 -- New_Return_Stmt -- 2631 --------------------- 2632 2633 procedure New_Return_Stmt is 2634 Res : ValueRef; 2635 begin 2636 if Unreach then 2637 return; 2638 end if; 2639 Res := BuildRetVoid (Builder); 2640 Set_Insn_Dbg (Res); 2641 Unreach := True; 2642 end New_Return_Stmt; 2643 2644 ------------------- 2645 -- Start_If_Stmt -- 2646 ------------------- 2647 2648 procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is 2649 Res : ValueRef; 2650 Bb_Then : BasicBlockRef; 2651 begin 2652 if Unreach then 2653 Block := (Bb => Null_BasicBlockRef); 2654 return; 2655 end if; 2656 2657 Bb_Then := AppendBasicBlock (Cur_Func, Empty_Cstring); 2658 Block := (Bb => AppendBasicBlock (Cur_Func, Empty_Cstring)); 2659 Res := BuildCondBr (Builder, Cond.LLVM, Bb_Then, Block.Bb); 2660 Set_Insn_Dbg (Res); 2661 2662 PositionBuilderAtEnd (Builder, Bb_Then); 2663 end Start_If_Stmt; 2664 2665 ------------------- 2666 -- New_Else_Stmt -- 2667 ------------------- 2668 2669 procedure New_Else_Stmt (Block : in out O_If_Block) is 2670 Res : ValueRef; 2671 pragma Unreferenced (Res); 2672 Bb_Next : BasicBlockRef; 2673 begin 2674 if not Unreach then 2675 Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); 2676 Res := BuildBr (Builder, Bb_Next); 2677 else 2678 if Block.Bb = Null_BasicBlockRef then 2679 -- The IF statement was unreachable. Else part is also 2680 -- unreachable. 2681 return; 2682 end if; 2683 Bb_Next := Null_BasicBlockRef; 2684 end if; 2685 2686 PositionBuilderAtEnd (Builder, Block.Bb); 2687 2688 Block := (Bb => Bb_Next); 2689 Unreach := False; 2690 end New_Else_Stmt; 2691 2692 -------------------- 2693 -- Finish_If_Stmt -- 2694 -------------------- 2695 2696 procedure Finish_If_Stmt (Block : in out O_If_Block) is 2697 Res : ValueRef; 2698 pragma Unreferenced (Res); 2699 Bb_Next : BasicBlockRef; 2700 begin 2701 if not Unreach then 2702 -- The branch can continue. 2703 if Block.Bb = Null_BasicBlockRef then 2704 Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); 2705 else 2706 Bb_Next := Block.Bb; 2707 end if; 2708 Res := BuildBr (Builder, Bb_Next); 2709 PositionBuilderAtEnd (Builder, Bb_Next); 2710 else 2711 -- The branch doesn't continue. 2712 if Block.Bb /= Null_BasicBlockRef then 2713 -- There is a fall-through (either from the then branch, or 2714 -- there is no else). 2715 Unreach := False; 2716 PositionBuilderAtEnd (Builder, Block.Bb); 2717 else 2718 Unreach := True; 2719 end if; 2720 end if; 2721 end Finish_If_Stmt; 2722 2723 --------------------- 2724 -- Start_Loop_Stmt -- 2725 --------------------- 2726 2727 procedure Start_Loop_Stmt (Label : out O_Snode) 2728 is 2729 Res : ValueRef; 2730 pragma Unreferenced (Res); 2731 begin 2732 if Unreach then 2733 Label := (Null_BasicBlockRef, Null_BasicBlockRef); 2734 else 2735 Label := (Bb_Entry => AppendBasicBlock (Cur_Func, Empty_Cstring), 2736 Bb_Exit => AppendBasicBlock (Cur_Func, Empty_Cstring)); 2737 Res := BuildBr (Builder, Label.Bb_Entry); 2738 PositionBuilderAtEnd (Builder, Label.Bb_Entry); 2739 end if; 2740 end Start_Loop_Stmt; 2741 2742 ---------------------- 2743 -- Finish_Loop_Stmt -- 2744 ---------------------- 2745 2746 procedure Finish_Loop_Stmt (Label : in out O_Snode) is 2747 Res : ValueRef; 2748 pragma Unreferenced (Res); 2749 begin 2750 if not Unreach then 2751 Res := BuildBr (Builder, Label.Bb_Entry); 2752 end if; 2753 if Label.Bb_Exit /= Null_BasicBlockRef then 2754 -- FIXME: always true... 2755 PositionBuilderAtEnd (Builder, Label.Bb_Exit); 2756 Unreach := False; 2757 else 2758 Unreach := True; 2759 end if; 2760 end Finish_Loop_Stmt; 2761 2762 ------------------- 2763 -- New_Exit_Stmt -- 2764 ------------------- 2765 2766 procedure New_Exit_Stmt (L : O_Snode) is 2767 Res : ValueRef; 2768 begin 2769 if not Unreach then 2770 Res := BuildBr (Builder, L.Bb_Exit); 2771 Set_Insn_Dbg (Res); 2772 Unreach := True; 2773 end if; 2774 end New_Exit_Stmt; 2775 2776 ------------------- 2777 -- New_Next_Stmt -- 2778 ------------------- 2779 2780 procedure New_Next_Stmt (L : O_Snode) is 2781 Res : ValueRef; 2782 begin 2783 if not Unreach then 2784 Res := BuildBr (Builder, L.Bb_Entry); 2785 Set_Insn_Dbg (Res); 2786 Unreach := True; 2787 end if; 2788 end New_Next_Stmt; 2789 2790 --------------------- 2791 -- Start_Case_Stmt -- 2792 --------------------- 2793 2794 procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is 2795 begin 2796 Block := (BB_Prev => GetInsertBlock (Builder), 2797 Value => Value.LLVM, 2798 Vtype => Value.Etype, 2799 BB_Next => Null_BasicBlockRef, 2800 BB_Others => Null_BasicBlockRef, 2801 BB_Choice => Null_BasicBlockRef, 2802 Nbr_Choices => 0, 2803 Choices => new O_Choice_Array (1 .. 8)); 2804 end Start_Case_Stmt; 2805 2806 ------------------ 2807 -- Start_Choice -- 2808 ------------------ 2809 2810 procedure Finish_Branch (Block : in out O_Case_Block) is 2811 Res : ValueRef; 2812 pragma Unreferenced (Res); 2813 begin 2814 -- Close previous branch. 2815 if not Unreach then 2816 if Block.BB_Next = Null_BasicBlockRef then 2817 Block.BB_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); 2818 end if; 2819 Res := BuildBr (Builder, Block.BB_Next); 2820 end if; 2821 end Finish_Branch; 2822 2823 procedure Start_Choice (Block : in out O_Case_Block) is 2824 Res : ValueRef; 2825 pragma Unreferenced (Res); 2826 begin 2827 if Block.BB_Choice /= Null_BasicBlockRef then 2828 -- Close previous branch. 2829 Finish_Branch (Block); 2830 end if; 2831 2832 Unreach := False; 2833 Block.BB_Choice := AppendBasicBlock (Cur_Func, Empty_Cstring); 2834 PositionBuilderAtEnd (Builder, Block.BB_Choice); 2835 end Start_Choice; 2836 2837 --------------------- 2838 -- New_Expr_Choice -- 2839 --------------------- 2840 2841 procedure Free is new Ada.Unchecked_Deallocation 2842 (O_Choice_Array, O_Choice_Array_Acc); 2843 2844 procedure New_Choice (Block : in out O_Case_Block; 2845 Low, High : ValueRef) 2846 is 2847 Choices : O_Choice_Array_Acc; 2848 begin 2849 if Block.Nbr_Choices = Block.Choices'Last then 2850 Choices := new O_Choice_Array (1 .. Block.Choices'Last * 2); 2851 Choices (1 .. Block.Choices'Last) := Block.Choices.all; 2852 Free (Block.Choices); 2853 Block.Choices := Choices; 2854 end if; 2855 Block.Nbr_Choices := Block.Nbr_Choices + 1; 2856 Block.Choices (Block.Nbr_Choices) := (Low => Low, 2857 High => High, 2858 Bb => Block.BB_Choice); 2859 end New_Choice; 2860 2861 procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is 2862 begin 2863 New_Choice (Block, Expr.LLVM, Null_ValueRef); 2864 end New_Expr_Choice; 2865 2866 ---------------------- 2867 -- New_Range_Choice -- 2868 ---------------------- 2869 2870 procedure New_Range_Choice 2871 (Block : in out O_Case_Block; Low, High : O_Cnode) 2872 is 2873 begin 2874 New_Choice (Block, Low.LLVM, High.LLVM); 2875 end New_Range_Choice; 2876 2877 ------------------------ 2878 -- New_Default_Choice -- 2879 ------------------------ 2880 2881 procedure New_Default_Choice (Block : in out O_Case_Block) is 2882 begin 2883 Block.BB_Others := Block.BB_Choice; 2884 end New_Default_Choice; 2885 2886 ------------------- 2887 -- Finish_Choice -- 2888 ------------------- 2889 2890 procedure Finish_Choice (Block : in out O_Case_Block) is 2891 begin 2892 null; 2893 end Finish_Choice; 2894 2895 ---------------------- 2896 -- Finish_Case_Stmt -- 2897 ---------------------- 2898 2899 procedure Finish_Case_Stmt (Block : in out O_Case_Block) 2900 is 2901 Bb_Default : constant BasicBlockRef := 2902 AppendBasicBlock (Cur_Func, Empty_Cstring); 2903 Bb_Default_Last : BasicBlockRef; 2904 Nbr_Cases : unsigned := 0; 2905 GE, LE : IntPredicate; 2906 Res : ValueRef; 2907 begin 2908 if Block.BB_Choice /= Null_BasicBlockRef then 2909 -- Close previous branch. 2910 Finish_Branch (Block); 2911 end if; 2912 2913 -- Strategy: use a switch instruction for simple choices, put range 2914 -- choices in the default using if statements. 2915 case Block.Vtype.Kind is 2916 when ON_Unsigned_Type 2917 | ON_Enum_Type 2918 | ON_Boolean_Type => 2919 GE := IntUGE; 2920 LE := IntULE; 2921 when ON_Signed_Type => 2922 GE := IntSGE; 2923 LE := IntSLE; 2924 when others => 2925 raise Program_Error; 2926 end case; 2927 2928 -- BB for the default case of the LLVM switch. 2929 PositionBuilderAtEnd (Builder, Bb_Default); 2930 Bb_Default_Last := Bb_Default; 2931 2932 for I in 1 .. Block.Nbr_Choices loop 2933 declare 2934 C : O_Choice_Type renames Block.Choices (I); 2935 begin 2936 if C.High /= Null_ValueRef then 2937 Bb_Default_Last := AppendBasicBlock (Cur_Func, Empty_Cstring); 2938 Res := BuildCondBr (Builder, 2939 BuildAnd (Builder, 2940 BuildICmp (Builder, GE, 2941 Block.Value, C.Low, 2942 Empty_Cstring), 2943 BuildICmp (Builder, LE, 2944 Block.Value, C.High, 2945 Empty_Cstring), 2946 Empty_Cstring), 2947 C.Bb, Bb_Default_Last); 2948 PositionBuilderAtEnd (Builder, Bb_Default_Last); 2949 else 2950 Nbr_Cases := Nbr_Cases + 1; 2951 end if; 2952 end; 2953 end loop; 2954 2955 -- Insert the switch 2956 PositionBuilderAtEnd (Builder, Block.BB_Prev); 2957 Res := BuildSwitch (Builder, Block.Value, Bb_Default, Nbr_Cases); 2958 for I in 1 .. Block.Nbr_Choices loop 2959 declare 2960 C : O_Choice_Type renames Block.Choices (I); 2961 begin 2962 if C.High = Null_ValueRef then 2963 AddCase (Res, C.Low, C.Bb); 2964 end if; 2965 end; 2966 end loop; 2967 2968 -- Insert the others. 2969 PositionBuilderAtEnd (Builder, Bb_Default_Last); 2970 if Block.BB_Others /= Null_BasicBlockRef then 2971 Res := BuildBr (Builder, Block.BB_Others); 2972 else 2973 Res := BuildUnreachable (Builder); 2974 end if; 2975 2976 if Block.BB_Next /= Null_BasicBlockRef then 2977 Unreach := False; 2978 PositionBuilderAtEnd (Builder, Block.BB_Next); 2979 else 2980 Unreach := True; 2981 end if; 2982 2983 Free (Block.Choices); 2984 end Finish_Case_Stmt; 2985 2986 function Get_LLVM_Type (Atype : O_Tnode) return TypeRef is 2987 begin 2988 case Atype.Kind is 2989 when ON_Incomplete_Record_Type 2990 | ON_Incomplete_Access_Type => 2991 if Atype.LLVM = Null_TypeRef then 2992 raise Program_Error with "early use of incomplete type"; 2993 end if; 2994 return Atype.LLVM; 2995 when ON_Union_Type 2996 | ON_Scalar_Types 2997 | ON_Access_Type 2998 | ON_Array_Type 2999 | ON_Array_Sub_Type 3000 | ON_Record_Type => 3001 return Atype.LLVM; 3002 when others => 3003 raise Program_Error; 3004 end case; 3005 end Get_LLVM_Type; 3006 3007 procedure Finish_Debug is 3008 begin 3009 declare 3010 Dbg_Cu : constant String := "llvm.dbg.cu" & ASCII.NUL; 3011 Producer : constant String := "ortho llvm"; 3012 Vals : ValueRefArray (0 .. 12); 3013 begin 3014 Vals := 3015 (ConstInt (Int32Type, DW_TAG_Compile_Unit, 0), 3016 Dbg_Current_Filedir, -- 1 file+dir 3017 ConstInt (Int32Type, 1, 0), -- 2 language (C) 3018 MDString (Producer), -- 3 producer 3019 ConstInt (Int1Type, 0, 0), -- 4 isOpt 3020 MDString (""), -- 5 flags 3021 ConstInt (Int32Type, 0, 0), -- 6 runtime version 3022 Null_ValueRef, -- 7 enum types 3023 Null_ValueRef, -- 8 retained types 3024 Get_Value (Subprg_Nodes), -- 9 subprograms 3025 Get_Value (Global_Nodes), -- 10 global var 3026 Null_ValueRef, -- 11 imported entities 3027 Null_ValueRef); -- 12 split debug 3028 3029 AddNamedMetadataOperand 3030 (Module, Dbg_Cu'Address, MDNode (Vals, Vals'Length)); 3031 end; 3032 3033 declare 3034 Module_Flags : constant String := "llvm.module.flags" & ASCII.NUL; 3035 Flags1 : ValueRefArray (0 .. 2); 3036 Flags2 : ValueRefArray (0 .. 2); 3037 begin 3038 Flags1 := (ConstInt (Int32Type, 1, 0), 3039 MDString ("Debug Info Version"), 3040 ConstInt (Int32Type, 1, 0)); 3041 AddNamedMetadataOperand 3042 (Module, Module_Flags'Address, MDNode (Flags1, Flags1'Length)); 3043 Flags2 := (ConstInt (Int32Type, 2, 0), 3044 MDString ("Dwarf Version"), 3045 ConstInt (Int32Type, 2, 0)); 3046 AddNamedMetadataOperand 3047 (Module, Module_Flags'Address, MDNode (Flags2, Flags2'Length)); 3048 end; 3049 end Finish_Debug; 3050 3051 Dbg_Str : constant String := "dbg"; 3052 3053 procedure Init is 3054 -- Some predefined types and functions. 3055 I8_Ptr_Type : TypeRef; 3056 begin 3057 Builder := CreateBuilder; 3058 Decl_Builder := CreateBuilder; 3059 Extra_Builder := CreateBuilder; 3060 3061 -- Create type i8 *. 3062 I8_Ptr_Type := PointerType (Int8Type); 3063 3064 -- Create intrinsic 'i8 *stacksave (void)'. 3065 Stacksave_Fun := AddFunction 3066 (Module, Stacksave_Name'Address, 3067 FunctionType (I8_Ptr_Type, (1 .. 0 => Null_TypeRef), 0, 0)); 3068 3069 -- Create intrinsic 'void stackrestore (i8 *)'. 3070 Stackrestore_Fun := AddFunction 3071 (Module, Stackrestore_Name'Address, 3072 FunctionType (VoidType, (1 => I8_Ptr_Type), 1, 0)); 3073 3074 -- Create intrinsic 'double llvm.copysign.f64 (double, double)'. 3075 Copysign_Fun := AddFunction 3076 (Module, Copysign_Name'Address, 3077 FunctionType (DoubleType, (0 .. 1 => DoubleType), 2, 0)); 3078 3079 Fp_0_5 := ConstReal (DoubleType, 0.5); 3080 3081 if Flag_Debug_Line then 3082 Debug_ID := GetMDKindID (Dbg_Str, Dbg_Str'Length); 3083 3084 declare 3085 Atypes : TypeRefArray (1 .. 2); 3086 Ftype : TypeRef; 3087 Name : String := "llvm.dbg.declare" & ASCII.NUL; 3088 begin 3089 Atypes := (MetadataType, MetadataType); 3090 Ftype := FunctionType (VoidType, Atypes, Atypes'Length, 0); 3091 Llvm_Dbg_Declare := AddFunction (Module, Name'Address, Ftype); 3092 AddFunctionAttr (Llvm_Dbg_Declare, 3093 NoUnwindAttribute + ReadNoneAttribute); 3094 end; 3095 end if; 3096 end Init; 3097 3098end Ortho_LLVM; 3099