diff --git a/.gitignore b/.gitignore index 3cf675dcf..b7f4e6c17 100644 --- a/.gitignore +++ b/.gitignore @@ -115,4 +115,4 @@ CMakeSettings.json .ccls-cache/* # ignore config -config.txt \ No newline at end of file +config.txt diff --git a/CMakeLists.txt b/CMakeLists.txt index ef81ee85c..980b2dc11 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,8 +1,9 @@ -cmake_minimum_required(VERSION 3.1) # we use target_sources() +cmake_minimum_required(VERSION 3.19) # we use target_sources() project(Extempore VERSION 0.8.9) -# for backwards compatibility with CMake older than 3.19 -cmake_policy(SET CMP0114 OLD) +if(POLICY CMP0135) + cmake_policy(SET CMP0135 NEW) +endif() option(ASSETS "download multimedia assets (approx 500MB)" OFF) option(BUILD_TESTS "build test targets (including examples)" ON) @@ -39,9 +40,20 @@ endif() # packaging (binary distribution) +# ARM64 requires macOS 11.0 (Big Sur) minimum +if(APPLE) + if(NOT DEFINED CMAKE_OSX_DEPLOYMENT_TARGET) + if(CMAKE_SYSTEM_PROCESSOR MATCHES "arm64" OR CMAKE_HOST_SYSTEM_PROCESSOR MATCHES "arm64") + set(CMAKE_OSX_DEPLOYMENT_TARGET 11.0) + endif() + endif() +endif() + if(PACKAGE) - # this needs to be set before project() is called - set(CMAKE_OSX_DEPLOYMENT_TARGET 10.12) + # For packaged binaries on Intel, enforce a 10.12 floor if still unset + if(NOT DEFINED CMAKE_OSX_DEPLOYMENT_TARGET) + set(CMAKE_OSX_DEPLOYMENT_TARGET 10.12) + endif() set(ASSETS ON) # necessary for packaging message(STATUS "Building Extempore for binary distribution (assets directory will be downloaded)") endif() @@ -66,8 +78,15 @@ if(EXTERNAL_SHLIBS) set(EXT_DEPS_INSTALL_DIR ${CMAKE_BINARY_DIR}/deps-install) set(EXT_PLATFORM_SHLIBS_DIR ${CMAKE_SOURCE_DIR}/libs/platform-shlibs) if(PACKAGE) + # Use generic tuning for x86_64 packages, but native tuning for ARM64 + if(CMAKE_SYSTEM_PROCESSOR MATCHES "arm64|aarch64|ARM64") + set(EXT_DEPS_C_FLAGS "${CMAKE_C_FLAGS_RELEASE}") + set(EXT_DEPS_CXX_FLAGS "${CMAKE_CXX_FLAGS_RELEASE}") + message(STATUS "ARM64 detected: using native CPU tuning") + else() set(EXT_DEPS_C_FLAGS "${CMAKE_C_FLAGS_RELEASE} -mtune=generic") set(EXT_DEPS_CXX_FLAGS "${CMAKE_CXX_FLAGS_RELEASE} -mtune=generic") + endif() message(STATUS "compiler flags for packaging:\nC ${EXT_DEPS_C_FLAGS}\nCXX ${EXT_DEPS_CXX_FLAGS}") endif() endif() @@ -119,7 +138,7 @@ if(APPLE) execute_process(COMMAND sw_vers -productVersion OUTPUT_VARIABLE EXTEMPORE_SYSTEM_VERSION OUTPUT_STRIP_TRAILING_WHITESPACE) - string(REGEX MATCH "^10.[0-9]+" EXTEMPORE_SYSTEM_VERSION ${EXTEMPORE_SYSTEM_VERSION}) + string(REGEX MATCH "^[0-9]+\\.?[0-9]*" EXTEMPORE_SYSTEM_VERSION ${EXTEMPORE_SYSTEM_VERSION}) set(EXTEMPORE_SYSTEM_ARCHITECTURE ${UNAME_MACHINE_NAME}) elseif(UNIX) # try lsb_release first - better at giving the distro name @@ -171,8 +190,10 @@ target_compile_definitions(pcre ) if(PACKAGE) + if(NOT CMAKE_SYSTEM_PROCESSOR MATCHES "arm64|aarch64|ARM64") target_compile_options(pcre PRIVATE -mtune=generic) + endif() endif() ############# @@ -195,67 +216,90 @@ ExternalProject_Add(portaudio_static -DCMAKE_CXX_FLAGS=${EXT_DEPS_CXX_FLAGS} -DCMAKE_INSTALL_PREFIX=${CMAKE_BINARY_DIR}/portaudio) -############## -# LLVM 3.8.0 # -############## +############### +# LLVM 21.1.7 # +############### # if you need to build LLVM by hand, the command will be something like -# cmake .. -DLLVM_TARGETS_TO_BUILD=X86 -DCMAKE_BUILD_TYPE=Release -DLLVM_ENABLE_TERMINFO=OFF -DLLVM_ENABLE_ZLIB=OFF -DCMAKE_INSTALL_PREFIX=c:/Users/ben/Code/extempore/llvm-3.8.0-release +# cmake .. -DLLVM_TARGETS_TO_BUILD=X86 -DCMAKE_BUILD_TYPE=Release -DLLVM_ENABLE_TERMINFO=OFF -DLLVM_ENABLE_ZLIB=OFF -DCMAKE_INSTALL_PREFIX=c:/Users/ben/Code/extempore/llvm-21.1.7-release + +# Detect target architecture for LLVM. +if(APPLE) + if(UNAME_MACHINE_NAME STREQUAL "arm64") + set(LLVM_TARGET_ARCH "AArch64") + set(LLVM_ARCH_PREFIX "AArch64") + else() + set(LLVM_TARGET_ARCH "X86") + set(LLVM_ARCH_PREFIX "X86") + endif() +elseif(UNIX) + if(CMAKE_SYSTEM_PROCESSOR MATCHES "aarch64|arm64") + set(LLVM_TARGET_ARCH "AArch64") + set(LLVM_ARCH_PREFIX "AArch64") + else() + set(LLVM_TARGET_ARCH "X86") + set(LLVM_ARCH_PREFIX "X86") + endif() +else() + # Only x86_64 currently supported for Windows. + set(LLVM_TARGET_ARCH "X86") + set(LLVM_ARCH_PREFIX "X86") +endif() + +message(STATUS "LLVM target architecture: ${LLVM_TARGET_ARCH}") + +set(CMAKE_CXX_STANDARD 17) +set(CMAKE_CXX_STANDARD_REQUIRED ON) if(NOT BUILD_LLVM) add_custom_target(LLVM) else() include(ExternalProject) - if(PACKAGE) ExternalProject_Add(LLVM PREFIX llvm - URL https://github.com/digego/extempore/releases/download/v0.8.9/llvm-3.8.0.src-patched-for-extempore.tar.xz - URL_MD5 600ee9a94d2e104f53be739568f3508e + URL https://github.com/llvm/llvm-project/releases/download/llvmorg-21.1.7/llvm-project-21.1.7.src.tar.xz + SOURCE_SUBDIR llvm CMAKE_ARGS - -DLLVM_TARGETS_TO_BUILD=X86 + -DLLVM_TARGETS_TO_BUILD=${LLVM_TARGET_ARCH} -DCMAKE_BUILD_TYPE=${CMAKE_BUILD_TYPE} -DLLVM_ENABLE_TERMINFO=OFF -DLLVM_ENABLE_ZLIB=OFF + -DLLVM_ENABLE_ZSTD=OFF + -DLLVM_ENABLE_LIBXML2=OFF -DLLVM_INCLUDE_TOOLS=ON -DLLVM_BUILD_TOOLS=ON -DLLVM_INCLUDE_UTILS=OFF -DLLVM_BUILD_RUNTIME=OFF -DLLVM_INCLUDE_EXAMPLES=OFF -DLLVM_INCLUDE_TESTS=OFF - -DLLVM_INCLUDE_GO_TESTS=OFF - -DLLVM_INCLUDE_GO_TESTS=OFF + -DLLVM_INCLUDE_BENCHMARKS=OFF -DLLVM_INCLUDE_DOCS=OFF + -DLLVM_ENABLE_BINDINGS=OFF + -DLLVM_ENABLE_OCAMLDOC=OFF -DCMAKE_C_FLAGS=${EXT_DEPS_C_FLAGS} -DCMAKE_CXX_FLAGS=${EXT_DEPS_CXX_FLAGS} -DCMAKE_INSTALL_PREFIX=${EXT_LLVM_DIR}) - else() - ExternalProject_Add(LLVM - PREFIX llvm - URL https://github.com/digego/extempore/releases/download/v0.8.9/llvm-3.8.0.src-patched-for-extempore.tar.xz - URL_MD5 600ee9a94d2e104f53be739568f3508e - CMAKE_ARGS - -DLLVM_TARGETS_TO_BUILD=X86 - -DCMAKE_BUILD_TYPE=${CMAKE_BUILD_TYPE} - -DLLVM_ENABLE_TERMINFO=OFF - -DLLVM_ENABLE_ZLIB=OFF - -DLLVM_INCLUDE_TOOLS=ON - -DLLVM_BUILD_TOOLS=ON - -DLLVM_INCLUDE_UTILS=OFF - -DLLVM_BUILD_RUNTIME=OFF - -DLLVM_INCLUDE_EXAMPLES=OFF - -DLLVM_INCLUDE_TESTS=OFF - -DLLVM_INCLUDE_GO_TESTS=OFF - -DLLVM_INCLUDE_GO_TESTS=OFF - -DLLVM_INCLUDE_DOCS=OFF - -DCMAKE_INSTALL_PREFIX=${EXT_LLVM_DIR}) - endif() ExternalProject_Add_StepTargets(LLVM install) endif() -# the ordering of these libs matters, especially with the gcc linker. -# Check the output of "llvm-config --libnames" to be sure -set(EXT_LLVM_LIBRARIES "LLVMLTO;LLVMObjCARCOpts;LLVMSymbolize;LLVMDebugInfoPDB;LLVMDebugInfoDWARF;LLVMMIRParser;LLVMLibDriver;LLVMOption;LLVMTableGen;LLVMOrcJIT;LLVMPasses;LLVMipo;LLVMVectorize;LLVMLinker;LLVMIRReader;LLVMAsmParser;LLVMX86Disassembler;LLVMX86AsmParser;LLVMX86CodeGen;LLVMSelectionDAG;LLVMAsmPrinter;LLVMX86Desc;LLVMMCDisassembler;LLVMX86Info;LLVMX86AsmPrinter;LLVMX86Utils;LLVMMCJIT;LLVMLineEditor;LLVMDebugInfoCodeView;LLVMInterpreter;LLVMExecutionEngine;LLVMRuntimeDyld;LLVMCodeGen;LLVMTarget;LLVMScalarOpts;LLVMInstCombine;LLVMInstrumentation;LLVMProfileData;LLVMObject;LLVMMCParser;LLVMTransformUtils;LLVMMC;LLVMBitWriter;LLVMBitReader;LLVMAnalysis;LLVMCore;LLVMSupport") +# Architecture-independent libraries (order matters for linker!) +set(EXT_LLVM_LIBRARIES_COMMON + "LLVMWindowsManifest;LLVMXRay;LLVMLibDriver;LLVMDlltoolDriver;LLVMTextAPIBinaryReader;LLVMCoverage;LLVMLineEditor;LLVMSandboxIR;LLVMOrcDebugging;LLVMOrcJIT;LLVMWindowsDriver;LLVMMCJIT;LLVMJITLink;LLVMInterpreter;LLVMExecutionEngine;LLVMRuntimeDyld;LLVMOrcTargetProcess;LLVMOrcShared;LLVMDWP;LLVMDebugInfoLogicalView;LLVMDebugInfoGSYM;LLVMOption;LLVMObjectYAML;LLVMObjCopy;LLVMMCA;LLVMMCDisassembler;LLVMLTO;LLVMCFGuard;LLVMCFIVerify;LLVMFrontendOpenACC;LLVMFrontendHLSL;LLVMFrontendDriver;LLVMFrontendDirective;LLVMExtensions;LLVMPasses;LLVMHipStdPar;LLVMCoroutines;LLVMipo;LLVMInstrumentation;LLVMVectorize;LLVMLinker;LLVMFrontendOpenMP;LLVMFrontendOffloading;LLVMDWARFLinkerParallel;LLVMDWARFLinkerClassic;LLVMDWARFLinker;LLVMDWARFCFIChecker;LLVMGlobalISel;LLVMMIRParser;LLVMAsmPrinter;LLVMSelectionDAG;LLVMCodeGen;LLVMCGData;LLVMTarget;LLVMObjCARCOpts;LLVMCodeGenTypes;LLVMIRPrinter;LLVMInterfaceStub;LLVMFileCheck;LLVMFuzzMutate;LLVMFuzzerCLI;LLVMScalarOpts;LLVMInstCombine;LLVMAggressiveInstCombine;LLVMTransformUtils;LLVMBitWriter;LLVMAnalysis;LLVMProfileData;LLVMDebuginfod;LLVMSymbolize;LLVMDebugInfoBTF;LLVMDebugInfoPDB;LLVMDebugInfoMSF;LLVMDebugInfoDWARF;LLVMDebugInfoDWARFLowLevel;LLVMObject;LLVMTextAPI;LLVMMCParser;LLVMIRReader;LLVMAsmParser;LLVMMC;LLVMDebugInfoCodeView;LLVMBitReader;LLVMFrontendAtomic;LLVMCore;LLVMRemarks;LLVMBitstreamReader;LLVMBinaryFormat;LLVMTargetParser;LLVMTableGen;LLVMTableGenBasic;LLVMTableGenCommon;LLVMTelemetry;LLVMSupport;LLVMDemangle") + +# Architecture-specific libraries +set(EXT_LLVM_LIBRARIES_X86 "LLVMX86Disassembler;LLVMX86AsmParser;LLVMX86CodeGen;LLVMX86Desc;LLVMX86Info") +set(EXT_LLVM_LIBRARIES_AARCH64 "LLVMAArch64Disassembler;LLVMAArch64AsmParser;LLVMAArch64CodeGen;LLVMAArch64Desc;LLVMAArch64Info;LLVMAArch64Utils") + +# Select the appropriate libraries. +if(LLVM_TARGET_ARCH STREQUAL "AArch64") + set(EXT_LLVM_LIBRARIES_ARCH ${EXT_LLVM_LIBRARIES_AARCH64}) +else() + set(EXT_LLVM_LIBRARIES_ARCH ${EXT_LLVM_LIBRARIES_X86}) +endif() + +# Combine into final list (arch-specific libs need to come before common libs for linker) +set(EXT_LLVM_LIBRARIES "${EXT_LLVM_LIBRARIES_ARCH};${EXT_LLVM_LIBRARIES_COMMON}") foreach(llvm_lib ${EXT_LLVM_LIBRARIES}) get_filename_component(LLVM_LIB_FULLPATH "${EXT_LLVM_DIR}/lib/${CMAKE_STATIC_LIBRARY_PREFIX}${llvm_lib}${CMAKE_STATIC_LIBRARY_SUFFIX}" ABSOLUTE) list(APPEND LLVM_LIBRARIES ${LLVM_LIB_FULLPATH}) @@ -281,7 +325,7 @@ if (EXT_DYLIB) runtime/scheme.xtm ) - add_library(extempore SHARED + add_library(extempore SHARED src/Extempore.cpp src/AudioDevice.cpp src/EXTZones.cpp @@ -289,6 +333,7 @@ if (EXT_DYLIB) src/EXTLLVM.cpp src/EXTThread.cpp src/Extempore.cpp + src/shims/__hash_memory.cpp src/OSC.cpp src/Scheme.cpp src/SchemeFFI.cpp @@ -306,6 +351,7 @@ else() src/EXTLLVM.cpp src/EXTThread.cpp src/Extempore.cpp + src/shims/__hash_memory.cpp src/OSC.cpp src/Scheme.cpp src/SchemeFFI.cpp @@ -361,14 +407,16 @@ endif() if(PACKAGE) target_compile_definitions(extempore PRIVATE -DEXT_SHARE_DIR=".") + if(NOT CMAKE_SYSTEM_PROCESSOR MATCHES "arm64|aarch64|ARM64") target_compile_options(extempore PRIVATE -mtune=generic) + endif() elseif(EXT_SHARE_DIR) target_compile_definitions(extempore PRIVATE -DEXT_SHARE_DIR="${EXT_SHARE_DIR}") elseif(EXT_DYLIB) target_compile_definitions(extempore - PRIVATE -DEXT_DYLIB=1 + PRIVATE -DEXT_DYLIB=1 PRIVATE -DEXT_SHARE_DIR="." ) else() @@ -385,7 +433,7 @@ if(UNIX) PRIVATE -D__STDC_FORMAT_MACROS PRIVATE -D__STDC_LIMIT_MACROS) target_compile_options(extempore - PRIVATE -std=c++11 + PRIVATE -std=c++17 PRIVATE -fvisibility-inlines-hidden # PRIVATE -fno-exceptions PRIVATE -fno-rtti @@ -399,13 +447,7 @@ endif() if(WIN32) target_compile_definitions(extempore PRIVATE -DPCRE_STATIC - PRIVATE -D_CRT_SECURE_NO_WARNINGS - # NOTE: this next define is necessary because VS2019 deprecated the std::tr2 - # namespace, but setting CXX_STANDARD to c++17 (required for "normal" - # std::filesystem) breaks a bunch of LLVM 3.8. So, when we finally upgrade - # LLVM, we should switch to std::filesystem, but for now let's just hold our - # nose and do this. - PRIVATE -D_SILENCE_EXPERIMENTAL_FILESYSTEM_DEPRECATION_WARNING) + PRIVATE -D_CRT_SECURE_NO_WARNINGS) set_source_files_properties( PROPERTIES COMPILE_FLAGS "/EHsc") @@ -535,6 +577,8 @@ else(WIN32) if(NOT ${group} STREQUAL "core") add_dependencies(${targetname} external_shlibs_${group}) add_dependencies(aot_external_${group} ${targetname}) + else() + add_dependencies(aot_core ${targetname}) endif() foreach(dep ${ARGN}) add_dependencies(${targetname} aot_${dep}) diff --git a/include/EXTClosureAddressTable.h b/include/EXTClosureAddressTable.h index 662193e10..27aa9d52b 100644 --- a/include/EXTClosureAddressTable.h +++ b/include/EXTClosureAddressTable.h @@ -4,6 +4,8 @@ #include +struct llvm_zone_t; + namespace extemp { namespace ClosureAddressTable { /////////////////////////////////////////////////////////////////////// @@ -19,6 +21,7 @@ namespace ClosureAddressTable { }; EXPORT closure_address_table* get_address_table(const char *name, extemp::ClosureAddressTable::closure_address_table *table); + EXPORT closure_address_table* add_address_table(llvm_zone_t* zone, char* name, uint32_t offset, char* type, int alloctype, closure_address_table* table); EXPORT uint32_t get_address_offset(uint64_t id, closure_address_table* table); EXPORT bool check_address_exists(uint64_t id, closure_address_table* table); diff --git a/include/EXTLLVM.h b/include/EXTLLVM.h index 2cc2736cb..3c66484aa 100644 --- a/include/EXTLLVM.h +++ b/include/EXTLLVM.h @@ -45,6 +45,9 @@ #include #include +#include "llvm/ExecutionEngine/Orc/ThreadSafeModule.h" +#include "llvm/Support/Error.h" + struct _llvm_callback_struct_ { void(*fptr)(void*,llvm_zone_t*); @@ -94,15 +97,11 @@ class GlobalVariable; class GlobalValue; class Function; class StructType; -class ModuleProvider; -class SectionMemoryManager; -class ExecutionEngine; - -namespace legacy -{ - -class PassManager; +class LLVMContext; +namespace orc { +class LLJIT; +class ThreadSafeContext; } } // end llvm namespace @@ -113,16 +112,23 @@ namespace extemp namespace EXTLLVM { -uint64_t getSymbolAddress(const std::string&); +uint64_t getFunctionAddress(const std::string&); void addModule(llvm::Module* m); -extern llvm::ExecutionEngine* EE; // TODO: nobody should need this (?) -extern llvm::Module* M; +extern std::unique_ptr JIT; + +extern std::unique_ptr TSC; + +llvm::orc::ThreadSafeContext& getThreadSafeContext(); +bool removeSymbol(const std::string& name); +void removeFromGlobalMap(const std::string& name); + +llvm::Error addTrackedModule(llvm::orc::ThreadSafeModule TSM, const std::vector& symbolNames); + extern int64_t LLVM_COUNT; extern bool OPTIMIZE_COMPILES; extern bool VERIFY_COMPILES; -extern llvm::legacy::PassManager* PM; -extern llvm::legacy::PassManager* PM_NO; +extern int OPTIMIZATION_LEVEL; // 0=O0, 1=O1, 2=O2, 3=O3 extern std::vector Ms; void initLLVM(); diff --git a/include/EXTZones.h b/include/EXTZones.h index ae262f896..563a8fa12 100644 --- a/include/EXTZones.h +++ b/include/EXTZones.h @@ -41,11 +41,21 @@ namespace EXTZones { EXPORT void llvm_zone_destroy(llvm_zone_t* Zone); llvm_zone_t* llvm_zone_reset(llvm_zone_t* Zone); EXPORT void* llvm_zone_malloc(llvm_zone_t* zone, uint64_t size); + EXPORT void* llvm_zone_malloc_from_current_zone(uint64_t size); + EXPORT void llvm_zone_print(llvm_zone_t* zone); + EXPORT uint64_t llvm_zone_ptr_size(void* ptr); + EXPORT bool llvm_zone_copy_ptr(void* ptr1, void* ptr2); + EXPORT bool llvm_ptr_in_zone(llvm_zone_t* zone, void* ptr); + EXPORT bool llvm_ptr_in_current_zone(void* ptr); llvm_zone_stack* llvm_threads_get_zone_stack(); void llvm_threads_set_zone_stack(llvm_zone_stack* Stack); void llvm_push_zone_stack(llvm_zone_t* Zone); llvm_zone_t* llvm_peek_zone_stack(); EXPORT llvm_zone_t* llvm_pop_zone_stack(); + EXPORT llvm_zone_t* llvm_peek_zone_stack_extern(); + EXPORT void llvm_push_zone_stack_extern(llvm_zone_t* Zone); + EXPORT llvm_zone_t* llvm_zone_create_extern(uint64_t Size); + EXPORT llvm_zone_t* llvm_zone_callback_setup(); void llvm_threads_inc_zone_stacksize(); void llvm_threads_dec_zone_stacksize(); uint64_t llvm_threads_get_zone_stacksize(); diff --git a/include/UNIV.h b/include/UNIV.h index 1cfebd11f..985409d73 100644 --- a/include/UNIV.h +++ b/include/UNIV.h @@ -187,7 +187,7 @@ inline void ascii_text_color(bool Bold, unsigned Foreground, unsigned Background } #ifdef _WIN32 extern int WINDOWS_COLORS[]; - extern int WINDOWS_BGCOLORS[]; + extern int WINDOWS_BGCOLORS[]; if (unlikely(extemp::UNIV::EXT_TERM == 1)) { Foreground = (Foreground > 7) ? 7 : Foreground; Background = (Background > 7) ? 0 : Background; diff --git a/libs/base/base.xtm b/libs/base/base.xtm index 6c4b404f7..f16af9099 100644 --- a/libs/base/base.xtm +++ b/libs/base/base.xtm @@ -346,20 +346,30 @@ (if (null? type) (if (and (impc:ti:polyfunc-exists? closure-name) (= (length (impc:ti:get-polyfunc-candidate-types closure-name)) 1)) - (let* ((t (impc:ir:pretty-print-type (car (impc:ti:get-polyfunc-candidate-types closure-name)))) - (bt (impc:ir:get-base-type t)) - (fullname (string-append closure-name - "_adhoc_" - (cname-encode bt) - "_native"))) - fullname) - (impc:compiler:print-compiler-error "Try forcing a type? Ambiguous call to get_native_fptr" (string->symbol closure-name))) - (let* ((bt (impc:ir:get-base-type (symbol->string (car type)))) - (fullname (string-append closure-name - "_adhoc_" - (cname-encode bt) - "_native"))) - fullname))))) + ;; It's a polyfunc, so look up actual name from adhoc-name-cache. + (let* ((target-type (car (impc:ti:get-polyfunc-candidate-types closure-name))) + (cache-key (cons closure-name target-type)) + (cached (assoc cache-key *impc:ti:adhoc-name-cache*))) + (if cached + (string-append (cdr cached) "_native") + ;; Cache miss, so construct the traditional name for AOT-loaded functions. + (let* ((t (impc:ir:pretty-print-type target-type)) + (bt (impc:ir:get-base-type t))) + (string-append closure-name "_adhoc_" (cname-encode bt) "_native")))) + ;; Not a polyfunc, so must be a regular closure, just append _native. + (if (impc:ti:closure-exists? closure-name) + (string-append closure-name "_native") + (impc:compiler:print-compiler-error "Try forcing a type? Ambiguous call to get_native_fptr" (string->symbol closure-name)))) + ;; When type is provided, look up the cached name. + (let* ((target-type (impc:ir:get-type-from-pretty-str (symbol->string (car type)))) + (cache-key (cons closure-name target-type)) + (cached (assoc cache-key *impc:ti:adhoc-name-cache*))) + (if cached + (string-append (cdr cached) "_native") + ;; Cache miss, so construct the traditional name for AOT-loaded functions. + (let* ((t (impc:ir:pretty-print-type target-type)) + (bt (impc:ir:get-base-type t))) + (string-append closure-name "_adhoc_" (cname-encode bt) "_native")))))))) ;; the same functionality, but for use in xtlang code (bind-macro @@ -528,7 +538,7 @@ Second item in tuple is a char* c-style string ") ;; easy String dataconstructors from c strings ;; zone alloc'ed versions - + (bind-func String "Create an xtlang String type from a c string (char array) @@ -550,18 +560,18 @@ Allocation size will be (+ (strlen cstr) 1) (lambda (cstr:i8*) (String cstr))) -;; strings need dedicated zcopy +;; strings need dedicated zcopy ;; so need to override default (bind-func zcopy:[String*,String*,mzone*,mzone*]* (lambda (x fromz toz) (if (llvm_ptr_in_zone fromz (cast x i8*)) (begin (push_zone toz) (let ((obj (zalloc))) - (begin + (begin (tset! obj 0 (tref x 0))) - (if (llvm_ptr_in_zone fromz (cast (tref x 1) i8*)) + (if (llvm_ptr_in_zone fromz (cast (tref x 1) i8*)) (let ((newptr:i8* (zalloc (+ 1 (tref x 0))))) - (strcpy newptr (cast (tref x 1) i8*)) ; (+ (tref x 0) 1)) + (strcpy newptr (cast (tref x 1) i8*)) ; (+ (tref x 0) 1)) (tset! obj 1 newptr)) (tset! obj 1 (tref x 1))) (pop_zone) @@ -581,7 +591,7 @@ Allocation size will be (+ (strlen cstr) 1) (lambda (x) (free (tref x 1)) (free x) - void)) + void)) (bind-func String_h "Create an xtlang String type from a c string (char array) @@ -1157,18 +1167,18 @@ Use via the polymorphic Str function (new_str (Symbol_z len (cstring str)))) new_str))) -;; symbols need dedicated zcopy +;; symbols need dedicated zcopy ;; so need to override default (bind-func zcopy:[Symbol*,Symbol*,mzone*,mzone*]* (lambda (x fromz toz) (if (llvm_ptr_in_zone fromz (cast x i8*)) (begin (push_zone toz) (let ((obj (zalloc))) - (begin + (begin (tset! obj 0 (tref x 0))) - (if (llvm_ptr_in_zone fromz (cast (tref x 1) i8*)) + (if (llvm_ptr_in_zone fromz (cast (tref x 1) i8*)) (let ((newptr:i8* (zalloc (+ 1 (tref x 0))))) - (strcpy newptr (cast (tref x 1) i8*)) ; (+ (tref x 0) 1)) + (strcpy newptr (cast (tref x 1) i8*)) ; (+ (tref x 0) 1)) (tset! obj 1 newptr)) (tset! obj 1 (tref x 1))) (pop_zone) @@ -1188,7 +1198,7 @@ Use via the polymorphic Str function (lambda (x) (free (tref x 1)) (free x) - void)) + void)) (bind-func equal "Equality test for Symbol diff --git a/libs/core/xthread.xtm b/libs/core/xthread.xtm index 981be03c7..8dc35b07c 100644 --- a/libs/core/xthread.xtm +++ b/libs/core/xthread.xtm @@ -25,7 +25,9 @@ (let ((t:<[void]*,mzone*>* (cast arg)) (f (tref t 0)) (z (tref t 1))) + (push_zone z) (f) + (pop_zone) (llvm_zone_destroy z) (cast null i8*)))) diff --git a/libs/external/glfw3.xtm b/libs/external/glfw3.xtm index e5955729f..b36abddbd 100644 --- a/libs/external/glfw3.xtm +++ b/libs/external/glfw3.xtm @@ -318,7 +318,7 @@ @param minor - index 1 @param rev - index 2") (bind-lib libglfw glfwGetVersionString [i8*]*) -(bind-lib libglfw glfwSetErrorCallback [GLFWerrorfun,GLFWerrorfun]* +(bind-lib libglfw glfwSetErrorCallback [i8*,i8*]* "@param cbfun - index 0") (bind-lib libglfw glfwGetMonitors [GLFWmonitor**,i32*]* "@param count - index 0") @@ -333,7 +333,7 @@ @param heightMM - index 2") (bind-lib libglfw glfwGetMonitorName [i8*,GLFWmonitor*]* "@param monitor - index 0") -(bind-lib libglfw glfwSetMonitorCallback [GLFWmonitorfun,GLFWmonitorfun]* +(bind-lib libglfw glfwSetMonitorCallback [i8*,i8*]* "@param cbfun - index 0") (bind-lib libglfw glfwGetVideoModes [GLFWvidmode*,GLFWmonitor*,i32*]* "@param monitor - index 0 @@ -438,25 +438,25 @@ @param pointer - index 1") (bind-lib libglfw glfwGetWindowUserPointer [void,GLFWwindow*]* "@param window - index 0") -(bind-lib libglfw glfwSetWindowPosCallback [GLFWwindowposfun,GLFWwindow*,GLFWwindowposfun]* +(bind-lib libglfw glfwSetWindowPosCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetWindowSizeCallback [GLFWwindowsizefun,GLFWwindow*,GLFWwindowsizefun]* +(bind-lib libglfw glfwSetWindowSizeCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetWindowCloseCallback [GLFWwindowclosefun,GLFWwindow*,GLFWwindowclosefun]* +(bind-lib libglfw glfwSetWindowCloseCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetWindowRefreshCallback [GLFWwindowrefreshfun,GLFWwindow*,GLFWwindowrefreshfun]* +(bind-lib libglfw glfwSetWindowRefreshCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetWindowFocusCallback [GLFWwindowfocusfun,GLFWwindow*,GLFWwindowfocusfun]* +(bind-lib libglfw glfwSetWindowFocusCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetWindowIconifyCallback [GLFWwindowiconifyfun,GLFWwindow*,GLFWwindowiconifyfun]* +(bind-lib libglfw glfwSetWindowIconifyCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetFramebufferSizeCallback [GLFWframebuffersizefun,GLFWwindow*,GLFWframebuffersizefun]* +(bind-lib libglfw glfwSetFramebufferSizeCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") (bind-lib libglfw glfwPollEvents [void]*) @@ -499,28 +499,28 @@ (bind-lib libglfw glfwSetCursor [void,GLFWwindow*,GLFWcursor*]* "@param window - index 0 @param cursor - index 1") -(bind-lib libglfw glfwSetKeyCallback [GLFWkeyfun,GLFWwindow*,GLFWkeyfun]* +(bind-lib libglfw glfwSetKeyCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetCharCallback [GLFWcharfun,GLFWwindow*,GLFWcharfun]* +(bind-lib libglfw glfwSetCharCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetCharModsCallback [GLFWcharmodsfun,GLFWwindow*,GLFWcharmodsfun]* +(bind-lib libglfw glfwSetCharModsCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetMouseButtonCallback [GLFWmousebuttonfun,GLFWwindow*,GLFWmousebuttonfun]* +(bind-lib libglfw glfwSetMouseButtonCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetCursorPosCallback [GLFWcursorposfun,GLFWwindow*,GLFWcursorposfun]* +(bind-lib libglfw glfwSetCursorPosCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetCursorEnterCallback [GLFWcursorenterfun,GLFWwindow*,GLFWcursorenterfun]* +(bind-lib libglfw glfwSetCursorEnterCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetScrollCallback [GLFWscrollfun,GLFWwindow*,GLFWscrollfun]* +(bind-lib libglfw glfwSetScrollCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") -(bind-lib libglfw glfwSetDropCallback [GLFWdropfun,GLFWwindow*,GLFWdropfun]* +(bind-lib libglfw glfwSetDropCallback [i8*,GLFWwindow*,i8*]* "@param window - index 0 @param cbfun - index 1") (bind-lib libglfw glfwJoystickPresent [i32,i32]* @@ -533,7 +533,7 @@ @param count - index 1") (bind-lib libglfw glfwGetJoystickName [i8*,i32]* "@param joy - index 0") -(bind-lib libglfw glfwSetJoystickCallback [GLFWjoystickfun,GLFWjoystickfun]* +(bind-lib libglfw glfwSetJoystickCallback [i8*,i8*]* "@param cbfun - index 0") (bind-lib libglfw glfwSetClipboardString [void,GLFWwindow*,i8*]* "@param window - index 0 @@ -574,7 +574,7 @@ (let ((res (glfwInit))) (if (= res 1) (begin - (glfwSetErrorCallback (convert (get_native_fptr glfw_error_callback))) + (glfwSetErrorCallback (cast (get_native_fptr glfw_error_callback) i8*)) res) res)))) diff --git a/runtime/bitcode.ll b/runtime/bitcode.ll index 769308daa..711ba90f0 100644 --- a/runtime/bitcode.ll +++ b/runtime/bitcode.ll @@ -1,3 +1,153 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; TYPE DEFINITIONS + +; Zone and closure variable table types +%mzone = type {i8*, i64, i64, i64, i8*, %mzone*} +%clsvar = type {i8*, i32, i8*, %clsvar*} + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; EXTERNAL RUNTIME FUNCTION DECLARATIONS + +; Closure address table functions (implemented in C++) +declare %clsvar* @add_address_table(%mzone*, i8*, i32, i8*, i32, %clsvar*) nounwind +declare %clsvar* @get_address_table(i8*, %clsvar*) nounwind +declare i32 @get_address_offset(i64, %clsvar*) nounwind +declare i1 @check_address_type(i64, %clsvar*, i8*) nounwind +declare i1 @check_address_exists(i64, %clsvar*) nounwind + +; Zone memory management functions (implemented in C++) +declare %mzone* @llvm_zone_callback_setup() nounwind +declare %mzone* @llvm_pop_zone_stack() nounwind +declare void @llvm_zone_destroy(%mzone*) nounwind +declare void @llvm_zone_print(%mzone*) nounwind +declare i8* @llvm_zone_malloc(%mzone*, i64) nounwind +declare i8* @llvm_zone_malloc_from_current_zone(i64) nounwind +declare i1 @llvm_ptr_in_zone(%mzone*, i8*) nounwind +declare i1 @llvm_zone_copy_ptr(i8*, i8*) nounwind +declare i64 @llvm_zone_ptr_size(i8*) nounwind +declare i1 @llvm_ptr_in_current_zone(i8*) nounwind +declare void @llvm_destroy_zone_after_delay(%mzone*, i64) + +; Scheme value constructor functions (implemented in C++) +declare i8* @mk_i64(i8*, i64) +declare i8* @mk_i32(i8*, i32) +declare i8* @mk_i16(i8*, i16) +declare i8* @mk_i8(i8*, i8) +declare i8* @mk_i1(i8*, i1) +declare i8* @mk_double(i8*, double) +declare i8* @mk_float(i8*, float) +declare i8* @mk_string(i8*, i8*) +declare i8* @mk_cptr(i8*, i8*) + +; Scheme value accessor functions (implemented in C++) +declare i64 @i64value(i8*) +declare i32 @i32value(i8*) +declare i16 @i16value(i8*) +declare i8 @i8value(i8*) +declare i1 @i1value(i8*) +declare double @r64value(i8*) +declare float @r32value(i8*) +declare i8* @string_value(i8*) +declare i8* @cptr_value(i8*) + +; Encoding/decoding utility functions (implemented in C++) +declare i8* @base64_encode(i8*, i64, i64*) nounwind +declare i8* @base64_decode(i8*, i64, i64*) nounwind +declare i8* @cname_encode(i8*, i64, i64*) nounwind +declare i8* @cname_decode(i8*, i64, i64*) nounwind + +; Standard C library math functions +declare i64 @llabs(i64) nounwind +declare float @sinhf(float) nounwind +declare float @tanf(float) nounwind +declare float @tanhf(float) nounwind + +; Standard C library file I/O functions +declare i32 @remove(i8*) nounwind + +declare i8* @list_ref(i8*, i32, i8*) + +; System functions +declare i8* @sys_sharedir() nounwind +declare i8* @sys_slurp_file(i8*) nounwind + +; Standard C library functions +declare i8* @malloc(i64) nounwind +declare i8* @realloc(i8*, i64) nounwind +declare void @free(i8*) nounwind +declare i8* @memset(i8*, i32, i64) nounwind +declare i8* @memcpy(i8*, i8*, i64) nounwind +declare i32 @memcmp(i8*, i8*, i64) nounwind +declare i32 @putchar(i32) nounwind +declare i64 @strlen(i8*) nounwind +declare i8* @strcpy(i8*, i8*) nounwind +declare i8* @strncpy(i8*, i8*, i64) nounwind +declare i8* @strcat(i8*, i8*) nounwind +declare i8* @strncat(i8*, i8*, i64) nounwind +declare i32 @strcmp(i8*, i8*) nounwind +declare i32 @strncmp(i8*, i8*, i64) nounwind +declare i8* @strchr(i8*, i32) nounwind +declare i8* @strstr(i8*, i8*) nounwind + +; Extempore runtime functions (implemented in C++) +declare i1 @rmatch(i8*, i8*) nounwind +declare i64 @rmatches(i8*, i8*, i8**, i64) nounwind +declare i8** @rsplit(i8*, i8*, i8**, i64) nounwind +declare i8* @rreplace(i8*, i8*, i8*) nounwind + +; Random number generators (implemented in C++) +declare double @imp_randd() nounwind +declare float @imp_randf() nounwind +declare i64 @imp_rand1_i64(i64) nounwind +declare i64 @imp_rand2_i64(i64, i64) nounwind +declare i32 @imp_rand1_i32(i32) nounwind +declare i32 @imp_rand2_i32(i32, i32) nounwind +declare double @imp_rand1_d(double) nounwind +declare double @imp_rand2_d(double, double) nounwind +declare float @imp_rand1_f(float) nounwind +declare float @imp_rand2_f(float, float) nounwind + +; Standard math library functions +declare double @atan2(double, double) nounwind +declare float @atan2f(float, float) nounwind + +; Additional Extempore runtime functions (implemented in C++) +; Note: Many zone/inline functions are defined in inline.ll or later in this file +declare i8* @llvm_get_function_ptr(i8*) nounwind +declare void @llvm_runtime_error(i64, i8*) nounwind +declare void @llvm_print_pointer(i8*) nounwind +declare void @llvm_print_i32(i32) nounwind +declare void @llvm_print_i64(i64) nounwind +declare void @llvm_print_f32(float) nounwind +declare void @llvm_print_f64(double) nounwind +declare i8* @extitoa(i64) nounwind +declare i64 @string_hash(i8*) nounwind +declare void @llvm_schedule_callback(i64, i8*) nounwind +declare void @llvm_send_udp(i8*, i32, i8*, i32) nounwind +declare i64 @next_prime(i64) nounwind +declare void @free_after_delay(i8*, double) nounwind +declare i8* @llvm_disassemble(i8*, i32) nounwind + +; Thread functions +declare i8* @thread_fork(i8*, i8*) nounwind +declare void @thread_destroy(i8*) nounwind +declare i32 @thread_join(i8*) nounwind +declare i32 @thread_kill(i8*) nounwind +declare i8* @thread_self() nounwind +declare i32 @thread_equal_self(i8*) nounwind +declare i32 @thread_equal(i8*, i8*) nounwind +declare i64 @thread_sleep(i64, i64) nounwind +declare i8* @mutex_create() nounwind +declare i32 @mutex_destroy(i8*) nounwind +declare i32 @mutex_lock(i8*) nounwind +declare i32 @mutex_unlock(i8*) nounwind +declare i32 @mutex_trylock(i8*) nounwind + +; Clock functions +declare double @clock_clock() nounwind +declare double @audio_clock_base() nounwind +declare double @audio_clock_now() nounwind + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SCHEME STUFF @@ -484,15 +634,17 @@ define private i8* @i16toptr(i16 %a) alwaysinline ret i8* %return } +; Portable 80-bit extended precision to double conversion +; Works on both x86_64 and ARM64 by manually parsing IEEE 754 extended format +; The 80-bit format is: 1 sign bit, 15 exponent bits, 64 mantissa bits (explicit integer bit) +; Input is big-endian (as used in AIFF files) +declare double @fp80_to_double_portable(i8*) nounwind + define private double @fp80ptrtod(i8* %fp80ptr) { - %1 = alloca i8*, align 8 - store i8* %fp80ptr, i8** %1, align 8 - %2 = load i8*, i8** %1, align 8 - %3 = bitcast i8* %2 to x86_fp80* - %4 = load x86_fp80, x86_fp80* %3, align 16 - %5 = fptrunc x86_fp80 %4 to double - ret double %5 +entry: + %result = call double @fp80_to_double_portable(i8* %fp80ptr) + ret double %result } declare i32 @printf(i8* noalias nocapture, ...) @@ -559,4 +711,4 @@ define private void @ascii_text_color(i32 %bold, i32 %fg, i32 %bg) nounwind alwa { call void @ascii_text_color_extern(i32 %bold, i32 %fg, i32 %bg) ret void -} \ No newline at end of file +} diff --git a/runtime/init.ll b/runtime/init.ll index 2941d21e3..73f7d4a77 100644 --- a/runtime/init.ll +++ b/runtime/init.ll @@ -557,7 +557,7 @@ entry: declare i8* @memset(i8* %dest, i32 %val, i64 %len) -declare void @llvm.memcpy.p0i8.p0i8.i64(i8*, i8*, i64, i32, i1) +declare void @llvm.memcpy.p0.p0.i64(ptr, ptr, i64, i1) declare %mzone* @llvm_zone_callback_setup() nounwind declare %mzone* @llvm_pop_zone_stack() nounwind diff --git a/runtime/inline.ll b/runtime/inline.ll index 1257996c1..3b1218052 100644 --- a/runtime/inline.ll +++ b/runtime/inline.ll @@ -1,3 +1,7 @@ +; Type definitions required for LLVM 21+ (types must be sized before GEP) +%mzone = type {i8*, i64, i64, i64, i8*, %mzone*} +%clsvar = type {i8*, i32, i8*, %clsvar*} + define private %clsvar* @new_address_table() nounwind alwaysinline { ret %clsvar* null @@ -56,3 +60,9 @@ define private i32 @is_integer(i8* %ptr) nounwind alwaysinline %res = call i32 @is_integer_extern(i8* %ptr) ret i32 %res } + +; Main callback for XTLang code (defined in Extempore.cpp) +declare void @xtm_set_main_callback(i8*) + +; Window event registration (defined in UNIV.cpp) +declare i32 @register_for_window_events() diff --git a/runtime/llvmir.xtm b/runtime/llvmir.xtm index 63fa22b74..9cee1bd75 100644 --- a/runtime/llvmir.xtm +++ b/runtime/llvmir.xtm @@ -55,10 +55,15 @@ (if *impc:compiler:print-raw-llvm* (print-full-nq *impc:compiler:queued-llvm-ir-string*)) (if (not (string=? *impc:compiler:queued-llvm-ir-string* "")) - (let ((res (llvm:jit-compile-ir-string *impc:compiler:queued-llvm-ir-string*))) + (let* ((ir-to-compile *impc:compiler:queued-llvm-ir-string*) + (res (llvm:jit-compile-ir-string ir-to-compile))) (impc:compiler:reset-jit-compilation-queue) - ;; (print "Flushed IR compilation queue with result: " res "\n") - res)))) + ;; (if (not res) + ;; (begin + ;; (print "FLUSH FAILED. IR was:\n") + ;; (print-full-nq ir-to-compile))) + res) + #t))) ;; JIT-compile the IR string, or queue it for AOT-compilation (define llvm:compile-ir @@ -1197,11 +1202,14 @@ ", ")) os) (emit (impc:ir:get-type-str (car t)) " (" os)) - (dotimes (i (length args)) - (if (> i 0) (emit ", " os)) - (if (symbol? (list-ref args i)) - (impc:compiler:print-could-not-resolve-type-error (list-ref args i))) - (emit (impc:ir:get-type-str (list-ref args i)) os)) + (let loop ((args-remaining args) (first? #t)) + (if (not (null? args-remaining)) + (let ((arg (car args-remaining))) + (if (not first?) (emit ", " os)) + (if (symbol? arg) + (impc:compiler:print-could-not-resolve-type-error arg)) + (emit (impc:ir:get-type-str arg) os) + (loop (cdr args-remaining) #f)))) (emit ")" os) (impc:ir:strip-space os)))) @@ -1211,9 +1219,12 @@ (let* ((os (make-string 0)) (args t)) (emit "{"os) - (dotimes (i (length args)) - (if (> i 0) (emit ", " os)) - (emit (impc:ir:get-type-str (cdr (list-ref args i))) os)) + (let loop ((args-remaining args) (first? #t)) + (if (not (null? args-remaining)) + (let ((arg (car args-remaining))) + (if (not first?) (emit ", " os)) + (emit (impc:ir:get-type-str (cdr arg)) os) + (loop (cdr args-remaining) #f)))) (emit "}" os) (impc:ir:strip-space os)))) @@ -1223,9 +1234,12 @@ (let* ((os (make-string 0)) (args t)) (emit "{"os) - (dotimes (i (length args)) - (if (> i 0) (emit ", " os)) - (emit (impc:ir:get-type-str (cdr (list-ref args i))) "*" os)) + (let loop ((args-remaining args) (first? #t)) + (if (not (null? args-remaining)) + (let ((arg (car args-remaining))) + (if (not first?) (emit ", " os)) + (emit (impc:ir:get-type-str (cdr arg)) "*" os) + (loop (cdr args-remaining) #f)))) (emit "}" os) (impc:ir:strip-space os)))) @@ -1233,13 +1247,14 @@ (define impc:ir:make-arglist-str (lambda (args . with-symbol?) (let* ((os (make-string 0))) - (dotimes (i (length args)) - (if (> i 0) (emit ", " os)) - (let ((arg (list-ref args i))) - ;(print 'arg: arg) + (let loop ((args-remaining args) (first? #t)) + (if (not (null? args-remaining)) + (let ((arg (car args-remaining))) + (if (not first?) (emit ", " os)) (emit (impc:ir:get-type-str (cdr arg)) os) (if (car with-symbol?) - (emit " %" (symbol->string (car arg)) os)))) + (emit " %" (symbol->string (car arg)) os)) + (loop (cdr args-remaining) #f)))) (impc:ir:strip-space os)))) @@ -1357,9 +1372,9 @@ (emit "\n; malloc closure address table\n" os2) (emit (impc:ir:gname "addytable" "%clsvar*") " = call %clsvar* @new_address_table()\n" os2) (define table (impc:ir:gname)) - (define ptridx 0) - (dotimes (i (length env)) - (let* ((e (list-ref env i)) + (let loop ((env-remaining env) (ptridx 0)) + (if (not (null? env-remaining)) + (let* ((e (car env-remaining)) (varname (if (regex:match? (symbol->string (car e)) "__sub$") (cadr (regex:matched (symbol->string (car e)) "(.*)__sub$")) (symbol->string (car e)))) @@ -1383,12 +1398,13 @@ "%clsvar* " (car table) ")\n" os2) (set! table (impc:ir:gname)) - (set! ptridx (+ ptridx (/ (sys:pointer-size) 8))))) ; need it as bytes + (loop (cdr env-remaining) (+ ptridx (/ (sys:pointer-size) 8)))))) ; need it as bytes (emit (impc:ir:gname "address-table" "i8*") " = bitcast %clsvar* " (car table) " to i8*\n" os2) ;; add data to environment structure (emit "; add data to environment\n" os1) - (dotimes (i (length env)) - (let* ((e (list-ref env i)) + (let loop ((env-remaining env) (i 0)) + (if (not (null? env-remaining)) + (let* ((e (car env-remaining)) (alloc? (not (regex:match? (symbol->string (car e)) "__sub$")))) ;; first fixup mangled name if not allocing (if (not alloc?) (set! e (cons (string->symbol (car (regex:split (symbol->string (car e)) "__sub$"))) @@ -1406,7 +1422,8 @@ ;;(emit "call ccc void @llvm_print_pointer(i8* " (car (impc:ir:gname)) ")\n" os1) (emit "store " (cadr t) " %" (symbol->string (car e)) "Ptr" ", " - (cadr t) "* " (car (impc:ir:gname "tmp_envptr")) "\n\n" os1))) + (cadr t) "* " (car (impc:ir:gname "tmp_envptr")) "\n\n" os1) + (loop (cdr env-remaining) (+ i 1))))) (emit "\n" os1) @@ -1496,8 +1513,9 @@ (begin (emit "; setup environment\n" os) (emit (string-append "%impenv = bitcast i8* %_impenv to " (impc:ir:make-struct-str-env env) "*\n") os) - (dotimes (i (length env)) - (let ((e (list-ref env i))) + (let loop ((env-remaining env) (i 0)) + (if (not (null? env-remaining)) + (let ((e (car env-remaining))) ;; need to strip __sub's (if (regex:match? (symbol->string (car e)) "__sub$") (set! e (cons (string->symbol (car (regex:split (symbol->string (car e)) "__sub$"))) @@ -1509,11 +1527,13 @@ (emit (string-append "%" (symbol->string (car e)) "Ptr = load " (impc:ir:get-type-str (cdr e)) "*, " (impc:ir:get-type-str (cdr e)) "** %" - (symbol->string (car e)) "Ptr_\n") os))))) + (symbol->string (car e)) "Ptr_\n") os) + (loop (cdr env-remaining) (+ i 1))))))) ;; next we pull the function arguments (emit "\n; setup arguments\n" os) - (dotimes (i (length args)) - (let* ((a (list-ref args i))) + (let loop ((args-remaining args)) + (if (not (null? args-remaining)) + (let* ((a (car args-remaining))) (set! *impc:ir:sym-name-stack* (cons (car a) *impc:ir:sym-name-stack*)) (if (> allocate-mem? 0) (begin ;; (println 'yes: allocate-mem? 'mem: ast) @@ -1531,7 +1551,8 @@ (emit "%" (symbol->string (car a)) "Ptr = bitcast i8* %dat_" (symbol->string (car a)) " to " (impc:ir:get-type-str (cdr a)) "*\n" os)) (emit "%" (symbol->string (car a)) "Ptr = alloca " (impc:ir:get-type-str (cdr a)) "\n" os)) (emit (string-append "store " (impc:ir:get-type-str (cdr a)) " %" (symbol->string (car a)) - ", " (impc:ir:get-type-str (cdr a)) "* %" (symbol->string (car a)) "Ptr\n") os))) + ", " (impc:ir:get-type-str (cdr a)) "* %" (symbol->string (car a)) "Ptr\n") os) + (loop (cdr args-remaining))))) (emit "\n" os) ;; compile body ;; (println '_compin: *impc:ir:sym-name-stack*) @@ -1606,8 +1627,9 @@ ;; next we pull the function arguments (emit "\n; setup arguments\n" os) - (dotimes (i (length args)) - (let* ((a (list-ref args i))) + (let loop ((args-remaining args)) + (if (not (null? args-remaining)) + (let* ((a (car args-remaining))) (set! *impc:ir:sym-name-stack* (cons (car a) *impc:ir:sym-name-stack*)) (if (> allocate-mem? 0) (begin ;; (println 'yes: allocate-mem? 'mem: ast) @@ -1625,7 +1647,8 @@ (emit "%" (symbol->string (car a)) "Ptr = bitcast i8* %dat_" (symbol->string (car a)) " to " (impc:ir:get-type-str (cdr a)) "*\n" os)) (emit "%" (symbol->string (car a)) "Ptr = alloca " (impc:ir:get-type-str (cdr a)) "\n" os)) (emit (string-append "store " (impc:ir:get-type-str (cdr a)) " %" (symbol->string (car a)) - ", " (impc:ir:get-type-str (cdr a)) "* %" (symbol->string (car a)) "Ptr\n") os))) + ", " (impc:ir:get-type-str (cdr a)) "* %" (symbol->string (car a)) "Ptr\n") os) + (loop (cdr args-remaining))))) (emit "\n" os) ;; compile body ;; (println '_compin: *impc:ir:sym-name-stack*) @@ -1681,16 +1704,16 @@ ;; (println 'symstr: symstr 'symtype: symtype) ;; (println 'typestr: typestr) (if (and (number? (cadr p)) ;; if numeric constant force to type of symbol - (impc:ir:number? (cdr (assoc-strcmp (caar p) types))) + (impc:ir:number? symtype) (impc:ir:number? (impc:ir:get-type-from-str typestr))) - (set! typestr (impc:ir:get-type-str (cdr (assoc-strcmp (caar p) types))))) + (set! typestr (impc:ir:get-type-str symtype))) ;; type check - ;; (println 'tt1: (impc:ir:get-type-from-str typestr) 'tt2: (cdr (assoc-strcmp (caar p) types))) + ;; (println 'tt1: (impc:ir:get-type-from-str typestr) 'tt2: symtype) (if (not (equal? (impc:ir:get-type-from-str typestr) ;; check to see if the two types are equal? - (cdr (assoc-strcmp (caar p) types)))) + symtype)) (impc:compiler:print-type-mismatch-error (impc:ir:pretty-print-type typestr) - (impc:ir:pretty-print-type (cdr (assoc-strcmp (caar p) types))) + (impc:ir:pretty-print-type symtype) (caar p))) ;(println 'value: value 'typestr: typestr) ;'cadrp (cadr p)) ;(emit (impc:ir:gname "zone" "%mzone*") " = call %mzone* @llvm_peek_zone_stack()\n" os) @@ -2309,7 +2332,7 @@ (impc:compiler:print-bad-type-error (car ast) "remember that closures must be pointers") (impc:compiler:print-bad-type-error (car ast) "bad type for closure"))))) ;;(recursive-call (if (eq? (car ast) (car *impc:ir:sym-name-stack*)) #t #f)) - (recursive-call (if (member (car ast) *impc:ir:sym-name-stack*) #t #f)) + (recursive-call (if (memq (car ast) *impc:ir:sym-name-stack*) #t #f)) (os (make-string 0)) (ftype (impc:ir:make-function-str functiontype #t)) (clstype (string-append "{i8*, i8*, " ftype "*}*")) @@ -2586,7 +2609,7 @@ (if global? ;; (impc:ti:globalvar-exists? (symbol->string (cadr ast))) ;; are we are setting a global variable? (emit (string-append "store " (cadr vv) " " (car vv) ", " (cadr vv) "* @" (symbol->string (cadr ast)) "\n") os) - (if (member (cadr ast) *impc:ir:sym-name-stack*) + (if (memq (cadr ast) *impc:ir:sym-name-stack*) ;; memq for symbols (emit (string-append "store " (cadr vv) " " (car vv) ", " (cadr vv) "* %" (symbol->string (cadr ast)) "Ptr\n") os) (impc:compiler:print-missing-identifier-error (cadr ast) 'variable))) @@ -4122,13 +4145,13 @@ (define impc:ir:intrinsic-substitution (lambda (name) (cond - ((string=? name "memcpy") "llvm.memcpy.p0i8.p0i8.i64") + ((string=? name "memcpy") "llvm.memcpy.p0.p0.i64") (else name)))) (define impc:ir:function-fixup-args (lambda (name) (cond - ((string=? name "memcpy") ", i32 1, i1 0") + ((string=? name "memcpy") ", i1 0") (else "")))) (define impc:ir:compiler:native-call diff --git a/runtime/llvmti.xtm b/runtime/llvmti.xtm index 222822fec..1df0c0873 100644 --- a/runtime/llvmti.xtm +++ b/runtime/llvmti.xtm @@ -1122,6 +1122,9 @@ ;; -------- ;; (define *impc:ti:closure-cache* '()) + +;; Map from (polyfunc-name . type) to adhoc name with counter. +(define *impc:ti:adhoc-name-cache* '()) ;; ;; each element of the list is of the form ;; @@ -2666,6 +2669,7 @@ (define *impc:aot:current-output-port* #f) (define *impc:aot:current-lib-name* "xtmdylib") +(define *impc:aot:owning-lib-name* "xtmdylib") (define *impc:aot:win-link-libraries* '(".\\libs\\platform-shlibs\\extempore.lib")) (define *impc:aot:win-link-libraries-exe* '(".\\libs\\platform-shlibs\\extempore.lib")) (define *impc:aot:unix-link-libraries* '("-lextempore -lm")) @@ -2765,7 +2769,9 @@ (define impc:aot:insert-static-binding-details (lambda (name type) - (if (output-port? *impc:aot:current-output-port*) + ;; Only emit binding details if we're compiling the owning library. + (if (and (output-port? *impc:aot:current-output-port*) + (equal? *impc:aot:owning-lib-name* *impc:aot:current-lib-name*)) (begin (write (list 'bind-lib (string->symbol *impc:aot:current-lib-name*) name type) *impc:aot:current-output-port*) @@ -3090,7 +3096,9 @@ (define impc:aot:insert-header (lambda (libname) - (if (output-port? *impc:aot:current-output-port*) + (set! *impc:aot:owning-lib-name* libname) + (if (and (output-port? *impc:aot:current-output-port*) + (equal? libname *impc:aot:current-lib-name*)) (begin (display (string-append "(sys:load-preload-check '" (substring libname 3) ")\n") *impc:aot:current-output-port*) @@ -3125,7 +3133,8 @@ (define impc:aot:import-ll (lambda (libname) (if (and (output-port? *impc:aot:current-output-port*) - (not *impc:compiler:aot:dll*)) + (not *impc:compiler:aot:dll*) + (equal? libname *impc:aot:current-lib-name*)) (begin (write `(llvm:compile-ir (sys:slurp-file ,(string-append "libs/aot-cache/" libname ".ll"))) *impc:aot:current-output-port*) @@ -3135,7 +3144,8 @@ (define impc:aot:insert-footer (lambda (libname) - (if (output-port? *impc:aot:current-output-port*) + (if (and (output-port? *impc:aot:current-output-port*) + (equal? libname *impc:aot:current-lib-name*)) (begin (display (string-append "(print-with-colors 'green 'default #t (print \"done\"))") *impc:aot:current-output-port*) @@ -3188,12 +3198,13 @@ (asdll? (if (sys:cmdarg "dll") #t #f)) (file-no-extension (filename-strip-extension (filename-from-path file-path))) (aot-compilation-file (string-append file-no-extension ".exe")) - (in-file-port (open-input-file (sanitize-platform-path file-path)))) + (in-file-port (open-input-file (sanitize-platform-path file-path))) + (original-optimize-flag (llvm:optimize))) (set! *impc:aot:current-output-port* #t) ;;(open-output-file aot-compilation-file)) (set! *impc:aot:func-defs-in-mod* '()) (if (impc:aot:currently-compiling?) (begin - (llvm:optimize #t); // should this be restored later? + (llvm:optimize #t) ;; this is the 'success' branch (set! *impc:aot:current-lib-name* file-no-extension) ;; (impc:aot:insert-header libname-no-extension) @@ -3244,10 +3255,13 @@ (impc:compiler:print-compiler-error "Failed compiling LLVM IR")) (impc:aot:compile-exe file-no-extension module libs asdll?)) (set! *impc:aot:current-output-port* #f) + ;; Restore original optimization flag + (llvm:optimize original-optimize-flag) ;; (close-port *impc:aot:current-output-port*) (quit 0)) (begin (begin (print-with-colors 'black 'red #t (print " Error ")) + (llvm:optimize original-optimize-flag) (print "\n\ncannot write AOT-compilation file at " aot-compilation-file-path "\n") (quit 2))))))) @@ -3272,7 +3286,8 @@ (llas-path (sanitize-platform-path (string-append (get-llvm-path) "/bin/llvm-as"))) (in-file-port (or (open-input-file (sanitize-platform-path lib-path)) - (open-input-file (sanitize-platform-path (string-append (sys:share-dir) "/" lib-path)))))) + (open-input-file (sanitize-platform-path (string-append (sys:share-dir) "/" lib-path))))) + (original-optimize-flag (llvm:optimize))) (if (not in-file-port) (begin (print-with-colors 'black 'red #t (print "Error:")) @@ -3303,7 +3318,7 @@ (set! *impc:aot:func-defs-in-mod* '()) (if (impc:aot:currently-compiling?) (begin - (llvm:optimize #t); // should this be restored later? + (llvm:optimize #t) ;; this is the 'success' branch (set! *impc:aot:current-lib-name* libname-no-extension) ;; module name for globals @@ -3324,13 +3339,16 @@ (print "Successfully wrote file to ") (print-with-colors 'green 'default #f (print aot-compilation-file-path "\n\n")) (impc:aot:print-compilation-details start-time) + (llvm:optimize original-optimize-flag) (quit 0)) (begin (print-with-colors 'black 'red #t (print " Error ")) (print "\n\nsomething went wrong in writing the output file ") (print-with-colors 'red 'faultde #t (print aot-compilation-file-path "\n")) + (llvm:optimize original-optimize-flag) (quit 1)))) (begin (print-with-colors 'black 'red #t (print " Error ")) (print "\n\ncannot write file at " aot-compilation-file-path "\n") + (llvm:optimize original-optimize-flag) (quit 2)))))))))) @@ -3349,7 +3367,9 @@ (libname (sanitize-platform-path (filename-from-path lib-path))) (libname-no-extension (string-append "xtm" (filename-strip-extension libname))) (output-dir (sanitize-platform-path (string-append (sys:share-dir) "/libs/aot-cache"))) - (aot-compilation-file-path (sanitize-platform-path (string-append output-dir "/" libname)))) + (aot-compilation-file-path (sanitize-platform-path (string-append output-dir "/" libname))) + (original-opt-level (llvm:optimization-level)) + (original-optimize-flag (llvm:optimize))) (if (not (sys:load-preload-check (string->symbol libname-no-extension))) (begin (print "AOT-compilation file not written ") (close-port *impc:aot:current-output-port*) @@ -3366,7 +3386,9 @@ (set! *impc:aot:func-defs-in-mod* '()) (if (impc:aot:currently-compiling?) (begin - (llvm:optimize #t); // should this be restored later? + (llvm:optimize #t) + ;; Use O3 optimization for AOT compilation. + (llvm:optimization-level 3) ;; this is the 'success' branch (set! *impc:aot:current-lib-name* libname-no-extension) ;; (impc:aot:insert-header libname-no-extension) @@ -3384,8 +3406,11 @@ (print "\n")) (let ((module (impc:compiler:flush-jit-compilation-queue))) (if (not module) - (impc:compiler:print-compiler-error "Failed compiling LLVM IR")) - (impc:aot:compile-module libname-no-extension module)) + (impc:compiler:print-compiler-error "Failed compiling LLVM IR") + (impc:aot:compile-module libname-no-extension module))) + ;; Restore configured optimization level and flag after AOT completes + (llvm:optimization-level original-opt-level) + (llvm:optimize original-optimize-flag) ;; (impc:aot:insert-footer libname-no-extension) (close-port *impc:aot:current-output-port*) (set! *impc:aot:current-lib-name* "xtmdylib") @@ -3472,7 +3497,7 @@ ;;(print 'ast: ast 'types: types) (cond ((null? ast) '()) ((atom? ast) ast) - ((member (car ast) *impc:lambdaslist*) + ((memq (car ast) *impc:lambdaslist*) (list* (car ast) ;; 'lambda (map (lambda (a) (if (and (list? a) @@ -3488,7 +3513,7 @@ a)) (cadr ast)) (f (cddr ast)))) - ((member (car ast) *impc:letslist*) + ((memq (car ast) *impc:letslist*) (list* (car ast) (map (lambda (a) (if (or (atom? a) @@ -3633,7 +3658,7 @@ (cond ((atom? ast) ast) ((null? ast) ast) ((list? ast) - (cond ((member (car ast) *impc:letslist*) + (cond ((memq (car ast) *impc:letslist*) ;; first find and replace all shadow vars (let* ((replace-pairs (cl:remove @@ -3669,7 +3694,7 @@ (cons (car newast) (cons (map (lambda (x) (cons (car x) (f (cdr x) fname))) (cadr newast)) (f (cddr newast) fname))))) - ((member (car ast) *impc:lambdaslist*) + ((memq (car ast) *impc:lambdaslist*) (let* ((replace-pairs (cl:remove #f @@ -4317,28 +4342,28 @@ Continue executing `body' forms until `test-expression' returns #f" ((eq? (car ast) 'free) (list 'free (list 'bitcast (impc:ti:first-transform (cadr ast) inbody?) 'i8*))) - ((member (car ast) '(vector_ref)) + ((memq (car ast) '(vector_ref)) (impc:ti:first-transform `(let ((v1 (alloc)) (v2 (vector ,@(cdr ast)))) (pset! v1 0 v2) v1) inbody?)) - ((member (car ast) '(array_ref)) + ((memq (car ast) '(array_ref)) (impc:ti:first-transform `(let ((a1 (alloc)) (a2 (array ,@(cdr ast)))) (pset! a1 0 a2) a1) inbody?)) - ((member (car ast) '(tuple_ref)) + ((memq (car ast) '(tuple_ref)) (impc:ti:first-transform `(let ((t1 (alloc)) (t2 (tuple ,@(cdr ast)))) (pset! t1 0 t2) t1) inbody?)) - ((member (car ast) '(vector)) + ((memq (car ast) '(vector)) `(make-vector ,@(map (lambda (x) (impc:ti:first-transform x inbody?)) (cdr ast)))) - ((member (car ast) '(array)) + ((memq (car ast) '(array)) `(make-array ,@(map (lambda (x) (impc:ti:first-transform x inbody?)) (cdr ast)))) - ((member (car ast) '(tuple)) + ((memq (car ast) '(tuple)) `(make-tuple ,@(map (lambda (x) (impc:ti:first-transform x inbody?)) (cdr ast)))) ((eq? (car ast) 'not) (impc:ti:first-transform (impc:ti:not (cadr ast)) inbody?)) - ((member (car ast) '(callback schedule)) + ((memq (car ast) '(callback schedule)) (impc:ti:first-transform (impc:ti:callback (impc:ti:first-transform (cdr ast) inbody?)) inbody?)) - ((and (member (car ast) *impc:mathbinaryaritylist*) + ((and (memq (car ast) *impc:mathbinaryaritylist*) (<> (length ast) 3)) (impc:ti:first-transform (impc:ti:binary-arity ast inbody?) inbody?)) - ((member (car ast) '(bitwise-not ~)) + ((memq (car ast) '(bitwise-not ~)) (impc:ti:bitwise-not-to-eor ast inbody?)) - ((member (car ast) *impc:lambdaslist*) + ((memq (car ast) *impc:lambdaslist*) (if inbody? (impc:ti:lambda ast) (cons (impc:ti:first-transform (car ast) inbody?) @@ -4363,7 +4388,7 @@ Continue executing `body' forms until `test-expression' returns #f" (list 'closure-refcheck (impc:ti:first-transform (cadr ast) inbody?) (symbol->string (caddr ast)))) - ((member (car ast) '(cast convert)) + ((memq (car ast) '(cast convert)) (if (= (length ast) 2) (impc:ti:first-transform (list (if (eq? (car ast) 'cast) 'bitcast @@ -4387,7 +4412,7 @@ Continue executing `body' forms until `test-expression' returns #f" ((eq? (car ast) 'doloop) (impc:ti:doloop ast inbody?)) ((eq? (car ast) 'dotimes) (impc:ti:dotimes ast inbody?)) ((eq? (car ast) 'while) (impc:ti:while ast inbody?)) - ((member (car ast) *impc:letslist*) + ((memq (car ast) *impc:letslist*) (cons (impc:ti:first-transform (car ast) inbody?) (cons (map (lambda (p) (list (impc:ti:first-transform (car p) #f) @@ -5624,7 +5649,7 @@ Continue executing `body' forms until `test-expression' returns #f" (equal? sym t)) 'exit (begin ;; (println 'update-var:> sym 'in: vars 'with: t 'kts: kts) - (if (member sym kts) ;; if in known types don't do anything + (if (memq sym kts) ;; if in known types don't do anything '() (if (and (not (assoc-strcmp sym vars)) (not (regex:match? (symbol->string sym) ":\\[")) @@ -5901,6 +5926,12 @@ Continue executing `body' forms until `test-expression' returns #f" (list (impc:ir:pointer-- (impc:ti:get-globalvar-type (symbol->string ast))))) ((impc:ti:nativefunc-exists? (symbol->string ast)) (list (impc:ti:get-nativefunc-type (symbol->string ast)))) + ;; Check for closures before falling through to polyfunc handling. + ;; This prevents closures that are also registered as polyfuncs + ;; from being incorrectly treated as polymorphic references. + ((impc:ti:closure-exists? (symbol->string ast)) + (list (cons (+ *impc:ir:closure* *impc:ir:pointer* *impc:ir:pointer*) + (map impc:ir:get-type-from-str (impc:ti:get-closure-arg-types (symbol->string ast)))))) (else (if (and (symbol? ast) (impc:ti:genericfunc-exists? (string->symbol (impc:ir:get-base-type (symbol->string ast))))) @@ -5952,9 +5983,9 @@ Continue executing `body' forms until `test-expression' returns #f" (if (impc:ti:closure-exists? (symbol->string ast)) (list (cons (+ *impc:ir:closure* *impc:ir:pointer* *impc:ir:pointer*) (map impc:ir:get-type-from-str (impc:ti:get-closure-arg-types (symbol->string ast))))) (list (impc:ir:pointer-- (impc:ti:get-globalvar-type (symbol->string ast))))))))) - ;; (println '---------- (member ast kts) 'type: type (impc:ir:type? type)) + ;; (println '---------- (memq ast kts) 'type: type (impc:ir:type? type)) (if (and request? - (not (member ast kts)) ;; if we're in KTS then we should ignore requests! + (not (memq ast kts)) ;; if we're in KTS then we should ignore requests! (not (null? request?))) (if (null? type) (begin @@ -5983,8 +6014,8 @@ Continue executing `body' forms until `test-expression' returns #f" (if (equal? request? *impc:ir:notype*) (set! request? #f)) ;; if request is false (if (not request?) - (begin (if (member (cadr ast) kts) (set! request? (cdr (assoc-strcmp (cadr ast) vars)))) - (if (member (caddr ast) kts) (set! request? (cdr (assoc-strcmp (caddr ast) vars)))))) + (begin (if (memq (cadr ast) kts) (set! request? (cdr (assoc-strcmp (cadr ast) vars)))) + (if (memq (caddr ast) kts) (set! request? (cdr (assoc-strcmp (caddr ast) vars)))))) ;; now start type checking (let* ((n1 (cadr ast)) (n2 (caddr ast)) @@ -6776,7 +6807,7 @@ Continue executing `body' forms until `test-expression' returns #f" (arity (- (length ast) 1)) ;; (lll (println 'gname gname arity (if request? (cons request? args) args))) (gpt (impc:ti:genericfunc-types gname arity (if request? (cons request? args) args))) - (gpt-valid (if (equal? #f gpt) + (gpt-valid (if (equal? #f gpt) (impc:compiler:print-compiler-error "no valid generic options available for: " ast) #t)) ;; request? request? args))) @@ -6885,14 +6916,14 @@ Continue executing `body' forms until `test-expression' returns #f" (let ((req (regex:matched request? "^%([^_]*).*")) (gen (regex:matched (symbol->string (cadr gpoly-type)) "^([A-Za-z][^{:]*).*"))) ;; (println 'req req 'gen gen) - (if (and (= (length req) 2) + (if (and (= (length req) 2) (= (length gen) 2)) (if (and (not (equal? (cadr req) (cadr gen))) #t) ;; (not (equal? (cadr gen) "_"))) ;; (impc:compiler:print-compiler-error "no valid generic options available for: " ast))))) - (impc:compiler:print-compiler-error (string-append "Return type mismatch for generic function which expected return type '" (cadr gen) "' and got named type '" (cadr req) "'") ast))))) + (impc:compiler:print-compiler-error (string-append "Return type mismatch for generic function which expected return type '" (cadr gen) "' and got named type '" (cadr req) "'") ast))))) ;; (println 'update 'return 'var 'with (impc:ti:update-var (cadr gpoly-type) vars kts (list request?))) - (if (not (member (cadr gpoly-type) vars)) + (if (not (assoc-strcmp (cadr gpoly-type) vars)) (set-cdr! vars (cons (list (cadr gpoly-type)) (cdr vars)))) (impc:ti:update-var (cadr gpoly-type) vars kts (list request?)))) (set! gpoly-type (cons (car gpoly-type) (cons request? (cddr gpoly-type)))))) @@ -7832,7 +7863,7 @@ xtlang's `let' syntax is the same as Scheme" (regex:match? request? "^%.*") (regex:match? a "^%.*") (not (equal? request? a))) - (impc:compiler:print-compiler-error (string-append "type error calculating return type - expected named type '" a "' got '" request? "'") ast)) + (impc:compiler:print-compiler-error (string-append "type error calculating return type - expected named type '" a "' got '" request? "'") ast)) (if *impc:ti:print-sub-checks* (println 'ret:> 'ast: ast 'a: a 'sym: sym)) (if (and (impc:ir:type? t) (impc:ir:closure? t)) @@ -8377,10 +8408,12 @@ xtlang's `let' syntax is the same as Scheme" ;; (println 'cls 'ref 'check: ast 'request? request?) (if (<> (length ast) 4) (impc:compiler:print-bad-arity-error ast)) - (let* (;; a should be a closure of some kind + (let* (;; a should be a closure or a single-candidate polyfunc. (a (if (and (symbol? (cadr ast)) - (impc:ti:closure-exists? (symbol->string (cadr ast)))) - #t ; // yes (cadr ast) is a globally defined closure + (or (impc:ti:closure-exists? (symbol->string (cadr ast))) + (and (impc:ti:polyfunc-exists? (symbol->string (cadr ast))) + (= 1 (length (impc:ti:get-polyfunc-candidate-names (symbol->string (cadr ast)))))))) + ; #t ; // yes (cadr ast) is a globally defined closure or single-candidate polyfunc. (impc:ti:type-check (cadr ast) vars kts #f))) ;; do NOT check against request! ;; b should be a string (the var's name) (b (impc:ti:type-check (caddr ast) vars kts (impc:ir:pointer++ (list *impc:ir:si8*))))) @@ -8396,10 +8429,12 @@ xtlang's `let' syntax is the same as Scheme" ;; (println 'cls2 'ref 'check: ast 'request? request?) (if (<> (length ast) 3) (impc:compiler:print-bad-arity-error ast)) - (let* (;; a should be a closure of some kind + (let* (;; a should be a closure or a single-candidate polyfunc. (a (if (and (symbol? (cadr ast)) - (impc:ti:closure-exists? (symbol->string (cadr ast)))) - #t ; // yes (cadr ast) is a globally defined closure + (or (impc:ti:closure-exists? (symbol->string (cadr ast))) + (and (impc:ti:polyfunc-exists? (symbol->string (cadr ast))) + (= 1 (length (impc:ti:get-polyfunc-candidate-names (symbol->string (cadr ast)))))))) + #t ; // yes (cadr ast) is a globally defined closure or single-candidate polyfunc. (impc:ti:type-check (cadr ast) vars kts #f))) ;; request?))) ;; b should be a string (the var's name) (b (impc:ti:type-check (caddr ast) vars kts (list *impc:ir:si8*)))) @@ -8666,7 +8701,7 @@ xtlang's `let' syntax is the same as Scheme" (set! a (car a))) (if (and (impc:ir:type? a) (list? b) - (member a b)) + (memq a b)) (set! b a)) ;; (car (cadr ast)) should be a symbol that we want to update with a (if (not (symbol? (car (cadr ast)))) @@ -8820,13 +8855,13 @@ xtlang's `let' syntax is the same as Scheme" ((and (atom? ast) (symbol? ast)) (impc:ti:symbol-check ast vars kts request?)) ((and (atom? ast) (string? ast)) (impc:ti:string-check ast vars kts request?)) ((atom? ast) (impc:compiler:print-compiler-error "internal error unhandled atom" ast)) - ((and (list? ast) (member (car ast) *impc:letslist*)) (impc:ti:let-check ast vars kts request?)) - ((and (list? ast) (member (car ast) *impc:lambdaslist*)) (impc:ti:lambda-check ast vars kts request?)) - ((and (list? ast) (equal? (car ast) 't:)) + ((and (list? ast) (memq (car ast) *impc:letslist*)) (impc:ti:let-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) *impc:lambdaslist*)) (impc:ti:lambda-check ast vars kts request?)) + ((and (list? ast) (eq? (car ast) 't:)) (impc:ti:type-check (cadr ast) vars kts (impc:ir:get-type-from-pretty-str (symbol->string (caddr ast))))) - ((and (list? ast) (member (car ast) *impc:mathbinaryaritylist*)) + ((and (list? ast) (memq (car ast) *impc:mathbinaryaritylist*)) ;; '(* / + - % modulo bitwise-and bitwise-or bitwise-eor bitwise-shift-left bitwise-shift-right bitwise-not))) (let ((r (impc:ti:math-check ast vars kts request?))) (if (impc:ir:tuple? r) @@ -8858,52 +8893,52 @@ xtlang's `let' syntax is the same as Scheme" (set-car! ast m) (set! r (impc:ti:type-check ast vars kts request?))))) *impc:ir:i1*)) - ((and (list? ast) (member (car ast) *impc:mathintrinsicslist*)) (impc:ti:math-intrinsic-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(dotimes))) (impc:ti:dotimes-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(while))) (impc:ti:while-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(printf))) (impc:ti:printf-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(sprintf))) (impc:ti:sprintf-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(fprintf))) (impc:ti:fprintf-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(sscanf))) (impc:ti:sscanf-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(fscanf))) (impc:ti:fscanf-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(push_zone))) (impc:ti:push_zone-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(pop_zone))) (impc:ti:pop_zone-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(push_new_zone))) (impc:ti:push_new_zone-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(create_zone))) (impc:ti:create_zone-check ast vars kts request?)) - ;;((and (list? ast) (member (car ast) '(memzone))) (impc:ti:memzone-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(llvm_callback))) (impc:ti:callback-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(make-vector))) (impc:ti:make-vector-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(vector-set!))) (impc:ti:vector-set-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(vector-ref))) (impc:ti:vector-ref-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(vector-shuffle))) (impc:ti:vector-shuffle-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(make-array))) (impc:ti:make-array-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(array-set!))) (impc:ti:array-set-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(array-ref))) (impc:ti:array-ref-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(array-ref-ptr))) (impc:ti:array-ref-ptr-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(pointer-set!))) (impc:ti:pointer-set-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(pointer-ref))) (impc:ti:pointer-ref-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(pointer-ref-ptr))) (impc:ti:pointer-ref-ptr-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(stack-alloc))) (impc:ti:stack-alloc-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(heap-alloc))) (impc:ti:heap-alloc-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(zone-alloc))) (impc:ti:zone-alloc-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(make-tuple))) (impc:ti:make-tuple-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(num-of-elts))) (impc:ti:num-of-elts-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(obj-size))) (impc:ti:obj-size-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(ref))) (impc:ti:ref-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(tuple-set!))) (impc:ti:tuple-set-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(tuple-ref))) (impc:ti:tuple-ref-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(tuple-ref-ptr))) (impc:ti:tuple-ref-ptr-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(closure-set!))) (impc:ti:closure-set-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(closure-ref))) (impc:ti:closure-ref-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(closure-refcheck))) (impc:ti:closure-refcheck-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(pref))) (impc:ti:pref-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(pdref))) (impc:ti:pdref-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(null?))) (impc:ti:null?-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(impc_null))) (impc:ti:null-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(bitcast))) (impc:ti:bitcast-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(bitconvert))) (impc:ti:bitconvert-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(void))) (impc:ti:void-check ast vars kts request?)) - ((and (list? ast) (member (car ast) '(fptrcall))) (impc:ti:fptrcall-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) *impc:mathintrinsicslist*)) (impc:ti:math-intrinsic-check ast vars kts request?)) + ((and (list? ast) (eq? (car ast) 'dotimes)) (impc:ti:dotimes-check ast vars kts request?)) + ((and (list? ast) (eq? (car ast) 'while)) (impc:ti:while-check ast vars kts request?)) + ((and (list? ast) (eq? (car ast) 'printf)) (impc:ti:printf-check ast vars kts request?)) + ((and (list? ast) (eq? (car ast) 'sprintf)) (impc:ti:sprintf-check ast vars kts request?)) + ((and (list? ast) (eq? (car ast) 'fprintf)) (impc:ti:fprintf-check ast vars kts request?)) + ((and (list? ast) (eq? (car ast) 'sscanf)) (impc:ti:sscanf-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(fscanf))) (impc:ti:fscanf-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(push_zone))) (impc:ti:push_zone-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(pop_zone))) (impc:ti:pop_zone-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(push_new_zone))) (impc:ti:push_new_zone-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(create_zone))) (impc:ti:create_zone-check ast vars kts request?)) + ;;((and (list? ast) (memq (car ast) '(memzone))) (impc:ti:memzone-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(llvm_callback))) (impc:ti:callback-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(make-vector))) (impc:ti:make-vector-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(vector-set!))) (impc:ti:vector-set-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(vector-ref))) (impc:ti:vector-ref-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(vector-shuffle))) (impc:ti:vector-shuffle-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(make-array))) (impc:ti:make-array-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(array-set!))) (impc:ti:array-set-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(array-ref))) (impc:ti:array-ref-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(array-ref-ptr))) (impc:ti:array-ref-ptr-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(pointer-set!))) (impc:ti:pointer-set-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(pointer-ref))) (impc:ti:pointer-ref-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(pointer-ref-ptr))) (impc:ti:pointer-ref-ptr-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(stack-alloc))) (impc:ti:stack-alloc-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(heap-alloc))) (impc:ti:heap-alloc-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(zone-alloc))) (impc:ti:zone-alloc-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(make-tuple))) (impc:ti:make-tuple-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(num-of-elts))) (impc:ti:num-of-elts-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(obj-size))) (impc:ti:obj-size-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(ref))) (impc:ti:ref-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(tuple-set!))) (impc:ti:tuple-set-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(tuple-ref))) (impc:ti:tuple-ref-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(tuple-ref-ptr))) (impc:ti:tuple-ref-ptr-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(closure-set!))) (impc:ti:closure-set-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(closure-ref))) (impc:ti:closure-ref-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(closure-refcheck))) (impc:ti:closure-refcheck-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(pref))) (impc:ti:pref-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(pdref))) (impc:ti:pdref-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(null?))) (impc:ti:null?-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(impc_null))) (impc:ti:null-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(bitcast))) (impc:ti:bitcast-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(bitconvert))) (impc:ti:bitconvert-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(void))) (impc:ti:void-check ast vars kts request?)) + ((and (list? ast) (memq (car ast) '(fptrcall))) (impc:ti:fptrcall-check ast vars kts request?)) ((and (list? ast) ;; poly func (specific match) (symbol? (car ast)) request? @@ -9136,19 +9171,27 @@ xtlang's `let' syntax is the same as Scheme" (not (string-contains? (symbol->string ast) ":")) (impc:ti:polyfunc-exists? (symbol->string ast))) (let* ((pname (symbol->string ast)) - (ts (impc:ti:get-polyfunc-candidate-types pname))) - (if (= (length ts) 1) - (string->symbol (string-append pname "_adhoc_" (cname-encode (impc:ir:get-base-type (impc:ir:pretty-print-type (car ts)))))) + (names (impc:ti:get-polyfunc-candidate-names pname))) + (if (and names (= (length names) 1)) + ;; Use actual implementation name from cache. + (string->symbol (car names)) (impc:compiler:print-compiler-error "Try forcing a type. Ambiguous polymorphic function" ast)))) ((and (symbol? ast) (string-contains? (symbol->string ast) ":") (impc:ti:polyfunc-exists? (car (regex:type-split (symbol->string ast) ":")))) (let* ((res (regex:type-split (symbol->string ast) ":")) (pname (car res)) - (ptype (if (impc:ti:typealias-exists? (cadr res)) - (impc:ir:get-base-type (impc:ir:pretty-print-type (impc:ti:get-typealias-type (cadr res)))) - (impc:ir:get-base-type (cadr res))))) - (string->symbol (string-append pname "_adhoc_" (cname-encode ptype))))) + (ptype-str (cadr res)) + (ptype (impc:ir:get-type-from-pretty-str + (if (impc:ti:typealias-exists? ptype-str) + (impc:ir:pretty-print-type (impc:ti:get-typealias-type ptype-str)) + ptype-str))) + ;; Look up actual implementation name. + (candidate (impc:ti:get-polyfunc-candidate pname ptype))) + (if candidate + candidate + ;; Fallback to manual construction if not found. + (string->symbol (string-append pname "_adhoc_" (cname-encode (impc:ir:get-base-type ptype-str))))))) ((and (symbol? ast) (string-contains? (symbol->string ast) ":")) (let* ((p (regex:type-split (symbol->string ast) ":")) @@ -9194,12 +9237,11 @@ xtlang's `let' syntax is the same as Scheme" (let* ((nm (regex:split (symbol->string ast) "##")) (n1 (car nm)) (type (cdr (assoc-strcmp ast types))) - (ptype (impc:ir:pretty-print-type type)) - (cn (cname-encode (impc:ir:get-base-type ptype))) - (newn (string-append n1 "_adhoc_" cn))) - (if (not (impc:ti:closure-exists? newn)) - (impc:compiler:print-compiler-error (string-append "Bad type: " ptype " for polymorphic function " (car nm)) ast)) - (string->symbol newn))) + ;; Use polyfunc cache to find the implementation. + (candidate (impc:ti:get-polyfunc-candidate n1 type))) + (if (not candidate) + (impc:compiler:print-compiler-error (string-append "Bad type: " (impc:ir:pretty-print-type type) " for polymorphic function " (car nm)) ast)) + candidate)) ((and (symbol? ast) (string-contains? (symbol->string ast) "##") (assoc-strcmp ast types)) @@ -9421,20 +9463,20 @@ xtlang's `let' syntax is the same as Scheme" (list (impc:ti:mark-returns (caddr ast) name in-body? last-pair? blocked?)) (if (not (null? (cdddr ast))) (list (impc:ti:mark-returns (cadddr ast) name in-body? last-pair? blocked?))))) - ((member (car ast) *impc:letslist*) + ((memq (car ast) *impc:letslist*) (append (list (car ast)) (list (map (lambda (a) ;; let assigns always block (lambda can override but nothing else) (list (car a) (impc:ti:mark-returns (cadr a) (car a) #f #f #t))) (cadr ast))) (impc:ti:mark-returns (cddr ast) name #t #f blocked?))) - ((member (car ast) *impc:lambdaslist*) + ((memq (car ast) *impc:lambdaslist*) (append (list (car ast)) (list (cadr ast)) ;; lambda always unblocks because lambdas always need a return (impc:ti:mark-returns (cddr ast) name #t #f #f))) ;((equal? (car ast) 'dotimes) ; (append '(dotimes) (list (cadr ast)) (impc:ti:mark-returns (cddr ast) name #t #f blocked?))) - ((equal? (car ast) 'begin) + ((eq? (car ast) 'begin) (if (null? (cdr ast)) (impc:compiler:print-no-retval-error ast)) (let* ((rev (reverse (cdr ast))) @@ -9566,7 +9608,7 @@ xtlang's `let' syntax is the same as Scheme" (define impc:ti:allocate-var? (lambda (ast) (cond ((null? ast) #f) - ((member ast *impc:lambdaslist*) #t) + ((memq ast *impc:lambdaslist*) #t) ((pair? ast) (or (impc:ti:allocate-var? (car ast)) (impc:ti:allocate-var? (cdr ast)))) @@ -9575,20 +9617,21 @@ xtlang's `let' syntax is the same as Scheme" (define impc:ti:allocate-var? (lambda (ast) (cond ((null? ast) 0) - ((member ast '(lambda lambdaz)) 3) + ((memq ast '(lambda lambdaz)) 3) ((eq? ast 'lambdah) 1) ((eq? ast 'lambdas) 2) ((pair? ast) - (let ((a (impc:ti:allocate-var? (car ast))) - (b (impc:ti:allocate-var? (cdr ast)))) - (if (> a b) a b))) + (let ((a (impc:ti:allocate-var? (car ast)))) + (if (= a 3) 3 + (let ((b (impc:ti:allocate-var? (cdr ast)))) + (if (> a b) a b))))) (else 0)))) ;; adds make-closure and make-env tags (define impc:ti:closure:convert (lambda (ast esyms) (cond ((pair? ast) - (if (member (car ast) *impc:lambdaslist*) + (if (memq (car ast) *impc:lambdaslist*) (let (;(env (impc:ti:block:check-for-free-syms ast esyms)) (allocate-mem-for-vars? (impc:ti:allocate-var? (cdr ast)))) (list (cond ((eq? (car ast) 'lambdah) '__make-closure-h) @@ -9600,7 +9643,7 @@ xtlang's `let' syntax is the same as Scheme" (cdr (reverse (cl:remove-duplicates esyms))) ;env (cadr ast) (impc:ti:closure:convert (caddr ast) (append (cadr ast) esyms)))) - (if (member (car ast) *impc:letslist*) + (if (memq (car ast) *impc:letslist*) (let* ((allocate-mem-for-vars? (impc:ti:allocate-var? ast)) (bindings (map (lambda (binding) (car binding)) @@ -9627,7 +9670,7 @@ xtlang's `let' syntax is the same as Scheme" (eq? (car ast) closure-sym)) (if (and (not (null? (cdr ast))) (list? (cadr ast)) - (member (caadr ast) *impc:lambdaslist*)) + (memq (caadr ast) *impc:lambdaslist*)) (cadr (cadr ast)) '())) (else (append (impc:ti:get-closure-arg-symbols closure-sym (car ast)) @@ -9758,7 +9801,7 @@ xtlang's `let' syntax is the same as Scheme" (lambda (ast forced-types) ;; (println 'ast: ast) (if (pair? ast) - (cond ((member (car ast) '(< > * / = + - <>)) + (cond ((memq (car ast) '(< > * / = + - <>)) (let ((a (assoc-strcmp (cadr ast) forced-types)) (b (assoc-strcmp (caddr ast) forced-types))) (if (and (and a b) @@ -9976,11 +10019,6 @@ xtlang's `let' syntax is the same as Scheme" (if (not (null? args)) (set! args (replace-all args (list (cons adhoc-poly-name symname))))) (set! code (replace-all code (list (cons adhoc-poly-name symname)))))) - ;; don't want type checking to find existing native versions! - (if (and *impc:compile* (not static)) - (begin - (llvm:erase-function (string-append (symbol->string symname) "_setter")) - (llvm:erase-function (string-append (symbol->string symname) "_maker")))) (let* ((symname-string (symbol->string symname)) (oldsymname-string symname-string) ;(c code) @@ -10060,21 +10098,24 @@ xtlang's `let' syntax is the same as Scheme" (f (cdr lst))))))) (f t5)) - (if (and poly ;;*impc:ti:implicit-adhoc-compiles* - (not (regex:match? adhoc-poly-name-string "(_poly_|_adhoc_)"))) - (let* ((p (assoc-strcmp symname types)) - (n (car p)) - (t (impc:ir:pretty-print-type (cdr p))) + ;; Append type encoding to adhoc name for global uniqueness. + (if (and poly (regex:match? symname-string "_adhoc_[0-9]+$")) + (let* ((p (assoc-strcmp symname types))) + (if p + (let* ((t (impc:ir:pretty-print-type (cdr p))) (base (impc:ir:get-base-type t)) - (depth (impc:ir:get-ptr-depth t)) - (new (string-append adhoc-poly-name-string "_adhoc_" (cname-encode base))) - (tt (assoc-strcmp symname types)) - (t6 (replace-all t5 (list (cons symname (string->symbol new)))))) - (set-car! tt (string->symbol new)) - (set! symname (string->symbol new)) - (set! symname-string new) - (set! newast (impc:ti:add-types-to-source symname t6 (cl:tree-copy types) (list)))) - (set! newast (impc:ti:add-types-to-source symname t5 (cl:tree-copy types) (list)))) + (final-name (string-append symname-string "_" (cname-encode base))) + (final-sym (string->symbol final-name)) + (old-sym symname)) + ;; Update symname in types list. + (set-car! p final-sym) + ;; Replace old name with new name in AST. + (set! t5 (replace-all t5 (list (cons old-sym final-sym)))) + ;; Update symname variable. + (set! symname final-sym) + (set! symname-string final-name))))) + + (set! newast (impc:ti:add-types-to-source symname t5 (cl:tree-copy types) (list))) ;; ;; modify code for static functions @@ -10160,7 +10201,22 @@ xtlang's `let' syntax is the same as Scheme" 0 "[static]")) (let* ((closure-type (cadr (impc:ir:gname))) ;; normal closure (closure-type-- (impc:ir:get-type-str (impc:ir:pointer-- (impc:ir:get-type-from-str closure-type)))) - (compile-stub? (not (impc:ti:closure-exists? symname-string))) + (existing-type (impc:ti:get-closure-type symname-string)) + ;; Compile stubs if first compilation or type has changed. + (compile-stub? (or (not (impc:ti:closure-exists? symname-string)) + (null? existing-type) + (not (equal? (impc:ir:get-type-from-str closure-type) existing-type)))) + ;; Erase old definitions only when recompiling stubs. + (_ (if (and *impc:compile* (not static) compile-stub?) + (begin + (llvm:erase-function symname-string) + (llvm:erase-function (string-append symname-string "_native")) + (llvm:erase-function (string-append symname-string "_setter")) + (llvm:erase-function (string-append symname-string "_maker")) + (llvm:erase-function (string-append symname-string "_getter")) + (llvm:remove-globalvar (string-append symname-string "_var")) + (llvm:remove-globalvar (string-append symname-string "_var_zone"))) + #f)) (maker-ir (string-append "define dllexport ccc " closure-type " @" symname-string "_maker" "(i8* %_impz) nounwind {\nentry:\n" ;; "%_zone = bitcast i8* %_impz to %mzone*\n" @@ -10456,12 +10512,12 @@ xtlang's `let' syntax is the same as Scheme" (if *impc:compiler:print* (println '------------------------------compiling 'maker----------------------------------->)) (if *impc:compiler:print* (print-full-nq maker-ir)) - (if *impc:compile* + (if (and *impc:compile* compile-stub?) (impc:compiler:queue-ir-for-compilation maker-ir)) (if *impc:compiler:print* (println '--------------------------------compiling 'setter----------------------------------->)) (if *impc:compiler:print* (print-full-nq setter-ir)) - (if *impc:compile* + (if (and *impc:compile* compile-stub?) (impc:compiler:queue-ir-for-compilation setter-ir)) (if *impc:compiler:print* (println '--------------------------------compiling 'getter----------------------------------->)) @@ -10503,12 +10559,23 @@ xtlang's `let' syntax is the same as Scheme" (impc:ti:update-closure-name adhoc-poly-name-string symname-string) (impc:ti:set-closure-type symname-string closure-type-list) (impc:ti:set-closure-body symname-string code) + ;; Store mapping for get_native_fptr lookup. + (set! *impc:ti:adhoc-name-cache* + (cons (cons (cons adhoc-poly-name-string closure-type-list) symname-string) + *impc:ti:adhoc-name-cache*)) ;; add to the AOT-header if we're precompiling (impc:aot:insert-closure-binding-details symname-string closure-type-list (impc:ti:get-closure-zone-size symname-string) (impc:ti:get-closure-docstring symname-string) (impc:ti:get-closure-body symname-string)) + ;; Clear old polyfunc candidates of same type before adding new one + ;; This prevents accumulation of candidates that causes "ambiguous wrapper" errors. + (let ((pfdata (assoc-strcmp adhoc-poly-name-string *impc:ti:polyfunc-cache*))) + (if pfdata + (vector-set! (cdr pfdata) 0 + (cl:remove-if (lambda (x) (equal? (vector-ref x 1) closure-type-list)) + (vector-ref (cdr pfdata) 0))))) (eval `(bind-poly ,adhoc-poly-name ,symname) (interaction-environment))) (begin (impc:ti:set-closure-type symname-string closure-type-list) @@ -11017,7 +11084,7 @@ xtlang's `let' syntax is the same as Scheme" (tfill! obj ,@argslist) (pref obj 0)))) (interaction-environment)) - (if copy? + (if copy? (begin (eval `(bind-func ,(string->symbol (string-append "hcopy:[" namestr "*," namestr "*]*")) (lambda (,(string->symbol (string-append "x:" namestr "*"))) @@ -11366,7 +11433,16 @@ xtlang's `let' syntax is the same as Scheme" (sys:command-output "echo $LD_LIBRARY_PATH") ":") - '("/usr/local/lib/" "/usr/lib/" "/opt/local/lib/" "/usr/lib/x86_64-linux-gnu"))) + '("/usr/local/lib/" + "/usr/lib/" + "/opt/local/lib/" + ;; Linux + "/usr/lib/x86_64-linux-gnu" + "/usr/lib/aarch64-linux-gnu" + ;; macOS + "/opt/homebrew/lib/" + "/usr/local/Cellar/" + "/opt/homebrew/Cellar/"))) (list (sanitize-platform-path (string-append "C:/Windows/System32/" path))))))) (if (null? candidate-paths) #f @@ -11511,13 +11587,13 @@ e.g. (impc:compiler:print-compiler-error "bind-lib-type failed" ,name))))) (define-macro (register-lib-type library name type docstring) - (if (impc:aot:currently-compiling?) + (if (impc:aot:currently-compiling?) (set! *impc:ti:suppress-ir-generation* #t) (set! *impc:ti:suppress-ir-generation* #f)) (let* ((a (impc:ir:get-pretty-tuple-arg-strings (symbol->string type))) (namestr (symbol->string name)) (typestr (symbol->string type))) - `(begin + `(begin (impc:ti:register-new-namedtype ,namestr ',(impc:ir:get-type-from-pretty-str typestr namestr) ,docstring) @@ -11643,9 +11719,7 @@ e.g. (llvm:run setter) ;; don't destroy - this happens in _setter func (sys:pop-memzone)) - (begin - (error) - (impc:compiler:print-missing-identifier-error (string->symbol (string-append func-name "_setter")) 'closure-setter))))))) + (impc:compiler:print-missing-identifier-error (string->symbol (string-append func-name "_setter")) 'closure-setter)))))) (define impc:ti:create-scm-wrapper? (lambda (func-name) diff --git a/src/AudioDevice.cpp b/src/AudioDevice.cpp index 70dd624f3..3536f5a6d 100644 --- a/src/AudioDevice.cpp +++ b/src/AudioDevice.cpp @@ -37,9 +37,14 @@ #include #include #include -#include #include +// x86 SSE intrinsics for audio_sanity_f optimization +#if defined(__x86_64__) || defined(_M_X64) || defined(__i386__) || defined(_M_IX86) +#include +#define USE_SSE_AUDIO_SANITY 1 +#endif + #include "AudioDevice.h" #include "TaskScheduler.h" #include "EXTMonitor.h" @@ -136,7 +141,13 @@ static inline SAMPLE audio_sanity(SAMPLE x) static inline float audio_sanity_f(float x) { if (likely(isfinite(x))) { +#if USE_SSE_AUDIO_SANITY _mm_store_ss(&x, _mm_min_ss(_mm_max_ss(_mm_set_ss(x), _mm_set_ss(-0.99f)), _mm_set_ss(0.99f))); +#else + // Portable branchless clamp for ARM64 and other architectures + if (x < -0.99f) x = -0.99f; + else if (x > 0.99f) x = 0.99f; +#endif return x; } return 0.0; @@ -201,7 +212,7 @@ void* audioCallbackMT(void* Args) set_thread_realtime(pthread_mach_thread_np(pthread_self()), clockFrequency*.01,clockFrequency*.007,clockFrequency*.007); #elif __linux__ set_thread_realtime(pthread_self(), SCHED_RR, 20); -#elif _WIN32 +#elif _WIN32 SetThreadPriority(GetCurrentThread(), 15); // 15 = THREAD_PRIORITY_TIME_CRITICAL #endif //printf("Starting RT Audio Process\n"); @@ -271,7 +282,7 @@ void* audioCallbackMTBuf(void* dat) { set_thread_realtime(pthread_mach_thread_np(pthread_self()), clockFrequency*.01,clockFrequency*.007,clockFrequency*.007); #elif __linux__ set_thread_realtime(pthread_self(), SCHED_RR, 20); -#elif _WIN32 +#elif _WIN32 SetThreadPriority(GetCurrentThread(),15); // 15 = THREAD_PRIORITY_TIME_CRITICAL #endif unsigned idx = uintptr_t(dat); @@ -370,7 +381,7 @@ int audioCallback(const void* InputBuffer, void* OutputBuffer, unsigned long Fra extemp::EXTZones::llvm_zone_reset(zone); } ++in; - } + } } else { // for when in channels & out channels don't match //SAMPLE* indata = alloc(UNIV::IN_CHANNELS); // auto //indata(in); diff --git a/src/EXTLLVM.cpp b/src/EXTLLVM.cpp index 645184476..1641c0814 100644 --- a/src/EXTLLVM.cpp +++ b/src/EXTLLVM.cpp @@ -40,33 +40,45 @@ // must be included before anything which pulls in #include "llvm/AsmParser/Parser.h" #include "llvm/Config/llvm-config.h" // for LLVM_VERSION_STRING -#include "llvm/ExecutionEngine/GenericValue.h" -#include "llvm/ExecutionEngine/Interpreter.h" -#include "llvm/ExecutionEngine/MCJIT.h" -#include "llvm/ExecutionEngine/SectionMemoryManager.h" +#include "llvm/ExecutionEngine/Orc/LLJIT.h" +#include "llvm/ExecutionEngine/Orc/ThreadSafeModule.h" + #include "llvm/IR/CallingConv.h" #include "llvm/IR/Constants.h" #include "llvm/IR/DataLayout.h" #include "llvm/IR/DerivedTypes.h" #include "llvm/IR/Instructions.h" #include "llvm/IR/LLVMContext.h" -#include "llvm/IR/LegacyPassManager.h" #include "llvm/IR/Module.h" -#include "llvm/LinkAllPasses.h" +#include "llvm/IR/Verifier.h" + +#include "llvm/Passes/PassBuilder.h" +#include "llvm/Passes/OptimizationLevel.h" + #include "llvm/Support/SourceMgr.h" #include "llvm/Support/TargetSelect.h" -#include "llvm/Support/TargetRegistry.h" #include "llvm/Support/raw_ostream.h" -#include "llvm/Target/TargetOptions.h" -#include "llvm/Support/MemoryObject.h" +#include "llvm/Support/Error.h" +#include "llvm/TargetParser/Host.h" + #include "llvm/MC/MCAsmInfo.h" -#include "llvm/MC/MCDisassembler.h" +#include "llvm/MC/MCDisassembler/MCDisassembler.h" #include "llvm/MC/MCInst.h" #include "llvm/MC/MCInstPrinter.h" #include "llvm/MC/MCContext.h" +#include "llvm/MC/MCSubtargetInfo.h" +#include "llvm/MC/MCRegisterInfo.h" +#include "llvm/MC/MCInstrInfo.h" +#include "llvm/MC/TargetRegistry.h" +#include "llvm/Target/TargetMachine.h" +#include "llvm/Target/TargetOptions.h" #include #include +#include +#include +#include +#include #include "stdarg.h" #include @@ -144,6 +156,63 @@ EXPORT void free16(void* Ptr) { #endif } +// Portable conversion from 80-bit extended precision (big-endian) to double. +// Used for reading AIFF audio files, which store sample rate in this format. +// Format: 1 sign bit, 15 exponent bits, 64 mantissa bits (with explicit integer bit) +EXPORT double fp80_to_double_portable(const unsigned char* bytes) +{ + // Read big-endian 80-bit value + unsigned int exponent = (unsigned(bytes[0]) << 8) | bytes[1]; + uint64_t mantissa = (uint64_t(bytes[2]) << 56) | (uint64_t(bytes[3]) << 48) | + (uint64_t(bytes[4]) << 40) | (uint64_t(bytes[5]) << 32) | + (uint64_t(bytes[6]) << 24) | (uint64_t(bytes[7]) << 16) | + (uint64_t(bytes[8]) << 8) | uint64_t(bytes[9]); + + // Extract sign bit. + int sign = (exponent >> 15) & 1; + exponent &= 0x7FFF; + + // Handle special cases. + if (exponent == 0 && mantissa == 0) { + return sign ? -0.0 : 0.0; + } + if (exponent == 0x7FFF) { + // Infinity or NaN - for audio sample rates, this shouldn't happen. + return sign ? -1.0/0.0 : 1.0/0.0; + } + + // Convert to double. + // x86_fp80 exponent bias is 16383, double bias is 1023. + int64_t exp_unbiased = int64_t(exponent) - 16383; + + // The mantissa has an explicit integer bit (bit 63). + // Double has implicit integer bit, so we need to handle this. + union { uint64_t i; double d; } result; + + if (mantissa & (1ULL << 63)) { + // Normal number - integer bit is set. + // Remove the integer bit and shift mantissa to fit in double's 52-bit mantissa. + uint64_t double_mantissa = (mantissa & 0x7FFFFFFFFFFFFFFFULL) >> 11; + int64_t double_exp = exp_unbiased + 1023; + + if (double_exp >= 2047) { + // Overflow to infinity. + return sign ? -1.0/0.0 : 1.0/0.0; + } else if (double_exp <= 0) { + // Underflow - denormalized or zero. + return sign ? -0.0 : 0.0; + } else { + // Pack into IEEE 754 double format. + result.i = (uint64_t(sign) << 63) | (uint64_t(double_exp) << 52) | double_mantissa; + } + } else { + // Denormalized or pseudo-denormalized - rare for audio sample rates. + return sign ? -0.0 : 0.0; + } + + return result.d; +} + const char* llvm_scheme_ff_get_name(foreign_func ff) { return LLVM_SCHEME_FF_MAP[ff].c_str(); @@ -183,7 +252,7 @@ EXPORT void llvm_schedule_callback(long long time, void* dat) EXPORT void* llvm_get_function_ptr(char* fname) { - return reinterpret_cast(extemp::EXTLLVM::EE->getFunctionAddress(fname)); + return reinterpret_cast(extemp::EXTLLVM::getFunctionAddress(fname)); } EXPORT char* extitoa(int64_t val) @@ -247,7 +316,7 @@ EXPORT void llvm_send_udp(char* host, int port, void* message, int message_lengt int ret = setsockopt(fd, SOL_SOCKET, SO_BROADCAST, &broadcastEnable, sizeof(broadcastEnable)); if (ret) { printf("Error: Could not open set socket to broadcast mode\n"); } ////////////////////////////////////// - + int err = sendto(fd, message, length, 0, (struct sockaddr*)&sa, sizeof(sa)); close(fd); #endif @@ -437,7 +506,7 @@ pointer llvm_scheme_env_set(scheme* _sc, char* sym) // Module* M = extemp::EXTLLVM::M; std::string funcname(xtlang_name); std::string getter("_getter"); - void*(*p)() = (void*(*)()) extemp::EXTLLVM::EE->getFunctionAddress(funcname + getter); + void*(*p)() = (void*(*)()) extemp::EXTLLVM::getFunctionAddress(funcname + getter); if (!p) { printf("Error attempting to set environment variable in closure %s.%s\n",fname,vname); return _sc->F; @@ -524,40 +593,95 @@ pointer llvm_scheme_env_set(scheme* _sc, char* sym) namespace extemp { namespace EXTLLVM { -llvm::ExecutionEngine* EE = nullptr; -llvm::legacy::PassManager* PM; -llvm::legacy::PassManager* PM_NO; -llvm::Module* M = nullptr; // TODO: obsolete? +std::unique_ptr JIT = nullptr; +std::unique_ptr TSC = nullptr; + +llvm::orc::ThreadSafeContext& getThreadSafeContext() { + if (!TSC) { + TSC = std::make_unique( + std::make_unique()); + } + return *TSC; +} + std::vector Ms; int64_t LLVM_COUNT = 0l; bool OPTIMIZE_COMPILES = true; bool VERIFY_COMPILES = true; +int OPTIMIZATION_LEVEL = 2; + +uint64_t getFunctionAddress(const std::string& name) { + if (!JIT) return 0; + auto sym = JIT->lookup(name); + if (!sym) { + llvm::consumeError(sym.takeError()); + return 0; + } + return sym->getValue(); +} + +bool removeSymbol(const std::string& name) { + if (!JIT) return false; + + auto& ES = JIT->getExecutionSession(); + auto& JD = JIT->getMainJITDylib(); + + for (const auto& tryName : {name, "_" + name}) { + llvm::orc::SymbolNameSet toRemove; + toRemove.insert(ES.intern(tryName)); + if (auto err = JD.remove(toRemove)) { + llvm::consumeError(std::move(err)); + } + } + return true; +} + +llvm::Error addTrackedModule(llvm::orc::ThreadSafeModule TSM, const std::vector& symbolNames) { + if (!JIT) return llvm::make_error("JIT not initialized", llvm::inconvertibleErrorCode()); -static llvm::SectionMemoryManager* MM = nullptr; + if (auto err = JIT->addIRModule(std::move(TSM))) { + return err; + } -uint64_t getSymbolAddress(const std::string& name) { - return MM->getSymbolAddress(name); + return llvm::Error::success(); } EXPORT const char* llvm_disassemble(const unsigned char* Code, int syntax) { size_t code_size = 1024 * 100; std::string Error; - llvm::TargetMachine *TM = extemp::EXTLLVM::EE->getTargetMachine(); - llvm::Triple Triple = TM->getTargetTriple(); - const llvm::Target TheTarget = TM->getTarget(); - std::string TripleName = Triple.getTriple(); - //const llvm::Target* TheTarget = llvm::TargetRegistry::lookupTarget(ArchName,Triple,Error); - const llvm::MCRegisterInfo* MRI(TheTarget.createMCRegInfo(TripleName)); - const llvm::MCAsmInfo* AsmInfo(TheTarget.createMCAsmInfo(*MRI,TripleName)); - const llvm::MCSubtargetInfo* STI(TheTarget.createMCSubtargetInfo(TripleName,"","")); - const llvm::MCInstrInfo* MII(TheTarget.createMCInstrInfo()); - //const llvm::MCInstrAnalysis* MIA(TheTarget->createMCInstrAnalysis(MII->get())); - llvm::MCContext Ctx(AsmInfo, MRI, nullptr); - llvm::MCDisassembler* DisAsm(TheTarget.createMCDisassembler(*STI, Ctx)); - llvm::MCInstPrinter* IP(TheTarget.createMCInstPrinter(Triple,syntax,*AsmInfo,*MII,*MRI)); //,*STI)); + + std::string TripleName = llvm::sys::getProcessTriple(); + llvm::Triple Triple(TripleName); + + const llvm::Target* TheTarget = llvm::TargetRegistry::lookupTarget(TripleName, Error); + if (!TheTarget) { + std::string errMsg = "Disassembler error: " + Error; + return strdup(errMsg.c_str()); + } + + std::unique_ptr MRI(TheTarget->createMCRegInfo(TripleName)); + if (!MRI) return strdup("Failed to create MCRegisterInfo"); + + llvm::MCTargetOptions MCOptions; + std::unique_ptr AsmInfo(TheTarget->createMCAsmInfo(*MRI, TripleName, MCOptions)); + if (!AsmInfo) return strdup("Failed to create MCAsmInfo"); + + std::unique_ptr STI(TheTarget->createMCSubtargetInfo(TripleName, "", "")); + if (!STI) return strdup("Failed to create MCSubtargetInfo"); + + std::unique_ptr MII(TheTarget->createMCInstrInfo()); + if (!MII) return strdup("Failed to create MCInstrInfo"); + + llvm::MCContext Ctx(Triple, AsmInfo.get(), MRI.get(), STI.get()); + std::unique_ptr DisAsm(TheTarget->createMCDisassembler(*STI, Ctx)); + if (!DisAsm) return strdup("Failed to create MCDisassembler"); + + std::unique_ptr IP(TheTarget->createMCInstPrinter(Triple, syntax, *AsmInfo, *MII, *MRI)); + if (!IP) return strdup("Failed to create MCInstPrinter"); + IP->setPrintImmHex(true); - IP->setUseMarkup(true); + std::string out_str; llvm::raw_string_ostream OS(out_str); llvm::ArrayRef mem(Code, code_size); @@ -566,7 +690,7 @@ EXPORT const char* llvm_disassemble(const unsigned char* Code, int syntax) OS << "\n"; for (index = 0; index < code_size; index += size) { llvm::MCInst Inst; - if (DisAsm->getInstruction(Inst, size, mem.slice(index), index, llvm::nulls(), llvm::nulls())) { + if (DisAsm->getInstruction(Inst, size, mem.slice(index), index, llvm::nulls())) { auto instSize(*reinterpret_cast(Code + index)); if (instSize <= 0) { break; @@ -576,7 +700,7 @@ EXPORT const char* llvm_disassemble(const unsigned char* Code, int syntax) OS.write_hex(size_t(Code) + index); OS.write(": ", 2); OS.write_hex(instSize); - IP->printInst(&Inst, OS, "", *STI); + IP->printInst(&Inst, 0, "", *STI, OS); OS << "\n"; } else if (!size) { size = 1; @@ -754,187 +878,183 @@ EXPORT int64_t thread_sleep(int64_t Secs, int64_t Nanosecs) #endif } +static void registerSymbol(const char* name, void* addr) { + if (!JIT) return; + auto& ES = JIT->getExecutionSession(); + auto& JD = JIT->getMainJITDylib(); + + llvm::orc::SymbolMap Symbols; + Symbols[ES.intern(name)] = { + llvm::orc::ExecutorAddr::fromPtr(addr), + llvm::JITSymbolFlags::Exported + }; + + auto err = JD.define(llvm::orc::absoluteSymbols(std::move(Symbols))); + if (err) { + llvm::consumeError(std::move(err)); + } +} void initLLVM() { - if (unlikely(EE)) { + if (unlikely(JIT)) { return; } - llvm::TargetOptions Opts; - Opts.GuaranteedTailCallOpt = true; - Opts.UnsafeFPMath = false; + llvm::InitializeNativeTarget(); llvm::InitializeNativeTargetAsmPrinter(); - LLVMInitializeX86Disassembler(); - auto& context(llvm::getGlobalContext()); - auto module(llvm::make_unique("xtmmodule_0", context)); - M = module.get(); - addModule(M); - if (!extemp::UNIV::ARCH.empty()) { - M->setTargetTriple(extemp::UNIV::ARCH); - } - // Build engine with JIT - llvm::EngineBuilder factory(std::move(module)); - factory.setEngineKind(llvm::EngineKind::JIT); - factory.setTargetOptions(Opts); - auto mm(llvm::make_unique()); - MM = mm.get(); - factory.setMCJITMemoryManager(std::move(mm)); -#ifdef _WIN32 - if (!extemp::UNIV::ATTRS.empty()) { - factory.setMAttrs(extemp::UNIV::ATTRS); - } - if (!extemp::UNIV::CPU.empty()) { - factory.setMCPU(extemp::UNIV::CPU); - } - llvm::TargetMachine* tm = factory.selectTarget(); -#else - factory.setOptLevel(llvm::CodeGenOpt::Aggressive); - llvm::Triple triple(llvm::sys::getProcessTriple()); - std::string cpu; - if (!extemp::UNIV::CPU.empty()) { - cpu = extemp::UNIV::CPU.front(); - } else { - cpu = llvm::sys::getHostCPUName(); - } - llvm::SmallVector lattrs; - if (!extemp::UNIV::ATTRS.empty()) { - for (const auto& attr : extemp::UNIV::ATTRS) { - lattrs.append(1, attr); - } - } else { - llvm::StringMap HostFeatures; - llvm::sys::getHostCPUFeatures(HostFeatures); + llvm::InitializeNativeTargetAsmParser(); + llvm::InitializeNativeTargetDisassembler(); + + // Create thread-safe context. + TSC = std::make_unique(std::make_unique()); + + // Build LLJIT. + auto JITBuilder = llvm::orc::LLJITBuilder(); + + // Configure target machine. + std::string triple = llvm::sys::getProcessTriple(); + std::string cpu = extemp::UNIV::CPU.empty() ? + std::string(llvm::sys::getHostCPUName()) : extemp::UNIV::CPU; + + auto HostFeatures = llvm::sys::getHostCPUFeatures(); + std::vector featureVec; + std::string featureString; for (auto& feature : HostFeatures) { - std::string featureName = feature.getKey().str(); - // temporarily disable all AVX512-related codegen because it - // causes crashes on this old version of LLVM - see GH #378 for - // more details. - if (feature.getValue() && featureName.compare(0, 6, "avx512")){ - lattrs.append(1, featureName); - }else{ - lattrs.append(1, std::string("-") + featureName); + std::string featureStr; + featureStr += (feature.getValue() ? "+" : "-"); + featureStr += feature.getKey().str(); + featureVec.push_back(featureStr); + if (!featureString.empty()) featureString += ","; + featureString += featureStr; + } + + if (extemp::UNIV::ARCH.empty()) { + extemp::UNIV::ARCH = triple; } - } + + JITBuilder.setJITTargetMachineBuilder( + llvm::orc::JITTargetMachineBuilder(llvm::Triple(triple)) + .setCPU(cpu) + .addFeatures(featureVec) + .setCodeGenOptLevel(llvm::CodeGenOptLevel::Aggressive)); + + // Create the JIT. + auto JITResult = JITBuilder.create(); + if (!JITResult) { + std::cerr << "ERROR: Failed to create LLJIT: " + << llvm::toString(JITResult.takeError()) << std::endl; + exit(1); + } + JIT = std::move(*JITResult); + + // Add DynamicLibrarySearchGenerator to make all process symbols available. + auto& MainJD = JIT->getMainJITDylib(); + auto DLSGOrErr = llvm::orc::DynamicLibrarySearchGenerator::GetForCurrentProcess( + JIT->getDataLayout().getGlobalPrefix()); + if (!DLSGOrErr) { + std::cerr << "ERROR: Failed to create DynamicLibrarySearchGenerator: " + << llvm::toString(DLSGOrErr.takeError()) << std::endl; + exit(1); } - llvm::TargetMachine* tm = factory.selectTarget(triple, "", cpu, lattrs); -#endif // _WIN32 - EE = factory.create(tm); - EE->DisableLazyCompilation(true); + MainJD.addGenerator(std::move(*DLSGOrErr)); + + // Print configuration. ascii_normal(); std::cout << "ARCH : " << std::flush; ascii_info(); - std::cout << std::string(tm->getTargetTriple().normalize()) << std::endl; -#ifdef _WIN32 - if (!std::string(tm->getTargetFeatureString()).empty()) { -#else - if (!std::string(tm->getTargetCPU()).empty()) { -#endif + std::cout << triple << std::endl; + + if (!cpu.empty()) { ascii_normal(); std::cout << "CPU : " << std::flush; ascii_info(); - std::cout << std::string(tm->getTargetCPU()) << std::endl; - } - if (!std::string(tm->getTargetFeatureString()).empty()) { - ascii_normal(); - std::cout << "ATTRS : " << std::flush; - auto data(tm->getTargetFeatureString().data()); - for (; *data; ++data) { - switch (*data) { - case '+': - ascii_info(); - break; - case '-': - ascii_error(); - break; - case ',': - ascii_normal(); - break; - } - putchar(*data); - } - putchar('\n'); + std::cout << cpu << std::endl; } + ascii_normal(); std::cout << "LLVM : " << std::flush; ascii_info(); std::cout << LLVM_VERSION_STRING; - std::cout << " MCJIT" << std::endl; + std::cout << " ORC JIT" << std::endl; ascii_normal(); - PM_NO = new llvm::legacy::PassManager(); - PM_NO->add(llvm::createAlwaysInlinerPass()); - PM = new llvm::legacy::PassManager(); - PM->add(llvm::createAggressiveDCEPass()); - PM->add(llvm::createAlwaysInlinerPass()); - PM->add(llvm::createArgumentPromotionPass()); - PM->add(llvm::createCFGSimplificationPass()); - PM->add(llvm::createDeadStoreEliminationPass()); - PM->add(llvm::createFunctionInliningPass()); - PM->add(llvm::createGVNPass(true)); - PM->add(llvm::createIndVarSimplifyPass()); - PM->add(llvm::createInstructionCombiningPass()); - PM->add(llvm::createJumpThreadingPass()); - PM->add(llvm::createLICMPass()); - PM->add(llvm::createLoopDeletionPass()); - PM->add(llvm::createLoopRotatePass()); - PM->add(llvm::createLoopUnrollPass()); - PM->add(llvm::createMemCpyOptPass()); - PM->add(llvm::createPromoteMemoryToRegisterPass()); - PM->add(llvm::createReassociatePass()); - PM->add(llvm::createScalarReplAggregatesPass()); - PM->add(llvm::createSCCPPass()); - PM->add(llvm::createTailCallEliminationPass()); - - static struct { - const char* name; - uintptr_t address; - } mappingTable[] = { - { "llvm_zone_destroy", uintptr_t(&extemp::EXTZones::llvm_zone_destroy) }, - }; - for (auto& elem : mappingTable) { - EE->updateGlobalMapping(elem.name, elem.address); - } - - // tell LLVM about some built-in functions - EE->updateGlobalMapping("get_address_offset", (uint64_t)&extemp::ClosureAddressTable::get_address_offset); - EE->updateGlobalMapping("string_hash", (uint64_t)&string_hash); - EE->updateGlobalMapping("swap64i", (uint64_t)&swap64i); - EE->updateGlobalMapping("swap64f", (uint64_t)&swap64f); - EE->updateGlobalMapping("swap32i", (uint64_t)&swap32i); - EE->updateGlobalMapping("swap32f", (uint64_t)&swap32f); - EE->updateGlobalMapping("unswap64i", (uint64_t)&unswap64i); - EE->updateGlobalMapping("unswap64f", (uint64_t)&unswap64f); - EE->updateGlobalMapping("unswap32i", (uint64_t)&unswap32i); - EE->updateGlobalMapping("unswap32f", (uint64_t)&unswap32f); - EE->updateGlobalMapping("rsplit", (uint64_t)&rsplit); - EE->updateGlobalMapping("rmatch", (uint64_t)&rmatch); - EE->updateGlobalMapping("rreplace", (uint64_t)&rreplace); - EE->updateGlobalMapping("r64value", (uint64_t)&r64value); - EE->updateGlobalMapping("mk_double", (uint64_t)&mk_double); - EE->updateGlobalMapping("r32value", (uint64_t)&r32value); - EE->updateGlobalMapping("mk_float", (uint64_t)&mk_float); - EE->updateGlobalMapping("mk_i64", (uint64_t)&mk_i64); - EE->updateGlobalMapping("mk_i32", (uint64_t)&mk_i32); - EE->updateGlobalMapping("mk_i16", (uint64_t)&mk_i16); - EE->updateGlobalMapping("mk_i8", (uint64_t)&mk_i8); - EE->updateGlobalMapping("mk_i1", (uint64_t)&mk_i1); - EE->updateGlobalMapping("string_value", (uint64_t)&string_value); - EE->updateGlobalMapping("mk_string", (uint64_t)&mk_string); - EE->updateGlobalMapping("cptr_value", (uint64_t)&cptr_value); - EE->updateGlobalMapping("mk_cptr", (uint64_t)&mk_cptr); - EE->updateGlobalMapping("sys_sharedir", (uint64_t)&sys_sharedir); - EE->updateGlobalMapping("sys_slurp_file", (uint64_t)&sys_slurp_file); - extemp::EXTLLVM::EE->finalizeObject(); + + // Register built-in symbols with the JIT. + + // Zone memory management functions + registerSymbol("llvm_zone_destroy", (void*)&extemp::EXTZones::llvm_zone_destroy); + registerSymbol("llvm_zone_malloc", (void*)&extemp::EXTZones::llvm_zone_malloc); + registerSymbol("llvm_zone_malloc_from_current_zone", (void*)&extemp::EXTZones::llvm_zone_malloc_from_current_zone); + registerSymbol("llvm_zone_print", (void*)&extemp::EXTZones::llvm_zone_print); + registerSymbol("llvm_zone_ptr_size", (void*)&extemp::EXTZones::llvm_zone_ptr_size); + registerSymbol("llvm_zone_copy_ptr", (void*)&extemp::EXTZones::llvm_zone_copy_ptr); + registerSymbol("llvm_ptr_in_zone", (void*)&extemp::EXTZones::llvm_ptr_in_zone); + registerSymbol("llvm_ptr_in_current_zone", (void*)&extemp::EXTZones::llvm_ptr_in_current_zone); + registerSymbol("llvm_pop_zone_stack", (void*)&extemp::EXTZones::llvm_pop_zone_stack); + registerSymbol("llvm_zone_callback_setup", (void*)&extemp::EXTZones::llvm_zone_callback_setup); + registerSymbol("llvm_peek_zone_stack_extern", (void*)&extemp::EXTZones::llvm_peek_zone_stack_extern); + registerSymbol("llvm_push_zone_stack_extern", (void*)&extemp::EXTZones::llvm_push_zone_stack_extern); + registerSymbol("llvm_zone_create_extern", (void*)&extemp::EXTZones::llvm_zone_create_extern); + registerSymbol("llvm_destroy_zone_after_delay", (void*)&llvm_destroy_zone_after_delay); + + // Closure address table functions + registerSymbol("get_address_offset", (void*)&extemp::ClosureAddressTable::get_address_offset); + registerSymbol("add_address_table", (void*)&extemp::ClosureAddressTable::add_address_table); + registerSymbol("get_address_table", (void*)&extemp::ClosureAddressTable::get_address_table); + registerSymbol("check_address_exists", (void*)&extemp::ClosureAddressTable::check_address_exists); + registerSymbol("check_address_type", (void*)&extemp::ClosureAddressTable::check_address_type); + registerSymbol("string_hash", (void*)&string_hash); + registerSymbol("swap64i", (void*)&swap64i); + registerSymbol("swap64f", (void*)&swap64f); + registerSymbol("swap32i", (void*)&swap32i); + registerSymbol("swap32f", (void*)&swap32f); + registerSymbol("unswap64i", (void*)&unswap64i); + registerSymbol("unswap64f", (void*)&unswap64f); + registerSymbol("unswap32i", (void*)&unswap32i); + registerSymbol("unswap32f", (void*)&unswap32f); + registerSymbol("rsplit", (void*)&rsplit); + registerSymbol("rmatch", (void*)&rmatch); + registerSymbol("rreplace", (void*)&rreplace); + registerSymbol("r64value", (void*)&r64value); + registerSymbol("mk_double", (void*)&mk_double); + registerSymbol("r32value", (void*)&r32value); + registerSymbol("mk_float", (void*)&mk_float); + registerSymbol("mk_i64", (void*)&mk_i64); + registerSymbol("mk_i32", (void*)&mk_i32); + registerSymbol("mk_i16", (void*)&mk_i16); + registerSymbol("mk_i8", (void*)&mk_i8); + registerSymbol("mk_i1", (void*)&mk_i1); + registerSymbol("string_value", (void*)&string_value); + registerSymbol("mk_string", (void*)&mk_string); + registerSymbol("cptr_value", (void*)&cptr_value); + registerSymbol("mk_cptr", (void*)&mk_cptr); + registerSymbol("sys_sharedir", (void*)&sys_sharedir); + registerSymbol("sys_slurp_file", (void*)&sys_slurp_file); + registerSymbol("fp80_to_double_portable", (void*)&fp80_to_double_portable); + return; } } // namespace EXTLLVM } // namespace extemp -#include - static std::unordered_map sGlobalMap; +static void cleanupLLVM() { + sGlobalMap.clear(); + extemp::EXTLLVM::Ms.clear(); + + if (extemp::EXTLLVM::JIT) { + extemp::EXTLLVM::JIT.reset(); + } +} + +static struct EXTLLVMCleanupRegistrar { + EXTLLVMCleanupRegistrar() { + std::atexit(cleanupLLVM); + } +} sCleanupRegistrar; + namespace extemp { void EXTLLVM::addModule(llvm::Module* Module) @@ -943,12 +1063,13 @@ void EXTLLVM::addModule(llvm::Module* Module) std::string str; llvm::raw_string_ostream stream(str); function.printAsOperand(stream, false); - auto result(sGlobalMap.insert(std::make_pair(stream.str().substr(1), &function))); + std::string funcName = stream.str().substr(1); + auto result(sGlobalMap.insert(std::make_pair(funcName, &function))); if (!result.second) { result.first->second = &function; } } - for (const auto& global : Module->getGlobalList()) { + for (const auto& global : Module->globals()) { std::string str; llvm::raw_string_ostream stream(str); global.printAsOperand(stream, false); @@ -960,6 +1081,10 @@ void EXTLLVM::addModule(llvm::Module* Module) Ms.push_back(Module); } +void EXTLLVM::removeFromGlobalMap(const std::string& name) { + sGlobalMap.erase(name); +} + const llvm::GlobalValue* EXTLLVM::getGlobalValue(const char* Name) { auto iter(sGlobalMap.find(Name)); diff --git a/src/Extempore.cpp b/src/Extempore.cpp index ec5842b8d..c8c090c9a 100644 --- a/src/Extempore.cpp +++ b/src/Extempore.cpp @@ -125,7 +125,7 @@ enum { OPT_COMPILE_STR, OPT_SHAREDIR, OPT_NOBASE, OPT_SAMPLERATE, OPT_FRAMES, OPT_PORT, OPT_TERM, OPT_NO_AUDIO, OPT_TIME_DIV, OPT_DEVICE, OPT_IN_DEVICE, OPT_DEVICE_NAME, OPT_IN_DEVICE_NAME, OPT_PRT_DEVICES, OPT_REALTIME, OPT_ARCH, OPT_CPU, OPT_ATTR, - OPT_LATENCY, + OPT_LATENCY, OPT_LEVEL, OPT_HELP }; @@ -155,6 +155,7 @@ CSimpleOptA::SOption g_rgOptions[] = { { OPT_ARCH, "--arch", SO_REQ_SEP }, { OPT_CPU, "--cpu", SO_REQ_SEP }, { OPT_ATTR, "--attr", SO_MULTI }, + { OPT_LEVEL, "--opt-level", SO_REQ_SEP }, { OPT_HELP, "--help", SO_NONE }, SO_END_OF_OPTIONS }; @@ -253,9 +254,9 @@ EXPORT int extempore_init(int argc, char** argv) } else { #ifdef _WIN32 extemp::UNIV::EXT_TERM = 1; -#else +#else extemp::UNIV::EXT_TERM = 0; -#endif +#endif } break; case OPT_NO_AUDIO: @@ -300,6 +301,9 @@ EXPORT int extempore_init(int argc, char** argv) case OPT_ATTR: extemp::UNIV::ATTRS.push_back(args.OptionArg()); break; + case OPT_LEVEL: + extemp::EXTLLVM::OPTIMIZATION_LEVEL = atoi(args.OptionArg()); + break; case OPT_HELP: default: std::cout << "Extempore's command line options: " << std::endl; @@ -310,6 +314,7 @@ EXPORT int extempore_init(int argc, char** argv) std::cout << " --sharedir: location of the Extempore share dir (which contains runtime/, libs/, examples/, etc.)" << std::endl; std::cout << " --runtime: [deprecated] use --sharedir instead" << std::endl; std::cout << " --nobase: don't load base lib on startup" << std::endl; + std::cout << " --opt-level: LLVM optimization level 0-3" << std::endl; std::cout << " --samplerate: audio samplerate" << std::endl; std::cout << " --frames: attempts to force frames [1024]" << std::endl; std::cout << " --channels: attempts to force num of output audio channels" << std::endl; @@ -401,7 +406,7 @@ EXPORT int extempore_init(int argc, char** argv) startup_ok &= primary->start(); extemp::SchemeREPL* primary_repl = new extemp::SchemeREPL(primary_name, primary); primary_repl->connectToProcessAtHostname(host, primary_port); - //std::cout << "primary started:" << std::endl << std::flush; + //std::cout << "primary started:" << std::endl << std::flush; if (!startup_ok) { ascii_error(); printf("ERROR:"); @@ -418,7 +423,7 @@ EXPORT int extempore_init(int argc, char** argv) #else sleep(2000); #endif - } + } #else primary = new extemp::SchemeProcess(extemp::UNIV::SHARE_DIR, primary_name, primary_port, 0, initexpr); diff --git a/src/SchemeFFI.cpp b/src/SchemeFFI.cpp index f2828161b..d0d50641e 100644 --- a/src/SchemeFFI.cpp +++ b/src/SchemeFFI.cpp @@ -37,31 +37,38 @@ /////////////////// #include +#include +#include // must be included before anything which pulls in #include "llvm/ADT/StringExtras.h" #include "llvm/AsmParser/Parser.h" #include "llvm-c/Core.h" -#include "llvm/Bitcode/ReaderWriter.h" -#include "llvm/ExecutionEngine/ExecutionEngine.h" -#include "llvm/ExecutionEngine/GenericValue.h" -#include "llvm/ExecutionEngine/Interpreter.h" +#include "llvm/Bitcode/BitcodeWriter.h" +#include "llvm/Bitcode/BitcodeReader.h" + +#include "llvm/ExecutionEngine/Orc/LLJIT.h" +#include "llvm/ExecutionEngine/Orc/ThreadSafeModule.h" + +#include "llvm/Passes/PassBuilder.h" +#include "llvm/Passes/OptimizationLevel.h" + #include "llvm/IR/CallingConv.h" #include "llvm/IR/Constants.h" #include "llvm/IR/DataLayout.h" #include "llvm/IR/DerivedTypes.h" +#include "llvm/IR/IRBuilder.h" #include "llvm/IR/Instructions.h" #include "llvm/IR/LLVMContext.h" #include "llvm/IR/Module.h" -#include "llvm/LinkAllPasses.h" +#include "llvm/Transforms/Utils/Cloning.h" #include "llvm/Support/ManagedStatic.h" -#include "llvm/Support/MutexGuard.h" #include "llvm/Support/SourceMgr.h" #include "llvm/Support/raw_ostream.h" #include "llvm/Support/raw_os_ostream.h" #include "llvm/Target/TargetOptions.h" -#include "llvm/IR/LegacyPassManager.h" #include "llvm/IR/Verifier.h" +#include "llvm/Support/Error.h" #include "SchemeFFI.h" #include "AudioDevice.h" @@ -71,11 +78,13 @@ #include "SchemeREPL.h" #include #include +#include +#include #ifdef _WIN32 #include #include -#include +#include #include #else #include @@ -149,6 +158,59 @@ namespace SchemeFFI { #include "ffi/llvm.inc" #include "ffi/clock.inc" +// LLVM identifier patterns +namespace LLVMPatterns { + // Identifier + constexpr const char* IDENT = R"([-a-zA-Z$._][-a-zA-Z$._0-9]*)"; + // Type identifier + constexpr const char* TYPE_IDENT = R"([a-zA-Z_$][a-zA-Z0-9_$-]*)"; + // Start of line + @symbol + constexpr const char* AT_SYMBOL_START = R"(^@()"; + // Whitespace + @symbol + constexpr const char* AT_SYMBOL_REF = R"([ \t]@()"; + // %symbol + constexpr const char* PERCENT_SYMBOL = R"(%()"; +} + +// define ... @symbol_name +static std::regex sDefineSymRegex( + std::string(R"(define[^\n]+@()") + LLVMPatterns::IDENT + ")", + std::regex::optimize | std::regex::ECMAScript); + +// declare ... @symbol_name +static std::regex sDeclareSymRegex( + std::string(R"(declare[^\n]+@()") + LLVMPatterns::IDENT + ")", + std::regex::optimize | std::regex::ECMAScript); + +// @name = external global type +static std::regex sExternalGlobalRegex( + std::string(LLVMPatterns::AT_SYMBOL_START) + LLVMPatterns::IDENT + R"()\s*=\s*external\s+global\s+(\S+))", + std::regex::optimize | std::regex::multiline); + +// declare cc 0 return_type @func_name(params) [nounwind] +static std::regex sExternalDeclareRegex( + R"(^\s*declare\s+cc\s+0\s+([^@]+)\s+@([^(]+)\(([^)]*)\)(?:\s+nounwind)?\s*$)", + std::regex::optimize | std::regex::multiline); + +// whitespace followed by @symbol (for references in code) +static std::regex sGlobalSymRegex( + std::string(LLVMPatterns::AT_SYMBOL_REF) + LLVMPatterns::IDENT + ")", + std::regex::optimize); + +// @symbol = ... (global variable definitions) +static std::regex sGlobalVarDefRegex( + std::string(LLVMPatterns::AT_SYMBOL_START) + LLVMPatterns::IDENT + R"()\s*=)", + std::regex::optimize | std::regex::multiline); + +// %type_name = type ... +static std::regex sTypeDefRegex( + std::string(R"(^\s*(%[-a-zA-Z$._0-9]+)\s*=\s*type\s+(.+)$)"), + std::regex::multiline); + +// %name.123 (numbered type suffixes) +static std::regex sTypeSuffixRegex( + std::string(LLVMPatterns::PERCENT_SYMBOL) + LLVMPatterns::TYPE_IDENT + R"()\.[0-9]+)"); + void initSchemeFFI(scheme* sc) { static struct { @@ -196,21 +258,142 @@ static std::string SanitizeType(llvm::Type* Type) if (pos != std::string::npos) { str.erase(pos - 1); } + // Strip numeric suffixes from named types. + str = std::regex_replace(str, sTypeSuffixRegex, "%$1"); return str; } -static std::regex sGlobalSymRegex("[ \t]@([-a-zA-Z$._][-a-zA-Z$._0-9]*)", std::regex::optimize); -static std::regex sDefineSymRegex("define[^\\n]+@([-a-zA-Z$._][-a-zA-Z$._0-9]*)", std::regex::optimize | std::regex::ECMAScript); + +// Track user-defined type definitions for LLVM 21's opaque pointers. +// Each new type definition needs to be included in subsequent compilations. +static std::unordered_map sUserTypeDefs; +static std::mutex sUserTypeDefsMutex; + +// Track external global variables for declaration in subsequent compilations. +// Maps global name to its type string (e.g., "SAMPLE_RATE" -> "i32"). +static std::unordered_map sExternalGlobals; +static std::mutex sExternalGlobalsMutex; + +// Track external library function declarations (from bind-lib) for inclusion in subsequent compilations. +// Maps function name to its full declaration string (e.g., "sf_close" -> "declare i32 @sf_close(i8*)"). +static std::unordered_map sExternalLibFunctions; +static std::mutex sExternalLibFunctionsMutex; +static std::unordered_map sFuncDeclRegexCache; + +// Cache generated declaration strings to avoid regenerating them on every JIT compilation. +// Maps symbol name to its full declaration string. +static std::unordered_map sCachedDeclarations; +static std::mutex sCachedDeclarationsMutex; + +// Track built-in types from the base runtime (bitcode.ll) to avoid duplicate definitions. +static std::unordered_set sBuiltinTypes; + +// Get user type definitions, filtered to exclude those already in the IR. +static std::string getUserTypeDefsStringFiltered(const std::string& existingIR) { + std::lock_guard lock(sUserTypeDefsMutex); + std::string result; + for (const auto& kv : sUserTypeDefs) { + std::string typeDef = kv.first + " = type " + kv.second; + // Check if this type is already defined. + if (existingIR.find(typeDef) == std::string::npos) { + result += typeDef + "\n"; + } + } + return result; +} + +// Get external globals, filtered to exclude those already in the IR. +static std::string getExternalGlobalsStringFiltered(const std::string& existingIR) { + std::lock_guard lock(sExternalGlobalsMutex); + std::string result; + for (const auto& kv : sExternalGlobals) { + std::string globalDecl = "@" + kv.first + " = external global " + kv.second; + // Check if this global is already declared. + if (existingIR.find(globalDecl) == std::string::npos) { + result += globalDecl + "\n"; + } + } + return result; +} + +static void extractAndStoreExternalGlobals(const std::string& ir) { + std::lock_guard lock(sExternalGlobalsMutex); + std::sregex_iterator it(ir.begin(), ir.end(), sExternalGlobalRegex); + std::sregex_iterator end; + for (; it != end; ++it) { + std::string globalName = (*it)[1].str(); + std::string globalType = (*it)[2].str(); + sExternalGlobals[globalName] = globalType; + } +} + +static void extractAndStoreExternalLibFunctions(const std::string& ir) { + std::lock_guard lock(sExternalLibFunctionsMutex); + std::sregex_iterator it(ir.begin(), ir.end(), sExternalDeclareRegex); + std::sregex_iterator end; + for (; it != end; ++it) { + std::string returnType = (*it)[1].str(); + std::string funcName = (*it)[2].str(); + std::string params = (*it)[3].str(); + + // Reconstruct the full declaration (simplified form without calling convention). + std::string fullDecl = "declare " + returnType + " @" + funcName + "(" + params + ") nounwind\n"; + sExternalLibFunctions[funcName] = fullDecl; + } +} + +// Get external lib functions, filtered to exclude those already declared in the IR. +static std::string getExternalLibFunctionsStringFiltered(const std::string& existingIR) { + std::lock_guard lock(sExternalLibFunctionsMutex); + std::string result; + constexpr std::string_view kRegexSpecials = R"(.+*?^$[](){}|\\)"; + // Check if each function is already declared. + for (const auto& kv : sExternalLibFunctions) { + const std::string& funcName = kv.first; + // Escape special regex characters in function name. + std::string escapedName; + for (char c : funcName) { + if (kRegexSpecials.find(c) != std::string_view::npos) { + escapedName += '\\'; + } + escapedName += c; + } + // Check if the function is already declared. + auto cacheIt = sFuncDeclRegexCache.find(funcName); + if (cacheIt == sFuncDeclRegexCache.end()) { + cacheIt = sFuncDeclRegexCache.emplace( + funcName, + std::regex("declare\\s+(?:cc\\s+\\d+\\s+)?[^@]*@" + escapedName + "\\s*\\(", std::regex::optimize) + ).first; + } + if (!std::regex_search(existingIR, cacheIt->second)) { + result += kv.second; + } + } + return result; +} + +static void extractAndStoreTypeDefs(const std::string& ir) { + std::lock_guard lock(sUserTypeDefsMutex); + std::sregex_iterator it(ir.begin(), ir.end(), sTypeDefRegex); + std::sregex_iterator end; + for (; it != end; ++it) { + std::string typeName = (*it)[1].str(); + std::string typeDef = (*it)[2].str(); + // Store types not present in the base runtime. + if (sBuiltinTypes.find(typeName) == sBuiltinTypes.end()) { + sUserTypeDefs[typeName] = typeDef; + } + } +} static llvm::Module* jitCompile(const std::string& String) { // Create some module to put our function into it. using namespace llvm; - legacy::PassManager* PM = extemp::EXTLLVM::PM; - legacy::PassManager* PM_NO = extemp::EXTLLVM::PM_NO; char modname[256]; - sprintf(modname, "xtmmodule_%lld", ++llvm_emitcounter); + snprintf(modname, sizeof(modname), "xtmmodule_%lld", ++llvm_emitcounter); std::string asmcode(String); SMDiagnostic pa; @@ -235,8 +418,22 @@ static llvm::Module* jitCompile(const std::string& String) sInlineString = inString.str(); #endif } + // Collect symbol references. std::copy(std::sregex_token_iterator(sInlineString.begin(), sInlineString.end(), sGlobalSymRegex, 1), std::sregex_token_iterator(), std::inserter(sInlineSyms, sInlineSyms.begin())); + + // Collect global variable definitions. + std::copy(std::sregex_token_iterator(sInlineString.begin(), sInlineString.end(), sGlobalVarDefRegex, 1), + std::sregex_token_iterator(), std::inserter(sInlineSyms, sInlineSyms.begin())); + + // Extract built-in type names from base runtime to avoid duplicate definitions. + if (sBuiltinTypes.empty()) { + std::sregex_iterator it(sInlineString.begin(), sInlineString.end(), sTypeDefRegex); + std::sregex_iterator end; + for (; it != end; ++it) { + sBuiltinTypes.insert((*it)[1].str()); + } + } { #ifdef DYLIB auto data = fs.open("runtime/inline.ll"); @@ -249,117 +446,254 @@ static llvm::Module* jitCompile(const std::string& String) #endif std::copy(std::sregex_token_iterator(tString.begin(), tString.end(), sGlobalSymRegex, 1), std::sregex_token_iterator(), std::inserter(sInlineSyms, sInlineSyms.begin())); + std::copy(std::sregex_token_iterator(tString.begin(), tString.end(), sGlobalVarDefRegex, 1), + std::sregex_token_iterator(), std::inserter(sInlineSyms, sInlineSyms.begin())); } } - if (sInlineBitcode.empty()) { - // need to avoid parsing the types twice - static bool first(true); - if (!first) { - auto newModule(parseAssemblyString(sInlineString, pa, getGlobalContext())); - if (newModule) { - std::string bitcode; - llvm::raw_string_ostream bitstream(sInlineBitcode); - llvm::WriteBitcodeToFile(newModule.get(), bitstream); -#ifdef DYLIB - auto data = fs.open("runtime/inline.ll"); - sInlineString = std::string(data.begin(), data.end()); -#else - std::ifstream inStream(UNIV::SHARE_DIR + "/runtime/inline.ll"); - std::stringstream inString; - inString << inStream.rdbuf(); - sInlineString = inString.str(); -#endif - } else { -std::cout << pa.getMessage().str() << std::endl; - abort(); - } - } else { - first = false; - } - } - std::unique_ptr newModule; + + // Detect if this is a bind-lib declaration. + // These should not have external lib functions prepended, to avoid duplicates. + bool isBindLibDeclaration = (asmcode.find("declare") == 0 && asmcode.size() < 500); + + // Build declarations string. std::vector symbols; std::copy(std::sregex_token_iterator(asmcode.begin(), asmcode.end(), sGlobalSymRegex, 1), std::sregex_token_iterator(), std::inserter(symbols, symbols.begin())); std::sort(symbols.begin(), symbols.end()); auto end(std::unique(symbols.begin(), symbols.end())); std::unordered_set ignoreSyms; + + // Ignore symbols defined as functions. std::copy(std::sregex_token_iterator(asmcode.begin(), asmcode.end(), sDefineSymRegex, 1), std::sregex_token_iterator(), std::inserter(ignoreSyms, ignoreSyms.begin())); + + // Ignore already declared symbols. + std::copy(std::sregex_token_iterator(asmcode.begin(), asmcode.end(), sDeclareSymRegex, 1), + std::sregex_token_iterator(), std::inserter(ignoreSyms, ignoreSyms.begin())); + + // Ignore symbols defined/declared as global variables. + std::copy(std::sregex_token_iterator(asmcode.begin(), asmcode.end(), sGlobalVarDefRegex, 1), + std::sregex_token_iterator(), std::inserter(ignoreSyms, ignoreSyms.begin())); std::string declarations; llvm::raw_string_ostream dstream(declarations); for (auto iter = symbols.begin(); iter != end; ++iter) { const char* sym(iter->c_str()); + // Skip symbols in sInlineSyms or ignoreSyms. if (sInlineSyms.find(sym) != sInlineSyms.end() || ignoreSyms.find(sym) != ignoreSyms.end()) { continue; } + // Skip symbols already in sExternalGlobals. + { + std::lock_guard lock(sExternalGlobalsMutex); + if (sExternalGlobals.find(sym) != sExternalGlobals.end()) { + continue; + } + } + // Skip symbols already in sExternalLibFunctions, unless this is a bind-lib declaration. + if (!isBindLibDeclaration) { + std::lock_guard lock(sExternalLibFunctionsMutex); + if (sExternalLibFunctions.find(sym) != sExternalLibFunctions.end()) { + continue; + } + } + + // Check if we've already cached this declaration. + { + std::lock_guard lock(sCachedDeclarationsMutex); + auto cachedIter = sCachedDeclarations.find(sym); + if (cachedIter != sCachedDeclarations.end()) { + dstream << cachedIter->second; + continue; + } + } + auto gv = extemp::EXTLLVM::getGlobalValue(sym); if (!gv) { continue; } + + std::string decl; auto func(llvm::dyn_cast(gv)); if (func) { - dstream << "declare " << SanitizeType(func->getReturnType()) << " @" << sym << " ("; + llvm::raw_string_ostream declStream(decl); + declStream << "declare " << SanitizeType(func->getReturnType()) << " @" << sym << " ("; bool first(true); - for (const auto& arg : func->getArgumentList()) { + for (const auto& arg : func->args()) { if (!first) { - dstream << ", "; + declStream << ", "; } else { first = false; } - dstream << SanitizeType(arg.getType()); + declStream << SanitizeType(arg.getType()); } if (func->isVarArg()) { - dstream << ", ..."; + declStream << ", ..."; } - dstream << ")\n"; + declStream << ")\n"; + decl = declStream.str(); } else { - auto str(SanitizeType(gv->getType())); - dstream << '@' << sym << " = external global " << str.substr(0, str.length() - 1) << '\n'; + auto globalVar = llvm::dyn_cast(gv); + if (globalVar) { + auto str(SanitizeType(globalVar->getValueType())); + decl = "@" + std::string(sym) + " = external global " + str + "\n"; + } else { + decl = "@" + std::string(sym) + " = external global ptr\n"; + } } + + // Cache the declaration for future use. + { + std::lock_guard lock(sCachedDeclarationsMutex); + sCachedDeclarations[sym] = decl; + } + dstream << decl; } -// std::cout << "**** DECL ****\n" << dstream.str() << "**** ENDDECL ****\n" << std::endl; - if (!sInlineBitcode.empty()) { - auto modOrErr(parseBitcodeFile(llvm::MemoryBufferRef(sInlineBitcode, ""), getGlobalContext())); - if (likely(modOrErr)) { - newModule = std::move(modOrErr.get()); - asmcode = sInlineString + dstream.str() + asmcode; - if (parseAssemblyInto(llvm::MemoryBufferRef(asmcode, ""), *newModule, pa)) { -std::cout << "**** DECL ****\n" << dstream.str() << "**** ENDDECL ****\n" << std::endl; - newModule.reset(); + + llvm::Module* modulePtr = nullptr; + + EXTLLVM::getThreadSafeContext().withContextDo([&](LLVMContext* ctx) { + // Initialize inline bitcode. + if (sInlineBitcode.empty()) { + static bool first(true); + if (!first) { + auto newModule(parseAssemblyString(sInlineString, pa, *ctx)); + if (newModule) { + llvm::raw_string_ostream bitstream(sInlineBitcode); + llvm::WriteBitcodeToFile(*newModule, bitstream); +#ifdef DYLIB + auto data = fs.open("runtime/inline.ll"); + sInlineString = std::string(data.begin(), data.end()); +#else + std::ifstream inStream(UNIV::SHARE_DIR + "/runtime/inline.ll"); + std::stringstream inString; + inString << inStream.rdbuf(); + sInlineString = inString.str(); +#endif + } else { + std::cout << pa.getMessage().str() << std::endl; + abort(); + } + } else { + first = false; } } - } else { - newModule = parseAssemblyString(asmcode, pa, getGlobalContext()); - } - if (newModule) { + + std::unique_ptr newModule; + + // Get user-defined type definitions and external globals. + std::string userTypeDefs = getUserTypeDefsStringFiltered(asmcode); + std::string externalGlobals = getExternalGlobalsStringFiltered(asmcode); + + if (!sInlineBitcode.empty()) { + auto modOrErr(parseBitcodeFile(llvm::MemoryBufferRef(sInlineBitcode, ""), *ctx)); + if (likely(modOrErr)) { + newModule = std::move(modOrErr.get()); + std::string externalLibFunctions = isBindLibDeclaration ? "" : + getExternalLibFunctionsStringFiltered(asmcode); + asmcode = sInlineString + userTypeDefs + externalGlobals + externalLibFunctions + dstream.str() + asmcode; + if (parseAssemblyInto(llvm::MemoryBufferRef(asmcode, ""), newModule.get(), nullptr, pa)) { + std::cout << "**** DECL ****\n" << dstream.str() << "**** ENDDECL ****\n" << std::endl; + newModule.reset(); + } + } + } else { + // First compilation - include user type definitions and external lib functions. + std::string externalLibFunctions = getExternalLibFunctionsStringFiltered(asmcode); + asmcode = userTypeDefs + externalLibFunctions + asmcode; + newModule = parseAssemblyString(asmcode, pa, *ctx); + } + + if (!newModule) { + std::string errstr; + llvm::raw_string_ostream ss(errstr); + pa.print("LLVM IR", ss); + printf("%s\n", ss.str().c_str()); + return; + } + + // Extract and store any new type definitions. + extractAndStoreTypeDefs(String); + + // Extract and store external global declarations. + extractAndStoreExternalGlobals(String); + + // Extract and store external library function declarations. + extractAndStoreExternalLibFunctions(String); + + // Set target triple. if (unlikely(!extemp::UNIV::ARCH.empty())) { - newModule->setTargetTriple(extemp::UNIV::ARCH); + newModule->setTargetTriple(llvm::Triple(extemp::UNIV::ARCH)); } + + // Optimize if (EXTLLVM::OPTIMIZE_COMPILES) { - PM->run(*newModule); - } else { - PM_NO->run(*newModule); + llvm::LoopAnalysisManager LAM; + llvm::FunctionAnalysisManager FAM; + llvm::CGSCCAnalysisManager CGAM; + llvm::ModuleAnalysisManager MAM; + + llvm::PassBuilder PB; + PB.registerModuleAnalyses(MAM); + PB.registerCGSCCAnalyses(CGAM); + PB.registerFunctionAnalyses(FAM); + PB.registerLoopAnalyses(LAM); + PB.crossRegisterProxies(LAM, FAM, CGAM, MAM); + + // Use configurable optimization level. + llvm::OptimizationLevel optLevel; + switch (EXTLLVM::OPTIMIZATION_LEVEL) { + case 0: optLevel = llvm::OptimizationLevel::O0; break; + case 1: optLevel = llvm::OptimizationLevel::O1; break; + case 3: optLevel = llvm::OptimizationLevel::O3; break; + case 2: + default: optLevel = llvm::OptimizationLevel::O2; break; + } + llvm::ModulePassManager MPM = PB.buildPerModuleDefaultPipeline(optLevel); + MPM.run(*newModule, MAM); } - } - //std::stringstream ss; - if (unlikely(!newModule)) - { -// std::cout << "**** CODE ****\n" << asmcode << " **** ENDCODE ****" << std::endl; -// std::cout << pa.getMessage().str() << std::endl << pa.getLineNo() << std::endl; - std::string errstr; - llvm::raw_string_ostream ss(errstr); - pa.print("LLVM IR",ss); - printf("%s\n",ss.str().c_str()); - return nullptr; - } else if (extemp::EXTLLVM::VERIFY_COMPILES && verifyModule(*newModule)) { + + // Verify the module. + if (extemp::EXTLLVM::VERIFY_COMPILES && verifyModule(*newModule)) { std::cout << "\nInvalid LLVM IR\n"; - return nullptr; - } + return; + } + + modulePtr = newModule.get(); + + // Extract symbol names from the module. + std::vector symbolNames; + + for (const auto& func : newModule->getFunctionList()) { + if (!func.isDeclaration()) { + symbolNames.push_back(func.getName().str()); + } + } + for (const auto& glob : newModule->globals()) { + if (!glob.isDeclaration()) { + symbolNames.push_back(glob.getName().str()); + } + } + + // Clone the module for metadata. + auto metadataModule = llvm::CloneModule(*newModule); + + // Add module to ORC JIT with symbol tracking. + auto TSM = llvm::orc::ThreadSafeModule(std::move(newModule), EXTLLVM::getThreadSafeContext()); + auto err = EXTLLVM::addTrackedModule(std::move(TSM), symbolNames); + + // Register cloned module metadata. + if (err) { + std::cerr << "Failed to add module to JIT: " + << llvm::toString(std::move(err)) << std::endl; + modulePtr = nullptr; + } else { + modulePtr = metadataModule.get(); + EXTLLVM::addModule(metadataModule.get()); + // Transfer ownership to Ms vector. + metadataModule.release(); + } + }); - llvm::Module *modulePtr = newModule.get(); - extemp::EXTLLVM::EE->addModule(std::move(newModule)); - extemp::EXTLLVM::EE->finalizeObject(); return modulePtr; } diff --git a/src/ffi/llvm.inc b/src/ffi/llvm.inc index abd7f3b57..ee1d5e47e 100644 --- a/src/ffi/llvm.inc +++ b/src/ffi/llvm.inc @@ -1,7 +1,23 @@ static pointer optimizeCompiles(scheme* Scheme, pointer Args) { + if (Args == Scheme->NIL) { + return EXTLLVM::OPTIMIZE_COMPILES ? Scheme->T : Scheme->F; + } EXTLLVM::OPTIMIZE_COMPILES = (pair_car(Args) == Scheme->T); - return Scheme->T; + return EXTLLVM::OPTIMIZE_COMPILES ? Scheme->T : Scheme->F; +} + +static pointer optimizationLevel(scheme* Scheme, pointer Args) +{ + if (Args == Scheme->NIL) { + return mk_integer(Scheme, EXTLLVM::OPTIMIZATION_LEVEL); + } + // Set optimization level (0-3) + int level = ivalue(pair_car(Args)); + if (level < 0) level = 0; + if (level > 3) level = 3; + EXTLLVM::OPTIMIZATION_LEVEL = level; + return mk_integer(Scheme, level); } static pointer jitCompileIRString(scheme* Scheme, pointer Args) @@ -10,7 +26,6 @@ static pointer jitCompileIRString(scheme* Scheme, pointer Args) if (!modulePtr) { return Scheme->F; } - extemp::EXTLLVM::addModule(modulePtr); return mk_cptr(Scheme, modulePtr); } @@ -54,39 +69,47 @@ static pointer get_struct_size(scheme* Scheme, pointer Args) char* struct_type_str = string_value(pair_car(Args)); unsigned long long hash = string_hash(struct_type_str); char name[128]; - sprintf(name,"_xtmT%lld",hash); + snprintf(name, sizeof(name), "_xtmT%llu", hash); char assm[1024]; - sprintf(assm,"%%%s = type %s",name,struct_type_str); + snprintf(assm, sizeof(assm), "%%%s = type %s", name, struct_type_str); + long size = -1; + EXTLLVM::getThreadSafeContext().withContextDo([&](llvm::LLVMContext* ctx) { llvm::SMDiagnostic pa; - auto newM(llvm::parseAssemblyString(assm, pa, llvm::getGlobalContext())); + auto newM(llvm::parseAssemblyString(assm, pa, *ctx)); if (!newM) { - return Scheme->F; + return; } - auto type(newM->getTypeByName(name)); + auto type(llvm::StructType::getTypeByName(*ctx, name)); if (!type) { + return; + } + const auto& layout = newM->getDataLayout(); + size = layout.getStructLayout(type)->getSizeInBytes(); + }); + + if (size < 0) { return Scheme->F; } - auto layout(new llvm::DataLayout(newM.get())); - long size = layout->getStructLayout(type)->getSizeInBytes(); - delete layout; return mk_integer(Scheme, size); } static llvm::StructType* getNamedType(const char* name) { - return EXTLLVM::M->getTypeByName(name); + llvm::StructType* result = nullptr; + EXTLLVM::getThreadSafeContext().withContextDo([&](llvm::LLVMContext* ctx) { + result = llvm::StructType::getTypeByName(*ctx, name); + }); + return result; } static pointer get_named_struct_size(scheme* Scheme, pointer Args) { - llvm::Module* M = EXTLLVM::M; auto type(getNamedType(string_value(pair_car(Args)))); if (!type) { return Scheme->F; } - auto layout(new llvm::DataLayout(M)); - long size = layout->getStructLayout(type)->getSizeInBytes(); - delete layout; + auto& DL = EXTLLVM::JIT->getDataLayout(); + long size = DL.getStructLayout(type)->getSizeInBytes(); return mk_integer(Scheme, size); } @@ -110,7 +133,7 @@ static pointer get_function_args(scheme* Scheme, pointer Args) } pointer str = mk_string(Scheme, tmp_name); pointer p = cons(Scheme, str, Scheme->NIL); - for (const auto& arg : func->getArgumentList()) { + for (const auto& arg : func->args()) { { EnvInjector injector(Scheme, p); std::string typestr2; @@ -171,53 +194,41 @@ static pointer get_global_variable_type(scheme* Scheme, pointer Args) static pointer get_function_pointer(scheme* Scheme, pointer Args) { auto name(string_value(pair_car(Args))); - void* p = EXTLLVM::EE->getPointerToGlobalIfAvailable(name); - if (!p) { // look for it as a JIT-compiled function - p = reinterpret_cast(EXTLLVM::EE->getFunctionAddress(name)); - if (!p) { + auto addr = EXTLLVM::getFunctionAddress(name); + if (!addr) { return Scheme->F; - } } - return mk_cptr(Scheme, p); + return mk_cptr(Scheme, reinterpret_cast(addr)); } static pointer remove_function(scheme* Scheme, pointer Args) { - auto func(EXTLLVM::EE->FindFunctionNamed(string_value(pair_car(Args)))); - if (!func) { - return Scheme->F; - } - if (func->mayBeOverridden()) { - func->dropAllReferences(); - func->removeFromParent(); + const char* name = string_value(pair_car(Args)); + if (EXTLLVM::removeSymbol(name)) { + EXTLLVM::removeFromGlobalMap(name); return Scheme->T; } - printf("Cannot remove function with dependencies\n"); return Scheme->F; } static pointer remove_global_var(scheme* Scheme, pointer Args) { - auto var(EXTLLVM::EE->FindGlobalVariableNamed(string_value(pair_car(Args)))); - if (!var) { - return Scheme->F; - } - var->dropAllReferences(); - var->removeFromParent(); + const char* name = string_value(pair_car(Args)); + if (EXTLLVM::removeSymbol(name)) { + EXTLLVM::removeFromGlobalMap(name); return Scheme->T; + } + return Scheme->F; } static pointer erase_function(scheme* Scheme, pointer Args) { - auto func(EXTLLVM::EE->FindFunctionNamed(string_value(pair_car(Args)))); - if (!func) { - return Scheme->F; - } - func->dropAllReferences(); - func->removeFromParent(); - //func->deleteBody(); - //func->eraseFromParent(); + const char* name = string_value(pair_car(Args)); + if (EXTLLVM::removeSymbol(name)) { + EXTLLVM::removeFromGlobalMap(name); return Scheme->T; + } + return Scheme->F; } static pointer llvm_call_void_native(scheme* Scheme, pointer Args) @@ -225,91 +236,222 @@ static pointer llvm_call_void_native(scheme* Scheme, pointer Args) char name[1024]; strcpy(name, string_value(pair_car(Args))); strcat(name, "_native"); - auto func(EXTLLVM::EE->FindFunctionNamed(string_value(pair_car(Args)))); - if (!func) { + + auto addr = EXTLLVM::getFunctionAddress(name); + if (!addr) { + addr = EXTLLVM::getFunctionAddress(string_value(pair_car(Args))); + if (!addr) { return Scheme->F; } - void* p = EXTLLVM::EE->getPointerToFunction(func); - if (!p) { - return Scheme->F; } - ((void(*)(void)) p)(); + auto p = reinterpret_cast(addr); + p(); return Scheme->T; } +static std::atomic CALL_STUB_COUNTER{0}; + static pointer call_compiled(scheme* Scheme, pointer Args) { - llvm::ExecutionEngine* EE = EXTLLVM::EE; -#ifdef LLVM_EE_LOCK - llvm::MutexGuard locked(EE->lock); -#endif - auto func(reinterpret_cast(cptr_value(pair_car(Args)))); + auto func = reinterpret_cast(cptr_value(pair_car(Args))); if (unlikely(!func)) { printf("No such function\n"); return Scheme->F; } - func->getArgumentList(); + + auto funcType = func->getFunctionType(); Args = pair_cdr(Args); + unsigned lgth = list_length(Scheme, Args); - if (unlikely(lgth != func->getArgumentList().size())) { + if (unlikely(lgth != funcType->getNumParams())) { printf("Wrong number of arguments for function!\n"); return Scheme->F; } - int i = 0; - std::vector fargs; - fargs.reserve(lgth); - for (const auto& arg : func->getArgumentList()) { - pointer p = car(Args); - Args = cdr(Args); - if (is_integer(p)) { - if (unlikely(arg.getType()->getTypeID() != llvm::Type::IntegerTyID)) { - printf("Bad argument type %i\n",i); + + if (!extemp::EXTLLVM::JIT) { + printf("LLVM JIT not initialized\n"); + return Scheme->F; + } + + // Resolve the compiled function address. + std::string name = func->getName().str(); + auto addr = EXTLLVM::getFunctionAddress(name); + if (!addr) { + addr = EXTLLVM::getFunctionAddress(name + "_native"); + if (!addr) { + return Scheme->F; + } + } + + // Marshal arguments into raw values. + struct ArgValue { + enum Kind { Int, Float, Double, Ptr } kind; + llvm::Type* ty; + uint64_t intVal; + double doubleVal; + float floatVal; + void* ptrVal; + }; + + std::vector argValues; + argValues.reserve(lgth); + + pointer argList = Args; + for (unsigned i = 0; i < lgth; ++i) { + auto argTy = funcType->getParamType(i); + pointer p = car(argList); + argList = cdr(argList); + + switch (argTy->getTypeID()) { + case llvm::Type::IntegerTyID: { + if (unlikely(!is_integer(p))) { + printf("Bad argument type %u\n", i); return Scheme->F; } - int width = arg.getType()->getPrimitiveSizeInBits(); - fargs[i].IntVal = llvm::APInt(width, ivalue(p)); - } else if (is_real(p)) { - if (arg.getType()->getTypeID() == llvm::Type::FloatTyID) { - fargs[i].FloatVal = rvalue(p); - } else if (arg.getType()->getTypeID() == llvm::Type::DoubleTyID) { - fargs[i].DoubleVal = rvalue(p); - } else { - printf("Bad argument type %i\n",i); + argValues.push_back({ArgValue::Int, argTy, static_cast(ivalue(p)), 0.0, 0.0f, nullptr}); + break; + } + case llvm::Type::FloatTyID: { + if (unlikely(!is_real(p))) { + printf("Bad argument type %u\n", i); return Scheme->F; } - } else if (is_string(p)) { - if (unlikely(arg.getType()->getTypeID() != llvm::Type::PointerTyID)) { - printf("Bad argument type %i\n",i); + float f = static_cast(rvalue(p)); + argValues.push_back({ArgValue::Float, argTy, 0u, 0.0, f, nullptr}); + break; + } + case llvm::Type::DoubleTyID: { + if (unlikely(!is_real(p))) { + printf("Bad argument type %u\n", i); return Scheme->F; } - fargs[i].PointerVal = string_value(p); - } else if (is_cptr(p)) { - if (unlikely(arg.getType()->getTypeID() != llvm::Type::PointerTyID)) { - printf("Bad argument type %i\n",i); + argValues.push_back({ArgValue::Double, argTy, 0u, rvalue(p), 0.0f, nullptr}); + break; + } + case llvm::Type::PointerTyID: { + void* rawPtr = nullptr; + if (is_string(p)) { + rawPtr = static_cast(string_value(p)); + } else if (is_cptr(p)) { + rawPtr = cptr_value(p); + } else { + printf("Bad argument type %u\n", i); return Scheme->F; } - fargs[i].PointerVal = cptr_value(p); - } else if (unlikely(is_closure(p))) { - printf("Bad argument at index %i you can't pass in a scheme closure.\n",i); + argValues.push_back({ArgValue::Ptr, argTy, 0u, 0.0, 0.0f, rawPtr}); + break; + } + default: + printf("Unsupported argument type at index %u\n", i); return Scheme->F; + } + } + + const auto& DL = extemp::EXTLLVM::JIT->getDataLayout(); + std::string stubName = "__extemp_call_stub_" + std::to_string(CALL_STUB_COUNTER.fetch_add(1)); + std::unique_ptr module; + + // Build a tiny stub inside the thread-safe context. + extemp::EXTLLVM::getThreadSafeContext().withContextDo([&](llvm::LLVMContext* ctx) { + auto ptrIntTy = llvm::Type::getIntNTy(*ctx, DL.getPointerSizeInBits()); + + std::vector argConsts; + argConsts.reserve(lgth); + + for (const auto& av : argValues) { + switch (av.kind) { + case ArgValue::Int: + argConsts.push_back(llvm::ConstantInt::get(av.ty, av.intVal)); + break; + case ArgValue::Float: + argConsts.push_back(llvm::ConstantFP::get(av.ty, av.floatVal)); + break; + case ArgValue::Double: + argConsts.push_back(llvm::ConstantFP::get(av.ty, av.doubleVal)); + break; + case ArgValue::Ptr: { + auto ptrAsInt = llvm::ConstantInt::get(ptrIntTy, reinterpret_cast(av.ptrVal)); + argConsts.push_back(llvm::ConstantExpr::getIntToPtr(ptrAsInt, av.ty)); + break; + } + } + } + + module = std::make_unique(stubName + "_module", *ctx); + module->setDataLayout(DL); + + auto stubType = llvm::FunctionType::get(funcType->getReturnType(), false); + auto stubFunc = llvm::Function::Create(stubType, llvm::Function::ExternalLinkage, stubName, module.get()); + stubFunc->setCallingConv(func->getCallingConv()); + + auto entryBB = llvm::BasicBlock::Create(*ctx, "entry", stubFunc); + llvm::IRBuilder<> builder(entryBB); + + auto targetAddrConst = llvm::ConstantInt::get(ptrIntTy, addr); + auto targetPtr = llvm::ConstantExpr::getIntToPtr(targetAddrConst, funcType->getPointerTo()); + llvm::FunctionCallee callee(funcType, targetPtr); + + auto callInst = builder.CreateCall(callee, argConsts); + callInst->setCallingConv(func->getCallingConv()); + + if (funcType->getReturnType()->isVoidTy()) { + builder.CreateRetVoid(); } else { - printf("Bad argument at index %i\n",i); - return Scheme->F; + builder.CreateRet(callInst); } + }); + + if (!module) { + return Scheme->F; + } + + // JIT the stub + auto TSM = llvm::orc::ThreadSafeModule(std::move(module), extemp::EXTLLVM::getThreadSafeContext()); + if (auto err = extemp::EXTLLVM::addTrackedModule(std::move(TSM), {stubName})) { + std::cerr << "Failed to JIT call stub: " << llvm::toString(std::move(err)) << std::endl; + return Scheme->F; + } + + auto stubAddr = EXTLLVM::getFunctionAddress(stubName); + if (!stubAddr) { + printf("Failed to resolve call stub\n"); + return Scheme->F; } - llvm::GenericValue gv = EE->runFunction(func, fargs); - switch(func->getReturnType()->getTypeID()) { - case llvm::Type::FloatTyID: - return mk_real(Scheme, gv.FloatVal); - case llvm::Type::DoubleTyID: - return mk_real(Scheme, gv.DoubleVal); - case llvm::Type::IntegerTyID: - return mk_integer(Scheme, gv.IntVal.getZExtValue()); // getRawData()); - case llvm::Type::PointerTyID: - return mk_cptr(Scheme, gv.PointerVal); - case llvm::Type::VoidTyID: + + // Call the stub and marshal the result back to Scheme. + auto retTy = funcType->getReturnType(); + switch (retTy->getTypeID()) { + case llvm::Type::FloatTyID: { + using StubFn = float(*)(); + float res = reinterpret_cast(stubAddr)(); + return mk_real(Scheme, res); + } + case llvm::Type::DoubleTyID: { + using StubFn = double(*)(); + double res = reinterpret_cast(stubAddr)(); + return mk_real(Scheme, res); + } + case llvm::Type::IntegerTyID: { + auto intTy = llvm::cast(retTy); + unsigned width = intTy->getBitWidth(); + uint64_t mask = (width >= 64) ? ~uint64_t(0) : ((uint64_t(1) << width) - 1); + + using StubFn = uint64_t(*)(); + uint64_t res = reinterpret_cast(stubAddr)() & mask; + return mk_integer(Scheme, res); + } + case llvm::Type::PointerTyID: { + using StubFn = void*(*)(); + void* res = reinterpret_cast(stubAddr)(); + return mk_cptr(Scheme, res); + } + case llvm::Type::VoidTyID: { + using StubFn = void(*)(); + reinterpret_cast(stubAddr)(); return Scheme->T; + } default: + printf("Unsupported return type for compiled call\n"); return Scheme->F; } } @@ -320,7 +462,7 @@ static pointer llvm_convert_float_constant(scheme* Scheme, pointer Args) if (floatin[1] == 'x') { return pair_car(Args); } - llvm::APFloat apf(llvm::APFloat::IEEEsingle, llvm::StringRef(floatin)); + llvm::APFloat apf(llvm::APFloat::IEEEsingle(), llvm::StringRef(floatin)); // TODO: if necessary, checks for inf/nan can be done here auto ival(llvm::APInt::doubleToBits(apf.convertToFloat())); return mk_string(Scheme, (std::string("0x") + llvm::utohexstr(ival.getLimitedValue(), true)).c_str()); @@ -333,7 +475,7 @@ static pointer llvm_convert_double_constant(scheme* Scheme, pointer Args) if (floatin[1] == 'x') { return pair_car(Args); } - llvm::APFloat apf(llvm::APFloat::IEEEdouble, llvm::StringRef(floatin)); + llvm::APFloat apf(llvm::APFloat::IEEEdouble(), llvm::StringRef(floatin)); // TODO: if necessary, checks for inf/nan can be done here auto ival(llvm::APInt::doubleToBits(apf.convertToFloat())); return mk_string(Scheme, (std::string("0x") + llvm::utohexstr(ival.getLimitedValue(), true)).c_str()); @@ -376,7 +518,10 @@ static pointer printLLVMModule(scheme* Scheme, pointer Args) // TODO: This isn't ss << *val; printf("At address: %p\n%s\n",val, ss.str().c_str()); } else { - ss << *extemp::EXTLLVM::M; + // Print all modules. + for (auto module : EXTLLVM::getModules()) { + ss << *module; + } } printf("%s", ss.str().c_str()); return Scheme->T; @@ -475,20 +620,35 @@ static pointer llvm_disasm(scheme* Scheme, pointer Args) return mk_string(Scheme, extemp::EXTLLVM::llvm_disassemble(fptr, syntax)); } +static void registerJITSymbol(const char* name, void* addr) { + if (!EXTLLVM::JIT) return; + auto& ES = EXTLLVM::JIT->getExecutionSession(); + auto& JD = EXTLLVM::JIT->getMainJITDylib(); + + llvm::orc::SymbolMap Symbols; + Symbols[ES.intern(name)] = { + llvm::orc::ExecutorAddr::fromPtr(addr), + llvm::JITSymbolFlags::Exported + }; + + auto err = JD.define(llvm::orc::absoluteSymbols(std::move(Symbols))); + if (err) { + llvm::consumeError(std::move(err)); + } +} + static pointer bind_symbol(scheme* Scheme, pointer Args) { auto library(cptr_value(pair_car(Args))); auto sym(string_value(pair_cadr(Args))); - llvm::ExecutionEngine* EE = EXTLLVM::EE; - llvm::MutexGuard locked(EE->lock); #ifdef _WIN32 auto ptr(reinterpret_cast(GetProcAddress(reinterpret_cast(library), sym))); #else auto ptr(dlsym(library, sym)); #endif if (likely(ptr)) { - EE->updateGlobalMapping(sym, reinterpret_cast(ptr)); + registerJITSymbol(sym, ptr); return Scheme->T; } return Scheme->F; @@ -498,11 +658,14 @@ static pointer update_mapping(scheme* Scheme, pointer Args) { auto sym(string_value(pair_car(Args))); auto ptr(cptr_value(pair_cadr(Args))); - llvm::ExecutionEngine* EE = EXTLLVM::EE; - llvm::MutexGuard locked(EE->lock); - // returns previous value of the mapping, or NULL if not set - auto oldval(EE->updateGlobalMapping(sym, reinterpret_cast(ptr))); - return mk_cptr(Scheme, reinterpret_cast(oldval)); + + // Extempore doesn't track arbitrary symbol addresses under ORC. + // Return 0 for "old". + uint64_t oldaddr = 0; + + registerJITSymbol(sym, ptr); + + return mk_cptr(Scheme, reinterpret_cast(oldaddr)); } static std::unordered_map LLVM_ALIAS_TABLE; @@ -548,13 +711,15 @@ static pointer get_named_type(scheme* Scheme, pointer Args) return Scheme->NIL; } -static pointer get_global_module(scheme* Scheme, pointer Args) +static pointer list_modules(scheme* Scheme, pointer Args) { - auto m(EXTLLVM::M); - if (!m) { - return Scheme->F; + pointer p = Scheme->NIL; + + for (auto module : EXTLLVM::getModules()) { + EnvInjector injector(Scheme, p); + p = cons(Scheme, mk_cptr(Scheme, module), p); } - return mk_cptr(Scheme, m); + return reverse_in_place(Scheme, Scheme->NIL, p); } static pointer export_llvmmodule_bitcode(scheme* Scheme, pointer Args) @@ -590,18 +755,19 @@ static pointer export_llvmmodule_bitcode(scheme* Scheme, pointer Args) fout.close(); #else std::error_code errcode; - llvm::raw_fd_ostream ss(filename, errcode, llvm::sys::fs::F_RW); + llvm::raw_fd_ostream ss(filename, errcode, llvm::sys::fs::OF_None); if (errcode) { std::cout << errcode.message() << std::endl; return Scheme->F; } - llvm::WriteBitcodeToFile(m,ss); + llvm::WriteBitcodeToFile(*m, ss); #endif return Scheme->T; } #define LLVM_DEFS \ { "llvm:optimize", &optimizeCompiles }, \ + { "llvm:optimization-level", &optimizationLevel }, \ { "llvm:jit-compile-ir-string", &jitCompileIRString}, \ { "llvm:ffi-set-name", &ff_set_name }, \ { "llvm:ffi-get-name", &ff_get_name }, \ @@ -622,6 +788,7 @@ static pointer export_llvmmodule_bitcode(scheme* Scheme, pointer Args) { "llvm:run", &call_compiled }, \ { "llvm:convert-float", &llvm_convert_float_constant }, \ { "llvm:convert-double", &llvm_convert_double_constant }, \ + { "llvm:list-modules", &list_modules }, \ { "llvm:count", &llvm_count }, \ { "llvm:count-set", &llvm_count_set }, \ { "llvm:count++", &llvm_count_inc }, \ @@ -637,5 +804,4 @@ static pointer export_llvmmodule_bitcode(scheme* Scheme, pointer Args) { "llvm:add-llvm-alias", &add_llvm_alias }, \ { "llvm:get-llvm-alias", &get_llvm_alias }, \ { "llvm:get-named-type", &get_named_type }, \ - { "llvm:get-global-module", &get_global_module }, \ { "llvm:export-module", &export_llvmmodule_bitcode } diff --git a/src/ffi/sys.inc b/src/ffi/sys.inc index 56ca67388..a83fc87a6 100644 --- a/src/ffi/sys.inc +++ b/src/ffi/sys.inc @@ -133,16 +133,16 @@ static pointer dirlist(scheme* Scheme, pointer Args) { #ifdef _WIN32 char* path = string_value(pair_car(Args)); - std::experimental::filesystem::path bpath(path); - if (!std::experimental::filesystem::exists(bpath)) { + std::filesystem::path bpath(path); + if (!std::filesystem::exists(bpath)) { return Scheme->NIL; } - if (!std::experimental::filesystem::is_directory(bpath)) { + if (!std::filesystem::is_directory(bpath)) { return Scheme->NIL; } - std::experimental::filesystem::directory_iterator end_it; + std::filesystem::directory_iterator end_it; pointer list = Scheme->NIL; - for (std::experimental::filesystem::directory_iterator it(bpath); it != end_it; ++it) { + for (std::filesystem::directory_iterator it(bpath); it != end_it; ++it) { EnvInjector injector(Scheme, list); pointer tlist = cons(Scheme, mk_string(Scheme, it->path().string().c_str()), list); list = tlist; diff --git a/src/shims/__hash_memory.cpp b/src/shims/__hash_memory.cpp new file mode 100644 index 000000000..daa515190 --- /dev/null +++ b/src/shims/__hash_memory.cpp @@ -0,0 +1,57 @@ +// hash_compat.cpp - Compatibility shim for libc++ ABI differences +// +// When LLVM is built with a different version of libc++ than the host compiler, +// the __hash_memory symbol may not be found. This provides the implementation. + +#include +#include + +// Only needed on Apple platforms where libc++ ABI version can differ +#if defined(__APPLE__) + +namespace std { +inline namespace __1 { + +// MurmurHash2 implementation matching libc++'s __hash_memory +// Marked weak so a libc++ that already exports this symbol wins. +__attribute__((visibility("default"), weak)) +size_t __hash_memory(const void* ptr, size_t len) noexcept { + static_assert(__SIZE_WIDTH__ == 64, "__hash_memory only needed on 64-bit macOS"); + const size_t m = 0xc6a4a7935bd1e995ULL; + const int r = 47; + size_t h = len * m; + const unsigned char* data = static_cast(ptr); + const unsigned char* end = data + (len & ~7ULL); + + while (data != end) { + size_t k; + __builtin_memcpy(&k, data, sizeof(k)); + k *= m; + k ^= k >> r; + k *= m; + h ^= k; + h *= m; + data += 8; + } + + switch (len & 7) { + case 7: h ^= static_cast(data[6]) << 48; [[fallthrough]]; + case 6: h ^= static_cast(data[5]) << 40; [[fallthrough]]; + case 5: h ^= static_cast(data[4]) << 32; [[fallthrough]]; + case 4: h ^= static_cast(data[3]) << 24; [[fallthrough]]; + case 3: h ^= static_cast(data[2]) << 16; [[fallthrough]]; + case 2: h ^= static_cast(data[1]) << 8; [[fallthrough]]; + case 1: h ^= static_cast(data[0]); + h *= m; + } + + h ^= h >> r; + h *= m; + h ^= h >> r; + return h; +} + +} // namespace __1 +} // namespace std + +#endif // __APPLE__