gcc/ada/back_end.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                            B A C K _ E N D                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2018, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 --  This is the version of the Back_End package for GCC back ends
  27
  28 with Atree;    use Atree;
  29 with Debug;    use Debug;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Lib;      use Lib;
  33 with Osint;    use Osint;
  34 with Opt;      use Opt;
  35 with Osint.C;  use Osint.C;
  36 with Namet;    use Namet;
  37 with Nlists;   use Nlists;
  38 with Stand;    use Stand;
  39 with Sinput;   use Sinput;
  40 with Stringt;  use Stringt;
  41 with Switch;   use Switch;
  42 with Switch.C; use Switch.C;
  43 with System;   use System;
  44 with Types;    use Types;
  45
  46 with System.OS_Lib; use System.OS_Lib;
  47
  48 package body Back_End is
  49
  50    type Arg_Array is array (Nat) of Big_String_Ptr;
  51    type Arg_Array_Ptr is access Arg_Array;
  52    --  Types to access compiler arguments
  53
  54    flag_stack_check : Int;
  55    pragma Import (C, flag_stack_check);
  56    --  Indicates if stack checking is enabled, imported from misc.c
  57
  58    save_argc : Nat;
  59    pragma Import (C, save_argc);
  60    --  Saved value of argc (number of arguments), imported from misc.c
  61
  62    save_argv : Arg_Array_Ptr;
  63    pragma Import (C, save_argv);
  64    --  Saved value of argv (argument pointers), imported from misc.c
  65
  66    function Len_Arg (Arg : Pos) return Nat;
  67    --  Determine length of argument number Arg on original gnat1 command line
  68
  69    -------------------
  70    -- Call_Back_End --
  71    -------------------
  72
  73    procedure Call_Back_End (Mode : Back_End_Mode_Type) is
  74
  75       --  The Source_File_Record type has a lot of components that are
  76       --  meaningless to the back end, so a new record type is created
  77       --  here to contain the needed information for each file.
  78
  79       type File_Info_Type is record
  80          File_Name        : File_Name_Type;
  81          Instance         : Instance_Id;
  82          Num_Source_Lines : Nat;
  83       end record;
  84
  85       File_Info_Array : array (1 .. Last_Source_File) of File_Info_Type;
  86
  87       procedure gigi
  88         (gnat_root                     : Int;
  89          max_gnat_node                 : Int;
  90          number_name                   : Nat;
  91          nodes_ptr                     : Address;
  92          flags_ptr                     : Address;
  93
  94          next_node_ptr                 : Address;
  95          prev_node_ptr                 : Address;
  96          elists_ptr                    : Address;
  97          elmts_ptr                     : Address;
  98
  99          strings_ptr                   : Address;
 100          string_chars_ptr              : Address;
 101          list_headers_ptr              : Address;
 102          number_file                   : Nat;
 103
 104          file_info_ptr                 : Address;
 105          gigi_standard_boolean         : Entity_Id;
 106          gigi_standard_integer         : Entity_Id;
 107          gigi_standard_character       : Entity_Id;
 108          gigi_standard_long_long_float : Entity_Id;
 109          gigi_standard_exception_type  : Entity_Id;
 110          gigi_operating_mode           : Back_End_Mode_Type);
 111
 112       pragma Import (C, gigi);
 113
 114    begin
 115       --  Skip call if in -gnatdH mode
 116
 117       if Debug_Flag_HH then
 118          return;
 119       end if;
 120
 121       --  The back end needs to know the maximum line number that can appear
 122       --  in a Sloc, in other words the maximum logical line number.
 123
 124       for J in 1 .. Last_Source_File loop
 125          File_Info_Array (J).File_Name        := Full_Debug_Name (J);
 126          File_Info_Array (J).Instance         := Instance (J);
 127          File_Info_Array (J).Num_Source_Lines :=
 128            Nat (Physical_To_Logical (Last_Source_Line (J), J));
 129       end loop;
 130
 131       --  Deal with case of generating SCIL, we should not be here unless
 132       --  debugging CodePeer mode in GNAT.
 133
 134       if Generate_SCIL then
 135          Error_Msg_N ("'S'C'I'L generation not available", Cunit (Main_Unit));
 136
 137          if CodePeer_Mode
 138            or else (Mode /= Generate_Object
 139                      and then not Back_Annotate_Rep_Info)
 140          then
 141             return;
 142          end if;
 143       end if;
 144
 145       --  We should be here in GNATprove mode only when debugging GNAT. Do not
 146       --  call gigi in that case, as it is not prepared to handle the special
 147       --  form of the tree obtained in GNATprove mode.
 148
 149       if GNATprove_Mode then
 150          return;
 151       end if;
 152
 153       --  The actual call to the back end
 154
 155       gigi
 156         (gnat_root          => Int (Cunit (Main_Unit)),
 157          max_gnat_node      => Int (Last_Node_Id - First_Node_Id + 1),
 158          number_name        => Name_Entries_Count,
 159          nodes_ptr          => Nodes_Address,
 160          flags_ptr          => Flags_Address,
 161
 162          next_node_ptr      => Next_Node_Address,
 163          prev_node_ptr      => Prev_Node_Address,
 164          elists_ptr         => Elists_Address,
 165          elmts_ptr          => Elmts_Address,
 166
 167          strings_ptr        => Strings_Address,
 168          string_chars_ptr   => String_Chars_Address,
 169          list_headers_ptr   => Lists_Address,
 170          number_file        => Num_Source_Files,
 171
 172          file_info_ptr                 => File_Info_Array'Address,
 173          gigi_standard_boolean         => Standard_Boolean,
 174          gigi_standard_integer         => Standard_Integer,
 175          gigi_standard_character       => Standard_Character,
 176          gigi_standard_long_long_float => Standard_Long_Long_Float,
 177          gigi_standard_exception_type  => Standard_Exception_Type,
 178          gigi_operating_mode           => Mode);
 179    end Call_Back_End;
 180
 181    -------------------------------
 182    -- Gen_Or_Update_Object_File --
 183    -------------------------------
 184
 185    procedure Gen_Or_Update_Object_File is
 186    begin
 187       null;
 188    end Gen_Or_Update_Object_File;
 189
 190    -------------
 191    -- Len_Arg --
 192    -------------
 193
 194    function Len_Arg (Arg : Pos) return Nat is
 195    begin
 196       for J in 1 .. Nat'Last loop
 197          if save_argv (Arg).all (Natural (J)) = ASCII.NUL then
 198             return J - 1;
 199          end if;
 200       end loop;
 201
 202       raise Program_Error;
 203    end Len_Arg;
 204
 205    -----------------------------
 206    -- Scan_Compiler_Arguments --
 207    -----------------------------
 208
 209    procedure Scan_Compiler_Arguments is
 210       Next_Arg : Positive;
 211       --  Next argument to be scanned
 212
 213       Output_File_Name_Seen : Boolean := False;
 214       --  Set to True after having scanned file_name for switch "-gnatO file"
 215
 216       procedure Scan_Back_End_Switches (Switch_Chars : String);
 217       --  Procedure to scan out switches stored in Switch_Chars. The first
 218       --  character is known to be a valid switch character, and there are no
 219       --  blanks or other switch terminator characters in the string, so the
 220       --  entire string should consist of valid switch characters, except that
 221       --  an optional terminating NUL character is allowed.
 222       --
 223       --  Back end switches have already been checked and processed by GCC in
 224       --  toplev.c, so no errors can occur and control will always return. The
 225       --  switches must still be scanned to skip "-o" or internal GCC switches
 226       --  with their argument.
 227
 228       ----------------------------
 229       -- Scan_Back_End_Switches --
 230       ----------------------------
 231
 232       procedure Scan_Back_End_Switches (Switch_Chars : String) is
 233          First : constant Positive := Switch_Chars'First + 1;
 234          Last  : constant Natural  := Switch_Last (Switch_Chars);
 235
 236       begin
 237          --  Skip -o, -G or internal GCC switches together with their argument.
 238
 239          if Switch_Chars (First .. Last) = "o"
 240            or else Switch_Chars (First .. Last) = "G"
 241            or else Is_Internal_GCC_Switch (Switch_Chars)
 242          then
 243             Next_Arg := Next_Arg + 1;
 244
 245          --  Do not record -quiet switch
 246
 247          elsif Switch_Chars (First .. Last) = "quiet" then
 248             null;
 249
 250          --  Store any other GCC switches. Also do special processing for some
 251          --  specific switches that the Ada front-end knows about.
 252
 253          else
 254             Store_Compilation_Switch (Switch_Chars);
 255
 256             --  For gcc back ends, -fno-inline disables Inline pragmas only,
 257             --  not Inline_Always to remain consistent with the always_inline
 258             --  attribute behavior.
 259
 260             if Switch_Chars (First .. Last) = "fno-inline" then
 261                Opt.Disable_FE_Inline := True;
 262
 263             --  Back end switch -fpreserve-control-flow also sets the front end
 264             --  flag that inhibits improper control flow transformations.
 265
 266             elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then
 267                Opt.Suppress_Control_Flow_Optimizations := True;
 268
 269             --  Back end switch -fdump-scos, which exists primarily for C, is
 270             --  also accepted for Ada as a synonym of -gnateS.
 271
 272             elsif Switch_Chars (First .. Last) = "fdump-scos" then
 273                Opt.Generate_SCO := True;
 274                Opt.Generate_SCO_Instance_Table := True;
 275
 276             elsif Switch_Chars (First) = 'g' then
 277                Debugger_Level := 2;
 278
 279                if First < Last then
 280                   case Switch_Chars (First + 1) is
 281                      when '0' =>
 282                         Debugger_Level := 0;
 283                      when '1' =>
 284                         Debugger_Level := 1;
 285                      when '2' =>
 286                         Debugger_Level := 2;
 287                      when '3' =>
 288                         Debugger_Level := 3;
 289                      when others =>
 290                         null;
 291                   end case;
 292                end if;
 293             end if;
 294          end if;
 295       end Scan_Back_End_Switches;
 296
 297       --  Local variables
 298
 299       Arg_Count : constant Natural := Natural (save_argc - 1);
 300       Args      : Argument_List (1 .. Arg_Count);
 301
 302    --  Start of processing for Scan_Compiler_Arguments
 303
 304    begin
 305       --  Acquire stack checking mode directly from GCC. The reason we do this
 306       --  is to make sure that the indication of stack checking being enabled
 307       --  is the same in the front end and the back end. This status obtained
 308       --  from gcc is affected by more than just the switch -fstack-check.
 309
 310       Opt.Stack_Checking_Enabled := (flag_stack_check /= 0);
 311
 312       --  Put the arguments in Args
 313
 314       for Arg in Pos range 1 .. save_argc - 1 loop
 315          declare
 316             Argv_Ptr : constant Big_String_Ptr := save_argv (Arg);
 317             Argv_Len : constant Nat            := Len_Arg (Arg);
 318             Argv     : constant String         :=
 319                          Argv_Ptr (1 .. Natural (Argv_Len));
 320          begin
 321             Args (Positive (Arg)) := new String'(Argv);
 322          end;
 323       end loop;
 324
 325       --  Loop through command line arguments, storing them for later access
 326
 327       Next_Arg := 1;
 328       while Next_Arg <= Args'Last loop
 329          Look_At_Arg : declare
 330             Argv : constant String := Args (Next_Arg).all;
 331
 332          begin
 333             --  If the previous switch has set the Output_File_Name_Present
 334             --  flag (that is we have seen a -gnatO), then the next argument
 335             --  is the name of the output object file.
 336
 337             if Output_File_Name_Present and then not Output_File_Name_Seen then
 338                if Is_Switch (Argv) then
 339                   Fail ("Object file name missing after -gnatO");
 340                else
 341                   Set_Output_Object_File_Name (Argv);
 342                   Output_File_Name_Seen := True;
 343                end if;
 344
 345             --  If the previous switch has set the Search_Directory_Present
 346             --  flag (that is if we have just seen -I), then the next argument
 347             --  is a search directory path.
 348
 349             elsif Search_Directory_Present then
 350                if Is_Switch (Argv) then
 351                   Fail ("search directory missing after -I");
 352                else
 353                   Add_Src_Search_Dir (Argv);
 354                   Search_Directory_Present := False;
 355                end if;
 356
 357             --  If not a switch, must be a file name
 358
 359             elsif not Is_Switch (Argv) then
 360                Add_File (Argv);
 361
 362             --  We must recognize -nostdinc to suppress visibility on the
 363             --  standard GNAT RTL sources. This is also a gcc switch.
 364
 365             elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdinc" then
 366                Opt.No_Stdinc := True;
 367                Scan_Back_End_Switches (Argv);
 368
 369             --  We must recognize -nostdlib to suppress visibility on the
 370             --  standard GNAT RTL objects.
 371
 372             elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdlib" then
 373                Opt.No_Stdlib := True;
 374
 375             elsif Is_Front_End_Switch (Argv) then
 376                Scan_Front_End_Switches (Argv, Args, Next_Arg);
 377
 378             --  All non-front-end switches are back-end switches
 379
 380             else
 381                Scan_Back_End_Switches (Argv);
 382             end if;
 383          end Look_At_Arg;
 384
 385          Next_Arg := Next_Arg + 1;
 386       end loop;
 387    end Scan_Compiler_Arguments;
 388
 389 end Back_End;