diff --git a/include/clasp/core/backtrace.h b/include/clasp/core/backtrace.h index b82c4dedf0..7006fdc6fa 100644 --- a/include/clasp/core/backtrace.h +++ b/include/clasp/core/backtrace.h @@ -82,7 +82,7 @@ FORWARD(SectionedAddress); namespace core { -T_sp dwarf_ep(size_t frameIndex, llvmo::ObjectFile_sp ofi, llvmo::DWARFContext_sp dcontext, llvmo::SectionedAddress_sp sa, - void*& codeStart, void*& functionStartAddress, bool& XEPp, int& arityCode); +T_sp dwarf_ep(size_t frameIndex, llvmo::ObjectFile_sp ofi, llvmo::DWARFContext_sp dcontext, void* absolute_ip, + void*& functionStartAddress, bool& XEPp, int& arityCode); } // namespace core diff --git a/include/clasp/core/function.h b/include/clasp/core/function.h index f99f503103..6167a4faea 100644 --- a/include/clasp/core/function.h +++ b/include/clasp/core/function.h @@ -228,7 +228,11 @@ class SimpleFun_O : public Function_O { SimpleFun_O(FunctionDescription_sp fdesc, T_sp code, const ClaspXepTemplate& entry_point); CL_DEFMETHOD FunctionDescription_sp functionDescription() const { return this->_FunctionDescription; }; - virtual Pointer_sp defaultEntryAddress() const; + // These two are useful for debugging things at a low level. + // They're unsafe. + Pointer_sp defaultEntryAddress() const; + Pointer_sp arityEntryAddress(size_t arity) const; + // Necessary since we have templated subclasses in clbind. // Doing so means the static analyzer marks SimpleFun as a // TemplatedKind, which makes the GC use templatedSizeof to @@ -293,7 +297,6 @@ class CoreFun_O : public General_O { public: CL_DEFMETHOD FunctionDescription_sp functionDescription() const { return this->_FunctionDescription; }; virtual void fixupInternalsForSnapshotSaveLoad(snapshotSaveLoad::Fixup* fixup); - virtual Pointer_sp defaultEntryAddress() const; string __repr__() const; }; @@ -337,7 +340,6 @@ class SimpleCoreFun_O : public SimpleFun_O { static SimpleCoreFun_sp make(FunctionDescription_sp fdesc, ClaspCoreFunction main, ClaspXepAnonymousFunction* xep); public: - virtual Pointer_sp defaultEntryAddress() const; llvmo::ObjectFile_sp code() const; CoreFun_sp localFun() const; string __repr__() const; @@ -372,7 +374,6 @@ class BytecodeSimpleFun_O : public SimpleFun_O { unsigned int bytecodeSize, BytecodeTrampolineFunction trampoline); public: - virtual Pointer_sp defaultEntryAddress() const; BytecodeModule_sp code() const; string __repr__() const; diff --git a/include/clasp/core/sourceFileInfo.fwd.h b/include/clasp/core/sourceFileInfo.fwd.h index 427905a905..42b953bb71 100644 --- a/include/clasp/core/sourceFileInfo.fwd.h +++ b/include/clasp/core/sourceFileInfo.fwd.h @@ -29,9 +29,4 @@ THE SOFTWARE. namespace core { FORWARD(FileScope); FORWARD(SourcePosInfo); - -uint clasp_sourcePosInfo_fileHandle(SourcePosInfo_sp info); -size_t clasp_sourcePosInfo_filepos(SourcePosInfo_sp info); -uint clasp_sourcePosInfo_lineno(SourcePosInfo_sp info); -uint clasp_sourcePosInfo_column(SourcePosInfo_sp info); }; // namespace core diff --git a/include/clasp/core/sourceFileInfo.h b/include/clasp/core/sourceFileInfo.h index 7d6eaa7e7e..d74cc20ebf 100644 --- a/include/clasp/core/sourceFileInfo.h +++ b/include/clasp/core/sourceFileInfo.h @@ -26,8 +26,6 @@ THE SOFTWARE. */ /* -^- */ -#define USE_WEAK_HASH_TABLE_FOR_SOURCE_POS_INFO 1 - #include #include #include @@ -58,22 +56,14 @@ class FileScope_O : public Scope_O { explicit FileScope_O(); virtual ~FileScope_O(){}; void initialize() override; - GCPRIVATE : // instance variables here - Pathname_sp _pathname; - /*! Allocated buffer that stores the file name until the program exits */ - char* _PermanentPathName; - char* _PermanentFileName; +GCPRIVATE : // instance variables here + Pathname_sp _pathname; int _FileHandle; public: // Functions here int fileHandle() const { return this->_FileHandle; }; - string fileName() const; - string parentPathName() const; - string namestring() const; CL_LISPIFY_NAME("FileScope-pathname"); CL_DEFMETHOD Pathname_sp pathname() const { return this->_pathname; }; - const char* permanentPathName(); - const char* permanentFileName(); string __repr__() const override; }; // FileScope class @@ -90,10 +80,10 @@ class SourcePosInfo_O : public General_O { public: // ctor/dtor for classes with shared virtual base explicit SourcePosInfo_O() : _FileId(UNDEF_UINT), _Filepos(0), _Lineno(0), _Column(0), _FunctionScope(nil()), - _InlinedAt(nil()){}; //, _Filepos(0) {}; + _InlinedAt(nil()){}; public: // instance variables here SourcePosInfo_O(uint spf, size_t filepos, uint spln, uint spc, T_sp function_scope, T_sp inlined_at) - : _FileId(spf), _Filepos(filepos), _Lineno(spln), _Column(spc), //, _Expander(expander) {} + : _FileId(spf), _Filepos(filepos), _Lineno(spln), _Column(spc), _FunctionScope(function_scope), _InlinedAt(inlined_at){}; public: @@ -109,7 +99,6 @@ class SourcePosInfo_O : public General_O { int column() const { return this->_Column; }; T_sp function_scope() const { return this->_FunctionScope; }; T_sp inlined_at() const { return this->_InlinedAt; }; - // bool equalp(T_sp obj) const; public: uint _FileId; size_t _Filepos; @@ -117,10 +106,8 @@ class SourcePosInfo_O : public General_O { uint _Column; T_sp _FunctionScope; T_sp _InlinedAt; - // Function_sp _Expander; - CL_DEFMETHOD size_t source_file_pos_filepos() const { return this->_Filepos; } - CL_DEFMETHOD size_t source_file_pos_lineno() const { return this->_Lineno; } - CL_DEFMETHOD size_t source_file_pos_column() const { return this->_Column; } + CL_LISPIFY_NAME(SourcePosInfo/pathname) + CL_DEFMETHOD Pathname_sp pathname() const; SourcePosInfo_sp source_pos_info_copy() const; T_sp setf_source_pos_info_inlined_at(T_sp inlinedAt); T_sp source_pos_info_inlined_at() const; @@ -133,32 +120,6 @@ SourcePosInfo_sp core__makeSourcePosInfo(const string& filename, bool filenamep, bool linenop, size_t column, bool columnp, T_sp function_scope = nil(), bool function_scope_p = false, T_sp inlined_at = nil(), bool inlined_at_p = false, T_sp defaults = nil(), bool defaults_p = false); - -inline core::Fixnum safe_fileId(T_sp spi) { - if (spi.nilp()) - return 0; - return gc::As(spi)->_FileId; -} - -inline core::Fixnum safe_filepos(T_sp spi) { - if (spi.nilp()) - return 0; - return gc::As(spi)->_FileId; -} - -inline core::Fixnum safe_lineno(T_sp spi) { - if (spi.nilp()) - return 0; - return gc::As(spi)->_Lineno; -} - -inline core::Fixnum safe_column(T_sp spi) { - if (spi.nilp()) - return 0; - return gc::As(spi)->_Column; -} -// Pass all arguments to a FunctionClosure -#define SOURCE_POS_INFO_FIELDS(spi) safe_fileId(spi), safe_filepos(spi), safe_lineno(spi), safe_column(spi) }; // namespace core template <> struct gctools::GCInfo { static bool constexpr NeedsInitialization = false; diff --git a/include/clasp/llvmo/claspLinkPass.h b/include/clasp/llvmo/claspLinkPass.h deleted file mode 100644 index c9604c8746..0000000000 --- a/include/clasp/llvmo/claspLinkPass.h +++ /dev/null @@ -1,32 +0,0 @@ -#pragma once - -/* - File: claspLinkPass.h -*/ - -/* -Copyright (c) 2014, Christian E. Schafmeister - -CLASP is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public -License as published by the Free Software Foundation; either -version 2 of the License, or (at your option) any later version. - -See directory 'clasp/licenses' for full details. - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. -*/ -/* -^- */ -namespace llvmo { - -void initialize_claspLinkPass(); -}; diff --git a/include/clasp/llvmo/llvmoExpose.h b/include/clasp/llvmo/llvmoExpose.h index c9713c01ea..5f34d16ed8 100644 --- a/include/clasp/llvmo/llvmoExpose.h +++ b/include/clasp/llvmo/llvmoExpose.h @@ -2913,7 +2913,36 @@ template <> struct to_object { static core::T_sp convert(llvm::UndefValue* ptr) { return ((llvmo::UndefValue_O::create(ptr))); } }; }; // namespace translate - ; + +namespace llvmo { +FORWARD(PoisonValue); +class PoisonValue_O : public UndefValue_O { + LISP_EXTERNAL_CLASS(llvmo, LlvmoPkg, llvm::PoisonValue, PoisonValue_O, "PoisonValue", UndefValue_O); + typedef llvm::PoisonValue ExternalType; + typedef llvm::PoisonValue* PointerToExternalType; + +public: + PointerToExternalType wrappedPtr() { return llvm_cast(this->_ptr); } + PointerToExternalType wrappedPtr() const { return llvm_cast(this->_ptr); } + void set_wrapped(PointerToExternalType ptr) { + this->_ptr = ptr; + } + static PoisonValue_sp create(llvm::PoisonValue* ptr); + PoisonValue_O() : Base(){}; + ~PoisonValue_O() {} + +public: + string __repr__() const; +}; // PoisonValue_O +}; // namespace llvmo +/* from_object translators */ +/* to_object translators */ + +namespace translate { +template <> struct to_object { + static core::T_sp convert(llvm::PoisonValue* ptr) { return ((llvmo::PoisonValue_O::create(ptr))); } +}; +}; // namespace translate namespace llvmo { FORWARD(ConstantPointerNull); diff --git a/repos.sexp b/repos.sexp index f13bb05d22..cc5aa1cff2 100644 --- a/repos.sexp +++ b/repos.sexp @@ -108,7 +108,7 @@ (:name :cleavir :repository "https://github.com/s-expressionists/Cleavir.git" :directory "src/lisp/kernel/contrib/Cleavir/" - :commit "e41eae5dcac98532148ffc9c524fbfefe70c2965") + :commit "18129fc245603a27ff49e4705e47a4470d6f2ce9") (:name :closer-mop :repository "https://github.com/pcostanza/closer-mop.git" :directory "src/lisp/kernel/contrib/closer-mop/" diff --git a/src/analysis/clasp_gc.sif b/src/analysis/clasp_gc.sif index e5dff00ea2..d3dfaf2cc2 100644 --- a/src/analysis/clasp_gc.sif +++ b/src/analysis/clasp_gc.sif @@ -103,25 +103,26 @@ "llvmo::Constant_O" "llvmo::FunctionCallee_O" "llvmo::DIBasicType_O" "llvmo::DIBuilder_O" "core::NativeVector_int_O" "llvmo::APInt_O" "llvmo::APFloat_O" "core::SimpleMDArrayCharacter_O" - "core::SimpleCharacterString_O" "core::Symbol_O" "core::Array_O" - "core::MDArray_byte4_t_O" "llvmo::Argument_O" "core::Iterator_O" - "llvmo::IRBuilderBase_O" "core::Null_O" "core::RequiredArgument" - "core::SingleDispatchMethod_O" "comp::VarInfo_O" "core::CxxObject_O" - "llvmo::ReturnInst_O" "llvmo::FunctionType_O" "clbind::DummyCreator_O" - "core::MDArray_byte16_t_O" "llvmo::DIContext_O" "llvmo::JITDylib_O" - "llvmo::Type_O" "core::Pointer_O" "llvmo::UnreachableInst_O" - "core::ComplexVector_int64_t_O" "core::FileScope_O" "core::Float_O" - "core::SimpleMDArray_byte4_t_O" "llvmo::DIDerivedType_O" - "comp::EntryCloseFixup_O" "core::SimpleVector_int64_t_O" - "llvmo::ConstantDataSequential_O" "comp::EntryFixup_O" - "core::MDArray_double_O" "llvmo::StoreInst_O" "llvmo::DebugLoc_O" - "core::WeakPointer_O" "core::DestDynEnv_O" "comp::Annotation_O" - "core::DynEnv_O" "core::BytecodeAstBlock_O" "comp::LexSetFixup_O" - "core::SimpleMDArray_byte8_t_O" "comp::SymbolMacroVarInfo_O" - "core::UnwindProtectDynEnv_O" "comp::LexicalInfo_O" - "llvmo::Instruction_O" "core::FileStream_O" "comp::ExitFixup_O" - "core::Rational_O" "core::CatchDynEnv_O" "core::MDArrayCharacter_O" - "llvmo::LandingPadInst_O" "core::ImmobileObject_O" "core::Function_O" + "core::SimpleCharacterString_O" "llvmo::PoisonValue_O" "core::Symbol_O" + "core::Array_O" "core::MDArray_byte4_t_O" "llvmo::Argument_O" + "core::Iterator_O" "llvmo::IRBuilderBase_O" "core::Null_O" + "core::RequiredArgument" "core::SingleDispatchMethod_O" "comp::VarInfo_O" + "core::CxxObject_O" "llvmo::ReturnInst_O" "llvmo::FunctionType_O" + "clbind::DummyCreator_O" "core::MDArray_byte16_t_O" "llvmo::DIContext_O" + "llvmo::JITDylib_O" "llvmo::Type_O" "core::Pointer_O" + "llvmo::UnreachableInst_O" "core::ComplexVector_int64_t_O" + "core::FileScope_O" "core::Float_O" "core::SimpleMDArray_byte4_t_O" + "llvmo::DIDerivedType_O" "comp::EntryCloseFixup_O" + "core::SimpleVector_int64_t_O" "llvmo::ConstantDataSequential_O" + "comp::EntryFixup_O" "core::MDArray_double_O" "llvmo::StoreInst_O" + "llvmo::DebugLoc_O" "core::WeakPointer_O" "core::DestDynEnv_O" + "comp::Annotation_O" "core::DynEnv_O" "core::BytecodeAstBlock_O" + "comp::LexSetFixup_O" "core::SimpleMDArray_byte8_t_O" + "comp::SymbolMacroVarInfo_O" "core::UnwindProtectDynEnv_O" + "comp::LexicalInfo_O" "llvmo::Instruction_O" "core::FileStream_O" + "comp::ExitFixup_O" "core::Rational_O" "core::CatchDynEnv_O" + "core::MDArrayCharacter_O" "llvmo::LandingPadInst_O" + "core::ImmobileObject_O" "core::Function_O" "core::SimpleMDArray_int2_t_O" "core::HashTableEql_O" "comp::ConstantInfo_O" "mp::ConditionVariable_O" "core::Real_O" "core::Lisp" "core::MDArray_byte8_t_O" "core::BytecodeAstThe_O" @@ -4362,6 +4363,14 @@ :offset-base-ctype "llvmo::UndefValue_O" :layout-offset-field-names ("_Class")} {fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" :offset-base-ctype "llvmo::UndefValue_O" :layout-offset-field-names ("_ptr")} +{class-kind :stamp-name "STAMPWTAG_llvmo__PoisonValue_O" :stamp-key "llvmo::PoisonValue_O" + :parent-class "llvmo::UndefValue_O" :lisp-class-base "llvmo::UndefValue_O" + :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "llvmo::PoisonValue_O" :layout-offset-field-names ("_Class")} +{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "llvmo::PoisonValue_O" :layout-offset-field-names ("_ptr")} {class-kind :stamp-name "STAMPWTAG_llvmo__ConstantArray_O" :stamp-key "llvmo::ConstantArray_O" :parent-class "llvmo::Constant_O" :lisp-class-base "llvmo::Constant_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} @@ -4834,12 +4843,6 @@ {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" :offset-ctype "gctools::smart_ptr" :offset-base-ctype "core::FileScope_O" :layout-offset-field-names ("_pathname")} -{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" - :offset-base-ctype "core::FileScope_O" - :layout-offset-field-names ("_PermanentPathName")} -{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" - :offset-base-ctype "core::FileScope_O" - :layout-offset-field-names ("_PermanentFileName")} {fixed-field :offset-type-cxx-identifier "ctype_int" :offset-ctype "int" :offset-base-ctype "core::FileScope_O" :layout-offset-field-names ("_FileHandle")} {class-kind :stamp-name "STAMPWTAG_core__Path_O" :stamp-key "core::Path_O" diff --git a/src/analysis/clasp_gc_cando.sif b/src/analysis/clasp_gc_cando.sif index 7e51558fce..2b50a2402d 100644 --- a/src/analysis/clasp_gc_cando.sif +++ b/src/analysis/clasp_gc_cando.sif @@ -176,18 +176,19 @@ "chem::ResidueOut" "core::NativeVector_int_O" "llvmo::DIBasicType_O" "llvmo::DIBuilder_O" "llvmo::APInt_O" "llvmo::APFloat_O" "core::SimpleMDArrayCharacter_O" "core::SimpleCharacterString_O" - "core::Symbol_O" "chem::AtomOrBondMatchNode_O" "core::Array_O" - "core::MDArray_byte4_t_O" "llvmo::Argument_O" "chem::FFItorDb_O" - "llvmo::IRBuilderBase_O" "units::Unit_O" "core::Null_O" - "chem::RingFinder_O" "chem::IterateBonds_O" "core::RequiredArgument" - "core::SingleDispatchMethod_O" "chem::CDFragment_O" "comp::VarInfo_O" - "core::CxxObject_O" "llvmo::ReturnInst_O" "llvmo::FunctionType_O" - "clbind::DummyCreator_O" "chem::EnergyDihedralRestraint" - "core::MDArray_byte16_t_O" "llvmo::DIContext_O" - "chem::FFNonbondCrossTermTable_O" "llvmo::JITDylib_O" "llvmo::Type_O" - "chem::Command_O" "core::Pointer_O" "llvmo::UnreachableInst_O" - "core::ComplexVector_int64_t_O" "chem::FFParameterBaseDb_O" - "core::FileScope_O" "core::SimpleMDArray_byte4_t_O" "core::Float_O" + "llvmo::PoisonValue_O" "core::Symbol_O" "chem::AtomOrBondMatchNode_O" + "core::Array_O" "core::MDArray_byte4_t_O" "llvmo::Argument_O" + "chem::FFItorDb_O" "llvmo::IRBuilderBase_O" "units::Unit_O" + "core::Null_O" "chem::RingFinder_O" "chem::IterateBonds_O" + "core::RequiredArgument" "core::SingleDispatchMethod_O" + "chem::CDFragment_O" "comp::VarInfo_O" "core::CxxObject_O" + "llvmo::ReturnInst_O" "llvmo::FunctionType_O" "clbind::DummyCreator_O" + "chem::EnergyDihedralRestraint" "core::MDArray_byte16_t_O" + "llvmo::DIContext_O" "chem::FFNonbondCrossTermTable_O" + "llvmo::JITDylib_O" "llvmo::Type_O" "chem::Command_O" "core::Pointer_O" + "llvmo::UnreachableInst_O" "core::ComplexVector_int64_t_O" + "chem::FFParameterBaseDb_O" "core::FileScope_O" + "core::SimpleMDArray_byte4_t_O" "core::Float_O" "chem::EnergySketchStretch" "chem::ResidueTest_O" "chem::RestraintDistance_O" "llvmo::DIDerivedType_O" "chem::SmartsRoot_O" "chem::TwisterDriver_O" "comp::EntryCloseFixup_O" @@ -9195,6 +9196,14 @@ :offset-base-ctype "llvmo::UndefValue_O" :layout-offset-field-names ("_Class")} {fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" :offset-base-ctype "llvmo::UndefValue_O" :layout-offset-field-names ("_ptr")} +{class-kind :stamp-name "STAMPWTAG_llvmo__PoisonValue_O" :stamp-key "llvmo::PoisonValue_O" + :parent-class "llvmo::UndefValue_O" :lisp-class-base "llvmo::UndefValue_O" + :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "llvmo::PoisonValue_O" :layout-offset-field-names ("_Class")} +{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "llvmo::PoisonValue_O" :layout-offset-field-names ("_ptr")} {class-kind :stamp-name "STAMPWTAG_llvmo__ConstantArray_O" :stamp-key "llvmo::ConstantArray_O" :parent-class "llvmo::Constant_O" :lisp-class-base "llvmo::Constant_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} @@ -9737,12 +9746,6 @@ {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" :offset-ctype "gctools::smart_ptr" :offset-base-ctype "core::FileScope_O" :layout-offset-field-names ("_pathname")} -{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" - :offset-base-ctype "core::FileScope_O" - :layout-offset-field-names ("_PermanentPathName")} -{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" - :offset-base-ctype "core::FileScope_O" - :layout-offset-field-names ("_PermanentFileName")} {fixed-field :offset-type-cxx-identifier "ctype_int" :offset-ctype "int" :offset-base-ctype "core::FileScope_O" :layout-offset-field-names ("_FileHandle")} {class-kind :stamp-name "STAMPWTAG_core__Path_O" :stamp-key "core::Path_O" diff --git a/src/core/backtrace.cc b/src/core/backtrace.cc index d64c822c49..622390b32e 100644 --- a/src/core/backtrace.cc +++ b/src/core/backtrace.cc @@ -161,133 +161,95 @@ static T_sp getSourcePosInfoForAddress(llvmo::DWARFContext_sp dcontext, llvmo::S return core__makeSourcePosInfo(source_path, true, 0, false, info.Line, true, info.Column, true); } -T_sp dwarf_ep(size_t frameIndex, llvmo::ObjectFile_sp ofi, llvmo::DWARFContext_sp dcontext, llvmo::SectionedAddress_sp sa, - void*& codeStart, void*& functionStartAddress, bool& XEPp, int& arityCode) { +// Given the start of a function (HERE), and an address and that address's +// object file and DWARF context, determine if the address is within that +// function. Sorta similar to debugger.cc's lookup_address. +static bool function_starting_here_contains_addr_p(llvmo::ObjectFile_sp ofi, llvmo::DWARFContext_sp dcontext, uintptr_t here, uintptr_t addr) { + void* here_ip = (void*)here; + // See if we are in the right object file. An object file's literals may + // include functions from other object files (e.g. due to weird #. stuff) + // and we don't want to check those. + if ((here < ofi->codeStart()) || (here > ofi->codeEnd())) + return false; + uintptr_t reladdr = addr - ofi->codeStart(); + llvmo::SectionedAddress_sp sa = llvmo::object_file_sectioned_address(here_ip, ofi, false); + auto eranges = llvmo::getAddressRangesForAddressInner(dcontext, sa); + if (!eranges) return false; // no debug info + for (auto range : eranges.get()) { + if ((range.LowPC <= reladdr) && (reladdr <= range.HighPC)) + return true; + } + return false; // not in any of the ranges +} + +T_sp dwarf_ep(size_t frameIndex, llvmo::ObjectFile_sp ofi, llvmo::DWARFContext_sp dcontext, void* absolute_ip, + void*& functionStartAddress, bool& XEPp, int& arityCode) { MaybeTrace trace(__FUNCTION__); - functionStartAddress = NULL; - D(printf("%s:%d:%s frameIndex = %lu\n", __FILE__, __LINE__, __FUNCTION__, frameIndex);); + functionStartAddress = NULL; XEPp = false; arityCode = 0; // // If the object file contains the interpreter_trampoline - then we are in the interpreter // if (ofi->codeStart() <= (uintptr_t)bytecode_trampoline && (uintptr_t)bytecode_trampoline < ofi->codeEnd()) { functionStartAddress = (void*)bytecode_trampoline; - D(printf("%s:%d:%s bytecode trampoline functionStartAddress = %p\n", __FILE__, __LINE__, __FUNCTION__, functionStartAddress);); return nil(); } - auto expected_ranges = llvmo::getAddressRangesForAddressInner(dcontext, sa); - if (expected_ranges) { - auto ranges = expected_ranges.get(); - if (ranges.size() == 0) { - D(printf("%s:%d:%s No ranges were found for %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(sa).c_str());); - } else { - if (ranges.size() > 1) { - printf("%s:%d:%s There is more than one range - there are %lu\n", __FILE__, __LINE__, __FUNCTION__, ranges.size()); - } else { - llvmo::ObjectFile_sp code = ofi; - codeStart = (void*)code->codeStart(); - uintptr_t absolute_LowPC = ranges.begin()->LowPC + (uintptr_t)codeStart; - functionStartAddress = (void*)(absolute_LowPC); - D(printf("%s:%d:%s Calculated functionStartAddress = %p\n", __FILE__, __LINE__, __FUNCTION__, functionStartAddress);); - T_O** rliterals = code->TOLiteralsStart(); - size_t nliterals = code->TOLiteralsSize(); - D(printf("%s%s:%d:%s sectioned address %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, - _rep_(sa).c_str());); - D(printf("%s%s:%d:%s codeStart = %p - %p\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, (void*)codeStart, - (void*)codeEnd);); - D(printf("%s%s:%d:%s objectFile = %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(ofi).c_str());); - D(for (auto range - : ranges) { - uintptr_t absolute_LowPC = range.LowPC + (uintptr_t)codeStart; - uintptr_t absolute_HighPC = range.HighPC + (uintptr_t)codeStart; - printf("%s%s:%d:%s found range %p - %p Absolute %p - %p\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, - (void*)range.LowPC, (void*)range.HighPC, (void*)absolute_LowPC, (void*)absolute_HighPC); - } printf("%s%s:%d:%s rliterals = %p nliterals = %lu\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, rliterals, - nliterals);); - for (size_t i = 0; i < nliterals; ++i) { - T_sp literal((gc::Tagged)(rliterals[i])); - if (gc::IsA(literal)) { - CoreFun_sp ep = gc::As_unsafe(literal); - uintptr_t absolute_entry = (uintptr_t)(ep->_Entry); - D(printf("%s%s:%d:%s CoreFun_sp %s absolute_entry = %p FunctionDescription name %s\n", trace.spaces().c_str(), - __FILE__, __LINE__, __FUNCTION__, _rep_(ep).c_str(), (void*)absolute_entry, - _rep_(ep->functionDescription()).c_str());); - for (auto range : ranges) { - uintptr_t absolute_LowPC = range.LowPC + (uintptr_t)codeStart; - uintptr_t absolute_HighPC = range.HighPC + (uintptr_t)codeStart; - if ((absolute_LowPC <= absolute_entry) && (absolute_entry < absolute_HighPC)) { - D(printf("%s%s:%d:%s Matched absolute_LowPC/absolute_HighPC %p/%p\n", trace.spaces().c_str(), __FILE__, __LINE__, - __FUNCTION__, (void*)absolute_LowPC, (void*)absolute_HighPC);); - XEPp = false; - // This will be identical to the entry point address in CoreFun_sp ep - return ep; - } else { - D(printf("%s%s:%d:%s DID NOT match absolute_LowPC/absolute_HighPC %p/%p\n", trace.spaces().c_str(), __FILE__, - __LINE__, __FUNCTION__, (void*)absolute_LowPC, (void*)absolute_HighPC);); - } - } - } else if (gc::IsA(literal)) { - SimpleFun_sp ep = gc::As_unsafe(literal); - D(printf("%s%s:%d:%s SimpleCoreFun_sp %s FunctionDescription name %s\n", trace.spaces().c_str(), __FILE__, __LINE__, - __FUNCTION__, _rep_(ep).c_str(), _rep_(ep->functionDescription()).c_str());); - for (size_t j = 0; j < NUMBER_OF_ENTRY_POINTS; ++j) { - uintptr_t absolute_entry = (uintptr_t)(ep->_EntryPoints[j]); - for (auto range : ranges) { - uintptr_t absolute_LowPC = range.LowPC + (uintptr_t)codeStart; - uintptr_t absolute_HighPC = range.HighPC + (uintptr_t)codeStart; - if ((absolute_LowPC <= absolute_entry) && (absolute_entry < absolute_HighPC)) { - D(printf("%s%s:%d:%s Matched arityCode: %lu absolute_LowPC/absolute_HighPC %p/%p\n", trace.spaces().c_str(), - __FILE__, __LINE__, __FUNCTION__, j, (void*)absolute_LowPC, (void*)absolute_HighPC);); - XEPp = true; - // This will be identical to ONE of the the entry point address in SimpleFun_sp ep - // arityCode is the index into the SimpleFun_sp vector corresponding to functionStartAddress - arityCode = j; - return ep; - } else { - // D(printf("%s%s:%d:%s absolute_entry -> %p DID NOT match absolute_LowPC/absolute_HighPC %p/%p\n", - // trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, (void*)absolute_entry, (void*)absolute_LowPC, - // (void*)absolute_HighPC );); - } - } - } - } + // Otherwise, we are hopefully in the object file somewhere. + // We go through all the literals in the object file looking for compiled + // functions, and get their ranges from the DWARF (this is similar to the + // lookup_address function in debugger.cc). Then if we're in one of those + // ranges, we have our entry point. + // We used to get the DWARF address ranges for the return address, but this + // is problematic in the presence of inlining: We will get the DWARF DIE for + // the inlined function, which is narrower than the actual entry point. + // Although, FIXME, we should report inlining properly. + uintptr_t retaddr = (uintptr_t)absolute_ip; + uintptr_t codeStart = ofi->codeStart(); + T_O** rliterals = ofi->TOLiteralsStart(); + size_t nliterals = ofi->TOLiteralsSize(); + for (size_t i = 0; i < nliterals; ++i) { + T_sp literal((gc::Tagged)(rliterals[i])); + if (gc::IsA(literal)) { + CoreFun_sp ep = gc::As_unsafe(literal); + uintptr_t entry = (uintptr_t)ep->_Entry; + if (function_starting_here_contains_addr_p(ofi, dcontext, entry, retaddr)) { + functionStartAddress = (void*)entry; + XEPp = false; + return ep; + } + } else if (gc::IsA(literal)) { + SimpleFun_sp ep = gc::As_unsafe(literal); + for (size_t j = 0; j < NUMBER_OF_ENTRY_POINTS; ++j) { + uintptr_t entry = (uintptr_t)(ep->_EntryPoints[j]); + if (function_starting_here_contains_addr_p(ofi, dcontext, entry, retaddr)) { + functionStartAddress = (void*)entry; + XEPp = true; + arityCode = j; } - // no hits - return nil(); } } } - D(printf("%s:%d:%s No eranges\n", __FILE__, __LINE__, __FUNCTION__);); + // no hits within the literals. return nil(); } -__attribute__((optnone)) static bool args_from_offset(size_t fi, void* ip, const char* string, T_sp name, bool XEPp, int arityCode, +__attribute__((optnone)) static bool args_from_offset(size_t fi, void* ip, int arityCode, void* frameptr, int32_t offset32, T_sp& closure, T_sp& args, int64_t patch_point_id) { MaybeTrace trace(__FUNCTION__); int64_t offset64 = static_cast(offset32); - D(printf("%s%s:%d:%s fi=%lu ip=%p fp = %p patch_point_id 0x%lx offset64 = %ld\n", trace.spaces().c_str(), __FILE__, __LINE__, - __FUNCTION__, fi, ip, frameptr, patch_point_id, offset64);); int64_t arity_code; if (frameptr && is_entry_point_arity(patch_point_id, arity_code)) { - D(printf("%s%s:%d:%s entry_point arity_code %ld\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, arity_code);); T_O** register_save_area = (T_O**)((intptr_t)frameptr + offset64); - D(printf("%s%s:%d:%s fi=%lu ip=%p fp %p arity_code %ld rsa=%p %s XEP(y=%d,a=%d) ", trace.spaces().c_str(), __FILE__, __LINE__, - __FUNCTION__, fi, ip, frameptr, arity_code, register_save_area, _rep_(name).c_str(), XEPp, arityCode);); - D(if (string) printf("%s", string);); - D(printf("\n");); T_sp tclosure((gc::Tagged)register_save_area[LCC_CLOSURE_REGISTER]); if (!gc::IsA(tclosure)) { - D(printf("%s%s:%d:%s bad tclosure %p\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, tclosure.raw_());); fprintf(stderr, "%s:%d:%s When trying to get arguments from CL frame read what should be a closure %p but it isn't\n", __FILE__, __LINE__, __FUNCTION__, tclosure.raw_()); return false; } closure = tclosure; - D(printf("%s%s:%d:%s closure = %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(closure).c_str());); if (arity_code == 0) { // For the general entry point the registers are (closure, nargs, arg_ptr) size_t nargs = (size_t)(register_save_area[LCC_NARGS_REGISTER]); - D(printf("%s%s:%d:%s nargs = %lu\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, nargs);); if (nargs > 256) { fprintf(stderr, "%s:%d:%s There are too many arguments %lu\n", __FILE__, __LINE__, __FUNCTION__, nargs); return false; @@ -296,12 +258,9 @@ __attribute__((optnone)) static bool args_from_offset(size_t fi, void* ip, const // Get the arg ptr from the register save area T_O** arg_ptr = (T_O**)register_save_area[LCC_ARGS_PTR_REGISTER]; // get the args from the arg_ptr - D(printf("%s%s:%d:%s About to read %lu xep args\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, nargs);); for (size_t i = 0; i < nargs; ++i) { T_O* rarg = arg_ptr[i]; T_sp temp((gctools::Tagged)rarg); - D(printf("%s%s:%d:%s read xep(general) arg %lu -> %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, i, - _rep_(temp).c_str());); largs << temp; } args = largs.cons(); @@ -310,16 +269,12 @@ __attribute__((optnone)) static bool args_from_offset(size_t fi, void* ip, const size_t arity_nargs = arity_code - 1; ASSERT(ENTRY_POINT_ARITY_BEGIN == 0); // maybe in the future we may want to support something else size_t nargs = arity_nargs + ENTRY_POINT_ARITY_BEGIN; - D(printf("%s%s:%d:%s About to read %lu xep%lu args\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, nargs, - arity_code - 1);); // Get the first args from the register save area ql::list largs; size_t args_in_rsa = std::min(nargs, (size_t)(LCC_WORDS_IN_REGISTER_SAVE_AREA - 1)); // -1 to remove closure arg int args_on_stack = nargs - (LCC_WORDS_IN_REGISTER_SAVE_AREA - 1); for (size_t i = 0; i < args_in_rsa; ++i) { T_sp temp((gctools::Tagged)(register_save_area[i + 1])); // +1 to skip closure arg - D(printf("%s%s:%d:%s read xep%lu arg %lu -> %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, nargs, i, - _rep_(temp).c_str());); largs << temp; } // and the rest from the stack frame if we support xepN functions that exhaust the available register arguments @@ -339,10 +294,8 @@ __attribute__((optnone)) static bool args_from_offset(size_t fi, void* ip, const } return true; } else { - D(printf("%s%s:%d:%s entry_point no stackmap entry\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__);); return false; } - D(printf("%s%s:%d:%s Extracted args: %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(args).c_str());); } bool sanity_check_args(void* frameptr, int32_t offset32, int64_t patch_point_id) { @@ -379,9 +332,9 @@ bool sanity_check_args(void* frameptr, int32_t offset32, int64_t patch_point_id) return true; // information not being available is unfortunate but sane } -__attribute__((optnone)) static bool args_for_function(size_t fi, void* ip, const char* string, bool XEPp, int arityCode, - void* code_start, void* functionStartAddress, llvmo::ObjectFile_sp ofi, - T_sp& functionDescriptionOrNil, void* frameptr, T_sp& closure, T_sp& args) { +__attribute__((optnone)) static bool args_for_function(size_t fi, void* ip, int arityCode, + void* functionStartAddress, llvmo::ObjectFile_sp ofi, + T_sp functionDescriptionOrNil, void* frameptr, T_sp& closure, T_sp& args) { MaybeTrace trace(__FUNCTION__); if (!functionStartAddress) { D(printf("%s:%d:%s functionStartAddress is NULL returning\n", __FILE__, __LINE__, __FUNCTION__);); @@ -394,19 +347,10 @@ __attribute__((optnone)) static bool args_for_function(size_t fi, void* ip, cons } uintptr_t stackmap_end = stackmap_start + ofi->_StackmapSize; bool args_available = false; - T_sp name = nil(); - ; - if (gc::IsA(functionDescriptionOrNil)) - name = gc::As_unsafe(functionDescriptionOrNil); - D(printf("%s%s:%d:%s functionStartAddress FunctionDescription %s code_start = %p functionStartAddress = %p\n", - trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(name).c_str(), (void*)code_start, - functionStartAddress);); auto thunk = [&](size_t _, const smStkSizeRecord& function, int32_t offsetOrSmallConstant, int64_t patchPointId) { if (function.FunctionAddress == (uintptr_t)functionStartAddress) { MaybeTrace tracel("functionStartAddress_thunk"); - D(printf("%s%s:%d:%s function.FunctionAddress = %p functionStartAddress = %p\n", trace.spaces().c_str(), __FILE__, __LINE__, - __FUNCTION__, (void*)function.FunctionAddress, functionStartAddress);); - if (args_from_offset(fi, ip, string, name, XEPp, arityCode, frameptr, offsetOrSmallConstant, closure, args, patchPointId)) + if (args_from_offset(fi, ip, arityCode, frameptr, offsetOrSmallConstant, closure, args, patchPointId)) args_available |= true; return; } @@ -424,44 +368,30 @@ static DebuggerFrame_sp make_lisp_frame(size_t frameIndex, void* absolute_ip, co MaybeTrace trace(__FUNCTION__); llvmo::SectionedAddress_sp sa = object_file_sectioned_address(absolute_ip, ofi, false); llvmo::DWARFContext_sp dcontext = llvmo::DWARFContext_O::createDWARFContext(ofi); - D(printf("%s%s:%d:%s sa= %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(sa).c_str());); T_sp spi = getSourcePosInfoForAddress(dcontext, sa); - D(printf("%s%s:%d:%s spi= %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(spi).c_str());); bool XEPp = false; int arityCode; - void* codeStart; void* functionStartAddress; - T_sp ep = dwarf_ep(frameIndex, ofi, dcontext, sa, codeStart, functionStartAddress, XEPp, arityCode); - D(printf("%s:%d:%s dwarf_ep returned ep = %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(ep).c_str());); - D(printf("%s:%d:%s dwarf_ep returned functionStartAddress = %p\n", __FILE__, __LINE__, __FUNCTION__, - (void*)functionStartAddress);); + T_sp ep = dwarf_ep(frameIndex, ofi, dcontext, absolute_ip, functionStartAddress, XEPp, arityCode); T_sp functionDescriptionOrNil = nil(); if (gc::IsA(ep)) functionDescriptionOrNil = gc::As_unsafe(ep)->functionDescription(); else if (gc::IsA(ep)) functionDescriptionOrNil = gc::As_unsafe(ep)->functionDescription(); - D(printf("%s:%d:%s functionDescriptionOrNil = %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(functionDescriptionOrNil).c_str());); T_sp closure = nil(), args = nil(); - bool args_available = args_for_function(frameIndex, absolute_ip, string, XEPp, arityCode, codeStart, functionStartAddress, ofi, + bool args_available = args_for_function(frameIndex, absolute_ip, arityCode, functionStartAddress, ofi, functionDescriptionOrNil, fbp, closure, args); T_sp fname = nil(); if (gc::IsA(functionDescriptionOrNil)) { fname = gc::As_unsafe(functionDescriptionOrNil)->functionName(); - D(printf("%s%s:%d:%s Using functionDescriptionOrNil %s to get name\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, - _rep_(fname).c_str());); } else if (args_available && gc::IsA(closure)) { - fname = gc::As_unsafe(closure)->functionName(); - D(printf("%s%s:%d:%s Using closure %s to get name\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, - _rep_(fname).c_str());); + Function_sp fclos = closure.as_unsafe(); + functionDescriptionOrNil = fclos->fdesc(); + fname = fclos->functionName(); } - D(printf("%s%s:%d:%s fname = %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(fname).c_str());); if (fname.nilp() && string) { - D(printf( - "%s:%d:%s So sad - the function-description name is NIL and the function-description.nilp()->%d trying to use string\n", - __FILE__, __LINE__, __FUNCTION__, functionDescriptionOrNil.nilp());); fname = SimpleBaseString_O::make(std::string(string)); } - D(printf("%s%s:%d:%s string = %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, string);); return DebuggerFrame_O::make(fname, Cons_O::create(sa, ofi), spi, functionDescriptionOrNil, closure, args, args_available, nil(), INTERN_(kw, lisp), XEPp); } @@ -600,11 +530,10 @@ static bool sanity_check_frame(size_t frameIndex, void* ip, void* fbp) { llvmo::ObjectFile_sp ofi = gc::As_unsafe(of); llvmo::SectionedAddress_sp sa = object_file_sectioned_address(ip, ofi, false); llvmo::DWARFContext_sp dcontext = llvmo::DWARFContext_O::createDWARFContext(ofi); - void* codeStart; void* functionStartAddress; bool XEPp = false; int arityCode; - T_sp ep = dwarf_ep(frameIndex, ofi, dcontext, sa, codeStart, functionStartAddress, XEPp, arityCode); + T_sp ep = dwarf_ep(frameIndex, ofi, dcontext, ip, functionStartAddress, XEPp, arityCode); uintptr_t stackmap_start = (uintptr_t)(ofi->_StackmapStart); uintptr_t stackmap_end = stackmap_start + ofi->_StackmapSize; if (gc::IsA(ep)) { diff --git a/src/core/foundation.cc b/src/core/foundation.cc index 74c67f197d..48357f1bf4 100644 --- a/src/core/foundation.cc +++ b/src/core/foundation.cc @@ -1260,20 +1260,6 @@ T_sp lisp_createStr(const string& s) { return SimpleBaseString_O::make(s); } T_sp lisp_createFixnum(int fn) { return make_fixnum(fn); } -SourcePosInfo_sp lisp_createSourcePosInfo(const string& fileName, size_t filePos, int lineno) { - SimpleBaseString_sp fn = SimpleBaseString_O::make(fileName); - T_mv sfi_mv = core__file_scope(fn); - MultipleValues& mvn = core::lisp_multipleValues(); - Fixnum_sp handle = gc::As(mvn.valueGet(1, sfi_mv.number_of_values())); - int sfindex = unbox_fixnum(handle); - return SourcePosInfo_O::create(sfindex, filePos, lineno, 0); -} - -/*! Create a core:source-pos-info object on the fly */ -SourcePosInfo_sp core__createSourcePosInfo(const string& filename, size_t filePos, int lineno) { - return lisp_createSourcePosInfo(filename, filePos, lineno); -} - T_sp lisp_createList(T_sp a1) { return Cons_O::create(a1, nil()); } T_sp lisp_createList(T_sp a1, T_sp a2) { return Cons_O::createList(a1, a2); }; T_sp lisp_createList(T_sp a1, T_sp a2, T_sp a3) { return Cons_O::createList(a1, a2, a3); }; diff --git a/src/core/function.cc b/src/core/function.cc index c57cf1ac00..40e1c7300b 100644 --- a/src/core/function.cc +++ b/src/core/function.cc @@ -53,6 +53,13 @@ namespace core { bytecode_trampoline_function bytecode_trampoline = bytecode_call; // default +CL_DEFMETHOD Pointer_sp SimpleFun_O::defaultEntryAddress() const { + return Pointer_O::create((void*)(this->_EntryPoints[0])); +} +CL_DEFMETHOD Pointer_sp SimpleFun_O::arityEntryAddress(size_t arity) const { + return Pointer_O::create((void*)(this->_EntryPoints[arity+1])); +} + void SimpleFun_O::fixupOneCodePointer(snapshotSaveLoad::Fixup* fixup, void** ptr) { #ifdef USE_PRECISE_GC if (snapshotSaveLoad::operation(fixup) == snapshotSaveLoad::InfoOp) { @@ -72,8 +79,6 @@ void SimpleFun_O::fixupOneCodePointer(snapshotSaveLoad::Fixup* fixup, void** ptr #endif } -CL_DEFMETHOD Pointer_sp SimpleFun_O::defaultEntryAddress() const { SUBCLASS_MUST_IMPLEMENT(); } - SimpleFun_O::SimpleFun_O(FunctionDescription_sp fdesc, T_sp code, const ClaspXepTemplate& entry_point) : Function_O(this), _FunctionDescription(fdesc), _Code(code), _EntryPoints(entry_point) { @@ -125,12 +130,10 @@ CoreFun_O::CoreFun_O(FunctionDescription_sp fdesc, T_sp code, llvmo::validateEntryPoint(code, entry_point); } - void BytecodeSimpleFun_O::set_trampoline(Pointer_sp trampoline) { +void BytecodeSimpleFun_O::set_trampoline(Pointer_sp trampoline) { this->_Trampoline = (BytecodeTrampolineFunction)trampoline->ptr(); } -Pointer_sp SimpleCoreFun_O::defaultEntryAddress() const { return Pointer_O::create((void*)this->_EntryPoints[0]); }; - CL_LISPIFY_NAME("simple-core-fun/code"); CL_DEFMETHOD llvmo::ObjectFile_sp SimpleCoreFun_O::code() const { @@ -142,10 +145,6 @@ CL_LISPIFY_NAME("simple-core-fun-local-fun"); CL_DEFMETHOD CoreFun_sp SimpleCoreFun_O::localFun() const { return this->_localFun; } -Pointer_sp CoreFun_O::defaultEntryAddress() const { return Pointer_O::create((void*)this->_Entry); }; - -Pointer_sp BytecodeSimpleFun_O::defaultEntryAddress() const { return Pointer_O::create((void*)this->_EntryPoints[0]); }; - CL_LISPIFY_NAME("bytecode-simple-fun/code"); CL_DEFMETHOD BytecodeModule_sp BytecodeSimpleFun_O::code() const { diff --git a/src/core/lambdaListHandler.cc b/src/core/lambdaListHandler.cc index 672105f9ba..ab344dc246 100644 --- a/src/core/lambdaListHandler.cc +++ b/src/core/lambdaListHandler.cc @@ -905,7 +905,7 @@ List_sp process_macro_lambda_list(List_sp lambda_list) { Symbol_sp name_symbol = cl__gensym(SimpleBaseString_O::make("macro-name")); // SourceCodeList_sp new_name_ll = // SourceCodeCons_O::createWithDuplicateSourceCodeInfo(name_symbol,new_lambda_list,lambda_list,_lisp); - ql::list sclist; // (af_lineNumber(lambda_list),af_column(lambda_list),core__file_scope(lambda_list)); + ql::list sclist; sclist << whole_symbol << environment_symbol << Cons_O::create(name_symbol, new_lambda_list); List_sp macro_ll = sclist.cons(); return macro_ll; diff --git a/src/core/readtable.cc b/src/core/readtable.cc index 2d10475d8e..9efdfd305a 100644 --- a/src/core/readtable.cc +++ b/src/core/readtable.cc @@ -269,18 +269,16 @@ CL_DECLARE(); CL_DOCSTRING(R"dx(Error signaler for when a comma (or splice) is outside a backquote.)dx"); DOCGROUP(clasp); CL_DEFUN T_mv core__reader_error_backquote_context(T_sp sin) { - FileScope_sp info = gc::As(core__file_scope(sin)); - // FIXME: Use a real condition class. - // SIMPLE_ERROR("Comma outside of backquote in file: {} line: {}", info->fileName() , stream_input_line(sin)); - string fn = info->fileName(); - if (fn.compare("-no-name-") == 0) { - READER_ERROR(SimpleBaseString_O::make("Comma outside of backquote in stream at line: ~a column ~a."), - Cons_O::createList(Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), + T_sp path = stream_pathname(sin); + if (path.nilp()) { + READER_ERROR(SimpleBaseString_O::make("Comma outside of backquote in stream: ~a at line: ~a column ~a."), + Cons_O::createList(sin, + Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); } else { READER_ERROR(SimpleBaseString_O::make("Comma outside of backquote in file: ~a line: ~a column ~a."), - Cons_O::createList(SimpleBaseString_O::make(fn), + Cons_O::createList(path, Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); @@ -329,16 +327,16 @@ CL_DECLARE(); CL_DOCSTRING(R"dx(reader_error_unmatched_close_parenthesis)dx"); DOCGROUP(clasp); CL_DEFUN T_mv core__reader_error_unmatched_close_parenthesis(T_sp sin, Character_sp ch) { - FileScope_sp info = gc::As(core__file_scope(sin)); - string fn = info->fileName(); - if (fn.compare("-no-name-") == 0) { - READER_ERROR(SimpleBaseString_O::make("Unmatched close parenthesis in stream at line: ~a column ~a."), - Cons_O::createList(Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), + T_sp path = stream_pathname(sin); + if (path.nilp()) { + READER_ERROR(SimpleBaseString_O::make("Unmatched close parenthesis in stream ~a at line: ~a column ~a."), + Cons_O::createList(sin, + Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); } else { READER_ERROR(SimpleBaseString_O::make("Unmatched close parenthesis in file ~a line: ~a column ~a."), - Cons_O::createList(SimpleBaseString_O::make(fn), + Cons_O::createList(path, Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); @@ -405,18 +403,15 @@ CL_DEFUN T_mv core__dispatch_macro_character(T_sp sin, Character_sp ch) { Character_sp subchar = gc::As(cl__read_char(sin, _lisp->_true(), nil(), _lisp->_true())); T_sp macro_func = cl__get_dispatch_macro_character(ch, subchar, _lisp->getCurrentReadTable()); if (macro_func.nilp()) { - // SIMPLE_ERROR("Undefined reader macro for {} {}", _rep_(ch) , _rep_(subchar)); - // Need to be a reader error - FileScope_sp info = gc::As(core__file_scope(sin)); - string fn = info->fileName(); - if (fn.compare("-no-name-") == 0) { - READER_ERROR(SimpleBaseString_O::make("Undefined reader macro for char '~a' subchar '~a' in stream at line: ~a column ~a."), - Cons_O::createList(ch, subchar, Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), + T_sp path = stream_pathname(sin); + if (path.nilp()) { + READER_ERROR(SimpleBaseString_O::make("Undefined reader macro for char '~a' subchar '~a' in stream ~a at line: ~a column ~a."), + Cons_O::createList(ch, subchar, sin, Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); } else { READER_ERROR(SimpleBaseString_O::make("Undefined reader macro for char '~a' subchar '~a' in file ~a line: ~a column ~a."), - Cons_O::createList(ch, subchar, SimpleBaseString_O::make(fn), + Cons_O::createList(ch, subchar, path, Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); diff --git a/src/core/sourceFileInfo.cc b/src/core/sourceFileInfo.cc index 363e05e993..4273a83bd5 100644 --- a/src/core/sourceFileInfo.cc +++ b/src/core/sourceFileInfo.cc @@ -45,6 +45,14 @@ THE SOFTWARE. namespace core { +static FileScope_sp fscope_from_handle(unsigned int handle) { + WITH_READ_LOCK(globals_->_SourceFilesMutex); + if (handle >= _lisp->_Roots._SourceFiles.size()) { + handle = 0; + } + return _lisp->_Roots._SourceFiles[handle]; +} + CL_LAMBDA(name); CL_DECLARE(); CL_DOCSTRING( @@ -62,19 +70,13 @@ CL_DEFUN T_mv core__file_scope(T_sp sourceFile) { } return _lisp->getOrRegisterFileScope(gc::As(ns)->get_std_string()); } else if (sourceFile.fixnump()) { - WITH_READ_LOCK(globals_->_SourceFilesMutex); - Fixnum_sp fnSourceFile(gc::As(sourceFile)); - size_t idx = unbox_fixnum(fnSourceFile); - if (idx >= _lisp->_Roots._SourceFiles.size()) { - idx = 0; - } - return Values(_lisp->_Roots._SourceFiles[idx], fnSourceFile); + return Values(fscope_from_handle(sourceFile.unsafe_fixnum()), sourceFile); } else if (cl__streamp(sourceFile)) { T_sp so = sourceFile; T_sp sfi = clasp_input_source_file_info(so); return core__file_scope(sfi); - } else if (FileScope_sp sfi = sourceFile.asOrNull()) { - return _lisp->getOrRegisterFileScope(sfi->namestring()); + } else if (sourceFile.isA()) { + return sourceFile; } else if (SourcePosInfo_sp spi = sourceFile.asOrNull()) { return core__file_scope(make_fixnum(spi->_FileId)); } @@ -84,6 +86,10 @@ CL_DEFUN T_mv core__file_scope(T_sp sourceFile) { namespace core { +Pathname_sp SourcePosInfo_O::pathname() const { + return fscope_from_handle(this->_FileId)->pathname(); +} + uint clasp_sourcePosInfo_fileHandle(SourcePosInfo_sp info) { return info->_FileId; } size_t clasp_sourcePosInfo_filepos(SourcePosInfo_sp info) { return info->_Filepos; } @@ -123,8 +129,6 @@ CL_DEFUN Integer_sp core__source_pos_info_filepos(T_sp info) { SIMPLE_ERROR("Argument {} must be a source-pos-info object", _rep_(info)); } -uint clasp_sourcePosInfo_lineno(SourcePosInfo_sp info) { return info->_Lineno; } - CL_LAMBDA(source-pos-info); CL_DECLARE(); CL_DOCSTRING(R"dx(sourcePosInfoLineno)dx"); @@ -133,7 +137,7 @@ CL_DEFUN Fixnum_sp core__source_pos_info_lineno(T_sp info) { if (info.nilp()) return make_fixnum(0); if (gc::IsA(info)) { - return Integer_O::create((gc::Fixnum)clasp_sourcePosInfo_lineno(gc::As_unsafe(info))); + return Integer_O::create(info.as_unsafe()->_Lineno); } SIMPLE_ERROR("Argument {} must be a source-pos-info object", _rep_(info)); } @@ -148,7 +152,7 @@ CL_DEFUN Fixnum_sp core__source_pos_info_column(T_sp info) { if (info.nilp()) return make_fixnum(0); if (gc::IsA(info)) { - return make_fixnum(clasp_sourcePosInfo_column(gc::As_unsafe(info))); + return Integer_O::create(info.as_unsafe()->_Column); } SIMPLE_ERROR("Argument {} must be a source-pos-info object", _rep_(info)); } @@ -156,43 +160,7 @@ CL_DEFUN Fixnum_sp core__source_pos_info_column(T_sp info) { namespace core { -#define ARGS_af_lineno "(arg)" -#define DECL_af_lineno "" -#define DOCS_af_lineno "lineNumber" -uint af_lineno(T_sp obj) { - if (obj.nilp()) { - return 0; - } else if (Cons_sp co = obj.asOrNull()) { - IMPLEMENT_MEF(fmt::format("Handle cons {} for af_lineno", _rep_(co))); - } else if (cl__streamp(obj)) { - return stream_input_line_as_uint(obj); - } else if (Function_sp fo = obj.asOrNull()) { - return af_lineno(fo->sourcePosInfo()); - } else if (SourcePosInfo_sp info = obj.asOrNull()) { - return info->_Lineno; - } - SIMPLE_ERROR("Implement lineNumber for {}", _rep_(obj)); -}; - -#define ARGS_af_column "(arg)" -#define DECL_af_column "" -#define DOCS_af_column "column" -uint af_column(T_sp obj) { - if (obj.nilp()) { - return 0; - } else if (gc::IsA(obj)) { - IMPLEMENT_MEF("Handle cons for af_column"); - } else if (cl__streamp(obj)) { - return stream_input_column_as_uint(obj); - } else if (Function_sp fo = obj.asOrNull()) { - return af_column(fo->sourcePosInfo()); - } else if (SourcePosInfo_sp info = obj.asOrNull()) { - return info->_Column; - } - SIMPLE_ERROR("Implement column for {}", _rep_(obj)); -}; - -FileScope_O::FileScope_O() : Base(), _PermanentPathName(NULL), _PermanentFileName(NULL){}; +FileScope_O::FileScope_O() : Base(){}; void FileScope_O::initialize() { this->Base::initialize(); } @@ -234,39 +202,6 @@ string FileScope_O::__repr__() const { return ss.str(); } -string FileScope_O::fileName() const { - String_sp s = gc::As(cl__file_namestring(this->_pathname)); - return s->get_std_string(); -} - -string FileScope_O::namestring() const { - String_sp s = gc::As(cl__namestring(this->_pathname)); - return s->get_std_string(); -} - -string FileScope_O::parentPathName() const { - String_sp s = gc::As(cl__directory_namestring(this->_pathname)); - return s->get_std_string(); -} - -const char* FileScope_O::permanentPathName() { - if (this->_PermanentPathName == NULL) { - string fn = this->namestring(); - this->_PermanentPathName = (char*)malloc(fn.size() + 1); - ::strcpy(this->_PermanentPathName, fn.c_str()); - } - return this->_PermanentPathName; -} - -const char* FileScope_O::permanentFileName() { - if (this->_PermanentFileName == NULL) { - string fn = this->fileName(); - this->_PermanentFileName = (char*)malloc(fn.size() + 1); - ::strcpy(this->_PermanentFileName, fn.c_str()); - } - return this->_PermanentFileName; -} - CL_DOCSTRING( R"dx(Like make-pathname lets you build a source-pos-info object from scratch or by referencing a defaults source-pos-info that provides default information)dx"); CL_LAMBDA(&key (filename "-nofile-" filenamep) (filepos 0 fileposp) (lineno 0 linenop) (column 0 columnp) (function-scope nil function_scope_p) (inlined-at nil inlined_at_p) (defaults nil defaults_p)); @@ -427,18 +362,4 @@ string SourcePosInfo_O::__repr__() const { return ss.str(); } -#if 0 -bool SourcePosInfo_O::equalp(T_sp other) const { - if (!other.generalp()) return false; - if (this == &*other) return true; - if (!gc::IsA(other)) return false; - SourcePosInfo_sp spi_other = gc::As_unsafe(other); - if (this->_FileId != spi_other->_FileId) return false; - if (this->_Filepos != spi_other->_Filepos) return false; - if (this->_Lineno != spi_other->_Lineno) return false; - if (this->_Column != spi_other->_Column) return false; - return true; -} -#endif - }; // namespace core diff --git a/src/lisp/cscript.lisp b/src/lisp/cscript.lisp index 36aaec38e7..8e8b78be81 100644 --- a/src/lisp/cscript.lisp +++ b/src/lisp/cscript.lisp @@ -37,7 +37,6 @@ #~"kernel/cmp/startup-primitives.lisp" #~"kernel/cmp/primitives.lisp" #~"kernel/cmp/cmpir.lisp" - #~"kernel/cmp/debuginfo.lisp" #~"kernel/cmp/cmprunall.lisp" #~"kernel/cmp/cmpliteral.lisp" #~"kernel/cmp/typeq.lisp" @@ -147,7 +146,6 @@ #~"kernel/stage/base/1-end.lisp" #~"kernel/stage/base/2-begin.lisp" :clasp-cleavir - #~"kernel/cmp/arguments.lisp" #~"kernel/lsp/queue.lisp" ;; cclasp sources #~"kernel/lsp/generated-encodings.lisp" #~"kernel/lsp/process.lisp" diff --git a/src/lisp/kernel/clasp-builder.lisp b/src/lisp/kernel/clasp-builder.lisp index ba2665b7db..11cd3f8c3c 100644 --- a/src/lisp/kernel/clasp-builder.lisp +++ b/src/lisp/kernel/clasp-builder.lisp @@ -230,13 +230,11 @@ (message :err "About to exit clasp"))) (defun prepare-metadata (system - &aux (make-create-file-args (find-symbol "MAKE-CREATE-FILE-ARGS" "CMP"))) - "Call make-create-file-args with each system path and the installed path so that when the -DIFile is actually created the argument list passed to llvm-sys:create-file will have already -been initialized with install path versus the build path of the source code file." + &aux (setf-translation (fdefinition (list 'setf (find-symbol "DEBUG-PATHNAME-TRANSLATION" "CLASP-CLEAVIR"))))) + "Set up translations for debug info such that we dump the installed paths into DWARF, rather than the build-time logical pathname translation." (mapc #'(lambda (entry &aux (source-path (getf entry :source-path)) (install-path (getf entry :install-path))) - (funcall make-create-file-args source-path (namestring source-path) install-path)) + (funcall setf-translation install-path source-path)) system)) (defun link-modules (output-file all-modules) diff --git a/src/lisp/kernel/cleavir/arguments.lisp b/src/lisp/kernel/cleavir/arguments.lisp new file mode 100644 index 0000000000..788a64b4c0 --- /dev/null +++ b/src/lisp/kernel/cleavir/arguments.lisp @@ -0,0 +1,582 @@ +(in-package :cmp) + +(defgeneric xep-nargs (arguments)) + +(defclass xep-arguments () ()) +(defclass general-xep-arguments (xep-arguments) + ((%array :initarg :array :reader xep-array) + (%nargs :initarg :nargs :reader xep-nargs))) +(defclass fixed-xep-arguments (xep-arguments) + ((%arguments :initarg :arguments :reader xep-arguments) + (%vrtypes :initarg :vrtypes :reader xep-vrtypes))) + +(defmethod xep-nargs ((arguments fixed-xep-arguments)) + (irc-size_t (length (xep-arguments arguments)))) + +;;; Generate code to get the nth argument (i.e. an LLVM Value) and return it. +;;; n is a constant (i.e. a Lisp integer). +(defgeneric nth-arg (arguments n)) +(defmethod nth-arg ((args general-xep-arguments) n) + (irc-t*-load (irc-typed-gep (llvm-sys:array-type-get %t*% 0) + (xep-array args) (list 0 n) "arg*"))) +(defmethod nth-arg ((args fixed-xep-arguments) n) + (nth n (xep-arguments args))) + +;;; Get the vrtype for the nth argument. +(defgeneric nth-vrtype (arguments n)) +(defmethod nth-vrtype ((args general-xep-arguments) n) + ;; rest arguments are always boxed at the moment. + (declare (ignore n)) + :object) +(defmethod nth-vrtype ((args fixed-xep-arguments) n) + (nth n (xep-vrtypes args))) + +;;; Generate code to get the arguments starting with the nth as an array. +;;; n is a constant (i.e. a Lisp integer). +(defgeneric remaining-args (args n)) +(defmethod remaining-args ((args general-xep-arguments) n) + ;; Note that n (a constant) must be less than nargs (a variable) for the + ;; GEP to be a valid pointer. We don't load from it in that case, but we + ;; still don't want to use an inbounds GEP because poison is bad. + (irc-const-gep1-64 %t**% (xep-array args) n "args")) +(defmethod remaining-args ((args fixed-xep-arguments) n) + ;; Here we have to actually allocate, and then fill it up. + ;; Since we have a constant nargs and constant n, the size of the + ;; allocation is fixed. + (let* ((vals (xep-arguments args)) + (size (- (length vals) n))) + (if (<= size 0) + (llvm-sys:constant-pointer-null-get %t**%) + (let ((res (alloca %t*% size))) + ;; Fill it up. + (loop for arg in (nthcdr n vals) + for vrt in (nthcdr n (xep-vrtypes args)) + for cast = (clasp-cleavir::cast-one vrt :object arg) + for i from 0 + for addr = (irc-typed-gep (llvm-sys:array-type-get %t*% 0) + res (list 0 i)) + do (irc-store cast addr)) + res)))) + +(defun compile-wrong-number-arguments-block (fname nargs min max) + ;; make a new irbuilder, so as to not disturb anything + (with-irbuilder ((llvm-sys:make-irbuilder (thread-local-llvm-context))) + (let ((errorb (irc-basic-block-create "wrong-num-args"))) + (irc-begin-block errorb) + (irc-intrinsic "cc_wrong_number_of_arguments" + ;; We use low max to indicate no upper limit. + fname nargs min (or max (irc-size_t 0))) + (irc-unreachable) + errorb))) + +;; Generate code to signal an error iff there weren't enough arguments provided. +(defun compile-error-if-not-enough-arguments (error-block cmin nargs) + (let* ((cont-block (irc-basic-block-create "enough-arguments")) + (cmp (irc-icmp-ult nargs cmin))) + (irc-cond-br cmp error-block cont-block) + (irc-begin-block cont-block))) + +;; Ditto but with too many. +(defun compile-error-if-too-many-arguments (error-block cmax nargs) + (let* ((cont-block (irc-basic-block-create "enough-arguments")) + (cmp (irc-icmp-ugt nargs cmax))) + (irc-cond-br cmp error-block cont-block) + (irc-begin-block cont-block))) + +;; Generate code to bind the required arguments. Return the LLVM values. +(defun compile-required-arguments (xepargs reqargs) + ;; reqargs is as returned from process-lambda-list- (# ...) where # is the count. + (loop for i from 0 + for req in (rest reqargs) ; maybe use for naming? + for arg = (nth-arg xepargs i) + for src-vrtype = (nth-vrtype xepargs i) + for dest-vrtype = (first (clasp-cleavir-bmir::rtype req)) + collect (clasp-cleavir::cast-one src-vrtype dest-vrtype arg))) + +(defgeneric compile-optional-arguments (xepargs optargs nreq false true)) +(defmethod compile-optional-arguments ((xepargs general-xep-arguments) + optargs nreq false true) + ;; General case: variadic call. + ;; optargs is (# var suppliedp default ...) + ;; We basically generate a switch. + ;; For (&optional a b) for example, + #| +size_t nargs_remaining; +switch (nargs) { + case 0: a = [nil]; a_p = [nil]; b = [nil]; b_p = [nil]; break; + case 1: a = va_arg(); a_p = [t]; b = [nil]; b_p = [nil]; break; + default: a = va_arg(); a_p = [t]; b = va_arg(); b_p = [t]; break; +} + |# + ;; All these assignments are done with phi so it's a bit more confusing to follow, unfortunately. + (let* ((nargs (xep-nargs xepargs)) + (nopt (first optargs)) + (nfixed (+ nopt nreq)) + (opts (rest optargs)) + (enough (irc-basic-block-create "enough-for-optional")) + (sw (irc-switch nargs enough nopt)) + (assn (irc-basic-block-create "optional-assignments")) + (final (irc-basic-block-create "done-parsing-optionals"))) + ;; We generate the assignments first, although they occur last. + ;; It's just a bit more convenient to do that way. + (irc-begin-block assn) + (multiple-value-bind (var-phis suppliedp-phis) + (loop with npreds = (1+ nopt) + for (var suppliedp) on opts by #'cdddr + for var-rtype = (first (clasp-cleavir-bmir:rtype var)) + for var-ltype = (clasp-cleavir::vrtype->llvm var-rtype) + for suppliedp-rtype = (first (clasp-cleavir-bmir:rtype suppliedp)) + for suppliedp-ltype = (clasp-cleavir::vrtype->llvm suppliedp-rtype) + collect (irc-phi var-ltype npreds) into var-phis + collect (irc-phi suppliedp-ltype npreds) into suppliedp-phis + finally (return (values var-phis suppliedp-phis))) + (irc-br final) + ;; Generate a block for each case. + (do ((i nreq (1+ i))) + ((= i nfixed)) + (let ((new (irc-basic-block-create (core:fmt nil "supplied-{}-arguments" i)))) + (llvm-sys:add-case sw (irc-size_t i) new) + (irc-begin-block new) + ;; Assign each optional parameter accordingly. + (loop for (var suppliedp) on opts by #'cdddr + for var-rtype = (first (clasp-cleavir-bmir::rtype var)) + for var-ltype = (clasp-cleavir::vrtype->llvm var-rtype) + for suppliedp-rtype = (first (clasp-cleavir-bmir:rtype suppliedp)) + for var-phi in var-phis + for suppliedp-phi in suppliedp-phis + for j from nreq + for enough = (< j i) + for src-vrtype = (nth-vrtype xepargs j) + for sp = (ecase suppliedp-rtype + (:object (if enough true false)) + (:boolean (jit-constant-i1 (if enough 1 0)))) + for val = (if enough + (clasp-cleavir::cast-one src-vrtype var-rtype + (nth-arg xepargs j)) + (llvm-sys:poison-value-get var-ltype)) + do (irc-phi-add-incoming suppliedp-phi sp new) + (irc-phi-add-incoming var-phi val new)) + (irc-br assn))) + ;; Default case: everything gets a value and a suppliedp=T. + (irc-begin-block enough) + (loop for (var suppliedp) on opts by #'cdddr + for var-phi in var-phis + for suppliedp-phi in suppliedp-phis + for i from nreq + for var-rtype = (first (clasp-cleavir-bmir:rtype var)) + for src-vrtype = (nth-vrtype xepargs i) + for suppliedp-rtype = (first (clasp-cleavir-bmir:rtype suppliedp)) + for val = (clasp-cleavir::cast-one src-vrtype var-rtype + (nth-arg xepargs i)) + do (irc-phi-add-incoming var-phi val enough) + (irc-phi-add-incoming suppliedp-phi + (ecase suppliedp-rtype + (:object true) + (:boolean (jit-constant-i1 1))) + enough)) + (irc-br assn) + ;; ready to generate more code + (irc-begin-block final) + (loop for (var suppliedp) on opts by #'cdddr + for var-phi in var-phis + for suppliedp-phi in suppliedp-phis + collect var-phi collect suppliedp-phi)))) + +(defmethod compile-optional-arguments ((xepargs fixed-xep-arguments) + optargs nreq false true) + ;; Specific case: Argcount is known. Optional processing is basically + ;; trivial in this circumstance. + (loop with args = (nthcdr nreq (xep-arguments xepargs)) + with src-vrtypes = (nthcdr nreq (xep-vrtypes xepargs)) + for (var suppliedp) on (rest optargs) by #'cdddr + for var-rtype = (first (clasp-cleavir-bmir:rtype var)) + for var-ltype = (clasp-cleavir::vrtype->llvm var-rtype) + for suppliedp-rtype = (first (clasp-cleavir-bmir:rtype suppliedp)) + for arg = (pop args) + for val = (if (null arg) + (llvm-sys:poison-value-get + (clasp-cleavir::vrtype->llvm var-rtype)) + (clasp-cleavir::cast-one (pop src-vrtypes) var-rtype arg)) + for sp = (ecase suppliedp-rtype + (:object (if (null arg) false true)) + (:boolean (jit-constant-i1 (if (null arg) 0 1)))) + collect val collect sp)) + +(defun compile-rest-argument (rest-var varest-p rest-alloc args nremaining) + (cmp:irc-branch-to-and-begin-block + (cmp:irc-basic-block-create "process-rest-argument")) + (let ((rtype (first (clasp-cleavir-bmir:rtype rest-var)))) + (list + (cond ((eq rest-alloc 'ignore) + ;; &rest variable is ignored- allocate nothing + (llvm-sys:poison-value-get (clasp-cleavir::vrtype->llvm rtype))) + ((eq rest-alloc 'dynamic-extent) + ;; Do the dynamic extent thing- alloca, then an intrinsic to initialize it. + (let ((rrest (alloca-dx-list :length nremaining :label "rrest"))) + (clasp-cleavir::cast-one + :object rtype + (irc-intrinsic "cc_gatherDynamicExtentRestArguments" + args nremaining + (irc-bit-cast rrest %t**%))))) + (varest-p + (ecase rtype + (:vaslist + (irc-make-vaslist nremaining args "va-rest-arg")) + (:object + (irc-intrinsic "cc_gatherVaRestArguments" + args nremaining (alloca-vaslist :label "rest"))))) + (t + ;; general case- heap allocation + (clasp-cleavir::cast-one + :object rtype + (irc-intrinsic "cc_gatherRestArguments" + args nremaining))))))) + +#| +Keyword processing is the most complicated part, unsurprisingly. +We process the arguments from back to front, e.g. in :a 7 :a 8 we'd set A +to 8 first, and then to 7 later, since the semantics demand that A +eventually end up as 7. +Here is pseudo-C for the parser for (&key a). [foo] indicates an inserted constant. +Having to write with phi nodes unfortunately makes things rather more confusing. + +if ((remaining_nargs % 2) == 1) + cc_oddKeywordException([*fname*]); +tstar bad_keyword = poison; +bool seen_bad_keyword = false; +tstar allow_other_keys = [nil], allow_other_keys_p = [nil]; +for (; remaining_nargs != 0; remaining_nargs -= 2) { + tstar key = remaining_args[remaining_nargs - 2]; + tstar value = remaining_args[remaining_nargs - 1]; + if (key == [:a]) { + a_p = [t]; a = value; continue; + } + ...ditto for other keys... + if (key == [:allow-other-keys]) { + allow_other_keys_p = [t]; allow_other_keys = value; continue; + } else { seen_bad_keyword = true; bad_keyword = key; } +} +if (seen_bad_keyword) + cc_ifBadKeywordArgumentException(allow_other_keys, bad_keyword, [*fname*]); +|# + +;;; Returns a new block that is jumped to when the keyword does match. +;;; This is used to set up a phi to actually "assign" the value. +(defun compile-one-key-test (keyword key-arg cont-block) + (let* ((keystring (string keyword)) + ;; NOTE: We might save a bit of time by moving this out of the loop. + ;; Or maybe LLVM can handle it. I don't know. + (key-const (clasp-cleavir::literal keyword)) + (match (irc-basic-block-create (core:fmt nil "matched-{}" keystring))) + (mismatch (irc-basic-block-create (core:fmt nil "not-{}" keystring)))) + (irc-cond-br (irc-icmp-eq key-arg key-const) match mismatch) + (irc-begin-block match) + (irc-br cont-block) + (irc-begin-block mismatch) + match)) + +(defun compile-key-arguments (keyargs lambda-list-aokp nremaining remaining false true fname) + (macrolet ((do-keys ((keyword) &body body) + `(do* ((cur-key (cdr keyargs) (cddddr cur-key)) + (,keyword (car cur-key) (car cur-key))) + ((endp cur-key)) + ,@body))) + (let ((aok-parameter-p nil) + allow-other-keys + (nkeys (car keyargs)) + (poison (llvm-sys:poison-value-get %t*%)) + (start (irc-basic-block-create "parse-key-arguments")) + (matching (irc-basic-block-create "match-keywords")) + (after (irc-basic-block-create "after-kw-loop")) + (unknown-kw (irc-basic-block-create "unknown-kw")) + (kw-loop (irc-basic-block-create "kw-loop")) + (kw-loop-continue (irc-basic-block-create "kw-loop-continue"))) + ;; Prepare for :allow-other-keys. + (unless lambda-list-aokp + ;; Is there an allow-other-keys argument? + (do-keys (key) + (when (eq key :allow-other-keys) (setf aok-parameter-p t) (return))) + ;; If there's no allow-other-keys argument, add one. + (unless aok-parameter-p + (setf keyargs (list* (1+ (car keyargs)) + ;; default, var, and suppliedp are of course dummies. + ;; At the end we can check aok-parameter-p to avoid + ;; actually assigning to them. + :allow-other-keys nil nil nil + (cdr keyargs))))) + (irc-branch-to-and-begin-block start) + ;; If the number of arguments remaining is odd, the call is invalid- error. + (let* ((odd-kw (irc-basic-block-create "odd-kw")) + (rem (irc-srem nremaining (irc-size_t 2))) ; parity + (evenp (irc-icmp-eq rem (irc-size_t 0)))) ; is parity zero (is SUB even)? + (irc-cond-br evenp kw-loop odd-kw) + ;; There have been an odd number of arguments, so signal an error. + (irc-begin-block odd-kw) + (irc-intrinsic "cc_oddKeywordException" fname) + (irc-unreachable)) + ;; Loop starts; welcome hell + (irc-begin-block kw-loop) + (let ((top-param-phis nil) (top-suppliedp-phis nil) + (new-blocks nil) + (nargs-remaining (irc-phi %size_t% 2 "nargs-remaining")) + (sbkw (irc-phi %i1% 2 "seen-bad-keyword")) + (bad-keyword (irc-phi %t*% 2 "bad-keyword"))) + (irc-phi-add-incoming nargs-remaining nremaining start) + (irc-phi-add-incoming sbkw (jit-constant-false) start) + (irc-phi-add-incoming bad-keyword poison start) + (loop for (key) on (cdr keyargs) by #'cddddr + for var-phi = (irc-phi %t*% 2 (format nil "~a-top" key)) + for suppliedp-phi = (irc-phi %t*% 2 (format nil "~s-suppliedp-top" key)) + do (push var-phi top-param-phis) + (push suppliedp-phi top-suppliedp-phis) + ;; If we're paying attention to :allow-other-keys, track it specially + ;; and initialize it to NIL. + (cond ((and (not lambda-list-aokp) (eq key :allow-other-keys)) + (irc-phi-add-incoming var-phi false start) + (setf allow-other-keys var-phi)) + (t (irc-phi-add-incoming var-phi poison start))) + (irc-phi-add-incoming suppliedp-phi false start)) + (setf top-param-phis (nreverse top-param-phis) + top-suppliedp-phis (nreverse top-suppliedp-phis)) + ;; Are we done? + (let ((zerop (irc-icmp-eq nargs-remaining (irc-size_t 0)))) + (irc-cond-br zerop after matching)) + (irc-begin-block matching) + ;; Start matching keywords + ;; We process right to left. This means that we process the leftmost + ;; instance of any keyword last, to match the language semantics. + (let* (;; FIXME: These subs can be nuw + (key-idx (irc-sub nargs-remaining (irc-size_t 2) "key-idx")) + (key-addr (irc-typed-gep %t**% remaining (list key-idx) "key*")) + (key-arg (irc-typed-load %t*% key-addr)) + (value-idx (irc-sub nargs-remaining (irc-size_t 1) "val-idx")) + (val-addr (irc-typed-gep %t**% remaining (list value-idx) "value*")) + (value-arg (irc-typed-load %t*% val-addr))) + (do-keys (key) + (push (compile-one-key-test key key-arg kw-loop-continue) new-blocks)) + (setf new-blocks (nreverse new-blocks)) + ;; match failure - as usual, works through phi + (irc-branch-to-and-begin-block unknown-kw) + (irc-br kw-loop-continue) + ;; Go around again. And do most of the actual work in phis. + (irc-begin-block kw-loop-continue) + (let ((npreds (1+ (* 2 nkeys)))) ; two for each key, plus one for unknown-kw. + (let ((bot-sbkw (irc-phi %i1% npreds "seen-bad-keyword-bottom")) + (bot-bad-keyword (irc-phi %t*% npreds "bad-keyword-bottom"))) + ;; Set up the top to use these. + (irc-phi-add-incoming sbkw bot-sbkw kw-loop-continue) + (irc-phi-add-incoming bad-keyword bot-bad-keyword kw-loop-continue) + ;; If we're coming from unknown-kw, store that. + (irc-phi-add-incoming bot-sbkw (jit-constant-true) unknown-kw) + (irc-phi-add-incoming bot-bad-keyword key-arg unknown-kw) + ;; If we're coming from a match block, don't change anything. + (dolist (new-block new-blocks) + (irc-phi-add-incoming bot-sbkw sbkw new-block) + (irc-phi-add-incoming bot-bad-keyword bad-keyword new-block))) + ;; OK now the actual keyword values. + (loop for var-new-block in new-blocks + for top-param-phi in top-param-phis + for top-suppliedp-phi in top-suppliedp-phis + for var-phi = (irc-phi %t*% npreds) + for suppliedp-phi = (irc-phi %t*% npreds) + ;; fix up the top part to take values from here + do (irc-phi-add-incoming top-param-phi var-phi kw-loop-continue) + (irc-phi-add-incoming top-suppliedp-phi suppliedp-phi kw-loop-continue) + ;; If coming from unknown-kw we keep our values the same. + (irc-phi-add-incoming var-phi top-param-phi unknown-kw) + (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi unknown-kw) + ;; All new-blocks other than this key's stick with what they have. + (dolist (new-block new-blocks) + (cond ((eq var-new-block new-block) + ;; Here, however, we get the new values + (irc-phi-add-incoming var-phi value-arg new-block) + (irc-phi-add-incoming suppliedp-phi true new-block)) + (t + (irc-phi-add-incoming var-phi top-param-phi new-block) + (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi new-block))))))) + (let ((dec (irc-sub nargs-remaining (irc-size_t 2)))) + (irc-phi-add-incoming nargs-remaining dec kw-loop-continue)) + (irc-br kw-loop) + ;; Loop over. + (irc-begin-block after) + ;; If we hit a bad keyword, and care, signal an error. + (unless lambda-list-aokp + (let ((aok-check (irc-basic-block-create "aok-check")) + (kw-assigns (irc-basic-block-create "kw-assigns"))) + (irc-cond-br sbkw aok-check kw-assigns) + (irc-begin-block aok-check) + (irc-intrinsic + "cc_ifBadKeywordArgumentException" + ;; aok was initialized to NIL, regardless of the suppliedp, so this is ok. + allow-other-keys bad-keyword fname) + (irc-br kw-assigns) + (irc-begin-block kw-assigns))) + (loop for top-param-phi in top-param-phis + for top-suppliedp-phi in top-suppliedp-phis + for (key) on (cdr keyargs) by #'cddddr + when (or (not (eq key :allow-other-keys)) + lambda-list-aokp aok-parameter-p) + collect top-param-phi + and collect top-suppliedp-phi))))) + +(defun compile-general-lambda-list-code (reqargs + optargs + rest-var + varest-p + key-flag + keyargs + allow-other-keys + xepargs + &key (safep t) + fname rest-alloc) + (cmp-log "Entered compile-general-lambda-list-code%N") + (let* ((nargs (xep-nargs xepargs)) + (nreq (car reqargs)) + (nopt (car optargs)) + (nfixed (+ nreq nopt)) + (creq (irc-size_t nreq)) + (cmax (if (or rest-var key-flag) + nil + (irc-size_t nfixed))) + (wrong-nargs-block + (when safep + (compile-wrong-number-arguments-block fname nargs creq cmax))) + ;; NOTE: Sometimes we don't actually need these. + ;; We could save miniscule time by not generating. + (iNIL (clasp-cleavir::%nil)) (iT (clasp-cleavir::%t))) + (append + (unless (zerop nreq) + (when safep + (compile-error-if-not-enough-arguments wrong-nargs-block creq nargs)) + (compile-required-arguments xepargs reqargs)) + (unless (zerop nopt) + (compile-optional-arguments xepargs optargs nreq iNIL iT)) + (if (or rest-var key-flag) + ;; We have &key and/or &rest, so parse with that expectation. + ;; Specifically, we have to get a variable for how many arguments are left after &optional. + (let* ((nremaining + (if (zerop nopt) + ;; With no optional arguments it's trivial. + (irc-sub nargs creq "nremaining") + ;; Otherwise we need nargs - nfixed, clamped to min 0. + ;; (Since nfixed > nargs is possible.) + ;; We used to have compile-optional-arguments return + ;; the number of remaining arguments, but that's a bit + ;; of pointless code for the rare case that we have + ;; both &optional and &rest/&key. + (irc-intrinsic "llvm.usub.sat.i64" nargs + (irc-size_t nfixed)))) + (remaining (remaining-args xepargs nfixed))) + ;; Note that we don't need to check for too many arguments here. + (append + (when rest-var + (compile-rest-argument rest-var varest-p rest-alloc remaining nremaining)) + (when key-flag + (compile-key-arguments keyargs (or allow-other-keys (not safep)) + nremaining remaining iNIL iT fname)))) + (when safep + (cmp-log "Last if-too-many-arguments {} {}" cmax nargs) + (compile-error-if-too-many-arguments wrong-nargs-block cmax nargs) + nil))))) + +(defun lambda-list-arguments (lambda-list) + (multiple-value-bind (reqargs optargs rest-var key-flag keyargs allow-other-keys auxargs varest-p) + (core:process-lambda-list lambda-list 'function) + (declare (ignore auxargs allow-other-keys varest-p key-flag)) + (cmp-log "reqargs = {}%N" reqargs) + (cmp-log "optargs = {}%N" optargs) + (cmp-log "rest-var = {}%N" rest-var) + (cmp-log "keyargs = {}%N" keyargs) + (let ((args '())) + (dolist (req (rest reqargs)) + (cmp-log "req-name = {}%N" req) + (push req args)) + (do ((cur (rest optargs) (cdddr cur))) + ((null cur) nil) + (let ((opt-name (car cur)) + (opt-flag (cadr cur))) + (cmp-log "opt cur = {}%N" cur) + (cmp-log "opt-name = {}%N" opt-name) + (cmp-log "opt-flag = {}%N" opt-flag) + (push opt-name args) + (when opt-flag (push opt-flag args)))) + (when rest-var (push rest-var args)) + (do ((cur (rest keyargs) (cddddr cur))) + ((null cur) nil) + (let ((key-name (caddr cur)) + (key-flag (cadddr cur))) + (cmp-log "key-name = {}%N" key-name) + (cmp-log "key-flag = {}%N" key-flag) + (push key-name args) + (when key-flag (push key-flag args)))) + (nreverse args)))) + +(defun calculate-cleavir-lambda-list-analysis (lambda-list) + ;; we assume that the lambda list is in its correct format: + ;; 1) required arguments are lexical locations. + ;; 2) optional arguments are ( ) + ;; 3) keyword arguments are ( ) + ;; this lets us cheap out on parsing, except &rest and &allow-other-keys. + (cmp-log "calculate-cleavir-lambda-list-analysis lambda-list -> {}%N" lambda-list) + (let (required optional rest-type rest key aok-p key-flag + (required-count 0) (optional-count 0) (key-count 0)) + (dolist (item lambda-list) + (case item + ((&optional) #|ignore|#) + ((&key) (setf key-flag t)) + ((&rest core:&va-rest) (setf rest-type item)) + ((&allow-other-keys) (setf aok-p t)) + (t (if (listp item) + (cond ((= (length item) 2) + ;; optional + (incf optional-count) + ;; above, we expect (location -p whatever) + ;; though it's specified as (var init -p) + ;; fix me + (push (first item) optional) + (push (second item) optional) + (push nil optional)) + (t ;; key, assumedly + (incf key-count) + (push (first item) key) + (push (first item) key) + ;; above, we treat this as being the location, + ;; even though from process-lambda-list it's + ;; the initform. + ;; this file needs work fixme. + (push (second item) key) + (push (third item) key))) + ;; nonlist; we picked off lambda list keywords, so it's an argument. + (cond (rest-type + ;; we've seen a &rest lambda list keyword, so this must be that + (setf rest item)) + ;; haven't seen anything, it's required + (t (incf required-count) + (push item required))))))) + (let* ((cleavir-lambda-list (ensure-cleavir-lambda-list lambda-list)) + (arguments (lambda-list-arguments cleavir-lambda-list))) + (make-cleavir-lambda-list-analysis + :cleavir-lambda-list (ensure-cleavir-lambda-list lambda-list) ; Is this correct? + :lambda-list-arguments arguments + :required (cons required-count (nreverse required)) + :optional (cons optional-count (nreverse optional)) + :rest rest + :key-flag key-flag + :key-count (cons key-count (nreverse key)) + :aok-p aok-p + :aux-p nil ; aux-p; unused here + :va-rest-p (if (eq rest-type 'core:&va-rest) t nil))))) + +;;; Main entry point. Returns the parsed arguments, i.e. a list of LLVM Values +;;; appropriate for the corresponding main function call. (But they're not cast.) +(defun compile-lambda-list-code (cleavir-lambda-list-analysis xepargs + &key (safep t) rest-alloc + (fname (clasp-cleavir::%nil))) + (multiple-value-bind (reqargs optargs rest-var key-flag keyargs allow-other-keys unused-auxs varest-p) + (process-cleavir-lambda-list-analysis cleavir-lambda-list-analysis) + (declare (ignore unused-auxs)) + (compile-general-lambda-list-code reqargs optargs rest-var varest-p + key-flag keyargs allow-other-keys + xepargs + :safep safep :rest-alloc rest-alloc + :fname fname))) diff --git a/src/lisp/kernel/cleavir/cast.lisp b/src/lisp/kernel/cleavir/cast.lisp new file mode 100644 index 0000000000..9ec991a1f5 --- /dev/null +++ b/src/lisp/kernel/cleavir/cast.lisp @@ -0,0 +1,162 @@ +(in-package #:clasp-cleavir) + +;;; Given an LLVM Value, its rtype, and a desired rtype, generate code to +;;; convert the value to the desired rtype. +(defun translate-cast (inputv inputrt outputrt) + ;; most of this is special casing crap due to 1-value values not being + ;; passed around as lists. + (cond ((eq inputrt :multiple-values) + (cond ((eq outputrt :multiple-values) + ;; A NOP like this isn't generated within code, but the + ;; translate-cast in layout-xep can end up here. + inputv) + ((not (listp outputrt)) (error "BUG: Bad rtype ~a" outputrt)) + ((= (length outputrt) 1) + (cast-one :object (first outputrt) + (cmp:irc-tmv-primary inputv))) + ((null outputrt) nil) + (t (cons (cast-one :object (first outputrt) + (cmp:irc-tmv-primary inputv)) + (loop for i from 1 + for ort in (rest outputrt) + for val = (cmp:irc-t*-load (return-value-elt i)) + collect (cast-one :object ort val)))))) + ((eq inputrt :vaslist) + (cond ((eq outputrt :multiple-values) + (%intrinsic-call "cc_load_values" + (list (cmp:irc-vaslist-nvals inputv) + (cmp:irc-vaslist-values inputv)))) + ((and (listp outputrt) (= (length outputrt) 1)) + (cast-one :object (first outputrt) + (cmp:irc-vaslist-nth (%size_t 0) inputv))) + (t (error "BUG: Cast from ~a to ~a" inputrt outputrt)))) + ((not (listp inputrt)) (error "BUG: Bad rtype ~a" inputrt)) + ;; inputrt must be a list (fixed values) + ((= (length inputrt) 1) + (cond ((eq outputrt :multiple-values) + (cmp:irc-make-tmv (%size_t 1) + (cast-one (first inputrt) :object inputv))) + ((not (listp outputrt)) + (error "BUG: Cast from ~a to ~a" inputrt outputrt)) + ((null outputrt) nil) + ((= (length outputrt) 1) + (cast-one (first inputrt) (first outputrt) inputv)) + (t ;; pad with nil + (assert (every (lambda (r) (eq r :object)) (rest outputrt))) + (cons (cast-one (first inputrt) (first outputrt) inputv) + (loop repeat (length (rest outputrt)) + collect (%nil)))))) + (t + (cond ((eq outputrt :multiple-values) + (%cast-to-mv + (loop for inv in inputv for irt in inputrt + collect (cast-one irt :object inv)))) + ((not (listp outputrt)) + (error "BUG: Cast from ~a to ~a" inputrt outputrt)) + ((= (length outputrt) 1) + (cond ((null inputrt) + (ecase (first outputrt) + ((:object) (%nil)) + ;; We can end up here with a variety of output vrtypes + ;; in some unusual situations where a primop expects + ;; a value, but control will never actually reach it. + ;; Ideally the compiler would not bother compiling + ;; such unreachable code, but sometimes it's stupid. + ((:fixnum) (llvm-sys:poison-value-get cmp:%fixnum%)) + ((:single-float) + (llvm-sys:poison-value-get cmp:%float%)) + ((:double-float) + (llvm-sys:poison-value-get cmp:%double%)))) + (t + (cast-one (first inputrt) (first outputrt) + (first inputv))))) + (t (%cast-some inputrt outputrt inputv)))))) + +;;; Given a list of Values, generate code to return it as multiple (Lisp) values. +(defun %cast-to-mv (values) + (cond ((null values) (cmp:irc-make-tmv (%size_t 0) (%nil))) + (t + (loop for i from 1 for v in (rest values) + do (cmp:irc-store v (return-value-elt i))) + (cmp:irc-make-tmv (%size_t (length values)) (first values))))) + +;;; Generate code to cast the Value from the given vrtype to the desired. +(defgeneric cast-one (from to value) + (:method (from to value) + (if (eql from to) + value + (error "BUG: Don't know how to cast ~a ~a to ~a" from value to)))) + +(defmethod cast-one ((from (eql :boolean)) (to (eql :object)) value) + ;; we could use a select instruction, but then we'd have a redundant memory load. + ;; which really shouldn't be a big deal, but why risk it. + (let* ((thenb (cmp:irc-basic-block-create "bool-t")) + (elseb (cmp:irc-basic-block-create "bool-nil")) + (_0 (cmp:irc-cond-br value thenb elseb)) + (merge (cmp:irc-basic-block-create "bool")) + (_1 (cmp:irc-begin-block merge)) + (phi (cmp:irc-phi cmp:%t*% 2 "bool"))) + (declare (ignore _0 _1)) + (cmp:irc-begin-block thenb) + (cmp:irc-phi-add-incoming phi (%t) thenb) + (cmp:irc-br merge) + (cmp:irc-begin-block elseb) + (cmp:irc-phi-add-incoming phi (%nil) elseb) + (cmp:irc-br merge) + (cmp:irc-begin-block merge) + phi)) + +(defmethod cast-one ((from (eql :object)) (to (eql :boolean)) value) + (cmp:irc-icmp-ne value (%nil))) + +(defmethod cast-one ((from (eql :single-float)) (to (eql :object)) value) + (cmp:irc-box-single-float value)) +(defmethod cast-one ((from (eql :object)) (to (eql :single-float)) value) + (cmp:irc-unbox-single-float value)) + +(defmethod cast-one ((from (eql :double-float)) (to (eql :object)) value) + (cmp:irc-box-double-float value)) +(defmethod cast-one ((from (eql :object)) (to (eql :double-float)) value) + (cmp:irc-unbox-double-float value)) + +(defmethod cast-one ((from (eql :base-char)) (to (eql :object)) value) + (cmp:irc-tag-base-char value)) +(defmethod cast-one ((from (eql :object)) (to (eql :base-char)) value) + (cmp:irc-untag-base-char value)) +(defmethod cast-one ((from (eql :character)) (to (eql :object)) value) + (cmp:irc-tag-character value)) +(defmethod cast-one ((from (eql :object)) (to (eql :character)) value) + (cmp:irc-untag-character value)) + +(defmethod cast-one ((from (eql :base-char)) (to (eql :character)) value) + (cmp:irc-zext value cmp:%i32%)) +(defmethod cast-one ((from (eql :character)) (to (eql :base-char)) value) + (cmp:irc-trunc value cmp:%i8%)) + +(defmethod cast-one ((from (eql :fixnum)) (to (eql :object)) value) + (cmp:irc-int-to-ptr value cmp:%t*%)) +(defmethod cast-one ((from (eql :object)) (to (eql :fixnum)) value) + (cmp:irc-ptr-to-int value cmp:%fixnum%)) + +(defmethod cast-one ((from (eql :utfixnum)) (to (eql :fixnum)) value) + (cmp:irc-shl value cmp:+fixnum-shift+ :nsw t)) +(defmethod cast-one ((from (eql :fixnum)) (to (eql :utfixnum)) value) + (cmp:irc-ashr value cmp:+fixnum-shift+ :exact t)) + +(defmethod cast-one ((from (eql :utfixnum)) (to (eql :object)) value) + (cmp:irc-tag-fixnum value)) +(defmethod cast-one ((from (eql :object)) (to (eql :utfixnum)) value) + (cmp:irc-untag-fixnum value cmp:%fixnum%)) + +(defmethod cast-one ((from (eql :object)) (to (eql :vaslist)) value) + ;; We only generate these when we know for sure the input is a vaslist, + ;; so we don't do checking. + (cmp:irc-unbox-vaslist value)) + +(defun %cast-some (inputrt outputrt inputv) + (let ((Lin (length inputrt)) (Lout (length outputrt)) + (pref (mapcar #'cast-one inputrt outputrt inputv))) + (cond ((<= Lout Lin) pref) + (t + (assert (every (lambda (r) (eq r :object)) (subseq outputrt Lin))) + (nconc pref (loop repeat (- Lout Lin) collect (%nil))))))) diff --git a/src/lisp/kernel/cleavir/clasp-cleavir.asd b/src/lisp/kernel/cleavir/clasp-cleavir.asd index a4853df9ca..88122ca690 100644 --- a/src/lisp/kernel/cleavir/clasp-cleavir.asd +++ b/src/lisp/kernel/cleavir/clasp-cleavir.asd @@ -28,6 +28,8 @@ (:file "ir") (:file "jit") (:file "translation-environment") + (:file "cast") + (:file "arguments") (:file "bir") (:file "bmir") (:file "blir") @@ -40,6 +42,7 @@ (:file "interval") (:file "type") (:file "transform") + (:file "debuginfo") (:file "translate") (:file "compile-bytecode") ;;(:file "translate-btb") ; not working yet diff --git a/src/lisp/kernel/cleavir/debuginfo.lisp b/src/lisp/kernel/cleavir/debuginfo.lisp new file mode 100644 index 0000000000..c237e98675 --- /dev/null +++ b/src/lisp/kernel/cleavir/debuginfo.lisp @@ -0,0 +1,325 @@ +(in-package #:clasp-cleavir) + +(defvar *generate-dwarf* t) + +(defvar *dibuilder*) +(defvar *dbg-current-scope*) + +(defun install-compile-unit (dibuilder file) + ;; NOTE: Despite the "create" name, this function also installs the + ;; new DICompileUnit into the DIBuilder. + (llvm-sys:dibuilder/create-compile-unit + dibuilder + llvm-sys:dw-lang-c-plus-plus ; why not dw-lang-common-lisp? + file "Clasp Common Lisp" nil "-v" 1 "the-split-name.log" :full-debug + 0 t nil :dntk-default nil "" "")) + +(defun make-dibuilder (module) + (llvm-sys:make-dibuilder module)) + +;;; Translate a logical pathname into a physical pathname to put into +;;; the DWARF info. Usually this is just translate-logical-pathname. +;;; But during build, our SYS host will point to the build directory, +;;; whereas we might want debug info to point to the install directory. +;;; For that, we can use (SETF DEBUG-PATHNAME-TRANSLATION) to set up +;;; our own mapping, instead of just using TRANSLATE-LOGICAL-PATHNAME. +;;; See PREPARE-METADATA in clasp-builder.lisp. +;;; We do this instead of having a single parameter like +;;; "*source-debug-physical-pathname*" to COMPILE-FILE as we may need +;;; multiple source files for a given input file due to inlining. +(defvar *debug-pathname-translations* (make-hash-table :test #'equal)) +(defun debug-pathname-translation (pathname) + (or (gethash pathname *debug-pathname-translations*) + (translate-logical-pathname pathname))) +(defun (setf debug-pathname-translation) (physical pathname) + (setf (gethash pathname *debug-pathname-translations*) physical)) + +(defun make-difile (pathname) + (let* ((physical (debug-pathname-translation pathname)) + (source (if (core:logical-pathname-p pathname) + (format nil ";; LOGICAL-PATHNAME=~a~%" + (namestring pathname)) + ;; LLVM expects that either all locations have + ;; a SOURCE or none of them do, so we always + ;; put in something. + ";;")) + (filename (file-namestring physical)) + (directory + (namestring + (make-pathname :name nil :type nil :defaults physical)))) + (llvm-sys:dibuilder/create-file *dibuilder* filename directory + nil source))) + +;;; Hash table from pathnames to DIFiles. (So, use an EQUAL test.) +;;; A source file can have other DIFiles in it due to inlining, so this is +;;; pretty important. +(defvar *difile-cache*) + +(defun ensure-difile (pathname) + (or (gethash pathname *difile-cache*) + (setf (gethash pathname *difile-cache*) + (make-difile pathname)))) + +(defun add-module-di-flags (module) + ;; add the flag that defines the Dwarf Version + ;; FIXME: Why do we use a pretty old DWARF version here? + (llvm-sys:add-module-flag + module + (llvm-sys:mdnode-get (cmp:thread-local-llvm-context) + (list + (llvm-sys:value-as-metadata-get (%i32 2)) + (llvm-sys:mdstring-get + (cmp:thread-local-llvm-context) "Dwarf Version") + (llvm-sys:value-as-metadata-get + (%i32 cmp::+debug-dwarf-version+))))) + (llvm-sys:add-module-flag + module + (llvm-sys:mdnode-get (cmp:thread-local-llvm-context) + (list + (llvm-sys:value-as-metadata-get (%i32 2)) + (llvm-sys:mdstring-get + (cmp:thread-local-llvm-context) "Debug Info Version") + (llvm-sys:value-as-metadata-get + (%i32 llvm-sys:+debug-metadata-version+)))))) + +;;; Bind *dibuilder*, and if a pathname is provided, +;;; also bind *dbg-current-scope* to a new DIFile. +;;; Afterwords finalize the DIBuilder, and add debug flags to the module. +(defmacro with-debuginfo ((llvm-ir-module + &key (path nil pathp)) + &body body) + (let ((gbody (gensym "BODY")) + (gmodule (gensym "MODULE"))) + ;; progn to error on declare expressions + `(flet ((,gbody () (progn ,@body))) + (if *generate-dwarf* + (let* ((,gmodule ,llvm-ir-module) + (*dibuilder* (make-dibuilder ,gmodule)) + (*difile-cache* (make-hash-table :test #'equal))) + (unwind-protect + ,(if pathp + `(let ((*dbg-current-scope* + (ensure-difile ,path))) + (install-compile-unit *dibuilder* + *dbg-current-scope*) + (,gbody)) + `(,gbody)) + (llvm-sys:dibuilder/finalize *dibuilder*) + (add-module-di-flags ,gmodule))) + (,gbody))))) + +;; Given a vrtype, create and return a metadata node describing the type +;; for debug information. (LLVM should take care of caching.) +;; FIXME: unhardcode the 64s +(defgeneric vrtype->di (vrtype)) +(defun di-zeroflags () + (core:enum-logical-or llvm-sys:diflags-enum '(llvm-sys:diflags-zero))) +(defun dispflags (&rest flags) + (core:enum-logical-or llvm-sys:dispflag-enum + (or flags '(llvm-sys:dispflag-zero)))) +(defun di-object-type () + (llvm-sys:create-basic-type *dibuilder* "T_O*" 64 + llvm-sys:+dw-ate-address+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :object))) (di-object-type)) +(defmethod vrtype->di ((vrtype (eql :boolean))) + ;; 8 is cargo-culted from what clang does for bool. + (llvm-sys:create-basic-type *dibuilder* "bool" 8 + llvm-sys:+dw-ate-boolean+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :single-float))) + (llvm-sys:create-basic-type *dibuilder* "float" 32 + llvm-sys:+dw-ate-float+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :double-float))) + (llvm-sys:create-basic-type *dibuilder* "double" 64 + llvm-sys:+dw-ate-float+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :base-char))) + (llvm-sys:create-basic-type *dibuilder* "char" 8 + llvm-sys:+dw-ate-unsigned-char+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :character))) + (llvm-sys:create-basic-type *dibuilder* "claspCharacter" 32 + llvm-sys:+dw-ate-unsigned-char+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :fixnum))) + (llvm-sys:create-basic-type *dibuilder* "fixnum" 64 + llvm-sys:+dw-ate-signed+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :utfixnum))) + (llvm-sys:create-basic-type *dibuilder* "utfixnum" 64 + llvm-sys:+dw-ate-unsigned+ (di-zeroflags))) + +(defun create-di-struct-type (dibuilder name elements + &key scope (alignment 64)) + ;; These types are used by the runtime rather than being defined + ;; anywhere, so the file spec is a little dumb. + (let ((file (ensure-difile #p"-implicit-")) (lineno 0)) + (llvm-sys:create-struct-type + dibuilder scope name file lineno + ;; WARNING: This may not work in general, + ;; since e.g. a three slot structure + ;; with 32-64-32 may end up as three words. + ;; I don't know how much this matters. + (loop for ty in elements + sum (llvm-sys:get-size-in-bits ty)) + alignment (di-zeroflags) nil + (llvm-sys:get-or-create-array + dibuilder elements) + 0 nil ""))) + +(defmethod vrtype->di ((vrtype (eql :vaslist))) + (create-di-struct-type + *dibuilder* "vaslist" + (list + (llvm-sys:create-pointer-type + *dibuilder* (di-object-type) 64 64 0 "" nil) + (llvm-sys:create-basic-type + *dibuilder* "size_t" 64 llvm-sys:+dw-ate-unsigned+ (di-zeroflags))))) + +(defgeneric rtype->di (rtype)) +(defmethod rtype->di ((rtype (eql :multiple-values))) + (create-di-struct-type + *dibuilder* "T_mv" + (list + (di-object-type) + (llvm-sys:create-basic-type + *dibuilder* "size_t" 64 llvm-sys:+dw-ate-unsigned+ (di-zeroflags))))) +(defmethod rtype->di ((rtype (eql :vaslist))) + (vrtype->di rtype)) +(defmethod rtype->di ((rtype list)) + (create-di-struct-type *dibuilder* "" (mapcar #'vrtype->di rtype))) + +(defun create-di-main-function-type (ir) + (let* ((returni (bir:returni ir)) + (retrtype (if returni + (cc-bmir:rtype (bir:input returni)) + nil)) + ;; An rtype of () is void, as is a function that never returns. + ;; void is indicated as a null DIType*, which we indicate as NIL. + (ret (if retrtype (rtype->di retrtype) nil)) + (envtypes (loop repeat (cleavir-set:size (bir:environment ir)) + collect (di-object-type))) + ;; FIXME: Recomputes crap from translate + (arguments (compute-arglist (bir:lambda-list ir))) + (arg-rtypes (mapcar #'cc-bmir:rtype arguments)) + (arg-vrtypes (mapcar #'first arg-rtypes)) + (arg-ditypes (mapcar #'vrtype->di arg-vrtypes)) + (paramspec (list* ret (nconc envtypes arg-ditypes))) + (param-array + (llvm-sys:get-or-create-type-array *dibuilder* paramspec))) + (llvm-sys:create-subroutine-type *dibuilder* param-array + (di-zeroflags) 0))) + +;;; Given a source-pos-info, return a pathname, lineno, and column +;;; as values. FIXME: This integer file handle thing is really silly. +(defun spi-info (spi) + (multiple-value-bind (handle filepos lineno column) + (core:source-pos-info-unpack spi) + (declare (ignore filepos)) + (values (core:file-scope-pathname (core:file-scope handle)) + lineno column))) + +(defun create-di-main-function (ir name &key (linkage-name name)) + (let* ((spi (origin-spi (origin-source (bir:origin ir)))) + (path (if spi + (core:source-pos-info/pathname spi) + #p"-unknown-file-")) + (difile (ensure-difile path)) + (lineno (core:source-pos-info-lineno spi))) + (llvm-sys:dibuilder/create-function + *dibuilder* difile name linkage-name difile lineno + (create-di-main-function-type ir) lineno + (di-zeroflags) (dispflags 'llvm-sys:dispflag-definition) + nil nil nil nil ""))) + +(defun create-di-nxep-type (n) + (let* ((args (make-list n :initial-element (di-object-type))) + (params (list* (rtype->di :multiple-values) args))) + (llvm-sys:create-subroutine-type + *dibuilder* + (llvm-sys:get-or-create-type-array *dibuilder* params) + (di-zeroflags) 0))) +(defun create-di-gxep-type () + (let* ((t** (llvm-sys:create-pointer-type + *dibuilder* (di-object-type) 64 64 0 "" nil)) + (size_t + (llvm-sys:create-basic-type + *dibuilder* "size_t" 64 llvm-sys:+dw-ate-unsigned+ + (di-zeroflags))) + (params (list (rtype->di :multiple-values) + (di-object-type) size_t t**))) + (llvm-sys:create-subroutine-type + *dibuilder* + (llvm-sys:get-or-create-type-array *dibuilder* params) + (di-zeroflags) 0))) + +(defun create-di-xep (ir name arity &key (linkage-name name)) + (let* ((spi (origin-spi (origin-source (bir:origin ir)))) + (path (if spi + (core:source-pos-info/pathname spi) + #p"-unknown-file-")) + (difile (ensure-difile path)) + (lineno (core:source-pos-info-lineno spi))) + (llvm-sys:dibuilder/create-function + *dibuilder* difile name linkage-name difile lineno + (if (eq arity :general-entry) + (create-di-gxep-type) + (create-di-nxep-type arity)) + lineno (di-zeroflags) (dispflags 'llvm-sys:dispflag-definition) + nil nil nil nil ""))) + +(defmacro with-di-subprogram ((function subprogram) &body body) + (let ((gfunction (gensym "FUNCTION")) (gsub (gensym "SUBPROGRAM"))) + `(let* ((,gfunction ,function) (,gsub (when *generate-dwarf* ,subprogram)) + (*dbg-current-scope* ,gsub)) + (when *generate-dwarf* + (llvm-sys:set-subprogram ,gfunction ,gsub)) + ,@body))) + +(defun get-dilocation (spi) + (multiple-value-bind (file lineno column) (spi-info spi) + (declare (ignore file)) + ;; We ignore the file because we use the local scope. + ;; The scoping doesn't fit super well with BIR, but oh well. + (llvm-sys:get-dilocation (cmp:thread-local-llvm-context) + lineno column *dbg-current-scope*))) + +;;; Generate debug info for a variable binding. +(defun di-bind-variable (name alloca spi vrtype) + (when spi + (multiple-value-bind (path line) (spi-info spi) + (let* ((type (vrtype->di vrtype)) + (var + (llvm-sys:create-auto-variable + *dibuilder* *dbg-current-scope* name + (ensure-difile path) line type nil (di-zeroflags) 0)) + (expr + (llvm-sys:create-expression-none *dibuilder*))) + (llvm-sys:dibuilder/insert-declare + *dibuilder* alloca var expr (get-dilocation spi) + (llvm-sys:get-insert-block cmp:*irbuilder*)))))) + +;;; Generate debug info for an SSA variable binding. +(defun di-bind-value (name value spi vrtype) + (when spi + (multiple-value-bind (path line) (spi-info spi) + (let* ((type (vrtype->di vrtype)) + (var + (llvm-sys:create-auto-variable + *dibuilder* *dbg-current-scope* name + (ensure-difile path) line type nil (di-zeroflags) 0)) + (expr + (llvm-sys:create-expression-none *dibuilder*))) + (llvm-sys:dibuilder/insert-dbg-value-intrinsic + *dibuilder* value var expr (get-dilocation spi) + (llvm-sys:get-insert-block cmp:*irbuilder*)))))) + +;;; if SPI is nil we unset the debug location. +(defun set-instruction-source-position (spi) + (when *generate-dwarf* + (if spi + (llvm-sys:set-current-debug-location + cmp:*irbuilder* + (get-dilocation spi)) + (llvm-sys:clear-current-debug-location cmp:*irbuilder*)))) + +(defmacro with-instruction-source-position ((spi) &body body) + `(unwind-protect + (progn (set-instruction-source-position ,spi) + ,@body) + (set-instruction-source-position nil))) diff --git a/src/lisp/kernel/cleavir/inline-prep.lisp b/src/lisp/kernel/cleavir/inline-prep.lisp index 9cbd3a7f4d..7d18b9cf48 100644 --- a/src/lisp/kernel/cleavir/inline-prep.lisp +++ b/src/lisp/kernel/cleavir/inline-prep.lisp @@ -26,46 +26,6 @@ ;; Add other clauses here (t #+(or)(warn "Add support for proclaim ~s~%" decl))))) -;;; Given a FUNCTION-AST, return the function-scope-info to insert into its body ASTs. -;;; or NIL if there's no source info. -(defun compute-fsi (ast) - (let ((orig (let ((orig (origin-source (cleavir-ast:origin ast)))) - (cond ((consp orig) (car orig)) - ((null orig) core:*current-source-pos-info*) - (t orig))))) - ;; See usage in cmp/debuginfo.lisp - (list (jit-function-name (cleavir-ast:name ast)) - (core:source-pos-info-lineno orig) - (core:source-pos-info-file-handle orig)))) - -;;; Stuff to put function scope infos into inline ast SPIs. -(defun insert-function-scope-info-into-spi (spi fsi) - ;; If something already has an FSI, we're in a nested inline AST - ;; and don't want to interfere with it. - (unless (core:source-pos-info-function-scope spi) - (core:setf-source-pos-info-function-scope spi fsi))) -(defun insert-function-scope-info-into-ast (ast fsi) - (let ((orig (origin-source (cleavir-ast:origin ast)))) - (cond ((consp orig) - (insert-function-scope-info-into-spi (car orig) fsi) - (insert-function-scope-info-into-spi (cdr orig) fsi)) - ((null orig) - (return-from insert-function-scope-info-into-ast ast)) - (t - (insert-function-scope-info-into-spi orig fsi))))) -(defun fix-inline-ast (ast) - (check-type ast cleavir-ast:function-ast) - (let ((fsi (compute-fsi ast))) - (unless (null fsi) - (insert-function-scope-info-into-ast ast fsi) - (labels ((aux (ast) - (typecase ast - (cleavir-ast:function-ast (fix-inline-ast ast)) - (t (insert-function-scope-info-into-ast ast fsi) - (cleavir-ast:map-children #'aux ast))))) - (cleavir-ast:map-children #'aux ast)))) - ast) - ;;; Bound by cst->ast to preserve source info. (defvar *compiling-cst* nil) @@ -80,7 +40,7 @@ (cst (if *compiling-cst* (cst:reconstruct *clasp-system* form *compiling-cst*) (cst:cst-from-expression form)))) - (fix-inline-ast (cst->ast cst env)))) + (cst->ast cst env))) ;;; Incorporated into DEFUN expansion (see lsp/evalmacros.lisp) (defun defun-inline-hook (name function-form env) @@ -95,75 +55,3 @@ (eval-when (:compile-toplevel :execute :load-toplevel) (setq core:*proclaim-hook* 'proclaim-hook)) - -;;; The following code sets up the chain of inlined-at info in AST origins. - -;;; Basically we want to recurse until we hit a SPI with no inlined-at, -;;; and set its inlined-at to the provided value. Also we clone everything, -;;; and memoize to avoid cloning too much. -(defun fix-inline-source-position (spi inlined-at table) - (or (gethash spi table) - (setf (gethash spi table) - (let ((clone (core:source-pos-info-copy spi))) - (core:setf-source-pos-info-inlined-at - clone - (let ((next (core:source-pos-info-inlined-at clone))) - (if next - (fix-inline-source-position next inlined-at table) - inlined-at))) - clone)))) - -(defun %allocate-copy (origin inlined-at table) - (etypecase origin - (null nil) - (cst:cons-cst (make-instance 'cst:cons-cst :raw (cst:raw origin))) - (cst:atom-cst (make-instance 'cst:atom-cst :raw (cst:raw origin))) - (cons - (cons (copy-origin-fixing-sources (car origin) inlined-at table) - (copy-origin-fixing-sources (cdr origin) inlined-at table))) - (core:source-pos-info - (let ((clone (core:source-pos-info-copy origin))) - (core:setf-source-pos-info-inlined-at - clone - (let ((next (core:source-pos-info-inlined-at clone))) - (if next - (copy-origin-fixing-sources next inlined-at table) - inlined-at))) - clone)))) - -(defun %initialize-copy (origin copy inlined-at table) - (typecase origin - (cst:cons-cst - (let ((car (copy-origin-fixing-sources (cst:first origin) - inlined-at table)) - (cdr (copy-origin-fixing-sources (cst:rest origin) - inlined-at table)) - (source (copy-origin-fixing-sources (cst:source origin) - inlined-at table))) - (reinitialize-instance copy :first car :rest cdr :source source))) - (cst:atom-cst - (let ((source (copy-origin-fixing-sources (cst:source origin) - inlined-at table))) - (reinitialize-instance copy :source source))))) - -(defun copy-origin-fixing-sources (origin inlined-at - &optional (table - (make-hash-table :test #'eq))) - (multiple-value-bind (copy presentp) - (gethash origin table) - (if presentp - copy - (let ((copy (%allocate-copy origin inlined-at table))) - (setf (gethash origin table) copy) - ;; For CSTs, initialize the copy now that subforms can refer to the - ;; existing entry (done this way in case of cycles) - (%initialize-copy origin copy inlined-at table) - copy)))) - -(defmethod cleavir-ast-to-bir:inline-origin (origin inlined-at (system clasp)) - (let ((inlined-at (origin-spi (origin-source inlined-at)))) - (if inlined-at - (progn - (check-type inlined-at core:source-pos-info) - (copy-origin-fixing-sources origin inlined-at)) - origin))) diff --git a/src/lisp/kernel/cleavir/landing-pad.lisp b/src/lisp/kernel/cleavir/landing-pad.lisp index fbe4b38de8..ab02129e26 100644 --- a/src/lisp/kernel/cleavir/landing-pad.lisp +++ b/src/lisp/kernel/cleavir/landing-pad.lisp @@ -71,8 +71,8 @@ (_ (cmp:irc-set-insert-point-basic-block ehresume ehbuilder)) (exn7 (llvm-sys:create-load-type-value-twine ehbuilder cmp:%exn% exn.slot "exn7")) (sel (llvm-sys:create-load-type-value-twine ehbuilder cmp:%ehselector% ehselector.slot "sel")) - (undef (llvm-sys:undef-value-get cmp:%exception-struct% )) - (lpad.val (llvm-sys:create-insert-value ehbuilder undef exn7 '(0) "lpad.val")) + (poison (llvm-sys:poison-value-get cmp:%exception-struct% )) + (lpad.val (llvm-sys:create-insert-value ehbuilder poison exn7 '(0) "lpad.val")) (lpad.val8 (llvm-sys:create-insert-value ehbuilder lpad.val sel '(1) "lpad.val8")) (_1 (llvm-sys:create-resume ehbuilder lpad.val8))) (declare (ignore _ _1)) @@ -234,13 +234,17 @@ (let ((rt (cc-bmir:rtype (first (bir:inputs (first destinations)))))) (cond ((eq rt :multiple-values) tmv) - ((equal rt '(:object)) - (cmp:irc-tmv-primary tmv)) - ((null rt) nil) ; redundant with nonlocal-valued-p - ((every (lambda (x) (eq x :object)) rt) - (list* (cmp:irc-tmv-primary tmv) - (loop for i from 1 below (length rt) - collect (cmp:irc-t*-load (return-value-elt i))))) + ((null rt) nil) + ((and (consp rt) (null (cdr rt))) + (cast-one :object (first rt) + (cmp:irc-tmv-primary tmv))) + ((listp rt) + (list* (cast-one :object (first rt) + (cmp:irc-tmv-primary tmv)) + (loop for i from 1 + for drt in (rest rt) + for v = (cmp:irc-t*-load (return-value-elt i)) + collect (cast-one :object drt v) ))) (t (error "BUG: Bad rtype ~a" rt)))))) (go-index (cmp:irc-typed-load cmp:%go-index% *go-index.slot*)) (sw (cmp:irc-switch go-index next ndestinations))) diff --git a/src/lisp/kernel/cleavir/translate-btb.lisp b/src/lisp/kernel/cleavir/translate-btb.lisp index d08053aee1..4c44328057 100644 --- a/src/lisp/kernel/cleavir/translate-btb.lisp +++ b/src/lisp/kernel/cleavir/translate-btb.lisp @@ -178,12 +178,8 @@ (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) ;; Parse lambda list. (cmp:with-landing-pad nil - (let ((ret (cmp:compile-lambda-list-code lambda-list-analysis - calling-convention - arity - :argument-out #'cc::out))) - (unless ret - (error "cmp:compile-lambda-list-code returned NIL which means this is not a function that should be generated"))) + (cmp:compile-lambda-list-code lambda-list-analysis + calling-convention arity) ;; Import cells. (let* ((closure-vec (first (llvm-sys:get-argument-list xep))) (llvm-function-info (cc::find-llvm-function-info ir)) @@ -194,30 +190,30 @@ when import ; skip unused fixed closure entries collect (cmp:irc-t*-load-atomic (cmp::gen-memref-address closure-vec offset)))) + #+(or) (source-pos-info (cc::function-source-pos-info ir))) ;; Tail call the real function. - (cmp:with-debug-info-source-position (source-pos-info) - (let* ((main-function (cc::main-function llvm-function-info)) - (function-type (llvm-sys:get-function-type main-function)) - (arguments - (mapcar (lambda (arg) - (cc::translate-cast (cc::in arg) - '(:object) (cc-bmir:rtype arg))) - (core:arguments llvm-function-info))) - (c - (cmp:irc-create-call-wft - function-type main-function - ;; Augment the environment lexicals as a local call would. - (nconc environment-values arguments))) - (returni (bir:returni ir)) - (rrtype (and returni (cc-bmir:rtype (bir:input returni))))) - #+(or)(llvm-sys:set-calling-conv c 'llvm-sys:fastcc) - ;; Box/etc. results of the local call. - (if returni - (cmp:irc-ret (cc::translate-cast - (cc::local-call-rv->inputs c rrtype) - rrtype :multiple-values)) - (cmp:irc-unreachable))))))) + (let* ((main-function (cc::main-function llvm-function-info)) + (function-type (llvm-sys:get-function-type main-function)) + (arguments + (mapcar (lambda (arg) + (cc::translate-cast (cc::in arg) + '(:object) (cc-bmir:rtype arg))) + (core:arguments llvm-function-info))) + (c + (cmp:irc-create-call-wft + function-type main-function + ;; Augment the environment lexicals as a local call would. + (nconc environment-values arguments))) + (returni (bir:returni ir)) + (rrtype (and returni (cc-bmir:rtype (bir:input returni))))) + #+(or)(llvm-sys:set-calling-conv c 'llvm-sys:fastcc) + ;; Box/etc. results of the local call. + (if returni + (cmp:irc-ret (cc::translate-cast + (cc::local-call-rv->inputs c rrtype) + rrtype :multiple-values)) + (cmp:irc-unreachable)))))) xep) (defun layout-xep-function (xep arity ir lambda-list-analysis lambda-name) @@ -235,34 +231,24 @@ (llvm-sys:make-irbuilder (cmp:thread-local-llvm-context))) (source-pos-info (cc::function-source-pos-info ir)) (lineno (core:source-pos-info-lineno source-pos-info))) - (cmp:with-guaranteed-*current-source-pos-info* () - (cmp:with-dbg-function (:lineno lineno - :function-type llvm-function-type - :function xep) - (llvm-sys:set-personality-fn xep (cmp:irc-personality-function)) - (llvm-sys:add-fn-attr2string xep "uwtable" "async") - (when (null (bir:returni ir)) - (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-no-return)) - (unless (policy:policy-value (bir:policy ir) - 'perform-optimization) - (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-no-inline) - (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-optimize-none)) - (cmp:irc-set-insert-point-basic-block entry-block - cmp:*irbuilder-function-alloca*) - (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (cmp:with-debug-info-source-position (source-pos-info) - (when sys:*drag-native-calls* - (cmp::irc-intrinsic "drag_native_calls")) - (let ((calling-convention - (cmp:setup-calling-convention xep - arity - :debug-on - (policy:policy-value - (bir:policy ir) - 'save-register-args) - :cleavir-lambda-list-analysis lambda-list-analysis - :rest-alloc (cc::compute-rest-alloc lambda-list-analysis)))) - (layout-xep-function* xep arity ir lambda-list-analysis calling-convention)))))))) + (llvm-sys:set-personality-fn xep (cmp:irc-personality-function)) + (llvm-sys:add-fn-attr2string xep "uwtable" "async") + (when (null (bir:returni ir)) + (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-no-return)) + (unless (policy:policy-value (bir:policy ir) + 'perform-optimization) + (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-no-inline) + (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-optimize-none)) + (cmp:irc-set-insert-point-basic-block entry-block + cmp:*irbuilder-function-alloca*) + (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) + (when sys:*drag-native-calls* + (cmp::irc-intrinsic "drag_native_calls")) + (let ((calling-convention + (cmp:initialize-calling-convention xep + arity + :rest-alloc (cc::compute-rest-alloc lambda-list-analysis)))) + (layout-xep-function* xep arity ir lambda-list-analysis calling-convention))))) (defun layout-xep-group (function lambda-name abi) (declare (ignore abi)) @@ -334,10 +320,7 @@ (if bir (let ((origin (bir:origin bir))) (if origin - (namestring - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle origin)))) + (namestring (core:source-pos-info/pathname origin)) "repl-code")) "repl-code")) @@ -351,9 +334,7 @@ (cc::*function-info* (make-hash-table :test #'eq)) (cc::*literal-fn* #'reference-literal)) (cmp::with-module (:module module) - (cmp:with-debug-info-generator (:module module - :pathname debug-namestring) - (layout-module bir-module abi :toplevels toplevels)) + (layout-module bir-module abi :toplevels toplevels) (cmp:irc-verify-module-safe module) (cmp::potentially-save-module)) (make-instance 'translation @@ -455,9 +436,7 @@ :function-name (cc::get-or-create-lambda-name irfun) :lambda-list (bir:original-lambda-list irfun) :docstring (bir:docstring irfun) - :source-pathname (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle spi))) + :source-pathname (core:source-pos-info/pathname spi) :lineno (core:source-pos-info-lineno spi) ;; Why 1+? :column (1+ (core:source-pos-info-column spi)) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 61ba9c45c4..9487b8f9bf 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -17,34 +17,8 @@ (%xep-function-description :initarg :xep-function-description :reader xep-function-description) (%main-function :initarg :main-function :reader main-function))) -(defun lambda-list-too-hairy-p (lambda-list) - (multiple-value-bind (reqargs optargs rest-var key-flag keyargs aok aux varest-p) - (cmp:process-bir-lambda-list lambda-list) - (declare (ignore reqargs optargs keyargs aok aux rest-var varest-p)) - key-flag)) - -(defun nontrivial-mv-local-call-p (call) - (cond ((typep call 'cc-bmir:fixed-mv-local-call) - ;; Could still be nontrivial if the number of arguments is wrong - (multiple-value-bind (req opt rest) - (cmp:process-bir-lambda-list (bir:lambda-list (bir:callee call))) - (let ((lreq (length (cc-bmir:rtype (second (bir:inputs call)))))) - (or (< lreq (car req)) - (and (not rest) (> lreq (+ (car req) (car opt)))))))) - ((typep call 'bir:mv-local-call) t) - (t nil))) - (defun xep-needed-p (function) (or (bir:enclose function) - ;; We need a XEP for more involved lambda lists. - (lambda-list-too-hairy-p (bir:lambda-list function)) - ;; or for mv-calls that might need to signal an error. - (and (cleavir-set:some #'nontrivial-mv-local-call-p - (bir:local-calls function)) - (multiple-value-bind (req opt rest) - (cmp:process-bir-lambda-list (bir:lambda-list function)) - (declare (ignore opt)) - (or (plusp (car req)) (not rest)))) ;; Assume that a function with no enclose and no local calls is ;; toplevel and needs an XEP. Else it would have been removed or ;; deleted as it is unreferenced otherwise. @@ -169,16 +143,18 @@ (defmethod translate-simple-instruction :around ((instruction bir:instruction) abi) (declare (ignore abi)) - (cmp:with-debug-info-source-position ((ensure-origin - (inst-source instruction) - 999902)) + (with-instruction-source-position + ((ensure-origin + (origin-spi (origin-source (bir:origin instruction))) + 999902)) (call-next-method))) (defmethod translate-terminator :around ((instruction bir:instruction) abi next) (declare (ignore abi next)) - (cmp:with-debug-info-source-position ((ensure-origin - (inst-source instruction) - 999903)) + (with-instruction-source-position + ((ensure-origin + (origin-spi (origin-source (bir:origin instruction))) + 999903)) (call-next-method))) (defmethod translate-terminator ((instruction bir:unreachable) @@ -197,7 +173,7 @@ ((null (rest rt)) (cmp:irc-ret inv)) (t ; fixed values return: construct an aggregate and return it. (let* ((stype (return-rtype->llvm rt)) - (s (llvm-sys:undef-value-get stype))) + (s (llvm-sys:poison-value-get stype))) (loop for i from 0 for v in inv do (setf s (cmp:irc-insert-value s v (list i)))) @@ -412,14 +388,19 @@ (let ((mv (restore-multiple-value-0)) (rt (cc-bmir:rtype phi))) (cond ((null rt)) - ((equal rt '(:object)) - (phi-out (cmp:irc-tmv-primary mv) phi block)) ((eq rt :multiple-values) (phi-out mv phi block)) - ((every (lambda (x) (eq x :object)) rt) + ((and (consp rt) (null (cdr rt))) + (phi-out (cast-one :object (first rt) + (cmp:irc-tmv-primary mv)) + phi block)) + ((listp rt) (phi-out - (list* (cmp:irc-tmv-primary mv) - (loop for i from 1 below (length rt) - collect (cmp:irc-t*-load (return-value-elt i)))) + (list* (cast-one :object (first rt) + (cmp:irc-tmv-primary mv)) + (loop for srt in (rest rt) + for i from 1 + for v = (cmp:irc-t*-load (return-value-elt i)) + collect (cast-one :object srt v))) phi block)) (t (error "BUG: Bad rtype ~a" rt))))) @@ -505,17 +486,25 @@ ;; Force the return values into a tmv for transmission. (rrv (when rv (let ((rt (cc-bmir:rtype rv))) - (cond ((equal rt '(:object)) - (cmp:irc-make-tmv (%size_t 1) (in rv))) - ((eq rt :multiple-values) (in rv)) + (cond ((eq rt :multiple-values) (in rv)) ((null rt) (cmp:irc-make-tmv (%size_t 0) (%nil))) - ((every (lambda (x) (eq x :object)) rt) - (let ((vals (in rv)) - (nvals (length rt))) + ((and (consp rt) (null (cdr rt))) + (let ((srt (first rt)) + (val (in rv))) + (cmp:irc-make-tmv (%size_t 1) + (cast-one srt :object val)))) + ((listp rt) + (let* ((vals (in rv)) + (nvals (length rt)) + (srt1 (first rt)) + (c1 (cast-one srt1 :object (first vals)))) (loop for i from 1 below nvals for v in (rest vals) - do (cmp:irc-store v (return-value-elt i))) - (cmp:irc-make-tmv (%size_t nvals) (first vals)))) + for srt in (rest rt) + for e = (return-value-elt i) + for c = (cast-one srt :object v) + do (cmp:irc-store v e)) + (cmp:irc-make-tmv (%size_t nvals) c1))) (t (error "BUG: Bad rtype ~a" rt)))))) (destination (bir:destination instruction)) (destination-id (get-destination-id destination))) @@ -701,62 +690,6 @@ (out (variable-in (bir:input instruction)) (bir:output instruction))) -(defun gen-rest-list (present-arguments) - (if (null present-arguments) - (%nil) - ;; Generate a call to cc_list. - ;; TODO: DX &rest lists. - (%intrinsic-invoke-if-landing-pad-or-call - "cc_list" (list* (%size_t (length present-arguments)) - present-arguments)))) - -(defun maybe-boxed-vaslist (boxp nvals vals) - (let ((vas (cmp:irc-make-vaslist nvals vals))) - (if boxp - (let ((mem (cmp:alloca cmp:%vaslist% 1))) - (cmp:irc-store vas mem) - (cmp:irc-tag-vaslist mem)) - vas))) - -(defun gen-va-rest-list (present-arguments boxp) - (let* ((nargs (length present-arguments)) - ;; nargs is constant, so this alloca is just in the intro block. - (dat (cmp:alloca cmp:%t*% nargs "local-va-rest"))) - ;; Store the arguments into the allocated memory. - (loop for arg in present-arguments - for i from 0 - do (cmp:irc-store arg (cmp:irc-typed-gep cmp:%t*% dat (list i)))) - ;; Make and return the va list object. - (maybe-boxed-vaslist boxp (%size_t nargs) dat))) - -(defun parse-local-call-optional-arguments (opt arguments) - (loop for (op) on (rest opt) by #'cdddr - if arguments - collect (translate-cast (pop arguments) '(:object) - (cc-bmir:rtype op)) - and collect (%t) - else - collect (cmp:irc-undef-value-get (argument-rtype->llvm op)) - and collect (%nil))) - -;; Create than argument list for a local call by parsing the callee's -;; lambda list and filling in the correct values at compile time. We -;; assume that we have already checked the validity of this call. -(defun parse-local-call-arguments (req opt rest rest-vrtype arguments) - (let* ((nreq (car req)) (nopt (car opt)) - (reqargs (subseq arguments 0 nreq)) - (more (nthcdr nreq arguments)) - (optargs (parse-local-call-optional-arguments opt more)) - (rest - (cond ((not rest) nil) - ((eq rest :unused) - (list (cmp:irc-undef-value-get cmp:%t*%))) - ((eq rest :va-rest) - (list (gen-va-rest-list (nthcdr nopt more) - (eq rest-vrtype :object)))) - (t (list (gen-rest-list (nthcdr nopt more))))))) - (append reqargs optargs rest))) - ;;; Get a reference to the literal for a function's simple fun. ;;; This is generic because it's also used by the BTB translator. (defgeneric reference-xep (function function-info)) @@ -816,64 +749,37 @@ :vaslist :object)) -(defun gen-local-call (callee arguments outputrt) - (let ((callee-info (find-llvm-function-info callee))) - (cond ((lambda-list-too-hairy-p (bir:lambda-list callee)) - ;; Has &key or something, so use the normal call protocol. - ;; We allocate a fresh closure for every call. Hopefully this - ;; isn't too expensive. We can always use stack allocation since - ;; there's no possibility of this closure being stored in a closure - ;; (If we local-call a self-referencing closure, the closure cell - ;; will get its value from some enclose. - ;; FIXME we could use that instead?) - (translate-cast (closure-call-or-invoke - (enclose callee :dynamic nil) - arguments) - :multiple-values outputrt)) - (t - ;; Call directly. - (multiple-value-bind (req opt rest-var key-flag keyargs aok aux - varest-p) - (cmp:process-bir-lambda-list (bir:lambda-list callee)) - (declare (ignore keyargs aok aux)) - (assert (not key-flag)) - (let ((largs (length arguments))) - (when (or (< largs (car req)) - (and (not rest-var) - (> largs (+ (car req) (car opt))))) - ;; too many or too few args; we can get here from - ;; fixed-mv-local-calls for instance. - (return-from gen-local-call - (translate-cast (closure-call-or-invoke - (enclose callee :dynamic nil) - arguments) - :multiple-values outputrt)))) - (let* ((rest-id (cond ((null rest-var) nil) - ((bir:unused-p rest-var) :unused) - (varest-p :va-rest) - (t t))) - (rest-vrtype (rest-vrtype rest-var)) - (subargs - (parse-local-call-arguments - req opt rest-id rest-vrtype arguments)) - (args (append (environment-arguments - (environment callee-info)) - subargs)) - (function (main-function callee-info)) - (function-type (llvm-sys:get-function-type function)) - (result-in-registers - (cmp::irc-call-or-invoke function-type function args))) - #+(or) - (llvm-sys:set-calling-conv result-in-registers 'llvm-sys:fastcc) - (local-call-rv->inputs result-in-registers outputrt))))))) +(defun gen-local-call (callee arguments argrts outputrt) + (let* ((analysis + ;; FIXME: Can be calculated redundantly + (cmp:calculate-cleavir-lambda-list-analysis + (bir:lambda-list callee))) + (callee-info (find-llvm-function-info callee)) + (envargs (environment-arguments (environment callee-info))) + (xepargs (make-instance 'cmp::fixed-xep-arguments + :arguments arguments :vrtypes argrts)) + (subargs (cmp:compile-lambda-list-code + analysis xepargs + :rest-alloc (compute-rest-alloc analysis) + :fname (clasp-cleavir::literal (bir:name callee)))) + (args (append envargs subargs)) + (function (main-function callee-info)) + (function-type (llvm-sys:get-function-type function)) + (result-in-registers + (cmp::irc-call-or-invoke function-type function args))) + #+(or) + (llvm-sys:set-calling-conv result-in-registers 'llvm-sys:fastcc) + (local-call-rv->inputs result-in-registers outputrt))) (defmethod translate-simple-instruction ((instruction bir:local-call) abi) (declare (ignore abi)) (let* ((callee (bir:callee instruction)) (args (mapcar #'in (rest (bir:inputs instruction)))) + (vrtypes (loop for inp in (rest (bir:inputs instruction)) + collect (first (cc-bmir:rtype inp)))) (output (bir:output instruction)) - (call (gen-local-call callee args (cc-bmir:rtype output)))) + (call (gen-local-call callee args vrtypes (cc-bmir:rtype output)))) (out call output))) (defmethod translate-simple-instruction ((instruction bir:call) abi) @@ -887,144 +793,36 @@ :label (datum-name-as-string output)) output))) -(defun general-mv-local-call-vas (callee vaslist label outputrt) - (translate-cast (cmp:irc-apply (enclose callee :dynamic nil) - (cmp:irc-vaslist-nvals vaslist) - (cmp:irc-vaslist-values vaslist) - label) - :multiple-values outputrt)) - -(defun direct-mv-local-call-vas (vaslist callee req opt rest-var varest-p - label outputrt) - (let* ((callee-info (find-llvm-function-info callee)) - (nreq (car req)) - (nopt (car opt)) - (rnret (cmp:irc-vaslist-nvals vaslist)) - (rvalues (cmp:irc-vaslist-values vaslist)) - (nfixed (+ nreq nopt)) - (mismatch - (unless (and (zerop nreq) rest-var) - (cmp:irc-basic-block-create "lmvc-arg-mismatch"))) - (mte (if rest-var - (cmp:irc-basic-block-create "lmvc-more-than-enough") - mismatch)) - (merge (cmp:irc-basic-block-create "lmvc-after")) - (sw (cmp:irc-switch rnret mte (+ 1 nreq nopt))) - (environment (environment callee-info)) - (rest-vaboxp (not (eq (rest-vrtype rest-var) :vaslist)))) - (labels ((load-return-value (n) - (cmp:irc-t*-load (cmp:irc-typed-gep cmp:%t*% rvalues (list n)))) - (load-return-values (low high) - (loop for i from low below high - collect (load-return-value i))) - (optionals (n) - (parse-local-call-optional-arguments - opt (load-return-values nreq (+ nreq n))))) - ;; Generate phis for the merge block's call. - (cmp:irc-begin-block merge) - (let ((opt-phis - (loop for (op s-p) on (rest opt) by #'cdddr - for op-ty = (argument-rtype->llvm op) - for s-p-ty = (argument-rtype->llvm s-p) - collect (cmp:irc-phi op-ty (1+ nopt)) - collect (cmp:irc-phi s-p-ty (1+ nopt)))) - (rest-phi - (cond ((null rest-var) nil) - ((bir:unused-p rest-var) - (cmp:irc-undef-value-get cmp:%t*%)) - (t (cmp:irc-phi (argument-rtype->llvm rest-var) - (1+ nopt)))))) - ;; Generate the mismatch block, if it exists. - (when mismatch - (cmp:irc-begin-block mismatch) - (cmp::irc-intrinsic-call-or-invoke - "cc_wrong_number_of_arguments" - (list (enclose callee :indefinite nil) rnret - (%size_t nreq) (%size_t nfixed))) - (cmp:irc-unreachable)) - ;; Generate not-enough-args cases. - (loop for i below nreq - do (cmp:irc-add-case sw (%size_t i) mismatch)) - ;; Generate optional arg cases, including the exactly-enough case. - (loop for i upto nopt - for b = (cmp:irc-basic-block-create - (format nil "lmvc-optional-~d" i)) - do (cmp:irc-add-case sw (%size_t (+ nreq i)) b) - (cmp:irc-begin-block b) - (loop for phi in opt-phis - for val in (optionals i) - do (cmp:irc-phi-add-incoming phi val b)) - (when (and rest-var (not (bir:unused-p rest-var))) - (cmp:irc-phi-add-incoming - rest-phi - (if varest-p - (maybe-boxed-vaslist - rest-vaboxp (%size_t 0) - (llvm-sys:constant-pointer-null-get cmp:%t**%)) - (%nil)) - b)) - (cmp:irc-br merge)) - ;; If there's a &rest, generate the more-than-enough arguments case. - (when rest-var - (cmp:irc-begin-block mte) - (loop for phi in opt-phis - for val in (optionals nopt) - do (cmp:irc-phi-add-incoming phi val mte)) - (unless (bir:unused-p rest-var) - (cmp:irc-phi-add-incoming - rest-phi - (if varest-p - (maybe-boxed-vaslist - rest-vaboxp - (cmp:irc-sub rnret (%size_t nfixed)) - (cmp:irc-typed-gep cmp:%t*% rvalues (list nfixed))) - (%intrinsic-invoke-if-landing-pad-or-call - "cc_mvcGatherRest2" - (list (cmp:irc-typed-gep cmp:%t*% rvalues (list nfixed)) - (cmp:irc-sub rnret (%size_t nfixed))))) - mte)) - (cmp:irc-br merge)) - ;; Generate the call, in the merge block. - (cmp:irc-begin-block merge) - (let* ((arguments - (nconc - (environment-arguments environment) - (loop for r in (rest req) - for j from 0 - collect (translate-cast (load-return-value j) '(:object) - (cc-bmir:rtype r))) - opt-phis - (when rest-var (list rest-phi)))) - (function (main-function callee-info)) - (function-type (llvm-sys:get-function-type function)) - (call - (cmp:irc-call-or-invoke function-type function arguments - cmp:*current-unwind-landing-pad-dest* - label))) - #+(or)(llvm-sys:set-calling-conv call 'llvm-sys:fastcc) - (local-call-rv->inputs call outputrt)))))) - (defmethod translate-simple-instruction ((instruction bir:mv-local-call) abi) (declare (ignore abi)) (let* ((output (bir:output instruction)) (outputrt (cc-bmir:rtype output)) - (oname (datum-name-as-string output)) (callee (bir:callee instruction)) (mvarg (second (bir:inputs instruction))) - (mvargrt (cc-bmir:rtype mvarg)) - (mvargi (in mvarg))) - (assert (eq mvargrt :vaslist)) - (out - (multiple-value-bind (req opt rest-var key-flag keyargs - aok aux varest-p) - (cmp::process-bir-lambda-list (bir:lambda-list callee)) - (declare (ignore keyargs aok aux)) - (if key-flag - (general-mv-local-call-vas callee mvargi oname outputrt) - (direct-mv-local-call-vas - mvargi callee req opt rest-var varest-p oname outputrt))) - output))) + (_ (assert (eq :vaslist (cc-bmir:rtype mvarg)))) + (mvargi (in mvarg)) + (analysis + ;; FIXME: Can be calculated redundantly + (cmp:calculate-cleavir-lambda-list-analysis + (bir:lambda-list callee))) + (callee-info (find-llvm-function-info callee)) + (envargs (environment-arguments (environment callee-info))) + (xepargs (make-instance 'cmp::general-xep-arguments + :array (cmp:irc-vaslist-values mvargi) + :nargs (cmp:irc-vaslist-nvals mvargi))) + (subargs (cmp:compile-lambda-list-code + analysis xepargs + :rest-alloc (compute-rest-alloc analysis) + :fname (clasp-cleavir::literal (bir:name callee)))) + (args (append envargs subargs)) + (function (main-function callee-info)) + (function-type (llvm-sys:get-function-type function)) + (result-in-registers + (cmp::irc-call-or-invoke function-type function args))) + (declare (ignore _)) + #+(or) (llvm-sys:set-calling-conv result-in-registers 'llvm-sys:fastcc) + (out (local-call-rv->inputs result-in-registers outputrt) output))) (defmethod translate-simple-instruction ((instruction cc-bmir:fixed-mv-local-call) abi) @@ -1040,6 +838,7 @@ (gen-local-call callee (if (= (length mvargrt) 1) (list mvargi) mvargi) + mvargrt (cc-bmir:rtype output)) output))) @@ -1097,92 +896,6 @@ (out (if (= ninputs 1) (in (first inputs)) (mapcar #'in inputs)) output))))) -(defun %cast-to-mv (values) - (cond ((null values) (cmp:irc-make-tmv (%size_t 0) (%nil))) - (t - (loop for i from 1 for v in (rest values) - do (cmp:irc-store v (return-value-elt i))) - (cmp:irc-make-tmv (%size_t (length values)) (first values))))) - -(defgeneric cast-one (from to value) - (:method (from to value) - (if (eql from to) - value - (error "BUG: Don't know how to cast ~a ~a to ~a" from value to)))) - -(defmethod cast-one ((from (eql :boolean)) (to (eql :object)) value) - ;; we could use a select instruction, but then we'd have a redundant memory load. - ;; which really shouldn't be a big deal, but why risk it. - (let* ((thenb (cmp:irc-basic-block-create "bool-t")) - (elseb (cmp:irc-basic-block-create "bool-nil")) - (_0 (cmp:irc-cond-br value thenb elseb)) - (merge (cmp:irc-basic-block-create "bool")) - (_1 (cmp:irc-begin-block merge)) - (phi (cmp:irc-phi cmp:%t*% 2 "bool"))) - (declare (ignore _0 _1)) - (cmp:irc-begin-block thenb) - (cmp:irc-phi-add-incoming phi (%t) thenb) - (cmp:irc-br merge) - (cmp:irc-begin-block elseb) - (cmp:irc-phi-add-incoming phi (%nil) elseb) - (cmp:irc-br merge) - (cmp:irc-begin-block merge) - phi)) -(defmethod cast-one ((from (eql :object)) (to (eql :boolean)) value) - (cmp:irc-icmp-ne value (%nil))) - -(defmethod cast-one ((from (eql :single-float)) (to (eql :object)) value) - (cmp:irc-box-single-float value)) -(defmethod cast-one ((from (eql :object)) (to (eql :single-float)) value) - (cmp:irc-unbox-single-float value)) - -(defmethod cast-one ((from (eql :double-float)) (to (eql :object)) value) - (cmp:irc-box-double-float value)) -(defmethod cast-one ((from (eql :object)) (to (eql :double-float)) value) - (cmp:irc-unbox-double-float value)) - -(defmethod cast-one ((from (eql :base-char)) (to (eql :object)) value) - (cmp:irc-tag-base-char value)) -(defmethod cast-one ((from (eql :object)) (to (eql :base-char)) value) - (cmp:irc-untag-base-char value)) -(defmethod cast-one ((from (eql :character)) (to (eql :object)) value) - (cmp:irc-tag-character value)) -(defmethod cast-one ((from (eql :object)) (to (eql :character)) value) - (cmp:irc-untag-character value)) - -(defmethod cast-one ((from (eql :base-char)) (to (eql :character)) value) - (cmp:irc-zext value cmp:%i32%)) -(defmethod cast-one ((from (eql :character)) (to (eql :base-char)) value) - (cmp:irc-trunc value cmp:%i8%)) - -(defmethod cast-one ((from (eql :fixnum)) (to (eql :object)) value) - (cmp:irc-int-to-ptr value cmp:%t*%)) -(defmethod cast-one ((from (eql :object)) (to (eql :fixnum)) value) - (cmp:irc-ptr-to-int value cmp:%fixnum%)) - -(defmethod cast-one ((from (eql :utfixnum)) (to (eql :fixnum)) value) - (cmp:irc-shl value cmp:+fixnum-shift+ :nsw t)) -(defmethod cast-one ((from (eql :fixnum)) (to (eql :utfixnum)) value) - (cmp:irc-ashr value cmp:+fixnum-shift+ :exact t)) - -(defmethod cast-one ((from (eql :utfixnum)) (to (eql :object)) value) - (cmp:irc-tag-fixnum value)) -(defmethod cast-one ((from (eql :object)) (to (eql :utfixnum)) value) - (cmp:irc-untag-fixnum value cmp:%fixnum%)) - -(defmethod cast-one ((from (eql :object)) (to (eql :vaslist)) value) - ;; We only generate these when we know for sure the input is a vaslist, - ;; so we don't do checking. - (cmp:irc-unbox-vaslist value)) - -(defun %cast-some (inputrt outputrt inputv) - (let ((Lin (length inputrt)) (Lout (length outputrt)) - (pref (mapcar #'cast-one inputrt outputrt inputv))) - (cond ((<= Lout Lin) pref) - (t - (assert (every (lambda (r) (eq r :object)) (subseq outputrt Lin))) - (nconc pref (loop repeat (- Lout Lin) collect (%nil))))))) - (define-condition box-emitted (ext:compiler-note) ((%name :initarg :name :reader name) (%inputrt :initarg :inputrt :reader inputrt) @@ -1211,76 +924,6 @@ :inputrt inputrt :outputrt outputrt :name name :origin (origin-source origin)))) -(defun translate-cast (inputv inputrt outputrt) - ;; most of this is special casing crap due to 1-value values not being - ;; passed around as lists. - (cond ((eq inputrt :multiple-values) - (cond ((eq outputrt :multiple-values) - ;; A NOP like this isn't generated within code, but the - ;; translate-cast in layout-xep can end up here. - inputv) - ((not (listp outputrt)) (error "BUG: Bad rtype ~a" outputrt)) - ((= (length outputrt) 1) - (cast-one :object (first outputrt) - (cmp:irc-tmv-primary inputv))) - ((null outputrt) nil) - (t (cons (cast-one :object (first outputrt) - (cmp:irc-tmv-primary inputv)) - (loop for i from 1 - for ort in (rest outputrt) - for val = (cmp:irc-t*-load (return-value-elt i)) - collect (cast-one :object ort val)))))) - ((eq inputrt :vaslist) - (cond ((eq outputrt :multiple-values) - (%intrinsic-call "cc_load_values" - (list (cmp:irc-vaslist-nvals inputv) - (cmp:irc-vaslist-values inputv)))) - ((and (listp outputrt) (= (length outputrt) 1)) - (cast-one :object (first outputrt) - (cmp:irc-vaslist-nth (%size_t 0) inputv))) - (t (error "BUG: Cast from ~a to ~a" inputrt outputrt)))) - ((not (listp inputrt)) (error "BUG: Bad rtype ~a" inputrt)) - ;; inputrt must be a list (fixed values) - ((= (length inputrt) 1) - (cond ((eq outputrt :multiple-values) - (cmp:irc-make-tmv (%size_t 1) - (cast-one (first inputrt) :object inputv))) - ((not (listp outputrt)) - (error "BUG: Cast from ~a to ~a" inputrt outputrt)) - ((null outputrt) nil) - ((= (length outputrt) 1) - (cast-one (first inputrt) (first outputrt) inputv)) - (t ;; pad with nil - (assert (every (lambda (r) (eq r :object)) (rest outputrt))) - (cons (cast-one (first inputrt) (first outputrt) inputv) - (loop repeat (length (rest outputrt)) - collect (%nil)))))) - (t - (cond ((eq outputrt :multiple-values) - (%cast-to-mv - (loop for inv in inputv for irt in inputrt - collect (cast-one irt :object inv)))) - ((not (listp outputrt)) - (error "BUG: Cast from ~a to ~a" inputrt outputrt)) - ((= (length outputrt) 1) - (cond ((null inputrt) - (ecase (first outputrt) - ((:object) (%nil)) - ;; We can end up here with a variety of output vrtypes - ;; in some unusual situations where a primop expects - ;; a value, but control will never actually reach it. - ;; Ideally the compiler would not bother compiling - ;; such unreachable code, but sometimes it's stupid. - ((:fixnum) (llvm-sys:undef-value-get cmp:%fixnum%)) - ((:single-float) - (llvm-sys:undef-value-get cmp:%float%)) - ((:double-float) - (llvm-sys:undef-value-get cmp:%double%)))) - (t - (cast-one (first inputrt) (first outputrt) - (first inputv))))) - (t (%cast-some inputrt outputrt inputv)))))) - (defmethod translate-simple-instruction ((instr cc-bmir:cast) (abi abi-x86-64)) (let* ((input (bir:input instr)) (inputrt (cc-bmir:rtype input)) (output (bir:output instr)) (outputrt (cc-bmir:rtype output))) @@ -1785,19 +1428,26 @@ (t (loop for i from 0 below (length rtype) collect (cmp:irc-extract-value llvm-value (list i)))))) -(defun layout-xep-function* (xep-group arity the-function ir calling-convention abi) +(defun layout-xep-function* (xep-group arity the-function ir abi) (declare (ignore abi)) (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) ;; Parse lambda list. (cmp:with-landing-pad nil - (let ((ret (cmp:compile-lambda-list-code (cmp:xep-group-cleavir-lambda-list-analysis xep-group) - calling-convention - arity - :argument-out #'out))) - (unless ret - (error "cmp:compile-lambda-list-code returned NIL which means this is not a function that should be generated"))) - ;; Import cells. - (let* ((closure-vec (first (llvm-sys:get-argument-list the-function))) + (let* ((args (llvm-sys:get-argument-list the-function)) + (closure-vec (first args)) + (analysis (cmp:xep-group-cleavir-lambda-list-analysis xep-group)) + (arguments + (cmp:compile-lambda-list-code + analysis + (if (eq arity :general-entry) + (make-instance 'cmp::general-xep-arguments + :array (third args) :nargs (second args)) + (make-instance 'cmp::fixed-xep-arguments + :arguments (rest args) + :vrtypes (make-list (length (rest args)) + :initial-element :object))) + :fname closure-vec :rest-alloc (compute-rest-alloc analysis))) + ;; Import cells. (llvm-function-info (find-llvm-function-info ir)) (environment-values (loop for import in (environment llvm-function-info) @@ -1806,58 +1456,54 @@ when import ; skip unused fixed closure entries collect (cmp:irc-t*-load-atomic (cmp::gen-memref-address closure-vec offset)))) - (source-pos-info (function-source-pos-info ir))) - ;; Tail call the real function. - (cmp:with-debug-info-source-position (source-pos-info) - (let* ((function-type (llvm-sys:get-function-type (main-function llvm-function-info))) - (arguments - (mapcar (lambda (arg) - (translate-cast (in arg) - '(:object) (cc-bmir:rtype arg))) - (arguments llvm-function-info))) - (c - (cmp:irc-create-call-wft - function-type - (main-function llvm-function-info) - ;; Augment the environment lexicals as a local call would. - (nconc environment-values arguments))) - (returni (bir:returni ir)) - (rrtype (and returni (cc-bmir:rtype (bir:input returni))))) - #+(or)(llvm-sys:set-calling-conv c 'llvm-sys:fastcc) - ;; Box/etc. results of the local call. - (if returni - (cmp:irc-ret (translate-cast - (local-call-rv->inputs c rrtype) - rrtype :multiple-values)) - (cmp:irc-unreachable))))))) + ;; Tail call the real function. + (function-type + (llvm-sys:get-function-type (main-function llvm-function-info))) + (c + (cmp:irc-create-call-wft + function-type + (main-function llvm-function-info) + ;; Augment the environment lexicals as a local call would. + (nconc environment-values arguments))) + (returni (bir:returni ir)) + (rrtype (and returni (cc-bmir:rtype (bir:input returni))))) + #+(or)(llvm-sys:set-calling-conv c 'llvm-sys:fastcc) + ;; Box/etc. results of the local call. + (if returni + (cmp:irc-ret (translate-cast + (local-call-rv->inputs c rrtype) + rrtype :multiple-values)) + (cmp:irc-unreachable))))) the-function) (defun layout-main-function* (the-function ir body-irbuilder body-block abi &key (linkage 'llvm-sys:internal-linkage)) (declare (ignore linkage)) - (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (cmp:with-irbuilder (body-irbuilder) - (with-catch-pad-prep - (cmp:irc-begin-block body-block) - (cmp:with-landing-pad (never-entry-landing-pad ir) - ;; Bind the arguments and the environment values - ;; appropriately. - (let ((llvm-function-info (find-llvm-function-info ir))) - (loop for arg in (llvm-sys:get-argument-list the-function) - ;; remove-if is to remove fixed closure params. - for lexical in (append (remove-if #'null (environment llvm-function-info)) - (arguments llvm-function-info)) - when lexical ; skip unused fixed - do (setf (gethash lexical *datum-values*) arg))) - ;; Branch to the start block. - (cmp:irc-br (iblock-tag (bir:start ir))) - ;; Lay out blocks. - (bir:do-iblocks (ib ir) - (layout-iblock ib abi)))))) - ;; Finish up by jumping from the entry block to the body block - (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (cmp:irc-br body-block)) + (cmp:with-irbuilder (body-irbuilder) + ;; Start the iblocks - put in phis and record them in our mapping + ;; for jumps. + (bir:do-iblocks (ib ir) + (setf (gethash ib *tags*) + (cmp:irc-basic-block-create (iblock-name ib))) + (initialize-iblock-translation ib)) + (with-catch-pad-prep + (cmp:irc-begin-block body-block) + (cmp:with-landing-pad (never-entry-landing-pad ir) + ;; Bind the arguments and the environment values + ;; appropriately. + (let ((llvm-function-info (find-llvm-function-info ir))) + (loop for arg in (llvm-sys:get-argument-list the-function) + ;; remove-if is to remove fixed closure params. + for lexical in (append (remove-if #'null (environment llvm-function-info)) + (arguments llvm-function-info)) + when lexical ; skip unused fixed + do (setf (gethash lexical *datum-values*) arg))) + ;; Branch to the start block. + (cmp:irc-br (iblock-tag (bir:start ir))) + ;; Lay out blocks. + (bir:do-iblocks (ib ir) + (layout-iblock ib abi))))) the-function) (defun layout-main-function (function lambda-name abi @@ -1871,8 +1517,6 @@ (cmp:module-make-global-string jit-function-name "fn-name")) (llvm-function-info (find-llvm-function-info function)) (the-function (main-function llvm-function-info)) - (llvm-function-type (llvm-sys:get-function-type the-function)) - #+(or)(function-description (main-function-description llvm-function-info)) (cmp:*current-function* the-function) (entry-block (cmp:irc-basic-block-create "entry" the-function)) (*function-current-multiple-value-array-address* @@ -1881,43 +1525,33 @@ (llvm-sys:make-irbuilder (cmp:thread-local-llvm-context))) (body-irbuilder (llvm-sys:make-irbuilder (cmp:thread-local-llvm-context))) - (body-block (cmp:irc-basic-block-create "body")) - (source-pos-info (function-source-pos-info function)) - (lineno (core:source-pos-info-lineno source-pos-info))) - (cmp:with-guaranteed-*current-source-pos-info* () - (cmp:with-dbg-function (:lineno lineno - :function-type llvm-function-type - :function the-function) - #+(or)(llvm-sys:set-calling-conv the-function 'llvm-sys:fastcc) - (llvm-sys:set-personality-fn the-function - (cmp:irc-personality-function)) - ;; we'd like to be able to be interruptable at any time, so we - ;; need async-safe unwinding tables basically everywhere. - ;; (Although in code that ignores interrupts we could loosen this.) - (llvm-sys:add-fn-attr2string the-function "uwtable" "async") - (when (null (bir:returni function)) - (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-no-return)) - (unless (policy:policy-value (bir:policy function) - 'perform-optimization) - (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-no-inline) - (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-optimize-none)) - (cmp:with-irbuilder (body-irbuilder) - (bir:map-iblocks - (lambda (ib) - (setf (gethash ib *tags*) - (cmp:irc-basic-block-create - (iblock-name ib))) - (initialize-iblock-translation ib)) - function)) - (cmp:irc-set-insert-point-basic-block entry-block - cmp:*irbuilder-function-alloca*) - (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (cmp:with-debug-info-source-position (source-pos-info) - (cmp:with-dbg-lexical-block - (:lineno (core:source-pos-info-lineno source-pos-info)) - (layout-main-function* the-function function - body-irbuilder body-block - abi :linkage linkage)))))))) + (body-block (cmp:irc-basic-block-create "body"))) + #+(or)(llvm-sys:set-calling-conv the-function 'llvm-sys:fastcc) + (llvm-sys:set-personality-fn the-function + (cmp:irc-personality-function)) + ;; we'd like to be able to be interruptable at any time, so we + ;; need async-safe unwinding tables basically everywhere. + ;; (Although in code that ignores interrupts we could loosen this.) + (llvm-sys:add-fn-attr2string the-function "uwtable" "async") + (when (null (bir:returni function)) + (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-no-return)) + (unless (policy:policy-value (bir:policy function) + 'perform-optimization) + (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-no-inline) + (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-optimize-none)) + (with-di-subprogram (the-function + (create-di-main-function + function + (llvm-sys:get-name the-function))) + (cmp:irc-set-insert-point-basic-block entry-block + cmp:*irbuilder-function-alloca*) + (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) + (layout-main-function* the-function function + body-irbuilder body-block + abi :linkage linkage) + ;; Finish up by jumping from the entry block to the body. + (cmp:irc-br body-block))) + the-function)) (defun compute-rest-alloc (cleavir-lambda-list-analysis) ;; FIXME: We seriously need to not reparse lambda lists a million times @@ -1930,8 +1564,7 @@ (t nil)))) (defun layout-xep-function (xep-arity xep-group function lambda-name abi) - (let* ((*datum-values* (make-hash-table :test #'eq)) - (jit-function-name (jit-function-name lambda-name)) + (let* ((jit-function-name (jit-function-name lambda-name)) (cmp:*current-function-name* jit-function-name) (cmp:*gv-current-function-name* (cmp:module-make-global-string jit-function-name "fn-name"))) @@ -1940,50 +1573,67 @@ (if (literal:general-entry-placeholder-p xep-arity-function) (progn ) - (progn - (let* ((llvm-function-type (cmp:fn-prototype arity)) - (cmp:*current-function* xep-arity-function) + (with-di-subprogram (xep-arity-function + (create-di-xep + function + (llvm-sys:get-name xep-arity-function) + arity)) + (let* ((cmp:*current-function* xep-arity-function) (entry-block (cmp:irc-basic-block-create "entry" xep-arity-function)) (*function-current-multiple-value-array-address* nil) (cmp:*irbuilder-function-alloca* - (llvm-sys:make-irbuilder (cmp:thread-local-llvm-context))) - (source-pos-info (function-source-pos-info function)) - (lineno (core:source-pos-info-lineno source-pos-info))) - (cmp:with-guaranteed-*current-source-pos-info* () - (cmp:with-dbg-function (:lineno lineno - :function-type llvm-function-type - :function xep-arity-function) - (llvm-sys:set-personality-fn xep-arity-function - (cmp:irc-personality-function)) - (llvm-sys:add-fn-attr2string xep-arity-function - "uwtable" "async") - (when (null (bir:returni function)) - (llvm-sys:add-fn-attr xep-arity-function - 'llvm-sys:attribute-no-return)) - (unless (policy:policy-value (bir:policy function) - 'perform-optimization) - (llvm-sys:add-fn-attr xep-arity-function 'llvm-sys:attribute-no-inline) - (llvm-sys:add-fn-attr xep-arity-function 'llvm-sys:attribute-optimize-none)) - (cmp:irc-set-insert-point-basic-block entry-block - cmp:*irbuilder-function-alloca*) - (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (cmp:with-debug-info-source-position (source-pos-info) - (if sys:*drag-native-calls* - (cmp::irc-intrinsic "drag_native_calls")) - (let* ((cleavir-lambda-list-analysis (cmp:xep-group-cleavir-lambda-list-analysis xep-group)) - (calling-convention - (cmp:setup-calling-convention xep-arity-function - arity - :debug-on - (policy:policy-value - (bir:policy function) - 'save-register-args) - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis - :rest-alloc (compute-rest-alloc cleavir-lambda-list-analysis)))) - (layout-xep-function* xep-group arity xep-arity-function function calling-convention abi)))))))))))) - - - + (llvm-sys:make-irbuilder (cmp:thread-local-llvm-context)))) + (llvm-sys:set-personality-fn xep-arity-function + (cmp:irc-personality-function)) + (llvm-sys:add-fn-attr2string xep-arity-function + "uwtable" "async") + (when (null (bir:returni function)) + (llvm-sys:add-fn-attr xep-arity-function + 'llvm-sys:attribute-no-return)) + (unless (policy:policy-value (bir:policy function) + 'perform-optimization) + (llvm-sys:add-fn-attr xep-arity-function 'llvm-sys:attribute-no-inline) + (llvm-sys:add-fn-attr xep-arity-function 'llvm-sys:attribute-optimize-none)) + (cmp:irc-set-insert-point-basic-block entry-block + cmp:*irbuilder-function-alloca*) + (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) + (with-instruction-source-position + ((ensure-origin + (origin-spi (origin-source (bir:origin function))) + 999903)) + (if sys:*drag-native-calls* + (cmp::irc-intrinsic "drag_native_calls")) + (when (policy:policy-value (bir:policy function) + 'save-register-args) + (save-registers xep-arity-function arity + (cmp:alloca-register-save-area arity))) + (layout-xep-function* xep-group arity xep-arity-function function abi))))))))) + +;;; Generate code to dump arguments ("registers") to a "register save area" in +;;; memory, where they can be read by the debugger even in the face of +;;; heavy optimization. +(defun save-registers (function arity rsa) + (let* ((arguments (llvm-sys:get-argument-list function)) + (nargs (length arguments)) + (rsa-type (llvm-sys:array-type-get cmp:%t*% nargs))) + (flet ((spill-reg (index reg name) + (cmp:irc-store reg + (cmp:irc-typed-gep rsa-type rsa (list 0 index) name) + ;; volatile, so optimizations don't remove it. + t))) + (cond ((eq arity :general-entry) + ;; special cased, since we pun the non-lispobj arguments. + (destructuring-bind (closure nargs args) arguments + (spill-reg 0 closure "rsa-closure") + (spill-reg 1 (cmp:irc-int-to-ptr nargs cmp:%i8*% "nargs-i8*") + "rsa-nargs") + (spill-reg 2 (cmp:irc-bit-cast args cmp:%i8*% "reg-i8*") "rsa-args"))) + (t + (loop for i from 0 + for arg in arguments + for name in '("rsa-closure" "rsa-arg0" "rsa-arg1" "rsa-arg2" + "rsa-arg3" "rsa-arg4" "rsa-arg5" "rsa-arg6") + do (spill-reg i arg name))))))) (defun maybe-note-return-cast (function) (let ((returni (bir:returni function))) @@ -2221,19 +1871,15 @@ COMPILE-FILE will use the default *clasp-env*." (pathname (let ((origin (origin-source (bir:origin bir)))) (if origin - (namestring - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle origin)))) - "repl-code")))) - ;; Link the C++ intrinsics into the module + (core:source-pos-info/pathname origin) + #p"repl-code")))) (cmp::with-module (:module module) - (cmp::cmp-log "Dumping module%N") - (cmp::cmp-log-dump-module module) (multiple-value-bind (ordered-raw-constants-list constants-table startup-shutdown-id) - (cmp:with-debug-info-generator (:module cmp:*the-module* :pathname pathname) - (literal:with-rtv - (translate bir :linkage linkage :abi abi))) + (with-debuginfo (module :path pathname) + (multiple-value-prog1 + (literal:with-rtv + (translate bir :linkage linkage :abi abi)) + (llvm-sys:optimize-module module cmp:*optimization-level*))) (declare (ignore constants-table)) (jit-add-module-return-function cmp:*the-module* startup-shutdown-id ordered-raw-constants-list))))) @@ -2302,19 +1948,21 @@ COMPILE-FILE will use the default *clasp-env*." (let ((eof-value (gensym)) (eclector.reader:*client* cmp:*cst-client*) (cst-to-ast:*compiler* 'cl:compile-file)) - (loop - ;; Required to update the source pos info. FIXME!? - (peek-char t source-sin nil) - ;; FIXME: if :environment is provided we should probably use a different read somehow - (let* ((core:*current-source-pos-info* (cmp:compile-file-source-pos-info source-sin)) - (cst (eclector.concrete-syntax-tree:read source-sin nil eof-value))) - #+debug-monitor(sys:monitor-message "source-pos ~a" core:*current-source-pos-info*) - (if (eq cst eof-value) - (return nil) - (progn - (when *compile-print* (cmp::describe-form (cst:raw cst))) - (core:with-memory-ramp (:pattern 'gctools:ramp) - (compile-file-cst cst environment)))))))) + (with-debuginfo (cmp:*the-module* + :path cmp::*compile-file-source-debug-pathname*) + (loop + ;; Required to update the source pos info. FIXME!? + (peek-char t source-sin nil) + ;; FIXME: if :environment is provided we should probably use a different read somehow + (let* ((core:*current-source-pos-info* (cmp:compile-file-source-pos-info source-sin)) + (cst (eclector.concrete-syntax-tree:read source-sin nil eof-value))) + #+debug-monitor(sys:monitor-message "source-pos ~a" core:*current-source-pos-info*) + (if (eq cst eof-value) + (return nil) + (progn + (when *compile-print* (cmp::describe-form (cst:raw cst))) + (core:with-memory-ramp (:pattern 'gctools:ramp) + (compile-file-cst cst environment))))))))) (defun cleavir-compile-file (input-file &rest kwargs) (let ((cmp:*cleavir-compile-file-hook* diff --git a/src/lisp/kernel/cleavir/translation-environment.lisp b/src/lisp/kernel/cleavir/translation-environment.lisp index 6e4be92268..546575f266 100644 --- a/src/lisp/kernel/cleavir/translation-environment.lisp +++ b/src/lisp/kernel/cleavir/translation-environment.lisp @@ -55,7 +55,8 @@ ;;; a little bit more complete. (defun full-datum-name-as-string (datum) (let ((*package* (find-package "KEYWORD"))) - (write-to-string datum :escape t :readably nil :pretty nil))) + (write-to-string (bir:name datum) + :escape t :readably nil :pretty nil))) (defgeneric vrtype->llvm (vrtype)) (defmethod vrtype->llvm ((vrtype (eql :object))) cmp:%t*%) @@ -79,7 +80,6 @@ ((:local :dynamic) ;; just an alloca (let* ((name (datum-name-as-string var)) - #+(or) (fname (full-datum-name-as-string var)) (rtype (cc-bmir:rtype var))) (if (null rtype) @@ -91,12 +91,8 @@ (first (cc-bmir:rtype var))) (t (error "BUG: Bad rtype ~a" rtype)))) (alloca (cmp:alloca (vrtype->llvm vrtype) 1 name)) - #+(or) - (spi (origin-spi (bir:origin var)))) - ;; set up debug info - ;; Disable for now - FIXME and get it working - #+(or)(cmp:dbg-variable-alloca alloca fname spi) - ;; return + (spi (origin-spi (origin-source (bir:origin var))))) + (di-bind-variable fname alloca spi vrtype) alloca)))) ((:indefinite) ;; make a cell @@ -204,10 +200,11 @@ (check-type variable bir:variable) (if (bir:immutablep variable) (prog1 (setf (gethash variable *datum-values*) value) - ;; FIXME - this doesn't work yet - #+(or)(cmp:dbg-variable-value - value (full-datum-name-as-string variable) - (origin-spi (bir:origin variable)))) + (let ((rtype (cc-bmir:rtype variable))) + (unless (null rtype) + (di-bind-value (full-datum-name-as-string variable) + value (origin-spi (origin-source (bir:origin variable))) + (first rtype))))) (if (null (cc-bmir:rtype variable)) value ;; NOTE: For typed loads in the future, use the rtype diff --git a/src/lisp/kernel/clos/conditions.lisp b/src/lisp/kernel/clos/conditions.lisp index b37e1c277d..7351074189 100644 --- a/src/lisp/kernel/clos/conditions.lisp +++ b/src/lisp/kernel/clos/conditions.lisp @@ -1081,8 +1081,11 @@ The conflict resolver must be one of ~s" chosen-symbol candidates)) (cell-error-name condition))))) (define-condition core:wrong-number-of-arguments (program-error) - (;; may be NIL if this is called from the interpreter and we don't know anything - ;; (KLUDGE, FIXME?) + (;; Some kind of name for the called function, or NIL if nothing is available. + ;; Note that this is not necessarily a legal function name. E.g. it could be + ;; a lambda expression, or an (FLET FOO) kind of name. + ;; It can also be a function itself rather than a name, because that's how + ;; it used to work. (called-function :initform nil :initarg :called-function :reader called-function) (given-nargs :initarg :given-nargs :reader given-nargs) ;; also may be NIL, same reason (KLUDGE, FIXME?) @@ -1093,10 +1096,11 @@ The conflict resolver must be one of ~s" chosen-symbol candidates)) (let* ((min (min-nargs condition)) (max (max-nargs condition)) (function (called-function condition)) - (name (and function (core:function-name function))) - (dname (if (eq name 'cl:lambda) "anonymous function" name))) + (fname (if (functionp function) + (core:function-name function) + function))) (format stream "~@[Calling ~a - ~]Got ~d arguments, but expected ~@?" - dname (given-nargs condition) + fname (given-nargs condition) (cond ((null max) "at least ~d") ((null min) "at most ~*~d") ;; I think "exactly 0" is better than "at most 0", thus duplication @@ -1129,9 +1133,12 @@ The conflict resolver must be one of ~s" chosen-symbol candidates)) (define-condition core:odd-keywords (program-error) ((%called-function :initarg :called-function :reader called-function)) (:report (lambda (condition stream) - (format stream "Odd number of keyword arguments~:[~; for ~s~]." - (called-function condition) - (core:function-name (called-function condition)))))) + (let* ((function (called-function condition)) + (fname (if (functionp function) + (core:function-name function) + function))) + (format stream "Odd number of keyword arguments~@[ for ~s~]." + fname))))) (define-condition core:unrecognized-keyword-argument-error (program-error) ((called-function :initarg :called-function :reader called-function :initform nil) diff --git a/src/lisp/kernel/clos/generic.lisp b/src/lisp/kernel/clos/generic.lisp index 498b144742..2e4f559ade 100644 --- a/src/lisp/kernel/clos/generic.lisp +++ b/src/lisp/kernel/clos/generic.lisp @@ -214,9 +214,7 @@ Not a valid documentation object ~A" ;; FIXME: Too many fields and the underlying function makes a new SPI. Dumb. (core:set-source-pos-info gfun - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle spi))) + (core:source-pos-info/pathname spi) (core:source-pos-info-filepos spi) (core:source-pos-info-lineno spi) ;; 1+ copied from cmpir.lisp. Dunno why it's there. diff --git a/src/lisp/kernel/cmp/arguments.lisp b/src/lisp/kernel/cmp/arguments.lisp deleted file mode 100644 index cfdf2eb919..0000000000 --- a/src/lisp/kernel/cmp/arguments.lisp +++ /dev/null @@ -1,719 +0,0 @@ -(in-package :cmp) - -;; A function of two arguments, an LLVM Value and a variable. -;; The "variable" is just whatever is provided to this code -;; (so that it can work with either b or c clasp). -;; The function should put the Value into the variable, possibly generating code to do so. -;; In order to work with cclasp's SSA stuff, it must be called exactly once for each variable. -(defvar *argument-out*) - -(defun compile-wrong-number-arguments-block (closure nargs min max) - ;; make a new irbuilder, so as to not disturb anything - (with-irbuilder ((llvm-sys:make-irbuilder (thread-local-llvm-context))) - (let ((errorb (irc-basic-block-create "wrong-num-args"))) - (irc-begin-block errorb) - (irc-intrinsic "cc_wrong_number_of_arguments" - ;; We use low max to indicate no upper limit. - closure nargs min (or max (irc-size_t 0))) - (irc-unreachable) - errorb))) - -;; Generate code to signal an error iff there weren't enough arguments provided. -(defun compile-error-if-not-enough-arguments (error-block cmin nargs) - (let* ((cont-block (irc-basic-block-create "enough-arguments")) - (cmp (irc-icmp-ult nargs cmin))) - (irc-cond-br cmp error-block cont-block) - (irc-begin-block cont-block))) - -;; Ditto but with too many. -(defun compile-error-if-too-many-arguments (error-block cmax nargs) - (let* ((cont-block (irc-basic-block-create "enough-arguments")) - (cmp (irc-icmp-ugt nargs cmax))) - (irc-cond-br cmp error-block cont-block) - (irc-begin-block cont-block))) - -;; Generate code to bind the required arguments. -(defun compile-required-arguments (reqargs cc) - ;; reqargs is as returned from process-lambda-list- (# ...) where # is the count. - ;; cc is the calling-convention object. - (dolist (req (cdr reqargs)) - (let ((arg (calling-convention-vaslist.va-arg cc))) - (cmp-log "(calling-convention-vaslist.va-arg cc) -> {}%N" arg) - (funcall *argument-out* arg req)))) - -;;; Unlike the other compile-*-arguments, this one returns a value- -;;; an LLVM Value for the number of arguments remaining. -(defun compile-optional-arguments (optargs nreq calling-conv false true) - ;; optargs is (# var suppliedp default ...) - ;; We basically generate a switch, but also return the number of arguments remaining - ;; (or zero if that's negative). - ;; For (&optional a b) for example, - #| -size_t nargs_remaining; -switch (nargs) { - case 0: nargs_remaining = 0; a = [nil]; a_p = [nil]; b = [nil]; b_p = [nil]; break; - case 1: nargs_remaining = 0; a = va_arg(); a_p = [t]; b = [nil]; b_p = [nil]; break; - default: nargs_remaining = nargs - 2; a = va_arg(); a_p = [t]; b = va_arg(); b_p = [t]; break; -} - |# - ;; All these assignments are done with phi so it's a bit more confusing to follow, unfortunately. - (let* ((nargs (calling-convention-nargs calling-conv)) - (nopt (first optargs)) - (nfixed (+ nopt nreq)) - (opts (rest optargs)) - (enough (irc-basic-block-create "enough-for-optional")) - (undef (irc-undef-value-get %t*%)) - (sw (irc-switch nargs enough nopt)) - (assn (irc-basic-block-create "optional-assignments")) - (final (irc-basic-block-create "done-parsing-optionals")) - (zero (irc-size_t 0))) - ;; We generate the assignments first, although they occur last. - ;; It's just a bit more convenient to do that way. - (irc-begin-block assn) - (let* ((npreds (1+ nopt)) - (nremaining (irc-phi %size_t% npreds "nargs-remaining")) - (var-phis nil) (suppliedp-phis nil)) - ;; We have to do this in two loops to ensure the PHIs come before any code - ;; generated by *argument-out*. - (dotimes (i nopt) - (push (irc-phi %t*% npreds) suppliedp-phis) - (push (irc-phi %t*% npreds) var-phis)) - ;; OK _now_ argument-out - (do* ((cur-opt opts (cdddr cur-opt)) - (var (car cur-opt) (car cur-opt)) - (suppliedp (cadr cur-opt) (cadr cur-opt)) - (var-phis var-phis (cdr var-phis)) - (var-phi (car var-phis) (car var-phis)) - (suppliedp-phis suppliedp-phis (cdr suppliedp-phis)) - (suppliedp-phi (car suppliedp-phis) (car suppliedp-phis))) - ((endp cur-opt)) - (funcall *argument-out* suppliedp-phi suppliedp) - (funcall *argument-out* var-phi var)) - (irc-br final) - ;; Generate a block for each case. - (do ((i nreq (1+ i))) - ((= i nfixed)) - (let ((new (irc-basic-block-create (core:fmt nil "supplied-{}-arguments" i)))) - (llvm-sys:add-case sw (irc-size_t i) new) - (irc-phi-add-incoming nremaining zero new) - (irc-begin-block new) - ;; Assign each optional parameter accordingly. - (do* ((var-phis var-phis (cdr var-phis)) - (var-phi (car var-phis) (car var-phis)) - (suppliedp-phis suppliedp-phis (cdr suppliedp-phis)) - (suppliedp-phi (car suppliedp-phis) (car suppliedp-phis)) - (j nreq (1+ j)) - (enough (< j i) (< j i))) - ((endp var-phis)) - (irc-phi-add-incoming suppliedp-phi (if enough true false) new) - (irc-phi-add-incoming var-phi (if enough (calling-convention-vaslist.va-arg calling-conv) undef) new)) - (irc-br assn))) - ;; Default case: everything gets a value and a suppliedp=T. - (irc-begin-block enough) - (irc-phi-add-incoming nremaining (irc-sub nargs (irc-size_t nfixed)) enough) - (dolist (suppliedp-phi suppliedp-phis) - (irc-phi-add-incoming suppliedp-phi true enough)) - (dolist (var-phi var-phis) - (irc-phi-add-incoming var-phi (calling-convention-vaslist.va-arg calling-conv) enough)) - (irc-br assn) - ;; ready to generate more code - (irc-begin-block final) - nremaining))) - -(defun compile-rest-argument (rest-var varest-p nremaining calling-conv) - (cmp:irc-branch-to-and-begin-block (cmp:irc-basic-block-create "process-rest-argument")) - (when rest-var - (let* ((rest-alloc (calling-convention-rest-alloc calling-conv)) - (rest (cond - ((eq rest-alloc 'ignore) - ;; &rest variable is ignored- allocate nothing - (irc-undef-value-get %t*%)) - ((eq rest-alloc 'dynamic-extent) - ;; Do the dynamic extent thing- alloca, then an intrinsic to initialize it. - (let ((rrest (alloca-dx-list :length nremaining :label "rrest"))) - (irc-intrinsic "cc_gatherDynamicExtentRestArguments" - (cmp:calling-convention-vaslist* calling-conv) - nremaining - (irc-bit-cast rrest %t**%)))) - (varest-p - #+(or) - (irc-tag-vaslist (cmp:calling-convention-vaslist* calling-conv) - "rest") - ;;#+(or) - (let ((temp-vaslist (alloca-vaslist :label "rest"))) - (irc-intrinsic "cc_gatherVaRestArguments" - (cmp:calling-convention-vaslist* calling-conv) - nremaining - temp-vaslist))) - (t - ;; general case- heap allocation - (irc-intrinsic "cc_gatherRestArguments" - (cmp:calling-convention-vaslist* calling-conv) - nremaining))))) - (funcall *argument-out* rest rest-var)))) - -;;; Keyword processing is the most complicated part, unsurprisingly. -#| -Here is pseudo-C for the parser for (&key a). [foo] indicates an inserted constant. -Having to write with phi nodes unfortunately makes things rather more confusing. - -if ((remaining_nargs % 2) == 1) - cc_oddKeywordException([*current-function-description*]); -tstar bad_keyword = undef; -bool seen_bad_keyword = false; -t_star a_temp = undef, a_p_temp = [nil], allow_other_keys_temp = [nil], allow_other_keys_p_temp = [nil]; -for (; remaining_nargs != 0; remaining_nargs -= 2) { - tstar key = va_arg(vaslist), value = va_arg(vaslist); - if (key == [:a]) { - if (a_p_temp == [nil]) { - a_p_temp = [t]; a_temp = value; continue; - } else continue; - } - if (key == [:allow-other-keys]) { - if (allow_other_keys_p_temp == [nil]) { - allow_other_keys_p_temp = [t]; allow_other_keys_temp = value; continue; - } else continue; - } - seen_bad_keyword = true; bad_keyword = key; -} -if (seen_bad_keyword) - cc_ifBadKeywordArgumentException(allow_other_keys_temp, bad_keyword, [*current-function-description*]); -a_p = a_p_temp; a = a_temp; -|# - -(defun compile-one-key-test (keyword key-arg suppliedp-phi cont-block false) - (let* ((keystring (string keyword)) - ;; NOTE: We might save a bit of time by moving this out of the loop. - ;; Or maybe LLVM can handle it. I don't know. - (key-const (clasp-cleavir::literal keyword)) - (match (irc-basic-block-create (core:fmt nil "matched-{}" keystring))) - (mismatch (irc-basic-block-create (core:fmt nil "not-{}" keystring)))) - (let ((test (irc-icmp-eq key-arg key-const))) - (irc-cond-br test match mismatch)) - (irc-begin-block match) - (let* ((new (irc-basic-block-create (core:fmt nil "new-{}" keystring))) - (old (irc-basic-block-create (core:fmt nil "old-{}" keystring)))) - (let ((test (irc-icmp-eq suppliedp-phi false))) - (irc-cond-br test new old)) - (irc-begin-block new) (irc-br cont-block) - (irc-begin-block old) (irc-br cont-block) - (irc-begin-block mismatch) - (values new old)))) - -(defun compile-key-arguments (keyargs lambda-list-aokp nremaining calling-conv false true) - (macrolet ((do-keys ((keyword) &body body) - `(do* ((cur-key (cdr keyargs) (cddddr cur-key)) - (,keyword (car cur-key) (car cur-key))) - ((endp cur-key)) - ,@body))) - (let ((aok-parameter-p nil) - allow-other-keys - (nkeys (car keyargs)) - (undef (irc-undef-value-get %t*%)) - (start (irc-basic-block-create "parse-key-arguments")) - (matching (irc-basic-block-create "match-keywords")) - (after (irc-basic-block-create "after-kw-loop")) - (unknown-kw (irc-basic-block-create "unknown-kw")) - (kw-loop (irc-basic-block-create "kw-loop")) - (kw-loop-continue (irc-basic-block-create "kw-loop-continue"))) - ;; Prepare for :allow-other-keys. - (unless lambda-list-aokp - ;; Is there an allow-other-keys argument? - (do-keys (key) - (when (eq key :allow-other-keys) (setf aok-parameter-p t) (return))) - ;; If there's no allow-other-keys argument, add one. - (unless aok-parameter-p - (setf keyargs (list* (1+ (car keyargs)) - ;; default, var, and suppliedp are of course dummies. - ;; At the end we can check aok-parameter-p to avoid - ;; actually assigning to them. - :allow-other-keys nil nil nil - (cdr keyargs))))) - (irc-branch-to-and-begin-block start) - ;; If the number of arguments remaining is odd, the call is invalid- error. - (let* ((odd-kw (irc-basic-block-create "odd-kw")) - (rem (irc-srem nremaining (irc-size_t 2))) ; parity - (evenp (irc-icmp-eq rem (irc-size_t 0)))) ; is parity zero (is SUB even)? - (irc-cond-br evenp kw-loop odd-kw) - ;; There have been an odd number of arguments, so signal an error. - (irc-begin-block odd-kw) - (unless (calling-convention-closure calling-conv) - (error "The calling-conv ~s does not have a closure" calling-conv)) - (irc-intrinsic "cc_oddKeywordException" - (calling-convention-closure calling-conv)) - (irc-unreachable)) - ;; Loop starts; welcome hell - (irc-begin-block kw-loop) - (let ((top-param-phis nil) (top-suppliedp-phis nil) - (new-blocks nil) (old-blocks nil) - (nargs-remaining (irc-phi %size_t% 2 "nargs-remaining")) - (sbkw (irc-phi %i1% 2 "seen-bad-keyword")) - (bad-keyword (irc-phi %t*% 2 "bad-keyword"))) - (irc-phi-add-incoming nargs-remaining nremaining start) - (irc-phi-add-incoming sbkw (jit-constant-false) start) - (irc-phi-add-incoming bad-keyword undef start) - (do-keys (key) - (let ((var-phi (irc-phi %t*% 2 (core:fmt nil "{}-top" (string key))))) - (push var-phi top-param-phis) - ;; If we're paying attention to :allow-other-keys, track it specially - ;; and initialize it to NIL. - (cond ((and (not lambda-list-aokp) (eq key :allow-other-keys)) - (irc-phi-add-incoming var-phi false start) - (setf allow-other-keys var-phi)) - (t (irc-phi-add-incoming var-phi undef start)))) - (let ((suppliedp-phi (irc-phi %t*% 2 (core:fmt nil "{}-suppliedp-top" (string key))))) - (push suppliedp-phi top-suppliedp-phis) - (irc-phi-add-incoming suppliedp-phi false start))) - (setf top-param-phis (nreverse top-param-phis) - top-suppliedp-phis (nreverse top-suppliedp-phis)) - ;; Are we done? - (let ((zerop (irc-icmp-eq nargs-remaining (irc-size_t 0)))) - (irc-cond-br zerop after matching)) - (irc-begin-block matching) - ;; Start matching keywords - (let ((key-arg (calling-convention-vaslist.va-arg calling-conv)) - (value-arg (calling-convention-vaslist.va-arg calling-conv))) - (do* ((cur-key (cdr keyargs) (cddddr cur-key)) - (key (car cur-key) (car cur-key)) - (suppliedp-phis top-suppliedp-phis (cdr suppliedp-phis)) - (suppliedp-phi (car suppliedp-phis) (car suppliedp-phis))) - ((endp cur-key)) - (multiple-value-bind (new-block old-block) - (compile-one-key-test key key-arg suppliedp-phi kw-loop-continue false) - (push new-block new-blocks) (push old-block old-blocks))) - (setf new-blocks (nreverse new-blocks) old-blocks (nreverse old-blocks)) - ;; match failure - as usual, works through phi - (irc-branch-to-and-begin-block unknown-kw) - (irc-br kw-loop-continue) - ;; Go around again. And do most of the actual work in phis. - (irc-begin-block kw-loop-continue) - (let ((npreds (1+ (* 2 nkeys)))) ; two for each key, plus one for unknown-kw. - (let ((bot-sbkw (irc-phi %i1% npreds "seen-bad-keyword-bottom")) - (bot-bad-keyword (irc-phi %t*% npreds "bad-keyword-bottom"))) - ;; Set up the top to use these. - (irc-phi-add-incoming sbkw bot-sbkw kw-loop-continue) - (irc-phi-add-incoming bad-keyword bot-bad-keyword kw-loop-continue) - ;; If we're coming from unknown-kw, store that. - (irc-phi-add-incoming bot-sbkw (jit-constant-true) unknown-kw) - (irc-phi-add-incoming bot-bad-keyword key-arg unknown-kw) - ;; If we're coming from a match block, don't change anything. - (dolist (new-block new-blocks) - (irc-phi-add-incoming bot-sbkw sbkw new-block) - (irc-phi-add-incoming bot-bad-keyword bad-keyword new-block)) - (dolist (old-block old-blocks) - (irc-phi-add-incoming bot-sbkw sbkw old-block) - (irc-phi-add-incoming bot-bad-keyword bad-keyword old-block))) - ;; OK now the actual keyword values. - (do* ((var-new-blocks new-blocks (cdr var-new-blocks)) - (var-new-block (car var-new-blocks) (car var-new-blocks)) - (top-param-phis top-param-phis (cdr top-param-phis)) - (top-param-phi (car top-param-phis) (car top-param-phis)) - (top-suppliedp-phis top-suppliedp-phis (cdr top-suppliedp-phis)) - (top-suppliedp-phi (car top-suppliedp-phis) (car top-suppliedp-phis))) - ((endp var-new-blocks)) - (let ((var-phi (irc-phi %t*% npreds)) - (suppliedp-phi (irc-phi %t*% npreds))) - ;; fix up the top part to take values from here - (irc-phi-add-incoming top-param-phi var-phi kw-loop-continue) - (irc-phi-add-incoming top-suppliedp-phi suppliedp-phi kw-loop-continue) - ;; If coming from unknown-kw we keep our values the same. - (irc-phi-add-incoming var-phi top-param-phi unknown-kw) - (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi unknown-kw) - ;; All new-blocks other than this key's stick with what they have. - (dolist (new-block new-blocks) - (cond ((eq var-new-block new-block) - ;; Here, however, we get the new values - (irc-phi-add-incoming var-phi value-arg new-block) - (irc-phi-add-incoming suppliedp-phi true new-block)) - (t - (irc-phi-add-incoming var-phi top-param-phi new-block) - (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi new-block)))) - ;; All old-blocks stick with what they have. - (dolist (old-block old-blocks) - (irc-phi-add-incoming var-phi top-param-phi old-block) - (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi old-block)))))) - (let ((dec (irc-sub nargs-remaining (irc-size_t 2)))) - (irc-phi-add-incoming nargs-remaining dec kw-loop-continue)) - (irc-br kw-loop) - ;; Loop over. - (irc-begin-block after) - ;; If we hit a bad keyword, and care, signal an error. - (unless lambda-list-aokp - (let ((aok-check (irc-basic-block-create "aok-check")) - (kw-assigns (irc-basic-block-create "kw-assigns"))) - (irc-cond-br sbkw aok-check kw-assigns) - (irc-begin-block aok-check) - (irc-intrinsic - "cc_ifBadKeywordArgumentException" - ;; aok was initialized to NIL, regardless of the suppliedp, so this is ok. - allow-other-keys bad-keyword (calling-convention-closure calling-conv)) - (irc-br kw-assigns) - (irc-begin-block kw-assigns))) - (do* ((top-param-phis top-param-phis (cdr top-param-phis)) - (top-param-phi (car top-param-phis) (car top-param-phis)) - (top-suppliedp-phis top-suppliedp-phis (cdr top-suppliedp-phis)) - (top-suppliedp-phi (car top-suppliedp-phis) (car top-suppliedp-phis)) - (cur-key (cdr keyargs) (cddddr cur-key)) - (key (car cur-key) (car cur-key)) - (var (caddr cur-key) (caddr cur-key)) - (suppliedp (cadddr cur-key) (cadddr cur-key))) - ((endp cur-key)) - (when (or (not (eq key :allow-other-keys)) lambda-list-aokp aok-parameter-p) - (funcall *argument-out* top-param-phi var) - (funcall *argument-out* top-suppliedp-phi suppliedp))))))) - -(defun compile-general-lambda-list-code (reqargs - optargs - rest-var - varest-p - key-flag - keyargs - allow-other-keys - calling-conv - &key argument-out (safep t)) - (cmp-log "Entered compile-general-lambda-list-code%N") - (let* ((*argument-out* argument-out) - (nargs (calling-convention-nargs calling-conv)) - (nreq (car reqargs)) - (nopt (car optargs)) - (nfixed (+ nreq nopt)) - (creq (irc-size_t nreq)) - (cmax (if (or rest-var key-flag) - nil - (irc-size_t nfixed))) - (wrong-nargs-block - (when safep - (compile-wrong-number-arguments-block - (calling-convention-closure calling-conv) - nargs creq cmax)))) - (unless (zerop nreq) - (when safep - (compile-error-if-not-enough-arguments wrong-nargs-block creq nargs)) - (compile-required-arguments reqargs calling-conv)) - (let (;; NOTE: Sometimes we don't actually need these. - ;; We could save miniscule time by not generating. - (iNIL (clasp-cleavir::%nil)) (iT (clasp-cleavir::%t))) - (if (or rest-var key-flag) - ;; We have &key and/or &rest, so parse with that expectation. - ;; Specifically, we have to get a variable for how many arguments are left after &optional. - (let ((nremaining - (if (zerop nopt) - ;; With no optional arguments it's trivial. - (irc-sub nargs creq "nremaining") - ;; Otherwise - (compile-optional-arguments optargs nreq calling-conv iNIL iT)))) - ;; Note that we don't need to check for too many arguments here. - (when rest-var - (compile-rest-argument rest-var varest-p nremaining calling-conv)) - (when key-flag - (compile-key-arguments keyargs (or allow-other-keys (not safep)) - nremaining calling-conv iNIL iT))) - ;; We don't have &key or &rest, but we might still have &optional. - (progn - (unless (zerop nopt) - ;; Return value of compile-optional-arguments is unneeded- - ;; we could use it in the error check to save a subtraction, though. - (compile-optional-arguments optargs nreq calling-conv iNIL iT)) - (when safep - (cmp-log "Last if-too-many-arguments {} {}" cmax nargs) - (compile-error-if-too-many-arguments wrong-nargs-block cmax nargs))))))) - - - - -(defun compile-only-req-and-opt-arguments (arity cleavir-lambda-list-analysis calling-conv &key argument-out (safep t)) - (multiple-value-bind (reqargs optargs) - (process-cleavir-lambda-list-analysis cleavir-lambda-list-analysis) - (let* ((register-args (calling-convention-register-args calling-conv)) - (nargs (calling-convention-nargs calling-conv)) - (nreq (car (cleavir-lambda-list-analysis-required cleavir-lambda-list-analysis))) - (creq (irc-size_t nreq)) - (nopt (car (cleavir-lambda-list-analysis-optional cleavir-lambda-list-analysis))) - (cmax (irc-size_t (+ nreq nopt))) - (error-block - ;; see kludge above - (when safep - (compile-wrong-number-arguments-block - (calling-convention-closure calling-conv) - nargs creq cmax)))) - ;; fixme: it would probably be nicer to generate one switch such that not-enough-arguments - ;; goes to an error block and too-many goes to another. then we'll only have one test on - ;; the argument count. llvm might reduce it to that anyway, though. - (flet ((ensure-register (registers undef &optional name) - (declare (ignore name)) - (let ((register (car registers))) - (if register - register - undef)))) - (unless (cmp:generate-function-for-arity-p arity cleavir-lambda-list-analysis) - (let ((error-block (compile-wrong-number-arguments-block (calling-convention-closure calling-conv) - (jit-constant-i64 (length register-args)) - (jit-constant-i64 nreq) - (jit-constant-i64 (+ nreq nopt))))) - (irc-br error-block) - (return-from compile-only-req-and-opt-arguments nil))) - ;; required arguments - (when (> nreq 0) - (when safep - (compile-error-if-not-enough-arguments error-block creq nargs)) - (dolist (req (cdr reqargs)) - ;; we pop the register-args so that the optionals below won't use em. - (funcall argument-out (pop register-args) req))) - ;; optional arguments. code is mostly the same as compile-optional-arguments (fixme). - (if (> nopt 0) - (let* ((npreds (1+ nopt)) - (undef (irc-undef-value-get %t*%)) - (true (clasp-cleavir::%t)) - (false (clasp-cleavir::%nil)) - (default (irc-basic-block-create "enough-for-optional")) - (assn (irc-basic-block-create "optional-assignments")) - (after (irc-basic-block-create "argument-parsing-done")) - (sw (irc-switch nargs default nopt)) - (var-phis nil) (suppliedp-phis nil)) - (irc-begin-block assn) - (dotimes (i nopt) - (push (irc-phi %t*% npreds) var-phis) - (push (irc-phi %t*% npreds) suppliedp-phis)) - (do ((cur-opt (cdr optargs) (cdddr cur-opt)) - (var-phis var-phis (cdr var-phis)) - (suppliedp-phis suppliedp-phis (cdr suppliedp-phis))) - ((endp cur-opt)) - (funcall argument-out (car suppliedp-phis) (second cur-opt)) - (funcall argument-out (car var-phis) (first cur-opt))) - (irc-br after) - ;; each case - (dotimes (i nopt) - (let* ((opti (+ i nreq)) - (blck (irc-basic-block-create (core:fmt nil "supplied-{}-arguments" opti)))) - (llvm-sys:add-case sw (irc-size_t opti) blck) - (do ((var-phis var-phis (cdr var-phis)) - (suppliedp-phis suppliedp-phis (cdr suppliedp-phis)) - (registers register-args (cdr registers)) - (optj nreq (1+ optj))) - ((endp var-phis)) - (cond ((< optj opti) ; enough arguments - (irc-phi-add-incoming (car suppliedp-phis) true blck) - (irc-phi-add-incoming (car var-phis) (ensure-register registers undef :nopt) blck)) - (t ; nope - (irc-phi-add-incoming (car suppliedp-phis) false blck) - (irc-phi-add-incoming (car var-phis) undef blck)))) - (irc-begin-block blck) (irc-br assn))) - ;; default - ;; just use a register for each argument - ;; we have to use another block because compile-error-etc does an invoke - ;; and generates more blocks. - (let ((default-cont (irc-basic-block-create "enough-for-optional-continued"))) - (do ((var-phis var-phis (cdr var-phis)) - (suppliedp-phis suppliedp-phis (cdr suppliedp-phis)) - (registers register-args (cdr registers))) - ((endp var-phis)) - (irc-phi-add-incoming (car suppliedp-phis) true default-cont) - (irc-phi-add-incoming (car var-phis) (ensure-register registers undef :var-phis) default-cont)) - (irc-begin-block default) - ;; test for too many arguments - (when safep - (compile-error-if-too-many-arguments error-block cmax nargs)) - (irc-branch-to-and-begin-block default-cont) - (irc-br assn) - ;; and, done. - (irc-begin-block after))) - ;; no optional arguments, so not much to do - (when safep - (compile-error-if-too-many-arguments error-block cmax nargs)))) - t))) - -(defun req-opt-only-p (cleavir-lambda-list) - (let ((nreq 0) (nopt 0) (req-opt-only t) - (state nil)) - (dolist (item cleavir-lambda-list) - (cond ((eq item '&optional) - (if (eq state '&optional) - (progn (setf req-opt-only nil) ; dupe &optional; just mark as general - (return)) - (setf state '&optional))) - ((member item lambda-list-keywords) - (setf req-opt-only nil) - (return)) - (t (if (eq state '&optional) - (incf nopt) - (incf nreq))))) - (values req-opt-only nreq nopt))) - -(defun lambda-list-arguments (lambda-list) - (multiple-value-bind (reqargs optargs rest-var key-flag keyargs allow-other-keys auxargs varest-p) - (core:process-lambda-list lambda-list 'function) - (declare (ignore auxargs allow-other-keys varest-p key-flag)) - (cmp-log "reqargs = {}%N" reqargs) - (cmp-log "optargs = {}%N" optargs) - (cmp-log "rest-var = {}%N" rest-var) - (cmp-log "keyargs = {}%N" keyargs) - (let ((args '())) - (dolist (req (rest reqargs)) - (cmp-log "req-name = {}%N" req) - (push req args)) - (do ((cur (rest optargs) (cdddr cur))) - ((null cur) nil) - (let ((opt-name (car cur)) - (opt-flag (cadr cur))) - (cmp-log "opt cur = {}%N" cur) - (cmp-log "opt-name = {}%N" opt-name) - (cmp-log "opt-flag = {}%N" opt-flag) - (push opt-name args) - (when opt-flag (push opt-flag args)))) - (when rest-var (push rest-var args)) - (do ((cur (rest keyargs) (cddddr cur))) - ((null cur) nil) - (let ((key-name (caddr cur)) - (key-flag (cadddr cur))) - (cmp-log "key-name = {}%N" key-name) - (cmp-log "key-flag = {}%N" key-flag) - (push key-name args) - (when key-flag (push key-flag args)))) - (nreverse args)))) - -(defun calculate-cleavir-lambda-list-analysis (lambda-list) - ;; we assume that the lambda list is in its correct format: - ;; 1) required arguments are lexical locations. - ;; 2) optional arguments are ( ) - ;; 3) keyword arguments are ( ) - ;; this lets us cheap out on parsing, except &rest and &allow-other-keys. - (cmp-log "calculate-cleavir-lambda-list-analysis lambda-list -> {}%N" lambda-list) - (let (required optional rest-type rest key aok-p key-flag - (required-count 0) (optional-count 0) (key-count 0)) - (dolist (item lambda-list) - (case item - ((&optional) #|ignore|#) - ((&key) (setf key-flag t)) - ((&rest core:&va-rest) (setf rest-type item)) - ((&allow-other-keys) (setf aok-p t)) - (t (if (listp item) - (cond ((= (length item) 2) - ;; optional - (incf optional-count) - ;; above, we expect (location -p whatever) - ;; though it's specified as (var init -p) - ;; fix me - (push (first item) optional) - (push (second item) optional) - (push nil optional)) - (t ;; key, assumedly - (incf key-count) - (push (first item) key) - (push (first item) key) - ;; above, we treat this as being the location, - ;; even though from process-lambda-list it's - ;; the initform. - ;; this file needs work fixme. - (push (second item) key) - (push (third item) key))) - ;; nonlist; we picked off lambda list keywords, so it's an argument. - (cond (rest-type - ;; we've seen a &rest lambda list keyword, so this must be that - (setf rest item)) - ;; haven't seen anything, it's required - (t (incf required-count) - (push item required))))))) - (let* ((cleavir-lambda-list (ensure-cleavir-lambda-list lambda-list)) - (arguments (lambda-list-arguments cleavir-lambda-list))) - (make-cleavir-lambda-list-analysis - :cleavir-lambda-list (ensure-cleavir-lambda-list lambda-list) ; Is this correct? - :req-opt-only-p (req-opt-only-p (ensure-cleavir-lambda-list lambda-list)) - :lambda-list-arguments arguments - :required (cons required-count (nreverse required)) - :optional (cons optional-count (nreverse optional)) - :rest rest - :key-flag key-flag - :key-count (cons key-count (nreverse key)) - :aok-p aok-p - :aux-p nil ; aux-p; unused here - :va-rest-p (if (eq rest-type 'core:&va-rest) t nil))))) - - - -(defun may-use-only-registers (cleavir-lambda-list-analysis) - (multiple-value-bind (req-opt-only nreq nopt) - (req-opt-only-p (cleavir-lambda-list-analysis-cleavir-lambda-list cleavir-lambda-list-analysis)) - (and req-opt-only - (and (<= +entry-point-arity-begin+ (+ nreq nopt)) - (< (+ nreq nopt) +entry-point-arity-end+))))) - -;;; compile-lambda-list-code -;;; you must provide the following lambdas -;;; alloca-size_t (label) that allocas a size_t slot in the current function -;;; alloca-vaslist (label) that allocas a vaslist slot in the current function -;;; translate-datum (datum) that translates a datum into an alloca in the current function -;;; -(defun compile-lambda-list-code (cleavir-lambda-list-analysis calling-conv arity - &key argument-out (safep t)) - "Return T if arguments were processed and NIL if they were not" - (cmp-log "about to compile-lambda-list-code cleavir-lambda-list-analysis: {}%N" cleavir-lambda-list-analysis) - (multiple-value-bind (reqargs optargs rest-var key-flag keyargs allow-other-keys unused-auxs varest-p) - (process-cleavir-lambda-list-analysis cleavir-lambda-list-analysis) - (declare (ignore unused-auxs)) - (cmp-log " reqargs -> {}%N" reqargs) - (cmp-log " optargs -> {}%N" optargs) - (cmp-log " keyargs -> {}%N" keyargs) - (cond - ((eq arity :general-entry) - (compile-general-lambda-list-code reqargs - optargs - rest-var - varest-p - key-flag - keyargs - allow-other-keys - calling-conv - :argument-out argument-out - :safep safep) - t ;; always successful for general lambda-list processing - ) - ((and (fixnump arity) - (may-use-only-registers cleavir-lambda-list-analysis)) - (let ((result (compile-only-req-and-opt-arguments arity cleavir-lambda-list-analysis #|reqargs optargs|# - calling-conv - :argument-out argument-out - :safep safep))) - result ; may be nil or t - )) - (t (let* ((register-args (calling-convention-register-args calling-conv)) - (nargs (length register-args)) - (arg-buffer (if (= nargs 0) - nil - (alloca-arguments nargs "ll-args"))) - (vaslist* (alloca-vaslist)) - (idx 0)) - (dolist (arg register-args) - (let ((arg-gep (irc-typed-gep (llvm-sys:array-type-get %t*% nargs) arg-buffer (list 0 idx)))) - (incf idx) - (irc-store arg arg-gep))) - (if (= nargs 0) - (vaslist-start vaslist* (jit-constant-i64 nargs)) - (vaslist-start vaslist* (jit-constant-i64 nargs) - (irc-bit-cast arg-buffer %i8**%))) - (setf (calling-convention-vaslist* calling-conv) vaslist*) - (compile-general-lambda-list-code reqargs - optargs - rest-var - varest-p - key-flag - keyargs - allow-other-keys - calling-conv - :argument-out argument-out - :safep safep) - ) - t ;; always successful when using general lambda-list processing - )))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Setup the calling convention -;; -(defun setup-calling-convention (llvm-function arity - &key debug-on rest-alloc cleavir-lambda-list-analysis) - (initialize-calling-convention llvm-function - arity - :debug-on debug-on - :rest-alloc rest-alloc - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis)) diff --git a/src/lisp/kernel/cmp/cmpexports.lisp b/src/lisp/kernel/cmp/cmpexports.lisp index db72e124c7..4e727f14a6 100644 --- a/src/lisp/kernel/cmp/cmpexports.lisp +++ b/src/lisp/kernel/cmp/cmpexports.lisp @@ -1,7 +1,6 @@ (in-package :cmp) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(with-debug-info-source-position - calculate-cleavir-lambda-list-analysis + (export '(calculate-cleavir-lambda-list-analysis module-report transform-lambda-parts codegen-startup-shutdown @@ -127,16 +126,9 @@ irc-apply function-type-create-on-the-fly evaluate-foreign-arguments - calling-convention-closure - calling-convention-vaslist* - calling-convention-vaslist.va-arg - calling-convention-nargs - calling-convention-register-args cmp-log cmp-log-dump-module cmp-log-dump-function - make-file-metadata - make-function-metadata function-info function-info-cleavir-lambda-list-analysis make-function-info @@ -149,7 +141,6 @@ compile-error-if-not-enough-arguments compile-lambda-function compile-lambda-list-code - make-calling-convention compiler-error compiler-warn compiler-style-warn @@ -194,6 +185,7 @@ alloca-vaslist alloca-temp-values alloca-arguments + alloca-register-save-area irc-and irc-or irc-xor @@ -310,8 +302,6 @@ jit-constant-unique-string-ptr module-make-global-string make-boot-function-global-variable - setup-calling-convention - initialize-calling-convention ensure-cleavir-lambda-list ensure-cleavir-lambda-list-analysis process-cleavir-lambda-list-analysis @@ -319,15 +309,6 @@ cleavir-lambda-list-analysis-rest process-bir-lambda-list typeid-core-unwind - *dbg-generate-dwarf* - *dbg-current-function-metadata* - *dbg-current-function-lineno* - *dbg-current-scope* - with-guaranteed-*current-source-pos-info* - with-dbg-function - with-dbg-lexical-block - dbg-variable-alloca - dbg-variable-value compile-file-source-pos-info c++-field-offset c++-field-index @@ -335,7 +316,6 @@ c++-struct*-type c++-field-ptr %closure%.offset-of[n]/t* - with-debug-info-generator with-irbuilder with-landing-pad make-uintptr_t diff --git a/src/lisp/kernel/cmp/cmpintrinsics.lisp b/src/lisp/kernel/cmp/cmpintrinsics.lisp index 04d41f36a7..a945edfa4d 100644 --- a/src/lisp/kernel/cmp/cmpintrinsics.lisp +++ b/src/lisp/kernel/cmp/cmpintrinsics.lisp @@ -615,64 +615,6 @@ Boehm and MPS use a single pointer" (irc-store shifted-nargs-next shifted-nargs*) val)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Provide the arguments passed to the function in a convenient manner. -;; Either the register arguments are available in register-args -;; or the vaslist is used to access the arguments -;; one after the other with calling-convention.va-arg -(defstruct (calling-convention (:type vector) :named) - closure - nargs - register-args ; The arguments that were passed in registers - vaslist* ; The address of the vaslist, or NIL - cleavir-lambda-list-analysis ; analysis of cleavir-lambda-list - rest-alloc ; whether we can dx or ignore a &rest argument - ) - -;; Parse the function arguments into a calling-convention - -(defun initialize-calling-convention (llvm-function arity &key debug-on cleavir-lambda-list-analysis rest-alloc) - (cmp-log "llvm-function: {}%N" llvm-function) - (let ((arguments (llvm-sys:get-argument-list llvm-function))) - (cmp-log "llvm-function arguments: {}%N" (llvm-sys:get-argument-list llvm-function)) - (cmp-log "llvm-function isVarArg: {}%N" (llvm-sys:is-var-arg llvm-function)) - (let ((register-save-area* (when debug-on (alloca-register-save-area arity :label "register-save-area"))) - (closure (first arguments))) - (cmp-log "A%N") - (unless (first arguments) - (error "initialize-calling-convention for arguments ~a - the closure is NIL" arguments)) - (cmp-log "A%N") - (cond - ((eq arity :general-entry) - (cmp-log "B%N") - (let* ((nargs (second arguments)) - (args (third arguments)) - (vaslist* (alloca-vaslist))) - (vaslist-start vaslist* nargs args) - (maybe-spill-to-register-save-area arity register-save-area* (list closure nargs args)) - (make-calling-convention :closure closure - :nargs nargs - :vaslist* vaslist* - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis - :rest-alloc rest-alloc))) - (t - (let ((nargs (length (cdr arguments))) - (register-args (cdr arguments))) - (maybe-spill-to-register-save-area arity register-save-area* (list* closure register-args)) - (make-calling-convention :closure closure - :nargs (jit-constant-i64 nargs) - :register-args register-args - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis - :rest-alloc rest-alloc))))))) - -;;; -;;; Read the next argument from the vaslist -(defun calling-convention-vaslist.va-arg (cc) - (let* ((vaslist (calling-convention-vaslist* cc))) - (gen-vaslist-pop vaslist))) - (defun fn-prototype (arity) (cond ((eq arity :general-entry) @@ -692,29 +634,6 @@ Boehm and MPS use a single pointer" (error "Arity is too high -add support for this ~a" arity)) (t (error "fn-prototype-names Illegal arity ~a" arity)))) -;; (Maybe) generate code to store registers in memory. Return value unspecified. -(defun maybe-spill-to-register-save-area (arity register-save-area* registers) - (cmp-log "maybe-spill-to-register-save-area register-save-area* -> {}%N" register-save-area*) - (cmp-log "maybe-spill-to-register-save-area registers -> {}%N" registers) - (when register-save-area* - (let ((words (irc-arity-info arity))) - (flet ((spill-reg (idx reg addr-name) - (let ((addr (irc-typed-gep (llvm-sys:array-type-get %t*% words) register-save-area* (list 0 idx) addr-name)) - (reg-i8* (cond - ((llvm-sys:type-equal (llvm-sys:get-type reg) %i64%) - (irc-int-to-ptr reg %i8*% "nargs-i8*")) - (t - (irc-bit-cast reg %i8*% "reg-i8*"))))) - (irc-store reg-i8* addr t) - addr))) - (let* ((names (if (eq arity :general-entry) - (list "rsa-closure" "rsa-nargs" "rsa-args") - (list "rsa-closure" "rsa-arg0" "rsa-arg1" "rsa-arg2" "rsa-arg3" "rsa-arg4" "rsa-arg5" "rsa-arg6" "rsa-arg7"))) - (idx 0)) - (mapc (lambda (reg name) - (spill-reg idx reg name) - (incf idx)) - registers names)))))) ;;; This is the normal C-style prototype for a function (define-symbol-macro %opaque-fn-prototype*% %i8*%) diff --git a/src/lisp/kernel/cmp/cmpir.lisp b/src/lisp/kernel/cmp/cmpir.lisp index 747f235eb6..ec4dfc39fb 100644 --- a/src/lisp/kernel/cmp/cmpir.lisp +++ b/src/lisp/kernel/cmp/cmpir.lisp @@ -83,7 +83,6 @@ That layout looks like: * Return true if bindings will be defined and false if not. " cleavir-lambda-list - req-opt-only-p (lambda-list-arguments nil) (required (list 0)) ; default zero required (optional (list 0)) ; default zero optional @@ -136,12 +135,12 @@ Maybe in the future we will want to actually put a test here." If nil then insert a general_entry_point_redirect_x function which just calls the general entry point. This is useful for entry points that just signal an argcount mismatch error - we can just use existing entry point functions that defer to the general rather than generating more code." (if (eq arity :general-entry) t - (if (cleavir-lambda-list-analysis-req-opt-only-p cll-analysis) - (let* ((nreq (car (cleavir-lambda-list-analysis-required cll-analysis))) - (nopt (car (cleavir-lambda-list-analysis-optional cll-analysis)))) - (not (or (< arity nreq) - (< (+ nreq nopt) arity)))) - nil))) + (let* ((nreq (car (cleavir-lambda-list-analysis-required cll-analysis))) + (nopt (car (cleavir-lambda-list-analysis-optional cll-analysis)))) + (and (not (or (< arity nreq) + (< (+ nreq nopt) arity))) + (null (cleavir-lambda-list-analysis-rest cll-analysis)) + (not (cleavir-lambda-list-analysis-key-flag cll-analysis)))))) (defstruct (xep-group (:type vector) :named) "xep-group describes a group of xep functions. @@ -192,9 +191,7 @@ local-function - the lcl function that all of the xep functions call." spi) (let ((lineno 0) (column 0) (filepos 0) (source-pathname "-unknown-file-")) (when spi - (setf source-pathname (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle spi))) + (setf source-pathname (core:source-pos-info/pathname spi) lineno (core:source-pos-info-lineno spi) ;; FIXME: Why 1+? column (1+ (core:source-pos-info-column spi)) @@ -255,6 +252,9 @@ local-function - the lcl function that all of the xep functions call." (let ((fixed-indices (irc-fix-gep-indices indices))) (llvm-sys:create-in-bounds-gep *irbuilder* type ptr fixed-indices name ))) +(defun irc-const-gep1-64 (type ptr index &optional (label "gep")) + (ensure-opaque-or-pointee-type-matches ptr type) + (llvm-sys:create-const-gep1-64 *irbuilder* type ptr index label)) (defun irc-const-gep2-64 (type ptr idx0 idx1 label) (ensure-opaque-or-pointee-type-matches ptr type) (llvm-sys:create-const-gep2-64 *irbuilder* type ptr idx0 idx1 label)) @@ -1157,7 +1157,7 @@ function-description - for debugging." (defun alloca-arguments (size &optional (label "callargs")) (llvm-sys:create-alloca *irbuilder-function-alloca* (llvm-sys:array-type-get %t*% size) (jit-constant-i64 1) label)) -(defun alloca-register-save-area (arity &key (irbuilder *irbuilder-function-alloca*) (label "vaslist")) +(defun alloca-register-save-area (arity &key (irbuilder *irbuilder-function-alloca*) (label "register-save-area")) "Alloca space for a register save area, and keep it in the stack map." (with-irbuilder (irbuilder) (multiple-value-bind (words index) diff --git a/src/lisp/kernel/cmp/cmpltv.lisp b/src/lisp/kernel/cmp/cmpltv.lisp index 5f7bcc052d..eb8c1f10f6 100644 --- a/src/lisp/kernel/cmp/cmpltv.lisp +++ b/src/lisp/kernel/cmp/cmpltv.lisp @@ -1317,9 +1317,7 @@ (make-instance 'spi-attr :function inst :pathname (ensure-constant - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle cspi)))) + (core:source-pos-info/pathname cspi)) :lineno (core:source-pos-info-lineno cspi) :column (core:source-pos-info-column cspi) :filepos (core:source-pos-info-filepos cspi)))) @@ -1443,9 +1441,7 @@ :start (core:bytecode-debug-info/start item) :end (core:bytecode-debug-info/end item) :pathname (ensure-constant - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle spi)))) + (core:source-pos-info/pathname spi)) :lineno (core:source-pos-info-lineno spi) :column (core:source-pos-info-column spi) :filepos (core:source-pos-info-filepos spi)))) diff --git a/src/lisp/kernel/cmp/cmprunall.lisp b/src/lisp/kernel/cmp/cmprunall.lisp index 92d7d3cdbb..5c0e955d54 100644 --- a/src/lisp/kernel/cmp/cmprunall.lisp +++ b/src/lisp/kernel/cmp/cmprunall.lisp @@ -39,26 +39,21 @@ load-time-value manager (true - in COMPILE-FILE) or not (false - in COMPILE)." (*irbuilder-run-all-alloca* irbuilder-alloca) (*irbuilder-run-all-body* irbuilder-body) (*current-function* run-all-fn)) - (cmp-log "Entering with-dbg-function%N") - (cmp:with-guaranteed-*current-source-pos-info* () - (cmp:with-dbg-function (:lineno 0 - :function run-all-fn - :function-type (cmp:fn-prototype :general-entry)) - ;; Set up dummy debug info for these irbuilders - (let ((entry-bb (irc-basic-block-create "entry" run-all-fn))) - (irc-set-insert-point-basic-block entry-bb irbuilder-alloca)) - (cmp-log "bb work do-make-new-run-all%N") - (let ((body-bb (irc-basic-block-create "body" run-all-fn))) - (irc-set-insert-point-basic-block body-bb irbuilder-body) - ;; Setup exception handling and cleanup landing pad - (with-irbuilder (irbuilder-alloca) - (let ((entry-branch (irc-br body-bb))) - (irc-set-insert-point-instruction entry-branch irbuilder-alloca) - (with-irbuilder (irbuilder-body) - (progn - (cmp-log "running body do-make-new-run-all%N") - (funcall body run-all-fn)) - (irc-ret-null-t*)))))))) + ;; Set up dummy debug info for these irbuilders + (let ((entry-bb (irc-basic-block-create "entry" run-all-fn))) + (irc-set-insert-point-basic-block entry-bb irbuilder-alloca)) + (cmp-log "bb work do-make-new-run-all%N") + (let ((body-bb (irc-basic-block-create "body" run-all-fn))) + (irc-set-insert-point-basic-block body-bb irbuilder-body) + ;; Setup exception handling and cleanup landing pad + (with-irbuilder (irbuilder-alloca) + (let ((entry-branch (irc-br body-bb))) + (irc-set-insert-point-instruction entry-branch irbuilder-alloca) + (with-irbuilder (irbuilder-body) + (progn + (cmp-log "running body do-make-new-run-all%N") + (funcall body run-all-fn)) + (irc-ret-null-t*)))))) (values run-all-fn))) (defmacro with-make-new-run-all ((run-all-fn &optional (name-suffix '(core:fmt nil "*{}" (core:next-number)))) &body body) diff --git a/src/lisp/kernel/cmp/compile-file-parallel.lisp b/src/lisp/kernel/cmp/compile-file-parallel.lisp index 6ecf063e85..a58b1b70e5 100644 --- a/src/lisp/kernel/cmp/compile-file-parallel.lisp +++ b/src/lisp/kernel/cmp/compile-file-parallel.lisp @@ -131,10 +131,9 @@ ;;; (defun compile-from-module (job - &key optimize - optimize-level + &key optimize-level intermediate-output-type) - (declare (ignore optimize optimize-level)) + (declare (ignore optimize-level)) (let ((module (ast-job-module job))) (ecase intermediate-output-type (:in-memory-object @@ -149,48 +148,43 @@ (gctools:thread-local-cleanup)) (values)) -(defun ast-job-to-module (job &key optimize optimize-level) +(defun ast-job-to-module (job &key (optimize-level *optimization-level*)) (let ((module (llvm-create-module (format nil "module~a" (ast-job-form-index job)))) (core:*current-source-pos-info* (ast-job-source-pos-info job))) - (with-module (:module module - :optimize (when optimize #'llvm-sys:optimize-module) - :optimize-level optimize-level) - (with-debug-info-generator (:module module - :pathname *compile-file-source-debug-pathname*) - (with-make-new-run-all (run-all-function (format nil "module~a" (ast-job-form-index job))) + (with-module (:module module) + (with-make-new-run-all (run-all-function (format nil "module~a" (ast-job-form-index job))) + (clasp-cleavir::with-debuginfo (module :path cmp::*compile-file-source-debug-pathname*) (with-literal-table (:id (ast-job-form-index job)) - (core:with-memory-ramp (:pattern 'gctools:ramp) - (literal:arrange-thunk-as-top-level - (clasp-cleavir-translate-bir::translate-ast - (ast-job-ast job))))) - (let ((startup-function (add-global-ctor-function module run-all-function - :position (ast-job-form-counter job)))) + (core:with-memory-ramp (:pattern 'gctools:ramp) + (literal:arrange-thunk-as-top-level + (clasp-cleavir-translate-bir::translate-ast + (ast-job-ast job)))))) + (let ((startup-function (add-global-ctor-function module run-all-function + :position (ast-job-form-counter job)))) ;;; (add-llvm.used module startup-function) - (add-llvm.global_ctors module 15360 startup-function) - (setf (ast-job-startup-function-name job) (llvm-sys:get-name startup-function)) - ;; The link-once-odrlinkage should keep the startup-function alive and that - ;; should keep everything else alive as well. - ) - #+(or) - (make-boot-function-global-variable module run-all-function - :position (ast-job-form-index job) - ))) + (add-llvm.global_ctors module 15360 startup-function) + (setf (ast-job-startup-function-name job) (llvm-sys:get-name startup-function)) + ;; The link-once-odrlinkage should keep the startup-function alive and that + ;; should keep everything else alive as well. + ) + #+(or) + (make-boot-function-global-variable module run-all-function + :position (ast-job-form-index job) + )) (cmp-log "About to verify the module%N") (cmp-log-dump-module module) (irc-verify-module-safe module) (quick-module-dump module (format nil "preoptimize~a" (ast-job-form-index job))) - ;; ALWAYS link the builtins in, inline them and then remove them. - #+(or)(link-inline-remove-builtins module) - module))) + module) + (llvm-sys:optimize-module module optimize-level) + module)) (defun compile-from-ast (job &key - optimize - optimize-level + (optimize-level *optimization-level*) intermediate-output-type) (setf (ast-job-module job) - (ast-job-to-module job :optimize optimize - :optimize-level optimize-level)) - (compile-from-module job :optimize optimize :optimize-level optimize-level + (ast-job-to-module job :optimize-level optimize-level)) + (compile-from-module job :optimize-level optimize-level :intermediate-output-type intermediate-output-type)) (defun read-one-ast (source-sin environment eof-value) @@ -241,7 +235,6 @@ environment &key (compile-from-module nil) ; If nil - then compile from the ast in threads - optimize optimize-level output-path (intermediate-output-type :in-memory-object) ; or :bitcode @@ -273,7 +266,7 @@ multithreaded performance that we should explore." #+(or cclasp eclasp)(eclector.reader:*client* cmp:*cst-client*) ast-jobs (_ (cfp-log "Starting the pool of threads~%")) - (job-args `(:optimize ,optimize :optimize-level ,optimize-level + (job-args `(:optimize-level ,optimize-level :intermediate-output-type ,intermediate-output-type)) (pool (make-thread-pool (if compile-from-module 'compile-from-module @@ -302,14 +295,13 @@ multithreaded performance that we should explore." :form-index form-index :form-counter form-counter))) (when compile-from-module - (let ((module (ast-job-to-module ast-job :optimize optimize :optimize-level optimize-level))) + (let ((module (ast-job-to-module ast-job :optimize-level optimize-level))) (setf (ast-job-module ast-job) module))) (unless ast-only (push ast-job ast-jobs) (thread-pool-enqueue pool ast-job)) #+(or) (compile-from-ast ast-job - :optimize optimize :optimize-level optimize-level :intermediate-output-type intermediate-output-type)))) ;; Send :quit messages to all threads. @@ -334,7 +326,6 @@ multithreaded performance that we should explore." output-type output-path environment - (optimize t) (optimize-level *optimization-level*) ast-only) "* Arguments @@ -343,7 +334,6 @@ multithreaded performance that we should explore." - environment :: Arbitrary, passed only to hook Compile a lisp source file into an LLVM module." (cclasp-loop2 input-stream environment - :optimize optimize :optimize-level optimize-level :output-path output-path :intermediate-output-type (ecase output-type @@ -389,8 +379,7 @@ Compile a lisp source file into an LLVM module." (error "Add support for output-type: ~a" output-type)))) (defun compile-stream/parallel (input-stream output-path - &key (optimize t) - (optimize-level *optimization-level*) + &key (optimize-level *optimization-level*) (output-type *default-output-type*) environment ;; Use as little llvm as possible for timing @@ -403,7 +392,6 @@ Compile a lisp source file into an LLVM module." :output-type output-type :output-path output-path :environment environment - :optimize optimize :optimize-level optimize-level :ast-only ast-only))) (cond (dry-run (format t "Doing nothing further~%") nil) diff --git a/src/lisp/kernel/cmp/compile-file.lisp b/src/lisp/kernel/cmp/compile-file.lisp index f2aada8929..acc353c90f 100644 --- a/src/lisp/kernel/cmp/compile-file.lisp +++ b/src/lisp/kernel/cmp/compile-file.lisp @@ -166,7 +166,6 @@ &key environment image-startup-position - (optimize t) (optimize-level *optimization-level*)) "* Arguments - source-sin :: An input stream to read forms from. @@ -175,22 +174,16 @@ Compile a Lisp source stream and return a corresponding LLVM module." (let* ((name (namestring *compile-file-pathname*)) (module (llvm-create-module name)) run-all-name) - (unless module (error "module is NIL")) (cmp-log "About to with-module%N") - (with-module (:module module - :optimize (when optimize #'llvm-sys:optimize-module) - :optimize-level optimize-level) + (with-module (:module module) ;; (1) Generate the code - (cmp-log "About to with-debug-info-generator%N") - (with-debug-info-generator (:module *the-module* - :pathname *compile-file-source-debug-pathname*) - (cmp-log "About to with-make-new-run-all%N") - (with-make-new-run-all (run-all-function name) - (cmp-log "About to with-literal-table%N") - (with-literal-table (:id 0) - (cmp-log "About to loop-read-and-compile-file-forms%N") - (loop-read-and-compile-file-forms source-sin environment)) - (setf run-all-name (llvm-sys:get-name run-all-function)))) + (cmp-log "About to with-make-new-run-all%N") + (with-make-new-run-all (run-all-function name) + (cmp-log "About to with-literal-table%N") + (with-literal-table (:id 0) + (cmp-log "About to loop-read-and-compile-file-forms%N") + (loop-read-and-compile-file-forms source-sin environment)) + (setf run-all-name (llvm-sys:get-name run-all-function))) (cmp-log "About to verify the module%N") (cmp-log-dump-module *the-module*) (irc-verify-module-safe *the-module*) @@ -199,9 +192,7 @@ Compile a Lisp source stream and return a corresponding LLVM module." (make-boot-function-global-variable module run-all-name :position image-startup-position :register-library t)) - ;; Now at the end of with-module another round of optimization is done - ;; but the RUN-ALL is now referenced by the CTOR and so it won't be optimized away - ;; ---- MOVE OPTIMIZATION in with-module to HERE ---- + (llvm-sys:optimize-module module optimize-level) (quick-module-dump module "postoptimize") module)) @@ -244,15 +235,14 @@ Compile a Lisp source stream and return a corresponding LLVM module." ((:source-debug-offset *compile-file-source-debug-offset*) 0) - ;; these ought to be removed, or at least made + ;; this ought to be removed, or at least made ;; to use lisp-level optimization policy rather - ;; than what they do now, which is LLVM stuff. - (optimize t) + ;; than what it does now, which is LLVM stuff. (optimize-level *optimization-level*) &allow-other-keys) ;; These are all just passed along to other functions. (declare (ignore output-file environment type - image-startup-position optimize optimize-level)) + image-startup-position optimize-level)) "See CLHS compile-file." (with-compilation-unit () (let* ((output-path (apply #'compile-file-pathname input-file args)) @@ -289,7 +279,6 @@ Compile a Lisp source stream and return a corresponding LLVM module." (defun compile-stream/serial (input-stream output-path &rest args &key - (optimize t) (optimize-level *optimization-level*) (output-type *default-output-type*) ;; type can be either :kernel or :user @@ -307,7 +296,6 @@ Compile a Lisp source stream and return a corresponding LLVM module." (let ((module (compile-stream-to-module input-stream :environment environment :image-startup-position image-startup-position - :optimize optimize :optimize-level optimize-level))) (compile-file-output-module module output-path output-type type diff --git a/src/lisp/kernel/cmp/compile.lisp b/src/lisp/kernel/cmp/compile.lisp index 62182d8ded..8e481934b3 100644 --- a/src/lisp/kernel/cmp/compile.lisp +++ b/src/lisp/kernel/cmp/compile.lisp @@ -4,18 +4,11 @@ (defparameter *lambda-args-num* 0) -(defmacro with-module (( &key module - (optimize nil) - (optimize-level '*optimization-level*) - dry-run) &rest body) +(defmacro with-module ((&key module) &rest body) `(let* ((*the-module* ,module)) (or *the-module* (error "with-module *the-module* is NIL")) - (multiple-value-prog1 - (with-irbuilder ((llvm-sys:make-irbuilder (thread-local-llvm-context))) - ,@body) - (cmp-log "About to optimize-module%N") - ;;(cmp-log-dump-module ,module) - (when (and ,optimize ,optimize-level (null ,dry-run)) (funcall ,optimize ,module ,optimize-level ))))) + (with-irbuilder ((llvm-sys:make-irbuilder (thread-local-llvm-context))) + ,@body))) (defun compile-with-hook (compile-hook definition env) (with-compilation-unit () diff --git a/src/lisp/kernel/cmp/compiler-conditions.lisp b/src/lisp/kernel/cmp/compiler-conditions.lisp index 0a15ae2886..f8d62a247e 100644 --- a/src/lisp/kernel/cmp/compiler-conditions.lisp +++ b/src/lisp/kernel/cmp/compiler-conditions.lisp @@ -85,8 +85,7 @@ (redefinition-new-type condition) (compiler-warning-name condition) (redefinition-old-type condition) - (file-scope-pathname - (file-scope origin)) + (source-pos-info/pathname origin) (source-pos-info-lineno origin) (source-pos-info-column origin)))))) @@ -279,8 +278,7 @@ Operation was (~s~{ ~s~})." (origin (if (consp origin) (car origin) origin))) (handler-case (format *error-output* "~& at ~a ~d:~d~%" - (file-scope-pathname - (file-scope origin)) + (source-pos-info/pathname origin) (source-pos-info-lineno origin) (source-pos-info-column origin)) (error (e) diff --git a/src/lisp/kernel/cmp/debuginfo.lisp b/src/lisp/kernel/cmp/debuginfo.lisp deleted file mode 100644 index c77a104bff..0000000000 --- a/src/lisp/kernel/cmp/debuginfo.lisp +++ /dev/null @@ -1,421 +0,0 @@ -;;; -;;; File: debuginfo.lisp -;;; - -;; Copyright (c) 2014, Christian E. Schafmeister -;; -;; CLASP is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Library General Public -;; License as published by the Free Software Foundation; either -;; version 2 of the License, or (at your option) any later version. -;; -;; See directory 'clasp/licenses' for full details. -;; -;; The above copyright notice and this permission notice shall be included in -;; all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -;; THE SOFTWARE. - -;; -^- - -(in-package :cmp) - -;;; These variables are pretty important to what debug information actually goes -;;; into the file. For example, and as a note to later developers, I just got bit -;;; by the fact that a source position info's filename is often irrelevant - the -;;; dbg-current-scope and dbg-current-file are used. -;;; (defvar *dbg-generate-dwarf* t) <<--- defined in init.lisp -(defvar *dbg-compile-unit*) -(defvar *dbg-current-file*) -(defvar *dbg-current-function-metadata*) -(defvar *dbg-current-function-lineno*) -(defvar *dbg-current-scope* nil - "Stores the current enclosing lexical scope for debugging info") -;;; Unlike other DI structures, each call to create-function seems to result -;;; in a distinct DISubprogram - not our intention. So we hash on the scope. -;;; ATM function scopes are lists so an EQUAL hash table is fine here. -(defvar *dbg-function-metadata-cache*) -;;; We make a cache for file metadata just to save time and make reproducible -;;; builds possible -(defvar *dbg-file-metadata-cache* (make-hash-table :test #'equal)) - -(defun dbg-create-function-type (difile function-type) - (declare (ignore difile function-type)) - "Currently create a bogus function type" - (let ((arg-array (llvm-sys:get-or-create-type-array *the-module-dibuilder* - (list - (llvm-sys:create-basic-type *the-module-dibuilder* - "int" 64 - llvm-sys:+dw-ate-signed-fixed+ - (core:enum-logical-or llvm-sys:diflags-enum - '(llvm-sys:diflags-zero))))))) - (llvm-sys:create-subroutine-type *the-module-dibuilder* arg-array - (core:enum-logical-or llvm-sys:diflags-enum '(llvm-sys:diflags-zero)) - 0))) - -(defmacro with-dibuilder ((module) &rest body) - `(let ((*the-module-dibuilder* (llvm-sys:make-dibuilder ,module))) - (unwind-protect - (progn ,@body) - (llvm-sys:finalize *the-module-dibuilder*) - ;; add the flag that defines the Dwarf Version - (llvm-sys:add-module-flag *the-module* - (llvm-sys:mdnode-get (thread-local-llvm-context) - (list - (llvm-sys:value-as-metadata-get (jit-constant-i32 2)) - (llvm-sys:mdstring-get (thread-local-llvm-context) "Dwarf Version") - (llvm-sys:value-as-metadata-get (jit-constant-i32 +debug-dwarf-version+))))) - (llvm-sys:add-module-flag *the-module* - (llvm-sys:mdnode-get (thread-local-llvm-context) - (list - (llvm-sys:value-as-metadata-get (jit-constant-i32 2)) - (llvm-sys:mdstring-get (thread-local-llvm-context) "Debug Info Version") - (llvm-sys:value-as-metadata-get (jit-constant-i32 llvm-sys:+debug-metadata-version+)))))))) - -(defmacro with-dbg-compile-unit ((source-pathname) &rest body) - (let ((path (gensym)) - (file (gensym)) - (dir-name (gensym))) - `(let* ((,path (pathname ,source-pathname)) - (,file *dbg-current-file*) - (,dir-name (directory-namestring ,path)) - (*dbg-function-metadata-cache* (make-hash-table :test #'equal)) - (*dbg-compile-unit* (llvm-sys:create-compile-unit - *the-module-dibuilder* ; dibuilder - llvm-sys:dw-lang-c-plus-plus ; 1 llvm-sys:dw-lang-common-lisp - ,file ; 2 file - "clasp Common Lisp compiler" ; 4 producer - nil ; 5 isOptimized - "-v" ; 6 compiler flags - 1 ; 7 RV run-time version - "the-split-name.log" ; 8 splitname - :full-debug ; 9 DebugEmissionKind (:full-debug :line-tables-only) - 0 ; 10 DWOld - t ; 11 SplitDebugInlining - nil ; 12 DebugInfoForProfiling - :dntk-default ; 13 DebugNameTableKind - nil ; 14 RangesBaseAddress - "" ; 15 SysRoot (-isysroot value) - "" ; 16 SDK - ))) - (declare (ignorable ,dir-name)) ; cmp-log may expand empty - (cmp-log "with-dbg-compile-unit *dbg-compile-unit*: {}%N" *dbg-compile-unit*) - (cmp-log "with-dbg-compile-unit source-pathname: {}%N" ,source-pathname) - (cmp-log "with-dbg-compile-unit file-name: [{}]%N" ,file) - (cmp-log "with-dbg-compile-unit dir-name: [{}]%N" ,dir-name) - ,@body))) - -(defun do-make-create-file-args (pathname logical-pathname) - (let ((filename (file-namestring pathname)) - (directory (namestring (make-pathname :name nil :type nil :defaults pathname)))) - (list filename - (if (zerop (length directory)) - "." - (string-right-trim '(#\/) directory)) - nil - (if logical-pathname - ;; If we include the source we should put this at the end - (core:fmt nil ";; LOGICAL-PATHNAME={}%n" logical-pathname) - ;; KLUDGE: LLVM complains "inconsistent use of embedded source" - ;; if some DIFiles have a source field and some don't. - ";;")))) - -(defun make-create-file-args (pathname namestring &optional install-pathname) - (let (args) - (if (typep pathname 'logical-pathname) - (let ((translated-path (translate-logical-pathname pathname))) - (setq args (do-make-create-file-args (or install-pathname translated-path) namestring)) - (funcall #'(setf gethash) args translated-path *dbg-file-metadata-cache*)) - (setq args (do-make-create-file-args (or install-pathname pathname) nil))) - (funcall #'(setf gethash) args pathname *dbg-file-metadata-cache*))) - -(defun make-file-metadata (path) - (let ((namestring (if (typep path 'pathname) - (namestring path) - path)) - (pathname (if (typep path 'pathname) - path - (parse-namestring path)))) - (multiple-value-bind (args foundp) - (gethash path *dbg-file-metadata-cache*) - (apply #'llvm-sys:create-file *the-module-dibuilder* - (if foundp args (make-create-file-args pathname namestring)))))) - -(defmacro with-dbg-file-descriptor ((source-pathname) &rest body) - `(let ((*dbg-current-file* (make-file-metadata (pathname ,source-pathname)))) - ,@body)) - -(defmacro with-debug-info-generator ((&key module pathname) &rest body) - "One macro that uses three other macros" - (let ((body-func (gensym))) - `(flet ((,body-func () ,@body)) - (if *dbg-generate-dwarf* - (with-dibuilder (,module) - (with-dbg-file-descriptor (,pathname) - (with-dbg-compile-unit (,pathname) - (funcall #',body-func)))) - (funcall #',body-func))))) - -(defun make-function-metadata (&key file-metadata linkage-name function-type lineno) - (llvm-sys:create-function - *the-module-dibuilder* ; 0 DIBuilder - file-metadata ; 1 function scope - linkage-name ; 2 function name - linkage-name ; 3 function name - file-metadata ; 4 file where function is defined - lineno ; 5 lineno - (dbg-create-function-type file-metadata function-type) ; 6 function-type - lineno ; 7 scopeLine - set to the beginning of the scope this starts - (core:enum-logical-or llvm-sys:diflags-enum '(llvm-sys:diflags-zero)) ; 8 flags - (core:enum-logical-or llvm-sys:dispflag-enum '(llvm-sys:dispflag-definition)) ; 9 spflags - nil ; 10 TParam = nullptr - nil ; 11 Decl = nullptr - nil ; 12 ThrownTypes = nullptr - nil ; 13 Annotations = nullptr - "" ; 14 TargetFunctionName = "" - #| -(DIScope *Scope, ; 1 - StringRef Name, ; 2 - StringRef LinkageName, ;3 - DIFile *File, ;4 - unsigned LineNo, ; 5 - DISubroutineType *Ty, ; 6 - unsigned ScopeLine, ; 7 - DINode::DIFlags Flags=DINode::FlagZero, ; 8 - DISubprogram::DISPFlags SPFlags=DISubprogram::SPFlagZero, ; 9 - DITemplateParameterArray TParams=nullptr, - DISubprogram *Decl=nullptr, - DITypeArray ThrownTypes=nullptr) -|# - )) - -(defun do-dbg-function (closure lineno function-type function) - (declare (ignore function-type)) - (unless *current-source-pos-info* - (warn "*current-source-pos-info* is undefined - this may cause problems - wrap with-dbg-function in with-guaranteed-*current-source-pos-info* to fix this")) - (let ((linkage-name (llvm-sys:get-name function))) - (multiple-value-bind (file-scope file-handle) - (core:file-scope (llvm-sys:get-path *dbg-current-file*)) - (declare (ignore file-scope)) - (if (and *dbg-generate-dwarf* *the-module-dibuilder*) - (let* ((current-subprogram (cached-function-scope (list linkage-name lineno file-handle))) - (*dbg-current-function-metadata* current-subprogram) - (*dbg-current-scope* current-subprogram) - (*dbg-current-function-lineno* lineno)) - (llvm-sys:set-subprogram function current-subprogram) - (funcall closure)) - (funcall closure))))) - -(defmacro with-guaranteed-*current-source-pos-info* (() &rest body) - `(let ((core:*current-source-pos-info* (if core:*current-source-pos-info* - core:*current-source-pos-info* - (core:make-source-pos-info :filename "dummy-filename")))) - (progn - ,@body))) - -(defmacro with-dbg-function ((&key lineno function-type function) &rest body) - (cmp-log "Entered with-dbg-function%N") - `(do-dbg-function - (lambda () (progn ,@body)) - ,lineno ,function-type ,function)) - -(defvar *with-dbg-lexical-block* nil) - -(defun do-dbg-lexical-block (closure lineno) - (let ((*with-dbg-lexical-block* t)) - (if (and *dbg-generate-dwarf* *the-module-dibuilder*) - (progn - (unless *dbg-current-scope* - (error "The *dbg-current-scope* is nil - it cannot be when create-lexical-block is called")) - ;; TODO: Dwarf path discriminator - (let* ((*dbg-current-scope* (llvm-sys:create-lexical-block *the-module-dibuilder* - *dbg-current-scope* - *dbg-current-file* - lineno 0))) - (cmp-log "with-dbg-lexical-block%N") - (funcall closure))) - (funcall closure)))) - -(defmacro with-dbg-lexical-block - ((&key (lineno (core:source-pos-info-lineno core:*current-source-pos-info*))) - &body body) - `(do-dbg-lexical-block (lambda () ,@body) ,lineno)) - -(defun dbg-clear-irbuilder-source-location (irbuilder) - (llvm-sys:clear-current-debug-location irbuilder)) - -(defun cached-file-metadata (file-handle) - ;; n.b. despite the name we don't cache, as llvm seems to handle it - (make-file-metadata (file-scope-pathname (file-scope file-handle)))) - -(defun cached-function-scope (function-scope-info &optional function-type) - ;; See production in cleavir/inline-prep.lisp - #+(or cclasp eclasp) - (when core:*debug-source-pos-info* - (let ((name (car function-scope-info))) - (when (char= #\^ (elt name (1- (length name)))) - (break "The name ~s ends in ^" name)))) - (multiple-value-bind (value found) - (gethash function-scope-info *dbg-function-metadata-cache*) - (if found - (values value :found-in-cache) - (values (setf (gethash function-scope-info *dbg-function-metadata-cache*) - (destructuring-bind (function-name lineno file-handle) - function-scope-info - (make-function-metadata :linkage-name function-name - :lineno lineno - :function-type (if function-type - function-type - (fn-prototype :general-entry)) - :file-metadata (cached-file-metadata file-handle)))) - :created)))) - -(defparameter *trap-zero-lineno* nil) - -(defun get-dilocation (spi dbg-current-scope) - (let* ((file-handle (core:source-pos-info-file-handle spi)) - (lineno (core:source-pos-info-lineno spi)) - (col (core:source-pos-info-column spi)) - (fsi (core:source-pos-info-function-scope spi)) - (inlined-at (core:source-pos-info-inlined-at spi)) - (scope (if inlined-at (cached-function-scope fsi) dbg-current-scope))) - (declare (ignore file-handle)) - (when (and *trap-zero-lineno* (zerop lineno)) - (format *error-output* "In get-dilocation lineno was zero! Setting to ~d~%" - (setf lineno 666666))) - (if inlined-at - (llvm-sys:get-dilocation (thread-local-llvm-context) - lineno col scope - (get-dilocation inlined-at dbg-current-scope)) - (llvm-sys:get-dilocation (thread-local-llvm-context) - lineno col scope)))) - -(defun dbg-set-irbuilder-source-location (irbuilder spi) - (when *dbg-generate-dwarf* - (let ((diloc (get-dilocation spi *dbg-current-scope*))) - (llvm-sys:set-current-debug-location irbuilder diloc)))) - -(defun dbg-create-auto-variable (&key (scope *dbg-current-scope*) - name (file *dbg-current-file*) - lineno type always-preserve) - (llvm-sys:create-auto-variable *the-module-dibuilder* - scope name file lineno type always-preserve - (core:enum-logical-or llvm-sys:diflags-enum - '(llvm-sys:diflags-zero)) - ;; FIXME: I'm guessing - 64)) - -(defun dbg-create-parameter-variable - (&key (scope *dbg-current-scope*) name argno (file *dbg-current-file*) - lineno type always-preserve annotations) - (progn - (unless (> argno 0) - (error "The argno for ~a must start at 1 - got ~a" name argno)) - (llvm-sys:create-parameter-variable *the-module-dibuilder* - scope - name - argno - file - lineno - type - always-preserve - (core:enum-logical-or llvm-sys:diflags-enum - '(llvm-sys:diflags-zero)) - annotations))) - -(defun dbg-parameter-var (name argno &optional (type-name "T_O*") - (type llvm-sys:+dw-ate-address+)) - (dbg-create-parameter-variable :name name :argno argno - :lineno *dbg-current-function-lineno* - :type (llvm-sys:create-basic-type - *the-module-dibuilder* - type-name 64 type 0) - :always-preserve t)) - -(defun %dbg-variable-addr (addr var) - (let* ((addrmd (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - (llvm-sys:value-as-metadata-get addr))) - (varmd (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - var)) - (diexpr (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - (llvm-sys:create-expression-none *the-module-dibuilder*)))) - (irc-intrinsic "llvm.dbg.addr" addrmd varmd diexpr))) - -;;; Put in debug information for a variable corresponding to an alloca. -(defun dbg-variable-alloca (alloca name spi - &optional (type-name "T_O*") - (type llvm-sys:+dw-ate-address+)) - (when spi ; don't bother if there's no info. - (let* ((type (llvm-sys:create-basic-type - *the-module-dibuilder* type-name 64 type 0)) - (fsi (core:source-pos-info-function-scope spi)) - (scope (if fsi - (cached-function-scope fsi) - *dbg-current-scope*)) - (auto-variable (dbg-create-auto-variable - :name name - :lineno (core:source-pos-info-lineno spi) - :scope scope - :type type))) - (%dbg-variable-addr alloca auto-variable)))) - -(defun %dbg-variable-value (value var) - (let* ((valuemd (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - (llvm-sys:value-as-metadata-get value))) - (varmd (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - var)) - (diexpr (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - (llvm-sys:create-expression-none *the-module-dibuilder*)))) - (irc-intrinsic "llvm.dbg.value" valuemd varmd diexpr))) - -;;; Put in debug information for a variable corresponding to an llvm Value. -(defun dbg-variable-value (value name spi - &optional (type-name "T_O*") - (type llvm-sys:+dw-ate-address+)) - (when spi - (let* ((type (llvm-sys:create-basic-type - *the-module-dibuilder* type-name 64 type 0)) - (fsi (core:source-pos-info-function-scope spi)) - (scope (if fsi - (cached-function-scope fsi) - *dbg-current-scope*)) - (auto-variable (dbg-create-auto-variable - :name name - :lineno (core:source-pos-info-lineno spi) - :scope scope - :type type))) - (unless auto-variable - (error "maybe-spill-to-register-save-area auto-variable is NIL")) - (%dbg-variable-value value auto-variable)))) - -(defun set-instruction-source-position (origin function-metadata) - (when *dbg-generate-dwarf* - (if origin - (let ((source-pos-info (if (consp origin) - (car origin) - origin)) - (*dbg-current-scope* function-metadata)) - (dbg-set-irbuilder-source-location *irbuilder* source-pos-info)) - (dbg-clear-irbuilder-source-location *irbuilder*)))) - -(defun do-debug-info-source-position (origin body-lambda) - (unwind-protect - (progn - (set-instruction-source-position origin *dbg-current-function-metadata*) - (funcall body-lambda)) - (set-instruction-source-position nil *dbg-current-function-metadata*))) - -(defmacro with-debug-info-source-position ((origin) &body body) - `(do-debug-info-source-position ,origin (lambda () ,@body))) diff --git a/src/lisp/kernel/cmp/disassemble.lisp b/src/lisp/kernel/cmp/disassemble.lisp index af22d2aa48..cd2ad84e1b 100644 --- a/src/lisp/kernel/cmp/disassemble.lisp +++ b/src/lisp/kernel/cmp/disassemble.lisp @@ -52,11 +52,11 @@ (disassemble-assembly start end)) (format t "; could not locate code object (bug?)~%")))))))) -(defun potentially-save-module () +(defun potentially-save-module (&optional (module *the-module*)) (when *save-module-for-disassemble* (setq *saved-module-from-clasp-jit* (with-output-to-string (*standard-output*) - (llvm-sys:dump-module *the-module* *standard-output*))))) + (llvm-sys:dump-module module *standard-output*))))) ;;; should work for both lambda expressions and interpreted functions. (defun disassemble-to-ir (thing) diff --git a/src/lisp/kernel/cmp/primitives.lisp b/src/lisp/kernel/cmp/primitives.lisp index cede70d7c5..c0c1a205c4 100644 --- a/src/lisp/kernel/cmp/primitives.lisp +++ b/src/lisp/kernel/cmp/primitives.lisp @@ -116,9 +116,9 @@ (primitive "cc_list" :t* (list :size_t) :varargs t) (primitive "cc_mvcGatherRest" :t* (list :size_t :t* :size_t)) (primitive "cc_mvcGatherRest2" :t* (list :t** :size_t)) - (primitive "cc_gatherRestArguments" :t* (list :vaslist* :size_t)) - (primitive "cc_gatherDynamicExtentRestArguments" :t* (list :vaslist* :size_t :t**)) - (primitive "cc_gatherVaRestArguments" :t* (list :vaslist* :size_t :vaslist*)) + (primitive "cc_gatherRestArguments" :t* (list :t** :size_t)) + (primitive "cc_gatherDynamicExtentRestArguments" :t* (list :t** :size_t :t*)) + (primitive "cc_gatherVaRestArguments" :t* (list :t** :size_t :vaslist*)) (primitive-unwinds "cc_ifBadKeywordArgumentException" :void (list :t* :t* :t*)) (primitive-unwinds "cc_error_bugged_come_from" :void (list :size_t) :does-not-return t) @@ -131,6 +131,7 @@ (primitive "llvm.sadd.with.overflow.i64" :{i64.i1} (list :i64 :i64)) (primitive "llvm.ssub.with.overflow.i32" :{i32.i1} (list :i32 :i32)) (primitive "llvm.ssub.with.overflow.i64" :{i64.i1} (list :i64 :i64)) + (primitive "llvm.usub.sat.i64" :i64 (list :i64 :i64)) (primitive "llvm.ctpop.i64" :i64 (list :i64)) ;; NOTE: FP primitives may signal a floating point exception but this ;; is not the same as raising an exception. I think. FIXME: Check. diff --git a/src/lisp/kernel/cmp/workbench.lisp b/src/lisp/kernel/cmp/workbench.lisp index 15b4e896a6..b35840b1d7 100644 --- a/src/lisp/kernel/cmp/workbench.lisp +++ b/src/lisp/kernel/cmp/workbench.lisp @@ -1,14 +1,12 @@ (progn (setf cmp::*debug-compiler* t) (setf cmp::*use-human-readable-bitcode* t) - (trace COMPILER:SETUP-CALLING-CONVENTION - COMPILER::IRC-local-FUNCTION-CREATE + (trace COMPILER::IRC-local-FUNCTION-CREATE cmp::irc-xep-functions-create COMPILER::CODEGEN-FILL-FUNCTION-FRAME COMPILER::CODEGEN-FUNCTION COMPILER::COMPILE-TO-MODULE COMPILER::CODEGEN-CLOSURE COMPILER:COMPILE-LAMBDA-FUNCTION COMPILER::GENERATE-LLVM-FUNCTION-FROM-CODE COMPILER::TRANSFORM-LAMBDA-PARTS COMPILE-FILE cmp::do-new-function - cmp::do-dbg-function cmp::compile-file-to-module cmp::loop-read-and-compile-file-forms cmp::bclasp-loop-read-and-compile-file-forms @@ -54,30 +52,23 @@ cmp::make-xep-arity cmp::irc-calculate-real-args cmp::irc-calculate-call-info - cmp::initialize-calling-convention cmp::compile-wrong-number-arguments-block cmp::compile-error-if-too-many-arguments cmp::compile-error-if-not-enough-arguments cmp::irc-icmp-ugt cmp::bclasp-llvm-function-info-xep-function cmp::maybe-spill-to-register-save-area - cmp::make-calling-convention cmp::layout-xep-function cmp::layout-xep-function* cmp::irc-create-call-wft cmp::irc-typed-gep cmp::irc-bit-cast - cmp::dbg-parameter-var - cmp::%dbg-variable-value - cmp::%dbg-variable-addr cmp::alloca-temp-values cmp::alloca-arguments cmp::alloca-register-save-area cmp::lambda-list-arguments cmp::jit-add-module-return-function cmp::c++-field-ptr - cmp::calling-convention-vaslist.va-arg - cmp::calling-convention-vaslist* cmp::irc-typed-load cmp::irc-add cmp::irc-sub diff --git a/src/lisp/kernel/init.lisp b/src/lisp/kernel/init.lisp index 5ed8347e38..1ca449fa04 100644 --- a/src/lisp/kernel/init.lisp +++ b/src/lisp/kernel/init.lisp @@ -160,8 +160,6 @@ ;; Setup a few things for the CMP package (eval-when (:execute :compile-toplevel :load-toplevel) (core::select-package :cmp)) -(sys:*make-special '*dbg-generate-dwarf*) -(setq *dbg-generate-dwarf* (null (member :disable-dbg-generate-dwarf *features*))) (export '(link-fasoll-modules link-fasobc-modules)) ;;; Turn on aclasp/bclasp activation-frame optimization (sys:*make-special '*activation-frame-optimize*) diff --git a/src/lisp/kernel/lsp/debug.lisp b/src/lisp/kernel/lsp/debug.lisp index 612ac64f6a..71bc0a5f21 100644 --- a/src/lisp/kernel/lsp/debug.lisp +++ b/src/lisp/kernel/lsp/debug.lisp @@ -49,9 +49,7 @@ ;;; these should maybe be deprecated, since they just go through source ;;; position info accessors. -(defun code-source-line-pathname (spi) - (core:file-scope-pathname - (core:file-scope (core:source-pos-info-file-handle spi)))) +(defun code-source-line-pathname (spi) (core:source-pos-info/pathname spi)) (defun code-source-line-line-number (spi) (core:source-pos-info-lineno spi)) (defun code-source-line-column (spi) (core:source-pos-info-column spi)) diff --git a/src/lisp/kernel/lsp/fli.lisp b/src/lisp/kernel/lsp/fli.lisp index a53d488bb5..b32bb9f710 100644 --- a/src/lisp/kernel/lsp/fli.lisp +++ b/src/lisp/kernel/lsp/fli.lisp @@ -466,7 +466,7 @@ (id (cmp::next-jit-compile-counter)) (varname (format nil "callback-lisp-function-~d" id)) (callback-name (format nil "callback-~d" id))) - (cmp::with-module (:module module :optimize nil) + (cmp::with-module (:module module) (let ((var (llvm-sys:make-global-variable module cmp:%t*% nil 'llvm-sys:external-linkage (llvm-sys:undef-value-get diff --git a/src/lisp/kernel/lsp/source-location.lisp b/src/lisp/kernel/lsp/source-location.lisp index bb68bb79cc..6f07ba5102 100644 --- a/src/lisp/kernel/lsp/source-location.lisp +++ b/src/lisp/kernel/lsp/source-location.lisp @@ -60,12 +60,10 @@ ;; FIXME: Move this source debug stuff to an interface ;; (in SPI, probably) (defun source-position-info->source-location (source-position-info definer) - (let ((csi (core:file-scope - (core:source-pos-info-file-handle source-position-info)))) - (make-source-location - :pathname (core:file-scope-pathname csi) - :offset (core:source-pos-info-filepos source-position-info) - :definer definer))) + (make-source-location + :pathname (core:source-pos-info/pathname source-position-info) + :offset (core:source-pos-info-filepos source-position-info) + :definer definer)) ;;; Class source positions are just stored in a slot, or ones from C++ are ;;; stored as sysprops. We prefer the slot. diff --git a/src/llvmo/claspLinkPass.cc b/src/llvmo/claspLinkPass.cc deleted file mode 100644 index 2d140d1898..0000000000 --- a/src/llvmo/claspLinkPass.cc +++ /dev/null @@ -1,94 +0,0 @@ -/* - File: claspLinkPass.cc -*/ - -/* -Copyright (c) 2014, Christian E. Schafmeister - -CLASP is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public -License as published by the Free Software Foundation; either -version 2 of the License, or (at your option) any later version. - -See directory 'clasp/licenses' for full details. - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. -*/ -/* -^- */ -#include -#include -#include -#include - -#include -#include -#include - -using namespace llvm; - -namespace { -struct ClaspLinkPass : public ModulePass { - static char ID; - ClaspLinkPass() : ModulePass(ID) {} - - virtual bool runOnModule(Module& M) { - errs() << "ClaspLinkPass " << __FILE__ << ":" << __LINE__ << '\n'; - GlobalVariable* funcs = M.getNamedGlobal(GLOBAL_BOOT_FUNCTIONS_NAME); - if (funcs == NULL) { - errs() << "Could not find global variable " << GLOBAL_BOOT_FUNCTIONS_NAME << '\n'; - return false; - } - llvm::PointerType* t = funcs->getType(); -#if 0 - errs() << "Dumping t\n"; - t->dump(); - errs() << '\n'; - llvm::Type *et = t->getElementType(); - errs() << "Dumping et\n"; - et->dump(); - errs() << '\n'; - int num = et->getArrayNumElements(); - errs() << "Number of elements: " << num << '\n'; - funcs->dump(); -#endif - llvm::ConstantInt* ci = llvm::ConstantInt::get(M.getContext(), llvm::APInt(/*nbits*/ 32, num, true)); -#if 0 -#pragma clang diagnostic push -#pragma GCC diagnostic ignored "-Wunused-variable" - llvm::GlobalVariable *gv = new llvm::GlobalVariable(M, llvm::IntegerType::get(M.getContext(), 32), true, llvm::GlobalValue::InternalLinkage, ci, GLOBAL_BOOT_FUNCTIONS_SIZE_NAME); -#pragma clang diagnostic pop -#endif - return true; // Change this to true once we modify the module - } -}; -} // namespace - -namespace llvmo { - -#define ARGS_af_addGlobalBootFunctionsSizePass "(pass-manager)" -#define DECL_af_addGlobalBootFunctionsSizePass "" -#define DOCS_af_addGlobalBootFunctionsSizePass "addGlobalBootFunctionsSizePass" -DOCGROUP(clasp); -CL_DEFUN void llvm_sys__addGlobalBootFunctionsSizePass(llvmo::PassManager_sp passManager) { - ModulePass* claspLinkPass = new ClaspLinkPass(); - passManager->wrappedPtr()->add(claspLinkPass); -} - -void initialize_claspLinkPass() { - // core::af_def(LlvmoPkg, "addGlobalBootFunctionsSizePass", &af_addGlobalBootFunctionsSizePass); -} -}; // namespace llvmo - -#if 0 -char ClaspLinkPass::ID = 0; -static RegisterPass X(CLASP_LINK_PASS_NAME, "ClaspLinkPass", false, false); -#endif diff --git a/src/llvmo/debugInfoExpose.cc b/src/llvmo/debugInfoExpose.cc index c70a2705c9..adcc87261f 100644 --- a/src/llvmo/debugInfoExpose.cc +++ b/src/llvmo/debugInfoExpose.cc @@ -258,9 +258,11 @@ CL_VALUE_ENUM(kw::_sym_CSK_MD5, llvm::DIFile::CSK_MD5); // Use it as zero valu CL_VALUE_ENUM(kw::_sym_CSK_SHA1, llvm::DIFile::CSK_SHA1); // Use it as zero value. CL_END_ENUM(_sym_CSKEnum); +CL_LAMBDA(dibuilder addr); CL_LISPIFY_NAME(createExpression); CL_EXTERN_DEFMETHOD(DIBuilder_O, (llvm::DIExpression * (llvm::DIBuilder::*)(llvm::ArrayRef)) & llvm::DIBuilder::createExpression); + CL_LISPIFY_NAME(createExpressionNone); DOCGROUP(clasp); CL_DEFUN llvm::DIExpression* llvm_sys__createExpressionNone(DIBuilder_sp dib) { return dib->wrappedPtr()->createExpression(); } @@ -275,12 +277,15 @@ CL_VALUE_ENUM(kw::_sym_DNTK_GNU, llvm::DICompileUnit::DebugNameTableKind::GNU); CL_VALUE_ENUM(kw::_sym_DNTK_None, llvm::DICompileUnit::DebugNameTableKind::None); CL_END_ENUM(_sym_DNTKEnum); +CL_LAMBDA(dibuilder lang file producer optimizedp flags runtime-version split-name emission-kind DW-old split-debug-inlining debug-info-for-profiling name-table-kind ranges-base-address sysroot sdk); CL_LISPIFY_NAME(createCompileUnit); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createCompileUnit); +CL_LAMBDA(dibuilder filename directory checksum source); CL_LISPIFY_NAME(createFile); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createFile); +CL_LAMBDA(dibuilder scope name linkage-name file lineno ty scope-line flags subprogram-flags template-params decl thrown-types annotations target-func-name); CL_LISPIFY_NAME(createFunction); CL_EXTERN_DEFMETHOD(DIBuilder_O, (llvm::DISubprogram * (llvm::DIBuilder::*)(llvm::DIScope * Scope, llvm::StringRef Name, @@ -292,33 +297,84 @@ CL_EXTERN_DEFMETHOD(DIBuilder_O, llvm::StringRef TargetFunctionName)) & llvm::DIBuilder::createFunction); +CL_LAMBDA(dibuilder scope file lineno column); CL_LISPIFY_NAME(createLexicalBlock); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createLexicalBlock); + +CL_LAMBDA(dibuilder name size encoding flags); CL_LISPIFY_NAME(createBasicType); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createBasicType); +CL_LAMBDA(dibuilder type name file lineno context alignment flags annotations); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createTypedef); +CL_LAMBDA(dibuilder pointee-type size alignment dwarf-address-space name annotations); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createPointerType); +CL_LAMBDA(dibuilder); CL_LISPIFY_NAME(createNullPtrType); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createNullPtrType); +CL_LAMBDA(dibuilder scope name file lineno size alignment flags derived-from elements runtime-lang vtable-holder unique-id); +CL_LISPIFY_NAME(createStructType); +CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createStructType); + +CL_LAMBDA(ditype); +CL_LISPIFY_NAME(getSizeInBits); +CL_EXTERN_DEFMETHOD(DIType_O, &llvm::DIType::getSizeInBits); + +CL_LAMBDA(dibuilder); CL_LISPIFY_NAME(createUnspecifiedParameter); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createUnspecifiedParameter); +CL_LAMBDA(dibuilder parameter-types flags calling-convention); CL_LISPIFY_NAME(createSubroutineType); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createSubroutineType); +CL_LAMBDA(dibuilder scope name file lineno type always-preserve-p flags alignment); CL_LISPIFY_NAME(createAutoVariable); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createAutoVariable); +CL_LAMBDA(dibuilder scope name argno file lineno type always-preserve-p flags annotations); CL_LISPIFY_NAME(createParameterVariable); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createParameterVariable); -CL_LISPIFY_NAME(insertDbgValueIntrinsicBasicBlock); -CL_EXTERN_DEFMETHOD(DIBuilder_O, (llvm::Instruction * (llvm::DIBuilder::*)(llvm::Value * Val, llvm::DILocalVariable* VarInfo, - llvm::DIExpression* Expr, const llvm::DILocation* DL, - llvm::BasicBlock* InsertAtEnd)) & - llvm::DIBuilder::insertDbgValueIntrinsic); +// We want to use these instead of manually inserting an intrinsic +// call so that when LLVM transitions to debug info records we +// don't have to do anything. +// (Despite the name, insertDbgValueIntrinsic can insert the new +// records rather than an intrinsic.) +// We don't expose the insert-before-instruction versions as we +// do not need them. +// FIXME: Function instead of a method because we don't really +// care about the DbgInstPtr return value and exposing it would +// be rather complex. +CL_LAMBDA(dibuilder val varinfo expr dilocation basic-block); +CL_LISPIFY_NAME(dibuilder/insertDbgValueIntrinsic); +CL_DEFUN void llvm_sys__insert_dbg_value(llvm::DIBuilder& DIBuilder, + llvm::Value* V, + llvm::DILocalVariable* VarInfo, + llvm::DIExpression* Expr, + DILocation_sp DL, + llvm::BasicBlock* InsertAtEnd) +{ + // FIXME: why not just use from_object? + // This is cargo-culted from IRBuilderBase_O::SetCurrentDebugLocation + llvm::DILocation* real_diloc = DL->operator llvm::DILocation*(); + DIBuilder.insertDbgValueIntrinsic(V, VarInfo, Expr, real_diloc, InsertAtEnd); +} +CL_LAMBDA(dibuilder val varinfo expr dilocation basic-block); +CL_LISPIFY_NAME(dibuilder/insertDeclare); +CL_DEFUN void llvm_sys__insert_declare(llvm::DIBuilder& DIBuilder, + llvm::Value* Storage, + llvm::DILocalVariable* VarInfo, + llvm::DIExpression* Expr, + DILocation_sp DL, + llvm::BasicBlock* InsertAtEnd) +{ + llvm::DILocation* real_diloc = DL->operator llvm::DILocation*(); + DIBuilder.insertDeclare(Storage, VarInfo, Expr, real_diloc, InsertAtEnd); +} +CL_LAMBDA(dibuilder); CL_LISPIFY_NAME(finalize); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::finalize); ; +CL_LAMBDA(dibuilder subprogram); CL_LISPIFY_NAME(finalizeSubprogram); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::finalizeSubprogram); ; @@ -365,6 +421,10 @@ CL_DEFMETHOD DITypeRefArray_sp DIBuilder_O::getOrCreateTypeArray(core::List_sp e } else if (DINode_sp di = oCar(cur).asOrNull()) { llvm::MDNode* mdnode = di->operator llvm::MDNode*(); vector_values.push_back(mdnode); + } else if (oCar(cur).nilp()) { + // null metadata is used in a few places, such as to indicate + // a void return type in a DISubroutineType. + vector_values.push_back(nullptr); } else { SIMPLE_ERROR("Handle conversion of {} to llvm::Value*", _rep_(oCar(cur))); } @@ -520,9 +580,12 @@ CL_DEFUN DWARFContext_sp DWARFContext_O::createDWARFContext(ObjectFile_sp ofi) { } CL_DEFMETHOD size_t DWARFContext_O::getNumCompileUnits() const { return this->wrappedPtr()->getNumCompileUnits(); } + +CL_LAMBDA(dwarf-context index); CL_LISPIFY_NAME(get-unit-at-index); CL_EXTERN_DEFMETHOD(DWARFContext_O, (llvm::DWARFUnit * (llvm::DWARFContext::*)(unsigned int)) & llvm::DWARFContext::getUnitAtIndex); +CL_LAMBDA(dwarf-context unit); CL_LISPIFY_NAME(get-line-table-for-unit); CL_EXTERN_DEFMETHOD(DWARFContext_O, (const llvm::DWARFDebugLine::LineTable* (llvm::DWARFContext::*)(DWARFUnit*)) & llvm::DWARFContext::getLineTableForUnit); diff --git a/src/llvmo/intrinsics.cc b/src/llvmo/intrinsics.cc index c6c787f5ee..c7868d0d99 100644 --- a/src/llvmo/intrinsics.cc +++ b/src/llvmo/intrinsics.cc @@ -85,10 +85,10 @@ ALWAYS_INLINE core::T_O* cc_ensure_valid_object(core::T_O* tagged_object) { NO_UNWIND_END(); } -ALWAYS_INLINE core::T_O* cc_gatherVaRestArguments(Vaslist* vaslist, std::size_t nargs, Vaslist untagged_vargs_rest[2]) { +ALWAYS_INLINE core::T_O* cc_gatherVaRestArguments(core::T_O** args, std::size_t nargs, Vaslist untagged_vargs_rest[2]) { NO_UNWIND_BEGIN(); - new (&untagged_vargs_rest[0]) Vaslist(nargs, vaslist->args()); - new (&untagged_vargs_rest[1]) Vaslist(nargs, vaslist->args()); + new (&untagged_vargs_rest[0]) Vaslist(nargs, args); + new (&untagged_vargs_rest[1]) Vaslist(nargs, args); T_O* result = untagged_vargs_rest->asTaggedPtr(); #ifdef DEBUG_VASLIST if (_sym_STARdebugVaslistSTAR && _sym_STARdebugVaslistSTAR->symbolValue().notnilp()) { diff --git a/src/llvmo/link_intrinsics.cc b/src/llvmo/link_intrinsics.cc index 78d8c9680e..dee02e3e82 100644 --- a/src/llvmo/link_intrinsics.cc +++ b/src/llvmo/link_intrinsics.cc @@ -610,11 +610,11 @@ T_O* cc_list(size_t nargs, ...) { /* Conses up a &rest argument from the passed valist. * Used in cmp/arguments.lisp for the general case of functions with a &rest in their lambda list. */ -__attribute__((visibility("default"))) core::T_O* cc_gatherRestArguments(Vaslist* vaslist, std::size_t nargs) { +__attribute__((visibility("default"))) core::T_O* cc_gatherRestArguments(core::T_O** args, std::size_t nargs) { NO_UNWIND_BEGIN(); ql::list result; for (int i = 0; i < nargs; ++i) { - core::T_O* tagged_obj = ENSURE_VALID_OBJECT((*vaslist)[i]); + core::T_O* tagged_obj = ENSURE_VALID_OBJECT(args[i]); result << gc::smart_ptr((gc::Tagged)tagged_obj); } MAYBE_VERIFY_ALIGNMENT(&*(result.result())); @@ -624,18 +624,18 @@ __attribute__((visibility("default"))) core::T_O* cc_gatherRestArguments(Vaslist /* Like cc_gatherRestArguments, but uses a vector of conses provided by the caller- * intended to be stack space, for &rest parameters declared dynamic-extent. */ -__attribute__((visibility("default"))) core::T_O* cc_gatherDynamicExtentRestArguments(Vaslist* vaslist, std::size_t nargs, +__attribute__((visibility("default"))) core::T_O* cc_gatherDynamicExtentRestArguments(core::T_O** args, std::size_t nargs, core::Cons_O* cur) { NO_UNWIND_BEGIN(); core::List_sp result = Cons_sp((gctools::Tagged)gctools::tag_cons((core::Cons_O*)cur)); if (nargs) { for (int i = 0; i < nargs - 1; ++i) { - core::T_O* tagged_obj = ENSURE_VALID_OBJECT((*vaslist)[i]); + core::T_O* tagged_obj = ENSURE_VALID_OBJECT(args[i]); Cons_O* next = cur + 1; new (cur) Cons_O(T_sp((gctools::Tagged)tagged_obj), T_sp((gctools::Tagged)gctools::tag_cons((core::Cons_O*)next))); cur = next; } - core::T_O* tagged_obj = ENSURE_VALID_OBJECT((*vaslist)[nargs - 1]); + core::T_O* tagged_obj = ENSURE_VALID_OBJECT(args[nargs - 1]); new (cur) Cons_O(T_sp((gctools::Tagged)tagged_obj), nil()); return result.raw_(); } diff --git a/src/llvmo/llvmoExpose.cc b/src/llvmo/llvmoExpose.cc index 2edb3a78a3..d8ca88ab1a 100644 --- a/src/llvmo/llvmoExpose.cc +++ b/src/llvmo/llvmoExpose.cc @@ -111,6 +111,7 @@ Error enableObjCRegistration(const char* PathToLibObjC); #include #include // #include // will be llvm/IR was llvm/Assembly +#include #include #include @@ -2168,13 +2169,22 @@ UndefValue_sp UndefValue_O::create(llvm::UndefValue* ptr) { return core::RP_Crea CL_LISPIFY_NAME(UNDEF_VALUE-GET); CL_EXTERN_DEFUN((llvm::UndefValue * (*)(llvm::Type * type)) & llvm::UndefValue::get); -; - string UndefValue_O::__repr__() const { stringstream ss; ss << "#<" << this->_instanceClass()->_classNameAsString() << ">"; return ss.str(); } + +PoisonValue_sp PoisonValue_O::create(llvm::PoisonValue* ptr) { return core::RP_Create_wrapped(ptr); }; + +CL_LISPIFY_NAME(POISON_VALUE-GET); +CL_EXTERN_DEFUN((llvm::PoisonValue * (*)(llvm::Type * type)) & llvm::PoisonValue::get); + +string PoisonValue_O::__repr__() const { + stringstream ss; + ss << "#<" << this->_instanceClass()->_classNameAsString() << ">"; + return ss.str(); +} }; // namespace llvmo namespace llvmo { @@ -2817,11 +2827,11 @@ CL_EXTERN_DEFMETHOD(IRBuilderBase_O, // CL_EXTERN_DEFMETHOD(IRBuilder_O, &IRBuilder_O::ExternalType::CreateConstGEP2_32); CL_LISPIFY_NAME(CreateConstGEP1-64); CL_EXTERN_DEFMETHOD(IRBuilderBase_O, - (llvm::Value * (IRBuilderBase_O::ExternalType::*)(llvm::Value*, uint64_t, const llvm::Twine&)) & + (llvm::Value * (IRBuilderBase_O::ExternalType::*)(llvm::Type*, llvm::Value*, uint64_t, const llvm::Twine&)) & IRBuilderBase_O::ExternalType::CreateConstGEP1_64); CL_LISPIFY_NAME(CreateConstInBoundsGEP1-64); CL_EXTERN_DEFMETHOD(IRBuilderBase_O, - (llvm::Value * (IRBuilderBase_O::ExternalType::*)(llvm::Value*, uint64_t, const llvm::Twine&)) & + (llvm::Value * (IRBuilderBase_O::ExternalType::*)(llvm::Type*, llvm::Value*, uint64_t, const llvm::Twine&)) & IRBuilderBase_O::ExternalType::CreateConstInBoundsGEP1_64); // CL_LISPIFY_NAME(CreateConstGEP2-64); // CL_EXTERN_DEFMETHOD(IRBuilderBase_O, &IRBuilderBase_O::ExternalType::CreateConstGEP2_64); @@ -4197,14 +4207,15 @@ CL_DEFUN void llvm_sys__optimizeModule(llvm::Module* module, int level) { llvm::FunctionAnalysisManager FAM; llvm::CGSCCAnalysisManager CGAM; llvm::ModuleAnalysisManager MAM; - +/* llvm::PipelineTuningOptions pipeline_opts; #if LLVM_VERSION_MAJOR > 15 pipeline_opts.InlinerThreshold = 0; #endif llvm::PassBuilder PB(NULL, pipeline_opts); - llvm::ModulePassManager MPM; +*/ + llvm::PassBuilder PB; PB.registerModuleAnalyses(MAM); PB.registerCGSCCAnalyses(CGAM); @@ -4228,7 +4239,13 @@ CL_DEFUN void llvm_sys__optimizeModule(llvm::Module* module, int level) { } #endif - PB.buildPerModuleDefaultPipeline(opt_level); + // In LLVM16, buildPerModuleDefaultPipeline does not work with O0. + // This was changed in 17 and up. +#if LLVM_VERSION_MAJOR < 17 + llvm::ModulePassManager MPM = opt_level == OptimizationLevel::O0 ? PB.buildO0DefaultPipeline(opt_level) : PB.buildPerModuleDefaultPipeline(opt_level); +#else + llvm::ModulePassManager MPM = PB.buildPerModuleDefaultPipeline(opt_level); +#endif MPM.run(*module, MAM); } diff --git a/src/llvmo/llvmoPackage.cc b/src/llvmo/llvmoPackage.cc index b9ae5ae731..f2e1316323 100644 --- a/src/llvmo/llvmoPackage.cc +++ b/src/llvmo/llvmoPackage.cc @@ -54,7 +54,6 @@ THE SOFTWARE. #include #include #include -#include #include #include #include diff --git a/src/scraper/code-generator.lisp b/src/scraper/code-generator.lisp index 4c2a8ecdf0..ef6cedd300 100644 --- a/src/scraper/code-generator.lisp +++ b/src/scraper/code-generator.lisp @@ -264,18 +264,26 @@ ) (format sout "#endif // EXPOSE_FUNCTION_BATCH~a~%" batch-num)))))) -(defun mangle-and-wrap-name (name arg-types) +(defun sanitize (stream argument colonp atsignp &rest params) + (declare (ignore argument colonp atsignp)) + (loop with underscore = nil + for c across (write-to-string argument) + when (alphanumericp c) + do (setf underscore nil) + (princ c stream) + else unless underscore + do (princ #\_ stream) + (setf underscore t))) + +(defun mangle-and-wrap-name (name return-type arg-types) "* Arguments - name :: A string * Description Convert colons to underscores" - (let ((type-part (with-output-to-string (sout) - (loop for type in arg-types - do (loop for c across type - do (if (alphanumericp c) - (princ c sout) - (princ #\_ sout))))))) - (format nil "wrapped_~a_~a" (substitute #\_ #\: name) type-part))) + (format nil "wrapped_~/cscrape:sanitize/_~/cscrape:sanitize/_~{~/cscrape:sanitize/~^_~}" + name + return-type + arg-types)) (defgeneric direct-call-function (c-code cl-code func c-code-info cl-code-info)) @@ -288,7 +296,7 @@ Convert colons to underscores" (if (function-ptr-type function-ptr) (multiple-value-bind (return-type arg-types) (convert-function-ptr-to-c++-types function-ptr) - (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) arg-types)) + (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) return-type arg-types)) (one-func-code (generate-wrapped-function wrapped-name (function-ptr-namespace function-ptr) @@ -314,7 +322,7 @@ Convert colons to underscores" (defmethod direct-call-function (c-code cl-code (func expose-defun) c-code-info cl-code-info) (multiple-value-bind (return-type arg-types) (parse-types-from-signature (signature% func)) - (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) arg-types)) + (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) return-type arg-types)) (one-func-code (generate-wrapped-function wrapped-name (namespace% func) @@ -336,7 +344,7 @@ Convert colons to underscores" (defmethod direct-call-function (c-code cl-code (func expose-defun-setf) c-code-info cl-code-info) (multiple-value-bind (return-type arg-types) (parse-types-from-signature (signature% func)) - (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) arg-types)) + (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) return-type arg-types)) (one-func-code (generate-wrapped-function wrapped-name (namespace% func)