├── llvm-interface ├── gnat.adc ├── .gitignore ├── prep.control ├── move-if-change ├── configure_default_target.sh ├── Makefile.target ├── zfp │ ├── zfp.gpr │ ├── s-assert.ads │ ├── a-except.adb │ ├── s-assert.adb │ ├── a-except.ads │ └── i-c.ads ├── gnat_llvm_c.gpr ├── gnatllvm-records-create.ads ├── tools.gpr ├── options.ads ├── ccg │ ├── ccg-transform.ads │ ├── ccg-codegen.ads │ ├── ccg-subprograms.ads │ ├── ccg-write.ads │ ├── ccg-helper.adb │ ├── ccg-instructions.ads │ ├── ccg-flow.ads │ ├── ccg-target.ads │ ├── ccg-aggregates.ads │ └── ccg-output.ads ├── uintp-llvm.ads ├── targext.c ├── gnatllvm-helper.adb ├── gnatllvm-arrays-create.ads ├── gnat_llvm.gpr ├── gcc_missing.c ├── check_for_llvm_apis.sh ├── gnatllvm-records-debug.ads ├── gnatllvm-types-create.ads ├── sdefault.adb ├── back_end.adb ├── gnatllvm-compile.ads ├── check_for_LLVM_aliasing_bug.sh ├── gnatllvm-builtins.ads ├── gnatllvm-conditionals.ads ├── gnatllvm-debuginfo.ads ├── gnatllvm-blocks.ads ├── gnatllvm-codegen.ads ├── gnatllvm-exprs.ads ├── gnatllvm-variables.ads ├── uintp-llvm.adb ├── gnatllvm-records-field_ref.ads └── gnatllvm-conversions.ads ├── acats ├── README └── Makefile ├── fixedbugs ├── README └── Makefile ├── testsuite └── .gitignore ├── llvm ├── .gitignore ├── patches │ ├── NVPTXTargetMachinepatch.diff │ ├── LLVMStructTBAAPatch.diff │ ├── ScalarEvolutionExpanderPatch.diff │ └── 0001-Add-overload-of-DIBuilder-createArrayType.patch └── Makefile ├── .gitreview ├── .gitattributes ├── TODO ├── .gitignore ├── Makefile ├── .gitlab-ci.plan ├── README.dragonegg ├── README.md └── .gitlab-ci.yml /llvm-interface/gnat.adc: -------------------------------------------------------------------------------- 1 | pragma Restrictions (No_Tasking); 2 | -------------------------------------------------------------------------------- /acats/README: -------------------------------------------------------------------------------- 1 | This directory is specific to AdaCore developers. 2 | -------------------------------------------------------------------------------- /fixedbugs/README: -------------------------------------------------------------------------------- 1 | This directory is specific to AdaCore developers. 2 | -------------------------------------------------------------------------------- /testsuite/.gitignore: -------------------------------------------------------------------------------- 1 | # Build/test results directories 2 | out 3 | output 4 | srccov 5 | -------------------------------------------------------------------------------- /llvm/.gitignore: -------------------------------------------------------------------------------- 1 | # Build/test results directories 2 | llvm-obj 3 | install 4 | 5 | # Imported sources 6 | llvm-*.src 7 | -------------------------------------------------------------------------------- /.gitreview: -------------------------------------------------------------------------------- 1 | [gerrit] 2 | host = git.adacore.com 3 | project = gnat-llvm 4 | defaultbranch = master 5 | defaultremote = origin 6 | -------------------------------------------------------------------------------- /llvm-interface/.gitignore: -------------------------------------------------------------------------------- 1 | # Build/test results directories 2 | bin 3 | lib 4 | obj-tools 5 | 6 | # External projects 7 | gnat_src 8 | -------------------------------------------------------------------------------- /llvm-interface/prep.control: -------------------------------------------------------------------------------- 1 | * -c 2 | -- Preprocess all files, but instead of deleting disabled lines turn them into 3 | -- special comments. 4 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | llvm-interface/include/unwind-pe.h no-precommit-check 2 | llvm/adainclude/*.ad[bs] no-precommit-check 3 | llvm/clang-bindings/*.ad[bs] no-precommit-check 4 | -------------------------------------------------------------------------------- /llvm-interface/move-if-change: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Like mv $1 $2, but if the files are the same, just delete $1. 3 | # Status is 0 if $2 is changed, 1 otherwise. 4 | if 5 | test -r $2 6 | then 7 | if 8 | cmp -s $1 $2 9 | then 10 | echo $2 is unchanged 11 | rm -f $1 12 | else 13 | mv -f $1 $2 14 | fi 15 | else 16 | mv -f $1 $2 17 | fi 18 | -------------------------------------------------------------------------------- /llvm-interface/configure_default_target.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -eu 4 | 5 | default_target="$1" 6 | 7 | cat << EOF > obj/tmp-options-target.ads 8 | package Options.Target is 9 | Default_Target_Triple : constant String := "$default_target"; 10 | end Options.Target; 11 | EOF 12 | 13 | ./move-if-change obj/tmp-options-target.ads obj/options-target.ads 14 | -------------------------------------------------------------------------------- /llvm-interface/Makefile.target: -------------------------------------------------------------------------------- 1 | zfp-c: build 2 | $(MAKE) -f gnat_src/Makefile.rts-c \ 3 | ADAINCLUDE=lib/rts-ccg/adainclude ADALIB=lib/rts-ccg/adalib \ 4 | SPARK2C="$(pwd)/bin/c-gcc" GNAT_SRC=gnat_src \ 5 | SECONDARY_STACK=1 OVERFLOW_CHECKS=1 6 | 7 | ccg-links: 8 | cd bin; for f in llvm-*; do \ 9 | ln -sf $$f `echo $$f | sed -e "s/llvm-/c-/"`; \ 10 | done 11 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | Limitations and missing features (identified so far): 2 | 3 | - use compatible calling convention on x86-64 for C structures 4 | - create better debug info for subprogram return 5 | - debug info for non C compatible types 6 | - support for some -fxxx and -m (e.g -mtune) code generation switches 7 | - track alignment of GL_Values 8 | - properly set and track TBAA tags 9 | - set tbaa.struct metadata 10 | - set range metadata 11 | -------------------------------------------------------------------------------- /fixedbugs/Makefile: -------------------------------------------------------------------------------- 1 | .PHONEY: save-result run 2 | 3 | all: run 4 | 5 | save-results: 6 | if [ -d output/old ]; then rm -rf output/old; fi 7 | if [ -d output/new ]; then mv output/new output/old; fi 8 | 9 | run: 10 | (cd support; ./testsuite.py -o ../output/new --old-output-dir=../output/old --jobs=12 \ 11 | --tests-dir=../bugs --test-sections=fixed --max-consecutive-failures=30 \ 12 | --target=llvm --discriminants=native,linux,Linux,x86_64-linux,x86_64) 13 | -------------------------------------------------------------------------------- /llvm/patches/NVPTXTargetMachinepatch.diff: -------------------------------------------------------------------------------- 1 | *** lib/Target/NVPTX/NVPTXTargetMachine.cpp.old 2020-03-23 11:01:02.000000000 -0400 2 | --- lib/Target/NVPTX/NVPTXTargetMachine.cpp 2020-10-01 11:51:23.485703369 -0400 3 | *************** 4 | *** 100,104 **** 5 | Ret += "-p3:32:32-p4:32:32-p5:32:32"; 6 | 7 | ! Ret += "-i64:64-i128:128-v16:16-v32:32-n16:32:64"; 8 | 9 | return Ret; 10 | --- 100,104 ---- 11 | Ret += "-p3:32:32-p4:32:32-p5:32:32"; 12 | 13 | ! Ret += "-i64:64-i128:128-v16:16-v32:32-n16:32:64-S64"; 14 | 15 | return Ret; 16 | -------------------------------------------------------------------------------- /llvm-interface/zfp/zfp.gpr: -------------------------------------------------------------------------------- 1 | project ZFP is 2 | 3 | Common_Flags := Split (External ("CFLAGS", "-O2"), " ") & 4 | External_As_List ("EXTRALIBFLAGS", " "); 5 | Ada_Flags := Common_Flags & ("-nostdinc", "-I../adainclude") 6 | & Split (External ("ADAFLAGS", "-gnatpg"), " "); 7 | 8 | for Object_Dir use "../obj"; 9 | for Library_Name use "gnat"; 10 | for Library_Dir use "../adalib"; 11 | for Library_Kind use External ("LIBRARY_KIND", "static"); 12 | 13 | package Compiler is 14 | for Switches ("Ada") use Ada_Flags; 15 | end Compiler; 16 | 17 | end ZFP; 18 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Build/test results directories 2 | alis.list 3 | obj 4 | 5 | # Imported sources 6 | acats 7 | fixedbugs 8 | ccg-tests 9 | llvm-bindings 10 | 11 | # Code editors artifacts 12 | .#* 13 | #* 14 | *~ 15 | gnatinspect.db 16 | .dir-locals.el 17 | .helix 18 | compile_flags.txt 19 | 20 | # Compilation artifacts 21 | *.o 22 | *.ali 23 | *.bc 24 | *.s 25 | *.ll 26 | *.so 27 | a.out 28 | b~*.adb 29 | b~*.ads 30 | 31 | # Python testsuite artifacts 32 | *.pyc 33 | __pycache__ 34 | 35 | # Script generally used to define some environment variable to ease using 36 | # programs/libraries from the project. 37 | env 38 | 39 | # Vim 40 | *.swp 41 | *.swo 42 | -------------------------------------------------------------------------------- /acats/Makefile: -------------------------------------------------------------------------------- 1 | .PHONEY: save-result save-ccg-results tests ccg 2 | 3 | O=O0 4 | 5 | all: ccg tests 6 | 7 | save-results: 8 | if [ -d output/old ]; then rm -rf output/old; fi 9 | if [ -d output/new ]; then mv output/new output/old; fi 10 | 11 | save-ccg-results: 12 | if [ -d output-ccg/old ]; then rm -rf output-ccg/old; fi 13 | if [ -d output-ccg/new ]; then mv output-ccg/new output-ccg/old; fi 14 | 15 | tests: 16 | ./run_acats_test.py --target=llvm -t tmp -o output/new --old-output-dir=output/old --acats-version=4 --disable-cleanup --jobs=48 17 | 18 | ccg: 19 | CCG=1 OPTIMIZE=$(O) ./run_acats_test.py --target=ccg -t tmp-ccg -o output-ccg/new --old-output-dir=output-ccg/old --acats-version=4 --disable-cleanup --jobs=48 20 | -------------------------------------------------------------------------------- /llvm/patches/LLVMStructTBAAPatch.diff: -------------------------------------------------------------------------------- 1 | *** lib/Analysis/TypeBasedAliasAnalysis.cpp.old 2020-01-02 17:46:09.047102194 -0500 2 | --- lib/Analysis/TypeBasedAliasAnalysis.cpp 2020-01-02 17:52:33.489117324 -0500 3 | *************** 4 | *** 571,575 **** 5 | for (unsigned I = 0, E = BaseType.getNumFields(); I != E; ++I) { 6 | TBAAStructTypeNode T = BaseType.getFieldType(I); 7 | ! if (T == FieldType || hasField(T, FieldType)) 8 | return true; 9 | } 10 | --- 571,576 ---- 11 | for (unsigned I = 0, E = BaseType.getNumFields(); I != E; ++I) { 12 | TBAAStructTypeNode T = BaseType.getFieldType(I); 13 | ! if (matchAccessTags(createAccessTag(T.getNode()), 14 | ! createAccessTag(FieldType.getNode()))) 15 | return true; 16 | } 17 | -------------------------------------------------------------------------------- /llvm-interface/gnat_llvm_c.gpr: -------------------------------------------------------------------------------- 1 | project GNAT_LLVM_C is 2 | for Languages use ("C", "C++"); 3 | for Source_Dirs use (".", "obj"); 4 | for Object_Dir use "obj"; 5 | 6 | type Build_Type is ("Debug", "Production"); 7 | Build : Build_Type := External ("Build", "Debug"); 8 | 9 | package Compiler is 10 | case Build is 11 | when "Debug" => 12 | for Switches ("C") use ("-g"); 13 | for Switches ("C++") use ("-g"); 14 | 15 | when "Production" => 16 | for Switches ("C") use ("-O2", "-g"); 17 | for Switches ("C++") use ("-O2", "-g"); 18 | end case; 19 | end Compiler; 20 | 21 | package Naming is 22 | for Body_Suffix ("C++") use ".cc"; 23 | end Naming; 24 | 25 | end GNAT_LLVM_C; 26 | -------------------------------------------------------------------------------- /llvm/patches/ScalarEvolutionExpanderPatch.diff: -------------------------------------------------------------------------------- 1 | *** lib/Transforms/Utils/ScalarEvolutionExpander.cpp.old 2020-12-18 14:57:38.000000000 -0500 2 | --- lib/Transforms/Utils/ScalarEvolutionExpander.cpp 2021-02-22 19:45:20.988741704 -0500 3 | *************** 4 | *** 1416,1419 **** 5 | --- 1416,1430 ---- 6 | Result = PN->getIncomingValueForBlock(LatchBlock); 7 | 8 | + // We might be introducing a new use of the post-inc IV that is not poison 9 | + // safe, in which case we should drop poison generating flags. Only keep 10 | + // those flags for which SCEV has proven that they always hold. 11 | + if (isa(Result)) { 12 | + auto *I = cast(Result); 13 | + if (!S->hasNoUnsignedWrap()) 14 | + I->setHasNoUnsignedWrap(false); 15 | + if (!S->hasNoSignedWrap()) 16 | + I->setHasNoSignedWrap(false); 17 | + } 18 | + 19 | // For an expansion to use the postinc form, the client must call 20 | // expandCodeFor with an InsertPoint that is either outside the PostIncLoop 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: sanity-check 2 | $(MAKE) -C llvm-interface build gnatlib-automated 3 | 4 | .PHONY: acats ccg-acats fixed-bugs ccg-tests llvm clean distclean 5 | 6 | sanity-check: 7 | @if ! [ -d llvm-interface/gnat_src ]; then \ 8 | echo "error: directory llvm-interface/gnat_src not found"; exit 1; \ 9 | fi 10 | 11 | build build-opt clean gnatlib bootstrap automated zfp: sanity-check 12 | $(MAKE) -C llvm-interface $@ 13 | 14 | gnatlib%: sanity-check 15 | $(MAKE) -C llvm-interface $@ 16 | 17 | # Entry points for cross builds. Currently, it builds a cross compiler that 18 | # isn't bootstrapped (i.e., we build it directly with native GNAT). The 19 | # runtimes need to be built separately. 20 | cross-automated: 21 | $(MAKE) -C llvm-interface build-opt 22 | 23 | # Build the full runtime instrumented with SymCC. This target requires SymCC and 24 | # a working GNAT-LLVM on the path, i.e., it builds only the runtime. 25 | symcc-automated: 26 | $(MAKE) -C llvm-interface \ 27 | RTSBASE=rts-symcc \ 28 | gnatlib-symcc-automated 29 | 30 | llvm: 31 | $(MAKE) -j1 -C llvm setup 32 | $(MAKE) -C llvm llvm 33 | 34 | acats: 35 | $(MAKE) -C acats tests 36 | 37 | ccg-acats: 38 | $(MAKE) -C acats ccg 39 | 40 | fixed-bugs: 41 | $(MAKE) -C fixedbugs 42 | 43 | ccg-tests: 44 | $(MAKE) -C ccg-tests/tests 45 | 46 | distclean: clean 47 | $(MAKE) -C llvm clean 48 | 49 | -------------------------------------------------------------------------------- /.gitlab-ci.plan: -------------------------------------------------------------------------------- 1 | def build(): 2 | # Do not rebuild gcc/gnat 3 | anod_install("gcc") 4 | anod_build("gnat-llvm") 5 | 6 | 7 | def build_ccg(): 8 | anod_install("gcc") 9 | anod_install("gnat-doc", qualifier="ugx") 10 | anod_build("gnat-llvm-core", qualifier="ccg") 11 | 12 | 13 | def test_fixedbugs(): 14 | anod_install("gnat-llvm") 15 | anod_build("aunit", qualifier={"compiler": "gnat-llvm"}) 16 | anod_build("gnatcoll-core", qualifier={"compiler": "gnat-llvm"}) 17 | anod_build("libgpr", qualifier={"compiler": "gnat-llvm"}) 18 | anod_build("xmlada", qualifier={"compiler": "gnat-llvm"}) 19 | anod_test("fixedbugs", qualifier="compiler=gnat-llvm") 20 | 21 | 22 | def test_acats(): 23 | anod_install("gnat-llvm") 24 | anod_test("acats", qualifier="compiler=gnat-llvm") 25 | 26 | 27 | def ccg_common(): 28 | anod_install("gcc", build="x86-linux") 29 | # Installed from the artifact 30 | anod_install("gnat-llvm-core", qualifier="ccg") 31 | # We need to force the build here, since the dependency to the sources 32 | # is lost by the installation of gnat-llvm-core 33 | anod_build("ccg", target="c") 34 | 35 | 36 | def test_acats_ccg(): 37 | ccg_common() 38 | anod_test("acats-4-ccg", target="c") 39 | 40 | def test_acats_ccg_optimized(): 41 | ccg_common() 42 | anod_test("acats-4-ccg", target="c", qualifier={"optimize": True}) 43 | 44 | def test_ccg(): 45 | ccg_common() 46 | anod_test("ccg", target="c") 47 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-records-create.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | package GNATLLVM.Records.Create is 19 | 20 | function Create_Record_Type (TE : Record_Kind_Id) return MD_Type 21 | with Post => Present (Create_Record_Type'Result); 22 | -- Create a type for the record denoted by TE 23 | 24 | end GNATLLVM.Records.Create; 25 | -------------------------------------------------------------------------------- /llvm-interface/tools.gpr: -------------------------------------------------------------------------------- 1 | with "gnat_llvm_c"; 2 | 3 | project Tools is 4 | for Source_Dirs use (".", "obj", "gnat_src"); 5 | for Object_Dir use "obj"; 6 | for Exec_Dir use "bin"; 7 | for Languages use ("Ada"); 8 | 9 | for Main use 10 | ("gnatmake.adb", "gnatbind.adb", "gnatlink.adb", "gnatchop.adb", 11 | "gnatkr.adb", "gnatls.adb", "gnatprep.adb", "gnatname.adb", 12 | "gnatclean.adb", "gnatcmd.adb"); 13 | 14 | package Builder is 15 | for Executable ("gnatmake.adb") use "llvm-gnatmake"; 16 | for Executable ("gnatbind.adb") use "llvm-gnatbind"; 17 | for Executable ("gnatlink.adb") use "llvm-gnatlink"; 18 | for Executable ("gnatchop.adb") use "llvm-gnatchop"; 19 | for Executable ("gnatkr.adb") use "llvm-gnatkr"; 20 | for Executable ("gnatls.adb") use "llvm-gnatls"; 21 | for Executable ("gnatprep.adb") use "llvm-gnatprep"; 22 | for Executable ("gnatname.adb") use "llvm-gnatname"; 23 | for Executable ("gnatclean.adb") use "llvm-gnatclean"; 24 | for Executable ("gnatcmd.adb") use "llvm-gnat"; 25 | 26 | for Switches ("Ada") use ("-m"); 27 | for Global_Configuration_Pragmas use "gnat.adc"; 28 | end Builder; 29 | 30 | type Build_Type is ("Debug", "Production"); 31 | Build : Build_Type := External ("Build", "Debug"); 32 | 33 | Common_Switches := ("-g", "-gnatg"); 34 | 35 | package Compiler is 36 | case Build is 37 | when "Debug" => 38 | for Switches ("Ada") use Common_Switches & ("-gnata", "-gnateE"); 39 | 40 | when "Production" => 41 | for Switches ("Ada") use Common_Switches & ("-O2", "-gnatpn"); 42 | end case; 43 | end Compiler; 44 | 45 | package Linker is 46 | -- Force -static-libgcc via Required_Switches so that gprbuild does 47 | -- not override it. 48 | for Required_Switches use ("-static-libgcc"); 49 | for Switches ("Ada") use ("-static-libstdc++"); 50 | end Linker; 51 | 52 | end Tools; 53 | -------------------------------------------------------------------------------- /llvm-interface/options.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2022-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | -- We provide a unit separate from GNATLLVM to avoid dragging dependencies 19 | -- on LLVM libraries in GNAT tools. 20 | 21 | with Ada.Command_Line; use Ada.Command_Line; 22 | with GNAT.Directory_Operations; use GNAT.Directory_Operations; 23 | with System.OS_Lib; use System.OS_Lib; 24 | 25 | package Options is 26 | 27 | Executable : constant String := Base_Name (Command_Name, ".exe"); 28 | First : constant Integer := Executable'First; 29 | 30 | CCG : constant Boolean := 31 | Getenv ("CCG").all /= "" 32 | or else (Executable'Length > 2 33 | and then Executable (First .. First + 1) = "c-"); 34 | -- True if CCG mode should be enabled 35 | 36 | end Options; 37 | -------------------------------------------------------------------------------- /llvm-interface/ccg/ccg-transform.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- C C G -- 3 | -- -- 4 | -- Copyright (C) 2020-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with CCG.Helper; use CCG.Helper; 19 | 20 | package CCG.Transform is 21 | 22 | -- This package contains subprograms used to do transformations to the 23 | -- LLVM IR prior to generating C code from them. 24 | 25 | function Has_Unique_Predecessor (BB : Basic_Block_T) return Boolean 26 | with Pre => Present (BB); 27 | -- Return True iff BB has only one effective predeccessor. By "effective" 28 | -- we mean that if the it does have a single predecessor but that block 29 | -- is just an unconditional branch plus optionally Phi nodes, that 30 | -- predecessor also must only have a single predecessor. 31 | 32 | procedure Transform_Blocks (V : Value_T) 33 | with Pre => Is_A_Function (V); 34 | -- Transform the basic blocks in V so that we can generate cleaner code 35 | 36 | end CCG.Transform; 37 | -------------------------------------------------------------------------------- /README.dragonegg: -------------------------------------------------------------------------------- 1 | Why not DragonEgg? 2 | ------------------ 3 | 4 | If you know about the DragonEgg project (https://dragonegg.llvm.org/) then a 5 | natural question is "why starting a GNAT LLVM project from scratch instead of 6 | building on top of DragonEgg?" 7 | 8 | From a technical perspective, it's a closer call, but there are a number of 9 | non-technical advantages of our approach: 10 | 11 | - We want a "pure" LLVM approach that is as easy to integrate and fit 12 | into the LLVM ecosystem as possible; 13 | 14 | - DragonEgg makes the whole technology more fragile: any change in any part 15 | may break things in a potentially hard to identify way 16 | (GNAT+Gigi+GCC+DragonEgg+LLVM vs GNAT+GNAT LLVM+LLVM) 17 | 18 | - The GNAT LLVM approach allows us to have code written in Ada instead of 19 | C++ in the case of DragonEgg. 20 | 21 | There are also limitations in the current state of DragonEgg, which we'd 22 | have to remove as part of a project based on DragonEgg: 23 | 24 | - It hasn't been touched since 2014 (except for 25 | https://reviews.llvm.org/D35667) and as far as Ada is concerned, 26 | supports only LLVM 3.3 and GCC 4.6. 27 | 28 | - It only supports x86 and ARM processor families (at least in terms of 29 | supported builtins) 30 | 31 | - Debug info support is poor 32 | 33 | The technical advantage of a DragonEgg approach is that we could use all 34 | the present "tree lowering" code that's not only in Gigi, but in GCC (for 35 | example, GCC knows how to do a MOD, not REM, operation, but we have to 36 | produce that code from scratch) and we need at least some sort of 37 | intermediate structure between the GNAT tree and the LLVM IR. But a 38 | disadvantage is that DragonEgg's goal and strength is the ability to 39 | support all GCC front-ends and here we are focusing on good Ada support, so 40 | we wouldn't really be taking advantage of this strength. Another 41 | disadvantage is that some concepts (such as alias sets) don't map well 42 | between GCC and LLVM and it's better to directly generate the LLVM style 43 | of the concepts directly from the sources. 44 | 45 | Finally, DragonEgg was meant as a way to bring many language front-ends to 46 | LLVM. Since then, all languages supported by GCC have been plugged to 47 | LLVM except Ada, so this would leave DragonEgg Ada specific, 48 | with lots of unnecessary complexity. 49 | -------------------------------------------------------------------------------- /llvm-interface/uintp-llvm.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with LLVM.Types; use LLVM.Types; 19 | 20 | with GNATLLVM; use GNATLLVM; 21 | 22 | package Uintp.LLVM is 23 | 24 | function UI_To_Words (U : Uint) return Word_Array; 25 | -- Convert a Uint into an array of words representing the value 26 | 27 | function UI_To_LLVM (T : Type_T; U : Uint) return Value_T; 28 | -- Convert a Uint into an LLVM native integer constant 29 | 30 | function UI_To_ULL (U : Uint) return ULL; 31 | function "+" (U : Uint) return ULL renames UI_To_ULL; 32 | -- Like UI_To_Int, but for Unsigned_Long_Long 33 | 34 | function UI_Is_In_ULL_Range (U : Uint) return Boolean; 35 | -- Like UI_Is_In_Int_Range, but for Unsigned_Long_Long; 36 | 37 | function UI_From_ULL (V : ULL) return Uint is 38 | (UI_From_LLI (LLI (V))); 39 | function "+" (V : ULL) return Uint renames UI_From_ULL; 40 | -- Like UI_From_Int, but for ULL. 41 | -- ??? This implementation doesn't work for the highest half of ULL, 42 | -- but we're not going to see sizes that large (the only place where 43 | -- this is used), so that's OK. 44 | 45 | end Uintp.LLVM; 46 | -------------------------------------------------------------------------------- /llvm-interface/targext.c: -------------------------------------------------------------------------------- 1 | /**************************************************************************** 2 | * * 3 | * GNAAMP COMPILER COMPONENTS * 4 | * * 5 | * J T A R G E X T * 6 | * * 7 | * C Implementation File * 8 | * * 9 | * Copyright (C) 2006-2025, AdaCore * 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. * 17 | * * 18 | * You should have received a copy of the GNU General Public License and * 19 | * a copy of the GCC Runtime Library Exception along with this program; * 20 | * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * 21 | * . * 22 | * * 23 | ****************************************************************************/ 24 | 25 | /* This is the LLVM substitute for "targext.c" that is needed for building 26 | certain GNAT tools (such as llvm-gnatmake). */ 27 | 28 | /* This file contains target-specific parameters describing the file */ 29 | /* extension for object and executable files. It is used by the compiler, */ 30 | /* binder and tools. */ 31 | 32 | #define TARGET_OBJECT_SUFFIX ".o" 33 | #define TARGET_EXECUTABLE_SUFFIX "" 34 | 35 | const char *__gnat_target_object_extension = TARGET_OBJECT_SUFFIX; 36 | const char *__gnat_target_executable_extension = TARGET_EXECUTABLE_SUFFIX; 37 | const char *__gnat_target_debuggable_extension = TARGET_EXECUTABLE_SUFFIX; 38 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-helper.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | package body GNATLLVM.Helper is 19 | -------------------- 20 | -- Set_Subprogram -- 21 | -------------------- 22 | 23 | procedure Set_Subprogram_Debug_Metadata (V : GL_Value; M : Metadata_T) is 24 | begin 25 | Set_Subprogram (+V, M); 26 | end Set_Subprogram_Debug_Metadata; 27 | 28 | -------------------------------- 29 | -- Add_Named_Metadata_Operand -- 30 | -------------------------------- 31 | 32 | procedure Add_Named_Metadata_Operand (Name : String; M : Metadata_T) is 33 | begin 34 | Add_Named_Metadata_Operand (Name, Metadata_As_Value (M)); 35 | end Add_Named_Metadata_Operand; 36 | 37 | -------------------------------- 38 | -- Add_Named_Metadata_Operand -- 39 | -------------------------------- 40 | 41 | procedure Add_Named_Metadata_Operand (Name : String; V : Value_T) is 42 | begin 43 | Add_Named_Metadata_Operand (Module, Name, V); 44 | end Add_Named_Metadata_Operand; 45 | 46 | -------------------------------- 47 | -- Set_Current_Debug_Location -- 48 | ------------------------------- 49 | 50 | procedure Set_Current_Debug_Location (MD : Metadata_T) is 51 | begin 52 | Set_Current_Debug_Location_2 (IR_Builder, MD); 53 | end Set_Current_Debug_Location; 54 | 55 | end GNATLLVM.Helper; 56 | -------------------------------------------------------------------------------- /llvm/Makefile: -------------------------------------------------------------------------------- 1 | # Note that this Makefile is optional and mainly used by core GNAT LLVM 2 | # developers: you can use an existing install of LLVM instead. 3 | # llvm-interface/Makefile will work as long as llvm-config is found in your 4 | # PATH. 5 | 6 | PWD:=$(shell pwd) 7 | LLVM_RELEASE=19.1.7 8 | LLVM_INSTALL_DIR=$(PWD)/install 9 | LLVM_SRC_DIR=llvm-project-$(LLVM_RELEASE).src 10 | DL=wget 11 | LLVM_SRC_FNAME=$(LLVM_SRC_DIR).tar.xz 12 | LLVM_RELEASE_URL=https://github.com/llvm/llvm-project/releases/download/llvmorg-$(LLVM_RELEASE) 13 | LLVM_SRC_LINK=$(LLVM_RELEASE_URL)/$(LLVM_SRC_FNAME) 14 | LLVM_TARGETS=X86 15 | # Linking LLVM libraries and binaries requires lots of RAM and is a common cause 16 | # for out-of-memory errors. Restricting the build system to a single link job at 17 | # a time doesn't affect the build time significantly but protects us from those 18 | # memory issues. 19 | CMAKE_FLAGS=-DLLVM_TARGETS_TO_BUILD="$(LLVM_TARGETS)" \ 20 | -DBUILD_SHARED_LIBS=ON -DLLVM_INCLUDE_BENCHMARKS=OFF -DLLVM_ENABLE_PROJECTS=clang \ 21 | -DLLVM_PARALLEL_LINK_JOBS=1 \ 22 | -DLLVM_ENABLE_RUNTIMES="compiler-rt;libunwind" \ 23 | -DCLANG_DEFAULT_RTLIB=compiler-rt -DCLANG_DEFAULT_UNWINDLIB=libunwind \ 24 | -DLIBUNWIND_WEAK_PTHREAD_LIB=ON -DLIBUNWIND_USE_COMPILER_RT=ON 25 | # LLVM 15 requires us to specify a CMake build type explicitly; we use Debug for 26 | # the default target. 27 | CMAKE_FLAGS_DEBUG=-DCMAKE_BUILD_TYPE=Debug 28 | # No-debug mode is still good for GNAT-LLVM development: we enable assertions 29 | # and debug info. But it's much faster than debug mode because the LLVM code is 30 | # optimized during compilation. 31 | CMAKE_FLAGS_NO_DEBUG=-DCMAKE_BUILD_TYPE=RelWithDebInfo -DLLVM_ENABLE_ASSERTIONS=ON 32 | CMAKE_FLAGS_PROD=-DCMAKE_BUILD_TYPE=RelWithDebInfo 33 | 34 | .PHONY: configure 35 | 36 | all: setup llvm 37 | 38 | CONFIGURE=cd llvm-obj && CXX=g++ CC=gcc CXXC=g++ \ 39 | cmake -G "Unix Makefiles" -DCMAKE_INSTALL_PREFIX=$(LLVM_INSTALL_DIR) \ 40 | $(CMAKE_FLAGS) ../$(LLVM_SRC_DIR)/llvm 41 | 42 | setup: $(LLVM_SRC_DIR) 43 | 44 | $(LLVM_SRC_DIR): 45 | $(DL) $(LLVM_SRC_LINK) 46 | tar xJf $(LLVM_SRC_FNAME) 47 | rm $(LLVM_SRC_FNAME) 48 | 49 | llvm-obj/CMakeCache.txt: 50 | mkdir -p llvm-obj 51 | $(CONFIGURE) $(CMAKE_FLAGS_DEBUG) 52 | 53 | configure-no-debug: 54 | mkdir -p llvm-obj 55 | $(CONFIGURE) $(CMAKE_FLAGS_NO_DEBUG) 56 | 57 | configure-prod: 58 | mkdir -p llvm-obj 59 | $(CONFIGURE) $(CMAKE_FLAGS_PROD) 60 | 61 | llvm: llvm-obj/CMakeCache.txt 62 | $(MAKE) -s -C llvm-obj 63 | 64 | install: llvm 65 | cd llvm-obj && cmake -P cmake_install.cmake 66 | 67 | clean: 68 | rm -rf llvm-obj $(LLVM_INSTALL_DIR) 69 | 70 | distclean: clean 71 | rm -rf $(LLVM_SRC_DIR) 72 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-arrays-create.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | package GNATLLVM.Arrays.Create is 19 | 20 | function Create_Array_Type 21 | (TE : Type_Kind_Id; For_Orig : Boolean := False) return MD_Type 22 | with Pre => (if For_Orig then Is_Packed_Array_Impl_Type (TE) 23 | else Is_Array_Type (TE)), 24 | Post => Present (Create_Array_Type'Result); 25 | -- Return the type used to represent Array_Type_Node. This will be 26 | -- an opaque type if LLVM can't represent it directly. If For_Orig 27 | -- is True, set the array info for the Original_Record_Type of TE. 28 | 29 | function Create_Array_Fat_Pointer_Type 30 | (GT : Array_Or_PAT_GL_Type) return MD_Type 31 | with Post => Present (Create_Array_Fat_Pointer_Type'Result); 32 | -- Return the type used for fat pointers to the array type GT 33 | 34 | function Create_Array_Bounds_Type (GT : Array_Or_PAT_GL_Type) return MD_Type 35 | with Post => Present (Create_Array_Bounds_Type'Result); 36 | -- Return the type used to store array bounds. This is a structure 37 | -- that that follows the following pattern: { LB0, UB0, LB1, UB1, ... } 38 | 39 | function Create_Array_Bounds_And_Data_Type 40 | (GT : Array_Or_PAT_GL_Type) return MD_Type 41 | with Post => Present (Create_Array_Bounds_And_Data_Type'Result); 42 | -- Return the type used to store the bounds and data of an array 43 | 44 | end GNATLLVM.Arrays.Create; 45 | -------------------------------------------------------------------------------- /llvm-interface/zfp/s-assert.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT RUN-TIME COMPONENTS -- 4 | -- -- 5 | -- S Y S T E M . A S S E R T I O N S -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- Copyright (C) 1992-2025, 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. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- GNAT was originally developed by the GNAT team at New York University. -- 28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- This is the ZFP version of this file. 33 | 34 | package System.Assertions is 35 | 36 | Assert_Failure : exception; 37 | -- Exception raised when assertion fails 38 | 39 | procedure Raise_Assert_Failure (Msg : String) with Inline_Always; 40 | -- Called to raise Assert_Failure with given message 41 | 42 | end System.Assertions; 43 | -------------------------------------------------------------------------------- /llvm-interface/zfp/a-except.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A D A . E X C E P T I O N S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- Copyright (C) 1992-2025, 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. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- GNAT was originally developed by the GNAT team at New York University. -- 28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | package body Ada.Exceptions is 33 | 34 | --------------------- 35 | -- Raise_Exception -- 36 | --------------------- 37 | 38 | procedure Raise_Exception (E : Exception_Id; Message : String := "") is 39 | pragma Unreferenced (E, Message); 40 | begin 41 | raise Program_Error; 42 | end Raise_Exception; 43 | 44 | end Ada.Exceptions; 45 | -------------------------------------------------------------------------------- /llvm-interface/zfp/s-assert.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT RUN-TIME COMPONENTS -- 4 | -- -- 5 | -- S Y S T E M . A S S E R T I O N S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- Copyright (C) 1992-2025, 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. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- GNAT was originally developed by the GNAT team at New York University. -- 28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- This version is for ZFP run times 33 | 34 | package body System.Assertions is 35 | 36 | -------------------------- 37 | -- Raise_Assert_Failure -- 38 | -------------------------- 39 | 40 | procedure Raise_Assert_Failure (Msg : String) is 41 | begin 42 | raise Assert_Failure with Msg; 43 | end Raise_Assert_Failure; 44 | 45 | end System.Assertions; 46 | -------------------------------------------------------------------------------- /llvm-interface/gnat_llvm.gpr: -------------------------------------------------------------------------------- 1 | with "gnat_llvm_c"; 2 | 3 | project Gnat_LLVM is 4 | for Source_Dirs use 5 | (".", "obj", "gnat_src", "ccg", "../llvm-bindings/adainclude"); 6 | for Object_Dir use "obj"; 7 | for Exec_Dir use "bin"; 8 | for Languages use ("Ada"); 9 | for Main use ("gnat1drv.adb", "gcc_wrapper.adb"); 10 | 11 | type Build_Type is ("Debug", "Production"); 12 | Build : Build_Type := External ("Build", "Debug"); 13 | 14 | type Supported_LLVM_Version is ("16", "19"); 15 | LLVM_Version : Supported_LLVM_Version := External ("LLVM_Version", "16"); 16 | 17 | package Builder is 18 | for Executable ("gnat1drv.adb") use "llvm-gnat1"; 19 | for Executable ("gcc_wrapper.adb") use "llvm-gcc"; 20 | 21 | for Switches ("Ada") use ("-m"); 22 | for Global_Configuration_Pragmas use "gnat.adc"; 23 | end Builder; 24 | 25 | Common_Switches := ("-g", "-gnatg", "-gnatep=prep.control", 26 | "-gnateDLLVM_Version_Major=" & LLVM_Version); 27 | 28 | package Compiler is 29 | case Build is 30 | when "Debug" => 31 | for Switches ("Ada") use Common_Switches & ("-gnata", "-gnateE"); 32 | 33 | when "Production" => 34 | for Switches ("Ada") use 35 | Common_Switches & ("-O2", "-gnatpn"); 36 | end case; 37 | end Compiler; 38 | 39 | package Linker is 40 | -- Force -static-libgcc via Required_Switches so that gprbuild does 41 | -- not override it. 42 | for Required_Switches use ("-static-libgcc"); 43 | for Switches ("Ada") use ("-static-libstdc++", "-lclangBasic"); 44 | end Linker; 45 | 46 | package CodePeer is 47 | for Switches use ("-level", "1"); 48 | -- ("-level", "3", "--be-messages=validity_check", "--no-lal-checkers", 49 | -- "-dbg-on", "limitations"); 50 | for Excluded_Source_Dirs use ("gnat_src", "obj"); 51 | end CodePeer; 52 | 53 | package Coverage is 54 | for Ignored_Source_Files use 55 | ("ada_get_targ.adb", -- used by CodePeer/SPARK 56 | "bindo-validators*", -- debug code 57 | "*ccg*", -- LLVM-based CCG back-end 58 | "cprint*", -- old CCG back-end 59 | "*_dist.adb", -- annex E 60 | "g-*", -- runtime files, only partly used by GNAT 61 | "llvm*", -- llvm bindings 62 | "c?info.adb", -- preprocessing tools 63 | "x[elnostu]*", -- preprocessing tools 64 | "get_scos.adb", 65 | "indepsw-*", 66 | "*dll*", -- old gnatdll tool 67 | "pprint.adb", -- used by CodePeer/SPARK 68 | "sa_message*", -- used by CodePeer 69 | "*scil*", -- used by CodePEer 70 | "sco*", -- used by GNATcov 71 | "*spark*", -- used by SPARK 72 | "vast.adb"); -- empty file for now 73 | end Coverage; 74 | 75 | end Gnat_LLVM; 76 | -------------------------------------------------------------------------------- /llvm-interface/gcc_missing.c: -------------------------------------------------------------------------------- 1 | /**************************************************************************** 2 | * * 3 | * GNAT COMPILER COMPONENTS * 4 | * * 5 | * j m i s s i n g * 6 | * * 7 | * Copyright (C) 1998-2025, AdaCore * 8 | * * 9 | * GNAT is free software; you can redistribute it and/or modify it under * 10 | * terms of the GNU General Public License as published by the Free Soft- * 11 | * ware Foundation; either version 3, or (at your option) any later ver- * 12 | * sion. GNAT is distributed in the hope that it will be useful, but WITH- * 13 | * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * 14 | * or FITNESS FOR A PARTICULAR PURPOSE. * 15 | * * 16 | * You should have received a copy of the GNU General Public License and * 17 | * a copy of the GCC Runtime Library Exception along with this program; * 18 | * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * 19 | * . * 20 | * * 21 | ****************************************************************************/ 22 | 23 | /* This file contains the C routines or variables which are defined in 24 | some GCC source (and hence not available when compiling here). */ 25 | 26 | /* Originally defined in GCC's toplev.c. GNAT uses this flag to 27 | determine whether stack checking is enabled on the target (controls 28 | allocation strategy for large objects in certain cases). */ 29 | int flag_stack_check = 0; 30 | 31 | /* Originally defined in GCC's common.opt. Controls the balance between GNAT 32 | encodings and standard DWARF to emit in the debug infomation. Useful for 33 | DWARF debugging information generation only so not used in CodePeer. */ 34 | int gnat_encodings = 0; 35 | 36 | /* Originally defined in GCC's toplev.c. */ 37 | int optimize = 0; 38 | int optimize_size = 0; 39 | 40 | /* Originally defined in toplev.c, used in exp_cg.adb. */ 41 | void *callgraph_info_file = (void *)0; 42 | 43 | /* Originally defined in misc.c. */ 44 | unsigned int save_argc = 0; 45 | const char **save_argv = (const char **)0; 46 | 47 | /* Originally defined in GCC's prefix.c. We need a dummy 48 | update_path and set_std_prefix for osint.adb. */ 49 | void 50 | set_std_prefix (char *path, int len) 51 | { 52 | } 53 | 54 | char * 55 | update_path (char *path, char *key) 56 | { 57 | return path; 58 | } 59 | 60 | /* Originally defined in version.c */ 61 | const char gnat_version_string[] = "1.0"; 62 | 63 | -------------------------------------------------------------------------------- /llvm-interface/check_for_llvm_apis.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | set -u 3 | 4 | # Usage: check_for_llvm_api.sh "path/to/llvm-config" 5 | 6 | llvm_config="$1" 7 | 8 | cxxflags=$($llvm_config --cxxflags) 9 | ldflags=$($llvm_config --libs all --ldflags --system-libs) 10 | 11 | # The output defines. 12 | rm -f obj/def_*.h 13 | 14 | # Test for some specific LLVM API. 15 | api_test() { 16 | defname="$1" 17 | program="$2" 18 | filename=obj/test_${defname}.cpp 19 | 20 | # Just include whatever headers are required by any test. 21 | cat < $filename 22 | #include "llvm/IR/DIBuilder.h" 23 | #include "llvm/IR/DebugInfo.h" 24 | using namespace llvm; 25 | $program 26 | EOF 27 | 28 | if gcc $cxxflags $ldflags --syntax-only $filename 2> /dev/null; then 29 | echo "#define GNAT_LLVM_$defname" >obj/def_${defname}.h 30 | fi 31 | 32 | rm $filename 33 | } 34 | 35 | # Test a ".ll" file to see if llvm-as parses it. 36 | ll_test() { 37 | defname="$1" 38 | program="$2" 39 | filename=obj/test_${defname}.ll 40 | llvmas=$($llvm_config --bindir)/llvm-as 41 | 42 | echo "$program" > $filename 43 | if $llvmas < $filename > /dev/null 2>&1; then 44 | echo "#define GNAT_LLVM_$defname" >obj/def_${defname}.h 45 | fi 46 | } 47 | 48 | api_test HAVE_SUBRANGE_TYPE "DISubrangeType *subrange_value = nullptr;" & 49 | # This checks for both the "name" patch and the "bit stride" patch. 50 | api_test HAVE_ARRAY_NAME "MDNode *named(DIBuilder *builder) { return builder->createArrayType(nullptr, StringRef(), nullptr, 0, 32, 0, nullptr, {}, nullptr, nullptr, nullptr, nullptr, nullptr); }" & 51 | api_test HAVE_FIXED_POINT "DIFixedPointType *fp_type = nullptr;" & 52 | 53 | # This method's signature changed in the patch to allow types to have 54 | # function scope. 55 | api_test HAVE_TYPE_FN_SCOPE "void call(DebugInfoFinder *f, DILocalVariable *v) { f->processVariable(v); }" & 56 | 57 | # Test that checks if sizes and offsets can be dynamic. 58 | api_test HAVE_DYNAMIC_OFFSETS "void call(DIBuilder *b) { b->createMemberType(nullptr, StringRef(), nullptr, 0, nullptr, 0, nullptr, DINode::FlagZero, nullptr); }" & 59 | 60 | # Test whether multiple members can be included in a variant. 61 | api_test HAVE_MULTI_MEMBER_VARIANT "void call(DIBuilder *b) { b->createVariantMemberType(nullptr, DINodeArray(), (Constant*)nullptr, (DIType*)nullptr); }" & 62 | 63 | # Test whether DISubrangeType can hold a DIDerivedType. This was 64 | # added after the initial DISubrangeType patch. 65 | api_test HAVE_SUBRANGE_TYPE_EXTENSION "DIDerivedType *call(DISubrangeType::BoundType bound) { return bound.dyn_cast(); }" & 66 | 67 | # Test whether DIExpression can handle DW_OP_rot, DW_OP_neg, and 68 | # DW_OP_ops. A single test is sufficient because these all landed in 69 | # the same patch. 70 | ll_test HAVE_DW_EXPRESSION_EXTENSIONS '!named = !{!DIExpression(DW_OP_push_object_address, DW_OP_lit0, DW_OP_lit0, DW_OP_neg, DW_OP_abs, DW_OP_rot, DW_OP_rot, DW_OP_rot, DW_OP_plus, DW_OP_plus)}' & 71 | 72 | wait 73 | 74 | for def in obj/def_*.h; do 75 | cat $def 76 | done > obj/tmp-gnat-llvm-config.h 77 | ./move-if-change obj/tmp-gnat-llvm-config.h obj/gnat-llvm-config.h 78 | 79 | rm -f obj/def_*.h 80 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-records-debug.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with Repinfo; use Repinfo; 19 | 20 | package GNATLLVM.Records.Debug is 21 | -- Subpackage for creating the LLVM debuginfo for a given record. 22 | 23 | function Hash (F : Record_Field_Kind_Id) return Ada.Containers.Hash_Type 24 | is (Hash_Type (F)); 25 | -- A hash function for use in the discriminant map. 26 | 27 | package Discriminant_Map_Pkg is new Ada.Containers.Hashed_Maps 28 | (Key_Type => Record_Field_Kind_Id, 29 | Element_Type => Metadata_T, 30 | Hash => Hash, 31 | Equivalent_Keys => "="); 32 | -- A map from a discriminant's (canonical) entity to the LLVM debuginfo. 33 | 34 | subtype Discriminant_Map is Discriminant_Map_Pkg.Map; 35 | -- The type of a discriminant map. 36 | 37 | function Canonical_Discriminant_For (E : Entity_Id) return Entity_Id; 38 | -- A helper function to find the canonical discriminant (for the 39 | -- purposes of debuginfo generation) given some discriminant. 40 | 41 | function Create_Record_Debug_Info (TE : Void_Or_Type_Kind_Id; 42 | Original_Type : Entity_Id; 43 | Debug_Scope : Metadata_T; 44 | Name : String; 45 | Size : ULL; 46 | Align : Nat; 47 | S : Source_Ptr) return Metadata_T; 48 | -- Create the LLVM debuginfo for a given record. 49 | 50 | function Convert_To_Dwarf_Expression (Expr : Node_Ref_Or_Val; 51 | Original_Type : Entity_Id) 52 | return Metadata_T; 53 | -- Convert a back annotation expression to a DWARF expression. 54 | -- Returns the LLVM metadata for the expression. Note that this 55 | -- may return a DIExpression, but if the expression it is just a 56 | -- constant it will return a Constant. 57 | 58 | end GNATLLVM.Records.Debug; 59 | -------------------------------------------------------------------------------- /llvm-interface/ccg/ccg-codegen.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- C C G -- 3 | -- -- 4 | -- Copyright (C) 2022-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | package CCG.Codegen is 19 | 20 | type Inline_Header is (None, Inline_Always, Inline); 21 | -- Says whether to output no function to .h file, only those that are 22 | -- are marked as Inline_Always, or those plus ones marked Inline. 23 | 24 | Emit_Header : Boolean := False; 25 | -- If True, emit header to .h file 26 | 27 | Header_Inline : Inline_Header := None; 28 | -- Says which inline functions to write to .h file 29 | 30 | Emit_C_Line : Boolean := False; 31 | -- When generating C code, indicates that we want to generate #line 32 | -- directives. This corresponds to -g. 33 | 34 | Inlines_In_Header : Boolean := False; 35 | -- If True, we have at least one inline function in the header file 36 | 37 | Use_Stdint : Boolean := False; 38 | -- If True, use the integer type names in 39 | 40 | Prefer_Packed : Boolean := False; 41 | -- If True, prefe to emit a "packed" attribute on records 42 | 43 | Elab_Spec_Func : Value_T := No_Value_T; 44 | Elab_Body_Func : Value_T := No_Value_T; 45 | -- Function corresponding to the spec and body elab proc, respectively. 46 | 47 | procedure Initialize_Output; 48 | -- Do any initialization needed to output C. This is always called after 49 | -- we've obtained target parameters. 50 | 51 | procedure Note_Enum (TE : E_Enumeration_Type_Id); 52 | -- Indicate that we're processing the declaration of TE, an enumeration 53 | -- type. 54 | 55 | procedure Generate (Module : Module_T); 56 | -- The main procedure, which generates C code from the LLVM IR 57 | 58 | function Process_Switch (S : String) return Boolean; 59 | -- S is a switch passed to GNAT LLVM. If it's a switch meaningful 60 | -- to us, process it and return True. 61 | 62 | function Is_Switch (S : String) return Boolean; 63 | -- S is a switch passed to GNAT LLVM. If it's a switch meaningful 64 | -- to CCG, return True. 65 | 66 | end CCG.Codegen; 67 | -------------------------------------------------------------------------------- /llvm-interface/zfp/a-except.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT RUN-TIME COMPONENTS -- 4 | -- -- 5 | -- A D A . E X C E P T I O N S -- 6 | -- (Version for No Exception Handlers/No_Exception_Propagation) -- 7 | -- -- 8 | -- S p e c -- 9 | -- -- 10 | -- Copyright (C) 1992-2025, Free Software Foundation, Inc. -- 11 | -- -- 12 | -- This specification is derived from the Ada Reference Manual for use with -- 13 | -- GNAT. The copyright notice above, and the license provisions that follow -- 14 | -- apply solely to the contents of the part following the private keyword. -- 15 | -- -- 16 | -- GNAT is free software; you can redistribute it and/or modify it under -- 17 | -- terms of the GNU General Public License as published by the Free Soft- -- 18 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 19 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 20 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 21 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 22 | -- -- 23 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 24 | -- additional permissions described in the GCC Runtime Library Exception, -- 25 | -- version 3.1, as published by the Free Software Foundation. -- 26 | -- -- 27 | -- You should have received a copy of the GNU General Public License and -- 28 | -- a copy of the GCC Runtime Library Exception along with this program; -- 29 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 30 | -- . -- 31 | -- -- 32 | -- GNAT was originally developed by the GNAT team at New York University. -- 33 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- 34 | -- -- 35 | ------------------------------------------------------------------------------ 36 | 37 | -- Version for use when there are no handlers in the partition (i.e. either 38 | -- of Restriction No_Exception_Handlers or No_Exception_Propagation is set). 39 | 40 | with System; 41 | 42 | package Ada.Exceptions 43 | with Preelaborate 44 | is 45 | 46 | type Exception_Id is private with Preelaborable_Initialization; 47 | 48 | Null_Id : constant Exception_Id; 49 | 50 | procedure Raise_Exception (E : Exception_Id; Message : String := "") 51 | with No_Return, Inline_Always; 52 | 53 | private 54 | 55 | type Exception_Id is access all System.Address; 56 | Null_Id : constant Exception_Id := null; 57 | 58 | end Ada.Exceptions; 59 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-types-create.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | package GNATLLVM.Types.Create is 19 | 20 | function Create_Type (TE : Void_Or_Type_Kind_Id) return MD_Type 21 | with Pre => TE = Get_Fullest_View (TE), 22 | Post => Present (Create_Type'Result); 23 | -- Given a GNAT type TE, build the corresponding LLVM type, building 24 | -- a GL_Type first if necessary. 25 | 26 | procedure Copy_Annotations (In_TE, Out_TE : Type_Kind_Id) 27 | with Pre => In_TE = Get_Fullest_View (Out_TE); 28 | -- Copy any annotations we made from In_TE to Out_TE 29 | 30 | procedure Annotate_Object_Size_And_Alignment 31 | (E : Exception_Or_Object_Kind_Id; 32 | GT : GL_Type; 33 | Want_Max : Boolean := True); 34 | -- Perform back-annotation of size and alignment of E. If Want_Max is 35 | -- True, we want the maximum size of GT, in case it's an unconstrained 36 | -- record type. 37 | 38 | function Validate_Alignment 39 | (E : Entity_Id; Align : Uint; Current_Align : Nat) return Uint 40 | with Pre => Present (E), 41 | Post => Present (Validate_Alignment'Result); 42 | -- Current_Align is the current alignment of E, either because it's the 43 | -- alignment of the LLVM type (if E is a type) or because it's the 44 | -- alignment of E's type (if E if an object). Align is a proposed 45 | -- alignment for E. See if it's valid (possibly issuing an error 46 | -- message if not) and return it if so or some other acceptable value 47 | -- if not. 48 | 49 | function Validate_Size 50 | (E : Entity_Id; 51 | GT : GL_Type; 52 | Size : Uint; 53 | For_Type : Boolean := False; 54 | For_Component : Boolean := False; 55 | Zero_Allowed : Boolean := False; 56 | Is_RM_Size : Boolean := False) return Uint 57 | with Pre => Present (E) and then Present (GT); 58 | -- Validate that size Size is valid for entity E of type GT. For_Type 59 | -- is True if we're doing this for a type, For_Component if this is 60 | -- for the component of an array and Zero_Allowed if a size of zero is 61 | -- considered a valid size. Give an error message if needed and return 62 | -- a valid size. Is_RM_Size indicates this size is from RM_Size; 63 | -- this may change the text of the error message. 64 | 65 | end GNATLLVM.Types.Create; 66 | -------------------------------------------------------------------------------- /llvm-interface/ccg/ccg-subprograms.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- C C G -- 3 | -- -- 4 | -- Copyright (C) 2020-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with LLVM.Core; use LLVM.Core; 19 | 20 | with CCG.Helper; use CCG.Helper; 21 | with CCG.Utils; use CCG.Utils; 22 | 23 | package CCG.Subprograms is 24 | 25 | -- This package contains subprograms and data used in the handling of 26 | -- subprograms and writing out the final C code. 27 | 28 | procedure Add_To_Source_Order (N : Node_Id) 29 | with Pre => Nkind (N) in N_Pragma | N_Subprogram_Declaration | 30 | N_Subprogram_Body | N_Object_Declaration | 31 | N_Object_Renaming_Declaration | 32 | N_Exception_Declaration | 33 | N_Exception_Renaming_Declaration; 34 | -- Add N to the list of file-level objects present in the source if 35 | -- it indeed does come from the source. 36 | 37 | procedure Protect_Source_Order; 38 | -- Make a pass over everything we added to the source order and 39 | -- set up to be notified if any of them have been deleted. 40 | 41 | procedure New_Subprogram (V : Value_T) 42 | with Pre => Present (Is_A_Function (V)); 43 | -- Switch to a new subprogram V 44 | 45 | function Curr_Func return Value_T 46 | with Post => Present (Curr_Func'Result); 47 | -- Return the decl for the function being converted to C 48 | 49 | procedure Call_Instruction (V : Value_T; Ops : Value_Array) 50 | with Pre => Is_A_Call_Inst (V); 51 | -- Process a call instruction 52 | 53 | procedure Declare_Subprogram (V : Value_T) 54 | with Pre => Is_A_Function (V); 55 | -- Write a declaration for subprogram V 56 | 57 | procedure Output_Subprogram (V : Value_T) 58 | with Pre => Is_A_Function (V); 59 | -- Generate the C statements and decls for V, a subprogram 60 | 61 | procedure Output_Function_Type_Typedef (T : Type_T) 62 | with Pre => Is_Function_Type (Get_Element_Type (T)); 63 | -- Output a typedef for T, which is a pointer to a function type 64 | 65 | procedure Add_Decl_Line (Idx : Local_Decl_Idx) 66 | with Pre => Present (Idx); 67 | procedure Add_Stmt_Line (Idx : Stmt_Idx) 68 | with Pre => Present (Idx); 69 | -- Add a declaration or statement line to the current subprogram 70 | 71 | procedure Write_C_File; 72 | -- Write all the typedefs, globals, and decls and statements for 73 | -- all subprograms. 74 | 75 | end CCG.Subprograms; 76 | -------------------------------------------------------------------------------- /llvm-interface/sdefault.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- S D E F A U L T -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- Copyright (C) 1998-2025, AdaCore -- 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 | ------------------------------------------------------------------------------ 22 | 23 | -- This is the GNAT-to-LLVM version of package body Sdefault. 24 | 25 | -- This package body provides the llvm-gnat1 implementation of the routines 26 | -- that locate the Ada library source and object directories. 27 | 28 | with Options; use Options; 29 | with Options.Target; use Options.Target; 30 | with Osint; use Osint; 31 | 32 | package body Sdefault is 33 | pragma Style_Checks (Off); 34 | 35 | ------------------------------ 36 | -- Include_Dir_Default_Name -- 37 | ------------------------------ 38 | 39 | function Include_Dir_Default_Name return String_Ptr is 40 | begin 41 | return Relocate_Path ("/PREFIX", 42 | (if CCG then "/PREFIX/lib/rts-ccg/adainclude" 43 | else "/PREFIX/lib/gnat-llvm/" & 44 | Default_Target_Triple & 45 | "/rts-native/adainclude")); 46 | end Include_Dir_Default_Name; 47 | 48 | ----------------------------- 49 | -- Object_Dir_Default_Name -- 50 | ----------------------------- 51 | 52 | function Object_Dir_Default_Name return String_Ptr is 53 | begin 54 | return Relocate_Path ("/PREFIX", 55 | (if CCG then "/PREFIX/lib/rts-ccg/adalib" 56 | else "/PREFIX/lib/gnat-llvm/" & 57 | Default_Target_Triple & 58 | "/rts-native/adalib")); 59 | end Object_Dir_Default_Name; 60 | 61 | ----------------------- 62 | -- Search_Dir_Prefix -- 63 | ----------------------- 64 | 65 | function Search_Dir_Prefix return String_Ptr is 66 | begin 67 | return Relocate_Path ("/PREFIX", 68 | (if CCG then "/PREFIX/lib/" 69 | else "/PREFIX/lib/gnat-llvm/" & 70 | Default_Target_Triple & "//")); 71 | end Search_Dir_Prefix; 72 | 73 | ----------------- 74 | -- Target_Name -- 75 | ----------------- 76 | 77 | function Target_Name return String_Ptr is 78 | begin 79 | return new String'(Default_Target_Triple); 80 | end Target_Name; 81 | 82 | end Sdefault; 83 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | GNAT LLVM 2 | ========= 3 | 4 | This is an Ada compiler based on LLVM, connecting the GNAT front-end to the 5 | LLVM code generator to generate LLVM bitcode for Ada and to open the LLVM 6 | ecosystem to Ada. 7 | 8 | Note that we are not planning on replacing any existing GNAT port that's 9 | based on GCC: this project is meant to provide additional, not replacement, 10 | GNAT ports. 11 | 12 | You are welcome to experiment with this technology and provide 13 | feedback on successes, usages, limitations, pull requests, etc. 14 | 15 | - For more information on LLVM, see [llvm.org](https://llvm.org). 16 | - For more information on GNAT, see [adacore.com](https://www.adacore.com). 17 | 18 | Building 19 | -------- 20 | 21 | To build GNAT LLVM from sources, follow these steps: 22 | 23 | - First do a checkout of this repository and go to this directory: 24 | 25 | git clone https://github.com/AdaCore/gnat-llvm.git 26 | cd gnat-llvm 27 | 28 | - Then obtain a check out of the latest GNAT sources from gcc.gnu.org under 29 | the llvm-interface directory: 30 | 31 | git clone git://gcc.gnu.org/git/gcc.git llvm-interface/gcc 32 | 33 | then under non Windows systems: 34 | 35 | ln -s gcc/gcc/ada llvm-interface/gnat_src 36 | 37 | under Windows systems: 38 | 39 | mv llvm-interface/gcc/gcc/ada llvm-interface/gnat_src 40 | 41 | - Obtain the Ada bindings for LLVM: 42 | 43 | git clone https://github.com/AdaCore/llvm-bindings.git 44 | 45 | - Install (and put in your PATH) a recent GNAT, e.g GNAT Community 2021 46 | or GCC 11. 47 | 48 | - Install LLVM and Clang 19.1.x 49 | 50 | The recommended way to build GNAT LLVM is to use an existing LLVM and 51 | Clang package installed via e.g. `brew install llvm` on Mac OS or `sudo 52 | apt-get install llvm-dev` on Ubuntu. You can also build LLVM yourself with 53 | the options that suit your needs. After installing/building, make sure the 54 | LLVM bin directory containing `llvm-config` and `clang` is in your `PATH`. 55 | 56 | An alternative only suitable for core GNAT LLVM development on x86 native 57 | configurations is to use the following command, assuming you have CMake 58 | version >= 3.20 in your path: 59 | 60 | make llvm 61 | 62 | Note that there's currently a bug in LLVM's aliasing handling. We check 63 | for it and generate slightly pessimized code in that case, but a patch 64 | to be applied to LLVM's `lib/Analyze` directory is in the file 65 | `llvm/patches/LLVMStructTBAAPatch.diff`. 66 | 67 | - Finally build GNAT LLVM: 68 | 69 | make 70 | 71 | This creates a "ready to use" set of directories "bin" and "lib" under 72 | llvm-interface which you can put in your PATH: 73 | 74 | PATH=$PWD/llvm-interface/bin:$PATH 75 | 76 | - If you want in addition to generate bitcode for the GNAT runtime, you can do: 77 | 78 | make gnatlib-bc 79 | 80 | This will generate `libgnat.bc` and `libgnarl.bc` in the `adalib` directory, along 81 | with `libgnat.a` and `libgnarl.a`. 82 | 83 | Usage 84 | ----- 85 | 86 | - To run the compiler and produce a native object file: 87 | 88 | llvm-gcc -c file.adb 89 | 90 | - To debug the compiler: 91 | 92 | gdb -args llvm-gnat1 -c file.adb 93 | 94 | - To build a complete native executable: 95 | 96 | llvm-gnatmake main.adb 97 | 98 | - To build a whole project: 99 | 100 | gprbuild -Pprj ... 101 | 102 | - To generate LLVM bitcode (will generate a .bc file): 103 | 104 | llvm-gcc -c -emit-llvm file.adb 105 | 106 | - To generate LLVM assembly (will generate a .ll file): 107 | 108 | llvm-gcc -c -S -emit-llvm file.adb 109 | 110 | - To generate native assembly file (will generate a .s file): 111 | 112 | llvm-gcc -S file.adb 113 | 114 | License 115 | ------- 116 | 117 | The GNAT LLVM tool is licensed under the GNU General Public License version 3 118 | or later; see file `COPYING3` for details. 119 | -------------------------------------------------------------------------------- /llvm-interface/ccg/ccg-write.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- C C G -- 3 | -- -- 4 | -- Copyright (C) 2020-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with CCG.Output; use CCG.Output; 19 | with CCG.Strs; use CCG.Strs; 20 | 21 | package CCG.Write is 22 | 23 | -- This package contains subprograms and data used to output the saved 24 | -- C statements into the output file. 25 | 26 | Needs_Malloc_H : Boolean := False; 27 | -- True if we need to add an include for because we 28 | -- use alloca. 29 | 30 | procedure Write_Value 31 | (V : Value_T; 32 | Flags : Value_Flags := Default_Value_Flags; 33 | For_Precedence : Precedence := Primary) 34 | with Pre => Present (V); 35 | procedure Write_Type 36 | (T : Type_T; 37 | Flags : Type_Flags := Default_Type_Flags; 38 | E : Entity_Id := Empty; 39 | V : Value_T := No_Value_T) 40 | with Pre => Present (T); 41 | procedure Write_BB_Value (BB : Basic_Block_T) 42 | with Pre => Present (BB); 43 | -- Write the name of a value, type, or basic block. For types, possibly 44 | -- use entity or value to help say something about the type. 45 | 46 | procedure Write_C_Name (S : String; Need_Suffix : Boolean := False) 47 | with Pre => S'Length > 0; 48 | -- Write S as a valid name in C. If Need_Suffix is True, force a 49 | -- suffix to distinguish it from a normal C name. 50 | 51 | -- just write the initial definition of the struct, with no fields. 52 | 53 | procedure Initialize_Writing; 54 | procedure Finalize_Writing; 55 | -- Set up for writing lines of C and finalize writing them 56 | 57 | procedure Write_C_Line (OL : Out_Line); 58 | procedure Write_C_Line 59 | (Idx : Stmt_Idx; Start_Block, End_Block : Block_Style := None) 60 | with Pre => Present (Idx); 61 | procedure Write_C_Line (Idx : Typedef_Idx); 62 | procedure Write_C_Line (Idx : Global_Decl_Idx); 63 | procedure Write_C_Line (Idx : Local_Decl_Idx) 64 | with Pre => Present (Idx); 65 | procedure Write_C_Line 66 | (S : Str; 67 | Indent_Type : Indent_Style := Normal; 68 | End_Block : Block_Style := None; 69 | V : Value_T := No_Value_T; 70 | No_Debug_Info : Boolean := False) 71 | with Pre => Present (S); 72 | procedure Write_C_Line 73 | (S : String; 74 | Indent_Type : Indent_Style := Normal; 75 | End_Block : Block_Style := None; 76 | V : Value_T := No_Value_T; 77 | No_Debug_Info : Boolean := False); 78 | -- Write one line to our output file, taking care of any required 79 | -- debug data, source line writing, and #line directives. 80 | 81 | end CCG.Write; 82 | -------------------------------------------------------------------------------- /llvm-interface/ccg/ccg-helper.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- C C G -- 3 | -- -- 4 | -- Copyright (C) 2020-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with stddef_h; 19 | with Interfaces.C; use Interfaces.C; 20 | with Interfaces.C.Strings; use Interfaces.C.Strings; 21 | 22 | package body CCG.Helper is 23 | 24 | --------------------------- 25 | -- Const_Real_Get_Double -- 26 | --------------------------- 27 | 28 | function Const_Real_Get_Double 29 | (V : Value_T; Loses_Info : out Boolean) return Double 30 | is 31 | C_Loses_Info : aliased Bool_T; 32 | Result : constant Double := 33 | Const_Real_Get_Double (V, C_Loses_Info'Access); 34 | 35 | begin 36 | Loses_Info := C_Loses_Info /= 0; 37 | return Result; 38 | end Const_Real_Get_Double; 39 | 40 | --------------------- 41 | -- Get_Opcode_Name -- 42 | --------------------- 43 | 44 | function Get_Opcode_Name (Opc : Opcode_T) return String is 45 | function Get_Opcode_Name_C (Opc : Opcode_T) return chars_ptr 46 | with Import, Convention => C, External_Name => "Get_Opcode_Name"; 47 | begin 48 | return Value (Get_Opcode_Name_C (Opc)); 49 | end Get_Opcode_Name; 50 | 51 | ------------------- 52 | -- Get_As_String -- 53 | ------------------- 54 | 55 | function Get_As_String (V : Value_T) return String is 56 | Length : aliased stddef_h.size_t; 57 | S : constant String := Get_As_String (V, Length'Access); 58 | begin 59 | return S; 60 | end Get_As_String; 61 | 62 | ---------------------------- 63 | -- Get_Debug_Loc_Filename -- 64 | ---------------------------- 65 | 66 | function Get_Debug_Loc_Filename (V : Value_T) return String is 67 | Length : aliased unsigned; 68 | Str : constant String := Get_Debug_Loc_Filename (V, Length'Access); 69 | 70 | begin 71 | return Str; 72 | end Get_Debug_Loc_Filename; 73 | 74 | ----------------------------- 75 | -- Get_Debug_Loc_Directory -- 76 | ----------------------------- 77 | 78 | function Get_Debug_Loc_Directory (V : Value_T) return String is 79 | Length : aliased unsigned; 80 | Str : constant String := Get_Debug_Loc_Directory (V, Length'Access); 81 | 82 | begin 83 | return Str; 84 | end Get_Debug_Loc_Directory; 85 | 86 | ------------------------ 87 | -- Get_Debug_Loc_Line -- 88 | ------------------------ 89 | 90 | function Get_Debug_Loc_Line (V : Value_T) return Physical_Line_Number is 91 | Line : constant unsigned := Get_Debug_Loc_Line (V); 92 | begin 93 | return (if Line = 0 then 1 else Physical_Line_Number (Line)); 94 | end Get_Debug_Loc_Line; 95 | 96 | ------------------- 97 | -- Set_Successor -- 98 | ------------------- 99 | 100 | procedure Set_Successor (V : Value_T; J : Nat; BB : Basic_Block_T) is 101 | begin 102 | Set_Successor (V, unsigned (J), BB); 103 | end Set_Successor; 104 | 105 | end CCG.Helper; 106 | -------------------------------------------------------------------------------- /.gitlab-ci.yml: -------------------------------------------------------------------------------- 1 | stages: 2 | - check 3 | - build 4 | - test # not actually used, needed for test template 5 | - test-gnat-llvm 6 | - test-ccg 7 | 8 | # CCG testing is launched when some specific files have changed, or manually 9 | .ccg-rulesrules_template:: &ccg-rules 10 | - if: $CI_PIPELINE_SOURCE == 'merge_request_event' 11 | changes: 12 | - llvm-interface/ccg/* 13 | - if: $CI_PIPELINE_SOURCE == 'merge_request_event' 14 | when: manual 15 | allow_failure: true # This improves reporting. Otherwise the CI remains "stuck" untils those jobs are launched 16 | 17 | include: 18 | # Issue check 19 | - component: $CI_SERVER_FQDN/eng/gitlab-templates/check-issue@~latest 20 | 21 | # Build 22 | - component: $CI_SERVER_FQDN/eng/gitlab-templates/build@~latest 23 | inputs: 24 | anod-args: run build 25 | generic-anod-ci-args: --add-dep eng/toolchain/gnat 26 | cpus: 16 27 | save-component: true 28 | windows: true 29 | windows-cpus: 8 30 | windows-mem: 16 31 | 32 | - component: $CI_SERVER_FQDN/eng/gitlab-templates/build@~latest 33 | inputs: 34 | job-name: build-ccg 35 | component-name: ccg 36 | anod-args: run build_ccg 37 | generic-anod-ci-args: --add-dep eng/toolchain/gnat 38 | cpus: 16 39 | save-component: true 40 | 41 | # Testing of gnat-llvm 42 | - component: $CI_SERVER_FQDN/eng/gitlab-templates/test@~latest 43 | inputs: 44 | job-name: fixedbugs 45 | stage: test-gnat-llvm 46 | anod-args: run test_fixedbugs 47 | generic-anod-ci-args: --add-dep eng/toolchain/gnatbugs-fixed 48 | windows: true 49 | windows-cpus: 8 50 | windows-mem: 16 51 | - component: $CI_SERVER_FQDN/eng/gitlab-templates/test@~latest 52 | inputs: 53 | job-name: acats 54 | stage: test-gnat-llvm 55 | anod-args: run test_acats 56 | generic-anod-ci-args: --add-dep eng/toolchain/acats 57 | windows: true 58 | windows-cpus: 8 59 | windows-mem: 16 60 | 61 | # Testing of ccg 62 | - component: $CI_SERVER_FQDN/eng/gitlab-templates/test@~latest 63 | inputs: 64 | job-name: ccg 65 | component-name: ccg 66 | # Declaring an explicit dependency on the "build-ccg" job is required to 67 | # make generic_anod_ci import the right set of Cathod components. 68 | needs: 69 | - build-ccg:linux 70 | stage: test-ccg 71 | anod-args: run test_ccg 72 | generic-anod-ci-args: --add-dep eng/toolchain/ccg-tests 73 | rules: *ccg-rules 74 | - component: $CI_SERVER_FQDN/eng/gitlab-templates/test@~latest 75 | inputs: 76 | job-name: acats-ccg 77 | component-name: ccg 78 | # Declaring an explicit dependency on the "build-ccg" job is required to 79 | # make generic_anod_ci import the right set of Cathod components. 80 | needs: 81 | - build-ccg:linux 82 | stage: test-ccg 83 | anod-args: run test_acats_ccg 84 | generic-anod-ci-args: --add-dep eng/toolchain/acats 85 | rules: *ccg-rules 86 | - component: $CI_SERVER_FQDN/eng/gitlab-templates/test@~latest 87 | inputs: 88 | job-name: acats-ccg-optimized 89 | component-name: ccg 90 | # Declaring an explicit dependency on the "build-ccg" job is required to 91 | # make generic_anod_ci import the right set of Cathod components. 92 | needs: 93 | - build-ccg:linux 94 | stage: test-ccg 95 | anod-args: run test_acats_ccg_optimized 96 | generic-anod-ci-args: --add-dep eng/toolchain/acats 97 | rules: *ccg-rules 98 | 99 | # Additional customization 100 | 101 | .fixedbugs:common: 102 | # It happens regularly that tests are added which fail for GNAT-LLVM; not 103 | # failing the pipeline improves the user experience in such cases because it 104 | # lets us merge without scary warning messages (while still showing failed 105 | # tests for assessment). 106 | allow_failure: true 107 | 108 | .build:common: 109 | variables: 110 | # Let's not bother with the docs; they're unaffected by this repository's 111 | # code. 112 | ANOD_ENABLE_DOC: false 113 | 114 | build:windows: 115 | rules: 116 | # The Windows build shouldn't trigger automatically because it takes a long 117 | # time, and most changes aren't specific to Windows. Also mark it as 118 | # non-critical because otherwise the pipeline gets stuck if the job isn't 119 | # started. 120 | - if: $CI_PIPELINE_SOURCE == "merge_request_event" 121 | allow_failure: true 122 | when: manual 123 | 124 | acats:windows: 125 | timeout: 4h 126 | 127 | fixedbugs:windows: 128 | timeout: 4h 129 | -------------------------------------------------------------------------------- /llvm-interface/ccg/ccg-instructions.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- C C G -- 3 | -- -- 4 | -- Copyright (C) 2020-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with CCG.Environment; use CCG.Environment; 19 | with CCG.Helper; use CCG.Helper; 20 | with CCG.Strs; use CCG.Strs; 21 | 22 | package CCG.Instructions is 23 | 24 | procedure Force_To_Variable (V : Value_T) 25 | with Pre => Present (V), Post => No (Get_C_Value (V)); 26 | -- If V has an expression for it, declare V as a variable and copy the 27 | -- expression into it. 28 | 29 | procedure Assignment 30 | (LHS : Value_T; RHS : Str; Is_Opencode_Builtin : Boolean := False) 31 | with Pre => Present (LHS) and then Present (RHS); 32 | -- Take action to assign LHS the value RHS. If Is_Builtin is True, 33 | -- this is a call instruction that we've rewritten as code, so 34 | -- no call is involved. 35 | 36 | procedure Instruction (V : Value_T; Ops : Value_Array) 37 | with Pre => Acts_As_Instruction (V); 38 | -- Output the instruction V with operands Ops 39 | 40 | procedure Process_Instruction (V : Value_T) 41 | with Pre => Acts_As_Instruction (V); 42 | -- Process instruction V 43 | 44 | type Process_Operand_Option is (POO_Signed, POO_Unsigned, X); 45 | -- An operand to Process_Operand that says whether we care which 46 | -- signedless the operand is and, if so, which one. 47 | 48 | function Process_Operand 49 | (V : Value_T; POO : Process_Operand_Option; P : Precedence) return Str 50 | with Pre => Present (V), Post => Present (Process_Operand'Result); 51 | -- Called when we care about any high bits in a possible partial-word 52 | -- operand and possibly about signedness. We return the way to 53 | -- reference V. If nothing is special, this is just +V + P. 54 | 55 | procedure Output_Copy 56 | (LHS, RHS : Str; T : Type_T; V : Value_T := No_Value_T) 57 | with Pre => Present (LHS) and then Present (RHS) and then Present (T); 58 | procedure Output_Copy (LHS : Str; RHS : Value_T; T : Type_T) 59 | with Pre => Present (LHS) and then Present (RHS) and then Present (T); 60 | procedure Output_Copy (LHS, RHS : Value_T; T : Type_T) 61 | with Pre => Present (LHS) and then Present (RHS) and then Present (T); 62 | procedure Output_Copy (LHS : Value_T; RHS : Str; T : Type_T) 63 | with Pre => Present (LHS) and then Present (RHS) and then Present (T); 64 | -- Write a statement to copy RHS, of type T, to LHS. If V is Present, 65 | -- it represents something that may give line/file information. 66 | 67 | procedure Process_Pending_Values (Calls_Only : Boolean := False); 68 | -- Walk the set of pending values in reverse order and generate 69 | -- assignments for any that haven't been written yet. Is Call_Only, 70 | -- we only want to process pending calls (this is used when seeing a 71 | -- load). 72 | 73 | procedure Clear_Pending_Values with Inline; 74 | -- Clear any pending values that remain in the table. We do this after 75 | -- we've processed all of them and at the end of a subprogram. In the 76 | -- latter case, they're dead, but we don't want them to be output as 77 | -- part of another subprogram. 78 | 79 | function Create_Annotation (N : N_Pragma_Id) return Nat; 80 | -- Return the value to eventually pass to Output_Annotation to perform 81 | -- the operation designated by the pragma N if there is one to perform. 82 | -- Otherwise, return 0. 83 | 84 | procedure Output_Annotation (J : Nat; V : Value_T; Is_Global : Boolean); 85 | -- Output the annotation we recorded as J (the return of the previous 86 | -- function) in instruction V. If Is_Global, this is at file level. 87 | 88 | end CCG.Instructions; 89 | -------------------------------------------------------------------------------- /llvm/patches/0001-Add-overload-of-DIBuilder-createArrayType.patch: -------------------------------------------------------------------------------- 1 | From 0f4581dbb39fbfe04977a25ddca76cd689f7fc5f Mon Sep 17 00:00:00 2001 2 | From: Tom Tromey 3 | Date: Mon, 27 Jan 2025 12:45:14 -0700 4 | Subject: [PATCH 1/3] Add overload of DIBuilder::createArrayType 5 | 6 | DICompositeType has an attribute representing the name of a type, but 7 | currently it isn't possible to set this for array types via the 8 | DIBuilder method. This patch adds a new overload of 9 | DIBuilder::createArrayType that allows "full" construction of an array 10 | type. This is useful for Ada, where arrays are a bit more first-class 11 | than C. 12 | --- 13 | llvm/include/llvm/IR/DIBuilder.h | 29 +++++++++++++++++++++++++++++ 14 | llvm/lib/IR/DIBuilder.cpp | 25 +++++++++++++++++++++++++ 15 | 2 files changed, 54 insertions(+) 16 | 17 | diff --git a/llvm/include/llvm/IR/DIBuilder.h b/llvm/include/llvm/IR/DIBuilder.h 18 | index 45b94044bc64..90ac220a0387 100644 19 | --- a/llvm/include/llvm/IR/DIBuilder.h 20 | +++ b/llvm/include/llvm/IR/DIBuilder.h 21 | @@ -557,6 +557,35 @@ namespace llvm { 22 | PointerUnion Allocated = nullptr, 23 | PointerUnion Rank = nullptr); 24 | 25 | + /// Create debugging information entry for an array. 26 | + /// \param Scope Scope in which this enumeration is defined. 27 | + /// \param Name Union name. 28 | + /// \param File File where this member is defined. 29 | + /// \param LineNumber Line number. 30 | + /// \param Size Array size. 31 | + /// \param AlignInBits Alignment. 32 | + /// \param Ty Element type. 33 | + /// \param Subscripts Subscripts. 34 | + /// \param DataLocation The location of the raw data of a descriptor-based 35 | + /// Fortran array, either a DIExpression* or 36 | + /// a DIVariable*. 37 | + /// \param Associated The associated attribute of a descriptor-based 38 | + /// Fortran array, either a DIExpression* or 39 | + /// a DIVariable*. 40 | + /// \param Allocated The allocated attribute of a descriptor-based 41 | + /// Fortran array, either a DIExpression* or 42 | + /// a DIVariable*. 43 | + /// \param Rank The rank attribute of a descriptor-based 44 | + /// Fortran array, either a DIExpression* or 45 | + /// a DIVariable*. 46 | + DICompositeType *createArrayType( 47 | + DIScope *Scope, StringRef Name, DIFile *File, unsigned LineNumber, 48 | + uint64_t Size, uint32_t AlignInBits, DIType *Ty, DINodeArray Subscripts, 49 | + PointerUnion DataLocation = nullptr, 50 | + PointerUnion Associated = nullptr, 51 | + PointerUnion Allocated = nullptr, 52 | + PointerUnion Rank = nullptr); 53 | + 54 | /// Create debugging information entry for a vector type. 55 | /// \param Size Array size. 56 | /// \param AlignInBits Alignment. 57 | diff --git a/llvm/lib/IR/DIBuilder.cpp b/llvm/lib/IR/DIBuilder.cpp 58 | index 6c873c3c6644..27e930e5a87f 100644 59 | --- a/llvm/lib/IR/DIBuilder.cpp 60 | +++ b/llvm/lib/IR/DIBuilder.cpp 61 | @@ -600,6 +600,31 @@ DIBuilder::createArrayType(uint64_t Size, uint32_t AlignInBits, DIType *Ty, 62 | return R; 63 | } 64 | 65 | +DICompositeType * 66 | +DIBuilder::createArrayType(DIScope *Scope, StringRef Name, DIFile *File, unsigned LineNumber, 67 | + uint64_t Size, uint32_t AlignInBits, DIType *Ty, 68 | + DINodeArray Subscripts, 69 | + PointerUnion DL, 70 | + PointerUnion AS, 71 | + PointerUnion AL, 72 | + PointerUnion RK) { 73 | + auto *R = DICompositeType::get( 74 | + VMContext, dwarf::DW_TAG_array_type, Name, File, LineNumber, 75 | + getNonCompileUnitScope(Scope), Ty, Size, 76 | + AlignInBits, 0, DINode::FlagZero, Subscripts, 0, nullptr, nullptr, "", 77 | + nullptr, 78 | + DL.is() ? (Metadata *)DL.get() 79 | + : (Metadata *)DL.get(), 80 | + AS.is() ? (Metadata *)AS.get() 81 | + : (Metadata *)AS.get(), 82 | + AL.is() ? (Metadata *)AL.get() 83 | + : (Metadata *)AL.get(), 84 | + RK.is() ? (Metadata *)RK.get() 85 | + : (Metadata *)RK.get()); 86 | + trackIfUnresolved(R); 87 | + return R; 88 | +} 89 | + 90 | DICompositeType *DIBuilder::createVectorType(uint64_t Size, 91 | uint32_t AlignInBits, DIType *Ty, 92 | DINodeArray Subscripts) { 93 | -- 94 | 2.47.1 95 | 96 | -------------------------------------------------------------------------------- /llvm-interface/zfp/i-c.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- I N T E R F A C E S . C -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- Copyright (C) 1992-2025, Free Software Foundation, Inc. -- 10 | -- -- 11 | -- This specification is derived from the Ada Reference Manual for use with -- 12 | -- GNAT. The copyright notice above, and the license provisions that follow -- 13 | -- apply solely to the contents of the part following the private keyword. -- 14 | -- -- 15 | -- GNAT is free software; you can redistribute it and/or modify it under -- 16 | -- terms of the GNU General Public License as published by the Free Soft- -- 17 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 18 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 19 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 20 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 21 | -- -- 22 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 23 | -- additional permissions described in the GCC Runtime Library Exception, -- 24 | -- version 3.1, as published by the Free Software Foundation. -- 25 | -- -- 26 | -- You should have received a copy of the GNU General Public License and -- 27 | -- a copy of the GCC Runtime Library Exception along with this program; -- 28 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 29 | -- . -- 30 | -- -- 31 | -- GNAT was originally developed by the GNAT team at New York University. -- 32 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- 33 | -- -- 34 | ------------------------------------------------------------------------------ 35 | 36 | -- This version contains only the type definitions for standard interfacing 37 | -- with C. All functions have been removed from the original spec. 38 | 39 | package Interfaces.C 40 | with Pure, No_Elaboration_Code_All 41 | is 42 | 43 | -- Declaration's based on C's 44 | 45 | CHAR_BIT : constant := 8; 46 | SCHAR_MIN : constant := -128; 47 | SCHAR_MAX : constant := 127; 48 | UCHAR_MAX : constant := 255; 49 | 50 | -- Signed and Unsigned Integers. Note that in GNAT, we have ensured that 51 | -- the standard predefined Ada types correspond to the standard C types 52 | 53 | type int is new Integer; 54 | type short is new Short_Integer; 55 | type long is new Long_Integer; 56 | type long_long is new Long_Long_Integer; 57 | 58 | type signed_char is range SCHAR_MIN .. SCHAR_MAX; 59 | for signed_char'Size use CHAR_BIT; 60 | 61 | type unsigned is mod 2 ** int'Size; 62 | type unsigned_short is mod 2 ** short'Size; 63 | type unsigned_long is mod 2 ** long'Size; 64 | type unsigned_long_long is mod 2 ** long_long'Size; 65 | 66 | type unsigned_char is mod (UCHAR_MAX + 1); 67 | for unsigned_char'Size use CHAR_BIT; 68 | 69 | subtype plain_char is unsigned_char; 70 | 71 | type ptrdiff_t is 72 | range -(2 ** (Standard'Address_Size - 1)) .. 73 | +(2 ** (Standard'Address_Size - 1) - 1); 74 | 75 | type size_t is mod 2 ** Standard'Address_Size; 76 | 77 | -- Boolean type 78 | 79 | type C_bool is new Boolean; 80 | pragma Convention (C, C_bool); 81 | 82 | -- Floating-Point 83 | 84 | type C_float is new Float; 85 | type double is new Standard.Long_Float; 86 | type long_double is new Standard.Long_Long_Float; 87 | 88 | ---------------------------- 89 | -- Characters and Strings -- 90 | ---------------------------- 91 | 92 | type char is new Character; 93 | 94 | nul : constant char := char'First; 95 | 96 | type char_array is array (size_t range <>) of aliased char; 97 | for char_array'Component_Size use CHAR_BIT; 98 | 99 | ------------------------------------ 100 | -- Wide Character and Wide String -- 101 | ------------------------------------ 102 | 103 | type wchar_t is new Wide_Character; 104 | for wchar_t'Size use Standard'Wchar_T_Size; 105 | 106 | wide_nul : constant wchar_t := wchar_t'First; 107 | 108 | type wchar_array is array (size_t range <>) of aliased wchar_t; 109 | 110 | end Interfaces.C; 111 | -------------------------------------------------------------------------------- /llvm-interface/back_end.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2008-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with GNATLLVM; use GNATLLVM; 19 | with GNATLLVM.Codegen; use GNATLLVM.Codegen; 20 | with GNATLLVM.Compile; use GNATLLVM.Compile; 21 | 22 | with Ada.Directories; use Ada.Directories; 23 | with GNAT.OS_Lib; use GNAT.OS_Lib; 24 | with Namet; use Namet; 25 | with Osint; use Osint; 26 | with Osint.C; use Osint.C; 27 | with Output; use Output; 28 | 29 | with Adabkend; 30 | with Gnatvsn; use Gnatvsn; 31 | with Errout; use Errout; 32 | with Lib; use Lib; 33 | with Opt; use Opt; 34 | with Options; use Options; 35 | with Types; use Types; 36 | 37 | package body Back_End is 38 | 39 | package GNAT2LLVM is new Adabkend 40 | (Product_Name => "GNAT for " & (if CCG then "CCG" else "LLVM"), 41 | Copyright_Years => "2013-" & Current_Year, 42 | Driver => GNAT_To_LLVM, 43 | Is_Back_End_Switch => Is_Back_End_Switch); 44 | 45 | procedure Scan_Compiler_Arguments renames GNAT2LLVM.Scan_Compiler_Arguments; 46 | 47 | ------------------- 48 | -- Call_Back_End -- 49 | ------------------- 50 | 51 | procedure Call_Back_End (Mode : Back_End_Mode_Type) is 52 | begin 53 | -- Deal with case of generating SCIL, we should not be here unless 54 | -- debugging CodePeer mode in GNAT. 55 | 56 | if Generate_SCIL then 57 | Error_Msg_N ("'S'C'I'L generation not available", Cunit (Main_Unit)); 58 | 59 | if CodePeer_Mode 60 | or else (Mode /= Generate_Object 61 | and then not Back_Annotate_Rep_Info) 62 | then 63 | return; 64 | end if; 65 | end if; 66 | 67 | -- We should be here in GNATprove mode only when debugging GNAT. Do not 68 | -- call the back-end in that case, as it is not prepared to handle the 69 | -- special form of the tree obtained in GNATprove mode. 70 | 71 | if GNATprove_Mode then 72 | return; 73 | end if; 74 | 75 | -- Call the back end itself if it has work to do 76 | 77 | if Mode = Generate_Object or else Back_Annotate_Rep_Info then 78 | if Mode = Declarations_Only then 79 | Decls_Only := True; 80 | Code_Generation := None; 81 | end if; 82 | 83 | GNAT2LLVM.Call_Back_End; 84 | end if; 85 | end Call_Back_End; 86 | 87 | ------------------------------- 88 | -- Gen_Or_Update_Object_File -- 89 | ------------------------------- 90 | 91 | procedure Gen_Or_Update_Object_File is 92 | Obj_File_Name : constant String := 93 | (if Output_File_Name_Present then Get_Output_Object_File_Name 94 | else Base_Name 95 | (Get_Name_String (Name_Id (Unit_File_Name (Main_Unit)))) 96 | & Get_Target_Object_Suffix.all); 97 | Success : Boolean; 98 | 99 | begin 100 | -- If we're to generate code, create an empty .o file is there isn't 101 | -- one already. Then set the time of that file to be the same as 102 | -- that of the .ali file. 103 | 104 | if Code_Generation = Write_Object then 105 | Close (Create_New_File (Obj_File_Name, Binary)); 106 | Osint.C.Set_File_Name (ALI_Suffix.all); 107 | GNAT.OS_Lib.Copy_Time_Stamps 108 | (Name_Buffer (1 .. Name_Len), Obj_File_Name, Success); 109 | end if; 110 | 111 | -- If we're using JSON error messages, the GCC backend will write an 112 | -- empty JSON array and a newline. This doesn't relate to object files, 113 | -- but this is the only place that's called in the backend late enough. 114 | 115 | if Opt.JSON_Output then 116 | Set_Standard_Error; 117 | Write_Line ("[]"); 118 | Set_Standard_Output; 119 | end if; 120 | 121 | end Gen_Or_Update_Object_File; 122 | 123 | begin 124 | -- Set the switches in Opt that we depend on 125 | 126 | Back_End_Return_Slot := True; 127 | Expand_Nonbinary_Modular_Ops := True; 128 | Unnest_Subprogram_Mode := True; 129 | CCG_Mode := CCG; 130 | end Back_End; 131 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-compile.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with GNATLLVM.GLType; use GNATLLVM.GLType; 19 | with GNATLLVM.GLValue; use GNATLLVM.GLValue; 20 | 21 | package GNATLLVM.Compile is 22 | 23 | procedure GNAT_To_LLVM (GNAT_Root : N_Compilation_Unit_Id); 24 | -- Generate LLVM from GNAT_Root and then compile it 25 | 26 | procedure Emit (N : Node_Id) 27 | with Pre => Present (N); 28 | -- Emit code for the tree starting at N 29 | 30 | procedure Emit (List : List_Id); 31 | -- Emit a node and every element of a (possibly empty) List 32 | 33 | function Emit 34 | (N : N_Subexpr_Id; 35 | LHS : GL_Value := No_GL_Value; 36 | For_LHS : Boolean := False; 37 | Prefer_LHS : Boolean := False) return GL_Value 38 | with Post => Present (Emit'Result); 39 | -- Compile an expression node to an LLVM value or a reference to the 40 | -- value, whichever involves the least work. LHS may be an expression 41 | -- to which the value should be assigned. If the assignment was done, 42 | -- return LHS. For_LHS is true if we're evaluating this for the LHS of 43 | -- an assignment. Prefer_LHS is true if we're in a context (like 44 | -- 'Address) where we prefer returning an LValue if we can, but we are 45 | -- allowed to have a context where the result isn't an LHS. 46 | 47 | procedure Push_Suppress_Overflow; 48 | procedure Pop_Suppress_Overflow; 49 | -- Push and pop the level of supressing overflow messages. This is used 50 | -- during trial elaborations, such as in Is_No_Elab_Needed to avoid 51 | -- producing error messages for values that may not be used and 52 | -- certainly will not be used in that context. 53 | 54 | function Emit_LValue 55 | (N : N_Subexpr_Id; 56 | LHS : GL_Value := No_GL_Value; 57 | For_LHS : Boolean := False) return GL_Value 58 | with Post => Present (Emit_LValue'Result); 59 | -- Compile an expression node to an LLVM value that's a reference. If 60 | -- N corresponds to an LValue in the language, then the result will 61 | -- also be an LValue. LHS, For_LHS is like for Emit. 62 | 63 | function Emit_Safe_LValue 64 | (N : N_Subexpr_Id; 65 | LHS : GL_Value := No_GL_Value; 66 | For_LHS : Boolean := False) return GL_Value 67 | with Post => Present (Emit_Safe_LValue'Result); 68 | -- Likewise, but push the LValue pair table so we compute this as 69 | -- a safe subexpression. LHS is like for Emit. 70 | 71 | function Emit_Expression 72 | (N : N_Subexpr_Id; 73 | LHS : GL_Value := No_GL_Value) return GL_Value 74 | is 75 | (Get (To_Primitive (Emit (N, LHS => LHS)), Object)) 76 | with Post => Is_Primitive_GL_Type (Emit_Expression'Result); 77 | -- Likewise, but return something that's to be used as a value (but 78 | -- may nevertheless be a reference if its type is of variable size). 79 | -- LHS is like for Emit. It will always be the primitive form. 80 | 81 | function Emit_Safe_Expr 82 | (N : N_Subexpr_Id; LHS : GL_Value := No_GL_Value) return GL_Value 83 | with Post => Present (Emit_Safe_Expr'Result); 84 | -- Like Emit_Primitive_Expression, but push the LValue pair table 85 | -- so we compute this as a safe subexpression. LHS is like for 86 | -- Emit. 87 | 88 | function Simple_Value_Action 89 | (N : N_Expression_With_Actions_Id; Has_All : out Boolean) 90 | return Opt_N_Subexpr_Id; 91 | -- If N just declares the value it returns, return the initializer 92 | -- of that value; otherwise return Empty. Has_All is True if we 93 | -- have an N_Explicit_Dereference of the expression. 94 | 95 | procedure Process_Freeze_Entity (N : N_Freeze_Entity_Id); 96 | -- Process the actual freezing denoted by node N 97 | 98 | procedure Record_Code_Position (E : E_Package_Id); 99 | procedure Insert_Code_For (E : E_Package_Id); 100 | -- When we have a package body with a Freeze_Node, we need to record the 101 | -- position in the code to place that code for that package body and 102 | -- then insert it at the location of the Freeze_Node. 103 | 104 | end GNATLLVM.Compile; 105 | -------------------------------------------------------------------------------- /llvm-interface/check_for_LLVM_aliasing_bug.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | set -eu 3 | 4 | cat << EOF > obj/c43204h.ll 5 | ; ModuleID = 'c43204h.adb' 6 | source_filename = "c43204h.adb" 7 | target datalayout = "e-m:e-i64:64-f80:128-n8:16:32:64-S128" 8 | target triple = "x86_64-unknown-linux-gnu" 9 | 10 | %c43204h__AREC1T = type <{ i64, i64 }> 11 | 12 | define void @_ada_c43204h() { 13 | entry: 14 | %AREC1 = alloca %c43204h__AREC1T, align 16 15 | %procgGP393__A8b = alloca [2 x i32], align 8 16 | %procgGP393__J9b = alloca i32, align 4 17 | %procgGP393__ga11 = alloca [2 x i32], align 8 18 | %0 = getelementptr inbounds [2 x i32], [2 x i32]* %procgGP393__A8b, i64 0, i32 0 19 | store i32 1, i32* %0, align 8, !tbaa !0 20 | store i32 1, i32* %procgGP393__J9b, align 4, !tbaa !4 21 | %attr-address = ptrtoint i32* %procgGP393__J9b to i64 22 | %1 = getelementptr inbounds %c43204h__AREC1T, %c43204h__AREC1T* %AREC1, i32 0, i32 0 23 | store i64 %attr-address, i64* %1, align 16, !tbaa !6 24 | br label %2 25 | 26 | 2: ; preds = %loop-stmts, %entry 27 | %3 = load volatile i32, i32* %procgGP393__J9b, align 4, !tbaa !4 28 | %4 = icmp slt i32 %3, 2 29 | br i1 %4, label %loop-stmts, label %loop-exit 30 | 31 | loop-stmts: ; preds = %2 32 | %5 = load volatile i32, i32* %procgGP393__J9b, align 4, !tbaa !4 33 | %attr-succ = add nsw i32 %5, 1 34 | store volatile i32 %attr-succ, i32* %procgGP393__J9b, align 4, !tbaa !4 35 | %6 = load volatile i32, i32* %procgGP393__J9b, align 4, !tbaa !4 36 | %7 = sub nsw i32 %6, 1 37 | %8 = call i32 @report__ident_int(i32 2) 38 | %9 = getelementptr inbounds [2 x i32], [2 x i32]* %procgGP393__A8b, i64 0, i32 %7 39 | store i32 %8, i32* %9, align 4, !tbaa !0 40 | br label %2 41 | 42 | loop-exit: ; preds = %2 43 | %10 = load [2 x i32], [2 x i32]* %procgGP393__A8b, align 8, !tbaa !9 44 | store [2 x i32] %10, [2 x i32]* %procgGP393__ga11, align 8, !tbaa !14 45 | %attr-address1 = ptrtoint [2 x i32]* %procgGP393__ga11 to i64 46 | %11 = getelementptr inbounds %c43204h__AREC1T, %c43204h__AREC1T* %AREC1, i32 0, i32 1 47 | store i64 %attr-address1, i64* %11, align 8, !tbaa !18 48 | br label %13 49 | 50 | 12: ; preds = %13 51 | call void @c43204h__procg(%c43204h__AREC1T* align 16 %AREC1) 52 | ret void 53 | 54 | 13: ; preds = %loop-exit 55 | br label %12 56 | } 57 | 58 | define internal void @c43204h__procg(%c43204h__AREC1T* nest noalias nocapture readonly dereferenceable(16) %AREC2F) { 59 | entry: 60 | %0 = getelementptr inbounds %c43204h__AREC1T, %c43204h__AREC1T* %AREC2F, i32 0, i32 0 61 | %1 = load i64, i64* %0, align 8, !tbaa !20 62 | %2 = inttoptr i64 %1 to i32* 63 | %3 = getelementptr inbounds %c43204h__AREC1T, %c43204h__AREC1T* %AREC2F, i32 0, i32 0 64 | %4 = load i64, i64* %3, align 8, !tbaa !20 65 | %5 = inttoptr i64 %4 to i32* 66 | %6 = getelementptr inbounds %c43204h__AREC1T, %c43204h__AREC1T* %AREC2F, i32 0, i32 1 67 | %7 = load i64, i64* %6, align 8, !tbaa !23 68 | %8 = inttoptr i64 %7 to [2 x i32]* 69 | %9 = getelementptr inbounds [2 x i32], [2 x i32]* %8, i64 0, i32 1 70 | %10 = load i32, i32* %9, align 4, !tbaa !24 71 | %11 = icmp ne i32 %10, 2 72 | br i1 %11, label %12, label %13 73 | 74 | 12: ; preds = %entry 75 | call void @abort() 76 | br label %13 77 | 78 | 13: ; preds = %12, %entry 79 | ret void 80 | } 81 | 82 | declare void @abort() 83 | 84 | declare i32 @report__ident_int(i32) 85 | 86 | !0 = !{!1, !1, i64 0, i64 4} 87 | !1 = !{!2, i64 4, !"integer#TN"} 88 | !2 = !{!3, i64 4, !"integerB#TN"} 89 | !3 = !{!"Ada Root"} 90 | !4 = !{!5, !5, i64 0, i64 4} 91 | !5 = !{!2, i64 4, !"integerB#T10"} 92 | !6 = !{!7, !7, i64 0, i64 8} 93 | !7 = !{!8, i64 8, !"system__address#T0"} 94 | !8 = !{!3, i64 8, !"system__address#TN"} 95 | !9 = !{!10, !10, i64 0, i64 8} 96 | !10 = !{!3, i64 8, !"c43204h__arr11#TN#AD", !11, i64 0, i64 4, !13, i64 4, i64 4} 97 | !11 = !{!12, i64 4, !"integer#T11"} 98 | !12 = !{!1, i64 4, !"integer#T2"} 99 | !13 = !{!12, i64 4, !"integer#T12"} 100 | !14 = !{!15, !15, i64 0, i64 8} 101 | !15 = !{!3, i64 8, !"c43204h__procgGP393__T7b#TN#AD", !16, i64 0, i64 4, !17, i64 4, i64 4} 102 | !16 = !{!12, i64 4, !"integer#T6"} 103 | !17 = !{!12, i64 4, !"integer#T7"} 104 | !18 = !{!19, !19, i64 0, i64 8} 105 | !19 = !{!8, i64 8, !"system__address#T1"} 106 | !20 = !{!21, !7, i64 0, i64 8} 107 | !21 = !{!22, i64 16, !"c43204h__AREC1T", !7, i64 0, i64 8, !19, i64 8, i64 8} 108 | !22 = !{!3, i64 16, !"c43204h__AREC1T#TN", !7, i64 0, i64 8, !19, i64 8, i64 8} 109 | !23 = !{!21, !19, i64 8, i64 8} 110 | !24 = !{!10, !13, i64 4, i64 4} 111 | 112 | EOF 113 | opt -O2 obj/c43204h.ll -o obj/c43204h_o.bc 114 | llvm-dis obj/c43204h_o.bc 115 | if [ "`wc -l obj/c43204h_o.ll | awk '{print $1}'` " -gt "40" ]; then 116 | BUG=False 117 | echo "OK: using LLVM without the aliasing bug" 118 | else 119 | BUG=True 120 | echo "using LLVM with the aliasing bug, will pessimize slightly the optimized code" 121 | fi 122 | cat << EOF > obj/tmp-gnatllvm-aliasing-params.ads 123 | package GNATLLVM.Aliasing.Params is 124 | LLVM_Struct_Tag_Bug : constant Boolean := $BUG; 125 | end GNATLLVM.Aliasing.Params; 126 | EOF 127 | 128 | ./move-if-change obj/tmp-gnatllvm-aliasing-params.ads obj/gnatllvm-aliasing-params.ads 129 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-builtins.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with GNATLLVM.GLType; use GNATLLVM.GLType; 19 | with GNATLLVM.GLValue; use GNATLLVM.GLValue; 20 | with GNATLLVM.MDType; use GNATLLVM.MDType; 21 | with GNATLLVM.Instructions; use GNATLLVM.Instructions; 22 | 23 | package GNATLLVM.Builtins is 24 | 25 | -- When we want to create an overloaded intrinsic, we need to specify 26 | -- what operand signature the intrinsic has. The following are those 27 | -- that we currently support. 28 | 29 | type Overloaded_Intrinsic_Kind is 30 | (Unary, Binary, Ternary, Boolean_And_Data); 31 | 32 | function Build_Intrinsic 33 | (Name : String; 34 | Return_GT : GL_Type; 35 | Overloaded_Types : MD_Type_Array := (1 .. 0 => <>)) return GL_Value 36 | with Pre => Is_Primitive_GL_Type (Return_GT), 37 | Post => Present (Build_Intrinsic'Result); 38 | -- Build an intrinsic function of the specified return type and name. 39 | -- The function parameters are obtained from LLVM. The list of 40 | -- overloaded types must contain exactly one LLVM type for each 41 | -- overloaded type in the intrinsic's function signature. 42 | 43 | function Call_Intrinsic 44 | (Name : String; Args : GL_Value_Array) return GL_Value 45 | is 46 | (Call (Build_Intrinsic (Name, Related_Type (Args (Args'First)), 47 | (1 => Type_Of (Args (Args'First)))), 48 | Args)); 49 | -- Create an intrinsic with the given name and type of the arguments, 50 | -- overloaded on the type of the first argument, and call it. 51 | 52 | function Call_Intrinsic0 (Name : String; GT : GL_Type) return GL_Value is 53 | (Call (Build_Intrinsic (Name, GT, (1 .. 0 => <>)), (1 .. 0 => <>))); 54 | -- Similar, but for intrinsics with no arguments 55 | 56 | function Emit_Intrinsic_Call 57 | (N : N_Subprogram_Call_Id; Subp : Subprogram_Kind_Id) return GL_Value; 58 | -- If Subp is an intrinsic that we know how to handle, emit the LLVM 59 | -- for it and return the result. Otherwise, No_GL_Value. 60 | 61 | function Get_Default_Alloc_Fn return GL_Value 62 | with Post => Present (Get_Default_Alloc_Fn'Result); 63 | -- Get default function to use for allocating memory 64 | 65 | function Get_Default_Free_Fn return GL_Value 66 | with Post => Present (Get_Default_Free_Fn'Result); 67 | -- Get default function to use for freeing memory 68 | 69 | function Get_Memory_Compare_Fn return GL_Value 70 | with Post => Present (Get_Memory_Compare_Fn'Result); 71 | -- Get function to use to compare memory 72 | 73 | function Get_Stack_Save_Fn return GL_Value 74 | with Post => Present (Get_Stack_Save_Fn'Result); 75 | -- Get function to save stack pointer 76 | 77 | function Get_Stack_Restore_Fn return GL_Value 78 | with Post => Present (Get_Stack_Restore_Fn'Result); 79 | -- Get function to restore stack pointer 80 | 81 | function Get_Expect_Fn return GL_Value 82 | with Post => Present (Get_Expect_Fn'Result); 83 | -- Get function corresponding to llvm.expect 84 | 85 | function Get_Frame_Address_Fn return GL_Value 86 | with Post => Present (Get_Frame_Address_Fn'Result); 87 | -- Get function corresponding to llvm.frameaddress 88 | 89 | function Get_Tramp_Init_Fn return GL_Value 90 | with Post => Present (Get_Tramp_Init_Fn'Result); 91 | function Get_Tramp_Adjust_Fn return GL_Value 92 | with Post => Present (Get_Tramp_Adjust_Fn'Result); 93 | -- Get functions to create and adjust trampolines 94 | 95 | function Get_Enable_Execute_Stack_Fn return GL_Value 96 | with Post => Present (Get_Enable_Execute_Stack_Fn'Result); 97 | -- Get function to make a portion of the stack executable 98 | 99 | function Get_Get_Address_Fn return GL_Value 100 | with Post => Present (Get_Get_Address_Fn'Result); 101 | -- Get function to obtain the address from a pointer 102 | 103 | function Get_Set_Address_Fn return GL_Value 104 | with Post => Present (Get_Set_Address_Fn'Result); 105 | -- Get function to set the address of a pointer 106 | 107 | procedure Initialize; 108 | -- Initialize module 109 | 110 | end GNATLLVM.Builtins; 111 | -------------------------------------------------------------------------------- /llvm-interface/ccg/ccg-flow.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- C C G -- 3 | -- -- 4 | -- Copyright (C) 2020-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with LLVM.Core; use LLVM.Core; 19 | 20 | with CCG.Environment; use CCG.Environment; 21 | with CCG.Helper; use CCG.Helper; 22 | with CCG.Strs; use CCG.Strs; 23 | 24 | package CCG.Flow is 25 | 26 | -- This package contains the processing for Flows. We define a Flow 27 | -- as a piece of C code corresponding to a control structure in a 28 | -- subprogram. This can be piece of straight-line code that continues 29 | -- to another Flow, an if/then/elseif/else block, a switch statement, 30 | -- or a loop (not handled yet). 31 | -- 32 | -- We could create a discriminated variant record to record a Flow, 33 | -- but it's simpler to use three tables to represent this information. 34 | -- We use one table to contain information about one part of an "if", 35 | -- a second to contains information about one case of a switch 36 | -- statement, and the final table to represent a Flow itself. 37 | 38 | Line_Idx_Low_Bound : constant := 600_000_000; 39 | Line_Idx_High_Bound : constant := 699_999_999; 40 | type Line_Idx is range Line_Idx_Low_Bound .. Line_Idx_High_Bound; 41 | Empty_Line_Idx : constant Line_Idx := Line_Idx_Low_Bound; 42 | 43 | Case_Idx_Low_Bound : constant := 700_000_000; 44 | Case_Idx_High_Bound : constant := 799_999_999; 45 | type Case_Idx is range Case_Idx_Low_Bound .. Case_Idx_High_Bound; 46 | Empty_Case_Idx : constant Case_Idx := Case_Idx_Low_Bound; 47 | 48 | If_Idx_Low_Bound : constant := 800_000_000; 49 | If_Idx_High_Bound : constant := 899_999_999; 50 | type If_Idx is range If_Idx_Low_Bound .. If_Idx_High_Bound; 51 | Empty_If_Idx : constant If_Idx := If_Idx_Low_Bound; 52 | 53 | function Present (Idx : Line_Idx) return Boolean is (Idx /= Empty_Line_Idx); 54 | function Present (Idx : Case_Idx) return Boolean is (Idx /= Empty_Case_Idx); 55 | function Present (Idx : If_Idx) return Boolean is (Idx /= Empty_If_Idx); 56 | 57 | function No (Idx : Line_Idx) return Boolean is (Idx = Empty_Line_Idx); 58 | function No (Idx : Case_Idx) return Boolean is (Idx = Empty_Case_Idx); 59 | function No (Idx : If_Idx) return Boolean is (Idx = Empty_If_Idx); 60 | 61 | procedure Discard (Idx : Line_Idx) is null; 62 | procedure Discard (Idx : Case_Idx) is null; 63 | procedure Discard (Idx : If_Idx) is null; 64 | procedure Discard (Idx : Flow_Idx) is null; 65 | 66 | function Get_Or_Create_Flow (B : Basic_Block_T) return Flow_Idx 67 | with Pre => Present (B), 68 | Post => Present (Get_Or_Create_Flow'Result) 69 | and then Get_Flow (B) = Get_Or_Create_Flow'Result; 70 | function Get_Or_Create_Flow (V : Value_T) return Flow_Idx is 71 | (Get_Or_Create_Flow (Value_As_Basic_Block (V))) 72 | with Pre => Is_A_Basic_Block (V), 73 | Post => Present (Get_Or_Create_Flow'Result); 74 | -- Get (and create if needed) a Flow for a block 75 | 76 | procedure Add_Use (Idx : Flow_Idx) with Inline; 77 | procedure Remove_Use (Idx : Flow_Idx) with Inline; 78 | -- Add or remove (respectively) a usage of the Flow denoted by Idx, 79 | -- if any. Because we remove the uses of anything that has zero 80 | -- uses, if we're moving a flow index from one location to another, 81 | -- be sure that we add it to the new place before removing it from 82 | -- the previous. 83 | 84 | procedure Add_Line 85 | (S : Str; 86 | V : Value_T; 87 | Force_Left : Boolean := False; 88 | Semicolon : Boolean := True) 89 | with Pre => Present (S) and then Present (V); 90 | -- Add a line and corresponding instruction to the current flow 91 | 92 | procedure Simplify_Flow (Idx : Flow_Idx) 93 | with Pre => Present (Idx); 94 | -- Perform simplifications of Idx and the flows referenced by it 95 | 96 | procedure Output_Flow (Idx : Flow_Idx) 97 | with Pre => Present (Idx); 98 | -- Output the flow for Idx, if Present, and all nested flows 99 | 100 | procedure Maybe_Dump_Flow (Idx : Flow_Idx; V : Value_T; Desc : String) 101 | with Pre => Present (Idx) and then Present (V); 102 | -- Idx is the flow for the entry block of V. If -gnatd_u is specified, 103 | -- label the flow with Desc, and dump it. 104 | 105 | pragma Annotate (Xcov, Exempt_On, "Debug helper"); 106 | 107 | procedure Dump_Flow (J : Pos; Dump_All : Boolean) 108 | with Export, External_Name => "dfl"; 109 | -- Dump a flow to stderr. To simplify its use, this can be called 110 | -- either with the actual Flow_Idx value or a smaller integer which 111 | -- represents the low-order digits of the value. 112 | 113 | pragma Annotate (Xcov, Exempt_Off, "Debug helper"); 114 | 115 | end CCG.Flow; 116 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-conditionals.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with Einfo.Utils; use Einfo.Utils; 19 | with Nlists; use Nlists; 20 | 21 | with GNATLLVM.GLType; use GNATLLVM.GLType; 22 | with GNATLLVM.GLValue; use GNATLLVM.GLValue; 23 | with GNATLLVM.Types; use GNATLLVM.Types; 24 | 25 | package GNATLLVM.Conditionals is 26 | 27 | function Build_Short_Circuit_Op 28 | (Left, Right : N_Subexpr_Id; Op : Node_Kind) return GL_Value 29 | with Pre => Op in N_Op_Boolean | N_Short_Circuit, 30 | Post => Present (Build_Short_Circuit_Op'Result); 31 | -- Emit the LLVM IR for a short circuit operator ("or else", "and then") 32 | 33 | function Emit_Comparison 34 | (Kind : Node_Kind; LHS, RHS : N_Subexpr_Id) return GL_Value 35 | with Pre => Kind in N_Op_Compare, 36 | Post => Present (Emit_Comparison'Result); 37 | -- Generate a result which is a comparison of two expressions 38 | 39 | function Emit_And_Or_Xor 40 | (Kind : Node_Kind; LHS_Node, RHS_Node : N_Subexpr_Id) return GL_Value 41 | with Pre => Kind in N_Op_And | N_Op_Or | N_Op_Xor, 42 | Post => Present (Emit_And_Or_Xor'Result); 43 | -- Generate a result which is the logical operation of the two expressions 44 | 45 | procedure Emit_Comparison_And_Branch 46 | (Kind : Node_Kind; 47 | LHS, RHS : N_Subexpr_Id; 48 | BB_True, BB_False : Basic_Block_T) 49 | with Pre => Present (BB_True) and then Present (BB_False) 50 | and then Kind in N_Op_Compare; 51 | -- Similar, but generate comparison and branch to one of the basic 52 | -- blocks depending on the result 53 | 54 | function Build_Elementary_Comparison 55 | (Kind : Node_Kind; 56 | Orig_LHS, Orig_RHS : GL_Value) return GL_Value 57 | with Pre => Is_Elementary_Type (Orig_LHS) 58 | and then Is_Elementary_Type (Orig_RHS) 59 | and then Kind in N_Op_Compare, 60 | Post => Present (Build_Elementary_Comparison'Result); 61 | -- Helpers for Emit_Expression: handle comparison operations for 62 | -- elementary types. The second form only supports discrete or pointer 63 | -- types. 64 | 65 | procedure Emit_If (N : N_If_Statement_Id); 66 | -- Helper for Emit: handle if statements 67 | 68 | function Is_Simple_Conditional (N : N_Subexpr_Id) return Boolean; 69 | -- Return True if N is a simple conditional expression, meaning no 70 | -- comparisons of composite types. 71 | 72 | procedure Emit_If_Cond (N : N_Subexpr_Id; BB_True, BB_False : Basic_Block_T) 73 | with Pre => Present (BB_True) and then Present (BB_False); 74 | -- Helper for Emit_If to generate branch to BB_True or BB_False 75 | -- depending on whether Node is true or false. 76 | 77 | function Emit_If_Expression 78 | (N : N_If_Expression_Id; LHS : GL_Value) return GL_Value 79 | with Post => Present (Emit_If_Expression'Result); 80 | -- Helper for Emit_Expression: handle if expressions 81 | 82 | procedure Build_If_Range 83 | (LHS : GL_Value; 84 | Low, High : Uint; 85 | BB_True, BB_False : Basic_Block_T) 86 | with Pre => Present (LHS) and then Present (BB_True) 87 | and then Present (BB_False); 88 | -- Emit code to branch to BB_True or BB_False depending on whether LHS, 89 | -- which is of type Operand_Type, is in the range from Low to High. 90 | 91 | procedure Emit_Case_Statement (N : N_Case_Statement_Id); 92 | -- Generate code for a case statement 93 | 94 | procedure Emit_Loop_Statement (N : N_Loop_Statement_Id); 95 | -- Generate code for a loop 96 | 97 | procedure Emit_Case_Code 98 | (In_Alts : List_Id; LHS : GL_Value; In_BBs : Basic_Block_Array) 99 | with Pre => Present (In_Alts) and then Is_Primitive_GL_Type (LHS); 100 | -- Emit the code for a case-like part, which can be either a case 101 | -- statement or a computation related to a variant part of a record. 102 | -- Alts is a list of alternates whose values are to be compared with 103 | -- LHS. If alternative J has a matching choice, branch to In_BBs (J). 104 | 105 | function Emit_Min_Max 106 | (Exprs : List_Id; Compute_Max : Boolean) return GL_Value 107 | with Pre => List_Length (Exprs) = 2 108 | and then Is_Scalar_Type (Full_Etype (First (Exprs))), 109 | Post => Present (Emit_Min_Max'Result); 110 | -- Exprs must be a list of two scalar expressions with compatible types. 111 | -- Emit code to evaluate both expressions. If Compute_Max, return the 112 | -- maximum value and return the minimum otherwise. 113 | 114 | function Safe_For_Short_Circuit (N : N_Subexpr_Id) return Boolean 115 | with Pre => Present (N); 116 | -- True iff N is an expression for which we can safely convert a 117 | -- short-circuit operation to a non-short-circuit and vice versa. 118 | 119 | end GNATLLVM.Conditionals; 120 | -------------------------------------------------------------------------------- /llvm-interface/ccg/ccg-target.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- C C G -- 3 | -- -- 4 | -- Copyright (C) 2022-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with CCG.Strs; use CCG.Strs; 19 | 20 | package CCG.Target is 21 | 22 | -- This package contains target information about the C compiler used 23 | -- and how to format and generate code. 24 | 25 | Target_Info_File : String_Access := null; 26 | -- If non-null, the name of a file from which to read C target parameters 27 | 28 | Dump_C_Parameters : Boolean := False; 29 | -- True if we should dump the values of the C target parameters 30 | 31 | C_Parameter_File : String_Access := null; 32 | -- If non-null, the name of a file to dump the C parameters 33 | 34 | -- These are the parameters themselves 35 | 36 | C_Version : aliased Integer := 1999; 37 | -- C standard for which we're to write output 38 | 39 | C_Indent : aliased Integer := 2; 40 | -- Number of characters to indent at each level 41 | 42 | Max_Depth : aliased Integer := 43 | (80 / 2) / (2 * C_Indent); 44 | -- Maximum allowable nesting depth of constructs 45 | 46 | Always_Brace : aliased Boolean := False; 47 | -- True if we're to always write C lexical blocks using braces even 48 | -- if they're only a single line. 49 | 50 | Parens : aliased String_Access := new String'("warns"); 51 | -- Indicates how we handle parentheses. We can either always output 52 | -- them, output them only when needed, or output them when needed or 53 | -- when precedence is correct but looks suspicious to compilers. 54 | 55 | Have_Includes : aliased Boolean := True; 56 | -- True if we're to write #include lines for the standard C includes 57 | 58 | Inline_Always_Must : aliased Boolean := True; 59 | -- In some C compilers (e.g., clang), Inline_Always means to make a 60 | -- best try at inlining, but be silent if the function can't be inlned. 61 | -- In others (e.g., gcc), if the function can't be inlined, it issues 62 | -- a warning (or error, depending on the warning mode). The value of 63 | -- this option says which is the case. 64 | 65 | Inline_Style : aliased String_Access := new String'("std"); 66 | -- Says whether to use the MSVC form of the inline keyword ("__inline") 67 | -- or the standard form ("inline"). 68 | 69 | Code_Section_Modifier : aliased String_Access := new String'("section"); 70 | -- Gives the value of the "modifier" used for code sections. By default, 71 | -- the code and data sction modifiers are the same. 72 | 73 | Declare_Section_Modifier : aliased String_Access := new String'("$"); 74 | -- If not "$", the modifier to be used to declare a data section 75 | 76 | Packed_Mechanism : aliased String_Access := new String'("modifier"); 77 | -- Says how we output an indication that a record is packed. We 78 | -- can either use the "packed" modifier ("modifier"), a packed 79 | -- pragma in MSVC syntax ("pragma"), or we can't support packed records 80 | -- ("none"). 81 | 82 | procedure Set_C_Compiler (S : String); 83 | -- Set the parameters corresponding to the C compiler given in S 84 | 85 | procedure Read_C_Parameters (Name : String); 86 | -- Read C parameters from file Name 87 | 88 | procedure Set_C_Parameter (S : String); 89 | -- S is of the form "name=value". Use it to set parameter "name" to "value" 90 | 91 | procedure Output_C_Parameters; 92 | -- Output all the C parameters 93 | 94 | type OM_Blank is (Before, After, None); 95 | function Output_Modifier 96 | (M : String; 97 | Blank : OM_Blank := After; 98 | Val : Int := -1; 99 | S : String := "") return Str 100 | with Post => Present (Output_Modifier'Result); 101 | -- Return a Str corresponding to the way we write modifier M on our 102 | -- target. If Val is non-negative, we expect the template to contain a 103 | -- way to write an integer and if S is non-null, we expect it to 104 | -- contain a way to write a string (in both cases, the character 105 | -- '%'). Blank says whether we're to write a blank before or after the 106 | -- value. If we're writing the null string, we don't write a blank at 107 | -- all. 108 | 109 | function Has_Modifier (M : String) return Boolean; 110 | -- Return true if modifier M is present and not set to '$' 111 | 112 | procedure Maybe_Declare_Section (S : String); 113 | -- If we have to declare code sections, do so for section S 114 | 115 | function Pack_Via_Modifier return Boolean 116 | is (Packed_Mechanism.all = "modifier"); 117 | function Pack_Via_Pragma return Boolean 118 | is (Packed_Mechanism.all = "pragma"); 119 | function Pack_Not_Supported return Boolean 120 | is (Packed_Mechanism.all = "none"); 121 | -- Functions to say how we're indicating packed records in the C output 122 | 123 | function Inline_MSVC return Boolean is (Inline_Style.all = "msvc"); 124 | 125 | function Always_Parens return Boolean is (Parens.all = "always"); 126 | function Warns_Parens return Boolean is (Parens.all = "warns"); 127 | -- Functions to affect when we write parentheses 128 | 129 | end CCG.Target; 130 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-debuginfo.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with LLVM.Debug_Info; use LLVM.Debug_Info; 19 | 20 | with Einfo.Utils; use Einfo.Utils; 21 | 22 | with GNATLLVM.GLValue; use GNATLLVM.GLValue; 23 | with GNATLLVM.Records.Debug; use GNATLLVM.Records.Debug; 24 | 25 | package GNATLLVM.DebugInfo is 26 | 27 | procedure Push_Debug_Scope (SFI : Source_File_Index; Scope : Metadata_T) 28 | with Pre => not Emit_Debug_Info or else Present (Scope); 29 | -- Push the current debug scope and make Scope the present scope. Does 30 | -- nothing if not debugging. 31 | 32 | procedure Pop_Debug_Scope; 33 | -- Pop the debugging scope. Does nothing if not debugging. 34 | 35 | procedure Initialize; 36 | -- Set up the environment for generating debugging information 37 | 38 | procedure Finalize_Debugging; 39 | -- Finalize the debugging info at the end of the translation 40 | 41 | function Get_Debug_File_Node (File : Source_File_Index) return Metadata_T 42 | with Post => not Emit_Debug_Info 43 | or else Present (Get_Debug_File_Node'Result); 44 | -- Produce and return a DIFile entry for the specified source file index 45 | 46 | function Create_Subprogram_Debug_Info 47 | (Func : GL_Value; 48 | N : Node_Id; 49 | E : Opt_Subprogram_Kind_Id := Empty; 50 | Name : String := ""; 51 | Ext_Name : String := "") return Metadata_T 52 | with Pre => Present (Func) and then Present (N), 53 | Post => not Emit_Debug_Info 54 | or else Present (Create_Subprogram_Debug_Info'Result); 55 | -- Create debugging information for Func with entity E using 56 | -- the line number information in N for the location. 57 | 58 | procedure Push_Lexical_Debug_Scope (N : Node_Id) 59 | with Pre => Present (N); 60 | -- Push a lexical scope starting at N into the debug stack 61 | 62 | procedure Set_Debug_Pos_At_Node (N : Node_Id) 63 | with Pre => Present (N); 64 | -- Set builder position for debugging to the Sloc of N. 65 | 66 | procedure Push_Debug_Freeze_Pos; 67 | procedure Pop_Debug_Freeze_Pos; 68 | -- When we're doing expansion for computing sizes and/or field 69 | -- positions, we'll sometimes be going into nodes whose Sloc is at the 70 | -- point of definition of a type. Jumping to that Sloc is not helpful 71 | -- so these calls should be used to freeze the position. Each "push" 72 | -- must be cancelled with a "pop" and the position will be frozen until 73 | -- the all pushes have been popped. 74 | 75 | procedure Create_Global_Variable_Debug_Data (E : Entity_Id; V : GL_Value) 76 | with Pre => not Is_Type (E) and then Present (V); 77 | -- Build debugging data for E, a global variable, with V as its 78 | -- location. 79 | 80 | procedure Create_Local_Variable_Debug_Data 81 | (E : Entity_Id; V : GL_Value; Arg_Num : Nat := 0) 82 | with Pre => not Is_Type (E) and then Present (V); 83 | -- Likewise, for local variables. Arg_Num is the argument number if 84 | -- this is for a parameter. 85 | 86 | procedure Add_Label_Debug_Info (E : Entity_Id; B : Basic_Block_T) 87 | with Pre => Present (E); 88 | -- Add debugging info for the label E, corresponding to the 89 | -- given basic block. 90 | 91 | procedure Import_Module (N : Node_Id) 92 | with Pre => Present (N); 93 | -- Add debugging info for the "use" clause N. 94 | 95 | function Create_Type_Data (GT : GL_Type; 96 | M : access Discriminant_Map := null) 97 | return Metadata_T 98 | with Pre => Present (GT); 99 | -- Create metadata corresponding to the type of GT. Return 100 | -- No_Metadata_T if the type is too complex. 101 | 102 | Empty_DI_Expr : Metadata_T; 103 | -- An empty DI_Expr 104 | 105 | private 106 | 107 | -- Define the various Dwarf type attributes. This is encoded in 108 | -- llvm/BinaryFormat/Dwarf.def, but it's simpler to just repeat them 109 | -- here since they are part of the standard and won't change. 110 | 111 | DW_ATE_Address : constant DWARF_Type_Encoding_T := 16#01#; 112 | DW_ATE_Boolean : constant DWARF_Type_Encoding_T := 16#02#; 113 | DW_ATE_Complex_Float : constant DWARF_Type_Encoding_T := 16#03#; 114 | DW_ATE_Float : constant DWARF_Type_Encoding_T := 16#04#; 115 | DW_ATE_Signed : constant DWARF_Type_Encoding_T := 16#05#; 116 | DW_ATE_Signed_Char : constant DWARF_Type_Encoding_T := 16#06#; 117 | DW_ATE_Unsigned : constant DWARF_Type_Encoding_T := 16#07#; 118 | DW_ATE_Unsigned_Char : constant DWARF_Type_Encoding_T := 16#08#; 119 | DW_ATE_Imaginary_Float : constant DWARF_Type_Encoding_T := 16#09#; 120 | DW_ATE_Packed_Decimal : constant DWARF_Type_Encoding_T := 16#0A#; 121 | DW_ATE_Numeric_String : constant DWARF_Type_Encoding_T := 16#0B#; 122 | DW_ATE_Edited : constant DWARF_Type_Encoding_T := 16#0C#; 123 | DW_ATE_Signed_Fixed : constant DWARF_Type_Encoding_T := 16#0D#; 124 | DW_ATE_Unsigned_Fixed : constant DWARF_Type_Encoding_T := 16#0E#; 125 | DW_ATE_Decimal_Float : constant DWARF_Type_Encoding_T := 16#0F#; 126 | DW_ATE_UTF : constant DWARF_Type_Encoding_T := 16#10#; 127 | DW_ATE_UCS : constant DWARF_Type_Encoding_T := 16#11#; 128 | DW_ATE_ASCII : constant DWARF_Type_Encoding_T := 16#12#; 129 | 130 | end GNATLLVM.DebugInfo; 131 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-blocks.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with GNATLLVM.GLValue; use GNATLLVM.GLValue; 19 | with GNATLLVM.Subprograms; use GNATLLVM.Subprograms; 20 | 21 | package GNATLLVM.Blocks is 22 | 23 | -- We define a "block" here as an area of code that needs some sort of 24 | -- "protection" in that certain things are to be done when the block is 25 | -- exited, either normally, abnormally, or both. 26 | -- 27 | -- We handle three kinds of "things" here: 28 | -- 29 | -- (1) The stack pointer needs to be saved and restored to 30 | -- deallocate any variables created in the block. This is done 31 | -- both on normal and abnormal exit and operates from the start of 32 | -- the block to the end of the block. Every block other than the 33 | -- block corresponding to the enter subprogram has this action. 34 | -- 35 | -- (2) If there if an "at end" handler, it needs to be executed on 36 | -- any normal or abnormal exit, but this does not include the 37 | -- declarative region of the block. 38 | -- 39 | -- (3) If there are exception handles, they are executed if an 40 | -- exception occurs, but this also does not include the declarative 41 | -- region of the block. 42 | 43 | procedure Push_Block 44 | (At_End_Proc : Opt_N_Subexpr_Id := Empty; 45 | EH_List : List_Id := No_List; 46 | Finally_Stmts : List_Id := No_List; 47 | Catch_Unhandled : Boolean := False) 48 | with Pre => not Library_Level; 49 | -- Push a block onto the block stack 50 | 51 | procedure Maybe_Update_At_End (E : E_Constant_Id); 52 | -- E is a constant being declared. See if it's a static chain for 53 | -- the current function and update the at end parameter for the 54 | -- current block if necessary. 55 | 56 | procedure Save_Stack_Pointer; 57 | -- Generate a stack save at the start of the current block 58 | 59 | procedure Add_Lifetime_Entry (Ptr, Size : GL_Value) 60 | with Pre => Present (Ptr) and then Present (Size); 61 | -- Add an entry for a variable lifetime that ends at the end of this block 62 | 63 | function Get_Landing_Pad return Basic_Block_T; 64 | -- Get the basic block for the landingpad in the current block, if any 65 | 66 | procedure Pop_Block 67 | with Pre => not Library_Level; 68 | -- End the current block, generating code for any handlers, and 69 | -- pop the block stack. 70 | 71 | procedure Process_Push_Pop_xxx_Error_Label (N : N_Push_Pop_xxx_Label_Id); 72 | -- Process the above nodes by pushing and popping entries in our tables 73 | 74 | function Get_Exception_Goto_Entry (Kind : Node_Kind) return Opt_E_Label_Id 75 | with Pre => Kind in N_Raise_xxx_Error; 76 | -- Get the last entry in the exception goto stack for Kind, if any 77 | 78 | function Get_Label_BB 79 | (E : E_Label_Id; For_Address : Boolean := False) return Basic_Block_T 80 | with Post => Present (Get_Label_BB'Result); 81 | -- Lazily get the basic block associated with label E, creating it 82 | -- if we don't have it already. If For_Address is True, we're getting 83 | -- this label to take its address, so we ignore any fixups. 84 | 85 | function Enter_Block_With_Node (Node : Opt_N_Label_Id) return Basic_Block_T 86 | with Post => Present (Enter_Block_With_Node'Result); 87 | -- We need a basic block at the present location to branch to. 88 | -- This will normally be a new basic block, but may be the current 89 | -- basic block if it's empty and not the entry block. If Node is 90 | -- Present and already points to a basic block, we have to use 91 | -- that one. If Present, but it doesn't point to a basic block, 92 | -- set it to the one we made. 93 | 94 | procedure Push_Loop (LE : E_Loop_Id; Exit_Point : Basic_Block_T) 95 | with Pre => Present (Exit_Point); 96 | procedure Pop_Loop; 97 | 98 | function Get_Exit_Point (N : Opt_N_Has_Entity_Id) return Basic_Block_T 99 | with Post => Present (Get_Exit_Point'Result); 100 | -- If N is specied, find the exit point corresponding to its entity. 101 | -- Otherwise, find the most recent (most inner) exit point. 102 | 103 | procedure Emit_Raise_Call_If 104 | (V : GL_Value; 105 | N : Node_Id; 106 | Kind : RT_Exception_Code := CE_Overflow_Check_Failed) 107 | with Pre => Present (N) and then Present (V); 108 | -- Raise an exception (default is overflow) if V evaluates to True 109 | 110 | procedure Emit_Fixups_For_Return; 111 | -- We're going to do a return. Emit any needed fixups from the block 112 | -- we're in all the way out of the subprogram. 113 | 114 | procedure Emit_Raise_Call 115 | (N : Node_Id; Kind : RT_Exception_Code; Column : Boolean := False) 116 | with Pre => Present (N); 117 | -- Generate a call to a raise subprogram. If Column is true, this is 118 | -- call to and "extended" raise subprogram that accept column 119 | -- information. 120 | 121 | procedure Emit_Raise (N : N_Raise_xxx_Error_Id); 122 | -- Process an N_Raise_xxx_Error node 123 | 124 | procedure Emit_Reraise; 125 | -- Emit code for an N_Raise 126 | 127 | procedure Reset_Block_Tables; 128 | -- We don't cut back some of the tables in this module when we can 129 | -- because they aren't used much, but we can certinly empty them 130 | -- when a subprogram is completed. 131 | 132 | procedure Initialize; 133 | -- Initialize all global names 134 | 135 | end GNATLLVM.Blocks; 136 | -------------------------------------------------------------------------------- /llvm-interface/ccg/ccg-aggregates.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- C C G -- 3 | -- -- 4 | -- Copyright (C) 2020-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with Interfaces.C; use Interfaces.C; 19 | 20 | with LLVM.Core; use LLVM.Core; 21 | 22 | with Set_Targ; use Set_Targ; 23 | 24 | with CCG.Helper; use CCG.Helper; 25 | with CCG.Strs; use CCG.Strs; 26 | with CCG.Utils; use CCG.Utils; 27 | 28 | package CCG.Aggregates is 29 | 30 | -- This package contains routines used to process aggregate data, 31 | -- which are arrays and structs. 32 | 33 | -- For reasons discussed in the spec of GNATLLVM.Records.Create, we 34 | -- create most LLVM struct types as packed. However, we would prefer to 35 | -- not have most records packed in the C output, both because this 36 | -- makes it harder to read and to avoid warnings if we take the address 37 | -- of a packed field. Likewise, we'd prefer to avoid outputting any 38 | -- padding fields since they clutter the output. So we need to compute 39 | -- whether or not the record actually needs to be packed. It does if 40 | -- one of the following is true: 41 | -- 42 | -- - a field is at a position that is less than that determined by 43 | -- the default alignment of the previous field 44 | -- 45 | -- - the alignment of the record is less than that of its default 46 | -- alignment 47 | -- 48 | -- - the struct is part of an unconstrained record 49 | -- 50 | -- In order to make these determinations, we need a function that 51 | -- computes the default alignment of a type, which recurses over all 52 | -- fields in the struct. Because this is exponential in the depth of 53 | -- nesting of structs, we could use a map to cache the intermediate 54 | -- alignment, but multiple deep structures are rare. 55 | -- 56 | -- In addition to the default alignment that a record would have if it 57 | -- weren't packed, we have the actual alignment of the record, which is 58 | -- the default if we aren't going to pack it and byte-alignment if we 59 | -- are. 60 | -- 61 | -- We also record whether, for the non-packed case, we need to include 62 | -- padding fields. We do if the padding fields produce additional 63 | -- space. So there are three cases: 64 | -- 65 | -- (1) Each field is at its natural position, taking into account 66 | -- alignment. We don't pack the record or output padding fields. 67 | -- (2) At least one field is at a lower offset than its natural 68 | -- position. We must pack the record and output padding fields. 69 | -- (3) At least one field is at a higher offset than its natural position 70 | -- but none is at a lower offset. We don't pack the record, but 71 | -- do output padding fields. 72 | -- 73 | -- In computing alignment, we use the ABI-returned alignment for 74 | -- elementary types, which can be specified by the user in the data 75 | -- layout string, assume that the default alignment of a struct is the 76 | -- maximum alignments of all the fields in the struct, and assume that 77 | -- the alignment of an array is that of its component. 78 | 79 | type Struct_Out_Style_T is (Normal, Padding, Packed); 80 | -- Says how we want to output the struct. Packed also means that we 81 | -- output padding fields. 82 | 83 | procedure Need_IXX_Struct (J : Nat) 84 | with Pre => J < Long_Long_Size, Inline; 85 | -- Show that we need a struct to support a load or store of an iXX type 86 | 87 | procedure Output_IXX_Structs; 88 | -- Output any needed such structs 89 | 90 | function Default_Alignment (T : Type_T) return Nat 91 | with Pre => Present (T); 92 | function Struct_Out_Style (T : Type_T) return Struct_Out_Style_T 93 | with Pre => Is_Struct_Type (T); 94 | function Actual_Alignment (T : Type_T) return Nat is 95 | ((if Is_Struct_Type (T) and then Struct_Out_Style (T) = Packed 96 | then BPU else Default_Alignment (T))) 97 | with Pre => Present (T); 98 | 99 | procedure Output_Struct_Typedef (T : Type_T; Incomplete : Boolean := False) 100 | with Pre => Is_Struct_Type (T); 101 | -- Output a typedef for T, a struct type. If Incomplete, only output the 102 | -- initial struct definition, not the fields. 103 | 104 | procedure Error_If_Cannot_Pack (T : Type_T) 105 | with Pre => Present (T); 106 | -- We're using T in a context where it matters if its size isn't a 107 | -- multiple of its alignment, so give an error if that's that case 108 | -- and we don't support packing. 109 | 110 | procedure Output_Array_Typedef (T : Type_T) 111 | with Pre => Is_Array_Type (T); 112 | -- Output a typedef for T, an array type 113 | 114 | procedure Maybe_Output_Array_Return_Typedef (T : Type_T) 115 | with Pre => Is_Array_Type (T); 116 | -- If we haven't done so already, output the typedef for the struct that 117 | -- will be used as the actual return type if T were the return type of 118 | -- a function. This is known to be the name of T with a suffixed "_R". 119 | 120 | function Extract_Value_Instruction (V : Value_T; Op : Value_T) return Str 121 | with Pre => Is_A_Extract_Value_Inst (V) and then Present (Op), 122 | Post => Present (Extract_Value_Instruction'Result); 123 | -- Return the result of an extractvalue instruction V 124 | 125 | procedure Insert_Value_Instruction (V, Aggr, Op : Value_T) 126 | with Pre => Is_A_Insert_Value_Inst (V) and then Present (Aggr) 127 | and then Present (Op); 128 | -- Process an insertvalue instruction V with an initial value of Aggr 129 | -- and assigning Op to the component. 130 | 131 | procedure GEP_Instruction (V : Value_T; Ops : Value_Array) 132 | with Pre => Get_Opcode (V) = Op_Get_Element_Ptr and then Ops'Length > 1; 133 | -- Process a GEP instruction or a GEP constant expression 134 | 135 | end CCG.Aggregates; 136 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-codegen.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with Options; use Options; 19 | with Options.Target; use Options.Target; 20 | 21 | package GNATLLVM.Codegen is 22 | 23 | type Code_Generation_Kind is 24 | (Dump_IR, Write_IR, Write_BC, Write_Assembly, Write_Object, Write_C, 25 | None); 26 | 27 | Filename : String_Access := new String'(""); 28 | -- Filename to compile. 29 | 30 | Code_Generation : Code_Generation_Kind := Write_Object; 31 | -- Type of code generation we're doing 32 | 33 | Emit_C : Boolean := CCG; 34 | -- True if -emit-c was specified explicitly or CCG set 35 | 36 | Use_FE_Data : Boolean := Emit_C; 37 | -- Use Front End data to help C code generation 38 | 39 | Use_GNAT_Allocs : Boolean := False; 40 | -- True if we should emit calls to __gnat_malloc and __gnat_free even 41 | -- if generating C. 42 | 43 | CPU : String_Access := null; 44 | -- Name of the specific CPU for this compilation. 45 | 46 | ABI : String_Access := new String'(""); 47 | -- Name of the ABI to use during code generation. 48 | 49 | Features : String_Access := new String'(""); 50 | -- Features to enable or disable for this target 51 | 52 | Target_Triple : String_Access := 53 | new String'(Default_Target_Triple); 54 | -- Name of the target for this compilation 55 | 56 | Normalized_Target_Triple : String_Access := null; 57 | -- Target for this compilation, normalized for LLVM 58 | 59 | Target_Layout : String_Access := null; 60 | -- Target data layout, if specified 61 | 62 | Code_Gen_Level : Code_Gen_Opt_Level_T := Code_Gen_Level_None; 63 | -- Optimization level for codegen 64 | 65 | Code_Model : Code_Model_T := Code_Model_Default; 66 | Reloc_Mode : Reloc_Mode_T := Reloc_Default; 67 | PIC_Level : PIC_PIE_Level := 0; 68 | PIE_Level : PIC_PIE_Level := 0; 69 | No_Implicit_Float : Boolean := False; 70 | -- Code generation options 71 | 72 | Code_Opt_Level : Int := 0; 73 | Size_Opt_Level : Int := 0; 74 | -- Optimization levels 75 | 76 | SEH : Boolean := False; 77 | -- True if the target supports Structured Exception Handling 78 | 79 | DSO_Preemptable : Boolean := False; 80 | -- Indicates that the function or variable may be replaced by a symbol 81 | -- from outside the linkage unit at runtime. clang derives this from 82 | -- a complex set of machine-dependent criterial, but the need for 83 | -- this is rare enough that we'll just provide a switch instead. 84 | 85 | Optimize_IR : Boolean := True; 86 | -- True if we should optimize IR before writing it out when optimization 87 | -- is enabled. 88 | 89 | Enable_Execute_Stack : Boolean := False; 90 | -- True if we have to explicitly make the stack executable when we need 91 | -- it to be (e.g., when using stack-allocated trampolines). 92 | 93 | No_Strict_Aliasing_Flag : Boolean := False; 94 | C_Style_Aliasing : Boolean := False; 95 | No_Inlining : Boolean := False; 96 | Unroll_Loops : Boolean := True; 97 | Loop_Vectorization : Boolean := False; 98 | SLP_Vectorization : Boolean := False; 99 | Merge_Functions : Boolean := False; 100 | Prepare_For_Thin_LTO : Boolean := False; 101 | Prepare_For_LTO : Boolean := False; 102 | Reroll_Loops : Boolean := False; 103 | No_Tail_Calls : Boolean := False; 104 | Pass_Plugin_Name : String_Access := null; 105 | -- Switch options for optimization 106 | 107 | Enable_Fuzzer : Boolean := False; 108 | Enable_Address_Sanitizer : Boolean := False; 109 | San_Cov_Allow_List : String_Access := null; 110 | San_Cov_Ignore_List : String_Access := null; 111 | -- Sanitizer options (including the fuzzer, which implies coverage 112 | -- sanitizer) 113 | 114 | Force_Activation_Record_Parameter : Boolean := False; 115 | -- Indicates that we need to force all subprograms to have an activation 116 | -- record parameter. We need to do this for targets, such as WebAssembly, 117 | -- that require strict parameter agreement between calls and declarations. 118 | 119 | procedure Scan_Command_Line; 120 | -- Scan operands relevant to code generation 121 | 122 | procedure Initialize_GNAT_LLVM; 123 | -- Perform initializations that need to be done before calling the 124 | -- front end. 125 | 126 | procedure Initialize_LLVM_Target; 127 | -- Initialize all the data structures specific to the LLVM target code 128 | -- generation. 129 | 130 | procedure Generate_Code (GNAT_Root : N_Compilation_Unit_Id); 131 | -- Generate LLVM code from what we've compiled with a node for error 132 | -- messages. 133 | 134 | function Is_Back_End_Switch (Switch : String) return Boolean; 135 | -- Return True if Switch is a switch known to the back end 136 | 137 | function Output_File_Name (Extension : String) return String; 138 | -- Return the name of the output file, using the given Extension 139 | 140 | procedure Early_Error (S : String); 141 | -- This is called too early to call Error_Msg (because we haven't 142 | -- initialized the source input structure), so we have to use a 143 | -- low-level mechanism to emit errors here. 144 | 145 | function Get_LLVM_Error_Msg (Msg : Ptr_Err_Msg_Type) return String; 146 | -- Get the LLVM error message that was stored in Msg 147 | 148 | Libdevice_Filename : String_Access := 149 | new String'("/usr/local/cuda/nvvm/libdevice/libdevice.10.bc"); 150 | -- Location for libdevice for CUDA. 151 | -- ??? This should be moved back to the body once VC21-031 is fixed 152 | 153 | end GNATLLVM.Codegen; 154 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-exprs.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with GNATLLVM.GLValue; use GNATLLVM.GLValue; 19 | with GNATLLVM.Instructions; use GNATLLVM.Instructions; 20 | with GNATLLVM.Records.Field_Ref; use GNATLLVM.Records.Field_Ref; 21 | 22 | package GNATLLVM.Exprs is 23 | -- This can't be named GNATLLVM.Expressions because it conflicts 24 | -- with Expressions in Sinfo, 25 | 26 | function Is_Safe_From (LHS : GL_Value; N : N_Subexpr_Id) return Boolean 27 | with Pre => Present (LHS); 28 | -- True if we know that clobbering LHS won't change the value of N 29 | 30 | procedure LHS_And_Component_For_Assignment 31 | (N : N_Subexpr_Id; 32 | LHS : out GL_Value; 33 | F : out Opt_Record_Field_Kind_Id; 34 | Idxs : out Access_GL_Value_Array; 35 | BRD : out Bitfield_Ref_Desc; 36 | Only_Bitfield : Boolean := False); 37 | -- N is an expression that's used in a LHS context, either the LHS side 38 | -- of an N_Assignment_Statement or an actual corresponding to an Out 39 | -- (or in Out) parameter. If N represents an field selection (if 40 | -- Only_Bitfield then only if that field is a bitfield), then LHS is 41 | -- the Prefix of that selection and F is the field being selected. If 42 | -- N is an indexed reference, Idxs is a pointer to the list of indices. 43 | -- If N is a mixed bitfield reference, BRD describes the bitfield. 44 | -- Otherwise, F is Empty, Idxs is null, and LHS is the LValue form of N. 45 | 46 | procedure Add_Write_Back 47 | (LHS : GL_Value; F : Opt_Record_Field_Kind_Id; RHS : GL_Value) 48 | with Pre => (No (F) or else Is_Record_Type (LHS)) 49 | and then Present (RHS); 50 | -- Like Build_Field_Store, but stack the operation to be performed 51 | -- later. The operations are performed LIFO. 52 | 53 | procedure Perform_Writebacks; 54 | -- Perform any writebacks put onto the stack by the Add_Write_Back 55 | -- procedure. 56 | 57 | procedure Emit_Overflow_Check (V : GL_Value; N : N_Type_Conversion_Id) 58 | with Pre => Present (V) and then Is_Elementary_Type (V); 59 | -- Check that V is within the bounds of N's type. 60 | 61 | function Emit_Shift 62 | (Operation : Node_Kind; 63 | LHS_Node, RHS_Node : N_Subexpr_Id) return GL_Value 64 | with Pre => Operation in N_Op_Shift, Post => Present (Emit_Shift'Result); 65 | -- Handle shift and rotate operations 66 | 67 | function Emit_Binary_Operation (N : N_Binary_Op_Id) return GL_Value 68 | with Post => Present (Emit_Binary_Operation'Result); 69 | -- Handle other binary operations 70 | 71 | function Emit_Unary_Operation (N : N_Unary_Op_Id) return GL_Value 72 | with Post => Present (Emit_Unary_Operation'Result); 73 | -- Handle unary operations 74 | 75 | function Emit_Literal (N : N_Subexpr_Id) return GL_Value 76 | with Post => Present (Emit_Literal'Result); 77 | -- Generate code for a literal 78 | 79 | function Emit_Undef (GT : GL_Type) return GL_Value 80 | with Pre => Present (GT), Post => Present (Emit_Undef'Result); 81 | -- Emit an undef appropriate for a return value of type TE 82 | 83 | procedure Emit_Assignment_Statement (N : N_Assignment_Statement_Id); 84 | procedure Emit_Pragma (N : N_Pragma_Id); 85 | 86 | function Emit_Attribute_Reference 87 | (N : N_Attribute_Reference_Id) return GL_Value 88 | with Post => Present (Emit_Attribute_Reference'Result); 89 | -- Handle N_Attribute_Reference nodes 90 | 91 | procedure Emit_Assignment 92 | (LValue : GL_Value; 93 | Expr : Opt_N_Subexpr_Id := Empty; 94 | Value : GL_Value := No_GL_Value; 95 | Forwards_OK : Boolean := True; 96 | Backwards_OK : Boolean := True; 97 | VFA : Boolean := False) 98 | with Pre => Present (LValue) 99 | and then (Present (Expr) or else Present (Value)); 100 | -- Copy the value of the expression Expr or Value to LValue 101 | 102 | procedure Emit_Code_Statement (N : N_Code_Statement_Id); 103 | -- Generate code for inline asm 104 | 105 | function Build_Max 106 | (LHS, RHS : GL_Value; Name : String := "") return GL_Value 107 | is 108 | (Build_Select 109 | ((if Is_Floating_Point_Type (LHS) then 110 | F_Cmp (Real_OGT, LHS, RHS) 111 | else 112 | I_Cmp ((if Is_Unsigned_Type (LHS) then Int_UGT else Int_SGT), 113 | LHS, RHS)), 114 | LHS, RHS, Name)) 115 | with Pre => Present (LHS) and then Present (RHS), 116 | Post => Present (Build_Max'Result); 117 | 118 | function Build_Min 119 | (LHS, RHS : GL_Value; Name : String := "") return GL_Value 120 | is 121 | (Build_Select 122 | ((if Is_Floating_Point_Type (LHS) then 123 | F_Cmp (Real_OLT, LHS, RHS) 124 | else 125 | I_Cmp ((if Is_Unsigned_Type (LHS) then Int_ULT else Int_SLT), 126 | LHS, RHS)), 127 | LHS, RHS, Name)) 128 | with Pre => Present (LHS) and then Present (RHS), 129 | Post => Present (Build_Min'Result); 130 | 131 | function Build_Inc_Wrap 132 | (LHS, RHS : GL_Value; Name : String := "") return GL_Value 133 | is 134 | -- LLVM Language Reference: 135 | -- *ptr = (*ptr u>= val) ? 0 : (*ptr + 1) 136 | 137 | (Build_Select (I_Cmp (Int_UGE, LHS, RHS), Const_Int (LHS, 0), LHS + 1, 138 | Name)) 139 | with Pre => Present (LHS) and then Present (RHS), 140 | Post => Present (Build_Inc_Wrap'Result); 141 | 142 | function Build_Dec_Wrap 143 | (LHS, RHS : GL_Value; Name : String := "") return GL_Value 144 | is 145 | -- LLVM Language Reference: 146 | -- *ptr = ((*ptr == 0) || (*ptr u> val)) ? val : (*ptr - 1) 147 | 148 | (Build_Select (Build_Or (I_Cmp (Int_EQ, LHS, Const_Int (LHS, 0)), 149 | I_Cmp (Int_UGT, LHS, RHS)), 150 | RHS, LHS - 1, Name)) 151 | with Pre => Present (LHS) and then Present (RHS), 152 | Post => Present (Build_Dec_Wrap'Result); 153 | 154 | end GNATLLVM.Exprs; 155 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-variables.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with GNATLLVM.GLValue; use GNATLLVM.GLValue; 19 | 20 | package GNATLLVM.Variables is 21 | 22 | type Interface_Names_Id is new Nat; 23 | type Global_Dup_Id is new Nat; 24 | type Global_Dup_Value_Id is new Nat; 25 | 26 | Empty_Interfaces_Name_Id : constant Interface_Names_Id := 0; 27 | Empty_Global_Dup_Id : constant Global_Dup_Id := 0; 28 | Empty_Global_Dup_Value_Id : constant Global_Dup_Value_Id := 0; 29 | 30 | function Present (Idx : Interface_Names_Id) return Boolean is (Idx /= 0); 31 | function Present (Idx : Global_Dup_Id) return Boolean is (Idx /= 0); 32 | function Present (Idx : Global_Dup_Value_Id) return Boolean is (Idx /= 0); 33 | 34 | function No (Idx : Interface_Names_Id) return Boolean is (Idx = 0); 35 | function No (Idx : Global_Dup_Id) return Boolean is (Idx = 0); 36 | function No (Idx : Global_Dup_Value_Id) return Boolean is (Idx = 0); 37 | 38 | Detected_Duplicates : Boolean := False; 39 | 40 | procedure Register_Global_Name (S : String) 41 | with Pre => not Detected_Duplicates; 42 | -- Register that we may be generating a global (variable or subprogram) 43 | -- of name S. Must be called after we've looked for globals with 44 | -- Interface_Names. Must not be called twice with the same name. 45 | 46 | procedure Detect_Duplicate_Global_Names; 47 | -- Make a pass over all library units looking for the use of the same 48 | -- global name in two different entities and keep a record of all such 49 | -- duplications. 50 | 51 | function Get_Dup_Global_Value (E : Global_Name_Kind_Id) return GL_Value; 52 | -- If E corresponds to a duplicated interface name and we've aready 53 | -- created a global for it, return that global. 54 | 55 | procedure Set_Dup_Global_Value (E : Global_Name_Kind_Id; V : GL_Value) 56 | with Pre => Present (V); 57 | -- If E corresponds to a duplicated interface name, record that we've 58 | -- created a value for it. 59 | 60 | function Get_Dup_Global_Value (S : String) return GL_Value; 61 | procedure Set_Dup_Global_Value (S : String; V : GL_Value) 62 | with Pre => Present (V); 63 | -- Similar, but for strings (for builtins) 64 | 65 | procedure Emit_Decl_Lists 66 | (List1 : List_Id := No_List; 67 | List2 : List_Id := No_List; 68 | End_List : Node_Id := Empty; 69 | Pass1 : Boolean := True; 70 | Pass2 : Boolean := True); 71 | -- Elaborate decls in the lists List1 and List2, if present. We make 72 | -- two passes, one to elaborate anything other than bodies (but we 73 | -- declare a function if there was no spec). The second pass 74 | -- elaborates the bodies. 75 | -- 76 | -- End_List gives the element in the list past the end. Normally, this 77 | -- is Empty, but can be First_Real_Statement for a 78 | -- Handled_Sequence_Of_Statements. 79 | -- 80 | -- We make a complete pass through both lists if Pass1 is true, then 81 | -- make the second pass over both lists if Pass2 is true. The lists 82 | -- usually correspond to the public and private parts of a package. 83 | 84 | function Maybe_Promote_Alloca 85 | (T : Type_T; Elts : GL_Value := No_GL_Value) return Basic_Block_T 86 | with Pre => Present (T); 87 | -- Called when about to do an alloca of type T to see if that 88 | -- alloca should be promoted to the entry block. The return from 89 | -- this function must be passed to Done_Promoting_Alloca along 90 | -- with the alloca immediately after emitting the alloca. The 91 | -- pair of calls will do what's necessary, either promoting the 92 | -- alloca or forcing a stack save/restore. If Elts isn't specified, 93 | -- it's presumed to be 1. 94 | procedure Done_Promoting_Alloca 95 | (Alloca : GL_Value; 96 | BB : Basic_Block_T; 97 | T : Type_T; 98 | Elts : GL_Value := No_GL_Value) 99 | with Pre => Present (Alloca) and then Present (T); 100 | 101 | function Is_Static_Address 102 | (N : N_Subexpr_Id; Not_Symbolic : Boolean := False) return Boolean; 103 | -- Return True if N represents an address that can computed statically. 104 | -- If Not_Symbolic is True, only return if this address is a constant 105 | -- integer (rare). 106 | 107 | function Static_Address (N : N_Subexpr_Id) return GL_Value; 108 | -- Return the LLVM representation of the address represented by N, or 109 | -- report an error and return undefined if N isn't (a conversion of) a 110 | -- compile-time known address. 111 | 112 | function Is_No_Elab_Needed 113 | (N : N_Subexpr_Id; 114 | Not_Symbolic : Boolean := False; 115 | Restrict_Types : Boolean := False) return Boolean 116 | with Pre => Present (N); 117 | -- Return True if N represents an expression that can be computed 118 | -- without needing an elab proc. If Not_Symbolic is True, we also 119 | -- can't alllow anything symbolic. If Restrict_Types is True, we can't 120 | -- allow anything that's an access type or an elementary type wider 121 | -- than a word. 122 | 123 | function Is_No_Elab_Needed_For_Entity 124 | (E : Evaluable_Kind_Id; 125 | Not_Symbolic : Boolean := False; 126 | Restrict_Types : Boolean := False) return Boolean; 127 | -- Return True if E represents an entity that can be computed 128 | -- without needing an elab proc. If Not_Symbolic is True, we also 129 | -- can't alllow anything symbolic. If Restrict_Types is True, we can't 130 | -- allow anything that's an access type or an elementary type wider 131 | -- than a word. 132 | 133 | function Make_Global_Constant (V : GL_Value) return GL_Value 134 | with Pre => not Is_Reference (V), 135 | Post => Is_A_Global_Variable (Make_Global_Constant'Result) 136 | or else Is_Undef (Make_Global_Constant'Result); 137 | -- Create a global constant that contains the value of V 138 | 139 | procedure Emit_Declaration 140 | (N : N_Declaration_Id; For_Freeze_Entity : Boolean := False); 141 | -- Emit a declaration. For_Freeze_Entity is True if we're processing 142 | -- a Freeze_Entity. 143 | 144 | procedure Emit_Renaming_Declaration (N : N_Renaming_Declaration_Id); 145 | -- Emit an object or exception renaming declaration 146 | 147 | function Emit_Entity 148 | (E : Evaluable_Kind_Id; 149 | N : Opt_N_Has_Entity_Id := Empty; 150 | Prefer_LHS : Boolean := False) return GL_Value; 151 | -- Evaluate an entity E. If Present, N is the corresponding N_Identifier 152 | -- node. Prefer_LHS is True if we'd prefer this for a LHS context. 153 | 154 | end GNATLLVM.Variables; 155 | -------------------------------------------------------------------------------- /llvm-interface/ccg/ccg-output.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- C C G -- 3 | -- -- 4 | -- Copyright (C) 2020-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with LLVM.Core; use LLVM.Core; 19 | 20 | with CCG.Codegen; use CCG.Codegen; 21 | with CCG.Environment; use CCG.Environment; 22 | with CCG.Helper; use CCG.Helper; 23 | with CCG.Strs; use CCG.Strs; 24 | 25 | package CCG.Output is 26 | 27 | -- This package contains subprograms used to output segments of C 28 | -- code into structures that are later written to the output file. 29 | 30 | -- When we write a C block structure, we have various indentation 31 | -- rules and we may or may not need an open and close brace. We 32 | -- have various types of blocks, which we name here according to 33 | -- the statement type. 34 | 35 | type Block_Style is (None, Decl, If_Part, Switch); 36 | 37 | -- There are three possible indentations for a line: normal indentation, 38 | -- all the way on the left (labels) and aligned with the brace (switch 39 | -- statement). 40 | 41 | type Indent_Style is (Normal, Left, Under_Brace); 42 | 43 | function Present (BS : Block_Style) return Boolean is 44 | (BS /= None); 45 | function Present (INDS : Indent_Style) return Boolean is 46 | (INDS /= Normal); 47 | 48 | function No (BS : Block_Style) return Boolean is 49 | (BS = None); 50 | function No (INDS : Indent_Style) return Boolean is 51 | (INDS = Normal); 52 | 53 | -- We represent each line being output as an Str, but also record 54 | -- other information that helps us output the line. 55 | 56 | type Out_Line is record 57 | Line_Text : Str; 58 | -- The actual string to output 59 | 60 | Start_Block : Block_Style; 61 | -- The type of block, if any, started by this line 62 | 63 | End_Block : Block_Style; 64 | -- The type of block, if any, ended by this line. If the line starts 65 | -- with a brace, we use this line instead of writing a line with 66 | -- just a brace. 67 | 68 | Indent_Type : Indent_Style; 69 | -- The indentation desired for this line 70 | 71 | V : Value_T; 72 | -- An LLVM value corresponding to this line, if any 73 | 74 | No_Debug_Info : Boolean; 75 | -- If True, don't use V for debug information 76 | 77 | end record; 78 | 79 | procedure Output_Typedef (T : Type_T; Incomplete : Boolean := False) 80 | with Pre => Present (T), 81 | Post => Get_Is_Typedef_Output (T) 82 | or else (Incomplete and then Get_Is_Incomplete_Output (T)); 83 | -- Output the typedef for T, if any. If Incomplete an T is a struct type, 84 | 85 | procedure Output_Decl 86 | (S : Str; 87 | Semicolon : Boolean := True; 88 | Is_Typedef : Boolean := False; 89 | Is_Global : Boolean := False; 90 | Start_Block : Block_Style := None; 91 | End_Block : Block_Style := None; 92 | Indent_Type : Indent_Style := Normal; 93 | V : Value_T := No_Value_T; 94 | No_Debug_Info : Boolean := False) 95 | with Pre => Present (S); 96 | procedure Output_Decl 97 | (S : String; 98 | Semicolon : Boolean := True; 99 | Is_Typedef : Boolean := False; 100 | Is_Global : Boolean := False; 101 | Start_Block : Block_Style := None; 102 | End_Block : Block_Style := None; 103 | Indent_Type : Indent_Style := Normal; 104 | V : Value_T := No_Value_T; 105 | No_Debug_Info : Boolean := False); 106 | -- Save S as a decl for the current subprogram. Append a semicolon to 107 | -- the string if requested (the default) and specify indentation 108 | -- parameters. V, if Present, is a value that we may be able to get 109 | -- debug information from. If Is_Global is True, this is for the global 110 | -- section, in front of all subprograms; otherwise it's local to the 111 | -- current subprogram. 112 | 113 | procedure Output_Stmt 114 | (S : Str; 115 | Semicolon : Boolean := True; 116 | Indent_Type : Indent_Style := Normal; 117 | V : Value_T := No_Value_T; 118 | No_Debug_Info : Boolean := False); 119 | procedure Output_Stmt 120 | (S : String; 121 | Semicolon : Boolean := True; 122 | Indent_Type : Indent_Style := Normal; 123 | V : Value_T := No_Value_T; 124 | No_Debug_Info : Boolean := False); 125 | -- Like Output_Decl, but for the statement part of the current subprogram 126 | 127 | procedure Start_Output_Block (BS : Block_Style); 128 | -- Indicate that the next call to Output_Decl or Output_Stmt is the 129 | -- start of a block of the specified style. 130 | 131 | procedure End_Decl_Block 132 | (BS : Block_Style; 133 | Is_Typedef : Boolean := False; 134 | Is_Global : Boolean := False); 135 | procedure End_Stmt_Block (BS : Block_Style); 136 | -- Flag the last line output via Output_Decl or Output_Stmt as being 137 | -- the last in its block. 138 | 139 | function Get_Typedef_Line (Idx : Typedef_Idx) return Out_Line; 140 | function Get_Local_Decl_Line (Idx : Local_Decl_Idx) return Out_Line; 141 | function Get_Stmt_Line (Idx : Stmt_Idx) return Out_Line; 142 | function Get_Global_Decl_Line (Idx : Global_Decl_Idx) return Out_Line 143 | with Pre => Present (Idx); 144 | -- Given an index to a decl or statement, return the data for it 145 | 146 | function Get_Global_Decl_Value (Idx : Global_Decl_Idx) return Value_T 147 | with Pre => Present (Idx); 148 | -- Get the value, if any, being declared by a global decl line 149 | 150 | function Get_Last_Typedef return Typedef_Idx; 151 | function Get_Last_Global_Decl return Global_Decl_Idx; 152 | -- Return the index of the last typedef or global decl that was output 153 | 154 | function Is_Entry_Block (BB : Basic_Block_T) return Boolean is 155 | (Get_Entry_Basic_Block (Get_Basic_Block_Parent (BB)) = BB) 156 | with Pre => Present (BB); 157 | function Is_Entry_Block (V : Value_T) return Boolean is 158 | ((if Is_A_Basic_Block (V) then Is_Entry_Block (Value_As_Basic_Block (V)) 159 | else Is_Entry_Block (Get_Instruction_Parent (V)))) 160 | with Pre => Is_A_Basic_Block (V) or else Is_A_Instruction (V); 161 | -- Determine whether something is the entry block or an instruction 162 | -- within the entry block 163 | 164 | procedure Maybe_Decl (V : Value_T; For_Initializer : Boolean := False) 165 | with Pre => Present (V); 166 | -- See if we need to write a declaration for V and write one if so. 167 | -- If For_Initializer, we can allow any constants, not just simple ones. 168 | 169 | function Generic_Ptr return Str is 170 | (if Use_Stdint then +"int8_t *" else +"signed char *"); 171 | -- Return the string to use for a "generic" pointer 172 | 173 | end CCG.Output; 174 | -------------------------------------------------------------------------------- /llvm-interface/uintp-llvm.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with Interfaces; use Interfaces; 19 | 20 | with stdint_h; use stdint_h; 21 | 22 | with LLVM.Core; use LLVM.Core; 23 | 24 | package body Uintp.LLVM is 25 | 26 | subtype Unsigned_64 is Interfaces.Unsigned_64; 27 | 28 | function Big_UI_To_Words (U : Uint) return Word_Array; 29 | -- Convert a Uint into an array of words representing the value 30 | 31 | ---------------- 32 | -- UI_To_LLVM -- 33 | ---------------- 34 | 35 | function UI_To_LLVM (T : Type_T; U : Uint) return Value_T is 36 | begin 37 | if UI_Is_In_Int_Range (U) then 38 | return Const_Int (T, ULL (UI_To_Int (U)), True); 39 | else 40 | declare 41 | Words : Word_Array := Big_UI_To_Words (U); 42 | Result : constant Value_T := Const_Int_Of_Arbitrary_Precision 43 | (T, Words'Length, Words (Words'First)'Access); 44 | 45 | begin 46 | return (if U < Uint_0 then Const_Neg (Result) else Result); 47 | end; 48 | end if; 49 | end UI_To_LLVM; 50 | 51 | --------------- 52 | -- UI_To_ULL -- 53 | --------------- 54 | 55 | function UI_To_ULL (U : Uint) return ULL is 56 | begin 57 | if UI_Is_In_Int_Range (U) then 58 | return ULL (UI_To_Int (U)); 59 | else 60 | declare 61 | Words : constant Word_Array := Big_UI_To_Words (U); 62 | begin 63 | -- We assume that ULL is no wider than an element of Word_Array, 64 | -- but is no narrower than Int. 65 | 66 | pragma Assert (ULL'Size <= Words (Words'First)'Size 67 | and then ULL'Size >= Int'Size); 68 | 69 | -- If this takes up more than one word, it's too large. 70 | -- Otherwise, return the value. 71 | 72 | if Words'Length /= 1 then 73 | raise Constraint_Error; 74 | else 75 | return ULL (Words (Words'First)); 76 | end if; 77 | end; 78 | end if; 79 | 80 | end UI_To_ULL; 81 | 82 | ------------------------ 83 | -- UI_Is_In_ULL_Range -- 84 | ------------------------ 85 | 86 | function UI_Is_In_ULL_Range (U : Uint) return Boolean is 87 | begin 88 | return UI_Is_In_Int_Range (U) 89 | or else Big_UI_To_Words (U)'Length = 1; 90 | end UI_Is_In_ULL_Range; 91 | 92 | ----------------- 93 | -- UI_To_Words -- 94 | ----------------- 95 | 96 | function UI_To_Words (U : Uint) return Word_Array is 97 | Words : Word_Array (1 .. 1); 98 | begin 99 | -- If this fits in an int, get that value. We can't use 100 | -- Big_UI_To_Words for many integer values due to the way Uint works. 101 | 102 | if UI_Is_In_Int_Range (U) then 103 | Words (1) := uint64_t (UI_To_Int (U)); 104 | return Words; 105 | else 106 | return Big_UI_To_Words (U); 107 | end if; 108 | end UI_To_Words; 109 | 110 | --------------------- 111 | -- Big_UI_To_Words -- 112 | --------------------- 113 | 114 | function Big_UI_To_Words (U : Uint) return Word_Array is 115 | D_Table : Udigits.Table_Ptr renames Udigits.Table; 116 | Loc : constant Int := Uints.Table (U).Loc; 117 | Length : constant Pos := Uints.Table (U).Length; 118 | N_Bits : constant Pos := Base_Bits * Length; 119 | N_Words : constant Pos := (N_Bits + 63) / 64; 120 | N_Padding_Bits : constant Pos := N_Words * 64 - N_Bits; 121 | Words : Word_Array (1 .. N_Words) := (others => 0); 122 | Cur_Word : Nat := N_Words; 123 | Cur_Bit : Nat := 64; 124 | 125 | function Ones (Length : Nat) return uint64_t is 126 | (uint64_t (2 ** Integer (Length) - 1)); 127 | -- Return a bitfield with the Length least significant bits set to 1 128 | 129 | procedure Push_Bits (Bits : uint64_t; Length : Nat); 130 | -- Push Bits (an integer Length bits arge) into the upper bits of Words 131 | -- right after the cursor. Update the cursor accordingly. 132 | 133 | --------------- 134 | -- Push_Bits -- 135 | --------------- 136 | 137 | procedure Push_Bits (Bits : uint64_t; Length : Nat) is 138 | Buffer : Unsigned_64 := Unsigned_64 (Bits); 139 | Buffer_Length : Nat := Length; 140 | 141 | begin 142 | -- Cur_Bit is how many bits are left inside the current word 143 | 144 | if Length > Cur_Bit then 145 | -- There are more bits to store than free bits inside the 146 | -- current word: first store the upper ones. 147 | 148 | declare 149 | Left_Over : constant Nat := Buffer_Length - Cur_Bit; 150 | -- Number of bits left in the buffer after storing 151 | -- high-order bits. 152 | 153 | begin 154 | -- First finish filling the current word 155 | 156 | Words (Cur_Word) := uint64_t 157 | (Unsigned_64 (Words (Cur_Word)) 158 | or Shift_Right (Buffer, Integer (Left_Over))); 159 | 160 | -- Then go to the next one, updating both the cursor and the 161 | -- bits to store. 162 | 163 | Cur_Word := Cur_Word - 1; 164 | Cur_Bit := 64; 165 | Buffer := Buffer and Unsigned_64 (Ones (Left_Over)); 166 | Buffer_Length := Left_Over; 167 | end; 168 | end if; 169 | 170 | Words (Cur_Word) := uint64_t (Unsigned_64 (Words (Cur_Word)) 171 | or Shift_Left (Buffer, Integer (Cur_Bit - Buffer_Length))); 172 | Cur_Bit := Cur_Bit - Buffer_Length; 173 | 174 | if Cur_Bit = Nat (0) then 175 | Cur_Word := Cur_Word - 1; 176 | Cur_Bit := 64; 177 | end if; 178 | end Push_Bits; 179 | 180 | begin 181 | -- Note that LLVM takes the first word passed to it as the low-order 182 | -- part of the constant, not the high-order, as might be expected. 183 | -- Also, the absolute value of the constant is what's stored in the 184 | -- Uint table and we later negate if it's negative. 185 | 186 | Push_Bits (0, N_Padding_Bits); 187 | 188 | for J in 1 .. Nat (Length) loop 189 | Push_Bits (uint64_t (abs D_Table (Loc + J - 1)), Base_Bits); 190 | end loop; 191 | 192 | -- When the highest-order Udigit has a low value, it can happen that 193 | -- the highest-order word is zero. In that case, shorten the array to 194 | -- prevent the creation of unnecessarily long LLVM constants. 195 | 196 | -- ??? Removing high-order zeros can change the signed interpretation 197 | -- of the value. Since we return the absolute value and rely on the 198 | -- caller to negate it if necessary, the negation can now overflow. 199 | -- This already happens in UI_To_LLVM because it truncates the result 200 | -- via Const_Int_Of_Arbitrary_Precision, but we may still want to 201 | -- clean up the code. 202 | 203 | if Words (N_Words) = 0 then 204 | return Words (1 .. N_Words - 1); 205 | else 206 | return Words; 207 | end if; 208 | end Big_UI_To_Words; 209 | 210 | end Uintp.LLVM; 211 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-records-field_ref.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2024-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | package GNATLLVM.Records.Field_Ref is 19 | 20 | -- We need to handle a nested set of component and index references 21 | -- where at least the outer one is a bitfield reference. In that case, 22 | -- the front end will always produce a reference to a field of either a 23 | -- primitive type or a small aggregate type. We want to always process 24 | -- only that inner reference. This is both for efficiency reasons (to 25 | -- avoid loading and storing lots of data we don't need and duplicate 26 | -- data since front end splits up the reference) and because there's no 27 | -- straightforward way of writing such in C for objects wider than the 28 | -- size of "long long". 29 | -- 30 | -- We define here a record that's passed to and returned by subrograms 31 | -- that implement this feature. It contains value pointing near the 32 | -- first bit of the data, the number of bits that the needed field is 33 | -- located past LHS, the type of the field, and its size in bits. 34 | 35 | type Bitfield_Ref_Desc is record 36 | LHS : GL_Value; 37 | GT : GL_Type; 38 | Offset : Nat; 39 | Size : Nat; 40 | end record; 41 | 42 | No_BRD : Bitfield_Ref_Desc := (No_GL_Value, No_GL_Type, 0, 0); 43 | function Present (BRD : Bitfield_Ref_Desc) return Boolean is 44 | (Present (BRD.LHS)); 45 | function No (BRD : Bitfield_Ref_Desc) return Boolean is 46 | (No (BRD.LHS)); 47 | 48 | function Is_Normalized (BRD : Bitfield_Ref_Desc) return Boolean; 49 | -- Used for pre- and post-conditions. A BRD is "normalized" if 50 | -- 51 | -- (1) its size isn't larger than the maximum intger type 52 | -- (2) its GL_Type isn't padded 53 | -- (3) either LHS isn't a reference or the offset is within a byte 54 | 55 | function Normalize (BRD : Bitfield_Ref_Desc) return Bitfield_Ref_Desc 56 | with Pre => Present (BRD), 57 | Post => Is_Normalized (Normalize'Result); 58 | -- Return a BRD that has been normalized 59 | 60 | function Record_Field_Offset 61 | (V : GL_Value; Field : Record_Field_Kind_Id) return GL_Value 62 | with Pre => not Is_Data (V), 63 | Post => Present (Record_Field_Offset'Result); 64 | -- Return a GL_Value that represents the offset of a given record field 65 | 66 | function Emit_Record_Aggregate 67 | (N : N_Subexpr_Id; Result_So_Far : GL_Value) return GL_Value 68 | with Pre => Nkind (N) in N_Aggregate | N_Extension_Aggregate 69 | and then Is_Record_Type (Full_Etype (N)), 70 | Post => Present (Emit_Record_Aggregate'Result); 71 | -- Emit code for a record aggregate at Node. Result_So_Far, if 72 | -- Present, contain any fields already filled in for the record. 73 | 74 | -- Compute and return the position in bits of the field specified by E 75 | -- from the start of its type as a value of Size_Type. If Present, V is 76 | -- a value of that type, which is used in the case of a discriminated 77 | -- record. 78 | 79 | -- Because the structure of record and field info is private and we 80 | -- don't want to generate too many accessors, we provide a function 81 | -- here to collect and return information about fields in an RI. 82 | 83 | type Struct_Field is record 84 | Field : Record_Field_Kind_Id; 85 | Offset : ULL; 86 | MDT : MD_Type; 87 | GT : GL_Type; 88 | end record; 89 | 90 | type Struct_Field_Array is array (Nat range <>) of Struct_Field; 91 | 92 | function RI_To_Struct_Field_Array 93 | (Ridx : Record_Info_Id) return Struct_Field_Array 94 | with Pre => Present (Ridx); 95 | -- Return an array of struct field entries for the fields in the RI 96 | 97 | function Collect_Mixed_Bitfield 98 | (In_N : N_Subexpr_Id; 99 | For_LHS : Boolean := False; 100 | Prefer_LHS : Boolean := False) return Bitfield_Ref_Desc 101 | with Post => No (Collect_Mixed_Bitfield'Result) 102 | or else Is_Normalized (Collect_Mixed_Bitfield'Result); 103 | 104 | function Field_To_Use 105 | (LHS : GL_Value; F : Record_Field_Kind_Id) return Record_Field_Kind_Id 106 | with Pre => Present (LHS); 107 | -- Return the actual field to use to access field F of LHS. This may 108 | -- be a field from a related type. 109 | 110 | function Selector_Field 111 | (N : N_Selected_Component_Id) return Record_Field_Kind_Id; 112 | -- Given a selector for a record, return the actual field to use, taking 113 | -- into account the need to find a matching field in related records 114 | -- in some cases. 115 | 116 | function Build_Field_Load 117 | (In_V : GL_Value; 118 | In_F : Record_Field_Kind_Id; 119 | LHS : GL_Value := No_GL_Value; 120 | For_LHS : Boolean := False; 121 | Prefer_LHS : Boolean := False; 122 | VFA : Boolean := False) return GL_Value 123 | with Pre => Is_Record_Type (In_V), 124 | Post => Present (Build_Field_Load'Result); 125 | -- V represents a record. Return a value representing loading field 126 | -- In_F from that record. If For_LHS is True, this must be a reference 127 | -- to the field, otherwise, it may or may not be a reference, depending 128 | -- on what's simpler and the value of Prefer_LHS. 129 | 130 | function Build_Field_Store 131 | (In_LHS : GL_Value; 132 | In_F : Record_Field_Kind_Id; 133 | RHS : GL_Value; 134 | VFA : Boolean := False) return GL_Value 135 | with Pre => Is_Record_Type (In_LHS) and then Present (RHS); 136 | -- Likewise, but perform a store of RHS into the F component of In_LHS. 137 | -- If we return a value, that's the record that needs to be stored into 138 | -- the actual LHS. If no value if returned, all our work is done. 139 | 140 | procedure Build_Field_Store 141 | (LHS : GL_Value; 142 | In_F : Record_Field_Kind_Id; 143 | RHS : GL_Value; 144 | VFA : Boolean := False) 145 | with Pre => Is_Record_Type (LHS) and then Present (RHS); 146 | -- Similar to the function version, but we always update LHS. 147 | 148 | -- If In_N is a nested mix of component and indexed references and one of 149 | -- the component references is to a bitfield, return data describing 150 | -- the final reference. 151 | 152 | function Build_Bitfield_Load 153 | (BRD : Bitfield_Ref_Desc; LHS : GL_Value := No_GL_Value) return GL_Value 154 | with Pre => Is_Normalized (BRD); 155 | -- Generate a load of the data from a description of a bitfield. LHS, 156 | -- if Present, is a possible location for the result. 157 | 158 | procedure Build_Bitfield_Store (RHS : GL_Value; BRD : Bitfield_Ref_Desc) 159 | with Pre => Present (RHS) and then Is_Normalized (BRD) 160 | and then Is_Reference (BRD.LHS); 161 | -- Generate a store of RHS to a description of a bitfield 162 | 163 | function Build_Bitfield_Store 164 | (RHS : GL_Value; BRD : Bitfield_Ref_Desc) return GL_Value 165 | with Pre => Present (RHS) and then Is_Normalized (BRD), 166 | Post => Present (Build_Bitfield_Store'Result) = 167 | not Is_Reference (BRD.LHS); 168 | -- Generate a store of RHS to a description of a bitfield. If BRD.LHS is 169 | -- data, we return the new value of the bitfield field in the record. 170 | 171 | end GNATLLVM.Records.Field_Ref; 172 | -------------------------------------------------------------------------------- /llvm-interface/gnatllvm-conversions.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T - L L V M -- 3 | -- -- 4 | -- Copyright (C) 2013-2025, AdaCore -- 5 | -- -- 6 | -- This is free software; you can redistribute it and/or modify it under -- 7 | -- terms of the GNU General Public License as published by the Free Soft- -- 8 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 9 | -- sion. This software is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 12 | -- License for more details. You should have received a copy of the GNU -- 13 | -- General Public License distributed with this software; see file -- 14 | -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 15 | -- of the license. -- 16 | ------------------------------------------------------------------------------ 17 | 18 | with GNATLLVM.GLType; use GNATLLVM.GLType; 19 | with GNATLLVM.GLValue; use GNATLLVM.GLValue; 20 | with GNATLLVM.MDType; use GNATLLVM.MDType; 21 | 22 | package GNATLLVM.Conversions is 23 | 24 | function Emit_Conversion 25 | (N : N_Subexpr_Id; 26 | GT : GL_Type; 27 | From_N : Opt_N_Subexpr_Id := Empty; 28 | For_LHS : Boolean := False; 29 | Is_Unchecked : Boolean := False; 30 | Need_Overflow_Check : Boolean := False; 31 | Float_Truncate : Boolean := False; 32 | No_Truncation : Boolean := False) return GL_Value 33 | with Pre => Present (GT) 34 | and then not (Is_Unchecked and Need_Overflow_Check), 35 | Post => Present (Emit_Conversion'Result); 36 | -- Emit code to convert N to GT, optionally in unchecked mode 37 | -- and optionally with an overflow check. From_N is the conversion node, 38 | -- if there is a corresponding source node. 39 | 40 | function Emit_Convert_Value 41 | (N : N_Subexpr_Id; GT : GL_Type) return GL_Value 42 | is 43 | (Get (Emit_Conversion (N, GT), Object)) 44 | with Pre => Present (GT), Post => Present (Emit_Convert_Value'Result); 45 | -- Emit code to convert N to GT and get it as a value 46 | 47 | function Convert 48 | (V : GL_Value; 49 | GT : GL_Type; 50 | Float_Truncate : Boolean := False; 51 | Is_Unchecked : Boolean := False; 52 | No_Truncation : Boolean := False) return GL_Value 53 | with Pre => Is_Data (V) and then Present (GT) 54 | and then Is_Elementary_Type (V), 55 | Post => Is_Data (Convert'Result) 56 | and then Is_Elementary_Type (Convert'Result); 57 | -- Convert V to the type GT, with both the types of V and GT being 58 | -- elementary. Flags are as for Emit_Conversion. 59 | 60 | function Convert 61 | (V, T : GL_Value; 62 | Float_Truncate : Boolean := False; 63 | Is_Unchecked : Boolean := False) return GL_Value is 64 | (Convert (V, Related_Type (T), Float_Truncate, Is_Unchecked)) 65 | with Pre => Is_Data (V) and then Is_Elementary_Type (V) 66 | and then Is_Elementary_Type (T), 67 | Post => Is_Data (Convert'Result) 68 | and then Is_Elementary_Type (Convert'Result); 69 | -- Variant of above where the type is that of another value (T) 70 | 71 | function Convert_Ref (V : GL_Value; GT : GL_Type) return GL_Value 72 | with Pre => Is_Reference (V) and then Present (GT), 73 | Post => Is_Reference (Convert_Ref'Result); 74 | -- Convert V, which should be a reference, into a reference to GT 75 | 76 | function Convert_Ref 77 | (V : GL_Value; T : GL_Value) return GL_Value is 78 | (Convert_Ref (V, Related_Type (T))) 79 | with Pre => Present (V) and then Present (T), 80 | Post => Is_Access_Type (Convert_Ref'Result); 81 | -- Likewise, but get type from V 82 | 83 | function Convert_To_Access 84 | (V : GL_Value; 85 | GT : GL_Type; 86 | Is_Unchecked : Boolean := False) return GL_Value 87 | with Pre => Present (V) and then Present (GT), 88 | Post => Is_Access_Type (Convert_To_Access'Result); 89 | -- Convert Src, which should be an access or reference, into an access 90 | -- type GT 91 | 92 | function Convert_To_Access 93 | (V : GL_Value; T : GL_Value) return GL_Value is 94 | (Convert_To_Access (V, Related_Type (T))) 95 | with Pre => Present (V) and then Present (T), 96 | Post => Is_Access_Type (Convert_To_Access'Result); 97 | -- Likewise, but get type from V 98 | 99 | function Convert_GT (V : GL_Value; GT : GL_Type) return GL_Value 100 | with Pre => Present (V) and then Present (GT), 101 | Post => Present (Convert_GT'Result); 102 | -- Convert V to GT. ??? We have a mess here because the front end 103 | -- often treats different types as if they're identical, but we, 104 | -- unfortunately, sometimes must keep the original type. This means that 105 | -- we may sometimes do nothing even though we actually have to convert 106 | -- due to a GT difference of the types. Nothing we can do about it 107 | -- for now. 108 | 109 | function Maybe_Convert_GT (V : GL_Value; GT : GL_Type) return GL_Value is 110 | (if Full_Etype (Related_Type (V)) = Full_Etype (GT) then V 111 | else Convert_GT (V, GT)) 112 | with Pre => Present (V) and then Present (GT), 113 | Post => Present (Maybe_Convert_GT'Result); 114 | -- Likewise, but only do so if V and GT have different GNAT types 115 | 116 | function Convert_Pointer (V : GL_Value; GT : GL_Type) return GL_Value 117 | with Pre => Is_Pointer (V) and then Present (GT), 118 | Post => Is_Pointer (Convert_Pointer'Result); 119 | -- V is a reference to some object. Convert it to a reference to GT 120 | -- with the same relationship. 121 | 122 | function Is_Nonsymbolic_Constant 123 | (V : Value_T; MDT : MD_Type) return Boolean 124 | with Pre => Present (V) and then Present (MDT); 125 | 126 | function Convert_Aggregate_Constant 127 | (V : GL_Value; GT : GL_Type) return GL_Value 128 | with Pre => Present (V) and then not Is_Nonnative_Type (GT) 129 | and then Is_Constant (V), 130 | Post => Related_Type (Convert_Aggregate_Constant'Result) = GT 131 | and then Is_Constant (Convert_Aggregate_Constant'Result); 132 | -- Convert V, a constant, to GT 133 | 134 | function Convert_Aggregate_Constant 135 | (V : Value_T; T : Type_T) return Value_T 136 | with Pre => Present (V) and then Present (T) and then Is_Constant (V), 137 | Post => Type_Of (Convert_Aggregate_Constant'Result) = T 138 | and then Is_Constant (Convert_Aggregate_Constant'Result); 139 | -- Likewise for native LLVM objects 140 | 141 | function Can_Convert_Aggregate_Constant 142 | (V : GL_Value; GT : GL_Type) return Boolean 143 | with Pre => Present (V) and then Present (GT); 144 | -- Return True iff Convert_Aggregate_Constant can convert V to GT 145 | 146 | function Strip_Complex_Conversions 147 | (N : Opt_N_Subexpr_Id) return Opt_N_Subexpr_Id; 148 | -- Remove any conversion from N, if Present, if they are record or array 149 | -- conversions that increase the complexity of the size of the 150 | -- type because the caller will be doing any needed conversions. 151 | 152 | function Strip_Conversions (N : Opt_N_Subexpr_Id) return Opt_N_Subexpr_Id; 153 | -- Likewise, but remove all conversions 154 | 155 | function Is_Unsigned_For_Convert (GT : GL_Type) return Boolean 156 | with Pre => Present (GT); 157 | -- True if we are to treate GT as unsigned for the purpose of a 158 | -- conversion. 159 | 160 | function Is_Unsigned_For_RM (GT : GL_Type) return Boolean 161 | with Pre => Present (GT); 162 | -- Return true if GT has an unsigned representation. This needs to be 163 | -- used when the representation of types whose precision is not equal 164 | -- to their size is manipulated based on the RM size. 165 | 166 | function Is_Parent_Of (T_Need, T_Have : Record_Kind_Id) return Boolean; 167 | -- True if T_Have is a parent type of T_Need 168 | 169 | end GNATLLVM.Conversions; 170 | --------------------------------------------------------------------------------