src/ortho/llvm-nodebug/ortho_code_main.adb


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
pre { line-height: 125%; margin: 0; }
td.linenos pre { color: #000000; background-color: #f0f0f0; padding: 0 5px 0 5px; }
span.linenos { color: #000000; background-color: #f0f0f0; padding: 0 5px 0 5px; }
td.linenos pre.special { color: #000000; background-color: #ffffc0; padding: 0 5px 0 5px; }
span.linenos.special { color: #000000; background-color: #ffffc0; padding: 0 5px 0 5px; }
.highlight .hll { background-color: #ffffcc }
.highlight { background: #ffffff; }
.highlight .c { color: #888888 } /* Comment */
.highlight .err { color: #a61717; background-color: #e3d2d2 } /* Error */
.highlight .k { color: #008800; font-weight: bold } /* Keyword */
.highlight .ch { color: #888888 } /* Comment.Hashbang */
.highlight .cm { color: #888888 } /* Comment.Multiline */
.highlight .cp { color: #cc0000; font-weight: bold } /* Comment.Preproc */
.highlight .cpf { color: #888888 } /* Comment.PreprocFile */
.highlight .c1 { color: #888888 } /* Comment.Single */
.highlight .cs { color: #cc0000; font-weight: bold; background-color: #fff0f0 } /* Comment.Special */
.highlight .gd { color: #000000; background-color: #ffdddd } /* Generic.Deleted */
.highlight .ge { font-style: italic } /* Generic.Emph */
.highlight .gr { color: #aa0000 } /* Generic.Error */
.highlight .gh { color: #333333 } /* Generic.Heading */
.highlight .gi { color: #000000; background-color: #ddffdd } /* Generic.Inserted */
.highlight .go { color: #888888 } /* Generic.Output */
.highlight .gp { color: #555555 } /* Generic.Prompt */
.highlight .gs { font-weight: bold } /* Generic.Strong */
.highlight .gu { color: #666666 } /* Generic.Subheading */
.highlight .gt { color: #aa0000 } /* Generic.Traceback */
.highlight .kc { color: #008800; font-weight: bold } /* Keyword.Constant */
.highlight .kd { color: #008800; font-weight: bold } /* Keyword.Declaration */
.highlight .kn { color: #008800; font-weight: bold } /* Keyword.Namespace */
.highlight .kp { color: #008800 } /* Keyword.Pseudo */
.highlight .kr { color: #008800; font-weight: bold } /* Keyword.Reserved */
.highlight .kt { color: #888888; font-weight: bold } /* Keyword.Type */
.highlight .m { color: #0000DD; font-weight: bold } /* Literal.Number */
.highlight .s { color: #dd2200; background-color: #fff0f0 } /* Literal.String */
.highlight .na { color: #336699 } /* Name.Attribute */
.highlight .nb { color: #003388 } /* Name.Builtin */
.highlight .nc { color: #bb0066; font-weight: bold } /* Name.Class */
.highlight .no { color: #003366; font-weight: bold } /* Name.Constant */
.highlight .nd { color: #555555 } /* Name.Decorator */
.highlight .ne { color: #bb0066; font-weight: bold } /* Name.Exception */
.highlight .nf { color: #0066bb; font-weight: bold } /* Name.Function */
.highlight .nl { color: #336699; font-style: italic } /* Name.Label */
.highlight .nn { color: #bb0066; font-weight: bold } /* Name.Namespace */
.highlight .py { color: #336699; font-weight: bold } /* Name.Property */
.highlight .nt { color: #bb0066; font-weight: bold } /* Name.Tag */
.highlight .nv { color: #336699 } /* Name.Variable */
.highlight .ow { color: #008800 } /* Operator.Word */
.highlight .w { color: #bbbbbb } /* Text.Whitespace */
.highlight .mb { color: #0000DD; font-weight: bold } /* Literal.Number.Bin */
.highlight .mf { color: #0000DD; font-weight: bold } /* Literal.Number.Float */
.highlight .mh { color: #0000DD; font-weight: bold } /* Literal.Number.Hex */
.highlight .mi { color: #0000DD; font-weight: bold } /* Literal.Number.Integer */
.highlight .mo { color: #0000DD; font-weight: bold } /* Literal.Number.Oct */
.highlight .sa { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Affix */
.highlight .sb { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Backtick */
.highlight .sc { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Char */
.highlight .dl { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Delimiter */
.highlight .sd { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Doc */
.highlight .s2 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Double */
.highlight .se { color: #0044dd; background-color: #fff0f0 } /* Literal.String.Escape */
.highlight .sh { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Heredoc */
.highlight .si { color: #3333bb; background-color: #fff0f0 } /* Literal.String.Interpol */
.highlight .sx { color: #22bb22; background-color: #f0fff0 } /* Literal.String.Other */
.highlight .sr { color: #008800; background-color: #fff0ff } /* Literal.String.Regex */
.highlight .s1 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Single */
.highlight .ss { color: #aa6600; background-color: #fff0f0 } /* Literal.String.Symbol */
.highlight .bp { color: #003388 } /* Name.Builtin.Pseudo */
.highlight .fm { color: #0066bb; font-weight: bold } /* Name.Function.Magic */
.highlight .vc { color: #336699 } /* Name.Variable.Class */
.highlight .vg { color: #dd7700 } /* Name.Variable.Global */
.highlight .vi { color: #3333bb } /* Name.Variable.Instance */
.highlight .vm { color: #336699 } /* Name.Variable.Magic */
.highlight .il { color: #0000DD; font-weight: bold } /* Literal.Number.Integer.Long *//** \file
 *
 *  This file contains special DoxyGen information for the generation of the main page and other special
 *  documentation pages. It is not a project source file.
 */

/** \page Page_BuildLibrary Building as a Linkable Library
 *
 *  The LUFA library can be built as a proper linkable library (with the extention .a) under AVR-GCC, so that
 *  the library does not need to be recompiled with each revision of a user project. Instructions for creating
 *  a library from a given source tree can be found in the AVR-GCC user manual included in the WinAVR install
 *  /Docs/ directory.
 *
 *  However, building the library is <b>not recommended</b>, as the static (compile-time) options will be
 *  unable to be changed without a recompilation of the LUFA code. Therefore, if the library is to be built
 *  from the LUFA source, it should be made to be application-specific and compiled with the static options
 *  that are required for each project (which should be recorded along with the library).
 *
 *  Normal library use has the library components compiled in at the same point as the application code, as
 *  demonstrated in the library demos and applications. This is the preferred method, as the library is recompiled
 *  each time to ensure that all static options for a particular application are applied.
 */
--  LLVM back-end for ortho - Main subprogram.
--  Copyright (C) 2014 Tristan Gingold
--
--  This program is free software: you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation, either version 2 of the License, or
--  (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program.  If not, see <gnu.org/licenses>.

with Ada.Command_Line; use Ada.Command_Line;
with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Ada.Text_IO; use Ada.Text_IO;

with Ortho_Front; use Ortho_Front;
with LLVM.BitWriter;
with LLVM.Core; use LLVM.Core;
with LLVM.Target; use LLVM.Target;
with LLVM.TargetMachine; use LLVM.TargetMachine;
with LLVM.Analysis;
with LLVM.Transforms.Scalar;
with Ortho_LLVM; use Ortho_LLVM;
with Interfaces;
with Interfaces.C; use Interfaces.C;

procedure Ortho_Code_Main is
   --  Name of the output filename (given by option '-o').
   Output : String_Acc := null;

   type Output_Kind_Type is (Output_Llvm, Output_Bytecode,
                             Output_Assembly, Output_Object);
   Output_Kind : Output_Kind_Type := Output_Llvm;

   --  True if the LLVM output must be displayed (set by '--dump-llvm')
   Flag_Dump_Llvm : Boolean := False;

   --  Index of the first file argument.
   First_File : Natural;

   --  Current option index.
   Optind : Natural;

   --  Number of arguments.
   Argc : constant Natural := Argument_Count;

   --  Name of the module.
   Module_Name : String := "ortho" & Ascii.Nul;

   --  Target triple.
   Triple : Cstring := Empty_Cstring;

   Target : aliased TargetRef;

   CPU : constant Cstring := Empty_Cstring;
   Features : constant Cstring := Empty_Cstring;
   Reloc : RelocMode := RelocDefault;

   function To_String (C : Cstring) return String is
      function Strlen (C : Cstring) return Natural;
      pragma Import (C, Strlen);

      subtype Fat_String is String (Positive);
      type Fat_String_Acc is access Fat_String;

      function To_Fat_String_Acc is new
        Ada.Unchecked_Conversion (Cstring, Fat_String_Acc);
   begin
      return To_Fat_String_Acc (C)(1 .. Strlen (C));
   end To_String;

   Codegen : CodeGenFileType := ObjectFile;

   Msg : aliased Cstring;
begin
   Ortho_Front.Init;

   --  Decode options.
   First_File := Natural'Last;
   Optind := 1;
   while Optind <= Argc loop
      declare
         Arg : constant String := Argument (Optind);
      begin
         if Arg (1) = '-' then
            if Arg = "--dump-llvm" then
               Flag_Dump_Llvm := True;
            elsif Arg = "-o" then
               if Optind = Argc then
                  Put_Line (Standard_Error, "error: missing filename to '-o'");
                  return;
               end if;
               Output := new String'(Argument (Optind + 1) & ASCII.Nul);
               Optind := Optind + 1;
            elsif Arg = "-quiet" then
               --  Skip silently.
               null;
            elsif Arg = "-S" then
               Output_Kind := Output_Assembly;
               Codegen := AssemblyFile;
            elsif Arg = "-c" then
               Output_Kind := Output_Object;
               Codegen := ObjectFile;
            elsif Arg = "-O0" then
               Optimization := CodeGenLevelNone;
            elsif Arg = "-O1" or else Arg = "-O" then
               Optimization := CodeGenLevelLess;
            elsif Arg = "-O2" then
               Optimization := CodeGenLevelDefault;
            elsif Arg = "-O3" then
               Optimization := CodeGenLevelAggressive;
            elsif Arg = "-fpic" or Arg = "-fPIC" then
               Reloc := RelocPIC;
            elsif Arg = "-fno-pic" then
               Reloc := RelocStatic;
            elsif Arg = "--emit-llvm" then
               Output_Kind := Output_Llvm;
            elsif Arg = "--emit-bc" then
               Output_Kind := Output_Bytecode;
            elsif Arg = "-glines"
              or else Arg = "-gline-tables-only"
            then
               null;
            elsif Arg = "-g" then
               null;
            else
               --  This is really an argument.
               declare
                  procedure Unchecked_Deallocation is
                     new Ada.Unchecked_Deallocation
                    (Name => String_Acc, Object => String);

                  Opt : String_Acc := new String'(Arg);
                  Opt_Arg : String_Acc;
                  Res : Natural;
               begin
                  Opt_Arg := null;
                  if Optind < Argument_Count then
                     declare
                        Arg1 : constant String := Argument (Optind + 1);
                     begin
                        if Arg1 (Arg1'First) /= '-' then
                           Opt_Arg := new String'(Arg1);
                        end if;
                     end;
                  end if;

                  Res := Ortho_Front.Decode_Option (Opt, Opt_Arg);
                  case Res is
                     when 0 =>
                        Put_Line (Standard_Error,
                                  "unknown option '" & Arg & "'");
                        return;
                     when 1 =>
                        null;
                     when 2 =>
                        Optind := Optind + 1;
                     when others =>
                        raise Program_Error;
                  end case;
                  Unchecked_Deallocation (Opt);
                  Unchecked_Deallocation (Opt_Arg);
               end;
            end if;
         else
            First_File := Optind;
            exit;
         end if;
      end;
      Optind := Optind + 1;
   end loop;

   --  Link with LLVM libraries.
   InitializeNativeTarget;
   InitializeNativeAsmPrinter;

   --  LinkInJIT;

   Module := ModuleCreateWithName (Module_Name'Address);

   --  Extract target triple
   Triple := GetDefaultTargetTriple;
   SetTarget (Module, Triple);

   --  Get Target
   if GetTargetFromTriple (Triple, Target'Access, Msg'Access) /= 0 then
      raise Program_Error;
   end if;

   --  Create a target machine
   Target_Machine := CreateTargetMachine
     (Target, Triple, CPU, Features, Optimization, Reloc, CodeModelDefault);

   Target_Data := GetTargetMachineData (Target_Machine);

   SetDataLayout (Module, CopyStringRepOfTargetData (Target_Data));

   Ortho_LLVM.Init;

   Set_Exit_Status (Failure);

   if First_File > Argument_Count then
      begin
         if not Parse (null) then
            return;
         end if;
      exception
         when others =>
            return;
      end;
   else
      for I in First_File .. Argument_Count loop
         declare
            Filename : constant String_Acc :=
              new String'(Argument (First_File));
         begin
            if not Parse (Filename) then
               return;
            end if;
         exception
            when others =>
               return;
         end;
      end loop;
   end if;

   if Flag_Dump_Llvm then
      DumpModule (Module);
   end if;

   --  Verify module.
   if False then
      if LLVM.Analysis.VerifyModule
        (Module, LLVM.Analysis.PrintMessageAction, Msg'Access) /= 0
      then
         DisposeMessage (Msg);
         raise Program_Error;
      end if;
   end if;

   if Optimization > CodeGenLevelNone then
      declare
         use LLVM.Transforms.Scalar;
         Global_Manager : constant Boolean := False;
         Pass_Manager : PassManagerRef;
         Res : Bool;
         pragma Unreferenced (Res);
         A_Func : ValueRef;
      begin
         if Global_Manager then
            Pass_Manager := CreatePassManager;
         else
            Pass_Manager := CreateFunctionPassManagerForModule (Module);
         end if;

         LLVM.Target.AddTargetData (Target_Data, Pass_Manager);
         AddPromoteMemoryToRegisterPass (Pass_Manager);
         AddCFGSimplificationPass (Pass_Manager);

         if Global_Manager then
            Res := RunPassManager (Pass_Manager, Module);
         else
            A_Func := GetFirstFunction (Module);
            while A_Func /= Null_ValueRef loop
               Res := RunFunctionPassManager (Pass_Manager, A_Func);
               A_Func := GetNextFunction (A_Func);
            end loop;
         end if;
      end;
   end if;

   if Output /= null then
      declare
         Error : Boolean;
      begin
         Msg := Empty_Cstring;

         case Output_Kind is
            when Output_Assembly
              | Output_Object =>
               Error := LLVM.TargetMachine.TargetMachineEmitToFile
                 (Target_Machine, Module,
                  Output.all'Address, Codegen, Msg'Access) /= 0;
            when Output_Bytecode =>
               Error := LLVM.BitWriter.WriteBitcodeToFile
                 (Module, Output.all'Address) /= 0;
            when Output_Llvm =>
               Error := PrintModuleToFile
                 (Module, Output.all'Address, Msg'Access) /= 0;
         end case;
         if Error then
            Put_Line (Standard_Error,
                      "error while writing to " & Output.all);
            if Msg /= Empty_Cstring then
               Put_Line (Standard_Error,
                         "message: " & To_String (Msg));
               DisposeMessage (Msg);
            end if;
            Set_Exit_Status (2);
            return;
         end if;
      end;
   else
      DumpModule (Module);
   end if;

   Set_Exit_Status (Success);
exception
   when others =>
      Set_Exit_Status (2);
      raise;
end Ortho_Code_Main;