diff --git a/include/clasp/core/bytecode_compiler.h b/include/clasp/core/bytecode_compiler.h index f9e6840066..e4daf72b21 100644 --- a/include/clasp/core/bytecode_compiler.h +++ b/include/clasp/core/bytecode_compiler.h @@ -352,17 +352,19 @@ class Lexenv_O : public General_O { T_sp _funs; List_sp _decls; size_t frame_end; + T_sp _global; public: - Lexenv_O(T_sp nvars, T_sp ntags, T_sp nblocks, T_sp nfuns, List_sp ndecls, size_t nframe_end) - : _vars(nvars), _tags(ntags), _blocks(nblocks), _funs(nfuns), _decls(ndecls), frame_end(nframe_end){}; + Lexenv_O(T_sp nvars, T_sp ntags, T_sp nblocks, T_sp nfuns, List_sp ndecls, size_t nframe_end, T_sp global = nil()) + : _vars(nvars), _tags(ntags), _blocks(nblocks), _funs(nfuns), _decls(ndecls), frame_end(nframe_end), _global(global) {}; CL_LISPIFY_NAME(lexenv/make) + CL_LAMBDA(vars tags blocks funs decls frame_end &optional global) CL_DEF_CLASS_METHOD - static Lexenv_sp make(T_sp vars, T_sp tags, T_sp blocks, T_sp funs, List_sp decls, size_t frame_end) { - return gctools::GC::allocate(vars, tags, blocks, funs, decls, frame_end); + static Lexenv_sp make(T_sp vars, T_sp tags, T_sp blocks, T_sp funs, List_sp decls, size_t frame_end, T_sp global) { + return gctools::GC::allocate(vars, tags, blocks, funs, decls, frame_end, global); } - static Lexenv_sp make_top_level() { - return make(nil(), nil(), nil(), nil(), nil(), 0); + static Lexenv_sp make_top_level(T_sp global = nil()) { + return make(nil(), nil(), nil(), nil(), nil(), 0, global); } CL_DEFMETHOD List_sp vars() const { return this->_vars; } CL_DEFMETHOD List_sp tags() const { return this->_tags; } @@ -370,18 +372,27 @@ class Lexenv_O : public General_O { CL_DEFMETHOD List_sp funs() const { return this->_funs; } CL_DEFMETHOD List_sp decls() const { return this->_decls; } CL_DEFMETHOD size_t frameEnd() const { return this->frame_end; } + CL_DEFMETHOD T_sp global() const { return this->_global; } public: inline Lexenv_sp sub_vars(List_sp vars, size_t frame_end) const { - return make(vars, tags(), blocks(), funs(), decls(), frame_end); + return make(vars, tags(), blocks(), funs(), decls(), frame_end, global()); + } + inline Lexenv_sp sub_funs(List_sp funs) const { + return make(vars(), tags(), blocks(), funs, decls(), frameEnd(), global()); } - inline Lexenv_sp sub_funs(List_sp funs) const { return make(vars(), tags(), blocks(), funs, decls(), frameEnd()); } inline Lexenv_sp sub_funs(List_sp funs, size_t frame_end) const { - return make(vars(), tags(), blocks(), funs, decls(), frame_end); + return make(vars(), tags(), blocks(), funs, decls(), frame_end, global()); + } + inline Lexenv_sp sub_tags(List_sp tags) const { + return make(vars(), tags, blocks(), funs(), decls(), frameEnd() + 1, global()); + } + inline Lexenv_sp sub_block(List_sp blocks) const { + return make(vars(), tags(), blocks, funs(), decls(), frameEnd() + 1, global()); + } + inline Lexenv_sp sub_decls(List_sp decls) const { + return make(vars(), tags(), blocks(), funs(), decls, frameEnd(), global()); } - inline Lexenv_sp sub_tags(List_sp tags) const { return make(vars(), tags, blocks(), funs(), decls(), frameEnd() + 1); } - inline Lexenv_sp sub_block(List_sp blocks) const { return make(vars(), tags(), blocks, funs(), decls(), frameEnd() + 1); } - inline Lexenv_sp sub_decls(List_sp decls) const { return make(vars(), tags(), blocks(), funs(), decls, frameEnd()); } public: /* Bind each variable to a stack location, returning a new lexical @@ -809,9 +820,9 @@ class LoadTimeValueInfo_O : public General_O { CL_DEFMETHOD T_sp form() { return this->_form; } CL_LISPIFY_NAME(LoadTimeValueInfo/ReadOnlyP) CL_DEFMETHOD bool read_only_p() { return this->_read_only_p; } - // Evaluate the load time value form. + // Evaluate the load time value form in the given global environment. CL_LISPIFY_NAME(LoadTimeValueInfo/eval) - CL_DEFMETHOD T_sp eval(); + CL_DEFMETHOD T_sp eval(T_sp env); }; // Wrapper for compiler constant literals. Having this is necessary to @@ -940,7 +951,7 @@ class Module_O : public General_O { CL_DEFMETHOD SimpleVector_sp create_debug_info(); // Link, then create actual run-time function objects and a bytecode module. // Suitable for cl:compile. - CL_DEFMETHOD void link_load(); + CL_DEFMETHOD void link_load(T_sp env); }; class Cfunction_O : public General_O { @@ -1043,7 +1054,7 @@ class Cfunction_O : public General_O { public: // Convenience method to link the module and return the new bytecode function // corresponding to this cfunction. Good for cl:compile. - CL_DEFMETHOD Function_sp link_function(); + CL_DEFMETHOD Function_sp link_function(T_sp env); public: // For use as a BytecodeDebugInfo. T_sp start() const; @@ -1051,7 +1062,7 @@ class Cfunction_O : public General_O { }; // Main entry point -Function_sp bytecompile(T_sp, Lexenv_sp); +Function_sp bytecompile(T_sp, T_sp); // main entry point for using the evaluator T_mv cmp__bytecode_implicit_compile_form(T_sp, T_sp); T_mv bytecode_toplevel_eval(T_sp, T_sp); diff --git a/include/clasp/core/cleavirEnvPackage.fwd.h b/include/clasp/core/cleavirEnvPackage.fwd.h deleted file mode 100644 index ed898e0942..0000000000 --- a/include/clasp/core/cleavirEnvPackage.fwd.h +++ /dev/null @@ -1,32 +0,0 @@ -#pragma once -/* - File: cleavirEnvPackage.fwd.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_PACKAGE_ASSOCIATION(cleavirEnv, CleavirEnvPkg, "CLEAVIR-ENVIRONMENT") - -SYMBOL_EXPORT_SC_(CleavirEnvPkg, macroFunction); -SYMBOL_EXPORT_SC_(CleavirEnvPkg, symbolMacroExpansion); diff --git a/include/clasp/core/compiler.h b/include/clasp/core/compiler.h index 1e31d5982b..4ea365a32f 100644 --- a/include/clasp/core/compiler.h +++ b/include/clasp/core/compiler.h @@ -64,7 +64,7 @@ struct Initializer { }; size_t startup_functions_are_waiting(); -core::T_O* startup_functions_invoke(T_O* literals_or_null); +void startup_functions_invoke(T_O* literals_or_null); std::tuple do_dlopen(const string& str_path, const int n_mode); std::tuple do_dlclose(void* p_handle); @@ -95,7 +95,6 @@ void expect_offset(T_sp key, T_sp alist, size_t expected); }; namespace core { -void start_code_interpreter(gctools::GCRootsInModule* roots, char* bytecode, size_t nbytes, bool log); void core__throw_function(T_sp tag, T_sp result_form); void register_startup_function(const StartUp& startup); void transfer_StartupInfo_to_my_thread(); diff --git a/include/clasp/core/configure_clasp.h b/include/clasp/core/configure_clasp.h index 630801552b..c147b1fd13 100644 --- a/include/clasp/core/configure_clasp.h +++ b/include/clasp/core/configure_clasp.h @@ -93,8 +93,6 @@ THE SOFTWARE. #define __EX(var) #var #define CXX_MACRO_STRING(var) __EX(var) -#define CLASP_GCROOTS_IN_MODULE(NAME) __clasp_gcroots_in_module_##NAME -#define GCROOTS_IN_MODULE_NAME CXX_MACRO_STRING(CLASP_GCROOTS_IN_MODULE()) #define CLASP_LITERALS(NAME) __clasp_literals_##NAME #define LITERALS_NAME CXX_MACRO_STRING(CLASP_LITERALS()) #define INTPTR_BITS 64 diff --git a/include/clasp/core/core.h b/include/clasp/core/core.h index 55d962243c..c4eeb8de2d 100644 --- a/include/clasp/core/core.h +++ b/include/clasp/core/core.h @@ -96,9 +96,6 @@ typedef double long_float_t; #define NOINLINE __attribute__((noinline)) #define MAYBE_INLINE __attribute__((noinline)) -#define RUN_ALL_FUNCTION_NAME "RUN-ALL" -#define CLASP_CTOR_FUNCTION_NAME "CLASP-CTOR" - #ifdef CLASP_THREADS #include #endif diff --git a/include/clasp/core/function.h b/include/clasp/core/function.h index e41639789b..027dcf4e0e 100644 --- a/include/clasp/core/function.h +++ b/include/clasp/core/function.h @@ -52,14 +52,8 @@ namespace core { extern char* global_dump_functions; /* The following MUST MATCH %function-description% in cmpintrinsics.lisp -Each thread maintains a current GCRootsInModule structure that stores roots -used by the FunctionDescription objects. Every time a Function_O object is created -a FunctionDescription is allocated using 'new' and if the GCRootsInModule can still fit -all of the slots (two currently) indicated by the fields that end in 'Index' then that -GCRootsInModule* is written into the FunctionDescription and the indices into the -GCRootsInModule are written into the FunctionDescription. Then the function description -objects that need to be managed by the GC are written into the GCRootsInModule object. -A pointer to the new FunctionDescription object is then written into the instance +Every time a Function_O object is created +a FunctionDescription is allocated using 'new'. A pointer to the new FunctionDescription object is then written into the instance of the Function_O subclass. A virtual function in the Function_O is used to recover the pointer to the FunctionDescription object for the Function_O. I used a virtual function because different subclasses store the FunctionDescription* @@ -312,6 +306,7 @@ class CoreFunGenerator_O : public General_O { CL_DEFMETHOD FunctionDescription_sp functionDescription() const { return this->_FunctionDescription; } + CoreFun_sp generate(void**) const; }; // A SimpleCoreFun is a SimpleFun with an associated CoreFun. @@ -397,15 +392,17 @@ class SimpleCoreFunGenerator_O : public General_O { public: FunctionDescription_sp _FunctionDescription; T_sp _entry_point_indices; - size_t _localFunIndex; + CoreFunGenerator_sp _CoreFunGenerator; public: // Accessors - SimpleCoreFunGenerator_O(FunctionDescription_sp fdesc, T_sp entry_point_indices, size_t lepIndex) - : _FunctionDescription(fdesc), _entry_point_indices(entry_point_indices), _localFunIndex(lepIndex){}; + SimpleCoreFunGenerator_O(FunctionDescription_sp fdesc, T_sp entry_point_indices, CoreFunGenerator_sp cfg) + : _FunctionDescription(fdesc), _entry_point_indices(entry_point_indices), _CoreFunGenerator(cfg){}; std::string __repr__() const; - size_t coreFunIndex() const; + CL_LISPIFY_NAME(SimpleCoreFunGenerator/CoreFunGenerator); + CL_DEFMETHOD CoreFunGenerator_sp coreFunGenerator() const { return this->_CoreFunGenerator; } CL_DEFMETHOD FunctionDescription_sp functionDescription() const { return this->_FunctionDescription; }; + SimpleCoreFun_sp generate(CoreFun_sp, void**) const; }; FunctionDescription_sp makeFunctionDescription(T_sp functionName, T_sp lambda_list = unbound(), T_sp docstring = nil(), @@ -442,9 +439,6 @@ BytecodeSimpleFun_sp core__makeBytecodeSimpleFun(FunctionDescription_sp fdesc, B size_t localsFrameSize, size_t environmentSize, size_t pcIndex, size_t bytecodeSize, Pointer_sp trampoline); -SimpleCoreFun_sp makeSimpleCoreFunFromGenerator(SimpleCoreFunGenerator_sp ep, gctools::GCRootsInModule* roots, void** fptrs); -CoreFun_sp makeCoreFunFromGenerator(CoreFunGenerator_sp ep, void** fptrs); - }; // namespace core namespace core { @@ -504,15 +498,18 @@ class FunctionCell_O : public Function_O { static FunctionCell_sp make(T_sp name, Function_sp initial); static FunctionCell_sp make(T_sp name); // unbound public: - Function_sp real_function() const { + CL_LISPIFY_NAME(FunctionCell/function) + CL_DEFMETHOD Function_sp real_function() const { // relaxed because nobody should be synchronizing on this, // but in practice it's probably irrelevant what we do? return this->_Function.load(std::memory_order_relaxed); } void real_function_set(Function_sp fun) { this->_Function.store(fun, std::memory_order_relaxed); } static SimpleFun_sp cachedUnboundSimpleFun(T_sp name); - void fmakunbound(T_sp name); - bool fboundp() const; + CL_LISPIFY_NAME(FunctionCell/makunbound) + CL_DEFMETHOD void fmakunbound(T_sp name); + CL_LISPIFY_NAME(FunctionCell/boundp) + CL_DEFMETHOD bool fboundp() const; // like real_function() but signals an error if we are un-fbound. Function_sp fdefinition() const; diff --git a/include/clasp/core/lisp.h b/include/clasp/core/lisp.h index 31bb1270e7..067f8291d1 100644 --- a/include/clasp/core/lisp.h +++ b/include/clasp/core/lisp.h @@ -725,11 +725,13 @@ class Lisp { private: T_sp findPackage_no_lock(String_sp packageName) const; T_sp findPackage_no_lock(const string& packageName) const; + T_sp findPackageGlobal_no_lock(String_sp packageName) const; public: bool recognizesPackage(const string& packageName) const; T_sp findPackage(const string& packageName, bool errorp = false) const; T_sp findPackage(String_sp packageName, bool errorp = false) const; + T_sp findPackageGlobal(String_sp packageName, bool errorp = false) const; void inPackage(const string& packageName); void selectPackage(Package_sp pack); Package_sp getCurrentPackage() const; diff --git a/include/clasp/core/symbol.h b/include/clasp/core/symbol.h index a4f608b98e..9da1718217 100644 --- a/include/clasp/core/symbol.h +++ b/include/clasp/core/symbol.h @@ -91,6 +91,8 @@ class VariableCell_O : public General_O { mutable std::atomic _BindingIdx; T_sp _Name; // used for error messages and printing only public: + CL_LISPIFY_NAME(VariableCell/make) + CL_DEF_CLASS_METHOD static VariableCell_sp make(T_sp name); private: @@ -115,6 +117,8 @@ class VariableCell_O : public General_O { uint32_t ensureBindingIndex() const; // Return the value, or UNBOUND if unbound. + CL_LISPIFY_NAME(VariableCell/ValueUnsafe) + CL_DEFMETHOD T_sp valueUnsafe() const { #ifdef CLASP_THREADS uint32_t index = this->_BindingIdx.load(std::memory_order_relaxed); @@ -135,10 +139,14 @@ class VariableCell_O : public General_O { #endif return globalValueUnsafeSeqCst(); } - inline bool boundP() const { return !(valueUnsafe().unboundp()); } + CL_LISPIFY_NAME(VariableCell/boundp) + CL_DEFMETHOD + bool boundP() const { return !(valueUnsafe().unboundp()); } // Return the value or signal an error if unbound. - inline T_sp value() const { + CL_LISPIFY_NAME(VariableCell/value) + CL_DEFMETHOD + T_sp value() const { T_sp val = valueUnsafe(); if (val.unboundp()) unboundError(); @@ -162,7 +170,9 @@ class VariableCell_O : public General_O { else return val; } - inline void makunbound() { set_value(unbound()); } + CL_LISPIFY_NAME(VariableCell/makunbound) + CL_DEFMETHOD + void makunbound() { set_value(unbound()); } inline T_sp valueSeqCst() const { T_sp val = valueUnsafeSeqCst(); if (val.unboundp()) diff --git a/include/clasp/core/unwind.h b/include/clasp/core/unwind.h index 6e84edf666..6725498cab 100644 --- a/include/clasp/core/unwind.h +++ b/include/clasp/core/unwind.h @@ -5,6 +5,7 @@ #include #include #include // DynamicScopeManager +#include // eval::funcall namespace core { @@ -337,7 +338,7 @@ template T_mv call_with_catch(T_sp tag, Catchf&& cf) { } } -template __attribute__((optnone)) T_mv fprogv(List_sp symbols, List_sp values, Boundf&& bound) { +template T_mv fprogv(List_sp symbols, List_sp values, Boundf&& bound) { if (symbols.consp()) { Symbol_sp sym = CONS_CAR(symbols).as(); List_sp nsymbols = CONS_CDR(symbols); @@ -353,4 +354,35 @@ template __attribute__((optnone)) T_mv fprogv(List_sp symbols, } } +template T_mv fprogv_env_aux(T_sp env, + List_sp symbols, List_sp values, + Boundf&& bound) { + // general case, look up cells + if (symbols.consp()) { + Symbol_sp sym = CONS_CAR(symbols).as(); + T_sp rcell = eval::funcall(_sym_fcge_ensure_vcell, env, sym); + VariableCell_sp cell = rcell.as(); + List_sp nsymbols = CONS_CDR(symbols); + if (values.consp()) { + return call_with_cell_bound(cell, CONS_CAR(values), + [&]() { return fprogv_env_aux(env, nsymbols, CONS_CDR(values), bound); }); + } else { // out of values - make unbound + return call_with_cell_bound(cell, unbound(), + [&]() { return fprogv_env_aux(env, nsymbols, nil(), bound); }); + } + } else { // no symbols + return bound(); + } +} + +template T_mv fprogv_env(T_sp env, List_sp symbols, List_sp values, + Boundf&& bound) { + // special case: if env is nil (the usual main environment), use fprogv. + // This avoids calling fcge-ensure-vcell, so it's ok to do primitively. + if (env.nilp()) return fprogv(symbols, values, bound); + // more generally: look up cells in the environment + // (but don't bother to repeat this nilp check) + else return fprogv_env_aux(env, symbols, values, bound); +} + }; // namespace core diff --git a/include/clasp/gctools/memoryManagement.h b/include/clasp/gctools/memoryManagement.h index 07c26bd7ec..b32f46683f 100644 --- a/include/clasp/gctools/memoryManagement.h +++ b/include/clasp/gctools/memoryManagement.h @@ -1141,42 +1141,6 @@ void untag_literal_index(size_t findex, size_t& index, size_t& tag); namespace gctools { -/*! Maintains pointers to arrays of roots that are stored in LLVM Modules - we add and remove during runtime as Modules are compiled and (in the future) removed. - */ - -struct GCRootsInModule { - static int const TransientRawIndex = 0; - static size_t const DefaultCapacity = 256; - // Fields - core::SimpleVector_O** _TransientAlloca; - void* _module_memory; - size_t _num_entries; - size_t _capacity; - /*fnLispCallingConvention* */ void** _function_pointers; - size_t _function_pointer_count; - GCRootsInModule(void* module_mem, size_t num_entries, core::SimpleVector_O** transient_alloca, size_t transient_entries, - size_t function_pointer_count, void** fptrs); - void setup_transients(core::SimpleVector_O** transient_alloca, size_t transient_entries); - - size_t remainingCapacity() { return this->_capacity - this->_num_entries; }; - size_t push_back(Tagged val); - Tagged setLiteral(size_t index, Tagged val); - Tagged getLiteral(size_t index); - Tagged setTransient(size_t index, Tagged val); - Tagged getTransient(size_t index); - Tagged setTaggedIndex(char tag, size_t index, Tagged val); - Tagged getTaggedIndex(char tag, size_t index); - /*fnLispCallingConvention*/ void* lookup_function(size_t index); - void* address(size_t index) { return reinterpret_cast(&reinterpret_cast(this->_module_memory)[index + 1]); } -}; - -void initialize_gcroots_in_module(GCRootsInModule* gcroots_in_module, core::T_O** root_address, size_t num_roots, - gctools::Tagged initial_data, core::SimpleVector_O** transientAlloca, size_t transient_entries, - size_t function_pointer_number, void** fptrs); -core::T_O* read_gcroots_in_module(GCRootsInModule* roots, size_t index); -void shutdown_gcroots_in_module(GCRootsInModule* gcroots_in_module); - inline core::T_O* ensure_valid_object(core::T_O* tagged_object) { // Only validate general objects for now if (tagged_generalp(tagged_object)) { diff --git a/include/clasp/gctools/threadlocal.h b/include/clasp/gctools/threadlocal.h index 80983bfa98..337119befd 100644 --- a/include/clasp/gctools/threadlocal.h +++ b/include/clasp/gctools/threadlocal.h @@ -5,7 +5,7 @@ #include // copy #include -typedef core::T_O* (*T_OStartUp)(core::T_O*); +typedef void (*T_OStartUp)(core::T_O*); typedef void (*voidStartUp)(void); namespace core { @@ -269,7 +269,6 @@ struct ThreadLocalState { std::string _initializer_symbol; void* _object_file_start; size_t _object_file_size; - gctools::GCRootsInModule* _GCRootsInModule; StartupInfo _Startup; bool _Breakstep; // Should we check for breaks? // What frame are we stepping over? NULL means step-into mode. @@ -305,7 +304,7 @@ struct ThreadLocalState { ThreadLocalState(bool dummy); void finish_initialization_main_thread(core::T_sp theNilObject); ThreadLocalState(); - void initialize_thread(mp::Process_sp process, bool initialize_GCRoots); + void initialize_thread(mp::Process_sp process); pid_t safe_fork(); diff --git a/include/clasp/llvmo/code.h b/include/clasp/llvmo/code.h index 7d71552fc9..9b133dbae9 100644 --- a/include/clasp/llvmo/code.h +++ b/include/clasp/llvmo/code.h @@ -148,7 +148,6 @@ class ObjectFile_O : public LibraryBase_O { void* literalsStart() const; core::T_O** TOLiteralsStart() const { return (core::T_O**)literalsStart(); } size_t TOLiteralsSize() const { return literalsSize() / sizeof(core::T_O*); } - virtual std::string filename() const; core::T_sp codeLineTable() const; virtual void validateEntryPoint(const core::ClaspXepFunction& entry_point); diff --git a/include/clasp/llvmo/intrinsics.h b/include/clasp/llvmo/intrinsics.h index 5f07b071b6..77676f785b 100644 --- a/include/clasp/llvmo/intrinsics.h +++ b/include/clasp/llvmo/intrinsics.h @@ -51,66 +51,6 @@ THE SOFTWARE. extern "C" { -typedef void LtvcReturn; - -LtvcReturn ltvc_make_closurette(gctools::GCRootsInModule* holder, char tag, size_t index, - /*size_t function_index,*/ size_t entry_point_index); -LtvcReturn ltvc_make_closurette_no_function_info(gctools::GCRootsInModule* holder, char tag, size_t index, size_t function_index); -LtvcReturn ltvc_make_nil(gctools::GCRootsInModule* holder, char tag, size_t index); -LtvcReturn ltvc_make_t(gctools::GCRootsInModule* holder, char tag, size_t index); -LtvcReturn ltvc_make_ratio(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* num, core::T_O* denom); -LtvcReturn ltvc_make_complex(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* real, core::T_O* imag); -LtvcReturn ltvc_make_cons(gctools::GCRootsInModule* holder, char tag, size_t index); -LtvcReturn ltvc_rplaca(gctools::GCRootsInModule* holder, core::T_O* cons_t, core::T_O* car_t); -LtvcReturn ltvc_rplacd(gctools::GCRootsInModule* holder, core::T_O* cons_t, core::T_O* cdr_t); -LtvcReturn ltvc_make_list(gctools::GCRootsInModule* holder, char tag, size_t index, size_t len); -LtvcReturn ltvc_fill_list(gctools::GCRootsInModule* holder, core::T_O* list, size_t len, ...); -LtvcReturn ltvc_make_array(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* telement_type, - core::T_O* tdimensions); -LtvcReturn ltvc_make_hash_table(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* test_t); -void ltvc_setf_row_major_aref(gctools::GCRootsInModule* holder, core::T_O* array_t, size_t row_major_index, core::T_O* value_t); -void ltvc_setf_gethash(gctools::GCRootsInModule* holder, core::T_O* hash_table_t, core::T_O* key_index_t, core::T_O* value_index_t); -LtvcReturn ltvc_make_fixnum(gctools::GCRootsInModule* holder, char tag, size_t index, int64_t val); -LtvcReturn ltvc_make_bignum(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* bignum_string_t); -LtvcReturn ltvc_make_next_bignum(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* bignum); -LtvcReturn ltvc_make_bitvector(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* bitvector_string_t); -LtvcReturn ltvc_make_symbol(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* name_t, core::T_O* package_t); -LtvcReturn ltvc_make_character(gctools::GCRootsInModule* holder, char tag, size_t index, uintptr_t val); -LtvcReturn ltvc_make_base_string(gctools::GCRootsInModule* holder, char tag, size_t index, const char* str); -LtvcReturn ltvc_make_pathname(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* host_t, core::T_O* device_t, - core::T_O* directory_t, core::T_O* name_t, core::T_O* type_t, core::T_O* version_t); - -LtvcReturn ltvc_make_function_description(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* sourcePathname_t, - core::T_O* functionName_t, core::T_O* lambdaList_t, core::T_O* docstring_t, - core::T_O* declares_t, size_t lineno, size_t column, size_t filepos); - -LtvcReturn ltvc_make_local_entry_point(gctools::GCRootsInModule* holder, char tag, size_t index, size_t functionIndex, - core::T_O* functionDescription_t); - -LtvcReturn ltvc_make_global_entry_point(gctools::GCRootsInModule* holder, char tag, size_t index, size_t functionIndex, - core::T_O* functionDescription_t, size_t localEntryPointIndex); - -LtvcReturn ltvc_ensure_fcell(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* fname); -LtvcReturn ltvc_ensure_vcell(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* vname); - -LtvcReturn ltvc_make_package(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* package_name_t); -LtvcReturn ltvc_make_random_state(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* random_state_string_t); -LtvcReturn ltvc_find_class(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* class_name_t); -LtvcReturn ltvc_make_binary16(gctools::GCRootsInModule* holder, char tag, size_t index, core::short_float_t f); -LtvcReturn ltvc_make_binary32(gctools::GCRootsInModule* holder, char tag, size_t index, core::single_float_t f); -LtvcReturn ltvc_make_binary64(gctools::GCRootsInModule* holder, char tag, size_t index, core::double_float_t f); -LtvcReturn ltvc_make_binary80(gctools::GCRootsInModule* holder, char tag, size_t index, core::long_float_t f); -LtvcReturn ltvc_make_binary128(gctools::GCRootsInModule* holder, char tag, size_t index, core::long_float_t f); -LtvcReturn ltvc_enclose(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* lambdaName, size_t function_index, - size_t function_info_index); -LtvcReturn ltvc_allocate_instance(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* klass); -LtvcReturn ltvc_set_mlf_creator_funcall(gctools::GCRootsInModule* holder, char tag, size_t index, size_t fptr_index, - const char* name); -LtvcReturn ltvc_mlf_init_funcall(gctools::GCRootsInModule* holder, size_t fptr_index, const char* name); -LtvcReturn ltvc_set_ltv_funcall(gctools::GCRootsInModule* holder, char tag, size_t index, size_t fptr_index, const char* name); -LtvcReturn ltvc_toplevel_funcall(gctools::GCRootsInModule* holder, size_t fptr_index, const char* name); - -void cc_invoke_startup_functions(); void cc_validate_tagged_pointer(core::T_O* ptr); // ---------------------------------------------------------------------------- diff --git a/include/clasp/llvmo/jit.h b/include/clasp/llvmo/jit.h index add28cb7d5..f25c2ef40a 100644 --- a/include/clasp/llvmo/jit.h +++ b/include/clasp/llvmo/jit.h @@ -131,10 +131,7 @@ class ClaspJIT_O : public core::General_O { ObjectFile_sp addIRModule(JITDylib_sp dylib, Module_sp cM, ThreadSafeContext_sp context, size_t startupID); ObjectFile_sp addObjectFile(JITDylib_sp dylib, std::unique_ptr objectFile, bool print, size_t startupId); - /*! Return a pointer to a function WHAT FUNCTION??????? - llvm_sys__jitFinalizeReplFunction needs to build a closure over it - */ - void* runStartupCode(JITDylib_sp dylib, const std::string& startupName, core::T_sp initialDataOrUnbound); + void runStartupCode(JITDylib_sp dylib, const std::string& startupName, core::T_sp initialDataOrUnbound); void installMainJITDylib(); void adjustMainJITDylib(JITDylib_sp dylib); ClaspJIT_O(); @@ -152,7 +149,6 @@ class ClaspJIT_O : public core::General_O { #define EH_FRAME_NAME "__TEXT,__eh_frame" #define BSS_NAME "__DATA,__bss" #define STACKMAPS_NAME "__LLVM_STACKMAPS,__llvm_stackmaps" -#define OS_GCROOTS_IN_MODULE_NAME ("_" GCROOTS_IN_MODULE_NAME) #define OS_LITERALS_NAME ("_" LITERALS_NAME) #elif defined(_TARGET_OS_LINUX) #define TEXT_NAME ".text" @@ -160,7 +156,6 @@ class ClaspJIT_O : public core::General_O { #define DATA_NAME ".data" #define BSS_NAME ".bss" #define STACKMAPS_NAME ".llvm_stackmaps" -#define OS_GCROOTS_IN_MODULE_NAME (GCROOTS_IN_MODULE_NAME) #define OS_LITERALS_NAME (LITERALS_NAME) #elif defined(_TARGET_OS_FREEBSD) #define TEXT_NAME ".text" @@ -168,14 +163,12 @@ class ClaspJIT_O : public core::General_O { #define DATA_NAME ".data" #define BSS_NAME ".bss" #define STACKMAPS_NAME ".llvm_stackmaps" -#define OS_GCROOTS_IN_MODULE_NAME (GCROOTS_IN_MODULE_NAME) #define OS_LITERALS_NAME (LITERALS_NAME) #else #error "What is the name of stackmaps section on this OS??? __llvm_stackmaps or .llvm_stackmaps" #endif namespace llvmo { -extern std::string gcroots_in_module_name; extern std::string literals_name; extern std::atomic global_JITDylibCounter; diff --git a/include/clasp/llvmo/llvmoExpose.h b/include/clasp/llvmo/llvmoExpose.h index f0b32c67c7..10ef5c81f6 100644 --- a/include/clasp/llvmo/llvmoExpose.h +++ b/include/clasp/llvmo/llvmoExpose.h @@ -1490,6 +1490,8 @@ class ConstantExpr_O : public Constant_O { public: static Constant_sp getInBoundsGetElementPtr(llvm::Type* element_type, Constant_sp constant, core::List_sp idxList); + static Constant_sp getIntToPtr(llvm::Constant* c, llvm::Type* ty, + bool only_if_reduced_p); }; // ConstantExpr_O }; // namespace llvmo diff --git a/include/clasp/llvmo/llvmoPackage.h b/include/clasp/llvmo/llvmoPackage.h index b40e3011d2..eac32f3e0d 100644 --- a/include/clasp/llvmo/llvmoPackage.h +++ b/include/clasp/llvmo/llvmoPackage.h @@ -31,6 +31,11 @@ THE SOFTWARE. PACKAGE_USE("COMMON-LISP"); PACKAGE_SHADOW("FUNCTION"); +PACKAGE_SHADOW("TYPE"); +PACKAGE_SHADOW("OR"); +PACKAGE_SHADOW("AND"); +PACKAGE_SHADOW("MIN"); +PACKAGE_SHADOW("MAX"); NAMESPACE_PACKAGE_ASSOCIATION(llvmo, LlvmoPkg, "LLVM-SYS"); namespace llvmo { diff --git a/repos.sexp b/repos.sexp index ba498e1e61..b6d0f6ccfd 100644 --- a/repos.sexp +++ b/repos.sexp @@ -6,9 +6,8 @@ :pin 1) (:name :alexandria :directory "src/lisp/kernel/contrib/alexandria/" - :repository "https://github.com/clasp-developers/alexandria.git" - :branch "master" - :commit "8514d8e68ed0c733abf7f96f9e91b24912686dc4" + :repository "https://github.com/Bike/alexandria.git" + :branch "lambda-list-fix" :pin 1) (:name :anaphora :extension :cando @@ -17,6 +16,11 @@ :branch "master" :commit "bcf0f7485eec39415be1b2ec6ca31cf04a8ab5c5" :pin 1) + (:name :anatomicl + :directory "src/lisp/kernel/contrib/Anatomicl/" + :repository "https://github.com/s-expressionists/Anatomicl.git" + :branch "main" + :pin 1) (:name :ansi-test :directory "dependencies/ansi-test/" :repository "https://github.com/clasp-developers/ansi-test.git" @@ -126,7 +130,7 @@ (:name :cleavir :directory "src/lisp/kernel/contrib/Cleavir/" :repository "https://github.com/s-expressionists/Cleavir.git" - :branch "main" + :branch "cross" :pin 0) (:name :closer-mop :directory "src/lisp/kernel/contrib/closer-mop/" @@ -134,6 +138,16 @@ :branch "master" :commit "4809f692ecf7b7c8c01ebea55ee10489e0992920" :pin 1) + (:name :clostrum + :directory "src/lisp/kernel/contrib/Clostrum/" + :repository "https://github.com/s-expressionists/Clostrum.git" + :branch "master" + :pin 1) + (:name :common-macros + :directory "src/lisp/kernel/contrib/Common-macros/" + :repository "https://github.com/robert-strandh/Common-macros/" + :branch "master" + :pin 1) (:name :concrete-syntax-tree :directory "src/lisp/kernel/contrib/Concrete-Syntax-Tree/" :repository "https://github.com/s-expressionists/Concrete-Syntax-Tree.git" @@ -147,6 +161,11 @@ :branch "master" :commit "fcbd927dee7f311915a27ee557e3db1d4510403c" :pin 1) + (:name :ecclesia + :directory "src/lisp/kernel/contrib/Ecclesia/" + :repository "https://github.com/s-expressionists/Ecclesia.git" + :branch "main" + :pin 1) (:name :eclector :directory "src/lisp/kernel/contrib/Eclector/" :repository "https://github.com/s-expressionists/Eclector.git" @@ -159,6 +178,10 @@ :branch "master" :commit "7588b430ad7c52f91a119b4b1c9a549d584b7064" :pin 2) + (:name :extrinsicl + :directory "src/lisp/kernel/contrib/Extrinsicl/" + :repository "https://github.com/s-expressionists/Extrinsicl.git" + :branch "cross") (:name :fast-io :extension :cando :directory "src/lisp/kernel/contrib/fast-io/" @@ -180,6 +203,26 @@ :branch "master" :commit "9566ce8adfb299faef803d95736c780413a1373c" :pin 1) + (:name :khazern + :repository "https://github.com/s-expressionists/Khazern.git" + :directory "src/lisp/kernel/contrib/Khazern/" + :commit "6821e5c1690df422f1b2868f26b396eff3d7b6fe" + :pin 1) + (:name :incless + :directory "src/lisp/kernel/contrib/Incless/" + :repository "https://github.com/s-expressionists/Incless.git" + :commit "201baeebb85fdd93e5f6ef514e7e5b47aa5d2d52" + :pin 1) + (:name :inravina + :directory "src/lisp/kernel/contrib/Inravina/" + :repository "https://github.com/s-expressionists/Inravina.git" + :commit "ddcb0d2e85958cda83173b054ed6338246aa7bbf" + :pin 1) + (:name :invistra + :directory "src/lisp/kernel/contrib/Invistra/" + :repository "https://github.com/s-expressionists/Invistra.git" + :commit "f55493f93475b1c2a4fca81b55db04ada3c285fc" + Pin 1) (:name :khazern :directory "src/lisp/kernel/contrib/Khazern/" :repository "https://github.com/s-expressionists/Khazern.git" @@ -206,6 +249,11 @@ :branch "fix-asdf-feature" :commit "9c98bf629328b27a5a3fbb7a637afd1db439c00f" :pin 1) + (:name :maclina + :directory "src/lisp/kernel/contrib/Maclina/" + :repository "https://github.com/s-expressionists/Maclina.git" + :branch "cross" + :pin 1) (:name :mgl-pax :extension :cando :directory "src/lisp/kernel/contrib/mgl-pax/" @@ -220,6 +268,11 @@ :branch "master" :commit "6eea56674442b884a4fee6ede4c8aad63541aa5b" :pin 1) + (:name :nontrivial-gray-streams + :directory "src/lisp/kernel/contrib/nontrivial-gray-streams/" + :repository "https://github.com/yitzchak/nontrivial-gray-streams.git" + :branch "main" + :pin 1) (:name :parser.common-rules :extension :cando :directory "src/lisp/kernel/contrib/parser.common-rules/" @@ -241,6 +294,11 @@ :branch "master" :commit "47a70ba1e32362e03dad6ef8e6f36180b560f86a" :pin 1) + (:name :quaviver + :directory "src/lisp/kernel/contrib/quaviver/" + :repository "https://github.com/s-expressionists/quaviver.git" + :branch "main" + :pin 1) (:name :quicklisp-client :directory "dependencies/quicklisp-client/" :repository "https://github.com/quicklisp/quicklisp-client.git" @@ -327,6 +385,11 @@ :branch "master" :commit "87b35ff9202b107230e35790e93c471cc7880900" :pin 1) + (:name :trivial-package-local-nicknames + :directory "src/lisp/kernel/contrib/trivial-package-local-nicknames" + :repository "https://github.com/phoe/trivial-package-local-nicknames.git" + :branch "master" + :pin 1) (:name :trivial-package-locks :directory "src/lisp/kernel/contrib/trivial-package-locks/" :repository "https://github.com/yitzchak/trivial-package-locks.git" @@ -346,6 +409,11 @@ :branch "master" :commit "d00f7abcbb127969884ea639a334827c3b5a0ad2" :pin 1) + (:name :trucler + :directory "src/lisp/kernel/contrib/Trucler/" + :repository "https://github.com/s-expressionists/Trucler.git" + :branch "master" + :pin 1) (:name :usocket :directory "src/lisp/kernel/contrib/usocket/" :repository "https://github.com/usocket/usocket.git" diff --git a/src/analysis/clasp_gc.sif b/src/analysis/clasp_gc.sif index de12bf32c7..8b37fe196d 100644 --- a/src/analysis/clasp_gc.sif +++ b/src/analysis/clasp_gc.sif @@ -3749,9 +3749,10 @@ :offset-ctype "gctools::smart_ptr" :offset-base-ctype "core::SimpleCoreFunGenerator_O" :layout-offset-field-names ("_entry_point_indices")} -{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" :offset-base-ctype "core::SimpleCoreFunGenerator_O" - :layout-offset-field-names ("_localFunIndex")} + :layout-offset-field-names ("_CoreFunGenerator")} {class-kind :stamp-name "STAMPWTAG_clasp_ffi__ForeignTypeSpec_O" :stamp-key "clasp_ffi::ForeignTypeSpec_O" :parent-class "core::General_O" :lisp-class-base "core::General_O" :root-class "core::T_O" :stamp-wtag 3 @@ -4894,6 +4895,9 @@ :layout-offset-field-names ("_decls")} {fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" :offset-base-ctype "comp::Lexenv_O" :layout-offset-field-names ("frame_end")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" :offset-base-ctype "comp::Lexenv_O" + :layout-offset-field-names ("_global")} {class-kind :stamp-name "STAMPWTAG_comp__BlockInfo_O" :stamp-key "comp::BlockInfo_O" :parent-class "core::General_O" :lisp-class-base "core::General_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} diff --git a/src/analysis/clasp_gc_cando.sif b/src/analysis/clasp_gc_cando.sif index fc8404b6d9..22acf8f16c 100644 --- a/src/analysis/clasp_gc_cando.sif +++ b/src/analysis/clasp_gc_cando.sif @@ -8829,9 +8829,10 @@ :offset-ctype "gctools::smart_ptr" :offset-base-ctype "core::SimpleCoreFunGenerator_O" :layout-offset-field-names ("_entry_point_indices")} -{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" :offset-base-ctype "core::SimpleCoreFunGenerator_O" - :layout-offset-field-names ("_localFunIndex")} + :layout-offset-field-names ("_CoreFunGenerator")} {class-kind :stamp-name "STAMPWTAG_core__CoreFunGenerator_O" :stamp-key "core::CoreFunGenerator_O" :parent-class "core::General_O" :lisp-class-base "core::General_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} diff --git a/src/core/bootStrapCoreSymbolMap.cc b/src/core/bootStrapCoreSymbolMap.cc index 52f5902372..0641abd6ba 100644 --- a/src/core/bootStrapCoreSymbolMap.cc +++ b/src/core/bootStrapCoreSymbolMap.cc @@ -29,7 +29,6 @@ THE SOFTWARE. #include #include #include -#include #include #include #include diff --git a/src/core/bytecode.cc b/src/core/bytecode.cc index 08be54c097..16df16cd16 100644 --- a/src/core/bytecode.cc +++ b/src/core/bytecode.cc @@ -197,6 +197,21 @@ void vm_record_playback(void* value, const char* name) { #define VM_RECORD_PLAYBACK(value, name) #endif +// Defined later in Lisp. Lambda list (environment name) and they return cells. +// ensure_vcell is actually used in progv_env in unwind.h. +SYMBOL_EXPORT_SC_(CorePkg, fcge_ensure_fcell); +SYMBOL_EXPORT_SC_(CorePkg, fcge_ensure_vcell); + +// Resolve a function designator in a given environment. +static Function_sp fdesignator_in_env(T_sp desig, T_sp env) { + if (desig.isA()) + return desig.as_unsafe(); + else { + T_sp cell = eval::funcall(_sym_fcge_ensure_fcell, env, desig); + return cell.as(); + } +} + static unsigned char* long_dispatch(VirtualMachine&, unsigned char*, MultipleValues& multipleValues, T_O**, T_O**, Closure_O*, core::T_O**, core::T_O**, size_t, core::T_O**, uint8_t); @@ -892,12 +907,13 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure return gctools::return_type(nil().raw_(), 0); } case vm_code::progv: { - uint8_t c = *(++pc); // environment + uint8_t c = *(++pc); DBG_VM1("progv %" PRIu8 "\n", c); + T_sp env((gctools::Tagged)literals[c]); T_sp vals((gctools::Tagged)(vm.pop(sp))); T_sp vars((gctools::Tagged)(vm.pop(sp))); vm._pc = ++pc; - fprogv(vars, vals, [&]() { return bytecode_vm(vm, literals, closed, closure, fp, sp, lcc_nargs, lcc_args); }); + fprogv_env(env, vars, vals, [&]() { return bytecode_vm(vm, literals, closed, closure, fp, sp, lcc_nargs, lcc_args); }); sp = vm._stackPointer; pc = vm._pc; break; @@ -905,7 +921,8 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure case vm_code::fdefinition: { // We have function cells in the literals vector. While these are // themselves callable, we have to resolve the cell because we - // use vm_code::fdefinition for lookup of #'foo. + // use vm_code::fdefinition for lookup of #'foo, which may e.g. + // have its type or identity tested. uint8_t c = *(++pc); DBG_VM1("fdefinition %" PRIu8 "\n", c); T_sp cell((gctools::Tagged)literals[c]); @@ -942,10 +959,11 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure break; } case vm_code::fdesignator: { - uint8_t c = *(++pc); // ignored environment parameter + uint8_t c = *(++pc); DBG_VM1("fdesignator %" PRIu8 "\n", c); + T_sp env((gctools::Tagged)literals[c]); T_sp desig((gctools::Tagged)vm.pop(sp)); - Function_sp fun = coerce::calledFunctionDesignator(desig); + Function_sp fun = env.nilp() ? coerce::calledFunctionDesignator(desig) : fdesignator_in_env(desig, env); vm.push(sp, fun.raw_()); VM_RECORD_PLAYBACK(run.raw_(), "fdesignator"); pc++; @@ -1427,10 +1445,11 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi uint8_t low = *(++pc); uint16_t c = low + (*(++pc) << 8); DBG_VM1("long progv %" PRIu16 "\n", c); + T_sp env((gctools::Tagged)literals[c]); T_sp vals((gctools::Tagged)(vm.pop(sp))); T_sp vars((gctools::Tagged)(vm.pop(sp))); vm._pc = ++pc; - fprogv(vars, vals, [&]() { return bytecode_vm(vm, literals, closed, closure, fp, sp, lcc_nargs, lcc_args); }); + fprogv_env(env, vars, vals, [&]() { return bytecode_vm(vm, literals, closed, closure, fp, sp, lcc_nargs, lcc_args); }); sp = vm._stackPointer; pc = vm._pc; break; @@ -1439,8 +1458,9 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi uint8_t low = *(++pc); uint16_t n = low + (*(++pc) << 8); DBG_VM1("long fdesignator %" PRIu16 "\n", n); + T_sp env((gctools::Tagged)literals[n]); T_sp desig((gctools::Tagged)vm.pop(sp)); - Function_sp fun = coerce::calledFunctionDesignator(desig); + Function_sp fun = env.nilp() ? coerce::calledFunctionDesignator(desig) : fdesignator_in_env(desig, env); vm.push(sp, fun.raw_()); pc++; break; diff --git a/src/core/bytecode_compiler.cc b/src/core/bytecode_compiler.cc index 2692b35ede..e18f65b37d 100644 --- a/src/core/bytecode_compiler.cc +++ b/src/core/bytecode_compiler.cc @@ -27,14 +27,6 @@ T_sp Lexenv_O::variableInfo(T_sp varname) { } } -T_sp Lexenv_O::lookupSymbolMacro(T_sp sname) { - T_sp info = this->variableInfo(sname); - if (gc::IsA(info)) - return gc::As_unsafe(info)->expander(); - else - return nil(); -} - T_sp Lexenv_O::functionInfo(T_sp funname) { T_sp funs = this->funs(); if (funs.nilp()) @@ -48,19 +40,6 @@ T_sp Lexenv_O::functionInfo(T_sp funname) { } } -T_sp Lexenv_O::lookupMacro(Symbol_sp macroname) { - T_sp info = this->functionInfo(macroname); - if (gc::IsA(info)) - return gc::As_unsafe(info)->expander(); - else if (gc::IsA(info)) - return nil(); // not a macro, i.e. shadowed - // no local info: check global - else if (macroname->fboundp() && macroname->macroP()) - return macroname->symbolFunction(); - else // nothing - return nil(); -} - T_sp Lexenv_O::blockInfo(T_sp blockname) { T_sp blocks = this->blocks(); if (blocks.nilp()) @@ -212,11 +191,12 @@ Lexenv_sp Lexenv_O::macroexpansion_environment() { if (gc::IsA(info) || gc::IsA(info)) new_funs << pair; } - return Lexenv_O::make(new_vars.cons(), nil(), nil(), new_funs.cons(), this->decls(), 0); + return Lexenv_O::make(new_vars.cons(), nil(), nil(), new_funs.cons(), this->decls(), 0, global()); } -CL_DEFUN Lexenv_sp make_null_lexical_environment() { - return Lexenv_O::make(nil(), nil(), nil(), nil(), nil(), 0); +CL_LAMBDA(&optional global) +CL_DEFUN Lexenv_sp make_null_lexical_environment(T_sp global) { + return Lexenv_O::make_top_level(global); } void assemble(const Context context, uint8_t opcode, List_sp operands) { @@ -228,9 +208,6 @@ void assemble(const Context context, uint8_t opcode, List_sp operands) { } } -template -[[deprecated]] inline constexpr void print_type(T&& t, const char* msg=nullptr) {} - CL_LAMBDA(code position &rest values); CL_DEFUN void assemble_into(SimpleVector_byte8_t_sp code, size_t position, List_sp values) { for (auto cur : values) @@ -263,11 +240,7 @@ void assemble_maybe_long(const Context context, uint8_t opcode, List_sp operands } } -CL_DEFUN T_sp var_info(Symbol_sp sym, Lexenv_sp env) { - // Local? - T_sp info = env->variableInfo(sym); - if (info.notnilp()) - return info; +static inline T_sp main_env_var_info(Symbol_sp sym) { // Constant? // (Constants are also specialP, so we have to check constancy first.) if (cl__keywordp(sym) || sym->getReadOnly()) @@ -287,17 +260,23 @@ CL_DEFUN T_sp var_info(Symbol_sp sym, Lexenv_sp env) { return nil(); } -// Like the above, but returns a std::variant. Good when you don't need -// to cons up info objects. -VarInfoV var_info_v(Symbol_sp sym, Lexenv_sp env) { +// Defined later in Lisp. Lambda list (environment name) +// returns a variable info or NIL. +SYMBOL_EXPORT_SC_(CorePkg, fcge_lookup_var); + +CL_DEFUN T_sp var_info(Symbol_sp sym, Lexenv_sp env) { + // Local? T_sp info = env->variableInfo(sym); - if (gc::IsA(info)) // in_place_type_t? - return VarInfoV(LexicalVarInfoV(gc::As_unsafe(info))); - else if (gc::IsA(info)) - return VarInfoV(SpecialVarInfoV(gc::As_unsafe(info))); - else if (gc::IsA(info)) - return VarInfoV(SymbolMacroVarInfoV(gc::As_unsafe(info))); - ASSERT(info.nilp()); + if (info.notnilp()) + return info; + T_sp global = env->global(); + if (global.nilp()) + return main_env_var_info(sym); + else + return eval::funcall(core::_sym_fcge_lookup_var, global, sym); +} + +static inline VarInfoV main_env_var_info_v(Symbol_sp sym) { // Constant? if (cl__keywordp(sym) || sym->getReadOnly()) return VarInfoV(ConstantVarInfoV(sym->symbolValue())); @@ -316,11 +295,48 @@ VarInfoV var_info_v(Symbol_sp sym, Lexenv_sp env) { return VarInfoV(NoVarInfoV()); } -CL_DEFUN T_sp fun_info(T_sp name, Lexenv_sp env) { - // Local? - T_sp info = env->functionInfo(name); - if (info.notnilp()) - return info; +// Like var_info, but returns a std::variant. Good when you don't need +// to cons up info objects. (But it does anyway for alternate global envs.) +VarInfoV var_info_v(Symbol_sp sym, Lexenv_sp env) { + T_sp info = env->variableInfo(sym); + if (info.isA()) + return VarInfoV(LexicalVarInfoV(info.as_unsafe())); + else if (info.isA()) + return VarInfoV(SpecialVarInfoV(info.as_unsafe())); + else if (info.isA()) + return VarInfoV(SymbolMacroVarInfoV(info.as_unsafe())); + ASSERT(info.nilp()); + + // Nothing local so try a global lookup. + T_sp global = env->global(); + if (global.nilp()) + return main_env_var_info_v(sym); + else { + info = eval::funcall(core::_sym_fcge_lookup_var, global, sym); + if (info.isA()) + return VarInfoV(LexicalVarInfoV(info.as_unsafe())); + else if (info.isA()) + return VarInfoV(SpecialVarInfoV(info.as_unsafe())); + else if (info.isA()) + return VarInfoV(SymbolMacroVarInfoV(info.as_unsafe())); + else if (info.isA()) + return VarInfoV(ConstantVarInfoV(info.as_unsafe())); + else { + ASSERT(info.nilp()); + return VarInfoV(NoVarInfoV()); + } + } +} + +T_sp Lexenv_O::lookupSymbolMacro(T_sp sname) { + VarInfoV info = var_info_v(sname, this->asSmartPtr()); + if (std::holds_alternative(info)) + return std::get(info).expander(); + else + return nil(); +} + +static inline T_sp main_env_fun_info(T_sp name) { // Split into setf and not versions. if (name.consp()) { List_sp cname = name; @@ -365,14 +381,21 @@ CL_DEFUN T_sp fun_info(T_sp name, Lexenv_sp env) { } } -FunInfoV fun_info_v(T_sp name, Lexenv_sp env) { +SYMBOL_EXPORT_SC_(CorePkg, fcge_lookup_fun); + +CL_DEFUN T_sp fun_info(T_sp name, Lexenv_sp env) { // Local? T_sp info = env->functionInfo(name); - if (gc::IsA(info)) - return FunInfoV(LocalFunInfoV(gc::As_unsafe(info))); - else if (gc::IsA(info)) - return FunInfoV(LocalMacroInfoV(gc::As_unsafe(info))); - ASSERT(info.nilp()); + if (info.notnilp()) + return info; + T_sp global = env->global(); + if (global.nilp()) + return main_env_fun_info(name); + else + return eval::funcall(core::_sym_fcge_lookup_fun, global, name); +} + +static inline FunInfoV main_env_fun_info_v(T_sp name) { // Split into setf and not versions. if (name.consp()) { List_sp cname = name; @@ -404,6 +427,41 @@ FunInfoV fun_info_v(T_sp name, Lexenv_sp env) { } } +FunInfoV fun_info_v(T_sp name, Lexenv_sp env) { + // Local? + T_sp info = env->functionInfo(name); + if (gc::IsA(info)) + return FunInfoV(LocalFunInfoV(gc::As_unsafe(info))); + else if (gc::IsA(info)) + return FunInfoV(LocalMacroInfoV(gc::As_unsafe(info))); + ASSERT(info.nilp()); + + T_sp global = env->global(); + if (global.nilp()) + return main_env_fun_info_v(name); + else { + info = eval::funcall(core::_sym_fcge_lookup_fun, global, name); + if (info.isA()) + return FunInfoV(GlobalFunInfoV(info.as_unsafe())); + else if (info.isA()) + return FunInfoV(GlobalMacroInfoV(info.as_unsafe())); + else { + ASSERT(info.nilp()); + return FunInfoV(NoFunInfoV()); + } + } +} + +T_sp Lexenv_O::lookupMacro(Symbol_sp macroname) { + FunInfoV info = fun_info_v(macroname, this->asSmartPtr()); + if (std::holds_alternative(info)) + return std::get(info).expander(); + else if (std::holds_alternative(info)) + return std::get(info).expander(); + else + return nil(); +} + bool Lexenv_O::notinlinep(T_sp fname) { for (auto cur : this->decls()) { T_sp decl = oCar(cur); @@ -1078,8 +1136,8 @@ SimpleVector_byte8_t_sp Module_O::create_bytecode() { CL_DEFUN T_sp lambda_list_for_name(T_sp raw_lambda_list) { return core::lambda_list_for_name(raw_lambda_list); } -Function_sp Cfunction_O::link_function() { - this->module()->link_load(); +Function_sp Cfunction_O::link_function(T_sp env) { + this->module()->link_load(env); // Linking installed the GBEP in this cfunction's info. Return that. return this->info(); } @@ -1129,7 +1187,8 @@ void Module_O::link() { cmodule->resolve_fixup_sizes(); } -void Module_O::link_load() { +void Module_O::link_load(T_sp env) { + // env is global, used to look up cells. Module_sp cmodule = this->asSmartPtr(); cmodule->link(); SimpleVector_byte8_t_sp bytecode = cmodule->create_bytecode(); @@ -1176,17 +1235,27 @@ void Module_O::link_load() { literals[i] = gc::As_unsafe(lit)->info(); else if (gc::IsA(lit)) { LoadTimeValueInfo_sp ltvinfo = gc::As_unsafe(lit); - literals[i] = ltvinfo->eval(); + literals[i] = ltvinfo->eval(env); if (!ltvinfo->read_only_p()) mutableLTVs << Integer_O::create(i); } else if (gc::IsA(lit)) literals[i] = gc::As_unsafe(lit)->value(); - else if (gc::IsA(lit)) - literals[i] = core__ensure_function_cell(gc::As_unsafe(lit)->fname()); - else if (gc::IsA(lit)) - literals[i] = gc::As_unsafe(lit)->vname()->ensureVariableCell(); + else if (gc::IsA(lit)) { + if (env.nilp()) + literals[i] = core__ensure_function_cell(gc::As_unsafe(lit)->fname()); + else + literals[i] = eval::funcall(core::_sym_fcge_ensure_fcell, env, + lit.as_unsafe()->fname()); + } + else if (gc::IsA(lit)) { + if (env.nilp()) + literals[i] = gc::As_unsafe(lit)->vname()->ensureVariableCell(); + else + literals[i] = eval::funcall(core::_sym_fcge_ensure_vcell, env, + lit.as_unsafe()->vname()); + } else if (gc::IsA(lit)) - literals[i] = nil(); // the only environment we have + literals[i] = env; else SIMPLE_ERROR("BUG: Weird thing in compiler literals vector: {}", _rep_(lit)); } @@ -1210,7 +1279,7 @@ void Module_O::link_load() { Cfunction_sp cfun = gc::As_assert(tfun); BytecodeSimpleFun_sp fun = cfun->info(); if (btb_bcfun_p(fun, debug_info)) { - T_sp nat = eval::funcall(_sym_STARautocompile_hookSTAR->symbolValue(), fun, nil()); + T_sp nat = eval::funcall(_sym_STARautocompile_hookSTAR->symbolValue(), fun, env); fun->setSimpleFun(gc::As_assert(nat)); } } @@ -1858,7 +1927,7 @@ CL_DEFUN Cfunction_sp compile_lambda(T_sp lambda_list, List_sp body, Lexenv_sp e name = Cons_O::createList(cl::_sym_lambda, comp::lambda_list_for_name(oll)); Cfunction_sp function = Cfunction_O::make(module, name, docstring, oll, source_info); Context context(-1, nil(), function, source_info); - Lexenv_sp lenv = Lexenv_O::make(env->vars(), env->tags(), env->blocks(), env->funs(), env->decls(), 0); + Lexenv_sp lenv = Lexenv_O::make(env->vars(), env->tags(), env->blocks(), env->funs(), env->decls(), 0, env->global()); Fixnum_sp ind = module->cfunctions()->vectorPushExtend(function); function->setIndex(ind.unsafe_fixnum()); if (all_declares.notnilp() || source_info.notnilp()) { @@ -2783,9 +2852,17 @@ void compile_form(T_sp form, Lexenv_sp env, const Context context) { } } -CL_LAMBDA(module lambda-expression &optional (env (cmp::make-null-lexical-environment))); +static Lexenv_sp coerce_lexenv_desig(T_sp env) { + if (env.isA()) + return env.as_unsafe(); + else + return Lexenv_O::make_top_level(env); +} + +CL_LAMBDA(module lambda-expression &optional env); CL_DOCSTRING(R"dx(Compile the given lambda-expression into an existing module. Return a handle to it.)dx"); -CL_DEFUN Cfunction_sp bytecompile_into(Module_sp module, T_sp lambda_expression, Lexenv_sp env) { +CL_DEFUN Cfunction_sp bytecompile_into(Module_sp module, T_sp lambda_expression, T_sp tenv) { + Lexenv_sp env = coerce_lexenv_desig(tenv); if (!gc::IsA(lambda_expression) || (oCar(lambda_expression) != cl::_sym_lambda)) SIMPLE_ERROR("bytecompiler passed a non-lambda-expression: {}", _rep_(lambda_expression)); T_sp lambda_list = oCadr(lambda_expression); @@ -2794,18 +2871,12 @@ CL_DEFUN Cfunction_sp bytecompile_into(Module_sp module, T_sp lambda_expression, source_location_for(lambda_expression, core::_sym_STARcurrentSourcePosInfoSTAR->symbolValue())); } -CL_LAMBDA(lambda-expression &optional (env (cmp::make-null-lexical-environment))); -CL_DEFUN Function_sp bytecompile(T_sp lambda_expression, Lexenv_sp env) { +CL_LAMBDA(lambda-expression &optional env) +CL_DEFUN Function_sp bytecompile(T_sp lambda_expression, T_sp env) { Module_sp module = Module_O::make(); Cfunction_sp cf = bytecompile_into(module, lambda_expression, env); - return cf->link_function(); -} - -static Lexenv_sp coerce_lexenv_desig(T_sp env) { - if (env.nilp()) - return make_null_lexical_environment(); - else - return gc::As(env); + T_sp global = env.isA() ? env.as_unsafe()->global() : env; + return cf->link_function(global); } SYMBOL_EXPORT_SC_(CompPkg, bytecode_implicit_compile_form); @@ -2815,11 +2886,14 @@ CL_DEFUN T_mv cmp__bytecode_implicit_compile_form(T_sp form, T_sp env) { T_sp lexpr = Cons_O::createList(cl::_sym_lambda, nil(), Cons_O::createList(cl::_sym_declare), Cons_O::createList(cl::_sym_progn, form)); // printf("%s:%d:%s lexpr = %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(lexpr).c_str()); - Function_sp thunk = bytecompile(lexpr, coerce_lexenv_desig(env)); + Function_sp thunk = bytecompile(lexpr, env); return eval::funcall(thunk); } -T_sp LoadTimeValueInfo_O::eval() { return cmp__bytecode_implicit_compile_form(this->form(), make_null_lexical_environment()); } +T_sp LoadTimeValueInfo_O::eval(T_sp env) { + return cmp__bytecode_implicit_compile_form(this->form(), + Lexenv_O::make_top_level(env)); +} T_mv bytecode_toplevel_eval(T_sp, T_sp); diff --git a/src/core/cleavirEnvPackage.cc b/src/core/cleavirEnvPackage.cc deleted file mode 100644 index f5e77beb4e..0000000000 --- a/src/core/cleavirEnvPackage.cc +++ /dev/null @@ -1,34 +0,0 @@ -/* - File: cleavirEnvPackage.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 diff --git a/src/core/commandLineOptions.cc b/src/core/commandLineOptions.cc index 00d8663d6f..741e853abe 100644 --- a/src/core/commandLineOptions.cc +++ b/src/core/commandLineOptions.cc @@ -59,8 +59,6 @@ const char* help = R"dx(Usage: clasp Describe the clasp data structures for lldb Python API to /tmp/clasp.py -d, --describe Describe the clasp data structures for lldb Python API to - -U, --unpack-faso - Unpack the faso into separate object files --noinform Don't print startup banner text --noprint @@ -295,9 +293,6 @@ void process_clasp_arguments(CommandLineOptions* options) { if (*arg == "-h" || *arg == "--help") { std::cout << help << std::endl; exit(0); - } else if (*arg == "-U" || *arg == "--unpack-faso") { - clasp_unpack_faso(*++arg); - exit(0); } else if (*arg == "-v" || *arg == "--version") { options->printVersion(); std::cout << std::endl; diff --git a/src/core/compiler.cc b/src/core/compiler.cc index 42eac17da9..a38fdde146 100644 --- a/src/core/compiler.cc +++ b/src/core/compiler.cc @@ -297,7 +297,7 @@ size_t startup_functions_are_waiting() { }; /*! Invoke the startup functions and clear the array of startup functions */ -core::T_O* startup_functions_invoke(T_O* literals) { +void startup_functions_invoke(T_O* literals) { size_t startup_count = 0; StartUp* startup_functions = NULL; { @@ -332,16 +332,11 @@ core::T_O* startup_functions_invoke(T_O* literals) { previous = startup; switch (startup._Type) { case StartUp::T_O_function: - result = ((T_OStartUp)startup._Function)(literals); // invoke the startup function - if (result) { - printf("%s:%d:%s Returning a function pointer %p from startup_functions_invoke - we need to support this\n", __FILE__, - __LINE__, __FUNCTION__, result); - } + ((T_OStartUp)startup._Function)(literals); // invoke the startup function break; case StartUp::void_function: ((voidStartUp)startup._Function)(); printf("%s:%d:%s Returning NULL startup_functions_invoke\n", __FILE__, __LINE__, __FUNCTION__); - result = NULL; } } #ifdef DEBUG_STARTUP @@ -349,7 +344,6 @@ core::T_O* startup_functions_invoke(T_O* literals) { #endif free(startup_functions); } - return result; } } // namespace core @@ -472,7 +466,7 @@ CL_DEFUN T_sp core__startup_image_pathname(bool extension) { ss << "sys:lib;images;" << (extension ? "extension" : "base"); T_sp mode = comp::_sym_STARdefault_output_typeSTAR->symbolValue(); if (mode == kw::_sym_faso) { - ss << ".faso"; + ss << ".nfasl"; // ss << ".faso"; } else if (mode == kw::_sym_fasoll) { ss << ".fasoll"; } else if (mode == kw::_sym_fasobc) { @@ -487,250 +481,6 @@ CL_DEFUN T_sp core__startup_image_pathname(bool extension) { return pn; }; -struct FasoHeader; - -struct ObjectFileInfo { - size_t _ObjectId; - size_t _StartPage; - size_t _NumberOfPages; - size_t _ObjectFileSize; -}; - -struct FasoHeader { - uint8_t _Magic[4]; - uint32_t _Version; - size_t _PageSize; - size_t _HeaderPageCount; - size_t _NumberOfObjectFiles; - ObjectFileInfo _ObjectFiles[0]; - - static size_t calculateSize(size_t numberOfObjectFiles) { - size_t header = sizeof(FasoHeader); - size_t entries = numberOfObjectFiles * sizeof(ObjectFileInfo); - return header + entries; - } - static size_t calculateHeaderNumberOfPages(size_t numberOfObjectFiles, size_t pageSize) { - size_t size = FasoHeader::calculateSize(numberOfObjectFiles); - size_t numberOfPages = (size + pageSize) / pageSize; - return numberOfPages; - } - - size_t calculateObjectFileNumberOfPages(size_t objectFileSize) const { - size_t numberOfPages = (objectFileSize + this->_PageSize) / this->_PageSize; - return numberOfPages; - } -}; - -void setup_FasoHeader(FasoHeader* header) { - header->_Magic[0] = FASO_MAGIC_NUMBER_0; - header->_Magic[1] = FASO_MAGIC_NUMBER_1; - header->_Magic[2] = FASO_MAGIC_NUMBER_2; - header->_Magic[3] = FASO_MAGIC_NUMBER_3; - header->_Version = FASO_VERSION; - header->_PageSize = getpagesize(); -} - -CL_LAMBDA(path-desig object-files &key (start-object-id 0)); -CL_DOCSTRING(R"dx(Concatenate object files in OBJECT-FILES into a faso file and write it out to PATH-DESIG. -You can set the starting ObjectId using the keyword START-OBJECT-ID argument.)dx") -DOCGROUP(clasp); -CL_DEFUN void core__write_faso(T_sp pathDesig, List_sp objectFiles, T_sp tstart_object_id) { - // clasp_write_string(fmt::format("Writing FASO file to {} for {} object files\n" , _rep_(pathDesig) , cl__length(objectFiles))); - pathDesig = cl__translate_logical_pathname(pathDesig); - size_t start_object_id = 0; - if (tstart_object_id.fixnump()) { - if (tstart_object_id.unsafe_fixnum() >= 0) { - start_object_id = tstart_object_id.unsafe_fixnum(); - // printf("%s:%d assigned start_object_id = %lu\n", __FILE__, __LINE__, start_object_id ); - } else { - SIMPLE_ERROR("start-object-id must be a positive integer - got: {}", _rep_(tstart_object_id).c_str()); - } - } - // printf("%s:%d start_object_id = %lu\n", __FILE__, __LINE__, start_object_id ); - // printf("%s:%d Number of object files: %lu\n", __FILE__, __LINE__, cl__length(objectFiles)); - FasoHeader* header = (FasoHeader*)malloc(FasoHeader::calculateSize(cl__length(objectFiles))); - setup_FasoHeader(header); - header->_HeaderPageCount = FasoHeader::calculateHeaderNumberOfPages(cl__length(objectFiles), getpagesize()); - header->_NumberOfObjectFiles = cl__length(objectFiles); - List_sp cur = objectFiles; - size_t nextPage = header->_HeaderPageCount; - for (size_t ii = 0; ii < cl__length(objectFiles); ++ii) { - header->_ObjectFiles[ii]._ObjectId = ii + start_object_id; - header->_ObjectFiles[ii]._StartPage = nextPage; - Array_sp of = gc::As(oCar(cur)); - cur = oCdr(cur); - size_t num_pages = header->calculateObjectFileNumberOfPages(cl__length(of)); - header->_ObjectFiles[ii]._NumberOfPages = num_pages; - nextPage += num_pages; - header->_ObjectFiles[ii]._ObjectFileSize = cl__length(of); -#if 0 - clasp_write_string(fmt::format("Object-file {} StartPage = {} _NumberOfPages: {} _ObjectFileSize: {}\n" - , ii - , header->_ObjectFiles[ii]._StartPage - , header->_ObjectFiles[ii]._NumberOfPages - , header->_ObjectFiles[ii]._ObjectFileSize)); -#endif - } - String_sp filename = gc::As(cl__namestring(pathDesig)); - FILE* fout = fopen(filename->get_std_string().c_str(), "w"); - // Write header - size_t header_bytes = FasoHeader::calculateSize(header->_NumberOfObjectFiles); - fwrite((const void*)header, header_bytes, 1, fout); - - // Fill out to the end of the page - size_t pad_bytes = - FasoHeader::calculateHeaderNumberOfPages(header->_NumberOfObjectFiles, header->_PageSize) * header->_PageSize - header_bytes; - char empty_byte(0xcc); - for (size_t ii = 0; ii < pad_bytes; ++ii) { - fwrite((const void*)&empty_byte, 1, 1, fout); - } - // Write out each object file - List_sp ocur = objectFiles; - for (size_t ofindex = 0; ofindex < header->_NumberOfObjectFiles; ofindex++) { - size_t of_bytes = header->_ObjectFiles[ofindex]._ObjectFileSize; - Array_sp of = gc::As(oCar(ocur)); - ocur = oCdr(ocur); - fwrite((const void*)of->rowMajorAddressOfElement_(0), of_bytes, 1, fout); - size_t of_pad_bytes = header->_ObjectFiles[ofindex]._NumberOfPages * header->_PageSize - of_bytes; - for (size_t of_padi = 0; of_padi < of_pad_bytes; ++of_padi) { - fwrite((const void*)&empty_byte, 1, 1, fout); - } - } - fclose(fout); -}; - -struct MmapInfo { - int _FileDescriptor; - void* _Memory; - size_t _ObjectFileAreaStart; - size_t _ObjectFileAreaSize; - MmapInfo(int fd, void* mem, size_t start, size_t size) - : _FileDescriptor(fd), _Memory(mem), _ObjectFileAreaStart(start), _ObjectFileAreaSize(size){}; -}; - -struct FasoObjectFileInfo { - size_t _ObjectId; - size_t _ObjectFileSize; - FasoObjectFileInfo(size_t oid, size_t ofs) : _ObjectId(oid), _ObjectFileSize(ofs){}; -}; - -DOCGROUP(clasp); -CL_LAMBDA(output-path-designator faso-files &optional (verbose nil)); -CL_DEFUN void core__link_faso_files(T_sp outputPathDesig, List_sp fasoFiles, bool verbose) { - if (verbose) - clasp_write_string(fmt::format("Writing FASO file to {} for {} object files\n", _rep_(outputPathDesig), cl__length(fasoFiles))); - std::vector allObjectFiles; - std::vector mmaps; - List_sp cur = fasoFiles; - for (size_t ii = 0; ii < cl__length(fasoFiles); ++ii) { - String_sp filename = gc::As(cl__namestring(oCar(cur))); - cur = oCdr(cur); - int fd = open(filename->get_std_string().c_str(), O_RDONLY); - if (verbose) - clasp_write_string(fmt::format("mmap'ing file[{}] {}\n", ii, _rep_(filename))); - off_t fsize = lseek(fd, 0, SEEK_END); - lseek(fd, 0, SEEK_SET); - void* memory = mmap(NULL, fsize, PROT_READ, MAP_SHARED | MAP_FILE, fd, 0); - if (memory == MAP_FAILED) { - close(fd); - SIMPLE_ERROR("Could not mmap {} because of {}", _rep_(filename), strerror(errno)); - } - close(fd); - FasoHeader* header = (FasoHeader*)memory; - if (header->_Magic[0] != FASO_MAGIC_NUMBER_0 || header->_Magic[1] != FASO_MAGIC_NUMBER_1 || - header->_Magic[2] != FASO_MAGIC_NUMBER_2 || header->_Magic[3] != FASO_MAGIC_NUMBER_3) { - SIMPLE_ERROR("Illegal and unknown file type - magic number: %X%X%X%X\n", (uint8_t)header->_Magic[0], - (uint8_t)header->_Magic[1], (uint8_t)header->_Magic[2], (uint8_t)header->_Magic[3]); - } else if (header->_Version != FASO_VERSION) { - SIMPLE_ERROR("FASO version {:04x} is not readable by this loader", header->_Version); - } else { - size_t object0_offset = (header->_HeaderPageCount * header->_PageSize); - if (verbose) - clasp_write_string( - fmt::format("object0_offset {} fsize-object0_offset {} bytes\n", object0_offset, ((size_t)fsize - object0_offset))); - mmaps.emplace_back(MmapInfo(fd, memory, object0_offset, (size_t)fsize - object0_offset)); - for (size_t ofi = 0; ofi < header->_NumberOfObjectFiles; ++ofi) { - size_t of_length = header->_ObjectFiles[ofi]._ObjectFileSize; - if (verbose) - clasp_write_string(fmt::format("{}:{} object file {} id: {} length: {}\n", __FILE__, __LINE__, ofi, - header->_ObjectFiles[ofi]._ObjectId, of_length)); - FasoObjectFileInfo fofi(header->_ObjectFiles[ofi]._ObjectId, of_length); - allObjectFiles.emplace_back(fofi); - if (verbose) - clasp_write_string(fmt::format("allObjectFiles.size() = {}\n", allObjectFiles.size())); - } - } - } - FasoHeader* header = (FasoHeader*)malloc(FasoHeader::calculateSize(allObjectFiles.size())); - setup_FasoHeader(header); - header->_HeaderPageCount = FasoHeader::calculateHeaderNumberOfPages(allObjectFiles.size(), getpagesize()); - header->_NumberOfObjectFiles = allObjectFiles.size(); - if (verbose) - clasp_write_string(fmt::format("Writing out all object files {}\n", allObjectFiles.size())); - size_t nextPage = header->_HeaderPageCount; - for (size_t ofi = 0; ofi < allObjectFiles.size(); ofi++) { - header->_ObjectFiles[ofi]._ObjectId = allObjectFiles[ofi]._ObjectId; - header->_ObjectFiles[ofi]._StartPage = nextPage; - size_t num_pages = header->calculateObjectFileNumberOfPages(allObjectFiles[ofi]._ObjectFileSize); - header->_ObjectFiles[ofi]._NumberOfPages = num_pages; - nextPage += num_pages; - header->_ObjectFiles[ofi]._ObjectFileSize = allObjectFiles[ofi]._ObjectFileSize; - if (verbose) - clasp_write_string(fmt::format("object file {} _StartPage={} _NumberOfPages={} _ObjectFileSize={}\n", ofi, - header->_ObjectFiles[ofi]._StartPage, header->_ObjectFiles[ofi]._NumberOfPages, - header->_ObjectFiles[ofi]._ObjectFileSize)); - } - String_sp filename = gc::As(cl__namestring(outputPathDesig)); - - FILE* fout = fopen(filename->get_std_string().c_str(), "w"); - if (!fout) { - SIMPLE_ERROR("Could not open file {}", _rep_(filename)); - } - if (verbose) { - clasp_write_string(fmt::format("Writing file: {}\n", _rep_(filename))); - } - // Write header - size_t header_bytes = FasoHeader::calculateSize(header->_NumberOfObjectFiles); - if (verbose) - clasp_write_string(fmt::format("Writing {} bytes of header\n", header_bytes)); - fwrite((const void*)header, header_bytes, 1, fout); - - // clasp_write_string(fmt::format("Writing header {} bytes\n" , header_bytes )); - // Fill out to the end of the page - size_t pad_bytes = - FasoHeader::calculateHeaderNumberOfPages(header->_NumberOfObjectFiles, header->_PageSize) * header->_PageSize - header_bytes; - if (verbose) - clasp_write_string(fmt::format("Writing {} bytes of header for padding\n", pad_bytes)); - char empty_byte(0xcc); - for (size_t ii = 0; ii < pad_bytes; ++ii) { - fwrite((const void*)&empty_byte, 1, 1, fout); - } - unsigned char pad(0xcc); - for (size_t mmi = 0; mmi < mmaps.size(); mmi++) { - size_t bytes_to_write = mmaps[mmi]._ObjectFileAreaSize; - size_t page_size = getpagesize(); - size_t padding = (((size_t)(bytes_to_write + page_size - 1) / page_size) * page_size - bytes_to_write); - if (verbose) - clasp_write_string(fmt::format("Writing {} bytes of object files\n", bytes_to_write)); - fwrite((const void*)((const char*)mmaps[mmi]._Memory + mmaps[mmi]._ObjectFileAreaStart), bytes_to_write, 1, fout); - if (verbose) - clasp_write_string(fmt::format("Writing {} bytes of padding\n", padding)); - for (size_t pi = 0; pi < padding; ++pi) { - fwrite(&pad, 1, 1, fout); - } - size_t mmap_size = mmaps[mmi]._ObjectFileAreaStart + mmaps[mmi]._ObjectFileAreaSize; - int res = munmap(mmaps[mmi]._Memory, mmap_size); - if (res != 0) { - SIMPLE_ERROR("Could not munmap memory"); - } - } - if (verbose) - clasp_write_string(fmt::format("Closing {}\n", _rep_(filename))); - fclose(fout); - if (verbose) - clasp_write_string(fmt::format("Returning {}\n", _rep_(filename))); -} - DOCGROUP(clasp); CL_LAMBDA(path-designator &optional (verbose *load-verbose*) (print t) (external-format :default)); CL_DEFUN core::T_sp core__load_fasoll(T_sp pathDesig, T_sp verbose, T_sp print, T_sp external_format) { @@ -747,52 +497,6 @@ CL_DEFUN core::T_sp core__load_fasobc(T_sp pathDesig, T_sp verbose, T_sp print, return _lisp->_true(); } -DOCGROUP(clasp); -CL_LAMBDA(path-designator &optional (verbose *load-verbose*) (print t) (external-format :default)); -CL_DEFUN core::T_sp core__load_faso(T_sp pathDesig, T_sp verbose, T_sp print, T_sp external_format) { - String_sp sfilename = gc::As(cl__namestring(pathDesig)); - std::string filename = sfilename->get_std_string(); - int fd = open(filename.c_str(), O_RDONLY); - off_t fsize = lseek(fd, 0, SEEK_END); - lseek(fd, 0, SEEK_SET); - void* memory = mmap(NULL, fsize, PROT_READ, MAP_SHARED | MAP_FILE, fd, 0); - if (memory == MAP_FAILED) { - close(fd); - SIMPLE_ERROR("Could not mmap {} because of {}", _rep_(pathDesig), strerror(errno)); - } - close(fd); // Ok to close file descriptor after mmap - llvmo::ClaspJIT_sp jit = gc::As(_lisp->_Roots._ClaspJIT); - FasoHeader* header = (FasoHeader*)memory; - if (header->_Version != FASO_VERSION) - SIMPLE_ERROR("FASO version {:04x} is not readable by this loader", header->_Version); - llvmo::JITDylib_sp jitDylib; - for (size_t fasoIndex = 0; fasoIndex < header->_NumberOfObjectFiles; ++fasoIndex) { - if (!jitDylib || header->_ObjectFiles[fasoIndex]._ObjectId == 0) { - jitDylib = jit->createAndRegisterJITDylib(filename); - } - void* of_start = (void*)((char*)header + header->_ObjectFiles[fasoIndex]._StartPage * header->_PageSize); - size_t of_length = header->_ObjectFiles[fasoIndex]._ObjectFileSize; - if (print.notnilp()) - clasp_write_string(fmt::format("{}:{} Adding faso {} object file {} to jit\n", __FILE__, __LINE__, filename, fasoIndex)); - llvm::StringRef sbuffer((const char*)of_start, of_length); - stringstream tryUniqueName; - tryUniqueName << filename << "-" << header->_ObjectFiles[fasoIndex]._ObjectId; - std::string uniqueName = llvmo::ensureUniqueMemoryBufferName(tryUniqueName.str()); - llvm::StringRef name(uniqueName); - std::unique_ptr memoryBuffer(llvm::MemoryBuffer::getMemBuffer(sbuffer, name, false)); - [[maybe_unused]] llvmo::ObjectFile_sp objectFile = - jit->addObjectFile(jitDylib, std::move(memoryBuffer), print.notnilp(), header->_ObjectFiles[fasoIndex]._ObjectId); - // printf("%s:%d:%s addObjectFile objectFile = %p badge: 0x%0x jitDylib = %p\n", __FILE__, __LINE__, __FUNCTION__, - // objectFile.raw_(), lisp_badge(objectFile), jitDylib.raw_()); - T_mv startupName = core__startup_linkage_shutdown_names(header->_ObjectFiles[fasoIndex]._ObjectId, nil()); - String_sp startupName_str = gc::As(startupName); - DEBUG_OBJECT_FILES_PRINT( - ("%s:%d:%s running startup %s\n", __FILE__, __LINE__, __FUNCTION__, startupName_str->get_std_string().c_str())); - jit->runStartupCode(jitDylib, startupName_str->get_std_string(), unbound()); - } - return _lisp->_true(); -} - int global_jit_pid = -1; FILE* global_jit_log_stream = NULL; bool global_jit_log_symbols = false; @@ -838,102 +542,6 @@ CL_DEFUN void core__jit_register_symbol(const std::string& name, size_t size, vo } } -DOCGROUP(clasp); -CL_DEFUN core::T_sp core__describe_faso(T_sp pathDesig) { - String_sp filename = gc::As(cl__namestring(pathDesig)); - int fd = open(filename->get_std_string().c_str(), O_RDONLY); - off_t fsize = lseek(fd, 0, SEEK_END); - lseek(fd, 0, SEEK_SET); - void* memory = mmap(NULL, fsize, PROT_READ, MAP_SHARED | MAP_FILE, fd, 0); - if (memory == MAP_FAILED) { - close(fd); - SIMPLE_ERROR("Could not mmap {} because of {}", _rep_(pathDesig), strerror(errno)); - } - FasoHeader* header = (FasoHeader*)memory; - clasp_write_string(fmt::format("NumberOfObjectFiles {}\n", header->_NumberOfObjectFiles)); - for (size_t fasoIndex = 0; fasoIndex < header->_NumberOfObjectFiles; ++fasoIndex) { - // clasp_write_string(fmt::format("Adding faso {} object file {} to jit\n" , _rep_(filename) , fasoIndex)); - clasp_write_string(fmt::format("Object file {} ObjectId: {} start-page: {} bytes: {} pages: {}\n", fasoIndex, - header->_ObjectFiles[fasoIndex]._ObjectId, header->_ObjectFiles[fasoIndex]._StartPage, - header->_ObjectFiles[fasoIndex]._ObjectFileSize, - header->_ObjectFiles[fasoIndex]._NumberOfPages)); - } - return _lisp->_true(); -} - -void clasp_unpack_faso(const std::string& path_designator) { - size_t pos = path_designator.find_last_of('.'); - if (pos == std::string::npos) { - SIMPLE_ERROR("Could not find extension in path: {}", path_designator); - } - std::string prefix = path_designator.substr(0, pos); - int fd = open(path_designator.c_str(), O_RDONLY); - off_t fsize = lseek(fd, 0, SEEK_END); - lseek(fd, 0, SEEK_SET); - void* memory = mmap(NULL, fsize, PROT_READ, MAP_SHARED | MAP_FILE, fd, 0); - if (memory == MAP_FAILED) { - close(fd); - SIMPLE_ERROR("Could not mmap {} because of {}", path_designator, strerror(errno)); - } - FasoHeader* header = (FasoHeader*)memory; - printf("NumberOfObjectFiles %lu\n", header->_NumberOfObjectFiles); - for (size_t fasoIndex = 0; fasoIndex < header->_NumberOfObjectFiles; ++fasoIndex) { - void* of_start = (void*)((char*)header + header->_ObjectFiles[fasoIndex]._StartPage * header->_PageSize); - size_t of_length = header->_ObjectFiles[fasoIndex]._ObjectFileSize; - stringstream sfilename; - sfilename << prefix << "-" << fasoIndex << "-" << header->_ObjectFiles[fasoIndex]._ObjectId << ".o"; - FILE* fout = fopen(sfilename.str().c_str(), "w"); - fwrite(of_start, of_length, 1, fout); - fclose(fout); - printf("Object file[%lu] ObjectId: %lu start-page: %lu bytes: %lu pages: %lu\n", fasoIndex, - header->_ObjectFiles[fasoIndex]._ObjectId, header->_ObjectFiles[fasoIndex]._StartPage, - header->_ObjectFiles[fasoIndex]._ObjectFileSize, header->_ObjectFiles[fasoIndex]._NumberOfPages); - } -} - -CL_DOCSTRING(R"dx(Unpack the faso file into individual object files.)dx"); -DOCGROUP(clasp); -CL_DEFUN void core__unpack_faso(T_sp path_designator) { - Pathname_sp pn_filename = cl__pathname(path_designator); - String_sp sname = gc::As(cl__namestring(pn_filename)); - clasp_unpack_faso(sname->get_std_string()); -} - -CL_LAMBDA(name &optional verbose print external-format); -CL_DOCSTRING(R"dx(load-binary-directory - load a binary file inside the directory)dx"); -DOCGROUP(clasp); -CL_DEFUN T_mv core__load_binary_directory(T_sp pathDesig, T_sp verbose, T_sp print, T_sp external_format) { - T_sp tpath; - String_sp nameStr = gc::As(cl__namestring(cl__probe_file(pathDesig))); - string name = nameStr->get_std_string(); - if (name[name.size() - 1] == '/') { - // strip last slash - name = name.substr(0, name.size() - 1); - } - struct stat stat_path; - stat(name.c_str(), &stat_path); - if (S_ISDIR(stat_path.st_mode) != 0) { - // - // If the fasl name is a directory it has the structure... - // /foo/bar/baz.fasl change this to... - // /foo/bar/baz.fasl/baz.fasl - size_t slash_pos = name.find_last_of('/', name.size() - 1); - if (slash_pos != std::string::npos) { - name = name + "/fasl.fasl"; - SimpleBaseString_sp sbspath = SimpleBaseString_O::make(name); - tpath = cl__pathname(sbspath); - if (cl__probe_file(tpath).nilp()) { - SIMPLE_ERROR("Could not find bundle {}", _rep_(sbspath)); - } - } else { - SIMPLE_ERROR("Could not open {} as a fasl file", name); - } - } else { - SIMPLE_ERROR("Could not find bundle {}", _rep_(pathDesig)); - } - return core__load_binary(tpath, verbose, print, external_format); -} - void startup_shutdown_names(size_t id, const std::string& prefix, std::string& start, std::string& shutdown) { stringstream sstart; stringstream sshutdown; @@ -975,12 +583,6 @@ CL_DEFUN T_mv core__startup_linkage(size_t id, core::T_sp prefix) { return Values(result1, result2); } -CL_LAMBDA(name &optional verbose print external-format); -CL_DECLARE(); -CL_DOCSTRING(R"dx(load-binary)dx"); -DOCGROUP(clasp); -CL_DEFUN T_mv core__load_binary(T_sp pathDesig, T_sp verbose, T_sp print, T_sp external_format) { DEPRECATED(); }; - // ----------------------------------------------------------------------------- // ----------------------------------------------------------------------------- std::tuple do_dlopen(const string& str_path, const int n_mode) { @@ -1213,6 +815,11 @@ CL_DEFUN T_mv core__progv_function(List_sp symbols, List_sp values, Function_sp return fprogv(symbols, values, [&]() { return eval::funcall(func); }); } +CL_DEFUN T_mv core__progv_env_function(T_sp env, List_sp symbols, List_sp values, + Function_sp thunk) { + return fprogv_env(env, symbols, values, [&]() { return eval::funcall(thunk); }); +} + DOCGROUP(clasp); CL_DEFUN T_mv core__declared_global_inline_p(T_sp name) { return gc::As(_sym_STARfunctions_to_inlineSTAR->symbolValue())->gethash(name); @@ -1245,12 +852,6 @@ CL_DEFUN T_sp core__run_function(T_sp object) { return nil(); } -DOCGROUP(clasp); -CL_DEFUN T_sp core__run_make_mlf(T_sp object) { return core__run_function(object); } - -DOCGROUP(clasp); -CL_DEFUN T_sp core__run_init_mlf(T_sp object) { return core__run_function(object); } - DOCGROUP(clasp); CL_DEFUN T_sp core__make_builtin_class(T_sp object) { printf("%s:%d:%s with %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(object).c_str()); @@ -1265,466 +866,6 @@ SYMBOL_SC_(CorePkg, dlsym); SYMBOL_SC_(CorePkg, dladdr); SYMBOL_EXPORT_SC_(CorePkg, callWithVariableBound); -template char document() { return '\0'; }; -template <> char document() { return 'c'; }; -template <> char document() { return 'z'; }; -template <> char document() { return 'S'; }; -template <> char document() { return 'O'; }; -#ifdef CLASP_SHORT_FLOAT -template <> char document() { return 's'; }; -#endif -template <> char document() { return 'f'; }; -template <> char document() { return 'd'; }; -#ifdef CLASP_LONG_FLOAT -template <> char document() { return 'l'; }; -#endif -template <> char document() { return 'f'; }; - -char ll_read_char(T_sp stream, bool log, size_t& index) { - while (1) { - char c = stream_read_char(stream); - if (c == '!') { - std::string msg; - char d; - do { - d = stream_read_char(stream); - if (d != '!') { - msg += d; - } - index++; - } while (d != '!'); - if (log) - printf("%s:%d byte-code message: %s\n", __FILE__, __LINE__, msg.c_str()); - } else - return c; - } -} - -#if 0 -#define SELF_DOCUMENT(ty, stream, index) \ - { \ - char _xx = document(); \ - stream_write_char(stream, _xx); \ - ++index; \ - } -#define SELF_CHECK(ty, stream, index) \ - { \ - char _xx = document(); \ - claspCharacter _cc = ll_read_char(stream, log, index); \ - ++index; \ - if (_xx != _cc) \ - SIMPLE_ERROR("Mismatch of ltvc read types read '%c' expected '%c'", _cc, _xx); \ - } -#else -#define SELF_DOCUMENT(ty, stream, index) \ - {} -#define SELF_CHECK(ty, stream, index) \ - {} -#endif - -DOCGROUP(clasp); -CL_DEFUN size_t core__ltvc_write_char(T_sp object, T_sp stream, size_t index) { - SELF_DOCUMENT(char, stream, index); - if (object.fixnump()) { - stream_write_char(stream, object.unsafe_fixnum() & 0xff); - ++index; - } else if (object.characterp()) { - stream_write_char(stream, object.unsafe_character()); - ++index; - } else { - SIMPLE_ERROR("Expected fixnum or character - got {}", _rep_(object)); - } - return index; -} - -char ltvc_read_char(char*& bytecode, char* byteend, bool log) { - if (bytecode >= byteend) - SIMPLE_ERROR("Unexpected EOF"); // FIXME - char c = *bytecode++; - if (log) - printf("%s:%d:%s -> '%c'/%d\n", __FILE__, __LINE__, __FUNCTION__, c, c); - return c; -} - -void compact_write_size_t(size_t data, T_sp stream, size_t& index) { - int64_t nb = 0; - for (nb = sizeof(data) - 1; nb >= 0; nb--) { - if (((char*)&data)[nb] != '\0') - break; - } - nb += 1; - stream_write_char(stream, '0' + nb); - clasp_write_characters((char*)&data, nb, stream); - index += nb + 1; -} - -size_t compact_read_size_t(char*& bytecode, char* byteend) { - if (bytecode >= byteend) - SIMPLE_ERROR("Unexpected EOF"); // FIXME - size_t data = 0; - int64_t nb = *bytecode++ - '0'; - if (nb < 0 || nb > 8) { - printf("%s:%d Illegal size_t size %lld\n", __FILE__, __LINE__, (long long)nb); - abort(); - } - if (bytecode > byteend - nb) - SIMPLE_ERROR("Unexpected EOF"); - for (size_t ii = 0; ii < nb; ++ii) { - ((char*)&data)[ii] = *bytecode++; - } - return data; -} - -DOCGROUP(clasp); -CL_DEFUN size_t core__ltvc_write_size_t(T_sp object, T_sp stream, size_t index) { - SELF_DOCUMENT(size_t, stream, index); - size_t data = clasp_to_size_t(object); - compact_write_size_t(data, stream, index); - return index; -} - -size_t ltvc_read_size_t(char*& bytecode, char* byteend, bool log) { - size_t data = compact_read_size_t(bytecode, byteend); - if (log) - printf("%s:%d:%s -> %lu\n", __FILE__, __LINE__, __FUNCTION__, data); - return data; -} - -DOCGROUP(clasp); -CL_DEFUN size_t core__ltvc_write_string(T_sp object, T_sp stream, size_t index) { - SELF_DOCUMENT(char*, stream, index); - std::string str = gc::As(object)->get_std_string(); - index = core__ltvc_write_size_t(make_fixnum(str.size()), stream, index); - clasp_write_characters((char*)str.c_str(), str.size(), stream); - index += str.size(); - return index; -} - -std::string ltvc_read_string(char*& bytecode, char* byteend, bool log) { - // SELF_CHECK(char *, stream, index); - size_t len = ltvc_read_size_t(bytecode, byteend, log); - if (bytecode > byteend - len) - SIMPLE_ERROR("Unexpected EOF"); // FIXME - std::string str(len, ' '); - for (size_t i = 0; i < len; ++i) { - str[i] = *bytecode++; - } - if (log) - printf("%s:%d:%s -> \"%s\"\n", __FILE__, __LINE__, __FUNCTION__, str.c_str()); - return str; -} - -DOCGROUP(clasp); -CL_DEFUN size_t core__ltvc_write_bignum(T_sp object, T_sp stream, size_t index) { - SELF_DOCUMENT(long long, stream, index); - core::Bignum_sp bignum = gc::As(object); - mp_size_t length = bignum->length(); - const mp_limb_t* limbs = bignum->limbs(); - compact_write_size_t(length, stream, index); - for (mp_size_t i = 0; i < std::abs(length); i++) - compact_write_size_t(limbs[i], stream, index); - return index; -} - -T_O* ltvc_read_bignum(char*& bytecode, char* byteend, bool log) { - // SELF_CHECK(long long, stream, index); - mp_size_t length = compact_read_size_t(bytecode, byteend); - size_t size = std::abs(length); - mp_limb_t limbs[size]; - for (mp_size_t i = 0; i < size; i++) { - limbs[i] = compact_read_size_t(bytecode, byteend); - } - return reinterpret_cast(Bignum_O::create_from_limbs(length, 0, false, size, limbs).raw_()); -} - -#ifdef CLASP_SHORT_FLOAT -DOCGROUP(clasp); -CL_DEFUN size_t core__ltvc_write_short_float(T_sp object, T_sp stream, size_t index) { - SELF_DOCUMENT(long_short_t, stream, index); - uint16_t bits = float_convert::float_to_bits(object.unsafe_short_float()); - clasp_write_characters((char*)bits, 2, stream); - index += 2; - return index; - - clasp_write_characters((char*)&data, sizeof(data), stream); - index += sizeof(data); - return index; -} -#endif - -short_float_t ltvc_read_binary16(char*& bytecode, char* byteend, bool log) { - SELF_CHECK(short_float_t, stream, index); - using convert = float_convert; - uint16_t bits = 0; - if (bytecode > byteend - 2) - SIMPLE_ERROR("Unexpected EOF"); - for (size_t i = 0; i < 2; ++i) { - ((char*)&bits)[i] = *bytecode++; - } - if (log) - fmt::print("{}:{}:{} -> '{}'\n", __FILE__, __LINE__, __FUNCTION__, bits); -#ifdef CLASP_SHORT_FLOAT_BINARY16 - return convert::bits_to_float(bits); -#else - return convert::quadruple_to_float(convert::bits_to_quadruple>(bits)); -#endif -} - -DOCGROUP(clasp); -CL_DEFUN size_t core__ltvc_write_float(T_sp object, T_sp stream, size_t index) { - SELF_DOCUMENT(float, stream, index); - if (object.single_floatp()) { - float data = object.unsafe_single_float(); - clasp_write_characters((char*)&data, sizeof(data), stream); - index += sizeof(data); - } else { - SIMPLE_ERROR("Expected single-float got {}", _rep_(object)); - } - return index; -} - -float ltvc_read_float(char*& bytecode, char* byteend, bool log) { - // SELF_CHECK(float, stream, index); - float data; - if (bytecode > byteend - sizeof(data)) - SIMPLE_ERROR("Unexpected EOF"); - for (size_t i = 0; i < sizeof(data); ++i) { - ((char*)&data)[i] = *bytecode++; - } - if (log) - printf("%s:%d:%s -> '%f'\n", __FILE__, __LINE__, __FUNCTION__, data); - return data; -} - -DOCGROUP(clasp); -CL_DEFUN size_t core__ltvc_write_double(T_sp object, T_sp stream, size_t index) { - SELF_DOCUMENT(double, stream, index); - double data = gc::As(object)->get(); - clasp_write_characters((char*)&data, sizeof(data), stream); - index += sizeof(data); - return index; -} - -double ltvc_read_double(char*& bytecode, char* byteend, bool log) { - SELF_CHECK(double, stream, index); - double data; - if (bytecode > byteend - sizeof(data)) - SIMPLE_ERROR("Unexpected EOF"); - for (size_t i = 0; i < sizeof(data); ++i) { - ((char*)&data)[i] = *bytecode++; - } - if (log) - printf("%s:%d:%s -> '%lf'\n", __FILE__, __LINE__, __FUNCTION__, data); - return data; -} - -#ifdef CLASP_LONG_FLOAT -DOCGROUP(clasp); -CL_DEFUN size_t core__ltvc_write_long_float(T_sp object, T_sp stream, size_t index) { - SELF_DOCUMENT(long_float_t, stream, index); -#ifdef CLASP_LONG_FLOAT_BINARY80 - constexpr size_t width = 10; -#else - constexpr size_t width = 16; -#endif - unsigned _BitInt(width * 8) bits = float_convert::float_to_bits(gc::As(object)->get()); - clasp_write_characters((char*)&bits, width, stream); - index += width; - return index; -} -#endif - -long_float_t ltvc_read_binary80(char*& bytecode, char* byteend, bool log) { - SELF_CHECK(long_float_t, stream, index); - using convert = float_convert; - unsigned _BitInt(80) bits = 0; - if (bytecode > byteend - 10) - SIMPLE_ERROR("Unexpected EOF"); - for (size_t i = 0; i < 10; ++i) { - ((char*)&bits)[i] = *bytecode++; - } - if (log) - fmt::print("{}:{}:{} -> '{}'\n", __FILE__, __LINE__, __FUNCTION__, (__uint128_t)bits); -#ifdef CLASP_LONG_FLOAT_BINARY80 - return convert::bits_to_float(bits); -#else - return convert::quadruple_to_float(convert::bits_to_quadruple>(bits)); -#endif -} - -long_float_t ltvc_read_binary128(char*& bytecode, char* byteend, bool log) { - SELF_CHECK(long_float_t, stream, index); - using convert = float_convert; - unsigned _BitInt(128) bits = 0; - if (bytecode > byteend - 16) - SIMPLE_ERROR("Unexpected EOF"); - for (size_t i = 0; i < 16; ++i) { - ((char*)&bits)[i] = *bytecode++; - } - if (log) - fmt::print("{}:{}:{} -> '{}'\n", __FILE__, __LINE__, __FUNCTION__, (__uint128_t)bits); -#ifdef CLASP_LONG_FLOAT_BINARY128 - return convert::bits_to_float(bits); -#else - return convert::quadruple_to_float(convert::bits_to_quadruple>(bits)); -#endif -} - -CL_DOCSTRING(R"dx(tag is (0|1|2) where 0==literal, 1==transient, 2==immediate)dx"); -DOCGROUP(clasp); -CL_DEFUN size_t core__ltvc_write_object(T_sp ttag, T_sp index_or_immediate, T_sp stream, size_t index) { - SELF_DOCUMENT(T_O*, stream, index); - if (ttag.characterp() && (ttag.unsafe_character() == 'l' || ttag.unsafe_character() == 't' || ttag.unsafe_character() == 'i')) { - char tag = ttag.unsafe_character(); - stream_write_char(stream, tag); - index += 1; - size_t data; - if (ttag.unsafe_character() == 'l' || ttag.unsafe_character() == 't') { - data = index_or_immediate.unsafe_fixnum(); - } else { - // Immediate data. - // Note that the immediate may be signed, so we have to convert - // it to an unsigned like this. - data = clasp_to_ssize_t(index_or_immediate); - } - compact_write_size_t(data, stream, index); - return index; - } - SIMPLE_ERROR("tag must be 0, 1 or 2 - you passed {}", _rep_(ttag)); -} - -T_O* ltvc_read_object(gctools::GCRootsInModule* roots, char*& bytecode, char* byteend, bool log) { - // SELF_CHECK(T_O *, stream, index); - if (bytecode >= byteend) - SIMPLE_ERROR("Unexpected EOF"); - char tag = *bytecode++; - char ttag; - if (tag == 'l') - ttag = 0; // literal - else if (tag == 't') - ttag = 1; // transient - else if (tag == 'i') - ttag = 2; // immediate - else { - printf("%s:%d The object tag must be 'l', 't' or 'i'\n", __FILE__, __LINE__); - abort(); - } - if (log) - printf("%s:%d:%s tag = %c\n", __FILE__, __LINE__, __FUNCTION__, tag); - size_t data; - data = compact_read_size_t(bytecode, byteend); - if (log) - printf("%s:%d:%s index = %lu\n", __FILE__, __LINE__, __FUNCTION__, data); - switch (tag) { - case 'l': { - gctools::Tagged val = roots->getLiteral(data); - if (log) { - T_sp o((gctools::Tagged)val); - printf("%s:%d:%s literal -> %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(o).c_str()); - } - return (T_O*)val; - } break; - case 't': { - gctools::Tagged val = roots->getTransient(data); - if (log) { - T_sp o((gctools::Tagged)val); - printf("%s:%d:%s transient -> %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(o).c_str()); - } - return (T_O*)val; - } break; - case 'i': { - gctools::Tagged val = (gctools::Tagged)data; - if (log) { - T_sp o((gctools::Tagged)val); - printf("%s:%d:%s immediate -> %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(o).c_str()); - } - return (T_O*)val; - } - default: { - SIMPLE_ERROR("Could not read an object for using tag {} data {}", tag, data); - }; - }; -} - -Cons_O* ltvc_read_list(gctools::GCRootsInModule* roots, size_t num, char*& bytecode, char* byteend, bool log) { - ql::list result; - for (size_t ii = 0; ii < num; ++ii) { - T_sp obj((gctools::Tagged)ltvc_read_object(roots, bytecode, byteend, log)); - result << obj; - } - if (log) { - printf("%s:%d:%s list -> %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(result.cons()).c_str()); - } - return (Cons_O*)result.cons().tagged_(); -} - -void ltvc_fill_list_varargs(gctools::GCRootsInModule* roots, T_O* list, size_t len, Cons_O* varargs) { - // Copy the vargs list into the ltv one. - // FIXME: This is obviously inefficient. - T_sp cur((gctools::Tagged)list); - T_sp vargs((gctools::Tagged)varargs); - for (; len != 0; --len) { - Cons_sp cur_cons = gc::As(cur); - Cons_sp cur_vargs = gc::As(vargs); - cur_cons->rplaca(cur_vargs->car()); - cur = cur_cons->cdr(); - vargs = cur_vargs->cdr(); - } -} - -void ltvc_mlf_create_basic_call_varargs(gctools::GCRootsInModule* holder, char tag, size_t index, T_O* fname, size_t len, - Cons_O* varargs) { - T_sp tfname((gctools::Tagged)fname); - T_sp tvarargs((gctools::Tagged)varargs); - T_sp val = core__apply0(coerce::calledFunctionDesignator(tfname), tvarargs); - holder->setTaggedIndex(tag, index, val.tagged_()); -} - -void ltvc_mlf_init_basic_call_varargs(gctools::GCRootsInModule* holder, T_O* fname, size_t len, Cons_O* varargs) { - (void)len; // don't need it. - T_sp tfname((gctools::Tagged)fname); - T_sp tvarargs((gctools::Tagged)varargs); - core__apply0(coerce::calledFunctionDesignator(tfname), tvarargs); -} - -#define DEFINE_LTV_PARSERS -#include -#undef DEFINE_LTV_PARSERS - -void start_code_interpreter(gctools::GCRootsInModule* roots, char* bytecode, size_t nbytes, bool log) { - volatile uint32_t i = 0x01234567; - // return 0 for big endian, 1 for little endian. - if ((*((uint8_t*)(&i))) == 0x67) { - // Little endian - the code is set up for this - } else { - printf("%s:%d This is a big-endian architecture and the byte-code interpreter is set up for little-endian - fix this before " - "proceeding\n", - __FILE__, __LINE__); - abort(); - } - char* byteend = bytecode + nbytes; - while (1) { - if (log) { - printf("%s:%d ------- top of byte-code interpreter\n", __FILE__, __LINE__); - } - char c = ltvc_read_char(bytecode, byteend, log); - switch (c) { - case 0: - goto DONE; -#define DEFINE_LTV_SWITCH -#include -#undef DEFINE_LTV_SWITCH - default: { - SIMPLE_ERROR("While loading a faso file an illegal byte-code {} was detected. This usually happens when a faso file " - "is out of date and the byte code has changed in the meantime.", - (int)c); - } - } - } -DONE: - return; -} - void initialize_compiler_primitives(LispPtr lisp) { // Initialize raw object translators needed for Foreign Language Interface support diff --git a/src/core/corePackage.cc b/src/core/corePackage.cc index 78d55d6a65..339d840141 100644 --- a/src/core/corePackage.cc +++ b/src/core/corePackage.cc @@ -47,7 +47,6 @@ THE SOFTWARE. #include #include #include -#include #include #include #include @@ -191,15 +190,12 @@ SYMBOL_EXPORT_SC_(CorePkg, _BANG_unbound_BANG_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_WNOHANG_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_application_name_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_bitcode_name_PLUS_); -SYMBOL_EXPORT_SC_(CorePkg, _PLUS_clasp_ctor_function_name_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_class_name_to_lisp_name_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_executable_name_PLUS_); -SYMBOL_EXPORT_SC_(CorePkg, _PLUS_gcroots_in_module_name_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_io_syntax_progv_list_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_known_typep_predicates_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_literals_name_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_numberOfFixedArguments_PLUS_); -SYMBOL_EXPORT_SC_(CorePkg, _PLUS_run_all_function_name_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_standardReadtable_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_type_header_value_map_PLUS_); SYMBOL_EXPORT_SC_(CorePkg, _PLUS_variant_name_PLUS_); @@ -233,6 +229,7 @@ SYMBOL_EXPORT_SC_(CorePkg, fileExists); SYMBOL_EXPORT_SC_(CorePkg, fillArrayWithElt); SYMBOL_EXPORT_SC_(CorePkg, fillPointerSet); SYMBOL_EXPORT_SC_(CorePkg, fixnump); +SYMBOL_EXPORT_SC_(CorePkg, float_infinity_string); SYMBOL_EXPORT_SC_(CorePkg, foreign_call); SYMBOL_EXPORT_SC_(CorePkg, foreign_call_pointer); SYMBOL_EXPORT_SC_(CorePkg, index); @@ -242,7 +239,6 @@ SYMBOL_EXPORT_SC_(CorePkg, lambdaName); SYMBOL_EXPORT_SC_(CorePkg, loadSource); SYMBOL_EXPORT_SC_(CorePkg, load_binary); SYMBOL_EXPORT_SC_(CorePkg, load_bytecode); -SYMBOL_EXPORT_SC_(CorePkg, load_faso); SYMBOL_EXPORT_SC_(CorePkg, load_fasobc); SYMBOL_EXPORT_SC_(CorePkg, load_fasoll); SYMBOL_EXPORT_SC_(CorePkg, localGo); @@ -547,8 +543,6 @@ void CoreExposer_O::define_essential_globals(LispPtr lisp) { _sym_STARbuild_stlibSTAR->defconstant(SimpleBaseString_O::make(BUILD_STLIB)); _sym_STARbuild_linkflagsSTAR->defconstant(SimpleBaseString_O::make(BUILD_LINKFLAGS)); _sym_STARbuild_cppflagsSTAR->defconstant(SimpleBaseString_O::make(BUILD_CPPFLAGS)); - _sym__PLUS_run_all_function_name_PLUS_->defconstant(SimpleBaseString_O::make(RUN_ALL_FUNCTION_NAME)); - _sym__PLUS_clasp_ctor_function_name_PLUS_->defconstant(SimpleBaseString_O::make(CLASP_CTOR_FUNCTION_NAME)); SYMBOL_SC_(CorePkg, cArgumentsLimit); _sym_cArgumentsLimit->defconstant(make_fixnum(Lisp::MaxFunctionArguments)); _sym_STARdebugMacroexpandSTAR->defparameter(nil()); @@ -633,8 +627,6 @@ void CoreExposer_O::define_essential_globals(LispPtr lisp) { // could sniff the magic number before we dispatch on pathname type, but this is inefficient since // it results in two file opens. If we had only one FASL format this wouldn't be an issue. hooks = Cons_O::create(Cons_O::create(SimpleBaseString_O::make("fasl"), _sym_load_bytecode), hooks); - hooks = Cons_O::create(Cons_O::create(clasp_make_fixnum(FASO_MAGIC_NUMBER), _sym_load_faso), hooks); - hooks = Cons_O::create(Cons_O::create(SimpleBaseString_O::make("faso"), _sym_load_faso), hooks); hooks = Cons_O::create(Cons_O::create(SimpleBaseString_O::make("fasoll"), _sym_load_fasoll), hooks); hooks = Cons_O::create(Cons_O::create(SimpleBaseString_O::make("fasobc"), _sym_load_fasobc), hooks); hooks = Cons_O::create(Cons_O::create(SimpleBaseString_O::make("l"), _sym_loadSource), hooks); @@ -674,7 +666,6 @@ void CoreExposer_O::define_essential_globals(LispPtr lisp) { _sym_STARallow_with_interruptsSTAR->defparameter(_lisp->_true()); _sym_STARexit_backtraceSTAR->defparameter(nil()); clos::_sym__PLUS_the_standard_class_PLUS_->defparameter(_lisp->_Roots._TheStandardClass); - core::_sym__PLUS_gcroots_in_module_name_PLUS_->defparameter(SimpleBaseString_O::make(GCROOTS_IN_MODULE_NAME)); core::_sym__PLUS_literals_name_PLUS_->defparameter(SimpleBaseString_O::make(LITERALS_NAME)); _sym_STARdebug_threadsSTAR->defparameter(nil()); _sym_STARdebug_fastgfSTAR->defparameter(nil()); @@ -693,20 +684,16 @@ void CoreExposer_O::define_essential_globals(LispPtr lisp) { _sym_STARnumber_of_entry_pointsSTAR->defparameter(make_fixnum(NUMBER_OF_ENTRY_POINTS)); _sym_STARcore_startup_functionSTAR->defparameter(nil()); comp::_sym_STARcompile_file_parallelSTAR->defparameter(nil()); -#ifdef DEFAULT_OUTPUT_TYPE_FASO - comp::_sym_STARdefault_output_typeSTAR->defparameter(kw::_sym_faso); -#endif #ifdef DEFAULT_OUTPUT_TYPE_FASOLL comp::_sym_STARdefault_output_typeSTAR->defparameter(kw::_sym_fasoll); #endif #ifdef DEFAULT_OUTPUT_TYPE_FASOBC comp::_sym_STARdefault_output_typeSTAR->defparameter(kw::_sym_fasobc); #endif -#ifdef DEFAULT_OUTPUT_TYPE_BYTECODE +#if defined(DEFAULT_OUTPUT_TYPE_BYTECODE) || defined(DEFAULT_OUTPUT_TYPE_FASO) comp::_sym_STARdefault_output_typeSTAR->defparameter(kw::_sym_bytecode); #endif comp::_sym_STARforce_startup_external_linkageSTAR->defparameter(nil()); - gctools::_sym_STARdebug_gcrootsSTAR->defparameter(nil()); #ifdef DEBUG_LLVM_OPTIMIZATION_LEVEL_0 int optimization_level = 0; #else diff --git a/src/core/eclector_readtable.cc b/src/core/eclector_readtable.cc index 4b5b88d6f0..9ab7d69c7d 100644 --- a/src/core/eclector_readtable.cc +++ b/src/core/eclector_readtable.cc @@ -45,7 +45,6 @@ SYMBOL_EXPORT_SC_(EclectorReadtablePkg, copy_readtable); SYMBOL_EXPORT_SC_(EclectorReadtablePkg, copy_readtable_into); SYMBOL_EXPORT_SC_(EclectorReadtablePkg, make_dispatch_macro_character); SYMBOL_EXPORT_SC_(EclectorReadtablePkg, readtable_case); -SYMBOL_EXPORT_SC_(EclectorReadtablePkg, setf_readtable_case); SYMBOL_EXPORT_SC_(EclectorReadtablePkg, set_syntax_from_char); SYMBOL_EXPORT_SC_(EclectorReadtablePkg, readtablep); }; // namespace eclector_readtable diff --git a/src/core/extensionPackage.cc b/src/core/extensionPackage.cc index 654ee21e26..d4376aadb0 100644 --- a/src/core/extensionPackage.cc +++ b/src/core/extensionPackage.cc @@ -56,7 +56,6 @@ SYMBOL_EXPORT_SC_(ExtPkg, compiledFunctionName); SYMBOL_EXPORT_SC_(ExtPkg, constant_form_value); SYMBOL_EXPORT_SC_(ExtPkg, decoding_error); SYMBOL_EXPORT_SC_(ExtPkg, encoding_error); -SYMBOL_EXPORT_SC_(ExtPkg, float_infinity_string); SYMBOL_EXPORT_SC_(ExtPkg, float_nan_string); SYMBOL_EXPORT_SC_(ExtPkg, lambda_block); SYMBOL_EXPORT_SC_(ExtPkg, lexicalVar); diff --git a/src/core/fli.cc b/src/core/fli.cc index 41c214aea1..a73ee3fe8d 100644 --- a/src/core/fli.cc +++ b/src/core/fli.cc @@ -297,12 +297,6 @@ inline void register_foreign_types(void) { CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, unsigned_long_long, unsigned long long, kw::_sym_unsigned_long_long, "unsigned long long"); CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, unsigned_char, unsigned char, kw::_sym_unsigned_char, "unsigned char"); - CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, uchar, unsigned char, kw::_sym_uchar, "uchar"); - CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, ushort, unsigned short, kw::_sym_ushort, "ushort"); - CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, uint, unsigned int, kw::_sym_uint, "uint"); - CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, ulong, unsigned long, kw::_sym_ulong, "ulong"); - CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, llong, long long, kw::_sym_llong, "llong"); - CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, ullong, unsigned long long, kw::_sym_ullong, "ullong"); CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, int8, int8_t, kw::_sym_int8, "int8"); CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, uint8, uint8_t, kw::_sym_uint8, "uint8"); CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, int16, int16_t, kw::_sym_int16, "int16"); @@ -313,7 +307,6 @@ inline void register_foreign_types(void) { CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, uint64, uint64_t, kw::_sym_uint64, "uint64"); CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, double, double, kw::_sym_double, "double"); CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, float, float, kw::_sym_float, "float"); - CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, single_float, float, kw::_sym_single_float, "float"); CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, long_double, long double, kw::_sym_long_double, "long double"); CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, time, time_t, kw::_sym_time, "time"); CLASP_CORE_FLI_REGISTER_FOREIGN_TYPE(sp_tst, n_index++, pointer, void*, kw::_sym_pointer, "pointer"); diff --git a/src/core/float_to_string.cc b/src/core/float_to_string.cc index bf45a6c756..a6915d5f15 100644 --- a/src/core/float_to_string.cc +++ b/src/core/float_to_string.cc @@ -1,4 +1,3 @@ -/* -*- mode: c; c-basic-offset: 8 -*- */ /* Copyright (c) 2010, Juan Jose Garcia Ripoll. @@ -11,6 +10,7 @@ */ #define ECL_INCLUDE_MATH_H +#include #include #include #include @@ -80,7 +80,7 @@ static void print_float_exponent(T_sp buffer, Float_sp number, gc::Fixnum exp) { if (e != 'e' || exp != 0) { StrNs_sp sbuffer = gc::As(buffer); sbuffer->vectorPushExtend(clasp_make_character(e)); - core__integer_to_string(sbuffer, clasp_make_fixnum(exp), clasp_make_fixnum(10), false, false); + core__integer_to_string(sbuffer, clasp_make_fixnum(exp), clasp_make_fixnum(10),false, false); } } @@ -89,7 +89,7 @@ T_sp core_float_to_string_free(Float_sp number, Number_sp e_min, Number_sp e_max if (Float_O::isnan(number)) { return eval::funcall(ext::_sym_float_nan_string, number); } else if (Float_O::isinf(number)) { - return eval::funcall(ext::_sym_float_infinity_string, number); + return eval::funcall(core::_sym_float_infinity_string, number); } T_mv mv_exp = core__float_to_digits(nil(), number, nil(), nil()); Fixnum_sp exp = gc::As_unsafe(mv_exp); @@ -122,4 +122,39 @@ T_sp core_float_to_string_free(Float_sp number, Number_sp e_min, Number_sp e_max } return buffer; } + +// Redefined in print.lisp to respect *print-readably* and *print-eval* +// (Also to not cons a new string every time) +CL_DEFUN T_sp core__float_infinity_string(Float_sp number) { +#ifdef CLASP_SHORT_FLOAT + if (number.short_floatp()) { + if (std::signbit(number.unsafe_short_float())) + return SimpleBaseString_O::make("#.ext:short-float-negative-infinity"); + else + return SimpleBaseString_O::make("#.ext:short-float-positive-infinity"); + } else +#endif + if (number.single_floatp()) { + if (std::signbit(number.unsafe_single_float())) + return SimpleBaseString_O::make("#.ext:single-float-negative-infinity"); + else + return SimpleBaseString_O::make("#.ext:single-float-positive-infinity"); + } else + if (number.isA()) { + if (std::signbit(number.as_unsafe()->get())) + return SimpleBaseString_O::make("#.ext:double-float-negative-infinity"); + else + return SimpleBaseString_O::make("#.ext:double-float-positive-infinity"); + } +#ifdef CLASP_LONG_FLOAT + else if (number.isA()) { + if (std::signbit(number.as_unsafe()->get())) + return SimpleBaseString_O::make("#.ext:long-float-negative-infinity"); + else + return SimpleBaseString_O::make("#.ext:long-float-positive-infinity"); + } +#endif + else SIMPLE_ERROR("Illegal type"); +} + }; // namespace core diff --git a/src/core/foundation.cc b/src/core/foundation.cc index a5aa69b5b4..ed95c34b0b 100644 --- a/src/core/foundation.cc +++ b/src/core/foundation.cc @@ -931,7 +931,7 @@ static Function_sp bytecompile_wrapper(Function_sp entry, List_sp vars, Symbol_s List_sp funcall_form = Cons_O::create(cleavirPrimop::_sym_funcall, Cons_O::create(entry, vars)); List_sp declare_form = Cons_O::createList(cl::_sym_declare, Cons_O::createList(core::_sym_lambdaName, name)); List_sp form = Cons_O::createList(cl::_sym_lambda, lambda_list, declare_form, funcall_form); - return comp::bytecompile(form, comp::Lexenv_O::make_top_level()); + return comp::bytecompile(form, nil()); } void lisp_defineSingleDispatchMethod(T_sp name, Symbol_sp classSymbol, diff --git a/src/core/function.cc b/src/core/function.cc index 309570b76c..f73cf051fb 100644 --- a/src/core/function.cc +++ b/src/core/function.cc @@ -221,21 +221,17 @@ bool CoreFun_O::dladdrablep(std::set& uniques) { return true; } -CL_LAMBDA(&key function-description entry-point-functions local-entry-point-index); +CL_LAMBDA(&key function-description entry-point-functions core-fun-generator); DOCGROUP(clasp); CL_DEFUN SimpleCoreFunGenerator_sp core__makeSimpleCoreFunGenerator(FunctionDescription_sp fdesc, T_sp entryPointIndices, - size_t localEntryPointIndex) { - auto entryPoint = gctools::GC::allocate(fdesc, entryPointIndices, localEntryPointIndex); - // printf("%s:%d:%s entryPoint-> %p\n", __FILE__, __LINE__, __FUNCTION__, (void*)entryPoint.raw_()); - return entryPoint; + CoreFunGenerator_sp cfg) { + return gctools::GC::allocate(fdesc, entryPointIndices, cfg); } CL_LAMBDA(&key function-description entry-point-functions); DOCGROUP(clasp); CL_DEFUN CoreFunGenerator_sp core__makeCoreFunGenerator(FunctionDescription_sp fdesc, T_sp entryPointIndices) { - auto entryPoint = gctools::GC::allocate(fdesc, entryPointIndices); - // printf("%s:%d:%s entryPoint-> %p\n", __FILE__, __LINE__, __FUNCTION__, (void*)entryPoint.raw_()); - return entryPoint; + return gctools::GC::allocate(fdesc, entryPointIndices); } std::string CoreFunGenerator_O::__repr__() const { @@ -268,10 +264,6 @@ std::string SimpleCoreFun_O::__repr__() const { return ss.str(); } -CL_LISPIFY_NAME("simple-core-fun-generator-local-fun-index"); -CL_DEFMETHOD -size_t SimpleCoreFunGenerator_O::coreFunIndex() const { return this->_localFunIndex; } - std::string SimpleCoreFunGenerator_O::__repr__() const { stringstream ss; ss << "#_entry_point_indices.consp()) { - SIMPLE_ERROR("The CoreFun {} does not have entry-points", _rep_(original)); +CL_LISPIFY_NAME("core-fun-generator/generate"); +CL_DEFMETHOD +CoreFun_sp CoreFunGenerator_O::generate(void** entry_points) const { + if (!_entry_point_indices.consp()) { + SIMPLE_ERROR("The CoreFunGenerator {} does not have entry-points", _rep_(this->asSmartPtr())); } - T_sp firstEntryPoint = CONS_CAR(original->_entry_point_indices); + T_sp firstEntryPoint = CONS_CAR(_entry_point_indices); if (!firstEntryPoint.fixnump()) { - SIMPLE_ERROR("The FunctionDescriptionGenerator {} does not have entry-points indices", _rep_(original)); + SIMPLE_ERROR("The CoreFunGenerator {} does not have entry-points indices", _rep_(this->asSmartPtr())); } size_t entryPointIndex = firstEntryPoint.unsafe_fixnum(); ClaspCoreFunction entry_point = (ClaspCoreFunction)(entry_points[entryPointIndex]); @@ -414,16 +408,18 @@ CoreFun_sp makeCoreFunFromGenerator(CoreFunGenerator_sp original, void** entry_p if (entry_point) { code = llvmo::identify_code_or_library(reinterpret_cast(entry_point)); } - auto entryPoint = gctools::GC::allocate(original->_FunctionDescription, code, entry_point); + auto entryPoint = gctools::GC::allocate(_FunctionDescription, code, entry_point); return entryPoint; } -SimpleCoreFun_sp makeSimpleCoreFunFromGenerator(SimpleCoreFunGenerator_sp original, gctools::GCRootsInModule* roots, - void** entry_points) { - if (!original->_entry_point_indices.consp()) { - SIMPLE_ERROR("The SimpleCoreFun {} does not have entry-points", _rep_(original)); +CL_LISPIFY_NAME("simple-core-fun-generator/generate"); +CL_DEFMETHOD +SimpleCoreFun_sp SimpleCoreFunGenerator_O::generate(CoreFun_sp core, + void** entry_points) const { + if (!_entry_point_indices.consp()) { + SIMPLE_ERROR("The SimpleCoreFunGenerator {} does not have entry-points", _rep_(this->asSmartPtr())); } - List_sp epIndices = gc::As(original->_entry_point_indices); + List_sp epIndices = gc::As(_entry_point_indices); size_t num = cl__length(epIndices); if (num != ClaspXepFunction::Entries) { SIMPLE_ERROR("{} is not enough entry_points for a ClaspXepFunction expected {}\n", num, @@ -434,17 +430,16 @@ SimpleCoreFun_sp makeSimpleCoreFunFromGenerator(SimpleCoreFunGenerator_sp origin for (auto entry : epIndices) { T_sp oneEntryPointIndex = CONS_CAR(entry); if (!oneEntryPointIndex.fixnump()) { - SIMPLE_ERROR("The FunctionDescriptionGenerator {} does not have entry-points indices", _rep_(original)); + SIMPLE_ERROR("The SimpleCoreFunGenerator {} does not have entry-points indices", _rep_(this->asSmartPtr())); } size_t entryPointIndex = oneEntryPointIndex.unsafe_fixnum(); ClaspXepAnonymousFunction entry_point = (ClaspXepAnonymousFunction)(entry_points[entryPointIndex]); xepFunction._EntryPoints[cur] = entry_point; cur++; } - CoreFun_sp localFun((gctools::Tagged)roots->getLiteral(original->_localFunIndex)); T_sp code = unbound(); code = llvmo::identify_code_or_library(reinterpret_cast(xepFunction._EntryPoints[0])); - return gctools::GC::allocate(original->_FunctionDescription, xepFunction, code, localFun); + return gctools::GC::allocate(_FunctionDescription, xepFunction, code, core); } DOCGROUP(clasp); @@ -768,6 +763,24 @@ FunctionCell_sp FunctionCell_O::make(T_sp name) { return FunctionCell_O::make(name, cf); } +CL_LISPIFY_NAME(FunctionCell/make); +CL_LAMBDA(name &optional (initial nil initialp)); +CL_DEFUN FunctionCell_sp core__make_function_cell(T_sp name, + T_sp initial, T_sp initialp) { + if (initialp.nilp()) + return FunctionCell_O::make(name); + else + return FunctionCell_O::make(name, initial.as()); +} + +// KLUDGE: We have no CL_DEFMETHOD_SETF, so we do this +CL_LISPIFY_NAME(FunctionCell/function); +CL_DEFUN_SETF Function_sp core__function_cell_set_function(Function_sp nfun, + FunctionCell_sp cell) { + cell->real_function_set(nfun); + return nfun; +} + void FunctionCell_O::fmakunbound(T_sp name) { Closure_sp cf = gctools::GC::allocate_container(false, 1, cachedUnboundSimpleFun(name)); cf[0] = name; diff --git a/src/core/lisp.cc b/src/core/lisp.cc index f93e76583c..005091a6dc 100644 --- a/src/core/lisp.cc +++ b/src/core/lisp.cc @@ -389,7 +389,7 @@ CL_DEFUN void core__set_debug_start_code(T_sp on) { global_debug_start_code = on void Lisp::initializeMainThread() { mp::Process_sp main_process = mp::Process_O::make_process(INTERN_(core, top_level), nil(), _lisp->copy_default_special_bindings(), nil(), 0); - my_thread->initialize_thread(main_process, false); + my_thread->initialize_thread(main_process); } void Lisp::startupLispEnvironment() { @@ -464,6 +464,7 @@ void Lisp::startupLispEnvironment() { _lisp->findPackage(ExtPkg).as()->addImplementationPackage(_lisp->_Roots._CorePackage); _lisp->findPackage(ExtPkg).as()->addImplementationPackage(_lisp->findPackage(ClosPkg).as()); + _lisp->findPackage(ExtPkg).as()->addImplementationPackage(_lisp->findPackage(CompPkg).as()); _lisp->_Roots._CommonLispPackage->setLockedP(true); //_lisp->_Roots._CorePackage->setLockedP(true); @@ -992,6 +993,16 @@ T_sp Lisp::findPackage(const string& name, bool errorp) const { return this->findPackage(SimpleBaseString_O::make(name), errorp); } +T_sp Lisp::findPackageGlobal_no_lock(String_sp name) const { + T_sp fi = this->_Roots._PackageNameIndexMap->gethash(name); + if (fi.nilp()) { + return nil(); // return nil if no package found + } + ASSERT(fi.fixnump()); + Package_sp getPackage = this->_Roots._Packages[fi.unsafe_fixnum()]; + return getPackage; +} + T_sp Lisp::findPackage_no_lock(String_sp name) const { // Check local nicknames first. if (_lisp->_Roots._TheSystemIsUp) { @@ -1000,13 +1011,7 @@ T_sp Lisp::findPackage_no_lock(String_sp name) const { return local; } // OK, now global names. - T_sp fi = this->_Roots._PackageNameIndexMap->gethash(name); - if (fi.nilp()) { - return nil(); // return nil if no package found - } - ASSERT(fi.fixnump()); - Package_sp getPackage = this->_Roots._Packages[fi.unsafe_fixnum()]; - return getPackage; + return this->findPackageGlobal_no_lock(name); } T_sp Lisp::findPackage(String_sp name, bool errorp) const { @@ -1020,6 +1025,17 @@ T_sp Lisp::findPackage(String_sp name, bool errorp) const { PACKAGE_ERROR(name); } +T_sp Lisp::findPackageGlobal(String_sp name, bool errorp) const { + { + WITH_READ_LOCK(globals_->_PackagesMutex); + T_sp res = this->findPackageGlobal_no_lock(name); + if (!errorp || res.isA()) + return res; + } + // Signal the error only after releasing the lock. + PACKAGE_ERROR(name); +} + void Lisp::remove_package(String_sp name) { WITH_READ_WRITE_LOCK(globals_->_PackagesMutex); T_sp fi = this->_Roots._PackageNameIndexMap->gethash(name); @@ -1629,6 +1645,18 @@ CL_DEFUN T_sp cl__find_package(T_sp name_desig) { return _lisp->findPackage(name); } +CL_DEFUN T_sp core__find_package_global(T_sp name_desig) { + // Look up a package, ignoring local nicknames. + // Could also be done as e.g. + // (let ((*package* (find-package "CL"))) (find-package ...)) + // but doing more work in order to do less work is silly. + if (Package_sp pkg = name_desig.asOrNull()) + return pkg; + String_sp name = coerce::stringDesignator(name_desig); + // TODO: Support wide string package names + return _lisp->findPackageGlobal(name); +} + CL_LAMBDA(package-designator); CL_DECLARE(); CL_DOCSTRING(R"dx(selectPackage)dx"); diff --git a/src/core/load.cc b/src/core/load.cc index f0f721896f..3326e65925 100644 --- a/src/core/load.cc +++ b/src/core/load.cc @@ -162,11 +162,7 @@ CL_DEFUN T_sp core__load_no_package_set(T_sp lsource, T_sp verbose, T_sp print, filename = core__coerce_to_file_pathname(pathname); T_sp kind = core__file_kind(gc::As(filename), true); if (kind == kw::_sym_directory) { - ok = core__load_binary_directory(filename, verbose, print, external_format); - if (ok.nilp()) { - SIMPLE_ERROR("LOAD: Could not load file {}", _rep_(filename)); - } - return _lisp->_true(); + SIMPLE_ERROR("LOAD: Could not load file {}", _rep_(filename)); } if (!pntype.nilp() && (pntype != kw::_sym_wild)) { /* If filename already has an extension, make sure diff --git a/src/core/loadltv.cc b/src/core/loadltv.cc index 1e768a80e9..3b61e2778c 100644 --- a/src/core/loadltv.cc +++ b/src/core/loadltv.cc @@ -79,6 +79,9 @@ struct loadltv { gctools::Vec0 _literals; uint8_t _index_bytes = 1; size_t _next_index = 0; + // native modules + T_sp _JITDylib = nil(); + uint16_t _next_native_module = 0; loadltv(Stream_sp stream) : _stream(stream) {} @@ -631,7 +634,10 @@ struct loadltv { void op_package() { size_t index = next_index(); String_sp name = gc::As(get_ltv(read_index())); - set_ltv(_lisp->findPackage(name, true), index); + // The file compiler only uses global names, so ignore local nicknames. + // This means we can't use this op for user code, e.g. we can't reduce + // (load-time-value (find-package "WHATEVER")) to this op. Careful! + set_ltv(_lisp->findPackageGlobal(name, true), index); } void op_bignum() { @@ -827,21 +833,32 @@ struct loadltv { } void attr_clasp_function_native(uint32_t bytes) { - void *mainptr, *xepptr; - BytecodeSimpleFun_sp fun = gc::As(get_ltv(read_index())); - FunctionDescription_sp fdesc = fun->fdesc(); - std::string mainn = gc::As(get_ltv(read_index()))->get_std_string(); - std::string xepn = gc::As(get_ltv(read_index()))->get_std_string(); - BytecodeModule_sp mod = fun->code(); - llvmo::JITDylib_sp dylib = gc::As(mod->nativeModule()); - // FIXME: Do we need to grab a lock to use the JIT? - llvmo::ClaspJIT_sp jit = gc::As(_lisp->_Roots._ClaspJIT); - if (!jit->do_lookup(dylib, mainn, mainptr)) - // Failed lookup: Maybe a warning? Error right now to debug - SIMPLE_ERROR("Could not find pointer for name |{}|", mainn); - if (!jit->do_lookup(dylib, xepn, xepptr)) - SIMPLE_ERROR("Could not find pointer for name |{}|", xepn); - fun->setSimpleFun(SimpleCoreFun_O::make(fun->fdesc(), (ClaspCoreFunction)mainptr, (ClaspXepAnonymousFunction*)xepptr)); + T_sp tfunction = get_ltv(read_index()); + Function_sp function = tfunction.as(); + uint16_t module_id = read_u16(); + uint16_t corei = read_u16(); + uint16_t xepi = read_u16(); + + llvmo::ClaspJIT_sp jit = _lisp->_Roots._ClaspJIT.as_assert(); + llvmo::JITDylib_sp dylib = _JITDylib.as(); + int fvector_name_len = snprintf(NULL, 0, "function-vector-%d", module_id); + char fvector_name[fvector_name_len+1]; // +1 for null terminator + sprintf(fvector_name, "function-vector-%d", module_id); + void* vfvector; + if (!jit->do_lookup(dylib, fvector_name, vfvector)) + SIMPLE_ERROR("Could not find function vector {}", &fvector_name[0]); + void** fvector = (void**)vfvector; + + CoreFun_sp core = makeCoreFun(function->fdesc(), + (ClaspCoreFunction)fvector[corei]); + + ClaspXepTemplate xep; + for (size_t ii = 0; ii < ClaspXepFunction::Entries; ++ii) + xep._EntryPoints[ii] = (ClaspXepAnonymousFunction)fvector[xepi + ii]; + SimpleCoreFun_sp scf = makeSimpleCoreFun(function->fdesc(), xep, core); + + // Install in the function and we're done. + function->setSimpleFun(scf); } void attr_clasp_source_pos_info(uint32_t bytes) { @@ -993,10 +1010,21 @@ struct loadltv { } void attr_clasp_module_native(uint32_t bytes) { + size_t module_id = _next_native_module++; // FIXME: Do we need to grab a lock to use the JIT? llvmo::ClaspJIT_sp jit = gc::As(_lisp->_Roots._ClaspJIT); BytecodeModule_sp mod = gc::As(get_ltv(read_index())); uint32_t nmc = read_u32(); // machine code length + + // FIXME: Use a better name, I guess? Not sure how much it matters. + std::string uniqueName = llvmo::ensureUniqueMemoryBufferName("bytecode-fasl"); + // Lazily initialize a dylib for this FASL. + if (_JITDylib.nilp()) { + _JITDylib = jit->createAndRegisterJITDylib(uniqueName); + //mod->setf_nativeModule(_JITDylib); + } + llvmo::JITDylib_sp dylib = _JITDylib.as_assert(); + // Read in the machine code. // At the moment all machine code we give to JIT is unmanaged - e.g. // load-faso just mmaps a file and leaves the mmap around forever. // This is the unlinked object code, not the code that actually runs, @@ -1007,23 +1035,33 @@ struct loadltv { stream_read_byte8(_stream, mc, nmc); // read in machine code // Now feed the machine code to the JIT. llvm::StringRef sbuffer((const char*)mc, nmc); - // FIXME: Use a better name, I guess? Not sure how much it matters. - std::string uniqueName = llvmo::ensureUniqueMemoryBufferName("bytecode-fasl"); llvm::StringRef name(uniqueName); - llvmo::JITDylib_sp dylib = jit->createAndRegisterJITDylib(uniqueName); - mod->setf_nativeModule(dylib); std::unique_ptr memoryBuffer(llvm::MemoryBuffer::getMemBuffer(sbuffer, name, false)); llvmo::ObjectFile_sp obj = jit->addObjectFile(dylib, std::move(memoryBuffer), false, 0); + // Loaded the object, so now we just need to stick the literals in. uint16_t nlits = read_u16(); // We can't use the object's TOLiteralsStart because it won't exist before // we actually query the symbol, due to the JIT's laziness. + int namelen = snprintf(NULL, 0, "__clasp_literals_%zu", module_id); + char literals_name[namelen+1]; // +1 for null terminator + sprintf(literals_name, "__clasp_literals_%zu", module_id); void* vlits; - if (!jit->do_lookup(dylib, "__clasp_literals_", vlits)) - SIMPLE_ERROR("Could not find literals"); - T_O** lits = (T_O**)vlits; - for (size_t i = 0; i < nlits; ++i) { - lits[i] = get_ltv(read_index()).raw_(); + if (!jit->do_lookup(dylib, literals_name, vlits)) { + SIMPLE_ERROR("While loading native module: Could not find literals {}", + &literals_name[0]); + } else { + T_O** lits = (T_O**)vlits; + for (size_t i = 0; i < nlits; ++i) { + lits[i] = get_ltv(read_index()).raw_(); + } + /* + uint16_t nfuns = read_u16(); + for (size_t j = 0; j < nfuns; ++j) { + uint16_t corei = read_u16(); + uint16_t xepi = read_u16(); + } +*/ } } @@ -1048,10 +1086,14 @@ struct loadltv { attr_lambda_list(attrbytes); } else if (name == "clasp:function-native") { attr_clasp_function_native(attrbytes); - } else if (name == "clasp:source-pos-info") { + } else if (name == "clasp:source-pos-info" + || name == "source-pos-info") { attr_clasp_source_pos_info(attrbytes); - } else if (name == "clasp:module-debug-info") { + } else if (name == "clasp:module-debug-info" + || name == "module-debug-info") { attr_clasp_module_debug_info(attrbytes); + } else if (name == "clasp:module-mutable-ltv") { + attr_clasp_module_mutable_ltv(attrbytes); } else if (name == "clasp:module-native") { attr_clasp_module_native(attrbytes); } else { @@ -1074,6 +1116,9 @@ struct loadltv { } _next_index = 0; _literals.assign(nobjs, unbound()); + // Also reset the dylib. + _JITDylib = nil(); + _next_native_module = 0; } void load_instruction() { diff --git a/src/core/mpPackage.cc b/src/core/mpPackage.cc index 471a19e1e5..bb44777362 100644 --- a/src/core/mpPackage.cc +++ b/src/core/mpPackage.cc @@ -176,7 +176,7 @@ void Process_O::run(void* cold_end_of_stack) { my_thread_low_level = &thread_local_state_low_level; my_thread = &thread_local_state; my_thread->startUpVM(); - my_thread->initialize_thread(this->asSmartPtr(), true); + my_thread->initialize_thread(this->asSmartPtr()); // my_thread->create_sigaltstack(); _ThreadInfo = my_thread; diff --git a/src/core/numerics.cc b/src/core/numerics.cc index 3f4cd1bf5b..e85ef25894 100644 --- a/src/core/numerics.cc +++ b/src/core/numerics.cc @@ -218,6 +218,14 @@ SYMBOL_EXPORT_SC_(ClPkg, leastPositiveNormalizedSingleFloat); SYMBOL_EXPORT_SC_(ClPkg, leastPositiveNormalizedShortFloat); SYMBOL_EXPORT_SC_(ClPkg, leastPositiveNormalizedDoubleFloat); SYMBOL_EXPORT_SC_(ClPkg, leastPositiveNormalizedLongFloat); +SYMBOL_EXPORT_SC_(ClPkg, singleFloatEpsilon); +SYMBOL_EXPORT_SC_(ClPkg, singleFloatNegativeEpsilon); +SYMBOL_EXPORT_SC_(ClPkg, shortFloatEpsilon); +SYMBOL_EXPORT_SC_(ClPkg, shortFloatNegativeEpsilon); +SYMBOL_EXPORT_SC_(ClPkg, doubleFloatEpsilon); +SYMBOL_EXPORT_SC_(ClPkg, doubleFloatNegativeEpsilon); +SYMBOL_EXPORT_SC_(ClPkg, longFloatEpsilon); +SYMBOL_EXPORT_SC_(ClPkg, longFloatNegativeEpsilon); SYMBOL_EXPORT_SC_(ExtPkg, singleFloatPositiveInfinity); SYMBOL_EXPORT_SC_(ExtPkg, singleFloatNegativeInfinity); SYMBOL_EXPORT_SC_(ExtPkg, shortFloatPositiveInfinity); @@ -228,6 +236,29 @@ SYMBOL_EXPORT_SC_(ExtPkg, longFloatPositiveInfinity); SYMBOL_EXPORT_SC_(ExtPkg, longFloatNegativeInfinity); SYMBOL_EXPORT_SC_(ClPkg, pi); +/* + * The epsilons are weird constants. They are _not_ equivalent to C++'s epsilons: + * C++'s epsilons are the difference between 1 and the next representable float, + * whereas CL's is the smallest positive float that you can add to 1 to get the + * next representable float. (Or subtract, for the negative epsilons.) + * Due to rounding, this defines the epsilons to be a little more than one half + * of the difference between 1 and the next representable float. + * In other words, nextfloat of half the C++ epsilon. The nextfloat/"little more" + * is to ensure we're rounding up. + * Hopefully this makes some sense to you, but it's hella confusing. + * Somewhat cribbed from SBCL which uses this same formulation, but implemented + * with direct manipulation of the float bits, which I'd rather avoid. + * Sidenote/TODO?: When C++23 is available this can be constexpr/consteval. + */ +template +static inline F compute_epsilon(bool negative) { + F ceps = negative + ? F(1) - std::nextafter(F(1), F(0)) + : std::nextafter(F(1), F(2)) - F(1); + F halfceps = std::ldexp(ceps, -1); + return std::nextafter(halfceps, F(1)); +} + void exposeCando_Numerics() { cl::_sym_mostPositiveShortFloat->defconstant(clasp_make_single_float(std::numeric_limits::max())); cl::_sym_mostNegativeShortFloat->defconstant(clasp_make_single_float(-std::numeric_limits::max())); @@ -235,6 +266,8 @@ void exposeCando_Numerics() { cl::_sym_leastNegativeShortFloat->defconstant(clasp_make_single_float(-std::numeric_limits::denorm_min())); cl::_sym_leastNegativeNormalizedShortFloat->defconstant(clasp_make_single_float(-std::numeric_limits::min())); cl::_sym_leastPositiveNormalizedShortFloat->defconstant(clasp_make_single_float(std::numeric_limits::min())); + cl::_sym_shortFloatEpsilon->defconstant(clasp_make_single_float(compute_epsilon(false))); + cl::_sym_shortFloatNegativeEpsilon->defconstant(clasp_make_single_float(compute_epsilon(true))); ext::_sym_shortFloatPositiveInfinity->defconstant(clasp_make_single_float(std::numeric_limits::infinity())); ext::_sym_shortFloatNegativeInfinity->defconstant(clasp_make_single_float(-std::numeric_limits::infinity())); @@ -244,6 +277,8 @@ void exposeCando_Numerics() { cl::_sym_leastNegativeSingleFloat->defconstant(clasp_make_single_float(-std::numeric_limits::denorm_min())); cl::_sym_leastNegativeNormalizedSingleFloat->defconstant(clasp_make_single_float(-std::numeric_limits::min())); cl::_sym_leastPositiveNormalizedSingleFloat->defconstant(clasp_make_single_float(std::numeric_limits::min())); + cl::_sym_singleFloatEpsilon->defconstant(clasp_make_single_float(compute_epsilon(false))); + cl::_sym_singleFloatNegativeEpsilon->defconstant(clasp_make_single_float(compute_epsilon(true))); ext::_sym_singleFloatPositiveInfinity->defconstant(clasp_make_single_float(std::numeric_limits::infinity())); ext::_sym_singleFloatNegativeInfinity->defconstant(clasp_make_single_float(-std::numeric_limits::infinity())); @@ -253,6 +288,8 @@ void exposeCando_Numerics() { cl::_sym_leastNegativeDoubleFloat->defconstant(DoubleFloat_O::create(-std::numeric_limits::denorm_min())); cl::_sym_leastNegativeNormalizedDoubleFloat->defconstant(DoubleFloat_O::create(-std::numeric_limits::min())); cl::_sym_leastPositiveNormalizedDoubleFloat->defconstant(DoubleFloat_O::create(std::numeric_limits::min())); + cl::_sym_doubleFloatEpsilon->defconstant(DoubleFloat_O::create(compute_epsilon(false))); + cl::_sym_doubleFloatNegativeEpsilon->defconstant(DoubleFloat_O::create(compute_epsilon(true))); ext::_sym_doubleFloatPositiveInfinity->defconstant(DoubleFloat_O::create(std::numeric_limits::infinity())); ext::_sym_doubleFloatNegativeInfinity->defconstant(DoubleFloat_O::create(-std::numeric_limits::infinity())); @@ -262,6 +299,8 @@ void exposeCando_Numerics() { cl::_sym_leastNegativeLongFloat->defconstant(LongFloat_O::create(-std::numeric_limits::denorm_min())); cl::_sym_leastNegativeNormalizedLongFloat->defconstant(LongFloat_O::create(-std::numeric_limits::min())); cl::_sym_leastPositiveNormalizedLongFloat->defconstant(LongFloat_O::create(std::numeric_limits::min())); + cl::_sym_longFloatEpsilon->defconstant(LongFloat_O::create(compute_epsilon(false))); + cl::_sym_longFloatNegativeEpsilon->defconstant(LongFloat_O::create(compute_epsilon(true))); ext::_sym_longFloatPositiveInfinity->defconstant(LongFloat_O::create(std::numeric_limits::infinity())); ext::_sym_longFloatNegativeInfinity->defconstant(LongFloat_O::create(-std::numeric_limits::infinity())); diff --git a/src/core/pathname.cc b/src/core/pathname.cc index 6c4d241e78..038bdbd44f 100644 --- a/src/core/pathname.cc +++ b/src/core/pathname.cc @@ -311,12 +311,14 @@ Pathname_sp Pathname_O::makePathname(T_sp host, T_sp device, T_sp directory, T_s p = LogicalPathname_O::create(); logical = true; } else { + if (cl__length(host) == 0) // treat empty string as nil + host = nil(); p = Pathname_O::create(); } - } else if (host.nilp()) { + } else if (host.nilp() || host == kw::_sym_unspecific) { p = Pathname_O::create(); } else { - x = directory; + x = host; component = kw::_sym_host; goto ERROR; } diff --git a/src/core/primitives.cc b/src/core/primitives.cc index fbe704fc8f..cc05faf2ba 100644 --- a/src/core/primitives.cc +++ b/src/core/primitives.cc @@ -150,7 +150,6 @@ CL_DEFUN T_sp core__interpreter_symbols() { #define SocketsPkg_SYMBOLS #define ServeEventPkg_SYMBOLS #define CompPkg_SYMBOLS -#define CleavirEnvPkg_SYMBOLS #define CleavirPrimopPkg_SYMBOLS #define ClosPkg_SYMBOLS #define GrayPkg_SYMBOLS @@ -680,8 +679,9 @@ CL_DEFUN T_sp cl__macro_function(Symbol_sp symbol, T_sp env) { } else if (gc::IsA(env)) { return gc::As_unsafe(env)->lookupMacro(symbol); } else { - if (cleavirEnv::_sym_macroFunction->fboundp()) { - return eval::funcall(cleavirEnv::_sym_macroFunction, symbol, env); + SYMBOL_EXPORT_SC_(CorePkg, cleavir_macro_function); + if (core::_sym_cleavir_macro_function->fboundp()) { + return eval::funcall(core::_sym_cleavir_macro_function, symbol, env); } else { printf("%s:%d Unexpected environment for MACRO-FUNCTION before Cleavir is available - using toplevel environment\n", __FILE__, __LINE__); @@ -1798,6 +1798,16 @@ CL_DEFUN T_sp core__function_source_pos_info(T_sp functionDesignator) { return closure->sourcePosInfo(); } +CL_DEFUN T_sp core__variable_source_info(T_sp var) { + return core::_sym_STARvariableSourceInfosSTAR->symbolValue().as_assert()->gethash(var); +} + +CL_LISPIFY_NAME("core:variableSourceInfo"); +CL_DEFUN_SETF T_sp core__set_variable_source_info(T_sp info, T_sp var) { + core::_sym_STARvariableSourceInfosSTAR->symbolValue().as_assert()->hash_table_setf_gethash(var, info); + return info; +} + }; // namespace core namespace core { diff --git a/src/core/readtable.cc b/src/core/readtable.cc index 0fa8a54df5..f8dc18031b 100644 --- a/src/core/readtable.cc +++ b/src/core/readtable.cc @@ -110,8 +110,10 @@ DOCGROUP(clasp); CL_DEFUN T_mv cl__get_macro_character(Character_sp chr, T_sp readtable) { if (gc::IsA(readtable)) { return gc::As_unsafe(readtable)->get_macro_character_(chr); - } - return eval::funcall(eclector_readtable::_sym_get_macro_character, readtable, chr); + } else if (readtable.nilp()) { + return core::_sym__PLUS_standardReadtable_PLUS_->symbolValue().as_unsafe()->get_macro_character_(chr); + } else + return eval::funcall(eclector_readtable::_sym_get_macro_character, readtable, chr); }; CL_LAMBDA(&optional (from-readtable cl:*readtable*) to-readtable); @@ -120,7 +122,7 @@ CL_DOCSTRING(R"dx(clhs: copy-readtable)dx"); DOCGROUP(clasp); CL_DEFUN T_sp cl__copy_readtable(T_sp fromReadTable, T_sp toReadTable) { if (fromReadTable.nilp()) { - return Readtable_O::create_standard_readtable(); + fromReadTable = core::_sym__PLUS_standardReadtable_PLUS_->symbolValue(); } if (gc::IsA(fromReadTable)) { if (toReadTable.notnilp() && !gc::IsA(toReadTable)) { @@ -145,6 +147,13 @@ CL_DEFUN T_sp cl__readtable_case(T_sp readtable) { return eval::funcall(eclector_readtable::_sym_readtable_case, readtable); } +static void check_readtable_case(Symbol_sp newCase) { + if ((newCase != kw::_sym_upcase) && (newCase != kw::_sym_downcase) + && (newCase != kw::_sym_preserve) && (newCase != kw::_sym_invert)) + TYPE_ERROR(newCase, + Cons_O::createList(cl::_sym_member, kw::_sym_upcase, kw::_sym_downcase, kw::_sym_preserve, kw::_sym_invert)); +} + CL_LISPIFY_NAME("cl:readtable-case"); CL_LAMBDA(mode readtable); CL_DECLARE(); @@ -153,7 +162,8 @@ DOCGROUP(clasp); CL_DEFUN_SETF T_sp core__readtable_case_set(T_sp mode, T_sp readTable) { if (gc::IsA(readTable)) return gc::As_unsafe(readTable)->setf_readtable_case_(gc::As(mode)); - return eval::funcall(eclector_readtable::_sym_setf_readtable_case, mode, readTable); + check_readtable_case(mode.as()); + return eval::funcall(eclector_readtable::_sym_readtable_case->getSetfFdefinition(), mode, readTable); } CL_LAMBDA(dispChar subChar newFunction &optional (readtable *readtable*)); @@ -174,7 +184,9 @@ DOCGROUP(clasp); CL_DEFUN T_sp cl__get_dispatch_macro_character(Character_sp dispChar, Character_sp subChar, T_sp readtable) { if (gc::IsA(readtable)) return gc::As_unsafe(readtable)->get_dispatch_macro_character_(dispChar, subChar); - return eval::funcall(eclector_readtable::_sym_get_dispatch_macro_character, readtable, dispChar, subChar); + else if (readtable.nilp()) + return core::_sym__PLUS_standardReadtable_PLUS_->symbolValue().as_unsafe()->get_dispatch_macro_character_(dispChar, subChar); + else return eval::funcall(eclector_readtable::_sym_get_dispatch_macro_character, readtable, dispChar, subChar); }; CL_LAMBDA(ch func-desig &optional non-terminating-p (readtable *readtable*)); @@ -222,7 +234,6 @@ SYMBOL_SC_(CorePkg, STARconsing_dotSTAR); SYMBOL_SC_(CorePkg, STARpreserve_whitespace_pSTAR); SYMBOL_SC_(CorePkg, STARinput_streamSTAR); SYMBOL_SC_(CorePkg, STARbackquote_levelSTAR); -SYMBOL_SC_(CorePkg, STARstandard_readtableSTAR); CL_LAMBDA(stream chr); CL_DECLARE(); @@ -879,9 +890,6 @@ Readtable_sp Readtable_O::create_standard_readtable() { Symbol_sp sym = gc::As(oCadr(cur)); rt->set_dispatch_macro_character_(sharp, ch, sym); } - // reinstall the things defined in lisp - if (core::_sym_sharpmacros_lisp_redefine->fboundp()) - eval::funcall(core::_sym_sharpmacros_lisp_redefine, rt); return rt; } @@ -914,15 +922,9 @@ clasp_readtable_case Readtable_O::getReadtableCaseAsEnum_() { } Symbol_sp Readtable_O::setf_readtable_case_(Symbol_sp newCase) { - - if ((newCase == kw::_sym_upcase) || (newCase == kw::_sym_downcase) || (newCase == kw::_sym_preserve) || - (newCase == kw::_sym_invert)) { - this->Case_ = newCase; - return newCase; - } else { - TYPE_ERROR(newCase, - Cons_O::createList(cl::_sym_member, kw::_sym_upcase, kw::_sym_downcase, kw::_sym_preserve, kw::_sym_invert)); - } + check_readtable_case(newCase); + this->Case_ = newCase; + return newCase; } T_sp Readtable_O::set_syntax_type_(Character_sp ch, T_sp syntaxType) { diff --git a/src/core/singleDispatchGenericFunction.cc b/src/core/singleDispatchGenericFunction.cc index 61d6a83b9d..cc88f8f9be 100644 --- a/src/core/singleDispatchGenericFunction.cc +++ b/src/core/singleDispatchGenericFunction.cc @@ -65,6 +65,9 @@ CL_DEFUN List_sp core__callHistory(SingleDispatchGenericFunction_sp func) { retu CL_LISPIFY_NAME(SingleDispatchGenericFunction/specializerIndices); CL_DEFUN List_sp core__specializerIndices(SingleDispatchGenericFunction_sp func) { return Cons_O::createList(Integer_O::create(func->argumentIndex)); } +CL_LISPIFY_NAME(SingleDispatchGenericFunction/methods); +CL_DEFUN T_sp core__sdgf_methods(SingleDispatchGenericFunction_sp func) { return func->methods.load(std::memory_order_relaxed); } + CL_DECLARE(); CL_DOCSTRING(R"dx(ensureSingleDispatchGenericFunction)dx"); DOCGROUP(clasp); diff --git a/src/core/symbol.cc b/src/core/symbol.cc index 5a0233dd27..a0188284fd 100644 --- a/src/core/symbol.cc +++ b/src/core/symbol.cc @@ -237,6 +237,13 @@ uint32_t VariableCell_O::ensureBindingIndex() const { void VariableCell_O::unboundError() const { UNBOUND_VARIABLE_ERROR(name()); } +// KLUDGE: No CL_DEFMETHOD_SETF, therefore +CL_LISPIFY_NAME(VariableCell/Value); +CL_DEFUN_SETF T_sp core__variable_cell_set_value(T_sp val, VariableCell_sp cell) { + cell->set_value(val); + return val; +} + VariableCell_sp Symbol_O::ensureVariableCell() { VariableCell_sp vcell = variableCell(); if (vcell.unboundp()) { diff --git a/src/core/trampoline/trampoline.cc b/src/core/trampoline/trampoline.cc index c7a18c2821..eecc9285b9 100644 --- a/src/core/trampoline/trampoline.cc +++ b/src/core/trampoline/trampoline.cc @@ -4,15 +4,6 @@ #define MAGIC 3735879680 -struct Gcroots { - uint64_t val1; - void *val2; - uint64_t val3; - uint64_t val4; - void **val5; - uint64_t val6; -}; - struct return_type { void *_ptr; uint64_t _nvals; @@ -25,7 +16,6 @@ typedef return_type(bytecode_trampoline_type)(uint64_t pc, void *closure, uint64 extern "C" { -Gcroots CLASP_GCROOTS_IN_MODULE(trampoline)[0]; void *CLASP_LITERALS(trampoline)[0]; // Use asm and nodebug to add declaration for the LLVM intrinsic. diff --git a/src/core/write_symbol.cc b/src/core/write_symbol.cc index 66b7e92571..a464e2e36d 100644 --- a/src/core/write_symbol.cc +++ b/src/core/write_symbol.cc @@ -190,8 +190,8 @@ void clasp_write_symbol(Symbol_sp x, T_sp stream) { package = cl::_sym_nil->homePackage(); name = cl::_sym_nil->symbolName(); } else { - package = gc::As(x)->homePackage(); - name = gc::As(x)->symbolName(); + package = x->homePackage(); + name = x->symbolName(); } if (!print_readably && !clasp_print_escape()) { diff --git a/src/cross-clasp/base.lisp b/src/cross-clasp/base.lisp new file mode 100644 index 0000000000..b1037f6779 --- /dev/null +++ b/src/cross-clasp/base.lisp @@ -0,0 +1,549 @@ +(in-package #:cross-clasp) + +;;; Install stuff in an environment to match what we need for build. +;;; To paper over a lot of details: many macros, and then what functions +;;; are defined in C++ and thus available before any Lisp is loaded. + +(defmethod maclina.compile:debug-lambda-name ((client client) decls) + (loop for (declare . decs) in decls + for p = (assoc 'core:lambda-name decs) + when p return (second p))) + +(defmethod maclina.compile:debug-lambda-list ((client client) decls) + (loop for (declare . decs) in decls + for p = (assoc 'core:lambda-list decs) + when p + return (values (rest p) t) + finally (return (values nil nil)))) + +(defun cmp::register-global-function-def (type name) + (declare (ignore type)) + (clostrum:note-function m:*client* *build-rte* name) + (signal 'maclina.compile:resolve-function :name name) + (values)) + +(defmethod common-macro-definitions::output-stream-from-string-function-name + ((client client)) + 'core::make-string-output-stream-from-string) + +(defun proclaim (proclamation) + ;; FIXME: record types, etc + (when (consp proclamation) + (case (car proclamation) + ((special) + (loop for s in (rest proclamation) + do (clostrum:make-variable m:*client* *build-rte* s))) + ((ftype) + ;; We don't use types (yet?), but treat an ftype declaration as + ;; noting a function, as some code (like alexandria) does. + (loop for f in (cddr proclamation) + do (cmp::register-global-function-def 'defun f))))) + (values)) + +(defun core::*make-special (var) + (clostrum:make-variable m:*client* *build-rte* var)) + +(defmethod common-macro-definitions:proclaim + ((client client) declspec env) + (declare (ignore env)) + (if (and (consp declspec) (eq (car declspec) 'special)) + ;; special case this so clasp can load it early. + `(progn + ,@(loop for s in (rest declspec) + collect `(core::*make-special ',s))) + ;; proclaim is defined a bit late. + nil #+(or)`(cl:proclaim ',declspec))) + +(defmethod common-macro-definitions:add-local-nickname ((client client)) + 'ext:add-package-local-nickname) + +(defun clos::note-generic (name compiler-generic) + (clostrum:note-function m:*client* *build-rte* name) + (signal 'maclina.compile:resolve-function :name name) + (setf (clostrum:operator-inline-data m:*client* *build-rte* name) + compiler-generic) + (values)) + +(defun core:put-f (plist value indicator) + (setf (getf plist indicator) value) + plist) + +;;; make a package in the build environment. +;;; this basically entails resolving all names with respect to that +;;; environment, and then making a host package with CROSS-CLASP.CLASP. +;;; prepended to the name. +(defun %make-package (package-name &key nicknames use) + (let* ((name (string package-name)) + (hname (concatenate 'string "CROSS-CLASP.CLASP." name)) + (use + (loop for u in use + for s = (string u) + collect (or (clostrum:find-package + m:*client* *build-rte* s) + (error "Tried to use undefined package ~s" s)))) + #+(or) + (_ (when (find-package hname) + (delete-package hname))) ; fuck it + (package (or (find-package hname) (cl:make-package hname :use use)))) + #+(or)(declare (ignore _)) + (setf (clostrum:package-name m:*client* *build-rte* package) name + (clostrum:find-package m:*client* *build-rte* name) package) + (loop for nick in nicknames + for snick = (string nick) + do (setf (clostrum:find-package m:*client* *build-rte* snick) + package)) + package)) + + +;;; We ignore package locks for now +(defun ext:add-implementation-package (implementors &optional package) + (declare (ignore implementors package))) + +(defun ext:setf-expander (name) + (clostrum:setf-expander m:*client* *build-ce* name)) +(defun (setf ext:setf-expander) (expander name) + (setf (clostrum:setf-expander m:*client* *build-rte* name) expander)) + +(defmethod common-macro-definitions::wrap-in-setf-setf-expander + ((client client) name function environment) + (declare (ignore environment)) + `(setf (ext:setf-expander ',name) ,function)) + +(defmethod common-macro-definitions:get-setf-expansion + ((client client) place &optional environment) + (let ((env (or environment *build-rte*))) + (extrinsicl:get-setf-expansion + client env (macroexpand-hook) place))) + +;;; We define our own SETF over Common Macros'. This is because we want to +;;; minimize how much code actually needs to be compiled by using simple +;;; expansions when available. +;;; E.g. if we have (defun foo ...), that will end up as +;;; (setf (fdefinition 'foo) (lambda ...)), which in turn ends up as +;;; (funcall #'(setf fdefinition) (lambda ...) 'foo). +;;; Without our own setf there would be a let* and such so the file compiler +;;; would just compile the whole thing rather than only the function definition +;;; which is repetitive and wasteful given how many thousands of functions +;;; we want to define. +(defmacro %setf (&whole form &rest pairs &environment env) + `(progn ; progn is of course ok, just means top level form processing + ,@(loop for sub on pairs by #'cddr + when (null (cdr sub)) + do (error "Odd number of arguments to SETF: ~s~%" form) + collect (expand-1-setf (first sub) (second sub) env)))) + +(defun expand-1-setf (place new-value-form env) + (multiple-value-bind (vars vals stores write) + (common-macro-definitions:get-setf-expansion m:*client* place env) + (cond (; (setq whatever store) with no vars + (and (= (length stores) 1) (null vars) + (consp write) (consp (cdr write)) (consp (cddr write)) + (null (cdddr write)) + (eq (first write) 'cl:setq) + (eq (third write) (first stores))) + `(setq ,(second write) ,new-value-form)) + (; (funcall #'whatever store ...) with no vars + (and (= (length stores) 1) (null vars) + (consp write) (eq (car write) 'cl:funcall) (consp (cdr write)) + (consp (cadr write)) (eq (caadr write) 'cl:function) + (consp (cddr write)) (eq (caddr write) (first stores)) + ;; See bug #1720 - weak hash table problem here + (not (equal (cadadr write) '(setf core::variable-source-info)))) + `(funcall ,(cadr write) ,new-value-form ,@(cdddr write))) + (; (set var store), as generated by extrinsicl + (and (= (length stores) 1) (= (length vars) 1) + (consp write) (eq (car write) 'cl:set) + (consp (cdr write)) (consp (cddr write)) + (null (cdddr write)) + (eq (second write) (first vars)) + (eq (third write) (first stores))) + `(set ,(first vals) ,new-value-form)) + ((null vars) `(multiple-value-bind ,stores ,new-value-form ,write)) + (t + `(let* ,(mapcar #'list vars vals) + (multiple-value-bind ,stores ,new-value-form ,write)))))) + +(defmacro %remf (&environment env place indicator) + (multiple-value-bind (vars vals stores store-form access-form) + (common-macro-definitions:get-setf-expansion m:*client* place env) + (let ((s (gensym "s"))) + `(let* (,@(mapcar #'list vars vals) (,s ,indicator)) + (multiple-value-bind (,(car stores) flag) + (core:rem-f ,access-form ,s) + ,store-form + flag))))) + +(defun install-packages (&optional (client m:*client*) + (environment *build-rte*)) + (macrolet ((defpack (name hostname &rest nicknames) + `(let ((package (find-package ',hostname))) + (setf (clostrum:package-name client environment package) ,name + (clostrum:find-package client environment ,name) package + ,@(loop for nick in nicknames + collect `(clostrum:find-package client environment + ,nick) + collect 'package))))) + (defpack "COMMON-LISP" #:common-lisp "CL") + (defpack "COMMON-LISP-USER" #:cross-clasp.clasp.cl-user "CL-USER") + (defpack "CORE" #:cross-clasp.clasp.core "SYS" "SYSTEM" "SI") + (defpack "GCTOOLS" #:cross-clasp.clasp.gctools) + (defpack "MP" #:cross-clasp.clasp.mp) + (defpack "LLVM" #:cross-clasp.clasp.llvm) + (defpack "LLVM-SYS" #:cross-clasp.clasp.llvm-sys) + (defpack "CLOS" #:cross-clasp.clasp.clos) + (defpack "COMPILER" #:cross-clasp.clasp.cmp "CMP") + (defpack "SEQUENCE" #:cross-clasp.clasp.sequence) + (defpack "GRAY" #:cross-clasp.clasp.gray) + (defpack "MPI" #:cross-clasp.clasp.mpi) + (defpack "CLASP-FFI" #:cross-clasp.clasp.clasp-ffi) + (defpack "CLBIND" #:cross-clasp.clasp.clbind) + (defpack "CLASP-DEBUG" #:cross-clasp.clasp.debug) + (defpack "CLANG-COMMENTS" #:cross-clasp.clasp.clang-comments) + (defpack "CLANG-AST" #:cross-clasp.clasp.clang-ast) + (defpack "AST-TOOLING" #:cross-clasp.clasp.ast-tooling) + (defpack "EXT" #:cross-clasp.clasp.ext) + (defpack "KEYWORD" #:keyword) + (defpack "ECCLESIA" #:cross-clasp.clasp.ecclesia)) + (setf (clostrum:package-name client environment + (find-package "ECCLESIA")) + "ECCLESIA")) + +;;; FIXME: defconstant should really be in common macros. +(defun core::symbol-constantp (name) + (clostrum:constantp m:*client* *build-rte* name)) +(defun (setf core::symbol-constantp) (value name) + (when value + (clostrum:make-constant m:*client* *build-rte* name + (m:symbol-value m:*client* *build-rte* name))) + value) + +(defun (setf ext:symbol-macro) (expander name &optional env) + (let ((env (if env + (trucler:global-environment m:*client* env) + *build-rte*))) + (setf (clostrum-sys:variable-status m:*client* env name) :symbol-macro + (clostrum-sys:variable-macro-expander m:*client* env name) expander))) + +(defun ext:specialp (name) + (eq (clostrum:variable-status m:*client* *build-ce* name) :special)) + +(defmacro %defconstant (name value &optional doc) + (declare (ignore doc)) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (set ',name ,value) + (funcall #'(setf core::symbol-constantp) t ',name) + #+(or) + (core::make-constant ',name ,value)) + ,@(when (ext:current-source-location) + `((setf (core::variable-source-info ',name) + ',(ext:current-source-location)))) + ',name)) + +(defun core::make-simple-vector-t (dimension initial-element iep) + (if iep + (make-array dimension :initial-element initial-element) + (make-array dimension))) + +(defun initial-features (features) + ;; FEATURES are those gathered from the executable. We just tack on + ;; an indication that we're building from the host Lisp, as well as :CLOS. + ;; We could add :CLOS from the sources instead? + (list* :building-clasp :clos features)) + +;; This gets the currently present *features*. Used in build. +(defun features () + (m:symbol-value m:*client* *build-rte* '*features*)) + +(defparameter *copied-variables* + '(;;Eclector expects these to be globally bound + eclector.reader::*quasiquotation-state* + eclector.reader::*quasiquotation-depth* + eclector.reader::*consing-dot-allowed-p* + ;; We need these to be available for dumping + cmp::*additional-clasp-character-names* + cmp::*mapping-char-code-to-char-names*)) + +(defun install-setfs () + (macrolet ((def (name lambda-list &body body) + `(setf (ext:setf-expander ',name) + #',(ext:parse-define-setf-expander + name lambda-list body)))) + (def getf (&environment env place indicator + &optional (default nil default-p)) + (multiple-value-bind (vars vals stores store-form access-form) + (common-macro-definitions:get-setf-expansion m:*client* place env) + (let* ((itemp (gensym "ITEMP")) (store (gensym "STORE")) (def (gensym "DEF"))) + (values `(,@vars ,itemp ,@(if default-p (list def) nil)) + `(,@vals ,indicator ,@(if default-p (list default) nil)) + `(,store) + `(let ((,(car stores) (core:put-f ,access-form ,store ,itemp))) + ,@(if default-p (list def) nil) ; prevent unused variable warning + ,store-form + ,store) + `(getf ,access-form ,itemp ,@(if default-p (list def) nil)))))) + (def sbit (&environment env array &rest subscripts) + (common-macro-definitions:get-setf-expansion + m:*client* `(aref ,array ,@subscripts) env)))) + +(defun install-delayed-macros (client rte) + (loop for name being each hash-key of core::*delayed-macros* + using (hash-value expander) + when (member name '(declaim defclass defgeneric defmethod defstruct)) + do (setf (clostrum:macro-function client rte name) expander))) + +(defun %install-delayed-macros () + (install-delayed-macros m:*client* *build-rte*)) + +(defun install-mop (client rte) + ;; In order to avoid any shenanigans, we do not import closer-mop symbols + ;; into our CLOS package. We probably could arrange something to ensure that + ;; the compiler dumps MOP symbols as being in the CLOS package, but egh. + ;; I'm only importing stuff we really need for now. + (loop for s in '(#:ensure-class #:ensure-generic-function) + for mopsym = (or (find-symbol (symbol-name s) "CLOSER-MOP") + (error "Somehow missing MOP symbol ~a" s)) + for clossym = (intern (symbol-name s) "CROSS-CLASP.CLASP.CLOS") + do (setf (clostrum:fdefinition client rte clossym) + (fdefinition mopsym)))) + +(defun %format-symbol (package control &rest arguments) + (apply #'alexandria:format-symbol + (etypecase package + ((eql t) (m:symbol-value m:*client* *build-rte* '*package*)) + (null package) + (package package) + ((or symbol string character) + (clostrum:find-package m:*client* *build-rte* (string package)))) + control arguments)) + +(defun %symbolicate (&rest things) + (let ((*package* (m:symbol-value m:*client* *build-rte* '*package*))) + (apply #'alexandria:symbolicate things))) + +(defun install-environment (&optional (client m:*client*) + (rte *build-rte*) + (ce *build-ce*)) + (declare (ignore ce)) + (extrinsicl:install-cl client rte) + (extrinsicl.maclina:install-eval client rte) + (loop for vname in '(core::*condition-restarts* core::*restart-clusters* + core::*interrupts-enabled* core::*allow-with-interrupts* + core:*quasiquote* core::*sharp-equal-final-table* + core:*variable-source-infos* + ext:*invoke-debugger-hook* ext:*toplevel-hook* + ext:*inspector-hook* core::*documentation-pool* + core:*initialize-hooks* core:*terminate-hooks* + core:*extension-systems* + core::*circle-counter* core::*circle-stack* + core:*functions-to-inline* core:*functions-to-notinline* + mp:*current-process* + core:+type-header-value-map+ + ext:+process-standard-input+ ext:+process-standard-output+ + ext:+process-error-output+ ext:+process-terminal-io+ + cmp::*default-output-type* cmp:*source-locations* + cmp::*optimize* cmp::*optimization-level* + cmp:*btb-compile-hook* cmp::*code-walker*) + do (clostrum:make-variable client rte vname)) + (loop for vname in *copied-variables* + do (clostrum:make-variable client rte vname (symbol-value vname))) + (loop for fname in '(core::symbol-constantp (setf core::symbol-constantp) + (setf ext:symbol-macro) + core::*make-special ext:specialp + core::find-declarations core:process-declarations + core::dm-too-many-arguments core::dm-too-few-arguments + cmp::register-global-function-def + ext:setf-expander (setf ext:setf-expander) + mp::atomic-expander (setf mp::atomic-expander) + ext:parse-macro + core::function-block-name + ext:constant-form-value + core:put-f core::packages-iterator + core::process-lambda-list + ext:type-expander (setf ext:type-expander) + core::normalize-type + core::class-info (setf core::class-info) + ext:current-source-location + core::variable-source-info + (setf core::variable-source-info) + ;; Used by compiler, not expected to exist in target + core::delay-macro + ;; used in CLOS, not expected to actually exist + ;; in the target + clos::note-generic clos::note-method + ;; used in CLOS, replaced in target + clos::parse-specialized-lambda-list + clos::fixup-method-lambda-list clos::method-lambda + ;; used specifically to reconstruct compiler metaobjects + ;; in CFASL loading + (setf slot-value) + ;; FIXME: Used in common-macros defmacro expansions + ecclesia:list-structure + ext:parse-compiler-macro ext:parse-deftype + ext:parse-define-setf-expander + ext:add-implementation-package + core::make-simple-vector-t + ;; Used in clasp local macroexpanders (native build) + #+clasp si::search-keyword #+clasp si::check-keywords + ;; used in compiler macro expansions + core::make-vector + core::make-simple-vector-character + core::concatenate-into-sequence + core::coerce-to-list + core::apply0 core::apply1 + core::apply2 core::apply3 core::apply4 + clos::classp core::subclassp + core::fixnump + core::two-arg-+ core::two-arg-* + core::two-arg-- core::negate + core::two-arg-/ core::reciprocal + core::two-arg-< core::two-arg-<= + core::two-arg-> core::two-arg->= + core::two-arg-= + core::logand-2op core::logior-2op + core::find-class-holder + ext::class-unboundp ext::class-get + cmp::warn-undefined-type + cmp::warn-cannot-coerce + #+clasp si:backquote-append) + for f = (fdefinition fname) + do (setf (clostrum:fdefinition client rte fname) f)) + (loop for (fname . src) in '((cl:proclaim . proclaim) + (cl:make-package . %make-package) + (ext:add-package-local-nickname + . trivial-package-local-nicknames:add-package-local-nickname) + (clos::class-slots . closer-mop:class-slots) + (clos::slot-definition-name + . closer-mop:slot-definition-name) + (clos::gf-info . gf-info) + (clos::find-compiler-class + . find-compiler-class) + (core::install-delayed-macros + . %install-delayed-macros) + (cross-clasp.clasp.alexandria::make-gensym-list + . alexandria:make-gensym-list) + (cross-clasp.clasp.alexandria::format-symbol + . %format-symbol) + (cross-clasp.clasp.alexandria::ensure-car + . alexandria:ensure-car) + (cross-clasp.clasp.alexandria::ensure-list + . alexandria:ensure-list) + (cross-clasp.clasp.alexandria::symbolicate + . %symbolicate) + (cross-clasp.clasp.alexandria::generate-switch-body + . alexandria::generate-switch-body) + (cross-clasp.clasp.khazern::unique-name + . khazern:unique-name)) + for f = (fdefinition src) + do (setf (clostrum:fdefinition client rte fname) f)) + (loop for mname in '(eclector.reader:quasiquote + #+clasp si:quasiquote + ext:with-current-source-form + core::with-clean-symbols core::with-unique-names + core::once-only + core::defconstant-eqx core::defconstant-equal + core::while core::until + clos::with-early-accessors + clos::define-method-combination + clos::define-simple-method-combination + clos::define-complex-method-combination + mp:with-lock + mp:without-interrupts mp:with-interrupts + mp::atomic mp::define-atomic-expander + mp::define-simple-atomic-expander mp::cas + mp::atomic-update-explicit mp::atomic-update + mp::atomic-incf-explicit mp::atomic-incf + mp::atomic-decf-explicit mp::atomic-decf + mp::atomic-push-explicit mp::atomic-push + mp::atomic-pop-explicit mp::atomic-pop + mp::atomic-pushnew-explicit mp::atomic-pushnew + clos::early-allocate-instance + clos::earlier-allocate-instance + clos::early-initialize-instance + clos::early-make-instance + clos::with-mutual-defclass + clos::with-effective-method-parameters + clos::base-satiate + cst::quasiquote cst::db) + for m = (macro-function mname) + do (setf (clostrum:macro-function client rte mname) m)) + (loop for (mname . src) in '((defun . core::%defun) + (defmacro . core::%defmacro) + (define-compiler-macro . core::%define-compiler-macro) + (deftype . core::%deftype) + (define-setf-expander . core::%define-setf-expander) + (defvar . core::%defvar) + (defparameter . core::%defparameter) + (defconstant . %defconstant) + (defclass . clos::early-defclass) + (defgeneric . clos::early-defgeneric) + (defmethod . clos::early-defmethod) + (defstruct . clos::early-defstruct) + (call-method . clos::%call-method) + (handler-bind . %handler-bind) + (assert . %assert) + (check-type . %check-type) + (restart-case . %restart-case) + (restart-bind . %restart-bind) + (with-condition-restarts . %with-condition-restarts) + (with-package-iterator . %with-package-iterator) + (ccase . core::%ccase) + (ecase . core::%ecase) + (ctypecase . core::%ctypecase) + (etypecase . core::%etypecase) + (setf . %setf) + (remf . %remf) + (cross-clasp.clasp.trivial-with-current-source-form::with-current-source-form + . ext:with-current-source-form)) + for m = (macro-function src) + do (setf (clostrum:macro-function client rte mname) m)) + (loop for (fname . set) in '((mp::atomic . mp::expand-atomic)) + for f = (fdefinition set) + do (setf (clostrum:setf-expander client rte fname) f)) + ;; We UNdefine defsetf, because the one in common macros uses the host backquote, + ;; which we cannot in general deal with. + ;; This lets Clasp's DEFSETF be defined during build. + (loop for mname in '(defsetf) + do (clostrum:fmakunbound client rte mname)) + (install-setfs) + (install-mop client rte) + ;; Extrinsicl copies over a bunch of classes, but we actually need + ;; to use our own instead. + (loop for s being the external-symbols of "CL" + do (setf (clostrum:find-class client rte s) nil)) + ;; These exist in the compiler (but not at load time!) so that we can load the + ;; CFASLs of clos/hierarchy.lisp and so on. + (loop for cs in '(clos::compiler-class clos::compiler-eql-specializer + clos::compiler-slotd clos::direct-slotd clos::effective-slotd + clos::compiler-method-combination clos::compiler-generic + clos::compiler-method clos::compiler-reader + clos::compiler-writer clos::effective-reader + clos::effective-writer) + for c = (find-class cs) + do (setf (clostrum:find-class client rte cs) c)) + ;; also copies over many constants we don't want. + ;; They will be defined in runtime-variables.lisp or the library. + ;; The only ones we want to keep are + ;; those that are implementation-independent. + (loop for s being the external-symbols of "CL" + unless (or (not (clostrum:constantp client rte s)) + (member s '(nil pi t))) + do (clostrum:makunbound client rte s)) + (values)) + +(defun initialize (character-names-path features-path) + (load-unicode-file character-names-path) + (setf m:*client* (make-instance 'client) + *build-rte* (make-instance 'run-time-environment) + *build-ce* (make-instance 'clostrum-basic:compilation-environment + :parent *build-rte*)) + (core::reset-delayed-macros) + (reset-class-infos) + (install-environment) + (install-packages) + (maclina.vm-cross:initialize-vm 20000) + (let ((features (with-open-file (s features-path) + (read s)))) + (clostrum:make-parameter m:*client* *build-rte* '*features* + (initial-features features))) + (values)) diff --git a/src/cross-clasp/build.lisp b/src/cross-clasp/build.lisp new file mode 100644 index 0000000000..e248786150 --- /dev/null +++ b/src/cross-clasp/build.lisp @@ -0,0 +1,115 @@ +(in-package #:cross-clasp) + +;;; Compute simple instructions for the builder. Each instruction is either +;;; (:load "whatever.cfasl") meaning to load an existing cfasl, or +;;; (:compile-file "whatever.lisp" "source" "whatever.fasl" "whatever.cfasl") +;;; meaning to compile a new one. If CLEAN is true, compile everything. +;;; To figure out what to do, we just compare file write dates. If a FASL and +;;; CFASL exist, and were written after the source file, just load the CFASL. +;;; Otherwise, compile the source anew, and then compile all remaining files +;;; regardless of how new their FASLs are (in case of compile time dependency). +(defun compute-system (input-files output-files source-pathnames cfasls + &key clean) + (loop for input in input-files + for source in source-pathnames + for output in output-files + for cfasl in cfasls + if (or clean + (not (probe-file output)) (not (probe-file cfasl))) + do (setf clean t) + and collect `(:compile-file ,input ,source ,output ,cfasl) + else collect (let ((input-date (ignore-errors (file-write-date input))) + (output-date (ignore-errors (file-write-date output))) + (cfasl-date (ignore-errors (file-write-date cfasl)))) + (cond ((and input-date + output-date (> output-date input-date) + cfasl-date (> cfasl-date input-date)) + `(:load ,cfasl)) + (t (setf clean t) + `(:compile-file ,input ,source + ,output ,cfasl)))))) + +;;; Execute the system's build instruction. +(defun build-system (system &key native (parallel-jobs 1)) + (let ((*compile-verbose* t) (*compile-print* t) + (*load-verbose* t) (*load-print* t) + ;; COMPILER instead of CMP so that we get Clasp's package, + ;; not the local package nickname. + ;; We disable Cleavir because it's too slow: + ;; The build compiles a _lot_ of macroexpanders, mostly for CLOS, + ;; and constructing CSTs for their bodies takes positively + ;; stupid amounts of time. FIXME? + #+clasp(compiler:*cleavir-compile-hook* nil)) + (handler-bind + (;; SBCL's script processor muffles style warnings, which is + ;; pretty unfortunate for us, so print them ourselves here. + #+sbcl + (style-warning (lambda (w) + (format *error-output* "~&WARNING: ~a~%" w) + (muffle-warning w)))) + (#-clasp maclina.compile:with-compilation-unit + #+clasp with-compilation-unit () + (loop with ct-client = (make-instance 'ct-client) + with compiler = (if native + #'build-native-file + #'build-bytecode-file) + with compile-count = (count :compile-file system + :key #'first) + for (command . rest) in system + do (ecase command + ((:compile-file) + (destructuring-bind (input source output cfasl) rest + (cond ((> parallel-jobs 1) + (fork-worker compiler input output source + cfasl ct-client) + (maclina.load:load-bytecode + cfasl :environment *build-rte*)) + (t + (funcall compiler input output source + cfasl ct-client))))) + ((:load) + (destructuring-bind (cfasl) rest + (maclina.load:load-bytecode + cfasl :environment *build-rte*))))))))) + +(defun build-bytecode-file (input output source cfasl ct-client) + (maclina.compile-file:compile-file + input :output-file output + :environment *build-rte* + :evaluation-client ct-client + :output-cfasl cfasl + :source-pathname source)) + +(defun build-native-file (input output source cfasl ct-client) + ;; We don't want native CFASLs so don't do that part. + ;; That also means we don't need an evaluation-client, + ;; which clasp's compile-file doesn't support in any case. + (declare (ignore ct-client cfasl) + #-clasp(ignore input output source)) + #+clasp + (compile-file + input :output-file output + :environment *build-rte* + :source-pathname source + ;; already doing fork build so don't do extra parallelism + :parallel nil + :native t)) + +(defun build (input-files output-files source-pathnames) + (multiple-value-bind (fasls cfasls) + (loop for (output cfasl) on output-files by #'cddr + collect output into fasls + collect cfasl into cfasls + finally (return (values fasls cfasls))) + (let ((system (compute-system input-files fasls + source-pathnames cfasls))) + (build-system system)))) + +(defun build-native (input-files output-files source-pathnames cfasls + &key (parallel-jobs 1)) + (let ((system (compute-system input-files output-files + source-pathnames cfasls))) + (with-forking (:parallel-jobs parallel-jobs + :total-jobs (count :compile-file system + :key #'first)) + (build-system system :native t :parallel-jobs parallel-jobs)))) diff --git a/src/cross-clasp/clos/classes.lisp b/src/cross-clasp/clos/classes.lisp new file mode 100644 index 0000000000..8960f75423 --- /dev/null +++ b/src/cross-clasp/clos/classes.lisp @@ -0,0 +1,832 @@ +(in-package #:cross-clasp.clasp.clos) + +(defclass compiler-metaobject () ()) + +(defclass specializer (compiler-metaobject) ()) + +;; These aren't actual host classes. That's because working around MOP's requirements +;; for class initialization is more trouble than it's worth. +;; (We never want to make instances of instances of COMPILER-CLASS, but that doesn't +;; really help since MOP doesn't much contemplate such a thing.) +;; We do use MOP accessors so that e.g. anatomicl has an easier time dealing with +;; what we have. +;; Possibly we could inherit from CLASS instead of STANDARD-CLASS, but then +;; a) we'd need to put in all these slots ourselves anyway, and +;; b) nobody ever does that so hosts may get stupid. +(defclass compiler-class (specializer) + ((%name :initarg :name :accessor class-name :reader name) + (%supers :initarg :supers :reader mop:class-direct-superclasses) + (%subs :initform nil :accessor direct-subclasses :reader mop:class-direct-subclasses) + (%class-precedence-list :accessor class-precedence-list + :reader mop:class-precedence-list) + (%direct-slots :initarg :direct-slots :reader mop:class-direct-slots) + (%slots :accessor slots :reader mop:class-slots) + ;; These two are not like MOP - they are literal plists. + (%direct-default-initargs :initarg :direct-default-initargs + :reader direct-default-initargs) + (%default-initargs :accessor default-initargs) + (%source-position :initform nil :initarg :source-position + :reader source-position) + (%metaclass :initarg :metaclass :reader metaclass))) + +;;; Used in build environment +(defun core::subclassp (class1 class2) + (assert (and (typep class1 'compiler-class) + (typep class2 'compiler-class))) + (member class2 (class-precedence-list class1))) + +;;; Needed for Anatomicl +(defmethod closer-mop:class-finalized-p ((class compiler-class)) t) + +(defun fake-initfunction () + (error "Somehow called a cross-clasp fake initfunction!")) + +(defmethod closer-mop:class-direct-default-initargs ((class compiler-class)) + (loop for (key form) on (direct-default-initargs class) by #'cddr + collect (list key form #'fake-initfunction))) +(defmethod closer-mop:class-default-initargs ((class compiler-class)) + (loop for (key form) on (default-initargs class) by #'cddr + collect (list key form #'fake-initfunction))) + +(defmethod print-object ((o compiler-class) stream) + (print-unreadable-object (o stream :type t) + (write (name o) :stream stream)) + o) + +(defclass compiler-eql-specializer (specializer) + ((%object :initarg :object :reader mop:eql-specializer-object))) + +(defvar *eql-specializers* (make-hash-table)) +(defun intern-eql-specializer (object) + ;; Not sure this function is actually required + ;; (versus making multiple eql specializers) + ;; but it's trivial so why not. + (multiple-value-bind (spec presentp) (gethash object *eql-specializers*) + (if presentp + spec + (setf (gethash object *eql-specializers*) (make-instance 'compiler-eql-specializer + :object object))))) + +(defclass compiler-slotd (compiler-metaobject) + ((%name :initarg :name :reader name :reader closer-mop:slot-definition-name) + (%initform :initarg :initform :reader initform) + (%initformp :initarg :initformp :reader initformp :type boolean) + (%initargs :initarg :initargs :initform () :reader initargs) + (%readers :initarg :readers :initform () :reader readers) + (%writers :initarg :writers :initform () :reader writers) + (%type :initarg :type :initform t :reader stype + :reader closer-mop:slot-definition-type) + (%allocation :initarg :allocation :initform :instance :reader allocation) + (%location :initarg :location :initform nil :reader location))) +(defclass direct-slotd (compiler-slotd) + (;; only relevant for direct slots + (%effective-readers :initform nil :accessor effective-readers) + (%effective-writers :initform nil :accessor effective-writers))) +(defclass effective-slotd (compiler-slotd) ()) + +(defmethod print-object ((o compiler-slotd) stream) + (print-unreadable-object (o stream :type t) + (write (name o) :stream stream)) + o) + +(defclass compiler-method-combination (compiler-metaobject) + ((%name :initarg :name :reader name) + (%options :initarg :options :reader options))) + +;;; we could cache these but meh +(defun ensure-method-combination (spec) + (make-instance 'compiler-method-combination + :name (first spec) :options (rest spec))) + +(defclass compiler-generic (compiler-metaobject) + ((%name :initarg :name :reader name) + (%lambda-list :initarg :lambda-list :reader lambda-list) + (%required-parameters :initarg :reqargs :reader required-parameters) + ;; this is broader than whether there's a &rest - it's whether there are + ;; any more parameters after the required parameters at all. + ;; so it's also true with &optional or &key. + (%restp :initarg :restp :reader restp) + (%apo :initarg :apo :reader apo) ; argument precedence order + ;; a vector with T if a parameter is specialized at all, otherwise NIL. + (%specializer-profile :initarg :specializer-profile + :accessor specializer-profile) + (%method-combination :initarg :method-combination + :reader gf-method-combination + :type compiler-method-combination) + (%method-class :initarg :method-class :reader method-class) + (%declarations :initarg :declarations :reader declarations) + (%gf-class :initarg :class :reader gf-class) + (%methods :initarg :methods :initform () :accessor methods))) + +(defmethod initialize-instance :after ((i compiler-generic) &rest initargs) + (declare (ignore initargs)) + (setf (specializer-profile i) + (make-array (length (apo i)) :initial-element nil))) + +(defun update-specializer-profile (generic specializers + &optional (find-class #'cross-clasp:find-compiler-class)) + (loop with tclass = (funcall find-class 't) + with sprof = (specializer-profile generic) + for i from 0 + for spec in specializers + unless (eq spec tclass) + do (setf (aref sprof i) t))) + +(defmethod print-object ((o compiler-generic) stream) + (print-unreadable-object (o stream :type t) + (write (name o) :stream stream)) + o) + +(defclass compiler-method (compiler-metaobject) + ((%gf :initarg :gf :reader gf) + (%lambda-list :initarg :lambda-list :reader lambda-list) + (%specializers :initarg :specializers :reader specializers) + (%qualifiers :initarg :qualifiers :reader qualifiers) + (%mclass :initarg :class :reader mclass) + (%keywords :initarg :keywords :reader method-keywords) + (%aok-p :initarg :aok-p :reader method-allows-other-keys-p) + ;; A cons (LEAF mform &optional fform) or (CONTF mform fform) + ;; mform, at load time, will be evaluated to produce the + ;; method function. fform, if present, evaluates to + ;; the raw leaf or contf function. The latter is only used + ;; in effective methods (method-combination.lisp). + (%function :initarg :function-form :reader method-function + :type (cons (member leaf contf))))) + +(defmethod print-object ((o compiler-method) stream) + (print-unreadable-object (o stream :type t) + (format stream "~s ~{~s ~}(~{~s~^ ~})" + (name (gf o)) (qualifiers o) + (mapcar #'name (specializers o)))) + o) + +(defclass compiler-accessor (compiler-method) + ((%slot :initarg :slot :reader slot) + (%keywords :initform nil) + (%aok-p :initform nil))) +(defclass compiler-reader (compiler-accessor) ()) +(defclass compiler-writer (compiler-accessor) ()) + +(defclass effective-accessor (compiler-method) + ((%original :initarg :original :reader original) + (%allocation :initform :instance :reader allocation) + (%location :initarg :location :reader location) + (%keywords :initform nil) + (%aok-p :initform nil))) +(defclass effective-reader (effective-accessor) ()) +(defclass effective-writer (effective-accessor) ()) + +(defgeneric sclass (effective-accessor)) +(defmethod sclass ((e effective-reader)) (first (specializers e))) +(defmethod sclass ((e effective-writer)) (second (specializers e))) + +(defun parse-slot-specifier (slot-specifier) + (etypecase slot-specifier + (symbol (values slot-specifier nil nil nil nil nil t :instance nil)) + (cons (loop with name = (first slot-specifier) + with initargs = () + with initform + with initformp = nil + with readers = () + with writers = () + with type = t with typep = nil + with allocation = :instance with allocationp = nil + with location = nil + for (key value) on (rest slot-specifier) by #'cddr + do (ecase key + ((:initform) + (if initformp + (error "duplicate initform") + (setf initform value initformp t))) + ((:initarg) + (check-type value symbol "a valid initarg") + (push value initargs)) + ((:reader) + (check-type value symbol "a valid reader name") + (push value readers)) + ((:writer) + (check-type value + (or symbol + (cons (eql setf) (cons symbol null))) + "a valid writer name") + (push value writers)) + ((:accessor) + (check-type value symbol "a valid accessor name") + (push value readers) + (push `(setf ,value) writers)) + ((:type) + (if typep + (error "duplicate type") + (setf type value typep t))) + ((:allocation) + (cond (allocationp (error "duplicate allocation")) + ((and (eq value :class) location) + (error "~s ~s and ~s are incompatible" + :class :allocation :location)) + (t (setf allocation value allocationp t)))) + ((:location) + (check-type value (integer 0) "a slot location") + (cond (location (error "duplicate location")) + ((eq allocation :class) + (error "~s ~s and ~s are incompatible" + :class :allocation :location)) + (t (setf location value))))) + finally (return (values name + initform initformp initargs + readers writers type + allocation location)))))) + +(defun make-direct-slotd (slot-specifier) + (multiple-value-bind (name initform initformp initargs + readers writers type allocation location) + (parse-slot-specifier slot-specifier) + (make-instance 'direct-slotd + :name name :initform initform :initformp initformp + :initargs initargs :readers readers :writers writers + :type type :allocation allocation :location location))) + +(defun parse-class-options (options) + (loop with metaclass with documentation + with default-initargs with default-initargs-p + with source-position + for (key . value) in options + do (ecase key + ((:metaclass) + (if metaclass + (error "Duplicate ~s option" :metaclass) + (destructuring-bind (clname) value + (setf metaclass clname)))) + ((:documentation) + (if documentation + (error "Duplicate ~s option" :documentation) + (destructuring-bind (docstring) value + (setf documentation docstring)))) + ((:default-initargs) + (if default-initargs-p + (error "Duplicate ~s option" :default-initargs) + (setf default-initargs value + default-initargs-p t)))) + finally (return (values metaclass + documentation default-initargs + source-position)))) + +(defun compute-effective-slot (slotds location) + (flet ((app (reader) + (remove-duplicates + (mapcan (lambda (x) (copy-list (funcall reader x))) slotds) + ;; EQUAL for setf writer names + ;; i mean this rem-dup might be pointless anyway + :test #'equal))) + (multiple-value-bind (initform initformp) + (loop for slotd in slotds + when (initformp slotd) + return (values (initform slotd) t) + finally (return (values nil nil))) + ;; Verify location + (loop with locp = nil + for slotd in slotds + for loc = (location slotd) + when loc + do (cond (locp + (error "Duplicate ~s" :location)) + ((= loc location)) + (t (error "Location mismatch for ~s" + (name (first slotds))))) + (setf locp t)) + ;; Verify allocation + (loop with allocation = (allocation (first slotds)) + for slotd in (rest slotds) + for alloc = (allocation slotd) + when alloc + do (unless (eq alloc allocation) + (error "Allocation mismatch for ~s" + (name (first slotds))))) + ;; Make the slotd + (make-instance 'effective-slotd + :name (name (first slotds)) :initform initform :initformp initformp + :initargs (app #'initargs) + :readers (app #'readers) :writers (app #'writers) + :type `(and ,@(loop for slotd in slotds + for type = (stype slotd) + unless (eq type 't) ; who care + collect type)) + :allocation (allocation (first slotds)) + :location (ecase (allocation (first slotds)) + (:instance location) + (:class nil)))))) + +(defun compute-slots (cpl) + (let* (;; An alist from slot names to lists of direct slotds + ;; of the same name in order from most to least specific. + ;; The different slotds are sorted least specific first. + (direct-slots + (loop with result = nil + for class in cpl + do (loop for slotd in (reverse (mop:class-direct-slots class)) + for name = (name slotd) + for existing = (assoc name result) + when existing + do (push slotd (cdr existing)) + else + do (push (list name slotd) result)) + finally (return result)))) + (loop for (_ . direct-slotds) in direct-slots + for i from 0 + ;; now make the slotds most specific first. + collect (compute-effective-slot (reverse direct-slotds) i)))) + +(defun compute-default-initargs (cpl) + ;; We didn't do the canonicalization stuff out of laziness and + ;; because initfunctions don't make much sense here, so this is + ;; just append with duplicates removed. + (loop with seen = () + for class in cpl + for inits = (direct-default-initargs class) + nconc (loop for (k v) on inits by #'cddr + unless (member k seen) + do (push k seen) + and collect k + and collect v))) + +(defun finalizedp (class) + (slot-boundp class '%class-precedence-list)) + +(defun finalize-inheritance (class) + (let* ((supers (mop:class-direct-superclasses class)) + (_ (loop for sup in supers + unless (finalizedp sup) + do (finalize-inheritance sup))) + (cpl (compute-class-precedence-list class supers)) + (effective-slotds (compute-slots cpl)) + (default-initargs (compute-default-initargs cpl))) + (declare (ignore _)) + (setf (class-precedence-list class) cpl + (slots class) effective-slotds + (default-initargs class) default-initargs)) + (values)) + +(defun initialize-compiler-class (class name supers slotds source + options + &key (find-class + #'cross-clasp:find-compiler-class)) + (multiple-value-bind (metaclass documentation default-initargs) + (parse-class-options options) + (declare (ignore documentation)) ; FIXME? + (let* ((metaclass (or metaclass 'standard-class)) + (supers (or supers + (ecase metaclass + ((standard-class) '(standard-object)) + ((funcallable-standard-class) + '(funcallable-standard-object)) + ((built-in-class) + (if (eq name t) ; weird special case + () + '(t)))))) + (supers (mapcar find-class supers)) + (slotds (mapcar #'make-direct-slotd slotds)) + (rmetaclass (funcall find-class metaclass))) + (reinitialize-instance + class + :supers supers :direct-slots slotds + :direct-default-initargs default-initargs + :source-position source + :metaclass rmetaclass) + (finalize-inheritance class) + (loop for super in supers + do (push class (direct-subclasses super))) + class))) + +(defun make-compiler-class (name supers slotds source options) + (initialize-compiler-class (make-instance 'compiler-class + :name name) + name supers slotds source options)) + +(defun primitive-accessor (class) + (ecase (name (metaclass class)) + (standard-class 'standard-instance-access) + (funcallable-standard-class 'funcallable-standard-instance-access))) + +(defun expand-early-allocate-instance (class) + (let ((funcallablep (find (cross-clasp:find-compiler-class + 'funcallable-standard-object) + (mop:class-precedence-list class)))) + `(let* ((class (find-class ',(name class))) + (slotds (with-early-accessors (std-class) + (class-slots class))) + (size (length slotds)) + (stamp (core:class-stamp-for-instances class))) + ;; note that we don't set the funcallable instance function + ;; for funcallables. that's because we're going to set those up + ;; later anyway. + (,(if funcallablep + 'core:allocate-raw-funcallable-instance + 'core:allocate-raw-instance) + class + (core:make-rack + size slotds stamp (core:unbound)))))) + +(defmacro early-allocate-instance (class-name) + (expand-early-allocate-instance (cross-clasp:find-compiler-class class-name))) + +;;; Used to make slots in the weird early parts. +;;; They expand into this. The delay is important since when they expand +;;; into this, the compiler class doesn't have slots yet. Or something. +(defmacro earlier-allocate-instance (class-name) + `(core:allocate-standard-instance + (find-class ',class-name) + ,(length (mop:class-slots (cross-clasp:find-compiler-class class-name))))) + +(defmacro early-initialize-instance (class-name object &rest initargs) + (let* ((class (cross-clasp:find-compiler-class class-name)) + (sia (primitive-accessor class)) + (slots (mop:class-slots class)) + (o (gensym "OBJECT"))) + `(let ((,o ,object)) + (setf + ,@(loop with invalid-keys + for (key val) on initargs by #'cddr + for slotd = (loop for slotd in slots + when (member key (initargs slotd)) + return slotd + finally (push key invalid-keys) + (return nil)) + when slotd + collect `(,sia ,o ,(location slotd)) + and collect val + and do (setf slots (remove slotd slots)) + finally (unless (null invalid-keys) + (error "Unrecognized or duplicate initargs: ~s" + invalid-keys))) + ;; FIXME: Doesn't detect initargs that genuinely correspond to no slot. + ;; Oh well! + ,@(loop for (key form) in (default-initargs class) + for slotd = (loop for slotd in slots + when (member key (initargs slotd)) + return slotd) + when slotd + collect `(,sia ,o ,(location slotd)) + and collect form + and do (setf slots (remove slotd slots))) + ;; Initialize other slots with initforms, if they have em. + ,@(loop for slotd in slots + when (initformp slotd) + collect `(,sia ,o ,(location slotd)) + and collect (initform slotd))) + ,o))) + +(defmacro early-make-instance (class-name &rest initargs) + `(early-initialize-instance + ,class-name + (early-allocate-instance ,class-name) + ,@initargs)) + +;; returns a bunch of bindings for macrolet. +(defun early-accessors (class) + (loop with sia = (primitive-accessor class) + for slotd in (mop:class-slots class) + for loc = (location slotd) + ;; for accessors we just use all possible readers, even if + ;; there's no corresponding writers. + ;; this is early! chaos reigns! + for accessors = (readers slotd) + nconc (loop for acc in accessors + collect `(,acc (object) + (list ',sia object ',loc))))) + +(defmacro with-early-accessors ((&rest class-names) &body body) + `(macrolet (,@(loop for name in class-names + for class = (cross-clasp:find-compiler-class name) + nconc (early-accessors class))) + ,@body)) + +(defun build-direct-slot-form (slotd) + `(early-initialize-instance + standard-direct-slot-definition + (earlier-allocate-instance standard-direct-slot-definition) + :name ',(name slotd) + :initform ,(if (initformp slotd) + `',(initform slotd) + '+initform-unsupplied+) + :initfunction ,(if (initformp slotd) + `#'(lambda () + ,(initform slotd)) + nil) + :initargs ',(initargs slotd) + :readers ',(readers slotd) + :writers ',(writers slotd) + :type ',(stype slotd) + :allocation ',(allocation slotd) + :location ',(location slotd))) + +(defun build-slot-form (compiler-slotd) + `(early-initialize-instance + standard-effective-slot-definition + (earlier-allocate-instance standard-effective-slot-definition) + :name ',(name compiler-slotd) + :initform ,(if (initformp compiler-slotd) + `',(initform compiler-slotd) + '+initform-unsupplied+) + :initfunction ,(if (initformp compiler-slotd) + `#'(lambda () + ,(initform compiler-slotd)) + nil) + :initargs ',(initargs compiler-slotd) + :readers ',(readers compiler-slotd) + :writers ',(writers compiler-slotd) + :type ',(stype compiler-slotd) + :allocation ',(allocation compiler-slotd) + :location ,(ecase (allocation compiler-slotd) + (:instance `',(location compiler-slotd)) + (:class `(list ,(if (initformp compiler-slotd) + (initform compiler-slotd) + '(core:unbound))))))) + +(defun canonicalized-default-initargs-form (default-initargs) + `(list + ,@(loop for (k v) on default-initargs by #'cddr + collect `(list ',k ',v #'(lambda () ,v))))) + +(defun initialize-class-form (var class) + `(progn + ;; EARLY-INITIALIZE-INSTANCE takes care of initforms + ;; and such. This also reduces special casing, hopefully. + (early-initialize-instance + ,(name (metaclass class)) ,var + :name ',(name class) + :direct-superclasses (list ,@(loop for super + in (mop:class-direct-superclasses class) + for sname = (name super) + collect `(find-class ',sname))) + :direct-slots (list ,@(loop for slot in (mop:class-direct-slots class) + collect (build-direct-slot-form + slot))) + ;; since default-initargs is set separately there can be + ;; duplicate initfunctions, but I do not care. + :direct-default-initargs ,(canonicalized-default-initargs-form + (direct-default-initargs class)) + :source-position ',(source-position class)) + (with-early-accessors (std-class) + (setf (%class-slots ,var) + (list ,@(loop for slot in (mop:class-slots class) + collect (build-slot-form slot))) + (%class-precedence-list ,var) + (list ,@(loop for s in (mop:class-precedence-list class) + collect `(find-class ',(name s)))) + (%class-default-initargs ,var) + ,(canonicalized-default-initargs-form + (default-initargs class)) + (%class-direct-subclasses ,var) + (list ,@(loop for sub in (mop:class-direct-subclasses class) + for sname = (name sub) + collect `(find-class ',sname))) + (%class-finalized-p ,var) t + (class-size ,var) ,(length (mop:class-slots class)))) + ,var)) + +;;; FIXME? These are pretty verbose because make-%leaf-method-function +;;; is defined later in method-function.lisp. We'd have to interleave +;;; it in the with-mutual-defclass form which I think would be a little +;;; tricky so I'll hold off. +(defun reader-mf-form (slot-name) + `(let ((i (early-make-instance %leaf-method-function + :fmf (lambda (object) + (slot-value object ',slot-name))))) + (set-funcallable-instance-function + i + (lambda (args next) + (declare (ignore next)) + ;; argcount has been checked by gf already + (slot-value (first args) ',slot-name))) + i)) +(defun writer-mf-form (slot-name) + `(let ((i (early-make-instance %leaf-method-function + :fmf (lambda (value object) + (setf (slot-value object ',slot-name) value))))) + (set-funcallable-instance-function + i + (lambda (args next) + (declare (ignore next)) + ;; argcount has been checked by gf already + (setf (slot-value (second args) ',slot-name) (first args)))) + i)) + +;;; Return a list of accessor methods for a defclass form. +(defun build-accessors (class &optional (find-class + #'cross-clasp:find-compiler-class)) + (loop with rll = (list (name class)) + with wll = (list 'new (name class)) + for slot in (mop:class-direct-slots class) + nconc (loop for reader in (readers slot) + for egf = (cross-clasp:gf-info reader) + for gf = (or egf + (make-instance 'compiler-generic + :name reader :lambda-list rll + :reqargs rll :restp nil + :apo rll + :method-combination + (ensure-method-combination '(standard)) + :method-class (funcall find-class 'standard-method) + :declarations () + :class (funcall find-class 'standard-generic-function))) + for fmf = (reader-mf-form (name slot)) + for method = (make-instance 'compiler-reader + :gf gf :lambda-list rll + :qualifiers () :slot slot + :specializers (list class) + :function-form `(leaf ,fmf) + :class (funcall find-class 'standard-reader-method)) + collect method) + nconc (loop for writer in (writers slot) + for egf = (cross-clasp:gf-info writer) + for gf = (or egf + (make-instance 'compiler-generic + :name writer :lambda-list wll + :reqargs wll :restp nil + :apo wll + :method-combination + (ensure-method-combination '(standard)) + :method-class (funcall find-class 'standard-method) + :declarations () + :class (funcall find-class 'standard-generic-function))) + for fmf = (writer-mf-form (name slot)) + for method = (make-instance 'compiler-writer + :gf gf :lambda-list wll + :qualifiers () :slot slot + :specializers (list (funcall find-class 't) + class) + :function-form `(leaf ,fmf) + :class (funcall find-class 'standard-writer-method)) + collect method))) + +;;; note-generic is defined in environment.lisp +(defun note-method (compiler-generic compiler-method) + ;; TODO: Sanity checks + (push compiler-method (methods compiler-generic)) + (update-specializer-profile compiler-generic (specializers compiler-method)) + (values)) + +(defun build-note-accessors (accessors) + (loop for method in accessors + for gf = (gf method) + unless (cross-clasp:gf-info (name gf)) + collect `(note-generic ',(name gf) ,gf) + collect `(note-method ,gf ,method))) + +(defun build-install-accessors (accessors) + (loop for method in accessors + for gf = (gf method) + for name = (name gf) + for defgf = (not (cross-clasp:gf-info name)) + for gfv = (gensym "GENERIC-FUNCTION") + ;; build-gf-form and build-method-form + ;; are defined in clos-generics.lisp. + collect `(let ((,gfv ,(if defgf + (build-gf-form gf) + `(fdefinition ',name)))) + ,@(when defgf + `((setf (fdefinition ',name) ,gfv))) + (with-early-accessors (standard-generic-function) + ,(etypecase method + (compiler-reader + `(setf (aref (generic-function-specializer-profile ,gfv) 0) + t)) + (compiler-writer + `(setf (aref (generic-function-specializer-profile ,gfv) 1) + t))) + (push ,(build-method-form method) + (%generic-function-methods ,gfv)))))) + +(defun expand-early-defclass (class) + (let ((name (name class)) + (accessors (build-accessors class))) + `(progn + (eval-when (:compile-toplevel) + (setf (find-class ',name) ,class) + ,@(build-note-accessors accessors)) + (eval-when (:load-toplevel :execute) + (let* ((old-class (find-class ',name nil)) + (class + (or old-class + ,(expand-early-allocate-instance (metaclass class))))) + ;; Install class. + ;; we do this first so the CPL can refer to the class. + (core:setf-find-class class ',name) + ;; Initialize rack slots. + ,(initialize-class-form 'class class) + ;; Install as subclass. + (with-early-accessors (std-class) + ,@(loop for super in (mop:class-direct-superclasses class) + ;; ADJOIN not available yet, so no pushnew + ;; find-class is _not_ done in load-time-value, since + ;; the classes will not exist at load-time-value time + collect `(let ((super (find-class ',(name super)))) + (unless (member class (class-direct-subclasses super)) + (push class (class-direct-subclasses super)))))) + ;; Install stamp. + (unless old-class + (core:class-new-stamp class))) + ,@(build-install-accessors accessors) + ',name)))) + +(defmacro early-defclass (&whole whole name (&rest supers) (&rest slotds) &rest options) + ;; ignore redefinitions - some pop up from the generated cxx-classes.lisp + (if (cross-clasp:find-compiler-class name nil) + 'nil + (let* ((source (maclina.compile:form-source-location whole))) + (expand-early-defclass (make-compiler-class name supers slotds source options))))) + +;;; Welcome to the deep magic. +;;; This macro allows defmacro forms as its toplevel to refer to each +;;; other kind of like letrec. For example it's okay to have classes +;;; with themselves as a metaclass, or with a metaclass that's defined +;;; later, bla bla bla. This is all needed to describe CLOS. +;;; The basic goal here is for all the base class definitions to be +;;; meaningfully described by simple and clear DEFCLASS forms. +;;; This includes being able to _change_ these definitions in the future, +;;; so the magic does _not_ include that kind of special casing. +;;; Here's what we do: +;;; 1) at compile time: make all compiler classes, then fill them in +;;; 2) at load time: first, make all classes +;;; 3) fill them in +;;; 4) compute sigs so all the class instances are not obsolete. +(defmacro with-mutual-defclass (&body body) + (loop for form in body + unless (and (consp form) (eq (car form) 'defclass)) + do (error "Only DEFCLASS forms are allowed here.")) + ;; Before any expansion we set up compiler classes. + ;; These are dumped as literals, but only into :compile-toplevel code + ;; so they don't end up in the FASL. + ;; Note that we refer back to this list rather than doing + ;; (setf find-class) at macroexpansion time, so that expanding this + ;; macro does not have or rely on side effects. + (let* ((compiler-classes + (loop for (_ name) in body + for class = (make-instance 'compiler-class :name name) + collect (cons name class))) + (find-class (lambda (name) + (or (cdr (assoc name compiler-classes)) + (error "No class: ~s" name)))) + accessors) + ;; initialize the classes + (loop for form in body + for (_1 _2 supers slotds . options) = form + for source = (maclina.compile:form-source-location form) + for (name . cclass) in compiler-classes + do (initialize-compiler-class + cclass name supers slotds source options + :find-class find-class)) + ;; and finalize their inheritance. + (loop for (_ . cclass) in compiler-classes + unless (finalizedp cclass) do (finalize-inheritance cclass)) + ;; Generate accessor methods & generics. + (setf accessors + (loop for (_ . cclass) in compiler-classes + nconc (build-accessors cclass find-class))) + ;; All compiler classes are done, let's expand. + `(progn + (eval-when (:compile-toplevel) + ,@(loop for (name . class) in compiler-classes + collect `(setf (find-class ',name) ',class)) + ,@(build-note-accessors accessors)) + (eval-when (:load-toplevel :execute) + ;; Here is what the FASL is actually going to do. + ;; First, make all the classes. We already have all class sizes, + ;; so this isn't much of a problem. + ;; Note that the primordial image already has several classes + ;; defined, such as STANDARD-CLASS. This makes our job here easier. + ;; With fewer primordial classes, we'd need to do some toposorting + ;; or something, and special case standard-class. + ,@(loop for (name . class) in compiler-classes + for metaclass = (metaclass class) + collect `(unless (find-class ',name nil) + (core:class-new-stamp + (core:setf-find-class + (core:allocate-standard-instance + (find-class ',(name metaclass)) + ,(length (mop:class-slots metaclass))) + ',name) + ',name))) + ;; Now we fill in all the classes. We can use the compile-time + ;; CPLs and effective slots. The standard-direct-slot-definition + ;; etc classes have already been made so we can make instances of + ;; them without an issue. + ,@(loop for (name . class) in compiler-classes + for metaclass = (metaclass class) + collect `(let ((class (find-class ',name))) + ,(initialize-class-form 'class class))) + ;; Define accessor functions. + ,@(build-install-accessors accessors) + ;; Finally, go through the classes setting the sigs of + ;; their slotds, which did not exist when they were created. + ;; Also set the sigs of the classes themselves. This is + ;; necessary because they were created when their classes + ;; didn't yet have slots. I don't understand how the existing + ;; bootstrap code does or avoids this. + (with-early-accessors (std-class) + ,@(loop for (name . class) in compiler-classes + collect `(let ((class (find-class ',name))) + (core:instance-sig-set class) + (loop for s in (class-slots class) + do (core:instance-sig-set s)) + (loop for s in (class-direct-slots class) + do (core:instance-sig-set s))))))))) diff --git a/src/cross-clasp/clos/cpl.lisp b/src/cross-clasp/clos/cpl.lisp new file mode 100644 index 0000000000..2c953d4555 --- /dev/null +++ b/src/cross-clasp/clos/cpl.lisp @@ -0,0 +1,76 @@ +(in-package #:cross-clasp.clasp.clos) + +;;;; identical to the runtime code, except it presumes everything is a +;;;; compiler-class and not forward referenced. + +(defun compute-class-precedence-list (new-class superclasses) + (labels ((walk-supers (superclasses) + ;; Creates two lists, one with all the superclasses of a class to be created, + ;; and a second list with lists (c1 c2 c3 ... cn) that represent a partial + ;; ordering of the classes (c1 > c2), (c2 > c3), etc." + (let ((class-list '()) + (precedence-lists (list superclasses))) + (loop (unless superclasses + (return (values class-list precedence-lists))) + (let ((next-class (pop superclasses))) + #+(or) + (when (forward-referenced-class-p next-class) + (error "Cannot compute class precedence list for forward-referenced class ~A." + (class-name next-class))) + (unless (member next-class class-list :test 'eql) + (let ((more-classes + (mop:class-direct-superclasses next-class))) + (setf class-list (list* next-class class-list) + precedence-lists (list* (list* next-class more-classes) + precedence-lists) + superclasses (append more-classes superclasses)))))))) + (cycle-error (class) + (error "A cycle has been detected in the class precedence list for ~A." + (class-name class))) + (has-no-precedent (class precedence-lists) + ;; Check if CLASS is not preceded by any other class in the partial order. + (dolist (partial-order precedence-lists t) + (when (member class (rest partial-order) :test 'eql) + (return nil)))) + (free-elements (class-list precedence-lists) + ;; Return classes that are not preceded by anyone + (let ((output '())) + (dolist (class class-list) + (when (has-no-precedent class precedence-lists) + (push class output))) + output)) + (next-element (free-list cpl) + ;; Compute the next element that we will add to the class precedence list. + (if (or (null cpl) (endp free-list) (endp (rest free-list))) + (first free-list) + (dolist (i cpl nil) + (dolist (j (mop:class-direct-superclasses i)) + (when (member j free-list :test 'eql) + (return-from next-element j)))))) + (delete-class (class precedence-lists) + (do ((l precedence-lists (rest l))) + ((null l) + (delete nil precedence-lists)) + (let ((one-list (first l))) + (when (eq class (first one-list)) + (setf (first l) (rest one-list))))))) + (cond ((null superclasses) + (list new-class)) + #+(or) ; we don't keep CPLs around, but maybe we ought to? + ((and (endp (rest superclasses)) + #+(or) + (not (forward-referenced-class-p (first superclasses)))) + (list* new-class (slot-value (first superclasses) 'precedence-list))) + (t + (multiple-value-bind (class-list precedence-lists) + (walk-supers superclasses) + (do ((cpl (list new-class))) + ((null class-list) + (if precedence-lists (cycle-error new-class) (nreverse cpl))) + (let* ((candidates (free-elements class-list precedence-lists)) + (next (next-element candidates cpl))) + (unless next + (cycle-error new-class)) + (setf precedence-lists (delete-class next precedence-lists) + class-list (delete next class-list) + cpl (cons next cpl))))))))) diff --git a/src/cross-clasp/clos/define-method-combination.lisp b/src/cross-clasp/clos/define-method-combination.lisp new file mode 100644 index 0000000000..de67d6ad0b --- /dev/null +++ b/src/cross-clasp/clos/define-method-combination.lisp @@ -0,0 +1,126 @@ +#-building-clasp(in-package #:cross-clasp.clasp.clos) +#+building-clasp(in-package #:clos) + +;;;; This file is compiled/loaded both by the host and the target. +;;;; Tricky bit with that: the host CLOS package shadows DEFINE-METHOD-COMBINATION. +;;;; The target package does not. But this should work out, as the loader doesn't +;;;; know or care about packaging - it will just intern D-M-C in CLOS and whether +;;;; that puts it in CL or not depends on the target package. + +(defmacro define-simple-method-combination (name &key documentation + identity-with-one-argument + (operator name)) + `(define-complex-method-combination + ,name (&optional (order :MOST-SPECIFIC-FIRST)) + ((around (:AROUND)) + (principal (,name) :REQUIRED t)) + ,documentation + (let ((main-effective-method + (list* ',operator (mapcar (lambda (x) + (list 'call-method x ())) + (if (eql order :MOST-SPECIFIC-LAST) + (reverse principal) + principal))))) + (cond (around + (list 'call-method (first around) + (append (rest around) + (list (list 'make-method main-effective-method))))) + ,@(if identity-with-one-argument + `(((null (rest principal)) + (second main-effective-method)))) + (t main-effective-method))))) + +(defun parse-complex-dmc-body (body) + (loop with argsp = nil with gfp = nil + with args = nil with gf = nil + for rbody on body + for first = (first rbody) + if (and (consp first) (eq (first first) :arguments) + (not argsp)) + do (setf argsp t args (rest first)) + else if (and (consp first) (eq (first first) :generic-function) + (cdr (rest first)) (null (cddr first)) + (symbolp (second first)) (not gfp)) + do (setf gfp t gf (second first)) + else do (loop-finish) + finally (return (values args argsp gf gfp rbody)))) + +(defmacro define-complex-method-combination (name (&rest lambda-list) + (&rest method-groups) + &rest body) + (unless (symbolp name) + (error "Method combination name must be a symbol, but got ~s" name)) + (multiple-value-bind (args-lambda-list argsp gf-symbol gfp body) + (parse-complex-dmc-body body) + (declare (ignore args-lambda-list gfp)) + (when argsp + (warn "Option :ARGUMENTS is not supported in DEFINE-METHOD-COMBINATION.") + (return-from define-complex-method-combination + `(error "Option :ARGUMENTS is not supported in DEFINE-METHOD-COMBINATION."))) + (let ((gf-symbol (or gf-symbol (gensym "GENERIC-FUNCTION"))) + (group-names '()) (group-checks '()) (group-after '())) + (dolist (group method-groups) + (destructuring-bind (group-name predicate &key description + (order :most-specific-first) + (required nil)) + group + (declare (ignore description)) ; FIXME? + (if (symbolp group-name) + (push group-name group-names) + (error "Method combination method group name must be a symbol, but got ~s" group-name)) + (let ((condition + (cond ((eql predicate '*) 'T) + ((null predicate) `(null .method-qualifiers.)) + ((symbolp predicate) + `(,predicate .method-qualifiers.)) + ((consp predicate) + (let* ((q (last predicate 0)) + (p (copy-list (butlast predicate 0)))) + (when (every #'symbolp p) + (if (eql q '*) + `(every #'equal ',p .method-qualifiers.) + `(equal ',p .method-qualifiers.))))) + (t (error "Invalid method group predicate: ~s" predicate))))) + (push `(,condition (push .method. ,group-name)) group-checks)) + (when required + (push `(unless ,group-name + ;; Effective methods can be computed in other situations than being + ;; about to call them. As such, compute-effective-method should not + ;; signal an error unless the computation is impossible. Lacking a + ;; required method is by contrast a problem that only needs to be + ;; signaled when the function is actually being called. So we return + ;; an error form. ...but because we want an independent function for + ;; the dtree interpreter, we return something specially recognizable + ;; by compute-outcome, so the generic function etc. can be hooked up. + (return-from ,name '(%magic-no-required-method ,group-name))) + group-after)) + (case order + (:most-specific-first + (push `(setf ,group-name (nreverse ,group-name)) group-after)) + (:most-specific-last) + (otherwise + (let ((order-var (gensym))) + (setf group-names (append group-names (list (list order-var order))) + group-after (list* `(when (eq ,order-var :most-specific-first) + (setf ,group-name (nreverse ,group-name))) + group-after))))))) + `(install-method-combination + ',name + (lambda (,gf-symbol .methods-list. ,@lambda-list) + (declare (core:lambda-name ,name) + (ignorable ,gf-symbol)) + (block ,name + (let (,@group-names) + (dolist (.method. .methods-list.) + (let ((.method-qualifiers. (method-qualifiers .method.))) + (cond ,@(nreverse group-checks) + (t (invalid-method-error .method. + "Method qualifiers ~S are not allowed in the method ~ + combination ~S." .method-qualifiers. ',name))))) + ,@group-after + ,@body))))))) + +(defmacro define-method-combination (name &body body) + (if (and body (listp (first body))) + `(define-complex-method-combination ,name ,@body) + `(define-simple-method-combination ,name ,@body))) diff --git a/src/cross-clasp/clos/discriminate.lisp b/src/cross-clasp/clos/discriminate.lisp new file mode 100644 index 0000000000..f74b165839 --- /dev/null +++ b/src/cross-clasp/clos/discriminate.lisp @@ -0,0 +1,93 @@ +(in-package #:cross-clasp.clasp.clos) + +;;;; Generate a discriminating function. +#| +Because stamps are not stable, we can't generate an efficient search at +build time - we don't know what the stamps will be at runtime. (It would +be nice to figure out how to do that, but I can't think of any easy to +maintain system right now.) So we just generate some basic CASEs. These +are a little inefficient, but if need be they could be updated into +something more optimized once the system is up. + +We also use a pretty inefficient expansion that doesn't merge paths +to similar outcomes or anything. +|# + +(defun generate-discrimination (outcome-tags miss-tag + positions args specializer-profile + call-history) + (cond + ((null positions) + (unless (= (length call-history) 1) + (error "Duplicate call history entries: ~s" call-history)) + `(go ,(or (cdr (assoc (cdr (first call-history)) outcome-tags)) + (error "No tag for outcome: ~s" (cdr (first call-history)))))) + ((null (elt specializer-profile (first positions))) + (generate-discrimination + outcome-tags miss-tag + (rest positions) args specializer-profile call-history)) + (t (loop + ;; A list (specializer . reduced-call-history) + ;; where reduced-call-history is the subset of call-history with that + ;; specializer in this position. + with tree = nil + for position = (first positions) + for arg = (nth position args) + for entry in call-history + for (specs . outcome) = entry + for spec = (first specs) + for existing = (assoc spec tree) + if existing + do (push entry (cdr existing)) + else + do (push (list spec entry) tree) + do (assert (typep spec 'compiler-class)) + finally + (return + `(let ((stamp (instance-stamp ,arg))) + (cond + ,@(loop for (spec . entries) in tree + for scode = `(load-time-value + (let ((stamp (core:class-stamp-for-instances ,spec))) + (if (eq stamp (core:unbound)) + (error "Unbound stamp for ~s" ',(name spec)) + stamp)) + t) + collect `((= ,scode stamp) + ,(generate-discrimination + outcome-tags miss-tag + (rest positions) args specializer-profile + entries))) + (t (go ,miss-tag))))))))) + +(defun generate-discriminator (generic gf-form call-history) + (let* ((reqargs (required-parameters generic)) + (rest (if (restp generic) (gensym "REST") nil)) + ;; Produce an alist from outcomes to tags. The same outcome + ;; will get the same tag. + (outcome-tags (loop for (_ . outcome) in call-history + unless (assoc outcome result) + collect (cons outcome (gensym "OUTCOME")) + into result + finally (return result))) + ;; A list of positions of arguments according to the APO. + (positions (loop for a in (apo generic) + collect (or (position a reqargs) + (error "No position: ~s" a)))) + (miss (gensym "MISS"))) + `(lambda (,@reqargs ,@(if rest `(&rest ,rest) nil)) + (with-effective-method-parameters (,@reqargs ,rest) + (block nil + (tagbody + ,(generate-discrimination outcome-tags miss + positions reqargs + (specializer-profile generic) + call-history) + ,@(loop for (outcome . tag) in outcome-tags + collect tag + collect `(return ,(form outcome))) + ,miss + (return + ,(if rest + `(apply #'miss ,gf-form ,@reqargs ,rest) + `(miss ,gf-form ,@reqargs))))))))) diff --git a/src/cross-clasp/clos/dump.lisp b/src/cross-clasp/clos/dump.lisp new file mode 100644 index 0000000000..e4a5bacdfe --- /dev/null +++ b/src/cross-clasp/clos/dump.lisp @@ -0,0 +1,160 @@ +(in-package #:cross-clasp.clasp.clos) + +(defmethod maclina.compile-file:make-load-form ((client cross-clasp:client) + (object outcome) + &optional env) + (declare (ignore env)) + (let* ((form (form object)) + (ep (and (consp form) (eq (first form) 'call-method) + (typep (second form) 'effective-accessor))) + (oclass (cond ((not ep) 'effective-method-outcome) + ((typep (second form) 'effective-reader) + 'optimized-slot-reader) + ((typep (second form) 'effective-writer) + 'optimized-slot-writer) + (t (error "Unknown method class in ~s" form))))) + (values `(early-allocate-instance ,oclass) + `(early-initialize-instance + ,oclass ,object + :methods '(,@(methods object)) + ,@(if ep + `(:index ,(location (second form)) + :slot-name ',(name (slot (original (second form)))) + :class ,(etypecase (second form) + (effective-reader + (first (specializers (second form)))) + (effective-writer + (second (specializers (second form)))))) + `(:function ,(let* ((gf (gf (first (methods object)))) + (req (required-parameters gf)) + (rest (if (restp gf) + (gensym "REST") + nil)) + (ll (if rest + `(,@req &rest ,rest) + req))) + `(lambda ,ll + (with-effective-method-parameters + (,@req ,rest) + ,(form object)))) + :form ',form)))))) + +#+clasp +(defmethod make-load-form ((object outcome) &optional env) + (maclina.compile-file:make-load-form maclina.machine:*client* object env)) + +(defmethod maclina.compile-file:make-load-form ((client cross-clasp:client) + (object compiler-class) + &optional env) + (declare (ignore env)) + `(find-class ',(name object))) + +#+clasp +(defmethod make-load-form ((object compiler-class) &optional env) + (maclina.compile-file:make-load-form maclina.machine:*client* object env)) + +;;; method dumping is based on the premises that +;;; a) by the time they appear literally, they will already be loaded into the +;;; generic function, so we just need to grab them +;;; b) EXCEPT for effective accessors, which will not yet exist. But their +;;; direct slots will exist, so they must be installed. +;;; c) any one effective accessor will only be dumped in one file. Otherwise +;;; we might get duplicates, which I think is harmless but dumb. +;;; d) slots also already exist. + +(defmethod maclina.compile-file:make-load-form ((client cross-clasp:client) + (object compiler-method) + &optional env) + (declare (ignore env)) + (let* ((gf (gf object)) + (pos (position object (methods gf)))) + (assert pos () "Method on ~s for ~s ~s does not exist" + (name gf) (qualifiers object) (mapcar #'name (specializers object))) + `(with-early-accessors (standard-generic-function) + (elt (generic-function-methods (fdefinition ',(name gf))) ,pos)))) + +#+clasp +(defmethod make-load-form ((object compiler-method) &optional env) + (maclina.compile-file:make-load-form maclina.machine:*client* object env)) + +(defmethod maclina.compile-file:make-load-form ((client cross-clasp:client) + (object effective-accessor) + &optional env) + (declare (ignore env)) + (multiple-value-bind (mclass class-getter cache) + (etypecase object + (effective-reader (values 'effective-reader-method + #'first + '%effective-readers)) + (effective-writer (values 'effective-writer-method + #'second + '%effective-writers))) + (let* ((original (original object)) + (class (funcall class-getter (specializers original))) + ;; we dump the pos form ourselves rather than rely on m-l-f + ;; because we need to look up the slotd in its class, and the + ;; slotd doesn't know what its class is. + (dslot (slot original)) + (dslotpos (position dslot (mop:class-direct-slots class)))) + (assert dslotpos () "Slot ~s is not present in its class ~s" + (name dslot) (name class)) + (values `(early-allocate-instance ,mclass) + `(progn + (early-initialize-instance ,mclass ,object + :original ',original + :location ',(location object)) + (with-early-accessors (std-class standard-direct-slot-definition) + (push (cons ',(location object) ,object) + (,cache (elt (class-direct-slots ,class) + ,dslotpos))))))))) + +#+clasp +(defmethod make-load-form ((object effective-accessor) &optional env) + (maclina.compile-file:make-load-form maclina.machine:*client* object env)) + +;;; The following method is for objects that end up in cfasls but not fasls, +;;; so we don't have to be nearly as scrupulous - they execute in the compiler's +;;; environment, not the target primitive clasp, and use the ct-client. +(defun %make-load-form-saving-slots (object &key (slot-names nil snp) + environment) + (declare (ignore environment)) + (let* ((class (class-of object)) + (all-slots (mop:class-slots class)) + (slot-names + (if snp slot-names (mapcar #'mop:slot-definition-name all-slots)))) + ;; sanity check that slots exist + (when snp + (loop for sn in slot-names + unless (find sn all-slots :key #'mop:slot-definition-name) + collect sn into broken + finally (when broken + (error "BUG: Missing slots: ~s" broken)))) + ;; dump + (values `(allocate-instance (find-class ',(class-name class))) + `(progn ,@(loop for slot-name in slot-names + if (slot-boundp object slot-name) + collect `(setf (slot-value ,object ',slot-name) + ',(slot-value object slot-name)) + else collect `(slot-makunbound ,object ',slot-name)))))) + +(defmethod maclina.compile-file:make-load-form ((client cross-clasp:ct-client) + (object compiler-metaobject) + &optional env) + (declare (ignore env)) + (%make-load-form-saving-slots object)) + +(defmethod maclina.compile-file:make-load-form ((client cross-clasp:ct-client) + (object compiler-generic) + &optional env) + (declare (ignore env)) + (multiple-value-bind (create init) (call-next-method) + (values `(or (gf-info ',(name object)) ,create) + `(unless (gf-info ',(name object)) ,init)))) + +(defmethod maclina.compile-file:make-load-form ((client cross-clasp:ct-client) + (object compiler-class) + &optional env) + (declare (ignore env)) + (multiple-value-bind (create init) (call-next-method) + (values `(or (find-compiler-class ',(name object) nil) ,create) + `(unless (find-compiler-class ',(name object) nil) ,init)))) diff --git a/src/cross-clasp/clos/generics.lisp b/src/cross-clasp/clos/generics.lisp new file mode 100644 index 0000000000..77c00b69de --- /dev/null +++ b/src/cross-clasp/clos/generics.lisp @@ -0,0 +1,539 @@ +(in-package #:cross-clasp.clasp.clos) + +(defclass outcome () + ((%methods :initarg :methods :reader methods) + (%form :initarg :form :reader form))) + +(defun parse-defgeneric-options (options) + (loop with apo with mc with doc with gfclass with mclass + for (name . value) in options + if (member name seen-options) + do (error "Redundant ~s" name) + if (eq name :argument-precedence-order) + do (setf apo value) + else if (eq name :method-combination) + do (setf mc value) + else if (eq name :documentation) + ;; if this was for user code we'd want to do more + ;; validation here (check cdr is null) + do (setf doc (first value)) + else if (eq name :generic-function-class) + do (setf gfclass (first value)) + else if (eq name :method-class) + do (setf mclass (first value)) + else if (eq name :method) + collect value into methods + else if (eq name 'declare) + append value into declarations + else do (error "Unknown option ~s" name) + unless (member name '(declare :method)) + collect name into seen-options + finally (return (values methods apo declarations doc + mc gfclass mclass)))) + +(defun build-mc-form (method-combination) + `(early-make-instance method-combination + :name ',(name method-combination) + :compiler (search-method-combination + ',(name method-combination)) + :options ',(options method-combination))) + +(defun build-gf-form (compiler-generic) + `(let ((gf (early-make-instance + ,(name (gf-class compiler-generic)) + :lambda-list ',(lambda-list compiler-generic) + :method-combination ,(build-mc-form + (gf-method-combination compiler-generic)) + :argument-precedence-order ',(apo compiler-generic) + :method-class (find-class + ',(name (method-class compiler-generic))) + specializer-profile ',(specializer-profile compiler-generic) + :declarations ',(declarations compiler-generic)))) + (core:setf-function-name gf ',(name compiler-generic)) + (core:setf-lambda-list gf ',(lambda-list compiler-generic)) + (set-funcallable-instance-function + ;; this is invalidated-discriminator-closure, but that's defined later. + ;; miss is defined in miss.lisp. + gf (lambda (&rest args) + (declare (core:lambda-name invalidated-discriminator)) + (apply #'miss gf args))) + gf)) + +(defmacro early-defgeneric (name lambda-list &rest options) + (multiple-value-bind (methods apo declarations doc + method-combination class method-class) + (parse-defgeneric-options options) + (declare (ignore doc)) + (multiple-value-bind (required optional rest keys aokp aux keysp) + (alexandria:parse-ordinary-lambda-list lambda-list) + (declare (ignore keys aokp aux)) + (let* ((restp (or optional rest keysp)) + (method-combination + (ensure-method-combination + (or method-combination '(standard)))) + (apo (or apo required)) + (gf (make-instance 'compiler-generic + :name name + :lambda-list lambda-list + :reqargs required :restp restp + :apo apo + :method-combination method-combination + :method-class (cross-clasp:find-compiler-class + (or method-class 'standard-method)) + :declarations declarations + :class (cross-clasp:find-compiler-class + (or class 'standard-generic-function))))) + `(progn + (eval-when (:compile-toplevel) + (note-generic ',name ,gf)) + (setf (fdefinition ',name) ,(build-gf-form gf)) + ,@(loop for method in methods + collect `(defmethod ,name ,@method))))))) + +;;; return the parsed lambda list, but the second value is the list of +;;; specializer specifiers. +(defun parse-method-lambda-list (lambda-list) + (multiple-value-bind (req opt rest keys aokp aux keyp) + (alexandria:parse-ordinary-lambda-list lambda-list + :allow-specializers t) + (multiple-value-bind (req specs) + (loop for r in req + if (consp r) + collect (first r) into params + and collect (second r) into specs + else + collect r into params + and collect 't into specs + finally (return (values params specs))) + (values req specs opt rest keys aokp aux keyp)))) + +;;; Used by Clasp's DEFMETHOD +(defun cross-clasp.clasp.clos::parse-specialized-lambda-list (lambda-list) + (multiple-value-bind (req opt rest keys aokp aux keyp) + (alexandria:parse-ordinary-lambda-list lambda-list + :allow-specializers t) + (multiple-value-bind (req specializers specializedp) + (loop for r in req + if (consp r) + collect (first r) into rs + and collect (second r) into specializers + and collect t into specializedp + else + collect r into rs + and collect 't into specializers + and collect nil into specializedp + finally (return (values rs specializers specializedp))) + (values (reconstruct-lambda-list req opt rest keys aokp aux keyp) + req specializers specializedp)))) +(defun cross-clasp.clasp.clos::fixup-method-lambda-list (lambda-list) + (method-inner-lambda-list lambda-list)) + +(defun specializer-form (specializer) + (etypecase specializer + (compiler-class `(find-class ',(name specializer))) + (compiler-eql-specializer + `(intern-eql-specializer + ',(mop:eql-specializer-object specializer))))) + +(defgeneric build-method-initargs (compiler-method) + (:method-combination append)) + +(defmethod build-method-initargs append ((method compiler-method)) + `(:generic-function (fdefinition ',(name (gf method))) + :lambda-list ',(lambda-list method) + :keywords ',(method-keywords method) + :aok-p ',(method-allows-other-keys-p method) + :specializers (list ,@(mapcar #'specializer-form + (specializers method))) + :qualifiers ',(qualifiers method) + :function ,(second (method-function method)))) + +(defun direct-slot-form (class slot) + (let ((pos (position slot (mop:class-direct-slots class)))) + (assert pos) + `(with-early-accessors (std-class) + (nth ,pos (class-direct-slots (find-class ',(name class))))))) + +(defmethod build-method-initargs append ((method compiler-reader)) + `(:slot-definition + ,(direct-slot-form (first (specializers method)) (slot method)))) +(defmethod build-method-initargs append ((method compiler-writer)) + `(:slot-definition + ,(direct-slot-form (second (specializers method)) (slot method)))) + +(defun build-method-form (compiler-method) + `(early-make-instance ,(name (mclass compiler-method)) + ,@(build-method-initargs compiler-method))) + +(defun block-name (function-name) + (etypecase function-name + (symbol function-name) + ((cons (eql setf) (cons symbol null)) (second function-name)))) + +(defun parse-specializer (spec) + (etypecase spec + (symbol (cross-clasp:find-compiler-class spec)) + ((cons (eql eql) (cons (cons (eql quote) (cons t null)) null)) + (intern-eql-specializer (second (second spec)))) + ((cons (eql eql) (cons (not (or cons symbol)) null)) ; (eql [self-evaluating]) + (intern-eql-specializer (second spec))) + ((cons (eql eql) (cons t null)) + (error "Can't handle evaluated EQL specializer: ~a" spec)))) + +(defun early-method-lambda (lambda-expression environment) + (let (;; If we want to support arbitrary classes for gfs/methods, FIXME here + (gf (mop:class-prototype (find-class 'standard-generic-function))) + (meth (mop:class-prototype (find-class 'standard-method)))) + (multiple-value-bind (method-lambda options) + (%make-method-lambda gf meth lambda-expression environment) + (values method-lambda + (let* ((cnm-p* (or (second (member ''call-next-method-p options + :test #'equal)) + 'function)) + (nmp-p* (or (second (member ''next-method-p-p options + :test #'equal)) + 'function)) + ;; account for extra quoting for evaluation + (cnm-p (cond ((equal cnm-p* ''nil) nil) + ((equal cnm-p* ''t) t) + (t 'function))) + (nmp-p (cond ((equal nmp-p* ''nil) nil) + ((equal nmp-p* ''t) t) + (t 'function)))) + (not (or cnm-p nmp-p))))))) + +;;; Used in build, mimics Clasp's +(defun our-method-lambda-p (method-lambda) + (and (consp method-lambda) + (eq (car method-lambda) 'lambda) + (consp (cdr method-lambda)) + (equal (second method-lambda) '(.method-args. .next-methods.)))) +(defun wrap-contf-lexical-function-binds (form contsym cnm-p nnmp-p + default-cnm-form) + `(macrolet (,@(when (eq cnm-p 't) + `((call-next-method (&rest args) + (if (null args) + ',default-cnm-form + (list* 'funcall ',contsym args))))) + ,@(when (eq nnmp-p 't) + `((next-method-p () + '(typep ,contsym '(not %no-next-method-continuation)))))) + (flet (,@(when (eq cnm-p 'function) + `((call-next-method (&rest cnm-args) + (if (null cnm-args) + ,default-cnm-form + (apply ,contsym cnm-args))))) + ,@(when (eq nnmp-p 'function) + `((next-method-p () + (typep ,contsym '(not %no-next-method-continuation)))))) + ,form))) +(defun contf-lambda (lambda-list lambda-name decls doc body + call-next-method-p no-next-method-p-p) + (let ((contsym (gensym "METHOD-CONTINUATION"))) + (multiple-value-bind (req opt rest keys aokp aux keysp) + (alexandria:parse-ordinary-lambda-list lambda-list) + (declare (ignore keys aokp)) + (if (or (not (null opt)) rest keysp) + `(lambda (,contsym &rest .method-args.) + (declare (core:lambda-name ,lambda-name)) + ,@(when doc (list doc)) + ,(wrap-contf-lexical-function-binds + `(apply (lambda ,lambda-list ,@decls ,@body) .method-args.) + contsym call-next-method-p no-next-method-p-p + `(apply ,contsym .method-args.))) + ;; We have only required parameters. This allows us to use a function + ;; that doesn't APPLY so much. + ;; We have to rebind the required parameters so that call-next-method + ;; can get at the originals, e.g. when the method body SETQs a param. + (let ((req-aliases (loop for r in req + collect (gensym (symbol-name r)))) + (aux-binds + (loop for (var init) in aux + collect `(,var ,init)))) + `(lambda (,contsym ,@req-aliases) + (declare (core:lambda-name ,lambda-name)) + ,@(when doc (list doc)) + ,(wrap-contf-lexical-function-binds + `(let* (,@(mapcar #'list req req-aliases) + ,@aux-binds) + ,@decls + ,@body) + contsym call-next-method-p no-next-method-p-p + `(funcall ,contsym ,@req-aliases)))))))) +(defun method-lambda (name lambda-expression env + lambda-name lambda-list body declarations documentation) + (declare (ignore name)) + (multiple-value-bind (method-lambda options) + (%make-method-lambda + (mop:class-prototype (find-class 'standard-generic-function)) + (mop:class-prototype (find-class 'standard-method)) + lambda-expression env) + (let* ((cnm-p* (or (second (member ''call-next-method-p options + :test #'equal)) + 'function)) + (nmp-p* (or (second (member ''next-method-p-p options + :test #'equal)) + 'function)) + ;; account for extra quoting for evaluation + (cnm-p (cond ((equal cnm-p* ''nil) nil) + ((equal cnm-p* ''t) t) + (t 'function))) + (nmp-p (cond ((equal nmp-p* ''nil) nil) + ((equal nmp-p* ''t) t) + (t 'function)))) + (values + (cond ((not (our-method-lambda-p method-lambda)) method-lambda) + ((not (or cnm-p nmp-p)) + `(make-%leaf-method-function ,lambda-expression)) + (t `(make-%contf-method-function + ,(contf-lambda lambda-list lambda-name declarations documentation + body cnm-p nmp-p)))) + options)))) + +(defun expand-early-defmethod (name qualifiers lambda-list body environment) + (multiple-value-bind (required specializers optional rest keys aokp aux keysp) + (parse-method-lambda-list lambda-list) + (let ((rlambda-list (reconstruct-lambda-list required optional + rest keys aokp aux keysp)) + ;; Same as above but with no &aux, for method-lambda-list et al. + (elambda-list (reconstruct-lambda-list required optional + rest keys aokp () keysp))) + (multiple-value-bind (method-lambda leafp) + (let ((args (gensym "ARGS"))) + (early-method-lambda + `(lambda (&rest ,args) + ;; not using the lambda list directly so we don't have to + ;; process declarations. + (block ,(block-name name) + (destructuring-bind ,rlambda-list ,args ,@body))) + environment)) + ;; Because we assume all methods are standard, we use our own method + ;; bodies. The code is written this way in case at some far off time + ;; we do want to allow nonstandard methods. + (declare (ignore method-lambda)) + (let* ((generic-function (cross-clasp:gf-info name)) + (gfp (not (not generic-function))) + (restp (or optional rest keysp)) + (generic-function + (if gfp + generic-function + (make-instance 'compiler-generic + :name name + :lambda-list elambda-list ; FIXME: adjust &key? + :reqargs required :restp restp + :apo required + :method-combination (ensure-method-combination + '(standard)) + :method-class (cross-clasp:find-compiler-class + 'standard-method) + :declarations () + :class (cross-clasp:find-compiler-class + 'standard-generic-function)))) + (mfsname (format nil "~a~@[-~a~]-(~{~a~^ ~})-METHOD" + name qualifiers specializers)) + (package + ;; We can't define stuff in the CL package + ;; so we just substitute CLOS for it. But we don't always want + ;; to use CLOS since we define methods from other packages and + ;; CLOS is locked. + (let ((s (etypecase name + (symbol (symbol-package name)) + ((cons (eql setf) (cons symbol null)) + (symbol-package (second name)))))) + (if (eq s (load-time-value (find-package "CL") t)) + (find-package "CROSS-CLASP.CLASP.CLOS") + s))) + (mfname (intern mfsname package)) + (cname (gensym "CONTINUATION")) + (argsname (gensym "METHOD-ARGS")) + (function-form (if leafp + `(leaf (make-%leaf-method-function #',mfname) + #',mfname) + `(contf (make-%contf-method-function #',mfname) + #',mfname))) + (method (make-instance 'compiler-method + :gf generic-function + :lambda-list elambda-list + :keywords (mapcar #'caar keys) + :aok-p aokp + :specializers (mapcar #'parse-specializer specializers) + :qualifiers qualifiers + :class (method-class generic-function) + :function-form function-form)) + (gfg (gensym "GENERIC-FUNCTION"))) + `(progn + (eval-when (:compile-toplevel) + ,@(unless gfp + `((note-generic ',name ,generic-function))) + (note-method ,generic-function ,method)) + ,(multiple-value-bind (body decls) + (alexandria:parse-body body :documentation t) + (if leafp + `(defun ,mfname ,rlambda-list + ,@decls + (declare (ignorable ,@required)) + (block ,(block-name name) + ,@body)) + `(defun ,mfname (,cname &rest ,argsname) + (block ,(block-name name) + (flet (;; If you want to use next-method-p: Too bad + (call-next-method (&rest args) + (if args + (apply ,cname args) + (apply ,cname ,argsname)))) + (declare (ignorable #'call-next-method)) + (apply (lambda ,rlambda-list + (declare (ignorable ,@required)) + ,@decls + ,@body) + ,argsname)))))) + (let ((,gfg ,(if gfp + `(fdefinition ',name) + (build-gf-form generic-function)))) + ,@(unless gfp + `((setf (fdefinition ',name) ,gfg))) + (with-early-accessors (standard-generic-function) + ;; If we specialized anything, update the specializer profile. + ,@(loop with tc = (cross-clasp:find-compiler-class 't) + for spec in (specializers method) + for i from 0 + if (typep spec 'compiler-eql-specializer) + collect `(aref sp ,i) into body + and collect `(let ((e (aref sp ,i)) + (o ',(mop:eql-specializer-object spec))) + (if (listp e) (cons o e) (list o))) + into body + else unless (eq spec tc) + collect `(aref sp ,i) into body + ;; FIXME: this won't work if there was already an eql spec + and collect t into body + finally (return + (if (null body) + nil + `((let ((sp (generic-function-specializer-profile ,gfg))) + (setf ,@body)))))) + (push ,(build-method-form method) + (%generic-function-methods ,gfg)))))))))) + +(defmacro early-defmethod (name &rest rest &environment env) + (loop for r on rest + for e = (first r) + if (consp e) + return (expand-early-defmethod name qualifiers e (rest r) env) + else collect e into qualifiers)) + +;;; + +(defun apo-permutation (generic) + (loop with req = (required-parameters generic) + for a in (apo generic) + collect (or (position a req) (error "Invalid APO")))) + +(defun apo-function (generic) + ;; Return a function that permutes a list according to the APO. + (let ((perm (apo-permutation generic))) + (lambda (list) + (loop for p in perm collect (nth p list))))) + +(defun applicable-method-p (method classes) + (loop for spec in (specializers method) + for class in classes + always (member spec (mop:class-precedence-list class)))) + +(defun method< (method1 method2 gspecs apof) + (loop for spec1 in (funcall apof (specializers method1)) + for spec2 in (funcall apof (specializers method2)) + for gspec in (funcall apof gspecs) + do (case (specializer< spec1 spec2 gspec) + ((<) (return t)) + ((>) (return nil))))) + +(defun specializer< (s1 s2 gspec) + (let ((cpl (mop:class-precedence-list gspec))) + (cond ((eq s1 s2) '=) + ((member s1 (member s2 cpl)) '>) + ((member s2 (member s1 cpl)) '<) + (t (error "Incomparable specializers: ~s ~s" s1 s2))))) + +(defun compute-applicable-methods-using-classes (generic classes) + (sort (loop for method in (methods generic) + when (applicable-method-p method classes) + collect method) + (let ((apof (apo-function generic))) + (lambda (m1 m2) (method< m1 m2 classes apof))))) + +;;; + +(defun call-history-from-speclists (gfun speclists) + (loop for speclist in speclists + for classes = (mapcar #'cross-clasp:find-compiler-class speclist) + for am = (compute-applicable-methods-using-classes gfun classes) + for fm = (final-methods am classes) + for existing = (find fm outcomes :key #'methods :test #'equal) + for outcome = (or existing + (make-instance 'outcome + :methods fm + :form (compute-effective-method gfun fm))) + collect (cons classes outcome) into call-history + unless existing + collect outcome into outcomes + finally (return call-history))) + +(defun final-methods (methods classes) + (loop for method in methods collect (final-method method classes))) + +(defgeneric final-method (method classes)) +(defmethod final-method ((method compiler-method) classes) + (declare (ignore classes)) + method) +(defmethod final-method ((method compiler-reader) classes) + (let* ((direct (slot method)) + (class (first classes)) + (effloc (location (find (name direct) (mop:class-slots class) :key #'name)))) + (or (find effloc (effective-readers direct) :key #'location) + (let ((final (make-instance 'effective-reader + :gf (gf method) :lambda-list (lambda-list method) + :specializers classes :qualifiers (qualifiers method) + :class (mclass method) + :original method :location effloc))) + (push final (effective-readers direct)) + final)))) +(defmethod final-method ((method compiler-writer) classes) + (let* ((direct (slot method)) + (class (second classes)) + (effloc (location (find (name direct) (mop:class-slots class) :key #'name)))) + (or (find effloc (effective-writers direct) :key #'location) + (let ((final (make-instance 'effective-writer + :gf (gf method) :lambda-list (lambda-list method) + :specializers classes :qualifiers (qualifiers method) + :class (mclass method) + :original method :location effloc))) + (push final (effective-writers direct)) + final)))) + +(defun find-method-form (method methods-var) + (let* ((gf (gf method)) + (pos (position method (methods gf)))) + (assert pos) + `(elt ,methods-var ,pos))) + +(defun call-history-form (call-history) + `(list + ,@(loop for (classes . outcome) in call-history + for classforms = (loop for class in classes + collect `(find-class ',(name class))) + for classvec = `(vector ,@classforms) + collect `(cons ,classvec ,outcome)))) + +(defmacro base-satiate (name &rest speclists) + (let* ((gfun (cross-clasp:gf-info name)) + (call-history (call-history-from-speclists gfun speclists)) + (gfv (gensym (string (if (consp name) (second name) name)))) + (ch-form (call-history-form call-history))) + `(with-early-accessors (standard-generic-function) + (let* ((,gfv (fdefinition ',name)) + (discriminator ,(generate-discriminator gfun gfv call-history))) + (setf (generic-function-call-history ,gfv) ,ch-form + (%fallback-discriminator ,gfv) discriminator) + (set-funcallable-instance-function ,gfv discriminator) + (values))))) diff --git a/src/cross-clasp/clos/make-method-lambda.lisp b/src/cross-clasp/clos/make-method-lambda.lisp new file mode 100644 index 0000000000..706b2a97b9 --- /dev/null +++ b/src/cross-clasp/clos/make-method-lambda.lisp @@ -0,0 +1,115 @@ +(in-package #:cross-clasp.clasp.clos) + +(defgeneric %make-method-lambda + (generic-function method lambda-expression environment)) + +;;; A sham environment that definitely doesn't have call-next-method or +;;; next-method-p bound, since we apparently can't rely on that. Not sure why. +(defclass cnmless () + ((%underlying :initarg :underlying :reader underlying))) + +(defmethod trucler:describe-block (client (env cnmless) name) + (trucler:describe-block client (underlying env) name)) +(defmethod trucler:describe-declarations (client (env cnmless)) + (trucler:describe-declarations client (underlying env))) +(defmethod trucler:describe-function (client (env cnmless) name) + (case name + ((call-next-method next-method-p) nil) + (t (trucler:describe-function client (underlying env) name)))) +(defmethod trucler:describe-optimize (client (env cnmless)) + (trucler:describe-optimize client (underlying env))) +(defmethod trucler:describe-tag (client (env cnmless) name) + (trucler:describe-tag client (underlying env) name)) +(defmethod trucler:describe-variable (client (env cnmless) name) + (trucler:describe-variable client (underlying env) name)) +(defmethod trucler:global-environment (client (env cnmless)) + (trucler:global-environment client (underlying env))) + +;;; Return two values indicating the use of CALL-NEXT-METHOD and NEXT-METHOD-P +;;; in the lambda. Each value can be either T, meaning used in a call, or +;;; FUNCTION, meaning used generally (e.g. by #'call-next-method), or NIL meaning +;;; not referenced at all. +;;; To do this, we compile the body in the environment, and note +;;; if there are unresolved references to call-next-method or next-method-p. +;;; We run silent by suppressing all warnings and errors. If compilation fails +;;; we assume the worst (that it does refer to next methods, somehow). +;;; T is never returned for either value because we cannot distinguish the ways +;;; in which the functions are referenced, but Clasp uses the above convention. +(defun walk-method-lambda (method-lambda environment) + (let ((cnm-p nil) (nmp-p nil) + ;; Block compilation unit output on abort + (*error-output* (make-broadcast-stream)) + (environment (make-instance 'cnmless :underlying environment))) + (handler-bind ((maclina.compile:unknown-function + (lambda (c) + (case (maclina.compile:name c) + (call-next-method (setf cnm-p 'function)) + (next-method-p (setf nmp-p 'function))))) + (warning #'muffle-warning) + (error (lambda (c) + (return-from walk-method-lambda + (values 'function 'function))))) + ;; Compile without linking. This is important so that for example + ;; it doesn't bother trying to resolve load-time-value forms. + (maclina.compile:compile-into (maclina.compile:make-cmodule) + method-lambda environment)) + (values cnm-p nmp-p))) + +;;; Given a parsed lambda list, reconstruct it. +;;; This is used after getting the specializers out. +(defun reconstruct-lambda-list (required optional rest keys aokp aux keyp) + `(,@required + ,@(when optional '(&optional)) ,@(loop for opt in optional + for (var default -p) = opt + collect (if -p + opt + (list var default))) + ,@(when rest `(&rest ,rest)) + ,@(when keyp '(&key)) ,@(loop for key in keys + for ((keyword var) default -p) = key + collect (if -p + key + (list (list keyword var) default))) + ;; Keyword checking is done by the GF, so methods should not check again + ,@(when (or keyp aokp) '(&allow-other-keys)) + ,@(when aux `(&aux ,@aux)))) + +(defun method-inner-lambda-list (lambda-list) + (multiple-value-call #'reconstruct-lambda-list + (alexandria:parse-ordinary-lambda-list lambda-list))) + +(defmethod %make-method-lambda ((gf standard-generic-function) + (method standard-method) + lambda-expression environment) + (declare (ignore gf method)) + (assert (typep lambda-expression '(cons (eql lambda) (cons list t)))) + (multiple-value-bind (cnm-p nmp-p) + (walk-method-lambda lambda-expression environment) + (let ((lambda-list (second lambda-expression)) (body (cddr lambda-expression))) + (multiple-value-bind (body decls doc) + (alexandria:parse-body body + :documentation t :whole lambda-expression) + (let ((lambda-name (loop for (declare . decs) in decls + for p = (assoc 'core:lambda-name decs) + when p return (second p)))) + (values + `(lambda (.method-args. .next-methods.) + ,@(when doc (list doc)) + ,@(when lambda-name `((declare (cross-clasp.clasp.core:lambda-name + ,lambda-name)))) + (flet (,@(when cnm-p + `((call-next-method (&rest args) + (if (null .next-methods.) + ;; FIXME: should call no-next-method. + ;; This is hard, because the method doesn't exist + ;; when this method is created. + (error "No next method") + (funcall (method-function (car .next-methods.)) + (if (null args) .method-args. args) + (rest .next-methods.)))))) + ,@(when nmp-p + `((next-method-p () (not (null .next-methods.)))))) + (apply (lambda (,(method-inner-lambda-list lambda-list)) + ,@decls ,@body) + .method-args.))) + (list ''call-next-method-p `',cnm-p ''next-method-p-p `',nmp-p))))))) diff --git a/src/cross-clasp/clos/method-combination.lisp b/src/cross-clasp/clos/method-combination.lisp new file mode 100644 index 0000000000..3071a1aa40 --- /dev/null +++ b/src/cross-clasp/clos/method-combination.lisp @@ -0,0 +1,110 @@ +(in-package #:cross-clasp.clasp.clos) + +(defun invalid-qualified (methods allowed empty-ok-p) + (loop for method in methods + for qual = (qualifiers method) + unless (or (and empty-ok-p (null qual)) + (and (= (length qual) 1) + (member (first qual) allowed))) + collect method)) + +(defun check-qualifiers (generic methods allowed &optional (empty-ok-p t)) + (let ((invalid (invalid-qualified methods allowed empty-ok-p))) + (unless (null invalid) + (error "Invalid qualifiers for methods on ~s: ~s" + (name generic) invalid)))) + +(defun qualified-methods (qualifiers methods) + (loop for method in methods + when (equal qualifiers (qualifiers method)) + collect method)) + +(defun compute-standard-effective-method (gf methods) + (check-qualifiers gf methods '(:around :before :after)) + (let* ((around (qualified-methods '(:around) methods)) + (before (qualified-methods '(:before) methods)) + (primary (qualified-methods () methods)) + (after (qualified-methods '(:after) methods))) + (when (null primary) + (error "Missing primary methods on ~s" (name gf))) + (flet ((call-methods (methods) + (loop for method in methods + collecting `(call-method ,method)))) + (let* ((wprimary `(call-method ,(first primary) (,@(rest primary)))) + (wafter (if after + `(multiple-value-prog1 ,wprimary ,(call-methods after)) + wprimary)) + (wbefore (if before + `(progn ,(call-methods before) ,wafter) + wafter)) + (waround (cond ((not around) wbefore) + ((or before after) + `(call-method ,(first around) + (,@(rest around) + (make-method ,wbefore)))) + (t `(call-method ,(first around) + (,@(rest around) ,@primary)))))) + waround)))) + +(defun compute-effective-method (generic methods) + (let ((mc (gf-method-combination generic))) + (unless (and (eq (name mc) 'standard) (null (options mc))) + (error "Method combination (~s~{~s~^ ~}) unsupported" + (name mc) (options mc))) + (compute-standard-effective-method generic methods))) + +(defmacro with-effective-method-parameters ((&rest spreadable) &body body) + `(symbol-macrolet ((+emf-params+ (,@spreadable))) ,@body)) + +(defun emf-params (env) (cross-clasp:build-macroexpand-1 '+emf-params+ env)) + +;;; This is only present during build. So we skip details. In particular, +;;; we don't make an actual method object for make-method, because we know +;;; our methods never examine their next-methods as methods. +;;; We don't keep method objects around at all - this makes dumping +;;; call-method forms much easier. +(defmacro %call-method (method &optional next-methods &environment env) + (etypecase method + (effective-reader + (let* ((args (emf-params env)) + (arg (if (rest args) (first args) `(first ,(first args)))) + (valuef + (ecase (allocation method) + ((:instance) `(standard-instance-access arg ',(location method)))))) + `(let* ((arg ,arg) + (value ,valuef)) + (if (eq value (core:unbound)) + (slot-unbound (class-of arg) arg ',(name (slot (original method)))) + value)))) + (effective-writer + (let* ((args (emf-params env)) + (value (if (rest args) (first args) `(first ,(first args)))) + (obj (cond ((null (rest args)) `(second ,(first args))) + ((null (cddr args)) `(first ,(second args))) + (t (second args))))) + (ecase (allocation method) + ((:instance) + `(setf (standard-instance-access ,obj ',(location method)) ,value))))) + (compiler-accessor (error "Unreplaced accessor method: ~s" method)) + ((cons (eql make-method) (cons t null)) (second method)) + (compiler-method + (ecase (first (method-function method)) + ((leaf) + ;; Some (leaf ...) will not have a function form - those for accessors - + ;; but they ought to be handled in the above cases. + (assert (third (method-function method))) + `(apply ,(third (method-function method)) ,@(emf-params env))) + ((contf) + `(apply ,(third (method-function method)) + ,(if (null next-methods) + `(lambda (&rest args) + (declare (ignore args)) + (error "BUG: no next method")) + (let* ((args (emf-params env)) + (req (butlast args)) + (rest (first (last args)))) + `(lambda (,@req ,@(when rest `(&rest ,rest))) + (call-method ,(first next-methods) + ,(rest next-methods))))) + ,@(emf-params env))))))) + diff --git a/src/cross-clasp/condition-system-macros.lisp b/src/cross-clasp/condition-system-macros.lisp new file mode 100644 index 0000000000..1f1ba60319 --- /dev/null +++ b/src/cross-clasp/condition-system-macros.lisp @@ -0,0 +1,182 @@ +(in-package #:cross-clasp) + +;;; Kind of a frankenstein of Clasp and common macros here. + +(defun restart-clause-pop-keywords-from-clause (clause-forms) + (let ((things clause-forms) report interactive test) + (macrolet ((handle-keyword (symbol keyword) + (let ((value (gensym "KEYWORD-VALUE"))) + `(progn + (when ,symbol + (error "Duplicate ~S in clause ~S." ,keyword clause-forms)) + (pop things) + (let ((,value (pop things))) + (unless ,value + (error "~S may not be NIL in HANDLER-CLAUSE." ,keyword)) + (setf ,symbol ,value)))))) + (loop + (let ((thing (first things))) + (cond + ((null (rest things)) + (return (values things report interactive test))) + ((eq thing :report) (handle-keyword report :report)) + ((eq thing :interactive) (handle-keyword interactive :interactive)) + ((eq thing :test) (handle-keyword test :test)) + (t (return (values things report interactive test))))))))) + +;;; FIXME? +(defmacro ext:with-current-source-form ((&rest forms) &body body) + `(progn ,@forms ,@body)) + +(defmacro %handler-bind (bindings &body forms) + `(let ((core::*handler-clusters* + (cons (list ,@(mapcar #'(lambda (binding) + (ext:with-current-source-form (binding) + (unless (and (listp binding) + (= (length binding) 2)) + (error + "Ill-formed handler binding ~s." + binding)) + `(cons (lambda (condition) + (typep condition ',(car binding))) + ,(cadr binding)))) + bindings)) + core::*handler-clusters*))) + ,@forms)) + +(defun munge-restart-case-clause (clause) + (ext:with-current-source-form (clause) + (destructuring-bind (name lambda-list . body) clause + (multiple-value-bind (body report interactive test) + (restart-clause-pop-keywords-from-clause body) + (values name lambda-list body + (nconc + (etypecase report + (string + (list :report-function + `(lambda (stream) (write-string ,report stream)))) + (null nil) + ((or symbol (cons (eql lambda))) + (list :report-function `#',report))) + (if interactive + (list :interactive-function `#',interactive) + nil) + (if test + (list :test-function `#',test) + nil))))))) + +(defun munge-with-condition-restarts-form (original-form env) + (ext:with-current-source-form (original-form) + (let ((form (build-macroexpand original-form env))) + (if (consp form) + (let* ((name (first form)) + (condition-form + (case name + ((signal) + `(core::coerce-to-condition ,(second form) + (list ,@(cddr form)) + 'simple-condition + 'signal)) + ((warn) + `(core::coerce-to-condition ,(second form) + (list ,@(cddr form)) + 'simple-warning 'warn)) + ((error) + `(core::coerce-to-condition ,(second form) + (list ,@(cddr form)) + 'simple-error 'error)) + ((cerror) + `(core::coerce-to-condition ,(third form) + (list ,@(cdddr form)) + 'simple-error + 'cerror))))) + (if condition-form + (let ((condition-var (gensym "CONDITION"))) + `(let ((,condition-var ,condition-form)) + (with-condition-restarts ,condition-var + (first core::*restart-clusters*) + ,(if (eq name 'cerror) + `(cerror ,(second form) ,condition-var) + `(,name ,condition-var))))) + original-form)) + original-form)))) + +(defmacro %with-condition-restarts (condition restarts &body forms) + `(let ((core::*condition-restarts* (cons (cons ,condition ,restarts) + core::*condition-restarts*))) + ,@forms)) + +(defmacro %restart-bind (bindings &body forms) + `(let ((core::*restart-clusters* + (cons (list ,@(mapcar #'(lambda (binding) + `(core::make-restart + :NAME ',(car binding) + :FUNCTION ,(cadr binding) + ,@(cddr binding))) + bindings)) + core::*restart-clusters*))) + ,@forms)) + +(defmacro %restart-case (expression &body clauses &environment env) + (let* ((block-tag (gensym)) + (temp-var (gensym)) + ;; This is a gensym in order to avoid leaving cross-clasp symbols + ;; in macroexpansions. + (temp-arg (gensym)) + ;; A list of (name lambda-list body restart-bind-plist) + (data + (loop for clause in clauses + collect (multiple-value-list + (munge-restart-case-clause clause)))) + ;; restart names passed through make-symbol to prevent collisions. + (gnames (loop for (name) in data + for sname = (symbol-name name) + collect (make-symbol sname))) + (expression (munge-with-condition-restarts-form expression env))) + `(block ,block-tag + (let ((,temp-var nil)) + (tagbody + (return-from ,block-tag + ;; NOTE: Might need to mess with package locks + ;; when binding functions of the given names + ;; but right now clasp and maclina ignore locks + ;; for local bindings. + (flet (,@(loop for gname in gnames + collect `(,gname (&rest ,temp-arg) + (setq ,temp-var ,temp-arg) + (go ,gname)))) + (declare (dynamic-extent + ,@(loop for gname in gnames + collect `(function ,gname)))) + (restart-bind + (,@(loop for (name _1 _2 kws) in data + for gname in gnames + collect `(,name #',gname ,@kws))) + ,expression))) + ,@(loop for gname in gnames + for (_ lambda-list body) in data + collect gname ; tag + collect `(return-from ,block-tag + (apply #'(lambda ,lambda-list ,@body) + ,temp-var)))))))) + + +(defmacro %assert (test-form &optional places (datum nil datump) &rest arguments) + `(core::while (not ,test-form) + (setf (values ,@places) + ;; Defined in clos/conditions.lisp + (core::assert-failure ',test-form ',places (list ,@places) + ;; If DATUM is provided, it must be for a + ;; condition; NIL is not acceptable. + ,(if datump datum nil) ,@arguments)))) + +(defmacro %check-type (place type &optional type-string) + (when (and (consp type) (eq 'quote (car type))) + (error "Quoted type specifier in ~s: ~s" + 'check-type type)) + (let ((aux (gensym))) + `(let ((,aux ,place)) + (unless (typep ,aux ',type) + ;; defined in lsp/assert.lisp + (setf ,place (core::do-check-type ,aux ',type ',type-string ',place))) + nil))) diff --git a/src/cross-clasp/cross-clasp.asd b/src/cross-clasp/cross-clasp.asd new file mode 100644 index 0000000000..6a5204066c --- /dev/null +++ b/src/cross-clasp/cross-clasp.asd @@ -0,0 +1,45 @@ +(asdf:defsystem #:cross-clasp + :depends-on (:maclina :closer-mop :extrinsicl :extrinsicl/maclina :anatomicl + :alexandria :ecclesia :clostrum-basic + :trivial-package-local-nicknames :eclector-concrete-syntax-tree + (:feature :clasp :cleavir-maclina-to-bir/module)) + :components ((:file "packages") + (:file "vm-clasp" :depends-on ("packages") :if-feature :clasp) + (:file "trucler-clasp" :depends-on ("packages") + :if-feature :clasp) + (:file "environment" + :depends-on ((:feature :clasp "vm-clasp") + (:feature :clasp "trucler-clasp") + "packages")) + (:file "macrology" :depends-on ("packages")) + (:file "condition-system-macros" :depends-on ("packages")) + (:file "mp-macros" :depends-on ("macrology" "packages")) + (:file "mp-atomics" :depends-on ("packages")) + (:module "clos" :depends-on ("packages") + :components ((:file "cpl") + (:file "classes") + (:file "method-combination" :depends-on ("classes")) + (:file "discriminate" :depends-on ("method-combination")) + (:file "make-method-lambda") + (:file "generics" :depends-on ("make-method-lambda" + "discriminate")) + (:file "dump" :depends-on ("generics")) + (:file "define-method-combination"))) + (:file "defstruct" :depends-on ("clos")) + (:file "with-package-iterator" :depends-on ("environment" "packages")) + (:file "define-unicode-tables" :depends-on ("packages")) + (:file "cst" :depends-on ("packages")) + (:file "opt" :depends-on ("packages")) + (:file "source-pos-info" :depends-on ("packages")) + (:file "native" :depends-on ("packages") + :if-feature :clasp) + (:file "base" :depends-on ("environment" "clos" "defstruct" + "condition-system-macros" + "mp-macros" "mp-atomics" + "define-unicode-tables" + "cst" "packages")) + (:file "fork" :depends-on ("packages") + :if-feature :clasp) + (:file "build" + :depends-on ("base" "packages" + (:feature :clasp "fork"))))) diff --git a/src/cross-clasp/cst.lisp b/src/cross-clasp/cst.lisp new file mode 100644 index 0000000000..8c03d01f5d --- /dev/null +++ b/src/cross-clasp/cst.lisp @@ -0,0 +1,79 @@ +(in-package #:cross-clasp.clasp.concrete-syntax-tree) + +;;;; Give environment-friendly definitions of some CST macros. + +(defun transform (sourcef form) + (typecase form + ;; We can use CL:LIST instead of building a CST because TRANSFORM always + ;; returns a form used as a non-final argument to %APPEND. + (cl:atom `(cl:list (%quote ,sourcef ',form))) + ((cl:cons (eql unquote)) `(cl:list ,(cl:second form))) + ((cl:cons (eql unquote-splicing)) (cl:second form)) + (t `(cl:list ,(appender sourcef form))))) + +(defun transform-compound (sourcef object) + (labels ((rec (object) + (typecase object + ((cl:cons t cl:atom) ; (a . b) + (cl:list (transform sourcef (cl:car object)) + `(%quote ,sourcef ',(cl:cdr object)))) + ((cl:cons t (cl:cons (eql unquote))) ; (a . ,b) + (cl:list (transform sourcef (cl:car object)) + (cl:second (cl:cdr object)))) + ((cl:cons t (cl:cons (eql unquote-splicing))) ; (a . ,@b) + (error "unquote-splicing-in-dotted-list")) + (t (cl:list* (transform sourcef (cl:car object)) + (rec (cl:cdr object))))))) + (rec object))) + +(defun appender (sourcef argument) + ;; We could do some optimization here - transforming to a %LIST*, etc. + `(%append ,sourcef ,@(transform-compound sourcef argument))) + +(defun transform-qq-argument (sourcef argument) + (if (cl:atom argument) + `(%quote ,sourcef ',argument) + (case (cl:car argument) + ((unquote) (cl:second argument)) + ((unquote-splicing) (error "unquote-splicing-at-top")) + (t (appender sourcef argument))))) + +(defmacro quasiquote (sourcef argument) + (let ((gsource (gensym "SOURCE"))) + `(let ((,gsource ,sourcef)) + ,(transform-qq-argument gsource argument)))) + +(defun destructure-variables (tree form) + (let ((bindings '()) + (body-forms '())) + (labels ((traverse (sub-tree sub-form) + (cond ((cl:null sub-tree) + (push `(%null-or-lose ,sub-form ,form ',tree) + body-forms)) + ((symbolp sub-tree) + (push `(,sub-tree ,sub-form) bindings)) + ((not (cl:consp sub-tree)) + (error "expectetree-but-found ~a" sub-tree)) + (t + (let ((temp (gensym))) + (push `(,temp ,sub-form) bindings) + (traverse (cl:first sub-tree) + `(%first-or-lose ,temp ,form ',tree)) + (traverse (cl:rest sub-tree) + `(%rest-or-lose ,temp ,form ',tree))))))) + (traverse tree form)) + (values (reverse bindings) (nreverse body-forms)))) + +(defmacro db (source-var tree form &body body) + ;; We use the DUMMY-VAR hack so we can execute BODY-FORMS after + ;; BINDINGS but before BODY without messing with BODY's + ;; declarations. + (let ((form-var (gensym)) (dummy-var (gensym))) + (multiple-value-bind (bindings body-forms) + (destructure-variables tree form-var) + `(let* ((,form-var ,form) + (,source-var (source ,form-var)) + ,@bindings + (,dummy-var ,@body-forms)) + (declare (ignorable ,source-var ,dummy-var)) + ,@body)))) diff --git a/src/cross-clasp/define-unicode-tables.lisp b/src/cross-clasp/define-unicode-tables.lisp new file mode 100644 index 0000000000..67c20e9e54 --- /dev/null +++ b/src/cross-clasp/define-unicode-tables.lisp @@ -0,0 +1,178 @@ +(cl:in-package #:cross-clasp) + +(defparameter *additional-clasp-character-mappings-alist* + `(("NULL" . #.(code-char 0)) + ("NUL" . #.(code-char 0)) + ("SOH" . #.(code-char 1)) + ("STX" . #.(code-char 2)) + ("ETX" . #.(code-char 3)) + ("EOT" . #.(code-char 4)) + ("ENQ" . #.(code-char 5)) + ("ACK" . #.(code-char 6)) + ("BELL" . #.(code-char 7)) + ("BEL" . #.(code-char 7)) + ("BS" . #.(code-char 8)) + ("HT" . #.(code-char 9)) + ("LF" . #.(code-char 10)) + ("VT" . #.(code-char 11)) + ("FF" . #.(code-char 12)) + ("CR" . #.(code-char 13)) + ("SO" . #.(code-char 14)) + ("SI" . #.(code-char 15)) + ("DLE" . #.(code-char 16)) + ("DC1" . #.(code-char 17)) + ("DC2" . #.(code-char 18)) + ("DC3" . #.(code-char 19)) + ("DC4" . #.(code-char 20)) + ("NAK" . #.(code-char 21)) + ("SYN" . #.(code-char 22)) + ("ETB" . #.(code-char 23)) + ("CAN" . #.(code-char 24)) + ("EM" . #.(code-char 25)) + ("SUB" . #.(code-char 26)) + ("ESCAPE" . #.(code-char 27)) + ("ESC" . #.(code-char 27)) + ("FS" . #.(code-char 28)) + ("GS" . #.(code-char 29)) + ("RS" . #.(code-char 30)) + ("US" . #.(code-char 31)) + ("SP" . #.(code-char 32)) + ("EXCLAMATION_MARK" . #.(code-char 33)) + ("QUOTATION_MARK" . #.(code-char 34)) + ("NUMBER_SIGN" . #.(code-char 35)) + ("DOLLAR_SIGN" . #.(code-char 36)) + ("PERCENT_SIGN" . #.(code-char 37)) + ("AMPERSAND" . #.(code-char 38)) + ("APOSTROPHE" . #.(code-char 39)) + ("LEFT_PARENTHESIS" . #.(code-char 40)) + ("RIGHT_PARENTHESIS" . #.(code-char 41)) + ("ASTERISK" . #.(code-char 42)) + ("PLUS_SIGN" . #.(code-char 43)) + ("COMMA" . #.(code-char 44)) + ("HYPHEN-MINUS" . #.(code-char 45)) + ("FULL_STOP" . #.(code-char 46)) + ("SOLIDUS" . #.(code-char 47)) + ("DIGIT_ZERO" . #.(code-char 48)) + ("DIGIT_ONE" . #.(code-char 49)) + ("DIGIT_TWO" . #.(code-char 50)) + ("DIGIT_THREE" . #.(code-char 51)) + ("DIGIT_FOUR" . #.(code-char 52)) + ("DIGIT_FIVE" . #.(code-char 53)) + ("DIGIT_SIX" . #.(code-char 54)) + ("DIGIT_SEVEN" . #.(code-char 55)) + ("DIGIT_EIGHT" . #.(code-char 56)) + ("DIGIT_NINE" . #.(code-char 57)) + ("COLON" . #.(code-char 58)) + ("SEMICOLON" . #.(code-char 59)) + ("LESS-THAN_SIGN" . #.(code-char 60)) + ("EQUALS_SIGN" . #.(code-char 61)) + ("GREATER-THAN_SIGN" . #.(code-char 62)) + ("QUESTION_MARK" . #.(code-char 63)) + ("COMMERCIAL_AT" . #.(code-char 64)) + ("LATIN_CAPITAL_LETTER_A" . #.(code-char 65)) + ("LATIN_CAPITAL_LETTER_B" . #.(code-char 66)) + ("LATIN_CAPITAL_LETTER_C" . #.(code-char 67)) + ("LATIN_CAPITAL_LETTER_D" . #.(code-char 68)) + ("LATIN_CAPITAL_LETTER_E" . #.(code-char 69)) + ("LATIN_CAPITAL_LETTER_F" . #.(code-char 70)) + ("LATIN_CAPITAL_LETTER_G" . #.(code-char 71)) + ("LATIN_CAPITAL_LETTER_H" . #.(code-char 72)) + ("LATIN_CAPITAL_LETTER_I" . #.(code-char 73)) + ("LATIN_CAPITAL_LETTER_J" . #.(code-char 74)) + ("LATIN_CAPITAL_LETTER_K" . #.(code-char 75)) + ("LATIN_CAPITAL_LETTER_L" . #.(code-char 76)) + ("LATIN_CAPITAL_LETTER_M" . #.(code-char 77)) + ("LATIN_CAPITAL_LETTER_N" . #.(code-char 78)) + ("LATIN_CAPITAL_LETTER_O" . #.(code-char 79)) + ("LATIN_CAPITAL_LETTER_P" . #.(code-char 80)) + ("LATIN_CAPITAL_LETTER_Q" . #.(code-char 81)) + ("LATIN_CAPITAL_LETTER_R" . #.(code-char 82)) + ("LATIN_CAPITAL_LETTER_S" . #.(code-char 83)) + ("LATIN_CAPITAL_LETTER_T" . #.(code-char 84)) + ("LATIN_CAPITAL_LETTER_U" . #.(code-char 85)) + ("LATIN_CAPITAL_LETTER_V" . #.(code-char 86)) + ("LATIN_CAPITAL_LETTER_W" . #.(code-char 87)) + ("LATIN_CAPITAL_LETTER_X" . #.(code-char 88)) + ("LATIN_CAPITAL_LETTER_Y" . #.(code-char 89)) + ("LATIN_CAPITAL_LETTER_Z" . #.(code-char 90)) + ("LEFT_SQUARE_BRACKET" . #.(code-char 91)) + ("REVERSE_SOLIDUS" . #.(code-char 92)) + ("RIGHT_SQUARE_BRACKET" . #.(code-char 93)) + ("CIRCUMFLEX_ACCENT" . #.(code-char 94)) + ("LOW_LINE" . #.(code-char 95)) + ("GRAVE_ACCENT" . #.(code-char 96)) + ("LATIN_SMALL_LETTER_A" . #.(code-char 97)) + ("LATIN_SMALL_LETTER_B" . #.(code-char 98)) + ("LATIN_SMALL_LETTER_C" . #.(code-char 99)) + ("LATIN_SMALL_LETTER_D" . #.(code-char 100)) + ("LATIN_SMALL_LETTER_E" . #.(code-char 101)) + ("LATIN_SMALL_LETTER_F" . #.(code-char 102)) + ("LATIN_SMALL_LETTER_G" . #.(code-char 103)) + ("LATIN_SMALL_LETTER_H" . #.(code-char 104)) + ("LATIN_SMALL_LETTER_I" . #.(code-char 105)) + ("LATIN_SMALL_LETTER_J" . #.(code-char 106)) + ("LATIN_SMALL_LETTER_K" . #.(code-char 107)) + ("LATIN_SMALL_LETTER_L" . #.(code-char 108)) + ("LATIN_SMALL_LETTER_M" . #.(code-char 109)) + ("LATIN_SMALL_LETTER_N" . #.(code-char 110)) + ("LATIN_SMALL_LETTER_O" . #.(code-char 111)) + ("LATIN_SMALL_LETTER_P" . #.(code-char 112)) + ("LATIN_SMALL_LETTER_Q" . #.(code-char 113)) + ("LATIN_SMALL_LETTER_R" . #.(code-char 114)) + ("LATIN_SMALL_LETTER_S" . #.(code-char 115)) + ("LATIN_SMALL_LETTER_T" . #.(code-char 116)) + ("LATIN_SMALL_LETTER_U" . #.(code-char 117)) + ("LATIN_SMALL_LETTER_V" . #.(code-char 118)) + ("LATIN_SMALL_LETTER_W" . #.(code-char 119)) + ("LATIN_SMALL_LETTER_X" . #.(code-char 120)) + ("LATIN_SMALL_LETTER_Y" . #.(code-char 121)) + ("LATIN_SMALL_LETTER_Z" . #.(code-char 122)) + ("LEFT_CURLY_BRACKET" . #.(code-char 123)) + ("VERTICAL_LINE" . #.(code-char 124)) + ("RIGHT_CURLY_BRACKET" . #.(code-char 125)) + ("TILDE" . #.(code-char 126)) + ("DEL" . #.(code-char 127)))) + +(defparameter cmp::*additional-clasp-character-names* + (alexandria:alist-hash-table *additional-clasp-character-mappings-alist* + :test 'equalp)) + +(defparameter cmp::*mapping-char-code-to-char-names* + (make-hash-table :size (* 1024 32))) + +(defun note-mapping-code (code name) + (setf (gethash name cmp::*additional-clasp-character-names*) + (code-char code)) + (setf (gethash (code-char code) cmp::*mapping-char-code-to-char-names*) name)) + +(defun note-mapping-char (char name) + (setf (gethash name cmp::*additional-clasp-character-names*) char) + (setf (gethash char cmp::*mapping-char-code-to-char-names*) name)) + +(defun process-unicode-file (path) + (with-open-file (stream path + :element-type 'character :direction :input :external-format :utf-8) + (loop for (code . name) in (read stream nil) + when (>= code #xA0) + do (note-mapping-code code name)))) + +(defun process-low-mappings () + ;;; now need to store the mappings for the chars with code < #XA0 + (dolist (pair *additional-clasp-character-mappings-alist*) + (note-mapping-char (cdr pair)(car pair))) + ;;; assure the offical names from clhs + (dolist (pair '(("Backspace" . #.(code-char 8)) + ("Tab" . #.(code-char 9)) + ("Newline" . #.(code-char 10)) + ("Page" . #.(code-char 12)) + ("Return" . #.(code-char 13)) + ("Space" . #.(code-char 32)) + ("Rubout" . #.(code-char 127)))) + (setf (gethash (cdr pair) cmp::*mapping-char-code-to-char-names*) + (car pair)) + (setf (gethash (car pair) cmp::*additional-clasp-character-names*) + (cdr pair)))) + +(defun load-unicode-file (path) + (process-unicode-file path) + (process-low-mappings)) diff --git a/src/cross-clasp/defstruct.lisp b/src/cross-clasp/defstruct.lisp new file mode 100644 index 0000000000..a917422f01 --- /dev/null +++ b/src/cross-clasp/defstruct.lisp @@ -0,0 +1,76 @@ +(in-package #:cross-clasp.clasp.clos) + +(defmethod anatomicl:find-class ((client cross-clasp:client) symbol + &optional (errorp t) environment) + (declare (ignore errorp environment)) + (cross-clasp:find-compiler-class symbol)) + +(defmethod anatomicl:structure-class-name ((client cross-clasp:client)) + ;; This is only really used to validate included structures, + ;; and only in the host! So we need it to be this. + 'compiler-class) +(defmethod anatomicl:structure-object-name ((client cross-clasp:client)) + 'structure-object) + +(defmethod anatomicl:structure-slot-definition-read-only ((slotd compiler-slotd)) + (null (writers slotd))) + +;; We want to override anatomicl's usual method, which expands into an anatomicl function. +;; We also skip the CHECK-TYPE since the expansion's nontrivial I guess, FIXME +(defmethod anatomicl::generate-copier ((client cross-clasp:client) + (desc anatomicl::defstruct-object-description) + layout copier-name) + (declare (ignore layout)) + `(defun ,copier-name (object) (copy-structure object))) + +(defmethod anatomicl::generate-setf-structure-description ((client cross-clasp:client) + desc) + (declare (ignore desc)) + (error "~s not implemented yet TODO" 'anatomicl::generate-setf-structure-description)) + +(defmethod anatomicl::generate-slot-initialization-form ((client cross-clasp:client) + (desc anatomicl::defstruct-object-description) + layout obj slot value) + ;; TODO? Could be more efficient by grabbing the rack beforehand? + `(setf (standard-instance-access ,obj ,(position slot layout)) ,value)) + +(defun parse->slotd (anaslotd) + ;; accessors are handled elsewhere + `(,(anatomicl::slot-name anaslotd) + :initarg ,(anatomicl::keywordify (anatomicl::slot-name anaslotd)) + ,@(when (anatomicl::slot-initform-p anaslotd) + `(:initform ,(anatomicl::slot-initform anaslotd))) + ,(if (anatomicl::slot-read-only anaslotd) ':reader ':accessor) + ,(anatomicl::slot-accessor-name anaslotd) + :type ,(anatomicl::slot-type anaslotd))) + +(defmethod anatomicl::generate-defstruct-bits ((client cross-clasp:client) + (desc anatomicl::defstruct-object-description) + layout environment) + (declare (ignore environment)) + `(progn + (defclass ,(anatomicl::defstruct-name desc) + (,(or (anatomicl::defstruct-included-structure-name desc) + 'structure-object)) + (,@(mapcar #'parse->slotd layout)) + (:default-initargs ,@(loop for slotd in layout + when (anatomicl::slot-initform-p slotd) + collect (anatomicl::keywordify + (anatomicl::slot-name slotd)) + and collect (anatomicl::slot-initform slotd))) + (:metaclass structure-class)) + ,@(when (anatomicl::defstruct-print-object desc) + (list `(defmethod print-object ((object ,(anatomicl::defstruct-name desc)) + stream) + (funcall (function ,(anatomicl::defstruct-print-object desc)) + object stream)))))) + +(defmacro early-defstruct (name-and-options &rest slots &environment env) + (let (;; Make sure accessors etc. are interned in the cross reader *package*, + ;; rather than the host *package*. + (*package* (maclina.machine:symbol-value maclina.machine:*client* + cross-clasp::*build-rte* + '*package*))) + (anatomicl:expand-defstruct maclina.machine:*client* + (anatomicl:parse-defstruct name-and-options slots) + env))) diff --git a/src/cross-clasp/environment.lisp b/src/cross-clasp/environment.lisp new file mode 100644 index 0000000000..f0d33e14d9 --- /dev/null +++ b/src/cross-clasp/environment.lisp @@ -0,0 +1,161 @@ +(in-package #:cross-clasp) + +(defvar *build-rte*) +(defvar *build-ce*) + +(defclass client (#-clasp maclina.vm-cross:client + #+clasp vm-clasp:client + #+clasp trucler-native-clasp:client) + ()) + +;;; A client used for compile-time evaluation. At the moment this just means +;;; defining some MAKE-LOAD-FORMs differently; see clos/dump.lisp. +(defclass ct-client (client) ()) + +(defclass run-time-environment (clostrum-basic:run-time-environment) ()) + +(define-condition substituting-package (warning) + ((%package-name :reader substituting-package :initarg :substituting)) + (:report (lambda (condition stream) + (format stream "Unknown package ~s; substituting CORE" + (substituting-package condition))))) + +(defmethod maclina.machine:find-package ((client client) env (package-name string)) + (or (clostrum:find-package m:*client* env package-name) + (warn 'substituting-package :substituting package-name) + (cl:find-package "CROSS-CLASP.CLASP.CORE"))) + +(defmethod maclina.compile-file::package-name ((client client) env package) + (or (clostrum:package-name client env package) + (warn 'substituting-package :substituting package) + "CORE")) + +(defun cross-compile-file (input-file &rest keys) + (apply #'maclina.compile-file:compile-file input-file + :environment *build-rte* + keys)) + +(defmethod clostrum-sys:variable-cell :around (client (environment run-time-environment) symbol) + (if (keywordp symbol) + (let ((cell (clostrum-sys:ensure-variable-cell client environment symbol))) + (setf (clostrum-sys:variable-cell-value client cell) symbol) + cell) + (call-next-method))) + +(defmethod clostrum-sys:variable-status :around (client (environment run-time-environment) symbol) + (declare (ignore client)) + (if (keywordp symbol) + :constant + (call-next-method))) + +(defun fdesignator (designator) + (etypecase designator + (function designator) + (symbol (clostrum:fdefinition m:*client* *build-rte* designator)))) + +(defun macroexpand-hook () + (fdesignator + (maclina.machine:symbol-value m:*client* *build-rte* + '*macroexpand-hook*))) + +(defun build-macroexpand-1 (form &optional env) + (extrinsicl:macroexpand-1 m:*client* (or env *build-rte*) + (macroexpand-hook) form)) +(defun build-macroexpand (form &optional env) + (extrinsicl:macroexpand m:*client* (or env *build-rte*) + (macroexpand-hook) form)) + +(defun ext:type-expander (specifier &optional env) + (let ((env (trucler:global-environment + m:*client* (or env *build-rte*)))) + (clostrum:type-expander m:*client* env specifier))) +(defun (setf ext:type-expander) (expander specifier &optional env) + (declare (ignore env)) + (setf (clostrum:type-expander m:*client* *build-rte* specifier) + expander)) + +(defun typexpand-1 (type-specifier &optional env) + (let ((expander + (etypecase type-specifier + (symbol (ext:type-expander type-specifier env)) + (cons (ext:type-expander (first type-specifier) env)) + (class nil)))) + (if expander + (values (funcall expander type-specifier env) t) + (values type-specifier nil)))) + +(defun typexpand (type-specifier &optional env) + (multiple-value-bind (expansion expandedp) + (typexpand-1 type-specifier env) + (if expandedp + (values (typexpand expansion env) t) + (values type-specifier nil)))) + +(defun core::normalize-type (type &optional env) + (let ((type (typexpand type env))) + (if (consp type) + (values (first type) (rest type)) + (values type nil)))) + +(defun describe-variable (symbol &optional env) + (trucler:describe-variable m:*client* (or env *build-rte*) symbol)) + +(defun constantp (form &optional env) + (typecase form + (symbol (let ((info (describe-variable form env))) + (typecase info + (trucler:constant-variable-description t) + ;; could put symbol macros here + (t nil)))) + (cons ; could expand this obviously + (case (first form) + ((quote) t) + (t nil))) + (t t))) + +(defun constant-form-value (form &optional env) + (let ((env (or env *build-rte*))) + (typecase form + (symbol (let ((info (describe-variable form env))) + (etypecase info + (trucler:constant-variable-description + (trucler:value info))))) + (cons + (ecase (first form) + ((quote) (second form)))) + (t form)))) + +(defun find-compiler-class (name &optional (errorp t)) + (clostrum:find-class m:*client* *build-rte* name errorp)) + +(defvar *class-infos* (make-hash-table :test #'eq)) + +(defun reset-class-infos () + (clrhash *class-infos*)) + +(defun core::class-info (name &optional env) + (multiple-value-bind (info presentp) (gethash name *class-infos*) + (if presentp + info + (let ((env (trucler:global-environment + m:*client* (or env *build-rte*)))) + (not (not (clostrum:find-class m:*client* env name nil))))))) +(defun (setf core::class-info) (value name &optional env) + (declare (ignore env)) + (setf (gethash name *class-infos*) value)) + +(defun gf-info (name) + ;; stuffed into inline data for now + (let ((dat (clostrum:operator-inline-data m:*client* *build-rte* + name))) + (etypecase dat + ((or null clos::compiler-generic) dat) + (t (error "Not a generic: ~s" name))))) + +;;; necessary as extrinsicl/maclina's methods are specialized on vm-cross:client +#+clasp +(defmethod extrinsicl:symbol-value ((client client) env symbol) + (m:symbol-value client env symbol)) +#+clasp +(defmethod (setf extrinsicl:symbol-value) (new (client client) env symbol) + (setf (m:symbol-value client env symbol) new)) diff --git a/src/cross-clasp/fork.lisp b/src/cross-clasp/fork.lisp new file mode 100644 index 0000000000..bbaf90487f --- /dev/null +++ b/src/cross-clasp/fork.lisp @@ -0,0 +1,165 @@ +(in-package #:cross-clasp) + +(defclass fork-worker () + ((%pid :initarg :pid :reader pid) + (%index :initarg :index :reader index) + (%arguments :initarg :arguments :reader child-arguments) + (%child-stdout :initarg :child-stdout :reader child-stdout) + (%child-stderr :initarg :child-stderr :reader child-stderr) + (%start-time :initform (get-internal-run-time) + :reader start-time) + (%finish-time :accessor finish-time) + (%signal :initform nil :accessor child-signal) + (%status :initform nil :accessor child-status))) + +(defgeneric job-description (job) + (:method ((job fork-worker)) + ;; FIXME: Durr + (first (child-arguments job)))) + +(defun ansi-control (&optional level) + (si:fmt t "%e[{:d}m" + (cond ((eq level :err) 31) + ((eq level :warn) 33) + ((eq level :emph) 32) + ((eq level :debug) 36) + ((eq level :info) 37) + (t 0)))) + +(defun message (level control-string &rest args) + (ansi-control level) + (apply #'format t control-string args) + (ansi-control) + (terpri)) + +(defun message-fd (level fd) + (let ((buffer (make-array 1024 :element-type 'base-char :adjustable nil))) + (ansi-control level) + (si:lseek fd 0 :seek-set) + (loop (multiple-value-bind (num-read errno) + (si:read-fd fd buffer) + (declare (ignore errno)) + (if (> num-read 0) + (write-sequence buffer t :start 0 :end num-read) + (return)))) + (si:close-fd fd) ; FIXME: unwind protect? + (ansi-control))) + +;;; Given JOBS, which is a hash table from PIDs to FORK-WORKERs, +;;; wait for one job to finish, remove the job from JOBS, and return +;;; the job. +(defun wait-on-children (jobs) + (loop (multiple-value-bind (wpid status) + (si:wait) + (when (= -1 wpid) + (message :err "No children left to wait on.") + (si:exit 1)) + (let ((entry (gethash wpid jobs))) + (cond ((si:wifsignaled status) + (setf (child-signal entry) (si:wtermsig status)) + (remhash wpid jobs) + (return entry)) + ((si:wifexited status) + (setf (child-status entry) (si:wexitstatus status)) + (remhash wpid jobs) + (return entry))))))) + +;;; Display information about a completed job. +(defun display-job (job) + (let ((failedp + (or (child-signal job) (not (zerop (child-status job)))))) + (message (if failedp :err :emph) + "~:[Compiled~;Failed~] [~d~@[ of ~d~]] ~a~%" + failedp + (index job) *total-jobs* (job-description job))) + (message-fd :info (child-stdout job)) + (message-fd :warn (child-stderr job)) + (cond ((child-signal job) + (message :err "~&~tProcess exited with signal ~a" + (child-signal job))) + ((not (zerop (child-status job))) + (message :err "~&~tProcess exited with status ~a" + (child-status job))))) + +;;; Fork off a process to apply FUNCTION to ARGUMENTS. +(defun %fork-worker (jobs index function &rest arguments) + (let ((child-stdout (si:mkstemp-fd "clasp-build-stdout")) + (child-stderr (si:mkstemp-fd "clasp-build-stderr"))) + (multiple-value-bind (maybe-error pid) + (si:fork-redirect child-stdout child-stderr) + (let ((job (make-instance 'fork-worker + :child-stdout child-stdout + :child-stderr child-stderr + :arguments arguments + :pid pid :index index))) + (cond ((zerop pid) + ;; Child + ;; FIXME: immensely stupid kludge to get at host EXT + (#.(let ((*package* (find-package "KEYWORD"))) + (find-symbol "DISABLE-DEBUGGER" "EXT"))) + ;;(ext:disable-debugger) + (apply function arguments) + (setf (finish-time job) (get-internal-run-time)) + (sys:c_exit)) + (t + ;; Parent + (setf (gethash pid jobs) job))))))) + +(defvar *jobs*) +(defvar *running-job-count*) +(defvar *max-running*) +(defvar *next-job-index*) +(defvar *total-jobs*) + +(defun call-with-forking (parallel-jobs total-jobs thunk) + (let ((*jobs* (make-hash-table)) + (*running-job-count* 0) + (*max-running* parallel-jobs) + (*next-job-index* 0) + (*total-jobs* total-jobs)) + (multiple-value-prog1 + (funcall thunk) + (finish-output) + ;; Wait for all forks to finish. + (loop until (zerop *running-job-count*) + do (display-job (wait-on-children *jobs*)) + (decf *running-job-count*))))) + +(defmacro with-forking ((&key (parallel-jobs '1) + (total-jobs nil)) + &body body) + `(call-with-forking ,parallel-jobs ,total-jobs + (lambda () (progn ,@body)))) + +(defun fork-worker (function &rest arguments) + (loop while (> *running-job-count* *max-running*) + do (display-job (wait-on-children *jobs*)) + (decf *running-job-count*)) + (apply #'%fork-worker *jobs* *next-job-index* function arguments) + (incf *running-job-count*) + (incf *next-job-index*)) + +;;; For each element in ARGLISTS, we fork and call WORK on the +;;; arglist, while in the main thread we call SEQWORK on the arglist. +;;; For building, WORK builds the native FASL, while SEQWORK loads +;;; the previously created CFASL. +(defun fork-loop (work seqwork arglists &key (parallel-jobs 1)) + (let ((jobs (make-hash-table)) + (running 0) + (count (length arglists))) + (loop for arglist in arglists + for i from 0 + ;; Wait for jobs to finish until we can set up a new worker. + do (loop until (< running parallel-jobs) + do (display-job (wait-on-children jobs) count) + (decf running)) + ;; now fork off the work + (apply #'fork-worker jobs index work arglist) + (incf running) + ;; and do the sequential action + (funcall seqwork arglist)) + ;; Wait for all forks to finish. + (loop until (zerop running) + do (display-job (wait-on-children jobs) count) + (decf running))) + (values)) diff --git a/src/cross-clasp/macrology.lisp b/src/cross-clasp/macrology.lisp new file mode 100644 index 0000000000..8b521119f9 --- /dev/null +++ b/src/cross-clasp/macrology.lisp @@ -0,0 +1,292 @@ +(in-package #:cross-clasp.clasp.core) + +(defmacro with-unique-names (symbols &body body) + `(let* ,(mapcar (lambda (symbol) + (let* ((symbol-name (symbol-name symbol)) + (stem symbol-name)) + `(,symbol (gensym ,stem)))) + symbols) + ,@body)) + +(defmacro with-clean-symbols (symbols &body body) + "Rewrites the given forms replacing the given symbols with uninterned +ones, which is useful for creating hygienic macros." + `(progn ,@(sublis (mapcar #'(lambda (s) (cons s (make-symbol (symbol-name s)))) + symbols) + body))) + +(defmacro once-only (specs &body body) + "Once-Only ({(Var Value-Expression)}*) Form* + +Create a Let* which evaluates each Value-Expression, binding a +temporary variable to the result, and wrapping the Let* around the +result of the evaluation of Body. Within the body, each Var is bound +to the corresponding temporary variable. + +Bare symbols in `specs' are equivalent to: + + (symbol symbol) + +Example: + + (defmacro cons1 (x) + (once-only (x) `(cons ,x ,x))) + (let ((y 0)) + (cons1 (incf y))) + ; => (1 . 1) +" + (labels ((frob (specs body) + (if (null specs) + `(progn ,@body) + (let ((spec (first specs))) + (cond ((atom spec) + (setf spec (list spec spec))) + ((/= (length spec) 2) + (error "Malformed Once-Only binding spec: ~S." spec))) + (let ((name (first spec)) + (exp-temp (gensym))) + `(let ((,exp-temp ,(second spec)) + (,name (gensym "OO-"))) + (list 'let (list (list ,name ,exp-temp)) + ,(frob (rest specs) body)) + #+(or) ; can't use host quasiquote + `(let ((,,name ,,exp-temp)) + ,,(frob (rest specs) body)))))))) + (frob specs body))) + +(defmacro defconstant-eqx (name form test &rest rest) + `(defconstant ,name + (let ((value ,form)) + (cond ((not (boundp ',name)) value) + ((,test (symbol-value ',name) value) + (symbol-value ',name)) + (t value))) ; probably error + ,@rest)) + +(defmacro defconstant-equal (name form &rest rest) + `(defconstant-eqx ,name ,form equal ,@rest)) + +(defun process-declarations (body &optional docstringp) + (multiple-value-bind (body decls doc) + (alexandria:parse-body body :documentation docstringp) + (let* ((decls (mapcan (lambda (L) (copy-list (cdr L))) decls)) + (specials + (loop for thing in decls + when (and (consp thing) + (eq (car thing) 'special)) + append (cdr thing)))) + (values decls body doc specials)))) + +(defun find-declarations (body &optional (docp t)) + (multiple-value-bind (decls body doc) + (process-declarations body docp) + (values (if decls `((declare ,@decls)) nil) + body doc))) + +(defun dm-too-many-arguments (current-form vl macro-name) + (error 'destructure-wrong-number-of-arguments + :macro-name macro-name :lambda-list vl :arguments current-form + :problem :too-many)) + +(defun dm-too-few-arguments (current-form vl macro-name) + (error 'destructure-wrong-number-of-arguments + :macro-name macro-name :lambda-list vl :arguments current-form + :problem :too-few)) + +(defun function-block-name (fname) + (etypecase fname + (symbol fname) + ((cons (eql setf) (cons symbol null)) (second fname)))) + +(defun process-lambda-list (lambda-list context) + (ecase context + ((function) + (multiple-value-bind (required optional rest keys aokp aux keyp) + (alexandria:parse-ordinary-lambda-list lambda-list) + (values (list* (length required) required) + (list* (length optional) + (loop for (var def -p) in optional + collect var collect def collect -p)) + rest keyp + (list* (length keys) + (loop for ((var key) def -p) in keys + collect var collect key collect def collect -p)) + aokp + (loop for (var def) in aux collect var collect def) + ;; varest-p + nil))))) + +;;; So that parsed macros/whatever can be used in the host w/o complaint. +(declaim (declaration lambda-name lambda-list)) + +(defun cross-clasp.clasp.ext:parse-macro (name lambda-list body &optional env) + (ecclesia:parse-macro-using-canonicalization name lambda-list body env + `((lambda-name (macro-function ,name)) + (lambda-list ,@lambda-list)))) + +(defun cross-clasp.clasp.ext:parse-compiler-macro + (name lambda-list body &optional env) + (ecclesia:parse-compiler-macro-using-canonicalization + name lambda-list body env + `((lambda-name (compiler-macro-function ,name)) + (lambda-list ,@lambda-list)))) + +(defun cross-clasp.clasp.ext:parse-deftype (name lambda-list body &optional env) + (ecclesia:parse-deftype name lambda-list body env + `((lambda-name (cross-clasp.clasp.ext:type-expander ,name)) + (lambda-list ,@lambda-list)))) + +(defun cross-clasp.clasp.ext:parse-define-setf-expander + (name lambda-list body &optional env) + (ecclesia:parse-macro name lambda-list body env + `((lambda-name (cross-clasp.clasp.ext:setf-expander ,name)) + (lambda-list ,@lambda-list)))) + +(defmacro while (condition &body body) `(loop while ,condition do (progn ,@body))) +(defmacro until (condition &body body) `(loop until ,condition do (progn ,@body))) + +(defmacro %defun (&whole whole name lambda-list &body body) + (multiple-value-bind (body decls doc) + (alexandria:parse-body body :documentation t :whole whole) + `(progn + (eval-when (:compile-toplevel) + (cross-clasp.clasp.cmp::register-global-function-def 'defun ',name)) + (setf (fdefinition ',name) + (lambda ,lambda-list + (declare (lambda-name ,name)) + ,@decls + ,@(when doc (list doc)) + (block ,(function-block-name name) ,@body))) + ',name))) + +;;; We avoid clobbering build macros while building Clasp itself, because that +;;; makes it easier to deal with bootstrapping weirdness. +;;; But when we build libraries we need the full Clasp macros. +;;; So, during build we store macro functions in this variable, and then load +;;; them once Clasp is complete enough. +(defvar *delayed-macros* (make-hash-table)) + +(defun delay-macro (name expander) + (setf (gethash name *delayed-macros*) expander)) + +(defun reset-delayed-macros () (clrhash *delayed-macros*)) + +(defmacro %defmacro (name lambda-list &body body &environment env) + (let ((lexpr (cross-clasp.clasp.ext:parse-macro name lambda-list body env))) + `(progn + (eval-when (:compile-toplevel) + (let ((expander #',lexpr)) + (if (macro-function ',name) + (delay-macro ',name expander) + (setf (macro-function ',name) expander)))) + (eval-when (:load-toplevel :execute) + (setf (macro-function ',name) #',lexpr)) + ',name))) + +(defmacro %define-compiler-macro (name lambda-list &body body &environment env) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (compiler-macro-function ',name) + #',(cross-clasp.clasp.ext:parse-compiler-macro name lambda-list body env)) + ',name)) + +(defmacro %deftype (name lambda-list &body body &environment env) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (cross-clasp.clasp.ext:type-expander ',name) + #',(cross-clasp.clasp.ext:parse-deftype name lambda-list body env)) + ',name)) + +(defmacro %define-setf-expander (name lambda-list &body body &environment env) + (let ((lexpr (cross-clasp.clasp.ext:parse-define-setf-expander + name lambda-list body env))) + `(progn + (eval-when (:compile-toplevel) + (unless (cross-clasp.clasp.ext:setf-expander ',name) + (setf (cross-clasp.clasp.ext:setf-expander ',name) #',lexpr))) + (eval-when (:load-toplevel :execute) + (setf (cross-clasp.clasp.ext:setf-expander ',name) #',lexpr)) + ',name))) + +;;; Dummy functions, since we don't need to record source locations +;;; during build. +(defun variable-source-info (var) nil) +(defun (setf variable-source-info) (info var) + (declare (ignore var)) + info) + +(defmacro %defvar (name &optional (value nil valuep) doc) + `(progn + (declaim (special ,name)) + ,@(when valuep + `((unless (boundp ',name) + (setf (symbol-value ',name) ,value)))) + ,@(when (cross-clasp.clasp.ext:current-source-location) + `((setf (variable-source-info ',name) + ',(cross-clasp.clasp.ext:current-source-location)))) + ,@(when doc + `((cross-clasp.clasp.ext:annotate ',name 'documentation 'variable ,doc))) + ',name)) + +(defmacro %defparameter (name value &optional doc) + `(progn + (declaim (special ,name)) + (setf (symbol-value ',name) ,value) + ,@(when (cross-clasp.clasp.ext:current-source-location) + `((setf (variable-source-info ',name) + ',(cross-clasp.clasp.ext:current-source-location)))) + ,@(when doc + `((cross-clasp.clasp.ext:annotate ',name 'documentation 'variable ,doc))) + ',name)) + +;;; These are in common-macros, but they use their own condition classes &c. + +;;; Process a t/otherwise clause into an unambiguous normal clause. +(defun remove-otherwise-from-clauses (clauses) + (mapcar #'(lambda (clause) + (let ((options (first clause))) + (if (member options '(t otherwise)) + (cons (list options) (rest clause)) + clause))) + clauses)) + +(defun accumulate-cases (clauses) + (loop for (mems) in clauses + when (listp mems) append mems + else collect mems)) + +(defmacro %ccase (keyplace &rest clauses) + (let* ((key (gensym)) + (repeat (gensym)) + (block (gensym)) + (clauses (remove-otherwise-from-clauses clauses))) + `(block ,block + (tagbody ,repeat + (let ((,key ,keyplace)) + (return-from ,block + (case ,key ,@clauses + (t (setf ,keyplace + (ccase-error ',keyplace ,key + ',(accumulate-cases clauses))) + (go ,repeat))))))))) +(defmacro %ecase (keyform &rest clauses) + (let ((key (gensym)) + (clauses (remove-otherwise-from-clauses clauses))) + `(let ((,key ,keyform)) + (case ,key ,@clauses + (t (ecase-error ,key ',(accumulate-cases clauses))))))) + +(defmacro %etypecase (keyform &rest clauses) + (let ((key (gensym))) + `(let ((,key ,keyform)) + (cond ,@(loop for (type . body) in clauses + collect `((typep ,key ',type) ,@body)) + (t (etypecase-error ,key ',(mapcar #'car clauses))))))) + +(defmacro %ctypecase (keyplace &rest clauses) + (let ((key (gensym))) + `(loop with ,key = ,keyplace + do (cond ,@(loop for (type . body) in clauses + collect `((typep ,key ',type) + (return (progn ,@body))))) + (setf ,keyplace + (ctypecase-error ',keyplace ,key + ',(mapcar #'car clauses)))))) diff --git a/src/cross-clasp/mp-atomics.lisp b/src/cross-clasp/mp-atomics.lisp new file mode 100644 index 0000000000..530c9472e4 --- /dev/null +++ b/src/cross-clasp/mp-atomics.lisp @@ -0,0 +1,446 @@ +(in-package #:cross-clasp.clasp.mp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; DEFINE-ATOMIC-EXPANSION, GET-ATOMIC-EXPANSION +;;; + +;;; technically we should store this in the environment but it doesn't +;;; actually matter, as we only have the one set of expanders. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *atomic-expanders* (make-hash-table)) + + (defun clear-atomic-expanders () + (setf *atomic-expanders* (make-hash-table))) + (defun atomic-expander (symbol) + (values (gethash symbol *atomic-expanders*))) + (defun (setf atomic-expander) (expander symbol) + (setf (gethash symbol *atomic-expanders*) expander))) + +(defun get-atomic-expansion (place &rest keys + &key environment (order nil orderp) + &allow-other-keys) + "Analogous to GET-SETF-EXPANSION. Returns the following seven values: +* a list of temporary variables, which will be bound as if by LET* +* a list of forms, whose results will be bound to the variables +* a variable for the old value of PLACE, for use in CAS +* a variable for the new value of PLACE, for use in CAS and SETF +* a form to atomically read the value of PLACE +* a form to atomically write the value of PLACE +* a form to perform an atomic EQ-based compare-and-swap of PLACE +The keyword arguments are passed unmodified to the expander, except that +defaulting of ORDER is applied." + (declare (ignore order)) + ;; Default the order parameter. KLUDGEy. + (unless orderp (setf keys (list* :order :sequentially-consistent keys))) + (etypecase place + (symbol + (let ((info (cross-clasp:describe-variable place environment))) + (etypecase info + (trucler:special-variable-description + (apply #'get-atomic-expansion `(symbol-value ',place) keys)) + (trucler:symbol-macro-description + (apply #'get-atomic-expansion + (cross-clasp:build-macroexpand-1 place environment) + keys)) + (trucler:lexical-variable-description + (error "Lexical variable is not an atomic place: ~s" place)) + (trucler:constant-variable-description + (error "Constant is not an atomic place: ~s" place)) + (null + (error "Can't macroexpand atomic place for unknown variable: ~s" + place))))) + (cons + (let* ((name (car place)) + (expander (atomic-expander name))) + (if expander + (apply expander place keys) + (multiple-value-bind (expansion expanded) + (cross-clasp:build-macroexpand-1 place environment) + (if expanded + (apply #'get-atomic-expansion expansion keys) + (error "Not an atomic place: ~s" place)))))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun expand-atomic-expander (name place-ll expander-ll body) + (let ((place (gensym "PLACE"))) + (multiple-value-bind (body decls doc) + (alexandria:parse-body body :documentation t) + ;; FIXME: probably have to sort the decls by lambda list (ugh) + `(lambda (,place ,@expander-ll) + ,@decls + ,@(when doc (list doc)) + (destructuring-bind ,place-ll (rest ,place) + (block ,name ,@body))))))) + +(defmacro define-atomic-expander (accessor + place-lambda-list expander-lambda-list + &body body) + "Analogous to DEFINE-SETF-EXPANDER; defines how to access (accessor ...) +places atomically. +The body must return the seven values of GET-ATOMIC-EXPANSION. +It is up to you the definer to ensure the swap is performed atomically. +This means you will almost certainly need Clasp's synchronization operators +(e.g., CAS on some other place). +Unlike setf expanders, atomic expanders can take arbitrary keyword arguments. +These correspond to any keyword arguments used in an ATOMIC place, plus the +keyword :environment which holds the environment, and the defaulting of :order +to :sequentially-consistent. The EXPANDER-LAMBDA-LIST is this lambda list. +All expanders should be prepared to accept :order and :environment. Anything +beyond that is your extension." + (let ((expander (expand-atomic-expander + accessor place-lambda-list expander-lambda-list body))) + `(progn + (eval-when (:compile-toplevel) + (unless (atomic-expander ',accessor) + (setf (atomic-expander ',accessor) #',expander))) + (eval-when (:load-toplevel :execute) + (setf (atomic-expander ',accessor) #',expander)) + ',accessor))) + +;;; RELEASE and ACQUIRE-RELEASE don't really make sense for writes +(defun reduce-read-order (order) + (ecase order + ((:sequentially-consistent :acquire :relaxed) order) + ((:acquire-release) :acquire) + ((:release) :relaxed))) + +;;; same idea +(defun reduce-write-order (order) + (ecase order + ((:sequentially-consistent :release :relaxed) order) + ((:acquire-release) :release) + ((:acquire) :relaxed))) + +(defmacro define-simple-atomic-expander (name (&rest params) + reader writer casser + &optional documentation) + (let ((stemps (loop repeat (length params) collect (gensym "TEMP")))) + `(define-atomic-expander ,name (,@params) (&key order environment) + (declare (ignore environment)) + ,@(when documentation (list documentation)) + (let ((scmp (gensym "CMP")) (snew (gensym "NEW")) + ,@(loop for stemp in stemps + collect `(,stemp (gensym "TEMP"))) + (read-order (reduce-read-order order)) + (write-order (reduce-write-order order))) + (values (list ,@stemps) (list ,@params) scmp snew + (list ',reader read-order ,@stemps) + (list 'progn (list ',writer write-order snew ,@stemps) snew) + (list ',casser order scmp snew ,@stemps)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ATOMIC itself +;;; + +(defmacro atomic (place &rest keys &key order &allow-other-keys + &environment env) + "(ATOMIC place &key order &allow-other-keys) +Atomically read from PLACE. ORDER is an atomic ordering specifier, i.e. one of +the keywords: +:RELAXED :ACQUIRE :RELEASE :ACQUIRE-RELEASE :SEQUENTIALLY-CONSISTENT +The default is the last. The meanings of these match the C++ standard (more +detailed explanation forthcoming elsewhere). +Other keywords are passed to the atomic expander function. +Experimental." + (declare (ignore order)) + (multiple-value-bind (temps values old new read write cas) + (apply #'get-atomic-expansion place :environment env keys) + (declare (ignore old new write cas)) + `(let* (,@(mapcar #'list temps values)) ,read))) + +;;; Installed as a setf expander in base.lisp. +(defun expand-atomic (whole env) + (destructuring-bind (place &rest keys &key &allow-other-keys) (rest whole) + (multiple-value-bind (temps vals old new read write cas) + (apply #'get-atomic-expansion place :environment env keys) + (declare (ignore old cas)) + (values temps vals `(,new) write read)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; CAS +;;; + +(defmacro cas (place old new &rest keys &key order &allow-other-keys + &environment env) + "(CAS place old new) +Atomically store NEW in PLACE if OLD matches the current value of PLACE. +Matching is as if by EQ. +Returns the previous value of PLACE; if it's EQ to OLD the swap happened. +Only the swap is atomic. Evaluation of PLACE's subforms, OLD, and NEW is +not guaranteed to be in any sense atomic with the swap, and likely won't be. +PLACE must be a CAS-able place. CAS-able places are either symbol macros, +special variables, +or accessor forms with a CAR of +SYMBOL-VALUE, SYMBOL-PLIST, CLOS:STANDARD-INSTANCE-ACCESS, THE, +SLOT-VALUE, CLOS:SLOT-VALUE-USING-CLASS, CAR, CDR, FIRST, REST, SVREF, +or macro forms that expand into CAS-able places, +or an accessor defined with DEFINE-ATOMIC-EXPANDER. +Some CAS accessors have additional semantic constraints. +You can see their documentation with e.g. (documentation 'slot-value 'mp:atomic) +This is planned to be expanded to include variables, +possibly other simple vectors, and slot accessors. +Keys are passed to GET-ATOMIC-EXPANSION. +Experimental." + (declare (ignore order)) + (multiple-value-bind (temps values oldvar newvar read write cas) + (apply #'get-atomic-expansion place :environment env keys) + (declare (ignore read write)) + `(let* (,@(mapcar #'list temps values) + (,oldvar ,old) (,newvar ,new)) + ,cas))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Derived operators +;;; + +(defmacro atomic-update-explicit ((place + &rest keys &key order &allow-other-keys) + update-fn &rest arguments &environment env) + (declare (ignore order)) + (multiple-value-bind (vars vals old new read write cas) + (apply #'get-atomic-expansion place :environment env keys) + (declare (ignore write)) + (let ((gfn (gensym "UPDATE-FN")) + (asyms (loop repeat (length arguments) collect (gensym "ARG")))) + `(let* (,@(mapcar #'list vars vals) + (,gfn ,update-fn) + ,@(mapcar #'list asyms arguments) + (,old ,read)) + (loop for ,new = (funcall ,gfn ,old ,@asyms) + until (eq ,old (setf ,old ,cas)) + finally (return ,new)))))) + +(defmacro atomic-update (place update-fn &rest arguments) + "Perform an atomic update of PLACE. In more detail, the value of PLACE is +set to (funcall UPDATE-FN VALUE ARGUMENTS...), where VALUE is the old value of +PLACE. This is analogous to what DEFINE-MODIFY-MACRO expansions do. +As with DEFINE-MODIFY-MACRO, the new value is returned. +Evaluation order is left to right as specified in CLHS 5.1.1.1. Note that this +is different from the SBCL macro of the same name, which may perform multiple +evaluations of the update-fn and arguments, and passes arguments to the update +function in a different order." + `(atomic-update-explicit (,place) ,update-fn ,@arguments)) + +(defmacro atomic-incf-explicit ((place &rest keys &key order &allow-other-keys) + &optional (delta 1)) + (declare (ignore order)) + `(atomic-update-explicit (,place ,@keys) #'+ ,delta)) + +(defmacro atomic-decf-explicit ((place &rest keys &key order &allow-other-keys) + &optional (delta 1)) + (declare (ignore order)) + `(atomic-update-explicit (,place ,@keys) #'- ,delta)) + +(defmacro atomic-incf (place &optional (delta 1)) + `(atomic-update ,place #'+ ,delta)) + +(defmacro atomic-decf (place &optional (delta 1)) + `(atomic-update ,place #'- ,delta)) + +(defmacro atomic-push-explicit + (item (place &rest keys &key order &allow-other-keys) &environment env) + (declare (ignore order)) + (multiple-value-bind (vars vals old new read write cas) + (apply #'get-atomic-expansion place :environment env keys) + (declare (ignore write)) + (let ((gitem (gensym "ITEM"))) + `(let* ((,gitem ,item) ; evaluate left-to-right (CLHS 5.1.1.1) + ,@(mapcar #'list vars vals) + (,old ,read) + (,new (cons ,gitem ,old))) + (loop until (eq ,old (setf ,old ,cas)) + do (setf (cdr ,new) ,old) + finally (return ,new)))))) + +(defmacro atomic-push (item place) + "As CL:PUSH, but as an atomic RMW operation." + `(atomic-push-explicit ,item (,place))) + +(defmacro atomic-pop-explicit ((place &rest keys &key order &allow-other-keys) + &environment env) + (declare (ignore order)) + (multiple-value-bind (vars vals old new read write cas) + (apply #'get-atomic-expansion place :environment env keys) + (declare (ignore write)) + `(let* (,@(mapcar #'list vars vals) + (,old ,read)) + (loop (let ((,new (cdr ,old))) + (when (eq ,old (setf ,old ,cas)) + (return (car ,old)))))))) + +(defmacro atomic-pop (place) + "As CL:POP, but as an atomic RMW operation." + `(atomic-pop-explicit (,place))) + +(defmacro atomic-pushnew-explicit (item (place + &rest place-keys + &key order &allow-other-keys) + &rest keys &key key test test-not + &environment env) + (declare (ignore key test test-not) (ignore order)) + (multiple-value-bind (vars vals old new read write cas) + (apply #'get-atomic-expansion place :environment env place-keys) + (declare (ignore write)) + (let ((gitem (gensym "ITEM")) (bname (gensym "ATOMIC-PUSHNEW")) + gkeybinds gkeys) + ;; Ensuring CLHS 5.1.1.1 evaluation order is weird here. We'd like to + ;; only evaluate the keys one time, but we want the adjoin to get + ;; constant keywords the compiler transformations can work with. + (loop for thing in keys + if (cross-clasp:constantp thing env) + do (push (cross-clasp:constant-form-value thing env) gkeys) + else + do (let ((gkey (gensym "K"))) + (push gkey gkeys) + (push `(,gkey ,thing) gkeybinds)) + finally (setf gkeys (nreverse gkeys) + gkeybinds (nreverse gkeybinds))) + ;; Actual expansion + `(let* ((,gitem ,item) + ,@(mapcar #'list vars vals) + ,@gkeybinds + (,old ,read)) + (loop named ,bname + for ,new = (adjoin ,gitem ,old ,@gkeys) + until (eq ,old (setf ,old ,cas)) + finally (return-from ,bname ,new)))))) + +(defmacro atomic-pushnew (item place &rest keys &key test test-not key) + (declare (ignore test test-not key)) + "As CL:PUSHNEW, but as an atomic RMW operation. +ITEM, the subforms of PLACE, and the keywords are evaluated exactly once in the +same order as they are for CL:PUSHNEW, specified in CLHS 5.1.1.1." + `(atomic-pushnew-explicit ,item (,place) ,@keys)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Particular atomic expanders +;;; + +(define-atomic-expander the (type place) (&rest keys) + "(cas (the y x) o n) = (cas x (the y o) (the y n))" + (multiple-value-bind (vars vals old new read write cas) + (apply #'get-atomic-expansion place keys) + (values vars vals old new + `(the ,type ,read) + `(let ((,new (the ,type ,new))) ,write) + `(let ((,old (the ,type ,old)) (,new (the ,type ,new))) ,cas)))) + +(define-atomic-expander first (list) (&rest keys) + (apply #'get-atomic-expansion `(car ,list) keys)) +(define-atomic-expander rest (list) (&rest keys) + (apply #'get-atomic-expansion `(cdr ,list) keys)) + +(define-simple-atomic-expander car (list) + core:car-atomic core:rplaca-atomic core:cas-car) +(define-simple-atomic-expander cdr (list) + core:cdr-atomic core:rplacd-atomic core:cas-cdr) + +;; Ignores order specification for the moment. +(define-atomic-expander symbol-value (symbol) (&key order environment) + (declare (ignore order environment)) + "Because special variable bindings are always thread-local, the symbol-value +of a symbol can only be used for synchronization through this accessor if there +are no bindings (in which case the global, thread-shared value is used." + (let ((gs (gensym "SYMBOL")) (cmp (gensym "CMP")) (new (gensym "NEW"))) + (values (list gs) (list symbol) cmp new + `(core:atomic-symbol-value ,gs) + `(progn (core:atomic-set-symbol-value ,new ,gs) ,new) + `(core:cas-symbol-value ,cmp ,new ,gs)))) + +(define-atomic-expander symbol-plist (symbol) (&key order environment) + (declare (ignore order environment)) + (let ((gs (gensym "SYMBOL")) (cmp (gensym "CMP")) (new (gensym "NEW"))) + (values (list gs) (list symbol) cmp new + `(core:atomic-symbol-plist ,gs) + `(progn (core:atomic-set-symbol-plist ,new ,gs) ,new) + `(core:cas-symbol-plist ,cmp ,new ,gs)))) + +(define-atomic-expander svref (simple-vector index) (&key order environment) + (declare (ignore environment)) + (let ((gv (gensym "VECTOR")) (gi (gensym "INDEX")) + (cmp (gensym "CMP")) (new (gensym "NEW")) + (read-order (reduce-read-order order)) + (write-order (reduce-write-order order))) + (values (list gv gi) + (list `(the simple-vector ,simple-vector) + `(let ((,gi (the fixnum ,index))) + (unless (array-in-bounds-p ,gv ,gi) + (error 'core:sequence-out-of-bounds + :datum ,gi + :expected-type (list 'integer 0 (length ,gv)) + :object ,gv)) + ,gi)) + cmp new + `(core::atomic-aref ,read-order ,gv ,gi) + `(setf (core::atomic-aref ,write-order ,gv ,gi) ,new) + `(core::acas ,order ,cmp ,new ,gv ,gi)))) + +#+(or) +(define-simple-atomic-expander svref (vector index) + core:atomic-svref core:atomic-svset core:cas-svref) + +(define-simple-atomic-expander core:rack-ref (rack index) + core::atomic-rack-read core::atomic-rack-write core::cas-rack) + +(define-atomic-expander clos:standard-instance-access + (instance location) + (&rest keys) + "The requirements of the normal STANDARD-INSTANCE-ACCESS writer +must be met, including that the slot has allocation :instance, and is +bound before the operation. +If there is a CHANGE-CLASS conflicting with this operation the +consequences are not defined." + (apply #'get-atomic-expansion + `(core:rack-ref (core:instance-rack ,instance) ,location) + keys)) +(define-atomic-expander clos:funcallable-standard-instance-access + (instance location) (&rest keys) + "See STANDARD-INSTANCE-ACCESS for requirements." + (apply #'get-atomic-expansion + `(core:rack-ref (core:instance-rack ,instance) ,location) + keys)) + +(define-atomic-expander slot-value (object slot-name) (&rest keys) + (let ((gobject (gensym "OBJECT")) (gsname (gensym "SLOT-NAME")) + (gslotd (gensym "SLOTD")) (gclass (gensym "CLASS"))) + (multiple-value-bind (vars vals cmpv newv read write cas) + (apply #'get-atomic-expansion + `(clos:slot-value-using-class ,gclass ,gobject ,gslotd) + keys) + (values (list* gobject gsname gclass gslotd vars) + (list* object slot-name `(class-of ,gobject) + `(find ,gsname (class-slots ,gclass) + :key #'slot-definition-name)) + cmpv newv + `(if ,gslotd + ,read + (slot-missing ,gclass ,gobject ,gsname 'slot-value)) + `(if ,gslotd + ,write + (progn (slot-missing ,gclass ,gobject ,gsname 'setf ,newv) + ,newv)) + `(if ,gslotd + ,cas + (slot-missing ,gclass ,gobject ,gsname + 'cas (list ,cmpv ,newv))))))) + +;;; Duplicate defined in clasp's clos/atomics.lisp, but defined here to make +;;; the code nicer. Various functions defined in clos/miss.lisp. +;;; FIXME: Rearrange things so it only needs to be defined within Clasp. +(define-atomic-expander clos::generic-function-call-history (generic-function) + (&rest keys) + (let ((gf (gensym "GENERIC-FUNCTION")) (index (gensym "INDEX"))) + (multiple-value-bind (vars vals cmp new read write cas) + (apply #'get-atomic-expansion + `(clos:funcallable-standard-instance-access ,gf ,index) + keys) + (values (list* gf index vars) + (list* generic-function + `(clos::%gfclass-call-history-loc (class-of ,gf)) + vals) + cmp new read write cas)))) diff --git a/src/cross-clasp/mp-macros.lisp b/src/cross-clasp/mp-macros.lisp new file mode 100644 index 0000000000..afdd847b71 --- /dev/null +++ b/src/cross-clasp/mp-macros.lisp @@ -0,0 +1,67 @@ +(in-package #:cross-clasp.clasp.mp) + +(defmacro without-interrupts (&body body) + (core::with-unique-names + (outer-allow-with-interrupts outer-interrupts-enabled) + `(multiple-value-prog1 + (macrolet ((allow-with-interrupts (&body allow-forms) + (list* 'let + (list (list 'core::*allow-with-interrupts* + ',outer-allow-with-interrupts)) + allow-forms)) + (with-restored-interrupts (&body with-forms) + (list* 'let + (list (list 'core::*interrupts-enabled* + ',outer-interrupts-enabled)) + with-forms)) + (with-local-interrupts (&body with-forms) + (list 'let* + (list (list 'core::*allow-with-interrupts* + ',outer-allow-with-interrupts) + (list 'core::*interrupts-enabled* + ',outer-allow-with-interrupts)) + (list 'when ',outer-allow-with-interrupts + '(core::check-pending-interrupts)) + (list* 'locally with-forms)))) + (let* ((,outer-interrupts-enabled core::*interrupts-enabled*) + (core::*interrupts-enabled* nil) + (,outer-allow-with-interrupts + core::*allow-with-interrupts*) + (core::*allow-with-interrupts* nil)) + (declare (ignorable ,outer-allow-with-interrupts + ,outer-interrupts-enabled)) + ,@body)) + (when core::*interrupts-enabled* + (core::check-pending-interrupts))))) + +(defmacro with-interrupts (&body body) + (core::with-unique-names (allowp enablep) + ;; We could manage without ENABLEP here, but that would require + ;; taking extra care not to ever have *ALLOW-WITH-INTERRUPTS* NIL + ;; and *INTERRUPTS-ENABLED* T -- instead of risking future breakage + ;; we take the tiny hit here. + `(let* ((,allowp core::*allow-with-interrupts*) + (,enablep core::*interrupts-enabled*) + (core::*interrupts-enabled* (or ,enablep ,allowp))) + (when (and ,allowp (not ,enablep)) + (core::check-pending-interrupts)) + (locally ,@body)))) + +(defmacro with-lock ((lock-form &rest options) &body body) + (declare (ignore options)) ; none yet + (core::with-unique-names (lock) + `(let ((,lock ,lock-form)) + (unwind-protect + (progn + (get-lock ,lock) + (locally ,@body)) + (giveup-lock ,lock))))) + +(defmacro with-rwlock ((lock op) &body body) + (assert (member op '(:read :write) :test #'eq)) + (let ((s-lock (gensym))) + `(let ((,s-lock ,lock)) + (,(if (eq :read op) 'shared-lock 'write-lock) ,s-lock) + (unwind-protect + (progn ,@body) + (,(if (eq :read op) 'shared-unlock 'write-unlock) ,s-lock))))) diff --git a/src/cross-clasp/native.lisp b/src/cross-clasp/native.lisp new file mode 100644 index 0000000000..5101690786 --- /dev/null +++ b/src/cross-clasp/native.lisp @@ -0,0 +1,76 @@ +(in-package #:cross-clasp) + +(defclass native-compile-client () ()) +(defvar *native-compile-client* (make-instance 'native-compile-client)) + +(defun module-native-compiler (bytecode literals-info pc-map module-id) + (multiple-value-bind (irmodule fmap literals) + (maclina->bir:compile-cmodule-into + *native-compile-client* bytecode literals-info pc-map + (make-instance 'cleavir-bir:module)) + (clasp-cleavir::bir-transformations irmodule clasp-cleavir:*clasp-system*) + (let (;; KLUDGE + (clasp-cleavir::*make-constant-info* + #'maclina.compile::make-constant-info)) + (clasp-bytecode-to-bir::translate-cmodule + irmodule fmap literals module-id + (let ((f (m:symbol-value m:*client* *build-rte* '*compile-file-pathname*))) + (if f + (namestring f) + "unknown-file")))))) + +(defmethod maclina.compile-file::module-native-attr-name ((client client)) + "clasp:module-native") +(defmethod maclina.compile-file::function-native-attr-name ((client client)) + "clasp:function-native") + +(in-package #:maclina.compile-file) + +(defmethod ensure-module-literal ((info compiler::variable-cell-info)) + (ensure-vcell (compiler::variable-cell-info/vname info))) + +(in-package #:clasp-bytecode-to-bir) + +(defmethod maclina.compile-file::native-module-code ((mod nmodule)) + (nmodule-code mod)) +(defmethod maclina.compile-file::native-module-fmap ((mod nmodule)) + (nmodule-fmap mod)) +(defmethod maclina.compile-file::native-module-literals ((mod nmodule)) + (nmodule-literals mod)) + +(in-package #:clasp-cleavir) + +(defmethod ensure-literal-info ((info maclina.compile:constant-info) + &optional (cinfo info)) + (ensure-similar (maclina.compile:constant-info-value info) t + (vector-push-extend cinfo *constant-indices*) + *similarity*)) + +(defmethod ensure-literal-info ((info maclina.compile:ltv-info) &optional (cinfo info)) + (let ((table (similarity-table-ltv *similarity*))) + (or (gethash ltv-info table) + (setf (gethash ltv-info table) + (vector-push-extend cinfo *constant-indices*))))) + +(defmethod ensure-literal-info ((vinfo maclina.compile:value-cell-info) + &optional (cinfo vinfo)) + (let ((table (similarity-table-vcell *similarity*)) + (vname (maclina.compile:value-cell-info-name vinfo))) + (or (gethash vname table) + (setf (gethash vname table) + (vector-push-extend cinfo *constant-indices*))))) + +(defmethod ensure-literal-info ((finfo maclina.compile:fdefinition-info) + &optional (cinfo finfo)) + (let ((table (similarity-table-fcell *similarity*)) + (fname (maclina.compile:fdefinition-info-name finfo))) + (or (gethash fname table) + (setf (gethash fname table) + (vector-push-extend cinfo *constant-indices*))))) + +(defmethod ensure-literal-info ((info maclina.compile:cfunction) + &optional (cinfo info)) + (let ((table (similarity-table-fungen *similarity*))) + (or (gethash info table) + (setf (gethash info table) + (vector-push-extend cinfo *constant-indices*))))) diff --git a/src/cross-clasp/opt.lisp b/src/cross-clasp/opt.lisp new file mode 100644 index 0000000000..4a4be5ec12 --- /dev/null +++ b/src/cross-clasp/opt.lisp @@ -0,0 +1,108 @@ +(in-package #:cross-clasp) + +;;; Defines a bunch of functions that are used in +;;; Clasp's compiler macro expansions. + +(defun clos::classp (object) (typep object 'class)) +(defun core::short-float-p (object) (typep object 'short-float)) +(defun core::single-float-p (object) (typep object 'single-float)) +(defun core::double-float-p (object) (typep object 'double-float)) +(defun core::long-float-p (object) (typep object 'long-float)) + +(defun core::fixnump (object) + ;; Make sure we use Clasp's idea of a fixnum. + ;; the constants are defined by runtime-variables.lisp. + (and (integerp object) + (>= object (constant-form-value 'most-negative-fixnum)) + (<= object (constant-form-value 'most-positive-fixnum)))) + +(defun core::apply0 (function args) (apply function args)) +(defun core::apply1 (function args a0) (apply function a0 args)) +(defun core::apply2 (function args a0 a1) (apply function a0 a1 args)) +(defun core::apply3 (function args a0 a1 a2) + (apply function a0 a1 a2 args)) +(defun core::apply4 (function args &rest rest) + (multiple-value-call function + (values-list rest) (values-list args))) + +(defun core::two-arg-+ (x y) (+ x y)) +(defun core::two-arg-* (x y) (* x y)) +(defun core::two-arg-- (x y) (- x y)) +(defun core::negate (x) (- x)) +(defun core::two-arg-/ (x y) (/ x y)) +(defun core::reciprocal (x) (/ x)) +(defun core::two-arg-< (x y) (< x y)) +(defun core::two-arg-<= (x y) (<= x y)) +(defun core::two-arg-> (x y) (> x y)) +(defun core::two-arg->= (x y) (>= x y)) +(defun core::two-arg-= (x y) (= x y)) + +(defun core::logand-2op (x y) (logand x y)) +(defun core::logior-2op (x y) (logior x y)) + +;; Use classes as "class holders". +(defun core::find-class-holder (name) + (find-compiler-class name nil)) +;; FIXME: These two oughtn't be in ext +(defun ext::class-unboundp (holder) (null holder)) +(defun ext::class-get (holder) holder) +#| +(defun core::to-short-float (n) (float n 0s0)) +(defun core::to-single-float (n) (float n 0f0)) +(defun core::to-double-float (n) (float n 0d0)) +(defun core::to-long-float (n) (float n 0l0)) +|# +(defun core::make-vector (element-type dimension &optional adjustablep + fill-pointer displaced-to + (displaced-index-offset 0) + initial-element iesp) + (cond + (iesp + (make-array dimension :element-type element-type + :adjustable adjustablep :fill-pointer fill-pointer + :initial-element initial-element)) + (displaced-to + (make-array dimension :element-type element-type + :adjustable adjustablep :fill-pointer fill-pointer + :displaced-to displaced-to + :displaced-index-offset displaced-index-offset)) + (t + (make-array dimension :element-type element-type + :adjustable adjustablep :fill-pointer fill-pointer)))) + +(defun core::concatenate-into-sequence (result &rest seqs) + (loop for pos = 0 then (+ pos (length seq)) + for seq in seqs + do (replace result seq :start1 pos)) + result) +#| +(defun core::every/1 (predicate sequence) (every predicate sequence)) +(defun core::stringify (thing) (prin1-to-string thing)) +|# +(defun core::make-simple-vector-character + (dimension initial-element iesp) + (if iesp + (make-array dimension :initial-element initial-element + :element-type 'character) + (make-array dimension :element-type 'character))) + +(defun core::coerce-to-list (object) (coerce object 'list)) + +(define-condition undefined-type-warning (style-warning) + ((%name :initarg :name :reader name) + (%origin :initarg :origin :reader origin) + (%kind :initform 'type)) + (:report (lambda (condition stream) + (format stream "Undefined type ~s" (name condition))))) + +(defun cmp::warn-undefined-type (origin type) + (warn 'undefined-type-warning :name type :origin origin)) + +(define-condition cannot-coerce-warning (style-warning) + ((%name :initarg :name :reader name) + (%origin :initarg :origin :reader origin)) + (:report (lambda (condition stream) + (format stream "Cannot coerce to type ~s: unknown or not defined for coerce" (name condition))))) + +(defun cmp::warn-cannot-coerce (origin type) + (warn 'cannot-coerce-warning :name type :origin origin)) diff --git a/src/cross-clasp/opt/control.lisp b/src/cross-clasp/opt/control.lisp new file mode 100644 index 0000000000..e36636d139 --- /dev/null +++ b/src/cross-clasp/opt/control.lisp @@ -0,0 +1,181 @@ +(in-package #:cross-clasp) + +(define-cross-compiler-macro apply + (&whole form function &rest arguments &environment env) + (if (null arguments) + form ; error, leave it to runtime + (let* ((fixed (butlast arguments)) + (last (first (last arguments))) + (fsym (gensym "FUNCTION")) + (syms (gensym-list fixed)) + (op (case (length fixed) + ((0) 'core:apply0) + ((1) 'core:apply1) + ((2) 'core:apply2) + ((3) 'core:apply3) + (otherwise 'core:apply4)))) + ;; Pick off (apply ... nil), which could be generated + ;; (for example in CLOS). + (if (and (constantp last env) + (null (ext:constant-form-value last env))) + `(funcall ,function ,@fixed) + ;; The LET is so that we evaluate the arguments to APPLY + ;; in the correct order. + `(let ((,fsym (core:coerce-called-fdesignator ,function)) + ,@(mapcar #'list syms fixed)) + (,op ,fsym ,last ,@syms)))))) + +(defun core:coerce-called-fdesignator (fdesignator) + (etypecase fdesignator + (function fdesignator) + (symbol + (clostrum:fdefinition m:*client* *build-rte* fdesignator)))) +(defun core:apply0 (f last) (apply f last)) +(defun core:apply1 (f last a0) (apply f a0 last)) +(defun core:apply2 (f last a0 a1) (apply f a0 a1 last)) +(defun core:apply3 (f last a0 a1 a2) (apply f a0 a1 a2 last)) +(defun core:apply4 (f last &rest r) + (multiple-value-call f (values-list r) (values-list last))) + +(defun function-form-p (form) + (and (consp form) + (eq (car form) 'function) + (consp (cdr form)) + (null (cddr form)))) + +;;; Collapse (coerce-fdesignator #'foo) to #'foo, +;;; (coerce-fdesignator 'foo) to (fdefinition 'foo), +;;; and (coerce-fdesignator (lambda ...)) to (lambda ...). +;;; Note that cclasp should have more sophisticated IR-level analyses +;;; expanding on this. +(define-cross-compiler-macro core:coerce-fdesignator + (&whole form designator &environment env) + ;; In order to cover (lambda ...), among other possibilities, macroexpand. + (let ((designator (macroexpand designator env))) + (cond ((function-form-p designator) designator) + ((constantp designator env) + (let ((value (ext:constant-form-value designator env))) + (cond ((symbolp value) `(fdefinition ,designator)) + ((functionp value) value) + (t form)))) + (t form)))) +(define-compiler-macro core:coerce-called-fdesignator + (&whole form designator &environment env) + (let ((designator (macroexpand designator env))) + (cond ((function-form-p designator) designator) + ((constantp designator env) + (let ((value (ext:constant-form-value designator env))) + (cond ((symbolp value) `(fdefinition ,designator)) + ((functionp value) value) + (t form)))) + (t form)))) + +(define-compiler-macro not (objectf) + ;; Take care of (not (not x)), which code generates sometimes. + (if (and (consp objectf) + (eq (car objectf) 'not) + (consp (cdr objectf)) + (null (cddr objectf))) + `(if ,(second objectf) t nil) + ;; Or just use the obvious + `(if ,objectf nil t))) + +(define-compiler-macro eql (&whole form x y &environment env) + (if (constantp x env) + (when (constantp y env) + ;; Both constant: Fold. + (return-from eql + (eql (ext:constant-form-value x env) + (ext:constant-form-value y env)))) + (if (constantp y env) + ;; y is constant but not x. swap for the rest of the code + ;; (no order of evaluation problem, since constant) + ;; We haven't loaded rotatef yet. + (let ((w x) (z y)) + (setq x z y w)) + ;; Neither is constant - nothing to do + (return-from eql form))) + ;; OK now x is constant and y is not. + (let ((xv (ext:constant-form-value x env))) + (if (typep xv 'core::eq-incomparable) + ;; X is a bignum or something - can't help that. + form + ;; X can be compared by EQ. + `(eq ',xv ,y)))) + +(define-compiler-macro identity (object) + ;; ensure only the primary value is returned. + `(prog1 ,object)) + +(define-compiler-macro constantly (object) + (let ((s (gensym "CONSTANTLY-OBJECT"))) + `(let ((,s ,object)) + (lambda (&rest args) + (declare (ignore args)) + ,s)))) + +;;; Dummy macro for use by the bytecode compiler. Ignored by cclasp. +(defmacro cleavir-primop:case (keyform &rest clauses) + `(case ,keyform ,@clauses)) + +(define-compiler-macro case (&whole form keyform &rest clauses) + ;;; Check degenerate case + (when (null clauses) + (return-from case `(progn ,keyform nil))) + ;;; Use CLEAVIR-PRIMOP:CASE if everything is immediate. + ;;; In any case, check for redundant keys, and skip them in the + ;;; expansion, while issuing a style warning. + (let* ((last (first (last clauses))) + (default-provided-p (member (first last) '(t otherwise))) + (default (if default-provided-p + last + '(otherwise nil))) + (cases (if default-provided-p (butlast clauses) clauses)) + (seen-keys (make-hash-table))) + (flet ((filter-keys (keys) + ;; Return two values: A list with the duplicates removed, + ;; and the list of duplicates removed. + (loop for k in keys + when (gethash k seen-keys) + collect k into redundant-keys + else collect k into cleaned-keys + do (setf (gethash k seen-keys) t) + finally (return (values cleaned-keys redundant-keys))))) + (loop with redundantp = nil + with optimizablep = t + for case in cases + for (keything . body) = case + for keys = (cond + ;; Defaults in the middle: macro handles this. + ((eq keything 't) (return form)) + ((eq keything 'otherwise) (return form)) + ;; Normal case + ((listp keything) keything) + (t (list keything))) + for (skeys rkeys) = (multiple-value-list (filter-keys keys)) + unless (every #'core:create-tagged-immediate-value-or-nil skeys) + do (setf optimizablep nil) + unless (null rkeys) + do (ext:with-current-source-form (keys) + (warn 'core::simple-style-warning + :format-control "Redundant keys in CASE: ~a" + :format-arguments (list rkeys))) + (setf redundantp t optimizablep nil) + unless (null skeys) + collect (cons skeys body) into new-cases + finally (return + (cond (optimizablep + `(cleavir-primop:case ,keyform + ,@new-cases + ,default)) + (redundantp + ;; Since we expand into CASE again, + ;; this compiler macro will be + ;; triggered again, but this time + ;; there will be no redundancy. + ;; If this cmacro was part of the + ;; macro instead, this wouldn't happen. + `(case ,keyform ,@new-cases ,default)) + (t form))))))) + +;;; every, etc. defined in opt-sequence diff --git a/src/cross-clasp/packages.lisp b/src/cross-clasp/packages.lisp new file mode 100644 index 0000000000..2e0d13d105 --- /dev/null +++ b/src/cross-clasp/packages.lisp @@ -0,0 +1,393 @@ +(defpackage #:cross-clasp.clasp.core + (:use #:cl) + (:export #:+type-header-value-map+ #:header-stamp + #:stamps-adjacent-p + #:next-startup-position) + (:export #:vaslist #:vaslistp #:vaslist-length #:vaslist-pop + #:list-from-vaslist) + (:export #:operator-shadowed-p #:process-declarations) + (:export #:simple-program-error + #:out-of-extent-unwind #:no-catch-tag + #:simple-stream-error #:closed-stream + #:simple-file-error #:file-does-not-exist #:file-exists + #:simple-package-error #:import-name-conflict #:export-name-conflict + #:use-package-name-conflict #:unintern-name-conflict + #:package-lock-violation + #:do-not-funcall-special-operator #:wrong-number-of-arguments + #:odd-keywords #:unrecognized-keyword-argument-error + #:simple-parse-error #:simple-reader-error) + (:export #:defconstant-equal) + (:export #:check-pending-interrupts #:terminal-interrupt + #:signal-code-alist) + ;; Clasp usually only defines these if the underlying OS has the given signal. + ;; Defining them unconditionally shouldn't be a problem, though. They'll just + ;; never actually be signaled. + (:export #:sigabrt #:sigalrm #:sigbus #:sigchld #:sigcont #:sigemt #:sigfpe + #:sighup #:sigill #:sigint #:sigio #:sigkill #:sigpipe #:sigpoll + #:sigprof #:sigpwr #:sigquit #:sigsegv #:sigstop #:sigtstp #:sigsys + #:sigterm #:sigtrap #:sigttin #:sigttou #:sigurg #:sigusr1 #:sigusr2 + #:sigvtalrm #:sigxcpu #:sigxfsz #:sigwinch) + (:export #:lambda-name #:lambda-list) + (:export #:general #:generalp) + (:export #:parse-bytespec) + (:export #:put-f #:rem-f) + (:export #:hash-table-pairs #:hash-equal #:hash-table-weakness + #:hash-table-custom #:hash-table-equal #:hash-table-eql #:hash-table-eq + #:hash-table-equalp) + (:export #:fmt) + (:export #:name-of-class #:class-source-location #:cxx-method-source-location + #:instancep #:instance-ref) + (:export #:proper-list-p) + (:export #:ratiop + #:short-float-p #:single-float-p #:double-float-p #:long-float-p) + (:export #:printing-char-p) + (:export #:data-vector-p #:replace-array #:vref + #:make-simple-vector-t + #:complex-vector-t #:simple-mdarray-t #:mdarray-t + #:abstract-simple-vector #:complex-vector #:mdarray #:simple-mdarray + #:str-ns #:str8ns #:simple-character-string #:str-wns #:bit-vector-ns + #:simple-mdarray-base-char #:mdarray-base-char + #:simple-mdarray-character #:mdarray-character + #:simple-mdarray-bit #:mdarray-bit + #:sbv-bit-and #:sbv-bit-ior #:sbv-bit-xor #:sbv-bit-eqv + #:sbv-bit-nand #:sbv-bit-nor #:sbv-bit-andc1 #:sbv-bit-andc2 + #:sbv-bit-orc1 #:sbv-bit-orc2 #:sbv-bit-not) + (:export #:num-op-asin #:num-op-acos #:num-op-atan + #:num-op-asinh #:num-op-acosh #:num-op-atanh) + (:export #:car-atomic #:rplaca-atomic #:cas-car + #:cdr-atomic #:rplacd-atomic #:cas-cdr + #:atomic-symbol-value #:atomic-set-symbol-value #:cas-symbol-value + #:atomic-symbol-plist #:atomic-set-symbol-plist #:cas-symbol-plist) + (:export #:function-name #:setf-function-name #:setf-lambda-list + #:function-docstring #:function-source-pos #:set-source-pos-info) + (:export #:single-dispatch-generic-function-p) + (:export #:creator #:instance-creator #:standard-class-creator + #:funcallable-instance-creator #:derivable-cxx-class-creator + #:class-rep-creator + #:compute-instance-creator + #:class-holder + #:allocate-standard-instance #:allocate-raw-instance + #:allocate-raw-funcallable-instance + #:class-stamp-for-instances #:class-new-stamp + #:instance #:funcallable-instance #:derivable-cxx-object + #:instance-sig #:instance-sig-set #:instance-stamp + #:rack #:make-rack #:rack-sig #:rack-ref + #:instance-rack #:instance-class) + (:export #:core-fun-generator #:simple-core-fun-generator + #:simple-fun #:core-fun #:simple-core-fun #:closure + #:single-dispatch-generic-function #:single-dispatch-method + #:gfbytecode-simple-fun #:gfbytecode-simple-fun/make + #:gfbytecode-simple-fun/bytecode #:gfbytecode-simple-fun/literals + #:bytecode-simple-fun #:bytecode-simple-fun/code + #:bytecode-simple-fun/entry-pc-n #:bytecode-simple-fun/bytecode-size + #:bytecode-module #:bytecode-module/bytecode #:bytecode-module/literals + #:bytecode-module/debug-info + #:function/entry-point + #:make-closure #:closure-length #:closure-ref) + (:export #:setf-find-class) + (:export #:cxx-object #:make-cxx-object #:cxx-object-p #:cxx-class + #:clbind-cxx-class #:derivable-cxx-class + #:encode #:decode) + (:export #:argc #:argv #:getpid #:temporary-directory #:mkstemp #:rmdir) + (:export #:unix-get-local-time-zone #:unix-daylight-saving-time #:waitpid) + (:export #:thread-local-write-to-string-output-stream + #:get-thread-local-write-to-string-output-stream-string + #:write-addr) + (:export #:list-all-logical-hosts #:logical-host-p) + (:export #:weak-pointer #:ephemeron + #:make-weak-pointer #:weak-pointer-valid #:weak-pointer-value + #:ephemeron) + (:export #:external-object #:pointer #:wrapped-pointer #:immobile-object + #:native-vector) + (:export #:symbol-to-enum-converter) + (:export #:*echo-repl-tpl-read*) + (:export #:signal-servicing) + (:export #:num-logical-processors) + (:export #:noprint-p #:noinform-p) + (:export #:quasiquote #:*quasiquote* + #:unquote #:unquote-nsplice #:unquote-splice) + (:export #:scope #:file-scope #:file-scope-pathname #:mkstemp) + (:export #:interpret) + (:export #:wrong-number-of-arguments #:sequence-out-of-bounds) + (:export #:set-breakstep #:unset-breakstep #:breakstepping-p + #:invoke-internal-debugger #:debugger-disabled-p) + (:export #:variable-cell #:function-cell) + (:export #:dyn-env #:unknown-dyn-env #:dest-dyn-env #:lex-dyn-env + #:block-dyn-env #:tagbody-dyn-env #:catch-dyn-env + #:unwind-protect-dyn-env #:binding-dyn-env + #:vmframe-dyn-env) + (:export #:call-with-frame #:primitive-print-backtrace + #:debugger-frame #:debugger-frame-up #:debugger-frame-down + #:debugger-frame-fname #:debugger-frame-source-position + #:debugger-frame-function-description #:debugger-frame-lang + #:debugger-frame-closure #:debugger-frame-xep-p + #:debugger-frame-args-available-p #:debugger-frame-args + #:debugger-local #:debugger-frame-locals) + (:export #:function-description #:function-description-lambda-list + #:function-description-source-pathname + #:function-description-lineno #:function-description-column + #:function-description-docstring) + (:export #:package-documentation + #:package-local-nicknames-internal + #:call-with-package-read-lock #:call-with-package-read-write-lock) + (:export #:*functions-to-inline* #:*functions-to-notinline*) + (:export #:*variable-source-infos*) + (:export #:make-source-pos-info #:source-pos-info + #:source-pos-info-lineno #:source-pos-info-column + #:source-pos-info-file-handle #:source-pos-info-filepos + #:source-pos-info-inlined-at #:source-pos-info-function-scope + #:setf-source-pos-info-extra) + (:export #:input-stream-source-pos-info) + (:export #:bytecode-debug-info #:bytecode-debug-info/start #:bytecode-debug-info/end + #:bytecode-debug-vars #:bytecode-debug-vars/bindings + #:bytecode-debug-var + #:bytecode-debug-var/decls #:bytecode-debug-var/name + #:bytecode-debug-var/frame-index #:bytecode-debug-var/cellp + #:bytecode-debug-location #:bytecode-debug-location/location + #:bytecode-ast-decls #:bytecode-ast-decls/decls + #:bytecode-ast-the #:bytecode-ast-the/type #:bytecode-ast-the/receiving + #:bytecode-ast-if #:bytecode-ast-if/receiving + #:bytecode-ast-tagbody #:bytecode-ast-tagbody/tags + #:bytecode-ast-block + #:bytecode-ast-block/receiving #:bytecode-ast-block/name + #:bytecode-debug-macroexpansion #:bytecode-debug-macroexpansion/macro-name) + (:export #:syntax-type #:+standard-readtable+ + #:*read-hook* #:*read-preserving-whitespace-hook*) + (:export #:load-source #:link-fasl-files) + (:export #:command-line-load-eval-sequence + #:rc-file-name #:no-rc-p #:noinform-p + #:is-interactive-lisp #:load-extensions #:startup-type + #:*extension-systems* #:*initialize-hooks* #:*terminate-hooks*) + (:export #:*use-interpreter-for-eval*) + (:export #:sl-boundp #:unbound #:unused) + (:export #:quit)) + +(defpackage #:cross-clasp.clasp.gctools + (:use #:cl) + (:export #:garbage-collect #:finalize) + (:export #:save-lisp-and-die) + (:export #:thread-local-unwind-counter #:bytes-allocated)) + +(defpackage #:cross-clasp.clasp.clos + (:use #:cl) + (:local-nicknames (#:core #:cross-clasp.clasp.core) + (#:mop #:closer-mop)) + (:shadow #:define-method-combination) + (:export #:slot-value-using-class) + (:export #:standard-instance-access + #:funcallable-standard-instance-access) + (:export #:set-funcallable-instance-function #:get-funcallable-instance-function) + (:export #:no-applicable-method-error) + (:export #:generic-function-name)) + +(defpackage #:cross-clasp.clasp.mp + (:use #:cl) + (:local-nicknames (#:core #:cross-clasp.clasp.core) + (#:clos #:cross-clasp.clasp.clos)) + (:export #:mutex #:make-lock #:get-lock #:giveup-lock #:holding-lock-p) + (:export #:shared-mutex #:recursive-mutex #:make-shared-mutex + #:shared-lock #:write-lock + #:shared-unlock #:write-unlock) + (:export #:condition-variable #:make-condition-variable + #:condition-variable-wait #:condition-variable-signal) + (:export #:with-lock #:with-rwlock + #:without-interrupts #:with-interrupts) + (:export #:*current-process* #:all-processes + #:process #:process-name #:process-active-p + #:interrupt-process #:process-suspend #:process-resume #:process-join + #:suspend-loop #:abort-process #:process-kill #:process-cancel) + (:export #:process-error #:process-error-process + #:process-join-error #:process-join-error-original-condition + #:process-join-error-aborted + #:push-default-special-binding) + (:export #:interrupt #:service-interrupt #:enqueue-interrupt + #:signal-pending-interrupts #:signal-interrupt #:raise + #:interactive-interrupt #:simple-interrupt #:simple-interactive-interrupt + #:cancellation-interrupt #:call-interrupt #:call-interrupt-function + #:suspension-interrupt #:posix-interrupt) + (:export #:atomic #:cas #:atomic-incf #:atomic-push #:atomic-pop + #:atomic-update + #:get-atomic-expansion #:define-atomic-expander + #:not-atomic #:not-atomic-place)) + +(defpackage #:cross-clasp.clasp.llvm-sys + (:use #:cl) + (:export #:tag-tests)) + +(defpackage #:cross-clasp.clasp.cmp + (:use #:cl #:cross-clasp.clasp.core) + (:export #:code-walk) + (:export #:module + #:module/make #:module/link #:module/create-bytecode #:module/literals + #:module/create-debug-info + #:cfunction + #:cfunction #:cfunction/nlocals #:cfunction/closed #:cfunction/entry-point + #:cfunction/final-size #:cfunction/name #:cfunction/doc + #:cfunction/lambda-list #:cfunction/module + #:annotation #:annotation/module-position #:label #:fixup + #:label-fixup #:control-label-fixup #:jump-if-supplied-fixup + #:lex-fixup #:lex-ref-fixup #:encage-fixup #:lex-set-fixup + #:entry-fixup #:restore-spfixup #:exit-fixup #:entry-close-fixup + #:lexical-info #:var-info #:lexical-var-info #:special-var-info + #:symbol-macro-var-info #:constant-var-info #:fun-info + #:global-fun-info #:local-fun-info #:global-macro-info + #:local-macro-info #:block-info #:tag-info + #:constant-info #:constant-info/value + #:load-time-value-info + #:load-time-value-info/form #:load-time-value-info/read-only-p + #:function-cell-info #:function-cell-info/fname + #:variable-cell-info #:variable-cell-info/vname + #:env-info + #:make-null-lexical-environment + #:lexenv + #:lexenv/make #:lexenv/add-specials #:lexenv/macroexpansion-environment + #:lexenv/vars #:lexenv/tags #:lexenv/blocks #:lexenv/funs + #:lexenv/decls #:lexenv/frame-end + #:symbol-macro-var-info/make + #:local-macro-info/make + #:bytecompile #:bytecompile-into) + (:export #:with-atomic-file-rename) + (:export #:register-global-function-def) + (:export #:*source-locations*) + (:export #:*btb-compile-hook* #:*cleavir-compile-hook*)) + +(defpackage #:cross-clasp.clasp.sequence + (:use) + (:export #:make-sequence-iterator #:with-sequence-iterator #:dosequence) + (:export #:elt #:length #:make-sequence-like #:adjust-sequence) + (:export #:make-simple-sequence-iterator + #:iterator-step #:iterator-endp #:iterator-element + #:iterator-index #:iterator-copy) + (:export #:protocol-unimplemented #:protocol-unimplemented-operation) + (:export #:emptyp #:count #:count-if #:count-if-not #:find #:find-if #:find-if-not + #:position #:position-if #:position-if-not #:subseq #:copy-seq #:fill + #:nsubstitute #:nsubstitute-if #:nsubstitute-if-not + #:substitute #:substitute-if #:substitute-if-not + #:replace #:nreverse #:reverse #:reduce #:mismatch #:search + #:delete #:delete-if #:delete-if-not #:remove #:remove-if #:remove-if-not + #:delete-duplicates #:remove-duplicates #:sort #:stable-sort) + (:export #:make-sequence #:define-iterative-sequence + #:define-random-access-sequence #:make-random-access-iterator)) + +(defpackage #:cross-clasp.clasp.debug + (:use #:cl) + (:export #:with-truncated-stack) + (:export #:step-form #:step-into #:step-over) + (:export #:frame-arguments)) + +(defpackage #:cross-clasp.clasp.ext + (:use #:cl) + (:export #:byte2 #:byte4 #:byte8 #:byte16 #:byte32 #:byte64 + #:integer2 #:integer4 #:integer8 #:integer16 + #:integer32 #:integer64) + (:export #:short-float-to-bits #:single-float-to-bits + #:double-float-to-bits #:long-float-to-bits) + (:export #:specialp #:symbol-macro) + (:export #:check-arguments-type) + (:export #:ansi-stream) + (:export #:+process-standard-input+ #:+process-standard-output+ + #:+process-error-output+ #:+process-terminal-io+) + (:export #:constant-form-value) + (:export #:with-current-source-form #:current-source-location + #:source-location #:source-location-pathname) + (:export #:function-lambda-list) + (:export #:type-expander) + (:export #:parse-define-setf-expander #:setf-expander) + (:export #:parse-deftype) + (:export #:parse-macro #:parse-compiler-macro) + (:export #:array-index) + (:export #:interactive-interrupt) + (:export #:add-package-local-nickname #:add-implementation-package + #:package-implemented-by-list + #:lock-package #:unlock-package #:package-locked-p) + (:export #:*ed-functions*) + (:export #:*invoke-debugger-hook* #:*inspector-hook* + #:restart-associated-conditions + #:restart-function #:restart-report-function + #:restart-interactive-function #:restart-test-function) + (:export #:segmentation-violation + #:interactive-interrupt + #:stack-overflow #:stack-overflow-size #:stack-overflow-type + #:storage-exhausted #:bus-error + #:name-conflict #:name-conflict-candidates #:resolve-conflict + #:undefined-class #:assert-error + #:character-coding-error #:encoding-error #:decoding-error + #:character-encoding-error #:character-decoding-error + #:stream-encoding-error #:stream-decoding-error) + (:export #:tpl-frame #:tpl-argument #:tpl-arguments) + (:export #:ansi-stream) + (:export #:annotate #:*module-provider-functions*) + (:export #:getenv) + (:export #:*toplevel-hook*) + (:export #:current-source-location) + (:export #:compiler-note #:start-autocompilation) + (:import-from #:cross-clasp.clasp.core #:quit) + (:export #:quit)) + +(defpackage #:cross-clasp.clasp.gray + (:use #:cl) + (:shadow #:streamp #:open-stream-p #:input-stream-p #:output-stream-p) + (:shadow #:pathname #:truename) + (:shadow #:stream-external-format #:stream-element-type) + (:shadow #:close) + (:import-from #:cross-clasp.clasp.ext #:ansi-stream) + (:export #:fundamental-stream + #:fundamental-input-stream #:fundamental-output-stream + #:fundamental-character-stream #:fundamental-binary-stream + #:fundamental-character-input-stream #:fundamental-character-output-stream + #:fundamental-binary-input-stream #:fundamental-binary-output-stream) + (:export #:streamp #:input-stream-p #:output-stream-p + #:open-stream-p #:stream-interactive-p) + (:export #:stream-write-sequence #:stream-read-sequence) + (:export #:stream-write-char #:stream-unread-char + #:stream-peek-char #:stream-read-char + #:stream-write-string #:stream-read-line + #:stream-read-char-no-hang #:stream-terpri #:stream-fresh-line) + (:export #:stream-write-byte #:stream-read-byte) + (:export #:stream-clear-input #:stream-clear-output #:stream-listen + #:stream-finish-output #:stream-force-output) + (:export #:stream-element-type #:stream-external-format + #:stream-file-length #:stream-file-string-length) + (:export #:pathname #:truename #:stream-file-descriptor) + (:export #:close) + (:export #:stream-input-line #:stream-input-column + #:stream-line-number #:stream-start-line-p + #:stream-line-length #:stream-line-column + #:stream-file-position #:stream-advance-to-column)) + +;; Used by some external packages and such, for some reason +(defpackage #:cross-clasp.clasp.cl-user + (:use #:cl)) + +(defpackage #:cross-clasp.clasp.alexandria + (:use #:cl)) +(defpackage #:cross-clasp.clasp.concrete-syntax-tree + (:use #:cl)) +(defpackage #:cross-clasp.clasp.ecclesia + (:use #:cl)) +(defpackage #:cross-clasp.clasp.trivial-with-current-source-form + (:use #:cl)) +(defpackage #:cross-clasp.clasp.khazern + (:use #:cl)) + +(defpackage #:cross-clasp + (:use #:cl) + (:local-nicknames (#:m #:maclina.machine) + (#:core #:cross-clasp.clasp.core) + (#:clos #:cross-clasp.clasp.clos) + (#:cmp #:cross-clasp.clasp.cmp) + (#:gray #:cross-clasp.clasp.gray) + (#:gc #:cross-clasp.clasp.gctools) + (#:mp #:cross-clasp.clasp.mp) + (#:llvm-sys #:cross-clasp.clasp.llvm-sys) + (#:ext #:cross-clasp.clasp.ext) + (#:cst #:cross-clasp.clasp.concrete-syntax-tree)) + (:shadow #:proclaim #:constantp) + (:export #:client #:ct-client) + (:export #:fill-environment) + (:export #:find-compiler-class #:gf-info) + (:import-from #:cross-clasp.clasp.ext #:constant-form-value) + (:export #:build-macroexpand #:build-macroexpand-1 + #:describe-variable + #:constantp #:constant-form-value) + (:export #:initialize #:cross-compile-file #:install-delayed-macros #:build)) diff --git a/src/cross-clasp/source-pos-info.lisp b/src/cross-clasp/source-pos-info.lisp new file mode 100644 index 0000000000..dd881b8e8f --- /dev/null +++ b/src/cross-clasp/source-pos-info.lisp @@ -0,0 +1,22 @@ +(in-package #:cross-clasp) + +(defun ext:current-source-location () + (maclina.compile:default-source-location)) + +(defmethod maclina.compile-file:make-load-form + ((client client) (object maclina.compile-file:source-location) + &optional environment) + (declare (ignore environment)) + (values `(core:make-cxx-object + (find-class 'core:source-pos-info) + :sfi (core:file-scope + ,(namestring (maclina.compile-file:source-location-pathname object))) + :fp ',(car (maclina.compile-file:source-location-position object)) + :l 0 :c 0))) ; FIXME + +;;; KLUDGE +(defmethod maclina.compile-file:make-load-form + ((client ct-client) (object maclina.compile-file:source-location) + &optional environment) + (declare (ignore environment)) + 'nil) diff --git a/src/cross-clasp/trucler-clasp.lisp b/src/cross-clasp/trucler-clasp.lisp new file mode 100644 index 0000000000..26998fe760 --- /dev/null +++ b/src/cross-clasp/trucler-clasp.lisp @@ -0,0 +1,294 @@ +(defpackage #:trucler-native-clasp + (:use #:cl) + (:import-from #:trucler-native #:client) + (:export #:client)) + +(in-package #:trucler-native-clasp) + +(defmethod trucler:describe-variable + ((client client) (env clasp-cleavir:clasp-global-environment) + symbol) + (cond ((constantp symbol) + (make-instance 'trucler:constant-variable-description + :name symbol :value (symbol-value symbol))) + ((ext:specialp symbol) + (make-instance 'trucler:global-special-variable-description + :name symbol :type (clasp-cleavir::global-type symbol))) + ((ext:symbol-macro symbol) + (make-instance 'trucler:global-symbol-macro-description + :name symbol :expansion (macroexpand-1 symbol) + :type (clasp-cleavir::global-type symbol))) + (t nil))) + +(defmethod trucler:describe-variable ((client client) (env null) symbol) + (trucler:describe-variable client clasp-cleavir:*clasp-env* symbol)) + +(defmethod trucler:describe-variable + ((client client) (env cmp:lexenv) symbol) + (let ((info (cmp:var-info symbol env))) + (etypecase info + (null + ;; Not locally bound: Check the global environment. + (trucler:describe-variable + client (cmp:lexenv/global env) symbol)) + (cmp:lexical-var-info + ;; This will probably not go well - cleavir expects an identity, etc. + (make-instance 'trucler:lexical-variable-description + :name symbol :identity nil)) + (cmp:special-var-info + (make-instance 'trucler:local-special-variable-description + :name symbol)) + (cmp:symbol-macro-var-info + (make-instance 'trucler:local-symbol-macro-description + :name symbol + :expansion (funcall (cmp:symbol-macro-var-info/expander info) + symbol env))) + (cmp:constant-var-info + (make-instance 'trucler:constant-variable-description + :name symbol + ;; FIXME: better interface + :value (core:variable-cell/value + (core::fcge-ensure-vcell (cmp:lexenv/global env) symbol))))))) + +(defmethod trucler:describe-function + ((client client) + (environment clasp-cleavir:clasp-global-environment) + function-name) + (cond + ((and (symbolp function-name) + (clasp-cleavir::treat-as-special-operator-p function-name)) + (make-instance 'trucler:special-operator-description + :name function-name)) + ;; If the function name is the name of a macro, then + ;; MACRO-FUNCTION returns something other than NIL. + ((and (symbolp function-name) (not (null (macro-function function-name)))) + ;; we're global, so the macro must be global. + (make-instance 'trucler:global-macro-description + :name function-name + ;;:inline (clasp-cleavir::global-inline-status function-name) + :expander (macro-function function-name) + :compiler-macro (compiler-macro-function function-name))) + ((fboundp function-name) + (let* ((cleavir-ast (clasp-cleavir:inline-ast function-name)) + (inline-status (clasp-cleavir::global-inline-status function-name)) + (flags (gethash function-name clasp-cleavir::*fn-flags*)) + (transforms (gethash function-name clasp-cleavir::*fn-transforms*)) + (derivers (gethash function-name clasp-cleavir::*derivers*)) + (folds (gethash function-name clasp-cleavir::*folds*)) + (vaslistablep (cc-vaslist:vaslistablep function-name)) + (attributes (if (or flags transforms folds derivers) + (make-instance 'cleavir-attributes:attributes + :flags (or flags (cleavir-attributes:make-flags)) + :identities (if (or transforms folds + derivers vaslistablep) + (list function-name) + nil)) + (cleavir-attributes:default-attributes)))) + (declare (ignore attributes)) ; for now + (make-instance 'trucler:global-function-description + :name function-name + :type (clasp-cleavir::global-ftype function-name) + :compiler-macro (compiler-macro-function function-name) + :inline inline-status + :inline-data cleavir-ast + #+(or):attributes #+(or) attributes))) + ;; A top-level defun for the function has been seen. + ;; The expansion calls cmp::register-global-function-def at compile time, + ;; which is hooked up so that among other things this works. + ((cmp:known-function-p function-name) + (make-instance 'trucler:global-function-description + :name function-name + :type (clasp-cleavir::global-ftype function-name) + :compiler-macro (compiler-macro-function function-name) + :inline (clasp-cleavir::global-inline-status function-name) + :inline-data (clasp-cleavir:inline-ast function-name))) + (t nil))) + +(defmethod trucler:describe-function ((client client) (env null) symbol) + (trucler:describe-function client clasp-cleavir:*clasp-env* symbol)) + +(defmethod trucler:describe-function + ((client client) (environment cmp:lexenv) symbol) + (if (and (symbolp symbol) + (clasp-cleavir::treat-as-special-operator-p symbol)) + ;; The bytecode compiler doesn't know about special operators. + ;; (It might need to learn for Trucler, later.) + (make-instance 'trucler:special-operator-description :name symbol) + (let ((info (cmp:fun-info symbol environment))) + (etypecase info + (null ; check global + (trucler:describe-function + client (cmp:lexenv/global environment) symbol)) + (cmp:global-fun-info + (make-instance 'trucler:global-function-description + :name symbol + :compiler-macro (cmp:global-fun-info/cmexpander info))) + (cmp:local-fun-info + ;; As with lexical variables, this may not end well + ;; as there will be no identity or anything. + (make-instance 'trucler:local-function-description + :name symbol :identity nil)) + (cmp:global-macro-info + (make-instance 'trucler:global-macro-description + :name symbol :expander (cmp:global-macro-info/expander info))) + (cmp:local-macro-info + (make-instance 'trucler:local-macro-description + :name symbol :expander (cmp:local-macro-info/expander info))))))) + +(defmethod trucler:describe-declarations + ((client client) + (environment clasp-cleavir:clasp-global-environment)) + ;; FIXME: Support CL:DECLARATION + '(;; Behavior as in convert-form.lisp + core:lambda-name core:lambda-list)) + +(defmethod trucler:describe-declarations ((client client) (env null)) + (trucler:describe-declarations client clasp-cleavir:*clasp-env*)) + +(defmethod trucler:describe-declarations ((client client) (env cmp:lexenv)) + (trucler:describe-declarations client (cmp:lexenv/global env))) + +(defmethod trucler:describe-optimize + ((client client) (env clasp-cleavir:clasp-global-environment)) + (let ((opt cmp:*optimize*)) + (flet ((qual (name) + (cleavir-compilation-policy:optimize-value opt name))) + (declare (inline qual)) + (make-instance 'trucler:optimize-description + :safety (qual 'safety) :space (qual 'space) :debug (qual 'debug) + :compilation-speed (qual 'compilation-speed) :speed (qual 'speed) + #+(or):optimize #+(or)opt #+(or):policy #+(or)cmp:*policy*)))) + +(defmethod trucler:describe-optimize ((client client) (env null)) + (trucler:describe-optimize client clasp-cleavir:*clasp-env*)) + +(defmethod trucler:describe-optimize ((client client) (env cmp:lexenv)) + ;; FIXME + (trucler:describe-optimize client (cmp:lexenv/global env))) + +(defmethod trucler:global-environment ((client client) (env cmp:lexenv)) + (cmp:lexenv/global env)) + +;;; + +(defgeneric desc->info (desc)) +(defmethod desc->info ((desc trucler:lexical-variable-description)) + (cmp:lexical-var-info/make (trucler:identity desc) nil)) +(defmethod desc->info ((desc trucler:symbol-macro-description)) + (cmp:symbol-macro-var-info/make + (let ((expansion (trucler:expansion desc))) + (lambda (form env) (declare (ignore form env)) expansion)))) +(defmethod desc->info + ((desc trucler:local-special-variable-description)) + (cmp:special-var-info/make nil)) +(defmethod desc->info + ((desc trucler:global-special-variable-description)) + (cmp:special-var-info/make t)) + +(defmethod trucler:augment-with-variable-description + ((client client) (env clasp-cleavir:clasp-global-environment) + (desc trucler:variable-description)) + (cmp:lexenv/make + (list (cons (trucler:name desc) (desc->info desc))) + nil nil nil nil 0)) + +(defmethod trucler:augment-with-variable-description + ((client client) (env null) (desc trucler:variable-description)) + (trucler:augment-with-variable-description + client clasp-cleavir:*clasp-env* desc)) + +(defmethod trucler:augment-with-variable-description + ((client client) (env cmp:lexenv) + (desc trucler:variable-description)) + (cmp:lexenv/make + (acons (trucler:name desc) (desc->info desc) (cmp:lexenv/vars env)) + (cmp:lexenv/tags env) (cmp:lexenv/blocks env) (cmp:lexenv/funs env) + (cmp:lexenv/decls env) (cmp:lexenv/frame-end env) + (cmp:lexenv/global env))) + +(defmethod desc->info + ((desc trucler:local-function-description)) + (cmp:local-fun-info/make (trucler:identity desc))) +(defmethod desc->info + ((desc trucler:local-macro-description)) + (cmp:local-macro-info/make (trucler:expander desc))) + +(defmethod trucler:augment-with-function-description + ((client client) (env clasp-cleavir:clasp-global-environment) + (desc trucler:function-description)) + (cmp:lexenv/make + nil nil nil + (list (cons (trucler:name desc) (desc->info desc))) + (if (and (typep desc 'trucler:inline-mixin) + (eq (trucler:inline desc) 'cl:notinline)) + (list (trucler:name desc)) + nil) + 0)) + +(defmethod trucler:augment-with-function-description + ((client client) (env null) (desc trucler:function-description)) + (trucler:augment-with-function-description + client clasp-cleavir:*clasp-env* desc)) + +(defmethod trucler:augment-with-function-description + ((client client) (env cmp:lexenv) + (desc trucler:function-description)) + (cmp:lexenv/make + (cmp:lexenv/vars env) nil nil + (acons (trucler:name desc) (desc->info desc) (cmp:lexenv/funs env)) + (if (and (typep desc 'trucler:inline-mixin) + (eq (trucler:inline desc) 'cl:notinline)) + (list (trucler:name desc)) + nil) + 0 (cmp:lexenv/global env))) + +(defmethod trucler:augment-with-block-description + ((client client) (env clasp-cleavir:clasp-global-environment) + (desc trucler:block-description)) + (cmp:lexenv/make + nil nil + (list (cons (trucler:name desc) (trucler:identity desc))) + nil nil 0)) + +(defmethod trucler:augment-with-block-description + ((client client) (env null) (desc trucler:block-description)) + (trucler:augment-with-block-description + client clasp-cleavir:*clasp-env* desc)) + +(defmethod trucler:augment-with-block-description + ((client client) (env cmp:lexenv) (desc trucler:block-description)) + (cmp:lexenv/make + (cmp:lexenv/vars env) (cmp:lexenv/tags env) + (acons (trucler:name desc) (trucler:identity desc) + (cmp:lexenv/blocks env)) + (cmp:lexenv/funs env) (cmp:lexenv/decls env) + (cmp:lexenv/frame-end env) (cmp:lexenv/global env))) + +(defmethod trucler:augment-with-tag-description + ((client client) (env clasp-cleavir:clasp-global-environment) + (desc trucler:tag-description)) + (cmp:lexenv/make + nil + (list (cons (trucler:name desc) (trucler:identity desc))) + nil nil nil 0)) + +(defmethod trucler:augment-with-tag-description + ((client client) (env null) (desc trucler:tag-description)) + (trucler:augment-with-tag-description + client clasp-cleavir:*clasp-env* desc)) + +(defmethod trucler:augment-with-tag-description + ((client client) (env cmp:lexenv) (desc trucler:tag-description)) + (cmp:lexenv/make + (cmp:lexenv/vars env) + (acons (trucler:name desc) (trucler:identity desc) + (cmp:lexenv/tags env)) + (cmp:lexenv/blocks env) (cmp:lexenv/funs env) + (cmp:lexenv/decls env) (cmp:lexenv/frame-end env) + (cmp:lexenv/global env))) + +;;; The lexenv don't track optimize info. FIXME +;;; FIXME +(defmethod trucler:augment-with-optimize-description + ((client client) env (desc trucler:optimize-description)) + env) diff --git a/src/cross-clasp/vm-clasp.lisp b/src/cross-clasp/vm-clasp.lisp new file mode 100644 index 0000000000..62cc017892 --- /dev/null +++ b/src/cross-clasp/vm-clasp.lisp @@ -0,0 +1,189 @@ +(in-package #:core) + +(defmethod fcge-ensure-fcell (env name) + (clostrum:ensure-operator-cell maclina.machine:*client* env name)) +(defmethod fcge-ensure-vcell (env name) + (clostrum:ensure-variable-cell maclina.machine:*client* env name)) + +(defmethod fcge-lookup-fun (env name) + (ecase (clostrum:operator-status maclina.machine:*client* + env name) + ((nil) nil) + ((:function) (cmp:global-fun-info/make + (clostrum:compiler-macro-function + maclina.machine:*client* env name))) + ((:macro) (cmp:global-macro-info/make + (clostrum:macro-function + maclina.machine:*client* env name))) + ;; should have been picked off by bytecompile's normal processing + ;; but we use this elsewere, e.g. cl:macro-function + ;; We probably ought to have some kind of special-operator-info, + ;; but failing that, here's a KLUDGE. + ((:special-operator) nil))) + +(defmethod fcge-lookup-var (env name) + (ecase (clostrum:variable-status maclina.machine:*client* + env name) + ((nil) nil) + ((:special) (cmp:special-var-info/make t)) + ((:constant) + (cmp:constant-var-info/make + (clostrum:symbol-value maclina.machine:*client* env name))) + ((:symbol-macro) + (cmp:symbol-macro-var-info/make + (clostrum:variable-macro-expander maclina.machine:*client* + env name))))) + +(defmethod fcge-find-package (env name) + (clostrum:find-package maclina.machine:*client* env name)) + +(defpackage #:vm-clasp + (:use #:cl) + (:local-nicknames (#:m #:maclina.machine) + (#:mc #:maclina.compile)) + (:export #:client)) + +(in-package #:vm-clasp) + +(defclass client () ()) + +(defmethod m:make-module ((client client) bytecode) + (core:bytecode-module/make bytecode)) + +(defmethod m:literals ((module core:bytecode-module)) + (core:bytecode-module/literals module)) +(defmethod (setf m:literals) + (literals (module core:bytecode-module)) + (core:bytecode-module/setf-literals module literals) + literals) + +(defmethod m:pc-map ((module core:bytecode-module)) + (core:bytecode-module/debug-info module)) +(defmethod (setf m:pc-map) + (map (module core:bytecode-module)) + (core:bytecode-module/setf-debug-info module map) + map) + +(defmethod m:make-function + ((client client) module nlocals nenv entry size) + (core:bytecode-simple-fun/make + (core:function-description/make) + module nlocals nenv entry size + (cmp:compile-trampoline nil))) + +(defmethod m:locals-frame-size ((fun core:bytecode-simple-fun)) + (core:bytecode-simple-fun/locals-frame-size fun)) +(defmethod m:environment-size ((fun core:bytecode-simple-fun)) + (core:bytecode-simple-fun/environment-size fun)) +(defmethod m:entry-pc ((fun core:bytecode-simple-fun)) + (core:bytecode-simple-fun/entry-pc-n fun)) +(defmethod m:size ((fun core:bytecode-simple-fun)) + (core:bytecode-simple-fun/bytecode-size fun)) + +(defmethod m:name ((fun core:bytecode-simple-fun)) + (core:function-name fun)) +(defmethod (setf m:name) (name (fun core:bytecode-simple-fun)) + (core:function/setf-function-name fun name) + name) + +(defmethod m:link-function ((client client) env fname) + (clostrum:ensure-operator-cell client env fname)) +(defmethod m:link-variable ((client client) env vname) + (clostrum:ensure-variable-cell client env vname)) + +(defmethod mc:load-map-info ((client client) (info m:source-info)) + ;; Nnnnnot sure the source locations are compatible. FIXME? + (core:bytecode-debug-location/make (m:start info) (m:end info) + (m:source info))) +(defmethod mc:load-map-info ((client client) (info m:declarations-info)) + (core:bytecode-ast-decls/make (m:start info) (m:end info) + (m:declarations info))) +(defmethod mc:load-map-info ((client client) (info m:the-info)) + (core:bytecode-ast-the/make (m:start info) (m:end info) + (m:the-type info) (m:receiving info))) +(defmethod mc:load-map-info ((client client) (info m:if-info)) + (core:bytecode-ast-if/make (m:start info) (m:end info) + (m:receiving info))) +(defmethod mc:load-map-info ((client client) (info m:tagbody-info)) + (core:bytecode-ast-tagbody/make (m:start info) (m:end info) + (m:tags info))) +(defmethod mc:load-map-info ((client client) (info m:vars-info)) + (core:bytecode-debug-vars/make + (m:start info) (m:end info) + (loop for var in (m:bindings info) + collect (core:bytecode-debug-var/make + (m:name var) (m:index var) (m:cellp var) + (m:declarations var))))) + +(defmethod clostrum-basic:make-variable-cell ((client client) env name) + (declare (ignore client env)) + (core:variable-cell/make name)) +(defmethod clostrum-basic:make-operator-cell ((client client) env name) + (declare (ignore client env)) + (core:function-cell/make name)) + +(defmethod clostrum-sys:variable-cell-value (client (cell core:variable-cell)) + (declare (ignore client)) + (core:variable-cell/value-unsafe cell)) +(defmethod (setf clostrum-sys:variable-cell-value) + (new client (cell core:variable-cell)) + (declare (ignore client)) + (setf (core:variable-cell/value cell) new)) +(defmethod clostrum-sys:variable-cell-boundp (client (cell core:variable-cell)) + (declare (ignore client)) + (core:variable-cell/boundp cell)) +(defmethod clostrum-sys:variable-cell-makunbound (client (cell core:variable-cell)) + (declare (ignore client)) + (core:variable-cell/makunbound cell)) + +(defmethod clostrum-sys:operator-cell-value (client (cell core:function-cell)) + (declare (ignore client)) + (core:function-cell/function cell)) +(defmethod (setf clostrum-sys:operator-cell-value) + (new client (cell core:function-cell)) + (declare (ignore client)) + (let ((new (if (eql new t) ; special operator + (lambda (&rest args) + (declare (ignore args)) + (error 'core::do-not-funcall-special-operator + :name (core:function-name cell) + :operator (core:function-name cell))) + new))) + (setf (core:function-cell/function cell) new)) + new) +(defmethod clostrum-sys:operator-cell-boundp (client (cell core:function-cell)) + (declare (ignore client)) + (core:function-cell/boundp cell)) +(defmethod clostrum-sys:operator-cell-makunbound (client (cell core:function-cell)) + (declare (ignore client)) + (core:function-cell/makunbound cell (core:function-name cell))) + +(defmethod m:symbol-value ((client client) env symbol) + (core:variable-cell/value (clostrum:ensure-variable-cell client env symbol))) +(defmethod (setf m:symbol-value) (new (client client) env symbol) + (setf (core:variable-cell/value + (clostrum:ensure-variable-cell client env symbol)) + new)) +(defmethod m:boundp ((client client) env symbol) + ;; FIXME: Parents? + (let ((cell (clostrum-sys:variable-cell client env symbol))) + (and cell (core:variable-cell/boundp cell)))) +(defmethod m:makunbound ((client client) env symbol) + (let ((cell (clostrum-sys:variable-cell client env symbol))) + (when cell + (core:variable-cell/makunbound cell)))) + +(defmethod m:call-with-progv ((client client) env symbols values thunk) + (core:progv-env-function symbols values env thunk)) + +(defmethod m:fboundp ((client client) env name) + (clostrum:fboundp client env name)) +(defmethod m:fdefinition ((client client) env name) + (clostrum:fdefinition client env name)) +(defmethod (setf m:fdefinition) (new (client client) env name) + (setf (clostrum:fdefinition client env name) new)) +(defmethod m:fmakunbound ((client client) env name) + (clostrum:fmakunbound client env name)) + +(defmethod m:multiple-values-limit ((client client)) + multiple-values-limit) diff --git a/src/cross-clasp/with-package-iterator.lisp b/src/cross-clasp/with-package-iterator.lisp new file mode 100644 index 0000000000..0e6fccc9ca --- /dev/null +++ b/src/cross-clasp/with-package-iterator.lisp @@ -0,0 +1,93 @@ +(in-package #:cross-clasp) + +(defun inherited-symbols (package) + (loop for s being the symbols of package + for name = (symbol-name s) + when (eql (nth-value 1 (find-symbol name package)) :inherited) + collect s)) + +(defun internal-symbols (package) + (loop for s being the present-symbols of package + for name = (symbol-name s) + when (eql (nth-value 1 (find-symbol name package)) :internal) + collect s)) + +(defun external-symbols (package) + ;; subtlety: to be external the symbol has to be present, because + ;; export will import inherited symbols before marking them exported + (loop for s being the external-symbols of package collect s)) + +(defun present-symbols (package) + (loop for s being the present-symbols of package collect s)) + +(defun internal-and-inherited-symbols (package) + (loop for s being the symbols of package + for name = (symbol-name s) + unless (eql (nth-value 1 (find-symbol name package)) :external) + collect s)) + +(defun external-and-inherited-symbols (package) + (loop for s being the symbols of package + for name = (symbol-name s) + unless (eql (nth-value 1 (find-symbol name package)) :internal) + collect s)) + +(defun all-symbols (package) + (loop for s being the symbols of package collect s)) + +(defun coerce-package-designator (designator) + (etypecase designator + (package designator) + ((or character string symbol) + (or (clostrum:find-package m:*client* *build-rte* (string designator)) + (error 'package-error :package designator))))) + +(defun core::packages-iterator (packages symbol-types maybe-list) + (declare (ignore maybe-list)) ; clasp has this but we don't need it + (let ((bad-types (set-difference symbol-types '(:internal :external :inherited)))) + (unless (null bad-types) + (error "Bad symbol-types for ~s: ~s" + 'with-package-iterator bad-types))) + (let ((packages (etypecase packages + (list (mapcar #'coerce-package-designator packages)) + ((or package character string symbol) + (list (coerce-package-designator packages)))))) + (when (or (null packages) (null symbol-types)) + (flet ((iterate () (values nil nil nil nil))) #'iterate)) + (let* ((getter (cond ((equal symbol-types '(:inherited)) #'inherited-symbols) + ((equal symbol-types '(:internal)) #'internal-symbols) + ((equal symbol-types '(:external)) #'external-symbols) + ((or (equal symbol-types '(:internal :external)) + (equal symbol-types '(:external :internal))) + #'present-symbols) + ((or (equal symbol-types '(:internal :inherited)) + (equal symbol-types '(:inherited :internal))) + #'internal-and-inherited-symbols) + ((or (equal symbol-types '(:external :inherited)) + (equal symbol-types '(:inherited :external))) + #'external-and-inherited-symbols) + (t ; already ruled out bad specs, so it must be all 3 + #'all-symbols))) + (package (pop packages)) + (symbols (funcall getter package))) + (flet ((iterate () + (tagbody + again + (when (null symbols) + (cond ((null packages) + (return-from iterate (values nil nil nil nil))) + (t (setf package (pop packages) + symbols (funcall getter package)) + (go again)))) + (let ((sym (pop symbols))) + (return-from iterate + (values t sym + (nth-value 1 (find-symbol (symbol-name sym) package)) + package)))))) + #'iterate)))) + +(defmacro %with-package-iterator ((iterator package-list &rest symbol-types) + &body body) + (let ((ithunk (gensym "ITERATOR-THUNK"))) + `(let ((,ithunk (core::packages-iterator ,package-list ',symbol-types t))) + (macrolet ((,iterator () (list 'funcall ',ithunk))) ,@body)))) diff --git a/src/gctools/memoryManagement.cc b/src/gctools/memoryManagement.cc index eb43779301..49145b9826 100644 --- a/src/gctools/memoryManagement.cc +++ b/src/gctools/memoryManagement.cc @@ -39,7 +39,6 @@ THE SOFTWARE. #include #include #include -#include #include #include #include @@ -61,18 +60,6 @@ THE SOFTWARE. #include #endif -#if 0 -#define GCROOT_LOG(x) \ - if (_sym_STARdebug_gcrootsSTAR && _sym_STARdebug_gcrootsSTAR.boundp() && _sym_STARdebug_gcrootsSTAR->symbolValue() && \ - _sym_STARdebug_gcrootsSTAR->symbolValue().notnilp()) { \ - printf x; \ - } -#else -#define GCROOT_LOG(x) -#endif - -SYMBOL_EXPORT_SC_(GcToolsPkg, STARdebug_gcrootsSTAR); - extern "C" { void gc_park() { #if defined(USE_BOEHM) @@ -161,107 +148,11 @@ size_t _global_stack_max_size; StackRoot* rooted_StackRoots = NULL; #endif -void GCRootsInModule::setup_transients(core::SimpleVector_O** transient_alloca, size_t transient_entries) { - if (!transient_alloca && transient_entries != 0) { - printf("%s:%d:%s PROBLEM!!! transient_alloca is %p and transient_entries is %lu\n", __FILE__, __LINE__, __FUNCTION__, - transient_alloca, transient_entries); - abort(); - } - if (transient_alloca && transient_entries > 0) { - core::SimpleVector_sp sv = core::SimpleVector_O::make(transient_entries); - for (size_t ii = 0; ii < transient_entries; ++ii) { - (*sv)[ii] = core::make_fixnum(12345); - } - GCROOT_LOG(("%s:%d Setup simple vector@%p\n", __FILE__, __LINE__, (void*)sv.tagged_())); - *transient_alloca = &(*sv); - this->_TransientAlloca = transient_alloca; - } else { - this->_TransientAlloca = nullptr; - } -} - -GCRootsInModule::GCRootsInModule(void* module_mem, size_t num_entries, core::SimpleVector_O** transient_alloca, - size_t transient_entries, size_t function_pointer_count, void** fptrs) { - DEBUG_OBJECT_FILES_PRINT(("%s:%d:%s Compiled code literals are from %p to %p\n", __FILE__, __LINE__, __FUNCTION__, module_mem, - (char*)module_mem + (sizeof(core::T_O*) * num_entries))); - llvmo::JITDataReadWriteMaybeExecute(); - this->_function_pointer_count = function_pointer_count; - this->_function_pointers = fptrs; - this->_num_entries = num_entries; - this->_capacity = num_entries; - this->_module_memory = module_mem; - this->setup_transients(transient_alloca, transient_entries); - llvmo::JITDataReadExecute(); -} - -/*! initial_data is a gctools::Tagged pointer to a List of tagged pointers. - */ -void initialize_gcroots_in_module(GCRootsInModule* roots, core::T_O** root_address, size_t num_roots, gctools::Tagged initial_data, - core::SimpleVector_O** transientAlloca, size_t transient_entries, size_t function_pointer_count, - void** fptrs) { - // Get the address of the memory space in the llvm::Module - uintptr_t address = reinterpret_cast(root_address); - core::T_O** module_mem = reinterpret_cast(address); - // printf("%s:%d:%s address=%p nargs=%" PRu "\n", __FILE__, __LINE__, __FUNCTION__, (void*)address, nargs); - // printf("%s:%d:%s constants-table contents: vvvvv\n", __FILE__, __LINE__, __FUNCTION__ ); - // Create a GCRootsInModule structure to write the constants with - // FIXME: The GCRootsInModule is on the stack - once it's gone we loose the ability - // to keep track of the constants and in the future when we start GCing code - // we need to keep track of the constants. - new (roots) GCRootsInModule(reinterpret_cast(module_mem), num_roots, transientAlloca, transient_entries, - function_pointer_count, (void**)fptrs); - size_t idx = 0; - if (initial_data != 0) { - core::List_sp args((gctools::Tagged)initial_data); - for (auto c : args) { - core::T_sp arg = CONS_CAR(c); - - // - // This is where we translate some literals - // This is like load-time - // - if (gc::IsA(arg)) { - core::SimpleCoreFunGenerator_sp fdgen = gc::As_unsafe(arg); - arg = core::makeSimpleCoreFunFromGenerator(fdgen, roots, fptrs); - } else if (gc::IsA(arg)) { - core::CoreFunGenerator_sp fdgen = gc::As_unsafe(arg); - arg = core::makeCoreFunFromGenerator(fdgen, fptrs); - } - - roots->setLiteral(idx, arg.tagged_()); - ++idx; - } - } -} - -core::T_O* read_gcroots_in_module(GCRootsInModule* roots, size_t index) { return (core::T_O*)(roots->getLiteral(index)); } - -void shutdown_gcroots_in_module(GCRootsInModule* roots) { roots->_TransientAlloca = NULL; } - DOCGROUP(clasp); CL_DEFUN Fixnum gctools__nextStampValue() { return Header_s::StampWtagMtag::shift_unshifted_stamp(global_NextUnshiftedStamp); } DOCGROUP(clasp); CL_DEFUN Fixnum gctools__NextUnshiftedStampValue() { return global_NextUnshiftedStamp; } -CL_LAMBDA(address args); -DOCGROUP(clasp); -CL_DEFUN void gctools__register_roots(core::T_sp taddress, core::List_sp args) { - size_t nargs = core::cl__length(args); - // Get the address of the memory space in the llvm::Module - uintptr_t address = translate::make_from_object(taddress); - core::T_O** module_mem = reinterpret_cast(address); - // printf("%s:%d:%s address=%p nargs=%" PRu "\n", __FILE__, __LINE__, __FUNCTION__, (void*)address, nargs); - // printf("%s:%d:%s constants-table contents: vvvvv\n", __FILE__, __LINE__, __FUNCTION__ ); - // Create a ConstantsTable structure to write the constants with - GCRootsInModule ct(reinterpret_cast(module_mem), nargs, NULL, 0, 0, NULL); - size_t i = 0; - for (auto c : args) { - core::T_sp arg = oCar(c); - ct.setLiteral(i, arg.tagged_()); - ++i; - } -} - }; // namespace gctools namespace gctools { void lisp_increment_recursive_allocation_counter(ThreadLocalStateLowLevel* thread, size_t header_value) { @@ -721,123 +612,6 @@ void FinishAssingingBuiltinStamps() { }; // namespace gctools -namespace gctools { -Tagged GCRootsInModule::setLiteral(size_t raw_index, Tagged val) { - BOUNDS_ASSERT(raw_index < this->_capacity); - BOUNDS_ASSERT(raw_index < this->_num_entries); -#if 0 - printf("%s:%d:%s setting literal raw_index = %lu this->_module_memory = %p - turn off optnone\n", - __FILE__, __LINE__, __FUNCTION__, - raw_index, (void*)this->_module_memory ); -#endif - llvmo::JITDataReadWriteMaybeExecute(); - reinterpret_cast(this->_module_memory)[raw_index] = reinterpret_cast(val); - llvmo::JITDataReadExecute(); - return val; -} -Tagged GCRootsInModule::getLiteral(size_t raw_index) { - BOUNDS_ASSERT(raw_index < this->_capacity); - BOUNDS_ASSERT(raw_index < this->_num_entries); - return reinterpret_cast(reinterpret_cast(this->_module_memory)[raw_index]); -} - -size_t GCRootsInModule::push_back(Tagged val) { - size_t index = this->_num_entries; - this->_num_entries++; - this->setLiteral(index, val); - return index; -} - -Tagged GCRootsInModule::setTransient(size_t index, Tagged val) { - if (this->_TransientAlloca) { - core::SimpleVector_O* transients = *this->_TransientAlloca; - if (transients) { - BOUNDS_ASSERT(index < transients->length()); - core::T_sp tval((gctools::Tagged)val); - if (transients) { - GCROOT_LOG(("%s:%d:%s GCRootsInModule@%p[%lu] - writing %p of transient vector %p length: %lu\n", __FILE__, __LINE__, - __FUNCTION__, (void*)this, index, (void*)tval.tagged_(), (void*)transients.tagged_(), transients->length())); - GCROOT_LOG((" value -> %s\n", _rep_(tval).c_str())); - } else { - GCROOT_LOG(("%s:%d:%s GCRootsInModule@%p - writing %p to transient@%lu of transient vector %p BUT ITS NOT THERE!!!\n", - __FILE__, __LINE__, __FUNCTION__, (void*)this, (void*)tval.tagged_(), index, (void*)transients.tagged_())); - } - (*transients)[index] = tval; - return val; - } - printf("%s:%d There is no transients vector\n", __FILE__, __LINE__); - abort(); - } - printf("%s:%d:%s The _TransientAlloca was NULL but index is %lu\n", __FILE__, __LINE__, __FUNCTION__, index); - abort(); -} - -Tagged GCRootsInModule::getTransient(size_t index) { - if (this->_TransientAlloca) { - core::SimpleVector_O* transients = *this->_TransientAlloca; - if (transients) { - BOUNDS_ASSERT(index < transients->length()); - core::T_sp tval = (*transients)[index]; - if (transients) { - GCROOT_LOG(("%s:%d:%s GCRootsInModule@%p[%lu] - read %p of transient vector %p length: %lu value-> %s\n", __FILE__, - __LINE__, __FUNCTION__, (void*)this, index, (void*)tval.tagged_(), (void*)transients.tagged_(), - transients->length(), _rep_(tval).c_str())); - } else { - GCROOT_LOG(("%s:%d:%s GCRootsInModule@%p - writing %p to transient@%lu of transient vector %p BUT ITS NOT THERE!!!\n", - __FILE__, __LINE__, __FUNCTION__, (void*)this, (void*)tval.tagged_(), index, (void*)transients.tagged_())); - } - return tval.tagged_(); - } - printf("%s:%d There is no transients vector\n", __FILE__, __LINE__); - abort(); - } - printf("%s:%d:%s There _TransientAlloca is NULL index = %lu\n", __FILE__, __LINE__, __FUNCTION__, index); - abort(); -} - -Tagged GCRootsInModule::setTaggedIndex(char tag, size_t index, Tagged val) { - GCROOT_LOG(("%s:%d:%s GCRootsInModule@%p[%lu] tag '%d'\n", __FILE__, __LINE__, __FUNCTION__, (void*)this, index, tag)); - switch (tag) { - case 'l': - case LITERAL_TAG_CHAR: { - return setLiteral(index, val); - } - case 't': - case TRANSIENT_TAG_CHAR: { - return setTransient(index, val); - }; - }; - printf("%s:%d Illegal index %lu/0x%lx tag %c\n", __FILE__, __LINE__, index, index, tag); - abort(); -} - -Tagged GCRootsInModule::getTaggedIndex(char tag, size_t index) { - GCROOT_LOG(("%s:%d:%s GCRootsInModule@%p[%lu] tag '%d'\n", __FILE__, __LINE__, __FUNCTION__, (void*)this, index, tag)); - switch (tag) { - case 'l': - case LITERAL_TAG_CHAR: { - return getLiteral(index); - } - case 't': - case TRANSIENT_TAG_CHAR: { - return getTransient(index); - }; - }; - printf("%s:%d Illegal index %lu/0x%lx tag %c\n", __FILE__, __LINE__, index, index, tag); - abort(); -} - -void* GCRootsInModule::lookup_function(size_t index) { - if (index < this->_function_pointer_count) { - return (void*)this->_function_pointers[index]; - } - printf("%s:%d Illegal function pointer index %lu must be less than %lu\n", __FILE__, __LINE__, index, - this->_function_pointer_count); - abort(); -} - -}; // namespace gctools - namespace gctools { /* Walk all of the roots, passing the address of each root and what it represents */ diff --git a/src/gctools/threadlocal.cc b/src/gctools/threadlocal.cc index dd69fed0c7..b69b19aa72 100644 --- a/src/gctools/threadlocal.cc +++ b/src/gctools/threadlocal.cc @@ -423,7 +423,7 @@ void thread_local_invoke_and_clear_cleanup() { // Need to use LTO to inline this. inline void registerTypesAllocated(size_t bytes) { my_thread->_BytesAllocated += bytes; } -void ThreadLocalState::initialize_thread(mp::Process_sp process, bool initialize_GCRoots = true) { +void ThreadLocalState::initialize_thread(mp::Process_sp process) { // printf("%s:%d Initialize all ThreadLocalState things this->%p\n",__FILE__, __LINE__, (void*)this); this->_Process = process; process->_ThreadInfo = this; diff --git a/src/koga/configure.lisp b/src/koga/configure.lisp index a65ad31ff5..82e65593df 100644 --- a/src/koga/configure.lisp +++ b/src/koga/configure.lisp @@ -644,10 +644,22 @@ is not compatible with snapshots.") :scraper) :generate-vm-header (list (make-source #P"generate-vm-header.lisp" :build)) + :generate-lisp-info + (list (make-source #p"generate-lisp-info.lisp" :build)) + :compile-bytecode-image + (list (make-source #P"compile-bytecode-image.lisp" :build)) + :link-bytecode-image + (list (make-source #P"link-bytecode-image.lisp" :build)) + :compile-native-image + (list (make-source #p"compile-native-image.lisp" :build)) + :link-native-image + (list (make-source #p"link-native-image.lisp")) :compile-systems (list (make-source #P"compile-systems.lisp" :build)) :update-unicode (list (make-source #P"update-unicode.lisp" :build)) + :generate-encodings + (list (make-source #p"generate-encodings.lisp" :build)) :load-clasp (list (make-source #P"load-clasp.lisp" :build)) :snapshot-clasp @@ -656,8 +668,6 @@ is not compatible with snapshots.") (list (make-source #P"compile-clasp.lisp" :build)) :compile-module (list (make-source #P"compile-module.lisp" :build)) - :link-fasl - (list (make-source #P"link-fasl.lisp" :build)) :analyze-file (list (make-source #P"analyze-file.lisp" :build)) :analyze-generate @@ -684,7 +694,7 @@ is not compatible with snapshots.") :eclasp-link :sclasp :install-bin :install-code :clasp :regression-tests :analyzer :analyze :tags :install-extension-code :vm-header - :trampoline) + :trampoline :nclasp) :config-h (list (make-source #P"config.h" :variant) :scraper) @@ -692,7 +702,7 @@ is not compatible with snapshots.") (list (make-source #P"version.h" :variant)) :base-translations (list (make-source #P"generated/base-translations.lisp" :variant) - :cclasp) + :nclasp) :extension-translations (list (make-source #P"generated/extension-translations.lisp" :variant) :extension-translations) @@ -820,7 +830,7 @@ then they will overide the current variant's corresponding property." (defun fasl-extension (configuration) "Return the fasl extension based on the build mode." (case (build-mode configuration) - (:faso "faso") + (:faso "nfasl" #+(or)"faso") (:fasobc "fasobc") (:fasoll "fasoll") (otherwise "fasl"))) diff --git a/src/koga/ninja.lisp b/src/koga/ninja.lisp index 85924aef99..55c1ffc649 100644 --- a/src/koga/ninja.lisp +++ b/src/koga/ninja.lisp @@ -88,6 +88,14 @@ :command (lisp-command "generate-vm-header.lisp" "$out $in") :restat 1 :description "Generating VM header from $in") + (ninja:write-rule output-stream :generate-lisp-info + :command "$clasp -n -- $out /dev/null" + :description "Generating info from Clasp runtime" + :restat 1) + (ninja:write-rule output-stream :generate-encodings + :command (lisp-command "generate-encodings.lisp" "$out $in") + :description "Generating character encoding tables" + :restat 1) (ninja:write-rule output-stream :compile-systems :command "$clasp --norc --non-interactive --base --feature ignore-extensions --load compile-systems.lisp -- $out $systems" :description "Compiling systems: $systems" @@ -131,24 +139,16 @@ "$cxx -dynamiclib $variant-ldflags $ldflags -install_name @rpath/$libname -o$out $in $variant-ldlibs $ldlibs") #-darwin "$cxx -shared $variant-ldflags $ldflags -o$out $in $variant-ldlibs $ldlibs" :description "Linking $out") - (ninja:write-rule output-stream :load-cclasp - :command "$clasp --norc --disable-mpi --ignore-image --feature clasp-min --load load-clasp.lisp -- base 0 $source" - :description "Loading clasp $name" - :pool "console") - (ninja:write-rule output-stream :snapshot-cclasp - :command "$clasp --norc --disable-mpi --ignore-image --feature clasp-min --load snapshot-clasp.lisp -- $out base 0 $source" - :description "Snapshot clasp $name" - :pool "console") - (ninja:write-rule output-stream :compile-cclasp - :command "$clasp --norc --disable-mpi --ignore-image --feature clasp-min --load compile-clasp.lisp -- base 0 $source" - :description "Compiling clasp $name" + (ninja:write-rule output-stream :compile-bytecode-image + :command (lisp-command "compile-bytecode-image.lisp" "$in --output $out --sources $sources") + :description "Building Clasp bytecode image" + :restat 1) + (ninja:write-rule output-stream :compile-native-image + :command "$clasp --norc --disable-mpi --image $image --load \"SYS:SRC;LISP;MODULES;ASDF;BUILD;ASDF.LISP\" --eval \"(provide :asdf)\" --load compile-native-image.lisp --quit -- $in --output $out --sources $sources --cfasls $cfasls" + :description "Compiling Clasp native image" :restat 1 :pool "console") (when (extensions configuration) - (ninja:write-rule output-stream :load-eclasp - :command "$clasp --norc --disable-mpi --base --feature ignore-extension-systems --feature cclasp --load load-clasp.lisp -- extension $position $source" - :description "Loading eclasp" - :pool "console") (ninja:write-rule output-stream :snapshot-eclasp :command "$clasp --norc --disable-mpi --base --feature ignore-extension-systems --feature cclasp --load snapshot-clasp.lisp -- $out extension $position $source" :description "Snapshot eclasp" @@ -185,8 +185,8 @@ :command "$clasp --norc --base --feature ignore-extensions --load \"../dependencies/ansi-test/run-random-type-tests.lisp\"" :description "Running pfdietz test-random-integer-forms" :pool "console") - (ninja:write-rule output-stream :link-fasl - :command "$clasp --norc --disable-mpi --ignore-image --feature clasp-min --load link-fasl.lisp -- $out $in" + (ninja:write-rule output-stream :link-bytecode-image + :command (lisp-command "link-bytecode-image.lisp" "$out $in") :restat 1 :description "Linking $target") (ninja:write-rule output-stream "link-fasl-abc" @@ -583,6 +583,13 @@ (format nil "~{\"~/ninja:escape/\"~^ ~}" (mapcar #'source-logical-namestring sources)))) +(defun source-fasl (source &key (type "fasl")) + (make-source-output source + :type type + :root (if (eq (source-root source) :variant-generated) + :variant-lib-generated + :variant-lib))) + (defun jupyter-kernel-path (configuration name &key system) (declare (ignore configuration)) (merge-pathnames (make-pathname :directory (list :relative @@ -624,114 +631,94 @@ :install-outputs install-output))) (defmethod print-variant-target-sources - (configuration (name (eql :ninja)) output-stream (target (eql :cclasp)) sources + (configuration (name (eql :ninja)) output-stream (target (eql :nclasp)) sources &key &allow-other-keys) - (let* ((vimage (image-source configuration nil)) - (vimage-installed (image-source configuration nil :package-lib)) + (let* ((features.sexp (make-source "features.sexp" :variant-generated)) + (runtime-packages.lisp (make-source "runtime-packages.lisp" + :variant-generated)) + (cxx-classes.lisp (make-source "cxx-classes.lisp" :variant-generated)) + (runtime-functions.lisp (make-source "runtime-functions.lisp" + :variant-generated)) + (runtime-variables.lisp (make-source "runtime-variables.lisp" + :variant-generated)) + (runtime-info.lisp (make-source "runtime-info.lisp" :variant-generated)) + (type-map.lisp (make-source "type-map.lisp" :variant-generated)) + (fli-specs.lisp (make-source "fli-specs.lisp" :variant-generated)) + (generated-encodings.lisp + (make-source "generated-encodings.lisp" :variant-generated)) + (vimage (make-source "images/base.fasl" :variant-lib)) + (vimage-installed (make-source "images/base.fasl" :package-lib)) + (nimage (make-source "images/base.nfasl" :variant-lib)) + (nimage-installed (make-source "images/base.nfasl" :package-lib)) + (image (ecase (build-mode configuration) + ((:bytecode) vimage) + ((:bytecode-faso :faso) nimage))) (iclasp (make-source "iclasp" :variant)) (clasp-with-env (wrap-with-env configuration iclasp))) - (ninja:write-build output-stream :load-cclasp - :clasp clasp-with-env - :source (make-kernel-source-list configuration sources) - :inputs sources - :implicit-inputs (list iclasp - (make-source "tools-for-build/character-names.sexp" :code)) - :outputs (list (build-name "load_cclasp"))) - (ninja:write-build output-stream :compile-cclasp - :clasp clasp-with-env - :source (make-kernel-source-list configuration sources) - :inputs sources - :implicit-inputs (list iclasp - (make-source "tools-for-build/character-names.sexp" :code)) - :outputs (mapcar (lambda (x) - (make-source-output x - :type (fasl-extension configuration) - :root (if (eq (source-root x) :variant-generated) - :variant-lib-generated - :variant-lib))) - sources)) - (ninja:write-build output-stream (case (build-mode configuration) - ((:bytecode :bytecode-faso :faso :fasoll :fasobc) :link-fasl) - (otherwise "link-fasl-abc")) - :variant-ldflags *variant-ldflags* - :variant-ldlibs *variant-ldlibs* + (ninja:write-build output-stream :generate-lisp-info + :outputs (list features.sexp runtime-packages.lisp + cxx-classes.lisp runtime-functions.lisp + runtime-variables.lisp runtime-info.lisp + type-map.lisp fli-specs.lisp) :clasp clasp-with-env - :target "cclasp" - :inputs (mapcar (lambda (x) - (make-source-output x - :type (fasl-extension configuration) - :root (if (eq (source-root x) :variant-generated) - :variant-lib-generated - :variant-lib))) - sources) - :implicit-inputs (list iclasp) - :outputs (list vimage)) + :implicit-inputs (list iclasp)) + (ninja:write-build output-stream :generate-encodings + :inputs (list (make-source "tools-for-build/encodingdata.txt" :code)) + :outputs (list generated-encodings.lisp)) + (let ((fasls (mapcar #'source-fasl sources)) + (outputs ; interleaved fasls and cfasls + (loop for source in sources + collect (source-fasl source) + collect (source-fasl source :type "cfasl")))) + (ninja:write-build output-stream :compile-bytecode-image + :inputs (list* (make-source "tools-for-build/character-names.sexp" + :code) + features.sexp + sources) + :sources (make-kernel-source-list + configuration sources) + :outputs outputs) + (ninja:write-build output-stream :link-bytecode-image + :inputs fasls + :outputs (list vimage) + :target target)) + (let ((nfasls (loop for source in sources + collect (source-fasl source :type "nfasl"))) + (cfasls + (format nil "~{\"~/ninja:escape/\"~^ ~}" + (loop for source in sources + collect (source-fasl source + :type "cfasl"))))) + (ninja:write-build output-stream :compile-native-image + :clasp clasp-with-env + :source (make-kernel-source-list configuration sources) + :inputs (list* (make-source "tools-for-build/character-names.sexp" + :code) + features.sexp + sources) + :sources (make-kernel-source-list configuration sources) + :cfasls cfasls + :implicit-inputs (list iclasp vimage) + :image vimage + :outputs nfasls) + (ninja:write-build output-stream :link-bytecode-image + :clasp clasp-with-env + :outputs (list nimage) + :inputs nfasls)) (ninja:write-build output-stream :phony :inputs (list (build-name "iclasp") - vimage + image (build-name "modules")) - :outputs (list (build-name "cclasp"))) - (when (jupyter configuration) - (let ((kernels (loop for name in (if (member :cando (extensions configuration)) - (list "clasp" "cando") - (list "clasp")) - for clasp = (make-source name :variant) - for build-name = (build-name name) - for output = (jupyter-kernel-path configuration - (format nil "~a_~a" - (if (equal name "clasp") - "common-lisp" - "cando") - build-name)) - do (ninja:write-build output-stream :jupyter-user-kernel - :outputs (list output) - :inputs (list (build-name "cclasp")) - :variant-path *variant-path* - :name build-name - :bin-path clasp - :load-system 1 - :clasp clasp-with-env) - collect output))) - (ninja:write-build output-stream :phony - :inputs kernels - :outputs (list (build-name "jupyter_cclasp"))) - (unless (eq :sclasp (default-stage configuration)) - (ninja:write-build output-stream :phony - :inputs (list (build-name "jupyter_cclasp")) - :outputs (list (build-name "jupyter")))))) + :outputs (list (build-name "nclasp"))) (when *variant-default* - (let ((kernels (when (jupyter configuration) - (loop with system = (not (uiop:subpathp (share-path configuration) - (uiop:getenv-absolute-directory "HOME"))) - for name in (if (member :cando (extensions configuration)) - (list "clasp" "cando") - (list "clasp")) - for clasp = (make-source name :variant) - for output = (jupyter-kernel-path configuration - (if (equal name "clasp") - "common-lisp_clasp" - "cando_cando") - :system system) - do (ninja:write-build output-stream (if system - :jupyter-system-kernel - :jupyter-user-kernel) - :outputs (list output) - :inputs (list (build-name "cclasp")) - :name name - :variant-path *variant-path* - :bin-path name - :load-system 1 - :clasp clasp-with-env) - collect output)))) - (ninja:write-build output-stream :install-file - :inputs (list vimage) - :outputs (list vimage-installed)) - (ninja:write-build output-stream :phony - :inputs (list* "install_iclasp" - "install_modules" - vimage-installed - kernels) - :outputs (list "install_cclasp")))))) + (ninja:write-build output-stream :install-file + :inputs (list vimage) + :outputs (list vimage-installed)) + (ninja:write-build output-stream :phony + :inputs (list "install_iclasp" + "install_modules" + vimage-installed) + :outputs (list "install_nclasp"))))) (defmethod print-variant-target-sources (configuration (name (eql :ninja)) output-stream (target (eql :modules)) sources @@ -748,62 +735,37 @@ (configuration (name (eql :ninja)) output-stream (target (eql :eclasp)) sources &key &allow-other-keys) (when (extensions configuration) - (let* ((cimage (image-source configuration nil)) - (eimage (image-source configuration t)) - (eimage-installed (image-source configuration t :package-lib)) - (iclasp (make-source "iclasp" :variant)) + (let* ((cimage (make-source "images/base.fasl" :variant-lib)) + (eimage (image-source configuration t)) + (eimage-installed (image-source configuration t :package-lib)) + (iclasp (make-source "iclasp" :variant)) (clasp-with-env (wrap-with-env configuration iclasp)) - (eclasp-sources (member #P"src/lisp/kernel/stage/extension/0-begin.lisp" sources :key #'source-path :test #'equal))) - (ninja:write-build output-stream :load-eclasp - :clasp clasp-with-env - :source (make-kernel-source-list configuration sources) - :inputs sources - :position (- (length sources) (length eclasp-sources)) - :source (make-kernel-source-list configuration eclasp-sources) - :inputs eclasp-sources - :implicit-inputs (list iclasp cimage (build-name "cclasp") - (make-source "tools-for-build/character-names.sexp" :code)) - :outputs (list (build-name "load_eclasp"))) + (eclasp-sources (member #P"src/lisp/kernel/stage/extension/0-begin.lisp" sources :key #'source-path :test #'equal)) + (fasls (mapcar (lambda (x) + (source-fasl x :type (fasl-extension configuration))) + eclasp-sources))) (ninja:write-build output-stream :compile-eclasp :clasp clasp-with-env :image cimage :position (- (length sources) (length eclasp-sources)) :source (make-kernel-source-list configuration eclasp-sources) :inputs eclasp-sources - :implicit-inputs (list iclasp cimage (build-name "cclasp") - (make-source "tools-for-build/character-names.sexp" :code)) - :outputs (mapcar (lambda (x) - (make-source-output x - :type (fasl-extension configuration) - :root (if (eq (source-root x) :variant-generated) - :variant-lib-generated - :variant-lib))) - eclasp-sources)) - (ninja:write-build output-stream (case (build-mode configuration) - ((:bytecode :bytecode-faso :faso :fasoll :fasobc) :link-fasl) - (otherwise "link-fasl-abc")) - :variant-ldflags *variant-ldflags* - :variant-ldlibs *variant-ldlibs* - :clasp clasp-with-env - :target "eclasp" - :inputs (mapcar (lambda (x) - (make-source-output x - :type (fasl-extension configuration) - :root (if (eq (source-root x) :variant-generated) - :variant-lib-generated - :variant-lib))) - sources) + :implicit-inputs (list iclasp (build-name "nclasp")) + :outputs fasls) + (ninja:write-build output-stream :link-bytecode-image + :inputs (list* cimage fasls) :implicit-inputs (list iclasp) - :outputs (list eimage)) + :outputs (list eimage) + :target target) (ninja:write-build output-stream :phony - :inputs (list eimage (build-name "cclasp")) + :inputs (list eimage (build-name "nclasp")) :outputs (list (build-name "eclasp"))) (when *variant-default* (ninja:write-build output-stream :install-file :inputs (list eimage) :outputs (list eimage-installed)) (ninja:write-build output-stream :phony - :inputs (list "install_cclasp" + :inputs (list "install_nclasp" eimage-installed) :outputs (list "install_eclasp")))))) @@ -813,29 +775,29 @@ &aux (clasp (wrap-with-env configuration (make-source "iclasp" :variant)))) (ninja:write-build output-stream :regression-tests :clasp clasp - :inputs (list (build-name "cclasp")) + :inputs (list (build-name "nclasp")) :outputs (list (build-name "test"))) (ninja:write-build output-stream :bench :clasp clasp - :inputs (list (build-name "cclasp")) + :inputs (list (build-name "nclasp")) :outputs (list (build-name "bench"))) (ninja:write-build output-stream :ansi-test :clasp clasp - :inputs (list (build-name "cclasp")) + :inputs (list (build-name "nclasp")) :outputs (list (build-name "ansi-test"))) (ninja:write-build output-stream :asdf-test :clasp clasp :target "t" - :inputs (list (build-name "cclasp")) + :inputs (list (build-name "nclasp")) :outputs (list (build-name "asdf-test"))) (ninja:write-build output-stream :asdf-test :clasp clasp :target "u" - :inputs (list (build-name "cclasp")) + :inputs (list (build-name "nclasp")) :outputs (list (build-name "asdf-test-upgrade"))) (ninja:write-build output-stream :test-random-integer :clasp clasp - :inputs (list (build-name "cclasp")) + :inputs (list (build-name "nclasp")) :outputs (list (build-name "test-random-integer"))) (when (member :cando (extensions configuration)) (ninja:write-build output-stream :cando-regression-tests @@ -875,7 +837,7 @@ (ninja:write-build output-stream :compile-systems :clasp (wrap-with-env configuration (make-source "iclasp" :variant)) :inputs sources - :implicit-inputs (list (build-name "cclasp")) + :implicit-inputs (list (build-name "nclasp")) :systems "clasp-analyzer" :outputs (list (make-source "analyzer.stub" :variant-lib)))) @@ -891,7 +853,7 @@ (ninja:write-build output-stream :analyze-file :clasp (wrap-with-env configuration (make-source "iclasp" :variant)) :inputs (list source) - :implicit-inputs (list (build-name "cclasp") + :implicit-inputs (list (build-name "nclasp") (build-name "generated" :gc :boehm) database (make-source "analyzer.stub" :variant-lib)) @@ -911,7 +873,7 @@ (ninja:write-build output-stream :analyze-generate :clasp (wrap-with-env configuration (make-source "iclasp" :variant)) :inputs outputs - :implicit-inputs (list (build-name "cclasp") + :implicit-inputs (list (build-name "nclasp") (build-name "generated" :gc :boehm) (make-source "analyzer.stub" :variant-lib)) :sif sif diff --git a/src/koga/scripts.lisp b/src/koga/scripts.lisp index b3612b158d..bac43e0ed7 100644 --- a/src/koga/scripts.lisp +++ b/src/koga/scripts.lisp @@ -27,16 +27,187 @@ (ninja:with-timestamp-preserving-stream (stream (first (uiop:command-line-arguments))) (cmpref:generate-virtual-machine-header stream))")) +(defmethod print-prologue (configuration (name (eql :generate-lisp-info)) output-stream) + (declare (ignore configuration)) + (format output-stream "~ +(print *features* (open (core:argv 3) :if-exists :overwrite :if-does-not-exist :create :direction :output)) +(let ((o (open (core:argv 4) :if-exists :overwrite :if-does-not-exist :create :direction :output))) + (write-line \"(eval-when (:compile-toplevel)\" o) + (mapc #'(lambda (p) + (if (if (string= (package-name p) \"COMMON-LISP\") nil (if (string= (package-name p) \"KEYWORD\") nil t)) + (print `(defpackage ,(package-name p) + (:use ,@(mapcar #'package-name (package-use-list p))) + (:nicknames ,@(package-nicknames p)) + (:shadow ,@(mapcar #'symbol-name (package-shadowing-symbols p))) + (:export ,@(let ((ss '())) + (maphash #'(lambda (k v) (setq ss (cons k ss))) + (core:package-hash-tables p)) + ss))) + o))) + (list-all-packages)) + (write-line \")\" o)) +(print `(progn + ,@(mapcar #'(lambda (cn) + `(defclass ,cn (,@(mapcar #'core:name-of-class + (clos:direct-superclasses (find-class cn)))) + () + (:metaclass ,(core:name-of-class (class-of (find-class cn)))))) + (reverse core:*all-cxx-classes*))) + (open (core:argv 5) :if-exists :overwrite :if-does-not-exist :create :direction :output)) +(print `(eval-when (:compile-toplevel) + (mapcar (lambda (fname) (cmp::register-global-function-def 'defun fname)) + '(,@(let ((ss '())) + (flet ((frob (k v) + (if (fboundp v) + (if (not (macro-function v)) + (if (not (special-operator-p v)) + (setq ss (cons v ss))))) + (if (fboundp `(setf ,v)) + (setq ss (cons `(setf ,v) ss))))) + (mapc #'(lambda (p) + (multiple-value-call + #'(lambda (ext int &rest _) + (maphash #'frob ext) + (maphash #'frob int)) + (core:package-hash-tables p))) + (list-all-packages))) + ss)))) + (open (core:argv 6) :if-exists :overwrite :if-does-not-exist :create :direction :output)) +(print `(eval-when (:compile-toplevel) + ,@(let ((ss '())) + (flet ((frob (k v) + (if (constantp v) + (let ((value (symbol-value v))) + ;; only dump definitely-serializable constants + (if (if (integerp value) t (if (stringp value) t nil)) + (setq ss (cons `(defconstant ,v (if (boundp ',v) (symbol-value ',v) ',value)) ss)))) + (if (ext:specialp v) + (setq ss (cons `(defvar ,v) ss)))))) + (mapc #'(lambda (p) + (if (not (string= (package-name p) \"KEYWORD\")) + (multiple-value-call + #'(lambda (ext int &rest _) + (maphash #'frob ext) + (maphash #'frob int)) + (core:package-hash-tables p)))) + (list-all-packages))) + ss)) + (open (core:argv 7) :if-exists :overwrite :if-does-not-exist :create :direction :output)) +(let ((s (open (core:argv 8) :if-exists :overwrite :if-does-not-exist :create :direction :output))) + (print `(in-package #:cmp) s) + (print `(defvar +cxx-data-structures-info+ ',(llvm-sys:cxx-data-structures-info)) s)) +(let ((s (open (core:argv 9) :if-exists :overwrite :if-does-not-exist :create :direction :output))) + (print `(in-package #:core) s) + (print `(eval-when (:compile-toplevel) + (defparameter +type-header-value-map+ + (loop with table = (make-hash-table :test #'eq) + for (type . header) in + '(,@(let ((s ())) + (maphash + #'(lambda (k v) + (setq s (cons (cons k v) s))) + core:+type-header-value-map+) + s)) + do (setf (gethash type table) header) + finally (return table)))) + s)) +;; This is probably the worst, in terms of pidginness. +;; In primitive Clasp we have no operator for mapping over a vector. +(let ((s (open (core:argv 10) :if-exists :overwrite :if-does-not-exist :create :direction :output))) + (print `(in-package #:clasp-ffi) s) + (print `(eval-when (:compile-toplevel) + (defparameter *foreign-type-specs* + '(,@(let ((len (length clasp-ffi:*foreign-type-spec-table*))) + (labels ((frob (index accum) + (if (>= index len) (return-from frob accum)) + (let ((spec (aref clasp-ffi:*foreign-type-spec-table* index))) + (frob (+ index 1) + (if spec + (cons (cons (clasp-ffi:%lisp-symbol spec) index) accum) + accum))))) + (frob 0 nil)))))) + s)) +(core:quit)")) + (defmethod print-prologue (configuration (name (eql :update-unicode)) output-stream) (declare (ignore configuration)) (print-asdf-stub output-stream t :unicode-data) (pprint '(apply #'uiop:symbol-call "UNICODE-DATA" "GENERATE" (uiop:command-line-arguments)) output-stream)) +(defmethod print-prologue (configuration (name (eql :generate-encodings)) output-stream) + (declare (ignore configuration)) + (print-asdf-stub output-stream t :encoding-generator) + (let ((*package* (find-package "KOGA"))) ; don't print package prefixes + (pprint '(defvar *encoding-data*) output-stream) + (pprint '(defvar *generated-encodings.lisp*) output-stream) + (pprint '(destructuring-bind (generated-encodings.lisp encodingdata.txt) + (uiop:command-line-arguments) + (setf *encoding-data* (uiop:symbol-call "ENCODING-GENERATOR" "PROCESS-ENCODINGS-FILE" encodingdata.txt) + *generated-encodings.lisp* generated-encodings.lisp)) + output-stream) + (pprint '(with-open-file (gen *generated-encodings.lisp* + :direction :output + :if-does-not-exist :create + :if-exists :supersede + :external-format :utf-8) + (pprint '(in-package #:ext) gen) (terpri gen) + (format gen "(defvar *encoding-data*~% #.~s)" + `(loop with data = (make-hash-table) + for (encoding . table) in ',*encoding-data* + for ht = (make-hash-table) + do (setf (gethash encoding data) ht) + (loop for (code . unicode) in table + for char = (code-char unicode) + do (setf (gethash code ht) char + (gethash char ht) code)) + finally (return data)))) + output-stream))) + (defmethod print-prologue (configuration (name (eql :generate-sif)) output-stream) (declare (ignore configuration)) (print-asdf-stub output-stream t :clasp-scraper) (pprint '(apply #'uiop:symbol-call "CSCRAPE" "GENERATE-SIF" (uiop:command-line-arguments)) output-stream)) +(defmethod print-prologue (configuration (name (eql :compile-bytecode-image)) output-stream) + (declare (ignore configuration)) + (print-asdf-stub output-stream t :cross-clasp) + (format output-stream " +(destructuring-bind (character-names features &rest sources) + (uiop:command-line-arguments) + (uiop:symbol-call \"CROSS-CLASP\" \"INITIALIZE\" character-names features) + (let* ((breaker (position \"--output\" sources :test #'string=)) + (_ (unless breaker (error \"Need --output to compile-bytecode-image\"))) + (b2 (position \"--sources\" sources :test #'string=)) + (_2 (unless b2 (error \"Need --sources to compile-bytecode-image\"))) + (input (subseq sources 0 breaker)) + (output (subseq sources (1+ breaker) b2)) + (sourcepaths (subseq sources (1+ b2)))) + (uiop:symbol-call \"CROSS-CLASP\" \"BUILD\" input output sourcepaths)))")) + +(defmethod print-prologue (configuration (name (eql :compile-native-image)) output-stream) + (declare (ignore configuration)) + (print-asdf-stub output-stream t :cross-clasp) + (format output-stream " +(destructuring-bind (character-names features &rest sources) + (uiop:command-line-arguments) + (uiop:symbol-call \"CROSS-CLASP\" \"INITIALIZE\" character-names features) + (let* ((number-of-jobs + (if (ext:getenv \"CLASP_BUILD_JOBS\") + (parse-integer (ext:getenv \"CLASP_BUILD_JOBS\")) + ~d)) + (breaker (position \"--output\" sources :test #'string=)) + (_ (unless breaker (error \"Need --output to compile-bytecode-image\"))) + (b2 (position \"--sources\" sources :test #'string=)) + (_2 (unless b2 (error \"Need --sources to compile-bytecode-image\"))) + (b3 (position \"--cfasls\" sources :test #'string=)) + (_3 (unless b3 (error \"Need --crasls to compile-bytecode-image\"))) + (input (subseq sources 0 breaker)) + (output (subseq sources (1+ breaker) b2)) + (sourcepaths (subseq sources (1+ b2) b3)) + (cfasls (subseq sources (1+ b3)))) + (uiop:symbol-call \"CROSS-CLASP\" \"BUILD-NATIVE\" input output sourcepaths cfasls :parallel-jobs number-of-jobs)))" + (jobs configuration))) + (defmethod print-prologue (configuration (name (eql :compile-systems)) output-stream) (declare (ignore configuration)) (format output-stream "#-asdf (require :asdf)~% @@ -79,69 +250,18 @@ :faso (build-mode configuration)))) -(defmethod print-prologue (configuration (name (eql :load-clasp)) output-stream) - (format output-stream "(load #P\"sys:src;lisp;kernel;clasp-builder.lisp\") -(setq core::*number-of-jobs* - (if (ext:getenv \"CLASP_BUILD_JOBS\") - (parse-integer (ext:getenv \"CLASP_BUILD_JOBS\")) - ~a)) -(defvar *system* (core:load-clasp :reproducible ~s - :name (elt core:*command-line-arguments* 0) - :position (parse-integer (elt core:*command-line-arguments* 1)) - :system (core:command-line-paths 2))) -(if (fboundp 'core:top-level) - (core:top-level) - (core:low-level-repl))" (jobs configuration) (reproducible-build configuration))) - -(defmethod print-prologue (configuration (name (eql :snapshot-clasp)) output-stream) - (format output-stream "(load #P\"sys:src;lisp;kernel;clasp-builder.lisp\") -(setq core::*number-of-jobs* - (if (ext:getenv \"CLASP_BUILD_JOBS\") - (parse-integer (ext:getenv \"CLASP_BUILD_JOBS\")) - ~a)) -(defvar *system* (core:load-clasp :reproducible ~s - :name (elt core:*command-line-arguments* 1) - :position (parse-integer (elt core:*command-line-arguments* 2)) - :system (core:command-line-paths 3))) -(gctools:save-lisp-and-die (elt core:*command-line-arguments* 0) :executable t) -(core:quit)" (jobs configuration) (reproducible-build configuration))) - -(defmethod print-prologue (configuration (name (eql :compile-clasp)) output-stream) - (format output-stream "(setq cmp:*default-output-type* ~s) -(load #P\"sys:src;lisp;kernel;clasp-builder.lisp\") -(setq core::*number-of-jobs* - (if (ext:getenv \"CLASP_BUILD_JOBS\") - (parse-integer (ext:getenv \"CLASP_BUILD_JOBS\")) - ~a)) -(core:load-and-compile-clasp :reproducible ~s :system-sort ~s - :name (elt core:*command-line-arguments* 0) - :position (parse-integer (elt core:*command-line-arguments* 1)) - :system (core:command-line-paths 2)) -(core:quit)" - (if (eq (build-mode configuration) :bytecode-faso) - :faso - (build-mode configuration)) - (jobs configuration) (reproducible-build configuration) - (and (> (jobs configuration) 1) (parallel-build configuration)))) - -(defmethod print-prologue (configuration (name (eql :link-fasl)) output-stream) - (format output-stream "(setq *features* (cons :aclasp *features*) - cmp:*default-output-type* ~s) -(load #P\"sys:src;lisp;kernel;clasp-builder.lisp\") -(load #P\"sys:src;lisp;kernel;cmp;jit-setup.lisp\") -(core:link-fasl :output-file (pathname (elt core:*command-line-arguments* 0)) - :system (core:command-line-paths 1)) -(core:quit)" - (if (eq (build-mode configuration) :bytecode-faso) - :faso - (build-mode configuration)))) +(defmethod print-prologue (configuration (name (eql :link-bytecode-image)) output-stream) + (declare (ignore configuration)) + (print-asdf-stub output-stream t :maclina/compile-file) + (format output-stream "(apply #'uiop:symbol-call \"MACLINA.COMPILE-FILE\" \"LINK-FASLS\" + (uiop:command-line-arguments))")) (defmethod print-prologue (configuration (name (eql :analyze-generate)) output-stream) (declare (ignore configuration)) (print-asdf-stub output-stream nil :clasp-analyzer) (format output-stream " (clasp-analyzer:merge-and-generate-code (pathname (elt core:*command-line-arguments* 0)) - (core::command-line-paths 1))")) + (map 'list #'pathname (subseq core:*command-line-arguments* 1)))")) (defmethod print-prologue (configuration (name (eql :analyze-file)) output-stream) (declare (ignore configuration)) @@ -279,6 +399,12 @@ exec $(dirname \"$0\")/iclasp -f ignore-extensions --base \"$@\"")) &key &allow-other-keys) (print-translations output-stream sources)) +(defmethod print-variant-target-sources + (configuration (name (eql :base-translations)) output-stream + (target (eql :nclasp)) sources + &key &allow-other-keys) + (print-translations output-stream sources)) + (defmethod print-variant-target-sources (configuration (name (eql :extension-translations)) output-stream (target (eql :extension-translations)) sources @@ -286,7 +412,7 @@ exec $(dirname \"$0\")/iclasp -f ignore-extensions --base \"$@\"")) (print-translations output-stream sources)) (defmethod print-prologue (configuration (name (eql :base-immutable)) output-stream) - (pprint-immutable-systems output-stream (gethash :cclasp (target-systems configuration)))) + (pprint-immutable-systems output-stream (gethash :nclasp (target-systems configuration)))) (defmethod print-prologue (configuration (name (eql :extension-immutable)) output-stream) (pprint-immutable-systems output-stream (gethash :eclasp (target-systems configuration)))) diff --git a/src/koga/units.lisp b/src/koga/units.lisp index e019b112d3..4a8b0de6e2 100644 --- a/src/koga/units.lisp +++ b/src/koga/units.lisp @@ -244,7 +244,7 @@ (unless default-target (setf default-target (if (extensions configuration) "eclasp-boehmprecise" - "cclasp-boehmprecise"))) + "nclasp-boehmprecise"))) (loop with bitcode-name = (subseq default-target (1+ (position #\- default-target))) for variant in (variants configuration) when (equal bitcode-name (variant-bitcode-name variant)) diff --git a/src/lisp/cscript.lisp b/src/lisp/cscript.lisp index 9bac4b963a..d46eb2670c 100644 --- a/src/lisp/cscript.lisp +++ b/src/lisp/cscript.lisp @@ -1,62 +1,81 @@ -(defun add-cclasp-sources (target) +(defun add-nclasp-sources (target) (k:sources target - #~"kernel/stage/base/0-begin.lisp" - #~"kernel/stage/base/1-begin.lisp" - #~"kernel/lsp/prologue.lisp" - #~"kernel/init.lisp" - #~"kernel/cmp/runtime-info.lisp" - #~"kernel/lsp/sharpmacros.lisp" - #~"kernel/cmp/jit-setup.lisp" - #~"kernel/clsymbols.lisp" - #~"kernel/lsp/packages.lisp" - #~"kernel/lsp/foundation.lisp" - #~"kernel/lsp/export.lisp" - #~"kernel/lsp/defmacro.lisp" - #~"kernel/lsp/helpfile.lisp" - #~"kernel/lsp/evalmacros.lisp" - #~"kernel/lsp/claspmacros.lisp" - #~"kernel/lsp/source-transformations.lisp" + #@"runtime-packages.lisp" + #@"runtime-functions.lisp" + #@"runtime-variables.lisp" + #@"type-map.lisp" + #~"kernel/contrib-packages.lisp" + #~"kernel/cmp/cmpref-package.lisp" + ;; Enough CLOS to call generic functions + #~"kernel/clos/method-combination-environment.lisp" + #~"kernel/clos/standard-method-combinations.lisp" + #~"kernel/clos/hierarchy.lisp" + #~"kernel/clos/method-function.lisp" + #~"kernel/clos/eql-specializer.lisp" + #~"kernel/clos/applicable-methods.lisp" + #~"kernel/clos/effective-method.lisp" + #~"kernel/clos/outcome.lisp" + #~"kernel/clos/slot-value.lisp" + #~"kernel/clos/effective-accessor.lisp" + #~"kernel/clos/dtree-ops.lisp" + #~"kernel/clos/interpreted-discriminator.lisp" + #~"kernel/clos/miss.lisp" + #~"kernel/clos/check-initargs.lisp" + #~"kernel/clos/static-gfs/package.lisp" + #~"kernel/clos/static-gfs/flag.lisp" + #~"kernel/clos/make.lisp" + #~"kernel/clos/print.lisp" + #~"kernel/clos/misc.lisp" + #@"cxx-classes.lisp" + #~"kernel/clos/base-satiation.lisp" + ;; Library + #~"kernel/lsp/debug.lisp" + #~"kernel/clos/conditions.lisp" + #~"kernel/lsp/assert.lisp" + #~"kernel/clos/package.lisp" + #~"kernel/lsp/ext-package.lisp" #~"kernel/lsp/arraylib.lisp" - #~"kernel/lsp/setf.lisp" - #~"kernel/lsp/listlib.lisp" - #~"kernel/lsp/mislib.lisp" - #~"kernel/lsp/defstruct.lisp" + #~"kernel/lsp/numlib.lisp" #~"kernel/lsp/predlib.lisp" #~"kernel/lsp/cdr-5.lisp" - #~"kernel/lsp/cmuutil.lisp" + #~"kernel/lsp/module.lisp" + #~"kernel/clos/streams.lisp" + #~"kernel/lsp/pprint.lisp" + #~"kernel/lsp/listlib.lisp" + #~"kernel/lsp/mislib.lisp" #~"kernel/lsp/seqmacros.lisp" #~"kernel/lsp/seq.lisp" #~"kernel/lsp/seqlib.lisp" #~"kernel/lsp/iolib.lisp" #~"kernel/lsp/trace.lisp" - #~"kernel/lsp/debug.lisp" - #~"kernel/cmp/cmpexports.lisp" - #~"kernel/cmp/cmpsetup.lisp" + #~"kernel/lsp/assorted.lisp" + #~"kernel/lsp/packlib.lisp" + #~"kernel/clos/sequences.lisp" + #~"kernel/lsp/helpfile.lisp" + #~"kernel/lsp/describe.lisp" + #~"kernel/lsp/source-location.lisp" + #~"kernel/clos/inspect.lisp" + ;; CLOS part two: defining new generics, classes, etc + #~"kernel/clos/change.lisp" + #~"kernel/clos/dependent.lisp" + #~"kernel/clos/class.lisp" + #~"kernel/clos/cpl.lisp" + #~"kernel/clos/generic.lisp" + #~"kernel/clos/method.lisp" + ;; compiler #~"kernel/cmp/cmputil.lisp" - #~"kernel/cmp/cmpintrinsics.lisp" - #~"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" - #~"kernel/cmp/codegen-special-form.lisp" + #~"kernel/cmp/compiler-conditions.lisp" #~"kernel/cmp/compile.lisp" - #~"kernel/cmp/external-clang.lisp" + #~"kernel/cmp/walk.lisp" #~"kernel/cmp/bytecode-machines.lisp" - #~"kernel/cmp/bytecode-reference.lisp" - #@"base-translations.lisp" - #~"kernel/stage/base/0-end.lisp" - #~"kernel/cmp/cmpwalk.lisp" - #~"kernel/lsp/assert.lisp" - #~"kernel/lsp/iolib.lisp" - #~"kernel/lsp/numlib.lisp" - #~"kernel/lsp/describe.lisp" - #~"kernel/lsp/module.lisp" - #~"kernel/lsp/loop2.lisp" + #~"kernel/cmp/bytecode-introspect.lisp" #~"kernel/cmp/disassemble.lisp" - #~"kernel/cmp/opt/opt.lisp" ; need loop + #~"kernel/cmp/bundle.lisp" + #~"kernel/cmp/exports.lisp" + ;; compiler macros + #~"kernel/lsp/source-transformations.lisp" + #~"kernel/cmp/compiler-macro.lisp" + #~"kernel/cmp/opt/opt.lisp" #~"kernel/cmp/opt/opt-character.lisp" #~"kernel/cmp/opt/opt-number.lisp" #~"kernel/cmp/opt/opt-type.lisp" @@ -66,43 +85,48 @@ #~"kernel/cmp/opt/opt-array.lisp" #~"kernel/cmp/opt/opt-object.lisp" #~"kernel/cmp/opt/opt-print.lisp" + ;; macros + #~"kernel/lsp/cmuutil.lisp" #~"kernel/lsp/shiftf-rotatef.lisp" - #~"kernel/lsp/assorted.lisp" - #~"kernel/lsp/packlib.lisp" + #~"kernel/lsp/setf.lisp" + #~"kernel/lsp/do.lisp" #~"kernel/lsp/defpackage.lisp" #~"kernel/lsp/format.lisp" + #~"kernel/lsp/format-pprint.lisp" + #~"kernel/lsp/defmacro.lisp" + #~"kernel/lsp/evalmacros.lisp" + #~"kernel/lsp/defstruct.lisp" + #~"kernel/lsp/sharpmacros.lisp" #~"kernel/lsp/mp.lisp" #~"kernel/lsp/atomics.lisp" - #~"kernel/clos/package.lisp" + #~"kernel/lsp/mp-package.lisp" + #~"kernel/clos/atomics.lisp" + #~"kernel/clos/define-method-combination.lisp" + #~"kernel/lsp/special-operators.lisp" + ;; some extensions + #~"kernel/lsp/defvirtual.lisp" + #~"kernel/clos/telemetry.lisp" + #~"kernel/cmp/xref.lisp" + #@"generated-encodings.lisp" + #~"kernel/lsp/encodings.lisp" + #~"kernel/lsp/posix.lisp" + #~"kernel/lsp/process.lisp" + ;; toplevel + #~"kernel/lsp/top.lisp" + #~"kernel/lsp/top-hook.lisp" + #~"kernel/install-delayed-macros.lisp" + :ecclesia + :khazern-extension-intrinsic + ;; logical pathname translation + #@"base-translations.lisp" + #~"modules/sockets/sockets.lisp" + #@"base-immutable.lisp" + ;; CLOS part three: compiled discriminators, user satiation, static GFs + #~"kernel/clos/compiled-discriminator.lisp" + #~"kernel/clos/satiation.lisp" #~"kernel/clos/static-gfs/package.lisp" #~"kernel/clos/static-gfs/flag.lisp" #~"kernel/clos/static-gfs/constructor.lisp" - #~"kernel/clos/static-gfs/reinitializer.lisp" - #~"kernel/clos/static-gfs/changer.lisp" - #~"kernel/clos/hierarchy.lisp" - #~"kernel/clos/cpl.lisp" - #~"kernel/clos/std-slot-value.lisp" - #~"kernel/clos/slot.lisp" - #~"kernel/clos/boot.lisp" - #~"kernel/clos/kernel.lisp" - #~"kernel/clos/outcome.lisp" - #~"kernel/clos/discriminate.lisp" - #~"kernel/clos/dtree.lisp" - #~"kernel/clos/dtree-graphviz.lisp" - #~"kernel/clos/effective-accessor.lisp" - #~"kernel/clos/closfastgf.lisp" - #~"kernel/clos/satiation.lisp" - #~"kernel/clos/method.lisp" - #~"kernel/clos/combin.lisp" - #~"kernel/clos/std-accessors.lisp" - #~"kernel/clos/defclass.lisp" - #~"kernel/clos/slotvalue.lisp" - #~"kernel/clos/standard.lisp" - #~"kernel/clos/builtin.lisp" - #~"kernel/clos/change.lisp" - #~"kernel/clos/stdmethod.lisp" - #~"kernel/clos/generic.lisp" - #~"kernel/clos/fixup.lisp" #~"kernel/clos/static-gfs/cell.lisp" #~"kernel/clos/static-gfs/effective-method.lisp" #~"kernel/clos/static-gfs/svuc.lisp" @@ -113,56 +137,44 @@ #~"kernel/clos/static-gfs/compute-constructor.lisp" #~"kernel/clos/static-gfs/dependents.lisp" #~"kernel/clos/static-gfs/compiler-macros.lisp" - #~"kernel/clos/static-gfs/reinitialize-instance.lisp" - #~"kernel/clos/static-gfs/update-instance-for-different-class.lisp" - #~"kernel/clos/static-gfs/change-class.lisp" - #~"kernel/lsp/source-location.lisp" - #~"kernel/lsp/defvirtual.lisp" - #~"kernel/clos/streams.lisp" - #~"kernel/lsp/pprint.lisp" - #~"kernel/lsp/format-pprint.lisp" - #~"kernel/clos/conditions.lisp" - #~"kernel/clos/print.lisp" - #~"kernel/clos/sequences.lisp" - #~"kernel/cmp/compiler-conditions.lisp" - #~"kernel/lsp/packlib2.lisp" - #~"kernel/clos/inspect.lisp" - #~"kernel/clos/telemetry.lisp" - #~"kernel/lsp/loadltv.lisp" ; need loop - :khazern-extension-intrinsic + ;; file compiler :eclector-concrete-syntax-tree - #~"kernel/cmp/eclector-client.lisp" - #~"kernel/cmp/fixup-eclector-readtables.lisp" - #~"kernel/cmp/activate-clasp-readtables-for-eclector.lisp" - #~"kernel/cmp/define-unicode-tables.lisp" + #~"kernel/cmp/variables.lisp" + #~"kernel/clos/make-load-form.lisp" + #~"kernel/cmp/eclector.lisp" + #~"kernel/cmp/startup-primitives.lisp" #~"kernel/cmp/cmpltv.lisp" - #~"kernel/cmp/disltv.lisp" #~"kernel/cmp/compile-file.lisp" - #~"kernel/cmp/cmpbundle.lisp" - #~"kernel/lsp/bytecode-introspect.lisp" - #~"kernel/lsp/fli.lisp" - #~"kernel/lsp/posix.lisp" - #~"modules/sockets/sockets.lisp" - #~"kernel/lsp/top.lisp" - #~"kernel/stage/base/1-end.lisp" - #~"kernel/stage/base/2-begin.lisp" + ;; native compiler + #~"kernel/cleavir/literal-package.lisp" + #@"runtime-info.lisp" + #~"kernel/cleavir/runtime-info.lisp" + #~"kernel/cleavir/jit-setup.lisp" + #~"kernel/cmp/cmpsetup.lisp" + #~"kernel/cleavir/cmpintrinsics.lisp" + #~"kernel/cleavir/primitives.lisp" + #~"kernel/cleavir/cmpir.lisp" + #~"kernel/cmp/debuginfo.lisp" + #~"kernel/cmp/cmprunall.lisp" + #~"kernel/cleavir/cmpliteral.lisp" + #~"kernel/cmp/typeq.lisp" + #~"kernel/cmp/codegen-special-form.lisp" :clasp-cleavir #~"kernel/cmp/arguments.lisp" - #~"kernel/lsp/queue.lisp" ;; cclasp sources - #~"kernel/lsp/generated-encodings.lisp" - #~"kernel/lsp/process.lisp" - #~"kernel/lsp/encodings.lisp" + #~"kernel/cleavir/compile-file.lisp" + #~"kernel/cleavir/atomics.lisp" + #~"kernel/cleavir/disassemble.lisp" + #~"kernel/lsp/queue.lisp" + #~"kernel/cmp/compile-file-parallel.lisp" + #@"fli-specs.lisp" + #~"kernel/lsp/fli.lisp" #~"kernel/lsp/cltl2.lisp" #~"kernel/lsp/macroexpand-all.lisp" - #~"kernel/lsp/xref.lisp" - #@"base-immutable.lisp" - #~"kernel/stage/base/2-end.lisp" - #~"kernel/cmp/compile-file-parallel.lisp" - #~"kernel/cleavir/auto-compile.lisp" - #~"kernel/lsp/top-hook.lisp")) + #~"kernel/cmp/external-clang.lisp" + #~"kernel/cleavir/auto-compile.lisp")) (defun add-eclasp-sources (target) - (add-cclasp-sources target) + (add-nclasp-sources target) (k:sources target #~"kernel/stage/extension/0-begin.lisp" #@"extension-immutable.lisp" @@ -171,10 +183,11 @@ :extension-systems #~"kernel/stage/extension/0-end.lisp")) -(add-cclasp-sources :cclasp) +(add-nclasp-sources :nclasp) (add-eclasp-sources :eclasp) + (k:sources :extension-translations :extension-systems) @@ -222,5 +235,7 @@ :clasp-analyzer) (k:sources :vm-header + #~"kernel/cmp/cmpref-package.lisp" #~"kernel/cmp/startup-primitives.lisp" + #~"kernel/clos/dtree-ops.lisp" #~"kernel/cmp/bytecode-machines.lisp") diff --git a/src/lisp/kernel/clasp-builder.lisp b/src/lisp/kernel/clasp-builder.lisp deleted file mode 100644 index bb0a6a9238..0000000000 --- a/src/lisp/kernel/clasp-builder.lisp +++ /dev/null @@ -1,437 +0,0 @@ -#+(or) -(eval-when (:compile-toplevel :execute) - (setq *echo-repl-read* t)) -;; -;; Clasp builder code -;; -(eval-when (:compile-toplevel :load-toplevel :execute) - (core:select-package :core)) - -(defvar *number-of-jobs* 1) - -(defun ansi-control (&optional level) - (core:fmt t "%e[{:d}m" - (cond ((eq level :err) 31) - ((eq level :warn) 33) - ((eq level :emph) 32) - ((eq level :debug) 36) - ((eq level :info) 37) - (t 0)))) - -(defun message (level control-string &rest args) - (ansi-control level) - (apply #'core:fmt t control-string args) - (ansi-control) - (terpri) - (when (eq level :err) - (core:exit 1))) - -(defun message-fd (level fd) - (let ((buffer (make-array 1024 :element-type 'base-char :adjustable nil))) - (ansi-control level) - (core:lseek fd 0 :seek-set) - (tagbody - top - (multiple-value-bind (num-read errno) - (core:read-fd fd buffer) - (when (> num-read 0) - (write-sequence buffer t :start 0 :end num-read) - (go top)))) - (core:close-fd fd) - (ansi-control))) - -#+(or) -(progn - (defparameter *log* (open "/tmp/clasp-builder-log.txt" :direction :output :if-exists :supersede)) - (si:fset 'core::mmsg #'(lambda (whole env) - (let ((fmt (cadr whole)) - (args (cddr whole))) - `(progn - (core:fmt *log* ,fmt ,@args) - (finish-output *log*)))) - t)) - -;;;#+(or) -(Si:fset 'core::mmsg #'(lambda (whole env) - nil) - t) - -(eval-when (:compile-toplevel :execute :load-toplevel) - (mmsg "Starting up%N")) - -#+clasp-min -(core:fset 'cmp::with-compiler-timer - (let ((body (gensym))) - #+(or)(core:fmt t "body = {}%N" body) - #'(lambda (whole env) - (let ((body (cddr whole))) - `(progn - ,@body)))) - t) - -(defun load-kernel-file (path &key (type cmp:*default-output-type*) silent) - (let ((filename (make-pathname :type (if (eq type :faso) "faso" "fasl") - :defaults path))) - (unless (eq type :faso) - (message :err "Illegal type {} for load-kernel-file {}" type (namestring path))) - (unless silent - (message nil "Loading {}" (namestring filename))) - (load filename :print nil :verbose nil) - path)) - -(defun compile-kernel-file (entry &rest args - &key reload count (output-type cmp:*default-output-type*) verbose print silent) - (let* ((filename (getf entry :source-path)) - (position (getf entry :position)) - (output-path (getf entry :output-path)) - (cmp::*module-startup-prefix* "kernel") - (compile-file-arguments (list* filename - :source-debug-pathname filename - :output-file output-path - :output-type output-type - :print print - :verbose verbose - :unique-symbol-prefix (format nil "~a~a" (pathname-name filename) position) - :type :kernel ;; (if reload :kernel nil) - :image-startup-position position - (getf entry :compile-file-options)))) - (unless silent - (message nil "Compiling [{} of {}] {}%N to {} - will reload: {}" - (getf entry :index) count filename output-path reload)) - (if verbose - (let ((before-ms (get-internal-run-time)) - (before-bytes (gctools:bytes-allocated))) - (apply #'compile-file compile-file-arguments) - (let ((after-ms (get-internal-run-time)) - (after-bytes (gctools:bytes-allocated))) - (message :info "; Compile time run({:.3f} secs) consed({} bytes)" - (float (/ (- after-ms before-ms) internal-time-units-per-second)) - (- after-bytes before-bytes)))) - (apply #'compile-file compile-file-arguments)) - (when reload - (load-kernel-file (make-pathname :type "fasl" :defaults output-path) :silent silent)) - output-path)) - -(eval-when (:compile-toplevel :execute) - (core:fset 'compile-execute-time-value - #'(lambda (whole env) - (let* ((expression (second whole)) - (result (eval expression))) - `',result)) - t)) - -(defun compile-system-serial (system &key reload (output-type cmp:*default-output-type*) &allow-other-keys - &aux (count (length system))) - (message :emph "Compiling system serially...") - (dolist (entry system) - (compile-kernel-file entry :reload reload :output-type output-type :count count :print t :verbose t))) - -(defun compile-system-parallel (system - &key reload (output-type cmp:*default-output-type*) - (parallel-jobs *number-of-jobs*) - &allow-other-keys) - (message :emph "Compiling system with {:d} parallel jobs..." parallel-jobs) - (let ((count (length system)) - (child-count 0) - (jobs (make-hash-table :test #'eql)) - entry) - (labels ((started-one (entry) - (message nil "Starting {: >3d} of {:d} [pid {:d}] {}" - (getf entry :index) count (getf entry :pid) (namestring (getf entry :source-path))) - (when (ext:getenv "CLASP_PAUSE_FORKED_CHILD") - (message :emph "CLASP_PAUSE_FORKED_CHILD is set - will pause all children until they receive SIGUSR1"))) - (finished-one (entry) - (when entry - (message :emph "Finished {: >3d} of {:d} [pid {:d}] {} output follows..." - (getf entry :index) count (getf entry :pid) (namestring (getf entry :source-path))) - (message-fd :info (getf entry :child-stdout)) - (message-fd :warn (getf entry :child-stderr))))) - (gctools:garbage-collect) - (tagbody - top - (when (or (and system (= child-count parallel-jobs)) - (and (null system) (> child-count 0))) - (multiple-value-bind (wpid status) - (core:wait) - (when (= -1 wpid) - (message :err "No children left to wait on.")) - (unless (or (core:wifsignaled status) - (core:wifexited status)) - (go top)) - (let ((entry (gethash wpid jobs))) - (finished-one entry) - (when (core:wifsignaled status) - (message :err "The child with wpid {} was terminated with signal {}." - wpid (core:wtermsig status))) - (unless (zerop (core:wexitstatus status)) - (message :err "The child with wpid {} exited with status {}." - wpid (core:wexitstatus status))) - (when reload - (load-kernel-file (getf entry :output-path) :silent nil)) - (decf child-count)))) - (when system - (setq entry (car system) - system (cdr system)) - (let ((child-stdout (core:mkstemp-fd "clasp-build-stdout")) - (child-stderr (core:mkstemp-fd "clasp-build-stderr"))) - (multiple-value-bind (maybe-error pid child-stream) - (core:fork-redirect child-stdout child-stderr) - (when maybe-error - (message :err "Could not fork when trying to build {}" entry)) - (cond ((zerop pid) - (when (ext:getenv "CLASP_PAUSE_FORKED_CHILD") - (gctools:wait-for-user-signal (core:fmt nil "Child with pid {} is waiting for SIGUSR1" - (core:getpid)))) - (ext:disable-debugger) - (let ((start-time (get-internal-run-time)) - (start-bytes (gctools:bytes-allocated))) - (compile-kernel-file entry :output-type output-type :silent t :verbose t) - (message :info "; Child time run({:.3f} secs) consed({} bytes)" - (float (/ (- (get-internal-run-time) start-time) - internal-time-units-per-second)) - (- (gctools:bytes-allocated) start-bytes)) - (sys:c_exit))) - (t - (started-one (funcall #'(setf gethash) - (list* :pid pid - :child-stdout child-stdout - :child-stderr child-stderr - :start-time (get-internal-run-time) - entry) - pid jobs)) - (incf child-count)))))) - (when (or system (> child-count 0)) - (go top)))))) - -(defun parallel-build-p () - (and core:*use-parallel-build* (> *number-of-jobs* 1))) - -(defun compile-system (&rest args) - (apply (if (parallel-build-p) - 'compile-system-parallel - 'compile-system-serial) - args)) - -(defun build-failure (condition) - (message :warn "%nBuild aborted.%nReceived condition of type: {}%n{}" - (type-of condition) - condition) - (when (parallel-build-p) - (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." - (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)) - system)) - -(defun link-modules (output-file all-modules) - (format t "link-modules output-file: ~a all-modules: ~a~%" output-file all-modules) - (cond ((eq cmp:*default-output-type* :bytecode) - (core:link-fasl-files output-file all-modules)) - ((eq cmp:*default-output-type* :faso) - (core:link-faso-files output-file all-modules nil)) - ((eq cmp:*default-output-type* :fasoll) - (cmp::link-fasoll-modules output-file all-modules)) - ((eq cmp:*default-output-type* :fasobc) - (cmp::link-fasobc-modules output-file all-modules)) - (t - (error "Unsupported value for cmp:*default-output-type* -> ~a" cmp:*default-output-type*)))) - -(defun link-fasl (&key (output-file (build-common-lisp-bitcode-pathname)) - (system (command-line-paths))) - (cond ((eq cmp:*default-output-type* :bytecode) - (core:link-fasl-files output-file system)) - ((eq cmp:*default-output-type* :faso) - ;; Do nothing - faso files are the result - (core:link-faso-files output-file system nil)) - ((eq cmp:*default-output-type* :fasoll) - (let* ((module (cmp:link-bitcode-modules-together output-file system :output-type :fasoll)) - (fout (open output-file :direction :output :if-exists :supersede))) - (llvm-sys:dump-module module fout))) - ((eq cmp:*default-output-type* :fasobc) - (let* ((module (cmp:link-bitcode-modules-together output-file system :output-type :fasobc))) - (llvm-sys:write-bitcode-to-file module (namestring output-file)))) - (t - (error "Unsupported value for cmp:*default-output-type* -> ~a" cmp:*default-output-type*)))) - -(defun construct-system (files position reproducible - &aux source-path output-path system last item new-last) - (tagbody - next - (when files - (setq source-path (car files) - output-path (bitcode-pathname source-path) - item (list :source-path source-path - :position position - :output-path output-path) - position (+ 1 position) - files (cdr files)) - (when reproducible - (setq item (list* :install-path (car files) item) - files (cdr files))) - (cond (last - (setq new-last (list item)) - (rplacd last new-last) - (setq last new-last)) - (t - (setq last (list item) - system last))) - (go next))) - system) - -(defun pprint-features (added-features removed-features) - (when removed-features - (message :info "Removed features {}" removed-features)) - (when added-features - (message :info "Added features {}" added-features))) - -(defvar +stage-features+ '(:clasp-min :clos :aclasp :bclasp :cclasp :eclasp)) -(defvar +load-weight+ 0.5d0) - -(defun load-stage (system stage name load-verbose) - (let ((start (make-pathname :host "sys" - :directory (list :absolute "src" "lisp" - "kernel" "stage" name) - :name (core:fmt nil "{:d}-begin" stage) - :type "lisp")) - (end (make-pathname :host "sys" - :directory (list :absolute "src" "lisp" - "kernel" "stage" name) - :name (core:fmt nil "{:d}-end" stage) - :type "lisp")) - (stage-keyword (intern (core:fmt nil "STAGE{:d}" stage) :keyword)) - (stage-time (get-internal-run-time)) - file-time entry file prev-file-time bytes) - (setq *features* (cons stage-keyword *features*)) - (message :emph "Loading stage {:d}..." stage) - (setq system (member start system - :test #'(lambda (path entry) - (equal path (getf entry :source-path))))) - (tagbody - next - (when system - (setq entry (car system) - file (getf entry :source-path) - file-time (get-internal-run-time) - bytes (gctools:bytes-allocated)) - (unless load-verbose - (message nil ";;; Loading {}" file)) - (let ((*load-verbose* load-verbose)) - (load file)) - (setq file-time (- (get-internal-run-time) file-time) - prev-file-time (getf entry :load-time)) - (rplaca system - (sys:put-f entry - (if prev-file-time - (+ (* +load-weight+ file-time) - (* (- 1 +load-weight+) prev-file-time)) - file-time) - :load-time)) - (when (and load-verbose (>= file-time internal-time-units-per-second)) - (message nil ";;; Load time({:.1f} seconds) consed({} bytes)" - (float (/ file-time internal-time-units-per-second)) - (- (gctools:bytes-allocated) bytes))) - (unless (equal end file) - (setq system (cdr system)) - (go next)))) - (setq *features* (core:remove-equal stage-keyword *features*)) - (message :emph "Stage {:d} time({:.1f} seconds)" - stage - (float (/ (- (get-internal-run-time) stage-time) internal-time-units-per-second))))) - -(defun stage-features (&rest new-features &aux added-features removed-features) - (dolist (feature +stage-features+) - (when (and (not (member feature new-features)) - (member feature *features*)) - (setq *features* (core:remove-equal feature *features*) - removed-features (cons feature removed-features)))) - (dolist (feature new-features) - (unless (member feature *features*) - (setq *features* (cons feature *features*) - added-features (cons feature added-features)))) - (pprint-features added-features removed-features)) - -(defun stage-count (system name - &aux (last-stage -1) source-path - (stage-directory (list :absolute "SRC" "LISP" "KERNEL" "STAGE" name))) - (dolist (entry system (1+ last-stage)) - (setq source-path (getf entry :source-path)) - (when (equalp (pathname-directory source-path) stage-directory) - (setq last-stage (max last-stage (parse-integer (pathname-name source-path) :junk-allowed t)))))) - -(defun load-clasp (&key (clean (ext:getenv "CLASP_CLEAN")) - (load-verbose (ext:getenv "CLASP_LOAD_VERBOSE")) - (name "base") - (position 0) - reproducible - (system-sort (ext:getenv "CLASP_SYSTEM_SORT")) - (stage-count (when (ext:getenv "CLASP_STAGE_COUNT") - (parse-integer (ext:getenv "CLASP_STAGE_COUNT")))) - (system (command-line-paths))) - (when (eq cmp:*default-output-type* :bytecode) - (setq *features* (list* :bytecode *features*))) - (setq *features* (list* :staging *features*) - system (construct-system system position reproducible)) - (let ((write-date 0) - (max-stage-count (stage-count system name))) - (cond ((null stage-count) - (setq stage-count max-stage-count)) - ((or (< stage-count 0) - (> stage-count max-stage-count)) - (message :err "Stage count of {} is out of bounds. Maximum stage count is {}." - stage-count max-stage-count))) - (dotimes (stage stage-count) - (load-stage system stage name load-verbose)) - (setq *features* (core:remove-equal :staging *features*)) - (when reproducible - (prepare-metadata system)) - (setq system (mapcar #'(lambda (entry &aux (output-path (getf entry :output-path)) - (source-path (getf entry :source-path))) - (setq write-date (max write-date (file-write-date source-path))) - (list* :out-of-date (or clean - (not (probe-file output-path)) - (< (file-write-date output-path) - write-date)) - entry)) - system)) - (if system-sort - (sort system #'> :key #'(lambda (entry) - (getf entry :load-time most-positive-fixnum))) - system))) - -(defun compile-clasp (system &aux (index 0)) - ;; Inline ASTs refer to various classes etc that are not available while earlier files are loaded. - ;; Therefore we can't have the compiler save inline definitions for files earlier than we're able - ;; to load inline definitions. We wait for the source code to turn it back on. - (setq core:*defun-inline-hook* nil - system (mapcan #'(lambda (entry) - (when (getf entry :out-of-date) - (incf index) - (list (list* :index index entry)))) - system)) - #-clasp-min - (handler-bind - ((error #'build-failure)) - (compile-system system)) - #+clasp-min - (compile-system system)) - -(defun load-and-compile-clasp (&rest rest) - (compile-clasp (apply #'load-clasp rest))) - -(export '(command-line-paths - compile-kernel-file - compile-system - compile-system-parallel - compile-system-serial - compile-clasp - link-fasl - load-and-compile-clasp - load-clasp - pprint-features - stage-features)) diff --git a/src/lisp/kernel/cleavir/atomics.lisp b/src/lisp/kernel/cleavir/atomics.lisp new file mode 100644 index 0000000000..4f09e35529 --- /dev/null +++ b/src/lisp/kernel/cleavir/atomics.lisp @@ -0,0 +1,16 @@ +(in-package #:mp) + +(defmethod %get-atomic-expansion ((place symbol) environment keys) + ;; KLUDGE: the cleavir interface may not be great for this. + (let ((info (cleavir-env:variable-info + clasp-cleavir:*clasp-system* environment place))) + (etypecase info + (cleavir-env:symbol-macro-info + (apply #'get-atomic-expansion (macroexpand-1 place environment) keys)) + (cleavir-env:special-variable-info + (apply #'get-atomic-expansion `(symbol-value ',place) keys)) + (cleavir-env:lexical-variable-info + ;; TODO + (error 'not-atomic :place place)) + (null + (error "Unknown variable ~a" place))))) diff --git a/src/lisp/kernel/cleavir/auto-compile.lisp b/src/lisp/kernel/cleavir/auto-compile.lisp index e3f8d41ecb..51a72c57f0 100644 --- a/src/lisp/kernel/cleavir/auto-compile.lisp +++ b/src/lisp/kernel/cleavir/auto-compile.lisp @@ -52,20 +52,7 @@ ;;; We don't queue anything until start-autocompilation is run. ;;; Afterwards we queue even if the worker is not going - more work for later. (defun queue-autocompilation (definition environment) - (when (global-definition-p definition) - (autocompilation-enqueue (cons definition environment))) - definition) - -;;; The BTB compiler currently is only safe for non-closures. FIXME. -;;; I think all we have to do is make sure we replace outer functions -;;; before inner functions, so that outer bytecode functions never have -;;; inner native functions. -(defun global-definition-p (definition) - (let ((name (core:function-name definition))) - (and (or (symbolp name) - (typep name '(cons (eql setf) (cons symbol null)))) - (fboundp name) - (eq definition (fdefinition name))))) + (autocompilation-enqueue (cons definition environment))) (defun autocompile-worker () (macrolet ((log (thing) @@ -83,12 +70,12 @@ (declare (ignore env)) ;; Make sure it hasn't been compiled already. (if (eq (core:entry-point def) def) - (handler-case (clasp-bytecode-to-bir:compile-function def) + (handler-case (clasp-bytecode-to-bir:compile-module + (core:simple-fun-code def)) (serious-condition (e) (log `(:error ,def ,e))) (:no-error (f) - (log `(:success ,def ,f)) - (core:set-simple-fun def f))) + (log `(:success ,def ,f)))) (log `(:redundant ,def)))) else do (log `(:bad-queue ,item))))) @@ -133,3 +120,229 @@ (setf (mp:atomic (symbol-value '*autocompilation-logging*) :order :relaxed) t)) (defun end-autocompilation-logging () (setf (mp:atomic (symbol-value '*autocompilation-logging*) :order :relaxed) nil)) + +;;; map from simple funs to optimized versions, +;;; for reoptimization later +(defvar *deoptimized-funs* (make-hash-table :test #'eq)) +;;; list of functions that have been deoptimized; used for presentation +;;; to the user etc +(defvar *deoptimized* nil) + +(defun deoptimized () *deoptimized*) + +(defun %deoptimize-function (function) + (declare (type core:simple-fun function)) + (let ((opt (core:function/entry-point function))) + (cond ((eq function opt) nil) ; no optimized version + (t (setf (gethash function *deoptimized-funs*) opt) + (core:set-simple-fun function function) + t)))) + +(defun %map-module-functions (f module) + (loop with any = nil + for thing across (core:bytecode-module/debug-info module) + ;; call on all functions - no quitting early so not THEREIS + when (typep thing 'core:bytecode-simple-fun) + do (setf any (or (funcall f thing) any)) + finally (return any))) + +;;; When we deoptimize, we try to deoptimize everything in a +;;; function's module, such as inner functions. That's probably +;;; what the user wants, practically speaking, unlike with TRACE. +(defun %deoptimize (function) + (if (typep function 'core:bytecode-simple-fun) + (%map-module-functions #'%deoptimize-function + (core:simple-fun-code function)) + nil)) + +(defgeneric %map-simple-funs (f function) + (:argument-precedence-order function f)) + +(defmethod %map-simple-funs (f (func core:simple-fun)) + (funcall f func)) +(defmethod %map-simple-funs (f (function core:closure)) + (%map-simple-funs f (core:function/entry-point function))) +(defmethod %map-simple-funs (f (function clos:funcallable-standard-object)) + (%map-simple-funs f (clos:get-funcallable-instance-function function))) +(defmethod %map-simple-funs :after (f (function generic-function)) + (loop for method in (clos:generic-function-methods function) + for mf = (clos:method-function method) + do (%map-simple-funs f mf))) +;;; KLUDGE: placement? +(defmethod %map-simple-funs :after (f (function clos::%leaf-method-function)) + (%map-simple-funs f (clos::fmf function))) +(defmethod %map-simple-funs :after (f (function clos::%contf-method-function)) + (%map-simple-funs f (clos::contf function))) + +(defun maybe-deoptimize (function) + (let ((deoptimized-any nil)) + (flet ((deopt (sf) + (when (%deoptimize sf) (setf deoptimized-any t)))) + (%map-simple-funs #'deopt function)) + (if deoptimized-any + (push function *deoptimized*) + (warn "~a has no optimized versions; skipping" function)))) + +(defmacro ext:deoptimize (&rest functions) + `(progn ,@(loop for fdesig in functions + collect `(maybe-deoptimize #',fdesig)) + (deoptimized))) + +(defun %reoptimize-function (function) + (declare (type core:simple-fun function)) + (let ((opt (gethash function *deoptimized-funs*))) + (cond (opt (remhash function *deoptimized-funs*) + (core:set-simple-fun function opt) + t) + (t nil)))) + +(defun %reoptimize (function) + (if (typep function 'core:bytecode-simple-fun) + (%map-module-functions #'%reoptimize-function + (core:simple-fun-code function)) + nil)) + +(defun %reoptimize-all () + ;; Just reoptimize everything directly + (maphash (lambda (fun opt) (core:set-simple-fun fun opt)) + *deoptimized-funs*) + (clrhash *deoptimized-funs*) + (setf *deoptimized* nil)) + +(defun maybe-reoptimize (function) + (let ((reoptimized-any nil)) + (when (member function *deoptimized*) + (flet ((reopt (sf) + (when (%reoptimize sf) (setf reoptimized-any t)))) + (%map-simple-funs #'reopt function)) + (setf *deoptimized* (delete function *deoptimized*))) + (unless reoptimized-any + (warn "~a was not deoptimized; skipping" function)))) + +(defmacro ext:reoptimize (&rest functions) + (if functions + `(progn ,@(loop for fdesig in functions + collect `(maybe-reoptimize #',fdesig)) + (deoptimized)) + `(%reoptimize-all))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Also in here for reasons: the compile-file thread pool +;;; Native compilation is slow, but thread safe, so when we compile-file +;;; we do it in parallel. See cmp:*compile-file-native* + +(in-package #:cmp) + +;;; note: jobs are intended to be an implementation detail. the user of +;;; the thread pool only gets results; see THREAD-POOL-FINISH +(defclass native-compile-job () + ((%function :initarg :function :reader ncjob-function) + (%arguments :initarg :arguments :reader ncjob-arguments) + (%result :initform nil :accessor ncjob-result) + (%serious-condition :initform nil :accessor ncjob-serious-condition) + (%warnings :initform nil :accessor ncjob-warnings) + (%notes :initform nil :accessor ncjob-notes) + (%other-conditions :initform nil :accessor ncjob-other-conditions) + ;; arbitrary data passed to thread-pool-enqueue + ;; and returned by thread-pool-finish + (%extra :initarg :extra :reader ncjob-extra))) + +(defun native-compile-worker (queue) + (lambda () + (declare (core:lambda-name native-compile-worker)) + (loop for job = (core:dequeue queue) + until (eq job :quit) + do (block nil + (setf (ncjob-result job) + (handler-bind + ((serious-condition + (lambda (e) + (setf (ncjob-serious-condition job) e) + ;; can't continue, so go wait for more jobs + (return))) + (warning + (lambda (w) + (push w (ncjob-warnings job)) + (muffle-warning w))) + (ext:compiler-note + (lambda (n) + (push n (ncjob-notes job)) + (cmp::muffle-note n))) + ((not (or ext:compiler-note warning serious-condition)) + (lambda (c) + (push c (ncjob-other-conditions job))))) + (apply (ncjob-function job) + (ncjob-arguments job)))))))) + +(defgeneric report-job-conditions (job)) +(defmethod report-job-conditions ((job native-compile-job)) + (mapc #'signal (ncjob-other-conditions job)) + ;; The WARN calls here never actually print warnings - the + ;; with-compilation-results handlers do, and then muffle the warnings + ;; (which is why we use WARN and not SIGNAL). Kind of ugly. + (mapc #'warn (ncjob-warnings job)) + (mapc #'cmp:note (ncjob-notes job)) + (when (ncjob-serious-condition job) + ;; We use SIGNAL rather than ERROR although the condition is serious. + ;; This is because the job has already exited and therefore there + ;; is no way to debug the problem. with-compilation-results will + ;; still understand that it's an error and report compilation failure. + ;; It's possible we could save the original backtrace and so on, but + ;; if you want to debug problems, it would probably be easier to + ;; use the serial compiler and debug them as they appear. + (signal (ncjob-serious-condition job)))) + +(defclass nc-thread-pool () + ((%threads :initarg :threads :reader nc-threads) + (%queue :initarg :queue :reader nc-queue) + (%jobs :initform nil :accessor nc-jobs))) + +(defun make-nc-thread-pool (&key (name 'native-compile-thread-pool) + (nthreads (core:num-logical-processors)) + special-bindings) + (loop with queue = (core:make-queue name) + with conc-name = (format nil "~(~a~)-" (symbol-name name)) + for thread-num below nthreads + collect (mp:process-run-function + (format nil "~a-~d" conc-name thread-num) + (native-compile-worker queue) + special-bindings) + into threads + finally (return (make-instance 'nc-thread-pool + :queue queue :threads threads)))) + +(defun thread-pool-enqueue (pool function arguments &optional extra) + (let ((job (make-instance 'native-compile-job + :function function :arguments arguments :extra extra))) + (push job (nc-jobs pool)) + (core:atomic-enqueue (nc-queue pool) job))) + +(defun enqueue-native-compilation (pool module bytecode literals debug-info id + debug-namestring) + (thread-pool-enqueue pool #'clasp-bytecode-to-bir:compile-cmodule + (list bytecode literals debug-info id + debug-namestring) + module)) + +(defun thread-pool-quit (pool) + (loop with queue = (nc-queue pool) + for thread in (nc-threads pool) + ;; only one is needed, but we do two out of an abundance of caution + ;; and because it's harmless + do (core:atomic-enqueue queue :quit) + (core:atomic-enqueue queue :quit))) + +(defun thread-pool-join (pool) + (mapc #'mp:process-join (nc-threads pool))) + +(defun thread-pool-finish (pool) + (thread-pool-quit pool) + (thread-pool-join pool) + ;; ok, now everything is done: signal conditions and return results + (loop for job in (nreverse (nc-jobs pool)) + do (report-job-conditions job) + ;; note that these are returned in the order they were enqueued. + ;; module IDs need to be sequential for the FASL loader, so this + ;; is important. + collect (list (ncjob-extra job) (ncjob-result job)))) diff --git a/src/lisp/kernel/cleavir/clasp-cleavir.asd b/src/lisp/kernel/cleavir/clasp-cleavir.asd index a4853df9ca..f0ca460590 100644 --- a/src/lisp/kernel/cleavir/clasp-cleavir.asd +++ b/src/lisp/kernel/cleavir/clasp-cleavir.asd @@ -40,9 +40,9 @@ (:file "interval") (:file "type") (:file "transform") + (:file "literal") (:file "translate") (:file "compile-bytecode") - ;;(:file "translate-btb") ; not working yet (:file "inline-prep") (:file "proclamations") (:file "hooks") diff --git a/src/lisp/kernel/cmp/cmpintrinsics.lisp b/src/lisp/kernel/cleavir/cmpintrinsics.lisp similarity index 72% rename from src/lisp/kernel/cmp/cmpintrinsics.lisp rename to src/lisp/kernel/cleavir/cmpintrinsics.lisp index e9702218cd..12d8497fa8 100644 --- a/src/lisp/kernel/cmp/cmpintrinsics.lisp +++ b/src/lisp/kernel/cleavir/cmpintrinsics.lisp @@ -2,11 +2,6 @@ ;;; File: cmpintrinsics.lisp ;;; -;; Should be commented out -#+(or) -(eval-when (:execute) - (setq core:*echo-repl-read* t)) - ;; Copyright (c) 2014, Christian E. Schafmeister ;; ;; CLASP is free software; you can redistribute it and/or @@ -54,18 +49,7 @@ Set this to other IRBuilders to make code go where you want") ;; - ssize_t ;; - time_t - -(defun llvm-print (msg) - (irc-intrinsic "debugMessage" (irc-bit-cast (module-make-global-string msg) %i8*%))) -(defun llvm-print-pointer (msg ptr) - (llvm-print msg) - (irc-intrinsic "debugPointer" (irc-bit-cast ptr %i8*%))) -(defun llvm-print-size_t (msg st) - (llvm-print msg) - (irc-intrinsic "debugPrint_size_t" (irc-bit-cast st %i64%))) - - -(defstruct (c++-struct :named (:type vector)) +(defstruct c++-struct name ; The symbol-macro name of the type tag ; The tag of the objects of this type type-getter ; A single argument lambda that when passed an (thread-local-llvm-context) returns the type @@ -77,27 +61,21 @@ Set this to other IRBuilders to make code go where you want") (defmacro define-c++-struct (name tag fields) "Defines the llvm struct and the dynamic variable OFFSETS.name that contains an alist of field names to offsets." - (let ((layout (gensym)) - (gs-field (gensym)) - (field-index (gensym))) + (let ((layout (gensym))) (let ((define-symbol-macro `(define-symbol-macro ,name (llvm-sys:struct-type-get (thread-local-llvm-context) (list ,@(mapcar #'first fields)) nil)))) - (let ((field-offsets `(let ((,layout (llvm-sys:data-layout-get-struct-layout (system-data-layout) ,name)) - (,field-index 0)) - (mapcar (lambda (,gs-field) - (prog1 - (cons (second ,gs-field) (- (llvm-sys:struct-layout-get-element-offset ,layout ,field-index) ,tag)) - (incf ,field-index))) - ',fields))) - (field-indices `(let ((,field-index 0)) ; - (mapcar (lambda (,gs-field) ; - (prog1 ; - (cons (second ,gs-field) ,field-index) ; - (incf ,field-index))) ; - ',fields))) + (let ((field-offsets `(let ((,layout (llvm-sys:data-layout-get-struct-layout (system-data-layout) ,name))) + (list + ,@(loop for (_ name) in fields + for field-index from 0 + collect `(cons ',name (- (llvm-sys:struct-layout-get-element-offset ,layout ,field-index) ,tag)))))) + (field-indices `(list + ,@(loop for (_ name) in fields + for field-index from 0 + collect `(cons ',name ,field-index)))) (field-type-getters-list (mapcar (lambda (type-name) ; #+(or)(format t "type-name -> ~s cadr -> ~s ,car -> ~s~%" type-name (cadr type-name) (car type-name)) ; `(cons ',(cadr type-name) (lambda () (llvm-sys:type-get-pointer-to ,(macroexpand (car type-name)))))) @@ -116,7 +94,7 @@ names to offsets." ) (let ((final `(progn ,define-symbol-macro - (defparameter ,(intern (core:fmt nil "INFO.{}" (string name))) + (defparameter ,(intern (format nil "INFO.~a" name)) (make-c++-struct :name ,name :tag ,tag :type-getter (lambda () (progn ,name)) @@ -143,13 +121,6 @@ names to offsets." (defun c++-struct*-type (struct-info) (llvm-sys:type-get-pointer-to (funcall (c++-struct-type-getter struct-info)))) - -(defun c++-field-ptr (struct-info tagged-object field-name &optional (label "")) - (let* ((tagged-object-i8* (irc-bit-cast tagged-object %i8*%)) - (field* (irc-typed-gep %i8% tagged-object-i8* (list (jit-constant-i64 (c++-field-offset field-name struct-info))))) - (field-type-getter (cdr (assoc field-name (c++-struct-field-type-getters struct-info)))) - (field-ptr (irc-bit-cast field* (funcall field-type-getter) label))) - field-ptr)) (defun c++-field-pointee-type (struct-info field-name) (let ((field-pointee-type-getter (cdr (assoc field-name (c++-struct-field-pointee-type-getters struct-info))))) @@ -227,7 +198,7 @@ names to offsets." ;;; "A run-all void ()* function prototype") (define-symbol-macro %fn-shut-down% (llvm-sys:function-type-get %void% nil)) -(define-symbol-macro %fn-start-up% (llvm-sys:function-type-get %t*% (list %t*%))) +(define-symbol-macro %fn-start-up% (llvm-sys:function-type-get %void% (list %t*%))) (defvar +fn-start-up-argument-names+ nil) ;;; "A pointer to the run-all function prototype") (define-symbol-macro %fn-start-up*% (llvm-sys:type-get-pointer-to %fn-start-up%)) @@ -250,6 +221,22 @@ names to offsets." ((= 4 +uintptr_t-size+) (jit-constant-i32 x)) (t (error "Add support for size uintptr_t = ~a" +uintptr_t-size+)))) +(defun llvm-print (msg) + (irc-intrinsic "debugMessage" (irc-bit-cast (module-make-global-string msg) %i8*%))) +(defun llvm-print-pointer (msg ptr) + (llvm-print msg) + (irc-intrinsic "debugPointer" (irc-bit-cast ptr %i8*%))) +(defun llvm-print-size_t (msg st) + (llvm-print msg) + (irc-intrinsic "debugPrint_size_t" (irc-bit-cast st %i64%))) + +(defun c++-field-ptr (struct-info tagged-object field-name &optional (label "")) + (let* ((tagged-object-i8* (irc-bit-cast tagged-object %i8*%)) + (field* (irc-typed-gep %i8% tagged-object-i8* (list (jit-constant-i64 (c++-field-offset field-name struct-info))))) + (field-type-getter (cdr (assoc field-name (c++-struct-field-type-getters struct-info)))) + (field-ptr (irc-bit-cast field* (funcall field-type-getter) label))) + field-ptr)) + ;;; DO NOT CHANGE THE FOLLOWING STRUCT!!! IT MUST MATCH vaslist (defun build-list-of-pointers (size type) @@ -323,8 +310,7 @@ Boehm and MPS use a single pointer" (define-symbol-macro %entry-point-vector*% (llvm-sys:type-get-pointer-to %entry-point-vector%)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (verify-global-entry-point (c++-struct-field-offsets info.%global-entry-point%))) +(core:verify-global-entry-point (c++-struct-field-offsets info.%global-entry-point%)) ;;; MUST match WrappedPointer_O layout @@ -335,7 +321,7 @@ Boehm and MPS use a single pointer" (%t*% :class) )) -(defconstant +wrapped-pointer.stamp-index+ (c++-field-index :stamp info.%wrapped-pointer%)) +(defparameter +wrapped-pointer.stamp-index+ (c++-field-index :stamp info.%wrapped-pointer%)) (define-symbol-macro %wrapped-pointer*% (llvm-sys:type-get-pointer-to %wrapped-pointer%)) (define-c++-struct %instance% +general-tag+ @@ -345,7 +331,7 @@ Boehm and MPS use a single pointer" )) -(defconstant +instance.rack-index+ (c++-field-index :rack info.%instance%)) +(defparameter +instance.rack-index+ (c++-field-index :rack info.%instance%)) (define-symbol-macro %instance*% (llvm-sys:type-get-pointer-to %instance%)) ;;; Must match SimpleVector_O aka GCArray_moveable @@ -354,8 +340,8 @@ Boehm and MPS use a single pointer" (%size_t% :length) (%tsp[0]% :data) )) -(defconstant +simple-vector.length-index+ (c++-field-index :length info.%simple-vector%)) -(defconstant +simple-vector.data-index+ (c++-field-index :data info.%simple-vector%)) +(defparameter +simple-vector.length-index+ (c++-field-index :length info.%simple-vector%)) +(defparameter +simple-vector.data-index+ (c++-field-index :data info.%simple-vector%)) (define-c++-struct %rack% +general-tag+ @@ -368,9 +354,9 @@ Boehm and MPS use a single pointer" (define-symbol-macro %rack*% (llvm-sys:type-get-pointer-to %rack%)) -(defconstant +rack.stamp-index+ (c++-field-index :stamp info.%rack%)) -(defconstant +rack.length-index+ (c++-field-index :length info.%rack%)) -(defconstant +rack.data-index+ (c++-field-index :data info.%rack%)) +(defparameter +rack.stamp-index+ (c++-field-index :stamp info.%rack%)) +(defparameter +rack.length-index+ (c++-field-index :length info.%rack%)) +(defparameter +rack.data-index+ (c++-field-index :data info.%rack%)) (define-c++-struct %mdarray% +general-tag+ ((%i8*% :vtable) @@ -391,9 +377,9 @@ Boehm and MPS use a single pointer" (%tsp[0]% :data)) ) (define-symbol-macro %value-frame*% (llvm-sys:type-get-pointer-to %value-frame%)) -(defconstant +value-frame.parent-index+ (c++-field-index :parent info.%value-frame%)) -(defconstant +value-frame.length-index+ (c++-field-index :length info.%value-frame%)) -(defconstant +value-frame.data-index+ (c++-field-index :data info.%value-frame%)) +(defparameter +value-frame.parent-index+ (c++-field-index :parent info.%value-frame%)) +(defparameter +value-frame.length-index+ (c++-field-index :length info.%value-frame%)) +(defparameter +value-frame.data-index+ (c++-field-index :data info.%value-frame%)) ;;; MUST match FuncallableInstance_O layout @@ -406,7 +392,7 @@ Boehm and MPS use a single pointer" (%atomic% :compiled-dispatch-function))) (define-symbol-macro %funcallable-instance*% (llvm-sys:type-get-pointer-to %funcallable-instance%)) -(defconstant +funcallable-instance.rack-index+ (c++-field-index :rack info.%funcallable-instance%)) +(defparameter +funcallable-instance.rack-index+ (c++-field-index :rack info.%funcallable-instance%)) (define-symbol-macro %funcallable-instance*% (llvm-sys:type-get-pointer-to %funcallable-instance%)) ;;; Ditto for FunctionCell_O @@ -428,8 +414,8 @@ Boehm and MPS use a single pointer" (%i32% :flags) ; index=6 offset=48 (%t*% :property-list))) ; index=7 offset=56 -(defconstant +symbol.function-index+ (c++-field-index :function info.%symbol%)) -(defconstant +symbol.setf-function-index+ (c++-field-index :setf-function info.%symbol%)) +(defparameter +symbol.function-index+ (c++-field-index :function info.%symbol%)) +(defparameter +symbol.setf-function-index+ (c++-field-index :setf-function info.%symbol%)) (define-symbol-macro %symbol*% (llvm-sys:type-get-pointer-to %symbol%)) (define-symbol-macro %symsp% (llvm-sys:struct-type-get (thread-local-llvm-context) (smart-pointer-fields %symbol*%) nil)) ;; "Sym_sp" @@ -441,43 +427,14 @@ Boehm and MPS use a single pointer" (define-symbol-macro %cons*% (llvm-sys:type-get-pointer-to %cons%)) -(defconstant +cons.car-index+ (c++-field-index :car info.%cons%)) -(defconstant +cons.cdr-index+ (c++-field-index :cdr info.%cons%)) +(defparameter +cons.car-index+ (c++-field-index :car info.%cons%)) +(defparameter +cons.cdr-index+ (c++-field-index :cdr info.%cons%)) (let* ((cons-size (llvm-sys:data-layout-get-type-alloc-size (system-data-layout) %cons%)) (cons-layout (llvm-sys:data-layout-get-struct-layout (system-data-layout) %cons%)) (cons-car-offset (llvm-sys:struct-layout-get-element-offset cons-layout +cons.car-index+)) (cons-cdr-offset (llvm-sys:struct-layout-get-element-offset cons-layout +cons.cdr-index+))) (core:verify-cons-layout cons-size cons-car-offset cons-cdr-offset)) - -;; This structure must match the gctools::GCRootsInModule structure -(define-c++-struct %gcroots-in-module% +general-tag+ - ((%size_t% :index-offset) - (%i8*% :module-memory) - (%size_t% :num-entries) - (%size_t% :capacity) - (%i8**% :function-pointers) - (%size_t% :number-of-functions))) - -(defun gcroots-in-module-initial-value (&optional literals size) - (declare (ignore literals)) - (llvm-sys:constant-struct-get %gcroots-in-module% - (list - (jit-constant-size_t 0) - #+(or)(if literals - (irc-bit-cast literals %i8*%) - (llvm-sys:constant-pointer-null-get %i8*%)) - (llvm-sys:constant-pointer-null-get %i8*%) - (if size - (jit-constant-size_t size) - (jit-constant-size_t 0)) - (jit-constant-size_t 0) - (llvm-sys:constant-pointer-null-get %i8**%) - (jit-constant-size_t 0) - ))) - -(define-symbol-macro %gcroots-in-module*% (llvm-sys:type-get-pointer-to %gcroots-in-module%)) - ;; The definition of %tmv% doesn't quite match T_mv because T_mv inherits from T_sp (define-symbol-macro %tmv% (llvm-sys:struct-type-get (thread-local-llvm-context) (smart-pointer-fields %t*% %size_t%) nil)) ;; "T_mv" (define-symbol-macro %return-type% %tmv%) @@ -620,7 +577,7 @@ Boehm and MPS use a single pointer" ;; 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) +(defstruct calling-convention closure nargs register-args ; The arguments that were passed in registers @@ -761,8 +718,7 @@ Boehm and MPS use a single pointer" (%size_t% data-length) (%tsp[0]% data0)) ) -(eval-when (:compile-toplevel :load-toplevel :execute) - (verify-closure (c++-struct-field-offsets info.%closure%))) +(core:verify-closure (c++-struct-field-offsets info.%closure%)) (defun %closure%.offset-of[n]/t* (index) "This assumes that the t* offset coincides with the tsp start" @@ -781,159 +737,6 @@ Boehm and MPS use a single pointer" "file-scope-handle")) |# -(defun add-llvm.used (module used-function) - (or used-function (error "used-function must not be NIL")) - (llvm-sys:make-global-variable - module - %i8*[1]% - nil - 'llvm-sys:appending-linkage - (llvm-sys:constant-array-get - %i8*[1]% - (list - (irc-bit-cast used-function %i8*%))) - "llvm.used")) - - -(defun add-global-ctor-function (module main-function &key position register-library) - (declare (ignore register-library)) - "Create a function with the name core:+clasp-ctor-function-name+ and -have it call the main-function" - #+(or)(unless (eql module (llvm-sys:get-parent main-function)) - (error "The parent of the func-ptr ~a (a module) does not match the module ~a" (llvm-sys:get-parent main-function) module)) -;;; (core::fmt t "add-global-ctor-function position: {}%N" position) - (multiple-value-bind (startup-function-name startup-function-linkage) - (core:startup-linkage-shutdown-names position) - (let* ((*the-module* module) - (ctor-fn (irc-simple-function-create - startup-function-name - %fn-ctor% - startup-function-linkage - *the-module* - :argument-names +fn-ctor-argument-names+))) - (let* ((irbuilder-body (llvm-sys:make-irbuilder (thread-local-llvm-context))) - (*current-function* ctor-fn) - (entry-bb (irc-basic-block-create "entry" ctor-fn))) - (irc-set-insert-point-basic-block entry-bb irbuilder-body) - (with-landing-pad nil - (with-irbuilder (irbuilder-body) - (let ((bc-main-function - (irc-bit-cast main-function %fn-start-up*% "fnptr-pointer"))) - (irc-intrinsic "cc_register_startup_function" - (jit-constant-size_t position) bc-main-function) - (irc-ret-void)))) - ;;(llvm-sys:dump fn) - #+(or)(let* ((function-name "_claspObjectFileStartUp") ; (core:fmt nil "ObjectFileStartUp-{}" (core:next-number))) - #+(or)(_ (core:fmt t "add-global-ctor-function name: {}%N" function-name)) - (outer-fn (irc-simple-function-create - function-name - %fn-ctor% - 'llvm-sys:internal-linkage - *the-module* - :argument-names +fn-ctor-argument-names+)) - (irbuilder-body (llvm-sys:make-irbuilder (thread-local-llvm-context))) - (*current-function* outer-fn) - (entry-bb (irc-basic-block-create "entry" outer-fn))) - (irc-set-insert-point-basic-block entry-bb irbuilder-body) - (with-landing-pad nil - (with-irbuilder (irbuilder-body) - (let* ((bc-main-function (irc-bit-cast main-function %fn-start-up*% "fnptr-pointer")) - (_ (irc-create-call-wft %fn-ctor% ctor-fn nil)) - (_ (irc-ret-void)))))) - (add-llvm.used *the-module* outer-fn)) - (add-llvm.used *the-module* ctor-fn) ;; Try this instead of the thing above - ) - ctor-fn))) - -(defun add-main-function (module run-all-function) - "Create an external function with the name main have it call the run-all-function" - (let* ((*the-module* module) - (fn (irc-simple-function-create - "MAIN" - %fn-start-up% - cmp:*default-linkage* - *the-module* - :argument-names +fn-start-up-argument-names+))) - (let* ((irbuilder-body (llvm-sys:make-irbuilder (thread-local-llvm-context))) - (*current-function* fn) - (entry-bb (irc-basic-block-create "entry" fn))) - (irc-set-insert-point-basic-block entry-bb irbuilder-body) - (with-irbuilder (irbuilder-body) - (let ((bc-bf - (irc-bit-cast run-all-function %fn-start-up*% "run-all-pointer"))) - (irc-intrinsic "cc_invoke_sub_run_all_function" bc-bf) - (irc-ret-null-t*)) - ;;(llvm-sys:dump fn) - fn)))) - - (defun find-global-ctor-function (module) - (let ((ctor (llvm-sys:get-function module core:+clasp-ctor-function-name+))) - (or ctor (error "Couldn't find the ctor-function: ~a" core:+clasp-ctor-function-name+)) - ctor)) - - (defun remove-llvm.global_ctors-if-exists (module) - (let ((global (llvm-sys:get-named-global module "llvm.global_ctors"))) - (if global - (llvm-sys:erase-from-parent global)))) - - (defun remove-llvm.used-if-exists (module) - (let ((global (llvm-sys:get-named-global module "llvm.used"))) - (if global - (llvm-sys:erase-from-parent global)))) - -(defun add-llvm.global_ctors (module priority global-ctor-function) - (or global-ctor-function (error "global-ctor-function must not be NIL")) - (llvm-sys:make-global-variable - module - %global-ctors-struct[1]% - nil - 'llvm-sys:appending-linkage - (llvm-sys:constant-array-get - %global-ctors-struct[1]% - (list - (llvm-sys:constant-struct-get %global-ctors-struct% - (list - (jit-constant-i32 priority) - global-ctor-function - (llvm-sys:constant-pointer-null-get %i8*%))))) - "llvm.global_ctors")) - -(defun make-boot-function-global-variable (module func-designator &key position register-library) - "* Arguments -- module :: An llvm module -- func-designator :: An llvm function designator -* Description -Add the global variable llvm.global_ctors to the Module (linkage appending) -and initialize it with an array consisting of one function pointer." - (let ((startup-fn (cond - ;; repl functions use an integer ID and we generate the startup-name and - ;; then lookup the function - ((fixnump func-designator) - (multiple-value-bind (startup-name shutdown-name) - (jit-startup-shutdown-function-names func-designator) - (declare (ignore shutdown-name)) - (llvm-sys:get-function module startup-name))) - ((stringp func-designator) - (llvm-sys:get-function module func-designator)) - ((typep func-designator 'llvm-sys:function) - func-designator) - (t (error "~a must be a function name or llvm-sys:function" func-designator))))) - (unless startup-fn - (error "Could not find ~a in module" func-designator)) - #+(or)(unless (eql module (llvm-sys:get-parent func-ptr)) - (error "The parent of the func-ptr ~a (a module) does not match the module ~a" (llvm-sys:get-parent func-ptr) module)) - (let* ((global-ctor (add-global-ctor-function module startup-fn - :position position - :register-library register-library))) - (incf *compilation-module-index*) - (multiple-value-bind (startup-name linkage) - (core:startup-linkage-shutdown-names 0) ; we only want to know linkage - (declare (ignore startup-name)) - (when (eq linkage 'llvm-sys:internal-linkage) - ;; Internal linkage means we can't look up a symbol to get the startup so we need to depend on - ;; static constructors to initialize things. - (add-llvm.global_ctors module *compilation-module-index* global-ctor)))))) - ;; ;; Ensure that the LLVM model of ;; tsp matches shared_ptr and @@ -952,7 +755,6 @@ and initialize it with an array consisting of one function pointer." (global-entry-point-layout (llvm-sys:data-layout-get-struct-layout data-layout %global-entry-point%)) (function-description-offset (c++-field-offset :function-description info.%global-entry-point%)) (vaslist-size (llvm-sys:data-layout-get-type-alloc-size data-layout %vaslist%)) - (gcroots-in-module-size (llvm-sys:data-layout-get-type-alloc-size data-layout %gcroots-in-module%)) (global-entry-point-size (llvm-sys:data-layout-get-type-alloc-size data-layout %global-entry-point%)) (function-description-size (llvm-sys:data-layout-get-type-alloc-size data-layout %function-description%))) (declare (ignore global-entry-point-layout global-entry-point-size)) @@ -963,7 +765,6 @@ and initialize it with an array consisting of one function pointer." :symbol-setf-function-offset symbol-setf-function-offset :function function-size :function-description-offset (+ function-description-offset +general-tag+) - :gcroots-in-module gcroots-in-module-size :vaslist vaslist-size :function-description function-description-size) @@ -1015,7 +816,7 @@ and initialize it with an array consisting of one function pointer." "Map exception names to exception class extern 'C' names") (mapcar #'(lambda (x &aux (name (car x)) (cname (cadr x))) - (funcall #'(setf gethash) cname name *exception-types-hash-table*)) + (setf (gethash name *exception-types-hash-table*) cname)) *exceptions*) (defun exception-typeid*-from-name (name) @@ -1027,88 +828,6 @@ and initialize it with an array consisting of one function pointer." (unless (llvm-sys:llvm-value-p result) (error "result must be an instance of llvm-sys:Value_O but instead it has the value ~s" result))) -(defun codegen-startup (module startup-function-name - THE-REPL-XEP-GROUP gcroots-in-module - array-type roots-array-or-nil number-of-roots - ordered-literals) - (declare (ignore ordered-literals)) - (let ((startup-fn (irc-simple-function-create startup-function-name - %fn-start-up% - 'llvm-sys:external-linkage ; this should be internal and invoked by a ctor but that doesn't seem to be happening yet - module - :argument-names (list "values" )))) - (llvm-sys:set-unnamed-addr startup-fn 'llvm-sys:none) - (let* ((irbuilder-alloca - (llvm-sys:make-irbuilder (thread-local-llvm-context))) - (irbuilder-body - (llvm-sys:make-irbuilder (thread-local-llvm-context))) - (*irbuilder-function-alloca* irbuilder-alloca) - (*irbuilder-function-body* irbuilder-body) - (*current-function* startup-fn) - (entry-bb (irc-basic-block-create "entry" startup-fn)) - (arguments (llvm-sys:get-argument-list startup-fn)) - (arg-values (first arguments))) - (cmp:irc-set-insert-point-basic-block entry-bb irbuilder-alloca) - (with-irbuilder (irbuilder-alloca) - (let ((start (if roots-array-or-nil - (irc-typed-gep array-type roots-array-or-nil (list 0 0)) - (llvm-sys:constant-pointer-null-get %t**%)))) - (multiple-value-bind (function-vector-length function-vector function-vector-type) - (literal:setup-literal-machine-function-vectors cmp:*the-module*) - (when gcroots-in-module - (irc-intrinsic "cc_initialize_gcroots_in_module" - gcroots-in-module ; holder - start ; root_address - (jit-constant-size_t number-of-roots) ; num_roots - arg-values ; initial_data - (llvm-sys:constant-pointer-null-get %i8**%) ; transient_alloca - (jit-constant-size_t 0) ; transient_entries - (jit-constant-size_t function-vector-length) ; function_pointer_count - (irc-bit-cast - (cmp:irc-typed-gep function-vector-type - function-vector - (list 0 0)) - %i8**%) ; fptrs - )))) - (when gcroots-in-module - (irc-intrinsic "cc_finish_gcroots_in_module" gcroots-in-module)) - (let ((global-entry-point (literal:constants-table-value (cmp:entry-point-reference-index (xep-group-entry-point-reference THE-REPL-XEP-GROUP))))) - (irc-ret (irc-bit-cast global-entry-point %t*%)))) - (values)))) - -(defun codegen-shutdown (module shutdown-function-name gcroots-in-module) - (let* ((shutdown-fn (irc-simple-function-create shutdown-function-name - %fn-shut-down% - 'llvm-sys::internal-linkage - module - :argument-names nil)) - (irbuilder-alloca - (llvm-sys:make-irbuilder (thread-local-llvm-context))) - (irbuilder-body (llvm-sys:make-irbuilder (thread-local-llvm-context))) - (*irbuilder-function-alloca* irbuilder-alloca) - (*irbuilder-function-body* irbuilder-body) - (*current-function* shutdown-fn) - (entry-bb (irc-basic-block-create "entry" shutdown-fn))) - (irc-set-insert-point-basic-block entry-bb irbuilder-alloca) - (with-irbuilder (irbuilder-alloca) - (if gcroots-in-module - (irc-intrinsic "cc_remove_gcroots_in_module" - gcroots-in-module)) - (irc-ret-void))) - (values)) - -(defun codegen-startup-shutdown (module startup-shutdown-id THE-REPL-XEP-GROUP &optional gcroots-in-module array-type roots-array-or-nil (number-of-roots 0) ordered-literals) - (multiple-value-bind (startup-function-name shutdown-function-name) - (jit-startup-shutdown-function-names startup-shutdown-id) - (codegen-startup module startup-function-name - THE-REPL-XEP-GROUP gcroots-in-module - array-type roots-array-or-nil number-of-roots - ordered-literals) - (codegen-shutdown module shutdown-function-name gcroots-in-module) - (make-boot-function-global-variable - module startup-shutdown-id :position startup-shutdown-id) - (values))) - ;;; Define what ltvc_xxx functions return (define-symbol-macro %ltvc-return% %void%) @@ -1213,10 +932,10 @@ they are dumped into /tmp" is dumped to a file before the block and after the block." `(progn (llvm-sys:sanity-check-module *the-module* 2) - (quick-module-dump *the-module* ,(core:fmt nil "{}-begin" info)) + (quick-module-dump *the-module* ,(format nil "~a-begin" info)) (multiple-value-prog1 (progn ,@body) (llvm-sys:sanity-check-module *the-module* 2) - (quick-module-dump *the-module* ,(core:fmt nil "{}-end" info))))) + (quick-module-dump *the-module* ,(format nil "~a-end" info))))) (defun module-report (module) diff --git a/src/lisp/kernel/cmp/cmpir.lisp b/src/lisp/kernel/cleavir/cmpir.lisp similarity index 87% rename from src/lisp/kernel/cmp/cmpir.lisp rename to src/lisp/kernel/cleavir/cmpir.lisp index 18871ab83d..eef5c72ec2 100644 --- a/src/lisp/kernel/cmp/cmpir.lisp +++ b/src/lisp/kernel/cleavir/cmpir.lisp @@ -32,24 +32,7 @@ (in-package :compiler) - -(defstruct (xep-arity (:type vector) :named) - "This describes one arity/entry-point for a 'xep-group'. -arity: - the arity of the function (:general-entry|0|1|2|3...|5) -function-or-placeholder - the llvm function or a placeholder for - the literal compiler to generate a pointer - to a fixed arity trampoline. " - arity ; arity of this entry point (:general-entry or an integer 0...n) - function-or-placeholder ; The function object for this entry point - ) - -(defun arity-code (arity) - (cond - ((eq arity :general-entry) - 0) - (t (1+ arity)))) - -(defstruct (cleavir-lambda-list-analysis (:type vector) :named) +(defstruct cleavir-lambda-list-analysis "An analysis of the cleavir lambda list. It breaks down the cleavir lambda-list into parts with a layout that comes from ECL's 'parse_lambda_list' function. That layout looks like: @@ -120,11 +103,6 @@ Maybe in the future we will want to actually put a test here." lambda-list ;; (error "ensure-cleavir-lambda-list doesn't know what to do with ~s" lambda-list)) ) -(defun ensure-cleavir-lambda-list-analysis (arg) - (unless (cleavir-lambda-list-analysis-p arg) - (error "This ~a is not a cleavir-lambda-list-analysis - it must be" arg)) - arg) - (defun process-bir-lambda-list (lambda-list) "Temporary until bir:lambda-list can return a cleavir-lambda-list-analysis" (let* ((cleavir-lambda-list (ensure-cleavir-lambda-list lambda-list)) @@ -143,33 +121,20 @@ If nil then insert a general_entry_point_redirect_x function which just calls th (< (+ nreq nopt) arity)))) nil))) -(defstruct (xep-group (:type vector) :named) +(defstruct xep-group "xep-group describes a group of xep functions. name - the common, unadorned name of the xep function cleavir-lambda-list-analysis - the cleavir-lambda-list-analysis that applies to the entire xep-group arities - a list of xep-arity -entry-point-reference - an index into the literal vector that stores the GeneralSimpleFun_O for this xep-group. +generator - a SimpleCoreFunGenerator for this xep group. local-function - the lcl function that all of the xep functions call." name cleavir-lambda-list-analysis arities - entry-point-reference + generator local-function) -(defun ensure-xep-function-not-placeholder (fn) - (when (literal:general-entry-placeholder-p fn) - (error "~a must be a xep-function" fn)) - fn) - -(defun xep-group-lookup (xep-group arity) - (dolist (entry (xep-group-arities xep-group)) - (let ((entry-arity (xep-arity-arity entry))) - (when (eql entry-arity arity) - (return-from xep-group-lookup entry)))) - (error "Could not find arity ~a in xep-group" arity)) - -(defstruct (function-info (:type list) :named - (:constructor %make-function-info +(defstruct (function-info (:constructor %make-function-info (function-name lambda-list cleavir-lambda-list-analysis @@ -202,24 +167,16 @@ local-function - the lcl function that all of the xep functions call." (%make-function-info function-name lambda-list cleavir-lambda-list-analysis docstring declares source-pathname lineno column filepos))) - -(defun irc-single-step-callback () - (irc-intrinsic "singleStepCallback" )) - (defun irc-arity-info (arity) "Return the (values register-save-words entry-index) for the arity" (cond ((eq arity :general-entry) (values 3 0)) - ((fixnump arity) (values (+ 1 arity) (+ 1 arity))) + ((core:fixnump arity) (values (+ 1 arity) (+ 1 arity))) (t (error "irc-arity-info Illegal arity ~a" arity)))) (defun irc-personality-function () (get-or-declare-function-or-error *the-module* "__gxx_personality_v0")) -(defun irc-set-cleanup (landpad val) - (llvm-sys:set-cleanup landpad val)) - - (defun irc-create-landing-pad (num-clauses &optional (name "")) (llvm-sys:create-landing-pad *irbuilder* %exception-struct% num-clauses name)) @@ -235,7 +192,7 @@ local-function - the lcl function that all of the xep functions call." (defun irc-fix-gep-indices (indices) (let ((fixed-indices (mapcar (lambda (val) (cond - ((fixnump val) (jit-constant-i32 val)) + ((core:fixnump val) (jit-constant-i32 val)) ((llvm-sys:type-equal %i32% val) val) ((llvm-sys:type-equal %i64% val) val) ((typep val 'llvm-sys:constant-int) val) @@ -276,9 +233,6 @@ local-function - the lcl function that all of the xep functions call." (defun irc-size_t (num) (jit-constant-size_t num)) -(defun irc-literal (lit &optional (label "literal")) - (irc-t*-load (literal:compile-reference-to-literal lit) label)) - (defvar *current-unwind-landing-pad-dest* nil) (defmacro with-landing-pad (unwind-landing-pad-dest &rest body) @@ -290,7 +244,7 @@ local-function - the lcl function that all of the xep functions call." (defun irc-size_t-*current-source-pos-info*-lineno () (jit-constant-size_t (core:source-pos-info-lineno core:*current-source-pos-info*))) (defun irc-size_t-*current-source-pos-info*-column () - (jit-constant-size_t (core:source-pos-info-column *current-source-pos-info*))) + (jit-constant-size_t (core:source-pos-info-column core:*current-source-pos-info*))) (defun irc-basic-block-create (name &optional (function *current-function*)) "Create a llvm::BasicBlock with (name) in the (function)" @@ -320,25 +274,6 @@ local-function - the lcl function that all of the xep functions call." (llvm-sys:set-insert-point-basic-block irbuilder theblock)) - -;; "Control if low-level block tracing is on or off" -;; -;; -;; You can do things like: -;; Put (push :flow *features*) / (pop *features*) -;; around a function and it will get low-level-trace commands inserted before -;; every function call and within every landing pad. - -(defparameter *next-low-level-trace-index* 1000000001) -(defun irc-low-level-trace (&optional where) - (if (member where *features*) - (progn - (let ((llt (get-or-declare-function-or-error *the-module* "lowLevelTrace"))) - (llvm-sys:create-call-function-pointer *irbuilder* llt (list (jit-constant-i32 *next-low-level-trace-index*)) "")) - (setq *next-low-level-trace-index* (+ 1 *next-low-level-trace-index*))) - nil)) - - (defun irc-begin-landing-pad-block (theblock) "This doesn't invoke low-level-trace - it would interfere with the landing pad" (or (llvm-sys:get-parent theblock) (error "irc-begin-landing-pad-block>> The block ~a doesn't have a parent" theblock)) @@ -873,7 +808,7 @@ Otherwise do a variable shift." ;;; This requires branching. We could alternately use the llvm select ;;; instruction, but I'm not as sure how it works (especially the "MDFrom" ;;; argument to CreateSelect). -(defun irc-vaslist-nth (n vaslist &optional (label "primary")) +(defun irc-vaslist-nth (n vaslist nilval &optional (label "primary")) (let ((novalues (irc-basic-block-create "vaslist-primary-no-values")) (values (irc-basic-block-create "vaslist-primary-values")) (merge (irc-basic-block-create "vaslist-primary-merge"))) @@ -881,16 +816,15 @@ Otherwise do a variable shift." (irc-icmp-ult n (irc-vaslist-nvals vaslist)) values novalues) (irc-begin-block novalues) - (let ((null (irc-literal nil "NIL"))) + (irc-br merge) + (irc-begin-block values) + (let ((primary (irc-t*-load (cmp:irc-typed-gep %t*% (irc-vaslist-values vaslist) (list n)) "primary"))) (irc-br merge) - (irc-begin-block values) - (let ((primary (irc-t*-load (cmp:irc-typed-gep %t*% (irc-vaslist-values vaslist) (list n)) "primary"))) - (irc-br merge) - (irc-begin-block merge) - (let ((phi (irc-phi %t*% 2 label))) - (irc-phi-add-incoming phi null novalues) - (irc-phi-add-incoming phi primary values) - phi))))) + (irc-begin-block merge) + (let ((phi (irc-phi %t*% 2 label))) + (irc-phi-add-incoming phi nilval novalues) + (irc-phi-add-incoming phi primary values) + phi)))) ;;; Given a vaslist, return a new vaslist with all values but the primary. ;;; If the vaslist is already empty, it is returned. @@ -972,17 +906,7 @@ But no irbuilders or basic-blocks. Return the fn." (defconstant +maxi32+ 4294967295) -(defstruct (entry-point-reference (:type vector) :named) - "Store an index into the literal vector for an entry-point. -index - the index into the literal vector -kind - :global or :local - for debugging. -function-description - for debugging." - index - kind ; for debugging (:global or :local) - function-description ; for debugging - ) - -(defstruct (function-description-placeholder (:type vector) :named) +(defstruct function-description-placeholder function function-name source-pathname lambda-list docstring declares lineno column filepos ) @@ -1015,92 +939,28 @@ function-description - for debugging." :column column :filepos filepos)))) -(defun irc-create-global-entry-point-reference (xep-arity-list module function-description local-entry-point-reference) - (declare (ignore module)) - (let* ((simple-fun-generator (let ((entry-point-indices (literal:register-xep-function-indices xep-arity-list))) - (sys:make-simple-core-fun-generator - :entry-point-functions entry-point-indices - :function-description function-description - :local-entry-point-index (entry-point-reference-index local-entry-point-reference)))) - (index (literal:reference-literal simple-fun-generator))) - (make-entry-point-reference :index index :kind :global :function-description function-description))) - -(defun irc-create-local-entry-point-reference (local-fn module function-description) - (declare (ignore module)) - (let* ((simple-fun-generator (let ((entry-point-index (literal:register-local-function-index local-fn))) - (sys:make-core-fun-generator - :entry-point-functions (list entry-point-index) - :function-description function-description))) - (index (literal:reference-literal simple-fun-generator))) - (make-entry-point-reference :index index :kind :local :function-description function-description))) - - -(defun irc-local-function-create (llvm-function-type linkage function-name module function-description) - "Create a local function and no function description is needed" - (let* ((local-function-name (concatenate 'string function-name "-lcl")) - (fn (irc-function-create llvm-function-type linkage local-function-name module)) - (local-entry-point-reference (irc-create-local-entry-point-reference fn module function-description))) - (values fn local-entry-point-reference))) - -(defparameter *multiple-entry-points* nil) -(defun irc-xep-functions-create (cleavir-lambda-list-analysis linkage function-name module function-description local-function local-entry-point-reference) - "Create a function and a function description for a cclasp function" - ;; MULTIPLE-ENTRY-POINT first return value is list of entry points - (let ((rev-xep-aritys '())) - (dolist (arity (list* :general-entry (subseq (list 0 1 2 3 4 5 6 7 8) +entry-point-arity-begin+ +entry-point-arity-end+))) - (let* ((xep-function-name (concatenate 'string function-name (format nil "-xep~a" (if (eq arity :general-entry) "" arity)))) - (fn (if (generate-function-for-arity-p arity cleavir-lambda-list-analysis) - (let* ((function-type (fn-prototype arity)) - (function (irc-function-create function-type linkage xep-function-name module))) - #+(or)(when (eq arity :general-entry) - (format t "About to add-param-attr for function: ~a~%" function) - (llvm-sys:add-param-attr function 2 'llvm-sys:attribute-in-alloca)) - function) - (literal:make-general-entry-placeholder :arity arity - :name xep-function-name - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis) - )) - (xep-arity (make-xep-arity :arity arity :function-or-placeholder fn))) - (push xep-arity rev-xep-aritys))) - (let* ((xep-aritys (nreverse rev-xep-aritys)) - (entry-point-reference (irc-create-global-entry-point-reference xep-aritys - module - function-description - local-entry-point-reference)) - (entry-point-info (make-xep-group :name function-name - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis - :arities xep-aritys - :entry-point-reference entry-point-reference - :local-function local-function))) - entry-point-info))) - (defun irc-pointer-cast (from totype &optional (label "")) (llvm-sys:create-pointer-cast *irbuilder* from totype label)) (defun irc-bit-cast (from totype &optional (label "bit-cast")) (llvm-sys:create-bit-cast *irbuilder* from totype label)) -(defun irc-irbuilder-status (&optional (irbuilder *irbuilder*) (label "current *irbuilder*")) - (core:fmt t "{} -> {}%N" label irbuilder)) - -#+(or) -(defun irc-constant-string-ptr (global-string-var) - (let* ((type (llvm-sys:get-pointer-element-type - (llvm-sys:get-scalar-type - (llvm-sys:get-type - global-string-var)))) - (ptr (llvm-sys:create-geparray *irbuilder* global-string-var (list (cmp:jit-constant-i32 0) (cmp:jit-constant-i32 0)) "ptr"))) - ptr)) - -(defun irc-dtor (name obj) - (declare (special *compiler-suppress-dtors*)) - (unless *compiler-suppress-dtors* (irc-intrinsic name obj))) - -(defmacro with-irbuilder ((irbuilder) &rest code) +(defmacro with-irbuilder ((irbuilder) &body code) "Set *irbuilder* to the given IRBuilder" `(let ((*irbuilder* ,irbuilder)) ,@code)) +(defmacro with-module (( &key module + (optimize nil) + (optimize-level '*optimization-level*) + dry-run) + &body body) + `(let* ((*the-module* ,module)) + (or *the-module* (error "with-module *the-module* is NIL")) + (multiple-value-prog1 + (progn ,@body) + (when (and ,optimize ,optimize-level (null ,dry-run)) (funcall ,optimize ,module ,optimize-level ))))) + ;;; ALLOCA functions (defun alloca (type size &optional (label "") (alignment 8)) @@ -1232,7 +1092,7 @@ function-description - for debugging." (cond ((eq arity :general-entry) 0) - ((fixnump arity) + ((core:fixnump arity) (+ 1 arity)) (t (error "irc-arity-index Illegal arity ~a" arity)))) @@ -1269,7 +1129,7 @@ function-description - for debugging." (list closure (jit-constant-size_t (length arguments)) (irc-bit-cast arg-buffer %t**%))) (list* closure arguments))) -(defstruct (call-info (:type vector) :named) +(defstruct call-info entry-point real-args function-type @@ -1378,11 +1238,8 @@ function-description - for debugging." (unless code (error "irc-create-invoke returning nil")) code))) -(defparameter *debug-create-call* nil) - (defun irc-create-call-wft (function-type entry-point args &optional (label "")) #+debug-compiler(check-call-types function-type args) - (if *debug-create-call* (core:fmt t "irc-create-call-wft function-type: {} entry-point: {} args: {}%N" function-type entry-point args )) (llvm-sys:create-call-function-pointer *irbuilder* function-type entry-point args label nil)) (defun irc-call-or-invoke (function-type function args &optional (landing-pad *current-unwind-landing-pad-dest*) (label "")) diff --git a/src/lisp/kernel/cleavir/cmpliteral.lisp b/src/lisp/kernel/cleavir/cmpliteral.lisp new file mode 100644 index 0000000000..63aa69c976 --- /dev/null +++ b/src/lisp/kernel/cleavir/cmpliteral.lisp @@ -0,0 +1,270 @@ +(in-package :literal) + +#+threads(defvar *value-table-id-lock* (mp:make-lock :name '*value-table-id-lock*)) +(defvar *value-table-id* 0) +(defun incf-value-table-id-value () + #+threads(mp:with-lock (*value-table-id-lock*) (incf *value-table-id*)) + #-threads(incf *value-table-id*)) + +(defun next-value-table-holder-name (module-id &optional suffix) + (if suffix + (core:fmt nil "{}-{}{}" suffix core:+literals-name+ module-id) + (core:fmt nil "{}{}" core:+literals-name+ module-id))) + +(defstruct literal-node-toplevel-funcall arguments) +(defstruct literal-node-call function source-pos-info holder) +(defstruct literal-node-side-effect name arguments) +(defstruct literal-dnode datum) +(defstruct (literal-node-creator (:include literal-dnode)) + name literal-name object arguments) +(defstruct (literal-node-runtime (:include literal-dnode)) object) + +(defstruct function-datum index) +#+short-float +(defstruct short-float-datum value) +(defstruct single-float-datum value) +(defstruct double-float-datum value) +#+long-float +(defstruct long-float-datum value) +(defstruct immediate-datum value) +(defstruct datum kind index literal-node-creator) + +(defun literal-datum-p (datum) + (eq (datum-kind datum) :literal)) + +(defun transient-datum-p (datum) + (eq (datum-kind datum) :transient)) + +(defun make-literal-datum (&key index) + (make-datum :kind :literal :index index)) + +(defun make-transient-datum () + (make-datum :kind :transient :index nil)) + +(defun upgrade-transient-datum-to-literal (datum) + (unless (transient-datum-p datum) + (error "The datum ~s must be a transient" datum)) + (setf (datum-kind datum) :literal) + (setf (datum-index datum) (new-table-index))) + +(defun literal-datum-index (datum) + (unless (literal-datum-p datum) + (error "The datum ~s must be a literal" datum)) + (datum-index datum)) + + +(defun datum-tag (datum) + (cond + ((literal-datum-p datum) #\l) + ((transient-datum-p datum) #\t) + (t (error "No tag for datum ~a" datum)))) + +(defun datum-index-tag-kind (datum) + (let ((index (datum-index datum)) + (tag (datum-tag datum)) + (kind (datum-kind datum))) + (values index tag kind))) + + +(defun literal-node-index (node) + (let ((datum (literal-dnode-datum node))) + (unless (literal-datum-p datum) + (error "The node ~a has a non-literal datum ~a" node datum)) + (datum-index datum))) + +(defparameter *literal-machine* nil) + +(defun run-all-add-node (node) + (vector-push-extend node (literal-machine-run-all-objects *literal-machine*)) + node) + +;;; ------------------------------------------------------------ +;;; +;;; Immediate objects don't need to be put into tables +;;; + +;;; Return NIL if the object is not immediate +;;; - if it is an immediate then return an immediate-datum object that +;;; contains the tagged immediate value. +(defun immediate-datum-or-nil (original) + (let ((immediate (core:create-tagged-immediate-value-or-nil original))) + (if immediate + (make-immediate-datum :value immediate) + nil))) + + + +(defun make-similarity-table (test) + (make-hash-table :test test)) + +(defun find-similar (object table) + (gethash object table)) + +(defun add-similar (object datum table) + (setf (gethash object table) datum)) + + +(defstruct literal-machine + (run-all-objects (make-array 64 :fill-pointer 0 :adjustable t)) + (table-index 0) + (function-vector (make-array 16 :fill-pointer 0 :adjustable t)) + (constant-data '()) + (identity-coalesce (make-similarity-table #'eq)) + (ratio-coalesce (make-similarity-table #'eql)) + (cons-coalesce (make-similarity-table #'eq)) + (complex-coalesce (make-similarity-table #'eql)) + (array-coalesce (make-similarity-table #'eq)) + (hash-table-coalesce (make-similarity-table #'eq)) + (bignum-coalesce (make-similarity-table #'eql)) + (symbol-coalesce (make-similarity-table #'eq)) + (base-string-coalesce (make-similarity-table #'equal)) + (pathname-coalesce (make-similarity-table #'equal)) + (function-description-coalesce (make-similarity-table #'equal)) + (entry-point-coalesce (make-similarity-table #'eq)) + (package-coalesce (make-similarity-table #'eq)) + (double-float-coalesce (make-similarity-table #'eql)) + #+long-float + (long-float-coalesce (make-similarity-table #'eql)) + (fcell-coalesce (make-similarity-table #'equal)) + (vcell-coalesce (make-similarity-table #'eq)) +) + + +;;; ------------------------------------------------------------ +;;; +;;; + +(defun new-table-index () + "Return the next ltv-index. If this is being invoked from COMPILE then +the value is put into *default-load-time-value-vector* and its index is returned" + (prog1 (literal-machine-table-index *literal-machine*) + (incf (literal-machine-table-index *literal-machine*)))) + +(defun new-datum (toplevelp) + (if toplevelp + (make-literal-datum :index (new-table-index)) + (make-transient-datum))) + +;;; Helper function: we write a few things out as base strings. +;;; FIXME: Use a more efficient representation. +(defun prin1-to-base-string (object) + (with-output-to-string (s nil :element-type 'base-char) + (prin1 object s))) + +(defun call-with-constant-arguments-p (form &optional env) + (and (consp form) + (core:proper-list-p (rest form)) + (symbolp (first form)) + (when (fboundp (first form)) + (and (not (macro-function (first form))) + (not (special-operator-p (first form))))) + (every (lambda (f) (constantp f env)) (rest form)))) + +(defvar *run-time-coalesce*) + +(defun pretty-load-time-name (object ltv-idx) + (cond + ((symbolp object) (core:fmt nil "SYMBOL->{}" object)) + ((consp object) "CONS") + ((arrayp object) "ARRAY") + ((numberp object) (format nil "NUMBER->~a" object)) + (t (subseq (core:fmt nil "ltv-idx_{}_val->{}" ltv-idx object) 0 30)))) + +;;;--------------------------------------------------------------------- +;;; +;;; run time values (i.e., cl:compile) +;;; + +(declaim (ftype (function (t boolean) (values (or immediate-datum literal-node) boolean)) run-time-reference-literal)) +(defun run-time-reference-literal (object read-only-p) + "If the object is an immediate object return (values immediate nil nil). + Otherwise return (values creator T index)." + (declare (ignore read-only-p)) + (let ((immediate-datum (immediate-datum-or-nil object))) + (if immediate-datum + (values immediate-datum NIL) + (let* ((similarity *run-time-coalesce*) + (existing (find-similar object similarity))) + (if existing + (values existing T) + (values (let* ((datum (new-datum t)) + (new-obj (make-literal-node-runtime :datum datum :object object))) + (add-similar object new-obj similarity) + (run-all-add-node new-obj) + new-obj) + T)))))) + +;;; ------------------------------------------------------------ +;;; +;;; compile-form +;;; +;;; Compile the form and return a 0-arity function that +;;; returns a result. +;;; + +(defun compile-form (form) + (funcall (find-symbol "COMPILE-FORM" "CLASP-CLEAVIR") + form)) + +;;; ------------------------------------------------------------ +;;; ------------------------------------------------------------ +;;; ------------------------------------------------------------ +;;; +;;; reference-literal +;;; +;;; Returns an index for the object for both COMPILE-FILE and COMPILE +;;; ------------------------------------------------------------ +;;; ------------------------------------------------------------ +;;; ------------------------------------------------------------ + +(defun reference-literal (object &optional read-only-p) + "Return (values index T) for the literal object in a constants-table. + Returns (values :poison-value-from-reference-literal nil) if the object is an immediate and doesn't have a place in the constants-table." + (let ((cmp:*compile-file-debug-dump-module* nil) + (cmp:*compile-debug-dump-module* nil)) + (multiple-value-bind (immediate-datum?literal-node-runtime in-array) + (run-time-reference-literal object read-only-p) + (if in-array + (let* ((literal-node-runtime immediate-datum?literal-node-runtime) + (index (literal-node-index literal-node-runtime))) + (values index T)) + (let ((immediate-datum immediate-datum?literal-node-runtime)) + (values (cmp:irc-maybe-cast-integer-to-t* (immediate-datum-value immediate-datum)) + nil)))))) + +;;; ------------------------------------------------------------ +;;; +;;; functions that are called by bclasp and cclasp that might +;;; be refactored to simplify the API + +(defun compile-reference-to-literal (literal + &optional (read-only-p t)) + "Generate a reference to a load-time-value or run-time-value literal depending if called from COMPILE-FILE or COMPILE respectively" + (multiple-value-bind (data-or-index in-array literal-name) + (reference-literal literal read-only-p) + (if in-array + (values (constants-table-reference data-or-index) literal-name) + data-or-index))) + +;;; ------------------------------------------------------------ +;;; +;;; Access load-time-values +;;; + +(defun constants-table-reference (index &key + (holder cmp:*load-time-value-holder-global-var*) + (holder-type cmp:*load-time-value-holder-global-var-type*) + literal-name) + (let ((label (if literal-name + (core:fmt nil "values-table[{}]/{}" index literal-name) + (core:fmt nil "values-table[{}]" index)))) + (cmp:irc-const-gep2-64 holder-type holder 0 index label))) + +(defun constants-table-value (index &key (holder cmp:*load-time-value-holder-global-var*) + (holder-type cmp:*load-time-value-holder-global-var-type*) + literal-name) + (cmp:irc-t*-load (constants-table-reference index + :holder holder + :holder-type holder-type + :literal-name literal-name))) + diff --git a/src/lisp/kernel/cleavir/compile-bytecode.lisp b/src/lisp/kernel/cleavir/compile-bytecode.lisp index 755d6bcdd0..87576c8d6d 100644 --- a/src/lisp/kernel/cleavir/compile-bytecode.lisp +++ b/src/lisp/kernel/cleavir/compile-bytecode.lisp @@ -6,7 +6,9 @@ (#:env #:cleavir-env) (#:policy #:cleavir-compilation-policy) (#:build #:cleavir-bir-builder)) - (:export #:compile-function #:compile-hook)) + (:export #:compile-module #:compile-function #:compile-hook) + (:export #:compile-cmodule + #:nmodule-code #:nmodule-literals #:nmodule-fmap)) (in-package #:clasp-bytecode-to-bir) @@ -15,7 +17,8 @@ (declare (ignore environment)) (handler-case (compile-function definition) (error (e) - (warn "BUG: Error during BTB compilation: ~a" e) + (cmp:note 'cmp:native-compilation-failure + :condition e) definition))) ;;; During file compilation we will have a cmp:cfunction rather than an @@ -60,6 +63,7 @@ ;;; Process a bytecode module's literals into something easy to turn into ;;; BIR. Note that we avoid making constants/LTVs ahead of time, since ;;; BTB or Cleavir may optimize them away (e.g. in unreachable code). +;;; FIXME: That's stupid, Cleavir can optimize away constants regardless. ;;; TODO?: If the bytecode recorded immutable LTVs as well, and the forms (or ;;; bytecode functions) that produced the values, we could dump an actual ;;; bytecode function into a FASL with zero information loss. @@ -82,25 +86,6 @@ (compute-runtime-literals literals mutables) irmodule))) -;;; Now, for compile file -(defgeneric compute-compile-literal (info)) -(defmethod compute-compile-literal ((info cmp:constant-info)) - (cons (cmp:constant-info/value info) nil)) -(defmethod compute-compile-literal ((info cmp:cfunction)) - (cons info nil)) -(defmethod compute-compile-literal ((info cmp:variable-cell-info)) - (cons info nil)) -(defmethod compute-compile-literal ((info cmp:function-cell-info)) - (cons info nil)) -(defmethod compute-compile-literal ((info cmp:load-time-value-info)) - (cons (cmp:load-time-value-info/form info) - (if (cmp:load-time-value-info/read-only-p info) - :ltv-readonly - :ltv-mutable))) - -(defun compute-compile-literals (literals) - (map 'vector #'compute-compile-literal literals)) - ;;; Shared entry point for both runtime and compile-file-time. (defun compile-bytecode-into (bytecode annotations literals irmodule) (let* ((blockmap (make-blockmap)) (funmap (make-funmap)) @@ -113,7 +98,7 @@ (sort (copy-list opannots) #'< :key #'core:bytecode-debug-info/end))) ;; Compile. - (core:do-instructions (mnemonic args opip ip next-annots) + (cmp::do-instructions (mnemonic args opip ip next-annots) (bytecode :annotations annotations) (let ((bir:*policy* (policy context)) (bir:*origin* (first (origin-stack context)))) @@ -179,8 +164,7 @@ ;;; Given a bytecode function, return a compiled native function. ;;; Used for CL:COMPILE. (defun compile-function (function - &key (abi clasp-cleavir:*abi-x86-64*) - (linkage 'llvm-sys:internal-linkage) + &key (abi clasp-cleavir::*abi-x86-64*) (system clasp-cleavir:*clasp-system*) (disassemble nil)) (multiple-value-bind (module funmap) @@ -196,59 +180,47 @@ (clasp-cleavir::*fixed-closures* (fixed-closures-map (fmap funmap))) (bir (finfo-irfun (find-bcfun function funmap)))) - (clasp-cleavir::bir->function bir :abi abi :linkage linkage)))) - -;;; COMPILE-FILE interface: take the components of a CMP:MODULE and return -;;; an NMODULE. The NMODULE contains everything COMPILE-FILE needs to dump -;;; native code such that the loader can use it: -;;; 1) The actual native code as bytes (an encoded ELF object) -;;; 2) A mapping from cfunctions to native symbol names, so they can be -;;; reconstructed by the loader. -;;; 3) A vector of literals. Each entry is either: -;;; - an integer, indicating the constant at that position of the -;;; cmp:module's literals. This may include cfunctions. -;;; - a cmp:constant-info or etc., indicating a constant not in the -;;; cmp:module's literals. -;;; - a LATE-FUNCTION, meaning a function introduced by BTB/translate, -;;; e.g. by transforms. Maybe. Not sure this happens, TODO -(defclass nmodule () - ((%code :initarg :code :reader nmodule-code) - (%fmap :initarg :fmap :reader nmodule-fmap) - (%literals :initarg :literals :reader nmodule-literals))) - -(defgeneric bir-constant->cmp (bir)) -(defmethod bir-constant->cmp ((constant bir:constant)) - (cmp:constant-info/make (bir:constant-value constant))) -(defmethod bir-constant->cmp ((ltv bir:load-time-value)) - (cmp:load-time-value-info/make (bir:form ltv) (bir:read-only-p ltv))) -(defmethod bir-constant->cmp ((fcell bir:function-cell)) - (cmp:function-cell-info/make (bir:function-name fcell))) -(defmethod bir-constant->cmp ((vcell bir:variable-cell)) - (cmp:variable-cell-info/make (bir:variable-name vcell))) - -(defun compute-nliterals (cliterals constants) - ;; CONSTANTS is the hash table produced by translation. - ;; Keys are BIR things, and values are indices into the eventual - ;; literals vector. - ;; CLITERALS is the vector produced by BTB, below. - ;; This consists of conses where the CDR is a placeholder or BIR thing. - ;; CONSTANTS may include constants not in CLITERALS and vice versa. - ;; This function produces a vector explaining to the file compiler how - ;; to produce the machine literals. There is one element for every index - ;; in the machine literals. Each element is of the format described in - ;; the comment above NMODULE, above. - (let* ((num (loop for value being the hash-values of constants - maximizing (if (integerp value) (1+ value) 0))) - (nliterals (make-array num))) - (loop for key being the hash-keys of constants - using (hash-value indexoid) - when (integerp indexoid) ; not an immediate - do (setf (aref nliterals indexoid) - ;; Check if the bytecode already had this constant. - (or (position key cliterals :key #'cdr) - ;; No, so translate back into CMP terms. - (bir-constant->cmp key)))) - nliterals)) + (clasp-cleavir::bir->function bir :abi abi)))) + +;;; Given a bytecode module, compute native functions for all bytecode functions +;;; in it, and install them as new simple funs. Return value irrelevant. +;;; Used by autocompilation. +(defun compile-module (module + &key (abi clasp-cleavir::*abi-x86-64*) + (system clasp-cleavir:*clasp-system*)) + (multiple-value-bind (irmodule funmap) (compile-bcmodule module) + (clasp-cleavir::bir-transformations irmodule system) + (multiple-value-bind (function-infos constants ctable fvector) + (let ((cleavir-cst-to-ast:*compiler* 'cl:compile) + (clasp-cleavir::*fixed-closures* + (fixed-closures-map (fmap funmap)))) + (clasp-cleavir::jit-bir irmodule :abi abi :pathname "repl-code")) + ;; Build up a mapping from generators to their original bytecode functions. + (let ((generator->bytecode + (loop with g->b = (make-hash-table) + for (bc ir) in (fmap funmap) + for info = (gethash ir function-infos) + for xep = (clasp-cleavir::xep-function info) + unless (eq xep :xep-unallocated) + do (setf (gethash (cmp:xep-group-generator xep) g->b) bc) + finally (return g->b)))) + ;; Replace any generators in the constants with the corresponding + ;; bytecode function, or a newly generated native function if there is + ;; no corresponding bytecode function (e.g. it's a new type check function). + ;; Store everything in the compiled code. + (loop for c across constants for i from 0 + for real-c = (if (typep c 'core:simple-core-fun-generator) + (or (gethash c generator->bytecode) + (clasp-cleavir::jit-generator c fvector)) + c) + do (setf (core:literals-vref ctable i) real-c)) + ;; Generate XEPs for all the bytecode functions, and store them as + ;; the bytecode functions' simple funs. + (loop for generator being the hash-keys of generator->bytecode + using (hash-value bcfun) + for fun = (clasp-cleavir::jit-generator generator fvector) + do (core:set-simple-fun bcfun fun))))) + (values)) (defun fixed-closures-map (fmap) (loop for entry in fmap @@ -434,7 +406,7 @@ (defun make-bir-function (bytecode-function inserter &optional (module (bir:module inserter))) - (let* ((lambda-list (core:function-lambda-list bytecode-function)) + (let* ((lambda-list (ext:function-lambda-list bytecode-function)) (function (make-instance 'bir:function :returni nil ; set by :return compilation :name (bcfun/fname bytecode-function) @@ -548,12 +520,33 @@ (setf (cdr c) ltv) (build:insert inserter 'bir:load-time-value-reference :inputs (list ltv) :outputs (list output)))) + ((eql :cfunction) + ;; A cfunction. This will be a non-closure function at runtime, + ;; but no function exists yet, so we have to make an ENCLOSE + ;; instruction. (The translator will not put in any consing, + ;; since again, this isn't a closure.) + ;; Bytecode functions don't need to go through this, although + ;; doing so might help inlining and such? TODO + (let ((irfun (make-bir-function value inserter))) + (setf (cdr c) irfun) + (add-function context value irfun nil) + (build:insert inserter 'bir:enclose + :code irfun + :outputs (list output)))) (bir:constant (build:insert inserter 'bir:constant-reference :inputs (list existing) :outputs (list output))) (bir:load-time-value (build:insert inserter 'bir:load-time-value-reference - :inputs (list existing) :outputs (list output)))) + :inputs (list existing) :outputs (list output))) + (cmp:cfunction + ;; should be impossible as cfunctions only appear once, + ;; but just in case + (let* ((finfo (find-bcfun existing (funmap context))) + (irfun (finfo-irfun finfo))) + (assert irfun) + (build:insert inserter 'bir:enclose :code irfun + :outputs (list output))))) (stack-push output context)))) (defun compile-constant (value inserter) @@ -735,7 +728,7 @@ (defun make-closure (template inserter context) (let* ((irfun (make-bir-function template inserter)) (enclose-out (make-instance 'bir:output - :name (core:function-name template))) + :name (bcfun/fname template))) (nclosed (bcfun/nvars template)) (closed (nreverse (subseq (stack context) 0 nclosed))) (real-closed (mapcar #'resolve-closed closed))) @@ -746,25 +739,33 @@ :code irfun :outputs (list enclose-out)) (add-function context template irfun real-closed) (setf (stack context) (nthcdr nclosed (stack context))) - enclose-out)) + (values enclose-out irfun))) (defmethod compile-instruction ((mnemonic (eql :make-closure)) inserter context &rest args) - (destructuring-bind ((template)) args - (stack-push (make-closure template inserter context) context))) + (destructuring-bind (const) args + (destructuring-bind (template . existing) const + ;; any given function is only closed over in one place. + (assert (member existing '(nil :cfunction))) + (multiple-value-bind (closure irfun) (make-closure template inserter context) + (setf (cdr const) irfun) + (stack-push closure context))))) (defmethod compile-instruction ((mnemonic (eql :make-uninitialized-closure)) inserter context &rest args) ;; Set up an ir function for the funmap and generate an enclose, ;; but leave the closure for initialize-closure. - (destructuring-bind ((template)) args - (let ((irfun (make-bir-function template inserter)) - (enclose-out (make-instance 'bir:output - :name (core:function-name template)))) - (build:insert inserter 'bir:enclose - :code irfun :outputs (list enclose-out)) - (add-function context template irfun nil) - (stack-push enclose-out context)))) + (destructuring-bind (const) args + (destructuring-bind (template . existing) const + (assert (member existing '(nil :cfunction))) + (let ((irfun (make-bir-function template inserter)) + (enclose-out (make-instance 'bir:output + :name (bcfun/fname template)))) + (setf (cdr const) irfun) + (build:insert inserter 'bir:enclose + :code irfun :outputs (list enclose-out)) + (add-function context template irfun nil) + (stack-push enclose-out context))))) (defmethod compile-instruction ((mnemonic (eql :initialize-closure)) inserter context &rest args) @@ -854,6 +855,12 @@ (setf (bir:lambda-list ifun) (append ll `(core:&va-rest ,rarg)) (aref (locals context) start) (cons rarg nil))))) +(defgeneric constant-value (constant) + (:method ((c symbol)) c)) + +(defmethod constant-value ((constant cmp:constant-info)) + (cmp:constant-info/value constant)) + (defmethod compile-instruction ((mnemonic (eql :parse-key-args)) inserter context &rest args) (destructuring-bind (start (key-count . aokp) keys) args @@ -862,7 +869,8 @@ (ll (bir:lambda-list ifun))) ;; The keys are put on the stack such that ;; the leftmost key is the _last_ pushed, etc. - (loop for key in keys + (loop for ckey in keys + for key = (constant-value ckey) for arg = (make-instance 'bir:argument :function ifun) for -p = (make-instance 'bir:argument :function ifun) collect (list key arg -p) into ll-app @@ -1134,6 +1142,13 @@ :inputs () :outputs () :next (list ib)) (build:begin inserter ib)))) +(defmethod compile-instruction ((mnemonic (eql :throw)) + inserter context &rest args) + (destructuring-bind () args + (build:terminate inserter 'bir:throwi + :inputs (list (stack-pop context) (mvals context)) + :outputs () :next ()))) + (defgeneric vcell/name (vcell)) (defmethod vcell/name ((vcell core:variable-cell)) (core:variable-cell/name vcell)) @@ -1257,12 +1272,15 @@ (defmethod compile-instruction ((mnemonic (eql :protect)) inserter context &rest args) - (destructuring-bind ((template)) args - (let ((cleanup (make-closure template inserter context)) - (body (build:make-iblock inserter :name '#:protect))) - (build:terminate inserter 'bir:unwind-protect - :inputs (list cleanup) :next (list body)) - (build:begin inserter body)))) + (destructuring-bind (const) args + (destructuring-bind (template . existing) const + (assert (member existing '(nil :cfunction))) + (multiple-value-bind (cleanup irfun) (make-closure template inserter context) + (let ((body (build:make-iblock inserter :name '#:protect))) + (setf (cdr const) irfun) + (build:terminate inserter 'bir:unwind-protect + :inputs (list cleanup) :next (list body)) + (build:begin inserter body)))))) (defmethod compile-instruction ((mnemonic (eql :cleanup)) inserter context &rest args) @@ -1489,19 +1507,19 @@ do (case spec ((cl:optimize) (setf opt - (policy:normalize-optimize - (append (copy-list rest) opt) clasp-cleavir:*clasp-env*)))) + (policy:normalize-optimize clasp-cleavir:*clasp-system* + (append (copy-list rest) opt))))) finally (push opt (optimize-stack context)) (setf (policy context) - (policy:compute-policy opt clasp-cleavir:*clasp-env*)))) + (policy:compute-policy clasp-cleavir:*clasp-system* opt)))) (defmethod end-annotation ((annot core:bytecode-ast-decls) inserter context) (declare (ignore inserter)) (when (degenerate-annotation-p annot) (return-from end-annotation)) (pop (optimize-stack context)) - (setf (policy context) (policy:compute-policy (first (optimize-stack context)) - clasp-cleavir:*clasp-env*))) + (setf (policy context) (policy:compute-policy clasp-cleavir:*clasp-system* + (first (optimize-stack context))))) (defmethod start-annotation ((annot core:bytecode-debug-location) inserter context) @@ -1556,3 +1574,133 @@ (defmethod end-annotation ((annot core:bytecode-debug-info) inserter context) (declare (ignore inserter context))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; COMPILE-FILE interface: take the components of a CMP:MODULE and return +;;; an NMODULE. The NMODULE contains everything COMPILE-FILE needs to dump +;;; native code such that the loader can use it: +;;; 1) The actual native code as bytes (an encoded ELF object) +;;; 2) A mapping from cfunctions to llvm-function-infos. These provide +;;; information that can be communicated to the loader to let it +;;; reconstruct functions. +;;; 3) A vector of literals. Each entry is a cons: +;;; - (value . :CONSTANT) - ordinary constant +;;; - (cfunction . :CFUNCTION) - a cfunction (eventual bytecode function) +;;; - (ltv-info . :LOAD-TIME-VALUE) +;;; TODO +;;; - a LATE-FUNCTION, meaning a function introduced by BTB/translate, +;;; e.g. by transforms. Maybe. Not sure this happens +(defclass nmodule () + ((%code :initarg :code :reader nmodule-code) + (%id :initarg :id :reader nmodule-id) + (%fmap :initarg :fmap :reader nmodule-fmap) + (%literals :initarg :literals :reader nmodule-literals))) + +;;; Process a bytecode cmp:module's literal infos into something easy to turn into +;;; BIR. BIR is computed eagerly, unlike compute-runtime-literals, because it makes +;;; translation easier. And optimization can still remove constants. +(defgeneric compute-compiled-literal (info module)) +(defmethod compute-compiled-literal ((info cmp:constant-info) module) + (cons info (bir:constant-in-module (cmp:constant-info/value info) module))) +(defmethod compute-compiled-literal ((info cmp:cfunction) module) + (declare (ignore module)) + (cons info :cfunction)) +(defmethod compute-compiled-literal ((info cmp:load-time-value-info) module) + (cons info (bir:load-time-value-in-module + (cmp:load-time-value-info/form info) + (cmp:load-time-value-info/read-only-p info) + module))) +(defmethod compute-compiled-literal ((info cmp:function-cell-info) module) + (cons info (bir:function-cell-in-module (cmp:function-cell-info/fname info) + module))) +(defmethod compute-compiled-literal ((info cmp:variable-cell-info) module) + (cons info (bir:variable-cell-in-module (cmp:variable-cell-info/vname info) + module))) +(defmethod compute-compiled-literal ((info cmp:env-info) module) + ;; FIXME? There's a bit of a mismatch here. Native-compiled code probably + ;; never refers to the environment, for now. + (cons info (bir:constant-in-module nil module))) + +(defun compute-compiled-literals (literals irmodule) + (map 'vector (lambda (lit) (compute-compiled-literal lit irmodule)) literals)) + +(defun cmodule->irmodule (bytecode literals-info debug-info) + (let* ((irmodule (make-instance 'bir:module)) + (literals (compute-compiled-literals literals-info irmodule)) + (fmap (compile-bytecode-into bytecode debug-info literals irmodule))) + ;;(cleavir-bir-disassembler:display irmodule) (terpri) + (clasp-cleavir::bir-transformations irmodule clasp-cleavir:*clasp-system*) + (values irmodule fmap literals))) + +;;; Compute an alist from bytecode cfunctions to pairs of indices into +;;; the function vector: (main xep) +(defun compute-native-fmap (cmap mmap) + (loop for cinfo in cmap + for cfun = (finfo-bcfun cinfo) + for irfun = (finfo-irfun cinfo) + for info = (gethash irfun mmap) + ;; functions may have been removed from the IR module, e.g. because they've been + ;; inlined. We could try to preserve some native code to keep in the bytecode + ;; function, but it's not necessary. + when info + collect (let* ((xep-group (clasp-cleavir::xep-function info)) + (generator (cmp:xep-group-generator xep-group)) + (xepi (first (core:simple-core-fun-generator-entry-point-indices generator))) + (coregen (core:simple-core-fun-generator/core-fun-generator generator)) + (corei (first (core:core-fun-generator-entry-point-indices coregen)))) + (list cfun corei xepi)))) + +(defun allocate-module-constants (constants) + ;; Generate translator constants for any infos that are actually used. + (loop for (cmp . ir) across constants + unless (and (not (typep ir 'bir:function)) + (cleavir-set:empty-set-p (bir:readers ir))) ; used? + ;; Pre-populate the translation constants + do (clasp-cleavir::ensure-literal-info ir cmp))) + +(defun allocate-llvm-function-infos (module fvector fmap) + (bir:do-functions (function module) + (let ((info (find function fmap :key #'finfo-irfun))) + (setf (gethash function clasp-cleavir::*function-info*) + (if info + (clasp-cleavir::allocate-llvm-function-info + function fvector (finfo-bcfun info)) + ;; no corresponding bytecode function: this is a new function + ;; the we have inserted (e.g. a type checker) + (clasp-cleavir::allocate-llvm-function-info + function fvector)))))) + +(defun translate-cmodule (ir fmap cmap module-id pathname) + (let ((module (cmp::llvm-create-module "compile")) + (function-info (make-hash-table :test #'eq)) + (ctable-name (literal:next-value-table-holder-name module-id)) + (ctable (make-array 16 :fill-pointer 0 :adjustable t)) + (fvector-name (format nil "function-vector-~d" module-id)) + (fvector (make-array 16 :fill-pointer 0 :adjustable t)) + (clasp-cleavir::*fixed-closures* (fixed-closures-map fmap)) + (abi clasp-cleavir::*abi-x86-64*)) ; FIXME + (cmp::with-module (:module module) + (cmp:with-debug-info-generator (:module cmp:*the-module* :pathname pathname) + (let* ((clasp-cleavir::*unwind-ids* (make-hash-table :test #'eq)) + (clasp-cleavir::*function-info* function-info)) + (allocate-llvm-function-infos ir fvector fmap) + (clasp-cleavir::with-constants (ctable ctable-name) + (allocate-module-constants cmap) + (clasp-cleavir::layout-module ir abi) + (cmp::potentially-save-module))) + (clasp-cleavir::gen-function-vector fvector fvector-name)) + ;;(llvm-sys:dump-module module) + (cmp:irc-verify-module-safe module)) + (make-instance 'nmodule + :code (cmp::generate-obj-asm-stream module :simple-vector-byte8 + 'llvm-sys:code-gen-file-type-object-file + cmp::*default-reloc-model*) + :id module-id + :fmap (compute-native-fmap fmap function-info) + :literals ctable))) + +(defun compile-cmodule (bytecode literals-info debug-info module-id pathname) + (multiple-value-bind (ir funmap cmap) + (cmodule->irmodule bytecode literals-info debug-info) + (translate-cmodule ir (fmap funmap) cmap module-id pathname))) diff --git a/src/lisp/kernel/cleavir/compile-file.lisp b/src/lisp/kernel/cleavir/compile-file.lisp new file mode 100644 index 0000000000..81bec44f73 --- /dev/null +++ b/src/lisp/kernel/cleavir/compile-file.lisp @@ -0,0 +1,37 @@ +(in-package #:cmp) + +(defun generate-obj-asm-stream (module output-stream file-type reloc-model &key (output-type *default-output-type*)) + (with-track-llvm-time + (let* ((triple-string (llvm-sys:get-target-triple module)) + (normalized-triple-string (llvm-sys:triple-normalize triple-string)) + (triple (llvm-sys:make-triple normalized-triple-string)) + (target-options (llvm-sys:make-target-options))) + (multiple-value-bind (target msg) + (llvm-sys:target-registry-lookup-target "" triple) + (unless target + (error msg)) + (llvm-sys:emit-module (llvm-sys:create-target-machine target + (llvm-sys:get-triple triple) + "" + "" + target-options + reloc-model + (code-model :jit nil :output-type output-type) + 'llvm-sys:code-gen-opt-default + nil) + output-stream + nil ; dwo-stream for dwarf objects + file-type module))))) + +(defun build-extension (type) + (cond ((or (eq type :bytecode) + (member :bytecode *features*)) + "fasl") + ((eq type :faso) + "faso") + ((eq type :fasoll) + "fasoll") + ((eq type :fasobc) + "fasobc") + (t + (error "Unsupported build-extension type ~a" type)))) diff --git a/src/lisp/kernel/cleavir/convert-special.lisp b/src/lisp/kernel/cleavir/convert-special.lisp index a0f3c14ad9..6bebdfc66d 100644 --- a/src/lisp/kernel/cleavir/convert-special.lisp +++ b/src/lisp/kernel/cleavir/convert-special.lisp @@ -203,7 +203,7 @@ ;; The type is too boring to note under any policy. ast ;; Do something. - (let* ((policy (env:policy (env:optimize-info env))) + (let* ((policy (env:policy (env:optimize-info system env))) (insert-type-checks (insert-type-checks-level policy context)) (vctype (ecase context diff --git a/src/lisp/kernel/cleavir/disassemble.lisp b/src/lisp/kernel/cleavir/disassemble.lisp new file mode 100644 index 0000000000..46851eb4d6 --- /dev/null +++ b/src/lisp/kernel/cleavir/disassemble.lisp @@ -0,0 +1,33 @@ +(in-package #:cmp) + +;;; Used by debugger - see clasp-debug:disassemble-frame +(defun disassemble-assembly (start end) + (format t "~&; disassemble-assembly Size: ~s Origin: ~s~%" (- (core:pointer-integer end) (core:pointer-integer start)) start) + (llvm-sys:disassemble-instructions (get-builtin-target-triple-and-data-layout) + start end)) + +(defun disassemble-function-to-asm (function) + (let ((function-pointers (core:function-pointer-alist function))) + (dolist (fp function-pointers) + (let ((entry-point-name (car fp)) + (address (cdr fp))) + (when address + (multiple-value-bind (symbol start end) + (core:lookup-address address) + (if symbol + (progn + (format t "Entry point ~a~%" (if (fixnump entry-point-name) + (format nil "xep~a" entry-point-name) + (string entry-point-name))) + (disassemble-assembly start end)) + (format t "; could not locate code object (bug?)~%")))))))) + +;;; should work for both lambda expressions and bytecode functions. +(defun disassemble-to-ir (thing) + (let* ((*save-module-for-disassemble* t) + (*saved-module-from-clasp-jit* nil)) + (compile nil thing) + (if *saved-module-from-clasp-jit* + (format t "~&Disassembly: ~a~%" *saved-module-from-clasp-jit*) + (error "Could not recover jitted module for ~a" thing))) + (values)) diff --git a/src/lisp/kernel/cleavir/hooks.lisp b/src/lisp/kernel/cleavir/hooks.lisp index ee8bb1af6e..1ea2ee63ae 100644 --- a/src/lisp/kernel/cleavir/hooks.lisp +++ b/src/lisp/kernel/cleavir/hooks.lisp @@ -43,13 +43,6 @@ (eval-when (:execute :load-toplevel) (setq cmp:*cleavir-compile-hook* 'bir-compile)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Set up the cmp:*CLEAVIR-COMPILE-FILE-HOOK* so that COMPILE-FILE uses Cleavir -;; -(eval-when (:execute :load-toplevel) - (setq cmp:*cleavir-compile-file-hook* 'bir-loop-read-and-compile-file-forms)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Hook the bytecode-to-bir compiler into cl:compile. diff --git a/src/lisp/kernel/cleavir/inline-prep.lisp b/src/lisp/kernel/cleavir/inline-prep.lisp index 9cbd3a7f4d..af30ac0d47 100644 --- a/src/lisp/kernel/cleavir/inline-prep.lisp +++ b/src/lisp/kernel/cleavir/inline-prep.lisp @@ -20,9 +20,9 @@ ((eq head 'cl:optimize) (setf cmp:*optimize* (policy:normalize-optimize - (append (rest decl) cmp:*optimize*) *clasp-env*) + *clasp-system* (append (rest decl) cmp:*optimize*)) cmp:*policy* - (policy:compute-policy cmp:*optimize* *clasp-env*))) + (policy:compute-policy *clasp-system* cmp:*optimize*))) ;; Add other clauses here (t #+(or)(warn "Add support for proclaim ~s~%" decl))))) @@ -93,8 +93,7 @@ ;; load-time-value correctly. (compute-inline-ast ,function-form t)))))) -(eval-when (:compile-toplevel :execute :load-toplevel) - (setq core:*proclaim-hook* 'proclaim-hook)) +(setq core::*proclaim-hook* 'proclaim-hook) ;;; The following code sets up the chain of inlined-at info in AST origins. diff --git a/src/lisp/kernel/cleavir/inline.lisp b/src/lisp/kernel/cleavir/inline.lisp index 72d864fa02..e24a8858a4 100644 --- a/src/lisp/kernel/cleavir/inline.lisp +++ b/src/lisp/kernel/cleavir/inline.lisp @@ -1,23 +1,11 @@ (in-package :clasp-cleavir) -#-bytecode -(progn - #+(or) -(eval-when (:execute) - (format t "Setting core:*echo-repl-read* to T~%") - (setq core:*echo-repl-read* t)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (setf cmp::*debug-create-call* nil)) +(progn (eval-when (:compile-toplevel :execute :load-toplevel) (setq core:*defun-inline-hook* 'defun-inline-hook)) -#+(or) -(eval-when (:execute) - (setq core:*echo-repl-read* t)) - #+(or) (defmacro debug-inline (msg &rest msg-args) `(progn diff --git a/src/lisp/kernel/cmp/jit-setup.lisp b/src/lisp/kernel/cleavir/jit-setup.lisp similarity index 89% rename from src/lisp/kernel/cmp/jit-setup.lisp rename to src/lisp/kernel/cleavir/jit-setup.lisp index 9cf43d2202..b9e4f6c482 100644 --- a/src/lisp/kernel/cmp/jit-setup.lisp +++ b/src/lisp/kernel/cleavir/jit-setup.lisp @@ -28,14 +28,10 @@ ;; Prepare the llvm system ;; -;;(in-package :cmp) -(eval-when (:compile-toplevel :load-toplevel :execute) - (core:select-package :cmp)) +(in-package #:cmp) (defconstant +debug-dwarf-version+ 5) -(export '*primitives*) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Thread-local special variables to support the LLVM compiler @@ -45,9 +41,6 @@ (eval-when (:load-toplevel :execute) (mp:push-default-special-binding 'cmp:*thread-safe-context* '(llvm-sys:create-thread-safe-context)) (mp:push-default-special-binding '*debugger-hook* nil) - (mp:push-default-special-binding 'core::*handler-clusters* nil) - (mp:push-default-special-binding 'core::*restart-clusters* nil) - (mp:push-default-special-binding 'core::*condition-restarts* nil) ;;; more thread-local special variables may be added in the future ) @@ -55,9 +48,6 @@ ;; (core:fmt t "*thread-safe-context* -> {}%N" *thread-safe-context*) (llvm-sys:thread-local-llvm-context)) -(export 'thread-local-llvm-context) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Image save load support @@ -82,11 +72,6 @@ (go top))))) (format t "Finished cmp:invoke-save-hooks~%")) -(defun snapshot-load-restore () - ) - -(export '(snapshot-load-restore register-save-hook)) - (defun parse-bitcode (filename context &key print output-type) ;; Load a module from a bitcode or .ll file (cond @@ -98,8 +83,6 @@ (llvm-sys:parse-irfile filename context)) (t (error "Add support for output-type ~a" output-type)))) -(export '(write-bitcode parse-bitcode load-ir-run-c-function)) - (defun get-builtin-target-triple-and-data-layout () "Query llvm for the target triple and the data-layout" (let* ((triple-str (llvm-sys:get-default-target-triple)) @@ -176,7 +159,6 @@ (go top) done)) link-module))) -(export 'link-bitcode-modules-together) (defvar *run-time-module-counter* 1) (defun next-run-time-module-name () @@ -192,18 +174,10 @@ (declare (ignore triple data-layout-str)) data-layout)) -(export 'system-data-layout) - #+(or) (eval-when (:compile-toplevel :load-toplevel :execute) (register-save-hook (function (lambda () (makunbound '*the-system-data-layout*))))) -(defun load-object-files (&optional (object-files core:*command-line-arguments*)) - (format t "load-object-files trying to load ~a~%" object-files) - (format t "output-type = ~a~%" cmp:*default-output-type*)) - -(export 'load-object-files) - (defun create-run-time-module-for-compile () "Run time modules are used by COMPILE - a new one needs to be created for every COMPILE. Return the module and the global variable that represents the load-time-value-holder as @@ -222,6 +196,12 @@ Return the module and the global variable that represents the load-time-value-ho "Keeps track of the current DIBuilder for generating DWARF debugging information for *the-module*. No DIBuilder is defined for the default module") +(defun potentially-save-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*))))) + (defun jit-constant-pointer-null-get (type) (llvm-sys:constant-pointer-null-get type)) @@ -319,14 +299,6 @@ No DIBuilder is defined for the default module") ((= 32 sizeof-size_t) (jit-constant-i32 val)) (t (error "Add support for size_t sizeof = ~a" sizeof-size_t))))) -(defun jit-constant-unique-string-ptr (str &optional (label "unique-str")) - "Get or create a unique string within the module and return a GEP i8* pointer to it" - (or *the-module* (error "jit-constant-unique-string-ptr *the-module* is NIL")) - (let* ((str-gv (llvm-sys:get-or-create-uniqued-string-global-variable - *the-module* str - (core:fmt nil "str-{}" str)))) - (irc-const-gep2-64 %t*% str-gv 0 0 label))) - (defun module-make-global-string (str &optional (label "")) (declare (ignore label)) @@ -393,8 +365,6 @@ No DIBuilder is defined for the default module") (format nil "(SETF ~a)" symbol)) (t raw-name)))) -(export 'print-name-from-unescaped-split-name) - (defun jit-repl-function-name () (sys:fmt nil "JITREPL-{}" (sys:next-number))) @@ -407,11 +377,6 @@ No DIBuilder is defined for the default module") (sys:fmt nil "{}-{}" sys:*module-startup-function-name* module-id) (sys:fmt nil "{}-{}" sys:*module-shutdown-function-name* module-id))) -(export '(jit-startup-shutdown-function-names jit-repl-function-name)) - - -(export '(unescape-and-split-jit-name)) - ;;; ------------------------------------------------------------ ;;; ;;; JIT facility @@ -423,8 +388,6 @@ No DIBuilder is defined for the default module") "Return the code-model for the compilation mode" 'llvm-sys:code-model-small) -(export 'code-model) - (defun do-track-llvm-time (closure) "Run the closure in and keep track of the time, adding it to this threads accumulated llvm time" (let ((start-llvm-time (get-internal-run-time))) @@ -433,13 +396,5 @@ No DIBuilder is defined for the default module") (let ((llvm-time (/ (- (get-internal-run-time) start-llvm-time) (float internal-time-units-per-second)))) (llvm-sys:accumulate-llvm-usage-seconds llvm-time))))) -(si::fset 'with-track-llvm-time - #'(lambda (args env) - (declare (core:lambda-name with-track-llvm-time) - (ignore env)) - (let ((code (cdr args))) - `(do-track-llvm-time - (function - (lambda () - ,@code))))) - t) +(defmacro with-track-llvm-time (&body code) + `(do-track-llvm-time (lambda () (progn ,@code)))) diff --git a/src/lisp/kernel/cleavir/jit.lisp b/src/lisp/kernel/cleavir/jit.lisp index 7a9b0ebeba..2ba54c7955 100644 --- a/src/lisp/kernel/cleavir/jit.lisp +++ b/src/lisp/kernel/cleavir/jit.lisp @@ -42,8 +42,6 @@ (format nil "MAIN-~a" (string-upcase (pathname-name lname)))) (string (cond - ((string= lname core:+run-all-function-name+) lname) ; this one is ok - ((string= lname core:+clasp-ctor-function-name+) lname) ; this one is ok ((string= lname "IMPLICIT-REPL") lname) ; this one is ok ((string= lname "TOP-LEVEL") (function-name-from-source-info lname)) @@ -115,39 +113,34 @@ cl:macro-function cl:compiler-macro-function ext::type-expander ext::setf-expander)) (jit-function-name (second lname))) - #+(or) ;; uncomment this to be more forgiving - (cons - (core:fmt t "jit-function-name handling UNKNOWN: {}%N" lname) - ;; What is this???? - (core:fmt nil "{}_CONS-LNAME?" lname)) + ;;#+(or) ;; uncomment this to be more forgiving + ((cons t (cons t null)) + (jit-function-name (second lname))) (t (error "Illegal lisp function name[~a]" lname)))) (defparameter *dump-compile-module* nil) (defparameter *jit-lock* (mp:make-recursive-mutex 'jit-lock)) -(defun jit-add-module-return-function (original-module startup-shutdown-id literals-list - &key output-path) - (declare (ignore output-path)) - (cmp:quick-module-dump original-module "module-before-optimize") +(defun jit-add-module (module startup-shutdown-id ctable-name fvector-name) + (cmp:irc-verify-module-safe module) (unwind-protect - (let ((module original-module)) - (cmp:irc-verify-module-safe module) - (let ((jit-engine (llvm-sys:clasp-jit))) - (multiple-value-bind (startup-name shutdown-name) - (cmp:jit-startup-shutdown-function-names startup-shutdown-id) - (let ((function (llvm-sys:get-function module startup-name))) - (if (null function) - (error "Could not obtain the startup function ~s by name" startup-name))) - (cmp:with-track-llvm-time - (when *dump-compile-module* - (format t "About to dump module~%") - (llvm-sys:dump-module module) - (format t "startup-name |{}|~%" startup-name) - (format t "Done dump module~%")) - (mp:with-lock (*jit-lock*) - (when (member :dump-compile *features*) - (llvm-sys:dump-module module)) - (llvm-sys:add-irmodule jit-engine (llvm-sys:get-main-jitdylib jit-engine) module cmp:*thread-safe-context* startup-shutdown-id) - (llvm-sys:jit-finalize-repl-function jit-engine startup-name shutdown-name literals-list)))))) + (let ((jit-engine (llvm-sys:clasp-jit))) + (cmp:with-track-llvm-time + (when *dump-compile-module* + (format t "About to dump module~%") + (llvm-sys:dump-module module) + (format t "Done dump module~%")) + (mp:with-lock (*jit-lock*) + (let ((dylib (llvm-sys:get-main-jitdylib jit-engine))) + ;; Install the literals, and as a bonus, collect the constants table + ;; and function vector so the caller can make or retrieve objects. + (let ((object-file + (llvm-sys:add-irmodule + jit-engine dylib module + cmp:*thread-safe-context* startup-shutdown-id)) + (litarr (llvm-sys:lookup jit-engine dylib ctable-name)) + (fvector + (llvm-sys:lookup jit-engine dylib fvector-name))) + (values object-file litarr fvector)))))) (gctools:thread-local-cleanup))) diff --git a/src/lisp/kernel/cleavir/landing-pad.lisp b/src/lisp/kernel/cleavir/landing-pad.lisp index 41ec042ee0..712c367db7 100644 --- a/src/lisp/kernel/cleavir/landing-pad.lisp +++ b/src/lisp/kernel/cleavir/landing-pad.lisp @@ -101,30 +101,29 @@ ;; pop the dynenv. (let ((de-stack (dynenv-storage u-p-instruction))) (%intrinsic-call "cc_set_dynenv_stack" (list de-stack))) - (let ((thunk (in (first (cleavir-bir:inputs u-p-instruction))))) - ;; There is a subtle point here with regard to unwinding out of a cleanup - ;; form. CLHS 5.2 specifies that when unwinding begins, exit points between - ;; the unwind point and the destination are "abandoned" and can no longer be - ;; exited to - doing so is undefined behavior. For example, the code - ;; (block nil (unwind-protect (throw something) (return))) - ;; has undefined consequences - the (return) effectively quits the throw - ;; before it can finish. - ;; An alternate X3J13 proposal, EXIT-EXTENT:MEDIUM, would have allowed this - ;; behavior. And we do too - no reason not to really. We do not abandon - ;; intervening exit points. And we indicate that by using for the call - ;; to the protected thunk the same dynamic-environment that was in place - ;; upon entry to the unwind-protect. - (let* ((nvals (%intrinsic-call "cc_nvalues" nil "nvals")) - ;; NOTE that this is kind of really dumb. We save the values, i.e. alloca - ;; a VLA, for every unwind protect executed. We could at least merge unwind - ;; protects in the same frame - but what would be really smart would be - ;; just having the exception object carry the values, so we can fuck with the - ;; global (thread-local) values with impunity while unwinding. - ;; Probably challenging to arrange in C++, though. - (mv-temp (cmp:alloca-temp-values nvals))) - (%intrinsic-call "cc_save_all_values" (list nvals mv-temp)) - (gen-call-cleanup u-p-instruction) - (%intrinsic-call "cc_load_all_values" (list nvals mv-temp)))) + ;; There is a subtle point here with regard to unwinding out of a cleanup + ;; form. CLHS 5.2 specifies that when unwinding begins, exit points between + ;; the unwind point and the destination are "abandoned" and can no longer be + ;; exited to - doing so is undefined behavior. For example, the code + ;; (block nil (unwind-protect (throw something) (return))) + ;; has undefined consequences - the (return) effectively quits the throw + ;; before it can finish. + ;; An alternate X3J13 proposal, EXIT-EXTENT:MEDIUM, would have allowed this + ;; behavior. And we do too - no reason not to really. We do not abandon + ;; intervening exit points. And we indicate that by using for the call + ;; to the protected thunk the same dynamic-environment that was in place + ;; upon entry to the unwind-protect. + (let* ((nvals (%intrinsic-call "cc_nvalues" nil "nvals")) + ;; NOTE that this is kind of really dumb. We save the values, i.e. alloca + ;; a VLA, for every unwind protect executed. We could at least merge unwind + ;; protects in the same frame - but what would be really smart would be + ;; just having the exception object carry the values, so we can fuck with the + ;; global (thread-local) values with impunity while unwinding. + ;; Probably challenging to arrange in C++, though. + (mv-temp (cmp:alloca-temp-values nvals))) + (%intrinsic-call "cc_save_all_values" (list nvals mv-temp)) + (gen-call-cleanup u-p-instruction) + (%intrinsic-call "cc_load_all_values" (list nvals mv-temp))) (cmp:irc-br next) bb))) diff --git a/src/lisp/kernel/cleavir/literal-package.lisp b/src/lisp/kernel/cleavir/literal-package.lisp new file mode 100644 index 0000000000..6da3537a60 --- /dev/null +++ b/src/lisp/kernel/cleavir/literal-package.lisp @@ -0,0 +1,14 @@ +(defpackage #:literal + (:use #:cl #:core) + (:export + #:next-value-table-holder-name + #:make-general-entry-placeholder + #:make-literal-node-call + #:make-literal-node-creator + #:literal-node-runtime-p + #:literal-node-runtime-object + #:lookup-literal-index + #:reference-literal + #:compile-reference-to-literal + #:constants-table-reference + #:constants-table-value)) diff --git a/src/lisp/kernel/cleavir/literal.lisp b/src/lisp/kernel/cleavir/literal.lisp new file mode 100644 index 0000000000..764be0052c --- /dev/null +++ b/src/lisp/kernel/cleavir/literal.lisp @@ -0,0 +1,234 @@ +(in-package #:clasp-cleavir) + +;; A vector of constants, load time values, etc. A constant's position in +;; the vector matches its position in the runtime constants vector. +(defvar *constant-indices*) + +(defvar *similarity*) + +(defstruct similarity-table + (identity (make-hash-table :test #'eq)) + ;; A few special tables for particular types we expect to see a lot of, + ;; or which can be meaningfully coalesced. + ;; Everything else gets the identity. + (number (make-hash-table :test #'eql)) + (cons (make-hash-table :test #'eq)) + (array (make-hash-table :test #'eq)) + (symbol (make-hash-table :test #'eq)) + (base-string (make-hash-table :test #'equal)) + (pathname (make-hash-table :test #'equal)) + (hash-table (make-hash-table :test #'eq)) + (fungen (make-hash-table :test #'eq)) ; also holds cfunctions + ;; The below tables are only used for file compilation, because they refer + ;; to objects that don't necessarily exist yet at compile time. + ;; For runtime compilation (COMPILE) all constants necessarily exist already. + ;; Table for LTVs; the nature of the keys is defined by the caller + ;; but have to work with an EQL table. + (ltv (make-hash-table :test #'eql)) + ;; Keyed by variable name + (vcell (make-hash-table :test #'eq)) + ;; Keyed by function name + (fcell (make-hash-table :test #'equal))) + +(defun similarity-table-for (object read-only-p &optional (simtable *similarity*)) + (if read-only-p + (typecase object + (number (similarity-table-number simtable)) + (cons (similarity-table-cons simtable)) + (array (similarity-table-array simtable)) + (symbol (similarity-table-symbol simtable)) + (base-string (similarity-table-base-string simtable)) + (pathname (similarity-table-pathname simtable)) + (t (similarity-table-identity simtable))) + (similarity-table-identity simtable))) + +(defun similar (object read-only-p &optional (simtable *similarity*)) + (gethash object (similarity-table-for object read-only-p simtable))) + +(defun (setf similar) (new object read-only-p &optional (simtable *similarity*)) + (setf (gethash object (similarity-table-for object read-only-p simtable)) new)) + +(defmacro ensure-similar (object read-only-p new-form + &optional (simtable '*similarity*)) + (let ((o (gensym "OBJECT")) (table (gensym "TABLE"))) + `(let* ((,o ,object) + (,table (similarity-table-for ,o ,read-only-p ,simtable))) + (or (gethash ,o ,table) + (setf (gethash ,o ,table) ,new-form))))) + +(defvar *make-constant-info* #'cmp:constant-info/make) + +(defun ensure-constant (constant &optional (simtable *similarity*)) + (ensure-similar constant t + (let ((info (funcall *make-constant-info* constant))) + (vector-push-extend info *constant-indices*)) + simtable)) + +(defgeneric ensure-literal-info (info &optional cinfo)) + +(defmethod ensure-literal-info ((constant-info cmp:constant-info) + &optional (cinfo constant-info)) + (ensure-similar (cmp:constant-info/value constant-info) t + (vector-push-extend cinfo *constant-indices*) + *similarity*)) +;; We adapt BIR info objects into our compiler's. +;; FIXME: Stupid +(defmethod ensure-literal-info ((constant-info bir:constant) &optional cinfo) + (let ((value (bir:constant-value constant-info))) + (ensure-similar value t + (vector-push-extend + (or cinfo (funcall *make-constant-info* value)) + *constant-indices*) + *similarity*))) + +(defmethod ensure-literal-info ((ltv-info cmp:load-time-value-info) + &optional (cinfo ltv-info)) + (let ((table (similarity-table-ltv *similarity*))) + (or (gethash ltv-info table) + (setf (gethash ltv-info table) + (vector-push-extend cinfo *constant-indices*))))) +(defmethod ensure-literal-info ((ltv-info bir:load-time-value) &optional cinfo) + (let ((table (similarity-table-ltv *similarity*))) + (or (gethash ltv-info table) + (setf (gethash ltv-info table) + (vector-push-extend + (or cinfo (cmp:load-time-value-info/make + (bir:form ltv-info) (bir:read-only-p ltv-info))) + *constant-indices*))))) + +(defmethod ensure-literal-info ((vinfo cmp:variable-cell-info) + &optional (cinfo vinfo)) + (let ((table (similarity-table-vcell *similarity*)) + (vname (cmp:variable-cell-info/vname vinfo))) + (or (gethash vname table) + (setf (gethash vname table) + (vector-push-extend cinfo *constant-indices*))))) +(defmethod ensure-literal-info ((vinfo bir:variable-cell) &optional cinfo) + (let ((table (similarity-table-vcell *similarity*)) + (vname (bir:variable-name vinfo))) + (or (gethash vname table) + (setf (gethash vname table) + (vector-push-extend + (or cinfo (cmp:variable-cell-info/make vname)) + *constant-indices*))))) + +(defmethod ensure-literal-info ((finfo cmp:function-cell-info) + &optional (cinfo finfo)) + (let ((table (similarity-table-fcell *similarity*)) + (fname (cmp:function-cell-info/fname finfo))) + (or (gethash fname table) + (setf (gethash fname table) + (vector-push-extend cinfo *constant-indices*))))) +(defmethod ensure-literal-info ((finfo bir:function-cell) &optional cinfo) + (let ((table (similarity-table-fcell *similarity*)) + (fname (bir:function-name finfo))) + (or (gethash fname table) + (setf (gethash fname table) + (vector-push-extend + (or cinfo (cmp:function-cell-info/make fname)) + *constant-indices*))))) + +(defmethod ensure-literal-info ((info cmp:env-info) &optional cinfo) + (declare (ignore cinfo)) + ;; FIXME: Make Cleavir aware of an explicit runtime environment? + (ensure-constant nil)) + +(defmethod ensure-literal-info ((info core:simple-core-fun-generator) + &optional (cinfo info)) + (let ((table (similarity-table-fungen *similarity*))) + (or (gethash info table) + (setf (gethash info table) + (vector-push-extend cinfo *constant-indices*))))) +(defmethod ensure-literal-info ((info cmp:cfunction) + &optional (cinfo info)) + (let ((table (similarity-table-fungen *similarity*))) + (or (gethash info table) + (setf (gethash info table) + (vector-push-extend cinfo *constant-indices*))))) +(defmethod ensure-literal-info ((info bir:function) &optional (cinfo info)) + (let ((table (similarity-table-fungen *similarity*))) + (or (gethash info table) + (setf (gethash info table) + (vector-push-extend cinfo *constant-indices*))))) + +;;; codegen + +(defvar *constants-vector-ir*) +(defun %constants-vector-type () cmp:%t*[0]%) + +(defun %constants-table-reference (index label) + (cmp:irc-const-gep2-64 (%constants-vector-type) + *constants-vector-ir* + 0 index + (or label "const_ref"))) + +(defun %load-constant (index label) + (cmp:irc-t*-load (%constants-table-reference index label) + (or label "const"))) + +(defun literal (constant &optional label) + (let ((immediate (core:create-tagged-immediate-value-or-nil constant))) + (if immediate + (llvm-sys:constant-expr/get-int-to-ptr (%i64 immediate) cmp:%t*% nil) + (%load-constant (ensure-constant constant) label)))) + +(defun info-literal (info &optional label) + (%load-constant + (typecase info + (bir:constant + (let ((imm (core:create-tagged-immediate-value-or-nil + (bir:constant-value info)))) + (if imm + (return-from info-literal + (llvm-sys:constant-expr/get-int-to-ptr (%i64 imm) cmp:%t*% nil)) + (ensure-literal-info info)))) + (cmp:constant-info + (let ((imm (core:create-tagged-immediate-value-or-nil + (cmp:constant-info/value info)))) + (if imm + (return-from info-literal + (llvm-sys:constant-expr/get-int-to-ptr (%i64 imm) cmp:%t*% nil)) + (ensure-literal-info info)))) + (t (ensure-literal-info info))) ; never immediate + label)) + +(defun do-constants (thunk constants constants-table-name) + (let ((*constant-indices* constants) + (*similarity* (make-similarity-table)) + ;; This is a dummy global variable that we will replace in the end. + (*constants-vector-ir* + (llvm-sys:make-global-variable cmp:*the-module* cmp:%t*[0]% + nil + 'llvm-sys:internal-linkage + nil + (concatenate 'string + constants-table-name + "-dummy")))) + (multiple-value-prog1 (multiple-value-call #'values + (funcall thunk) *constant-indices*) + ;; Replace the dummy with an array of the ultimate length. + (let* ((array-type + (llvm-sys:array-type-get cmp:%t*% (length *constant-indices*))) + (actual-table + (llvm-sys:make-global-variable + cmp:*the-module* array-type + nil 'llvm-sys:external-linkage + (llvm-sys:undef-value-get array-type) + constants-table-name))) + (llvm-sys:replace-all-uses-with *constants-vector-ir* actual-table) + (llvm-sys:erase-from-parent *constants-vector-ir*))))) + +(defmacro with-constants ((constants constants-table-name) &body body) + `(do-constants (lambda () (progn ,@body)) + ,constants ,constants-table-name)) + +(defun gen-function-vector (functions fvector-name) + (let ((type (llvm-sys:array-type-get cmp:%opaque-fn-prototype*% + (length functions)))) + (llvm-sys:make-global-variable cmp:*the-module* + type + nil 'llvm-sys:external-linkage + (llvm-sys:constant-array-get + type + (coerce functions 'list)) + fvector-name))) diff --git a/src/lisp/kernel/cleavir/packages.lisp b/src/lisp/kernel/cleavir/packages.lisp index 053172699f..6f76b94c03 100644 --- a/src/lisp/kernel/cleavir/packages.lisp +++ b/src/lisp/kernel/cleavir/packages.lisp @@ -40,8 +40,14 @@ ) (:export #:primop-rtype-info) ;; for ext:describe-compiler-policy, CL compiler macros + #-building-clasp (:implement #:ext #:cl)) +#+building-clasp +(progn + (ext:add-implementation-package '("CLASP-CLEAVIR") "EXT") + (ext:add-implementation-package '("CLASP-CLEAVIR") "CL")) + (defpackage #:clasp-cleavir-ast (:nicknames #:cc-ast) (:local-nicknames (#:ast #:cleavir-ast)) @@ -80,6 +86,7 @@ (:export #:reduce-module-instructions)) (defpackage #:clasp-cleavir-bmir + (:use #:cl) (:nicknames #:cc-bmir) (:shadow #:characterp #:consp #:load #:variable #:load-time-value) (:local-nicknames (#:bir #:cleavir-bir)) @@ -92,6 +99,7 @@ (:export #:cast-one)) (defpackage #:clasp-cleavir-blir + (:use #:cl) (:nicknames #:cc-blir) (:local-nicknames (#:bir #:cleavir-bir)) ;; Shadowing cl:load isn't strictly necessary, but will keep it from @@ -100,6 +108,7 @@ (:export #:memref2 #:offset #:load #:store #:cas)) (defpackage #:clasp-cleavir-vaslist + (:use #:cl) (:nicknames #:cc-vaslist) (:local-nicknames (#:bir #:cleavir-bir) (#:ctype #:cleavir-ctype) diff --git a/src/lisp/kernel/cleavir/policy.lisp b/src/lisp/kernel/cleavir/policy.lisp index 707cb6cacc..0f9bdacc83 100644 --- a/src/lisp/kernel/cleavir/policy.lisp +++ b/src/lisp/kernel/cleavir/policy.lisp @@ -8,7 +8,7 @@ (defmacro define-policy (name compute (&rest levels) &optional documentation) `(progn (defmethod policy:compute-policy-quality - ((quality (eql ',name)) optimize (env clasp-global-environment)) + ((client clasp) (quality (eql ',name)) optimize) (declare (ignorable optimize)) (symbol-macrolet (,@(loop for qual in +optimize-qualities+ @@ -20,10 +20,6 @@ *policy-qualities*) ',name)) -(defmethod policy:compute-policy-quality - (quality optimize (environment null)) - (policy:compute-policy-quality quality optimize *clasp-env*)) - (defmethod documentation ((name symbol) (dt (eql 'cmp:policy))) (second (assoc name *policy-descriptions*))) @@ -62,7 +58,7 @@ See TYPE-CHECK-THE for an explanation of the values.") "Should calls to pure functions with unused results be flushed, even if this will not preserve some error that the call might signal? If this policy is not in place, such calls may be flushed.") -(define-policy insert-step-conditions +(define-policy core::insert-step-conditions (>= debug 3) ((nil "no") (t "yes")) "Should the compiler insert code to signal step conditions? This adds a bit of overhead to every call.") @@ -123,12 +119,9 @@ Note that calls to functions that may box internally do not result in notes - FI (defun environment-has-policy-p (environment quality) (policy:policy-value - (cleavir-env:policy (cleavir-env:optimize-info environment)) quality)) + (cleavir-env:policy (cleavir-env:optimize-info *clasp-system* environment)) quality)) -(defmethod policy:policy-qualities append ((env clasp-global-environment)) - *policy-qualities*) -;;; FIXME: Can't just punt like normal since it's an APPEND method combo. -(defmethod policy:policy-qualities append ((env null)) +(defmethod policy:policy-qualities append ((client clasp)) *policy-qualities*) (defun ext:describe-compiler-policy (&optional optimize) @@ -136,9 +129,9 @@ Note that calls to functions that may box internally do not result in notes - FI OPTIMIZE should be the arguments of a CL:OPTIMIZE declaration specifier, e.g. ((SPEED 3) (SAFETY 1)). The policy printed is that that would be in place with current global policy augmented by the specifier. If OPTIMIZE is not provided, the unaugmented current global policy is printed." (let* ((optimize - (policy:normalize-optimize (append optimize cmp:*optimize*) - *clasp-env*)) - (policy (policy:compute-policy optimize *clasp-env*))) + (policy:normalize-optimize *clasp-system* + (append optimize cmp:*optimize*))) + (policy (policy:compute-policy *clasp-system* optimize))) (fresh-line) (format t " Optimize qualities:~%") (dolist (quality +optimize-qualities+) diff --git a/src/lisp/kernel/cmp/primitives.lisp b/src/lisp/kernel/cleavir/primitives.lisp similarity index 92% rename from src/lisp/kernel/cmp/primitives.lisp rename to src/lisp/kernel/cleavir/primitives.lisp index 12090fbdee..28c8350e79 100644 --- a/src/lisp/kernel/cmp/primitives.lisp +++ b/src/lisp/kernel/cleavir/primitives.lisp @@ -1,6 +1,6 @@ (in-package #:cmp) -(defstruct (primitive (:type vector) :named) +(defstruct primitive return-type-name argument-type-names return-attributes @@ -42,9 +42,11 @@ :returns-twice returns-twice :ltvc ltvc))))) +(defvar *primitives* (make-hash-table :test 'equal :thread-safe t)) + (defun define-primitive (name return-ty-attr args-ty-attr &key varargs does-not-throw does-not-return returns-twice ltvc) (let ((info (define-primitive-info name return-ty-attr args-ty-attr varargs does-not-throw does-not-return returns-twice ltvc))) - (funcall #'(setf gethash) info name *primitives*))) + (setf (gethash name *primitives*) info))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -63,8 +65,6 @@ "Define primitives that do NOT unwind the stack directly or through transitive calls" (define-primitive name return-ty args-ty :varargs varargs :does-not-throw t :does-not-return does-not-return :returns-twice returns-twice :ltvc ltvc)) -(defvar *primitives* (make-hash-table :test 'equal :thread-safe t)) - (defun general-entry-point-redirect-name (arity) "Return the name of the wrong-number-of-arguments function for the arity" (core:fmt nil "general_entry_point_redirect_{}" arity)) @@ -72,17 +72,7 @@ (defmacro primitives-macro () "ltvc functions are used to construct the byte-code interpreter" `(progn - ,@(mapcar (lambda (op) - (list* (if (second op) 'primitive-unwinds 'primitive) - (third op) - :ltvc-return - (list* 'list :gcroots-in-module* (fourth op)) - :ltvc t (cddddr op))) - cmpref:*startup-primitives-as-list*) - ,@'((primitive "ltvc_lookup_literal" :t* (list :gcroots-in-module* :size_t)) - (primitive "ltvc_lookup_transient" :t* (list :gcroots-in-module* :i8 :size_t)) - (primitive-unwinds "cc_register_startup_function" :void (list :size_t :fn-start-up*)) - (primitive "cc_protect_alloca" :void (list :i8*)) + ,@'((primitive "cc_protect_alloca" :void (list :i8*)) (primitive-unwinds "cc_error_type_error" :void (list :t* :t*) :does-not-return t) (primitive-unwinds "cc_error_array_out_of_bounds" :void (list :t* :t* :t*) :does-not-return t) @@ -211,19 +201,6 @@ (primitive-unwinds "cc_checkBound" :size_t (list :t* :size_t :t*)) (primitive "cc_simpleBitVectorAref" :i8 (list :t* :size_t)) (primitive "cc_simpleBitVectorAset" :void (list :t* :size_t :i8)) - (primitive "cc_initialize_gcroots_in_module" :void (list :gcroots-in-module* ; holder - :t** ; root_address - :size_t ; num_roots - :t* ; initial_data - :i8** ; transient_alloca - :size_t ; transient_entries - :size_t ; function_pointer_count - :i8** ; fptrs - )) - (primitive "cc_finish_gcroots_in_module" :void (list :gcroots-in-module*)) - (primitive "cc_remove_gcroots_in_module" :void (list :gcroots-in-module* )) - (primitive-unwinds "cc_invoke_sub_run_all_function" :void (list :fn-start-up*)) - (primitive-unwinds "cc_invoke_start_code_interpreter" :void (list :gcroots-in-module* :i8* :size_t :i8*)) (primitive "cc_verify_tag" :void (list :size_t :t* :size_t)) @@ -429,7 +406,6 @@ #+long-float (:binary80 %long-float%) #+long-float (:binary128 %long-float%) (:fn-start-up* %fn-start-up*%) - (:gcroots-in-module* %gcroots-in-module*%) (:i1 %i1%) (:i16 %i16%) (:i32 %i32%) diff --git a/src/lisp/kernel/cleavir/representation-selection.lisp b/src/lisp/kernel/cleavir/representation-selection.lisp index 728fd7fa36..fef661b704 100644 --- a/src/lisp/kernel/cleavir/representation-selection.lisp +++ b/src/lisp/kernel/cleavir/representation-selection.lisp @@ -279,6 +279,10 @@ (use-rtype (nth (position datum (bir:inputs inst)) (bir:outputs inst)))) (defmethod %use-rtype ((inst bir:jump) (datum bir:datum)) (use-rtype (nth (position datum (bir:inputs inst)) (bir:outputs inst)))) +(defmethod %use-rtype ((inst bir:throwi) (datum bir:datum)) + (ecase (position datum (bir:inputs inst)) + ((0) '(:object)) ; tag + ((1) :multiple-values))) ; returned values (defmethod %use-rtype ((inst bir:thei) (datum bir:datum)) ;; actual type tests, which need multiple values, should have been turned ;; into mv calls by this point. but out of an abundance of caution, @@ -616,6 +620,11 @@ (defmethod insert-casts ((instruction bir:unwind)) (insert-jump-coercion instruction)) +(defmethod insert-casts ((instruction bir:throwi)) + (maybe-cast-before instruction (first (bir:inputs instruction)) '(:object)) + (maybe-cast-before instruction (second (bir:inputs instruction)) + :multiple-values)) + (defmethod insert-casts ((instruction bir:call)) (object-inputs instruction) (cast-output instruction :multiple-values)) diff --git a/src/lisp/kernel/cmp/runtime-info.lisp b/src/lisp/kernel/cleavir/runtime-info.lisp similarity index 94% rename from src/lisp/kernel/cmp/runtime-info.lisp rename to src/lisp/kernel/cleavir/runtime-info.lisp index 82d8b9a9c7..10d1554b1c 100644 --- a/src/lisp/kernel/cmp/runtime-info.lisp +++ b/src/lisp/kernel/cleavir/runtime-info.lisp @@ -1,8 +1,4 @@ -;;(in-package :cmp) -(eval-when (:compile-toplevel :load-toplevel :execute) - (core:select-package :cmp)) - -(defvar +cxx-data-structures-info+ (llvm-sys:cxx-data-structures-info)) +(in-package #:cmp) (defun get-cxx-data-structure-info (name &optional (info +cxx-data-structures-info+)) (let ((find (assoc name info))) @@ -83,10 +79,6 @@ (defvar +binding-dynenv-size+ (get-cxx-data-structure-info :binding-dynenv-size)) (defvar +alignment+ (get-cxx-data-structure-info :alignment)) (defvar +args-in-registers+ (get-cxx-data-structure-info :lcc-args-in-registers)) -(export '(+fixnum-mask+ +ptag-mask+ +immediate-mask+ - +cons-tag+ - +character-tag+ +single-float-tag+ - +general-tag+ +vaslist-size+ +vaslist-alignment+ +void*-size+ +alignment+ )) (defvar +cons-car-offset+ (get-cxx-data-structure-info :cons-car-offset)) (defvar +cons-cdr-offset+ (get-cxx-data-structure-info :cons-cdr-offset)) (defvar +cons-size+ (get-cxx-data-structure-info :cons-size)) @@ -98,4 +90,3 @@ (defvar +entry-point-arity-begin+ (get-cxx-data-structure-info :entry-point-arity-begin)) (defvar +entry-point-arity-end+ (get-cxx-data-structure-info :entry-point-arity-end)) (defvar +number-of-entry-points+ (get-cxx-data-structure-info :number-of-entry-points)) - diff --git a/src/lisp/kernel/cleavir/setup.lisp b/src/lisp/kernel/cleavir/setup.lisp index d0b5aea986..01e4c5e62a 100644 --- a/src/lisp/kernel/cleavir/setup.lisp +++ b/src/lisp/kernel/cleavir/setup.lisp @@ -227,6 +227,13 @@ nil)) (cleavir-attributes:default-attributes)))) +(defun global-inline-status (name) + "Return 'cl:inline 'cl:notinline or nil" + (cond + ((core:declared-global-inline-p name) 'cl:inline) + ((core:declared-global-notinline-p name) 'cl:notinline) + (t nil))) + (defmethod env:function-info ((sys clasp) (environment clasp-global-environment) function-name) @@ -239,12 +246,12 @@ ((and (symbolp function-name) (not (null (macro-function function-name)))) (make-instance 'env:global-macro-info ; we're global, so the macro must be global. :name function-name - :inline (core:global-inline-status function-name) + :inline (global-inline-status function-name) :expander (macro-function function-name) :compiler-macro (compiler-macro-function function-name))) ((fboundp function-name) (let* ((cleavir-ast (inline-ast function-name)) - (inline-status (core:global-inline-status function-name)) + (inline-status (global-inline-status function-name)) (attributes (function-attributes function-name))) (make-instance 'env:global-function-info :name function-name @@ -261,7 +268,7 @@ :name function-name :type (global-ftype function-name) :compiler-macro (compiler-macro-function function-name) - :inline (core:global-inline-status function-name) + :inline (global-inline-status function-name) :ast (inline-ast function-name))) ( ;; If it is neither of the cases above, then this name does ;; not have any function-info associated with it. @@ -296,59 +303,32 @@ (make-instance 'env:local-macro-info :name symbol :expander (cmp:local-macro-info/expander info))))))) -(defmethod env:declarations ((environment null)) - (env:declarations *clasp-env*)) +(defmethod env:declarations ((sys clasp) (environment null)) + (env:declarations sys *clasp-env*)) ;;; TODO: Handle (declaim (declaration ...)) -(defmethod env:declarations - ((environment clasp-global-environment)) +(defmethod env:declarations ((sys clasp) (environment clasp-global-environment)) '(;; behavior as in convert-form.lisp core:lambda-name core:lambda-list)) -(defmethod env:declarations ((env cmp:lexenv)) (env:declarations *clasp-env*)) - -(eval-when (:compile-toplevel) - (format t "about to compute-policy~%")) +(defmethod env:declarations ((sys clasp) (env cmp:lexenv)) + (env:declarations sys *clasp-env*)) (setf cmp:*policy* - '#.(policy:compute-policy cmp:*optimize* *clasp-env*)) + (policy:compute-policy *clasp-system* cmp:*optimize*)) -(defmethod env:optimize-info ((environment clasp-global-environment)) +(defmethod env:optimize-info ((sys clasp) (environment clasp-global-environment)) ;; The default values are all 3. (make-instance 'env:optimize-info :optimize cmp:*optimize* :policy cmp:*policy*)) -(defmethod env:optimize-info ((environment NULL)) - (env:optimize-info *clasp-env*)) +(defmethod env:optimize-info ((sys clasp) (environment NULL)) + (env:optimize-info sys *clasp-env*)) -(defmethod env:optimize-info ((env cmp:lexenv)) +(defmethod env:optimize-info ((sys clasp) (env cmp:lexenv)) ;; FIXME: We will probably need lexenvs to track this eventually - (env:optimize-info *clasp-env*)) - - -(defmethod cleavir-environment:macro-function (symbol (environment clasp-global-environment)) - (cl:macro-function symbol)) - -(defmethod cleavir-environment:macro-function (symbol (environment null)) - (cl:macro-function symbol)) - -#+(or)(defmethod cleavir-environment:macro-function (symbol (environment core:environment)) - (cl:macro-function symbol environment)) - -#+(or)(defun cl:macro-function (symbol &optional (environment nil environment-p)) - (cond - ((typep environment 'core:environment) - (cl:macro-function symbol environment)) - (environment - (cleavir-environment:macro-function symbol environment)) - (t (cleavir-environment:macro-function symbol *clasp-env*)))) - -(defmethod cleavir-environment:symbol-macro-expansion (symbol (environment clasp-global-environment)) - (macroexpand symbol nil)) - -(defmethod cleavir-environment:symbol-macro-expansion (symbol (environment NULL)) - (macroexpand symbol nil)) + (env:optimize-info sys *clasp-env*)) ;;; Used by ext:symbol-macro (defun core:cleavir-symbol-macro (symbol environment) @@ -361,6 +341,13 @@ expansion)) nil))) +;;; Used by cl:macro-function +(defun core:cleavir-macro-function (symbol environment) + (let ((info (env:function-info *clasp-system* environment symbol))) + (if (typep info '(or env:global-macro-info env:local-macro-info)) + (env:expander info) + nil))) + ;;; Used by core:operator-shadowed-p (defun core:cleavir-operator-shadowed-p (name environment) (typep (env:function-info *clasp-system* environment name) @@ -378,7 +365,8 @@ (values (funcall def type-specifier env) t) (values type-specifier nil))))) -(defmethod env:type-expand ((environment clasp-global-environment) type-specifier) +(defmethod env:type-expand ((sys clasp) (environment clasp-global-environment) + type-specifier) ;; BEWARE: bclasp is really bad at unwinding, and mvb creates a ;; lambda, so we write this loop in a way that avoids RETURN. cclasp ;; will contify this and produce more efficient code anyway. @@ -390,8 +378,8 @@ (values type-specifier ever-expanded))))) (expand type-specifier nil))) -(defmethod env:type-expand ((environment null) type-specifier) - (env:type-expand clasp-cleavir:*clasp-env* type-specifier)) +(defmethod env:type-expand ((sys clasp) (environment null) type-specifier) + (env:type-expand sys clasp-cleavir:*clasp-env* type-specifier)) ;;; Needed because the default method ends up with classes, ;;; and that causes bootstrapping issues. @@ -434,27 +422,38 @@ next))) (env::entry (cleavir-env->bytecode (env::next env))))) -(defmethod cleavir-environment:eval (form env (dispatch-env NULL)) - "Evaluate the form in Clasp's top level environment" - (cleavir-environment:eval form env *clasp-env*)) - -(defmethod cleavir-environment:eval (form env (dispatch-env clasp-global-environment)) +(defmethod cleavir-environment:eval (form env (sys clasp)) (core:interpret form (cleavir-env->bytecode env))) (defun wrap-cst (cst) (cst:quasiquote (cst:source cst) (lambda () (cst:unquote cst)))) -(defmethod cleavir-environment:cst-eval (cst env (dispatch-env clasp-global-environment) - system) +(defmethod cleavir-environment:cst-eval (cst env (system clasp)) (declare (ignore system)) (core:interpret (cst:raw cst) (cleavir-env->bytecode env))) -(defmethod cleavir-environment:cst-eval (cst env (dispatch-env null) system) - (cleavir-environment:cst-eval cst env *clasp-env* system)) - (defmethod cmp:compiler-condition-origin ((condition cleavir-conditions:program-condition)) ;; FIXME: ignore-errors is a bit paranoid (let ((source (origin-source (cleavir-conditions:origin condition)))) (ignore-errors (if (consp source) (car source) source)))) + +(in-package #:core) + +;;; FCGE support functions, used by e.g. bytecode interpreter +(defgeneric fcge-ensure-fcell (environment name)) +(defgeneric fcge-ensure-vcell (environment name)) + +(defgeneric fcge-find-package (environment name)) + +;; Done through clostrum methods, but only in cross-clasp at the moment. +;; FIXME +(defgeneric fcge-lookup-fun (environment name)) +(defgeneric fcge-lookup-var (environment name)) + +;;; These methods are not actually necessary since the runtime treats NIL +;;; environments specially, but they're here for completeness. +(defmethod fcge-ensure-fcell ((env null) name) (ensure-function-cell name)) +(defmethod fcge-ensure-vcell ((env null) name) (ensure-variable-cell name)) +(defmethod fcge-find-package ((env null) name) (find-package name)) diff --git a/src/lisp/kernel/cleavir/transform.lisp b/src/lisp/kernel/cleavir/transform.lisp index 9b0f2cd13b..0e5c7de50d 100644 --- a/src/lisp/kernel/cleavir/transform.lisp +++ b/src/lisp/kernel/cleavir/transform.lisp @@ -167,41 +167,42 @@ Optimizations are available for any of: :origin (origin-source (bir:origin call))))))))) (defmacro %deftransformation (name) - `(eval-when (:compile-toplevel :load-toplevel :execute) + `(progn (setf (gethash ',name *bir-transformers*) nil) (setf (gethash ',name *fn-transforms*) '(,name)) ',name)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun vtype= (vtype1 vtype2) - (and (ctype:values-subtypep vtype1 vtype2 *clasp-system*) - (ctype:values-subtypep vtype2 vtype1 *clasp-system*))) - (defun vtype< (vtype1 vtype2) - (and (ctype:values-subtypep vtype1 vtype2 *clasp-system*) - ;; This also includes NIL NIL, but that probably won't happen - ;; if the first subtypep returns true - (not (ctype:values-subtypep vtype2 vtype1 *clasp-system*)))) - (defun %def-bir-transformer (name function argstype) - ;; We just use a reverse alist (function . argstype). - (let* ((transformers (gethash name *bir-transformers*)) - (existing (rassoc argstype transformers :test #'vtype=))) - (if existing - ;; replace - (setf (car existing) function) - ;; Merge in, respecting subtypep - (setf (gethash name *bir-transformers*) - (merge 'list (list (cons function argstype)) - (gethash name *bir-transformers*) - #'vtype< :key #'cdr)))))) +(defun vtype= (vtype1 vtype2) + (and (ctype:values-subtypep vtype1 vtype2 *clasp-system*) + (ctype:values-subtypep vtype2 vtype1 *clasp-system*))) +(defun vtype< (vtype1 vtype2) + (and (ctype:values-subtypep vtype1 vtype2 *clasp-system*) + ;; This also includes NIL NIL, but that probably won't happen + ;; if the first subtypep returns true + (not (ctype:values-subtypep vtype2 vtype1 *clasp-system*)))) +(defun %def-bir-transformer (name function argstype) + ;; We just use a reverse alist (function . argstype). + (let* ((transformers (gethash name *bir-transformers*)) + (existing (rassoc argstype transformers :test #'vtype=))) + (if existing + ;; replace + (setf (car existing) function) + ;; Merge in, respecting subtypep + (setf (gethash name *bir-transformers*) + (merge 'list (list (cons function argstype)) + (gethash name *bir-transformers*) + #'vtype< :key #'cdr))))) (defmacro %deftransform (name lambda-list argstype &body body) - (let ((argstype (env:parse-values-type-specifier argstype nil *clasp-system*))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (nth-value 1 (gethash ',name *bir-transformers*)) - (%deftransformation ,name)) - (%def-bir-transformer ',name (lambda ,lambda-list ,@body) ',argstype) - ',name))) + `(progn + (unless (nth-value 1 (gethash ',name *bir-transformers*)) + (%deftransformation ,name)) + (%def-bir-transformer ',name (lambda ,lambda-list ,@body) + (load-time-value (env:parse-values-type-specifier + ',argstype nil *clasp-system*) + t)) + ',name)) ;;; Given an expression, make a CST for it. ;;; FIXME: This should be more sophisticated. I'm thinking the source info @@ -238,9 +239,9 @@ Optimizations are available for any of: ;;; rest parts of the lambda list, and three for the corresponding types. ;;; This function returns two values: An ordinary lambda list and an ;;; unparsed values type representing the arguments. +(eval-when (:compile-toplevel :load-toplevel :execute) (defun process-deftransform-lambda-list (lambda-list) (loop with state = :required - with sys = *clasp-system* with reqparams = nil with optparams = nil with restparam = nil @@ -276,6 +277,7 @@ Optimizations are available for any of: restparam (nreverse reqtypes) (nreverse opttypes) resttype)))) +) (defmacro deftransform (name (typed-lambda-list &key (argstype (gensym "ARGSTYPE") argstypep) @@ -345,6 +347,28 @@ Optimizations are available for any of: (maybe-expand-typep type 'object)))) (decline-transform "non-constant type specifier"))))) +(deftransform core::%the-single (((tspec t) (value t)) :argstype args) + (with-transformer-types (tspec value) args + (declare (ignore value)) + (let ((sys *clasp-system*)) + (if (and (ctype:member-p sys tspec) + (= (length (ctype:member-members sys tspec)) 1)) + (let ((tspec (first (ctype:member-members sys tspec)))) + `(the (values ,tspec &rest nil) value)) + ;; the-single is only used internally, so a failure here is weird + (decline-transform "BUG: non-constant type specifier"))))) +(deftransform core::%the-single-return + (((tspec t) (value t) (return t)) :argstype args) + (with-transformer-types (tspec value return) args + (declare (ignore value return)) + (let ((sys *clasp-system*)) + (if (and (ctype:member-p sys tspec) + (= (length (ctype:member-members sys tspec)) 1)) + (let ((tspec (first (ctype:member-members sys tspec)))) + `(progn (the (values ,tspec &rest nil) value) return)) + ;; the-single is only used internally, so a failure here is weird + (decline-transform "BUG: non-constant type specifier"))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; (5) DATA AND CONTROL FLOW @@ -720,17 +744,16 @@ Optimizations are available for any of: collect (ctype:primary (bir:ctype arg) sys)) nil (ctype:bottom sys) sys))))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun parse-flusher-type (type) - (let ((opt (member '&optional type)) - (rest (member '&rest type)) - (sys *clasp-system*)) - (flet ((parse1 (ty) (env:parse-type-specifier ty nil sys))) - (ctype:values - (mapcar #'parse1 (ldiff type (or opt rest))) - (mapcar #'parse1 (rest (ldiff opt rest))) - (if rest (parse1 (second rest)) (ctype:bottom sys)) - sys))))) +(defun parse-flusher-type (type) + (let ((opt (member '&optional type)) + (rest (member '&rest type)) + (sys *clasp-system*)) + (flet ((parse1 (ty) (env:parse-type-specifier ty nil sys))) + (ctype:values + (mapcar #'parse1 (ldiff type (or opt rest))) + (mapcar #'parse1 (rest (ldiff opt rest))) + (if rest (parse1 (second rest)) (ctype:bottom sys)) + sys)))) ;;; Flush unless we're in safe code. (defmacro defflusher-unsafe (name) `(defflusher ,name (call) nil)) @@ -750,7 +773,7 @@ Optimizations are available for any of: `(defflusher ,name (call) (values (ctype:values-subtypep (call-argstype call) - ',(parse-flusher-type type) + (load-time-value (parse-flusher-type ',type) t) *clasp-system*)))) (defflusher-type special-operator-p symbol) diff --git a/src/lisp/kernel/cleavir/translate-btb.lisp b/src/lisp/kernel/cleavir/translate-btb.lisp deleted file mode 100644 index d08053aee1..0000000000 --- a/src/lisp/kernel/cleavir/translate-btb.lisp +++ /dev/null @@ -1,527 +0,0 @@ -(defpackage #:clasp-cleavir-2 - (:use #:cl) - (:local-nicknames (#:cc #:clasp-cleavir) - (#:bir #:cleavir-bir) - (#:bir-transformations #:cleavir-bir-transformations) - (#:ast #:cleavir-ast) - (#:ctype #:cleavir-ctype) - (#:cst-to-ast #:cleavir-cst-to-ast) - (#:build #:cleavir-bir-builder) - (#:env #:cleavir-env) - (#:policy #:cleavir-compilation-policy))) - -(in-package #:clasp-cleavir-2) - -;;; Backend information associated with a BIR function. -(defclass llvm-function-info () - (;; In BIR, function environments are sets but we'd like to have it - ;; be a list to ensure ordering. - (%environment :initarg :environment :type list :reader cc::environment) - ;; The argument variables of the function lambda list. - (%arguments :initarg :arguments :type list :reader core:arguments) - (%main-function :initarg :main-function :reader cc::main-function) - (%general-xep :initarg :general-xep :reader general-xep) - (%fixed-xeps :initarg :fixed-xeps :reader fixed-xeps - ;; obviously null <: sequence but this is more explicit. - :type (or null sequence)) - ;; The global variable holding an array of the XEP pointers. - (%xep :initarg :xep :reader xep) - ;; These should be obtainable from llvm-sys:get-name, but that seems to - ;; return "" for functions after some point. Weird. FIXME - (%main-function-name :initarg :main-function-name - :reader main-function-name) - (%xep-name :initarg :xep-name :reader xep-name))) - -;;; Result of TRANSLATE (below) containing everything needed for -;;; a compiled Lisp module: -;;; An LLVM-IR module, a map from BIR functions to function infos, -;;; and a constants map (from BIR constants etc. to either indices, -;;; or LLVM values for immediates). -(defclass translation () - ((%module :initarg :module :reader module) - (%constant-values :initarg :constant-values :reader constant-values) - (%function-info :initarg :function-info :reader function-info))) - -(defun allocate-llvm-function-info (function &key toplevels) - (let* ((lambda-name (cc::get-or-create-lambda-name function)) - (jit-function-name (cc::jit-function-name lambda-name)) - (arguments (cc::compute-arglist (bir:lambda-list function))) - (mtype (cc::compute-llvm-function-type function arguments)) - (xep-p (or (member function toplevels) (xep-needed-p function))) - (analysis (cmp:calculate-cleavir-lambda-list-analysis - (bir:lambda-list function))) - (main-function - (cmp:irc-function-create - mtype 'llvm-sys:external-linkage - (concatenate 'string jit-function-name ".main") - cmp:*the-module*)) - (general-xep - (when xep-p - (cmp:irc-function-create - (cmp:fn-prototype :general-entry) 'llvm-sys:external-linkage - (concatenate 'string jit-function-name ".xep-general") - cmp:*the-module*))) - (fixed-xeps - (when xep-p - (loop for i from cmp:+entry-point-arity-begin+ - below cmp:+entry-point-arity-end+ - for name = (format nil "~a.xep-~d" jit-function-name i) - collect (if (cmp::generate-function-for-arity-p i analysis) - (cmp:irc-function-create - (cmp:fn-prototype i) - 'llvm-sys:external-linkage name - cmp:*the-module*) - :placeholder)))) - (xep - (when xep-p - (let* ((name (concatenate 'string jit-function-name ".xep")) - ;; We rely on opaque pointer types here. Without them, - ;; we'd have to do some bitcasting. - (ptype (llvm-sys:type-get-pointer-to cmp:%void%)) - (xtype (llvm-sys:array-type-get - ptype - (1+ cmp:+entry-point-arity-end+))) - (null (llvm-sys:constant-pointer-null-get ptype)) - (init (llvm-sys:constant-array-get - xtype - (list* general-xep - (loop for f in fixed-xeps - collect (if (eq f :placeholder) - null - f)))))) - (llvm-sys:make-global-variable cmp:*the-module* xtype nil - 'llvm-sys:external-linkage - init name)))) - ;; Check for a forced closure layout first. - ;; if there isn't one, make one up. - (env (or (cc::fixed-closure function) - (cleavir-set:set-to-list - (bir:environment function))))) - (make-instance 'llvm-function-info - :environment env - :arguments arguments - :main-function main-function - :general-xep general-xep - :fixed-xeps fixed-xeps - :xep xep - :main-function-name (llvm-sys:get-name main-function) - :xep-name (when xep-p (llvm-sys:get-name xep))))) - -;;; See if a function needs a XEP based on the IR. -;;; Note that the toplevel function (i.e. the one returned by CL:COMPILE) -;;; also gets a XEP, but it's handled differently. -(defun xep-needed-p (function) - (or (bir:enclose function) - ;; We need a XEP for more involved lambda lists. - (cc::lambda-list-too-hairy-p (bir:lambda-list function)) - ;; or for mv-calls that might need to signal an error. - (and (cleavir-set:some #'cc::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)))))) - -(defun allocate-module-constants (module) - (let ((i 0)) - ;; Functions: If a XEP is needed, put in space for one - ;; except for toplevel functions, which don't need space in the - ;; literals vector as nothing inside the code references them. - (bir:do-functions (function module) - (when (xep-needed-p function) - ;; Keys in the *constant-values* table are usually BIR:CONSTANTs and - ;; stuff. So there is no possibility of overlap between a BIR:FUNCTION - ;; and a BIR:FUNCTION that literally appears in the code somehow. - (setf (gethash function cc::*constant-values*) i) - (incf i))) - ;; Actual constants - (cleavir-set:doset (value (bir:constants module)) - (let ((immediate (core:create-tagged-immediate-value-or-nil value))) - (setf (gethash value cc::*constant-values*) - (if immediate - (cmp:irc-int-to-ptr (cc::%i64 immediate) cmp:%t*%) - (prog1 i (incf i)))))) - i)) - -(defun nconstants () - (loop for value being the hash-values of cc::*constant-values* - maximizing (if (integerp value) (1+ value) 0))) - -;; A constant introduced at translate time. We use this instead of -;; bir:constant just to avoid any unneeded silliness with BIR modules -;; and backpointers. -(defclass last-minute-constant () - ((%value :initarg :value :reader bir:constant-value))) - -(defun reference-literal (value &optional read-only-p) - (declare (ignore read-only-p)) - (let ((next-index - ;; Check for an existing constant. - ;; While we're doing that, also check what a new constant - ;; index would be. - (loop for key being the hash-keys of cc::*constant-values* - using (hash-value indexoid) - when (and (typep key '(or bir:constant last-minute-constant)) - (eql (bir:constant-value key) value)) - do (return-from reference-literal - (values indexoid (integerp indexoid))) - maximizing (if (integerp indexoid) (1+ indexoid) 0))) - (immediate (core:create-tagged-immediate-value-or-nil value)) - (constant (make-instance 'last-minute-constant :value value))) - (if immediate - (values (setf (gethash constant cc::*constant-values*) - (cmp:irc-int-to-ptr (cc::%i64 immediate) cmp:%t*%)) - nil) - (values (setf (gethash constant cc::*constant-values*) next-index) t)))) - -(defun layout-xep-function* (xep arity ir lambda-list-analysis calling-convention) - (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"))) - ;; Import cells. - (let* ((closure-vec (first (llvm-sys:get-argument-list xep))) - (llvm-function-info (cc::find-llvm-function-info ir)) - (environment-values - (loop for import in (cc::environment llvm-function-info) - for i from 0 - for offset = (cmp:%closure%.offset-of[n]/t* i) - when import ; skip unused fixed closure entries - collect (cmp:irc-t*-load-atomic - (cmp::gen-memref-address closure-vec offset)))) - (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))))))) - xep) - -(defun layout-xep-function (xep arity ir lambda-list-analysis lambda-name) - ;; XEP is the LLVM function we are creating. - (let* ((cc::*datum-values* (make-hash-table :test #'eq)) - (jit-function-name (cc::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")) - (llvm-function-type (cmp:fn-prototype arity)) - (cmp:*current-function* xep) - (entry-block (cmp:irc-basic-block-create "entry" xep)) - (cc::*function-current-multiple-value-array-address* nil) - (cmp:*irbuilder-function-alloca* - (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)))))))) - -(defun layout-xep-group (function lambda-name abi) - (declare (ignore abi)) - ;; This goes way up here because we want it only noted once, not - ;; once for each arity we happen to emit. - (cc::maybe-note-return-cast function) - (let ((info (cc::find-llvm-function-info function)) - (analysis - (cmp:calculate-cleavir-lambda-list-analysis - (bir:lambda-list function)))) - (layout-xep-function (general-xep info) :general-entry - function analysis lambda-name) - (loop for xep in (fixed-xeps info) - for arity from 0 - unless (eq xep :placeholder) - do (layout-xep-function xep arity function analysis lambda-name)))) - -(defmacro with-literals (&body body) - `(let ((cmp:*load-time-value-holder-global-var-type* cmp:%t*[DUMMY]%) - (cmp:*load-time-value-holder-global-var* - (llvm-sys:make-global-variable cmp:*the-module* - cmp:%t*[DUMMY]% ; type - nil ; isConstant - 'llvm-sys:external-linkage - (llvm-sys:undef-value-get cmp:%t*[DUMMY]%) - "literals-DUMMY"))) - ,@body - ;; Now that the body has been run, we know exactly how many literals - ;; there are. As such, we can replace the array. - (let* ((arrayt - (llvm-sys:array-type-get cmp:%t*% (nconstants))) - (new-holder - (llvm-sys:make-global-variable cmp:*the-module* - arrayt - nil ; isConstant - 'llvm-sys:external-linkage - (llvm-sys:undef-value-get arrayt) - "__clasp_literals_")) - (bcast - (cmp:irc-bit-cast new-holder cmp:%t*[DUMMY]*% "bitcast-literals"))) - (llvm-sys:replace-all-uses-with cmp:*load-time-value-holder-global-var* - bcast) - (llvm-sys:erase-from-parent cmp:*load-time-value-holder-global-var*)) - (values))) - -(defun layout-procedure (function lambda-name abi &key toplevels) - (when (or (member function toplevels) (xep-needed-p function)) - (layout-xep-group function lambda-name abi)) - (cc::layout-main-function function lambda-name abi)) - -(defun layout-module (module abi &key toplevels) - ;; Create llvm IR functions for each BIR function. - (bir:do-functions (function module) - ;; Assign IDs to unwind destinations. We start from 1 to allow - ;; things to work with setjmp, which cannot return 0 from longjmp. - (let ((i 1)) - (cleavir-set:doset (entrance (bir:entrances function)) - (setf (gethash entrance cc::*unwind-ids*) i) - (incf i))) - (setf (gethash function cc::*function-info*) - (allocate-llvm-function-info function :toplevels toplevels))) - (with-literals - (allocate-module-constants module) - (bir:do-functions (function module) - (layout-procedure function (cc::get-or-create-lambda-name function) - abi :toplevels toplevels)))) - -(defun compute-debug-namestring (bir) - (if bir - (let ((origin (bir:origin bir))) - (if origin - (namestring - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle origin)))) - "repl-code")) - "repl-code")) - -(defun translate (bir-module - &key abi (name "compile") toplevels debug-namestring) - (unless debug-namestring - (setf debug-namestring (compute-debug-namestring (first toplevels)))) - (let ((module (cmp::llvm-create-module name)) - (cc::*unwind-ids* (make-hash-table :test #'eq)) - (cc::*constant-values* (make-hash-table :test #'eq)) - (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)) - (cmp:irc-verify-module-safe module) - (cmp::potentially-save-module)) - (make-instance 'translation - :module module :constant-values cc::*constant-values* - :function-info cc::*function-info*))) - -(defmethod cc::reference-xep (function (info llvm-function-info)) - (let ((cindex (or (gethash function cc::*constant-values*) - (error "BUG: Tried to ENCLOSE a function with no XEP")))) - (literal:constants-table-value cindex))) - -(defun bir->function (bir &key (abi cc::*abi-x86-64*)) - (let* ((translation - (translate (bir:module bir) :abi abi :toplevels (list bir))) - (module (module translation)) - (constants (constant-values translation)) - (cc::*function-info* (function-info translation)) - (jit (llvm-sys:clasp-jit)) - (dylib (llvm-sys:create-and-register-jitdylib jit "repl")) - (object (llvm-sys:add-irmodule jit dylib module - cmp:*thread-safe-context* 0))) - (declare (ignore object)) - (fill-constants jit dylib constants) - (let ((existing (gethash bir constants))) - (if existing - ;; There will already be a compiled fun in the literals - ;; if it's e.g. enclosed. - (core:literals-vref (llvm-sys:lookup jit dylib "__clasp_literals_") - existing) - ;; Otherwise, make a new function. - (make-compiled-fun jit dylib (make-function-description bir) - (cc::find-llvm-function-info bir)))))) - -;;; Return code for an IRMODULE as bytes. -;;; Used in COMPILE-FILE (specifically in compile-bytecode.lisp). -(defun emit-module (module) - (let* ((triple-string (llvm-sys:get-target-triple module)) - (normalized-triple-string - (llvm-sys:triple-normalize triple-string)) - (triple (llvm-sys:make-triple normalized-triple-string)) - (target-options (llvm-sys:make-target-options))) - (multiple-value-bind (target msg) - (llvm-sys:target-registry-lookup-target "" triple) - (unless target - (error msg)) - (llvm-sys:emit-module (llvm-sys:create-target-machine target - (llvm-sys:get-triple triple) - "" - "" - target-options - cmp::*default-reloc-model* - (cmp::code-model :jit nil) - 'llvm-sys:code-gen-opt-default - nil) - :simple-vector-byte8 - nil ; dwo-stream for dwarf objects - 'llvm-sys:code-gen-file-type-object-file - module)))) - -(defgeneric resolve-constant (ir)) - -(defmethod resolve-constant ((ir bir:constant)) - (bir:constant-value ir)) -(defmethod resolve-constant ((ir last-minute-constant)) - (bir:constant-value ir)) - -(defmethod resolve-constant ((ir bir:load-time-value)) - (eval (bir:form ir))) - -(defmethod resolve-constant ((ir bir:function-cell)) - (core:ensure-function-cell (bir:function-name ir))) - -(defmethod resolve-constant ((ir bir:variable-cell)) - (core:ensure-variable-cell (bir:variable-name ir))) - -(defun fill-constants (jit dylib constants) - (let ((literals (llvm-sys:lookup jit dylib "__clasp_literals_"))) - (loop for value being the hash-keys of constants - using (hash-value cinf) - ;; cinf is either a fixnum, meaning a literal, - ;; or an llvm Value, meaning an immediate. - ;; We don't need to do anything for immediates. - ;; We also need to handle functions a bit differently- building - ;; a simple fun for them. - if (typep value 'bir:function) - do (setf (cmp:literals-vref literals cinf) - (make-compiled-fun jit dylib - (make-function-description value) - (cc::find-llvm-function-info value))) - else if (integerp cinf) - do (setf (core:literals-vref literals cinf) - (resolve-constant value)))) - (values)) - -(defun make-function-description (irfun) - (let ((spi (cc::origin-spi (cc::origin-source (bir:origin irfun))))) - (if spi - (sys:function-description/make - :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))) - :lineno (core:source-pos-info-lineno spi) - ;; Why 1+? - :column (1+ (core:source-pos-info-column spi)) - :filepos (core:source-pos-info-filepos spi)) - (sys:function-description/make - :function-name (cc::get-or-create-lambda-name irfun) - :lambda-list (bir:original-lambda-list irfun) - :docstring (bir:docstring irfun) - :source-pathname "-unknown-file-")))) - -(defun make-compiled-fun (jit dylib fdesc info) - (let ((main (llvm-sys:lookup jit dylib (main-function-name info))) - (xep (llvm-sys:lookup jit dylib (xep-name info)))) - (core:make-simple-core-fun fdesc main xep))) - -(in-package #:clasp-bytecode-to-bir) - -(defmethod bir-constant->cmp ((constant clasp-cleavir-2::last-minute-constant)) - (cmp:constant-info/make (bir:constant-value constant))) - -(defun compute-native-fmap (funmap function-info) - (loop for (bcfun irfun) in (fmap funmap) - for info = (gethash irfun function-info) - for main = (clasp-cleavir-2::main-function-name info) - for xep = (clasp-cleavir-2::xep-name info) - collect (list bcfun main xep))) - -(defun compile-cmodule (bytecode annotations literals - &key debug-namestring - (system clasp-cleavir:*clasp-system*) - (abi clasp-cleavir:*abi-x86-64*)) - (let* ((irmod (make-instance 'bir:module)) - (cliterals (compute-compile-literals literals)) - (funmap - (compile-bytecode-into bytecode annotations cliterals irmod)) - (_ (clasp-cleavir::bir-transformations irmod system)) - (translation - (clasp-cleavir-2::translate - irmod :debug-namestring debug-namestring :abi abi - ;; All IR functions with a corresponding bytecode function - ;; need a XEP, so they can be put in the bytecode function. - :toplevels (mapcar #'second (fmap funmap)))) - (nliterals (compute-nliterals cliterals (clasp-cleavir-2::constant-values translation))) - (lmod (clasp-cleavir-2::module translation)) - (code (clasp-cleavir-2::emit-module lmod)) - (fmap (compute-native-fmap funmap (clasp-cleavir-2::function-info translation)))) - (declare (ignore _)) - (make-instance 'nmodule :code code :fmap fmap :literals nliterals))) - -(defun compile-function (function - &key (abi clasp-cleavir:*abi-x86-64*) - (system clasp-cleavir:*clasp-system*) - (disassemble nil)) - (multiple-value-bind (module funmap) - (compile-bcmodule (core:simple-fun-code function)) - (bir:verify module) - (when disassemble - (cleavir-bir-disassembler:display module)) - (clasp-cleavir::bir-transformations module system) - (let ((cleavir-cst-to-ast:*compiler* 'cl:compile) - ;; Ensure any closures have the same layout as original - ;; bytecode closures, so the simple fun can be swapped - ;; out transparently. - (clasp-cleavir::*fixed-closures* - (fixed-closures-map (fmap funmap))) - (bir (finfo-irfun (find-bcfun function funmap)))) - (clasp-cleavir-2::bir->function bir :abi abi)))) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 2b460ec3a6..d229b5be9a 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1,9 +1,5 @@ (in-package #:clasp-cleavir) -#+(or) -(eval-when (:execute) - (setq core:*echo-repl-read* t)) - ;;; Backend information associated with a BIR function. (defclass llvm-function-info () (;; In BIR, function environments are sets but we'd like to have it @@ -13,9 +9,13 @@ (%arguments :initarg :arguments :type list :reader arguments) ;; The eXternal Entry Point is in charge of loading values and ;; cells from the closure vector and parsing the number of arguments. + ;; This is :xep-unallocated if it was determined that no XEP is needed. (%xep-function :initarg :xep-function :reader xep-function) (%xep-function-description :initarg :xep-function-description :reader xep-function-description) - (%main-function :initarg :main-function :reader main-function))) + (%main-function :initarg :main-function :reader main-function) + ;; The constant (info) to use if we need to enclose at runtime. + ;; NIL if there's no XEP. + (%prototype :initarg :prototype :reader prototype))) (defun lambda-list-too-hairy-p (lambda-list) (multiple-value-bind (reqargs optargs rest-var key-flag keyargs aok aux varest-p) @@ -99,41 +99,125 @@ collect cmp:%t*%) (mapcar #'argument-rtype->llvm arguments)))) -(defun allocate-llvm-function-info (function &key (linkage 'llvm-sys:internal-linkage)) +(defstruct xep-arity + "This describes one arity/entry-point for a 'xep-group'. +arity: - the arity of the function (:general-entry or an integer 0...n) +function-or-placeholder - the llvm function or a placeholder for + the literal compiler to generate a pointer + to a fixed arity trampoline. " + arity + function-or-placeholder + ) + +(defstruct general-entry-placeholder arity) + +(defun make-1-xep-arity (arity function-name cleavir-lambda-list-analysis module) + (let* ((xep-function-name (format nil "~a-xep~a" function-name + (if (eq arity :general-entry) + "" + arity))) + (fn (if (cmp:generate-function-for-arity-p + arity cleavir-lambda-list-analysis) + (cmp:irc-function-create (cmp:fn-prototype arity) + 'llvm-sys:internal-linkage + xep-function-name module) + (make-general-entry-placeholder :arity arity)))) + (make-xep-arity :arity arity :function-or-placeholder fn))) + +(defun make-xep-arities (function-name cleavir-lambda-list-analysis module) + (list* (make-1-xep-arity :general-entry function-name + cleavir-lambda-list-analysis module) + (loop for arity from cmp:+entry-point-arity-begin+ + below cmp:+entry-point-arity-end+ + collect (make-1-xep-arity arity function-name + cleavir-lambda-list-analysis module)))) + +(defun wna-for (arity) + ;; Look up a wrong-number-of-arguments function for a given arity. + ;; What it actually does is call the general-arity XEP, which is + ;; always generated and always able to signal the right error + ;; when given the wrong arguments. + (cmp:get-or-declare-function-or-error + cmp:*the-module* + (cmp:general-entry-point-redirect-name arity))) + +(defun register-local-function-index (function fvector) + (vector-push-extend function fvector)) +(defun register-xep-function-indices (funs-placeholders fvector) + (loop for raw in funs-placeholders + for fun = (if (general-entry-placeholder-p raw) + (wna-for (general-entry-placeholder-arity raw)) + raw) + collect (vector-push-extend fun fvector))) + +(defun make-xep-group (the-function function-name lambda-list-analysis + function-description + local-fun-generator fvector) + (let* ((xep-arities (make-xep-arities function-name lambda-list-analysis + cmp:*the-module*)) + (xep-indices (register-xep-function-indices + (mapcar #'xep-arity-function-or-placeholder xep-arities) + fvector)) + (generator + (core:make-simple-core-fun-generator + :entry-point-functions xep-indices + :function-description function-description + :core-fun-generator local-fun-generator))) + (cmp:make-xep-group :name function-name + :cleavir-lambda-list-analysis lambda-list-analysis + :arities xep-arities + :generator generator + :local-function the-function))) + +;;; Given a BIR function, create the actual LLVM functions for the local +;;; and XEP functions, along with the function description and so on. +;;; if PROTOTYPE is provided, it will be used as the constant if this +;;; function is enclosed; otherwise a simple core fun generator +;;; will be used. Providing a prototype also forces a XEP to be generated. +(defun allocate-llvm-function-info (function fvector + &optional prototype) (let* ((lambda-name (get-or-create-lambda-name function)) (jit-function-name (jit-function-name lambda-name)) (function-info (calculate-function-info function lambda-name)) (arguments (compute-arglist (bir:lambda-list function))) - (function-description (cmp:irc-make-function-description function-info jit-function-name))) - (multiple-value-bind (the-function local-fun) - (cmp:irc-local-function-create - (compute-llvm-function-type function arguments) - 'llvm-sys:internal-linkage ;; was llvm-sys:private-linkage - jit-function-name - cmp:*the-module* - function-description) - (let ((xep-group (if (xep-needed-p function) - (cmp:irc-xep-functions-create (cmp:function-info-cleavir-lambda-list-analysis function-info) - linkage - jit-function-name - cmp:*the-module* - function-description - the-function - local-fun) - :xep-unallocated)) - ;; Check for a forced closure layout first. - ;; if there isn't one, make one up. - (env (or (fixed-closure function) - (cleavir-set:set-to-list - (bir:environment function))))) - (make-instance 'llvm-function-info - :environment env - :main-function the-function - :xep-function xep-group - :xep-function-description (if (eq xep-group :xep-unallocated) - xep-group - function-description) - :arguments arguments))))) + (function-description (cmp:irc-make-function-description function-info jit-function-name)) + (the-function + (cmp:irc-function-create + (compute-llvm-function-type function arguments) + 'llvm-sys:internal-linkage ;; was llvm-sys:private-linkage + (concatenate 'string jit-function-name "-lcl") + cmp:*the-module*)) + (local-fun-index (register-local-function-index the-function fvector)) + (core-generator (core:make-core-fun-generator + :entry-point-functions (list local-fun-index) + :function-description function-description)) + (xep-group (if (or prototype (xep-needed-p function)) + (make-xep-group the-function jit-function-name + (cmp:function-info-cleavir-lambda-list-analysis function-info) + function-description + core-generator fvector) + :xep-unallocated)) + ;; Check for a forced closure layout first. + ;; if there isn't one, make one up. + (env (or (fixed-closure function) + (cleavir-set:set-to-list + (bir:environment function))))) + (make-instance 'llvm-function-info + :environment env + :main-function the-function + :xep-function xep-group + :xep-function-description (if (eq xep-group :xep-unallocated) + xep-group + function-description) + :prototype (cond ((eq :xep-unallocated xep-group) nil) + (prototype) + ((cmp:xep-group-generator xep-group))) + :arguments arguments))) + +(defun allocate-llvm-function-infos (module fvector) + (bir:do-functions (function module) + (setf (gethash function *function-info*) + (allocate-llvm-function-info function fvector)))) (defun fixed-closure (function) (let ((fixed (cdr (assoc function *fixed-closures*)))) @@ -543,22 +627,11 @@ (defmethod translate-terminator ((instruction bir:throwi) abi next) (declare (ignore abi next)) + (save-multiple-value-0 (in (second (bir:inputs instruction)))) (%intrinsic-invoke-if-landing-pad-or-call "cc_throw" (list (in (first (bir:inputs instruction))))) (cmp:irc-unreachable)) -(defun gen-call-cleanup (uwprotect-inst) - (multiple-value-bind (ind old old-destack) - (bind-special (literal:constants-table-value - (literal:reference-variable-cell - 'core:*interrupts-enabled*) - :literal-name "*INTERRUPTS-ENABLED*") - (%nil)) - (cmp:with-landing-pad (maybe-entry-landing-pad - (bir:parent uwprotect-inst) *tags*) - (closure-call-or-invoke (in (first (bir:inputs uwprotect-inst))) nil)) - (unbind-special ind old old-destack))) - (defmethod translate-terminator ((instruction bir:unwind-protect) abi next) (declare (ignore abi)) (let* ((cleanup (cmp:irc-basic-block-create "unwind-protect-cleanup")) @@ -610,7 +683,7 @@ (defmethod translate-terminator ((instruction bir:constant-bind) abi next) (declare (ignore abi)) (let* ((inputs (bir:inputs instruction)) - (cellv (translate-constant-value (first inputs))) + (cellv (info-literal (first inputs))) (val (in (second inputs)))) (setf (dynenv-storage instruction) (multiple-value-list (bind-special cellv val)))) @@ -631,20 +704,13 @@ (defun maybe-insert-step-before (inst) (when (policy:policy-value (bir:policy inst) - 'insert-step-conditions) + 'core::insert-step-conditions) (let ((origin (bir:origin inst))) (when (typep origin 'cst:cst) (let* ((frame (%intrinsic-call "llvm.frameaddress.p0" (list (%i32 0)) "stepper-frame")) (raw (cst:raw origin)) - ;; See #1376: Sometimes the source form will be an immediate. - ;; This may be due to inadequacies in constant folding. - (lit - (handler-case - (literal:compile-reference-to-literal raw) - (serious-condition () - (literal:compile-reference-to-literal - ""))))) + (lit (literal raw))) (%intrinsic-invoke-if-landing-pad-or-call "cc_breakstep" (list lit frame))))))) @@ -658,7 +724,7 @@ (defun maybe-insert-step-after (inst) (when (and (policy:policy-value (bir:policy inst) - 'insert-step-conditions) + 'core::insert-step-conditions) (typep (bir:origin inst) 'cst:cst)) ;; OK, we inserted a cc_breakstep call in the above method, ;; so now we need to put in the cc_breakstep_after to support @@ -756,21 +822,17 @@ (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)) -(defmethod reference-xep (function (function-info llvm-function-info)) - (declare (ignore function)) - (let* ((enclosed-xep-group (xep-function function-info)) - (entry-point-reference (cmp:xep-group-entry-point-reference enclosed-xep-group))) - (when (eq enclosed-xep-group :xep-unallocated) +;;; Get a reference to a literal for a function's simple fun. +(defun reference-xep (function-info) + (let ((info (prototype function-info))) + (unless info (error "BUG: Tried to ENCLOSE a function with no XEP")) - (literal:constants-table-value (cmp:entry-point-reference-index entry-point-reference)))) + (info-literal info))) (defun enclose (function extent &optional (delay t)) (let* ((code-info (find-llvm-function-info function)) (environment (environment code-info)) - (xepc (reference-xep function code-info))) + (xepc (reference-xep code-info))) (if environment (let* ((ninputs (length environment)) (sninputs (%size_t ninputs)) @@ -1236,7 +1298,7 @@ (cmp:irc-vaslist-values inputv)))) ((and (listp outputrt) (= (length outputrt) 1)) (cast-one :object (first outputrt) - (cmp:irc-vaslist-nth (%size_t 0) inputv))) + (cmp:irc-vaslist-nth (%size_t 0) inputv (%nil)))) (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) @@ -1330,7 +1392,7 @@ (uindex (cmp:irc-untag-fixnum index cmp:%fixnum%)) (output (bir:output inst)) (label (datum-name-as-string output))) - (out (cmp:irc-vaslist-nth uindex vaslist label) output))) + (out (cmp:irc-vaslist-nth uindex vaslist (%nil) label) output))) (defmethod translate-simple-instruction ((inst cc-vaslist:nthcdr) abi) (declare (ignore abi)) (let* ((inputs (bir:inputs inst)) @@ -1650,45 +1712,21 @@ (defmethod translate-simple-instruction ((inst bir:load-time-value-reference) abi) (declare (ignore abi)) - (out (let* ((ltv (first (bir:inputs inst))) - (imm-or-index (gethash ltv *constant-values*)) - (label (datum-name-as-string (bir:output inst)))) - (assert imm-or-index () "Load-time-value not found!") - (if (integerp imm-or-index) - (literal:constants-table-value imm-or-index :literal-name label) - imm-or-index)) - (bir:output inst))) - -(defun translate-constant-value (constant) - (let* (;; NOTE: Printing out the constant for a label is problematic, - ;; because LLVM will reject (assert failure) if a label has - ;; any null bytes in it. Null bytes can arise in non-obvious - ;; ways, e.g. from non-ASCII Unicode characters. - (label "") - (immediate-or-index (gethash constant *constant-values*))) - (assert immediate-or-index () "Constant not found!") - (if (integerp immediate-or-index) - (literal:constants-table-value immediate-or-index :literal-name label) - immediate-or-index))) + (out (info-literal (first (bir:inputs inst))) (bir:output inst))) (defmethod translate-simple-instruction ((inst bir:constant-reference) abi) (declare (ignore abi)) - (out (translate-constant-value (bir:input inst)) (bir:output inst))) + (out (info-literal (bir:input inst)) (bir:output inst))) (defmethod translate-simple-instruction ((inst bir:constant-fdefinition) abi) (declare (ignore abi)) - (let* ((output (bir:output inst)) - (cell (bir:input inst)) - (index (gethash cell *constant-values*))) - (assert index () "Function cell not found!") - (out (cmp:irc-fdefinition - (literal:constants-table-value index :literal-name "")) - output))) + (out (cmp:irc-fdefinition (info-literal (bir:input inst))) + (bir:output inst))) (defmethod translate-simple-instruction ((inst bir:constant-symbol-value) abi) (declare (ignore abi)) - (let ((cell (translate-constant-value (bir:input inst))) + (let ((cell (info-literal (bir:input inst))) (output (bir:output inst))) (out (%intrinsic-invoke-if-landing-pad-or-call "cc_variableCellValue" (list cell) @@ -1697,7 +1735,7 @@ (defmethod translate-simple-instruction ((inst bir:set-constant-symbol-value) abi) (declare (ignore abi)) - (let ((cell (translate-constant-value (first (bir:inputs inst)))) + (let ((cell (info-literal (first (bir:inputs inst)))) (val (in (second (bir:inputs inst))))) (%intrinsic-call "cc_set_variableCellValue" (list cell val)))) @@ -1838,8 +1876,7 @@ (defun layout-main-function* (the-function ir body-irbuilder body-block - abi &key (linkage 'llvm-sys:internal-linkage)) - (declare (ignore linkage)) + abi) (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) (cmp:with-irbuilder (body-irbuilder) (with-catch-pad-prep @@ -1864,8 +1901,7 @@ (cmp:irc-br body-block)) the-function) -(defun layout-main-function (function lambda-name abi - &aux (linkage 'llvm-sys:internal-linkage)) ; llvm-sys:private-linkage +(defun layout-main-function (function lambda-name abi) (let* ((*tags* (make-hash-table :test #'eq)) (*datum-values* (make-hash-table :test #'eq)) (*dynenv-storage* (make-hash-table :test #'eq)) @@ -1921,7 +1957,7 @@ (:lineno (core:source-pos-info-lineno source-pos-info)) (layout-main-function* the-function function body-irbuilder body-block - abi :linkage linkage)))))))) + abi)))))))) (defun compute-rest-alloc (cleavir-lambda-list-analysis) ;; FIXME: We seriously need to not reparse lambda lists a million times @@ -1939,52 +1975,49 @@ (cmp:*current-function-name* jit-function-name) (cmp:*gv-current-function-name* (cmp:module-make-global-string jit-function-name "fn-name"))) - (let* ((arity (cmp:xep-arity-arity xep-arity)) - (xep-arity-function (cmp:xep-arity-function-or-placeholder xep-arity))) - (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) - (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)))))))))))) + (let* ((arity (xep-arity-arity xep-arity)) + (xep-arity-function (xep-arity-function-or-placeholder xep-arity))) + (unless (general-entry-placeholder-p xep-arity-function) + (let* ((llvm-function-type (cmp:fn-prototype arity)) + (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))))))))))) @@ -2010,50 +2043,16 @@ (dolist (xep-arity (cmp:xep-group-arities xep-group)) (layout-xep-function xep-arity xep-group function lambda-name abi)))) -(defun layout-procedure (function lambda-name abi - &key (linkage 'llvm-sys:internal-linkage)) - (declare (ignore linkage)) - (when (xep-needed-p function) +(defun layout-procedure (function lambda-name abi) + (unless (eq :xep-unallocated + (xep-function (find-llvm-function-info function))) (layout-xep-group function lambda-name abi)) (layout-main-function function lambda-name abi)) (defun get-or-create-lambda-name (bir) (or (bir:name bir) 'top-level)) -(defgeneric allocate-constant (ir)) - -(defun %allocate-constant (value read-only-p) - (let ((immediate (core:create-tagged-immediate-value-or-nil value))) - (if immediate - (cmp:irc-int-to-ptr (%i64 immediate) cmp:%t*%) - (literal:reference-literal value read-only-p)))) - -(defmethod allocate-constant ((ir bir:constant)) - (%allocate-constant (bir:constant-value ir) t)) - -(defmethod allocate-constant ((ir bir:load-time-value)) - (if (eq cst-to-ast:*compiler* 'cl:compile-file) - ;; Allocate an index in the literal table - ;; for this load-time-value. - (literal:load-time-value-from-thunk - (compile-form (bir:form ir) *clasp-env*)) - (%allocate-constant (eval (bir:form ir)) (bir:read-only-p ir)))) - -(defmethod allocate-constant ((ir bir:function-cell)) - (literal:reference-function-cell (bir:function-name ir))) - -(defmethod allocate-constant ((ir bir:variable-cell)) - (literal:reference-variable-cell (bir:variable-name ir))) - -;;; Given a BIR module, allocate its constants and load time -;;; values. We translate immediates directly, and use an index into -;;; the literal table for non-immediate constants. -(defun allocate-module-constants (module) - (cleavir-set:doset (constant (bir:constants module)) - (setf (gethash constant *constant-values*) - (allocate-constant constant)))) - -(defun layout-module (module abi &key (linkage 'llvm-sys:internal-linkage)) +(defun layout-module (module abi) ;; Create llvm IR functions for each BIR function. (bir:do-functions (function module) ;; Assign IDs to unwind destinations. We start from 1 to allow @@ -2061,19 +2060,15 @@ (let ((i 1)) (cleavir-set:doset (entrance (bir:entrances function)) (setf (gethash entrance *unwind-ids*) i) - (incf i))) - (setf (gethash function *function-info*) - (allocate-llvm-function-info function :linkage linkage))) - (allocate-module-constants module) + (incf i)))) (bir:do-functions (function module) (layout-procedure function (get-or-create-lambda-name function) - abi :linkage linkage))) + abi))) -(defun translate (bir &key abi linkage) +(defun translate (bir &key abi) (let* ((*unwind-ids* (make-hash-table :test #'eq)) - (*function-info* (make-hash-table :test #'eq)) - (*constant-values* (make-hash-table :test #'eq))) - (layout-module (bir:module bir) abi :linkage linkage) + (*function-info* (make-hash-table :test #'eq))) + (layout-module (bir:module bir) abi) (cmp::potentially-save-module) (xep-function (find-llvm-function-info bir)))) @@ -2208,10 +2203,9 @@ COMPILE-FILE will use the default *clasp-env*." (values)) (defun translate-ast (ast &key (abi *abi-x86-64*) - (linkage 'llvm-sys:internal-linkage) (system *clasp-system*)) (let ((bir (ast->bir ast system))) - (translate bir :abi abi :linkage linkage))) + (translate bir :abi abi))) (defun bir-compile (form env) (bir-compile-cst (cst:cst-from-expression form) env)) @@ -2220,10 +2214,77 @@ COMPILE-FILE will use the default *clasp-env*." (let ((cmp:*cleavir-compile-hook* #'bir-compile)) (compile name definition))) -(defun bir->function (bir &key (abi *abi-x86-64*) - (linkage 'llvm-sys:internal-linkage)) - (let ((module (cmp::create-run-time-module-for-compile)) - (pathname +;;; Given a BIR module, compile an LLVM module and return four values +;;; needed to JIT or otherwise use it: +;;; 1) the module +;;; 2) the hash table of BIR functions to llvm-function-infos +;;; 3) A list of constants the module needs, in the correct order +;;; 4) the startup-shutdown-id +(defun translate-bir (bir-module &key (abi *abi-x86-64*) + (module-id (core:next-jit-compile-counter)) + ;; actually a namestring + (pathname "repl-code")) + (let ((module (cmp::llvm-create-module "compile")) + (function-info (make-hash-table :test #'eq)) + (ctable-name (literal:next-value-table-holder-name module-id)) + (ctable (make-array 16 :fill-pointer 0 :adjustable t)) + (fvector-name (format nil "function-vector-~d" module-id)) + (fvector (make-array 16 :fill-pointer 0 :adjustable t))) + (cmp::with-module (:module module) + (cmp:with-debug-info-generator (:module cmp:*the-module* :pathname pathname) + (let* ((*unwind-ids* (make-hash-table :test #'eq)) + (*function-info* function-info)) + (allocate-llvm-function-infos bir-module fvector) + (with-constants (ctable ctable-name) + (layout-module bir-module abi) + (cmp::potentially-save-module)) + (gen-function-vector fvector fvector-name) + (values module function-info ctable + ctable-name fvector-name)))))) + +(defun jit-bir (bir-module &key (abi *abi-x86-64*) (pathname "repl-code")) + (let ((id (core:next-jit-compile-counter))) + (multiple-value-bind (module function-infos constants ctable-name fvector-name) + (translate-bir bir-module :abi abi :pathname pathname :module-id id) + ;; FIXME: A better design might be to store the functions vector + ;; in the ObjectFile and retrieve it that way, as we can already do + ;; with the literals. That would remove the necessity for llvm-sys:lookup + ;; calls in jit-add-module. + (multiple-value-bind (object-file ctable fvector) + (jit-add-module module id ctable-name fvector-name) + (declare (ignore object-file)) + (values function-infos constants ctable fvector))))) + +(defun jit-generator (generator fvector) + (core:simple-core-fun-generator/generate + generator + (core:core-fun-generator/generate + (core:simple-core-fun-generator/core-fun-generator generator) + fvector) + fvector)) + +;;; Given the literals returned from with-rtv, return a list of resolved literals +;;; that can be installed into the object file to actually be used by the code. +;;; This just means fixing up generators. +(defun jit-resolve-literals (literals fvector) + (loop for lit across literals + ;; "generators" are markers for what will eventually be actual functions. + ;; In order to create the functions, they need the actual function pointers. + ;; These function pointers are in the fvector (function pointer vector). + ;; We do the generation of actual functions here. + collect (etypecase lit + (core:simple-core-fun-generator (jit-generator lit fvector)) + (cmp:constant-info (cmp:constant-info/value lit)) + (cmp:load-time-value-info + (eval (cmp:load-time-value-info/form lit))) + (cmp:variable-cell-info + (core:ensure-variable-cell (cmp:variable-cell-info/vname lit))) + (cmp:function-cell-info + (core:ensure-function-cell (cmp:function-cell-info/fname lit))) + (t lit)))) + +(defun bir->function (bir &key (abi *abi-x86-64*)) + (let ((pathname (let ((origin (origin-source (bir:origin bir)))) (if origin (namestring @@ -2231,15 +2292,22 @@ COMPILE-FILE will use the default *clasp-env*." (core:file-scope (core:source-pos-info-file-handle origin)))) "repl-code")))) - ;; Link the C++ intrinsics into the module - (cmp::with-module (: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))) - (declare (ignore constants-table)) - (jit-add-module-return-function - cmp:*the-module* startup-shutdown-id ordered-raw-constants-list))))) + (multiple-value-bind (function-infos constants ctable fvector) + (jit-bir (bir:module bir) :abi abi :pathname pathname) + ;; Install literals. + (loop for lit in (jit-resolve-literals constants fvector) + for i from 0 + do (setf (core:literals-vref ctable i) lit)) + (let* ((info (or (gethash bir function-infos) + (error "Missing LLVM function info for BIR function ~a." + bir))) + (generator (cmp:xep-group-generator (xep-function info))) + (core-generator + (core:simple-core-fun-generator/core-fun-generator generator))) + (core:simple-core-fun-generator/generate + generator + (core:core-fun-generator/generate core-generator fvector) + fvector))))) ;;; Used from fli.lisp. ;;; Create a function like @@ -2278,7 +2346,9 @@ COMPILE-FILE will use the default *clasp-env*." caller)) (defun make-foreign-caller (signature) - (let ((bir (make-foreign-caller-ir signature))) + (let (;; KLUDGE: We use this variable to decide how to dump literals. + (cst-to-ast:*compiler* 'cl:compile) + (bir (make-foreign-caller-ir signature))) (bir-transformations (bir:module bir) *clasp-system*) (bir->function bir))) @@ -2293,34 +2363,3 @@ COMPILE-FILE will use the default *clasp-env*." (pre-ast (cst->ast cst env)) (ast (wrap-ast pre-ast))) (translate-ast ast))) - -(defun compile-file-cst (cst &optional (env *clasp-env*)) - (let* ((cmp:*default-condition-origin* (origin-spi (cst:source cst))) - (pre-ast (cst->ast cst env)) - (ast (wrap-ast pre-ast))) - (literal:arrange-thunk-as-top-level - (translate-ast ast :linkage cmp:*default-linkage*)))) - -(defun bir-loop-read-and-compile-file-forms (source-sin environment) - (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)))))))) - -(defun cleavir-compile-file (input-file &rest kwargs) - (let ((cmp:*cleavir-compile-file-hook* - 'bir-loop-read-and-compile-file-forms) - (cmp:*cleavir-compile-hook* 'bir-compile)) - (apply #'compile-file input-file kwargs))) diff --git a/src/lisp/kernel/cleavir/translation-environment.lisp b/src/lisp/kernel/cleavir/translation-environment.lisp index a049733418..c8930d23ff 100644 --- a/src/lisp/kernel/cleavir/translation-environment.lisp +++ b/src/lisp/kernel/cleavir/translation-environment.lisp @@ -6,7 +6,6 @@ (defvar *tags*) (defvar *datum-values*) -(defvar *constant-values*) (defvar *dynenv-storage*) (defvar *unwind-ids*) (defvar *function-info*) @@ -278,10 +277,9 @@ (bind (make-instance 'bir:constant-bind :iblock (bir:iblock uwprotect-inst)))) (multiple-value-bind (ind old old-destack) - (bind-special (literal:constants-table-value - (literal:reference-variable-cell - 'core:*interrupts-enabled*) - :literal-name "*INTERRUPTS-ENABLED*") + (bind-special (info-literal + (cmp:variable-cell-info/make 'core:*interrupts-enabled*) + "*INTERRUPTS-ENABLED*") (%nil)) (setf (dynenv-storage bind) (list ind old old-destack)) (cmp:with-landing-pad (maybe-entry-landing-pad bind *tags*) diff --git a/src/lisp/kernel/clos/applicable-methods.lisp b/src/lisp/kernel/clos/applicable-methods.lisp new file mode 100644 index 0000000000..26104c1ba0 --- /dev/null +++ b/src/lisp/kernel/clos/applicable-methods.lisp @@ -0,0 +1,148 @@ +(in-package #:clos) + +(defgeneric compute-applicable-methods (generic-function arguments)) +(defmethod compute-applicable-methods + ((gf standard-generic-function) args) + (sort-applicable-methods gf (applicable-method-list gf args) + (mapcar #'class-of args))) + +(defun applicable-method-list (gf args) + (flet ((applicable-method-p (method) + (loop for spec in (method-specializers method) + for arg in args + always (specializer-accepts-p spec arg)))) + ;; no remove-if-not yet. Could make it work via compiler macro + ;; or inlining i guess? + (loop for method in (generic-function-methods gf) + when (applicable-method-p method) + collect method))) + +;;; TODO?: Generalizers (arxiv 1403.2765), export +(defgeneric specializer-accepts-p (specializer object)) +(defmethod specializer-accepts-p ((spec class) object) + (core::of-class-p object spec)) +(defmethod specializer-accepts-p ((spec eql-specializer) object) + (eql object (eql-specializer-object spec))) + +;;; we don't have typep yet +(defgeneric eql-specializer-p (specializer)) +(defmethod eql-specializer-p ((spec eql-specializer)) t) +(defmethod eql-specializer-p ((spec class)) nil) + +(defgeneric compute-applicable-methods-using-classes + (generic-function classes)) +(defmethod compute-applicable-methods-using-classes + ((gf standard-generic-function) classes) + (flet ((applicable-method-p (method) + (loop for spec in (method-specializers method) + for class in classes + always (if (eql-specializer-p spec) + (if (core::of-class-p + (eql-specializer-object spec) + class) + (return-from compute-applicable-methods-using-classes + (values nil nil)) + nil) + (core::subclassp class spec))))) + (values (sort-applicable-methods + gf + (loop for method in (generic-function-methods gf) + when (applicable-method-p method) + collect method) + classes) + t))) + +;;; used in miss.lisp +(defun compute-applicable-methods-using-specializers (generic-function specializers) + (sort-applicable-methods + generic-function + (applicable-method-list-using-specializers generic-function specializers) + specializers)) + +(defun method-applicable-to-specializers-p (method argspecs) + (loop for spec in (method-specializers method) + for argspec in argspecs + always (cond ((eql-specializer-p argspec) + (specializer-accepts-p spec (eql-specializer-object argspec))) + ;; if the method has an eql specializer and we don't + ;; the method isn't applicable. + ((eql-specializer-p spec) nil) + (t (core:subclassp argspec spec))))) + +(defun applicable-method-list-using-specializers (gf argspecs) + (loop for method in (generic-function-methods gf) + when (method-applicable-to-specializers-p method argspecs) + collect method)) + +(defun sort-applicable-methods (gf methods args-specializers) + ;; Reorder args-specializers to match APO. + (let ((f (generic-function-a-p-o-function gf))) + (when f + (setf args-specializers + (funcall f (subseq args-specializers 0 + (length (generic-function-argument-precedence-order gf)))))) + ;; then order the list. Simple selection sort. FIXME? + ;; note that this mutates the list, so be sure methods + ;; is fresh. + (loop for to-sort on methods + do (loop for comparees on (rest to-sort) + for comparee = (first comparees) + for most-specific = (first to-sort) + when (eql (compare-methods most-specific comparee + args-specializers f) + 2) + do (rotatef (first comparees) (first to-sort)))) + methods)) + +(defun compare-methods (method-1 method-2 args-specializers f) + (let* ((specializers-list-1 (method-specializers method-1)) + (specializers-list-2 (method-specializers method-2))) + (compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1) + (if f (funcall f specializers-list-2) specializers-list-2) + args-specializers))) + +(defun compare-specializers-lists (spec-list-1 spec-list-2 args-specializers) + (loop for spec1 in spec-list-1 for spec2 in spec-list-2 + for arg-specializer in args-specializers + for c = (compare-specializers spec1 spec2 arg-specializer) + do (case c + ;; if =, just keep going + ((1) (return 1)) + ((2) (return 2)) + ((nil) + (error "The type specifiers ~S and ~S can not be disambiguated~ + with respect to the argument specializer: ~S" + (or spec1 t) (or spec2 t) arg-specializer))))) + +(defun fast-subtypep (spec1 spec2) + ;; Specialized version of subtypep which uses the fact that spec1 + ;; and spec2 are either classes or eql specializers (basically member types) + (if (eql-specializer-p spec1) + (if (eql-specializer-p spec2) + (eq spec1 spec2) ; take advantage of internment + (si::of-class-p (eql-specializer-object spec1) spec2)) + (if (eql-specializer-p spec2) + ;; There is only one class with a single element, which + ;; is NULL = (MEMBER NIL). + (and (null (eql-specializer-object spec2)) + (eq spec1 (load-time-value (find-class 'null) t))) + (si::subclassp spec1 spec2)))) + +(defun compare-specializers (spec-1 spec-2 arg-spec) + (let ((cpl (class-precedence-list (if (eql-specializer-p arg-spec) + (class-of (eql-specializer-object + arg-spec)) + arg-spec)))) + (cond ((eq spec-1 spec-2) '=) + ((fast-subtypep spec-1 spec-2) '1) + ((fast-subtypep spec-2 spec-1) '2) + ;; Per CLHS 7.6.6.1.2, an eql specializer is considered + ;; more specific than a class. Also, for an eql specializer + ;; to be compared to a class here, they must both be + ;; applicable, and as such the eql is a "sub specializer". + ((eql-specializer-p spec-1) '1) + ((eql-specializer-p spec-2) '2) + ((member spec-1 (rest (member spec-2 cpl))) '2) + ((member spec-2 (rest (member spec-1 cpl))) '1) + ;; This will force an error in the caller + (t nil)))) diff --git a/src/lisp/kernel/clos/atomics.lisp b/src/lisp/kernel/clos/atomics.lisp new file mode 100644 index 0000000000..9b1dd3c58e --- /dev/null +++ b/src/lisp/kernel/clos/atomics.lisp @@ -0,0 +1,98 @@ +(in-package #:clos) + +;;; FIXME: Only defined in its own file because (setf atomic-expander) is +;;; defined relatively late. + +(mp:define-atomic-expander standard-instance-access (instance location) + (&rest keys) + "The requirements of the normal STANDARD-INSTANCE-ACCESS writer +must be met, including that the slot has allocation :instance, and is +bound before the operation. +If there is a CHANGE-CLASS conflicting with this operation the +consequences are not defined." + (apply #'mp:get-atomic-expansion + `(core:rack-ref (core:instance-rack ,instance) ,location) + keys)) +(mp:define-atomic-expander funcallable-standard-instance-access + (instance location) (&rest keys) + "See STANDARD-INSTANCE-ACCESS for requirements." + (apply #'mp:get-atomic-expansion + `(core:rack-ref (core:instance-rack ,instance) ,location) + keys)) + +(defun atomic-svuc (order class object slotd) + (declare (ignore class)) ; FIXME: Method dispatch...? + (let* ((loc (slot-definition-location slotd)) + (v (ecase (slot-definition-allocation slotd) + ((:instance) + (core:atomic-rack-read order (core:instance-rack object) loc)) + ((:class) (core:car-atomic order loc))))) + (if (si:sl-boundp v) + v + (values (slot-unbound class object (slot-definition-name slotd)))))) +(defun (setf atomic-svuc) (new order class object slotd) + (declare (ignore class)) + (let ((loc (slot-definition-location slotd))) + (ecase (slot-definition-allocation slotd) + ((:instance) + (core:atomic-rack-write order new (core:instance-rack object) loc)) + ((:class) (core:rplaca-atomic order new loc))))) +(defun cas-svuc (order cmp new class obj slotd) + (declare (ignore class)) + (let ((loc (slot-definition-location slotd))) + (ecase (slot-definition-allocation slotd) + ((:instance) + (core:cas-rack order cmp new (core:instance-rack obj) loc)) + ((:class) (core:cas-car order cmp new loc))))) + +(mp:define-atomic-expander slot-value-using-class (class object slotd) + (&key order &allow-other-keys) + "Same requirements as STANDARD-INSTANCE-ACCESS, except the slot can have +allocation :class or other types. +If there is a redefinition of the class layout that affects the slot, that conflicts with this operation, the consequences are not defined. +Also, methods on SLOT-VALUE-USING-CLASS, SLOT-BOUNDP-USING-CLASS, and +(SETF SLOT-VALUE-USING-CLASS) are ignored (not invoked). +In the future, the CAS behavior may be customizable with a generic function." + (let ((gclass (gensym "CLASS")) (gobj (gensym "OBJECT")) + (gslotd (gensym "SLOTD")) (cmp (gensym "CMP")) (new (gensym "NEW"))) + (values (list gclass gobj gslotd) (list class object slotd) + cmp new + `(atomic-svuc ',order ,gclass ,gobj ,gslotd) + `(setf (atomic-svuc ',order ,gclass ,gobj ,gslotd) ,new) + `(cas-svuc ',order ,cmp ,new ,gclass ,gobj ,gslotd)))) + +(mp:define-atomic-expander slot-value (object slot-name) (&rest keys) + "See SLOT-VALUE-USING-CLASS documentation for constraints. +If no slot with the given SLOT-NAME exists, SLOT-MISSING will be called, +with operation = mp:cas, and new-value a list of OLD and NEW. +If SLOT-MISSING returns, its primary value is returned." + (let ((gobject (gensym "OBJECT")) (gsname (gensym "SLOT-NAME")) + (gslotd (gensym "SLOTD")) (gclass (gensym "CLASS"))) + (multiple-value-bind (vars vals cmpv newv read write cas) + (apply #'mp:get-atomic-expansion + `(slot-value-using-class ,gclass ,gobject ,gslotd) + keys) + (values (list* gobject gsname gclass gslotd vars) + (list* object slot-name `(class-of ,gobject) + `(find ,gsname (class-slots ,gclass) + :key #'slot-definition-name) + vals) + cmpv newv + `(if ,gslotd ,read (slot-missing ,gclass ,gobject ,gsname 'slot-value)) + `(if ,gslotd ,write (slot-missing ,gclass ,gobject ,gsname 'setf ,newv)) + `(if ,gslotd ,cas (slot-missing ,gclass ,gobject ,gsname 'mp:cas (list ,cmpv ,newv))))))) + +;;; Internal use only, but useful. +(mp:define-atomic-expander clos::generic-function-call-history (generic-function) + (&rest keys &key order environment) + (declare (ignore order environment)) + (let ((gf (gensym "GENERIC-FUNCTION")) (index (gensym "INDEX"))) + (multiple-value-bind (vars vals cmp new read write cas) + (apply #'mp:get-atomic-expansion + `(clos:funcallable-standard-instance-access ,gf ,index) + keys) + (values (list* gf index vars) + (list* generic-function + `(clos::%gfclass-call-history-loc (class-of ,gf)) + vals) + cmp new read write cas)))) diff --git a/src/lisp/kernel/clos/base-satiation.lisp b/src/lisp/kernel/clos/base-satiation.lisp new file mode 100644 index 0000000000..bbe79be10e --- /dev/null +++ b/src/lisp/kernel/clos/base-satiation.lisp @@ -0,0 +1,121 @@ +(in-package #:clos) + +;;; FIXME: Define in config, or at least elsewhere +(defconstant +where-tag-mask+ #b11000) +(defconstant +derivable-where-tag+ #b00000) +(defconstant +rack-where-tag+ #b01000) +(defconstant +wrapped-where-tag+ #b10000) +(defconstant +header-where-tag+ #b11000) +(defconstant +fixnum-tag+ 342) +(defconstant +single-float-tag+ 310) +(defconstant +character-tag+ 1582) +(defconstant +cons-tag+ 30) + +(defmacro core::header-stamp-case (stamp derivable rack wrapped header) + `(case (logand (ash ,stamp 2) ,+where-tag-mask+) + (,+derivable-where-tag+ ,derivable) + (,+rack-where-tag+ ,rack) + (,+wrapped-where-tag+ ,wrapped) + (,+header-where-tag+ ,header))) + +(defun instance-stamp (object) + ;; This is way dumber than the eventual dfuns, but we can take advantage + ;; of one cheat - nothing we're satiating here wants a non-general. + (cond + ((core:generalp object) + (let ((hstamp (core::header-stamp object))) + (core::header-stamp-case hstamp + (core::derivable-stamp object) + (core::rack-stamp object) + (core::wrapped-stamp object) + hstamp))) + ((consp object) +cons-tag+) + ((core:fixnump object) +fixnum-tag+) + ((core:single-float-p object) +single-float-tag+) + ((characterp object) +character-tag+) + (t (error "Unknown object ~s" object)))) + +;;; Minimum needed to call generic functions. +;;; May be an overestimate since debugging my way down to a +;;; truly minimum set sounds like a terrible time. +(base-satiate generic-function-methods (standard-generic-function)) +(base-satiate generic-function-a-p-o-function (standard-generic-function)) +(base-satiate generic-function-argument-precedence-order (standard-generic-function)) +(base-satiate generic-function-lambda-list (standard-generic-function)) +(base-satiate generic-function-method-combination (standard-generic-function)) +(base-satiate generic-function-specializer-profile (standard-generic-function)) + +(base-satiate method-specializers (standard-method) + (standard-reader-method) + (standard-writer-method)) +(base-satiate method-qualifiers (standard-method) + (standard-reader-method) (standard-writer-method) + (effective-reader-method) (effective-writer-method)) +(base-satiate method-function (standard-method)) +(base-satiate accessor-method-slot-definition + (standard-reader-method) (standard-writer-method) + (effective-reader-method) (effective-writer-method)) +(base-satiate effective-accessor-method-location + (effective-reader-method) (effective-writer-method)) + +(base-satiate contf (%contf-method-function)) + +(base-satiate slot-definition-name + (standard-direct-slot-definition) (standard-effective-slot-definition)) +(base-satiate slot-definition-location + (standard-direct-slot-definition) (standard-effective-slot-definition)) + +(base-satiate stamp-for-instances + (standard-class) (funcallable-standard-class) + (built-in-class)) +(base-satiate class-precedence-list + (standard-class) (funcallable-standard-class)) +(base-satiate class-slots + (standard-class) (funcallable-standard-class)) + +(base-satiate eql-specializer-p + (eql-specializer) (standard-class) (funcallable-standard-class) + (built-in-class)) +(base-satiate specializer-accepts-p + (standard-class t) (funcallable-standard-class t) + (built-in-class t) (eql-specializer t)) +(base-satiate compute-applicable-methods-using-classes + (standard-generic-function t)) +(base-satiate compute-applicable-methods (standard-generic-function t)) + +(base-satiate method-combination-compiler (method-combination)) +(base-satiate method-combination-options (method-combination)) + +(base-satiate perform-outcome + (optimized-slot-reader t) (optimized-slot-writer t) + (effective-method-outcome t)) +(base-satiate outcome-methods + (optimized-slot-reader) (optimized-slot-writer) (effective-method-outcome)) +(base-satiate optimized-slot-accessor-index + (optimized-slot-reader) (optimized-slot-writer)) +(base-satiate optimized-slot-accessor-slot-name + (optimized-slot-reader) (optimized-slot-writer)) +(base-satiate optimized-slot-accessor-class + (optimized-slot-reader) (optimized-slot-writer)) +(base-satiate effective-method-outcome-form (effective-method-outcome)) +(base-satiate effective-method-outcome-function (effective-method-outcome)) + +(base-satiate compute-effective-method (standard-generic-function t t)) + +(base-satiate c++-class-p (built-in-class) + (standard-class) (funcallable-standard-class)) + +(base-satiate dtree-op-arguments (dtree-op)) +(base-satiate dtree-op-long-arguments (dtree-op)) +(base-satiate dtree-op-label-argument-indices (dtree-op)) + +(base-satiate dtree-index (dtree-test) (bc-instruction) (bc-register-arg)) +(base-satiate (setf dtree-index) (t bc-label-arg)) +(base-satiate dtree-next (dtree-skip)) + +(base-satiate bc-instruction-code (bc-instruction)) +(base-satiate bc-lip (bc-instruction) (bc-label-arg)) +(base-satiate bc-constant-arg-value (bc-constant-arg)) +(base-satiate bc-constant-ref-ref (bc-constant-ref)) +(base-satiate bc-label-arg-delta (bc-label-arg)) +(base-satiate (setf bc-label-arg-delta) (t bc-label-arg)) diff --git a/src/lisp/kernel/clos/boot.lisp b/src/lisp/kernel/clos/boot.lisp deleted file mode 100644 index 2d340a692b..0000000000 --- a/src/lisp/kernel/clos/boot.lisp +++ /dev/null @@ -1,190 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi.o -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. - -(in-package "CLOS") - -#+(or) -(eval-when (:compile-toplevel :load-toplevel :execute) - (setq *echo-repl-read* t)) - -;;; ---------------------------------------------------------------------- -;;; Building basic classes. -;;; We have to work carefully because the system is obviously not yet -;;; self-consistent. -;;; Some classes, like standard-class, are partially defined in the -;;; interpreter. - -#+(or) -(defmacro debug-boot (msg &rest args) - `(format t ,msg ,@args)) -(defmacro debug-boot (msg &rest args) - (declare (ignore msg args))) - - -;; This ensures that each new class has its class-for-instances set -;; properly, and furthermore that it's only done once -;; (Because if ensure-boot-class is called again with the same name, -;; it'll just find-class the existing one.) -(defun allocate-boot-class (metaclass slot-count name) - (let ((class (core:allocate-standard-instance metaclass slot-count))) - (core:class-new-stamp class name) - class)) - -(defun ensure-boot-class (name &key (metaclass 'standard-class) - direct-superclasses direct-slots) - (debug-boot "!!ensure-boot-class for ~s metaclass: ~s direct-superclasses: ~s :direct-slots ~s~%" - name metaclass direct-superclasses direct-slots) - (let* ((the-metaclass (progn - (debug-boot " About to do the~%") - (find-class metaclass nil))) - (class (progn - (debug-boot " About to allocate-boot-class~%") - (or (find-class name nil) - (allocate-boot-class the-metaclass #.(length +standard-class-slots+) name))))) - ;; (debug-boot "About to with-early-accessors -> macroexpand = ~a~%" (macroexpand '(with-early-accessors (+standard-class-slots+) (setf (class-name class) name)))) - (debug-boot " About to with-early-accessors~%") - (with-early-accessors (+standard-class-slots+) - (let ((existing-slots (class-slots class))) - (when (and (typep existing-slots 'list) - (not (= (length existing-slots) - (length direct-slots))) - (not (zerop (length existing-slots)))) - (error "~S was called on the already instantiated class ~S, but with ~S slots while it already has ~S slots." - 'ensure-boot-class name (length direct-slots) (length existing-slots)))) - ;; (debug-boot " (get-setf-expansion '(class-name class) ENV) -> ~a~%" (macrolet ((hack (form &environment e) `',(multiple-value-list (get-setf-expansion form e)))) (hack '(class-name class)))) - (setf (class-name class) name) - (debug-boot " (class-name class) -> ~a name -> ~a~%" (class-name class) name) - ;; FIXME: This duplicates the :initform specifications in hierarchy.lisp. - (setf (specializer-direct-methods class) nil - (specializer-call-history-generic-functions class) nil - (specializer-mutex class) (mp:make-shared-mutex 'call-history-generic-functions-mutex) - (class-name class) name - ;; superclasses below - (class-direct-subclasses class) nil - ;; slots by add-slots below - ;; precedence below - ;; direct-slots also by add-slots - (class-direct-default-initargs class) nil - (class-default-initargs class) nil - (class-finalized-p class) t - (class-source-position class) nil) - (debug-boot " About to setf class name -> ~a class -> ~a~%" name class) - (core:setf-find-class class name) - (debug-boot " Done setf class name -> ~a class -> ~a~%" name class) - (setf - (class-dependents class) nil) - (debug-boot " About to add-slots~%") - (add-slots class direct-slots) - (debug-boot " About to get superclasses~%") - (let ((superclasses (loop for name in direct-superclasses - for parent = (find-class name) - do (pushnew class (class-direct-subclasses parent)) - collect parent))) - (debug-boot " Collected superclasses~%") - (setf (class-direct-superclasses class) superclasses) - ;; In clasp each class contains a default allocator functor - ;; that is used to allocate instances of this class - ;; If a superclass is derived from a C++ adaptor class - ;; then we must inherit its allocator - ;; This means that a class can only ever - ;; inherit from one C++ adaptor class - (setf (creator class) (sys:compute-instance-creator class the-metaclass superclasses)) - (debug-boot " compute-clos-class-precedence-list class->~a superclasses->~a~%" class superclasses) - (let ((cpl (compute-clos-class-precedence-list class superclasses))) - (debug-boot " computed") - (setf (class-precedence-list class) cpl))) - class))) - -(defun add-slots (class slots) - (declare (optimize speed (safety 0))) - ;; It does not matter that we pass NIL instead of a class object, - ;; because CANONICAL-SLOT-TO-DIRECT-SLOT will make simple slots. - (with-early-accessors (+standard-class-slots+ - +slot-definition-slots+) - (let* ((location-table (make-hash-table :size (if slots 24 0))) - (direct-slot-class (find-class 'standard-direct-slot-definition nil)) - (direct-slots (loop for slotd in slots - collect (apply #'make-simple-direct-slotd direct-slot-class slotd))) - (effective-slot-class (find-class 'standard-effective-slot-definition nil)) - (effective-slots (loop for i fixnum from 0 - for slotd in slots - for name = (getf slotd :name) - for declared-location of-type (or null fixnum) - = (getf slotd :location) - for s = (apply #'make-simple-slotd effective-slot-class slotd) - do (setf (slot-definition-location s) i - (gethash name location-table) i) - ;; do a sanity check on :location - when (and declared-location - (/= i (the fixnum declared-location))) - do (error "BUG: Primitive slot ~a has incorrect :location" - name) - collect s))) - (setf (class-slots class) effective-slots - (class-direct-slots class) direct-slots - (class-size class) (length slots)) - (setf (class-location-table class) location-table)))) - - -;; Create the classes -;; -(progn - (defvar +the-t-class+) - (defvar +the-class+) - (defvar +the-std-class+) - (defvar +the-funcallable-standard-class+)) - -(defmacro dbg-boot (fmt &rest fmt-args) - (declare (ignore fmt fmt-args)) - nil) - -#++ -(defmacro dbg-boot (fmt &rest fmt-args) - `(core:fmt t ,fmt ,@fmt-args)) - - -(defmacro boot-hierarchy () - `(progn - ,@(loop for (class . options) in +class-hierarchy+ - for direct-slots = (getf options :direct-slots) -;;; do (core:fmt t "boot-hierarchy class->{}%N" class) - collect - (if direct-slots - `(apply #'ensure-boot-class ',class - :direct-slots ,(parse-slots direct-slots) - ',(let ((copy (copy-list options))) - (remf copy :direct-slots) - copy)) - `(apply #'ensure-boot-class ',class ',options))))) - -(boot-hierarchy) - -(progn - (dbg-boot "About to setq stuff%N") - (setq +the-t-class+ (find-class 't nil)) - (setq +the-class+ (find-class 'class nil)) - (setq +the-std-class+ (find-class 'std-class nil)) - (setq +the-funcallable-standard-class+ - (find-class 'funcallable-standard-class nil))) -;; -;; Finalize -;; -;; This is needed so that the early slotds we made are not marked obsolete. -;; -(let () - (with-early-accessors (+standard-class-slots+) - (loop for (class-name) in +class-hierarchy+ - for class = (find-class class-name) - do (loop for s in (class-slots class) - do (si:instance-sig-set s)) - (loop for s in (class-direct-slots class) - do (si:instance-sig-set s))))) diff --git a/src/lisp/kernel/clos/builtin.lisp b/src/lisp/kernel/clos/builtin.lisp deleted file mode 100644 index cf82f2735d..0000000000 --- a/src/lisp/kernel/clos/builtin.lisp +++ /dev/null @@ -1,156 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi. -;;;; -;;;; This program 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 file '../Copyright' for full details. - -(in-package "CLOS") - -;;; ====================================================================== -;;; Built-in classes -;;; ---------------------------------------------------------------------- - -(defmethod make-instance ((class built-in-class) &rest initargs) - (declare (ignore initargs)) - (error "The built-in class (~A) cannot be instantiated" class)) - -(defmethod allocate-instance ((class built-in-class) &rest initargs) - (declare (ignore initargs)) - (error "The built-in class (~A) cannot be instantiated" class)) - -(defmethod ensure-class-using-class ((class null) name core:&va-rest rest) - (clos::gf-log "In ensure-class-using-class (class null)%N") - (clos::gf-log " class -> {}%N" name) - (multiple-value-bind (metaclass direct-superclasses options) - (apply #'help-ensure-class rest) - (declare (ignore direct-superclasses)) - (setf class (apply #'make-instance metaclass :name name options)) - (when name - (si:create-type-name name) - (setf (find-class name) class)))) - -(defmethod change-class ((instance t) (new-class symbol) core:&va-rest initargs) - (apply #'change-class instance (find-class new-class) initargs)) - -(defmethod make-instances-obsolete ((class symbol)) - (make-instances-obsolete (find-class class)) - class) - -(defmethod make-instance ((class-name symbol) core:&va-rest initargs) - (apply #'make-instance (find-class class-name) initargs)) - -(defmethod slot-makunbound-using-class ((class built-in-class) self slotd) - (declare (ignore self slotd)) - (error "SLOT-MAKUNBOUND-USING-CLASS cannot be applied on built-in object ~a of class ~a" class (class-of class))) - -(defmethod slot-boundp-using-class ((class built-in-class) self slotd) - (declare (ignore class self slotd)) - (error "SLOT-BOUNDP-USING-CLASS cannot be applied on built-in objects")) - -(defmethod slot-value-using-class ((class built-in-class) self slotd) - (declare (ignore class self slotd)) - (error "SLOT-VALUE-USING-CLASS cannot be applied on built-in objects")) - -(defmethod (setf slot-value-using-class) (val (class built-in-class) self slotd) - (declare (ignore class self slotd val)) - (error "SLOT-VALUE-USING-CLASS cannot be applied on built-in objects")) - -(defmethod slot-exists-p-using-class ((class built-in-class) self slotd) - (declare (ignore class self slotd)) - nil) - -#+threads -(defmethod cas-slot-value-using-class - (old new (class built-in-class) object slotd) - (declare (ignore old new object slotd)) - (error "Cannot modify slots of object with built-in-class")) - -;;; ====================================================================== -;;; STRUCTURES -;;; -;;; As an extension, we allow the use of MAKE-INSTANCE, as well as SLOT-VALUE -;;; and sundry, on structure objects and classes. -;;; However, at least for now we do not go through SHARED-INITIALIZE or -;;; INITIALIZE-INSTANCE when using constructors instead, so specializing those -;;; on structure classes has undefined behavior. -;;; Also note that we don't define whether uninitialized slots are bound, or -;;; what they are bound to if they are bound. -;;; Most of the methods in standard.lsp work fine for structures and don't need -;;; to be specialized here. - -(defmethod allocate-instance ((class structure-class) &rest initargs) - (declare (ignore initargs)) - (core:allocate-raw-instance class (make-rack-for-class class))) - -;;; The slot methods do need to be specialized. FIXME: Could possibly be -;;; cleaned up by making structure-class a subclass of std-class, but with -;;; an improved structure runtime we'd probably need to do something special -;;; here regardless. -(defmethod slot-value-using-class ((class structure-class) self slotd) - (let* ((location (slot-definition-location slotd)) - (value (standard-instance-access self location))) - (if (si:sl-boundp value) - value - (values (slot-unbound class self (slot-definition-name slotd)))))) - -(defmethod slot-boundp-using-class ((class structure-class) self slotd) - (declare (ignore class)) - (si:sl-boundp (standard-instance-access self - (slot-definition-location slotd)))) - -(defmethod (setf slot-value-using-class) (val (class structure-class) - self slotd) - (declare (ignore class)) - (setf (standard-instance-access self (slot-definition-location slotd)) val)) - -(defmethod slot-makunbound-using-class ((class structure-class) instance slotd) - (declare (ignore class)) - (setf (standard-instance-access instance (slot-definition-location slotd)) - (si:unbound)) - instance) - -#+threads -(defmethod cas-slot-value-using-class - (old new (class structure-class) object - (slotd standard-effective-slot-definition)) - (let ((loc (slot-definition-location slotd))) - (mp:cas (standard-instance-access object loc) old new))) - -#+threads -(defmethod atomic-slot-value-using-class - ((class structure-class) object (slotd standard-effective-slot-definition)) - (let* ((loc (slot-definition-location slotd)) - (v (mp:atomic (standard-instance-access object loc)))) - (if (si:sl-boundp v) - v - (values (slot-unbound class object (slot-definition-name slotd)))))) - -#+threads -(defmethod (setf atomic-slot-value-using-class) - (new-value (class structure-class) object - (slotd standard-effective-slot-definition)) - (let ((loc (slot-definition-location slotd))) - (setf (mp:atomic (standard-instance-access object loc)) new-value))) - -(defmethod finalize-inheritance ((class structure-class)) - (call-next-method) - (dolist (slot (class-slots class)) - (unless (eq :INSTANCE (slot-definition-allocation slot)) - (error "The structure class ~S can't have shared slots" (class-name class))))) - -(defun copy-structure (structure) - ;; This could be done slightly faster by making copy-structure generic, - ;; and having defstruct define a copy-structure method that works without a loop - ;; or checking the size. - (let* ((class (class-of structure)) - (copy (allocate-instance class)) - (size (class-size class))) - (loop for i below size - do (setf (si:instance-ref copy i) - (si:instance-ref structure i))) - copy)) diff --git a/src/lisp/kernel/clos/change.lisp b/src/lisp/kernel/clos/change.lisp index 4c7243ce06..688ce6d4f2 100644 --- a/src/lisp/kernel/clos/change.lisp +++ b/src/lisp/kernel/clos/change.lisp @@ -89,8 +89,11 @@ (slot-value-using-class old-class old-instance old-slotd))))))))) (values)) +(defmethod change-class (instance (new-class symbol) &rest initargs) + (apply #'change-class instance (find-class new-class) initargs)) + (defmethod change-class ((instance standard-object) (new-class standard-class) - core:&va-rest initargs) + &rest initargs) (let* ((old-rack (core:instance-rack instance)) (old-class (class-of instance)) (copy (core:allocate-raw-instance old-class old-rack)) @@ -114,7 +117,7 @@ (defmethod change-class ((instance funcallable-standard-object) (new-class funcallable-standard-class) - core:&va-rest initargs) + &rest initargs) (let* ((old-rack (core:instance-rack instance)) (old-class (class-of instance)) (copy (core:allocate-raw-funcallable-instance old-class old-rack)) @@ -350,7 +353,7 @@ (defmethod change-class ((instance class) new-class &rest initargs) (declare (ignore new-class initargs)) - (if (forward-referenced-class-p instance) + (if (typep instance 'forward-referenced-class) (call-next-method) (error "The metaclass of a class metaobject ~a cannot be changed per AMOP Ch. 6" instance))) diff --git a/src/lisp/kernel/clos/check-initargs.lisp b/src/lisp/kernel/clos/check-initargs.lisp new file mode 100644 index 0000000000..1b458fa1cb --- /dev/null +++ b/src/lisp/kernel/clos/check-initargs.lisp @@ -0,0 +1,118 @@ +(in-package #:clos) + +;;; There are different sets of initialization arguments. First we have +;;; those coming from the :INITARG option in the slots. Then we have +;;; all declared initargs which are keyword arguments to methods defined +;;; on SHARED-INITIALIZE, REINITIALIZE-INSTANCE, etc. (See ANSI 7.1.2) +;;; This file defines some common utilities for checking their validity. +;;; They're used in both make.lisp and change.lisp. + +(defun check-initargs-uncached (class initargs + &optional calls (slots (class-slots class))) + ;; We try to avoid calling compute-applicable-methods since that's work. + ;; (In simple tests, avoiding it gave a speedup of 2-3 times.) + ;; So we first check if all the initargs correspond to slots. If they do, + ;; great. If not we compute-applicable-methods to get more valid keywords. + ;; This assumes that the likely case is all the initargs corresponding to + ;; slots, but it shouldn't really be any slower if they don't. + ;; CALLS is a list of (function arglist). These can be passed directly + ;; to compute-applicable-methods. + (loop with aok = nil ; keep processing after aok to check for oddness/nonsymbols + with aok-seen-p = nil + with method-keys = nil + with method-keys-p = nil + with unknown-keys + for cur on initargs by #'cddr + for name = (first cur) + when (and (eql name :allow-other-keys) (not aok-seen-p)) + do (setf aok (second cur) aok-seen-p t) + do (cond + ((null (rest cur)) + (core:simple-program-error "No value supplied for the init-name ~S." + name)) + ((not (symbolp name)) + (core:simple-program-error "Not a valid initarg: ~s" name)) + ;; :allow-other-keys is always valid. + ((eql name :allow-other-keys)) + ;; Check if the key is associated with a slot + ((member name slots :test #'member :key #'slot-definition-initargs)) + ;; doesn't correspond to a slot, so check the methods. + ;; Compute those keywords first if we haven't. + ((progn + (unless method-keys-p + (setf method-keys-p t + method-keys (valid-keywords-from-calls calls)) + (when (eq method-keys t) ; &allow-other-keys + (return-from check-initargs-uncached))) + (member name method-keys))) + (t (push name unknown-keys))) + finally (when (and unknown-keys (not aok)) + (core:simple-program-error + "Unknown initialization options ~s for class ~a." + unknown-keys class)))) + +(defun valid-keywords-from-calls (calls) + (loop for call in calls + for methods = (apply #'compute-applicable-methods call) + for keywords = (valid-keywords-from-methods methods) + if (eq keywords t) + return keywords + else nconc keywords)) + +(defun valid-keywords-from-methods (methods) + (loop for method in methods + append (multiple-value-bind (keys aokp) (function-keywords method) + (when aokp (return t)) + keys))) + +;;; Like the above, but use a cached list of method initargs rather than +;;; grabbing them from methods. +(defun check-initargs (class initargs cached-keywords + &optional (slots (class-slots class))) + (unless (eq cached-keywords t) ;; meaning we have &allow-other-keys + (loop with aok = nil ; keep processing after aok to check for oddness/nonsymbols + with aok-seen-p = nil + with unknown-keys + for cur on initargs by #'cddr + for name = (first cur) + when (and (eql name :allow-other-keys) (not aok-seen-p)) + do (setf aok (second cur) aok-seen-p t) + do (cond + ((null (rest cur)) + (core:simple-program-error "No value supplied for the init-name ~S." + name)) + ((not (symbolp name)) + (core:simple-program-error "Not a valid initarg: ~s" name)) + ((eql name :allow-other-keys)) + ((member name slots :test #'member :key #'slot-definition-initargs)) + ((member name cached-keywords)) + (t (push name unknown-keys))) + finally (when (and unknown-keys (not aok)) + (core:simple-program-error + "Unknown initialization options ~s for class ~a." + unknown-keys class))))) + +;;; There's not really a perfect place for this, but we use it below. +;;; This is not a simple reader because the prototype is computed lazily. +(defgeneric class-prototype (class)) + +(defmethod class-prototype ((class std-class)) + ;; FIXME? atomicity + (if (slot-boundp class 'prototype) + (slot-value class 'prototype) + (setf (slot-value class 'prototype) (allocate-instance class)))) + +(defun precompute-valid-initarg-keywords (class) + (setf (class-valid-initargs class) + (loop with methods + = (nconc + (compute-applicable-methods + #'allocate-instance (list class)) + (compute-applicable-methods + #'initialize-instance (list (class-prototype class))) + (compute-applicable-methods + #'shared-initialize (list (class-prototype class) t))) + for m in methods + append (multiple-value-bind (keys aokp) (function-keywords m) + (when aokp (return t)) + keys)))) diff --git a/src/lisp/kernel/clos/standard.lisp b/src/lisp/kernel/clos/class.lisp similarity index 50% rename from src/lisp/kernel/clos/standard.lisp rename to src/lisp/kernel/clos/class.lisp index c6800248cd..f40b06ca16 100644 --- a/src/lisp/kernel/clos/standard.lisp +++ b/src/lisp/kernel/clos/class.lisp @@ -12,83 +12,22 @@ (in-package "CLOS") -;;; ---------------------------------------------------------------------- -;;; INSTANCES INITIALIZATION AND REINITIALIZATION -;;; - -(defmethod initialize-instance ((instance T) core:&va-rest initargs) - (apply #'shared-initialize instance 'T initargs)) - -(defmethod reinitialize-instance ((instance T ) &rest initargs) - (declare (dynamic-extent initargs)) - ;; NOTE: This dynamic extent declaration relies on the fact clasp's APPLY - ;; does not reuse rest lists. If it did, a method on #'shared-initialize, - ;; or whatever, could potentially let the rest list escape. - (when initargs - (check-initargs-uncached - (class-of instance) initargs - (list (list #'reinitialize-instance (list instance)) - (list #'shared-initialize (list instance t))))) - (apply #'shared-initialize instance '() initargs)) - -(defmethod shared-initialize ((instance T) slot-names core:&va-rest initargs) - ;; - ;; initialize the instance's slots is a two step process - ;; 1 A slot for which one of the initargs in initargs can set - ;; the slot, should be set by that initarg. If more than - ;; one initarg in initargs can set the slot, the leftmost - ;; one should set it. - ;; - ;; 2 Any slot not set by step 1, may be set from its initform - ;; by step 2. Only those slots specified by the slot-names - ;; argument are set. If slot-names is: - ;; T - ;; any slot not set in step 1 is set from its - ;; initform - ;; - ;; any slot in the list, and not set in step 1 - ;; is set from its initform - ;; - ;; () - ;; no slots are set from initforms - ;; - (let* ((class (class-of instance))) - ;; initialize-instance slots - (dolist (slotd (class-slots class)) - (core:vaslist-rewind (core:validate-vaslist initargs)) - (core:validate-vaslist initargs) - (let* ((slot-initargs (slot-definition-initargs slotd)) - (slot-name (slot-definition-name slotd))) - (or - ;; Try to initialize the slot from one of the initargs. - (do ((largs (core:validate-vaslist initargs)) - initarg - val) - ((progn - (= (core:vaslist-length (core:validate-vaslist largs)) 0)) - (progn nil)) - (setf initarg (core:vaslist-pop (core:validate-vaslist largs))) - (core:validate-vaslist largs) - #+(or)(when (endp largs) (core:simple-program-error "Wrong number of keyword arguments for SHARED-INITIALIZE, ~A" initargs)) - (when (= (core:vaslist-length (core:validate-vaslist largs)) 0) - (core:simple-program-error "Wrong number of keyword arguments for SHARED-INITIALIZE, ~A" - (progn - (core:vaslist-rewind initargs) - (core:list-from-vaslist initargs)))) - (unless (symbolp initarg) - (core:simple-program-error "Not a valid initarg: ~A" initarg)) - (setf val #+(or)(pop l) (core:vaslist-pop (core:validate-vaslist largs))) - (when (member initarg slot-initargs :test #'eq) - (setf (slot-value instance slot-name) val) - (return t))) - (when (and slot-names - (or (eq slot-names 'T) - (member slot-name slot-names)) - (not (slot-boundp instance slot-name))) - (let ((initfun (slot-definition-initfunction slotd))) - (when initfun - (setf (slot-value instance slot-name) (funcall initfun))))))))) - instance) +(defgeneric direct-slot-definition-class (class &rest canonicalized-slot)) +(defgeneric effective-slot-definition-class (class &rest canonicalized-slot)) +(defgeneric make-instances-obsolete (class)) +(defgeneric add-direct-subclass (parent child)) +(defgeneric remove-direct-subclass (parent child)) +(defgeneric validate-superclass (class superclass)) +(defgeneric finalize-inheritance (class)) +(defgeneric compute-slots (class)) +(defgeneric compute-effective-slot-definition-initargs (class direct-slotds)) +(defgeneric compute-effective-slot-definition (class name direct-slotds)) +(defgeneric compute-default-initargs (class)) +;; AMOP specifies some of the keys. FIXME? Dunno if we should bother +(defgeneric ensure-class-using-class (class name &key &allow-other-keys)) +(defgeneric reader-method-class (class direct-slot &rest initargs)) +(defgeneric writer-method-class (class direct-slot &rest initargs)) +(defgeneric (setf class-name) (new-name class)) (defun compute-instance-size (slots) ;; could just use cl:count, but type inference is bad atm @@ -96,90 +35,6 @@ when (eq (slot-definition-allocation slotd) :instance) sum 1)) -(defun make-rack-for-class (class) - (let (;; FIXME: Read this information from the class in one go, atomically. - (slotds (class-slots class)) - (size (class-size class)) - (stamp (core:class-stamp-for-instances class))) - (core:make-rack size slotds stamp (core:unbound)))) - -(defmethod allocate-instance ((class standard-class) &rest initargs) - (declare (ignore initargs)) - ;; CLHS says allocate-instance finalizes the class first. - ;; Dr. Strandh argues that this is impossible since the initargs should be the - ;; defaulted initargs, which cannot be computed without the class being finalized. - ;; More fundamentally but less legalistically, allocate-instance is not usually - ;; called except from make-instance, which checks finalization itself. - ;; If allocate-instance is nonetheless somehow called on an unfinalized class, - ;; class-size (also computed during finalization) will be unbound and error - ;; before anything terrible can happen. - ;; So we don't finalize here. - (core:allocate-raw-instance class (make-rack-for-class class))) - -(defmethod allocate-instance ((class core:derivable-cxx-class) &rest initargs) - (declare (ignore initargs)) - (core:allocate-raw-general-instance class (make-rack-for-class class))) - -(defun uninitialized-funcallable-instance-closure (funcallable-instance) - (lambda (core:&va-rest args) - (declare (core:lambda-name uninitialized-funcallable-instance)) - (declare (ignore args)) - (error "The funcallable instance ~a has not been initialized with a function" - funcallable-instance))) - -(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) - (declare (ignore initargs)) - (let ((instance (core:allocate-raw-funcallable-instance - class (make-rack-for-class class)))) - ;; MOP says if you call a funcallable instance before setting its function, - ;; the effects are undefined. (In the entry for set-funcallable-instance-function.) - ;; But we can be nice. - (set-funcallable-instance-function - instance (uninitialized-funcallable-instance-closure instance)) - instance)) - -(defmethod make-instance ((class class) &rest initargs) - (declare (dynamic-extent initargs)) ; see NOTE in reinitialize-instance/T - ;; Without finalization we can not find initargs. - (unless (class-finalized-p class) - (finalize-inheritance class)) - ;; We add the default-initargs first, because one of these initargs might - ;; be (:allow-other-keys t), which disables the checking of the arguments. - ;; (Paul Dietz's ANSI test suite, test CLASS-24.4) - (setf initargs (add-default-initargs class initargs)) - (let ((keywords (if (slot-boundp class 'valid-initargs) - (progn - (class-valid-initargs class)) - (progn - (precompute-valid-initarg-keywords class))))) - (check-initargs class initargs keywords)) - (let ((instance (apply #'allocate-instance class initargs))) - (apply #'initialize-instance instance initargs) - instance)) - -(defun delete-keyword (keyword list) - (loop until (eq (getf list keyword list) list) - do (remf list keyword)) - list) - -(defun add-default-initargs (class initargs) - ;; Here, for each slot which is not mentioned in the initialization - ;; arguments, but which has a value associated with :DEFAULT-INITARGS, - ;; we compute the value and add it to the list of initargs. - (let ((output '())) - (dolist (scan (class-default-initargs class)) - (let* ((initarg (first scan)) - (value (third scan)) - (supplied-value (si::search-keyword initargs initarg))) - (when (or (eq supplied-value '+initform-unsupplied+) - (eq supplied-value 'si::missing-keyword)) - (when (eq supplied-value '+initform-unsupplied+) - (setf initargs (delete-keyword initarg initargs))) - (setf output (list* (funcall value) initarg output))))) - (if output - (append initargs (nreverse output)) - initargs))) - ;;; ---------------------------------------------------------------------- ;;; CLASSES INITIALIZATION AND REINITIALIZATION ;;; @@ -193,7 +48,7 @@ (find-class 'standard-effective-slot-definition nil)) (defun unfinalizablep (class) - (or (forward-referenced-class-p class) + (or (typep class 'forward-referenced-class) (and (not (class-finalized-p class)) (some #'unfinalizablep (class-direct-superclasses class))))) @@ -201,15 +56,6 @@ (unless (unfinalizablep class) (finalize-inheritance class))) - -#+(or)(eval-when (:compile-toplevel :execute) - (format t "std-slot-value-lsp *print-implicit-compile-form* t~%") - (setf cmp::*print-implicit-compile-form* t)) - - -#+(or)(eval-when (:compile-toplevel :execute) - (gctools:wait-for-user-signal "About to standard-instance-access")) - (defmethod make-instances-obsolete ((class class)) ;; This changes what stamp new instances of the class get- which also means obsolete ;; instances will have a different stamp from their class, which is how the system @@ -225,6 +71,9 @@ (static-gfs:invalidate-changers* class) class) +(defmethod make-instances-obsolete ((class symbol)) + (make-instances-obsolete (find-class class))) + (defmethod initialize-instance :after ((class class) &rest initargs &key direct-slots) (declare (dynamic-extent initargs) ; see NOTE in reinitialize-instance/T @@ -276,26 +125,20 @@ (setf (creator class) (sys:compute-instance-creator class (class-of class) direct-superclasses)) class)) -(defun precompute-valid-initarg-keywords (class) - (setf (class-valid-initargs class) - (loop with methods = (nconc - (compute-applicable-methods - #'allocate-instance (list class)) - (compute-applicable-methods - #'initialize-instance (list (class-prototype class))) - (compute-applicable-methods - #'shared-initialize (list (class-prototype class) t))) - for m in methods - for k = (method-keywords m) - for aok-p = (method-allows-other-keys-p m) - when aok-p return t - else append k))) - -(defun update-dependents (object initargs) - (when *clos-booted* - (map-dependents - object - #'(lambda (dep) (apply #'update-dependent object dep initargs))))) +(defun freeze-class-slot-initfunction (slotd) + (when (eq (getf slotd :allocation) :class) + (let ((initfunc (getf slotd :initfunction))) + (when initfunc + (setf (getf slotd :initfunction) + (constantly (funcall initfunc)))))) + slotd) + +(defun canonical-slot-to-direct-slot (class slotd) + ;; Class slot init functions must be called right away + (let ((slotd (freeze-class-slot-initfunction slotd))) + (apply #'make-instance + (apply #'direct-slot-definition-class class slotd) + slotd))) (defmethod add-direct-subclass ((parent class) child) (pushnew child (%class-direct-subclasses parent))) @@ -309,8 +152,7 @@ (loop for superclass in supplied-superclasses ;; Until we process streams.lisp there are some invalid combinations ;; using built-in-class, which here we simply ignore. - unless (or (validate-superclass class superclass) - (not (eq *clos-booted* T))) + unless (validate-superclass class superclass) do (error "Class ~A is not a valid superclass for ~A" superclass class)) (setf supplied-superclasses (list (find-class (typecase class @@ -329,18 +171,63 @@ argument was supplied for metaclass ~S." (class-of class)))))))) (or (let ((c1 (class-of class)) (c2 (class-of superclass))) (or (eq c1 c2) - (and (eq c1 +the-standard-class+) (eq c2 +the-funcallable-standard-class+)) - (and (eq c2 +the-standard-class+) (eq c1 +the-funcallable-standard-class+)))) - (or (forward-referenced-class-p class) - (forward-referenced-class-p superclass)))) + (and (eq c1 #.(find-class 'standard-class)) + (eq c2 #.(find-class 'funcallable-standard-class))) + (and (eq c2 #.(find-class 'standard-class)) + (eq c1 #.(find-class 'funcallable-standard-class))))) + (or (typep class 'forward-referenced-class) + (typep superclass 'forward-referenced-class)))) ;;; NOTE: SBCL defines its own "SYSTEM-CLASS" to mean classes that are like ;;; built-in-classes but also subclassable. This may be worth consideration. (defmethod validate-superclass ((class class) (superclass built-in-class)) - (or (eq superclass +the-t-class+) ; FIXME: necessary? + (or (eq superclass #.(find-class 't)) ; required by AMOP ;; FIXME: Should gray streams go here? ;; Extensible sequences - (eq superclass (find-class 'sequence)))) + (eq superclass #.(find-class 'sequence)))) + +(defmethod add-dependent ((c class) dep) + (pushnew dep (class-dependents c))) + +(defmethod remove-dependent ((c class) dep) + (setf (class-dependents c) + (remove dep (class-dependents c)))) + +(defmethod map-dependents ((c class) function) + (dolist (d (class-dependents c)) + (funcall function d))) + +(defmethod (setf class-name) (new-name (class class)) + (reinitialize-instance class :name new-name) + new-name) + +;;; ---------------------------------------------------------------------- +;;; GENERIC FUNCTION INVALIDATION + +(defun call-history-entry-key-contains-specializers-p (key specializer) + (find specializer key :test #'eq)) + +(defun generic-function-call-history-separate-entries-with-specializer + (call-history specializer) + (loop for entry in call-history + for key = (car entry) + if (call-history-entry-key-contains-specializers-p key specializer) + collect entry into removed + else + collect entry into keep + finally (return (values keep removed)))) + +;; Remove all call entries referring directly to a class, and invalidate or +;; force their discriminating functions. +(defun invalidate-generic-functions-with-class-selector (class) + (loop for gf in (specializer-call-history-generic-functions class) + do (mp:atomic-update (generic-function-call-history gf) + #'generic-function-call-history-separate-entries-with-specializer + class) + ;; We don't force the dispatcher, because when a class with + ;; subclasses is redefined, we may end up here repeatedly. + ;; Eagerness would result in pointless compilation. + (invalidate-discriminating-function gf))) ;;; ---------------------------------------------------------------------- ;;; FINALIZATION OF CLASS INHERITANCE @@ -357,7 +244,7 @@ argument was supplied for metaclass ~S." (class-of class)))))))) ;; a not yet defined class or it has not yet been finalized. ;; In the first case we can just signal an error... ;; - (let ((x (find-if #'forward-referenced-class-p (rest cpl)))) + (let ((x (find-if (lambda (c) (typep c 'forward-referenced-class)) (rest cpl)))) (when x (error "Cannot finish building the class~% ~A~%~ because it contains a reference to the undefined class~% ~A" @@ -405,6 +292,31 @@ because it contains a reference to the undefined class~% ~A" ;; slot definitions from slot-value. (std-create-slots-table class)) +;;; +;;; Clasp classes store slots in a hash table for faster access. The +;;; following functions create the cache and allow us to locate the +;;; slots rapidly. +;;; +(defun std-create-slots-table (class) + (with-slots ((all-slots slots) + (location-table location-table)) + class + (let ((size (max 32 (* 2 (length all-slots)))) + (metaclass (si::instance-class class)) + (locations nil)) + (when (or (eq metaclass #.(find-class 'standard-class)) + (eq metaclass #.(find-class 'funcallable-standard-class)) + (eq metaclass #.(find-class 'structure-class))) + (setf locations (make-hash-table :size size)) + (dolist (slotd all-slots) + (setf (gethash (slot-definition-name slotd) locations) + (slot-definition-location slotd)))) + (setf location-table locations)))) + +;;; KLUDGE: Dummy definition, redefined in static-gfs +#+static-gfs +(defun static-gfs:invalidate-class-constructors (class) + (declare (ignore class))) (defmethod finalize-inheritance :after ((class std-class)) #+static-gfs @@ -415,12 +327,62 @@ because it contains a reference to the undefined class~% ~A" (static-gfs:invalidate-class-reinitializers* class) (std-class-generate-accessors class)) -(defmethod compute-class-precedence-list ((class class)) - (compute-clos-class-precedence-list class (class-direct-superclasses class))) - -(eval-when (:compile-toplevel :execute :load-toplevel) - (defmacro mapappend (fun &rest args) - `(reduce #'append (mapcar ,fun ,@args)))) +(defun std-class-generate-accessors (standard-class) + ;; + ;; The accessors are closures, which are generated every time the + ;; slots of the class change. The accessors are safe: they check that + ;; the slot is bound after retreiving the value, and they may take + ;; the liberty of using SI:INSTANCE-REF because they know the class of + ;; the instance. + ;; + (dolist (slotd (slot-value standard-class 'direct-slots)) + (with-slots ((name name) (allocation allocation) (location location) + (readers readers) (writers writers)) + slotd + (multiple-value-bind (reader writer) (std-class-accessors name) + (let* ((options (list :slot-definition slotd + :source-position (class-source-position + standard-class))) + (reader-args (list* :function reader + :generic-function nil + :qualifiers nil + :lambda-list '(object) + :specializers `(,standard-class) + options)) + (reader-class (apply #'reader-method-class standard-class slotd + reader-args)) + (writer-args (list* :function writer + :generic-function nil + :qualifiers nil + :lambda-list '(value object) + :specializers `(,(find-class t) ,standard-class) + options)) + (writer-class (apply #'writer-method-class standard-class slotd + writer-args))) + (dolist (fname readers) + (let ((method (make-method reader-class nil `(,standard-class) '(object) + reader + options))) + (add-method (ensure-generic-function fname) method))) + (dolist (fname writers) + (let ((method (make-method writer-class nil + `(,(find-class t) ,standard-class) '(value object) + writer + options))) + (add-method (ensure-generic-function fname) method)))))))) + +(defun std-class-accessors (slot-name) + (values (make-%leaf-method-function + #'(lambda (self) + (declare (core:lambda-name std-class-accessors.reader.lambda)) + (slot-value self slot-name))) + (make-%leaf-method-function + #'(lambda (new-value self) + (declare (core:lambda-name std-class-accessors.writer.lambda)) + (setf (slot-value self slot-name) new-value))))) + +(defmacro mapappend (fun &rest args) + `(reduce #'append (mapcar ,fun ,@args))) (defmethod compute-slots ((class class)) ;; INV: for some classes ECL expects that the order of the inherited slots is @@ -453,11 +415,6 @@ because it contains a reference to the undefined class~% ~A" :documentation (slot-definition-documentation slotd) :location (slot-definition-location slotd))) -(defun safe-slot-definition-location (slotd &optional default) - (if (or (listp slotd) (slot-boundp slotd 'location)) - (slot-definition-location slotd) - default)) - (defmethod compute-effective-slot-definition-initargs ((class class) direct-slotds) ;;; See CLHS 7.5.3 for the explanation of how slot options are inherited. (let (name initform initfunction allocation documentation @@ -486,7 +443,7 @@ because it contains a reference to the undefined class~% ~A" ((subtypep type new-type) type) (T `(and ,new-type ,type))))) ;;; Clasp extension: :location can be specified. - (let ((new-loc (safe-slot-definition-location slotd))) + (let ((new-loc (slot-definition-location slotd))) (if location (when new-loc (unless (eql location new-loc) @@ -524,16 +481,14 @@ because it contains a reference to the undefined class~% ~A" ;;; IMPORTANT: The following implementation of ENSURE-CLASS-USING-CLASS is ;;; shared by the metaclasses STANDARD-CLASS and STRUCTURE-CLASS. ;;; -(defmethod ensure-class-using-class ((class class) name core:&va-rest rest +(defmethod ensure-class-using-class ((class class) name &rest rest &key direct-slots direct-default-initargs &allow-other-keys) (declare (ignore direct-default-initargs direct-slots)) - (clos::gf-log "In ensure-class-using-class (class class) %N") - (clos::gf-log " name -> {}%N" name) (multiple-value-bind (metaclass direct-superclasses options) (apply #'help-ensure-class rest) (declare (ignore direct-superclasses)) - (cond ((forward-referenced-class-p class) + (cond ((typep class 'forward-referenced-class) (change-class class metaclass)) ((not (eq (class-of class) metaclass)) (error "When redefining a class, the metaclass can not change."))) @@ -541,9 +496,17 @@ because it contains a reference to the undefined class~% ~A" (when name (si:create-type-name name) (setf (find-class name) class)) - (clos::gf-log "Returning from ensure-class-using-class (class class)%N") class)) +(defmethod ensure-class-using-class ((class null) name &rest rest) + (multiple-value-bind (metaclass direct-superclasses options) + (apply #'help-ensure-class rest) + (declare (ignore direct-superclasses)) + (when name + (si:create-type-name name) + (setf (find-class name) + (apply #'make-instance metaclass :name name options))))) + (defun coerce-to-class (class-or-symbol &optional (fail nil)) (cond ((classp class-or-symbol) class-or-symbol) ((not (symbolp class-or-symbol)) @@ -568,6 +531,18 @@ because it contains a reference to the undefined class~% ~A" (values metaclass direct-superclasses (list* :direct-superclasses direct-superclasses options))) +(defmethod reader-method-class ((class std-class) + (direct-slot direct-slot-definition) + &rest initargs) + (declare (ignore class direct-slot initargs)) + (find-class 'standard-reader-method)) + +(defmethod writer-method-class ((class std-class) + (direct-slot direct-slot-definition) + &rest initargs) + (declare (ignore class direct-slot initargs)) + (find-class 'standard-writer-method)) + ;;; ---------------------------------------------------------------------- ;;; Around methods for COMPUTE-SLOTS which assign locations to each slot. ;;; @@ -584,8 +559,8 @@ because it contains a reference to the undefined class~% ~A" (let* ((size (compute-instance-size slots)) (instance-slots (remove :instance slots :key #'slot-definition-allocation :test-not #'eq)) - (numbered-slots (remove-if-not #'safe-slot-definition-location instance-slots)) - (other-slots (remove-if #'safe-slot-definition-location instance-slots)) + (numbered-slots (remove-if-not #'slot-definition-location instance-slots)) + (other-slots (remove-if #'slot-definition-location instance-slots)) (aux (make-array size :initial-element nil))) (loop for i in numbered-slots do (let ((loc (slot-definition-location i))) @@ -636,138 +611,228 @@ because it contains a reference to the undefined class~% ~A" (defmethod compute-slots :around ((class std-class)) (std-class-compute-slots class (call-next-method))) -;;; ====================================================================== -;;; STANDARD-OBJECT +;;; ---------------------------------------------------------------------- +;;; +;;; (PARSE-SLOTS slot-definition-form) => slot-definition-object +;;; +;;; This routine is the one responsible for parsing the definition of +;;; a slot in DEFCLASS. ;;; -;;; Standard-object has no slots and inherits only from t: -;;; (defclass standard-object (t) ()) - -(defun describe-slots (object stream) - (let* ((class (class-of object)) - (slotds (class-slots class)) - (max-slot-name-length 24) - (plist nil)) - ;; Go through the slots getting a max slot name length, - ;; and also sorting the slots by :allocation. - ;; (This code is based off of SBCL's SB-IMPL::DESCRIBE-INSTANCE.) - (dolist (slotd slotds) - (setf max-slot-name-length - (max max-slot-name-length - (length (symbol-name - (slot-definition-name slotd))))) - (push slotd (getf plist (slot-definition-allocation slotd)))) - ;; Now dump the info. - (loop for (allocation slotds) on plist by #'cddr - do (format stream "~&Slots with ~s allocation:" allocation) - (dolist (slotd (nreverse slotds)) ; keep original order - (let ((slot-name (slot-definition-name slotd))) - (format stream "~& ~va: ~a" - max-slot-name-length slot-name - (if (slot-boundp object slot-name) - (slot-value object slot-name) - "Unbound")))))) - object) - -(defmethod describe-object ((obj standard-object) (stream t)) - (let* ((class (class-of obj))) - (format stream "~&~S - ~S" - obj (class-name class)) - (describe-slots obj stream)) - obj) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun parse-slot (slot) + (if (symbolp slot) + `(list :name ',slot) + (do* (output + (options (rest slot)) + (extra nil) + (initfunction)) + ((null options) + (let ((result (nconc output extra))) + (if initfunction + `(list* :name ',(first slot) :initfunction ,initfunction ',result) + `(list* :name ',(first slot) ',result)))) + (let ((option (pop options))) + (when (endp options) + (si::simple-program-error + "In the slot description ~S,~%the option ~S is missing an argument" + slot option)) + (let ((value (pop options))) + (when (and (member option '(:allocation :initform :type :documentation)) + (getf options option)) + (si::simple-program-error + "In the slot description ~S,~%the option ~S is duplicated" + slot option)) + (case option + (:initarg (push value (getf output :initargs))) + (:initform (setf (getf output :initform) value + initfunction + `(lambda () ,value))) + (:accessor (push value (getf output :readers)) + (push `(setf ,value) (getf output :writers))) + (:reader (push value (getf output :readers))) + (:writer (push value (getf output :writers))) + (:allocation (setf (getf output :allocation) value)) + (:type (setf (getf output :type) value)) + (:documentation (push value (getf output :documentation))) + (otherwise (if (or (getf extra option) + (getf options option)) + (push value (getf extra option)) + (setf (getf extra option) value))))))))) + +(defun parse-slots (slots) + (do ((scan slots (cdr scan)) + (collect)) + ((null scan) + `(list ,@(nreverse collect))) + (let* ((slotd (parse-slot (first scan))) + (name (getf (cdr slotd) :name))) + (dolist (other-slotd collect) + ;;; name might be (quote ) so test with eq or eql does not work + (when (equal name (getf (cdr other-slotd) :name)) + (si::simple-program-error + "A definition for the slot ~S appeared twice in a DEFCLASS form" + name))) + (push slotd collect)))) + +;;; ---------------------------------------------------------------------- +;;; DEFCLASS + +(defun parse-default-initargs (default-initargs) + (do* ((output-list nil) + (scan default-initargs (cddr scan)) + (already-supplied '())) + ((endp scan) `(list ,@(nreverse output-list))) + (when (endp (rest scan)) + (si::simple-program-error "Wrong number of elements in :DEFAULT-INITARGS option.")) + (let ((slot-name (first scan)) + (initform (second scan))) + (if (member slot-name already-supplied) + (si::simple-program-error "~S is duplicated in :DEFAULT-INITARGS form ~S" + slot-name default-initargs) + (push slot-name already-supplied)) + (push `(list ',slot-name ',initform (lambda () + (declare (core:lambda-name parse-default-initargs.lambda)) + ,initform)) + output-list)))) + +(defun gen-note-accessors (slots) + (flet ((gen-note (name) + `(cmp::register-global-function-def 'defmethod ',name))) + (loop with result = nil + for slot in slots + when (consp slot) + do (loop for (key value) on (rest slot) by #'cddr + do (case key + ((:reader :writer) + (push (gen-note value) result)) + ((:accessor) + (push (gen-note value) result) + (push (gen-note `(setf ,value)) result)))) + finally (return result)))) + +(defun process-class-options (class-args) + (let ((options '()) + (processed-options '())) + (dolist (option class-args options) + (unless (consp option) + (si:simple-program-error + "Option ~s for DEFCLASS has invalid syntax: not a cons" option)) + (let ((option-name (first option)) + option-value) + (unless (symbolp option-name) + (si:simple-program-error + "~s is not a valid DEFCLASS option: not a symbol" option-name)) + (if (member option-name processed-options) + (si:simple-program-error + "Option ~s for DEFCLASS specified more than once" + option-name) + (push option-name processed-options)) + (setq option-value + (case option-name + ((:metaclass :documentation) + `',(second option)) +;; ((:source-position) (second option)) ; see FIXME above + (:default-initargs + (setf option-name :direct-default-initargs) + (parse-default-initargs (rest option))) + (otherwise + `',(rest option))) + options (list* `',option-name option-value options)))))) +) ; eval-when + +(defmacro defclass (name superclasses slots &rest options) + (let (;; Throw in source info if there is any. + (options (if (ext:current-source-location) + (list* (cons :source-position (ext:current-source-location)) options) + options))) + (unless (and (listp superclasses) (listp slots)) + (si::simple-program-error "Illegal defclass form: superclasses and slots should be lists")) + (unless (and (symbolp name) (every #'symbolp superclasses)) + (si::simple-program-error "Illegal defclass form: superclasses and class name are not valid")) + (let ((parsed-slots (parse-slots slots)) + (processed-class-options (process-class-options options))) + `(progn + (eval-when (:compile-toplevel) + ,@(gen-note-accessors slots) + (setf (core::class-info ',name) t)) + (eval-when (:load-toplevel :execute) + (ensure-class ',name :direct-superclasses ',superclasses + :direct-slots ,parsed-slots + ,@processed-class-options)))))) ;;; ---------------------------------------------------------------------- -;;; CHECK INITARGS +;;; ENSURE-CLASS ;;; -;;; There are different sets of initialization arguments. First we have -;;; those coming from the :INITARG option in the slots. Then we have -;;; all declared initargs which are keyword arguments to methods defined -;;; on SHARED-INITIALIZE, REINITIALIZE-INSTANCE, etc. (See ANSI 7.1.2) +(defun ensure-class (name &rest initargs) + (apply #'ensure-class-using-class + (let ((class (and name + (find-class name nil)))) + ;; Only classes which have a PROPER name are redefined. If a class + ;; with the same name is registered, but the name of the class does not + ;; correspond to the registered name, a new class is returned. + ;; [Hyperspec 7.7 for DEFCLASS] + (when (and class (eq name (class-name class))) + class)) + name initargs)) + +;;; ---------------------------------------------------------------------- +;;; (SETF FIND-CLASS) ;;; -(defun valid-keywords-from-methods (&rest method-lists) - (declare (dynamic-extent method-lists)) - (loop for methods in method-lists - when (member t methods :key #'method-keywords) - return t - nconc methods)) - -(defun check-initargs (class initargs cached-keywords - &optional (slots (class-slots class))) - ;; First get all initargs which have been declared in the given - ;; methods, then check the list of initargs declared in the slots - ;; of the class. - (unless (eq cached-keywords t) - (do* ((name-loc initargs (cddr name-loc)) - (allow-other-keys nil) - (allow-other-keys-found nil) - (unknown-key-names nil)) - ((null name-loc) - (when (and (not allow-other-keys) unknown-key-names) - (core:simple-program-error "Unknown initialization options ~S for class ~A." - (nreverse unknown-key-names) class))) - (let ((name (first name-loc))) - (cond ((null (cdr name-loc)) - (core:simple-program-error - "No value supplied for the init-name ~S." name)) - ;; This check must be here, because :ALLOW-OTHER-KEYS is a valid - ;; slot-initarg. - ((and (eql name :ALLOW-OTHER-KEYS) - (not allow-other-keys-found)) - (setf allow-other-keys (second name-loc) - allow-other-keys-found t)) - ;; Check if the arguments is associated with a slot - ((member name slots :test #'member :key #'slot-definition-initargs)) - ;; The initialization argument has been declared in some method - ((member name cached-keywords)) - (t - (push name unknown-key-names))))))) - -(defun check-initargs-uncached (class initargs - &optional calls (slots (class-slots class))) - ;; We try to avoid calling compute-applicable-methods since that's work. - ;; (In simple tests, avoiding it gave a speedup of 2-3 times.) - ;; So we first check if all the initargs correspond to slots. If they do, - ;; great. If not we compute-applicable-methods to get more valid keywords. - ;; This assumes that the likely case is all the initargs corresponding to - ;; slots, but it shouldn't really be any slower if they don't. - ;; CALLS is a list of (function arglist). These can be passed directly - ;; to compute-applicable-methods. - (do* ((name-loc initargs (cddr name-loc)) - (allow-other-keys nil) - (allow-other-keys-found nil) - (unknown-key-names nil) - (methods nil) - (methods-initialized-p nil)) - ((null name-loc) - (when (and (not allow-other-keys) unknown-key-names) - (core:simple-program-error - "Unknown initialization options ~S for class ~A." - (nreverse unknown-key-names) class))) - (let ((name (first name-loc))) - (cond ((null (cdr name-loc)) - (core:simple-program-error "No value supplied for the init-name ~S." - name)) - ;; This check must be here, because :ALLOW-OTHER-KEYS is a valid - ;; slot-initarg. - ((and (eql name :ALLOW-OTHER-KEYS) - (not allow-other-keys-found)) - (setf allow-other-keys (second name-loc) - allow-other-keys-found t)) - ;; Check if the arguments is associated with a slot - ((member name slots :test #'member :key #'slot-definition-initargs)) - ;; OK, doesn't correspond to a slot, so check the methods. - ((progn - (unless methods-initialized-p - (setf methods-initialized-p t - methods - (loop for call in calls - for methods - = (apply #'compute-applicable-methods call) - for methods2 = (valid-keywords-from-methods - methods) - when (eq methods2 t) ; allow-other-keys - do (return-from check-initargs-uncached) - nconcing methods2))) - (member name methods :test #'member :key #'method-keywords))) - (t (push name unknown-key-names)))))) +;;; KLUDGE: Dummy definition, redefined in static-gfs +#+static-gfs +(defun static-gfs:invalidate-designated-constructors (name) + (declare (ignore name))) + +(defun (setf find-class) (new-value name &optional errorp env) + (declare (ignore errorp env)) + (let ((old-class (find-class name nil))) + (cond + ((and old-class + (or (typep old-class 'built-in-class) + (member name '(class built-in-class) :test #'eq))) + (unless (eq new-value old-class) + (error "The class associated to the CL specifier ~S cannot be changed." + name))) + ((or (classp new-value) (null new-value)) + (core:setf-find-class new-value name) + #+static-gfs + (static-gfs:invalidate-designated-constructors name) + #+(or) ;static-gfs + (static-gfs:invalidate-designated-changers name)) + (t (error 'simple-type-error :datum new-value :expected-type '(or class null) + :format-control "~A is not a valid class for (setf find-class)" + :format-arguments (list new-value))))) + new-value) + +;;; ---------------------------------------------------------------------- +;;; class info + +#| +CLHS specifies that + +"If a defclass form appears as a top level form, the compiler must make the class name be recognized as a valid type name in subsequent declarations (as for deftype) and be recognized as a valid class name for defmethod parameter specializers and for use as the :metaclass option of a subsequent defclass. The compiler must make the class definition available to be returned by find-class when its environment argument is a value received as the environment parameter of a macro." + +Our DEFMETHOD and :metaclass do not need any compile time info. We do want to know what classes are classes for the TYPEP compiler macro. + +The CLHS's last requirement about find-class is a problem. We can't fully make classes at compile time. There might be methods on validate-superclass, ensure-class-using-class, *-slot-definition-class, etc., without which a class definition will be invalid, and which won't necessarily be defined at compile time. I am writing this comment because of such a problem with validate-superclass in a real library (bug #736). + +Partway making a class probably isn't valid either. We definitely can't make an actual instance of any specified metaclass, or actual slot definitions, for the above reasons, etc, etc. + +So we just ignore the CLHS requirement here and use a CLASS-INFO mechanism. This is a function that returns compile-time information about a class. A toplevel DEFCLASS form will, at compile time, register the class in the class-info table. + +Right now the only such information is that it exists. In the future I'd like to include real information (e.g. unparsed class options or slot definitions) for use in optimization or to the user. +|# + +(defvar *class-infos* (make-hash-table :test #'eq :thread-safe t)) + +(defun core::class-info (name &optional env) + (or (find-class name nil env) + (values (gethash name *class-infos*)))) +(defun (setf core::class-info) (value name &optional env) + (declare (ignore env)) + (if (null value) + (progn (remhash name *class-infos*) value) + (setf (gethash name *class-infos*) value))) diff --git a/src/lisp/kernel/clos/closfastgf.lisp b/src/lisp/kernel/clos/closfastgf.lisp deleted file mode 100644 index d2290fcc3f..0000000000 --- a/src/lisp/kernel/clos/closfastgf.lisp +++ /dev/null @@ -1,876 +0,0 @@ -;;; ------------------------------------------------------------ -;;; -;;; Generic function dispatch runtime -;;; This implements the algorithm described by Robert Strandh -;;; for fast generic function dispatch. See discriminate.lisp -;;; for the code generator, dtree.lisp for the interpreted -;;; version, and funcallableInstance.cc for the interpreter -;;; itself. - -(in-package :clos) - -;;; ------------------------------------------------------------ -;;; -;;; Debugging code -;;; -;;; Add :DEBUG-FASTGF to log fastgf messages during the slow path. -;;; -#+(or) -(eval-when (:compile-toplevel :load-toplevel :execute) - (pushnew :debug-fastgf *features*)) - -#+debug-fastgf -(eval-when (:execute :load-toplevel) - (defstruct (debug-fastgf-struct (:type vector)) - stream - didx - indent - miss-count) - (defvar *dmspaces* "| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | ") -;;; Cleanup up the directory - - (defvar *dispatch-history-dir* - (let ((dir (core:monitor-directory))) - (ensure-directories-exist dir) - (core:fmt *error-output* "!!!! Created gf dispatch monitor directory: {}%N" dir) - (core:fmt *error-output* "!!!! Run clasp with --feature fastgf-dump-module to write dispatchers to this directory%N") - (dolist (f (directory (core:fmt nil "{}/*.*" dir))) - (delete-file f)) - dir)) - (defun lazy-initialize-debug-fastgf () - (unless core:*debug-fastgf* - (let ((filename (core:fmt nil "{}/debug-miss-thread{}.log" - *dispatch-history-dir* - (mp:thread-id mp:*current-process*)))) - (setf core:*debug-fastgf* (make-debug-fastgf-struct :stream (open filename :direction :output) - :didx 0 - :indent 0 - :miss-count (make-hash-table)))))) - (defun debug-fastgf-stream () - (lazy-initialize-debug-fastgf) - (debug-fastgf-struct-stream core:*debug-fastgf*)) - - (defun debug-fastgf-didx () - (lazy-initialize-debug-fastgf) - (debug-fastgf-struct-didx core:*debug-fastgf*)) - (defun incf-debug-fastgf-didx () - (incf (debug-fastgf-struct-didx core:*debug-fastgf*))) - - (defun debug-fastgf-miss-count (gf) - (gethash gf (debug-fastgf-struct-miss-count core:*debug-fastgf*) 0)) - (defun incf-debug-fastgf-miss-count (gf) - (lazy-initialize-debug-fastgf) - (incf (gethash gf (debug-fastgf-struct-miss-count core:*debug-fastgf*) 0))) - - (defun debug-fastgf-indent () - (debug-fastgf-struct-indent core:*debug-fastgf*)) - (defun incf-debug-fastgf-indent () - (lazy-initialize-debug-fastgf) - (incf (debug-fastgf-struct-indent core:*debug-fastgf*) 2)) - (defun decf-debug-fastgf-indent () - (decf (debug-fastgf-struct-indent core:*debug-fastgf*) 2)) - (defmacro fmt-noindent (fmt &rest args) - `(progn - (lazy-initialize-debug-fastgf) - (core:fmt (debug-fastgf-stream) ,fmt ,@args))) - (defmacro fmt-indent (fmt &rest args) - `(progn - (lazy-initialize-debug-fastgf) - (core:fmt (debug-fastgf-stream) (subseq *dmspaces* 0 (min (length *dmspaces*) (debug-fastgf-indent)))) - (core:fmt (debug-fastgf-stream) ,fmt ,@args))) - (defun log-cmpgf-filename (gfname suffix extension) - (pathname (core:fmt nil "{}/dispatch-thread{}-{:0>5d}-{}.{}" - *dispatch-history-dir* - (mp:thread-id mp:*current-process*) - suffix - (debug-fastgf-didx) - (core:tostring gfname) - extension))) - (defmacro gf-log-dispatch-miss-followup (msg &rest args) - `(progn - (fmt-indent "------- ") - (fmt-noindent ,msg ,@args))) - (defmacro gf-log-dispatch-miss-message (msg &rest args) - `(fmt-indent ,msg ,@args)) - (defun pretty-selector-as-string (selector) - (cond - ((eql-specializer-p selector) - (with-early-accessors (+eql-specializer-slots+) - (core:fmt nil "(EQL {})" (eql-specializer-object selector)))) - ((null selector) - (core:fmt nil "NULL/(not-specialized?)")) - ((classp selector) ; A class - (core:fmt nil "[class {}/{}]" (class-name selector) (core:class-stamp-for-instances selector))) - (t ; This shouldn't happen - (core:fmt nil "!!!!!ILLEGAL-SELECTOR-IN-CALL-HISTORY-ENTRY-KEY!!!!!")))) - (defmacro gf-print-entry (index entry) - (let ((selector (gensym)) - (key (gensym))) - `(progn - (fmt-indent " entry#{:3d}: (" (prog1 ,index (incf ,index))) - (let ((,key (car ,entry))) - ;;(fmt-indent " ----> {}%N" history-entry) - (dolist (,selector (coerce ,key 'list)) - (fmt-noindent " {}" (pretty-selector-as-string ,selector))) - (fmt-noindent ")%N"))))) - (defun %gf-log-dispatch-miss (msg gf args) - (incf-debug-fastgf-didx) - (incf-debug-fastgf-miss-count gf) - (fmt-indent "------- DIDX:{} {}%N" (debug-fastgf-didx) msg) - (fmt-indent "Dispatch miss #{} for {}%N" (debug-fastgf-miss-count gf) - (generic-function-name gf)) - (let* ((call-history (mp:atomic (safe-gf-call-history gf)))) - (fmt-indent " args (num args -> {}): %N" (length args)) - (let ((arg-index -1)) - (dolist (arg args) - (fmt-indent "argument# {}: {}[{}/{}] %N" - (incf arg-index) arg (class-of arg) - (core:instance-stamp arg)))) - (let ((index 0)) - (fmt-indent " raw call-history (length -> {}):%N" (length call-history)) - (dolist (entry call-history) - (gf-print-entry index entry))) - (let* ((call-history (mp:atomic (safe-gf-call-history gf))) - (index 0)) - (fmt-indent " call-history (length -> {}):%N" (length call-history)) - (dolist (entry call-history) - (gf-print-entry index entry)))) - (finish-output (debug-fastgf-stream))) - (defmacro gf-log-dispatch-miss (msg gf args) - `(%gf-log-dispatch-miss ,msg ,gf ,args)) - (defmacro gf-log (fmt &rest fmt-args) `(fmt-indent ,fmt ,@fmt-args)) - (defmacro gf-log-noindent (fmt &rest fmt-args) `(fmt-noindent ,fmt ,@fmt-args)) - (defmacro gf-do (&body code) `(progn ,@code))) - -#-debug-fastgf -(eval-when (:execute :load-toplevel) - (defmacro gf-log-dispatch-miss (msg gf args) - (declare (ignore msg gf args))) - (defmacro gf-log-dispatch-miss-followup (msg &rest args) - (declare (ignore msg args))) - (defmacro gf-log-dispatch-miss-message (msg &rest args) - (declare (ignore msg args))) - (defmacro gf-log (fmt &rest fmt-args) (declare (ignore fmt fmt-args))) - (defmacro gf-log-noindent (fmt &rest fmt-args) - (declare (ignore fmt fmt-args))) - (defmacro gf-do (&body code) (declare (ignore code))) - (defun incf-debug-fastgf-indent ()) - (defun decf-debug-fastgf-indent ()) - ) - -;;; -------------------------------------------------- -;;; -;;; This section contains code that is called by CLOS to -;;; update generic-function-call-history and to call -;;; codegen-dispatcher to generate a new dispatch function when needed -;;; - -;; Returns true iff the instance was updated. -(defun maybe-update-instance (instance) - (when (and (core:instancep instance) - (si:sl-boundp (si:instance-sig instance))) - (with-early-accessors (+standard-class-slots+) - (let ((instance-stamp (core:instance-stamp instance)) - (class-stamp (core:class-stamp-for-instances - (core:instance-class instance)))) - (unless (= instance-stamp class-stamp) - (gf-log " instance-stamp matches that of class -> {}%N" - (= instance-stamp class-stamp)) - (gf-log "(core:instance-stamp i) -> {}%N" instance-stamp) - (gf-log "(core:class-stamp-for-instances (core:instance-class i)) -> {}%N" - class-stamp) - (update-instance instance) - t))))) - -(defun maybe-update-instances (arguments) - (let ((invalid-instance nil)) - (dolist (i arguments invalid-instance) - (setf invalid-instance (or (maybe-update-instance i) invalid-instance))))) - -(defun applicable-method-p (method specializers) - (loop for spec in (method-specializers method) - for argspec in specializers - always (cond ((eql-specializer-p spec) - (and (eql-specializer-p argspec) - (eql (eql-specializer-object argspec) - (eql-specializer-object spec)))) - ((eql-specializer-p argspec) - ;; This is (typep (e-s-o ...) spec) but we know spec is - ;; a class so we skip to this. - (si:subclassp (class-of (eql-specializer-object argspec)) - spec)) - (t (si:subclassp argspec spec))))) - -;;; This "fuzzed" applicable-method-p is used in -;;; update-call-history-for-add-method, below, to handle added EQL-specialized -;;; methods properly. See bug #1009. -(defun fuzzed-applicable-method-p (method specializers) - (loop for spec in (method-specializers method) - for argspec in specializers - always (cond ((eql-specializer-p spec) - (if (eql-specializer-p argspec) - (eql (eql-specializer-object argspec) - (eql-specializer-object spec)) - (si:subclassp argspec - (class-of (eql-specializer-object spec))))) - ((eql-specializer-p argspec) - (si:subclassp (class-of (eql-specializer-object argspec)) - spec)) - (t (si:subclassp argspec spec))))) - -(defun applicable-method-list-using-specializers (gf specializers) - (declare (optimize (speed 3))) - (with-early-accessors (+standard-method-slots+ - +standard-generic-function-slots+ - +eql-specializer-slots+ - +standard-class-slots+) - (loop for method in (generic-function-methods gf) - when (applicable-method-p method specializers) - collect (maybe-replace-method method specializers)))) - -(defun compute-applicable-methods-using-specializers (generic-function specializers) - (check-type specializers list) - (sort-applicable-methods - generic-function - (applicable-method-list-using-specializers generic-function specializers) - specializers)) - -(defun effective-slotd-from-accessor-method (method class) - (let* ((direct-slot (accessor-method-slot-definition method)) - (direct-slot-name (slot-definition-name direct-slot)) - (effective-slot-defs (class-slots class)) - (slot (loop for effective-slot in effective-slot-defs - when (eq direct-slot-name (slot-definition-name effective-slot)) - return effective-slot))) - (when (null slot) - ;; should be impossible. one way I hit it: abnormal slots from boot.lisp - (error "BUG: cannot find effective slot for optimized accessor! class ~s, slot name ~s" - class direct-slot-name)) - slot)) - -;; We try to reuse effective method functions when possible. -;; This has two advantages: One, we avoid recompiling the same effective method multiple times. -;; Two, the code generator can understand the outcomes as identical and merge tests together. -;; Note that this being correct relies on an important property: that compute-effective-method -;; can in fact be memoized. This would not be the case if for example a method on it returns -;; different things for the same (by EQUAL) applicable method lists randomly or by time, or if -;; a relevant compute-effective-method method is added after a generic function already has -;; computed some. Or if a method combination does something similarly weird. -;; I'm not really worried about this because nobody defines methods on c-e-m anyway. -;; Also, this is a max O(mn) search, where m is the number of methods and n the length of call -;; history. It could be more efficient, but that makes it more involved to remove old entries -;; (with this scheme they're just removed with the call history entries). -(defun find-existing-outcome (call-history methods) - (loop for (ignore . outcome) in call-history - when (equal methods (outcome-methods outcome)) - return outcome)) - -(defun optimizable-reader-method-p (method) - ;; In the future, we could use load-time-value instead of find-class every time, - ;; but the system loading architecture makes this dicey at the moment. - (eq (class-of method) (find-class 'standard-reader-method))) - -(defun optimizable-writer-method-p (method) - (eq (class-of method) (find-class 'standard-writer-method))) - -(defun standard-slotd-p (slotd) - (eq (class-of slotd) (find-class 'standard-effective-slot-definition))) - -(defun maybe-replace-method (method specializers) - (let ((mc (class-of method))) - (cond ((and - (eq mc (find-class 'standard-reader-method)) - (let ((eslotd (effective-slotd-from-accessor-method - method (first specializers)))) - (and (standard-slotd-p eslotd) - (intern-effective-reader - method (slot-definition-location eslotd)))))) - ((and - (eq mc (find-class 'standard-writer-method)) - (let ((eslotd (effective-slotd-from-accessor-method - method (second specializers)))) - (and (standard-slotd-p eslotd) - (intern-effective-writer - method (slot-definition-location eslotd)))))) - (t method)))) - -(defun final-methods (methods specializers) - (loop for method in methods - collect (maybe-replace-method method specializers))) - -;;; the gf-arg-info of a generic-function is a cons (boolean . vars) -;;; where vars is a list of symbols. This is used by effective-method-function -;;; to squeeze out a bit more performance by avoiding &va-rest when possible, -;;; which in turn allows methods to be called without APPLY. -;;; the boolean is whether a &rest is needed (so, whether there's an &optional, -;;; &rest, or &key in the generic function lambda list) and the vars are -;;; suggestions for the required parameters. The length has to be correct. -;;; so e.g. (T a b c) means a lambda list of (a b c &rest more) or so. -(defun gf-arg-info (gf) - (multiple-value-bind (nreq max) (generic-function-min-max-args gf) - (cons (or (not max) (> max nreq)) - ;; TODO: Would be kind of nice to get something like variable names. - (loop repeat nreq collect (gensym "REQ-ARG"))))) - -(defun compute-outcome - (generic-function method-combination methods actual-specializers) - ;; Calculate the effective-method-function as well as an optimized one - ;; so that we can apply the e-m-f to the arguments if we need to debug the optimized version. - ;; This will hopefully be expanded, but for now, we can at least optimize standard slot accesses. - ;; For that, we must determine whether there is not a custom slot-value-using-class method we have to - ;; call. We use an approximation: if the class is a standard-class and the slotd is a - ;; standard-effective-slot-definition, methods on svuc can't be defined per - ;; "restrictions on portable programs" in MOP. We also discount the possibility of specializing on the - ;; "object" argument, because it makes things harder for us with not much gain for users. - ;; (Just specialize accessors or something.) - ;; The upshot of this is that slot accesses will never be inlined for custom metaclasses or slotds. - ;; The less approximate way would be to check s-v-u-c itself. That's easy enough on its own, - ;; but also implies that methods added or removed to s-v-u-c invalidate all relevant accessors, - ;; which is not. - (when (null methods) - ;; no-applicable-method is different from the no-required-method we'd get if we went below, - ;; so we pick that off first. - ;; Similarly to nrm below, we return a sort of fake emf. - (return-from compute-outcome - (make-effective-method-outcome - :methods nil - :form '(em-apply #'no-applicable-method .generic-function.) - :function (lambda (core:&va-rest vaslist-args) - (apply #'no-applicable-method generic-function vaslist-args))))) - (let* ((em (compute-effective-method generic-function method-combination methods)) - ;; will be NIL unless em = (call-method METHOD ()) or (call-method METHOD) - (method (and (consp em) - (eq (first em) 'call-method) - (consp (cdr em)) - (or (null (cddr em)) - (and (consp (cddr em)) - (null (cdddr em)) - (null (third em)))) - (second em))) - (optimized - (cond ((eq (class-of method) (find-class 'effective-reader-method)) - (let ((slotd (accessor-method-slot-definition method)) - (location - (with-early-accessors (+effective-accessor-method-slots+) - (effective-accessor-method-location method))) - (class (first actual-specializers))) - (make-optimized-slot-reader :index location :methods methods - :slot-name (slot-definition-name slotd) - :class class))) - ((eq (class-of method) (find-class 'effective-writer-method)) - (let ((slotd (accessor-method-slot-definition method)) - (location - (with-early-accessors (+effective-accessor-method-slots+) - (effective-accessor-method-location method))) - (class (second actual-specializers))) - (make-optimized-slot-writer :index location :methods methods - :slot-name (slot-definition-name slotd) - :class class))) - ;; NOTE: This case is not required if we always use :form and don't use the - ;; interpreter. See also, comment in combin.lisp. - ((and (consp em) (eq (first em) '%magic-no-required-method)) - (gf-log "No-required-method as effective method%N") - (gf-log "em: {}%N" em) - (let ((group-name (second em))) - (make-effective-method-outcome - :methods methods :form em - :function (lambda (core:&va-rest vaslist-args) - (apply #'no-required-method - generic-function group-name vaslist-args))))) - (t - (gf-log "Using default effective method function%N") - (gf-log "(compute-effective-method generic-function method-combination methods) -> %N") - (gf-log "{}%N" em) - (make-effective-method-outcome - :methods methods :form em - :function (effective-method-function - em (gf-arg-info generic-function))))))) - #+debug-fastgf - (progn - (gf-log "vvv************************vvv%N") - (gf-log "compute-effective-method-function for {}%N" (generic-function-name generic-function)) - (gf-log "There are {} methods...%N" (length methods)) - (dolist (m methods) - (gf-log "Method: {} {} {}%N" (clos::method-specializers m) (clos::method-qualifiers m) m)) - (gf-log "Effective method function -> {}%N" optimized) - (gf-log "^^^************************^^^%N")) - optimized)) - -(defun outcome - (generic-function call-history method-combination methods actual-specializers) - (or (find-existing-outcome call-history methods) - (compute-outcome - generic-function method-combination methods actual-specializers))) - -(defun update-call-history-for-add-method (call-history method) - "When a method is added then we update the effective-method-functions for - those call-history entries with specializers that the method would apply to." - (loop for entry in call-history - for specializers = (coerce (car entry) 'list) - unless (fuzzed-applicable-method-p method specializers) - collect entry)) - -(defun update-generic-function-call-history-for-add-method (generic-function method) - "When a method is added then we update the effective-method-functions for - those call-history entries with specializers that the method would apply to. -FIXME!!!! This code will have problems with multithreading if a generic function is in flight. " - (mp:atomic-update (safe-gf-call-history generic-function) - #'update-call-history-for-add-method - method)) - -(defun update-call-history-for-remove-method (call-history method) - (let (new-call-history) - (loop for entry in call-history - for specializers = (coerce (car entry) 'list) - unless (applicable-method-p method specializers) - do (push (cons (car entry) (cdr entry)) new-call-history)) - new-call-history)) - -(defun update-generic-function-call-history-for-remove-method (generic-function method) - "When a method is removed then we update the effective-method-functions for - those call-history entries with specializers that the method would apply to - AND if that means there are no methods left that apply to the specializers - then remove the entry from the list. -FIXME!!!! This code will have problems with multithreading if a generic function is in flight. " - (mp:atomic-update (safe-gf-call-history generic-function) - #'update-call-history-for-remove-method - method)) - -;;; FIXME: Replace with atomic setf -(defun erase-generic-function-call-history (generic-function) - (setf (mp:atomic (safe-gf-call-history generic-function)) nil)) - -(defun specializer-key-match (key1 key2) - (declare (type simple-vector key1 key2)) - ;; Specializers can be compared by EQ, and so - (and (= (length key1) (length key2)) - (every #'eq key1 key2))) - -(defun call-history-find-key (call-history memoized-key) - "Return true if the given key is already present in the history, or else nil." - (loop for (key . ignore) in call-history - when (specializer-key-match key memoized-key) do (return-from call-history-find-key t)) - nil) - -(defun specializer-call-history-generic-functions-push-new (specializer generic-function) - (with-early-accessors (+specializer-slots+) - (mp:with-rwlock ((specializer-mutex specializer) :write) - (pushnew generic-function (specializer-call-history-generic-functions specializer) - :test #'eq)))) - -(defun check-long-call-history (generic-function) - #-debug-long-call-history - (declare (ignore generic-function)) - #+debug-long-call-history - (when (> (length (generic-function-call-history generic-function)) 16384) - (error "DEBUG-LONG-CALL-HISTORY is triggered - The call history for ~a is longer (~a entries) than 16384" generic-function (length (generic-function-call-history generic-function))))) - -(defun schgf-pushnew (memoized-key generic-function) - (loop for specializer across (the simple-vector memoized-key) - unless (eql-specializer-p specializer) - do (specializer-call-history-generic-functions-push-new - specializer generic-function))) - -(defun perform-outcome (outcome arguments) - (cond - ((optimized-slot-reader-p outcome) - ;; Call is like (name instance) - (let ((value (standard-location-access - (first arguments) (optimized-slot-reader-index outcome)))) - (if (si:sl-boundp value) - value - (values (slot-unbound (optimized-slot-reader-class outcome) (first arguments) - (optimized-slot-reader-slot-name outcome)))))) - ((optimized-slot-writer-p outcome) - ;; Call is like ((setf name) new-value instance) - (setf (standard-location-access - (second arguments) (optimized-slot-writer-index outcome)) - (first arguments))) - ((effective-method-outcome-p outcome) - (let ((function (effective-method-outcome-function outcome))) - (assert (not (null function))) ; FIXME: REMOVE - (apply function arguments))) - (t (error "BUG: Bad thing to be an outcome: ~a" outcome)))) - -#+debug-fastgf -(defvar *dispatch-miss-start-time*) - -;;; Given a list of lists of specializers, expand out all combinations. -;;; So for example, ((a b) (c) (d e)) => ((a c d) (b c d) (a c e) (b c e)) -;;; in some arbitrary order. -(defun specializers-combinate (list) - (if (null list) - '(nil) - (loop with next = (specializers-combinate (rest list)) - for elem in (first list) - nconc (loop for rest in next collect (cons elem rest))))) - -;;; Returns two values: the outcome to perform, and some new call history entries, -;;; or NIL if none should be added (e.g. due to eql specialization or another thread -;;; beating us to it.) -;;; This function has no side effects. DISPATCH-MISS is in charge of that. -(defun dispatch-miss-info (generic-function call-history arguments) - (let ((argument-classes (mapcar #'class-of arguments))) - (multiple-value-bind (class-method-list ok) - (compute-applicable-methods-using-classes generic-function argument-classes) - (gf-log "Called compute-applicable-methods-using-classes - returned method-list: {} ok: {}%N" - class-method-list ok) - (let* ((method-list (if ok - class-method-list - (compute-applicable-methods - generic-function arguments))) - (method-combination - (generic-function-method-combination generic-function)) - (final-methods (final-methods method-list argument-classes)) - (outcome (outcome - generic-function call-history method-combination - final-methods argument-classes))) - (values - outcome - ;; Can we memoize the call, i.e. add it to the call history? - (cond ((null final-methods) ; we avoid memoizing no-applicable-methods, - ;; as it's probably just a mistake, and will just pollute the call history. - ;; This assumption would be wrong if an application frequently called a gf - ;; wrong and relied on the signal behavior etc, - ;; but I find that possibility unlikely. - (gf-log-dispatch-miss "No applicable method" - generic-function arguments) - nil) - (ok ; classes are fine; use normal fastgf - (gf-log-dispatch-miss "Memoizing normal call" - generic-function arguments) - (let* ((key-length - (length (safe-gf-specializer-profile generic-function))) - (key (coerce (subseq argument-classes 0 key-length) 'vector))) - (if (find key call-history :key #'car :test #'specializer-key-match) - ;; another thread has already added this entry - nil - (list (cons key outcome))))) - ((eq (class-of generic-function) - (find-class 'standard-generic-function)) - ;; we have a call with eql specialized arguments. - ;; We can still memoize this sometimes, as long as the gf is - ;; standard so we don't need to worry about MOP. - ;; What we need to watch out for it the following situation- - ;; (defmethod foo ((x (eql 'x))) ...) - ;; (foo 'y) - ;; If we memoize this naively, - ;; we'll put in an entry for class SYMBOL, - ;; and then if we call (foo 'x) later, - ;; it will go to that instead of properly missing the cache. - ;; EQL specializers play merry hob hell with the assumption of - ;; fastgf that as long as you treat all classes distinctly - ;; there are no problems with inheritance, basically. - ;; We deal with this by memoizing every combination of eql - ;; specializers for the given classes at once. - (gf-log-dispatch-miss "Memoizing eql-specialized call" - generic-function arguments) - (loop for spec across (safe-gf-specializer-profile - generic-function) - for argument-class in argument-classes - collect (list* - argument-class - (if (consp spec) ; eql specialized - (loop for obj in spec - when (typep obj argument-class) - collect (intern-eql-specializer obj)) - nil)) - into combo - finally (let ((speclists (specializers-combinate combo))) - (return - (loop for speclist in speclists - for key = (coerce speclist 'simple-vector) - for methods = (compute-applicable-methods-using-specializers generic-function speclist) - for outcome = (outcome - generic-function - call-history - method-combination - methods - argument-classes) - for new-entry = (cons key outcome) - unless (find key call-history :key #'car - :test #'specializer-key-match) - collect new-entry into new-entries - ;; This is necessary so that OUTCOME uses the cached - ;; outcomes we are generating as we go. - and do (push new-entry call-history) - finally (return new-entries)))))) - (t - ;; No more options: we just don't memoize. - ;; This only occurs with eql specializers, - ;; at least with the standard c-a-m/-u-c methods. - (gf-log-dispatch-miss "Cannot memoize call" generic-function arguments) - nil))))))) - -(defun check-gf-argcount (generic-function nargs) - (multiple-value-bind (min max) - (generic-function-min-max-args generic-function) - (when (or (< nargs min) (and max (> nargs max))) - (error 'core:wrong-number-of-arguments - :called-function generic-function :given-nargs nargs - :min-nargs min :max-nargs max)))) - -(defun union-entries (old-call-history new-entries) - ;; We do this instead of UNION because the new entries can contain duplicates. - (loop for entry in new-entries do (pushnew entry old-call-history - :key #'car :test #'specializer-key-match)) - old-call-history) - -(defun memoize-entries (old-call-history generic-function arguments) - (union-entries old-call-history - (dispatch-miss-info generic-function old-call-history arguments))) - -(defun dispatch-miss (generic-function &rest arguments) - (#+debug-fastgf unwind-protect #-debug-fastgf multiple-value-prog1 - (progn - (incf-debug-fastgf-indent) - (check-gf-argcount generic-function (length arguments)) - ;; Update any invalid instances - (when (maybe-update-instances arguments) - (return-from dispatch-miss (apply generic-function arguments))) - ;; OK, real miss. - #+debug-fastgf - (progn - (gf-log "----{---- A dispatch-miss occurred[(1- (core:next-number))->{}] -> {} %N" (1- (core:next-number)) (clos::generic-function-name generic-function)) - (dolist (arg arguments) - (gf-log "{}[{}/{}] " (core:safe-repr arg) (core:safe-repr (class-of arg)) (core:instance-stamp arg))) - (gf-log-noindent "%N")) - (let* ((tracy - (and (typep generic-function 'standard-generic-function) - (with-early-accessors (+standard-generic-function-slots+) - (mp:atomic (%generic-function-tracy generic-function))))) - (report (and tracy (eq (car tracy) :profile-ongoing))) - (dispatch-miss-start-time - (when tracy (get-internal-real-time))) - #+debug-fastgf - (*dispatch-miss-start-time* (get-internal-real-time)) - ;; We have to recompute the new entries in the CAS loop because we need to - ;; ensure that outcome= works, i.e. that we don't end up with two distinct outcome - ;; objects in the call history that represent the same effective method. This would - ;; screw up discriminator generation; see # - outcome updatedp) - ;; If performance trace is on, squawk. - (when report - (format *trace-output* "~&; Dispatch miss: (~a~{ ~s~})~%" - (core:low-level-standard-generic-function-name generic-function) - arguments)) - ;; Do the miss. - (mp:atomic-update (safe-gf-call-history generic-function) - (lambda (call-history) - (multiple-value-bind (noutcome new-entries) - (dispatch-miss-info generic-function call-history arguments) - (setf outcome noutcome) - (cond ((null new-entries) - (setf updatedp nil) - call-history) - (t (setf updatedp t) - (union-entries call-history new-entries)))))) - (when updatedp (force-dispatcher generic-function)) - (gf-log "Performing outcome {}%N" outcome) - (when report - (format *trace-output* - "~&; ~fs overhead~%" - (/ (float (- (get-internal-real-time) - dispatch-miss-start-time)) - internal-time-units-per-second))) - (when tracy - (let (;; dumb hack - atomics don't know about cadr etc - (info (cdr tracy))) - (mp:atomic-incf (car info) - (/ (float (- (get-internal-real-time) - dispatch-miss-start-time)) - internal-time-units-per-second)) - (mp:atomic-push arguments (cdr info)))) - #+debug-fastgf - (let ((results (multiple-value-list - (perform-outcome outcome arguments)))) - (gf-log "+-+-+-+-+-+-+-+-+ dispatch-miss done real time: %f seconds%N" (/ (float (- (get-internal-real-time) *dispatch-miss-start-time*)) internal-time-units-per-second)) - (gf-log "----}---- Completed call to effective-method-function for {} results -> {}%N" (clos::generic-function-name generic-function) results) - (values-list results)) - #-debug-fastgf - (perform-outcome outcome arguments))) - (decf-debug-fastgf-indent))) - -;;; Called from the dtree interpreter, -;;; because APPLY from C++ is kind of annoying. -(defun dispatch-miss-va (generic-function vaslist-args) - (apply #'dispatch-miss generic-function vaslist-args)) - -(defvar *fastgf-force-compiler* nil) -(defun calculate-fastgf-dispatch-function - (generic-function &key (compile *fastgf-force-compiler*)) - (if (mp:atomic (safe-gf-call-history generic-function)) - (let ((timer-start (get-internal-real-time))) - (unwind-protect - (if (and #-cclasp nil compile cmp:*cleavir-compile-hook* - (not (eq cmp:*default-output-type* :bytecode))) - (compile nil (generate-discriminator generic-function)) - (bytecode-interpreted-discriminator generic-function)) - (let ((delta-seconds (/ (float (- (get-internal-real-time) timer-start) 1d0) - internal-time-units-per-second))) - (gctools:accumulate-discriminating-function-compilation-seconds delta-seconds)))) - (invalidated-discriminating-function-closure generic-function))) - -(defun force-dispatcher (generic-function) - (let (log-output) - #-debug-fastgf (declare (ignore log-output)) - #+debug-fastgf - (progn - (if (eq (class-of generic-function) (find-class 'standard-generic-function)) - (let ((generic-function-name (core:low-level-standard-generic-function-name generic-function))) - (setf log-output (log-cmpgf-filename generic-function-name "func" "ll")) - (gf-log "Writing dispatcher to {}%N" log-output)) - (setf log-output (log-cmpgf-filename (generic-function-name generic-function) "func" "ll"))) - (incf-debug-fastgf-didx)) - (set-funcallable-instance-function generic-function - (calculate-fastgf-dispatch-function - generic-function)))) - -;;; Used by interpret-dtree-program. -(defun compile-discriminating-function (generic-function) - ;; Ensure an up to date (i.e. won't need to miss on these arguments) - ;; interpreted discriminator is installed, so that if Cleavir calls the - ;; generic function we're compiling it won't go recursive. - (set-funcallable-instance-function generic-function - (calculate-fastgf-dispatch-function - generic-function :compile nil)) - (set-funcallable-instance-function generic-function - (calculate-fastgf-dispatch-function - generic-function :compile t))) - -#+debug-fastgf -(defvar *dispatch-miss-recursion-check* nil) - -(defun invalidated-dispatch-function (generic-function vaslist-args) - #+(or)(declare (optimize (debug 3))) - #+debug-fastgf - (when (find (cons generic-function (core:list-from-vaslist vaslist-args)) *dispatch-miss-recursion-check* - :test #'equal) - (format t "~&Recursive dispatch miss detected~%") - (ext:quit 1)) - (let (#+debug-fastgf - (*dispatch-miss-recursion-check* (cons (cons generic-function - (core:list-from-vaslist vaslist-args)) - *dispatch-miss-recursion-check*))) - - ;;; If there is a call history then compile a dispatch function - ;;; being extremely careful NOT to use any generic-function calls. - ;;; Then redo the call. - ;;; If there is no call history then treat this like a dispatch-miss. - #+debug-fastgf - (if (eq (class-of generic-function) (find-class 'standard-generic-function)) - (gf-log "Entered invalidated-dispatch-function for {} - avoiding generic function calls until return!!!%N" - (core:low-level-standard-generic-function-name generic-function)) - (gf-log "Entered invalidated-dispatch-function - avoiding generic function calls until return!!!%N")) - (gf-log "Specializer profile is {}%N" (safe-gf-specializer-profile generic-function)) - (if (mp:atomic (safe-gf-call-history generic-function)) - (progn - (force-dispatcher generic-function) - (apply generic-function vaslist-args)) - (apply #'dispatch-miss generic-function vaslist-args)))) - -;;; I don't believe the following few functions are called from anywhere, but they may be useful for debugging. - -#+(or) -(defun method-spec-matches-entry-spec (method-spec entry-spec) - (or - (and (consp method-spec) - (consp entry-spec) - (eq (car method-spec) 'eql) - (eql (second method-spec) (car entry-spec))) - (and (classp method-spec) (classp entry-spec) - (member method-spec (class-precedence-list entry-spec))))) - -#+(or) -(defun call-history-entry-involves-method-with-specializers (entry method-specializers) - (let ((key (car entry))) - (loop for method-spec in method-specializers - for entry-spec across key - always (method-spec-matches-entry-spec method-spec entry-spec)))) - -#+(or) -(defun call-history-after-method-with-specializers-change (gf method-specializers) - (loop for entry in (mp:atomic (safe-gf-call-history gf)) - unless (call-history-entry-involves-method-with-specializers entry method-specializers) - collect entry)) - -#+(or) -(defun call-history-after-class-change (gf class) -;;; (format t "call-history-after-class-change start: gf->~a call-history ->~a~%" gf (clos::generic-function-cal-history gf)) - (loop for entry in (mp:atomic (safe-gf-call-history gf)) - unless (loop for subclass in (subclasses* class) - thereis (call-history-entry-key-contains-specializer (car entry) subclass)) - collect entry)) - -(defun subclasses* (class) - (remove-duplicates - (cons class - (reduce #'append (mapcar #'subclasses* - (class-direct-subclasses class)))))) - -(defun call-history-entry-key-contains-specializers-p (key specializer) - (find specializer key :test #'eq)) - -(defun generic-function-call-history-separate-entries-with-specializer - (call-history gf specializer) - (declare (ignorable gf)) - (gf-log "generic-function-call-history-remove-entries-with-specializers gf: {}%N specializer: {}%N" gf specializer) - (loop for entry in call-history - for key = (car entry) - do (gf-log " check if entry key: {} contains specializer: {}%N" key specializer) - if (call-history-entry-key-contains-specializers-p key specializer) - do (gf-log " It does - removing entry%N") - and collect entry into removed - else - do (gf-log " It does not - keeping entry%N") - and collect entry into keep - finally (return (values keep removed)))) - -;; Remove all call entries referring directly to a class, and invalidate or -;; force their discriminating functions. -(defun invalidate-generic-functions-with-class-selector (class) - (gf-log "invalidate-generic-functions-with-class-selector {}%N" class) - (let ((generic-functions (specializer-call-history-generic-functions class))) - (gf-log " for class {} there are {} generic functions%N" - class (length generic-functions)) - (gf-log " generic functions -> {}%N" generic-functions) - (loop for gf in generic-functions - do (gf-log "generic function: {}%N" (clos:generic-function-name gf)) - (gf-log " (clos:get-funcallable-instance-function gf) -> {}%N" - (clos:get-funcallable-instance-function gf)) - (let ((new-call-history - (mp:atomic-update (safe-gf-call-history gf) - #'generic-function-call-history-separate-entries-with-specializer - gf class))) - (declare (ignorable new-call-history)) - (gf-log " edited call history%N") - (gf-log "{}%N" new-call-history) - (gf-log "Invalidating discriminating function%N") - ;; We don't force the dispatcher, because whena class with - ;; subclasses is redefined, we may end up here repeatedly. - ;; Eagerness would result in pointless compilation. - (invalidate-discriminating-function gf))))) - -;;; This is called by the dtree interpreter when it doesn't get enough arguments, -;;; because computing this stuff in C++ would be needlessly annoying. -(defun interp-wrong-nargs (generic-function given-nargs) - (multiple-value-bind (min max) (generic-function-min-max-args generic-function) - (error 'core:wrong-number-of-arguments - :called-function generic-function :given-nargs given-nargs - :min-nargs min :max-nargs max))) - - -;;; Implemented by Bike June 22, 2021 - -(defun maybe-compile-named-gf (name) - (when (fboundp name) - (let ((f (fdefinition name))) - (when (typep f 'standard-generic-function) - (clos:compile-discriminating-function f))))) - -(defun compile-all-generic-functions () - (do-all-symbols (s) - (maybe-compile-named-gf s) - (maybe-compile-named-gf `(setf ,s)))) - -(export 'compile-all-generic-functions) diff --git a/src/lisp/kernel/clos/combin.lisp b/src/lisp/kernel/clos/combin.lisp deleted file mode 100644 index ca69adb286..0000000000 --- a/src/lisp/kernel/clos/combin.lisp +++ /dev/null @@ -1,512 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi. -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; ECoLisp 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 file '../Copyright' for full details. - - -(in-package "CLOS") - -;; ---------------------------------------------------------------------- -;; EFFECTIVE METHOD FUNCTIONS -;; -;; Effective method functions are the functional version of effective -;; methods (effective methods being the forms returned by -;; compute-effective-method). On Clasp, they are functions that accept the -;; same arguments as the generic function. -;; In general we can simply compile the effective method, but the compiler -;; is slow, so we go to some effort to special case common effective -;; methods. -;; Note that we more often go through this mechanism than putting the -;; effective methods in the discriminating function directly. See -;; *inline-effective-methods* in discriminate.lisp. -;; The main entry to this section is EFFECTIVE-METHOD-FUNCTION, which -;; returns a function for a given effective method. -;; The ARG-INFO threaded throughout here is used to skip some APPLYing. -;; See closfastgf.lisp, gf-arg-info function. - -(defvar *avoid-compiling* nil) - -(defun emf-maybe-compile (form) - (if (or *avoid-compiling* (not cmp:*cleavir-compile-hook*)) - (coerce form 'function) - (let ((*avoid-compiling* t)) - (compile nil form)))) - -(defun emf-default (form &optional (arg-info '(t))) - (let ((restp (car arg-info)) (vars (cdr arg-info))) - (emf-maybe-compile - `(lambda (,@vars ,@(when restp '(core:&va-rest emf-more))) - (declare (core:lambda-name effective-method-function.lambda)) - (with-effective-method-parameters ((,@vars) ,(if restp 'emf-more nil)) - ,form))))) - -(defun std-method-p (method) - (let ((mc (class-of method))) - (or (eq mc (find-class 'standard-method)) - (eq mc (find-class 'standard-reader-method)) - (eq mc (find-class 'standard-writer-method)) - ;; Not remotely standard, but the same as standard-reader/writer - ;; for our purposes. - (eq mc (find-class 'effective-reader-method)) - (eq mc (find-class 'effective-writer-method))))) - -(defun make-method-form-p (form) - (and (consp form) - (eq (first form) 'make-method) - (consp (cdr form)))) - -(defun emf-from-contf (contf method next-methods - &optional (arg-info '(t))) - (let ((next (if (null next-methods) - (make-%no-next-method-continuation method) - (emf-call-method - (first next-methods) (list (rest next-methods)) - arg-info)))) - (lambda (core:&va-rest .method-args.) - (declare (core:lambda-name emf-from-contf.lambda)) - (apply contf next .method-args.)))) - -(defun emf-call-method (method rest &optional (arg-info '(t))) - (cond ((and - (std-method-p method) - ;; This next form will return NIL if the method does not have - ;; an FMF or CONTF, an unusual situation indicating the user - ;; has manually made a method with whatever function. - ;; In this scenario we go to the default case down there. - ;; NOTE that we use the early readers because we can call this - ;; very early due to satiation. And the early readers are valid - ;; because we just checked that this is a std method. - (destructuring-bind (&optional ((&rest next-methods))) rest - (or (early-fast-method-function method) ; FMFs are valid EMFs - (let ((contf (early-contf-method-function method))) - (when contf - (emf-from-contf - contf method next-methods arg-info))))))) - ((make-method-form-p method) - ;; FIXME: Should call-next-method etc be bound - (effective-method-function (second method) arg-info)) - ;; Could be a nonstandard method with its own EXPAND-APPLY-METHOD. - (t (emf-default `(call-method ,method ,@rest) arg-info)))) - -(defun effective-method-function (form &optional (arg-info '(t))) - ;; emf-default is always valid, but let's pick off a few cases - ;; so that we can avoid using the compiler, which is slow. - (if (consp form) - (case (first form) - ;; Note that MAKE-METHOD is not valid outside of a CALL-METHOD, - ;; so form shouldn't be a MAKE-METHOD form. - ((call-method) (emf-call-method (second form) (cddr form) - arg-info)) - (otherwise (emf-default form arg-info))) - (emf-default form arg-info))) - -;;; Used for early satiation. - -(defun early-emf-from-contf (contf method next-methods) - (let ((next (if (null next-methods) - (make-%no-next-method-continuation method) - (early-emf-call-method - (first next-methods) (rest next-methods))))) - (lambda (core:&va-rest .method-args.) - (declare (core:lambda-name emf-from-contf.lambda)) - (apply contf next .method-args.)))) - -(defun early-emf-call-method (method next-methods) - (cond ((method-p method) - (or (early-fast-method-function method) - (let ((contf (early-contf-method-function method))) - (when contf (early-emf-from-contf contf method next-methods))) - (error "BUG: early effective-method-function hit nonstandard method"))) - (t (error "BUG: early CALL-METHOD hit unusual method: ~a" method)))) - -(defun early-effective-method-function (form) - (if (and (consp form) (eq (first form) 'call-method)) - (let ((method (second form)) - (next-methods (third form))) - (early-emf-call-method method next-methods)) - (error "BUG: early effective-method-function hit unusual case"))) - -;; ---------------------------------------------------------------------- -;; CALL-METHOD - -(defun argforms-to-arg-info (argforms &optional env) - (let* ((final (first (rest argforms))) - (butl (butlast argforms))) - (cons (and (constantp final env) - (null (ext:constant-form-value final env))) - (loop for s in butl - if (symbolp s) collect (make-symbol (symbol-name s)) - else collect (gensym "REQ-ARG"))))) - -;;; Convert an element of the second argument of a usual call-method -;;; into a method or form producing a method. -(defun call-method-aux (gf method &optional (arg-info '(t))) - (cond ((method-p method) method) - ((make-method-form-p method) - `(make-instance ,(generic-function-method-class gf) - ;; FIXME?: These are of course lies. - ;; Our own method on shared-initialize will signal an error - ;; without these initargs, though. - :specializers '() - :qualifiers '() - :lambda-list '() - ;; FIXME: Should call-next-method etc be available? - :function (make-%method-function-fast - (effective-method-function - ',(second method) ',arg-info)))) - ;; FIXME: Delay this? Right now this error occurs during - ;; macroexpansion of CALL- or APPLY-METHOD. - (t (error "Invalid argument to CALL-METHOD: ~a" method)))) - -;;; Convert the second argument of a usual call-method into a list -;;; of methods. -(defun call-method-next-methods (gf next-methods &optional (arg-info '(t))) - (declare (ignore arg-info)) - (loop for nmethod in next-methods - collect (call-method-aux gf nmethod))) - -(defun std-expand-apply-method (method method-arguments arguments env) - (destructuring-bind (&optional ((&rest next-methods))) method-arguments - (let ((arg-info (argforms-to-arg-info arguments env))) - (cond - ;; Inline effective accessors. - ;; TODO: General inlining mechanism might be good. - ((and (eq (class-of method) (find-class 'effective-reader-method)) - (> (length arguments) 1)) ; need the first argument. - (let* ((location (with-early-accessors (+effective-accessor-method-slots+) - (effective-accessor-method-location method))) - (sname (slot-definition-name - (accessor-method-slot-definition method))) - (valuef - (cond ((si:fixnump location) - ;; instance location- easy - `(core:instance-ref ,(first arguments) ',location)) - ((consp location) - ;; class location. we need to find the new cell at load time. - `(car ,(class-cell-form sname - (first (method-specializers method))))) - (t - (error "BUG: Slot location ~a is not a fixnum or cons" location))))) - `(let ((value ,valuef)) - (if (cleavir-primop:eq value (core:unbound)) - (slot-unbound (class-of ,(first arguments)) - ,(first arguments) - ',sname) - value)))) - ((and (eq (class-of method) (find-class 'effective-writer-method)) - (> (length arguments) 2)) - (let ((location (with-early-accessors (+effective-accessor-method-slots+) - (effective-accessor-method-location method))) - (sname (slot-definition-name - (accessor-method-slot-definition method))) - (class (second (method-specializers method)))) - (cond ((si:fixnump location) - `(setf (si:instance-ref ,(second arguments) ,location) - ,(first arguments))) - ((consp location) - ;; class location - ;; Note we don't actually need the instance. - `(setf (car ,(class-cell-form sname class)) ,(first arguments))) - (t (error "BUG: Slot location ~a is not a fixnum or cons" location))))) - ;; Standard methods - ((fast-method-function method) - `(apply - ;; have to maybe do early- in case we're satiating early. - (load-time-value (,(if (std-method-p method) - 'early-fast-method-function - 'fast-method-function) - ,method) - t) - ,@arguments)) - ((contf-method-function method) - `(apply - (load-time-value (,(if (std-method-p method) - 'early-contf-method-function - 'contf-method-function) - ,method) - t) - (load-time-value - ,(if (null next-methods) - `(make-%no-next-method-continuation - ,method) - `(emf-call-method - ',(first next-methods) - '(,(rest next-methods)) ',arg-info)) - t) - ,@arguments)) - ;; Default: AMOP protocol. - (t `(funcall (load-time-value (method-function ,method) t) - ;; last element might be a vaslist - (apply #'list ,@arguments) - (load-time-value - (list ,@(call-method-next-methods - (method-generic-function method) - next-methods arg-info)) - t))))))) - -(defmacro apply-method (method (&rest method-arguments) &rest arguments - &environment env) - "Call the given method. METHOD-ARGUMENTS are the unevaluated arguments -passed in a CALL-METHOD form after the method. -ARGUMENTS is a list of forms that will evaluate to a spreadable -argument list designator." - ;; Pick off the standard case without calling the generic function, - ;; for metacircularity reasons. - (if (std-method-p method) - (std-expand-apply-method method method-arguments arguments env) - (expand-apply-method method method-arguments arguments env))) - -(defmacro call-method (method &rest method-arguments &environment env) - (if (make-method-form-p method) - (second method) ; FIXME: should we try to bind CALL-NEXT-METHOD etc? - (multiple-value-bind (required-arguments more-args) - (effective-method-parameters env) - `(apply-method ,method (,@method-arguments) - ,@required-arguments ,more-args)))) - -;; ---------------------------------------------------------------------- -;; DEFINE-METHOD-COMBINATION -;; -;; METHOD-COMBINATION objects are instances defined in hierarchy.lisp. -;; They have slots for the name, compiler, and options. Name is obvious, -;; and the options are those provided to the thing. -;; The "compiler" is somewhat misleadingly named; it's the function that -;; outptus the effective method form. -;; These functions are stored in the global *method-combinations* hash -;; table. (the standard method on) FIND-METHOD-COMBINATION ignores the gf, -;; and makes a new METHOD-COMBINATION instance with the "compiler" looked -;; up in the hash table, and the name and options. -;; The "compiler" functions take two arguments, plus the lambda-list from -;; the define-method-combination. The first argument is the generic function -;; (used for the :generic-function option of D-M-C), the second is the sorted -;; list of applicable methods, and the rest are the method combination options. -;; - -#+threads -(defparameter *method-combinations-lock* (mp:make-lock :name 'find-method-combination)) -(defparameter *method-combinations* (make-hash-table :size 32 :test 'eq)) - - -(defun search-method-combination (name) - (mp:with-lock (*method-combinations-lock*) - (gethash name *method-combinations*))) - -(defun install-method-combination (name function) - (mp:with-lock (*method-combinations-lock*) - (setf (gethash name *method-combinations*) function)) - name) - -(defun make-method-combination (name compiler options) - (with-early-make-instance +method-combination-slots+ - (o (find-class 'method-combination) - :name name - :compiler compiler - :options options) - o)) - -;; Will be upgraded into a generic function later. -(defun find-method-combination (gf method-combination-type-name method-combination-options) - (declare (ignore gf)) - (make-method-combination method-combination-type-name - (or (search-method-combination method-combination-type-name) - (error "~A does not name a method combination" - method-combination-type-name)) - method-combination-options)) - -(defun define-simple-method-combination (name &key documentation - identity-with-one-argument - (operator name)) - `(define-method-combination - ,name (&optional (order :MOST-SPECIFIC-FIRST)) - ((around (:AROUND)) - (principal (,name) :REQUIRED t)) - ,documentation - (let ((main-effective-method - `(,',operator ,@(mapcar #'(lambda (x) - (declare (core:lambda-name define-simple-method-combination.lambda)) - `(CALL-METHOD ,x NIL)) - (if (eql order :MOST-SPECIFIC-LAST) - (reverse principal) - principal))))) - (cond (around - `(call-method ,(first around) - (,@(rest around) (make-method ,main-effective-method)))) - (,(if identity-with-one-argument - '(rest principal) - t) - main-effective-method) - (t (second main-effective-method)))))) - -;;; See comment below. -(defmacro %magic-no-required-method (group-name) - `(em-apply #'no-required-method .generic-function. ',group-name)) - -(defun define-complex-method-combination (form) - (flet ((syntax-error () - (error "~S is not a valid DEFINE-METHOD-COMBINATION form" - form))) - (destructuring-bind (name lambda-list method-groups &rest body &aux - (group-names '()) - (group-checks '()) - (group-after '()) - (generic-function '.generic-function.)) - form - (unless (symbolp name) (syntax-error)) - (let ((x (first body))) - (when (and (consp x) (eql (first x) :ARGUMENTS)) - (warn "Option :ARGUMENTS is not supported in DEFINE-METHOD-COMBINATION.") - (return-from define-complex-method-combination - `(error "Option :ARGUMENTS is not supported in DEFINE-METHOD-COMBINATION.")))) - (let ((x (first body))) - (when (and (consp x) (eql (first x) :GENERIC-FUNCTION)) - (setf body (rest body)) - (unless (symbolp (setf generic-function (second x))) - (syntax-error)))) - (dolist (group method-groups) - (destructuring-bind (group-name predicate &key description - (order :most-specific-first) - (required nil)) - group - (declare (ignore description)) ; FIXME? - (if (symbolp group-name) - (push group-name group-names) - (syntax-error)) - (let ((condition - (cond ((eql predicate '*) 'T) - ((null predicate) `(null .method-qualifiers.)) - ((symbolp predicate) - `(,predicate .METHOD-QUALIFIERS.)) - ((consp predicate) - (let* ((q (last predicate 0)) - (p (copy-list (butlast predicate 0)))) - (when (every #'symbolp p) - (if (eql q '*) - `(every #'equal ',p .METHOD-QUALIFIERS.) - `(equal ',p .METHOD-QUALIFIERS.))))) - (t (syntax-error))))) - (push `(,condition (push .METHOD. ,group-name)) group-checks)) - (when required - (push `(unless ,group-name - ;; Effective methods can be computed in other situations than being - ;; about to call them. As such, compute-effective-method should not - ;; signal an error unless the computation is impossible. Lacking a - ;; required method is by contrast a problem that only needs to be - ;; signaled when the function is actually being called. So we return - ;; an error form. ...but because we want an independent function for - ;; the dtree interpreter, we return something specially recognizable - ;; by compute-outcome, so the generic function etc. can be hooked up. - (return-from ,name '(%magic-no-required-method ,group-name))) - group-after)) - (case order - (:most-specific-first - (push `(setf ,group-name (nreverse ,group-name)) group-after)) - (:most-specific-last) - (otherwise - (let ((order-var (gensym))) - (setf group-names (append group-names (list (list order-var order))) - group-after (list* `(when (eq ,order-var :most-specific-first) - (setf ,group-name (nreverse ,group-name))) - group-after))))))) - `(install-method-combination ',name - (lambda (,generic-function .methods-list. ,@lambda-list) - (declare (core:lambda-name ,name) - (ignorable ,generic-function)) - (block ,name - (let (,@group-names) - (dolist (.method. .methods-list.) - (let ((.method-qualifiers. (method-qualifiers .method.))) - (cond ,@(nreverse group-checks) - (t (invalid-method-error .method. - "Method qualifiers ~S are not allowed in the method ~ - combination ~S." .method-qualifiers. ',name))))) - ,@group-after - ,@body))))))) - -(defmacro define-method-combination (name &body body) - (if (and body (listp (first body))) - (define-complex-method-combination (list* name body)) - (apply #'define-simple-method-combination name body))) - -(defun method-combination-error (format-control &rest args) - ;; FIXME! We should emit a more detailed error! - (error "Method-combination error:~%~S" - (apply #'format nil format-control args))) - -(defun invalid-method-error (method format-control &rest args) - (error "Invalid method error for ~A~%~S" - method - (apply #'format nil format-control args))) - - - -;;; ---------------------------------------------------------------------- -;;; COMPUTE-EFFECTIVE-METHOD -;;; - -(defun compute-effective-method-function (gf method-combination applicable-methods) - (effective-method-function - (compute-effective-method gf method-combination applicable-methods))) - -;; will be upgraded into being the standard method on compute-effective-method in fixup. -(defun std-compute-effective-method (gf method-combination applicable-methods) - (declare (type method-combination method-combination) - (type generic-function gf) - (optimize speed (safety 0))) - ;; FIXME: early accessors here could technically be bad, if someone subclasses method-combination - ;; On the other hand, I've never seen anyone do that. D-M-C already has arbitrary code, and - ;; method combinations have no defined accessors - all you could do is add methods to - ;; compute-effective-method, itself unusual because, again, arbitrary code. - (with-early-accessors (+method-combination-slots+) - (let* ((compiler (method-combination-compiler method-combination)) - (options (method-combination-options method-combination))) - (if options - (apply compiler gf applicable-methods options) - (funcall compiler gf applicable-methods))))) - -(define-method-combination standard () - ((around (:around)) - (before (:before)) - (primary () :required t) - (after (:after))) - (flet ((call-methods (methods) - (mapcar (lambda (method) - `(call-method ,method)) - methods))) - ;; We're a bit more hopeful about avoiding make-method and m-v-p1 than - ;; the example in CLHS define-method-combination. - ;; Performance impact is likely to be marginal at best, but why not try? - (let* ((call-primary `(call-method ,(first primary) ,(rest primary))) - (call-before (if before - `(progn ,@(call-methods before) ,call-primary) - call-primary)) - (call-after (if after - `(multiple-value-prog1 ,call-before - ,@(call-methods (reverse after))) - call-before)) - (call-around (if around - (if (and (null before) (null after)) - `(call-method ,(first around) - (,@(rest around) - ,@primary)) - `(call-method ,(first around) - (,@(rest around) - (make-method ,call-after)))) - call-after))) - call-around))) - -(define-method-combination progn :identity-with-one-argument t) -(define-method-combination and :identity-with-one-argument t) -(define-method-combination max :identity-with-one-argument t) -(define-method-combination + :identity-with-one-argument t) -(define-method-combination nconc :identity-with-one-argument t) -(define-method-combination append :identity-with-one-argument nil) -(define-method-combination list :identity-with-one-argument nil) -(define-method-combination min :identity-with-one-argument t) -(define-method-combination or :identity-with-one-argument t) diff --git a/src/lisp/kernel/clos/discriminate.lisp b/src/lisp/kernel/clos/compiled-discriminator.lisp similarity index 78% rename from src/lisp/kernel/clos/discriminate.lisp rename to src/lisp/kernel/clos/compiled-discriminator.lisp index 3986232027..d52e220f03 100644 --- a/src/lisp/kernel/clos/discriminate.lisp +++ b/src/lisp/kernel/clos/compiled-discriminator.lisp @@ -1,25 +1,9 @@ (in-package #:clos) -#+(or) -(progn - (defclass node () ()) - (defclass ntest (node) - ((%paths :initarg :paths :reader ntest-paths))) - (defun make-ntest (paths) (make-instance 'ntest :paths paths)) - (defun ntest-p (object) (typep object 'ntest)) - (defclass leaf (node) - ((%form :initarg :form :reader leaf-form))) - (defun make-leaf (form) (make-instance 'leaf :form form)) - (defun leaf-p (object) (typep object 'leaf))) - -#-(or) -(progn - (defstruct (ntest (:type vector) :named - (:constructor make-ntest (paths))) - (paths nil :read-only t)) - (defstruct (leaf (:type vector) :named - (:constructor make-leaf (form))) - (form nil :read-only t))) +(defstruct (ntest (:constructor make-ntest (paths))) + (paths nil :read-only t)) +(defstruct (leaf (:constructor make-leaf (form))) + (form nil :read-only t)) ;;; Passed from above through symbol-macrolet so that I can ;;; survive the debugging process. @@ -98,21 +82,9 @@ (let ((*reduction-table* (make-hash-table :test #'equal))) (reduce-node tree))) -#+(or) -(progn - (defgeneric reduce-node (node)) - (defmethod reduce-node ((node leaf)) (reduce-leaf node)) - (defmethod reduce-node ((node ntest)) (reduce-test node))) - -#-(or) -(progn - (defun reduce-node (node) - (cond ((leaf-p node) (reduce-leaf node)) - ((ntest-p node) (reduce-test node)) - (t (error "BUG: Not a node: ~a" node))))) - -(defun reduce-leaf (leaf) leaf) ; nothing to be done. -(defun reduce-test (node) +(defgeneric reduce-node (node)) +(defmethod reduce-node ((node leaf)) node) ; nothing to be done. +(defmethod reduce-node ((node ntest)) (loop for (spec . next) in (ntest-paths node) for rnext = (reduce-node next) collect (cons spec rnext) into new-paths @@ -150,19 +122,6 @@ :key #'second)) (error "BUG: Unknown tag class ~a" class))) -(defun safe-eql-specializer-p (specializer) - (let ((sc (class-of specializer))) - (cond ((eq sc (find-class 'eql-specializer)) t) - ((eq sc (find-class 'standard-class)) nil) - ((eq sc (find-class 'funcallable-standard-class)) nil) - (t (typep specializer 'eql-specializer))))) - -(defun safe-eql-specializer-object (eql-specializer) - (if (eq (class-of eql-specializer) (find-class 'eql-specializer)) - (with-early-accessors (+eql-specializer-slots+) - (eql-specializer-object eql-specializer)) - (eql-specializer-object eql-specializer))) - (defun casify-specs (stampf default-tag specs) `(case ,stampf ,@(loop for (tag . keys) @@ -188,8 +147,8 @@ into tbody do (loop for spec in specs for pair = (cons spec tag) - do (cond ((safe-eql-specializer-p spec) - (push (cons (safe-eql-specializer-object spec) + do (cond ((eql-specializer-p spec) + (push (cons (eql-specializer-object spec) tag) eql-specs)) ((tag-spec-p spec) @@ -310,24 +269,6 @@ ;;; -;;; We pass the parameters to CALL-METHOD and sundry in this fashion. -(defmacro with-effective-method-parameters ((required-params rest) - &body body) - `(symbol-macrolet ((+emf-params+ - ((,@required-params) ,rest))) - ,@body)) - -(defun effective-method-parameters (&optional environment) - (multiple-value-bind (expansion expanded) - (macroexpand-1 '+emf-params+ environment) - (if expanded - (values (first expansion) (second expansion)) - ;; If we're not in a discriminator, and so the symbol macro - ;; isn't bound, we return a banal response. - ;; FIXME?: Might want to signal an error instead. - ;; .method-args. isn't as universal any more. - (values nil '.method-args.)))) - (defun class-cell-form (slot-name class) `(load-time-value (slot-definition-location @@ -336,8 +277,7 @@ ',slot-name ,class))))) (defmacro em-slot-read (location slot-name class &environment env) - (multiple-value-bind (arguments rest) (effective-method-parameters env) - (declare (ignore rest)) + (let ((arguments (effective-method-parameters env))) (unless (>= (length arguments) 1) (error "BUG: SLOT-READ effective method has insufficient required parameters")) (let ((valuef @@ -353,14 +293,8 @@ (slot-unbound ,class ,(first arguments) ',slot-name) value))))) -(defun generate-slot-reader (outcome) - `(em-slot-read ,(optimized-slot-reader-index outcome) - ,(optimized-slot-reader-slot-name outcome) - ,(optimized-slot-reader-class outcome))) - (defmacro em-slot-write (location slot-name class &environment env) - (multiple-value-bind (arguments rest) (effective-method-parameters env) - (declare (ignore rest)) + (let ((arguments (effective-method-parameters env))) (unless (>= (length arguments) 2) (error "BUG: SLOT-WRITE effective method has insufficient required parameters")) (cond ((si:fixnump location) @@ -371,19 +305,17 @@ `(rplaca ,(class-cell-form slot-name class) ,(first arguments))) (t (error "BUG: Slot location ~a is not a fixnum or cons" location))))) -(defun generate-slot-writer (outcome) - `(em-slot-write ,(optimized-slot-writer-index outcome) - ,(optimized-slot-writer-slot-name outcome) - ,(optimized-slot-writer-class outcome))) +(defgeneric generate-outcome (outcome)) + +(defmethod generate-outcome ((outcome optimized-slot-reader)) + `(em-slot-read ,(optimized-slot-accessor-index outcome) + ,(optimized-slot-accessor-slot-name outcome) + ,(optimized-slot-accessor-class outcome))) -(defun generate-outcome (outcome) - (cond ((optimized-slot-reader-p outcome) - (generate-slot-reader outcome)) - ((optimized-slot-writer-p outcome) - (generate-slot-writer outcome)) - ((effective-method-outcome-p outcome) - (generate-effective-method-call outcome)) - (t (error "BUG: Bad thing to be an outcome: ~a" outcome)))) +(defmethod generate-outcome ((outcome optimized-slot-writer)) + `(em-slot-write ,(optimized-slot-accessor-index outcome) + ,(optimized-slot-accessor-slot-name outcome) + ,(optimized-slot-accessor-class outcome))) ;;; This can be T, meaning prefer the form, NIL, meaning prefer the function, ;;; or CL:REQUIRE, meaning use the form or signal an error if it's missing. @@ -403,11 +335,9 @@ ;;; Apply a function to the effective method parameters. ;;; The MORE forms are put in front. (defmacro em-apply (function &rest more &environment env) - (multiple-value-bind (required rest) - (effective-method-parameters env) - `(apply ,function ,@more ,@required ,rest))) + `(apply ,function ,@more ,@(effective-method-parameters env))) -(defun generate-effective-method-call (outcome) +(defmethod generate-outcome ((outcome effective-method-outcome)) (let ((form (effective-method-outcome-form outcome)) (function (effective-method-outcome-function outcome))) (when (and (eq *inline-effective-methods* 'cl:require) @@ -447,7 +377,7 @@ (defun generate-discriminator-from-data (call-history specializer-profile generic-function-form nreq max-nargs - &key generic-function-name (miss-operator 'dispatch-miss) + &key generic-function-name (miss-operator 'miss) ((:inline-effective-methods *inline-effective-methods*) *inline-effective-methods*)) (let* ((more-args (if (or (not max-nargs) (> max-nargs nreq)) 'more-args nil)) @@ -457,7 +387,7 @@ ,@(when more-args `(&rest ,more-args))) ,@(when generic-function-name `((declare (core:lambda-name ,generic-function-name)))) - (with-effective-method-parameters ((,@required-args) ,more-args) + (with-effective-method-parameters (,@required-args ,more-args) (symbol-macrolet ((+gf-being-compiled+ ,generic-function-name)) (let ((.generic-function. ,generic-function-form)) ,(when (and more-args max-nargs) ; Check argcount. @@ -482,21 +412,35 @@ required-args `(apply #',miss-operator .generic-function. ,@required-args ,more-args))))))))) -(defun safe-gf-specializer-profile (gf) - (with-early-accessors (+standard-generic-function-slots+) - (generic-function-specializer-profile gf))) - -;;; This is a macro to make CAS and stuff work smoothly. -(defmacro safe-gf-call-history (gf) - (let ((idx (position 'call-history +standard-generic-function-slots+ - :key #'car))) - `(funcallable-standard-instance-access ,gf ,idx))) - (defun generate-discriminator (generic-function) (multiple-value-bind (min max) (generic-function-min-max-args generic-function) (generate-discriminator-from-data - (mp:atomic (safe-gf-call-history generic-function)) - (safe-gf-specializer-profile generic-function) + (generic-function-call-history generic-function) + (generic-function-specializer-profile generic-function) generic-function min max :generic-function-name (core:function-name generic-function)))) + +;;; exported interface +(defun compile-discriminating-function (generic-function) + ;; Ensure an up to date (i.e. won't need to miss on these arguments) + ;; interpreted discriminator is installed, so that if Cleavir calls the + ;; generic function we're compiling it won't go recursive. + (set-funcallable-instance-function + generic-function (bytecode-interpreted-discriminator generic-function)) + (set-funcallable-instance-function + generic-function + (compile nil (generate-discriminator generic-function))) + (values)) + +(defun maybe-compile-named-gf (name) + (when (fboundp name) + (let ((f (fdefinition name))) + (when (and (typep f 'standard-generic-function) + (not (null (generic-function-call-history f)))) + (clos:compile-discriminating-function f))))) + +(defun compile-all-generic-functions () + (do-all-symbols (s) + (maybe-compile-named-gf s) + (maybe-compile-named-gf `(setf ,s)))) diff --git a/src/lisp/kernel/clos/conditions.lisp b/src/lisp/kernel/clos/conditions.lisp index 207eb8aaf8..72cd53c2e1 100644 --- a/src/lisp/kernel/clos/conditions.lisp +++ b/src/lisp/kernel/clos/conditions.lisp @@ -24,10 +24,6 @@ ;;; proof that the condition system can be implemented. ;;; -#+(or) -(eval-when (:execute) - (setq core:*echo-repl-read* t)) - (in-package "SYSTEM") ;;; ---------------------------------------------------------------------- @@ -85,13 +81,13 @@ ;;; This is necessary for bootstrapping reasons: assert.lisp, at least, ;;; uses restart-bind before CLOS and static-gfs are up. +;;; FIXME: Probably not true in the cross build (defun make-restart (&key name function (report-function (lambda (stream) (prin1 name stream))) (interactive-function (constantly ())) (test-function (constantly t))) - (declare (notinline make-instance)) - (make-instance 'restart + (clos::early-make-instance restart :name name :function function :report-function report-function :interactive-function interactive-function @@ -194,6 +190,7 @@ (ext:restart-interactive-function real-restart))))) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun munge-with-condition-restarts-form (original-form env) (ext:with-current-source-form (original-form) (let ((form (macroexpand original-form env))) @@ -227,6 +224,7 @@ `(,name ,condition-var))))) original-form)) original-form)))) +) ; eval-when (defmacro restart-case (expression &body clauses &environment env) (flet ((transform-keywords (&key report interactive test) @@ -702,6 +700,10 @@ This is due to either a problem in foreign code (e.g., C++), or a bug in Clasp i (define-condition core:simple-program-error (simple-condition program-error) ()) +(defun core:simple-program-error (format-control &rest format-arguments) + (error 'core:simple-program-error + :format-control format-control :format-arguments format-arguments)) + (define-condition control-error (error) ()) (define-condition core:simple-control-error (simple-condition control-error) ()) @@ -1143,53 +1145,12 @@ The conflict resolver must be one of ~s" chosen-symbol candidates)) (define-condition core:simple-reader-error (simple-condition reader-error) ()) -(define-condition format-error (simple-error) - ((format-control :initarg :complaint) - (format-arguments :initarg :arguments) - (control-string :reader format-error-control-string - :initarg :control-string - :initform *default-format-error-control-string*) - (offset :reader format-error-offset :initarg :offset - :initform *default-format-error-offset*) - (print-banner :reader format-error-print-banner :initarg :print-banner - :initform t)) - (:report (lambda (condition stream) - (format - stream - "~:[~;Error in format: ~]~ - ~?~@[~% ~A~% ~V@T^~]" - (format-error-print-banner condition) - (simple-condition-format-control condition) - (simple-condition-format-arguments condition) - (format-error-control-string condition) - (format-error-offset condition))))) - -;;; Conditions the FORMAT compiler macro signals if there's an argument count mismatch. -;;; CLHS 22.3.10.2 says that having too few arguments is undefined, so that's a warning, -;;; but having too many just means they're ignored, so that's a style-warning. -;;; (Alternately we could not complain at all.) -(define-condition format-warning-too-few-arguments (warning) - ((control-string :initarg :control :reader format-warning-control-string) - (expected :initarg :expected :reader format-warning-expected) - (observed :initarg :observed :reader format-warning-observed)) - (:report (lambda (condition stream) - (format stream - "Format string ~s expects at least ~d arguments,~@ - but is only provided ~d." - (format-warning-control-string condition) - (format-warning-expected condition) - (format-warning-observed condition))))) -(define-condition format-warning-too-many-arguments (style-warning) - ((control-string :initarg :control :reader format-warning-control-string) - (expected :initarg :expected :reader format-warning-expected) - (observed :initarg :observed :reader format-warning-observed)) - (:report (lambda (condition stream) - (format stream - "Format string ~s expects at most ~d arguments,~@ - but is provided ~d." - (format-warning-control-string condition) - (format-warning-expected condition) - (format-warning-observed condition))))) +(defun core:simple-reader-error (stream format-control &rest format-arguments) + (error 'core:simple-reader-error + :stream stream :format-control format-control + :format-arguments format-arguments)) + + (defun signal-simple-error (condition-type continue-message format-control format-args @@ -1285,7 +1246,7 @@ The conflict resolver must be one of ~s" chosen-symbol candidates)) (dname (if (eq name 'cl:lambda) "anonymous function" name))) - (format stream "Calling ~a" name)))) + (format stream "Calling ~a" dname)))) (when (arguments-available-p condition) (format stream "~%With arguments:~%~t~s" (arguments condition)))))) diff --git a/src/lisp/kernel/clos/cpl.lisp b/src/lisp/kernel/clos/cpl.lisp index 6db6a8f710..9e6b8a90ed 100644 --- a/src/lisp/kernel/clos/cpl.lisp +++ b/src/lisp/kernel/clos/cpl.lisp @@ -12,10 +12,10 @@ (in-package "CLOS") -;;; Used below, so it needs to be defined at least before compute-clos-cpl is called. -(defun forward-referenced-class-p (x) - (let ((y (find-class 'FORWARD-REFERENCED-CLASS nil))) - (and y (si::subclassp (class-of x) y)))) +(defgeneric compute-class-precedence-list (class)) + +(defmethod compute-class-precedence-list ((class class)) + (compute-clos-class-precedence-list class (class-direct-superclasses class))) ;;; ---------------------------------------------------------------------- ;;; ORDERING OF CLASSES @@ -81,7 +81,7 @@ (loop (unless superclasses (return (values class-list precedence-lists))) (let ((next-class (pop superclasses))) - (when (forward-referenced-class-p next-class) + (when (typep next-class 'forward-referenced-class) (error "Cannot compute class precedence list for forward-referenced class ~A." (class-name next-class))) (unless (member next-class class-list :test 'eql) @@ -123,7 +123,7 @@ (cond ((null superclasses) (list new-class)) ((and (endp (rest superclasses)) - (not (forward-referenced-class-p (first superclasses)))) + (not (typep (first superclasses) 'forward-referenced-class))) (list* new-class (slot-value (first superclasses) 'precedence-list))) (t (multiple-value-bind (class-list precedence-lists) diff --git a/src/lisp/kernel/clos/defclass.lisp b/src/lisp/kernel/clos/defclass.lisp deleted file mode 100644 index 001a1a5593..0000000000 --- a/src/lisp/kernel/clos/defclass.lisp +++ /dev/null @@ -1,120 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi. -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. - -(in-package "CLOS") - -;;; ---------------------------------------------------------------------- -;;; DEFCLASS - -(defun parse-default-initargs (default-initargs) - (do* ((output-list nil) - (scan default-initargs (cddr scan)) - (already-supplied '())) - ((endp scan) `(list ,@(nreverse output-list))) - (when (endp (rest scan)) - (si::simple-program-error "Wrong number of elements in :DEFAULT-INITARGS option.")) - (let ((slot-name (first scan)) - (initform (second scan))) - (if (member slot-name already-supplied) - (si::simple-program-error "~S is duplicated in :DEFAULT-INITARGS form ~S" - slot-name default-initargs) - (push slot-name already-supplied)) - (push `(list ',slot-name ',initform (lambda () - (declare (core:lambda-name parse-default-initargs.lambda)) - ,initform)) - output-list)))) - -(defun gen-note-accessors (slots) - (flet ((gen-note (name) - `(cmp::register-global-function-def 'defmethod ',name))) - (loop with result = nil - for slot in slots - when (consp slot) - do (loop for (key value) on (rest slot) by #'cddr - do (case key - ((:reader :writer) - (push (gen-note value) result)) - ((:accessor) - (push (gen-note value) result) - (push (gen-note `(setf ,value)) result)))) - finally (return result)))) - -(defmacro defclass (name superclasses slots &rest options) - (let (;; Throw in source info if there is any. - (options (if core:*current-source-pos-info* - (list* (cons :source-position core:*current-source-pos-info*) options) - options))) - (unless (and (listp superclasses) (listp slots)) - (si::simple-program-error "Illegal defclass form: superclasses and slots should be lists")) - (unless (and (symbolp name) (every #'symbolp superclasses)) - (si::simple-program-error "Illegal defclass form: superclasses and class name are not valid")) - (let ((parsed-slots (parse-slots slots)) - (processed-class-options (process-class-options options))) - `(progn - (eval-when (:compile-toplevel) - ,@(gen-note-accessors slots) - (setf (core::class-info ',name) t)) - (eval-when (:load-toplevel :execute) - (ensure-class ',name :direct-superclasses ',superclasses - :direct-slots ,parsed-slots - ,@processed-class-options)))))) - -(defun process-class-options (class-args) - (let ((options '()) - (processed-options '())) - (dolist (option class-args options) - (unless (consp option) - (si:simple-program-error - "Option ~s for DEFCLASS has invalid syntax: not a cons" option)) - (let ((option-name (first option)) - option-value) - (unless (symbolp option-name) - (si:simple-program-error - "~s is not a valid DEFCLASS option: not a symbol" option-name)) - (if (member option-name processed-options) - (si:simple-program-error - "Option ~s for DEFCLASS specified more than once" - option-name) - (push option-name processed-options)) - (setq option-value - (case option-name - ((:metaclass :documentation) - (ext:maybe-quote (second option))) -;; ((:source-position) (second option)) ; see FIXME above - (:default-initargs - (setf option-name :direct-default-initargs) - (parse-default-initargs (rest option))) - (otherwise - (ext:maybe-quote (rest option)))) - options (list* (ext:maybe-quote option-name) - option-value options)))))) - -;;; ---------------------------------------------------------------------- -;;; ENSURE-CLASS -;;; -(defun ensure-class (name &rest initargs) - (apply #'ensure-class-using-class - (let ((class (and name - (find-class name nil)))) - ;; Only classes which have a PROPER name are redefined. If a class - ;; with the same name is registered, but the name of the class does not - ;; correspond to the registered name, a new class is returned. - ;; [Hyperspec 7.7 for DEFCLASS] - (when (and class (eq name (class-name class))) - class)) - name initargs)) - -#+(or) ;#+cross -(eval-when (compile) - (defun ensure-class (name &rest initargs) - (warn "Ignoring definition for class ~S" name))) - diff --git a/src/lisp/kernel/clos/define-method-combination.lisp b/src/lisp/kernel/clos/define-method-combination.lisp new file mode 100644 index 0000000000..de67d6ad0b --- /dev/null +++ b/src/lisp/kernel/clos/define-method-combination.lisp @@ -0,0 +1,126 @@ +#-building-clasp(in-package #:cross-clasp.clasp.clos) +#+building-clasp(in-package #:clos) + +;;;; This file is compiled/loaded both by the host and the target. +;;;; Tricky bit with that: the host CLOS package shadows DEFINE-METHOD-COMBINATION. +;;;; The target package does not. But this should work out, as the loader doesn't +;;;; know or care about packaging - it will just intern D-M-C in CLOS and whether +;;;; that puts it in CL or not depends on the target package. + +(defmacro define-simple-method-combination (name &key documentation + identity-with-one-argument + (operator name)) + `(define-complex-method-combination + ,name (&optional (order :MOST-SPECIFIC-FIRST)) + ((around (:AROUND)) + (principal (,name) :REQUIRED t)) + ,documentation + (let ((main-effective-method + (list* ',operator (mapcar (lambda (x) + (list 'call-method x ())) + (if (eql order :MOST-SPECIFIC-LAST) + (reverse principal) + principal))))) + (cond (around + (list 'call-method (first around) + (append (rest around) + (list (list 'make-method main-effective-method))))) + ,@(if identity-with-one-argument + `(((null (rest principal)) + (second main-effective-method)))) + (t main-effective-method))))) + +(defun parse-complex-dmc-body (body) + (loop with argsp = nil with gfp = nil + with args = nil with gf = nil + for rbody on body + for first = (first rbody) + if (and (consp first) (eq (first first) :arguments) + (not argsp)) + do (setf argsp t args (rest first)) + else if (and (consp first) (eq (first first) :generic-function) + (cdr (rest first)) (null (cddr first)) + (symbolp (second first)) (not gfp)) + do (setf gfp t gf (second first)) + else do (loop-finish) + finally (return (values args argsp gf gfp rbody)))) + +(defmacro define-complex-method-combination (name (&rest lambda-list) + (&rest method-groups) + &rest body) + (unless (symbolp name) + (error "Method combination name must be a symbol, but got ~s" name)) + (multiple-value-bind (args-lambda-list argsp gf-symbol gfp body) + (parse-complex-dmc-body body) + (declare (ignore args-lambda-list gfp)) + (when argsp + (warn "Option :ARGUMENTS is not supported in DEFINE-METHOD-COMBINATION.") + (return-from define-complex-method-combination + `(error "Option :ARGUMENTS is not supported in DEFINE-METHOD-COMBINATION."))) + (let ((gf-symbol (or gf-symbol (gensym "GENERIC-FUNCTION"))) + (group-names '()) (group-checks '()) (group-after '())) + (dolist (group method-groups) + (destructuring-bind (group-name predicate &key description + (order :most-specific-first) + (required nil)) + group + (declare (ignore description)) ; FIXME? + (if (symbolp group-name) + (push group-name group-names) + (error "Method combination method group name must be a symbol, but got ~s" group-name)) + (let ((condition + (cond ((eql predicate '*) 'T) + ((null predicate) `(null .method-qualifiers.)) + ((symbolp predicate) + `(,predicate .method-qualifiers.)) + ((consp predicate) + (let* ((q (last predicate 0)) + (p (copy-list (butlast predicate 0)))) + (when (every #'symbolp p) + (if (eql q '*) + `(every #'equal ',p .method-qualifiers.) + `(equal ',p .method-qualifiers.))))) + (t (error "Invalid method group predicate: ~s" predicate))))) + (push `(,condition (push .method. ,group-name)) group-checks)) + (when required + (push `(unless ,group-name + ;; Effective methods can be computed in other situations than being + ;; about to call them. As such, compute-effective-method should not + ;; signal an error unless the computation is impossible. Lacking a + ;; required method is by contrast a problem that only needs to be + ;; signaled when the function is actually being called. So we return + ;; an error form. ...but because we want an independent function for + ;; the dtree interpreter, we return something specially recognizable + ;; by compute-outcome, so the generic function etc. can be hooked up. + (return-from ,name '(%magic-no-required-method ,group-name))) + group-after)) + (case order + (:most-specific-first + (push `(setf ,group-name (nreverse ,group-name)) group-after)) + (:most-specific-last) + (otherwise + (let ((order-var (gensym))) + (setf group-names (append group-names (list (list order-var order))) + group-after (list* `(when (eq ,order-var :most-specific-first) + (setf ,group-name (nreverse ,group-name))) + group-after))))))) + `(install-method-combination + ',name + (lambda (,gf-symbol .methods-list. ,@lambda-list) + (declare (core:lambda-name ,name) + (ignorable ,gf-symbol)) + (block ,name + (let (,@group-names) + (dolist (.method. .methods-list.) + (let ((.method-qualifiers. (method-qualifiers .method.))) + (cond ,@(nreverse group-checks) + (t (invalid-method-error .method. + "Method qualifiers ~S are not allowed in the method ~ + combination ~S." .method-qualifiers. ',name))))) + ,@group-after + ,@body))))))) + +(defmacro define-method-combination (name &body body) + (if (and body (listp (first body))) + `(define-complex-method-combination ,name ,@body) + `(define-simple-method-combination ,name ,@body))) diff --git a/src/lisp/kernel/clos/dependent.lisp b/src/lisp/kernel/clos/dependent.lisp new file mode 100644 index 0000000000..4cfef20b81 --- /dev/null +++ b/src/lisp/kernel/clos/dependent.lisp @@ -0,0 +1,23 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- +;;;; +;;;; Copyright (c) 1992, Giuseppe Attardi. +;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. +;;;; +;;;; This program 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 file '../Copyright' for full details. + +(in-package "CLOS") + +(defgeneric add-dependent (metaobject dependent)) +(defgeneric remove-dependent (metaobject dependent)) +(defgeneric map-dependents (metaobject function)) +(defgeneric update-dependent (metaobject dependent &rest initargs)) + +(defun update-dependents (object initargs) + (map-dependents + object + #'(lambda (dep) (apply #'update-dependent object dep initargs)))) diff --git a/src/lisp/kernel/clos/dtree-graphviz.lisp b/src/lisp/kernel/clos/dtree-graphviz.lisp deleted file mode 100644 index fe5fdfe2c0..0000000000 --- a/src/lisp/kernel/clos/dtree-graphviz.lisp +++ /dev/null @@ -1,149 +0,0 @@ -(in-package :clos) - -(defstruct (bc-node (:type vector) :named) - name text - (edges (make-array 4 :adjustable t :fill-pointer 0))) - -(defstruct (bc-edge (:type vector) :named) - name node-place) - -(defstruct (bc-graph (:type vector) :named) - (nodes (make-hash-table)) - links - patches) - -(defun do-graphviz-linearize (tree graph depth) - (let ((node nil)) - (labels ((collect (tree &rest xs) - (let ((seen (gethash tree (bc-graph-nodes graph)))) - (if seen - (setq node seen) - (let ((name (gensym))) - (setf node (make-bc-node :name name - :text (format nil "~a-~a ~{ ~a~}" - (cond - ((symbolp tree) - tree) - (t (elt tree 0))) - (string name) - xs)) - (gethash tree (bc-graph-nodes graph)) node))))) - (wait (tree &optional (name (elt tree 0))) - (let ((new-tail (list nil))) - (push (cons new-tail tree) (bc-graph-links graph)) - (vector-push-extend (make-bc-edge :name name :node-place new-tail) (bc-node-edges node)))) - (next (tree name) - (vector-push-extend (make-bc-edge :name name :node-place (list (do-graphviz-linearize tree graph (1+ depth)))) - (bc-node-edges node))) - (cont () - (if (null (bc-graph-links graph)) - ;; nothing more to do - (return-from do-graphviz-linearize node) - ;; go to the next tree - (destructuring-bind (patchpoint . subtree) - (pop (bc-graph-links graph)) - (push (cons patchpoint subtree) (bc-graph-patches graph)) - (next subtree "cont"))))) - (cond ((argument-p tree) - (collect tree - :count (argument-count tree)) - (next (argument-next tree) "next")) - ((register-p tree) - (collect tree - :count (register-index tree)) - (next (register-next tree) "next")) - ((tag-test-p tree) - (collect tree) - (wait (elt (tag-test-tags tree) 0) "fixnum-tag") - (wait (elt (tag-test-tags tree) 1) "cons-tag") - (wait (elt (tag-test-tags tree) 2) "single-float-tag") - (wait (elt (tag-test-tags tree) 3) "character-tag") - (next (tag-test-default tree) "default")) - ((stamp-read-p tree) - (collect tree) - (wait (stamp-read-c++ tree) "c++") - (next (stamp-read-other tree) "other")) - ((<-branch-p tree) - (collect tree - (<-branch-pivot tree)) - (wait (<-branch-left tree) "left") - (next (<-branch-right tree) "right")) - ((=-check-p tree) - (collect tree - (=-check-pivot tree)) - (next (=-check-next tree) "next")) - ((range-check-p tree) - (collect tree - (range-check-min tree) - (range-check-max tree)) - (next (range-check-next tree) "next")) - ((eql-search-p tree) - (loop for object across (eql-search-objects tree) - for next across (eql-search-nexts tree) - do (collect tree - object) - (wait next "next")) - (next (eql-search-default tree) "default")) - ((miss-p tree) - (collect tree) - (cont)) - ((optimized-slot-reader-p tree) - (collect - (if (core:fixnump (optimized-slot-reader-index tree)) - 'optimized-slot-reader ; instance - 'car) ; class - (optimized-slot-reader-index tree) - (optimized-slot-reader-slot-name tree)) - (cont)) - ((optimized-slot-writer-p tree) - (collect - (if (core:fixnump (optimized-slot-writer-index tree)) - 'optimized-slot-writer ; instance - 'rplaca) ; class - (optimized-slot-writer-index tree)) - (cont)) - ((effective-method-outcome-p tree) - (collect tree - (effective-method-outcome-function tree)) - (cont)) - (t (error "BUG: Unknown dtree: ~a" tree)))) - node)) - -(defun graphviz-linearize (tree) - (let ((graph (make-bc-graph))) - (do-graphviz-linearize tree graph 0) - (loop for patch in (bc-graph-patches graph) - do (destructuring-bind (place . subtree) - patch - (let ((node (gethash subtree (bc-graph-nodes graph)))) - (setf (car place) node)))) - graph)) - -(defun render-dtree-graph (filename graph) - (with-open-file (fout filename :direction :output :if-exists :supersede) - (format fout "digraph {~%") - (maphash (lambda (key node) - (declare (ignore key)) - (format fout "~a [label=\"~a\"];~%" (string (bc-node-name node)) (bc-node-text node))) - (bc-graph-nodes graph)) - (maphash (lambda (key node) - (declare (ignore key)) - (loop for edge across (bc-node-edges node) - for to-node = (car (bc-edge-node-place edge)) - for to-node-name = (cond - ((symbolp to-node) to-node) - (t (bc-node-name to-node))) - do (format fout "~a -> ~a [label=\"~a\"];~%" - (bc-node-name node) - to-node-name - (bc-edge-name edge)))) - (bc-graph-nodes graph)) - (format fout "}~%"))) - -(defun render-dtree (filename generic-function) - (let* ((compiled (dtree-compile generic-function)) - (graph (graphviz-linearize compiled))) - (render-dtree-graph filename graph))) - -(export 'render-generic-function-dtree) - diff --git a/src/lisp/kernel/clos/dtree-ops.lisp b/src/lisp/kernel/clos/dtree-ops.lisp new file mode 100644 index 0000000000..c29179feca --- /dev/null +++ b/src/lisp/kernel/clos/dtree-ops.lisp @@ -0,0 +1,45 @@ +(in-package #:cmpref) + +(eval-when + #+building-clasp (:compile-toplevel) + #-building-clasp (:load-toplevel :execute) + (defvar *dtree-ops-as-list* + '(("miss" 0 "DTREE_OP_MISS") + ("advance" 1 "DTREE_OP_ADVANCE") + ("tag-test" 2 "DTREE_OP_TAG_TEST" ((:label-arg "DTREE_FIXNUM_TAG_OFFSET") + (:label-arg "DTREE_SINGLE_FLOAT_TAG_OFFSET") + (:label-arg "DTREE_CHARACTER_TAG_OFFSET") + (:label-arg "DTREE_CONS_TAG_OFFSET") + (:offset "DTREE_GENERAL_TAG_OFFSET"))) + ("stamp-read" 3 "DTREE_OP_STAMP_READ" ((:label-arg "DTREE_READ_HEADER_OFFSET") + (:offset "DTREE_READ_OTHER_OFFSET"))) + ("lt-branch" 4 "DTREE_OP_LT_BRANCH" ((:constant-arg "DTREE_LT_PIVOT_OFFSET") + (:label-arg "DTREE_LT_LEFT_OFFSET") + (:offset "DTREE_LT_RIGHT_OFFSET"))) + ("eq-check" 5 "DTREE_OP_EQ_CHECK" ((:constant-arg "DTREE_EQ_PIVOT_OFFSET") + (:offset "DTREE_EQ_NEXT_OFFSET"))) + ("range-check" 6 "DTREE_OP_RANGE_CHECK" ((:constant-arg "DTREE_RANGE_MIN_OFFSET") + (:constant-arg "DTREE_RANGE_MAX_OFFSET") + (:offset "DTREE_RANGE_NEXT_OFFSET"))) + ("eql" 7 "DTREE_OP_EQL" ((:constant-arg "DTREE_EQL_OBJECT_OFFSET") + (:label-arg "DTREE_EQL_BRANCH_OFFSET") + (:offset "DTREE_EQL_NEXT_OFFSET"))) + ("optimized-slot-reader" 8 "DTREE_OP_SLOT_READ" ((:constant-arg "DTREE_SLOT_READER_INDEX_OFFSET") + (:constant-arg "DTREE_SLOT_READER_SLOT_NAME_OFFSET"))) + ("optimized-slot-writer" 9 "DTREE_OP_SLOT_WRITE" ((:constant-arg "DTREE_SLOT_WRITER_INDEX_OFFSET"))) + ("car" 10 "DTREE_OP_CAR" ((:constant-arg "DTREE_CAR_READER_INDEX_OFFSET") + (:constant-arg "DTREE_CAR_READER_CAR_NAME_OFFSET"))) + ("rplaca" 11 "DTREE_OP_RPLACA" ((:constant-arg "DTREE_RPLACA_WRITER_INDEX_OFFSET"))) + ("effective-method-outcome" 12 "DTREE_OP_EFFECTIVE_METHOD" ((:constant-arg "DTREE_EFFECTIVE_METHOD_OFFSET"))) + ("farg0" 13 "DTREE_OP_FARG0") + ("farg1" 14 "DTREE_OP_FARG1") + ("farg2" 15 "DTREE_OP_FARG2") + ("farg3" 16 "DTREE_OP_FARG3") + ("farg4" 17 "DTREE_OP_FARG4") + ("argn" 18 "DTREE_OP_ARGN" ((:register-arg "DTREE_ARGN_OFFSET") + (:offset "DTREE_ARGN_NEXT_OFFSET"))) + ("sd-eq-branch" 19 "DTREE_OP_SD_EQ_BRANCH" ((:constant-arg "DTREE_SD_STAMP_OFFSET") + (:label-arg "DTREE_SD_FAIL_OFFSET") + (:offset "DTREE_SD_NEXT_OFFSET"))) + ("single-dispatch-miss" 20 "DTREE_OP_SINGLE_DISPATCH_MISS") + ))) diff --git a/src/lisp/kernel/clos/effective-accessor.lisp b/src/lisp/kernel/clos/effective-accessor.lisp index 010b769015..cabe3c804f 100644 --- a/src/lisp/kernel/clos/effective-accessor.lisp +++ b/src/lisp/kernel/clos/effective-accessor.lisp @@ -1,15 +1,30 @@ (in-package "CLOS") -(defun make-effective-accessor-method (class method location function) - (with-early-make-instance +effective-accessor-method-slots+ - (dam class - :function function - :original method - :location location) - dam)) +;;; needed for compute-effective-method +(defmethod method-qualifiers ((method effective-accessor-method)) + (with-early-accessors (effective-accessor-method) + (method-qualifiers (effective-accessor-method-original method)))) +;;; for compute-outcome +(defmethod accessor-method-slot-definition ((method effective-accessor-method)) + (with-early-accessors (effective-accessor-method) + (accessor-method-slot-definition (effective-accessor-method-original method)))) +;;; expand-apply-method +(defmethod method-specializers ((method effective-accessor-method)) + (with-early-accessors (effective-accessor-method) + (method-specializers (effective-accessor-method-original method)))) + +(defun make-effective-reader-method (method location function) + (early-make-instance effective-reader-method + :original method :location location + :function function)) + +(defun make-effective-writer-method (method location function) + (early-make-instance effective-writer-method + :original method :location location + :function function)) (defun make-effective-writer-function (location) - (make-%method-function-fast + (make-%leaf-method-function (if (consp location) (lambda (new object) (declare (core:lambda-name @@ -19,115 +34,65 @@ (lambda (new object) (declare (core:lambda-name effective-instance-writer)) - (setf (si:instance-ref object location) new))))) + ;; FIXME: funcallable- + (setf (standard-instance-access object location) new))))) (defun make-effective-reader-function (location slot-name) - (make-%method-function-fast + (make-%leaf-method-function (if (consp location) (lambda (object) (declare (core:lambda-name effective-class-reader)) (let ((val (car location))) - (if (cleavir-primop:eq val (core:unbound)) + (if (eq val (core:unbound)) (slot-unbound (class-of object) object slot-name) val))) (lambda (object) (declare (core:lambda-name effective-instance-reader)) - (let ((val (si:instance-ref object location))) - (if (cleavir-primop:eq val (core:unbound)) + (let ((val (standard-instance-access object location))) + (if (eq val (core:unbound)) (slot-unbound (class-of object) object slot-name) val)))))) -;;; moved here for bootstrapping reasons. -;;; functions are defined a bit later in slotvalue.lisp. -#+threads -(mp:define-atomic-expander slot-value-using-class (class object slotd) - (&rest keys) - "Same requirements as STANDARD-INSTANCE-ACCESS, except the slot can have -allocation :class. -Also, methods on SLOT-VALUE-USING-CLASS, SLOT-BOUNDP-USING-CLASS, and -(SETF SLOT-VALUE-USING-CLASS) are ignored (not invoked). -In the future, the CAS behavior may be customizable with a generic function." - (declare (ignore keys)) - (let ((gclass (gensym "CLASS")) (gobject (gensym "OBJECT")) - (gslotd (gensym "SLOTD")) (oldv (gensym "OLD")) (newv (gensym "NEWV"))) - (values (list gclass gobject gslotd) (list class object slotd) oldv newv - `(atomic-slot-value-using-class ,gclass ,gobject ,gslotd) - `(setf (atomic-slot-value-using-class ,gclass ,gobject ,gslotd) - ,newv) - `(cas-slot-value-using-class ,oldv ,newv - ,gclass ,gobject ,gslotd)))) - ;;; These can be called (through final-methods) from many threads simultaneously ;;; and so must be thread-safe. (defun intern-effective-reader (method location) - (loop with direct-slotd = (accessor-method-slot-definition method) - for table = (mp:atomic (slot-value direct-slotd '%effective-readers)) - for existing = (cdr (assoc location table)) - when existing - return existing - do (let ((eff - (make-effective-accessor-method - (find-class 'effective-reader-method) - method location - (make-effective-reader-function - location (slot-definition-name direct-slotd))))) - (when (eq (mp:cas (slot-value direct-slotd '%effective-readers) - table (acons location eff table)) - table) - (return eff))))) - -(defun early-intern-effective-reader (method location) - (with-early-accessors (+standard-accessor-method-slots+ - +direct-slot-definition-slots+) + ;; We could write things in terms of slot-value but that would require some + ;; nontrivial macro work to get CAS of slot-value. FIXME + (with-early-accessors (standard-direct-slot-definition) (loop with direct-slotd = (accessor-method-slot-definition method) - for table = (mp:atomic (%direct-slotd-effective-readers direct-slotd)) + with table = (mp:atomic (%effective-readers direct-slotd)) for existing = (cdr (assoc location table)) when existing return existing - do (let ((eff - (make-effective-accessor-method - (find-class 'effective-reader-method) - method location - (make-effective-reader-function - location (slot-definition-name direct-slotd))))) - (when (eq (mp:cas (%direct-slotd-effective-readers direct-slotd) - table (acons location eff table)) - table) - (return eff)))))) + do (let* ((eff + (make-effective-reader-method + method location + (make-effective-reader-function + location (slot-definition-name direct-slotd)))) + (new-table + (mp:cas (%effective-readers direct-slotd) + table (acons location eff table)))) + (if (eq new-table table) + (return eff) + (setf table new-table)))))) (defun intern-effective-writer (method location) - (loop with direct-slotd = (accessor-method-slot-definition method) - for table = (mp:atomic (slot-value direct-slotd '%effective-writers)) - for existing = (cdr (assoc location table)) - when existing - return existing - do (let ((eff - (make-effective-accessor-method - (find-class 'effective-writer-method) - method location - (make-effective-writer-function location)))) - (when (eq (mp:cas (slot-value direct-slotd '%effective-writers) - table (acons location eff table)) - table) - (return eff))))) - -(defun early-intern-effective-writer (method location) - (with-early-accessors (+standard-accessor-method-slots+ - +direct-slot-definition-slots+) + (with-early-accessors (standard-direct-slot-definition) (loop with direct-slotd = (accessor-method-slot-definition method) - for table = (mp:atomic (%direct-slotd-effective-writers direct-slotd)) + for table = (mp:atomic (%effective-writers direct-slotd)) for existing = (cdr (assoc location table)) when existing return existing - do (let ((eff - (make-effective-accessor-method - (find-class 'effective-writer-method) - method location - (make-effective-writer-function location)))) - (when (eq (mp:cas (%direct-slotd-effective-writers direct-slotd) - table (acons location eff table)) - table) - (return eff)))))) + do (let* ((eff + (make-effective-writer-method + method location + (make-effective-writer-function location))) + (new-table + (mp:cas (%effective-writers direct-slotd) + table (acons location eff table)))) + (if (eq table new-table) + (return eff) + (setf table new-table)))))) diff --git a/src/lisp/kernel/clos/effective-method.lisp b/src/lisp/kernel/clos/effective-method.lisp new file mode 100644 index 0000000000..86065ed74c --- /dev/null +++ b/src/lisp/kernel/clos/effective-method.lisp @@ -0,0 +1,252 @@ +(in-package #:clos) + +(defgeneric compute-effective-method (generic-function method-combination + applicable-methods)) + +(defmethod compute-effective-method ((gf standard-generic-function) + method-combination applicable-methods) + (let ((compiler (method-combination-compiler method-combination)) + (options (method-combination-options method-combination))) + (apply compiler gf applicable-methods options))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; EFFECTIVE METHOD FUNCTIONS +;;; +;;; Effective method functions are the functional version of effective +;;; methods (effective methods being the forms returned by +;;; compute-effective-method). On Clasp, they are functions that accept the +;;; same arguments as the generic function. +;;; In general we can simply compile the effective method, but the compiler +;;; is slow, so we go to some effort to special case common effective +;;; methods. +;;; Note that we more often go through this mechanism than putting the +;;; effective methods in the discriminating function directly. See +;;; *inline-effective-methods* in discriminate.lisp. +;;; The main entry to this section is EFFECTIVE-METHOD-FUNCTION, which +;;; returns a function for a given effective method. +;;; The ARG-INFO threaded throughout here is used to skip some APPLYing. +;;; See miss.lisp, gf-arg-info function. + +;;; We pass the parameters to CALL-METHOD and sundry in this fashion. +(defmacro with-effective-method-parameters ((&rest spreadable) &body body) + `(symbol-macrolet ((+emf-params+ (,@spreadable))) ,@body)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun effective-method-parameters (&optional environment) + (multiple-value-bind (expansion expanded) + (macroexpand-1 '+emf-params+ environment) + (if expanded + expansion + ;; If we're not in a discriminator, and so the symbol macro + ;; isn't bound, we return a banal response. + ;; FIXME?: Might want to signal an error instead. + ;; .method-args. isn't as universal any more. + '.method-args.)))) + +(defvar *avoid-compiling* nil) + +(defun emf-maybe-compile (form) + (if *avoid-compiling* + (let ((cmp:*cleavir-compile-hook* nil)) + (declare (special cmp:*cleavir-compile-hook*)) + (compile nil form)) + (let ((*avoid-compiling* t)) + (compile nil form)))) + +(defun emf-default (form arg-info) + (let ((rest (first (last arg-info))) (vars (butlast arg-info))) + (emf-maybe-compile + `(lambda (,@vars ,@(when rest `(&rest ,rest))) + (with-effective-method-parameters (,@arg-info) + ,form))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun make-method-form-p (form) + (and (consp form) + (eq (first form) 'make-method) + (consp (cdr form)) + (null (cddr form))))) + +(defun emf-from-contf (contf method next-methods arg-info) + (let ((next (if (null next-methods) + (make-%no-next-method-continuation method) + (emf-call-method + (first next-methods) (list (rest next-methods)) + arg-info)))) + (lambda (&rest .method-args.) + (apply contf next .method-args.)))) + +(defun emf-call-method (method rest arg-info) + (cond ((make-method-form-p method) + ;; FIXME: Should call-next-method etc be bound + (effective-method-function (second method) arg-info)) + ((eq (class-of (method-function method)) + (load-time-value (find-class '%leaf-method-function))) + ;; leaf method functions are valid EMFs. + (fmf (method-function method))) + ((eq (class-of (method-function method)) + (load-time-value (find-class '%contf-method-function))) + (destructuring-bind (&optional next-methods) rest + (emf-from-contf + (contf (method-function method)) + method next-methods arg-info))) + ;; Could be a nonstandard method with its own EXPAND-APPLY-METHOD. + (t (emf-default `(call-method ,method ,@rest) arg-info)))) + +(defun effective-method-function (form &optional (arg-info '(emf-more))) + ;; emf-default is always valid, but let's pick off a few cases + ;; so that we can avoid using the compiler, which is slow. + (if (consp form) + (case (first form) + ;; Note that MAKE-METHOD is not valid outside of a CALL-METHOD, + ;; so form shouldn't be a MAKE-METHOD form. + ((call-method) (emf-call-method (second form) (cddr form) arg-info)) + (otherwise (emf-default form arg-info))) + (emf-default form arg-info))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; CALL-METHOD +;;; + +(defun argforms-to-arg-info (argforms &optional env) + (let* ((final (first (rest argforms))) + (butl (butlast argforms))) + (cons (and (constantp final env) + (null (ext:constant-form-value final env))) + (loop for s in butl + if (symbolp s) collect (make-symbol (symbol-name s)) + else collect (gensym "REQ-ARG"))))) + +(defgeneric methodp (object)) +(defmethod methodp ((object method)) t) +(defmethod methodp (object) (declare (ignore object)) nil) + +;;; Convert an element of the second argument of a usual call-method +;;; into a method or form producing a method. +(defun call-method-aux (gf method &optional (arg-info '(emf-more))) + (cond ((methodp method) method) + ((make-method-form-p method) + `(make-instance ,(generic-function-method-class gf) + ;; FIXME?: These are of course lies. + ;; Our own method on shared-initialize will signal an error + ;; without these initargs, though. + :specializers '() + :qualifiers '() + :lambda-list '() + ;; FIXME: Should call-next-method etc be available? + :function (make-%leaf-method-function + (effective-method-function + ',(second method) ',arg-info)))) + ;; FIXME: Delay this? Right now this error occurs during + ;; macroexpansion of CALL- or APPLY-METHOD. + (t (error "Invalid argument to CALL-METHOD: ~a" method)))) + +;;; Convert the second argument of a usual call-method into a list +;;; of methods. +(defun call-method-next-methods (gf next-methods &optional (arg-info '(emf-more))) + (declare (ignore arg-info)) + (loop for nmethod in next-methods + collect (call-method-aux gf nmethod))) + +(defgeneric expand-apply-method (method method-arguments arguments env)) + +(defmethod expand-apply-method ((method effective-reader-method) + method-arguments arguments env) + (declare (ignore method-arguments)) + (let* ((location (effective-accessor-method-location method)) + (sname (slot-definition-name + (accessor-method-slot-definition method))) + (valuef + (cond ((core:fixnump location) + ;; instance location- easy + `(standard-instance-access ,(first arguments) ',location)) + ((consp location) + ;; class location. we need to find the new cell at load time. + `(car ,(class-cell-form sname + (first (method-specializers method))))) + (t + (error "BUG: Slot location ~a is not a fixnum or cons" location))))) + `(let ((value ,valuef)) + (if (core:sl-boundp value) + value + (slot-unbound (class-of ,(first arguments)) + ,(first arguments) + ',sname))))) + +(defmethod expand-apply-method ((method effective-writer-method) + method-arguments arguments env) + (declare (ignore method-arguments)) + (let ((location (effective-accessor-method-location method)) + (sname (slot-definition-name + (accessor-method-slot-definition method))) + (class (second (method-specializers method)))) + (cond ((core:fixnump location) + `(setf (standard-instance-access ,(second arguments) ,location) + ,(first arguments))) + ((consp location) + ;; class location + ;; Note we don't actually need the instance. + `(setf (car ,(class-cell-form sname class)) ,(first arguments))) + (t (error "BUG: Slot location ~a is not a fixnum or cons" location))))) + +(defun class-cell-form (slot-name class) + `(load-time-value + (slot-definition-location + (or (find ',slot-name (class-slots ,class) :key #'slot-definition-name) + (error "Probably a BUG: slot ~a in ~a stopped existing between compile and load" + ',slot-name ,class))))) + +(defmethod expand-apply-method ((method standard-method) + method-arguments arguments env) + ;; should be (&optional ((&rest next-methods))) but ecclesia is stupid + (destructuring-bind (&optional next-methods) method-arguments + (let ((arg-info (argforms-to-arg-info arguments env))) + (cond + ;; TODO: General inlining mechanism might be good. + ((eq (class-of (method-function method)) + (load-time-value (find-class '%leaf-method-function))) + `(apply + (load-time-value (fmf (method-function ,method)) t) + ,@arguments)) + ((eq (class-of (method-function method)) + (load-time-value (find-class '%contf-method-function))) + `(apply + (load-time-value (contf (method-function ,method)) t) + (load-time-value + ,(if (null next-methods) + `(make-%no-next-method-continuation + ,method) + `(emf-call-method + ',(first next-methods) + '(,(rest next-methods)) ',arg-info)) + t) + ,@arguments)) + ;; Default: AMOP protocol. + (t `(funcall (load-time-value (method-function ,method) t) + ;; last element might be a vaslist + (apply #'list ,@arguments) + (load-time-value + (list ,@(call-method-next-methods + (method-generic-function method) + next-methods arg-info)) + t))))))) + +(defmacro apply-method (method (&rest method-arguments) &rest arguments + &environment env) + "Call the given method. METHOD-ARGUMENTS are the unevaluated arguments +passed in a CALL-METHOD form after the method. +ARGUMENTS is a list of forms that will evaluate to a spreadable +argument list designator." + (expand-apply-method method method-arguments arguments env)) + +(let () + ;; This macro is only needed in the running system when generic functions miss, + ;; so we make sure it's not top level. + ;; Maybe should just be defined later? + (defmacro call-method (method &rest method-arguments &environment env) + (if (make-method-form-p method) + (second method) ; FIXME: should we try to bind CALL-NEXT-METHOD etc? + `(apply-method ,method (,@method-arguments) + ,@(effective-method-parameters env))))) diff --git a/src/lisp/kernel/clos/eql-specializer.lisp b/src/lisp/kernel/clos/eql-specializer.lisp new file mode 100644 index 0000000000..711dde6a7a --- /dev/null +++ b/src/lisp/kernel/clos/eql-specializer.lisp @@ -0,0 +1,47 @@ +(in-package #:clos) + +(defclass eql-specializer (specializer) + ((object :initarg :object :reader eql-specializer-object))) + +(defvar *eql-specializer-lock* (mp:make-lock :name 'eql-specializer)) + +(defvar *eql-specializer-hash* + (make-hash-table :size 128 :test #'eql)) + +(defun intern-eql-specializer (object) + (mp:with-lock (*eql-specializer-lock*) + (or (gethash object *eql-specializer-hash*) + (setf (gethash object *eql-specializer-hash*) + (early-make-instance eql-specializer :object object))))) + +;;; FIXME: Move? +(defgeneric add-direct-method (specializer method)) +(defgeneric remove-direct-method (specializer method)) +(defgeneric specializer-direct-generic-functions (specializer)) + +(defmethod add-direct-method ((spec specializer) (method method)) + (pushnew method (%specializer-direct-methods spec)) + (values)) + +(defmethod remove-direct-method ((spec specializer) (method method)) + (setf (%specializer-direct-methods spec) + (delete method (specializer-direct-methods spec))) + (values)) + +(defmethod add-direct-method ((spec specializer) (method method)) + (pushnew method (%specializer-direct-methods spec)) + (values)) + +(defmethod remove-direct-method ((spec eql-specializer) (method method)) + (mp:with-lock (*eql-specializer-lock*) + (call-next-method) + (unless (specializer-direct-methods spec) + (remhash spec *eql-specializer-hash*))) + (values)) + +(defmethod specializer-direct-generic-functions ((specializer specializer)) + (loop with result = nil + for method in (specializer-direct-methods specializer) + for gf = (method-generic-function method) + do (pushnew gf result :test #'eq) + finally (return result))) diff --git a/src/lisp/kernel/clos/fastgf.lisp b/src/lisp/kernel/clos/fastgf.lisp deleted file mode 100644 index f6e2898dd2..0000000000 --- a/src/lisp/kernel/clos/fastgf.lisp +++ /dev/null @@ -1,11 +0,0 @@ -(in-package :clos) -(defvar *core-clos-generic-functions* (all-generic-functions)) -;;(defvar *core-classes* ) -#|(defun calculate-core-classes () - (let ((all-classes (clos::subclasses* (find-class t))) - core-classes) - (loop for class in all-classes - |# -(print *package*) -;;(format t "There are ~a *core-classes*~&" (length *core-classes*)) -(format t "There are ~a *core-clos-generic-functions*~&" (length *core-clos-generic-functions*)) diff --git a/src/lisp/kernel/clos/fixup.lisp b/src/lisp/kernel/clos/fixup.lisp deleted file mode 100644 index 1de2bdef8a..0000000000 --- a/src/lisp/kernel/clos/fixup.lisp +++ /dev/null @@ -1,528 +0,0 @@ -;; Should be commented out -#+(or) -(eval-when (:execute) - (setq core:*echo-repl-read* t)) - -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi. -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. - -(in-package "CLOS") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Define generics for core functions. - -(defun function-to-method (name lambda-list specializers - &optional satiation-specializers (function (fdefinition name))) - ;; since we still have method.lisp's add-method in place, it will try to add - ;; the function-to-method-temp entry to *early-methods*. but then we unbind - ;; that, so things are a bit screwy. We do it more manually. - (let* ((f (ensure-generic-function 'function-to-method-temp)) ; FIXME: just make an anonymous one? - (mf (make-%method-function-fast function)) - (method - (make-method (find-class 'standard-method) - nil - (mapcar #'find-class specializers) - lambda-list - mf - (list - 'leaf-method-p t)))) - ;; we're still using the old add-method, which adds things to *early-methods*. - ;; We don't want to do that here, so we rebind *early-methods* and discard the value. - (let ((*early-methods* nil)) - (add-method f method)) - ;; Put in a call history to speed things up a little. - (loop with outcome = (make-effective-method-outcome - :methods (list method) - :form `(call-method ,method) - ;; Is a valid EMF. - :function function) - for specializers in satiation-specializers - collect (cons (map 'vector #'find-class specializers) outcome) - into new-call-history - finally (append-generic-function-call-history f new-call-history)) - ;; Finish setup - (core:setf-lambda-list f lambda-list) ; hook up the introspection - ;; (setf generic-function-name) itself goes through here, so to minimize - ;; bootstrap headaches we use the underlying writer directly. - (core:setf-function-name f name) - (setf (fdefinition name) f) - (when (boundp '*early-methods*) - (push (cons name (list method)) *early-methods*))) - (fmakunbound 'function-to-method-temp)) - -(function-to-method 'compute-applicable-methods - '(generic-function arguments) - '(standard-generic-function t) - '((standard-generic-function cons) (standard-generic-function null)) - #'std-compute-applicable-methods) - -(function-to-method 'compute-applicable-methods-using-classes - '(generic-function classes) - '(standard-generic-function t) - '((standard-generic-function cons) (standard-generic-function null)) - #'std-compute-applicable-methods-using-classes) - -(function-to-method 'compute-effective-method - '(generic-function method-combination applicable-methods) - '(standard-generic-function method-combination t) - '((standard-generic-function method-combination cons) - (standard-generic-function method-combination null)) - #'std-compute-effective-method) - -(function-to-method 'generic-function-method-class '(gf) - '(standard-generic-function) - '((standard-generic-function))) - -(function-to-method 'find-method-combination - '(gf method-combination-type-name method-combination-options) - '(standard-generic-function t t) - '((standard-generic-function symbol null))) - -(function-to-method 'generic-function-name - '(generic-function) - '(standard-generic-function)) - -(function-to-method '(setf generic-function-name) - '(new-name generic-function) - '(t standard-generic-function)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Satiate - -;;; Every gf needs a specializer profile, not just satiated ones -;;; They pretty much all need one, and before any gf calls, so we do this -;;; before calling add-direct-method below - -(dolist (method-info *early-methods*) - (compute-gf-specializer-profile (fdefinition (car method-info)))) - -;;; Trickiness here. -;;; During build we first load this file as source. In that case we add only -;;; enough call history entries to boot the system. -;;; Then we compile this file. And in that compiler, we have full CLOS, so we -;;; can use the complicated satiation code to some extent. Importantly, we -;;; work out actual EMFs ahead of time so that they're in the FASL and don't -;;; have to compile those at runtime. -;;; The complicated stuff is in the :load-toplevel. -;;; TODO: Figure out precompiled discriminating functions too. -;;; Main problem there is making sure the stamps are the same at compile and load. -(eval-when (:execute) - (satiate-minimal-generic-functions)) -(eval-when (:load-toplevel) - (satiate-clos)) - -;;; Generic functions can be called now! - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Make methods real - -;;; First generic function calls done here. - -(defun register-method-with-specializers (method) - (loop for spec in (method-specializers method) - do (add-direct-method spec method))) - -(defun fixup-early-methods () - (dolist (method-info *early-methods*) - (dolist (method (cdr method-info)) - (register-method-with-specializers method)))) - -(fixup-early-methods) - -(makunbound '*early-methods*) - -;;; *early-methods* is used by the primitive add-method in method.lisp. -;;; Avoid defining any new methods until the new add-method is installed. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Redefine ENSURE-GENERIC-FUNCTION - -;;; Uses generic functions properly now. -;;; DEFMETHOD and INSTALL-METHOD and stuff call ensure-generic-function, -;;; so after this they will do generic function calls. - -(defun ensure-generic-function (name &rest args &key &allow-other-keys) - (let ((gfun (si::traced-old-definition name))) - (cond ((not (legal-generic-function-name-p name)) - (core:simple-program-error "~A is not a valid generic function name" name)) - ((not (fboundp name)) - (setf (fdefinition name) - (apply #'ensure-generic-function-using-class gfun name args))) - ((si::instancep (or gfun (setf gfun (fdefinition name)))) - (let ((new-gf (apply #'ensure-generic-function-using-class gfun name args))) - new-gf)) - ((special-operator-p name) - (core:simple-program-error "The special operator ~A is not a valid name for a generic function" name)) - ((macro-function name) - (core:simple-program-error - "The symbol ~A is bound to a macro and is not a valid name for a generic function" name)) - ((not *clos-booted*) - (setf (fdefinition name) - (apply #'ensure-generic-function-using-class nil name args)) - (fdefinition name)) - (t - (core:simple-program-error "The symbol ~A is bound to an ordinary function and is not a valid name for a generic function" name))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Redefine things to their final form. - -(defun method-p (method) (typep method 'METHOD)) - -(defun make-method (method-class qualifiers specializers arglist function options) - (apply #'make-instance - method-class - :generic-function nil - :qualifiers qualifiers - :lambda-list arglist - :specializers specializers - :function function - :allow-other-keys t - options)) - -(defun all-keywords (l) - (let ((all-keys '())) - (do ((l (rest l) (cddddr l))) - ((null l) - all-keys) - (push (first l) all-keys)))) - -(defun congruent-lambda-p (l1 l2) - (multiple-value-bind (r1 opts1 rest1 key-flag1 keywords1 a-o-k1) - (core:process-lambda-list l1 'FUNCTION) - (multiple-value-bind (r2 opts2 rest2 key-flag2 keywords2 a-o-k2) - (core:process-lambda-list l2 'FUNCTION) - (and (= (length r2) (length r1)) - (= (length opts1) (length opts2)) - (eq (and (null rest1) (null key-flag1)) - (and (null rest2) (null key-flag2))) - ;; All keywords mentioned in the genericf function - ;; must be accepted by the method. - (or (null key-flag1) - (null key-flag2) - ;; Testing for a-o-k1 here may not be conformant when - ;; the fourth point of 7.6.4 is read literally, but it - ;; is more consistent with the generic function calling - ;; specification. Also it is compatible with popular - ;; implementations like SBCL and CCL. -- jd 2020-04-07 - a-o-k1 - a-o-k2 - (null (set-difference (all-keywords keywords1) - (all-keywords keywords2)))) - t)))) - -;;; auxiliary for add-method -;;; It takes a DEFMETHOD lambda list and returns a lambda list usable for -;;; initializing a generic function. The difficulty here is that the CLHS -;;; page for DEFMETHOD specifies that if a generic function is implicitly -;;; created, its lambda list lacks any specific keyword parameters. -;;; So (defmethod foo (... &key a)) (defmethod foo (... &key)) is legal. -;;; If we were to just use the same method lambda list, this would not be -;;; true. -(defun method-lambda-list-for-gf (lambda-list) - (multiple-value-bind (req opt rest keyflag keywords aok) - (core:process-lambda-list lambda-list 'function) - (declare (ignore keywords)) - `(,@(rest req) - ,@(unless (zerop (car opt)) - (cons '&optional (loop for (o) on (rest opt) - by #'cdddr - collect o))) - ,@(when rest (list '&rest rest)) - ,@(when keyflag '(&key)) - ,@(when aok '(&allow-other-keys))))) - -;;; It's possible we could use DEFMETHOD for these. - -(defun add-method (gf method) - ;; during boot it's a structure accessor - (declare (notinline method-qualifiers remove-method)) - (declare (notinline reinitialize-instance)) ; bootstrap stuff - ;; - ;; 1) The method must not be already installed in another generic function. - ;; - (let ((other-gf (method-generic-function method))) - (unless (or (null other-gf) (eq other-gf gf)) - (error "The method ~A belongs to the generic function ~A ~ -and cannot be added to ~A." method other-gf gf))) - ;; - ;; 2) The method and the generic function should have congruent lambda - ;; lists. That is, it should accept the same number of required and - ;; optional arguments, and only accept keyword arguments when the generic - ;; function does. - ;; - (let ((new-lambda-list (method-lambda-list method))) - (if (slot-boundp gf 'lambda-list) - (let ((old-lambda-list (generic-function-lambda-list gf))) - (unless (congruent-lambda-p old-lambda-list new-lambda-list) - (error "Cannot add the method ~A to the generic function ~A because their lambda lists ~A and ~A are not congruent." - method gf new-lambda-list old-lambda-list)) - ;; Add any keywords from the method to the gf display lambda list. - (maybe-augment-generic-function-lambda-list gf new-lambda-list)) - (reinitialize-instance - gf :lambda-list (method-lambda-list-for-gf new-lambda-list)))) - ;; - ;; 3) Finally, it is inserted in the list of methods, and the method is - ;; marked as belonging to a generic function. - ;; - (when (generic-function-methods gf) - (let* ((method-qualifiers (method-qualifiers method)) - (specializers (method-specializers method)) - (found (find-method gf method-qualifiers specializers nil))) - (when found - (remove-method gf found)))) - ;; - ;; Per AMOP's description of ADD-METHOD, we install the method by: - ;; i) Adding it to the list of methods. - (push method (%generic-function-methods gf)) - (setf (%method-generic-function method) gf) - ;; ii) Adding the method to each specializer's direct-methods. - (register-method-with-specializers method) - ;; iii) Computing a new discriminating function. - ;; Though in this case it will be the invalidated function. - (update-gf-specializer-profile gf (method-specializers method)) - (compute-a-p-o-function gf) - (update-generic-function-call-history-for-add-method gf method) - (set-funcallable-instance-function gf (compute-discriminating-function gf)) - ;; iv) Updating dependents. - (update-dependents gf (list 'add-method method)) - gf) - -(defun remove-method (gf method) - (setf (%generic-function-methods gf) - (delete method (generic-function-methods gf)) - (%method-generic-function method) nil) - (loop for spec in (method-specializers method) - do (remove-direct-method spec method)) - (compute-gf-specializer-profile gf) - (compute-a-p-o-function gf) - (update-generic-function-call-history-for-remove-method gf method) - (set-funcallable-instance-function gf (compute-discriminating-function gf)) - (update-dependents gf (list 'remove-method method)) - gf) - -;;(setq cmp:*debug-compiler* t) -(function-to-method 'add-method '(gf method) '(standard-generic-function standard-method) - '((standard-generic-function standard-method) - (standard-generic-function standard-reader-method) - (standard-generic-function standard-writer-method))) -(function-to-method 'remove-method '(gf method) '(standard-generic-function standard-method) - '((standard-generic-function standard-method) - (standard-generic-function standard-reader-method) - (standard-generic-function standard-writer-method))) -(function-to-method 'find-method '(gf qualifiers specializers &optional error) - '(standard-generic-function t t) - '((standard-generic-function null cons) - (standard-generic-function cons cons))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Error messages - -(defgeneric no-applicable-method (gf &rest args) - #+(or)(declare (optimize (debug 3)))) - -(defmethod no-applicable-method (gf &rest args) - #+(or)(declare (optimize (debug 3))) - (error 'no-applicable-method-error :generic-function gf :arguments args)) - -;;; FIXME: use actual condition classes - -;;; FIXME: See method.lisp: This is not actually used normally. -(defmethod no-next-method (gf method &rest args) - (declare (ignore gf)) - (error "In method ~A~%No next method given arguments ~A" method args)) - -(defun no-required-method (gf group-name &rest args) - (error "No applicable methods in required group ~a for generic function ~a~@ - Given arguments: ~a" - group-name (generic-function-name gf) args)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; MISCELLANY - -(defmethod reader-method-class ((class std-class) - (direct-slot direct-slot-definition) - &rest initargs) - (declare (ignore class direct-slot initargs)) - (find-class 'standard-reader-method)) - -(defmethod writer-method-class ((class std-class) - (direct-slot direct-slot-definition) - &rest initargs) - (declare (ignore class direct-slot initargs)) - (find-class 'standard-writer-method)) - -(eval-when (:load-toplevel) - (%satiate reader-method-class (standard-class standard-direct-slot-definition) - (funcallable-standard-class standard-direct-slot-definition)) - (%satiate writer-method-class (standard-class standard-direct-slot-definition) - (funcallable-standard-class standard-direct-slot-definition))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Finish initializing classes that we defined in C++ that -;;; are not in :COMMON-LISP or :SYS package -;;; so that we can use them as specializers for generic functions - -(defun gather-cxx-classes () - (let ((additional-classes (reverse core:*all-cxx-classes*)) - classes) - (dolist (class-symbol additional-classes) - (unless (or (eq class-symbol 'core::model) - (eq class-symbol 'core::instance) - (assoc class-symbol +class-hierarchy+)) - (push class-symbol classes))) - (nreverse classes))) - -(defun add-cxx-class (class-symbol) - (let* ((class (find-class class-symbol)) - (supers-names (mapcar #'(lambda (x) (class-name x)) - (clos:direct-superclasses class)))) - (ensure-boot-class class-symbol :metaclass 'core:cxx-class ;; was 'builtin-class - :direct-superclasses supers-names) - (finalize-inheritance class))) - -(defun add-extra-classes (additional-classes) - (dolist (class-symbol additional-classes) - (add-cxx-class class-symbol))) - -;; -;; Initialize all extra classes -;; -(add-extra-classes (gather-cxx-classes)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; We define the MAKE-LOAD-FORM for source-pos-info early, so that it can be -;;; used in the expansion of the defclass below. -;;; Most MAKE-LOAD-FORMs are in print.lisp. - -(defmethod make-load-form ((object core:file-scope) &optional env) - (declare (ignore env)) - (values - `(core:make-cxx-object ,(find-class 'core:file-scope)) - `(core:decode - ,object - ',(core:encode object)))) - -(defmethod make-load-form ((object core:source-pos-info) &optional environment) - (declare (ignore environment)) - (values - `(core:make-cxx-object ,(find-class 'core:source-pos-info) - :sfi ,(core:file-scope - (core:source-pos-info-file-handle object)) - :fp ,(core:source-pos-info-filepos object) - :l ,(core:source-pos-info-lineno object) - :c ,(core:source-pos-info-column object)) - `(core:setf-source-pos-info-extra - ',object - ',(core:source-pos-info-inlined-at object) - ',(core:source-pos-info-function-scope object)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; DEPENDENT MAINTENANCE PROTOCOL -;;; - -(defmethod add-dependent ((c class) dep) - (pushnew dep (class-dependents c))) - -(defmethod add-dependent ((c generic-function) dependent) - (pushnew dependent (generic-function-dependents c))) - -(defmethod remove-dependent ((c class) dep) - (setf (class-dependents c) - (remove dep (class-dependents c)))) - -(defmethod remove-dependent ((c standard-generic-function) dep) - (setf (generic-function-dependents c) - (remove dep (generic-function-dependents c)))) - -(defmethod map-dependents ((c class) function) - (dolist (d (class-dependents c)) - (funcall function d))) - -(defmethod map-dependents ((c standard-generic-function) function) - (dolist (d (generic-function-dependents c)) - (funcall function d))) - -;; FIXME: dependence on core:closure is not super -(%satiate map-dependents (standard-generic-function core:closure) - (standard-class core:closure)) - -(defgeneric update-dependent (object dependent &rest initargs)) - -;; After this, update-dependents will work -(setf *clos-booted* 'map-dependents) - -(defclass initargs-updater () - ()) - -(defun recursively-update-class-initargs-cache (a-class) - ;; Bug #588: If a class is forward referenced and you define an initialize-instance - ;; (or whatever) method on it, it got here and tried to compute valid initargs, which - ;; involved taking the class-prototype, which couldn't be allocated of course. - ;; There's no value in precomputing the initargs for an unfinished class, so we don't. - (when (class-finalized-p a-class) - (precompute-valid-initarg-keywords a-class) - (mapc #'recursively-update-class-initargs-cache (class-direct-subclasses a-class)))) - -(defmethod update-dependent ((object generic-function) (dep initargs-updater) - &rest initargs - &key ((add-method added-method) nil am-p) - ((remove-method removed-method) nil rm-p) - &allow-other-keys) - (declare (ignore initargs)) - (let ((method (cond (am-p added-method) (rm-p removed-method)))) - ;; update-dependent is also called when the gf itself is reinitialized, so make sure we actually have - ;; a method that's added or removed - (when method - (let ((spec (first (method-specializers method)))) ; the class being initialized or allocated - (when (classp spec) ; sanity check against eql specialization - (recursively-update-class-initargs-cache spec)))))) - -;; NOTE that we can't use MAKE-INSTANCE since the -;; compiler macro in static-gfs will put in code -;; that the loader can't handle yet. -;; We could use NOTINLINE now that bclasp handles it, -;; but we don't need to go through make-instance's song and dance anyway. -(let ((x (with-early-make-instance () (x (find-class 'initargs-updater)) x))) - (add-dependent #'shared-initialize x) - (add-dependent #'initialize-instance x) - (add-dependent #'allocate-instance x)) - -;; can't satiate this one, because the environment class will vary. -(function-to-method 'make-method-lambda - '(gf method lambda-form environment) - '(standard-generic-function standard-method t t)) - -;; ditto -(function-to-method 'expand-apply-method - '(method method-arguments arguments env) - '(standard-method t t t) - nil - #'std-expand-apply-method) - -(function-to-method 'compute-discriminating-function '(gf) - '(standard-generic-function) - '((standard-generic-function))) - -(function-to-method 'print-object - '(object stream) - '(t t)) - diff --git a/src/lisp/kernel/clos/generic.lisp b/src/lisp/kernel/clos/generic.lisp index 33b4b2f9da..33f95a92c1 100644 --- a/src/lisp/kernel/clos/generic.lisp +++ b/src/lisp/kernel/clos/generic.lisp @@ -1,7 +1,3 @@ -#+(or)(eval-when (:execute) - (format t "!~%!~%!~%!~%!~%In generic.lisp !~% Turning on :compare *feature* for ensure-generic-function~%!~%!~%!~%!~%") - (setq cl:*features* (cons :compare cl:*features*)) - (setq cl:*features* (cons :force-lots-of-gcs cl:*features*))) ;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- ;;;; ;;;; Copyright (c) 1992, Giuseppe Attardi. @@ -15,40 +11,39 @@ (in-package "CLOS") +(defgeneric ensure-generic-function-using-class + (generic-function-or-nil function-name &key &allow-other-keys)) +;; GENERIC-FUNCTION-NAME is defined earlier in misc.lisp, in case something +;; goes wrong and we want to print generic functions. +(defgeneric (setf generic-function-name) (name generic-function)) + +(defgeneric add-method (generic-function method)) +(defgeneric remove-method (generic-function method)) +(defgeneric find-method (generic-function qualifiers specializers &optional errorp)) + ;;; ---------------------------------------------------------------------- ;;; DEFGENERIC ;;; -(defmacro defgeneric (&rest args) - (multiple-value-bind (function-specifier lambda-list options) - (parse-defgeneric args) - (parse-lambda-list lambda-list) - ;; process options - (multiple-value-bind (option-list method-list) - (parse-generic-options options lambda-list) - (let* ((output `(progn - (eval-when (:compile-toplevel) - (cmp:register-global-function-def 'defgeneric ',function-specifier)) - (ensure-generic-function ',function-specifier - :delete-methods t ,@option-list)))) - (if method-list - `(progn - ,output - (associate-methods-to-gfun - ',function-specifier - ,@(loop for m in method-list collect `(defmethod ,function-specifier ,@m)))) - output))))) - -(defun parse-defgeneric (args) - ;; (values function-specifier lambda-list options) - (let (function-specifier) - (unless args - (core:simple-program-error "Illegal defgeneric form: missing generic function name")) - (setq function-specifier (pop args)) - (unless args - (core:simple-program-error "Illegal defgeneric form: missing lambda-list")) - (values function-specifier (first args) (rest args)))) +(defmacro defgeneric (function-specifier lambda-list &rest options) + (parse-lambda-list lambda-list) + ;; process options + (multiple-value-bind (option-list method-list) + (parse-generic-options options lambda-list) + (let* ((output `(progn + (eval-when (:compile-toplevel) + (cmp:register-global-function-def 'defgeneric ',function-specifier)) + (ensure-generic-function ',function-specifier + :delete-methods t ,@option-list)))) + (if method-list + `(progn + ,output + (associate-methods-to-gfun + ',function-specifier + ,@(loop for m in method-list collect `(defmethod ,function-specifier ,@m)))) + output)))) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun parse-generic-options (options lambda-list) (let* ((processed-options '()) (method-list '()) @@ -86,11 +81,13 @@ option-name)))) (setf arg-list `(',option-name ',option-value ,@arg-list))))))) (values `(:lambda-list ',lambda-list ,@arg-list - ,@(when core:*current-source-pos-info* - (list ''source-position core:*current-source-pos-info*)) + ,@(when (ext:current-source-location) + (list ''source-position (ext:current-source-location))) ,@(when declarations `(:declarations ',declarations))) method-list))) +) +(eval-when (:compile-toplevel :load-toplevel :execute) ;;; For effect. Checks whether the lambda list is well formed. (defun parse-lambda-list (lambda-list &optional post-keyword) (ext:with-current-source-form (lambda-list) @@ -107,6 +104,7 @@ (if (listp arg) (core:simple-program-error "the parameters cannot be specialized in generic function lambda-list") (parse-lambda-list (cdr lambda-list)))))))) +) (defun valid-declaration-p (decl) (and (eq (first decl) 'OPTIMIZE) @@ -166,6 +164,37 @@ Not a valid documentation object ~A" (core:simple-program-error "Cannot replace the lambda list of ~A with ~A because it is incongruent with some of the methods" gfun lambda-list)))) +(defun congruent-lambda-p (l1 l2) + (multiple-value-bind (r1 opts1 rest1 key-flag1 keywords1 a-o-k1) + (core:process-lambda-list l1 'FUNCTION) + (multiple-value-bind (r2 opts2 rest2 key-flag2 keywords2 a-o-k2) + (core:process-lambda-list l2 'FUNCTION) + (and (= (length r2) (length r1)) + (= (length opts1) (length opts2)) + (eq (and (null rest1) (null key-flag1)) + (and (null rest2) (null key-flag2))) + ;; All keywords mentioned in the genericf function + ;; must be accepted by the method. + (or (null key-flag1) + (null key-flag2) + ;; Testing for a-o-k1 here may not be conformant when + ;; the fourth point of 7.6.4 is read literally, but it + ;; is more consistent with the generic function calling + ;; specification. Also it is compatible with popular + ;; implementations like SBCL and CCL. -- jd 2020-04-07 + a-o-k1 + a-o-k2 + (null (set-difference (all-keywords keywords1) + (all-keywords keywords2)))) + t)))) + +(defun all-keywords (l) + (let ((all-keys '())) + (do ((l (rest l) (cddddr l))) + ((null l) + all-keys) + (push (first l) all-keys)))) + (defun initialize-gf-specializer-profile (gfun) (when (slot-boundp gfun 'lambda-list) (let* ((lambda-list (generic-function-lambda-list gfun)) @@ -222,6 +251,54 @@ Not a valid documentation object ~A" (compute-a-p-o-function gfun)) (t (initialize-gf-specializer-profile gfun)))) +;;; Recompute the specializer profile entirely. +;;; Needed if a method has been removed. +(defun compute-gf-specializer-profile (gf) + (setf (generic-function-specializer-profile gf) + ;; NOTE: If the gf has no methods, this results in a + ;; specializer profile of NIL, which is not a vector. + ;; This can cause errors in code that expects the sp to be + ;; a vector, but the sp being NIL in code like that indicates + ;; some kind of bug. We could use #() here instead, but that + ;; would just mask such bugs. + (let ((sp nil)) + (dolist (method (generic-function-methods gf)) + (let ((specializers (method-specializers method))) + (when (null sp) + (setf sp (make-array (length specializers)))) + (update-specializer-profile sp specializers))) + sp))) + +(defun update-specializer-profile (specializer-profile specializers) + (loop for spec in specializers + for i from 0 + for e = (svref specializer-profile i) + do (setf (svref specializer-profile i) + (cond ((typep spec 'eql-specializer) + (let ((o (eql-specializer-object spec))) + ;; Add to existing list of eql spec + ;; objects, or make a new one. + (if (consp e) + (adjoin o e) + (list o)))) + ((eql spec #.(find-class 't)) (or e nil)) + (t (or e t))))) + specializer-profile) + +(defun compute-a-p-o-function (gf) + (let ((a-p-o (generic-function-argument-precedence-order gf)) + (gf-ll (generic-function-lambda-list gf))) + (setf (generic-function-a-p-o-function gf) + (if (consp gf-ll) + (let ((required-arguments (rest (core:process-lambda-list gf-ll t)))) + (if (equal a-p-o required-arguments) + nil + (coerce `(lambda (%list) + (destructuring-bind ,required-arguments %list + (list ,@a-p-o))) + 'function))) + nil)))) + (defmethod initialize-instance :after ((gfun standard-generic-function) &rest initargs) (declare (ignore initargs)) (invalidate-discriminating-function gfun)) @@ -243,6 +320,9 @@ Not a valid documentation object ~A" (erase-generic-function-call-history gfun) (invalidate-discriminating-function gfun))) +(defun erase-generic-function-call-history (gf) + (setf (mp:atomic (generic-function-call-history gf)) nil)) + (defun associate-methods-to-gfun (name &rest methods) (let ((gfun (fdefinition name))) (dolist (method methods) @@ -337,15 +417,20 @@ Not a valid documentation object ~A" known-keys (list* key known-keys)))))) (values req opt restvar keyflag keysl aokp nil nil))) -;;; Kind of badly placed, but- returns minimum and maximum number of args allowed as values. -;;; max is NIL if infinite. Used by fastgf. -(defun generic-function-min-max-args (gf) - ;; since we call this from fastgf, it can't use generic functions (like g-f-l-l) - ;; but FIXME: this may be a problem if g-f-l-l being generic is relevant, e.g. for a user subclass. - (with-early-accessors (+standard-generic-function-slots+) - (multiple-value-bind (req opt restvar keyflag) ; rest are irrelevant - (core:process-lambda-list (generic-function-lambda-list gf) 'function) - (values (car req) (if (or restvar keyflag) nil (+ (car req) (car opt))))))) +(defmethod add-dependent ((c standard-generic-function) dependent) + (pushnew dependent (generic-function-dependents c))) + +(defmethod remove-dependent ((c standard-generic-function) dep) + (setf (generic-function-dependents c) + (remove dep (generic-function-dependents c)))) + +(defmethod map-dependents ((c standard-generic-function) function) + (dolist (d (generic-function-dependents c)) + (funcall function d))) + +(defmethod (setf generic-function-name) (name (gf standard-generic-function)) + (reinitialize-instance gf :name name) + name) (defun compile-generic-function-methods (gf) (loop with overall-warningsp = nil @@ -358,3 +443,222 @@ Not a valid documentation object ~A" overall-failurep (or overall-failurep failurep))) finally (return (values gf overall-warningsp overall-failurep)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Adding, removing, and finding methods +;;; This code is here rather than method.lisp because the operations on the +;;; generic are more involved than those on the methods. +;;; + +(defmethod add-method ((gf standard-generic-function) (method standard-method)) + ;; + ;; 1) The method must not be already installed in another generic function. + ;; + (let ((other-gf (method-generic-function method))) + (unless (or (null other-gf) (eq other-gf gf)) + (error "The method ~A belongs to the generic function ~A ~ +and cannot be added to ~A." method other-gf gf))) + ;; + ;; 2) The method and the generic function should have congruent lambda + ;; lists. That is, it should accept the same number of required and + ;; optional arguments, and only accept keyword arguments when the generic + ;; function does. + ;; + (let ((new-lambda-list (method-lambda-list method))) + (if (slot-boundp gf 'lambda-list) + (let ((old-lambda-list (generic-function-lambda-list gf))) + (unless (congruent-lambda-p old-lambda-list new-lambda-list) + (error "Cannot add the method ~A to the generic function ~A because their lambda lists ~A and ~A are not congruent." + method gf new-lambda-list old-lambda-list)) + ;; Add any keywords from the method to the gf display lambda list. + (maybe-augment-generic-function-lambda-list gf new-lambda-list)) + (reinitialize-instance + gf :lambda-list (method-lambda-list-for-gf new-lambda-list)))) + ;; + ;; 3) Finally, it is inserted in the list of methods, and the method is + ;; marked as belonging to a generic function. + ;; + (when (generic-function-methods gf) + (let* ((method-qualifiers (method-qualifiers method)) + (specializers (method-specializers method)) + (found (find-method gf method-qualifiers specializers nil))) + (when found + (remove-method gf found)))) + ;; + ;; Per AMOP's description of ADD-METHOD, we install the method by: + ;; i) Adding it to the list of methods. + (push method (%generic-function-methods gf)) + (setf (%method-generic-function method) gf) + ;; ii) Adding the method to each specializer's direct-methods. + (register-method-with-specializers method) + ;; iii) Computing a new discriminating function. + ;; Though in this case it will be the invalidated function. + (update-gf-specializer-profile gf (method-specializers method)) + (compute-a-p-o-function gf) + (update-generic-function-call-history-for-add-method gf method) + (set-funcallable-instance-function gf (compute-discriminating-function gf)) + ;; iv) Updating dependents. + (update-dependents gf (list 'add-method method)) + gf) + +;;; auxiliary for add-method +;;; It takes a DEFMETHOD lambda list and returns a lambda list usable for +;;; initializing a generic function. The difficulty here is that the CLHS +;;; page for DEFMETHOD specifies that if a generic function is implicitly +;;; created, its lambda list lacks any specific keyword parameters. +;;; So (defmethod foo (... &key a)) (defmethod foo (... &key)) is legal. +;;; If we were to just use the same method lambda list, this would not be +;;; true. +(defun method-lambda-list-for-gf (lambda-list) + (multiple-value-bind (req opt rest keyflag keywords aok) + (core:process-lambda-list lambda-list 'function) + (declare (ignore keywords)) + `(,@(rest req) + ,@(unless (zerop (car opt)) + (cons '&optional (loop for (o) on (rest opt) + by #'cdddr + collect o))) + ,@(when rest (list '&rest rest)) + ,@(when keyflag '(&key)) + ,@(when aok '(&allow-other-keys))))) + +(defun register-method-with-specializers (method) + (loop for spec in (method-specializers method) + do (add-direct-method spec method))) + +(defun update-gf-specializer-profile (gf specializers) + ;; Although update-specializer-profile mutates the vector, + ;; we still need this setf for the case in which the existing sp + ;; was NIL (see compute-gf-specializer-profile below for how this + ;; can arise). + (setf (generic-function-specializer-profile gf) + (let* ((sv (generic-function-specializer-profile gf)) + (to-update (or sv (make-array (length specializers) + :initial-element nil)))) + (update-specializer-profile to-update specializers)))) + +;;; This "fuzzed" applicable-method-p is used in +;;; update-call-history-for-add-method, below, to handle added EQL-specialized +;;; methods properly. See bug #1009. +(defun fuzzed-applicable-method-p (method specializers) + (loop for spec in (method-specializers method) + for argspec in specializers + always (cond ((typep spec 'eql-specializer) + (if (eql-specializer-p argspec) + (eql (eql-specializer-object argspec) + (eql-specializer-object spec)) + (si:subclassp argspec + (class-of (eql-specializer-object spec))))) + ((eql-specializer-p argspec) + (si:subclassp (class-of (eql-specializer-object argspec)) + spec)) + (t (si:subclassp argspec spec))))) + +(defun update-call-history-for-add-method (call-history method) + "When a method is added then we update the effective-method-functions for + those call-history entries with specializers that the method would apply to." + (loop for entry in call-history + for specializers = (coerce (car entry) 'list) + unless (fuzzed-applicable-method-p method specializers) + collect entry)) + +(defun update-generic-function-call-history-for-add-method (generic-function method) + "When a method is added then we update the effective-method-functions for + those call-history entries with specializers that the method would apply to. +FIXME!!!! This code will have problems with multithreading if a generic function is in flight. " + (mp:atomic-update (generic-function-call-history generic-function) + #'update-call-history-for-add-method method)) + +(defmethod remove-method ((gf standard-generic-function) (method standard-method)) + (setf (%generic-function-methods gf) + (delete method (generic-function-methods gf)) + (%method-generic-function method) nil) + (loop for spec in (method-specializers method) + do (remove-direct-method spec method)) + (compute-gf-specializer-profile gf) + (compute-a-p-o-function gf) + (update-generic-function-call-history-for-remove-method gf method) + (set-funcallable-instance-function gf (compute-discriminating-function gf)) + (update-dependents gf (list 'remove-method method)) + gf) + +(defun update-call-history-for-remove-method (call-history method) + (let (new-call-history) + (loop for entry in call-history + for specializers = (coerce (car entry) 'list) + unless (method-applicable-to-specializers-p method specializers) + do (push (cons (car entry) (cdr entry)) new-call-history)) + new-call-history)) + +(defun update-generic-function-call-history-for-remove-method (generic-function method) + "When a method is removed then we update the effective-method-functions for + those call-history entries with specializers that the method would apply to + AND if that means there are no methods left that apply to the specializers + then remove the entry from the list. +FIXME!!!! This code will have problems with multithreading if a generic function is in flight. " + (mp:atomic-update (generic-function-call-history generic-function) + #'update-call-history-for-remove-method method)) + +(defmethod find-method ((gf standard-generic-function) qualifiers specializers + &optional (errorp t)) + (flet ((filter-specializer (name) + (cond ((typep name 'specializer) + name) + ((atom name) + (let ((class (find-class name nil))) + (unless class + (error "~A is not a valid specializer name" name)) + class)) + ((and (eq (first name) 'EQL) + (null (cddr name))) + (intern-eql-specializer (second name))) + (t + (error "~A is not a valid specializer name" name)))) + (specializer= (cons-or-class specializer) + (eq cons-or-class specializer))) + (when (/= (length specializers) + (length (generic-function-argument-precedence-order gf))) + (error + "The specializers list~%~A~%does not match the number of required arguments (~a) in ~A" + specializers + (length (generic-function-argument-precedence-order gf)) + (generic-function-name gf))) + (loop with specializers = (mapcar #'filter-specializer specializers) + for method in (generic-function-methods gf) + when (and (equal qualifiers (method-qualifiers method)) + (every #'specializer= specializers (method-specializers method))) + do (return-from find-method method)) + ;; If we did not find any matching method, then the list of + ;; specializers might have the wrong size and we must signal + ;; an error. + (when errorp + (error "There is no method on the generic function ~S that agrees on qualifiers ~S and specializers ~S" + (generic-function-name gf) + qualifiers specializers))) + nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ENSURE-GENERIC-FUNCTION + +(defun legal-generic-function-name-p (name) + (si::valid-function-name-p name)) + +(defun ensure-generic-function (name &rest args &key &allow-other-keys) + (let ((gfun (si::traced-old-definition name))) + (cond ((not (legal-generic-function-name-p name)) + (core:simple-program-error "~A is not a valid generic function name" name)) + ((not (fboundp name)) + (setf (fdefinition name) + (apply #'ensure-generic-function-using-class gfun name args))) + ((si::instancep (or gfun (setf gfun (fdefinition name)))) + (let ((new-gf (apply #'ensure-generic-function-using-class gfun name args))) + new-gf)) + ((special-operator-p name) + (core:simple-program-error "The special operator ~A is not a valid name for a generic function" name)) + ((macro-function name) + (core:simple-program-error + "The symbol ~A is bound to a macro and is not a valid name for a generic function" name)) + (t + (core:simple-program-error "The symbol ~A is bound to an ordinary function and is not a valid name for a generic function" name))))) diff --git a/src/lisp/kernel/clos/hierarchy.lisp b/src/lisp/kernel/clos/hierarchy.lisp index f694d4249d..c3ad148e6b 100644 --- a/src/lisp/kernel/clos/hierarchy.lisp +++ b/src/lisp/kernel/clos/hierarchy.lisp @@ -1,530 +1,371 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi.o -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. +(in-package #:clos) -;;; -;;; COMMON LISP CLASSES HIERARCHY -;;; -;;; The following set of constants describe the slots, the names of -;;; the classes and their relation, including both standard Commmon Lisp -;;; and the MetaObject Protocol. This information is only loaded when -;;; bootstrapping and compiling ECL. -;;; +(defconstant +initform-unsupplied+ '+initform-unsupplied+) -(in-package "CLOS") +(defun standard-instance-access (instance location) + (core:rack-ref (core:instance-rack instance) location)) +(defun (setf standard-instance-access) (new instance location) + (setf (core:rack-ref (core:instance-rack instance) location) new)) +(defun funcallable-standard-instance-access (instance location) + (core:rack-ref (core:instance-rack instance) location)) +(defun (setf funcallable-standard-instance-access) + (new instance location) + (setf (core:rack-ref (core:instance-rack instance) location) new)) -;;; ---------------------------------------------------------------------- -;;; Class SPECIALIZER +(with-mutual-defclass -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel) - (defparameter +specializer-slots+ - ;; The number of specializer slots is fixed in instance.h. - ;; A change in the number of slots here needs to be reflected there. - ;; The slots marked with a :location are also fixed in instance.h. - ;; They need to have those locations, even in user subclasses of this class. - ;; Also note that boot.lisp ignores these locations for effective slots, just - ;; using the position in the list here; so that must match the :location. - ;; It checks this. - ;; Any changes to the slots below need to be reflected in instance.h - '((direct-methods :initform nil :reader specializer-direct-methods - :accessor %specializer-direct-methods) - (call-history-generic-functions - :initform nil - :reader specializer-call-history-generic-functions - :location 1) - (specializer-mutex :initform (mp:make-shared-mutex 'call-history-generic-functions-mutex) - :accessor specializer-mutex :location 2) - ;;; Any changes to the slots above need to be reflected in instance.h - ))) +(defclass t () + () + (:metaclass built-in-class)) -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel) - (defparameter +eql-specializer-slots+ - `(,@+specializer-slots+ - (object :initarg :object :reader eql-specializer-object)))) +(defclass standard-object (t) ()) -;;; ---------------------------------------------------------------------- -;;; Class METHOD-COMBINATION +(defclass metaobject () ()) -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel) - (defparameter +method-combination-slots+ - `((name :initarg :name :accessor method-combination-name) - (compiler :initarg :compiler :accessor method-combination-compiler) - (options :initarg :options :accessor method-combination-options)))) +(defclass method-combination (metaobject) + ((name :initarg :name :accessor method-combination-name) + ;; The "compiler" is somewhat misleadingly named; it's the function that + ;; outputs the effective method form. + ;; The "compiler" functions take two arguments, plus the lambda-list from + ;; the define-method-combination. The first argument is the generic function + ;; (used for the :generic-function option of D-M-C), the second is the sorted + ;; list of applicable methods, and the rest are the method combination options. + (compiler :initarg :compiler :accessor method-combination-compiler) + (options :initarg :options :accessor method-combination-options))) -;;; ---------------------------------------------------------------------- -;;; Class CLASS +(defclass specializer (metaobject) + ;; The number of specializer slots is fixed in instance.h. + ;; A change in the number of slots here needs to be reflected there. + ;; The slots marked with a :location are also fixed in instance.h. + ;; They need to have those locations, even in user subclasses of this class. + ;; Also note that boot.lisp ignores these locations for effective slots, just + ;; using the position in the list here; so that must match the :location. + ;; It checks this. + ;; Any changes to the slots below need to be reflected in instance.h + ((direct-methods :initform nil :reader specializer-direct-methods + :accessor %specializer-direct-methods) + (call-history-generic-functions + :initform nil + :reader specializer-call-history-generic-functions + :location 1) + (specializer-mutex :initform (mp:make-shared-mutex + 'call-history-generic-functions-mutex) + :reader specializer-mutex :location 2) + ;; Any changes to the slots above need to be reflected in instance.h + )) -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel) - (defparameter +class-slots+ - ;; Any changes involving adding, removing, rearranging slots below need to be reflected in instance.h. - ;; See comment in +specializer-slots+ about locations. - `(,@+specializer-slots+ - (name :initarg :name :initform nil :reader class-name :location 3) - (direct-superclasses :initarg :direct-superclasses :initform nil - :reader class-direct-superclasses :location 4 - :accessor %class-direct-superclasses) - (direct-subclasses :initform nil :location 5 - :reader class-direct-subclasses - :accessor %class-direct-subclasses) - (slots :reader class-slots :accessor %class-slots :location 6) - (precedence-list :reader class-precedence-list - :accessor %class-precedence-list :location 7) - (direct-slots :initarg :direct-slots :reader class-direct-slots :location 8 - :initform nil :accessor %class-direct-slots) - (direct-default-initargs :initarg :direct-default-initargs :location 9 - :initform nil :reader class-direct-default-initargs) - (default-initargs :reader class-default-initargs - :accessor %class-default-initargs :location 10) - (finalized :initform nil :reader class-finalized-p - :accessor %class-finalized-p :location 11) - (docstring :initarg :documentation :initform nil :location 12) - (size :accessor class-size) - (prototype) - (dependents :initform nil :accessor class-dependents :location 15) - (valid-initargs :accessor class-valid-initargs) - (location-table :initform nil :accessor class-location-table :location 17) - (stamp-for-instances :accessor stamp-for-instances :location 18) - (creator :accessor creator :location 19) - (source-position :initform nil :initarg :source-position :accessor class-source-position) - ;;; Any changes to the slots above need to be reflected in instance.h and metaClass.h - ))) +(defclass class (specializer) ()) -;;; ---------------------------------------------------------------------- -;;; STANDARD-CLASS +(defclass std-class (class) + ((name :initarg :name :initform nil :reader class-name :location 3) + (direct-superclasses :initarg :direct-superclasses :initform nil + :reader class-direct-superclasses :location 4 + :accessor %class-direct-superclasses) + (direct-subclasses :initform nil :location 5 + :reader class-direct-subclasses + :accessor %class-direct-subclasses) + (slots :reader class-slots :accessor %class-slots :location 6) + (precedence-list :reader class-precedence-list + :accessor %class-precedence-list :location 7) + (direct-slots :initarg :direct-slots :reader class-direct-slots :location 8 + :initform nil :accessor %class-direct-slots) + (direct-default-initargs :initarg :direct-default-initargs :location 9 + :initform nil :reader class-direct-default-initargs) + (default-initargs :reader class-default-initargs + :accessor %class-default-initargs :location 10) + (finalized :initform nil :reader class-finalized-p + :accessor %class-finalized-p :location 11) + (docstring :initarg :documentation :initform nil :location 12) + (size :accessor class-size) + (prototype) + (dependents :initform nil :accessor class-dependents :location 15) + (valid-initargs :accessor class-valid-initargs) + (location-table :initform nil :accessor class-location-table :location 17) + (stamp-for-instances :accessor stamp-for-instances :location 18) + (creator :accessor creator :location 19) + (source-position :initform nil :initarg :source-position :accessor class-source-position))) -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel) - (defparameter +standard-class-slots+ +class-slots+)) - -;;; ---------------------------------------------------------------------- -;;; STRUCTURE-CLASS +(defclass standard-class (std-class) ()) +(defclass built-in-class (std-class) ()) ; see "cut down" below + +(defclass slot-definition (metaobject) ()) +(defclass direct-slot-definition (slot-definition) + (;; see effective-accessor.lisp + (%effective-readers :initform nil :reader %effective-readers) + (%effective-writers :initform nil :reader %effective-writers))) +(defclass effective-slot-definition (slot-definition) ()) +(defclass standard-slot-definition (slot-definition) + ((name :initarg :name :initform nil :reader slot-definition-name) + (initform :initarg :initform :initform +initform-unsupplied+ + :reader slot-definition-initform) + (initfunction :initarg :initfunction :initform nil + :reader slot-definition-initfunction) + (declared-type :initarg :type :initform t :reader slot-definition-type) + (allocation :initarg :allocation :initform :instance :reader slot-definition-allocation) + (initargs :initarg :initargs :initform nil :reader slot-definition-initargs) + (readers :initarg :readers :initform nil :reader slot-definition-readers) + (writers :initarg :writers :initform nil :reader slot-definition-writers) + (docstring :initarg :documentation :initform nil :accessor slot-definition-documentation) + ;; in here because clasp sometimes allows it to be specified in + ;; direct slots, as an extension. + (location :initarg :location :initform nil :reader slot-definition-location + :accessor %slot-definition-location))) +(defclass standard-effective-slot-definition (standard-slot-definition + effective-slot-definition) + ()) +(defclass standard-direct-slot-definition (standard-slot-definition + direct-slot-definition) + ()) -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel) - (defparameter +structure-class-slots+ - ;; Note that we don't need some of the class-slots, e.g. initargs, so we could - ;; hypothetically reorganize things. - ;; We also don't really need any of these slots, but it might be good to have - ;; some kind of structure to represent descriptions of structures later. - `(,@+class-slots+ - (slot-descriptions) - (initial-offset) - (constructors)))) +(defclass funcallable-standard-class (std-class) ()) -;;; ---------------------------------------------------------------------- -;;; STANDARD-GENERIC-FUNCTION +(defclass function () () (:metaclass built-in-class)) -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel) - (defparameter +standard-generic-function-slots+ - '(;; A description of how the methods on this generic function are - ;; specialized. It's a simple-vector with as many elements as the gf - ;; has required arguments. If a parameter is unspecialized (i.e. - ;; all methods' specializers there are T), that element is NIL. - ;; If one or more methods have an eql specializer at that position, - ;; the element is a list of their eql specializer objects. - ;; Otherwise (i.e. the parameter is specialized with non eql - ;; specializers) the element is T. - (specializer-profile :initform nil - :accessor generic-function-specializer-profile) - ;; An alist of (specializer-key . outcome) representing previously - ;; seen calls to this function. A specializer-key is a vector of - ;; the direct specializers of the required arguments in the call, - ;; and an outcome is as in outcome.lisp. - (call-history :initform nil :accessor generic-function-call-history) - (method-combination - :initarg :method-combination - :initform (find-method-combination (class-prototype (find-class 'standard-generic-function)) - 'standard nil) - :reader generic-function-method-combination - :accessor %generic-function-method-combination) - ;; NOTE about generic function lambda lists. - ;; AMOP says rather specifically that the original lambda list - ;; passed to ensure-generic-function can be read, and that the - ;; implementation can't alter it. That's this. - ;; But we use the underlying function lambda list as well, for - ;; display. That's what maybe-augment in method.lisp deals with, - ;; and what ext:function-lambda-list returns. - (lambda-list :initarg :lambda-list - :reader generic-function-lambda-list) - (argument-precedence-order - :initarg :argument-precedence-order - :initform nil - :reader generic-function-argument-precedence-order - :accessor %generic-function-argument-precedence-order) - (method-class - :initarg :method-class - :initform (find-class 'standard-method)) - (methods :initform nil :reader generic-function-methods - :accessor %generic-function-methods) - (a-p-o-function :initform nil :accessor generic-function-a-p-o-function) - (declarations - :initarg :declarations - :initform nil - :reader generic-function-declarations) - (dependents :initform nil :accessor generic-function-dependents) - ;; An indicator that the GF is being traced somehow. - ;; If not being traced, this is NIL (the default). - ;; Otherwise, it's a cons. The car of the cons is either - ;; :PROFILE-ONGOING, meaning dispatch misses are printed to - ;; *TRACE-OUTPUT*, or - ;; :PROFILE-RECORD, meaning they aren't. In either case, the - ;; cadr is then the overhead recorded in seconds, and the - ;; cddr is a list of argument lists that have caused misses. - ;; More to come. See telemetry.lisp for interface. - (tracy :initform nil :accessor %generic-function-tracy - :type list)))) +(defclass funcallable-standard-object (function standard-object) + () + (:metaclass funcallable-standard-class)) -;;; ---------------------------------------------------------------------- -;;; STANDARD-METHOD +(defclass generic-function (metaobject funcallable-standard-object) + () + (:metaclass funcallable-standard-class)) -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel) - ;;; Class to be a superclass of both standard-method and effective accessors. - (defparameter +std-method-slots+ - '((the-function :initarg :function :reader method-function))) - - (defparameter +standard-method-slots+ - `(,@+std-method-slots+ - (the-generic-function :initarg :generic-function :initform nil - :reader method-generic-function - ;; Writer rather than accessor for the somewhat KLUDGEy - ;; reason that satiate-readers (in satiate.lisp) would try to - ;; satiate it for effective-*-method otherwise, and they don't - ;; have a method on it. - :writer (setf %method-generic-function)) - (lambda-list :initarg :lambda-list - :reader method-lambda-list) - (specializers :initarg :specializers :reader method-specializers) - (qualifiers :initform nil :initarg :qualifiers :reader method-qualifiers) - (docstring :initarg :documentation :initform nil) - ;; Usually we just use the function's source position, but - ;; sometimes this is inadequate, e.g. for accessors, which share - ;; a method-function. - ;; So for those we use this - but not normal DEFMETHOD. - (source-position :initform nil :initarg :source-position - :accessor method-source-position) - (plist :initform nil :initarg :plist :accessor method-plist) - ;; these are the precomputed results of cl:function-keywords. - (keywords :initform nil :initarg :keywords :accessor method-keywords) - (aok-p :initform nil :initarg :aok-p :accessor method-allows-other-keys-p) - ;; leaf-method-p is T if the method form doesn't call call-next-method or next-method-p - ;; our custom initargs are internal symbols, as per MOP "The defmethod macros" - (leaf-method-p :initform nil :initarg leaf-method-p :reader leaf-method-p))) +(defclass standard-generic-function (generic-function) + (;; A description of how the methods on this generic function are + ;; specialized. It's a simple-vector with as many elements as the gf + ;; has required arguments. If a parameter is unspecialized (i.e. + ;; all methods' specializers there are T), that element is NIL. + ;; If one or more methods have an eql specializer at that position, + ;; the element is a list of their eql specializer objects. + ;; Otherwise (i.e. the parameter is specialized with non eql + ;; specializers) the element is T. + (specializer-profile :initform nil :initarg specializer-profile + :accessor generic-function-specializer-profile) + ;; An alist of (specializer-key . outcome) representing previously + ;; seen calls to this function. A specializer-key is a vector of + ;; the direct specializers of the required arguments in the call, + ;; and an outcome is as in outcome.lisp. + ;; Convenient accessors defined in miss.lisp. + (call-history :initform nil) + (method-combination + :initarg :method-combination + :initform (find-method-combination (class-prototype (find-class 'standard-generic-function)) + 'standard nil) + :reader generic-function-method-combination + :accessor %generic-function-method-combination) + ;; NOTE about generic function lambda lists. + ;; AMOP says rather specifically that the original lambda list + ;; passed to ensure-generic-function can be read, and that the + ;; implementation can't alter it. That's this. + ;; But we use the underlying function lambda list as well, for + ;; display. That's what maybe-augment in method.lisp deals with, + ;; and what ext:function-lambda-list returns. + (lambda-list :initarg :lambda-list + :reader generic-function-lambda-list) + (argument-precedence-order + :initarg :argument-precedence-order + :initform nil + :reader generic-function-argument-precedence-order + :accessor %generic-function-argument-precedence-order) + (method-class + :initarg :method-class + :initform (find-class 'standard-method) + :reader generic-function-method-class) + (methods :initform nil :reader generic-function-methods + :accessor %generic-function-methods) + (a-p-o-function :initform nil :accessor generic-function-a-p-o-function) + (declarations + :initarg :declarations + :initform nil + :reader generic-function-declarations) + (dependents :initform nil :accessor generic-function-dependents) + ;; An indicator that the GF is being traced somehow. + ;; If not being traced, this is NIL (the default). + ;; Otherwise, it's a cons. The car of the cons is either + ;; :PROFILE-ONGOING, meaning dispatch misses are printed to + ;; *TRACE-OUTPUT*, or + ;; :PROFILE-RECORD, meaning they aren't. In either case, the + ;; cadr is then the overhead recorded in seconds, and the + ;; cddr is a list of argument lists that have caused misses. + ;; More to come. See telemetry.lisp for interface. + (tracy :initform nil :accessor %generic-function-tracy + :type list) + ;; The discriminating function that INVALIDATE-GENERIC-FUNCTION installs. + ;; For most functions this is just the invalidated-discriminator-closure, + ;; so this slot is merely a cache. However it is important for correctness: + ;; The build SATIATE stores the computed discriminators here, so that if a + ;; core function is invalidated, it falls back to a minimal version rather + ;; than being completely erased. Without that, it's possible to invalidate + ;; e.g. CLASS-SLOTS, which then crashes the system, as CLASS-SLOTS is needed + ;; in order for its own discriminator to be recomputed. + ;; FIXME?: It's somewhat wasteful for _every_ GF to have this slot when it's + ;; only really needed for a few core functions. + (fallback-discriminator :initform nil :accessor %fallback-discriminator)) + (:metaclass funcallable-standard-class)) - (defparameter +standard-accessor-method-slots+ - `(,@+standard-method-slots+ - (slot-definition :initarg :slot-definition - :initform nil - :reader accessor-method-slot-definition))) +(defclass method (metaobject) ()) +(defclass std-method (method) + ((the-function :initarg :function :reader method-function))) +(defclass standard-method (std-method) + ((the-generic-function :initarg :generic-function :initform nil + :reader method-generic-function + ;; Writer rather than accessor for the somewhat KLUDGEy + ;; reason that satiate-readers (in satiate.lisp) would try to + ;; satiate it for effective-*-method otherwise, and they don't + ;; have a method on it. + :writer (setf %method-generic-function)) + (lambda-list :initarg :lambda-list + :reader method-lambda-list) + (specializers :initarg :specializers :reader method-specializers) + (qualifiers :initform nil :initarg :qualifiers :reader method-qualifiers) + (docstring :initarg :documentation :initform nil) + ;; Usually we just use the function's source position, but + ;; sometimes this is inadequate, e.g. for accessors, which share + ;; a method-function. + ;; So for those we use this - but not normal DEFMETHOD. + (source-position :initform nil :initarg :source-position + :accessor method-source-position) + (plist :initform nil :initarg :plist :accessor method-plist) + ;; these are the precomputed results of cl:function-keywords. + (keywords :initform nil :initarg :keywords :accessor method-keywords) + (aok-p :initform nil :initarg :aok-p :accessor method-allows-other-keys-p))) - ;; This is for direct-reader-method and direct-writer-method, classes used - ;; internally to represent when an access method can be done directly - ;; (with standard-location-access, basically) instead of through slot-value. - ;; These methods are never actually associated with a generic function - ;; through add-method generic-function-methods etc., though they do have - ;; the method-generic-function set. - ;; NOTE that they do not have their own slots, instead proxying through - ;; the original, except for the function. - (defparameter +effective-accessor-method-slots+ - `(,@+std-method-slots+ - (original :initarg :original ; the accessor method this is based on. - :reader effective-accessor-method-original) - (location :initarg :location - :reader effective-accessor-method-location)))) +(defclass standard-accessor-method (standard-method) + ((slot-definition :initarg :slot-definition :initform nil + :reader accessor-method-slot-definition))) -;;; ---------------------------------------------------------------------- -;;; SLOT-DEFINITION -;;; +(defclass standard-reader-method (standard-accessor-method) ()) +(defclass standard-writer-method (standard-accessor-method) ()) -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel) - (core:defconstant-equal +slot-definition-slots+ - '((name :initarg :name :initform nil :reader slot-definition-name) - (initform :initarg :initform :initform +initform-unsupplied+ - :reader slot-definition-initform) - (initfunction :initarg :initfunction :initform nil - :reader slot-definition-initfunction) - (declared-type :initarg :type :initform t :reader slot-definition-type) - (allocation :initarg :allocation :initform :instance :reader slot-definition-allocation) - (initargs :initarg :initargs :initform nil :reader slot-definition-initargs) - (readers :initarg :readers :initform nil :reader slot-definition-readers) - (writers :initarg :writers :initform nil :reader slot-definition-writers) - (docstring :initarg :documentation :initform nil :accessor slot-definition-documentation) - (location :initarg :location :initform nil :reader slot-definition-location - :accessor %slot-definition-location) - ))) +;; needed to make accessor method functions +(defclass %leaf-method-function (funcallable-standard-object) + ((%fmf :initarg :fmf :accessor fmf)) + (:metaclass funcallable-standard-class)) +) ; with-mutual-defclass -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel) - (core:defconstant-equal +direct-slot-definition-slots+ - `(,@+slot-definition-slots+ - ;; see effective-accessor.lisp - (%effective-readers :initform nil :reader %direct-slotd-effective-readers) - (%effective-writers :initform nil :reader %direct-slotd-effective-writers)))) +;;; Enough classes now exist that we can use the "real" but still +;;; early defclass macro (does not invoke generics, etc.). -;;; ---------------------------------------------------------------------- -;;; %METHOD-FUNCTION -;;; -;;; See method.lisp for use. +;;; Used in discriminating function computation. +(defclass effective-accessor-method (std-method) + ((%original :initarg :original :reader effective-accessor-method-original) + (%location :initarg :location :reader effective-accessor-method-location))) +(defclass effective-reader-method (effective-accessor-method) ()) +(defclass effective-writer-method (effective-accessor-method) ()) -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel) - (core:defconstant-equal +%method-function-slots+ - '((fast-method-function :initarg :fmf :initform nil - :accessor %mf-fast-method-function) - (contf :initarg :contf :initform nil - :accessor %mf-contf)))) +;;; These should really be cut down - I mean, since when do they have +;;; a need for finalizedp and default initargs? +(defclass forward-referenced-class (std-class) ()) +(defclass core:cxx-class (std-class) ()) +(defclass core:clbind-cxx-class (std-class) ()) +(defclass core:derivable-cxx-class (std-class) ()) +;;; maybe also needs trimming? +(defclass structure-class (std-class) + ;; Note that we don't need some of the class-slots, e.g. initargs, so we + ;; could hypothetically reorganize things. + ;; We also don't really need any of these slots, but it might be good to have + ;; some kind of structure to represent descriptions of structures later. + (slot-descriptions + initial-offset + constructors)) -;;; ---------------------------------------------------------------------- -(eval-when (:compile-toplevel :execute #+clasp :load-toplevel ) - (core:defconstant-equal +builtin-classes-list+ - '( ;;(t object) - (core:general t) - (sequence t) - (list sequence) - (cons list) - (array core:general) - (vector array sequence) - (core:abstract-simple-vector vector) - (core:complex-vector vector) - (core:mdarray array) - (core:simple-mdarray core:mdarray) - (string vector) - #+(or unicode clasp) - (base-string string vector) - (simple-base-string core:abstract-simple-vector base-string) - (core:str8ns core:complex-vector base-string) - (string vector) - (core:simple-character-string core:abstract-simple-vector string) - (core:str-wns core:complex-vector string) - (bit-vector vector) - (cl:simple-bit-vector core:abstract-simple-vector bit-vector) - (core:bit-vector-ns core:complex-vector bit-vector) - (stream core:general) - (ext:ansi-stream stream) - (file-stream ext:ansi-stream) - (echo-stream ext:ansi-stream) - (string-stream ext:ansi-stream) - (two-way-stream ext:ansi-stream) - (synonym-stream ext:ansi-stream) - (broadcast-stream ext:ansi-stream) - (concatenated-stream ext:ansi-stream) - (character t) - (number t) - (real number) - (rational real) - (integer rational) - ;;#+clasp (fixnum integer) - ;;#+clasp (bignum integer) - (ratio rational) - (float real) - (complex number) - (symbol core:general) - (null symbol list) - #-clasp(keyword symbol) ;; Clasp doesn't use a keyword class - (package core:general) - (function core:general) - (pathname core:general) - (logical-pathname pathname) -;;; (hash-table) ;;No longer inherits from (core:general) - (random-state core:general) - (readtable core:general) - #+sse2 (ext::sse-pack)))) +(defclass structure-object (t) + () + (:metaclass structure-class)) -;;; FROM AMOP: -;;; -;;; Metaobject Class Direct Superclasses -;;; standard-object (t) -;;; funcallable-standard-object (standard-object function) -;;; * metaobject (standard-object) -;;; * generic-function (metaobject funcallable-standard-object) -;;; standard-generic-function (generic-function) -;;; * method (metaobject) -;;; standard-method (method) -;;; * standard-accessor-method (standard-method) -;;; standard-reader-method (standard-accessor-method) -;;; standard-writer-method (standard-accessor-method) -;;; * method-combination (metaobject) -;;; * slot-definition (metaobject) -;;; * direct-slot-definition (slot-definition) -;;; * effective-slot-definition (slot-definition) -;;; * standard-slot-definition (slot-definition) -;;; standard-direct-slot-definition (standard-slot-definition direct-slot-definition) -;;; standard-effective-slot-definition (standard-slot-definition effective-slot-definition) -;;; * specializer (metaobject) -;;; eql-specializer (specializer) -;;; * class (specializer) -;;; built-in-class (class) -;;; forward-referenced-class (class) -;;; standard-class (class) -;;; funcallable-standard-class (class) -;;; -;;;#+(or cclasp eclasp) -#+(or)(eval-when (:compile-toplevel :execute :load-toplevel) - (setq clasp-cleavir:*use-type-inference* nil)) +(defclass core:derivable-cxx-object (standard-object) + () + (:metaclass core:derivable-cxx-class)) -;;; Some classes are in here multiple times because they are created then recreated (in boot.lisp) +;;; needed for gray streams +(defclass stream (t) + () + (:metaclass built-in-class)) -(eval-when (eval #+clasp :compile-toplevel #+clasp :load-toplevel ) - (locally (declare (optimize (debug 0))) - (core:defconstant-equal +class-hierarchy+ - `((standard-class) - (built-in-class) - (standard-effective-slot-definition) - (standard-direct-slot-definition) - (standard-class - :metaclass nil ; Special-cased in boot.lisp - :direct-slots #.+standard-class-slots+) - (built-in-class - :metaclass nil ; Special-cased in boot.lisp - :direct-slots #.+standard-class-slots+) - (standard-direct-slot-definition - :direct-slots #3=#.+direct-slot-definition-slots+) - (standard-effective-slot-definition - :direct-slots #5=#.+slot-definition-slots+) - (t) - (class :direct-slots #.+class-slots+) - (standard-object - :direct-superclasses (t)) - (core:general - :direct-superclasses (t)) - (core:cxx-object - :direct-superclasses (core:general)) - (metaobject - :direct-superclasses (standard-object)) - (slot-definition - :direct-superclasses (metaobject) - :direct-slots #5#) - (standard-slot-definition - :direct-superclasses (slot-definition) - :direct-slots #5#) - (direct-slot-definition - :direct-superclasses (slot-definition) - :direct-slots #5#) - (effective-slot-definition - :direct-superclasses (slot-definition) - :direct-slots #5#) - (standard-direct-slot-definition - :direct-superclasses (standard-slot-definition direct-slot-definition) - :direct-slots #3#) - (standard-effective-slot-definition - :direct-superclasses (standard-slot-definition effective-slot-definition) - :direct-slots #5#) - (method-combination - :direct-superclasses (metaobject) - :direct-slots #.+method-combination-slots+) - (specializer - :direct-superclasses (metaobject) - :direct-slots #.+specializer-slots+) - (eql-specializer - :direct-superclasses (specializer) - :direct-slots #.+eql-specializer-slots+) - (class - :direct-superclasses (specializer) - :direct-slots #.+class-slots+) - (forward-referenced-class - :direct-superclasses (class) - :direct-slots #.+class-slots+) - (built-in-class - :direct-superclasses (class) - :direct-slots #1=#.+standard-class-slots+) - (core:cxx-class - :direct-superclasses (class) - :direct-slots #1#) - #+(or)(clbind:class-rep - :direct-superclasses (class) - :direct-slots #1#) - (std-class - :direct-superclasses (class) - :direct-slots #1#) - (standard-class - :direct-superclasses (std-class) - :direct-slots #1# - :metaclass standard-class) - (funcallable-standard-class - :direct-superclasses (std-class) - :direct-slots #1#) - ,@(loop for (name . rest) in +builtin-classes-list+ - for index from 1 - collect (list name - :metaclass 'built-in-class - :direct-superclasses (or rest (error "You must specify a superclass for ~a" name)))) - (funcallable-standard-object - :direct-superclasses (standard-object function) - ;; MOP technically says the metaclass is standard-class, - ;; but that's probably a mistake. - :metaclass funcallable-standard-class) - (generic-function - :metaclass funcallable-standard-class - :direct-superclasses (metaobject funcallable-standard-object)) - (standard-generic-function - :direct-superclasses (generic-function) - :direct-slots #.+standard-generic-function-slots+ - :metaclass funcallable-standard-class) - (method - :direct-superclasses (metaobject)) - (std-method - :direct-superclasses (method) - :direct-slots #.+std-method-slots+) - (standard-method - :direct-superclasses (std-method) - :direct-slots #.+standard-method-slots+) - (standard-accessor-method - :direct-superclasses (standard-method) - :direct-slots #2=#.+standard-accessor-method-slots+) - (standard-reader-method - :direct-superclasses (standard-accessor-method) - :direct-slots #2#) - (standard-writer-method - :direct-superclasses (standard-accessor-method) - :direct-slots #2#) - (effective-reader-method - :direct-superclasses (std-method) - :direct-slots #4=#.+effective-accessor-method-slots+) - (effective-writer-method - :direct-superclasses (std-method) - :direct-slots #4#) - (structure-class - :direct-superclasses (class) - :direct-slots #.+structure-class-slots+) - (structure-object - :metaclass structure-class - :direct-superclasses (t)) - (core:clbind-cxx-class - :direct-superclasses (class) - :direct-slots #.+standard-class-slots+) - (core:derivable-cxx-class - :direct-superclasses (std-class) - :direct-slots #.+standard-class-slots+) - (derivable-cxx-object - :metaclass core:derivable-cxx-class - :direct-superclasses (standard-object)) - (%method-function - :metaclass funcallable-standard-class - :direct-superclasses (funcallable-standard-object) - :direct-slots #.+%method-function-slots+) - (%no-next-method-continuation - :metaclass funcallable-standard-class - :direct-superclasses (funcallable-standard-object) - :direct-slots nil) - )))) +(defclass ext:ansi-stream (stream) + () + (:metaclass built-in-class)) -(eval-when (:compile-toplevel :execute) - (dolist (name-slot (core:class-slot-sanity-check)) - (let* ((name (car name-slot)) - (core-slot-index (cdr name-slot)) - (clos-slot-index (position name +standard-class-slots+ :key #'car))) - (if clos-slot-index - (unless (= core-slot-index clos-slot-index) - (error "There is a mismatch between what clasp thinks the ~a class slot index should be (~a) and where clos says the class slot index is (~a) - update metaClass.h~%" name core-slot-index clos-slot-index)) - (cond - ((eq name 'number-of-slots-in-standard-class) - (unless (= core-slot-index (length +standard-class-slots+)) - (error "There is a mismatch between what clasp thinks should be the number of standard-class slots (~a) and what clos says it is (~a) - update metaClass.h" core-slot-index (length +standard-class-slots+)))) - ((eq name 'number-of-slots-in-structure-class) - (unless (= core-slot-index (length +structure-class-slots+)) - (error "There is a mismatch between what clasp thinks should be the number of structure-class slots (~a) and what clos says it is (~a) - update metaClass.h" core-slot-index (length +structure-class-slots+)))) - (t (error "The class-slot-sanity-check ~a could not be verified against clos - fix the sanity check at the end of hierarchy.lsp" name-slot))))))) +;;; Here we define built in classes that have no slots (i.e. most of them). +;;; These are mostly defined in the Clasp runtime but are not initialized there, +;;; so it's important that we do so here. +(macrolet ((defbuiltin (name &rest supers) + `(defclass ,name (,@supers) () (:metaclass built-in-class))) + (defbuiltins (&rest blobs) + `(progn + ,@(loop for blob in blobs collect `(defbuiltin ,@blob))))) + (defbuiltins (core:general t) + (core:vaslist t) + (sequence t) + (list sequence) + (cons list) + (array core:general) + (vector array sequence) + (core:abstract-simple-vector vector) + (core:complex-vector vector) + (core:mdarray array) + (core:simple-mdarray core:mdarray) + (string vector) + (base-string string vector) + (simple-base-string core:abstract-simple-vector base-string) + (core:str8ns core:complex-vector base-string) + (string vector) + (core:simple-character-string core:abstract-simple-vector string) + (core:str-wns core:complex-vector string) + (bit-vector vector) + (simple-bit-vector core:abstract-simple-vector bit-vector) + (core:bit-vector-ns core:complex-vector bit-vector) + (stream core:general) + (ext:ansi-stream stream) + (file-stream ext:ansi-stream) + (echo-stream ext:ansi-stream) + (string-stream ext:ansi-stream) + (two-way-stream ext:ansi-stream) + (synonym-stream ext:ansi-stream) + (broadcast-stream ext:ansi-stream) + (concatenated-stream ext:ansi-stream) + (hash-table core:general) + (character t) + (number t) + (real number) + (rational real) + (integer rational) + (fixnum integer) + (bignum integer) + (ratio rational) + (float real) + #+short-float + (short-float float) + (single-float float) + (double-float float) + #+long-float + (long-float float) + (complex number) + (symbol core:general) + (null symbol list) + (package core:general) + (function core:general) + (pathname core:general) + (logical-pathname pathname) + (random-state core:general) + (readtable core:general) + (core:cxx-object core:general) + (core:scope core:general) + (core:file-scope core:scope) + (core:source-pos-info core:general) + #+sse2 (ext::sse-pack) + (cmp:constant-info core:general) + (cmp:load-time-value-info core:general) + (cmp:function-cell-info core:general) + (cmp:variable-cell-info core:general) + (cmp:env-info core:general) + (cmp:cfunction core:general) + (core:bytecode-debug-info core:general) + (core:bytecode-debug-vars core:bytecode-debug-info) + (core:bytecode-debug-location core:bytecode-debug-info) + (core:bytecode-debug-macroexpansion core:bytecode-debug-info) + (core:bytecode-ast-decls core:bytecode-debug-info) + (core:bytecode-ast-if core:bytecode-debug-info) + (core:bytecode-ast-block core:bytecode-debug-info) + (core:bytecode-ast-the core:bytecode-debug-info) + (core:bytecode-ast-tagbody core:bytecode-debug-info))) diff --git a/src/lisp/kernel/clos/dtree.lisp b/src/lisp/kernel/clos/interpreted-discriminator.lisp similarity index 62% rename from src/lisp/kernel/clos/dtree.lisp rename to src/lisp/kernel/clos/interpreted-discriminator.lisp index 44831de83c..636c811840 100644 --- a/src/lisp/kernel/clos/dtree.lisp +++ b/src/lisp/kernel/clos/interpreted-discriminator.lisp @@ -1,5 +1,74 @@ (in-package "CLOS") +;;; ISA + +(defclass dtree-op () + ((%sym :initarg :sym :reader dtree-op-sym) + (%code :initarg :code :reader dtree-op-code) + (%arguments :initarg :arguments :reader dtree-op-arguments) + (%long-arguments :initarg :long-arguments :reader dtree-op-long-arguments) + (%label-argument-indices :initarg :label-argument-indices + :reader dtree-op-label-argument-indices))) + +(defun dtree-op-byte-length (dtree-op long) + (1+ (if long + (let ((sum-bytes 0)) + (dolist (arg (dtree-op-long-arguments dtree-op)) + (let ((bytes (second arg))) + (incf sum-bytes bytes))) + sum-bytes) + (let ((sum-bytes 0)) + (dolist (arg (dtree-op-arguments dtree-op)) + (incf sum-bytes (second arg))) + sum-bytes)))) + +(macrolet ((defops () + (let* ((ops cmpref:*dtree-ops-as-list*) ; dtree-ops.lisp + (new-dtree-ops (make-list (length ops))) + new-isa) + (dolist (op ops) + (destructuring-bind (name code macro-name &optional argument-info) + op + (declare (ignore macro-name)) + (let* ((sym (intern (string-upcase name))) + ;; KLUDGE: make-array does not work at compile time + ;; because the element type T is resolved to a cmp class + #+(or) + (label-argument-indices (make-array 4 :adjustable t :fill-pointer 0)) + rev-label-argument-indices + rev-arguments + rev-long-arguments) + (dotimes (index (length argument-info)) + (let ((arg (elt argument-info index))) + (destructuring-bind (arg-type arg-name) + arg + (declare (ignore arg-name)) + (cond + ((eq arg-type :constant-arg) + (push `(constant-arg 1) rev-arguments) + (push `(constant-arg 2) rev-long-arguments)) + ((eq arg-type :label-arg) + (push index rev-label-argument-indices) + (push `(label-arg 1) rev-arguments) + (push `(label-arg 2) rev-long-arguments)) + ((eq arg-type :register-arg) + (push `(register-arg 1) rev-arguments) + (push `(register-arg 2) rev-long-arguments)) + ((eq (car arg) :offset)) + (t (error "Illegal argument type ~s" arg)))))) + (setf (elt new-dtree-ops code) + `(early-make-instance + dtree-op + :sym ',sym :code ',code + :arguments ',(nreverse rev-arguments) + :long-arguments ',(nreverse rev-long-arguments) + :label-argument-indices ',(apply #'vector (nreverse rev-label-argument-indices)))) + (push (list sym code) new-isa)))) + `(progn + (defparameter *dtree-ops* (vector ,@new-dtree-ops)) + (defparameter *isa* ',new-isa))))) + (defops)) + ;;; Misc (defun insert-sorted (item lst &optional (test #'<) (key #'identity)) @@ -12,10 +81,23 @@ sorted))) ;;; Building an abstract "basic" tree - no tag tests or anything -;;; NOTE: We could probably store this instead of the call history -(defstruct (test (:type vector) :named) index (paths nil)) -(defstruct (skip (:type vector) :named) next) +(defmacro define-type-predicate (function-name class-name) + `(progn + (defgeneric ,function-name (object)) + (defmethod ,function-name ((object ,class-name)) t) + (defmethod ,function-name ((object t)) nil))) + +(defclass dtree-test () + ((%index :initarg :index :reader dtree-index) + (%paths :initarg :paths :initform nil :accessor test-paths))) +(defun make-test (&key index paths) + (early-make-instance dtree-test :index index :paths paths)) + +(defclass dtree-skip () + ((%next :initarg :next :reader dtree-next))) +(defun make-skip (&key next) + (early-make-instance dtree-skip :next next)) ;;; Make a new subtree with only one path, starting with the ith specializer. (defun remaining-subtree (specializers outcome sprofile speclength i) @@ -33,14 +115,14 @@ ;;; Adds a call history entry to a tree, avoiding new nodes as much as possible. (defun add-entry (node specializers outcome sprofile speclength i) (unless (= i speclength) - (cond - ((outcome-p node) + (typecase node + (outcome ;; If we're here, we don't have anything to add. (error "BUG in ADD-ENTRY: Redundant call history entry: ~a" (cons specializers outcome))) - ((skip-p node) - (add-entry (skip-next node) specializers outcome sprofile speclength (1+ i))) - ((test-p node) + (dtree-skip + (add-entry (dtree-next node) specializers outcome sprofile speclength (1+ i))) + (dtree-test (let* ((spec (svref specializers i)) (pair (assoc spec (test-paths node)))) (if pair @@ -92,12 +174,12 @@ (defun bc-add-entry (node specializers outcome specializer-indices) (when specializer-indices (let ((specializer-index (car specializer-indices))) - (cond - ((outcome-p node) + (typecase node + (outcome ;; If we're here, we don't have anything to add. (error "BUG in BC-ADD-ENTRY: Redundant call history entry: ~a" (cons specializers outcome))) - ((test-p node) + (dtree-test (let* ((spec (svref specializers specializer-index)) (pair (assoc spec (test-paths node)))) (if pair @@ -155,23 +237,63 @@ ;;; If it eqls none of the OBJECTS, jump to DEFAULT. ;;; MISS: unconditional jump to dispatch-miss routine. -(defstruct (argument (:type vector) :named) count next) -(defstruct (register (:type vector) :named) index next) -(defstruct (tag-test (:type vector) :named) tags default) -(defstruct (stamp-read (:type vector) :named) c++ other) -(defstruct (<-branch (:type vector) :named) pivot left right) -(defstruct (=-check (:type vector) :named) pivot next) -(defstruct (range-check (:type vector) :named) min max next) -(defstruct (eql-search (:type vector) :named) objects nexts default) -(defstruct (miss (:type vector) :named)) +(defclass dtree-argument () + ((%count :initarg :count :reader argument-count) + (%next :initarg :next :reader dtree-next))) +(defun make-argument (&key count next) + (early-make-instance dtree-argument :count count :next next)) + +(defclass dtree-tag-test () + ((%tags :initarg :tags :reader tag-test-tags) + (%default :initarg :default :reader tag-test-default))) +(defun make-tag-test (&key tags default) + (early-make-instance dtree-tag-test :tags tags :default default)) + +(defclass dtree-stamp-read () + ((%c++ :initarg :c++ :reader stamp-read-c++) + (%other :initarg :other :reader stamp-read-other))) +(defun make-stamp-read (&key c++ other) + (early-make-instance dtree-stamp-read :c++ c++ :other other)) + +(defclass dtree-<-branch () + ((%pivot :initarg :pivot :reader pivot) + (%left :initarg :left :reader <-branch-left) + (%right :initarg :right :reader <-branch-right))) +(defun make-<-branch (&key pivot left right) + (early-make-instance dtree-<-branch :pivot pivot :left left :right right)) + +(defclass dtree-=-check () + ((%pivot :initarg :pivot :reader pivot) + (%next :initarg :next :reader dtree-next))) +(defun make-=-check (&key pivot next) + (early-make-instance dtree-=-check :pivot pivot :next next)) + +(defclass dtree-range-check () + ((%min :initarg :min :reader range-check-min) + (%max :initarg :max :reader range-check-max) + (%next :initarg :next :reader dtree-next))) +(defun make-range-check (&key min max next) + (early-make-instance dtree-range-check :min min :max max :next next)) + +(defclass dtree-eql-search () + ((%objects :initarg :objects :reader eql-search-objects) + (%nexts :initarg :nexts :reader eql-search-nexts) + (%default :initarg :default :reader eql-search-default))) +(defun make-eql-search (&key objects nexts default) + (early-make-instance dtree-eql-search + :objects objects :nexts nexts :default default)) + +(defclass dtree-miss () ()) +(defun make-miss () (early-make-instance dtree-miss)) (defun compile-tree-top (tree) (compile-tree tree)) (defun compile-tree (tree) - (cond ((outcome-p tree) tree) - ((skip-p tree) (make-argument :next (compile-tree (skip-next tree)))) - ((test-p tree) (compile-test tree)))) + (etypecase tree + (outcome tree) + (dtree-skip (make-argument :next (compile-tree (dtree-next tree)))) + (dtree-test (compile-test tree)))) (defun compile-test (test) (multiple-value-bind (eqls tags c++-classes other-classes) @@ -180,24 +302,40 @@ (c++-search (compile-ranges (classes-to-ranges c++-classes))) (other-search (compile-ranges (classes-to-ranges other-classes))) (stamp - (if (and (miss-p c++-search) (miss-p other-search)) + (if (and (typep c++-search 'dtree-miss) + (typep other-search 'dtree-miss)) c++-search ; no need to branch - miss immediately. (make-stamp-read :c++ c++-search :other other-search))) (tag-test - (if (and (miss-p stamp) + (if (and (typep stamp 'dtree-miss) (every #'null tags)) stamp ; miss immediately (compile-tag-test tags stamp)))) (make-argument - :count (test-index test) + :count (dtree-index test) ;; we do EQL tests before anything else. they could be moved later if we altered ;; when eql tests are stored in the call history, i think. :next (cond ((null eqls) ;; we shouldn't have any empty tests - sanity check this - (assert (not (miss-p tag-test))) + ;;(assert (not (miss-p tag-test))) tag-test) (t (compile-eql-search eqls tag-test))))))) +(defvar *tag-tests* (llvm-sys:tag-tests)) + +(defun tag-spec-p (class) ; is CLASS one that's manifested as a tag test? + (member (stamp-for-instances class) *tag-tests* :key #'second)) + +;;; FIXME: wrapped +(defgeneric c++-class-p (class)) +(defmethod c++-class-p ((class built-in-class)) t) +(defmethod c++-class-p ((class standard-class)) nil) +(defmethod c++-class-p ((class funcallable-standard-class)) nil) +(defmethod c++-class-p ((class structure-class)) nil) +;; These are not "C++ classes" in the sense of having low, unchanging stamps. +(defmethod c++-class-p ((class core:derivable-cxx-class)) nil) +(defmethod c++-class-p ((class core:clbind-cxx-class)) nil) + (defun differentiate-specializers (paths) (loop with eqls = nil with tags-vector = (tags-vector) @@ -205,26 +343,25 @@ with other-classes = nil for pair in paths for spec = (car pair) - do (cond ((safe-eql-specializer-p spec) (push pair eqls)) + do (cond ((eql-specializer-p spec) (push pair eqls)) ((tag-spec-p spec) (setf (svref tags-vector (class-tag spec)) (cdr pair))) + ((c++-class-p spec) + (setf c++-classes + (insert-sorted pair c++-classes #'< #'path-pair-key))) (t - (if (core::header-stamp-case (core:class-stamp-for-instances spec) - t t t nil) - (setf other-classes - (insert-sorted pair other-classes #'< #'path-pair-key)) - (setf c++-classes - (insert-sorted pair c++-classes #'< #'path-pair-key))))) + (setf other-classes + (insert-sorted pair other-classes #'< #'path-pair-key)))) finally (return (values eqls tags-vector c++-classes other-classes)))) -(defun path-pair-key (pair) (core:class-stamp-for-instances (car pair))) +(defun path-pair-key (pair) (stamp-for-instances (car pair))) ;;; tag tests (defun tags-vector () (make-array (length *tag-tests*) :initial-element nil)) (defun class-tag (class) ; what tag corresponds to CLASS? - (third (find (core:class-stamp-for-instances class) *tag-tests* :key #'second))) + (third (find (stamp-for-instances class) *tag-tests* :key #'second))) (defun compile-tag-test (tags where-test) (map-into tags (lambda (ex) (if (null ex) (make-miss) (compile-tree ex))) tags) @@ -235,8 +372,8 @@ ;; return whether the two NEXT nodes can be conflated. ;; note: at the moment, non-outcomes are probably never equal (defun next= (next1 next2) - (if (outcome-p next1) - (and (outcome-p next2) (outcome= next1 next2)) + (if (typep next1 'outcome) + (and (typep next2 'outcome) (outcome= next1 next2)) (eq next1 next2))) ;; Given (class . next-node) pairs, return ((low . high) . next-node) pairs, @@ -246,11 +383,11 @@ (flet ((fresh (stamp next) (cons (cons stamp stamp) next))) (if (null pairs) pairs - (loop with current = (fresh (core:class-stamp-for-instances (car (first pairs))) + (loop with current = (fresh (stamp-for-instances (car (first pairs))) (cdr (first pairs))) with result = (list current) - for ((class . next) . more) on (rest pairs) - for stamp = (core:class-stamp-for-instances class) + for (class . next) in (rest pairs) + for stamp = (stamp-for-instances class) if (and (core:stamps-adjacent-p (cdar current) stamp) (next= (cdr current) next)) do (setf (cdar current) stamp) @@ -300,69 +437,71 @@ (or (second (assoc inst *isa*)) (error "BUG: In fastgf linker, symbol is not an op: ~a" inst))) -(defstruct (bc-constant-arg (:type vector) :named) - value) - -(defstruct (bc-constant-ref (:type vector) :named) - ref) - -(defstruct (bc-label-arg (:type vector) :named) - lip index delta) - -(defstruct (bc-register-arg (:type vector) :named) - index) - -(defstruct (bc-instruction (:type vector) :named) - name lip index byte-index code final-op) - -(defstruct (bc-long-instruction (:type vector) (:include bc-instruction) :named) - code-add) - -(defun longify-instruction (short-instruction num-ops instr) +(defclass bc-constant-arg () + ((%value :initarg :value :reader bc-constant-arg-value))) +(defun make-bc-constant-arg (&key value) + (early-make-instance bc-constant-arg :value value)) + +(defclass bc-constant-ref () + ((%ref :initarg :ref :reader bc-constant-ref-ref))) +(defun make-bc-constant-ref (&key ref) + (early-make-instance bc-constant-ref :ref ref)) + +(defclass bc-label-arg () + ((%lip :initarg :lip :reader bc-lip) + (%index :initarg :index :accessor dtree-index) + (%delta :initarg :delta :accessor bc-label-arg-delta))) +(defun make-bc-label-arg (&key lip index delta) + (early-make-instance bc-label-arg :lip lip :index index :delta delta)) + +(defclass bc-register-arg () + ((%index :initarg :index :reader dtree-index))) +(defun make-bc-register-arg (&key index) + (early-make-instance bc-register-arg :index index)) + +(defclass bc-instruction () + ((%lip :initarg :lip :reader bc-lip) + (%index :initarg :index :reader dtree-index) + (%code :initarg :code :reader bc-instruction-code))) +(defun make-bc-instruction (&key lip index code) + (early-make-instance bc-instruction :lip lip :index index :code code)) + +(defun longify-instruction (short-instruction instr) (declare (ignorable instr)) - (let ((longer (make-bc-long-instruction :name (bc-instruction-name short-instruction) - :code (bc-instruction-code short-instruction) - :code-add num-ops - :lip (bc-instruction-lip short-instruction) - :index (bc-instruction-index short-instruction) - :byte-index (bc-instruction-byte-index short-instruction)))) -;;; (format t "longify-instruction ~s~% from ~s~%" longer instr) - longer)) - + (make-bc-instruction :code (bc-instruction-code short-instruction) + :lip (bc-lip short-instruction) + :index (dtree-index short-instruction))) (defun annotated-opcode (inst) (let* ((code-cell (assoc inst *isa*)) (code (second code-cell))) - (make-bc-instruction :name inst :code code))) + (make-bc-instruction :code code))) (defconstant +longify-trigger+ 255) ;; Move constants into the literals vector and replace them with ;; indices in the program. Also accumulate patchpoints for labels -(defun literalify-arguments (instr dtree-op literals coallesce-indexes) +(defun literalify-arguments (instr literals coallesce-indexes) (loop named literalify with long-arg = nil - for cur = (cdr instr) then (cdr cur) - for annotated-arg = (car cur) - for arg-type in (dtree-op-arguments dtree-op) - collect (cond - ((bc-constant-arg-p annotated-arg) + for annotated-arg in (cdr instr) + collect (typecase annotated-arg + (bc-constant-arg (let* ((arg (bc-constant-arg-value annotated-arg)) (seen-index-value (gethash arg coallesce-indexes))) (if (null seen-index-value) (let* ((index (vector-push-extend arg literals)) - (index-value (make-bc-constant-ref :ref index))) + (index-value (make-bc-constant-ref :ref index))) (setf (gethash arg coallesce-indexes) index-value) (when (> index +longify-trigger+) (setf long-arg t)) index-value) seen-index-value))) - ((bc-label-arg-p annotated-arg) annotated-arg) - ((bc-register-arg-p annotated-arg) annotated-arg) + (bc-label-arg annotated-arg) + (bc-register-arg annotated-arg) (t (error "Illegal arg ~a" annotated-arg))) into new-args - when (null (cdr cur)) - do (return-from literalify (values new-args long-arg)))) + finally (return-from literalify (values new-args long-arg)))) ;;; Move constants into a literal vector and replace them with references ;;; Return a vector of nil/T, one for each instruction if the instruction is long @@ -375,15 +514,13 @@ (new-program (loop for instr in compiled for index from 0 for annotated-op = (first instr) - for op = (bc-instruction-code annotated-op) - for dop = (elt *dtree-ops* op) collect (multiple-value-bind (new-args long-arg) - (literalify-arguments instr dop literals coallesce-indexes) + (literalify-arguments instr literals coallesce-indexes) (if long-arg (progn (format t "Dealing with long instruction ~s~%" instr) (setf (elt longs index) long-arg) - (longify-instruction annotated-op (length *dtree-ops*) instr)) + (longify-instruction annotated-op instr)) (list* annotated-op new-args)))))) (values new-program literals longs))) @@ -409,7 +546,7 @@ for idx below (length (dtree-op-label-argument-indices dtree-op)) for label-index = (elt (dtree-op-label-argument-indices dtree-op) idx) for annotated-jump-label = (elt (cdr instruction) label-index) - for jump-label = (bc-label-arg-index annotated-jump-label) + for jump-label = (dtree-index annotated-jump-label) for start-ip = ip for end-ip = (elt labels jump-label) for delta = (- end-ip start-ip) @@ -432,7 +569,7 @@ for long = (elt longs index) do (when (not long) (when (longify-instruction-p ip instr dop labels) - (setf (first instr) (longify-instruction annotated-op (length *dtree-ops*) instr) + (setf (first instr) (longify-instruction annotated-op instr) new-long t (elt longs index) t)))) (values longs new-long))) @@ -452,57 +589,38 @@ (defun byteify-args (args long bytecode) (labels ((two-byte (val bytecode) (let ((low (logand val #xff)) - (high (logand (ash val -8) #xff)) - (higher (ash val -16))) - (when (> higher 0) (error "A value ~a larger than 65535 cannot be coded in two bytes - you need a bigger vm" val)) + (high (logand (ash val -8) #xff))) + (when (> val 65535) + (error "A value ~a larger than 65535 cannot be coded in two bytes - you need a bigger vm" val)) (vector-push-extend low bytecode) - (vector-push-extend high bytecode)))) + (vector-push-extend high bytecode))) + (arg (arg-val) + (cond (long (two-byte arg-val bytecode)) + ((> arg-val +longify-trigger+) + (error "This value should be long ~a" arg-val)) + (t (vector-push-extend arg-val bytecode))))) (loop for arg in args - do (cond - ((bc-constant-ref-p arg) - (let ((arg-val (bc-constant-ref-ref arg))) - (if long - (two-byte arg-val bytecode) - (if (> arg-val +longify-trigger+) - (error "This value should be long ~a" arg-val) - (vector-push-extend arg-val bytecode))))) - ((bc-label-arg-p arg) - (let ((arg-val (bc-label-arg-delta arg))) - (if long - (two-byte arg-val bytecode) - (if (> arg-val +longify-trigger+) - (warn "This value should be long ~a" arg) - (vector-push-extend arg-val bytecode))))) - ((bc-register-arg-p arg) - (let ((arg-val (bc-register-arg-index arg))) - (if long - (two-byte arg-val bytecode) - (if (> arg-val +longify-trigger+) - (warn "This value should be long ~a" arg) - (vector-push-extend arg-val bytecode))))) + do (typecase arg + (bc-constant-ref (arg (bc-constant-ref-ref arg))) + (bc-label-arg (arg (bc-label-arg-delta arg))) + (bc-register-arg (arg (dtree-index arg))) (t (error "Illegal arg type ~a" arg)))))) -(defun bytecodeify (instructions longs labels bytecode) +(defun bytecodeify (instructions longs bytecode) (let* ((ip (length bytecode)) (saw-long nil) (new-instructions (loop for instr in instructions - for index from 0 for long across longs for annotated-op = (car instr) for op = (bc-instruction-code annotated-op) for final-op = (if long - (if (bc-long-instruction-p annotated-op) - (progn - (setf saw-long t) - (+ op (bc-long-instruction-code-add annotated-op))) - (error "instruction is not long ~a" annotated-op)) + (progn + (setf saw-long t) + (+ op (length *dtree-ops*))) op) for args = (cdr instr) - for byte-ip = (elt labels index) do (vector-push-extend final-op bytecode) do (byteify-args args long bytecode) - do (setf (bc-instruction-byte-index annotated-op) byte-ip - (bc-instruction-final-op annotated-op) final-op) collect (list* annotated-op (cdr instr))))) (values ip new-instructions saw-long))) @@ -541,76 +659,77 @@ (pop links) (setf (car patchpoint) ip) (next subtree))))) - (loop (cond ((argument-p tree) - (cond - ((null (argument-count tree)) - (collect (opcode 'advance))) - ((= (argument-count tree) 0) - (collect (opcode 'farg0))) - ((= (argument-count tree) 1) - (collect (opcode 'farg1))) - ((= (argument-count tree) 2) - (collect (opcode 'farg2))) - ((= (argument-count tree) 3) - (collect (opcode 'farg3))) - ((= (argument-count tree) 4) - (collect (opcode 'farg4))) - (t (collect(opcode 'argn) (argument-count tree)))) - (next (argument-next tree))) - ((tag-test-p tree) - (collect (opcode 'tag-test)) - (loop for tag across (tag-test-tags tree) - do (wait tag)) - (next (tag-test-default tree))) - ((stamp-read-p tree) - (collect (opcode 'stamp-read)) - (wait (stamp-read-c++ tree)) - (next (stamp-read-other tree))) - ((<-branch-p tree) - (collect (opcode 'lt-branch) - (<-branch-pivot tree)) - (wait (<-branch-left tree)) - (next (<-branch-right tree))) - ((=-check-p tree) - (collect (opcode 'eq-check) - (=-check-pivot tree)) - (next (=-check-next tree))) - ((range-check-p tree) - (collect (opcode 'range-check) - (range-check-min tree) - (range-check-max tree)) - (next (range-check-next tree))) - ((eql-search-p tree) - (loop for object across (eql-search-objects tree) - for next across (eql-search-nexts tree) - do (collect (opcode 'eql) - object) - (wait next)) - (next (eql-search-default tree))) - ((miss-p tree) - (collect (opcode 'miss)) - (cont)) - ((optimized-slot-reader-p tree) - (collect - (if (core:fixnump (optimized-slot-reader-index tree)) - (opcode 'optimized-slot-reader) ; instance - (opcode 'car)) ; class - (optimized-slot-reader-index tree) - (optimized-slot-reader-slot-name tree)) - (cont)) - ((optimized-slot-writer-p tree) - (collect - (if (core:fixnump (optimized-slot-writer-index tree)) - (opcode 'optimized-slot-writer) ; instance - (opcode 'rplaca)) ; class - (optimized-slot-writer-index tree)) - (cont)) - ((effective-method-outcome-p tree) - (collect (opcode 'effective-method-outcome) - (effective-method-outcome-function tree)) - (cont)) - (t (error "BUG: Unknown dtree: ~a" tree))))))) - + (loop (typecase tree + (dtree-argument + (cond + ((null (argument-count tree)) + (collect (opcode 'advance))) + ((= (argument-count tree) 0) + (collect (opcode 'farg0))) + ((= (argument-count tree) 1) + (collect (opcode 'farg1))) + ((= (argument-count tree) 2) + (collect (opcode 'farg2))) + ((= (argument-count tree) 3) + (collect (opcode 'farg3))) + ((= (argument-count tree) 4) + (collect (opcode 'farg4))) + (t (collect (opcode 'argn) (argument-count tree)))) + (next (dtree-next tree))) + (dtree-tag-test + (collect (opcode 'tag-test)) + (loop for tag across (tag-test-tags tree) + do (wait tag)) + (next (tag-test-default tree))) + (dtree-stamp-read + (collect (opcode 'stamp-read)) + (wait (stamp-read-c++ tree)) + (next (stamp-read-other tree))) + (dtree-<-branch + (collect (opcode 'lt-branch) (pivot tree)) + (wait (<-branch-left tree)) + (next (<-branch-right tree))) + (dtree-=-check + (collect (opcode 'eq-check) (pivot tree)) + (next (dtree-next tree))) + (dtree-range-check + (collect (opcode 'range-check) + (range-check-min tree) + (range-check-max tree)) + (next (dtree-next tree))) + (dtree-eql-search + (loop for object across (eql-search-objects tree) + for next across (eql-search-nexts tree) + do (collect (opcode 'eql) + object) + (wait next)) + (next (eql-search-default tree))) + (dtree-miss + (collect (opcode 'miss)) + (cont)) + (optimized-slot-reader + (collect + (if (core:fixnump (optimized-slot-accessor-index tree)) + (opcode 'optimized-slot-reader) ; instance + (opcode 'car)) ; class + (optimized-slot-accessor-index tree) + (optimized-slot-accessor-slot-name tree)) + (cont)) + (optimized-slot-writer + (collect + (if (core:fixnump (optimized-slot-accessor-index tree)) + (opcode 'optimized-slot-writer) ; instance + (opcode 'rplaca)) ; class + (optimized-slot-accessor-index tree)) + (cont)) + (effective-method-outcome + (collect (opcode 'effective-method-outcome) + (effective-method-outcome-function tree)) + (cont)) + (t (error "BUG: Unknown dtree: ~a" tree))))))) + +;;; Group an instruction into a list. The first element of the list is +;;; a bc-instruction and the remainder of the list are argument objects. (defun group-instruction (linear ip-place index) (symbol-macrolet ((ip (car ip-place)) (ip++ (prog1 (car ip-place) (incf (car ip-place))))) @@ -626,7 +745,7 @@ ((eq (car arg) 'register-arg) (make-bc-register-arg :index (elt linear ip++))) (t (error "Illegal arg type ~a" arg)))))) - (list* (make-bc-instruction :name (dtree-op-name dtree-op) :lip start-ip :code op :index index) arguments)))) + (list* (make-bc-instruction :lip start-ip :code op :index index) arguments)))) (defun group-instructions (linear) (let ((ip-place (list 0))) @@ -639,22 +758,24 @@ (let ((lip-to-index (make-hash-table :test 'eql))) (loop for instr in instructions for op = (first instr) - do (setf (gethash (bc-instruction-lip op) lip-to-index) (bc-instruction-index op))) + do (setf (gethash (bc-lip op) lip-to-index) (dtree-index op))) (loop for instr in instructions - for op = (first instr) for args = (rest instr) do (loop for arg in args - when (bc-label-arg-p arg) - do (setf (bc-label-arg-index arg) (gethash (bc-label-arg-lip arg) lip-to-index)))))) + when (typep arg 'bc-label-arg) + do (setf (dtree-index arg) (gethash (bc-lip arg) lip-to-index)))))) ;;; Bytecode approach (defun dtree-compile (generic-function) - (multiple-value-bind (basic specialized-length) - (bc-basic-tree - (safe-gf-call-history generic-function) - (safe-gf-specializer-profile generic-function)) - (values (compile-tree-top basic) specialized-length))) + (let ((call-history (generic-function-call-history generic-function))) + (if (null call-history) + (values (make-miss) 0) + (multiple-value-bind (basic specialized-length) + (bc-basic-tree + (generic-function-call-history generic-function) + (generic-function-specializer-profile generic-function)) + (values (compile-tree-top basic) specialized-length))))) ;;; Called by GFBytecodeSimpleFun/make (defun bytecode-dtree-compile (generic-function) @@ -666,7 +787,6 @@ (multiple-value-bind (instructions literals longs) (reference-literals grouped) (loop named longify - with new-long with long-changes do (let ((labels (generate-label-map instructions longs))) (multiple-value-setq (longs long-changes) @@ -679,7 +799,7 @@ (entry-points (make-array 16 :adjustable t :fill-pointer 0))) (update-label-deltas instructions labels longs) (multiple-value-bind (entry-ip new-instructions saw-long) - (bytecodeify instructions longs labels bytecode) + (bytecodeify instructions longs bytecode) (declare (ignorable saw-long)) (vector-push-extend entry-ip entry-points) (values (copy-seq bytecode) (copy-seq entry-points) (copy-seq literals) specialized-length @@ -690,8 +810,6 @@ (let ((program (sys:gfbytecode-simple-fun/make generic-function))) program)) -(export 'bytecode-dtree-compile :clos) - ;;; Return a list of instruction specs and labels, ;;; where each instruction spec is of the form (operator ...), ;;; and labels are integers. diff --git a/src/lisp/kernel/clos/kernel.lisp b/src/lisp/kernel/clos/kernel.lisp deleted file mode 100644 index 3d2495a8ea..0000000000 --- a/src/lisp/kernel/clos/kernel.lisp +++ /dev/null @@ -1,332 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi. -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. - -(in-package "CLOS") - -#+(or)(eval-when (:execute) - (setq core:*echo-repl-read* t)) - -(defparameter *clos-booted* nil) -(export '*clos-booted*) - -;;; Returns a closure usable as a discriminating function -;;; when the generic function is in the invalidated state. -(defun invalidated-discriminating-function-closure (gf) - (lambda (core:&va-rest args) - (declare (core:lambda-name invalidated-discriminating-function)) - (invalidated-dispatch-function gf args))) - -;;; Sets a GF's discrminating function to the "invalidated" state. -;;; In this state, the next call will compute a real discriminating function. -(defun invalidate-discriminating-function (gf) - (set-funcallable-instance-function - gf (invalidated-discriminating-function-closure gf))) - -(defun (setf find-class) (new-value name &optional errorp env) - (declare (ignore errorp env)) - (let ((old-class (find-class name nil))) - (cond - ((and old-class - (or (typep old-class 'built-in-class) - (member name '(class built-in-class) :test #'eq))) - (unless (eq new-value old-class) - (error "The class associated to the CL specifier ~S cannot be changed." - name))) - ((or (classp new-value) (null new-value)) - (core:setf-find-class new-value name) - #+static-gfs - (static-gfs:invalidate-designated-constructors name) - #+(or) ;static-gfs - (static-gfs:invalidate-designated-changers name)) - (t (error 'simple-type-error :datum new-value :expected-type '(or class null) - :format-control "~A is not a valid class for (setf find-class)" - :format-arguments (list new-value))))) - new-value) - - -;;; ---------------------------------------------------------------------- -;;; Methods - -(defun install-method (name qualifiers specializers lambda-list fun &rest options) - (declare (notinline ensure-generic-function)) - (let* ((gf (ensure-generic-function name)) - (method (make-method (generic-function-method-class gf) - qualifiers specializers lambda-list - fun options))) - (add-method gf method) - method)) - -;;; ---------------------------------------------------------------------- -;;; early versions - -;;; early version used during bootstrap -(defun ensure-generic-function (name &key (lambda-list (si::unbound) l-l-p)) - (if (and (fboundp name) (si::instancep (fdefinition name))) - (fdefinition name) - ;; create a fake standard-generic-function object: - (with-early-make-funcallable-instance +standard-generic-function-slots+ - (gfun (find-class 'standard-generic-function) - :lambda-list lambda-list - :method-combination nil - :argument-precedence-order - (and l-l-p (rest (si::process-lambda-list lambda-list t))) - :method-class (find-class 'standard-method) - :docstring nil - :methods nil - :a-p-o-function nil - :declarations nil - :dependents nil) - (core:setf-function-name gfun name) - (setf (generic-function-method-combination gfun) - (find-method-combination gfun 'standard nil)) - (invalidate-discriminating-function gfun) - (setf (fdefinition name) gfun) - gfun))) - -;;; made into generic functions later -(defun generic-function-name (generic-function) - (core:function-name generic-function)) - -(defun (setf generic-function-name) (new-name gf) - (declare (notinline reinitialize-instance)) ; bootstrapping - (if *clos-booted* - (reinitialize-instance gf :name new-name) - (core:setf-function-name gf new-name)) - new-name) - -;;; Will be the standard method after fixup. -(defun compute-discriminating-function (generic-function) - (invalidated-discriminating-function-closure generic-function)) - -;;; ---------------------------------------------------------------------- -;;; COMPUTE-APPLICABLE-METHODS -;;; -;;; This part is a source of problems because we have to access slots of -;;; various objects, which could potentially lead to infinite recursion as -;;; those accessors require also some dispatch. The solution is to avoid -;;; calling then generic function that implement the accessors. -;;; This is possible because: -;;; 1. The user can only extend compute-applicable-methods if it -;;; defines a method with a subclass of standard-generic-function -;;; 2. The user cannot extend slot-value and friends on standard-classes -;;; due to the restriction "Any method defined by a portable program -;;; on a specified generic function must have at least one specializer -;;; that is neither a specified class nor an eql specializer whose -;;; associated value is an instance of a specified class." -;;; 3. Subclasses of specified classes preserve the slot order in ECL. -;;; -(defun std-compute-applicable-methods (gf args) - (sort-applicable-methods gf - (applicable-method-list gf args) - (mapcar #'class-of args))) - -(setf (fdefinition 'compute-applicable-methods) #'std-compute-applicable-methods) - -(defun safe-method-specializers (method) - (let ((mc (class-of method))) - (cond ((or (eq mc (find-class 'standard-method)) - (eq mc (find-class 'standard-reader-method)) - (eq mc (find-class 'standard-writer-method))) - (with-early-accessors (+standard-method-slots+) - (method-specializers method))) - ((or (eq mc (find-class 'effective-reader-method)) - (eq mc (find-class 'effective-writer-method))) - (with-early-accessors (+standard-method-slots+ - +effective-accessor-method-slots+) - (method-specializers - (effective-accessor-method-original method)))) - (t (method-specializers method))))) - -(defun eql-specializer-p (specializer) (typep specializer 'eql-specializer)) - -(defun applicable-method-list (gf args) - (declare (optimize (speed 3))) - (with-early-accessors (+standard-generic-function-slots+ - +eql-specializer-slots+ - +standard-class-slots+) - (flet ((applicable-method-p (method args) - (loop for spec in (safe-method-specializers method) - for arg in args - always (if (eql-specializer-p spec) - (eql arg (eql-specializer-object spec)) - (si::of-class-p arg spec))))) - (loop for method in (generic-function-methods gf) - when (applicable-method-p method args) - collect method)))) - -(defun std-compute-applicable-methods-using-classes (gf classes) - (declare (optimize (speed 3))) - (with-early-accessors (+eql-specializer-slots+ +standard-generic-function-slots+) - (flet ((applicable-method-p (method classes) - (loop for spec in (safe-method-specializers method) - for class in classes - always (cond ((eql-specializer-p spec) - ;; EQL specializer can invalidate computation - (when (si::of-class-p (eql-specializer-object spec) class) - (return-from std-compute-applicable-methods-using-classes - (values nil nil))) - nil) - ((si::subclassp class spec)))))) - (values (sort-applicable-methods - gf - (loop for method in (generic-function-methods gf) - when (applicable-method-p method classes) - collect method) - classes) - t)))) - -(defun sort-applicable-methods (gf applicable-list args-specializers) - (declare (optimize (safety 0) (speed 3))) - (with-early-accessors (+standard-generic-function-slots+) - (let ((f (generic-function-a-p-o-function gf))) - ;; reorder args to match the precedence order - (when f - (setf args-specializers - (funcall f (subseq args-specializers 0 - (length (generic-function-argument-precedence-order gf)))))) - ;; then order the list. Simple selection sort. FIXME? - ;; note that this mutates the list, so be sure applicable-list - ;; is fresh. - (loop for to-sort on applicable-list - do (loop for comparees on (rest to-sort) - for comparee = (first comparees) - for most-specific = (first to-sort) - when (eql (compare-methods most-specific comparee - args-specializers f) - 2) - do (rotatef (first comparees) (first to-sort)))) - applicable-list))) - -(defun compare-methods (method-1 method-2 args-specializers f) - (let* ((specializers-list-1 (safe-method-specializers method-1)) - (specializers-list-2 (safe-method-specializers method-2))) - (compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1) - (if f (funcall f specializers-list-2) specializers-list-2) - args-specializers))) - -(defun compare-specializers-lists (spec-list-1 spec-list-2 args-specializers) - (loop for spec1 in spec-list-1 for spec2 in spec-list-2 - for arg-specializer in args-specializers - for c = (compare-specializers spec1 spec2 arg-specializer) - do (case c - ;; if =, just keep going - ((1) (return 1)) - ((2) (return 2)) - ((nil) - (error "The type specifiers ~S and ~S can not be disambiguated~ - with respect to the argument specializer: ~S" - (or spec1 t) (or spec2 t) arg-specializer))))) - -(defun fast-subtypep (spec1 spec2) - ;; Specialized version of subtypep which uses the fact that spec1 - ;; and spec2 are either classes or eql specializers (basically member types) - (with-early-accessors (+eql-specializer-slots+ +standard-class-slots+) - (if (eql-specializer-p spec1) - (if (eql-specializer-p spec2) - (eq spec1 spec2) ; take advantage of internment - (si::of-class-p (eql-specializer-object spec1) spec2)) - (if (eql-specializer-p spec2) - ;; There is only one class with a single element, which - ;; is NULL = (MEMBER NIL). - (and (null (eql-specializer-object spec2)) - (eq (class-name spec1) 'null)) - (si::subclassp spec1 spec2))))) - -(defun compare-specializers (spec-1 spec-2 arg-spec) - (with-early-accessors (+standard-class-slots+ +standard-class-slots+ - +eql-specializer-slots+) - (let ((cpl (class-precedence-list (if (eql-specializer-p arg-spec) - (class-of (eql-specializer-object - arg-spec)) - arg-spec)))) - (cond ((eq spec-1 spec-2) '=) - ((fast-subtypep spec-1 spec-2) '1) - ((fast-subtypep spec-2 spec-1) '2) - ;; Per CLHS 7.6.6.1.2, an eql specializer is considered - ;; more specific than a class. Also, for an eql specializer - ;; to be compared to a class here, they must both be - ;; applicable, and as such the eql is a "sub specializer". - ((eql-specializer-p spec-1) '1) - ((eql-specializer-p spec-2) '2) - ((member spec-1 (rest (member spec-2 cpl))) '2) - ((member spec-2 (rest (member spec-1 cpl))) '1) - ;; This will force an error in the caller - (t nil))))) - -;;; mutates the specializer profile to account for new specializers. -(defun update-specializer-profile (specializer-profile specializers) - (with-early-accessors (+eql-specializer-slots+) - (loop for spec in specializers - for i from 0 - for e = (svref specializer-profile i) - do (setf (svref specializer-profile i) - (cond ((eql-specializer-p spec) - (let ((o (eql-specializer-object spec))) - ;; Add to existing list of eql spec - ;; objects, or make a new one. - (if (consp e) - (adjoin o e) - (list o)))) - ((eql spec +the-t-class+) (or e nil)) - (t (or e t)))))) - specializer-profile) - -;;; Add one method to the specializer profile. -(defun update-gf-specializer-profile (gf specializers) - (with-early-accessors (+standard-generic-function-slots+) - ;; Although update-specializer-profile mutates the vector, - ;; we still need this setf for the case in which the existing sp - ;; was NIL (see compute-gf-specializer-profile below for how this - ;; can arise). - (setf (generic-function-specializer-profile gf) - (let* ((sv (generic-function-specializer-profile gf)) - (to-update (or sv (make-array (length specializers) - :initial-element nil)))) - (update-specializer-profile to-update specializers))))) - -;;; Recompute the specializer profile entirely. -;;; Needed if a method has been removed. -(defun compute-gf-specializer-profile (gf) - (with-early-accessors (+standard-generic-function-slots+) - (setf (generic-function-specializer-profile gf) - ;; NOTE: If the gf has no methods, this results in a - ;; specializer profile of NIL, which is not a vector. - ;; This can cause errors in code that expects the sp to be - ;; a vector, but the sp being NIL in code like that indicates - ;; some kind of bug. We could use #() here instead, but that - ;; would just mask such bugs. - (let ((sp nil)) - (dolist (method (generic-function-methods gf)) - (let ((specializers (safe-method-specializers method))) - (when (null sp) - (setf sp (make-array (length specializers)))) - (update-specializer-profile sp specializers))) - sp)))) - -(defun compute-a-p-o-function (gf) - (with-early-accessors (+standard-generic-function-slots+) - (let ((a-p-o (generic-function-argument-precedence-order gf)) - (gf-ll (generic-function-lambda-list gf))) - (setf (generic-function-a-p-o-function gf) - (if (consp gf-ll) - (let ((required-arguments (rest (core:process-lambda-list gf-ll t)))) - (if (equal a-p-o required-arguments) - nil - (coerce `(lambda (%list) - (destructuring-bind ,required-arguments %list - (list ,@a-p-o))) - 'function))) - nil))))) - -;;; Will be upgraded to a method in fixup. -(defun print-object (object stream) - (core::write-ugly-object object stream)) diff --git a/src/lisp/kernel/clos/make-load-form.lisp b/src/lisp/kernel/clos/make-load-form.lisp new file mode 100644 index 0000000000..ef00f701a4 --- /dev/null +++ b/src/lisp/kernel/clos/make-load-form.lisp @@ -0,0 +1,212 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- +;;;; +;;;; Copyright (c) 1992, Giuseppe Attardi. +;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. +;;;; +;;;; This program 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 file '../Copyright' for full details. + +(in-package "CLOS") + +;;; ---------------------------------------------------------------------- +;;; Load forms +;;; +;;; Clasp extends the ANSI specification by allowing to use +;;; MAKE-LOAD-FORM on almost any kind of lisp object. +;;; But it doesn't necessarily use those methods in the compiler. see cmpliteral.lisp +;;; + +(defun make-load-form-saving-slots (object &key slot-names environment) + ;; The ALLOCATE-INSTANCE form here is treated magically by the file + ;; compiler; see cmp/cmpliteral.lisp ALLOCATE-INSTANCE-FORM-P + (declare (ignore environment)) + (do* ((class (class-of object)) + (initialization (list object 'load-instance)) + (slots (class-slots class) (cdr slots))) + ((endp slots) + (values `(allocate-instance ,class) (nreverse initialization))) + (let* ((slot (first slots)) + (slot-name (slot-definition-name slot))) + (when (or (and (null slot-names) + (eq (slot-definition-allocation slot) :instance)) + (member slot-name slot-names)) + (when (slot-boundp object slot-name) + (push `',slot-name initialization) + (push `',(slot-value object slot-name) initialization)))))) + +;;; This function basically exists so that cmpliteral can handle +;;; make-load-form-saving-slots forms without compiling them recursively. +;;; We used to use a progn of setf slot-values, but that's more complex. +(defun load-instance (instance &rest slot-names-values) + (loop for (name value) on slot-names-values by #'cddr + do (setf (slot-value instance name) value)) + (values)) + +(defun need-to-make-load-form-p (object env) + "Return T if the object cannot be externalized using the lisp +printer and we should rather use MAKE-LOAD-FORM." + (declare (ignore env)) + (let ((*load-form-cache* nil)) + (declare (special *load-form-cache*)) + (labels ((recursive-test (object) + (loop + ;; For simple, atomic objects we just return NIL. There is no need to + ;; call MAKE-LOAD-FORM on them + (when (typep object '(or character number symbol pathname string bit-vector)) + (return nil)) + ;; For complex objects we set up a cache and run through the + ;; objects content looking for data that might require + ;; MAKE-LOAD-FORM to be externalized. The cache is used to + ;; solve the problem of circularity and of EQ references. + (unless *load-form-cache* + (setf *load-form-cache* (make-hash-table :size 128 :test #'eq))) + (when (gethash object *load-form-cache*) + (return nil)) + (setf (gethash object *load-form-cache*) t) + (cond ((arrayp object) + (unless (subtypep (array-element-type object) '(or character number)) + (dotimes (i (array-total-size object)) + (recursive-test (row-major-aref object i)))) + (return nil)) + ((consp object) + (recursive-test (car object)) + (setf object (rest object))) + (t + (throw 'need-to-make-load-form t)))))) + (catch 'need-to-make-load-form + (recursive-test object) + nil)))) + +(defgeneric make-load-form (object &optional env)) + +(defmethod make-load-form ((object t) &optional env) + (flet ((maybe-quote (object) + (if (or (consp object) (symbolp object)) + (list 'quote object) + object))) + (unless (need-to-make-load-form-p object env) + (return-from make-load-form (maybe-quote object))) + (typecase object + (array + (let ((init-forms '())) + (values `(make-array ',(array-dimensions object) + :element-type ',(array-element-type object) + :adjustable ',(adjustable-array-p object) + :initial-contents + ',(loop for i from 0 below (array-total-size object) + collect (let ((x (row-major-aref object i))) + (if (need-to-make-load-form-p x env) + (progn (push `(setf (row-major-aref ,object ,i) ',x) + init-forms) + 0) + x)))) + (and init-forms `(progn ,@init-forms))))) + (cons + (values `(cons ,(maybe-quote (car object)) nil) + (and (rest object) `(rplacd ,(maybe-quote object) + ,(maybe-quote (cdr object)))))) + (t + (no-make-load-form object))))) + +(defmethod make-load-form ((object standard-object) &optional environment) + (declare (ignore environment)) + (no-make-load-form object)) + +(defmethod make-load-form ((object structure-object) &optional environment) + (declare (ignore environment)) + (no-make-load-form object)) + +(defmethod make-load-form ((object condition) &optional environment) + (declare (ignore environment)) + (no-make-load-form object)) + +(defun no-make-load-form (object) + #+(or)(declare (optimize (debug 3))) + (error "No adequate specialization of MAKE-LOAD-FORM for an object of type ~a" + (type-of object))) + +(defmethod make-load-form ((class class) &optional environment) + ;; The find-class form here is treated magically by the file compiler- + ;; see cmp/cmpliteral.lisp FIND-CLASS-FORM-P + (declare (ignore environment)) + (let ((name (class-name class))) + (if (and name (eq (find-class name) class)) + `(find-class ',name) + (error "Cannot externalize anonymous class ~A" class)))) + +(defmethod make-load-form ((package package) &optional environment) + (declare (ignore environment)) + `(find-package ,(package-name package))) + +;;; Extension. (Allowed per CLHS 3.2.4.3.) +;;; This is required for a lot of satiation.lisp to function. +(defmethod make-load-form ((method method) &optional environment) + (declare (ignore environment)) + ;; FIXME: Should spruce up cmpliteral so it doesn't compile calls with + ;; all constant arguments. + `(load-method + ',(generic-function-name (method-generic-function method)) + ',(method-qualifiers method) + ',(method-specializers method))) + +;;; Also an extension, to support the above. +(defmethod make-load-form ((spec eql-specializer) &optional environment) + (declare (ignore environment)) + `(intern-eql-specializer ',(eql-specializer-object spec))) + +(defun class-slotd-form (slot-name class &optional earlyp) + (let ((form + `(or (find ',slot-name (class-slots ,class) :key #'slot-definition-name) + (error "Probably a BUG: slot ~a in ~a stopped existing between compile and load" + ',slot-name ,class)))) + (if earlyp + `(with-early-accessors (+standard-class-slots+ +slot-definition-slots+) + (flet ((slot-definition-name (sd) (slot-definition-name sd))) ; macro, so. + ,form)) + form))) + +(defmethod make-load-form ((method effective-reader-method) + &optional environment) + (declare (ignore environment)) + (let ((orig (effective-accessor-method-original method))) + `(,(if (eq (class-of orig) (find-class 'standard-reader-method)) + 'early-intern-effective-reader + 'intern-effective-reader) + ',orig + ',(effective-accessor-method-location method)))) + +(defmethod make-load-form ((method effective-writer-method) + &optional environment) + (declare (ignore environment)) + (let ((orig (effective-accessor-method-original method))) + `(,(if (eq (class-of orig) (find-class 'standard-writer-method)) + 'early-intern-effective-writer + 'intern-effective-writer) + ',orig + ',(effective-accessor-method-location method)))) + +(defmethod make-load-form ((object core:file-scope) &optional env) + (declare (ignore env)) + (values + `(core:make-cxx-object ,(find-class 'core:file-scope)) + `(core:decode + ,object + ',(core:encode object)))) + +(defmethod make-load-form ((object core:source-pos-info) &optional environment) + (declare (ignore environment)) + (values + `(core:make-cxx-object ,(find-class 'core:source-pos-info) + :sfi ,(core:file-scope + (core:source-pos-info-file-handle object)) + :fp ,(core:source-pos-info-filepos object) + :l ,(core:source-pos-info-lineno object) + :c ,(core:source-pos-info-column object)) + `(core:setf-source-pos-info-extra + ',object + ',(core:source-pos-info-inlined-at object) + ',(core:source-pos-info-function-scope object)))) diff --git a/src/lisp/kernel/clos/make.lisp b/src/lisp/kernel/clos/make.lisp new file mode 100644 index 0000000000..c04fe099c8 --- /dev/null +++ b/src/lisp/kernel/clos/make.lisp @@ -0,0 +1,132 @@ +(in-package #:clos) + +(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys)) +(defgeneric make-instance (class &rest initargs &key &allow-other-keys)) +(defgeneric initialize-instance (object &rest initargs &key &allow-other-keys)) +(defgeneric reinitialize-instance (object &rest initargs &key &allow-other-keys)) +(defgeneric shared-initialize (object slot-names &rest initargs + &key &allow-other-keys)) + +(defun make-rack-for-class (class) + (let (;; FIXME: Read this information from the class in one go, atomically. + (slotds (class-slots class)) + (size (class-size class)) + (stamp (core:class-stamp-for-instances class))) + (core:make-rack size slotds stamp (core:unbound)))) + +(defmethod allocate-instance ((class standard-class) &rest initargs) + (declare (ignore initargs)) + ;; CLHS says allocate-instance finalizes the class first. + ;; Dr. Strandh argues that this is impossible since the initargs should be the + ;; defaulted initargs, which cannot be computed without the class being finalized. + ;; More fundamentally but less legalistically, allocate-instance is not usually + ;; called except from make-instance, which checks finalization itself. + ;; If allocate-instance is nonetheless somehow called on an unfinalized class, + ;; class-size (also computed during finalization) will be unbound and error + ;; before anything terrible can happen. + ;; So we don't finalize here. + (core:allocate-raw-instance class (make-rack-for-class class))) + +(defmethod allocate-instance ((class structure-class) &rest initargs) + (declare (ignore initargs)) + (core:allocate-raw-instance class (make-rack-for-class class))) + +(defun uninitialized-funcallable-instance-closure (funcallable-instance) + (lambda (&rest args) + (declare (core:lambda-name uninitialized-funcallable-instance)) + (declare (ignore args)) + (error "The funcallable instance ~a has not been initialized with a function" + funcallable-instance))) + +(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) + (declare (ignore initargs)) + (let ((instance (core:allocate-raw-funcallable-instance + class (make-rack-for-class class)))) + ;; MOP says if you call a funcallable instance before setting its function, + ;; the effects are undefined. (In the entry for set-funcallable-instance-function.) + ;; But we can be nice. + (set-funcallable-instance-function + instance (uninitialized-funcallable-instance-closure instance)) + instance)) + +(defmethod allocate-instance ((class core:derivable-cxx-class) &rest initargs) + (declare (ignore initargs)) + (core:allocate-raw-general-instance class (make-rack-for-class class))) + +(defmethod make-instance ((class std-class) &rest initargs) + (declare (dynamic-extent initargs)) ; see NOTE in reinitialize-instance/T + ;; Without finalization we can not find initargs. + (unless (class-finalized-p class) + (finalize-inheritance class)) + ;; We add the default-initargs first, because one of these initargs might + ;; be (:allow-other-keys t), which disables the checking of the arguments. + ;; (Paul Dietz's ANSI test suite, test CLASS-24.4) + (setf initargs (add-default-initargs class initargs)) + (let ((keywords (if (slot-boundp class 'valid-initargs) + (class-valid-initargs class) + (precompute-valid-initarg-keywords class)))) + (check-initargs class initargs keywords)) + (let ((instance (apply #'allocate-instance class initargs))) + (apply #'initialize-instance instance initargs) + instance)) + +(defmethod make-instance ((name symbol) &rest initargs) + (apply #'make-instance (find-class name) initargs)) + +(defun add-default-initargs (class initargs) + ;; Here, for each slot which is not mentioned in the initialization + ;; arguments, but which has a value associated with :DEFAULT-INITARGS, + ;; we compute the value and add it to the list of initargs. + (loop for (initkey _ valuef) in (class-default-initargs class) + when (eq 'core::missing-keyword + (getf initargs initkey 'core::missing-keyword)) + collect initkey into defaulted + and collect (funcall valuef) into defaulted + finally (return (if (null defaulted) + initargs + (append initargs defaulted))))) + +(defmethod initialize-instance ((instance t) &rest initargs) + (apply #'shared-initialize instance t initargs)) + +(defmethod reinitialize-instance ((instance t) &rest initargs) + (declare (dynamic-extent initargs)) + ;; NOTE: This dynamic extent declaration relies on the fact clasp's APPLY + ;; does not reuse rest lists. If it did, a method on #'shared-initialize, + ;; or whatever, could potentially let the rest list escape. + (when initargs + (check-initargs-uncached + (class-of instance) initargs + (list (list #'reinitialize-instance (list instance)) + (list #'shared-initialize (list instance t))))) + (apply #'shared-initialize instance '() initargs)) + +(defmethod shared-initialize ((instance t) slot-names &rest initargs) + (unless (zerop (mod (length initargs) 2)) + (core:simple-program-error "Odd number of keyword arguments for ~a" + 'shared-initialize)) + (dolist (slotd (class-slots (class-of instance))) + (let ((slot-initargs (slot-definition-initargs slotd)) + (slot-name (slot-definition-name slotd))) + ;; Initialize the slot from an initarg, if one was provided. + (loop for (key val) on initargs by #'cddr + ;; FIXME: This is both inefficient and insufficiently correct. + ;; Inefficient because the same key can be checked multiple times + ;; as we loop over slots. Incorrect in that all slots may be resolved + ;; before a bad keyword appears. + ;; The generic function should probably check instead. + unless (symbolp key) + do (core:simple-program-error "Not a valid initarg: ~A" key) + when (member key slot-initargs) + do (setf (slot-value instance slot-name) val) + (go initialized)) + ;; If it hasn't been initialized yet, and is in slot-names, + ;; use the initform. + (when (and (or (eq slot-names 't) (member slot-name slot-names)) + (not (slot-boundp instance slot-name))) + (let ((initfun (slot-definition-initfunction slotd))) + (when initfun + (setf (slot-value instance slot-name) (funcall initfun)))))) + ;; implicit tagbody + initialized) + instance) diff --git a/src/lisp/kernel/clos/method-combination-environment.lisp b/src/lisp/kernel/clos/method-combination-environment.lisp new file mode 100644 index 0000000000..a3bfeb4860 --- /dev/null +++ b/src/lisp/kernel/clos/method-combination-environment.lisp @@ -0,0 +1,29 @@ +(in-package #:clos) + +;;; Storage and retrieval of method combinations in the global environment. +;;; Actual method combination objects are defined in hierarchy.lisp. + +;;; Method combinations are stored in the global *method-combinations* hash +;;; table. (the standard method on) FIND-METHOD-COMBINATION ignores the gf, +;;; and makes a new METHOD-COMBINATION instance with the "compiler" looked +;;; up in the hash table, and the name and options. + +(defparameter *method-combinations-lock* + (mp:make-lock :name 'find-method-combination)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *method-combinations* (make-hash-table :size 32 :test 'eq))) + +(defun search-method-combination (name) + (mp:with-lock (*method-combinations-lock*) + (gethash name *method-combinations*))) + +(eval-when (:load-toplevel :execute) + (defun install-method-combination (name function) + (mp:with-lock (*method-combinations-lock*) + (setf (gethash name *method-combinations*) function)) + name)) +;;; This definition only used during build. It ignores the lock, since the build +;;; is single-threaded anyway. +(eval-when (:compile-toplevel) + (defun install-method-combination (name function) + (setf (gethash name *method-combinations*) function))) diff --git a/src/lisp/kernel/clos/method-function.lisp b/src/lisp/kernel/clos/method-function.lisp new file mode 100644 index 0000000000..c7c55210e7 --- /dev/null +++ b/src/lisp/kernel/clos/method-function.lisp @@ -0,0 +1,49 @@ +(in-package #:clos) + +(defclass %no-next-method-continuation (funcallable-standard-object) + () + (:metaclass funcallable-standard-class)) + +(defclass %contf-method-function (funcallable-standard-object) + ((%contf :initarg :contf :accessor contf)) + (:metaclass funcallable-standard-class)) + +(defun make-%no-next-method-continuation (method) + (let ((nnmc (early-make-instance %no-next-method-continuation))) + (set-funcallable-instance-function + nnmc + (if (null method) + (lambda (&rest args) + (declare (ignore args)) + (error "No next method")) + (lambda (&rest args) + (apply #'no-next-method (method-generic-function method) method args)))) + nnmc)) + +(defun make-%contf-method-function (contf) + (let ((mf (early-make-instance %contf-method-function + :contf contf))) + (set-funcallable-instance-function + mf + (let (;; FIXME: Method not available yet :( + (nnmc (make-%no-next-method-continuation nil))) + (lambda (args next-methods) + (apply contf + (if (null next-methods) + nnmc + (lambda (&rest args) + (funcall (method-function (first next-methods)) + args (rest next-methods)))) + args)))) + mf)) + +(defun make-%leaf-method-function (fmf) + (let ((mf (early-make-instance %leaf-method-function + :fmf fmf))) + (set-funcallable-instance-function + mf + (lambda (arguments next-methods) + (declare (ignore next-methods)) + ;; FIXME: Avoid coerce-fdesignator in apply here + (apply fmf arguments))) + mf)) diff --git a/src/lisp/kernel/clos/method.lisp b/src/lisp/kernel/clos/method.lisp index c69651adb8..5816b38f7c 100644 --- a/src/lisp/kernel/clos/method.lisp +++ b/src/lisp/kernel/clos/method.lisp @@ -12,20 +12,8 @@ (in-package "CLOS") -;;; ---------------------------------------------------------------------- - -(defparameter *method-size* 32) ; Size of methods hash tables - -;;; This holds fake methods created during bootstrap. -;;; It is an alist of: -;;; (method-name {method}+) -(defparameter *early-methods* nil) - -;;; -;;; This is used by combined methods to communicate the next methods to -;;; the methods they call. -;;; -(defparameter *next-methods* nil) +(defgeneric make-method-lambda (generic-function method lambda-expression environment)) +(defgeneric function-keywords (method)) ;;; Add type declarations for the arguments of a METHOD. This implies ;;; copying the method arguments because the arguments may be modified. @@ -33,111 +21,6 @@ (defparameter *add-method-argument-declarations* nil) ) -;;; ---------------------------------------------------------------------- -;;; %METHOD-FUNCTIONs -;;; -;;; These are funcallable instances used as method functions. -;;; The idea is we hang extra info, such as how to call the method with -;;; our own faster convention, on the method function itself. This ensures -;;; things don't get out of sync. -;;; See pseudo class definition in hierarchy.lisp. Idea from SBCL. - -;;; First, fast method functions: for leaf methods (i.e. methods that don't -;;; use call-next-method or next-method-p). They are therefore just -;;; functions, accepting the generic function's arguments. This means they -;;; also double as effective method functions. - -(defun make-%method-function-fast (fmf) - (with-early-make-funcallable-instance +%method-function-slots+ - (%mf (find-class '%method-function) - :fmf fmf) - (core:setf-function-name %mf 'slow-method-function) - (set-funcallable-instance-function - %mf - (lambda (arguments next-methods) - (declare (core:lambda-name slow-method-function.fmf) - (ignore next-methods)) - ;; FIXME: Avoid coerce-fdesignator in apply here - (apply fmf arguments))) - %mf)) - -(defun fast-method-function (method) - (let ((mf (method-function method))) - ;; Internal class that is never subclassed, so just - (and (eq (class-of mf) (find-class '%method-function)) - (with-early-accessors (+%method-function-slots+) - (%mf-fast-method-function mf))))) - -(defun early-fast-method-function (method) - (with-early-accessors (+std-method-slots+ - +%method-function-slots+) - (let ((mf (method-function method))) - (and (eq (class-of mf) (find-class '%method-function)) - (%mf-fast-method-function mf))))) - -;;; Continuation method functions (contfs) can be put in place for -;;; anything, unless there's a user make-method-lambda method. -;;; A contf takes one argument, the continuation, and then the arguments -;;; of the generic function as the rest. The continuation is the effective -;;; method function executed by call-next-method. -;;; So it's either a closure with another contf or method-function, or a -;;; fast method function, or a special %no-next-method-continuation. -;;; The %no-next-method-continuation is a somewhat magical funcallable -;;; instance with an instance function that just calls no-next-method. -;;; But it's its own class so that next-method-p can distinguish it. - -(defun make-%no-next-method-continuation (method) - (with-early-make-funcallable-instance nil ; class has no slots. - (%nnmc (find-class '%no-next-method-continuation)) - (set-funcallable-instance-function - %nnmc - (if (null method) - (lambda (core:&va-rest args) - (declare (core:lambda-name %no-next-method-continuation.slow.bad) - (ignore args)) - (error "No next method")) - (lambda (core:&va-rest args) - (declare (core:lambda-name %no-next-method-continuation.lambda)) - (apply #'no-next-method (method-generic-function method) method args)))) - %nnmc)) - -(defun make-%method-function-contf (contf) - (with-early-make-funcallable-instance +%method-function-slots+ - (%mf (find-class '%method-function) - :contf contf) - (core:setf-function-name %mf 'slow-method-function) - (set-funcallable-instance-function - %mf - (let (;; FIXME: Method not available yet :( - (nnmc (make-%no-next-method-continuation nil))) - (lambda (.method-args. next-methods) - (declare (core:lambda-name slow-method-function.contf)) - ;; FIXME: Avoid coerce-fdesignator in apply here - (apply contf - (if (null next-methods) - nnmc - (lambda (&rest .method-args.) - (declare (core:lambda-name slot-method-function.contf.lambda)) - (funcall (method-function (first next-methods)) - .method-args. - (rest next-methods)))) - .method-args.)))) - %mf)) - -(defun contf-method-function (method) - (let ((mf (method-function method))) - ;; Internal class that is never subclassed, so just - (and (eq (class-of mf) (find-class '%method-function)) - (with-early-accessors (+%method-function-slots+) - (%mf-contf mf))))) - -(defun early-contf-method-function (method) - (with-early-accessors (+std-method-slots+ - +%method-function-slots+) - (let ((mf (method-function method))) - (and (eq (class-of mf) (find-class '%method-function)) - (%mf-contf mf))))) - (defun wrap-contf-lexical-function-binds (form contsym cnm-p nnmp-p default-cnm-form) `(macrolet (,@(when (eq cnm-p 't) @@ -165,7 +48,7 @@ (core:process-lambda-list lambda-list 'function) (declare (ignore keys aok-p)) (if (or (not (zerop (car opt))) rest keyf) - `(lambda (,contsym core:&va-rest .method-args.) + `(lambda (,contsym &rest .method-args.) (declare (core:lambda-name ,lambda-name)) ,@(when doc (list doc)) ,(wrap-contf-lexical-function-binds @@ -197,11 +80,6 @@ ;;; DEFMETHOD ;;; -(defun generic-function-method-class (generic-function) - (if *clos-booted* - (slot-value generic-function 'method-class) - (find-class 'standard-method))) - (defun maybe-augment-generic-function-lambda-list (gf method-lambda-list) "Add any &key parameters from method-lambda-list that are missing in the generic function lambda-list to the generic function lambda-list" @@ -234,19 +112,17 @@ in the generic function lambda-list to the generic function lambda-list" (core:setf-lambda-list gf new-ll))))))))))) (defun prototypes-for-make-method-lambda (name) - (if (not *clos-booted*) - (values nil nil) - (let ((gf? (and (fboundp name) (fdefinition name)))) - (if (or (null gf?) (not (si:instancep gf?))) - (values (class-prototype (find-class 'standard-generic-function)) - (class-prototype (find-class 'standard-method))) - (values gf? - (class-prototype (or (generic-function-method-class gf?) - (find-class 'standard-method)))))))) + (let ((gf? (and (fboundp name) (fdefinition name)))) + (if (or (null gf?) (not (si:instancep gf?))) + (values (class-prototype #.(find-class 'standard-generic-function)) + (class-prototype #.(find-class 'standard-method))) + (values gf? + (class-prototype (or (generic-function-method-class gf?) + #.(find-class 'standard-method))))))) ;;; Is this lambda form one returned by our make-method-lambda method (below)? ;;; If it is, we know what it does so we can kind of ignore it. -;;; See %method-function above. +;;; See method-function.lisp (defun our-method-lambda-p (method-lambda) ;; This is pretty KLUDGEy. But make-method-lambda pretty specifically has ;; to return a lambda expression, so there's only so much we can do as far @@ -256,14 +132,6 @@ in the generic function lambda-list to the generic function lambda-list" (consp (cdr method-lambda)) (equal (second method-lambda) '(.method-args. .next-methods.)))) -;;; These are used to pass information obtained from walking the method body -;;; up to method-lambda. This is kind of ugly, but I think the walking really -;;; has to be done in make-method-lambda to work properly with user methods, -;;; and we don't want to pass it back as an option because they're not actual -;;; options. -(defvar *call-next-method-p*) -(defvar *next-method-p-p*) - ;;; Does the work of calling make-method-lambda, and returns the same values. ;;; In the event the method lambda is the one returned by the standard method, ;;; instead of a lambda expression, this will return a form to create a @@ -272,17 +140,28 @@ in the generic function lambda-list to the generic function lambda-list" lambda-name lambda-list body declarations documentation) (multiple-value-bind (generic-function method) (prototypes-for-make-method-lambda name) - (let ((*call-next-method-p* 'function) - (*next-method-p-p* 'function)) - (multiple-value-bind (fn-form options) - (make-method-lambda generic-function method lambda-expression env) + (multiple-value-bind (fn-form options) + (make-method-lambda generic-function method lambda-expression env) + (let* ((cnm-p* (or (second (member ''call-next-method-p options + :test #'equal)) + 'function)) + (nmp-p* (or (second (member ''next-method-p-p options + :test #'equal)) + 'function)) + ;; account for extra quoting for evaluation + (cnm-p (cond ((equal cnm-p* ''nil) nil) + ((equal cnm-p* ''t) t) + (t 'function))) + (nmp-p (cond ((equal nmp-p* ''nil) nil) + ((equal nmp-p* ''t) t) + (t 'function)))) (values (if (our-method-lambda-p fn-form) - (if (not (or *call-next-method-p* *next-method-p-p*)) - `(make-%method-function-fast ,lambda-expression) - `(make-%method-function-contf + (if (not (or cnm-p nmp-p)) + `(make-%leaf-method-function ,lambda-expression) + `(make-%contf-method-function ,(contf-lambda lambda-list lambda-name declarations documentation body - *call-next-method-p* *next-method-p-p*))) + cnm-p nmp-p))) fn-form) options))))) @@ -322,6 +201,7 @@ in the generic function lambda-list to the generic function lambda-list" `(:documentation ',documentation)) ,@options))))))) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun specializers-expression (specializers) `(list ,@(loop for spec in specializers @@ -350,6 +230,7 @@ in the generic function lambda-list to the generic function lambda-list" `(eql ,(make-symbol (prin1-to-string form))))) spec)) specializers)) +) (defun fixup-method-lambda-list (lambda-list) ;; According to CLHS 7.6.4., @@ -383,6 +264,7 @@ in the generic function lambda-list to the generic function lambda-list" ,@(loop for (var default) on aux by #'cddr collect `(,var ,default)))))) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun make-raw-lambda (name lambda-list required-parameters specializers specializedps body qualifiers) @@ -431,34 +313,34 @@ in the generic function lambda-list to the generic function lambda-list" block)))) (values method-lambda lambda-name lambda-list (list block) total-declarations documentation)))) +) -(defun make-method-lambda (gf method method-lambda env) +(defmethod make-method-lambda ((gf standard-generic-function) + (method standard-method) method-lambda env) (declare (ignore gf method)) (multiple-value-bind (call-next-method-p next-method-p-p) (walk-method-lambda method-lambda env) - (setf *call-next-method-p* call-next-method-p - *next-method-p-p* next-method-p-p) - (let ((leaf-method-p (null (or call-next-method-p next-method-p-p)))) - (multiple-value-bind (declarations body doc) - (si:process-declarations (cddr method-lambda) t) ; We expect docstring - ;; source location here? - (let ((lambda-list (second method-lambda)) - (lambda-name-declaration (or (find 'core::lambda-name declarations :key #'car) - '(core:lambda-name make-method-lambda.lambda)))) - ;; Note that this specific (.method-args. .next-methods.) lambda list is used - ;; above to identify our method lambdas, so be conscientious if you change it. - (values `(lambda (.method-args. .next-methods.) - (declare ,lambda-name-declaration) - ,@(when doc (list doc)) - ,(gen-lexical-method-function-binds - call-next-method-p next-method-p-p - ;; FIXME: This might not work if the user is perverse enough to - ;; name a variable &whole, or something like that? - `(destructuring-bind ,lambda-list .method-args. - (declare ,@declarations) - ,@body))) - ;; double quotes as per evaluation, explained above in defmethod. - (list ''leaf-method-p (not (not leaf-method-p))))))))) + (multiple-value-bind (declarations body doc) + (si:process-declarations (cddr method-lambda) t) ; We expect docstring + ;; source location here? + (let ((lambda-list (second method-lambda)) + (lambda-name-declaration (or (find 'core::lambda-name declarations :key #'car) + '(core:lambda-name make-method-lambda.lambda)))) + ;; Note that this specific (.method-args. .next-methods.) lambda list is used + ;; above to identify our method lambdas, so be conscientious if you change it. + (values `(lambda (.method-args. .next-methods.) + (declare ,lambda-name-declaration) + ,@(when doc (list doc)) + ,(gen-lexical-method-function-binds + call-next-method-p next-method-p-p + ;; FIXME: This might not work if the user is perverse enough to + ;; name a variable &whole, or something like that? + `(destructuring-bind ,lambda-list .method-args. + (declare ,@declarations) + ,@body))) + ;; double quotes as per evaluation, explained above in defmethod. + (list ''call-next-method-p `',call-next-method-p + ''next-method-p-p `',next-method-p-p)))))) ;;; We want to avoid consing closures for call-next-method and next-method-p when possible, ;;; which is most of the time. We don't need a closure for just (call-next-method). @@ -524,72 +406,66 @@ in the generic function lambda-list to the generic function lambda-list" ;;; ---------------------------------------------------------------------- ;;; parsing -(defun legal-generic-function-name-p (name) - (si::valid-function-name-p name)) - (defun extract-lambda-list (specialized-lambda-list) (values (parse-specialized-lambda-list specialized-lambda-list))) (defun extract-specializer-names (specialized-lambda-list) (nth-value 2 (parse-specialized-lambda-list specialized-lambda-list))) - -;; For some reason clasp needs this at compile time but ecl does not -(eval-when (:execute :compile-toplevel :load-toplevel) - (defun parse-specialized-lambda-list (specialized-lambda-list) - "This function takes a method lambda list and outputs a new lambda list +(defun parse-specialized-lambda-list (specialized-lambda-list) + "This function takes a method lambda list and outputs a new lambda list where the specializers have disappeared, the list of required arguments, the list of specializers, and a list where each element is true iff that argument was specialized. (The last is useful for implementing IGNORE behavior.)" - ;; That is, clhs defmethod says that a specialized parameter is - ;; ignorable, essentially. - (ext:with-current-source-form (specialized-lambda-list) - ;; SI:PROCESS-LAMBDA-LIST will ensure that the lambda list is - ;; syntactically correct and will output as a second value - ;; list of required arguments. We use this list to extract the - ;; specializers and build a lambda list without specializers. - (do* ((arglist (rest (si::process-lambda-list specialized-lambda-list 'METHOD)) - (rest arglist)) - (lambda-list (copy-list specialized-lambda-list)) - (ll lambda-list (rest ll)) - (required-parameters '()) - (specializers '()) - (specializedps '()) - arg variable specializer specializedp) - ((null arglist) - (values lambda-list - (nreverse required-parameters) - (nreverse specializers) - (nreverse specializedps))) - (setf arg (first arglist)) - (ext:with-current-source-form (arg) - (cond - ;; Just a variable - ((atom arg) - (setf variable arg specializer T specializedp nil)) - ;; List contains more elements than variable and specializer - ((not (endp (cddr arg))) - (si::simple-program-error "Syntax error in method specializer ~A" arg)) - ;; Specializer is NIL - ((null (setf variable (first arg) - specializedp t - specializer (second arg))) - (si::simple-program-error - "NIL is not a valid specializer in a method lambda list")) - ;; Specializer looks like a class name - ((atom specializer)) - ;; Specializer is (EQL value) - ((and (eql (first specializer) 'EQL) - (cdr specializer) - (endp (cddr specializer)))) - ;; Otherwise, syntax error - (t - (si::simple-program-error "Syntax error in method specializer ~A" arg))) - (setf (first ll) variable) - (push variable required-parameters) - (push specializer specializers) - (push specializedp specializedps)))))) + ;; That is, clhs defmethod says that a specialized parameter is + ;; ignorable, essentially. + (ext:with-current-source-form (specialized-lambda-list) + ;; SI:PROCESS-LAMBDA-LIST will ensure that the lambda list is + ;; syntactically correct and will output as a second value + ;; list of required arguments. We use this list to extract the + ;; specializers and build a lambda list without specializers. + (do* ((arglist (rest (si::process-lambda-list specialized-lambda-list 'METHOD)) + (rest arglist)) + (lambda-list (copy-list specialized-lambda-list)) + (ll lambda-list (rest ll)) + (required-parameters '()) + (specializers '()) + (specializedps '()) + arg variable specializer specializedp) + ((null arglist) + (values lambda-list + (nreverse required-parameters) + (nreverse specializers) + (nreverse specializedps))) + (setf arg (first arglist)) + (ext:with-current-source-form (arg) + (cond + ;; Just a variable + ((atom arg) + (setf variable arg specializer T specializedp nil)) + ;; List contains more elements than variable and specializer + ((not (endp (cddr arg))) + (si::simple-program-error "Syntax error in method specializer ~A" arg)) + ;; Specializer is NIL + ((null (setf variable (first arg) + specializedp t + specializer (second arg))) + (si::simple-program-error + "NIL is not a valid specializer in a method lambda list")) + ;; Specializer looks like a class name + ((atom specializer)) + ;; Specializer is (EQL value) + ((and (eql (first specializer) 'EQL) + (cdr specializer) + (endp (cddr specializer)))) + ;; Otherwise, syntax error + (t + (si::simple-program-error "Syntax error in method specializer ~A" arg))) + (setf (first ll) variable) + (push variable required-parameters) + (push specializer specializers) + (push specializedp specializedps))))) (defun declaration-specializers (arglist declarations) (do ((argscan arglist (cdr argscan)) @@ -601,6 +477,41 @@ argument was specialized. (when (listp (first argscan)) (push `(TYPE ,(cadar argscan) ,(caar argscan)) declist)))) +;;; ---------------------------------------------------------------------- +;;; initialization + +(defmethod shared-initialize :before + ((method standard-method) slot-names &rest initargs + &key (specializers nil spec-supplied-p) + (lambda-list nil lambda-supplied-p) + ;; these options are only here to legitimize them being passed back from + ;; make-method-lambda; they are not actually used. + ;; (We can't simply remove them in method-lambda, as a user may bypass that + ;; function with their own method definitions.) + ;; our custom initargs are internal symbols, as per MOP "The defmethod macros" + ((call-next-method-p call-next-method-p)) + ((next-method-p-p next-method-p-p))) + (declare (ignore initargs call-next-method-p next-method-p-p)) + (when slot-names + (unless spec-supplied-p + (error "Specializer list not supplied in method initialization")) + (unless lambda-supplied-p + (error "Lambda list not supplied in method initialization")) + (unless (= (first (si::process-lambda-list lambda-list 'method)) + (length specializers)) + (error "The list of specializers does not match the number of required arguments in the lambda list ~A" + lambda-list))) + (when spec-supplied-p + (loop for s in specializers + unless (typep s 'specializer) + do (error "Object ~A is not a valid specializer" s)))) + +(defmethod shared-initialize :after + ((method standard-method) slot-names &rest initargs) + (declare (ignore slot-names initargs)) + (setf (values (method-keywords method) (method-allows-other-keys-p method)) + (compute-method-keywords (method-lambda-list method)))) + ;;; ---------------------------------------------------------------------- ;;; operations @@ -614,126 +525,46 @@ argument was specialized. collect k) allow-other-keys))) +(defmethod function-keywords ((method standard-method)) + (values (method-keywords method) (method-allows-other-keys-p method))) + +(defun install-method (name qualifiers specializers lambda-list fun &rest options) + (let* ((gf (ensure-generic-function name)) + (method (make-method (generic-function-method-class gf) + qualifiers specializers lambda-list + fun options))) + (add-method gf method) + method)) + (defun make-method (method-class qualifiers specializers lambda-list fun options) (multiple-value-bind (keys aok-p) (compute-method-keywords lambda-list) - (with-early-make-instance - ;; We choose the largest list of slots - +standard-accessor-method-slots+ - (method (if (classp method-class) - method-class - (find-class method-class)) - :generic-function nil - :lambda-list lambda-list - :function fun - :specializers specializers - :qualifiers qualifiers - :keywords keys - :aok-p aok-p - leaf-method-p (getf options 'leaf-method-p nil) - fast-method-function (getf options 'fast-method-function nil)) - method))) - -;;; early version used during bootstrap -(defun method-p (x) - (si::instancep x)) - -;;; early version used during bootstrap -(defun add-method (gf method) - (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+ +standard-class-slots+) - (let* ((name (core:function-name gf)) - (method-entry (assoc name *early-methods*))) - (unless method-entry - (setq method-entry (list name)) - (push method-entry *early-methods*)) - (push method (cdr method-entry)) - (push method (generic-function-methods gf)) - (setf (method-generic-function method) gf) - (unless (si::sl-boundp (generic-function-lambda-list gf)) - (setf (generic-function-lambda-list gf) (method-lambda-list method)) - (setf (generic-function-argument-precedence-order gf) - (rest (si::process-lambda-list (method-lambda-list method) t)))) - (maybe-augment-generic-function-lambda-list gf (method-lambda-list method)) - (compute-gf-specializer-profile gf) - (compute-a-p-o-function gf) - (invalidate-discriminating-function gf) - gf))) - -;; Upgraded into method in fixup. -(defun find-method (gf qualifiers specializers &optional (errorp t)) - (declare (notinline method-qualifiers)) - (flet ((filter-specializer (name) - (cond ((typep name 'specializer) - name) - ((atom name) - (let ((class (find-class name nil))) - (unless class - (error "~A is not a valid specializer name" name)) - class)) - ((and (eq (first name) 'EQL) - (null (cddr name))) - (intern-eql-specializer (second name))) - (t - (error "~A is not a valid specializer name" name)))) - (specializer= (cons-or-class specializer) - (eq cons-or-class specializer))) - (when (/= (length specializers) - (length (generic-function-argument-precedence-order gf))) - (error - "The specializers list~%~A~%does not match the number of required arguments (~a) in ~A" - specializers - (length (generic-function-argument-precedence-order gf)) - (generic-function-name gf))) - (loop with specializers = (mapcar #'filter-specializer specializers) - for method in (generic-function-methods gf) - when (and (equal qualifiers (method-qualifiers method)) - (every #'specializer= specializers (method-specializers method))) - do (return-from find-method method)) - ;; If we did not find any matching method, then the list of - ;; specializers might have the wrong size and we must signal - ;; an error. - (when errorp - (error "There is no method on the generic function ~S that agrees on qualifiers ~S and specializers ~S" - (generic-function-name gf) - qualifiers specializers))) - nil) + (apply #'make-instance + (if (classp method-class) + method-class + (find-class method-class)) + :generic-function nil + :lambda-list lambda-list + :function fun + :specializers specializers + :qualifiers qualifiers + :keywords keys + :aok-p aok-p + options))) (defun compile-method (method) (let ((mf (method-function method))) - (if (typep mf '%method-function) - (let ((fmf (%mf-fast-method-function mf)) - (contf (%mf-contf mf))) - ;; I don't see how a %method-function can have neither an - ;; fmf or contf, but if it doesn't, just fail without erroring. - ;; Since this compilation may have been initiated automatically. - ;; TODO: Maybe also compile the slow method function? - (cond (fmf - (multiple-value-bind (new-fmf warningsp failurep) - (compile nil fmf) - (unless failurep - (setf (%mf-fast-method-function mf) new-fmf)) - (values mf warningsp failurep))) - (contf - (multiple-value-bind (new-contf warningsp failurep) - (compile nil contf) - (unless failurep - (setf (%mf-contf mf) new-contf)) - (values mf warningsp failurep))))) - (values mf nil nil)))) - -;;; ---------------------------------------------------------------------- -;;; with-accessors - -(defmacro with-accessors (slot-accessor-pairs instance-form &body body) - (let* ((temp (gensym)) - (accessors (do ((scan slot-accessor-pairs (cdr scan)) - (res)) - ((null scan) (nreverse res)) - (let ((entry (car scan))) - (ext:with-current-source-form (entry) - (unless (and (listp entry) - (= (length entry) 2)) - (error "Malformed WITH-ACCESSORS syntax.")) - (push `(,(car entry) (,(cadr entry) ,temp)) res)))))) - `(let ((,temp ,instance-form)) - (symbol-macrolet ,accessors ,@body)))) + ;; TODO: Maybe also compile the slow method function? + (typecase mf + (%leaf-method-function + (multiple-value-bind (new-fmf warningsp failurep) + (compile nil (fmf mf)) + (unless failurep + (setf (fmf mf) new-fmf)) + (values mf warningsp failurep))) + (%contf-method-function + (multiple-value-bind (new-contf warningsp failurep) + (compile nil (contf mf)) + (unless failurep + (setf (contf mf) new-contf)) + (values mf warningsp failurep)))))) diff --git a/src/lisp/kernel/clos/misc.lisp b/src/lisp/kernel/clos/misc.lisp new file mode 100644 index 0000000000..6ea666b23e --- /dev/null +++ b/src/lisp/kernel/clos/misc.lisp @@ -0,0 +1,55 @@ +(in-package "CLOS") + +;;; find-method-combination + +(defun make-method-combination (name compiler options) + (early-make-instance method-combination + :name name + :compiler compiler + :options options)) + +(defgeneric find-method-combination (generic-function + method-combination-type-name + method-combination-options)) + +(defmethod find-method-combination ((gf standard-generic-function) + name options) + (declare (ignore gf)) + (make-method-combination name + (or (search-method-combination name) + (error "~A does not name a method combination" + name)) + options)) + +;;; no-etc-method + +(defgeneric no-applicable-method (generic-function &rest arguments)) + +(defmethod no-applicable-method (gf &rest args) + (error 'no-applicable-method-error :generic-function gf :arguments args)) + +;;; FIXME: See method.lisp: This is not actually used normally. +(defgeneric no-next-method (generic-function method &rest arguments)) + +(defmethod no-next-method ((gf standard-generic-function) (method standard-method) + &rest args) + (declare (ignore gf)) + (error "In method ~A~%No next method given arguments ~A" method args)) + +;;; and a few other method combination things + +(defun method-combination-error (format-control &rest args) + ;; FIXME! We should emit a more detailed error! + (error "Method-combination error:~%~S" + (apply #'format nil format-control args))) + +(defun invalid-method-error (method format-control &rest args) + (error "Invalid method error for ~A~%~S" + method + (apply #'format nil format-control args))) + +;;; generic-function-name + +(defgeneric generic-function-name (generic-function)) +(defmethod generic-function-name ((gf standard-generic-function)) + (core:function-name gf)) diff --git a/src/lisp/kernel/clos/miss.lisp b/src/lisp/kernel/clos/miss.lisp new file mode 100644 index 0000000000..e39fe00046 --- /dev/null +++ b/src/lisp/kernel/clos/miss.lisp @@ -0,0 +1,509 @@ +(in-package #:clos) + +(defun miss (generic-function &rest arguments) + (check-gf-argcount generic-function (length arguments)) + ;; Update any invalid instances + (when (maybe-update-instances arguments) + (return-from miss (apply generic-function arguments))) + ;; OK, real miss. Do it. + (let* ((tracy (generic-function-tracy generic-function)) + (start-time (when tracy (get-internal-real-time)))) + (when tracy + (trace-miss-start generic-function tracy start-time arguments)) + (multiple-value-bind (outcome updatedp) + (update-call-history generic-function arguments) + (when updatedp (force-discriminator generic-function)) + (when tracy + (trace-miss-end generic-function tracy start-time arguments)) + (perform-outcome outcome arguments)))) + +;;; FIXME: breaking a few abstractions in this one +;;; Called from atomic expansion defined in cross-clasp. +(defun %gfclass-call-history-loc (gfclass) + (if (eq gfclass + (load-time-value (find-class 'standard-generic-function))) + #.(let ((slots (class-slots (find-class 'standard-generic-function)))) + (or (position 'call-history slots :key #'slot-definition-name) + (error "BUG: standard-generic-function lacks CALL-HISTORY slot?"))) + (or (position 'call-history (class-slots gfclass) :key #'slot-definition-name) + (error "BUG?: generic-function lacks CALL-HISTORY slot?")))) +(defun %generic-function-call-history (order generic-function) + (core:atomic-rack-read order (core:instance-rack generic-function) + (%gfclass-call-history-loc (class-of generic-function)))) +(defun generic-function-call-history (generic-function) + (%generic-function-call-history :relaxed generic-function)) +(defun (setf %generic-function-call-history) (new order generic-function) + (core:atomic-rack-write order new + (core:instance-rack generic-function) + (%gfclass-call-history-loc (class-of generic-function)))) +(defun (setf generic-function-call-history) (new generic-function) + (setf (%generic-function-call-history :relaxed generic-function) new)) +(defun cas-generic-function-call-history (order old new generic-function) + (core:cas-rack order old new (core:instance-rack generic-function) + (%gfclass-call-history-loc (class-of generic-function)))) + +(defun generic-function-tracy (gf) + (let ((gfclass (class-of gf))) + (if (eq gfclass + (load-time-value (find-class 'standard-generic-function))) + (with-early-accessors (standard-generic-function) + (mp:atomic (%generic-function-tracy gf))) + (let* ((slotd (find 'tracy (class-slots gfclass) + :key #'slot-definition-name)) + (location (slot-definition-location slotd))) + (mp:atomic (funcallable-standard-instance-access gf location)))))) +;;; used in telemetry +(defun (setf generic-function-tracy) (new gf) + (let ((gfclass (class-of gf))) + (if (eq gfclass + (load-time-value (find-class 'standard-generic-function))) + (with-early-accessors (standard-generic-function) + (setf (mp:atomic (%generic-function-tracy gf)) new)) + (let* ((slotd (find 'tracy (class-slots gfclass) + :key #'slot-definition-name)) + (location (slot-definition-location slotd))) + (setf (mp:atomic + (funcallable-standard-instance-access gf location)) + new))))) + +(defun trace-miss-start (gf tracy start-time arguments) + (declare (ignore start-time)) + (when (eq (car tracy) :profile-ongoing) ; report + (format *trace-output* "~&; Dispatch miss: (~a~{ ~s~})~%" + (core:low-level-standard-generic-function-name gf) arguments))) + +(defun trace-miss-end (gf tracy start-time arguments) + (declare (ignore gf)) + (let ((time-s (/ (float (- (get-internal-real-time) start-time)) + internal-time-units-per-second))) + (when (eq (car tracy) :profile-ongoing) ; report + (format *trace-output* "~&; ~fs overhead~%" time-s)) + (let (;; dumb hack - atomics don't know about cadr etc + (info (cdr tracy))) + (mp:atomic-incf (car info) time-s) + (mp:atomic-push arguments (cdr info))))) + +;;; stupid aliases used by funcallableInstance.cc +(defun dispatch-miss-va (gf vaslist) (apply #'miss gf vaslist)) +(defun dispatch-miss (gf &rest args) (apply #'miss gf args)) + +(defun force-discriminator (generic-function) + (set-funcallable-instance-function generic-function + (calculate-std-discriminating-function + generic-function))) + +(defun calculate-std-discriminating-function (generic-function) + (bytecode-interpreted-discriminator generic-function)) + +(defun invalidate-discriminating-function (generic-function) + (set-funcallable-instance-function + generic-function + (fallback-discriminator generic-function))) + +(defun fallback-discriminator (generic-function) + (or (%fallback-discriminator generic-function) + (setf (%fallback-discriminator generic-function) + (invalidated-discriminator-closure generic-function)))) + +(defun invalidated-discriminator-closure (generic-function) + (lambda (&rest args) + (declare (core:lambda-name invalidated-discriminator)) + ;; A GF being invalidated is orthogonal from the call history being valid. + ;; For example, when methods are added or removed, the call history is + ;; altered accordingly and the GF is invalidated, but the remaining call + ;; history entries are still valid. All GF invalidation does is force the + ;; GF to recompute its discriminator (which it does need to do, since e.g. + ;; its discriminating function predates the method changes). + ;; So what this closure conceptually needs to do is recompute the + ;; discriminator and then call it. It's just a mechanism for laziness. + (if (generic-function-call-history generic-function) + (progn (force-discriminator generic-function) + (apply generic-function args)) + ;; If we know the call history is empty, the discriminator will do + ;; nothing but miss immediately, and MISS will add to the call history + ;; if possible and implement the GF regardless. So we skip + ;; computing the discriminator and just call MISS directly. + (apply #'miss generic-function args)))) + +(defgeneric compute-discriminating-function (generic-function)) + +(defmethod compute-discriminating-function ((gf standard-generic-function)) + (fallback-discriminator gf)) + +(defun update-call-history (generic-function arguments) + (let (outcome updatedp) + (flet ((updater (call-history arguments) + (multiple-value-bind (noutcome new-entries) + (miss-info generic-function call-history arguments) + (setf outcome noutcome) + (cond ((null new-entries) + (setf updatedp nil) + call-history) + (t (setf updatedp t) + (union-entries call-history new-entries)))))) + (mp:atomic-update (generic-function-call-history generic-function) + #'updater arguments)) + (values outcome updatedp))) + +(defun union-entries (old-call-history new-entries) + ;; We do this instead of UNION because the new entries can contain duplicates. + (loop for entry in new-entries + do (pushnew entry old-call-history + :key #'car :test #'specializer-key-match)) + old-call-history) + +(defun check-gf-argcount (generic-function nargs) + (multiple-value-bind (min max) + (generic-function-min-max-args generic-function) + (when (or (< nargs min) (and max (> nargs max))) + (error 'core:wrong-number-of-arguments + :called-function generic-function :given-nargs nargs + :min-nargs min :max-nargs max)))) + +;;; returns minimum and maximum number of args allowed as values. +;;; max is NIL if infinite. +(defun generic-function-min-max-args (gf) + (multiple-value-bind (req opt restvar keyflag) ; rest are irrelevant + (core:process-lambda-list (generic-function-lambda-list gf) 'function) + (values (car req) (if (or restvar keyflag) nil (+ (car req) (car opt)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Update instances. The bulk of the code is in change.lisp, +;;; including the core UPDATE-INSTANCE function. +;;; + +;;; Try to update instances; return true iff any updates were performed. +(defun maybe-update-instances (arguments) + ;; this is SOME, which doesn't exist yet. + (let ((updatedp nil)) + (dolist (i arguments updatedp) + (when (maybe-update-instance i) + (setf updatedp t))))) + +(defun maybe-update-instance (instance) + (when (core:instancep instance) + (let ((instance-stamp (core:instance-stamp instance)) + ;; circularity note: stamp-for-instances is a generic function, + ;; but we're calling it on the instance's class rather than the instance. + ;; Therefore the recursion is ok unless the class _is_ the instance. + ;; This is only the case for STANDARD-CLASS, which is never obsolete. + (class-stamp (stamp-for-instances (core:instance-class instance)))) + (unless (= instance-stamp class-stamp) + (update-instance instance) + t)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Performing outcomes +;;; + +(defgeneric perform-outcome (outcome arguments)) + +(defmethod perform-outcome ((outcome optimized-slot-reader) arguments) + (let ((value (standard-location-access + (first arguments) (optimized-slot-accessor-index outcome)))) + (if (core:sl-boundp value) + value + (values (slot-unbound (optimized-slot-accessor-class outcome) + (first arguments) + (optimized-slot-accessor-slot-name outcome)))))) + +(defmethod perform-outcome ((outcome optimized-slot-writer) arguments) + (setf (standard-location-access + (second arguments) (optimized-slot-accessor-index outcome)) + (first arguments))) + +(defmethod perform-outcome ((outcome effective-method-outcome) arguments) + (apply (effective-method-outcome-function outcome) arguments)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Computing new call history entries. +;;; + +;;; Returns two values: the outcome to perform, and some new call history entries, +;;; or NIL if none should be added (e.g. due to eql specialization or another thread +;;; beating us to it.) +;;; This function has no side effects. DISPATCH-MISS is in charge of that. +(defun miss-info (generic-function call-history arguments) + (let ((argument-classes (mapcar #'class-of arguments))) + (multiple-value-bind (class-method-list ok) + (compute-applicable-methods-using-classes generic-function argument-classes) + (let* ((method-list (if ok + class-method-list + (compute-applicable-methods + generic-function arguments))) + (method-combination + (generic-function-method-combination generic-function)) + (final-methods (final-methods method-list argument-classes)) + (outcome (outcome + generic-function call-history method-combination + final-methods argument-classes))) + (values + outcome + ;; Can we memoize the call, i.e. add it to the call history? + (cond ((null final-methods) ; we avoid memoizing no-applicable-methods, + ;; as it's probably just a mistake, and will just pollute the call history. + ;; This assumption would be wrong if an application frequently called a gf + ;; wrong and relied on the signal behavior etc, + ;; but I find that possibility unlikely. + nil) + (ok ; classes are fine; use normal fastgf + (let* ((key-length + (length (generic-function-specializer-profile + generic-function))) + (key + (concatenate 'vector + (subseq argument-classes 0 key-length)) + ;; broken because deftype breaks on atomic specs + #+(or)(coerce (subseq argument-classes 0 key-length) 'vector))) + (if (call-history-find-key call-history key) + ;; another thread has already added this entry + nil + (list (cons key outcome))))) + ((eq (class-of generic-function) + #.(find-class 'standard-generic-function)) + (memoize-eql-specialized generic-function method-combination + call-history argument-classes)) + (t + ;; No more options: we just don't memoize. + ;; This only occurs with eql specializers, + ;; at least with the standard c-a-m/-u-c methods. + nil))))))) + +(defun specializer-key-match (key1 key2) + (declare (type simple-vector key1 key2)) + ;; Specializers can be compared by EQ, and so + (and (= (length key1) (length key2)) + (every #'eq key1 key2))) + +(defun call-history-find-key (call-history key) + (find key call-history :key #'car :test #'specializer-key-match)) + +(defun memoize-eql-specialized (generic-function method-combination call-history + argument-classes) + ;; we have a call with eql specialized arguments. + ;; We can still memoize this sometimes, as long as the gf is + ;; standard so we don't need to worry about MOP. + ;; What we need to watch out for it the following situation- + ;; (defmethod foo ((x (eql 'x))) ...) + ;; (foo 'y) + ;; If we memoize this naively, + ;; we'll put in an entry for class SYMBOL, + ;; and then if we call (foo 'x) later, + ;; it will go to that instead of properly missing the cache. + ;; EQL specializers play merry hob hell with the assumption of + ;; fastgf that as long as you treat all classes distinctly + ;; there are no problems with inheritance, basically. + ;; We deal with this by memoizing every combination of eql + ;; specializers for the given classes at once. + (loop for spec across (generic-function-specializer-profile generic-function) + for argument-class in argument-classes + collect (list* argument-class + (if (consp spec) ; eql specialized + (loop for obj in spec + when (typep obj argument-class) + collect (intern-eql-specializer obj)) + nil)) + into combo + finally (return + (loop for speclist in (specializers-combinate combo) + for key = (coerce speclist 'simple-vector) + for omethods = (compute-applicable-methods-using-specializers + generic-function speclist) + for methods = (final-methods omethods speclist) + for outcome = (outcome + generic-function call-history + method-combination methods + argument-classes) + for new-entry = (cons key outcome) + unless (call-history-find-key call-history key) + collect new-entry into new-entries + ;; This is necessary so that OUTCOME uses the cached + ;; outcomes we are generating as we go. + and do (push new-entry call-history) + finally (return new-entries))))) + +;;; Given a list of lists of specializers, expand out all combinations. +;;; So for example, ((a b) (c) (d e)) => ((a c d) (b c d) (a c e) (b c e)) +;;; in some arbitrary order. +(defun specializers-combinate (list) + (if (null list) + '(nil) + (loop with next = (specializers-combinate (rest list)) + for elem in (first list) + nconc (loop for rest in next collect (cons elem rest))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Computing final methods. +;;; + +(defun final-methods (methods specializers) + (loop for method in methods + collect (final-method method specializers))) + +(defun final-method (method specializers) + (let ((mc (class-of method))) + (cond ((and + (eq mc (load-time-value (find-class 'standard-reader-method))) + (let ((eslotd (effective-slotd-from-accessor-method + method (first specializers)))) + (and (standard-slotd-p eslotd) + (intern-effective-reader + method (slot-definition-location eslotd)))))) + ((and + (eq mc (load-time-value (find-class 'standard-writer-method))) + (let ((eslotd (effective-slotd-from-accessor-method + method (second specializers)))) + (and (standard-slotd-p eslotd) + (intern-effective-writer + method (slot-definition-location eslotd)))))) + (t method)))) + +(defun standard-slotd-p (slotd) + (eq (class-of slotd) + (load-time-value (find-class 'standard-effective-slot-definition)))) + +(defun effective-slotd-from-accessor-method (method class) + (let* ((direct-slot (accessor-method-slot-definition method)) + (direct-slot-name (slot-definition-name direct-slot)) + (effective-slot-defs (class-slots class)) + (slot (loop for effective-slot in effective-slot-defs + when (eq direct-slot-name (slot-definition-name effective-slot)) + return effective-slot))) + (when (null slot) + ;; should be impossible. one way I hit it: abnormal slots from boot.lisp + (error "BUG: cannot find effective slot for optimized accessor! class ~s, slot name ~s" + class direct-slot-name)) + slot)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Computing outcomes +;;; + + +;;; Look for an existing outcome, or compute a new one if nothing matches. +(defun outcome + (generic-function call-history method-combination methods actual-specializers) + (or (find-existing-outcome call-history methods) + (compute-outcome + generic-function method-combination methods actual-specializers))) + +;; We try to reuse effective method functions when possible. +;; This has two advantages: One, we avoid recompiling the same effective method multiple times. +;; Two, the code generator can understand the outcomes as identical and merge tests together. +;; Note that this being correct relies on an important property: that compute-effective-method +;; can in fact be memoized. This would not be the case if for example a method on it returns +;; different things for the same (by EQUAL) applicable method lists randomly or by time, or if +;; a relevant compute-effective-method method is added after a generic function already has +;; computed some. Or if a method combination does something similarly weird. +;; I'm not really worried about this because nobody defines methods on c-e-m anyway. +;; Also, this is a max O(mn) search, where m is the number of methods and n the length of call +;; history. It could be more efficient, but that makes it more involved to remove old entries +;; (with this scheme they're just removed with the call history entries). +(defun find-existing-outcome (call-history methods) + (loop for (ignore . outcome) in call-history + when (equal methods (outcome-methods outcome)) + return outcome)) + +(defun compute-outcome + (generic-function method-combination methods actual-specializers) + ;; Calculate the effective-method-function as well as an optimized one + ;; so that we can apply the e-m-f to the arguments if we need to debug the optimized version. + ;; This will hopefully be expanded, but for now, we can at least optimize standard slot accesses. + ;; For that, we must determine whether there is not a custom slot-value-using-class method we have to + ;; call. We use an approximation: if the class is a standard-class and the slotd is a + ;; standard-effective-slot-definition, methods on svuc can't be defined per + ;; "restrictions on portable programs" in MOP. We also discount the possibility of specializing on the + ;; "object" argument, because it makes things harder for us with not much gain for users. + ;; (Just specialize accessors or something.) + ;; The upshot of this is that slot accesses will never be inlined for custom metaclasses or slotds. + ;; The less approximate way would be to check s-v-u-c itself. That's easy enough on its own, + ;; but also implies that methods added or removed to s-v-u-c invalidate all relevant accessors, + ;; which is not. + (when (null methods) + ;; no-applicable-method is different from the no-required-method we'd get if we went below, + ;; so we pick that off first. + ;; Similarly to nrm below, we return a sort of fake emf. + (return-from compute-outcome + (make-effective-method-outcome + :methods nil + :form '(em-apply #'no-applicable-method .generic-function.) + :function (lambda (&rest args) + (apply #'no-applicable-method generic-function args))))) + (let* ((em (compute-effective-method generic-function method-combination methods)) + ;; will be NIL unless em = (call-method METHOD ()) or (call-method METHOD) + (method (and (consp em) + (eq (first em) 'call-method) + (consp (cdr em)) + (or (null (cddr em)) + (and (consp (cddr em)) + (null (cdddr em)) + (null (third em)))) + (second em)))) + (cond ((eq (class-of method) + (load-time-value (find-class 'effective-reader-method))) + (let ((slotd (accessor-method-slot-definition method)) + (location + (with-early-accessors (effective-accessor-method) + (effective-accessor-method-location method))) + (class (first actual-specializers))) + (make-optimized-slot-reader :index location :methods methods + :slot-name (slot-definition-name slotd) + :class class))) + ((eq (class-of method) + (load-time-value (find-class 'effective-writer-method))) + (let ((slotd (accessor-method-slot-definition method)) + (location + (with-early-accessors (effective-accessor-method) + (effective-accessor-method-location method))) + (class (second actual-specializers))) + (make-optimized-slot-writer :index location :methods methods + :slot-name (slot-definition-name slotd) + :class class))) + ;; NOTE: This case is not required if we always use :form and don't use the + ;; interpreter. See also, comment in define-method-combination.lisp. + ((and (consp em) (eq (first em) '%magic-no-required-method)) + (let ((group-name (second em))) + (make-effective-method-outcome + :methods methods :form em + :function (lambda (&rest args) + (apply #'no-required-method + generic-function group-name args))))) + (t + (make-effective-method-outcome + :methods methods :form em + :function (effective-method-function + em (gf-arg-info generic-function))))))) + +;;; Not usually actually used due to compute-outcome looking for it above. +(defmacro %magic-no-required-method (group-name) + `(em-apply #'no-required-method .generic-function. ',group-name)) + +(defun no-required-method (gf group-name &rest args) + (error "No applicable methods in required group ~a for generic function ~a~@ + Given arguments: ~a" + group-name (generic-function-name gf) args)) + +;;; This is used by effective-method-function +;;; to squeeze out a bit more performance by avoiding &va-rest when possible, +;;; which in turn allows methods to be called without APPLY. +(defun gf-arg-info (gf) + (multiple-value-bind (nreq max) (generic-function-min-max-args gf) + (append + ;; TODO: Would be kind of nice to get something like variable names. + (loop repeat nreq collect (gensym "REQ-ARG")) + (list (if (or (not max) (> max nreq)) + (gensym "REST") + nil))))) + + + + + + + + diff --git a/src/lisp/kernel/clos/outcome.lisp b/src/lisp/kernel/clos/outcome.lisp index 43f4a59726..744cb6c8ce 100644 --- a/src/lisp/kernel/clos/outcome.lisp +++ b/src/lisp/kernel/clos/outcome.lisp @@ -6,13 +6,33 @@ ;;; Outcomes -(defstruct (outcome (:type vector) :named) methods) -(defstruct (optimized-slot-reader (:type vector) (:include outcome) :named) - index slot-name class) -(defstruct (optimized-slot-writer (:type vector) (:include outcome) :named) - index slot-name class) -(defstruct (effective-method-outcome (:type vector) (:include outcome) :named) - (form nil) (function nil)) +(defclass outcome () + ((%methods :initarg :methods :reader outcome-methods))) +(defclass optimized-slot-accessor (outcome) + ((%index :initarg :index :reader optimized-slot-accessor-index) + (%slot-name :initarg :slot-name :reader optimized-slot-accessor-slot-name) + (%class :initarg :class :reader optimized-slot-accessor-class))) +(defclass optimized-slot-reader (optimized-slot-accessor) ()) +(defclass optimized-slot-writer (optimized-slot-accessor) ()) +(defclass effective-method-outcome (outcome) + ((%form :initarg :form :reader effective-method-outcome-form) + (%function :initarg :function :reader effective-method-outcome-function))) + +(defgeneric outcome-p (object)) +(defmethod outcome-p ((o outcome)) t) +(defmethod outcome-p ((o t)) nil) + +;;; the makers can use early-make-instance since these classes aren't +;;; extensible. +(defun make-optimized-slot-reader (&key methods index slot-name class) + (early-make-instance optimized-slot-reader + :methods methods :index index :slot-name slot-name :class class)) +(defun make-optimized-slot-writer (&key methods index slot-name class) + (early-make-instance optimized-slot-writer + :methods methods :index index :slot-name slot-name :class class)) +(defun make-effective-method-outcome (&key methods form function) + (early-make-instance effective-method-outcome + :methods methods :form form :function function)) (defun outcome= (outcome1 outcome2) (eq outcome1 outcome2)) ; thanks, caching! (in find-existing-outcome) diff --git a/src/lisp/kernel/clos/package.lisp b/src/lisp/kernel/clos/package.lisp index 4eb8c9f405..24439cec1c 100644 --- a/src/lisp/kernel/clos/package.lisp +++ b/src/lisp/kernel/clos/package.lisp @@ -10,20 +10,9 @@ ;;;; ;;;; See file '../Copyright' for full details. -;;;; clasp - changes approved May1 2013 +(in-package "CLOS") - -#-clasp -(defpackage "CLOS" - (:use "CL" "EXT") - (:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" - "SIMPLE-PROGRAM-ERROR")) - - -#+clasp (in-package "CLOS") -;;;#+clasp (use-package '(:CORE) :clos) - -#+clasp +(eval-when (:compile-toplevel :load-toplevel :execute) (export '(WITH-SLOTS WITH-ACCESSORS UPDATE-INSTANCE-FOR-REDEFINED-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS STANDARD-METHOD STANDARD SLOT-UNBOUND SLOT-MISSING SLOT-MAKUNBOUND @@ -36,13 +25,11 @@ CHANGE-CLASS CALL-METHOD ALLOCATE-INSTANCE ADD-METHOD )) -#+clasp (export '(metaobject specializer UPDATE-DEPENDENT SLOT-DEFINITION-LOCATION CLASS-PRECEDENCE-LIST - +THE-FUNCALLABLE-STANDARD-CLASS+ CLASS-SLOTS SPECIALIZER MAKE-METHOD-LAMBDA @@ -53,7 +40,6 @@ MAP-DEPENDENTS STANDARD-READER-METHOD SLOT-DEFINITION-TYPE - STD-COMPUTE-EFFECTIVE-METHOD GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER EQL-SPECIALIZER COMPUTE-EFFECTIVE-SLOT-DEFINITION @@ -63,13 +49,10 @@ ENSURE-GENERIC-FUNCTION-USING-CLASS SLOT-DEFINITION-INITARGS METAOBJECT - NEED-TO-MAKE-LOAD-FORM-P COMPUTE-SLOTS - STD-COMPUTE-APPLICABLE-METHODS-USING-CLASSES GENERIC-FUNCTION-METHOD-COMBINATION CLASS-PROTOTYPE FUNCALLABLE-STANDARD-CLASS - STD-COMPUTE-APPLICABLE-METHODS SLOT-DEFINITION SET-FUNCALLABLE-INSTANCE-FUNCTION ACCESSOR-METHOD-SLOT-DEFINITION @@ -86,7 +69,6 @@ COMPUTE-DEFAULT-INITARGS FUNCALLABLE-STANDARD-INSTANCE-ACCESS READER-METHOD-CLASS - +THE-STD-CLASS+ SPECIALIZER-DIRECT-METHODS REMOVE-DEPENDENT DIRECT-SLOT-DEFINITION @@ -111,7 +93,6 @@ SLOT-DEFINITION-READERS ADD-DEPENDENT EXTRACT-LAMBDA-LIST - +THE-CLASS+ COMPUTE-CLASS-PRECEDENCE-LIST DIRECT-SLOT-DEFINITION-CLASS EFFECTIVE-SLOT-DEFINITION @@ -122,7 +103,6 @@ STANDARD-INSTANCE-ACCESS COMPUTE-APPLICABLE-METHODS-USING-CLASSES GENERIC-FUNCTION-METHOD-CLASS - +THE-STANDARD-CLASS+ FORWARD-REFERENCED-CLASS SLOT-BOUNDP-USING-CLASS INTERN-EQL-SPECIALIZER @@ -131,25 +111,24 @@ DOCSTRING STANDARD-SLOT-DEFINITION REMOVE-DIRECT-METHOD - +THE-T-CLASS+ CLASS-DIRECT-DEFAULT-INITARGS SLOT-DEFINITION-INITFUNCTION SLOT-DEFINITION-INITFORM class-source-position) ) -#+clasp + (export '(satiate satiate-initialization apply-method )) -#+clasp (export '(no-applicable-method-error)) -#+clasp -(export '(disassemble-discriminator)) +(export '(disassemble-discriminator + compilediscriminating-function ; also exported by runtime + compile-all-generic-functions)) -#+clasp (export '(start-profiling stop-profiling report-profiling profiling-data with-profiling)) +) ; eval-when diff --git a/src/lisp/kernel/clos/print.lisp b/src/lisp/kernel/clos/print.lisp index 6cc1f20371..3c50e18b8e 100644 --- a/src/lisp/kernel/clos/print.lisp +++ b/src/lisp/kernel/clos/print.lisp @@ -1,204 +1,15 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi. -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. +(in-package #:clos) -(in-package "CLOS") +(defgeneric print-object (object stream)) -;;; ---------------------------------------------------------------------- -;;; Load forms -;;; -;;; Clasp extends the ANSI specification by allowing to use -;;; MAKE-LOAD-FORM on almost any kind of lisp object. -;;; But it doesn't necessarily use those methods in the compiler. see cmpliteral.lisp -;;; +(defmethod print-object (object stream) + (core::write-ugly-object object stream)) -(defun make-load-form-saving-slots (object &key slot-names environment) - ;; The ALLOCATE-INSTANCE form here is treated magically by the file - ;; compiler; see cmp/cmpliteral.lisp ALLOCATE-INSTANCE-FORM-P - (declare (ignore environment)) - (do* ((class (class-of object)) - (initialization (list object 'load-instance)) - (slots (class-slots class) (cdr slots))) - ((endp slots) - (values `(allocate-instance ,class) (nreverse initialization))) - (let* ((slot (first slots)) - (slot-name (slot-definition-name slot))) - (when (or (and (null slot-names) - (eq (slot-definition-allocation slot) :instance)) - (member slot-name slot-names)) - (when (slot-boundp object slot-name) - (push `',slot-name initialization) - (push `',(slot-value object slot-name) initialization)))))) - -;;; This function basically exists so that cmpliteral can handle -;;; make-load-form-saving-slots forms without compiling them recursively. -;;; We used to use a progn of setf slot-values, but that's more complex. -(defun load-instance (instance &rest slot-names-values) - (loop for (name value) on slot-names-values by #'cddr - do (setf (slot-value instance name) value)) - (values)) - -(defun need-to-make-load-form-p (object env) - "Return T if the object cannot be externalized using the lisp -printer and we should rather use MAKE-LOAD-FORM." - (declare (ignore env)) - (let ((*load-form-cache* nil)) - (declare (special *load-form-cache*)) - (labels ((recursive-test (object) - (loop - ;; For simple, atomic objects we just return NIL. There is no need to - ;; call MAKE-LOAD-FORM on them - (when (typep object '(or character number symbol pathname string bit-vector)) - (return nil)) - ;; For complex objects we set up a cache and run through the - ;; objects content looking for data that might require - ;; MAKE-LOAD-FORM to be externalized. The cache is used to - ;; solve the problem of circularity and of EQ references. - (unless *load-form-cache* - (setf *load-form-cache* (make-hash-table :size 128 :test #'eq))) - (when (gethash object *load-form-cache*) - (return nil)) - (setf (gethash object *load-form-cache*) t) - (cond ((arrayp object) - (unless (subtypep (array-element-type object) '(or character number)) - (dotimes (i (array-total-size object)) - (recursive-test (row-major-aref object i)))) - (return nil)) - ((consp object) - (recursive-test (car object)) - (setf object (rest object))) - (t - (throw 'need-to-make-load-form t)))))) - (catch 'need-to-make-load-form - (recursive-test object) - nil)))) - -(defmethod make-load-form ((object t) &optional env) - (flet ((maybe-quote (object) - (if (or (consp object) (symbolp object)) - (list 'quote object) - object))) - (unless (need-to-make-load-form-p object env) - (return-from make-load-form (maybe-quote object))) - (typecase object - (array - (let ((init-forms '())) - (values `(make-array ',(array-dimensions object) - :element-type ',(array-element-type object) - :adjustable ',(adjustable-array-p object) - :initial-contents - ',(loop for i from 0 below (array-total-size object) - collect (let ((x (row-major-aref object i))) - (if (need-to-make-load-form-p x env) - (progn (push `(setf (row-major-aref ,object ,i) ',x) - init-forms) - 0) - x)))) - (and init-forms `(progn ,@init-forms))))) - (cons - (values `(cons ,(maybe-quote (car object)) nil) - (and (rest object) `(rplacd ,(maybe-quote object) - ,(maybe-quote (cdr object)))))) - (t - (no-make-load-form object))))) - -(defmethod make-load-form ((object standard-object) &optional environment) - (declare (ignore environment)) - (no-make-load-form object)) - -(defmethod make-load-form ((object structure-object) &optional environment) - (declare (ignore environment)) - (no-make-load-form object)) - -(defmethod make-load-form ((object condition) &optional environment) - (declare (ignore environment)) - (no-make-load-form object)) - -(defun no-make-load-form (object) - #+(or)(declare (optimize (debug 3))) - (error "No adequate specialization of MAKE-LOAD-FORM for an object of type ~a" - (type-of object))) - -(defmethod make-load-form ((class class) &optional environment) - ;; The find-class form here is treated magically by the file compiler- - ;; see cmp/cmpliteral.lisp FIND-CLASS-FORM-P - (declare (ignore environment)) - (let ((name (class-name class))) - (if (and name (eq (find-class name) class)) - `(find-class ',name) - (error "Cannot externalize anonymous class ~A" class)))) - -(defmethod make-load-form ((package package) &optional environment) - (declare (ignore environment)) - `(find-package ,(package-name package))) - -;;; Extension. (Allowed per CLHS 3.2.4.3.) -;;; This is required for a lot of satiation.lisp to function. -(defmethod make-load-form ((method method) &optional environment) - (declare (ignore environment)) - ;; FIXME: Should spruce up cmpliteral so it doesn't compile calls with - ;; all constant arguments. - `(load-method - ',(generic-function-name (method-generic-function method)) - ',(method-qualifiers method) - ',(method-specializers method))) - -;;; Also an extension, to support the above. -(defmethod make-load-form ((spec eql-specializer) &optional environment) - (declare (ignore environment)) - `(intern-eql-specializer ',(eql-specializer-object spec))) - -(defun class-slotd-form (slot-name class &optional earlyp) - (let ((form - `(or (find ',slot-name (class-slots ,class) :key #'slot-definition-name) - (error "Probably a BUG: slot ~a in ~a stopped existing between compile and load" - ',slot-name ,class)))) - (if earlyp - `(with-early-accessors (+standard-class-slots+ +slot-definition-slots+) - (flet ((slot-definition-name (sd) (slot-definition-name sd))) ; macro, so. - ,form)) - form))) - -(defmethod make-load-form ((method effective-reader-method) - &optional environment) - (declare (ignore environment)) - (let ((orig (effective-accessor-method-original method))) - `(,(if (eq (class-of orig) (find-class 'standard-reader-method)) - 'early-intern-effective-reader - 'intern-effective-reader) - ',orig - ',(effective-accessor-method-location method)))) - -(defmethod make-load-form ((method effective-writer-method) - &optional environment) - (declare (ignore environment)) - (let ((orig (effective-accessor-method-original method))) - `(,(if (eq (class-of orig) (find-class 'standard-writer-method)) - 'early-intern-effective-writer - 'intern-effective-writer) - ',orig - ',(effective-accessor-method-location method)))) - -;;; ---------------------------------------------------------------------- -;;; Printing -;;; ---------------------------------------------------------------------- - -;;; General method was moved up to fixup.lisp -#+(or) -(defmethod print-object ((instance t) stream) - (print-unreadable-object (instance stream) - (let ((*package* (find-package "CL"))) - (format stream "~S" - (class-name (si:instance-class instance))))) - instance) +(defmacro print-unreadable-object ((object stream &key type identity) &body body) + ;; this function is defined later in iolib.lisp. + `(core::%print-unreadable-object ,object ,stream ,type ,identity + ,(when body + `(lambda () ,@body)))) (defmethod print-object ((class class) stream) (print-unreadable-object (class stream :type t) @@ -210,20 +21,45 @@ printer and we should rather use MAKE-LOAD-FORM." (write (generic-function-name gf) :stream stream)) gf) +(defun %print-method (m stream) + (print-unreadable-object (m stream :type t) + ;; FIXME: Just use FORMAT + (princ (let ((gf (method-generic-function m))) + (if gf + (generic-function-name gf) + 'UNNAMED)) + stream) + (loop for q in (method-qualifiers m) + do (write-char #\Space stream) + (prin1 q stream)) + (write-char #\Space stream) + (prin1 (loop for spec in (method-specializers m) + collect (typecase spec + (class (class-name spec)) + (eql-specializer + `(eql ,(eql-specializer-object spec))) + (t spec))) + stream))) + (defmethod print-object ((m standard-method) stream) (print-unreadable-object (m stream :type t) - (format stream "~A ~{~S ~}~S" - (let ((gf (method-generic-function m))) - (if gf - (generic-function-name gf) - 'UNNAMED)) - (method-qualifiers m) - (loop for spec in (method-specializers m) - collect (cond ((and (classp spec) - (class-name spec))) - ((typep spec 'eql-specializer) - `(eql ,(eql-specializer-object spec))) - (t spec))))) + ;; FIXME: Just use FORMAT + (princ (let ((gf (method-generic-function m))) + (if gf + (generic-function-name gf) + 'UNNAMED)) + stream) + (loop for q in (method-qualifiers m) + do (write-char #\Space stream) + (prin1 q stream)) + (write-char #\Space stream) + (prin1 (loop for spec in (method-specializers m) + collect (typecase spec + (class (class-name spec)) + (eql-specializer + `(eql ,(eql-specializer-object spec))) + (t spec))) + stream)) m) (defmethod print-object ((s slot-definition) stream) @@ -241,8 +77,12 @@ printer and we should rather use MAKE-LOAD-FORM." (write (eql-specializer-object es) :stream stream)) es) +(defmethod print-object ((object standard-object) stream) + (print-unreadable-object (object stream :type t :identity t)) + object) + (defmethod print-object ((obj structure-object) stream) - (let* ((class (si:instance-class obj)) + (let* ((class (class-of obj)) (slotds (class-slots class))) (when (and ;; to fix ansi-tests PRINT-LEVEL.8 & PRINT-LEVEL.9 ;; printing a struct w/o slots @@ -264,7 +104,7 @@ printer and we should rather use MAKE-LOAD-FORM." (when (>= i limit) (write-string " ..." stream) (return)) - (setq sv (si:instance-ref obj i)) + (setq sv (standard-instance-access obj i)) (unless (eq sv (core:unbound)) ;; fix bug where symbols like :FOO::BAR are printed (write-string " " stream) @@ -278,97 +118,3 @@ printer and we should rather use MAKE-LOAD-FORM." (prin1 sv stream)))) (write-string ")" stream) obj)) - -(defmethod print-object ((object standard-object) stream) - (print-unreadable-object (object stream :type t :identity t)) - object) - -(defun ext::float-nan-string (x) - (when *print-readably* - (error 'print-not-readable :object x)) - (cdr (assoc (type-of x) - '((single-float . "#") - (double-float . "#") - (long-float . "#") - (short-float . "#"))))) - -(defun ext::float-infinity-string (x) - (when (and *print-readably* (null *read-eval*)) - (error 'print-not-readable :object x)) - (let* ((negative-infinities '((single-float . - "#.ext:single-float-negative-infinity") - (double-float . - "#.ext:double-float-negative-infinity") - (long-float . - "#.ext:long-float-negative-infinity") - (short-float . - "#.ext:short-float-negative-infinity"))) - (positive-infinities '((single-float . - "#.ext:single-float-positive-infinity") - (double-float . - "#.ext:double-float-positive-infinity") - (long-float . - "#.ext:long-float-positive-infinity") - (short-float . - "#.ext:short-float-positive-infinity"))) - (record (assoc (type-of x) - (if (plusp x) positive-infinities negative-infinities)))) - (unless record - (error "Not an infinity")) - (cdr record))) - -;;; ---------------------------------------------------------------------- -;;; Describe -;;; ---------------------------------------------------------------------- - -(defmethod describe-object ((obj t) (stream t)) - (format stream "~%~S is an instance of class ~S" - obj (class-name (class-of obj))) - obj) - -;;; ---------------------------------------------------------------------- -;;; Clasp specific methods - -(defmethod cl:print-object ((object core:general) stream) - (if (and *print-readably* (core:fieldsp object)) - (progn - (write-string "#i" stream) - (write (cons (class-name (class-of object)) (core:encode object)) :stream stream)) - (call-next-method))) - -(in-package :core) - -(defmacro field (node name slot-access) - (let ((valgs (gensym))) - `(case (core:record-stage ,node) - ((:initializing :saving) - (core:field-write ,node ,name ,slot-access)) - (:reading - (let ((,valgs (core:field-read ,node ,name ))) - (setf ,slot-access ,valgs))) - (:patching - (let ((,valgs (core:field-patch ,node ,name ,slot-access))) - (setf ,slot-access ,valgs)))))) - -(defmacro with-record-serialize-slots ((node) &rest name-slot-access-pairs) - (let ((valgs (gensym))) - `(case (core:record-stage ,node) - ((:initializing :saving) - ,@(loop for entry in name-slot-access-pairs - for name = (car entry) - for slot-access = (cadr entry) - collect `(core:field-write ,node ,name ,slot-access))) - (:reading - ,@(loop for entry in name-slot-access-pairs - for name = (car entry) - for slot-access = (cadr entry) - collect `(let ((,valgs (core:field-read ,node ,name ))) - (setf ,slot-access ,valgs)))) - (:patching - ,@(loop for entry in name-slot-access-pairs - for name = (car entry) - for slot-access = (cadr entry) - collect `(let ((,valgs (core:field-patch ,node ,name ,slot-access))) - (setf ,slot-access ,valgs))))))) -(export '(field with-record-serialize-slots)) - diff --git a/src/lisp/kernel/clos/satiation.lisp b/src/lisp/kernel/clos/satiation.lisp index b9de6c406a..99c0aafb68 100644 --- a/src/lisp/kernel/clos/satiation.lisp +++ b/src/lisp/kernel/clos/satiation.lisp @@ -1,237 +1,56 @@ (in-package "CLOS") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Satiation of generic functions to start fastgf -;;; -;;; Ideas copied from Sicl/Code/CLOS/satiation.lisp -;;; - -;;; Essentially, for some gfs we need in a consistent state for the system to work, -;;; during boot we fake a call history so that they can be called without invoking -;;; gfs such as themselves that haven't yet been placed in a working state. -;;; A fake call history is also nice for efficiency - if we install an anticipated -;;; history beforehand, we can avoid repeatedly compiling new discriminators. - -;;; In order to do things both at boot and in an exported interface, we duplicate -;;; some code. Unfortunate but I don't see a good way to avoid it. - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; UTILITY -;;; +;;; GENERAL SATIATION INTERFACE + +;;; Main entry point +;;; Actually quite simple. +;;; Possible improvement: Put in some handler-case stuff to reduce any errors to +;;; warnings, given that this is just for optimization. +(defun satiate (generic-function &rest lists-of-specializer-designators) + "Prepare a generic function so that its discriminating function will not have +to be recompiled very much when called with pre-specified specializers. +GENERIC-FUNCTION is a generic function. LISTS-OF-SPECIALIZER-DESIGNATORS is a +list of lists of specializer designator. Each inner list should have as many +elements as the generic function has specializable (i.e. required) arguments. +A specializer designator is either a specializer, or a symbol naming a class, or +a list (EQL object) - just like DEFMETHOD." + (loop with method-combination = (generic-function-method-combination generic-function) + with old-history = (generic-function-call-history generic-function) + for list in lists-of-specializer-designators + for specializers = (mapcar #'coerce-specializer-designator list) + for applicable-methods + = (compute-applicable-methods-using-specializers generic-function specializers) + for outcome = (or (find-existing-outcome history applicable-methods) + (outcome generic-function old-history method-combination + applicable-methods specializers)) + collect (cons (coerce specializers 'simple-vector) outcome) into history + finally (append-generic-function-call-history generic-function history) + (compile-discriminating-function generic-function))) + +(defun coerce-specializer-designator (specializer-designator) + (etypecase specializer-designator + (specializer specializer-designator) + (symbol (find-class specializer-designator)) + ((cons (eql eql) (cons t null)) ; (eql thing) + (intern-eql-specializer (second specializer-designator))))) ;;; Add a portion of call history into a gf's existing call history. ;;; If any entry to be added duplicates an existing entry, the new entry prevails. (defun append-generic-function-call-history (generic-function new-entries) - (loop for call-history = (mp:atomic (safe-gf-call-history generic-function)) - ;; By keeping the new entry, remove-if will return immediately in the - ;; usual case that the existing history is empty. - for cleaned-call-history = (remove-if (lambda (entry) - (call-history-find-key - new-entries (car entry))) - call-history) - for new-history = (append new-entries cleaned-call-history) - for exchange = (mp:cas (safe-gf-call-history generic-function) - call-history new-history) - until (eq exchange call-history))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; BOOT-TIME SATIATION - -;;; Satiation should occur before any generic function calls are performed, and -;;; involve no generic function calls. - -;;; effective-slot-from-accessor-method, but without gfs -(defun early-effective-slot-from-accessor-method (method class) - (with-early-accessors (+standard-accessor-method-slots+ - +slot-definition-slots+ - +class-slots+) - (let* ((direct-slot-definition (accessor-method-slot-definition method)) - (direct-slot-name (slot-definition-name direct-slot-definition)) - (slot (loop for effective-slot in (class-slots class) - when (eq direct-slot-name (slot-definition-name effective-slot)) - return effective-slot))) - (if slot - slot - (error "Bug during satiation: Could not find effective slot definition for ~a" - direct-slot-name))))) - -;;; Used by add-satiation-entries to compute an effective method without going through -;;; compute-effective-method and method-combinations, which call a few gfs. -;;; Standard method combination only. No qualifiers allowed (checks this). -;;; It could be improved to handle them; I just don't think we need to satiate anything -;;; that uses qualified methods. -;;; Does handle accessor methods so that they're fast, yet. -;;; FIXME: Duplication of other code, in this case compute-outcome, sucks. -(defun early-compute-outcome (methods specializers) - (with-early-accessors (+standard-method-slots+ - +slot-definition-slots+) - (mapc (lambda (method) - (when (method-qualifiers method) - ;; Hopefully the write won't trigger a recursive error...? - (error "Bug during satiation: method to be satiated ~a has qualifiers" - method))) - methods) - ;; Methods are sorted by std-compute-applicable-methods-using-classes, so - ;; we're just doing (call-method ,first (,@rest)) - (let ((first (first methods))) - ;; realistically, anything we satiate is going to be standard classes, but - ;; paranoia doesn't hurt here. - (cond ((optimizable-reader-method-p first) - (let* ((class (first specializers)) - (slot (early-effective-slot-from-accessor-method - first (first specializers)))) - (make-optimized-slot-reader :index (slot-definition-location slot) - :slot-name (slot-definition-name slot) - :methods (list first) - :class class))) - ((optimizable-writer-method-p first) - (let* ((class (second specializers)) - (slot (early-effective-slot-from-accessor-method - first (first specializers)))) - (make-optimized-slot-writer :index (slot-definition-location slot) - :slot-name (slot-definition-name slot) - :methods (list first) - :class class))) - (t ; general effective method function - (let ((form `(call-method ,first (,@(rest methods))))) - (make-effective-method-outcome - :function (early-effective-method-function form) - :form form - :methods methods))))))) - -;;; Add fictitious call history entries. -(defun add-satiation-entries (generic-function lists-of-specializers) - (let ((new-entries - (loop for specific-specializers in lists-of-specializers - for methods = (std-compute-applicable-methods-using-classes - generic-function specific-specializers) - ;; Simple cache to avoid duplicate outcomes. - for cached-outcome - = (cdr (assoc methods outcome-cache :test #'equal)) - ;; Everything in early satiation uses standard method combination. - for outcome = (or cached-outcome - (early-compute-outcome - methods specific-specializers)) - unless cached-outcome - collect (cons methods outcome) - into outcome-cache - collect (cons (coerce specific-specializers 'vector) outcome)))) - (append-generic-function-call-history generic-function new-entries))) - -(defun early-satiate (generic-function &rest lists-of-specializers) - ;; Many generic functions at startup will be missing specializer-profile at startup - ;; so we compute one here using the number of required arguments in the lambda-list. - ;; The call-history may be incorrect because of improper initialization as - ;; clos starts up - so lets wipe it out and then satiate it. - (gf-log "Starting satiate-generic-function%N") - ;; Wipe out the call-history and satiate it using methods - (gf-log "About to set call history%N") - (erase-generic-function-call-history generic-function) - (add-satiation-entries generic-function lists-of-specializers) - ;; Now when the function is called the discriminating-function will be invalidated-dispatch-function - ;; This well set up the real discriminating function. This shouldn't involve a dispatch miss, and - ;; no generic-function calls (other than the one for the actual call, of course). - (invalidate-discriminating-function generic-function)) - -;;; Satiate the minimum set of functions to make the system work. -;;; Essentially those that are used to compute new call history entries in the full system. -(defun satiate-minimal-generic-functions () - (macrolet ((satiate-one (gf-name &body lists-of-class-names) - `(prog2 - (gf-log ,(concatenate 'string "Satiating " (string gf-name) "%N")) - (early-satiate - (fdefinition ',gf-name) - ,@(loop for list in lists-of-class-names - collect `(list ,@(loop for name in list - collect `(find-class ',name))))) - (gf-log ,(concatenate 'string "Done satiating " (string gf-name) "%N"))))) - (satiate-one class-slots - (standard-class) - (funcallable-standard-class)) - ;; instance updates we shouldn't need to satiate... - (satiate-one compute-applicable-methods-using-classes - (standard-generic-function cons) - (standard-generic-function null)) ; nulls may not be necessary, but no big. - (satiate-one compute-applicable-methods - (standard-generic-function cons) - (standard-generic-function null)) - (satiate-one compute-effective-method - (standard-generic-function method-combination cons) - (standard-generic-function method-combination null)) - ;; We should satiate the method combination accessors, but we actually - ;; just use early accessors at the moment... which is probably wrong (FIXME?) - ;; Method readers are used by make-effective-accessor-method. - (macrolet ((satiate-method-reader (name) - `(satiate-one ,name - (standard-method) - (standard-reader-method) - (standard-writer-method) - (effective-reader-method) - (effective-writer-method)))) - (satiate-method-reader method-generic-function) - (satiate-method-reader method-lambda-list) - (satiate-method-reader method-specializers) - (satiate-method-reader method-qualifiers) - (satiate-method-reader method-function) - (satiate-method-reader method-source-position) - (satiate-method-reader method-plist) - (satiate-method-reader method-keywords) - (satiate-method-reader method-allows-other-keys-p) - (satiate-method-reader leaf-method-p)) - (satiate-one accessor-method-slot-definition - (standard-reader-method) (standard-writer-method)) - (satiate-one slot-definition-allocation - (standard-direct-slot-definition) - (standard-effective-slot-definition)) - (satiate-one slot-definition-name - (standard-direct-slot-definition) - (standard-effective-slot-definition)) - (satiate-one slot-definition-location - (standard-direct-slot-definition) - (standard-effective-slot-definition)) - (satiate-one generic-function-name - (standard-generic-function)) - (satiate-one generic-function-method-combination - (standard-generic-function)) - ;; This one is needed for the initial specializer profile computation in fixup. - ;; (i.e., it's called by initialize-generic-function-specializer-profile) - (satiate-one generic-function-lambda-list - (standard-generic-function)) - (satiate-one leaf-method-p - (standard-method) - (standard-reader-method) (standard-writer-method)))) - -;;; Used in the make-load-form for METHOD. -;;; It's like find-method, but always signals an error, and only accepts -;;; actual specializers. -(defun load-method (gf-name qualifiers specializers) - (let ((gf (fdefinition gf-name))) - (if (eq (class-of gf) (find-class 'standard-generic-function)) - ;; Get method without calling generic functions, in case we're - ;; loading a CLOS satiated definition. - (with-early-accessors (+eql-specializer-slots+ - +standard-generic-function-slots+ - +standard-method-slots+) - (when (/= (length specializers) - (length (generic-function-argument-precedence-order gf))) - (error - "The specializers list~%~A~%does not match the number of required arguments in ~A" - specializers (core:low-level-standard-generic-function-name gf))) - (loop for method in (generic-function-methods gf) - when (and (equal qualifiers (method-qualifiers method)) - ;; We can use EQ because it obviously works for classes, - ;; and eql specializers have an internment mechanism. - (every #'eq specializers (method-specializers method))) - do (return-from load-method method)) - (error "There is no method on the generic function ~S that agrees on qualifiers ~S and specializers ~S" - (core:low-level-standard-generic-function-name gf) - qualifiers specializers)) - (find-method gf qualifiers specializers t)))) - + (mp:atomic-update (generic-function-call-history generic-function) + (lambda (history new-entries) + (append new-entries + (remove-if (lambda (entry) + (call-history-find-key new-entries + (car entry))) + history))) + new-entries)) + +;;; Compile time discrimination is on the backburner until I decide how to make it +;;; work in cross-clasp. +#| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; DISCRIMINATING FUNCTIONS IN COMPILE-FILE @@ -338,38 +157,6 @@ :inline-effective-methods 'cl:require :generic-function-name name))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; GENERAL SATIATION INTERFACE - -;;; Main entry point -;;; Actually quite simple. -;;; Possible improvement: Put in some handler-case stuff to reduce any errors to -;;; warnings, given that this is just for optimization. -(defun satiate (generic-function &rest lists-of-specializer-designators) - "Prepare a generic function so that its discriminating function will not have -to be recompiled very much when called with pre-specified specializers. -GENERIC-FUNCTION is a generic function. LISTS-OF-SPECIALIZER-DESIGNATORS is a -list of lists of specializer designator. Each inner list should have as many -elements as the generic function has specializable (i.e. required) arguments. -A specializer designator is either a specializer, or a symbol naming a class, or -a list (EQL object) - just like DEFMETHOD." - (flet ((coerce-specializer-designator (specializer-designator) - (etypecase specializer-designator - (specializer specializer-designator) - (symbol (find-class specializer-designator)) - ((cons (eql eql) (cons t null)) ; (eql thing) - (intern-eql-specializer (second specializer-designator)))))) - (loop with method-combination = (generic-function-method-combination generic-function) - for list in lists-of-specializer-designators - for specializers = (mapcar #'coerce-specializer-designator list) - for applicable-methods - = (compute-applicable-methods-using-specializers generic-function specializers) - for outcome = (compute-outcome generic-function method-combination - applicable-methods specializers) - collect (cons (coerce specializers 'simple-vector) outcome) into history - finally (append-generic-function-call-history generic-function history)))) - ;;; The less simple part is doing things at compile-time. ;;; We can't put discriminating functions into FASLs because they include the class ;;; stamps, which are hard to synchronize between compile- and load-time. @@ -430,212 +217,4 @@ a list (EQL object) - just like DEFMETHOD." gf ,(if (eq cmp:*default-output-type* :bytecode) `(calculate-fastgf-dispatch-function gf) (compile-time-discriminator generic-function call-history))))))) - -;;; Exported auxiliary version for the common case of wanting to skip recompilations -;;; of shared-initialize etc. Just pass it a list of class designators and it'll fix -;;; up the CLOS initialization functions. -(defun satiate-initialization (&rest class-designators) - (let ((tail (mapcar #'list class-designators))) - (apply #'satiate #'initialize-instance tail) - (apply #'satiate #'reinitialize-instance tail)) - (apply #'satiate #'shared-initialize - (loop for classd in class-designators - collect (list classd 'symbol) - collect (list classd 'cons) - collect (list classd 'null)))) - -(define-compiler-macro satiate-initialization (&whole form &rest classdfs &environment env) - (if (every (lambda (classdf) (constantp classdf env)) classdfs) - (let* ((classds (mapcar (lambda (classdf) (ext:constant-form-value classdf env)) classdfs)) - (tail (mapcar #'list classds))) - `(progn - (%satiate initialize-instance ,@tail) - (%satiate reinitialize-instance ,@tail) - (%satiate shared-initialize - ,@(loop for classd in classds - collect `(,classd symbol) - collect `(,classd cons) - collect `(,classd null))))) - form)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; SATIATION OF SPECIFIC CLOS FUNCTIONS -;;; -;;; Used in boot - -;;; This macro is a holdover from the older satiation mechanism, which had to do -;;; more special things early on. I'm keeping it at least for now in case we -;;; need to go back to doing that kind of thing. - -(defmacro %early-satiate (generic-function-name &rest lists-of-specializer-names) - `(%satiate ,generic-function-name ,@lists-of-specializer-names)) - -(defmacro satiate-clos () - ;; This is the ahead-of-time satiation. If we get as much as possible we can speed startup a bit. - (labels ((readers-from-slot-description (slot-description) - (loop for (key arg) on (cdr slot-description) by #'cddr - when (eq key :reader) - collect arg - when (eq key :accessor) - collect arg)) - (satiate-readers (slot-descriptions specializerses) - (loop for slotdesc in slot-descriptions - for readers = (readers-from-slot-description slotdesc) - nconc (loop for reader in readers - collect `(%early-satiate ,reader ,@specializerses))))) - `(progn - ,@(satiate-readers +specializer-slots+ '((eql-specializer) - (standard-class) (funcallable-standard-class) - (structure-class) (built-in-class) (core:cxx-class) - (core:derivable-cxx-class) (core:clbind-cxx-class))) - ;; eql-specializer has only the one special slot, so we just do it manually. - (%early-satiate eql-specializer-object (eql-specializer)) - ,@(satiate-readers (set-difference +class-slots+ +specializer-slots+) - '((standard-class) (funcallable-standard-class) - (structure-class) (built-in-class) (core:cxx-class) - (core:derivable-cxx-class) (core:clbind-cxx-class))) - ,@(satiate-readers +standard-method-slots+ '((standard-method) - (standard-reader-method) (standard-writer-method) - (effective-reader-method) (effective-writer-method))) - ,@(satiate-readers (set-difference +standard-accessor-method-slots+ +standard-method-slots+) - '((standard-reader-method) (standard-writer-method) - (effective-reader-method) (effective-writer-method))) - ,@(satiate-readers +slot-definition-slots+ - '((standard-direct-slot-definition) (standard-effective-slot-definition))) - ,@(satiate-readers +standard-generic-function-slots+ - '((standard-generic-function))) - (%early-satiate generic-function-name (standard-generic-function)) - (%early-satiate (setf generic-function-name) - (cons standard-generic-function) - (symbol standard-generic-function)) - ;; Writers are done manually since the new-value classes are tricky to sort out - (macrolet ((satiate-specializer-writer (name &rest types) ; i mean, the types are classes though. - `(%early-satiate - (setf ,name) - ,@(loop for class in '(eql-specializer standard-class funcallable-standard-class - structure-class built-in-class core:cxx-class - core:clbind-cxx-class core:derivable-cxx-class) - nconc (loop for type in types - collect `(,type ,class)))))) - (satiate-specializer-writer %specializer-direct-methods null cons)) - (macrolet ((satiate-class-writer (name &rest types) - `(%early-satiate - (setf ,name) - ,@(loop for class in '(standard-class funcallable-standard-class - structure-class built-in-class core:cxx-class - core:clbind-cxx-class core:derivable-cxx-class) - nconc (loop for type in types collect `(,type ,class)))))) - (satiate-class-writer class-name symbol) - (satiate-class-writer %class-direct-superclasses null cons) - (satiate-class-writer %class-direct-subclasses null cons) - (satiate-class-writer %class-slots null cons) - (satiate-class-writer %class-precedence-list null cons) - (satiate-class-writer %class-direct-slots null cons) - (satiate-class-writer %class-default-initargs null cons) - (satiate-class-writer %class-finalized-p symbol) ; don't really "unfinalize", so no null - (satiate-class-writer class-size fixnum) - (satiate-class-writer class-dependents null cons) - (satiate-class-writer class-valid-initargs null cons) - (satiate-class-writer creator core:funcallable-instance-creator core:instance-creator)) - (macrolet ((satiate-method-writer (name &rest types) - `(%early-satiate - (setf ,name) - ,@(loop for class in '(standard-method - standard-writer-method standard-reader-method) - nconc (loop for type in types collect `(,type ,class)))))) - (satiate-method-writer %method-generic-function standard-generic-function) - (satiate-method-writer method-plist null cons) - (satiate-method-writer method-keywords null cons) ; note: why is this being called? - (satiate-method-writer method-allows-other-keys-p null cons)) - (macrolet ((satiate-slotd-writer (name &rest types) - `(%early-satiate - (setf ,name) - ,@(loop for class in '(standard-direct-slot-definition - standard-effective-slot-definition) - nconc (loop for type in types collect `(,type ,class)))))) - (satiate-slotd-writer %slot-definition-location fixnum cons)) - (macrolet ((satiate-gf-writer (name &rest types) - `(%early-satiate - (setf ,name) - ,@(loop for type in types collect `(,type standard-generic-function))))) - (satiate-gf-writer %generic-function-method-combination method-combination) - (satiate-gf-writer %generic-function-argument-precedence-order cons) - (satiate-gf-writer %generic-function-methods null cons) - (satiate-gf-writer generic-function-dependents null cons)) - ;; also done in function-to-method - (%early-satiate compute-applicable-methods-using-classes - (standard-generic-function cons) - (standard-generic-function null)) - ;; also done in function-to-method - (%early-satiate compute-applicable-methods - (standard-generic-function cons) - (standard-generic-function null)) - ;; also done in function-to-method - (%early-satiate compute-effective-method - (standard-generic-function method-combination cons) - (standard-generic-function method-combination null)) - (%early-satiate make-instance (symbol) (standard-class) (funcallable-standard-class)) - (%early-satiate allocate-instance (standard-class) (funcallable-standard-class) (structure-class)) - (%early-satiate add-direct-subclass - (standard-class standard-class) (funcallable-standard-class funcallable-standard-class) - (built-in-class standard-class) ; for gray streams - (structure-class structure-class)) - (%early-satiate validate-superclass - (standard-class standard-class) (funcallable-standard-class funcallable-standard-class) - (structure-class structure-class) (standard-class built-in-class)) - (macrolet ((satiate-classdefs (&rest classes) - (let ((tail (mapcar #'list classes))) - `(progn (%early-satiate finalize-inheritance ,@tail) - (%early-satiate compute-class-precedence-list ,@tail) - (%early-satiate compute-slots ,@tail) - (%early-satiate class-name ,@tail) - (%early-satiate class-prototype ,@tail) - (%early-satiate compute-default-initargs ,@tail) - (%early-satiate direct-slot-definition-class ,@tail) - (%early-satiate effective-slot-definition-class ,@tail))))) - (satiate-classdefs standard-class funcallable-standard-class structure-class - built-in-class core:derivable-cxx-class core:clbind-cxx-class)) - (%early-satiate compute-effective-slot-definition-initargs - (standard-class cons) (funcallable-standard-class cons) - (structure-class cons)) - (%early-satiate compute-effective-slot-definition - (standard-class symbol cons) (funcallable-standard-class symbol cons) - (structure-class symbol cons)) - (%early-satiate ensure-class-using-class (standard-class symbol) (null symbol)) - (%early-satiate function-keywords (standard-method) (standard-reader-method) (standard-writer-method)) - (%early-satiate add-direct-method - (structure-class standard-method) (eql-specializer standard-method) - (standard-class standard-method) (funcallable-standard-class standard-method) - (standard-class standard-reader-method) (standard-class standard-writer-method) - (built-in-class standard-method) - (built-in-class standard-writer-method) ; for the new-value argument - (funcallable-standard-class standard-reader-method) - (funcallable-standard-class standard-writer-method)) - (%early-satiate remove-direct-method - (structure-class standard-method) (eql-specializer standard-method) - (standard-class standard-method) (funcallable-standard-class standard-method) - (standard-class standard-reader-method) (standard-class standard-writer-method) - (built-in-class standard-method) - (built-in-class standard-writer-method) ; for the new-value argument - (funcallable-standard-class standard-reader-method) - (funcallable-standard-class standard-writer-method)) - (%early-satiate ensure-generic-function-using-class - (standard-generic-function symbol) (null symbol)) - ;; these are obviously not complete, but we can throw em in. - (macrolet ((partly-satiate-initializations (&rest classes) - (let ((tail (mapcar #'list classes))) - `(progn - (%early-satiate initialize-instance ,@tail) - (%early-satiate shared-initialize - ,@(loop for class in classes - collect `(,class symbol) - collect `(,class cons) - collect `(,class null))) - (%early-satiate reinitialize-instance ,@tail))))) - (partly-satiate-initializations - standard-generic-function standard-method standard-class structure-class - standard-reader-method standard-writer-method - standard-direct-slot-definition standard-effective-slot-definition - eql-specializer method-combination funcallable-standard-class)) - (%early-satiate make-instances-obsolete (standard-class) (funcallable-standard-class) (structure-class))))) +|# diff --git a/src/lisp/kernel/clos/sequences.lisp b/src/lisp/kernel/clos/sequences.lisp index 0f007cb868..29b9e23a39 100644 --- a/src/lisp/kernel/clos/sequences.lisp +++ b/src/lisp/kernel/clos/sequences.lisp @@ -982,3 +982,56 @@ (defmethod sequence:make-sequence-iterator ((sequence vector) &key from-end start end) (core::make-vector-iterator sequence from-end start end)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Package definition + +(in-package "SEQUENCE") + +(cl:export '(;; core protocol + adjust-sequence + elt + length + make-sequence-like + ;; iterator protocol + iterator-step + iterator-endp + iterator-element + iterator-index + iterator-copy + make-simple-sequence-iterator + make-sequence-iterator + ;; may be customized or derived + emptyp + ;; ditto, but are CL symbols too + count count-if count-if-not + copy-seq + delete delete-if delete-if-not + delete-duplicates + fill + find find-if find-if-not + mismatch + nsubstitute nsubstitute-if nsubstitute-if-not + nreverse + position position-if position-if-not + reduce + remove remove-if remove-if-not + remove-duplicates + replace + reverse + search + sort stable-sort + subseq + substitute substitute-if substitute-if-not + ;; helper macros + dosequence + with-sequence-iterator + ;; clasp extensions + protocol-unimplemented + protocol-unimplemented-operation + make-sequence + define-random-access-sequence + make-random-access-iterator + define-iterative-sequence + )) diff --git a/src/lisp/kernel/clos/slot-value.lisp b/src/lisp/kernel/clos/slot-value.lisp new file mode 100644 index 0000000000..76dc625fdf --- /dev/null +++ b/src/lisp/kernel/clos/slot-value.lisp @@ -0,0 +1,117 @@ +(in-package #:clos) + +;;; This works on both class locations (conses) and instance ones. +(defun standard-location-access (instance location) + (if (core:fixnump location) + (core:rack-ref (core:instance-rack instance) location) + (car location))) + +(defun (setf standard-location-access) (val instance location) + (if (core:fixnump location) + (setf (core:rack-ref (core:instance-rack instance) location) val) + (setf (car location) val))) + +;; FIND is not defined yet so we use this. +(defun %find-slot (class slot-name) + (loop for prospect in (class-slots class) + for prospect-name = (slot-definition-name prospect) + when (eql prospect-name slot-name) + return prospect)) + +(defun slot-value (object slot-name) + (let* ((class (class-of object)) + (slotd (%find-slot class slot-name))) + (if slotd + (slot-value-using-class class object slotd) + ;; Only the primary value of SLOT-MISSING is returned. + (values (slot-missing class object slot-name 'slot-value))))) + +(defun (setf slot-value) (value object slot-name) + (let* ((class (class-of object)) + (slotd (%find-slot class slot-name))) + (if slotd + (setf (slot-value-using-class class object slotd) value) + (slot-missing class object slot-name 'setf value))) + ;; 7.7.12: value of slot-missing is ignored for setf. + value) + +(defun slot-boundp (object slot-name) + (let* ((class (class-of object)) + (slotd (%find-slot class slot-name))) + (if slotd + (slot-boundp-using-class class object slotd) + (values (slot-missing class object slot-name 'slot-boundp))))) + +(defun slot-makunbound (object slot-name) + (let* ((class (class-of object)) + (slotd (%find-slot class slot-name))) + (if slotd + (slot-makunbound-using-class class object slotd) + (slot-missing class object slot-name 'slot-makunbound))) + object) + +(defgeneric slot-value-using-class (class object slot-definition)) +(defgeneric (setf slot-value-using-class) (value class object slot-definition)) +(defgeneric slot-boundp-using-class (class object slot-definition)) +(defgeneric slot-makunbound-using-class (class object slot-definition)) + +(defmethod slot-value-using-class ((class std-class) object slotd) + (let* ((location (slot-definition-location slotd)) + (value (standard-location-access object location))) + (if (core:sl-boundp value) + value + (values (slot-unbound class object (slot-definition-name slotd)))))) + +(defmethod (setf slot-value-using-class) (value (class std-class) object slotd) + (setf (standard-location-access object (slot-definition-location slotd)) value)) + +(defmethod slot-boundp-using-class (class object slotd) + (core:sl-boundp (standard-location-access object (slot-definition-location slotd)))) + +(defmethod slot-makunbound-using-class (class object slotd) + (setf (standard-location-access object (slot-definition-location slotd)) + (core:unbound))) + +(defgeneric slot-missing (class object slot-name operation &optional new-value)) +(defmethod slot-missing ((class t) object slot-name operation &optional new-value) + (declare (ignore operation new-value class)) + (error "~a is not a slot of ~a" slot-name object)) + +(defgeneric slot-unbound (class instance slot-name)) +(defmethod slot-unbound ((class t) instance slot-name) + (error 'unbound-slot :instance instance :name slot-name)) + +(defun slot-exists-p (object slot-name) + (find slot-name (class-slots (class-of object)) :key #'slot-definition-name)) + +(defmacro with-slots (slot-entries instance-form &body body) + (let* ((temp (gensym)) + (accessors + (do ((scan slot-entries (cdr scan)) + (res)) + ((null scan) (nreverse res)) + (let ((entry (first scan))) + (ext:with-current-source-form (entry) + (etypecase entry + (symbol + (push `(,entry (slot-value ,temp ',entry)) res)) + ((cons symbol (cons symbol null)) + (push `(,(first entry) + (slot-value ,temp ',(second entry))) + res)))))))) + `(let ((,temp ,instance-form)) + (symbol-macrolet ,accessors ,@body)))) + +(defmacro with-accessors (slot-accessor-pairs instance-form &body body) + (let* ((temp (gensym)) + (accessors (do ((scan slot-accessor-pairs (cdr scan)) + (res)) + ((null scan) (nreverse res)) + (let ((entry (car scan))) + (ext:with-current-source-form (entry) + (unless (and (listp entry) + (= (length entry) 2)) + (error "Malformed WITH-ACCESSORS syntax.")) + (push `(,(car entry) (,(cadr entry) ,temp)) res)))))) + `(let ((,temp ,instance-form)) + (symbol-macrolet ,accessors ,@body)))) diff --git a/src/lisp/kernel/clos/slot.lisp b/src/lisp/kernel/clos/slot.lisp deleted file mode 100644 index 8c9150656a..0000000000 --- a/src/lisp/kernel/clos/slot.lisp +++ /dev/null @@ -1,144 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi. -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. - -(in-package "CLOS") - -(defconstant +initform-unsupplied+ '+initform-unsupplied+) - -;;; ---------------------------------------------------------------------- -;;; SLOT descriptors -;;; - -(defun make-simple-slotd (class - &key name (initform +initform-unsupplied+) initfunction - (type 'T) (allocation :instance) - initargs readers writers documentation location) - (when (and (eq allocation :class) - (functionp initfunction)) - (setf initfunction (constantly (funcall initfunction)))) - (with-early-make-instance +slot-definition-slots+ - (slotd class - :name name - :initform initform - :initfunction initfunction - :type type - :allocation allocation - :initargs initargs - :readers readers - :writers writers - :documentation documentation - :location location) - slotd)) - -(defun make-simple-direct-slotd - (class &key name (initform +initform-unsupplied+) initfunction - (type 'T) (allocation :instance) - initargs readers writers documentation location) - (when (and (eq allocation :class) - (functionp initfunction)) - (setf initfunction (constantly (funcall initfunction)))) - (with-early-make-instance +direct-slot-definition-slots+ - (slotd class - :name name - :initform initform - :initfunction initfunction - :type type - :allocation allocation - :initargs initargs - :readers readers - :writers writers - :documentation documentation - :location location) - slotd)) - -(defun freeze-class-slot-initfunction (slotd) - (when (eq (getf slotd :allocation) :class) - (let ((initfunc (getf slotd :initfunction))) - (when initfunc - (setf (getf slotd :initfunction) - (constantly (funcall initfunc)))))) - slotd) - -(defun canonical-slot-to-direct-slot (class slotd) - ;; Class slot init functions must be called right away - (setf slotd (freeze-class-slot-initfunction slotd)) - (if (find-class 'slot-definition nil) - (apply #'make-instance - (apply #'direct-slot-definition-class class - (freeze-class-slot-initfunction slotd)) - slotd) - (apply #'make-simple-direct-slotd class slotd))) - -;;; ---------------------------------------------------------------------- -;;; -;;; (PARSE-SLOTS slot-definition-form) => slot-definition-object -;;; -;;; This routine is the one responsible for parsing the definition of -;;; a slot in DEFCLASS. -;;; - -(defun parse-slot (slot) - (if (symbolp slot) - `(list :name ',slot) - (do* (output - (options (rest slot)) - (extra nil) - (initfunction)) - ((null options) - (let ((result (nconc output extra))) - (if initfunction - `(list* :name ',(first slot) :initfunction ,initfunction ',result) - `(list* :name ',(first slot) ',result)))) - (let ((option (pop options))) - (when (endp options) - (si::simple-program-error - "In the slot description ~S,~%the option ~S is missing an argument" - slot option)) - (let ((value (pop options))) - (when (and (member option '(:allocation :initform :type :documentation)) - (getf options option)) - (si::simple-program-error - "In the slot description ~S,~%the option ~S is duplicated" - slot option)) - (case option - (:initarg (push value (getf output :initargs))) - (:initform (setf (getf output :initform) value - initfunction - `(lambda () ,value))) - (:accessor (push value (getf output :readers)) - (push `(setf ,value) (getf output :writers))) - (:reader (push value (getf output :readers))) - (:writer (push value (getf output :writers))) - (:allocation (setf (getf output :allocation) value)) - (:type (setf (getf output :type) value)) - (:documentation (push value (getf output :documentation))) - (otherwise (if (or (getf extra option) - (getf options option)) - (push value (getf extra option)) - (setf (getf extra option) value))))))))) - -(defun parse-slots (slots) - (do ((scan slots (cdr scan)) - (collect)) - ((null scan) - `(list ,@(nreverse collect))) - (let* ((slotd (parse-slot (first scan))) - (name (getf (cdr slotd) :name))) - (dolist (other-slotd collect) - ;;; name might be (quote ) so test with eq or eql does not work - (when (equal name (getf (cdr other-slotd) :name)) - (si::simple-program-error - "A definition for the slot ~S appeared twice in a DEFCLASS form" - name))) - (push slotd collect)))) - -;;; ---------------------------------------------------------------------- diff --git a/src/lisp/kernel/clos/slotvalue.lisp b/src/lisp/kernel/clos/slotvalue.lisp deleted file mode 100644 index b2b466d2d8..0000000000 --- a/src/lisp/kernel/clos/slotvalue.lisp +++ /dev/null @@ -1,93 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi.o -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. - - -(in-package "CLOS") - -(defmethod class-prototype ((class class)) - (unless (slot-boundp class 'prototype) - (setf (slot-value class 'prototype) (allocate-instance class))) - (slot-value class 'prototype)) - -(defmethod slot-value-using-class ((class std-class) self slotd) - (let* ((location (slot-definition-location slotd)) - (value (standard-location-access self location))) - (if (si:sl-boundp value) - value - (values (slot-unbound class self (slot-definition-name slotd)))))) - -(defmethod slot-boundp-using-class ((class std-class) self slotd) - (declare (ignore class)) - (si:sl-boundp (standard-location-access self (slot-definition-location slotd)))) - -;;; FIXME: argument precedence of class self slotd val would be preferred. -(defmethod (setf slot-value-using-class) (val (class std-class) self slotd) - (declare (ignore class)) - (setf (standard-location-access self (slot-definition-location slotd)) val)) - -(defmethod slot-makunbound-using-class ((class std-class) instance slotd) - (declare (ignore class)) - (setf (standard-location-access instance (slot-definition-location slotd)) (si:unbound)) - instance) - -;;; FIXME: argument precedence of class object slotd old new would be preferred. -;;; FIXME: (cas slot-value-using-class) would be a better name. -#+threads -(defmethod cas-slot-value-using-class - (old new (class std-class) object - (slotd standard-effective-slot-definition)) - (let ((loc (slot-definition-location slotd))) - (ecase (slot-definition-allocation slotd) - ((:instance) (mp:cas (standard-instance-access object loc) old new)) - ((:class) (mp:cas (car loc) old new))))) - -;;; FIXME: Should these even be methods? Semantics getting weird here. -;;; FIXME: Anyway they force sequentially consistent order, eck. - -#+threads -(defmethod atomic-slot-value-using-class - ((class std-class) object (slotd standard-effective-slot-definition)) - (let* ((loc (slot-definition-location slotd)) - (v (ecase (slot-definition-allocation slotd) - ((:instance) (mp:atomic (standard-instance-access object loc))) - ((:class) (mp:atomic (car loc)))))) - (if (si:sl-boundp v) - v - (values (slot-unbound class object (slot-definition-name slotd)))))) - -#+threads -(defmethod (setf atomic-slot-value-using-class) - (new-value (class std-class) object - (slotd standard-effective-slot-definition)) - (let ((loc (slot-definition-location slotd))) - (ecase (slot-definition-allocation slotd) - ((:instance) (setf (mp:atomic (standard-instance-access object loc)) - new-value)) - ((:class) (setf (mp:atomic (car loc)) new-value))))) - -;;; -;;; 3) Error messages related to slot access -;;; - -(defmethod slot-missing ((class t) object slot-name operation - &optional new-value) - (declare (ignore operation new-value class)) - (error "~A is not a slot of ~A" slot-name object)) - -(defmethod slot-unbound ((class t) object slot-name) - (declare (ignore class)) - (error 'unbound-slot :instance object :name slot-name)) - -(defmethod (setf class-name) (new-value (class class)) - (declare (notinline reinitialize-instance)) ; bootstrapping - (reinitialize-instance class :name new-value) - new-value) diff --git a/src/lisp/kernel/clos/standard-method-combinations.lisp b/src/lisp/kernel/clos/standard-method-combinations.lisp new file mode 100644 index 0000000000..575eef2e98 --- /dev/null +++ b/src/lisp/kernel/clos/standard-method-combinations.lisp @@ -0,0 +1,42 @@ +(in-package #:clos) + +(define-method-combination standard () + ((around (:around)) + (before (:before)) + (primary () :required t) + (after (:after))) + (flet ((call-methods (methods) + (mapcar (lambda (method) + `(call-method ,method)) + methods))) + ;; We're a bit more hopeful about avoiding make-method and m-v-p1 than + ;; the example in CLHS define-method-combination. + ;; Performance impact is likely to be marginal at best, but why not try? + (let* ((call-primary `(call-method ,(first primary) ,(rest primary))) + (call-before (if before + `(progn ,@(call-methods before) ,call-primary) + call-primary)) + (call-after (if after + `(multiple-value-prog1 ,call-before + ,@(call-methods (reverse after))) + call-before)) + (call-around (if around + (if (and (null before) (null after)) + `(call-method ,(first around) + (,@(rest around) + ,@primary)) + `(call-method ,(first around) + (,@(rest around) + (make-method ,call-after)))) + call-after))) + call-around))) + +(define-method-combination progn :identity-with-one-argument t) +(define-method-combination and :identity-with-one-argument t) +(define-method-combination max :identity-with-one-argument t) +(define-method-combination + :identity-with-one-argument t) +(define-method-combination nconc :identity-with-one-argument t) +(define-method-combination append :identity-with-one-argument nil) +(define-method-combination list :identity-with-one-argument nil) +(define-method-combination min :identity-with-one-argument t) +(define-method-combination or :identity-with-one-argument t) diff --git a/src/lisp/kernel/clos/static-gfs/compiler-macros.lisp b/src/lisp/kernel/clos/static-gfs/compiler-macros.lisp index 4dcdb7bccd..124a877def 100644 --- a/src/lisp/kernel/clos/static-gfs/compiler-macros.lisp +++ b/src/lisp/kernel/clos/static-gfs/compiler-macros.lisp @@ -4,12 +4,6 @@ ;;; and it's nice to not compile a bunch of constructors then. ;;; So we track what constructors we need and dump them all way later. (defvar *constructors-during-build*) -;;; This is based on the build procedure. We load everything and then compile. -;;; The load is serial, so that's when we should be saving everything. -;;; but only for cclasp, which means while bclasp is loading cclasp. -#+bclasp -(eval-when (:load-toplevel) - (setf *constructors-during-build* nil)) (defmacro precompile-build-constructors () (let ((specs *constructors-during-build*)) @@ -55,6 +49,7 @@ ;; circular or dotted list (values nil nil nil nil))) +(let () ; FIXME: allow in build, maybe? somehow? (define-compiler-macro make-instance (&whole form class-designatorf &rest initargs &environment env) (let ((class-designator @@ -86,4 +81,4 @@ `(let ((,cellg (ensure-constructor-cell ,class-designatorf ',keys)) ,@bindings) - (funcall ,cellg ,@syms)))))))) + (funcall ,cellg ,@syms))))))))) diff --git a/src/lisp/kernel/clos/static-gfs/compute-constructor.lisp b/src/lisp/kernel/clos/static-gfs/compute-constructor.lisp index 0d6138d20f..cf4a254ddb 100644 --- a/src/lisp/kernel/clos/static-gfs/compute-constructor.lisp +++ b/src/lisp/kernel/clos/static-gfs/compute-constructor.lisp @@ -1,6 +1,5 @@ (in-package #:static-gfs) - (defvar *compute-constructor-calls* 0) (defun compute-constructor-for-class (class class-form keys) @@ -13,12 +12,8 @@ ;; but again, we call this when make-instance is in progress- ;; it SHOULD signal an error. (clos:finalize-inheritance class)) - ;; bclasp-compile because cclasp is full of make-instance - ;;#+(or) - (let ((cmp:*cleavir-compile-hook* nil)) - (coerce (constructor-form class class-form keys) 'function)) - #+(or) - (cmp:bclasp-compile nil (constructor-form class class-form keys))))) + ;; bytecompile because cclasp is full of make-instance + (cmp:bytecompile (constructor-form class class-form keys))))) ;;; This function is called when an actual make-instance call is happening. ;;; So it should return something immediately valid or error. diff --git a/src/lisp/kernel/clos/static-gfs/constructor.lisp b/src/lisp/kernel/clos/static-gfs/constructor.lisp index 894c95ad5f..e89c22d66f 100644 --- a/src/lisp/kernel/clos/static-gfs/constructor.lisp +++ b/src/lisp/kernel/clos/static-gfs/constructor.lisp @@ -1,7 +1,5 @@ (in-package #:static-gfs) -;;;; NOTE: This file is compiled/loaded before CLOS is up. - #| We use a lazy strategy for constructor cells. That is, things like finalize-inheritance that render constructors invalid only mark them, and the actual computation of a new @@ -15,7 +13,7 @@ a constructor ought to be computed, before make-instance. ;;; MAPPING -;;; FIXME: Should be weak-key +;;; FIXME: :weakness :key (defvar *constructor-cells* (make-hash-table :test #'eq)) (defun make-invalid-cell (class-designator keys) diff --git a/src/lisp/kernel/clos/static-gfs/make-instance.lisp b/src/lisp/kernel/clos/static-gfs/make-instance.lisp index aaace1c545..e7b82b5329 100644 --- a/src/lisp/kernel/clos/static-gfs/make-instance.lisp +++ b/src/lisp/kernel/clos/static-gfs/make-instance.lisp @@ -3,7 +3,8 @@ (defun make-instance-form (class class-form keys params) (let ((patch-list (list - (cons (find-method #'make-instance nil (list (find-class 'class))) + (cons (find-method #'make-instance nil + (list (find-class 'clos::std-class))) #'standard-make-instance-form))) (methods (compute-applicable-methods #'make-instance (list class)))) (if (can-static-effective-method-p methods patch-list) diff --git a/src/lisp/kernel/clos/static-gfs/package.lisp b/src/lisp/kernel/clos/static-gfs/package.lisp index 727765ff97..ef51ebc0d9 100644 --- a/src/lisp/kernel/clos/static-gfs/package.lisp +++ b/src/lisp/kernel/clos/static-gfs/package.lisp @@ -7,4 +7,9 @@ (:export #:invalidate-changers* #:invalidate-class-changers #:invalidate-designated-changers) ;; make-instance compiler macro + #-building-clasp (:implement #:cl)) + +#+building-clasp +(progn + (ext:add-implementation-package '("STATIC-GFS") "CL")) diff --git a/src/lisp/kernel/clos/std-accessors.lisp b/src/lisp/kernel/clos/std-accessors.lisp deleted file mode 100644 index f4e48463d4..0000000000 --- a/src/lisp/kernel/clos/std-accessors.lisp +++ /dev/null @@ -1,173 +0,0 @@ - -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi.o -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. - -(in-package "CLOS") - -;;; ---------------------------------------------------------------------- -;;; ACCESSOR / READER / WRITER METHOD CREATION -;;; -;;; The following code creates unoptimized versions of the -;;; slot accessors defined for a class. They are designed so that at least -;;; some varieties work at boot time, but are called in normal system operation. -;;; -;;; There is not much optimization because fastgf can usually inline accesses anyway. -;;; The functions created here by std-class-accessors are set as the method functions -;;; of standard reader and writer methods, but these functions are only used -;;; if fastgf cannot optimize the access, which will only happen if there are -;;; additional user methods. In which case we have to go slowly anyway. -;;; - -(defun std-class-accessors (slot-name) - (values (make-%method-function-fast - #'(lambda (self) - (declare (core:lambda-name std-class-accessors.reader.lambda)) - (slot-value self slot-name))) - (make-%method-function-fast - #'(lambda (new-value self) - (declare (core:lambda-name std-class-accessors.writer.lambda)) - (setf (slot-value self slot-name) new-value))))) - -(defun safe-add-method (name method) - ;; Adds a method to a function which might have been previously defined - ;; as non-generic, without breaking the function - (cond ((or *clos-booted* - (not (fboundp name)) - (si::instancep (fdefinition name))) - (add-method (ensure-generic-function name) method)) - (t - ;; NOTE: Using fmakunbound means there will be a problem if - ;; NAME is ADD-METHOD or ENSURE-GENERIC-FUNCTION. - (fmakunbound name) - (add-method (ensure-generic-function name) method)))) - -(defun std-class-generate-accessors (standard-class) - ;; - ;; The accessors are closures, which are generated every time the - ;; slots of the class change. The accessors are safe: they check that - ;; the slot is bound after retreiving the value, and they may take - ;; the liberty of using SI:INSTANCE-REF because they know the class of - ;; the instance. - ;; - (dolist (slotd (slot-value standard-class 'direct-slots)) - (with-slots ((name name) (allocation allocation) (location location) - (readers readers) (writers writers)) - slotd - (multiple-value-bind (reader writer) (std-class-accessors name) - (let* ((options (list* :slot-definition slotd - :leaf-method-p t - (if (boundp '*early-methods*) - nil - (list - :source-position (class-source-position - standard-class))))) - (reader-args (list* :function reader - :generic-function nil - :qualifiers nil - :lambda-list '(object) - :specializers `(,standard-class) - options)) - (reader-class (if (boundp '*early-methods*) - 'standard-reader-method - (apply #'reader-method-class standard-class slotd - reader-args))) - (writer-args (list* :function writer - :generic-function nil - :qualifiers nil - :lambda-list '(value object) - :specializers `(,(find-class t) ,standard-class) - options)) - (writer-class (if (boundp '*early-methods*) - 'standard-writer-method - (apply #'writer-method-class standard-class slotd - writer-args)))) - (dolist (fname readers) - (let ((method (make-method reader-class nil `(,standard-class) '(object) - reader - options))) - (safe-add-method fname method) - ;; This is redundant, but we need it at boot time because - ;; the early MAKE-METHOD does not use the options field. - (unless *clos-booted* - (setf (slot-value method 'slot-definition) slotd)))) - (dolist (fname writers) - (let ((method (make-method writer-class nil - `(,(find-class t) ,standard-class) '(value object) - writer - options))) - (safe-add-method fname method) - ;; This is redundant, but we need it at boot time because - ;; the early MAKE-METHOD does not use the options field. - (unless *clos-booted* - (setf (slot-value method 'slot-definition) slotd))))))))) - -(defun reader-closure (index) - (lambda (object) - (declare (core:lambda-name reader-closure.lambda)) - (si:instance-ref object index))) - -(defun writer-closure (index) - (lambda (value object) - (declare (core:lambda-name writer-closure.lambda)) - (setf (si:instance-ref object index) value))) - -;;; Loop through the entire class hierarchy making accessors. -;;; Some classes may be reachable from multiple superclasses, so we have to -;;; track which ones we've already generated accessors for (the early add-method -;;; never replaces old methods, even with the same specializers and qualifiers!) - -(let ((seen nil)) - (labels ((generate-accessors (class) - (cond ((find class seen) (return-from generate-accessors)) - ((and (typep class 'std-class) - #+(or)(not (member (slot-value class 'name) - '(slot-definition - direct-slot-definition - effective-slot-definition - standard-slot-definition - standard-direct-slot-definition - standard-effective-slot-definition)))) - (std-class-generate-accessors class)) - ((typep class 'core:derivable-cxx-class) - (std-class-generate-accessors class)) - (t - (loop for slotd in (slot-value class 'slots) - for index = (slot-value slotd 'location) - do (loop for reader in (slot-value slotd 'readers) - do (if (fboundp reader) - (setf (fdefinition reader) (reader-closure index)))) - do (loop for writer in (slot-value slotd 'writers) - do (if (fboundp writer) - (setf (fdefinition writer) (writer-closure index))))))) - (push class seen) - (mapc #'generate-accessors (slot-value class 'direct-subclasses)))) - (generate-accessors +the-t-class+))) - -;;; Readers for effective accessor methods - -(macrolet ((defproxies (reader) - `(progn - (defmethod ,reader ((method effective-reader-method)) - (with-early-accessors (+effective-accessor-method-slots+) - (,reader (effective-accessor-method-original method)))) - (defmethod ,reader ((method effective-writer-method)) - (with-early-accessors (+effective-accessor-method-slots+) - (,reader (effective-accessor-method-original method)))))) - (def () - `(progn - ,@(loop for (name . plist) in +standard-accessor-method-slots+ - ;; See KLUDGE in WITH-EARLY-ACCESSORS - for reader = (or (getf plist :reader) - (getf plist :accessor)) - ;; effective accessors have their own function slot. - when (and reader (not (eq reader 'method-function))) - collect `(defproxies ,reader))))) - (def)) diff --git a/src/lisp/kernel/clos/std-slot-value.lisp b/src/lisp/kernel/clos/std-slot-value.lisp deleted file mode 100644 index 4075bb383c..0000000000 --- a/src/lisp/kernel/clos/std-slot-value.lisp +++ /dev/null @@ -1,391 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi.o -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. - -(in-package "CLOS") - -;;; ---------------------------------------------------------------------- -;;; SLOTS READING AND WRITING -;;; -;;; Functional and macro interface for accessing the slots of an instance. -;;; This interface is defined with specialization for classes that ECL -;;; knows of such as standard classes and funcallable standard class. -;;; This is needed to avoid circularity in compute-applicable-methods, -;;; which needs the slot values and thus cannot go through a dispatch -;;; itself. -;;; -;;; Note that using SLOT-VALUE or specialized versions of it is not -;;; wrong because the MOP enforces various restrictions on portable -;;; code: -;;; 1) Accessors must behave as SLOT-VALUE -;;; 2) In particular, any method defined by the user must be -;;; specialized on at least one non-specified class. This means -;;; that the user cannot change the behavoir of SLOT-VALUE for -;;; standard classes. -;;; -;;; First of all we define WITH-SLOTS because it is going to be useful -;;; for enforcing the use of SLOT-VALUE and not of accessors -;;; throughout the bootstrap code. -;;; - -#| -;;; Test for a bug with (etypecase x ((cons symbol (cons symbol null)) ... )) - -(eval-when (:compile-toplevel :execute) - (setf cmp::*debug-typeq* t) - (core::safe-trace cmp::compile-tag-check - cmp::compile-header-check - cmp::typep-expansion - ) - ) - -(defun check-symbolp (x) - (etypecase x - (symbol (print "It's a symbol")))) - - -(defun check-consp (x) - (etypecase x - (cons (print "It's a cons")))) -(defun check-cons-cons (x) - (etypecase x - ((cons symbol (cons symbol null)) (print "It's a cons cons")))) - -(eval-when (:compile-toplevel :execute) - (check-symbolp 'foo) - (check-consp '(1 2 3)) - (check-cons-cons '(a b))) -|# - -(defmacro with-slots (slot-entries instance-form &body body) - (let* ((temp (gensym)) - (accessors - (do ((scan slot-entries (cdr scan)) - (res)) - ((null scan) (nreverse res)) - (let ((entry (first scan))) - (ext:with-current-source-form (entry) - (etypecase entry - (symbol - (push `(,entry (slot-value ,temp ',entry)) res)) - ((cons symbol (cons symbol null)) - (push `(,(first entry) - (slot-value ,temp ',(second entry))) - res)))))))) - `(let ((,temp ,instance-form)) - (symbol-macrolet ,accessors ,@body)))) - -;;; -;;; The following macro is a convenience that can be used to directly -;;; access the slots of a class based on their s-form description. It -;;; is used internally by ECL during bootstrap. Unlike WITH-SLOTS, -;;; the macros directly access the slots by index. -;;; -(defmacro with-early-accessors ((&rest slot-definitions) &rest body) - `(macrolet - ,(loop for slots in slot-definitions - nconc (loop for (name . slotd) in (if (symbolp slots) - (symbol-value slots) - slots) - for index from 0 - ;; KLUDGE: The early slots sometimes have both readers and - ;; accessors so that only one is exported. In this case the - ;; reader usually has the name with no % and we use that in - ;; the code, so we prefer the reader here. - for accessor = (or (getf slotd :reader) (getf slotd :accessor)) - when accessor - collect `(,accessor (object) - `(standard-instance-access ,object ,,index)))) - ,@body)) - -;;; -;;; The following macro are also used at bootstrap for instantiating -;;; a class based only on the s-form description. -;;; -(defmacro with-early-make-instance (slots (object class &rest key-value-pairs) - &rest body) - (when (symbolp slots) - (setf slots (symbol-value slots))) - `(let* ((%class ,class) - (,object (core:allocate-standard-instance %class ,(length slots)))) - ;; This declaration isn't really helpful to the compiler, and causes problems - ;; with checking during boot. - #+(or)(declare (type standard-object ,object)) - ,@(flet ((initializerp (name list) - (not (eq (getf list name 'wrong) 'wrong)))) - (loop for (name . slotd) in slots - for initarg = (getf slotd :initarg) - for initform = (getf slotd :initform (si::unbound)) - for initvalue = (getf key-value-pairs initarg) - for index from 0 - do (cond ((and initarg (initializerp initarg key-value-pairs)) - (setf initform (getf key-value-pairs initarg))) - ((initializerp name key-value-pairs) - (setf initform (getf key-value-pairs name)))) - when (si:sl-boundp initform) - collect `(setf (si:instance-ref ,object ,index) ,initform))) - (with-early-accessors (,slots) - ,@body))) - -(defmacro with-early-make-funcallable-instance (slots (object class &rest key-value-pairs) - &rest body) - (when (symbolp slots) - (setf slots (symbol-value slots))) - `(let* ((%class ,class) - ;; Identical to above macro except here. (FIXME: rewrite more nicely.) - (,object (core:allocate-funcallable-standard-instance %class ,(length slots)))) - #+(or)(declare (type standard-object ,object)) - ,@(flet ((initializerp (name list) - (not (eq (getf list name 'wrong) 'wrong)))) - (loop for (name . slotd) in slots - for initarg = (getf slotd :initarg) - for initform = (getf slotd :initform (si::unbound)) - for initvalue = (getf key-value-pairs initarg) - for index from 0 - do (cond ((and initarg (initializerp initarg key-value-pairs)) - (setf initform (getf key-value-pairs initarg))) - ((initializerp name key-value-pairs) - (setf initform (getf key-value-pairs name)))) - when (si:sl-boundp initform) - collect `(setf (si:instance-ref ,object ,index) ,initform))) - (with-early-accessors (,slots) - ,@body))) - -;;; -;;; Clasp classes store slots in a hash table for faster access. The -;;; following functions create the cache and allow us to locate the -;;; slots rapidly. -;;; -(defun std-create-slots-table (class) - (with-slots ((all-slots slots) - (location-table location-table)) - class - (let ((size (max 32 (* 2 (length all-slots)))) - (metaclass (si::instance-class class)) - (locations nil)) - (when (or (eq metaclass (find-class 'standard-class)) - (eq metaclass (find-class 'funcallable-standard-class)) - (eq metaclass (find-class 'structure-class))) - (setf locations (make-hash-table :size size)) - (dolist (slotd all-slots) - (setf (gethash (slot-definition-name slotd) locations) - (slot-definition-location slotd)))) - (setf location-table locations)))) - -;;; -;;; STANDARD-CLASS INTERFACE -;;; -;;; Specific functions for slot reading, writing, boundness checking, etc. -;;; - -;;; MOP specifies that consequences are undefined if the slot is unbound when this function -;;; is called. We presume that that means for the reader, not the writer. -;;; If the reader is so called, in Clasp, it returns the slot-unbound marker. Users should -;;; not deal with that, but we can. - -(defun standard-instance-access (instance location) - (core:rack-ref (core:instance-rack instance) location)) - -(defun (setf standard-instance-access) (val instance location) - (setf (core:rack-ref (core:instance-rack instance) location) val)) - -#+threads -(mp:define-atomic-expander clos:standard-instance-access (instance location) - (&rest keys) - "The requirements of the normal STANDARD-INSTANCE-ACCESS writer -must be met, including that the slot has allocation :instance, and is -bound before the operation. -If there is a CHANGE-CLASS conflicting with this operation the -consequences are not defined." - (apply #'mp:get-atomic-expansion - `(core:rack-ref (core:instance-rack ,instance) ,location) - keys)) - -;;; On Clasp, funcallable instances and regular instances store -;;; their slots identically, at the moment. -(defun funcallable-standard-instance-access (instance location) - (core:rack-ref (core:instance-rack instance) location)) - -(defun (setf funcallable-standard-instance-access) (val instance location) - (setf (core:rack-ref (core:instance-rack instance) location) val)) - -#+threads -(mp:define-atomic-expander clos:funcallable-standard-instance-access - (instance location) (&rest keys) - "See STANDARD-INSTANCE-ACCESS for requirements." - (apply #'mp:get-atomic-expansion - `(core:rack-ref (core:instance-rack ,instance) ,location) - keys)) - -;;; This works on both class locations (conses) and instance ones. -(defun standard-location-access (instance location) - (if (core:fixnump location) - (core:rack-ref (core:instance-rack instance) location) - (car location))) - -(defun (setf standard-location-access) (val instance location) - (if (core:fixnump location) - (setf (core:rack-ref (core:instance-rack instance) location) val) - (setf (car location) val))) - -(defun slot-value (self slot-name) - (with-early-accessors (+standard-class-slots+ - +slot-definition-slots+) - (let* ((class (class-of self)) - (location-table (class-location-table class))) - (if location-table - (let ((location (gethash slot-name location-table nil))) - (if location - (let ((value (standard-location-access self location))) - (if (si:sl-boundp value) - value - (values (slot-unbound class self slot-name)))) - (slot-missing class self slot-name 'SLOT-VALUE))) - (let ((slotd - ;;; with-early-accessors defines local macros, not functions, - ;;; so we can't do this. - ;;; The fully correct thing to do would be having it define - ;;; local functions which are then inlined. - ;;; Anyway, so we loop more manually instead. - #+(or) (find slot-name (class-slots class) :key #'slot-definition-name) - (loop for prospect in (class-slots class) - for prospect-name = (slot-definition-name prospect) - when (eql slot-name prospect-name) - return prospect))) - (if slotd - (slot-value-using-class class self slotd) - (values (slot-missing class self slot-name 'SLOT-VALUE)))))))) - -(defun slot-exists-p (self slot-name) - (with-slots ((slots slots) (location-table location-table)) - (class-of self) - (if location-table ; only for direct instances of standard-class, etc - (values (gethash slot-name location-table nil)) - (find slot-name slots :key #'slot-definition-name)))) - -(defun slot-boundp (self slot-name) - (with-early-accessors (+standard-class-slots+ - +slot-definition-slots+) - (let* ((class (class-of self)) - (location-table (class-location-table class))) - (if location-table - (let ((location (gethash slot-name location-table nil))) - (if location - (si:sl-boundp (standard-location-access self location)) - (values (slot-missing class self slot-name 'SLOT-BOUNDP)))) - (let ((slotd - #+(or) (find slot-name (class-slots class) :key #'slot-definition-name) - ;; Can't break this out into a function because again, local macro. - ;; FIXME - (loop for prospect in (class-slots class) - for prospect-name = (slot-definition-name prospect) - when (eql slot-name prospect-name) - return prospect))) - (if slotd - (slot-boundp-using-class class self slotd) - (values (slot-missing class self slot-name 'SLOT-BOUNDP)))))))) - -(defun slot-makunbound (self slot-name) - (with-early-accessors (+standard-class-slots+ - +slot-definition-slots+) - (let* ((class (class-of self)) - (location-table (class-location-table class))) - (if location-table - (let ((location (gethash slot-name location-table nil))) - (if location - (setf (standard-location-access self location) (si:unbound)) - (slot-missing class self slot-name 'slot-makunbound))) - (let ((slotd - #+(or) (find slot-name (class-slots class) :key #'slot-definition-name) - ;; Can't break this out into a function because again, local macro. - ;; FIXME - (loop for prospect in (class-slots class) - for prospect-name = (slot-definition-name prospect) - when (eql slot-name prospect-name) - return prospect))) - (if slotd - (slot-makunbound-using-class class self slotd) - (slot-missing class self slot-name 'SLOT-BOUNDP)))))) - self) - -;;; 7.7.12 slot-missing -;;; If slot-missing returns, its values will be treated as follows: -;;; If the operation is setf or slot-makunbound, any values will be ignored by the caller. -;;; -> returning value after the calls to slot-missing -(defun (setf slot-value) (value self slot-name) - (with-early-accessors (+standard-class-slots+ - +slot-definition-slots+) - (let* ((class (class-of self)) - (location-table (class-location-table class))) - (if location-table - (let ((location (gethash slot-name location-table nil))) - (if location - (setf (standard-location-access self location) value) - (slot-missing class self slot-name 'SETF value))) - (let ((slotd - #+(or) (find slot-name (class-slots class) :key #'slot-definition-name) - (loop for prospect in (class-slots class) - for prospect-name = (slot-definition-name prospect) - when (eql slot-name prospect-name) - return prospect))) - (if slotd - (setf (slot-value-using-class class self slotd) value) - (slot-missing class self slot-name 'SETF value)))))) - value) - -;;; FIXME: (cas slot-value) would be a better name. -#+threads -(defun cas-slot-value (old new object slot-name) - (let* ((class (class-of object)) - (location-table (class-location-table class))) - (if location-table - (let ((location (gethash slot-name location-table))) - (if location - (core::instance-cas old new object location) - (slot-missing class object slot-name - 'mp:cas (list old new)))) - (let ((slotd (find slot-name (clos:class-slots class) - :key #'clos:slot-definition-name))) - (if slotd - (cas-slot-value-using-class old new class object slotd) - (slot-missing class object slot-name - 'mp:cas (list old new))))))) - -#+threads -(mp:define-atomic-expander slot-value (object slot-name) (&rest keys) - "See SLOT-VALUE-USING-CLASS documentation for constraints. -If no slot with the given SLOT-NAME exists, SLOT-MISSING will be called, -with operation = mp:cas, and new-value a list of OLD and NEW. -If SLOT-MISSING returns, its primary value is returned." - (let ((gobject (gensym "OBJECT")) (gsname (gensym "SLOT-NAME")) - (gslotd (gensym "SLOTD")) (gclass (gensym "CLASS"))) - (multiple-value-bind (vars vals cmpv newv read write cas) - (apply #'mp:get-atomic-expansion - `(slot-value-using-class ,gclass ,gobject ,gslotd) - keys) - (values (list* gobject gsname gclass gslotd vars) - (list* object slot-name `(class-of ,gobject) - `(find ,gsname (class-slots ,gclass) - :key #'slot-definition-name) - vals) - cmpv newv - `(if ,gslotd - ,read - (slot-missing ,gclass ,gobject ,gsname 'slot-value)) - `(if ,gslotd - ,write - (slot-missing ,gclass ,gobject ,gsname 'setf ,newv)) - #+(or) - `(cas-slot-value ,cmpv ,newv ,gobject ,gsname) - `(if ,gslotd - ,cas - (slot-missing ,gclass ,gobject ,gsname - 'mp:cas (list ,cmpv ,newv))))))) diff --git a/src/lisp/kernel/clos/stdmethod.lisp b/src/lisp/kernel/clos/stdmethod.lisp deleted file mode 100644 index 7ef57909ef..0000000000 --- a/src/lisp/kernel/clos/stdmethod.lisp +++ /dev/null @@ -1,95 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- -;;;; -;;;; Copyright (c) 1992, Giuseppe Attardi. -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. - -(in-package "CLOS") - -;;;---------------------------------------------------------------------- -;;; Method -;;; ---------------------------------------------------------------------- - -(defmethod function-keywords ((method standard-method)) - (values (method-keywords method) (method-allows-other-keys-p method))) - -(defmethod shared-initialize :before - ((method standard-method) slot-names &rest initargs - &key (specializers nil spec-supplied-p) - (lambda-list nil lambda-supplied-p)) - (declare (ignore initargs)) - (when slot-names - (unless spec-supplied-p - (error "Specializer list not supplied in method initialization")) - (unless lambda-supplied-p - (error "Lambda list not supplied in method initialization")) - (unless (= (first (si::process-lambda-list lambda-list 'method)) - (length specializers)) - (error "The list of specializers does not match the number of required arguments in the lambda list ~A" - lambda-list))) - (when spec-supplied-p - (loop for s in specializers - unless (typep s 'specializer) - do (error "Object ~A is not a valid specializer" s)))) - -(defmethod shared-initialize :after - ((method standard-method) slot-names &rest initargs) - (declare (ignore slot-names initargs)) - (setf (values (method-keywords method) (method-allows-other-keys-p method)) - (compute-method-keywords (method-lambda-list method)))) - -#+threads -(defparameter *eql-specializer-lock* (mp:make-lock :name 'eql-specializer)) -;; We don't want this hash-table erased when we reload during bootstrap, so defvar instead of parameter. -(defvar *eql-specializer-hash* - (make-hash-table :size 128 :test #'eql)) - -#+threads -(defun intern-eql-specializer (object) - (let ((table *eql-specializer-hash*)) - (flet ((get-it () - (or (gethash object table nil) - (setf (gethash object table) - ;; See note on initargs-updater in fixup.lisp. - (with-early-make-instance +eql-specializer-slots+ - (e (find-class 'eql-specializer) :object object) - e))))) - #+threads (mp:with-lock (*eql-specializer-lock*) (get-it)) - #-threads (get-it)))) - -(defmethod add-direct-method ((spec specializer) (method method)) - (pushnew method (%specializer-direct-methods spec)) - (values)) - -(defmethod remove-direct-method ((spec specializer) (method method)) - (setf (%specializer-direct-methods spec) - (delete method (specializer-direct-methods spec))) - (values)) - -#+threads -(defmethod remove-direct-method ((spec eql-specializer) (method method)) - (mp:with-lock (*eql-specializer-lock*) - (call-next-method) - (unless (specializer-direct-methods spec) - (remhash spec *eql-specializer-hash*))) - (values)) - -#-threads -(defmethod remove-direct-method ((spec eql-specializer) (method method)) - (call-next-method) - (unless (specializer-direct-methods spec) - (remhash spec *eql-specializer-hash*)) - (values)) - -(defmethod specializer-direct-generic-functions ((specializer specializer)) - (loop with result = nil - for method in (specializer-direct-methods specializer) - for gf = (method-generic-function method) - do (pushnew gf result :test #'eq) - finally (return result))) diff --git a/src/lisp/kernel/clos/streams.lisp b/src/lisp/kernel/clos/streams.lisp index e50c1124ad..a510e365d2 100644 --- a/src/lisp/kernel/clos/streams.lisp +++ b/src/lisp/kernel/clos/streams.lisp @@ -12,8 +12,6 @@ (in-package "GRAY") -(import 'ext:ansi-stream) - (unexport '(%close %input-stream-p %open-stream-p @@ -303,11 +301,10 @@ truename.")) ;;; generic functions. ;;; -(let ((clos::*clos-booted* 'clos:map-dependents)) - (defclass fundamental-stream (standard-object stream) - ((open-p :accessor open-stream-p - :initform t )) - (:documentation "the base class for all CLOS streams"))) +(defclass fundamental-stream (standard-object stream) + ((open-p :accessor open-stream-p + :initform t )) + (:documentation "the base class for all CLOS streams")) (defclass fundamental-input-stream (fundamental-stream) ()) @@ -934,4 +931,12 @@ truename.")) (pushnew 'gray-streams-module-provider ext:*module-provider-functions*) -#+(or cclasp eclasp) (eval-when (:load-toplevel) (setf clos:*clos-booted* t)) +(export '(fundamental-stream + fundamental-input-stream + fundamental-output-stream + fundamental-character-stream + fundamental-binary-stream + fundamental-character-input-stream + fundamental-character-output-stream + fundamental-binary-input-stream + fundamental-binary-output-stream)) diff --git a/src/lisp/kernel/clos/telemetry.lisp b/src/lisp/kernel/clos/telemetry.lisp index 50c265465d..397c883d2e 100644 --- a/src/lisp/kernel/clos/telemetry.lisp +++ b/src/lisp/kernel/clos/telemetry.lisp @@ -1,15 +1,12 @@ (in-package #:clos) -(defmacro %tracy (gf) - `(mp:atomic (slot-value ,gf 'tracy))) - (defun %start-profiling/record (gf) (check-type gf standard-generic-function) - (setf (%tracy gf) (list :profile-record 0.0))) + (setf (generic-function-tracy gf) (list :profile-record 0.0))) (defun %start-profiling/ongoing (gf) (check-type gf standard-generic-function) - (setf (%tracy gf) (list :profile-ongoing 0.0))) + (setf (generic-function-tracy gf) (list :profile-ongoing 0.0))) (defun start-profiling (generic-function &key (report :ongoing)) "Start profiling GENERIC-FUNCTION. @@ -28,13 +25,13 @@ See REPORT-PROFILING See PROFILING-DATA Experimental." - (setf (%tracy generic-function) nil)) + (setf (generic-function-tracy generic-function) nil)) (defun report-profiling (generic-function) "Print a representation of the current profile of GENERIC-FUNCTION to *TRACE-OUTPUT*. Experimental." - (let ((tracy (%tracy generic-function))) + (let ((tracy (generic-function-tracy generic-function))) (when (null tracy) (warn "~a is not being profiled" generic-function) (return-from report-profiling)) @@ -48,7 +45,7 @@ Experimental." "Return current profiling information for GENERIC-FUNCTION. Currently this consists of two values: the number of dispatch misses that have occured, and approximately how much overhead was incurred by these misses in seconds. Experimental." - (let ((tracy (%tracy generic-function))) + (let ((tracy (generic-function-tracy generic-function))) (when (null tracy) (warn "~a is not being profiled" generic-function) (return-from profiling-data (values 0 0.0))) diff --git a/src/lisp/kernel/cmp/activate-clasp-readtables-for-eclector.lisp b/src/lisp/kernel/cmp/activate-clasp-readtables-for-eclector.lisp deleted file mode 100644 index 66cb8c2438..0000000000 --- a/src/lisp/kernel/cmp/activate-clasp-readtables-for-eclector.lisp +++ /dev/null @@ -1,136 +0,0 @@ -(in-package #:cmp) - -(defmethod eclector.readtable:syntax-type ((readtable cl:readtable) char) - (core:syntax-type readtable char)) - -(defmethod eclector.readtable:get-macro-character ((readtable cl:readtable) char) - (cl:get-macro-character char readtable)) - -(defmethod eclector.readtable:set-macro-character - ((readtable cl:readtable) char function &optional non-terminating-p) - (cl:set-macro-character char function non-terminating-p readtable)) - -(defmethod eclector.readtable:get-dispatch-macro-character ((readtable cl:readtable) disp sub) - (cl:get-dispatch-macro-character disp sub readtable)) - -(defmethod eclector.readtable:set-dispatch-macro-character - ((readtable cl:readtable) disp sub function) - (cl:set-dispatch-macro-character disp sub function readtable)) - -(defmethod eclector.readtable:copy-readtable ((readtable cl:readtable)) - (cl:copy-readtable readtable)) - -(defmethod eclector.readtable:copy-readtable-into ((from cl:readtable) (to cl:readtable)) - (cl:copy-readtable from to)) - -(defmethod eclector.readtable:make-dispatch-macro-character - ((readtable cl:readtable) char &optional non-terminating-p) - (cl:make-dispatch-macro-character char non-terminating-p readtable)) - -(defmethod eclector.readtable:readtable-case (readtable) - (error 'type-error :datum readtable :EXPECTED-TYPE 'cl:readtable)) - -(defmethod eclector.readtable:readtable-case ((readtable cl:readtable)) - (cl:readtable-case readtable)) - -(defmethod (setf eclector.readtable:readtable-case) (mode (readtable cl:readtable)) - (setf (cl:readtable-case readtable) mode)) - -(defmethod (setf eclector.readtable:readtable-case) (mode readtable) - (declare (ignore mode)) - (error 'type-error :datum readtable :EXPECTED-TYPE 'cl:readtable)) - -(defmethod eclector.readtable:readtablep ((object cl:readtable)) t) - -(defvar core:*read-hook*) -(defvar core:*read-preserving-whitespace-hook*) - -;;; to avoid eclector.parse-result::*stack* being unbound, when *client* is bound to a parse-result-client -;;; Not sure whether this a a fortunate design in eclector - -(defclass clasp-non-cst-elector-client (cmp:clasp-eclector-client-mixin) ()) -(defvar *clasp-normal-eclector-client* (make-instance 'clasp-non-cst-elector-client)) - -(defclass clasp-tracking-elector-client (cmp:clasp-eclector-client-mixin eclector.parse-result:parse-result-client) ()) - -(defmethod eclector.base:source-position - ((client clasp-tracking-elector-client) stream) - (cmp:compile-file-source-pos-info stream)) - -(defmethod eclector.parse-result:make-expression-result - ((client clasp-tracking-elector-client) result children source) - (declare (ignore children)) - (when cmp:*source-locations* - (setf (gethash result cmp:*source-locations*) (car source))) - result) - -(defmethod eclector.reader:state-value - ((client cmp:clasp-eclector-client-mixin) (aspect (eql 'cl:*readtable*))) - cl:*readtable*) - -(defmethod eclector.reader:call-with-state-value - ((client cmp:clasp-eclector-client-mixin) thunk (aspect (eql 'cl:*readtable*)) value) - (let ((cl:*readtable* value)) - (funcall thunk))) - -(defun read-with-eclector (&optional (input-stream *standard-input*) - (eof-error-p t) - (eof-value nil) - (recursive-p nil)) - (let ((eclector.reader:*client* *clasp-normal-eclector-client*)) - (eclector.reader:read input-stream eof-error-p eof-value recursive-p))) - -(defun read-preserving-whitespace-with-eclector - (&optional (input-stream *standard-input*) - (eof-error-p t) - (eof-value nil) - (recursive-p nil)) - (let ((eclector.reader:*client* *clasp-normal-eclector-client*)) - (eclector.reader:read-preserving-whitespace input-stream eof-error-p - eof-value recursive-p))) - -(defun cl:read-from-string (string - &optional (eof-error-p t) eof-value - &key (start 0) (end (length string)) - preserve-whitespace) - (let ((eclector.reader:*client* *clasp-normal-eclector-client*)) - (eclector.reader:read-from-string string eof-error-p eof-value - :start start :end end - :preserve-whitespace preserve-whitespace))) - -;;; Fixed in https://github.com/s-expressionists/Eclector/commit/19d2d903bb04e3e59ff0557051e134e8ee6195c7 -(defun cl:read-delimited-list (char &optional (input-stream *standard-input*) recursive-p) - (let ((eclector.reader:*client* *clasp-normal-eclector-client*)) - (eclector.reader:read-delimited-list char input-stream recursive-p))) - -(defun core::set-eclector-reader-readmacros (readtable) - (eclector.reader::set-standard-macro-characters readtable) - (eclector.reader::set-standard-dispatch-macro-characters readtable) - (cl:set-dispatch-macro-character #\# #\A 'core:sharp-a-reader readtable) - (cl:set-dispatch-macro-character #\# #\D 'core::do-read-dense-specialized-array readtable) - (cl:set-dispatch-macro-character #\# #\I 'core::read-cxx-object readtable)) - -(defun init-clasp-as-eclector-reader () - (core::set-eclector-reader-readmacros cl:*readtable*) - (core::set-eclector-reader-readmacros (symbol-value 'core:+standard-readtable+)) - ;;; also change read - ;;; read-from-string is overwritten above - (setq core:*read-hook* 'read-with-eclector) - (setq core:*read-preserving-whitespace-hook* 'read-preserving-whitespace-with-eclector)) - -(init-clasp-as-eclector-reader) - -(defun patch-object (client value-old seen-objects) - (multiple-value-bind (state object*) - (eclector.reader:labeled-object-state client value-old) - (case state - ((nil) ; normal object - (eclector.reader:fixup client value-old seen-objects) - value-old) - ((:final :final/circular) object*) ; fully resolved circular reference - (otherwise value-old)))) ; unresolved reference - leave for later - -(defmethod eclector.reader:fixup (client (object core:cxx-object) seen-objects) - (let ((patcher (core:make-record-patcher (lambda (object) - (patch-object client object seen-objects))))) - (core:patch-object object patcher))) diff --git a/src/lisp/kernel/cmp/bundle.lisp b/src/lisp/kernel/cmp/bundle.lisp new file mode 100644 index 0000000000..1322c4de8b --- /dev/null +++ b/src/lisp/kernel/cmp/bundle.lisp @@ -0,0 +1,42 @@ +;;; +;;; File: cmpbundle.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) + +(defun builder (kind destination &rest keywords) + "This is used by ASDF to build fasl files." + (declare (ignore kind)) + (apply 'build-fasl destination keywords)) + +(defun build-fasl (out-file &key lisp-files init-name) + (declare (ignore init-name)) + (let ((output-name (case *default-output-type* + (:bytecode + (core:link-fasl-files out-file lisp-files) + (truename out-file)) + (otherwise + (error "Handle *default-output-type* ~a" *default-output-type*))))) + output-name)) diff --git a/src/lisp/kernel/cmp/bytecode-introspect.lisp b/src/lisp/kernel/cmp/bytecode-introspect.lisp new file mode 100644 index 0000000000..e886161c46 --- /dev/null +++ b/src/lisp/kernel/cmp/bytecode-introspect.lisp @@ -0,0 +1,287 @@ +(in-package #:cmp) + +;;; ------------------------------------------------------------ +;;; +;;; disassembler +;;; +;;; + +(defun early-mask-field (size position integer) + (logand (ash (lognot (ash -1 size)) + position) + integer)) + +(defun dis-signed (x size) + (logior x (- (early-mask-field 1 (1- size) x)))) + +(defun bc-unsigned (bytecode ip nbytes) + ;; Read NBYTES of little-endian integer. + (do* ((i 0 (1+ i)) + (s 0 (+ 8 s)) + (sum 0)) + ((= i nbytes) sum) + (incf sum (ash (aref bytecode (+ ip i)) s)))) + +(defun bc-signed (bytecode ip nbytes) + (dis-signed (bc-unsigned bytecode ip nbytes) + (* 8 nbytes))) + +;;; Return a list of all IPs that are jumped to. +(defun gather-labels (bytecode) + (let ((ip 0) + (end (length bytecode)) + (result nil) + (longp nil) + op) + (loop (setq op (cmpref:decode-instr (aref bytecode ip))) + ;; If the opcode is illegal, stop. + (when (null op) + (return (sort result #'<))) + ;; Go through the arguments, identifying any labels. + (let ((opip (if longp (1- ip) ip))) ; IP of instruction start + (incf ip) + (dolist (argi (if longp (fourth op) (third op))) + (let ((nbytes (cmpref:unmask-arg argi))) + (if (cmpref:label-arg-p argi) + (push (+ opip (bc-signed bytecode ip nbytes)) result)) + (incf ip nbytes)))) + ;; If this is a LONG, set that for the next instruction. + ;; (KLUDGE) + ;; Otherwise reset longp to false. + (setq longp (string= (first op) "long")) + (if (>= ip end) (return (sort result #'<)))))) + +(defun %disassemble-bytecode (bytecode start length labels) + (let* ((ip start) + (end (+ start length)) + (result nil) + (longp nil) + op) + (loop (setq op (cmpref:decode-instr (aref bytecode ip))) + ;; If this is a label position, mark that. + (let ((labelpos (position ip labels))) + (if labelpos (push (write-to-string labelpos) result))) + ;; If we have an illegal opcode, record it and then give up + ;; (as we have lost the instruction stream) + (when (null op) + (push (list (format nil "! ILLEGAL OPCODE #x~x" (aref bytecode ip)) nil nil) result) + (return (nreverse result))) + ;; Decode the instruction. If it's LONG, leave it to the next. KLUDGE + (let ((opip (if longp (1- ip) ip))) + (incf ip) + (cond + ((string= (first op) "long") (setq longp t)) + (t + (push (list (first op) longp + (let ((args nil)) + (dolist (argi (if longp (fourth op) (third op)) + (nreverse args)) + (let ((nbytes (cmpref:unmask-arg argi))) + (push + (cond ((cmpref:constant-arg-p argi) + (list :constant + (bc-unsigned bytecode ip nbytes))) + ((cmpref:label-arg-p argi) + (let* ((lip (+ opip (bc-signed bytecode ip nbytes))) + (lpos (position lip labels))) + (assert lpos) + (list :label lpos))) + ((cmpref:keys-arg-p argi) + (list :keys + (bc-unsigned bytecode ip nbytes))) + (t + (list :operand + (bc-unsigned bytecode ip nbytes)))) + args) + (incf ip nbytes))))) + result) + (setq longp nil)))) + (if (>= ip end) (return (nreverse result)))))) + +(defun disassemble-parse-key-args (name longp args literals) + ;; We special case this despite the keys-arg thing because it's + ;; just pretty weird all around. + (let* ((more-start (second (first args))) + (kci (second (second args))) + (aokp (logbitp 0 kci)) + (key-count (ash kci -1)) + (keystart (second (third args))) + (keys nil)) + ;; Gather the keys + (do ((i 0 (1+ i))) + ((= i key-count) (setq keys (nreverse keys))) + (push (aref literals (+ keystart i)) keys)) + ;; Print + (format t "~& ~:[~;long ~]~a~:[~;-aok~] ~d ~d '~s" + longp name aokp more-start key-count keys))) + +(defvar *functions-to-disassemble*) + +(defun disassemble-bytecode (module + &key (start 0) length labels + (function-name nil fnp)) + (let* ((bytecode (core:bytecode-module/bytecode module)) + (literals (core:bytecode-module/literals module)) + (length (or length (length bytecode))) + (dis (%disassemble-bytecode bytecode start length labels))) + (flet ((textify-operand (thing) + (destructuring-bind (kind value) thing + (cond ((eq kind :constant) + (let ((lit (aref literals value))) + ;; This may not be the best place for this check, + ;; but here we check for enclosed functions. + (when (and (typep lit 'core:bytecode-simple-fun) + (eq (core:bytecode-simple-fun/code lit) + module) + (boundp '*functions-to-disassemble*)) + (push lit *functions-to-disassemble*)) + (format nil "'~s" (aref literals value)))) + ((eq kind :label) (format nil "L~a" value)) + ((eq kind :operand) (format nil "~d" value)) + ;; :keys special cased below + (t (error "Illegal kind ~a" kind)))))) + (when fnp + (format t "function ~s~%" function-name)) + (dolist (item dis) + (cond + ((consp item) + ;; instruction + (destructuring-bind (name longp args) item + (if (string= name "parse-key-args") + (disassemble-parse-key-args name longp args literals) + (format t "~& ~:[~;long ~]~a~{ ~a~}~%" + longp name (mapcar #'textify-operand args))))) + ((or (stringp item) (symbolp item)) + ;; label + (format t "~&L~a:~%" item)) + (t (error "Illegal item ~a" item)))))) + (values)) + +(defun %disassemble-bytecode-function (bcfunction labels) + (let* ((simple bcfunction) + (module (core:bytecode-simple-fun/code simple)) + (start (core:bytecode-simple-fun/entry-pc-n simple)) + (length (core:bytecode-simple-fun/bytecode-size simple))) + (disassemble-bytecode module + :start start :length length :labels labels + :function-name (core:function-name bcfunction))) + (values)) + +(defun disassemble-bytecode-function (bcfunction) + (let* ((disassembled-functions nil) ; prevent recursion + (simple bcfunction) + (module (core:bytecode-simple-fun/code simple)) + (bytecode (core:bytecode-module/bytecode module)) + ;; We grab labels for the entire module, so that nonlocal exit points + ;; are noted completely and deterministically. + (labels (gather-labels bytecode)) + (*functions-to-disassemble* (list bcfunction))) + (loop (let ((fun (pop *functions-to-disassemble*))) + (unless (member fun disassembled-functions) + (push fun disassembled-functions) + (%disassemble-bytecode-function fun labels))) + (when (null *functions-to-disassemble*) + (return (values)))))) + +;;; ------------------------------------------------------------ +;;; +;;; Other introspection +;;; + + +(defun bytecode-next-arg (argspec bytecode opip ip nbytes) + (cond + ((cmpref:constant-arg-p argspec) + (cons :constant (bc-unsigned bytecode ip nbytes))) + ((cmpref:label-arg-p argspec) + (cons :label (+ opip (bc-signed bytecode ip nbytes)))) + ((cmpref:keys-arg-p argspec) + (cons :keys (bc-unsigned bytecode ip nbytes))) + (t (cons :operand (bc-unsigned bytecode ip nbytes))))) + +(defun collect-pka-args (bytecode ip nbytes) + ;; parse-key-args is eccentric, so we special case it. + ;; we have more-start, key-count-info, key-literal-start, key-frame-start. + ;; the first is an index into the arguments, the second is weird, the third + ;; is an index into the literals that's used a bit differently than usual, + ;; and the last is an index into the frame. + (let* ((more-start + (prog1 (bc-unsigned bytecode ip nbytes) + (incf ip nbytes))) + (key-count-info + (prog1 (bc-unsigned bytecode ip nbytes) + (incf ip nbytes))) + (key-count (ash key-count-info -1)) + (aokp (logbitp 0 key-count-info)) + (key-literal-start + (prog1 (bc-unsigned bytecode ip nbytes) + (incf ip nbytes)))) + (list (cons :operand more-start) + (cons :key-count-info (cons key-count aokp)) + (cons :keys key-literal-start)))) + +;;; Compute a list of annotations that start at the given IP. +;;; Return the list, and the index of the next annotation. +(defun new-annotations (annotations index ip) + (values + (loop with len = (length annotations) + while (< index len) + while (<= (core:bytecode-debug-info/start (aref annotations index)) ip) + when (= (core:bytecode-debug-info/start (aref annotations index)) ip) + collect (aref annotations index) + do (incf index)) + index)) + +(defmacro do-instructions ((mnemonic args opip ip + &optional (annots (gensym "ANNOTATIONS"))) + (bytecode &key (start 0) end annotations) + &body body) + (let ((bsym (gensym "BYTECODE")) + (gend (gensym "END")) + (longp (gensym "LONGP")) + (gannotations (gensym "ANNOTATIONS")) + (next-annotation-index (gensym "NEXT-ANNOTATION-INDEX")) + (op (gensym "OP"))) + `(loop with ,bsym = ,bytecode + with ,ip = ,start + with ,longp = nil + with ,gend = ,(or end `(+ ,ip (length ,bsym))) + with ,gannotations = ,annotations + with ,next-annotation-index = 0 + with ,annots = nil + for ,op = (cmpref:decode-instr (aref ,bsym ,ip)) + for ,mnemonic = (intern (string-upcase (first ,op)) "KEYWORD") + if (eql ,mnemonic :long) + do (setf ,longp t ,ip (1+ ,ip)) + else + do (let ((,opip (if ,longp (1- ,ip) ,ip))) + (incf ,ip) + (let ((,args + (if (eq ,mnemonic :parse-key-args) + (let ((nbytes (if ,longp 2 1))) + (prog1 (collect-pka-args ,bsym ,ip nbytes) + (incf ,ip (* 3 nbytes)))) + (loop for argspec + in (if ,longp (fourth ,op) (third ,op)) + for nbytes = (cmpref:unmask-arg argspec) + collect (bytecode-next-arg argspec ,bsym ,opip ,ip + nbytes) + do (incf ,ip nbytes))))) + (declare (ignorable ,args ,ip)) + (setf (values ,annots ,next-annotation-index) + (new-annotations ,gannotations + ,next-annotation-index ,ip)) + ,@body + (setf ,longp nil))) + until (>= ,ip ,gend)))) + +(defmacro do-module-instructions ((mnemonic args opip ip + &optional (annots (gensym "ANNOTATIONS"))) + (module) + &body body) + (let ((gmodule (gensym "MODULE"))) + `(let ((,gmodule ,module)) + (do-instructions (,mnemonic ,args ,opip ,ip ,annots) + ((core:bytecode-module/bytecode ,gmodule) + :annotations (core:bytecode-module/debug-info ,gmodule)) + ,@body)))) diff --git a/src/lisp/kernel/cmp/bytecode-machines.lisp b/src/lisp/kernel/cmp/bytecode-machines.lisp index 9dd148408f..a56ee68477 100644 --- a/src/lisp/kernel/cmp/bytecode-machines.lisp +++ b/src/lisp/kernel/cmp/bytecode-machines.lisp @@ -5,14 +5,26 @@ (defconstant +keys-arg+ #b011000) (defconstant +label-arg+ #b010000) -(defun constant-arg (val) - (logior +constant-arg+ val)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun constant-arg (val) + (logior +constant-arg+ val)) + + (defun label-arg (val) + (logior +label-arg+ val)) + + (defun keys-arg (val) + (logior +keys-arg+ val))) -(defun label-arg (val) - (logior +label-arg+ val)) +(defun constant-arg-p (val) + (= (logand +mask-arg+ val) +constant-arg+)) -(defun keys-arg (val) - (logior +keys-arg+ val)) +(defun label-arg-p (val) + (= (logand +mask-arg+ val) +label-arg+)) + +(defun keys-arg-p (val) + (= (logand +mask-arg+ val) +keys-arg+)) + +(defun unmask-arg (val) (logandc2 val +mask-arg+)) (macrolet ((defops (&rest ops) (let (rev-fullcodes @@ -99,6 +111,20 @@ ("encell" 63 (1) (2)) ("long" 255))) +;;; *full-codes* contains descriptions of the instructions in the following format: +;;; (name opcode (args...) (long-args...)) +;;; the name is a string. +;;; the args and long args are encoded as a number of bytes from 1 to 3, LOGIOR'd +;;; with the constant, label, and keys code that is appropriate, if any. +;;; One of these "instruction description" lists is what DECODE-INSTR returns. + +(defun decode-instr (opcode) + (let ((res (member opcode *full-codes* :key #'second))) + (if res + (first res) + nil))) + +#-building-clasp (defun pythonify-arguments (args) (declare (optimize (debug 3))) (let (rev-args) @@ -113,6 +139,7 @@ rev-args))) (nreverse rev-args))) +#-building-clasp (defun generate-python-bytecode-table (fout) (format fout "#ifdef PYTHON_OPCODES~%") (format fout "R\"opcodes(~%") @@ -129,138 +156,30 @@ (format fout ")opcodes\"~%") (format fout "#endif~%")) -#-clasp -(defpackage :clos - (:use #:common-lisp)) - -(in-package :clos) - -(eval-when (:compile-toplevel :execute :load-toplevel) - (defstruct (dtree-op (:type vector) :named) - sym name code macro-name macros arguments long-arguments - constant-argument-indices - label-argument-indices) - - (defstruct (dtree-macro (:type vector) :named) name value)) - -(macrolet ((defops (&rest ops) - (let ((new-dtree-ops (make-array (length ops))) - new-isa) - (dolist (op ops) - (destructuring-bind (name code macro-name &optional argument-info) - op - (let* ((sym (intern (string-upcase name))) - (constant-argument-indices (make-array 4 :adjustable t :fill-pointer 0)) - (label-argument-indices (make-array 4 :adjustable t :fill-pointer 0)) - rev-arguments - rev-long-arguments - rev-macros) - (push (make-dtree-macro :name macro-name :value code) rev-macros) - (dotimes (index (length argument-info)) - (let ((arg (elt argument-info index))) - (destructuring-bind (arg-type arg-name) - arg - (cond - ((eq arg-type 'constant-arg) - (vector-push-extend index constant-argument-indices) - (push `(constant-arg 1) rev-arguments) - (push `(constant-arg 2) rev-long-arguments) - (push (make-dtree-macro :name arg-name :value (1+ index)) rev-macros)) - ((eq arg-type 'label-arg) - (vector-push-extend index label-argument-indices) - (push `(label-arg 1) rev-arguments) - (push `(label-arg 2) rev-long-arguments) - (push (make-dtree-macro :name arg-name :value (1+ index)) rev-macros)) - ((eq arg-type 'register-arg) - (push `(register-arg 1) rev-arguments) - (push `(register-arg 2) rev-long-arguments) - (push (make-dtree-macro :name arg-name :value (1+ index)) rev-macros)) - ((eq (car arg) 'offset) - (push (make-dtree-macro :name arg-name :value (1+ index)) rev-macros)) - (t (error "Illegal argument type ~s" arg)))))) - (let ((dtree-op (make-dtree-op :sym sym - :name name - :code code - :macro-name macro-name - :macros (nreverse rev-macros) - :arguments (nreverse rev-arguments) - :long-arguments (nreverse rev-long-arguments) - :constant-argument-indices (copy-seq constant-argument-indices) - :label-argument-indices (copy-seq label-argument-indices)))) - (setf (elt new-dtree-ops code) dtree-op)) - (push (list sym code) new-isa)))) - `(progn - (defparameter *dtree-ops* ',new-dtree-ops) - (defparameter *isa* ',new-isa))))) - (defops - ("miss" 0 "DTREE_OP_MISS") - ("advance" 1 "DTREE_OP_ADVANCE") - ("tag-test" 2 "DTREE_OP_TAG_TEST" ((label-arg "DTREE_FIXNUM_TAG_OFFSET") - (label-arg "DTREE_SINGLE_FLOAT_TAG_OFFSET") - (label-arg "DTREE_CHARACTER_TAG_OFFSET") - (label-arg "DTREE_CONS_TAG_OFFSET") - (offset "DTREE_GENERAL_TAG_OFFSET"))) - ("stamp-read" 3 "DTREE_OP_STAMP_READ" ((label-arg "DTREE_READ_HEADER_OFFSET") - (offset "DTREE_READ_OTHER_OFFSET"))) - ("lt-branch" 4 "DTREE_OP_LT_BRANCH" ((constant-arg "DTREE_LT_PIVOT_OFFSET") - (label-arg "DTREE_LT_LEFT_OFFSET") - (offset "DTREE_LT_RIGHT_OFFSET"))) - ("eq-check" 5 "DTREE_OP_EQ_CHECK" ((constant-arg "DTREE_EQ_PIVOT_OFFSET") - (offset "DTREE_EQ_NEXT_OFFSET"))) - ("range-check" 6 "DTREE_OP_RANGE_CHECK" ((constant-arg "DTREE_RANGE_MIN_OFFSET") - (constant-arg "DTREE_RANGE_MAX_OFFSET") - (offset "DTREE_RANGE_NEXT_OFFSET"))) - ("eql" 7 "DTREE_OP_EQL" ((constant-arg "DTREE_EQL_OBJECT_OFFSET") - (label-arg "DTREE_EQL_BRANCH_OFFSET") - (offset "DTREE_EQL_NEXT_OFFSET"))) - ("optimized-slot-reader" 8 "DTREE_OP_SLOT_READ" ((constant-arg "DTREE_SLOT_READER_INDEX_OFFSET") - (constant-arg "DTREE_SLOT_READER_SLOT_NAME_OFFSET"))) - ("optimized-slot-writer" 9 "DTREE_OP_SLOT_WRITE" ((constant-arg "DTREE_SLOT_WRITER_INDEX_OFFSET"))) - ("car" 10 "DTREE_OP_CAR" ((constant-arg "DTREE_CAR_READER_INDEX_OFFSET") - (constant-arg "DTREE_CAR_READER_CAR_NAME_OFFSET"))) - ("rplaca" 11 "DTREE_OP_RPLACA" ((constant-arg "DTREE_RPLACA_WRITER_INDEX_OFFSET"))) - ("effective-method-outcome" 12 "DTREE_OP_EFFECTIVE_METHOD" ((constant-arg "DTREE_EFFECTIVE_METHOD_OFFSET"))) - ("farg0" 13 "DTREE_OP_FARG0") - ("farg1" 14 "DTREE_OP_FARG1") - ("farg2" 15 "DTREE_OP_FARG2") - ("farg3" 16 "DTREE_OP_FARG3") - ("farg4" 17 "DTREE_OP_FARG4") - ("argn" 18 "DTREE_OP_ARGN" ((register-arg "DTREE_ARGN_OFFSET") - (offset "DTREE_ARGN_NEXT_OFFSET"))) - ("sd-eq-branch" 19 "DTREE_OP_SD_EQ_BRANCH" ((constant-arg "DTREE_SD_STAMP_OFFSET") - (label-arg "DTREE_SD_FAIL_OFFSET") - (offset "DTREE_SD_NEXT_OFFSET"))) - ("single-dispatch-miss" 20 "DTREE_OP_SINGLE_DISPATCH_MISS") - )) - +#-building-clasp (defun dump-gf-bytecode-virtual-machine (stream) (format stream "#ifdef GF_BYTECODE_VM~%") - (dotimes (index (length *dtree-ops*)) - (let ((dtree-op (elt *dtree-ops* index))) - (dolist (macro (dtree-op-macros dtree-op)) - (format stream "#define ~a ~a~%" (dtree-macro-name macro) (dtree-macro-value macro)) - (finish-output stream)) - (terpri stream))) - (format stream "#define DTREE_OP_COUNT ~a~%" (length *dtree-ops*)) + (loop for (_ opcode name . args) in *dtree-ops-as-list* + for rargs = (first args) ; may be nil + do (format stream "#define ~a ~a~%" name opcode) + (loop for (_ arg) in rargs for i from 1 + do (format stream "#define ~a ~a~%" arg i)) + (terpri stream)) + (format stream "#define DTREE_OP_COUNT ~a~%" (length *dtree-ops-as-list*)) (format stream "#endif // GF_BYTECODE_VM~%")) +#-building-clasp (defun dump-gf-bytecode-virtual-machine-macro-names (stream) (format stream "#ifdef GF_BYTECODE_VM_NAMES~%") - (dotimes (index (length *dtree-ops*)) - (let* ((dtree-op (elt *dtree-ops* index)) - (macro-name (dtree-op-macro-name dtree-op))) - (format stream " case ~a: return ~s;~%" macro-name (string macro-name)))) + (loop for (_ opcode name) in *dtree-ops-as-list* + do (format stream " case ~a: return ~s;~%" name (string name))) (format stream "#endif // GF_BYTECODE_VM_NAMES~%")) +#-building-clasp (defun dump-python-gf-bytecode-virtual-machine (stream) (format stream "// This is where I dump the python GF bytecode VM~%")) -(export '(dump-gf-bytecode-virtual-machine - dump-gf-bytecode-virtual-machine-macro-names - dump-python-gf-bytecode-virtual-machine) :clos) - -(in-package :cmpref) - +#-building-clasp (defvar +reserved-c++-keywords+ '("alignas" "alignof" @@ -360,6 +279,7 @@ "xor" "xor_eq")) +#-building-clasp (defun c++ify (name) (when (member name +reserved-c++-keywords+ :test #'equalp) (setf name (concatenate 'string "_" name))) @@ -386,6 +306,7 @@ ((char= chr #\-) (format sout "_")) (t (format sout "~a" chr)))))))) +#-building-clasp (defun generate-vm-codes (fout) (write-line "#ifdef VM_CODES" fout) (terpri fout) @@ -400,90 +321,7 @@ (terpri fout) (write-line "#endif // VM_CODES" fout)) -;;; load time values machine - -(defstruct (ltv-info (:type vector) :named) type c++-type suffix gcroots) - -(defparameter *ltv-info* (make-hash-table :test #'equal)) - -(defun set-ltv-info (symbol c++-type suffix &optional gcroots) - (setf (gethash symbol *ltv-info*) (make-ltv-info :type symbol :c++-type c++-type :suffix suffix :gcroots gcroots))) - -(eval-when (:load-toplevel :execute) - (set-ltv-info :i8 "char" "char") - (set-ltv-info :size_t "size_t" "size_t") - (set-ltv-info :t* "T_O*" "object" t) - (set-ltv-info :i8* "string" "string") - (set-ltv-info :short-float "short_float_t" "binary16") - (set-ltv-info :single-float "float" "float") - (set-ltv-info :double-float "double" "double") - (set-ltv-info :binary80 "long_float_t" "binary80") - (set-ltv-info :binary128 "long_float_t" "binary128") - (set-ltv-info :uintptr_t "uintptr_t" "size_t") - (set-ltv-info :bignum "T_O*" "bignum") - (set-ltv-info :unknown "UNKNOWN" "UNKNOWN") - ) - -(defun build-one-ltv-function (op &optional (stream *standard-output*)) - (destructuring-bind (code unwindsp name arg-types &key varargs) - op - (declare (ignore code unwindsp)) - (format stream "void parse_~a(gctools::GCRootsInModule* roots, char*& bytecode, char* byteend, bool log) {~%" name) - (format stream " if (log) printf(\"%s:%d:%s parse_~a\\n\", __FILE__, __LINE__, __FUNCTION__);~%" name) - (let* ((arg-index 0) - (vars (let (names) - (dolist (arg-type arg-types) - (let* ((ltv-info (let ((info (gethash arg-type *ltv-info*))) - (if info - info - (make-ltv-info :type (format nil "UNKNOWN_~a" arg-type) - :c++-type (format nil "UNKNOWN_~a" arg-type) - :suffix (format nil "UNKNOWN_~a" arg-type))))) - (c++-arg-type (ltv-info-c++-type ltv-info)) - (suffix (ltv-info-suffix ltv-info)) - (gcroots (ltv-info-gcroots ltv-info)) - (variable-name (cond - ((and (= arg-index 0) (string= c++-arg-type "char")) "tag") - ((and (= arg-index 1) (string= c++-arg-type "size_t")) "index") - (t (format nil "arg~a" arg-index)))) - (read-variable-name (if (string= c++-arg-type "string") - (format nil "~a.c_str()" variable-name) - variable-name))) - (format stream " ~a ~a = ltvc_read_~a(~a bytecode, byteend, log );~%" c++-arg-type variable-name - suffix - (if gcroots - "roots, " - "")) - (incf arg-index) - (push read-variable-name names))) - (nreverse names)))) - (when varargs - (setf name (format nil "~a_varargs" name)) - (format stream " Cons_O* varargs = ltvc_read_list( roots, ~a, bytecode, byteend, log );~%" (car (last vars ))) - (setf vars (append vars (list "varargs")))) - (format stream " ~a( roots" name) - (dolist (var vars) - (format stream ", ~a" var)) - (format stream ");~%") - (format stream "};~%")))) - -(defun build-ltv-functions (primitives &optional (stream *standard-output*)) - (format stream "#ifdef DEFINE_LTV_PARSERS~%") - (dolist (prim primitives) - (build-one-ltv-function prim stream)) - (format stream "#endif // DEFINE_LTV_PARSERS~%")) - -(defun build-ltv-switch (primitives &optional (stream *standard-output*)) - (format stream "#ifdef DEFINE_LTV_SWITCH~%") - (dolist (prim primitives) - (format stream " case ~a:~% parse_~a(roots, bytecode, byteend, log);~% break;~%" - (first prim) (third prim))) - (format stream "#endif // DEFINE_LTV_SWITCH~%")) - -(defun build-ltv-machine (&optional (stream *standard-output*)) - (build-ltv-functions *startup-primitives-as-list* stream) - (build-ltv-switch *startup-primitives-as-list* stream)) - +#-building-clasp (defun build-bytecode-ltv-ops (&optional (stream *standard-output*)) (format stream "~%#ifdef DEFINE_BYTECODE_LTV_OPS~%enum class bytecode_ltv : uint8_t {~%") (dolist (op +bytecode-ltv-ops+) @@ -500,12 +338,11 @@ (format stream "};~%#endif~%")) ;;; entry point - +#-building-clasp (defun generate-virtual-machine-header (fout) (generate-vm-codes fout) (generate-python-bytecode-table fout) - (clos:dump-gf-bytecode-virtual-machine fout) - (clos:dump-gf-bytecode-virtual-machine-macro-names fout) - (clos:dump-python-gf-bytecode-virtual-machine fout) - (build-ltv-machine fout) + (dump-gf-bytecode-virtual-machine fout) + (dump-gf-bytecode-virtual-machine-macro-names fout) + (dump-python-gf-bytecode-virtual-machine fout) (build-bytecode-ltv-ops fout)) diff --git a/src/lisp/kernel/cmp/cmpbundle.lisp b/src/lisp/kernel/cmp/cmpbundle.lisp deleted file mode 100644 index dfbb2f34fe..0000000000 --- a/src/lisp/kernel/cmp/cmpbundle.lisp +++ /dev/null @@ -1,121 +0,0 @@ -;;; -;;; File: cmpbundle.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) - -(defun as-shell-command (list-of-args) - (with-output-to-string (sout) - (princ (car list-of-args) sout) - (dolist (c (cdr list-of-args)) - (core:fmt sout " {}" c)))) - -(defvar *safe-system-echo* nil) -(defvar *safe-system-max-retries* 4) -(defvar *safe-system-retry-wait-time* 0.1d0) ;; 100 milliseconds -;; The wait time will be doubled at each retry! - -(defun safe-system (cmd-list &key output-file-name) - (if *safe-system-echo* - (core:fmt t "safe-system: {}%N" cmd-list)) - - (multiple-value-bind (retval error-message) - (ext:vfork-execvp cmd-list) - - (unless (eql retval 0) - (error "Could not execute command with ext:vfork-execvp with ~s~% return-value: ~d error-message: ~s~%" cmd-list retval error-message))) - - (when output-file-name - (let ((sleep-time *safe-system-retry-wait-time*)) - (dotimes (nm1 (- *safe-system-max-retries* 1)) - (let ((n (+ nm1 1))) - (unless (probe-file output-file-name) - (if (>= n *safe-system-max-retries*) - (error "The file ~a was not created by shell command: ~a" output-file-name (as-shell-command cmd-list)) - (progn - (if *safe-system-echo* - (core:fmt t "safe-system: Retry count = {} of {}%N" n *safe-system-max-retries*)) - (core::sleep sleep-time) - (setq sleep-time (* 2 sleep-time))))))))) - - ;; Return T if all went well - t) - -(defun link-bitcode-modules-impl (output-pathname part-pathnames - &key output-type) - "Link a bunch of modules together, return the linked module" - (let* ((module (link-bitcode-modules-together (namestring output-pathname) part-pathnames :output-type output-type)) - (*compile-file-pathname* (pathname (merge-pathnames output-pathname))) - (*compile-file-truename* (translate-logical-pathname *compile-file-pathname*))) - (write-bitcode module (core:coerce-to-filename (pathname (if output-pathname - output-pathname - (error "The output pathname is NIL")))) - :output-type output-type) - module)) - -(defun link-fasobc-modules (output-pathname part-pathnames) - (link-bitcode-modules-impl output-pathname part-pathnames - :output-type :fasobc)) - -(defun link-fasoll-modules (output-pathname part-pathnames) - (link-bitcode-modules-impl output-pathname part-pathnames - :output-type :fasoll)) - -(export '(link-fasoll-modules link-fasobc-modules)) - -(defun builder (kind destination &rest keywords) - "This is used by ASDF to build fasl files." - (declare (ignore kind)) - (apply 'build-fasl destination keywords)) - -(export '(builder)) - -(defun build-faso-parallel (out-file &key lisp-files) - #+(or) - (progn - (format t "Linking ~s --> ~s~%" lisp-files out-file) - (format t "About to do link of ~s to ~s~%" lisp-files out-file)) - (core:link-faso-files out-file lisp-files) - (truename out-file)) - -(defun build-fasl (out-file &key lisp-files init-name) - (declare (ignore init-name)) - (let ((output-name (case *default-output-type* - (:faso - (build-faso-parallel out-file :lisp-files lisp-files)) - (:fasoll - (link-fasoll-modules out-file lisp-files) - (truename out-file)) - (:fasobc - (link-fasobc-modules out-file lisp-files) - (truename out-file)) - (:bytecode - (core:link-fasl-files out-file lisp-files) - (truename out-file)) - (otherwise - (error "Handle *default-output-type* ~a" *default-output-type*))))) - output-name)) - -(export 'build-fasl) diff --git a/src/lisp/kernel/cmp/cmpexports.lisp b/src/lisp/kernel/cmp/cmpexports.lisp deleted file mode 100644 index 65560d7106..0000000000 --- a/src/lisp/kernel/cmp/cmpexports.lisp +++ /dev/null @@ -1,459 +0,0 @@ -(in-package :cmp) -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(with-debug-info-source-position - calculate-cleavir-lambda-list-analysis - module-report - transform-lambda-parts - codegen-startup-shutdown - jit-startup-shutdown-function-names - irc-simple-function-create - find-intrinsic-name - +intrinsic/llvm.eh.typeid.for.p0+ - +intrinsic/llvm.stacksave.p0+ - +intrinsic/llvm.stackrestore.p0+ - *primitives* - primitive-argument-types - primitive-varargs - *track-inlined-functions* - *track-inlinee-name* - *debug-link-options* ;; A list of strings to inject into link commands - *compile-file-debug-dump-module* ;; Dump intermediate modules - *compile-debug-dump-module* ;; Dump intermediate modules - *default-linkage* - *compile-file-parallel-write-bitcode* - *default-compile-linkage* - quick-module-dump - write-bitcode - *irbuilder* - *compile-file-unique-symbol-prefix* - *optimize* *policy* - policy ; used as a doc-type - %ltv*% - irc-function-create - irc-make-function-description - irc-local-function-create - irc-xep-functions-create - xep-arity-arity - xep-arity-function-or-placeholder - xep-group-lookup - xep-group-p - xep-group-arities - xep-group-name - xep-group-entry-point-reference - xep-group-cleavir-lambda-list-analysis - +c++-stamp-max+ - %opaque-fn-prototype*% - fn-prototype - *cleavir-compile-file-hook* - *cleavir-compile-hook* - *btb-compile-hook* - *compile-print* - *current-function* - *current-function-name* - *current-unwind-landing-pad-dest* - *debug-compile-file* - *debug-compile-file-counter* - *generate-compile-file-load-time-values* - *gv-current-function-name* - *irbuilder* - *thread-safe-context* - thread-local-llvm-context - *load-time-value-holder-global-var-type* - *load-time-value-holder-global-var* - *low-level-trace* - *low-level-trace-print* - *the-module* - +header-size+ - +header-stamp-size+ - +header-stamp-offset+ - +cons-tag+ - +fixnum-mask+ - +fixnum-shift+ - +fixnum00-tag+ - +fixnum01-tag+ - #+tag-bits4 +fixnum10-tag+ - #+tag-bits4 +fixnum11-tag+ - +character-shift+ - +character-tag+ - +alignment+ - #+tag-bits4 +vaslist-ptag-mask+ - +vaslist0-tag+ - #+tag-bits4 +vaslist1-tag+ - +single-float-tag+ - +character-tag+ - +general-tag+ - +where-tag-mask+ - +derivable-where-tag+ - +rack-where-tag+ - +wrapped-where-tag+ - +header-where-tag+ - +literal-tag-char-code+ - +cons-size+ - +unwind-protect-dynenv-size+ - +binding-dynenv-size+ - *startup-primitives-as-list* - %void% - %i1% - %exception-struct% - %i16% - %i32% - %i32*% - %i64% - %i8**% - %i8*% - %i8% - %exn% - %ehselector% - %go-index% - %fixnum% - %word% - %mv-struct% - %size_t% - %t*% - %t*[0]% - %tsp% - %t*[0]*% - %tsp*% - %t**% - %t*[DUMMY]% - %t*[DUMMY]*% - %tmv% - %symbol% - %float% - %double% - %gcroots-in-module% - %gcroots-in-module*% - gcroots-in-module-initial-value - %function-description% - %function-description*% - entry-point-reference-index - irc-funcall-results-in-registers - 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 - make-file-metadata - make-function-metadata - function-info - function-info-cleavir-lambda-list-analysis - make-function-info - generate-function-for-arity-p - - irc-create-call-wft - irc-calculate-entry - compile-definition - codegen - compile-error-if-not-enough-arguments - compile-lambda-function - compile-lambda-list-code - make-calling-convention - compiler-error - compiler-warn - compiler-style-warn - note - define-primitive - warn-undefined-global-variable - warn-undefined-type - warn-cannot-coerce - warn-invalid-number-type - warn-icsp-iesp-both-specified - register-global-function-def - register-global-function-ref - safe-system - jit-constant-uintptr_t - irc-const-gep2-64 - irc-sext - irc-zext - irc-int-to-ptr - irc-ptr-to-int - irc-verify-module-safe - irc-verify-function - *suppress-llvm-output* - *optimization-level* - with-track-llvm-time - irc-add - irc-sub - irc-mul - irc-sdiv irc-srem - irc-udiv irc-urem - irc-shl irc-lshr irc-ashr - irc-add-clause - alloca - alloca-t* - alloca-exn - alloca-ehselector - alloca-go-index - alloca-i8 - alloca-i8* - alloca-i32 - alloca-size_t - alloca-return - alloca-vaslist - alloca-temp-values - alloca-arguments - irc-and - irc-or - irc-xor - irc-not - irc-basic-block-create - irc-begin-block - irc-br - irc-branch-to-and-begin-block - irc-cond-br - irc-call-or-invoke - irc-intrinsic-call-or-invoke - irc-bit-cast - irc-pointer-cast - irc-maybe-cast-integer-to-t* - irc-create-landing-pad - irc-exception-typeid* - irc-insert-value - irc-extract-value - irc-typed-gep - irc-typed-gep-variable - irc-smart-ptr-extract - irc-get-insert-block - irc-set-insert-point-basic-block - irc-size_t-*current-source-pos-info*-filepos - irc-size_t-*current-source-pos-info*-column - irc-size_t-*current-source-pos-info*-lineno - irc-icmp-eq - irc-icmp-ne - irc-icmp-ule - irc-icmp-ult - irc-icmp-uge - irc-icmp-ugt - irc-icmp-sle - irc-icmp-slt - irc-icmp-sge - irc-icmp-sgt - irc-intrinsic - irc-typed-load - irc-t*-load - irc-typed-load-atomic - irc-t*-load-atomic - irc-low-level-trace - irc-phi - irc-personality-function - irc-phi-add-incoming - irc-ret-void - irc-ret-null-t* - irc-ret - irc-undef-value-get - irc-store - irc-store-atomic - irc-cmpxchg - irc-struct-gep - vaslist-start - irc-read-slot - irc-write-slot - irc-make-tmv - irc-tmv-primary - irc-tmv-nret - irc-t*-result - irc-tmv-result - irc-make-vaslist - irc-vaslist-nvals - irc-vaslist-values - irc-vaslist-nth - irc-vaslist-nthcdr - irc-vaslist-last - irc-vaslist-butlast - irc-tag-vaslist - irc-unbox-vaslist - irc-header-stamp - irc-rack-stamp - irc-wrapped-stamp - irc-derivable-stamp - irc-switch - irc-add-case - irc-tag-fixnum - irc-tag-base-char - irc-untag-base-char - irc-tag-character - irc-untag-character - irc-trunc - irc-unreachable - irc-untag-fixnum - irc-untag-general - irc-untag-cons - irc-untag-vaslist - irc-tag-vaslist - irc-unbox-vaslist - irc-unbox-single-float - irc-box-single-float - irc-unbox-double-float - irc-box-double-float - irc-fdefinition - irc-setf-fdefinition - irc-real-array-displacement - irc-real-array-index-offset - irc-array-total-size - irc-array-rank - gen-%array-dimension - gen-instance-rack - gen-instance-rack-set - gen-rack-ref - gen-rack-set - gen-vaslist-pop - gen-vaslist-length - jit-constant-i1 - jit-constant-i8 - jit-constant-i32 - jit-constant-i64 - *default-function-attributes* - ensure-jit-constant-i64 - jit-constant-size_t - 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 - cleavir-lambda-list-analysis-cleavir-lambda-list - 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 - c++-struct-type - c++-struct*-type - c++-field-ptr - %closure%.offset-of[n]/t* - with-debug-info-generator - with-irbuilder - with-landing-pad - make-uintptr_t - +cons-car-offset+ - +cons-cdr-offset+ - +simple-vector._length-offset+ - +entry-point-arity-begin+ - +entry-point-arity-end+ - +number-of-entry-points+ - %uintptr_t% - %return-type% - %vaslist% - null-t-ptr - compile-error-if-too-many-arguments - *irbuilder-function-alloca* - irc-calculate-call-info - %RUN-AND-LOAD-TIME-VALUE-HOLDER-GLOBAL-VAR-TYPE% - compute-rest-alloc - tag-check-cond - header-check-cond - compile-tag-check - compile-header-check - ensure-xep-function-not-placeholder - general-entry-point-redirect-name - get-or-declare-function-or-error - ))) - -;;; exports for runall -(export '( - with-make-new-run-all - with-run-all-entry-codegen - with-run-all-body-codegen - generate-load-time-values - )) - -;;; exports for conditions -(export '(deencapsulate-compiler-condition - *default-condition-origin* - compiler-condition-origin - compiled-program-error - compiler-condition - undefined-variable-warning - undefined-function-warning - undefined-type-warning - redefined-function-warning - wrong-argcount-warning - compiler-macro-expansion-error-warning - unused-variable used-variable - fold-failure)) - -;;; Eclector -(export '(*cst-client* - clasp-eclector-client-mixin - clasp-cst-client)) - -(in-package :literal) - -(export '( - *byte-codes* - add-creator - next-value-table-holder-name - general-entry-placeholder-p - ensure-not-placeholder - make-general-entry-placeholder - make-literal-node-call - make-literal-node-creator - setup-literal-machine-function-vectors - run-all-add-node - entry-point-datum-for-xep-group - register-local-function-index - register-xep-function-indices - literal-node-runtime-p - literal-node-runtime-object - literal-node-closure-p - literal-node-creator-p - literal-node-creator-object - literal-node-creator-name - literal-node-creator-arguments - literal-node-side-effect-p - literal-node-side-effect-name - literal-node-side-effect-arguments - literal-node-call-p - literal-node-call-function - literal-node-call-source-pos-info - literal-node-call-holder - lookup-literal-index - reference-literal - load-time-reference-literal - compile-reference-to-literal - compile-load-time-value-thunk - new-table-index - constants-table-reference - constants-table-value - reference-function-cell - reference-variable-cell - load-time-value-from-thunk - with-rtv - arrange-thunk-as-top-level - with-literal-table)) - -(in-package :clasp-ffi) -(export '(with-foreign-object - with-foreign-objects - %foreign-alloc - %foreign-free - %mem-ref - %mem-set - %foreign-funcall - %foreign-funcall-pointer - %load-foreign-library - %close-foreign-library - %foreign-symbol-pointer - %foreign-type-size - %foreign-type-alignment - %defcallback - %callback - %get-callback - safe-translator-type)) - -(use-package :literal :cmp) diff --git a/src/lisp/kernel/cmp/cmpliteral.lisp b/src/lisp/kernel/cmp/cmpliteral.lisp deleted file mode 100644 index ef2113dc5d..0000000000 --- a/src/lisp/kernel/cmp/cmpliteral.lisp +++ /dev/null @@ -1,1003 +0,0 @@ -(in-package :literal) - -(defvar *gcroots-in-module*) -#+threads(defvar *value-table-id-lock* (mp:make-lock :name '*value-table-id-lock*)) -(defvar *value-table-id* 0) -(defun incf-value-table-id-value () - #+threads(unwind-protect - (progn - (mp:get-lock *value-table-id-lock*) - (incf *value-table-id*)) - (mp:giveup-lock *value-table-id-lock*)) - #-threads (incf *value-table-id*)) - -(defun next-value-table-holder-name (module-id &optional suffix) - (if suffix - (core:fmt nil "{}-{}{}" suffix core:+literals-name+ module-id) - (core:fmt nil "{}{}" core:+literals-name+ module-id))) - -(defstruct (literal-node-toplevel-funcall (:type vector) :named) arguments) -(defstruct (literal-node-call (:type vector) :named) function source-pos-info holder) -(defstruct (literal-node-side-effect (:type vector) :named) name arguments) -(defstruct (literal-dnode (:type vector) :named) datum) -(defstruct (literal-node-creator (:type vector) (:include literal-dnode) :named) - name literal-name object arguments) -(defstruct (literal-node-runtime (:type vector) (:include literal-dnode) :named) object) -(defstruct (literal-node-closure (:type vector) (:include literal-dnode) :named) function-index function entry-point-ref) - -(defstruct (function-datum (:type vector) :named) index) -#+short-float -(defstruct (short-float-datum (:type vector) :named) value) -(defstruct (single-float-datum (:type vector) :named) value) -(defstruct (double-float-datum (:type vector) :named) value) -#+long-float -(defstruct (long-float-datum (:type vector) :named) value) -(defstruct (immediate-datum (:type vector) :named) value) -(defstruct (datum (:type vector) :named) kind index literal-node-creator) - -(defun literal-datum-p (datum) - (eq (datum-kind datum) :literal)) - -(defun transient-datum-p (datum) - (eq (datum-kind datum) :transient)) - -(defun make-literal-datum (&key index) - (make-datum :kind :literal :index index)) - -(defun make-transient-datum () - (make-datum :kind :transient :index nil)) - -(defun upgrade-transient-datum-to-literal (datum) - (unless (transient-datum-p datum) - (error "The datum ~s must be a transient" datum)) - (setf (datum-kind datum) :literal) - (setf (datum-index datum) (new-table-index))) - -(defun literal-datum-index (datum) - (unless (literal-datum-p datum) - (error "The datum ~s must be a literal" datum)) - (datum-index datum)) - - -(defun datum-tag (datum) - (cond - ((literal-datum-p datum) #\l) - ((transient-datum-p datum) #\t) - (t (error "No tag for datum ~a" datum)))) - -(defun datum-index-tag-kind (datum) - (let ((index (datum-index datum)) - (tag (datum-tag datum)) - (kind (datum-kind datum))) - (values index tag kind))) - - -(defun literal-node-index (node) - (let ((datum (literal-dnode-datum node))) - (unless (literal-datum-p datum) - (error "The node ~a has a non-literal datum ~a" node datum)) - (datum-index datum))) - -(defparameter *literal-machine* nil) - -(defun run-all-add-node (node) - (vector-push-extend node (literal-machine-run-all-objects *literal-machine*)) - node) - -(defun calculate-table-size (nodes) - "Find the highest index and return 1+ that" - (let ((highest-index -1)) - (dolist (node nodes) - #+(or)(core:fmt t "generate-run-all-code generating node: {}%N" node) - (when (literal-node-creator-p node) - (let* ((datum (literal-dnode-datum node)) - (raw-index (datum-index datum))) - (when (literal-datum-p datum) - (setf highest-index (max highest-index raw-index)))))) - (1+ highest-index))) - -;;; ------------------------------------------------------------ -;;; -;;; Immediate objects don't need to be put into tables -;;; - -;;; Return NIL if the object is not immediate -;;; - if it is an immediate then return an immediate-datum object that -;;; contains the tagged immediate value. -(defun immediate-datum-or-nil (original) - (let ((immediate (core:create-tagged-immediate-value-or-nil original))) - (if immediate - (make-immediate-datum :value immediate) - nil))) - - - -(defun make-similarity-table (test) - (make-hash-table :test test)) - -(defun find-similar (object table) - (gethash object table)) - -(defun add-similar (object datum table) - (setf (gethash object table) datum)) - - -(defstruct (literal-machine (:type vector) :named) - (run-all-objects (make-array 64 :fill-pointer 0 :adjustable t)) - (table-index 0) - (function-vector (make-array 16 :fill-pointer 0 :adjustable t)) - (constant-data '()) - (identity-coalesce (make-similarity-table #'eq)) - (ratio-coalesce (make-similarity-table #'eql)) - (cons-coalesce (make-similarity-table #'eq)) - (complex-coalesce (make-similarity-table #'eql)) - (array-coalesce (make-similarity-table #'eq)) - (hash-table-coalesce (make-similarity-table #'eq)) - (bignum-coalesce (make-similarity-table #'eql)) - (symbol-coalesce (make-similarity-table #'eq)) - (base-string-coalesce (make-similarity-table #'equal)) - (pathname-coalesce (make-similarity-table #'equal)) - (function-description-coalesce (make-similarity-table #'equal)) - (entry-point-coalesce (make-similarity-table #'eq)) - (package-coalesce (make-similarity-table #'eq)) - (double-float-coalesce (make-similarity-table #'eql)) - #+long-float - (long-float-coalesce (make-similarity-table #'eql)) - (fcell-coalesce (make-similarity-table #'equal)) - (vcell-coalesce (make-similarity-table #'eq)) - (llvm-values (make-hash-table)) -) - - -;;; ------------------------------------------------------------ -;;; -;;; - -(defun new-table-index () - "Return the next ltv-index. If this is being invoked from COMPILE then -the value is put into *default-load-time-value-vector* and its index is returned" - (prog1 (literal-machine-table-index *literal-machine*) - (incf (literal-machine-table-index *literal-machine*)))) - -(defun finalize-transient-datum-indices (literal-machine) - "Give each datum a unique index" - (let* ((count (length (literal-machine-run-all-objects literal-machine))) - (ht (make-hash-table :size count)) - (index 0)) - (dotimes (lm-index count) - (let ((obj (elt (literal-machine-run-all-objects literal-machine) lm-index))) - (when (literal-dnode-p obj) - (let ((datum (literal-dnode-datum obj))) - (when (transient-datum-p datum) - (unless (gethash datum ht) - (setf (gethash datum ht) index) - (setf (datum-index datum) index) -;;; (format t "obj -> ~s~%" obj) - (incf index))))))) - index)) - -(defun new-datum (toplevelp) - (if toplevelp - (make-literal-datum :index (new-table-index)) - #+(or)(make-literal-datum :index (new-table-index)) - (make-transient-datum))) - -(defun lookup-literal-index (object) - "Given a literal object that has already been added to the literal table and will be recreated at load-time, -return the index in the literal table for that object. This is used in special cases like defcallback to -rewrite the slot in the literal table to store a closure." - (dolist (datum (literal-machine-constant-data *literal-machine*)) - (when (eq (literal-node-creator-object (datum-literal-node-creator datum)) object) - (unless (literal-datum-p datum) - (error "lookup-literal-index must passed an literal-datum - instead it got ~a" datum)) - (return-from lookup-literal-index (literal-datum-index datum)))) - (error "Could not find literal ~s" object)) - -(defun add-named-creator (name index literal-name object &rest args) - "Call the named function after converting fixnum args to llvm constants" - (let* ((creator (make-literal-node-creator :datum index :name name :literal-name literal-name :object object :arguments args)) - (primitive (gethash name cmp:*primitives*)) - (varargs (cmp:primitive-varargs primitive)) - (argument-types (cmp:primitive-argument-types primitive))) - (when (and (not varargs) (/= (length args) (- (length argument-types) 3))) - (error "You did not provide correct arguments for the primitive ~a~% varargs: ~a~% passed arguments: ~a~% needs arguments after third: ~a" - name varargs args argument-types)) - (setf (datum-literal-node-creator index) creator) - (push index (literal-machine-constant-data *literal-machine*)) - (run-all-add-node creator) - creator)) - -(defun add-creator (name index object &rest args) - "Call the named function after converting fixnum args to llvm constants" - (apply 'add-named-creator name index nil object args)) - -(defun add-side-effect-call (name &rest args) - "Call the named function after converting fixnum args to llvm constants" - (let ((rase (make-literal-node-side-effect :name name :arguments args))) - (run-all-add-node rase) - rase)) - -(defun add-side-effect-call-arglist (name args) - ;; identical to above, but without &rest - ;; because args could be tens of thousands long and i'm wary of blowing the stack - "Call the named function after converting fixnum args to llvm constants" - (let ((rase (make-literal-node-side-effect :name name :arguments args))) - (run-all-add-node rase) - rase)) - -(defstruct (general-entry-placeholder (:type vector) :named) - arity - name - cleavir-lambda-list-analysis - ) - -(defun ensure-not-placeholder (obj) - (when (general-entry-placeholder-p obj) - (error "The obj ~a must not be a general-entry-placeholder" obj)) - obj) - -(defun entry-point-datum-for-xep-group (xep-group) - (unless (cmp:xep-group-p xep-group) - (error "The argument ~a must be a xep-group" xep-group)) - (make-function-datum :index (cmp:entry-point-reference-index (cmp:xep-group-entry-point-reference xep-group)))) - -(defun register-function->function-datum-impl (function) - "Add a function to the (literal-machine-function-vector *literal-machine*)" - (unless (or (typep function 'llvm-sys:function) - (general-entry-placeholder-p function)) - (error "In register-function->function-datum-impl function ~s of ~s must be a function or a general-entry-placeholder" function (class-of function))) - (when (general-entry-placeholder-p function) - ;; Lookup a wrong-number-of-arguments function and use that - (let* ((wna-arity (general-entry-placeholder-arity function)) - (wna-function-name (cmp:general-entry-point-redirect-name wna-arity)) - (wna-function (cmp:get-or-declare-function-or-error cmp:*the-module* wna-function-name))) - (setf function wna-function))) - ;; Functions are laid out in linear order and xep-functions have all their entry points - ;; consecutive, one for each entry point - (let ((function-index (length (literal-machine-function-vector *literal-machine*)))) - (vector-push-extend function (literal-machine-function-vector *literal-machine*)) - (make-function-datum :index function-index))) - -(defun register-local-function->function-datum (local-fn) - "Add a function to the (literal-machine-function-vector *literal-machine*)" - (unless (typep local-fn 'llvm-sys:function) - (error "This ~a must be a llvm-sys:function - it is not" local-fn)) - (register-function->function-datum-impl local-fn)) - - -(defun register-xep-function->function-datums (f-or-p-list) - "Add a function to the (literal-machine-function-vector *literal-machine*)" - (let ((rev-datums nil)) - (dolist (xep-function-or-placeholder f-or-p-list) - (push (register-function->function-datum-impl xep-function-or-placeholder) rev-datums)) - ;; Make sure that all function indices are consecutive - (let ((datums (nreverse rev-datums)) - (prev-function-index nil)) - (dolist (datum datums) - (let ((cur-function-index (function-datum-index datum))) - (when prev-function-index - (unless (= (1+ prev-function-index) cur-function-index) - (error "The function indices for a xep-function are not consecutive"))) - (setf prev-function-index cur-function-index))) - datums))) - -(defun register-xep-function-indices (xep-arity-list) - "Add all functions in xep-function to the (literal-machine-function-vector *literal-machine*)" - (unless (listp xep-arity-list) - (error "Argument to register-xep-function-indices ~s must be a list" xep-arity-list)) - (let ((f-or-p-list (mapcar 'cmp:xep-arity-function-or-placeholder xep-arity-list))) - (unless (every (lambda (f-or-p) - (or (typep f-or-p 'llvm-sys:function) - (general-entry-placeholder-p f-or-p))) - f-or-p-list) - (error "The argument must be a list of functions or placeholders - it's a ~a" xep-arity-list)) - (let ((function-datums (register-xep-function->function-datums f-or-p-list))) - (mapcar 'function-datum-index function-datums)))) - -(defun register-local-function-index (local-function) - "Add a local function to the literal-machine-function-vector" - (function-datum-index (register-local-function->function-datum local-function))) - -;;; Helper function: we write a few things out as base strings. -;;; FIXME: Use a more efficient representation. -(defun prin1-to-base-string (object) - (with-output-to-string (s nil :element-type 'base-char) - (prin1 object s))) - -(defun ltv/nil (object index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (add-named-creator "ltvc_make_nil" index "NIL" object)) - -(defun ltv/t (object index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (add-named-creator "ltvc_make_t" index "T" object)) - -(defun ltv/ratio (ratio index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - (add-creator "ltvc_make_ratio" index ratio - (load-time-reference-literal (numerator ratio) read-only-p :toplevelp nil) - (load-time-reference-literal (denominator ratio) read-only-p :toplevelp nil))) - -(defun ltv/cons (cons index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - ;; While the general case (make_cons) works for all cases, - ;; it is far from the most efficient way to store a list. - ;; More importantly, for a long list we will recurse deeply and break the stack. - ;; So we have other alternatives for that. - (cond - ((core:proper-list-p cons) - (let* ((len (length cons)) - (val (add-creator "ltvc_make_list" index cons len))) - (add-side-effect-call-arglist - "ltvc_fill_list" - (list* val len - (mapcar (lambda (o) - (load-time-reference-literal o read-only-p :toplevelp nil)) - cons))) - val)) - (t - (let ((val (add-creator "ltvc_make_cons" index cons))) - (add-side-effect-call "ltvc_rplaca" val - (load-time-reference-literal (car cons) read-only-p :toplevelp nil)) - (add-side-effect-call "ltvc_rplacd" val - (load-time-reference-literal (cdr cons) read-only-p :toplevelp nil)) - val)))) - -(defun ltv/complex (complex index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - (add-creator "ltvc_make_complex" index complex - (load-time-reference-literal (realpart complex) read-only-p :toplevelp nil) - (load-time-reference-literal (imagpart complex) read-only-p :toplevelp nil))) - -(defun ltv/array (array index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - ;; We strip all non-simplicity out of arrays. As we do so it's important that we treat - ;; arrays with fill pointers as ending at that fill pointer - we don't want to restore - ;; the junk past the fill pointer into a simple array. - (multiple-value-bind (dims total-size) - (if (array-has-fill-pointer-p array) - (let ((L (length array))) (values (list L) L)) - (values (array-dimensions array) (array-total-size array))) - (let ((val (add-creator "ltvc_make_array" index array - (load-time-reference-literal (array-element-type array) read-only-p :toplevelp nil) - (load-time-reference-literal dims read-only-p :toplevelp nil)))) - (dotimes (i total-size) - (add-side-effect-call "ltvc_setf_row_major_aref" val i - (load-time-reference-literal (row-major-aref array i) read-only-p :toplevelp nil))) - val))) - -(defun ltv/hash-table (hash-table index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - (let ((ht (add-creator "ltvc_make_hash_table" index hash-table - (load-time-reference-literal (hash-table-test hash-table) read-only-p :toplevelp nil)))) - (maphash (lambda (key val) - (add-side-effect-call "ltvc_setf_gethash" ht - (load-time-reference-literal key read-only-p :toplevelp nil) - (load-time-reference-literal val read-only-p :toplevelp nil))) - hash-table) - ht)) - -(defun ltv/fixnum (fixnum index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (add-creator "ltvc_make_fixnum" index fixnum fixnum)) - -(defun ltv/bignum (bignum index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (add-creator "ltvc_make_next_bignum" index bignum bignum)) - -(defun ltv/bitvector (bitvector index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - (let ((bv-str (prin1-to-base-string bitvector))) - (add-creator "ltvc_make_bitvector" index bitvector - (load-time-reference-literal bv-str read-only-p :toplevelp nil)))) - -(defun ltv/random-state (random-state index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - (let ((rs-str (core:random-state-get random-state))) - (add-creator "ltvc_make_random_state" index random-state - (load-time-reference-literal rs-str read-only-p :toplevelp nil)))) - -(defun ltv/symbol (symbol index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - (let ((pkg (symbol-package symbol)) - (sym-str (symbol-name symbol))) - (add-named-creator "ltvc_make_symbol" index sym-str symbol - (load-time-reference-literal sym-str read-only-p :toplevelp nil) - (load-time-reference-literal pkg read-only-p :toplevelp nil)))) - -(defun ltv/character (char index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (add-creator "ltvc_make_character" index char - (char-code char))) - -(defun ltv/base-string (str index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (add-creator "ltvc_make_base_string" index str str)) - -(defun ltv/pathname (pathname index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - (add-creator "ltvc_make_pathname" index pathname - (load-time-reference-literal (pathname-host pathname) read-only-p :toplevelp nil) - (load-time-reference-literal (pathname-device pathname) read-only-p :toplevelp nil) - (load-time-reference-literal (pathname-directory pathname) read-only-p :toplevelp nil) - (load-time-reference-literal (pathname-name pathname) read-only-p :toplevelp nil) - (load-time-reference-literal (pathname-type pathname) read-only-p :toplevelp nil) - (load-time-reference-literal (pathname-version pathname) read-only-p :toplevelp nil))) - -(defun ltv/function-description (fdesc-ph index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - (add-creator "ltvc_make_function_description" index fdesc-ph - (load-time-reference-literal (sys:function-description-source-pathname fdesc-ph) read-only-p :toplevelp nil) - (load-time-reference-literal (sys:function-description-function-name fdesc-ph) read-only-p :toplevelp nil) - (load-time-reference-literal (sys:function-description-lambda-list fdesc-ph) read-only-p :toplevelp nil) - (load-time-reference-literal (sys:function-description-docstring fdesc-ph) read-only-p :toplevelp nil) - (load-time-reference-literal (sys:function-description-declares fdesc-ph) read-only-p :toplevelp nil) - (sys:function-description-lineno fdesc-ph) - (sys:function-description-column fdesc-ph) - (sys:function-description-filepos fdesc-ph))) - -(defun ltv/local-entry-point (entry-point index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - (let ((function-index (first (sys:core-fun-generator-entry-point-indices entry-point)))) - (add-creator "ltvc_make_local_entry_point" index entry-point - function-index - (load-time-reference-literal (sys:core-fun-generator/function-description entry-point) read-only-p :toplevelp nil)))) - -(defun ltv/global-entry-point (entry-point index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - (let ((function-index (first (sys:simple-core-fun-generator-entry-point-indices entry-point))) - (local-entry-point-index (sys:simple-core-fun-generator-local-fun-index entry-point))) - (add-creator "ltvc_make_global_entry_point" index entry-point - function-index - (load-time-reference-literal (sys:simple-core-fun-generator/function-description entry-point) read-only-p :toplevelp nil) - local-entry-point-index #+(or)(load-time-reference-literal (sys:global-entry-point-local-entry-point entry-point) read-only-p :toplevelp nil)))) - -(defun ltv/package (package index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp)) - (add-creator "ltvc_make_package" index package - (load-time-reference-literal (package-name package) read-only-p :toplevelp nil))) - -#+short-float/binary16 -(defun ltv/short-float (value index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (let* ((constant (make-short-float-datum :value value))) - (add-creator "ltvc_make_binary16" index value constant))) - -(defun ltv/single-float (single index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (let* ((constant (make-single-float-datum :value single))) - (add-creator "ltvc_make_binary32" index single constant))) - -(defun ltv/double-float (double index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (let* ((constant (make-double-float-datum :value double))) - (add-creator "ltvc_make_binary64" index double constant))) - -#+long-float/binary80 -(defun ltv/long-float (value index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (let* ((constant (make-long-float-datum :value value))) - (add-creator "ltvc_make_binary80" index value constant))) - -#+long-float/binary128 -(defun ltv/long-float (value index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (let* ((constant (make-long-float-datum :value value))) - (add-creator "ltvc_make_binary128" index value constant))) - -(defun call-with-constant-arguments-p (form &optional env) - (and (consp form) - (core:proper-list-p (rest form)) - (symbolp (first form)) - (when (fboundp (first form)) - (and (not (macro-function (first form))) - (not (special-operator-p (first form))))) - (every (lambda (f) (constantp f env)) (rest form)))) - -(defun ltv/mlf (object index read-only-p &key (toplevelp t)) - (declare (ignore toplevelp read-only-p)) - (multiple-value-bind (create initialize) - (make-load-form object) - (prog1 - ;; The compiler is slow, so we try to avoid it for a few common cases. - (cond - ((call-with-constant-arguments-p create) - (apply #'add-creator "ltvc_mlf_create_basic_call" index object - (load-time-reference-literal (first create) t :toplevelp nil) - (length (rest create)) - (mapcar (lambda (form) - (load-time-reference-literal - (ext:constant-form-value form) t :toplevelp nil)) - (rest create)))) - ;; General case - (t (let* ((fn (compile-form create)) - (name (cmp:xep-group-name fn))) - (add-creator "ltvc_set_mlf_creator_funcall" - index object (entry-point-datum-for-xep-group fn) name)))) - (when initialize - ;; If the form is a call to a named function, with all constant arguments, - ;; special case that to avoid the compiler. This covers e.g. the - ;; initialize-instance calls ASTs have as initialization forms. - (if (call-with-constant-arguments-p initialize) - (add-side-effect-call-arglist - "ltvc_mlf_init_basic_call" - (list* (load-time-reference-literal (first initialize) t :toplevelp nil) - (length (rest initialize)) - (mapcar (lambda (form) - (load-time-reference-literal - (ext:constant-form-value form) t :toplevelp nil)) - (rest initialize)))) - ;; General case. - (let* ((fn (compile-form initialize)) - (name (cmp:xep-group-name fn))) - (add-side-effect-call "ltvc_mlf_init_funcall" (entry-point-datum-for-xep-group fn) name))))))) - -(defun object-similarity-table-and-creator (literal-machine object read-only-p) - ;; Note: If an object has modifiable sub-parts, if we are not read-only-p - ;; we must use the (literal-machine-identity-coalesce literal-machine) or else the user will see spooky action at a distance. - (cond - ((null object) (values (literal-machine-identity-coalesce literal-machine) #'ltv/nil)) - ((eq t object) (values (literal-machine-identity-coalesce literal-machine) #'ltv/t)) - ((consp object) (values (literal-machine-cons-coalesce *literal-machine*) #'ltv/cons)) - ((fixnump object) (values nil #'ltv/fixnum)) - ((characterp object) (values nil #'ltv/character)) - #+short-float - ((core:short-float-p object) (values nil #'ltv/short-float)) - ((core:single-float-p object) (values nil #'ltv/single-float)) - ((symbolp object) (values (literal-machine-symbol-coalesce literal-machine) #'ltv/symbol)) - ((double-float-p object) (values (literal-machine-double-float-coalesce literal-machine) #'ltv/double-float)) - #+long-float - ((long-float-p object) (values (literal-machine-long-float-coalesce literal-machine) #'ltv/long-float)) - ((core:ratiop object) (values (literal-machine-ratio-coalesce literal-machine) #'ltv/ratio)) - ((sys:function-description-p object) (values (literal-machine-function-description-coalesce literal-machine) #'ltv/function-description)) - ((sys:core-fun-generator-p object) (values (literal-machine-function-description-coalesce literal-machine) #'ltv/local-entry-point)) - ((sys:simple-core-fun-generator-p object) (values (literal-machine-function-description-coalesce literal-machine) #'ltv/global-entry-point)) - ((bit-vector-p object) (values nil #'ltv/bitvector)) - ((core:base-string-p object) - (values (if read-only-p (literal-machine-identity-coalesce literal-machine) (literal-machine-base-string-coalesce literal-machine)) #'ltv/base-string)) - ((arrayp object) - (values (if read-only-p (literal-machine-identity-coalesce literal-machine) (literal-machine-array-coalesce literal-machine)) #'ltv/array)) - ((hash-table-p object) - (values (if read-only-p (literal-machine-identity-coalesce literal-machine) (literal-machine-hash-table-coalesce literal-machine)) #'ltv/hash-table)) - ((bignump object) (values (literal-machine-bignum-coalesce literal-machine) #'ltv/bignum)) - ((pathnamep object) (values (literal-machine-pathname-coalesce literal-machine) #'ltv/pathname)) - ((packagep object) (values (literal-machine-package-coalesce literal-machine) #'ltv/package)) - ((complexp object) (values (literal-machine-complex-coalesce literal-machine) #'ltv/complex)) - ((random-state-p object) (values (literal-machine-identity-coalesce literal-machine) #'ltv/random-state)) - (t #+(or)(warn "object-similarity-table-and-creator object -> ~s" object) - (values (literal-machine-identity-coalesce literal-machine) #'ltv/mlf)))) - -(defun write-argument-byte-code (arg stream byte-index) - (cond - ((function-datum-p arg) (core:ltvc-write-size-t (function-datum-index arg) stream byte-index)) - ((fixnump arg) (core:ltvc-write-size-t arg stream byte-index)) - ((characterp arg) (core:ltvc-write-char arg stream byte-index)) - ((stringp arg) (core:ltvc-write-string arg stream byte-index)) - ((core:bignump arg) (core:ltvc-write-bignum arg stream byte-index)) - ((immediate-datum-p arg) - (core:ltvc-write-object #\i (immediate-datum-value arg) stream byte-index)) - #+short-float - ((short-float-datum-p arg) (core:ltvc-write-short-float (long-float-datum-value arg) stream byte-index)) - ((single-float-datum-p arg) (core:ltvc-write-float (single-float-datum-value arg) stream byte-index)) - ((double-float-datum-p arg) (core:ltvc-write-double (double-float-datum-value arg) stream byte-index)) - #+long-float - ((long-float-datum-p arg) (core:ltvc-write-long-float (long-float-datum-value arg) stream byte-index)) - ((literal-dnode-p arg) - (cond - ((transient-datum-p (literal-dnode-datum arg)) - (core:ltvc-write-object #\t (datum-index (literal-dnode-datum arg)) stream byte-index)) - ((literal-datum-p (literal-dnode-datum arg)) - (core:ltvc-write-object #\l (datum-index (literal-dnode-datum arg)) stream byte-index)) - (t (error "Illegal literal-dnode object ~s" arg)))) - (t (error "write-argument-byte-code: handle object ~s" arg)))) - -(defun write-arguments-byte-code (arguments stream byte-index) - (dolist (arg arguments) - (setf byte-index (write-argument-byte-code arg stream byte-index))) - byte-index) - -(defun lookup-byte-code (name) - (let ((code (gethash name *byte-codes*))) - (unless code - (error "Could not find byte-code for ~a" name)) - code)) - -(defun write-literal-node-byte-code (fout node byte-index) - (cond - ((literal-node-creator-p node) - (let* ((datum (literal-dnode-datum node)) - (index (datum-index datum)) - (tag (datum-tag datum))) - (setf byte-index (core:ltvc-write-char (lookup-byte-code (literal-node-creator-name node)) fout byte-index)) - (setf byte-index (write-arguments-byte-code (list tag index) fout byte-index)) - (setf byte-index (write-arguments-byte-code (literal-node-creator-arguments node) fout byte-index)))) - ((literal-node-side-effect-p node) - (let* ((fn-name (literal-node-side-effect-name node)) - (args (literal-node-side-effect-arguments node))) - (setf byte-index (core:ltvc-write-char (lookup-byte-code fn-name) fout byte-index)) - (setf byte-index (write-arguments-byte-code args fout byte-index)))) - ((literal-node-toplevel-funcall-p node) - (setf byte-index (core:ltvc-write-char (lookup-byte-code "ltvc_toplevel_funcall") fout byte-index)) - (let ((arguments (cdr (literal-node-toplevel-funcall-arguments node)))) - ;; (format t "About to write arguments for literal-node-toplevel-funcall: ~s~%" arguments) - (setf byte-index (write-arguments-byte-code arguments fout byte-index)))) - ((literal-node-closure-p node) - (setf byte-index (core:ltvc-write-char (lookup-byte-code "ltvc_enclose") fout byte-index)) - (error "What do I do with the arguments for ~s" node) - (core:exit 1) - ) - (t (warn "Add support for node ~s" node))) - byte-index) - - -(defun write-literal-nodes-byte-code (nodes) - (let ((fout (make-string-output-stream)) - (byte-index 0)) - (dolist (node nodes) - (setf byte-index (write-literal-node-byte-code fout node byte-index))) - (setf byte-index (core:ltvc-write-char (code-char 0) fout byte-index)) - (get-output-stream-string fout))) - -;; Note that this is set up so that we don't need to actually create a -;; function cell in the compiler's environment. -(defun %reference-function-cell (fname) - (let* ((similarity (literal-machine-fcell-coalesce *literal-machine*)) - (existing (find-similar fname similarity))) - (if existing - (datum-literal-node-creator existing) - (let ((datum (new-datum t))) - (add-similar fname datum similarity) - (add-creator "ltvc_ensure_fcell" datum fname - (load-time-reference-literal fname t - :toplevelp nil)))))) - -(defun reference-function-cell (fname) - (let* ((data (if (cmp:generate-load-time-values) - (%reference-function-cell fname) - (run-time-reference-literal - (core:ensure-function-cell fname) nil))) - (index (literal-node-index data))) - (values index t))) - -(defun %reference-variable-cell (vname) - (let* ((similarity (literal-machine-vcell-coalesce *literal-machine*)) - (existing (find-similar vname similarity))) - (if existing - (datum-literal-node-creator existing) - (let ((datum (new-datum t))) - (add-similar vname datum similarity) - (add-creator "ltvc_ensure_vcell" datum vname - (load-time-reference-literal vname t - :toplevelp nil)))))) - -(defun reference-variable-cell (vname) - (let* ((data (if (cmp:generate-load-time-values) - (%reference-variable-cell vname) - (run-time-reference-literal - (core:ensure-variable-cell vname) nil))) - (index (literal-node-index data))) - (values index t))) - -(defparameter *ltv-trap* nil) - -(defun load-time-value-from-thunk (thunk) - "Arrange to evaluate the thunk into a load-time-value. -Return the index of the load-time-value" - (let ((datum (new-datum t))) - (add-creator "ltvc_set_ltv_funcall" datum nil (entry-point-datum-for-xep-group thunk) (cmp:xep-group-name thunk)) - (literal-datum-index datum))) - -(defun arrange-thunk-as-top-level (thunk) - "Arrange to evaluate the thunk as the top-level form." - (unless (cmp:xep-group-p thunk) - (error "The thunk ~s must be a xep-group" thunk)) - (run-all-add-node (make-literal-node-toplevel-funcall - :arguments (list *gcroots-in-module* - (entry-point-datum-for-xep-group thunk) - (cmp:xep-group-name thunk))))) - -(defun setup-literal-machine-function-vectors (the-module &key (id 0)) - (let* ((function-vector-length (length (literal-machine-function-vector *literal-machine*))) - (function-vector-type (llvm-sys:array-type-get cmp:%opaque-fn-prototype*% function-vector-length)) - (function-vector-global (llvm-sys:make-global-variable - the-module - function-vector-type - nil - 'llvm-sys:internal-linkage - (llvm-sys:constant-array-get function-vector-type - (map 'list - (lambda (fn) - (cmp:irc-bit-cast fn cmp:%opaque-fn-prototype*%)) - (literal-machine-function-vector *literal-machine*))) - (core:fmt nil "function-vector-{}" id)))) - (values function-vector-length function-vector-global function-vector-type))) - -(defun do-literal-table (id body-fn) - (let ((*gcroots-in-module* - (llvm-sys:make-global-variable cmp:*the-module* - cmp:%gcroots-in-module% ; type - nil ; isConstant - 'llvm-sys:internal-linkage - (cmp:gcroots-in-module-initial-value) - (core:fmt nil "{}{}" core:+gcroots-in-module-name+ (core:next-number)))) - (cmp:*load-time-value-holder-global-var-type* cmp:%t*[DUMMY]%) - (cmp:*load-time-value-holder-global-var* - (llvm-sys:make-global-variable cmp:*the-module* - cmp:%t*[DUMMY]% ; type - nil ; isConstant - 'llvm-sys:internal-linkage - (llvm-sys:undef-value-get cmp:%t*[DUMMY]%) - ;; nil ; initializer - (next-value-table-holder-name (core:next-number) "dummy"))) - (cmp:*generate-compile-file-load-time-values* t) - (real-name (next-value-table-holder-name (core:next-number))) ;; do we need to use a module-id??? - (*literal-machine* (make-literal-machine))) - (funcall body-fn) - ;; Generate the run-all function here - (let ((transient-entries (finalize-transient-datum-indices *literal-machine*))) - (cmp:with-run-all-body-codegen - (let ((ordered-run-all-nodes (coerce (literal-machine-run-all-objects *literal-machine*) 'list))) - (when *ltv-trap* - (break "Look at *literal-machine* ~a" *literal-machine*)) - (let* ((byte-code-string (write-literal-nodes-byte-code ordered-run-all-nodes)) - (byte-code-length (length byte-code-string)) - (byte-code-global (llvm-sys:make-string-global cmp:*the-module* byte-code-string - (core:fmt nil "startup-byte-code-{}" id)))) - (cmp:irc-intrinsic "cc_invoke_start_code_interpreter" - *gcroots-in-module* - (cmp:irc-bit-cast (cmp:irc-typed-gep (llvm-sys:array-type-get cmp:%i8% (1+ byte-code-length)) - byte-code-global (list 0 0)) - cmp:%i8*%) - (cmp:jit-constant-size_t byte-code-length) - (cmp:irc-bit-cast cmp::*current-function* cmp:%i8*%)) - (cmp:irc-intrinsic "cc_finish_gcroots_in_module" *gcroots-in-module*)))) - (let ((literal-entries (literal-machine-table-index *literal-machine*))) - (when t ;; (> literal-entries 0) - ;; We have a new table, replace the old one and generate code to register the new one - ;; and gc roots table - (let* ((array-type (llvm-sys:array-type-get cmp:%t*% literal-entries)) - (array-of-nulls (let (vals) - (dotimes (idx literal-entries) - (push (llvm-sys:constant-pointer-null-get cmp:%t*%) vals)) - vals)) - (correct-size-holder (llvm-sys:make-global-variable cmp:*the-module* - array-type - nil ; isConstant - 'llvm-sys:internal-linkage - (llvm-sys:constant-array-get array-type array-of-nulls) - real-name)) - (bitcast-correct-size-holder (cmp:irc-bit-cast correct-size-holder cmp:%t*[DUMMY]*% - "bitcast-table"))) - (llvm-sys:replace-all-uses-with cmp:*load-time-value-holder-global-var* - bitcast-correct-size-holder) - (multiple-value-bind (function-vector-length function-vector function-vector-type) - (setup-literal-machine-function-vectors cmp:*the-module* :id id) - (cmp:with-run-all-entry-codegen - (let ((transient-vector (cmp:alloca-i8* "transients"))) - (cmp:irc-intrinsic "cc_initialize_gcroots_in_module" - *gcroots-in-module* - (cmp:irc-pointer-cast correct-size-holder cmp:%t**% "") - (cmp:jit-constant-size_t literal-entries) - (cmp:irc-int-to-ptr (cmp:jit-constant-uintptr_t 0) - cmp:%t*%) - transient-vector - (cmp:jit-constant-size_t transient-entries) - (cmp:jit-constant-size_t function-vector-length) - (cmp:irc-bit-cast - (cmp:irc-typed-gep function-vector-type function-vector - (list 0 0)) - cmp:%i8**%) - )))) - ;; Erase the dummy holder - (llvm-sys:erase-from-parent cmp:*load-time-value-holder-global-var*))))))) - -(defmacro with-literal-table ((&key id)&body body) - `(do-literal-table ,id (lambda () ,@body))) - -(defun do-rtv (body-fn) - (let* ((cmp:*generate-compile-file-load-time-values* nil) - (module-id (core:next-jit-compile-counter)) - (cmp:*load-time-value-holder-global-var-type* cmp:%t*[0]%) - (cmp:*load-time-value-holder-global-var* - (llvm-sys:make-global-variable cmp:*the-module* - cmp:*load-time-value-holder-global-var-type* ; type - nil ; isConstant - 'llvm-sys:internal-linkage - nil - (next-value-table-holder-name module-id "dummy"))) - (*gcroots-in-module* - (llvm-sys:make-global-variable cmp:*the-module* - cmp:%gcroots-in-module% ; type - nil ; isConstant - 'llvm-sys:internal-linkage - (cmp:gcroots-in-module-initial-value) - (core:fmt nil "{}{}" core:+gcroots-in-module-name+ module-id))) - (*run-time-coalesce* (make-similarity-table #'eq)) - (*literal-machine* (make-literal-machine))) - (let* ((THE-REPL-FUNCTION (funcall body-fn)) - (run-time-values (coerce (literal-machine-run-all-objects *literal-machine*) 'list)) - (num-elements (length run-time-values)) - (constant-table nil)) - ;; Put the constants in order they will appear in the table. - ;; Return the orderered-raw-constants-list and the constants-table GlobalVariable - (when (> num-elements 0) - (let* ((ordered-literals-list (sort run-time-values #'< :key #'literal-node-index)) - (ordered-raw-constants-list - (mapcar (lambda (x) - (cond - ((literal-node-runtime-p x) - (literal-node-runtime-object x)) - ((and (literal-node-creator-p x) - (literal-node-closure-p - (literal-node-creator-object x))) - nil) - (t (error "Illegal object in ordered-literals-list it is: ~s" x)))) - ordered-literals-list)) - (array-type (llvm-sys:array-type-get cmp:%t*% (length ordered-literals-list)))) - (setf constant-table (llvm-sys:make-global-variable cmp:*the-module* - array-type - nil ; isConstant - 'llvm-sys:internal-linkage - (llvm-sys:undef-value-get array-type) - (next-value-table-holder-name module-id))) - (let ((bitcast-constant-table (cmp:irc-bit-cast constant-table cmp:%t*[0]*% "bitcast-table"))) - (llvm-sys:replace-all-uses-with cmp:*load-time-value-holder-global-var* bitcast-constant-table) - (llvm-sys:erase-from-parent cmp:*load-time-value-holder-global-var*) - (let ((cmp:*load-time-value-holder-global-var-type* cmp:%t*[0]%) - (cmp:*load-time-value-holder-global-var* bitcast-constant-table)) - (cmp:codegen-startup-shutdown cmp:*the-module* module-id THE-REPL-FUNCTION *gcroots-in-module* array-type constant-table num-elements ordered-literals-list) - (values ordered-raw-constants-list constant-table module-id)))))))) - -(defmacro with-rtv (&body body) - "Evaluate the code in the body in an environment where run-time values are assigned integer indices -starting from (literal-machine-table-index *literal-machine*) into a constants table and the run-time values are accumulated in *literal-machine*. -References to the run-time values are relative to the *load-time-value-holder-global-var*. -Once the body has evaluated, if there were run-time values accumulated then sort them by index and construct a new -global variable that can hold them all and replace every use of *load-time-value-holder-global-var* with this new constants-table. -Then erase the global variable in *load-time-value-holder-global-var* whether or not run time values were found -and return the sorted values and the constant-table or (values nil nil)." - `(do-rtv (lambda () (progn ,@body)))) - -(defun load-time-reference-literal (object read-only-p &key (toplevelp t)) - "If the object is an immediate object return (values immediate nil). - Otherwise return (values creator T)." - (let ((immediate-datum (immediate-datum-or-nil object)) - (desired-kind (if toplevelp :literal :transient))) - (if immediate-datum - (values immediate-datum nil) - (multiple-value-bind (similarity creator) - (object-similarity-table-and-creator *literal-machine* object read-only-p) - (let ((existing (if similarity (find-similar object similarity) nil))) - (cond - (existing - (when (and (eq desired-kind :literal) (eq :transient (datum-kind existing))) - (upgrade-transient-datum-to-literal existing)) - (values (datum-literal-node-creator existing) t)) - ;; Otherwise create a new datum at the current level of transientness - (t (let ((datum (new-datum toplevelp))) - (when similarity (add-similar object datum similarity)) - (values (funcall creator object datum read-only-p :toplevelp toplevelp) t))))))))) - -(defun pretty-load-time-name (object ltv-idx) - (cond - ((symbolp object) (core:fmt nil "SYMBOL->{}" object)) - ((consp object) "CONS") - ((arrayp object) "ARRAY") - ((numberp object) (format nil "NUMBER->~a" object)) - (t (subseq (core:fmt nil "ltv-idx_{}_val->{}" ltv-idx object) 0 30)))) - -;;;--------------------------------------------------------------------- -;;; -;;; run time values (i.e., cl:compile) -;;; - -(defvar *run-time-coalesce*) - -(declaim (ftype (function (t boolean) (values (or immediate-datum literal-node) boolean)) run-time-reference-literal)) -(defun run-time-reference-literal (object read-only-p) - "If the object is an immediate object return (values immediate nil nil). - Otherwise return (values creator T index)." - (declare (ignore read-only-p)) - (let ((immediate-datum (immediate-datum-or-nil object))) - (if immediate-datum - (values immediate-datum NIL) - (let* ((similarity *run-time-coalesce*) - (existing (find-similar object similarity))) - (if existing - (values existing T) - (values (let* ((datum (new-datum t)) - (new-obj (make-literal-node-runtime :datum datum :object object))) - (add-similar object new-obj similarity) - (run-all-add-node new-obj) - new-obj) - T)))))) - -;;; ------------------------------------------------------------ -;;; -;;; compile-form -;;; -;;; Compile the form and return a 0-arity function that -;;; returns a result. -;;; - -(defun compile-form (form) - (funcall (find-symbol "COMPILE-FORM" "CLASP-CLEAVIR") - form)) - -;;; ------------------------------------------------------------ -;;; ------------------------------------------------------------ -;;; ------------------------------------------------------------ -;;; -;;; reference-literal -;;; -;;; Returns an index for the object for both COMPILE-FILE and COMPILE -;;; ------------------------------------------------------------ -;;; ------------------------------------------------------------ -;;; ------------------------------------------------------------ - -(defun reference-literal (object &optional read-only-p) - "Return (values index T) for the literal object in a constants-table. - Returns (values :poison-value-from-reference-literal nil) if the object is an immediate and doesn't have a place in the constants-table." - (let ((cmp:*compile-file-debug-dump-module* nil) - (cmp:*compile-debug-dump-module* nil)) - (if (cmp:generate-load-time-values) - (multiple-value-bind (data in-array) - (load-time-reference-literal object read-only-p) - (if in-array - (values (literal-node-index data) T - (literal-node-creator-literal-name data)) - (values (cmp:irc-maybe-cast-integer-to-t* (immediate-datum-value data)) - nil))) - (multiple-value-bind (immediate-datum?literal-node-runtime in-array) - (run-time-reference-literal object read-only-p) - (if in-array - (let* ((literal-node-runtime immediate-datum?literal-node-runtime) - (index (literal-node-index literal-node-runtime))) - (values index T)) - (let ((immediate-datum immediate-datum?literal-node-runtime)) - (values (cmp:irc-maybe-cast-integer-to-t* (immediate-datum-value immediate-datum)) - nil))))))) - -;;; ------------------------------------------------------------ -;;; -;;; functions that are called by bclasp and cclasp that might -;;; be refactored to simplify the API - -(defun compile-reference-to-literal (literal - &optional (read-only-p t)) - "Generate a reference to a load-time-value or run-time-value literal depending if called from COMPILE-FILE or COMPILE respectively" - (multiple-value-bind (data-or-index in-array literal-name) - (reference-literal literal read-only-p) - (if in-array - (values (constants-table-reference data-or-index) literal-name) - data-or-index))) - -;;; ------------------------------------------------------------ -;;; -;;; Access load-time-values -;;; - -(defun constants-table-reference (index &key - (holder cmp:*load-time-value-holder-global-var*) - (holder-type cmp:*load-time-value-holder-global-var-type*) - literal-name) - (let ((label (if literal-name - (core:fmt nil "values-table[{}]/{}" index literal-name) - (core:fmt nil "values-table[{}]" index)))) - (cmp:irc-const-gep2-64 holder-type holder 0 index label))) - -(defun constants-table-value (index &key (holder cmp:*load-time-value-holder-global-var*) - (holder-type cmp:*load-time-value-holder-global-var-type*) - literal-name) - (cmp:irc-t*-load (constants-table-reference index - :holder holder - :holder-type holder-type - :literal-name literal-name))) - -(defun build-c++-byte-codes (primitives) - (let ((map (make-hash-table :test #'equal))) - (dolist (prim primitives) - (setf (gethash (third prim) map) (first prim))) - map)) - -(defvar *byte-codes* (build-c++-byte-codes cmpref:*startup-primitives-as-list*)) diff --git a/src/lisp/kernel/cmp/cmpltv.lisp b/src/lisp/kernel/cmp/cmpltv.lisp index 89575a4924..5dbcba0e0a 100644 --- a/src/lisp/kernel/cmp/cmpltv.lisp +++ b/src/lisp/kernel/cmp/cmpltv.lisp @@ -227,9 +227,7 @@ (%read-only-p :initarg :read-only-p :type boolean :reader load-time-value-creator-read-only-p) ;; The original form, for debugging/display - (%form :initarg :form :reader load-time-value-creator-form) - ;; The info object, for similarity checking - (%info :initarg :info :reader load-time-value-creator-info))) + (%form :initarg :form :reader load-time-value-creator-form))) (defclass init-object-array (instruction) ((%count :initarg :count :reader init-object-array-count))) @@ -274,10 +272,12 @@ (defclass function-native-attr (attribute) ((%name :initform (ensure-constant "clasp:function-native")) (%function :initarg :function :reader ll-function :type creator) - ;; Name of the main function (string) - (%main :initarg :main :reader main :type creator) - ;; Name of the XEP array (string) - (%xep :initarg :xep :reader xep :type creator))) + ;; ID number of the native module + (%module-id :initarg :id :reader module-id :type (unsigned-byte 16)) + ;; Index of the core function in the function vector + (%main :initarg :main :reader main :type (unsigned-byte 16)) + ;; Index of the first XEP function in the function vector + (%xep :initarg :xep :reader xep :type (unsigned-byte 16)))) #+clasp (defclass spi-attr (attribute) @@ -303,6 +303,7 @@ #+clasp (defclass module-native-attr (attribute) ((%name :initform (ensure-constant "clasp:module-native")) + (%id :initarg :id :reader id :type (unsigned-byte 16)) (%module :initarg :module :reader module :type creator) (%code :initarg :code :reader code :type (simple-array (unsigned-byte 8) (*))) @@ -381,14 +382,14 @@ (defmethod similarp ((creator vcreator) value) (eql (prototype creator) value)) -(defmethod similarp ((creator load-time-value-creator) ltvi) - (eql (load-time-value-creator-info creator) ltvi)) +;;; The global environment we're compiling in. Needed for load-time-value &c. +(defvar *environment*) ;;; EQL hash table from objects to creators. (defvar *coalesce*) ;;; Another EQL hash table for out-of-band objects that are also "coalesced". -;;; So far this means cfunctions and modules. +;;; So far this means cfunctions, modules, and ltv infos. ;;; This a separate variable because perverse code could use an out-of-band ;;; object in band (e.g. compiling a literal module) and we don't want to ;;; confuse those things. @@ -480,7 +481,7 @@ ;;; Given a form, get a constant handle to a function that at load time will ;;; have the effect of evaluating the form in a null lexical environment. -(defun add-form (form &optional env) +(defun add-form (form &optional (env *environment*)) ;; PROGN so that (declare ...) expressions for example correctly cause errors. (add-function (bytecode-cf-compile-lexpr `(lambda () (progn ,form)) env))) @@ -605,9 +606,9 @@ :prototype value :name (ensure-constant (symbol-name value))))))) -(defmethod add-constant ((value (eql nil))) +(defmethod add-constant ((value (eql 'nil))) (add-creator value (make-instance 'singleton-creator :prototype value))) -(defmethod add-constant ((value (eql t))) +(defmethod add-constant ((value (eql 't))) (add-creator value (make-instance 'singleton-creator :prototype value))) (defmethod add-constant ((value package)) @@ -699,10 +700,10 @@ ;;; function with all constant, #', or dumpable arguments (and not too many). ;;; Note that allowing these recursively dumpable forms may result in slightly ;;; subpar outcomes - for example we're not smart enough to turn the (LIST) -;;; arguments that appear in ENSURE-CLASS calls into constant NILs. +;;; arguments that appear in LOAD-DEFCLASS calls into constant NILs. ;;; But I (Bike) believe that's offset by the value of not making the loader ;;; make and run a one-time-use bytecode function. -(defun directly-creatable-form-p (form &optional env) +(defun directly-creatable-form-p (form &optional (env *environment*)) (or (constantp form env) ;; constantp includes non-symbols-or-lists, so this typecase is exhaustive (typecase form @@ -760,7 +761,7 @@ (rest form))))))) ;;; Make a possibly-special creator based on an MLF creation form. -(defun add-creation-form-creator (value form &optional env) +(defun add-creation-form-creator (value form &optional (env *environment*)) (let ((*creating* (cons value *creating*))) (if (directly-creatable-form-p form env) (let ((inst (add-direct-creator-form form env))) @@ -773,7 +774,7 @@ :function (add-form form env) :arguments ()))))) ;;; Make a possibly-special initializer. -(defun add-initializer-form (form &optional env) +(defun add-initializer-form (form &optional (env *environment*)) (cond ((constantp form env) nil) ; do nothing (good for e.g. defun's return) ((and (symbolp form) (not (nth-value 1 (macroexpand-1 form env)))) ;; also do nothing. this comes up for e.g. the *PACKAGE* returned from @@ -1435,13 +1436,17 @@ (defmethod ensure-module-literal ((info cmp:cfunction)) (ensure-function info)) +(defun ensure-ltv (info) + (or (find-oob info) + (add-oob + info + (make-instance 'load-time-value-creator + :function (add-form (cmp:load-time-value-info/form info)) + :read-only-p (cmp:load-time-value-info/read-only-p info) + :form (cmp:load-time-value-info/form info))))) + (defmethod ensure-module-literal ((info cmp:load-time-value-info)) - (add-instruction - (make-instance 'load-time-value-creator - :function (add-form (cmp:load-time-value-info/form info)) - :read-only-p (cmp:load-time-value-info/read-only-p info) - :form (cmp:load-time-value-info/form info) - :info info))) + (ensure-ltv info)) (defun ensure-fcell (name) (or (find-fcell name) @@ -1559,7 +1564,15 @@ collect i)) #+clasp -(defvar *native-compile-file-all* nil) +(defvar cmp:*compile-file-native* nil) +;; The ID number used for native code modules, if generated. +;; Different modules within the same init-object-array block must have +;; distinct numbers to name symbols distinctly. +#+clasp +(defvar *native-module-id*) + +#+clasp +(defvar *native-compile-thread-pool*) (defun add-module (value) ;; Add the module first to prevent recursion. @@ -1593,45 +1606,63 @@ :indices mutables)))) ;; Native compilation. #+clasp - (when *native-compile-file-all* - (let* ((native (funcall (find-symbol "COMPILE-CMODULE" - "CLASP-BYTECODE-TO-BIR") - bytecode info literals - :debug-namestring (namestring cmp::*compile-file-source-debug-pathname*))) - (code (funcall (find-symbol "NMODULE-CODE" - "CLASP-BYTECODE-TO-BIR") - native)) - (nlits (funcall (find-symbol "NMODULE-LITERALS" - "CLASP-BYTECODE-TO-BIR") - native))) - (add-instruction - (make-instance 'module-native-attr - :module mod - :code code - :literals (native-literals cliterals nlits))) - ;; Add attributes for the functions as well. - ;; We do this here instead of in the CFUNCTION methods because - ;; of the recursive nature of functions referring to modules - ;; referring to functions yada yada bla bla. - (loop with fmap = (funcall (find-symbol "NMODULE-FMAP" "CLASP-BYTECODE-TO-BIR") native) - for i across info - when (typep i 'cmp:cfunction) - do (let ((m (assoc i fmap))) - (assert m) - (destructuring-bind (main xep) (rest m) - (add-instruction - (make-instance 'function-native-attr - :function (ensure-function i) - :main (ensure-constant main) - :xep (ensure-constant xep)))))))) + (when cmp:*compile-file-native* + (if cmp::*compile-file-parallel* + (progn + (cmp::enqueue-native-compilation + *native-compile-thread-pool* + mod bytecode literals info *native-module-id* + (namestring cmp::*compile-file-source-debug-pathname*)) + (incf *native-module-id*)) + ;; serial - do it immediately + (handler-case + (let* ((id *native-module-id*) + (native (funcall (find-symbol "COMPILE-CMODULE" + "CLASP-BYTECODE-TO-BIR") + bytecode literals info id + (namestring cmp::*compile-file-source-debug-pathname*)))) + (incf *native-module-id*) + (add-native-module-instructions mod native)) + (serious-condition (e) + ;; error? who cares, native code is optional, move on + (cmp:note 'cmp:native-compilation-failure + :condition e))))) mod)) -(defun native-literals (cliterals nlits) - (map 'vector (lambda (lit) - (if (integerp lit) - (aref cliterals lit) - (ensure-module-literal lit))) - nlits)) +(defun add-native-module-instructions (module native-module) + (let* ((code (funcall (find-symbol "NMODULE-CODE" + "CLASP-BYTECODE-TO-BIR") + native-module)) + (nlits (funcall (find-symbol "NMODULE-LITERALS" + "CLASP-BYTECODE-TO-BIR") + native-module)) + (fmap (funcall (find-symbol "NMODULE-FMAP" + "CLASP-BYTECODE-TO-BIR") + native-module)) + (id (funcall (find-symbol "NMODULE-ID" + "CLASP-BYTECODE-TO-BIR") + native-module))) + (add-instruction + (make-instance 'module-native-attr + :module module + :id id + :code code + :literals (native-literals nlits))) + ;; Add attributes for the functions as well. + ;; We do this here instead of in the CFUNCTION methods because + ;; of the recursive nature of functions referring to modules + ;; referring to functions yada yada bla bla. + ;; It's possible that a bytecode function does not appear + ;; in the fmap. This can occur because e.g. it was inlined + ;; away. That's ok, it just means we don't dump an attr for it. + (loop for (f main xep) in fmap + do (add-instruction + (make-instance 'function-native-attr + :function (ensure-function f) + :id id :main main :xep xep))))) + +(defun native-literals (native-literals) + (map 'vector #'ensure-module-literal native-literals)) (defun ensure-module (module) (or (find-oob module) (add-module module))) @@ -1680,10 +1711,11 @@ (write-index (lambda-list attr) stream)) (defmethod encode ((attr function-native-attr) stream) - (write-b32 (* 3 *index-bytes*) stream) + (write-b32 (+ *index-bytes* 6) stream) (write-index (ll-function attr) stream) - (write-index (main attr) stream) - (write-index (xep attr) stream)) + (write-b16 (module-id attr) stream) + (write-b16 (main attr) stream) + (write-b16 (xep attr) stream)) #+clasp (defmethod encode ((attr spi-attr) stream) @@ -1927,7 +1959,8 @@ (cmp:lexenv/vars env) (cmp:lexenv/tags env) (cmp:lexenv/blocks env) (append macros (cmp:lexenv/funs env)) - (cmp:lexenv/decls env) (cmp:lexenv/frame-end env))))) + (cmp:lexenv/decls env) (cmp:lexenv/frame-end env) + (cmp:lexenv/global env))))) (defun bytecode-compile-toplevel-symbol-macrolet (bindings body env) (let ((smacros nil) (env (or env (cmp:make-null-lexical-environment)))) @@ -1943,9 +1976,9 @@ (append (nreverse smacros) (cmp:lexenv/vars env)) (cmp:lexenv/tags env) (cmp:lexenv/blocks env) (cmp:lexenv/funs env) (cmp:lexenv/decls env) - (cmp:lexenv/frame-end env))))) + (cmp:lexenv/frame-end env) (cmp:lexenv/global env))))) -(defun bytecode-compile-toplevel (form &optional (env (cmp:make-null-lexical-environment))) +(defun bytecode-compile-toplevel (form &optional (env *environment*)) (let ((core:*current-source-pos-info* (or (gethash form cmp:*source-locations*) core:*current-source-pos-info*)) @@ -1969,29 +2002,48 @@ (funcall (cmp:bytecompile `(lambda () (progn ,form)) env))) (bytecode-compile-file-form form env))))) +(defvar *reader-client* (make-instance 'cmp::clasp-tracking-eclector-client)) + ;; input is a character stream. (defun bytecode-compile-stream (input output-path - &key (environment - (cmp:make-null-lexical-environment)) + &key ((:environment *environment*)) &allow-other-keys) ;; *COMPILE-PRINT* is defined later in compile-file.lisp. (declare (special *compile-print*)) (with-constants () - ;; Read and compile the forms. - (loop with eof = (gensym "EOF") - with *compile-time-too* = nil - with eclector.reader:*client* = (make-instance 'cmp::clasp-tracking-elector-client) - with cfsdp = (core:file-scope cmp::*compile-file-source-debug-pathname*) - with cfsdl = cmp::*compile-file-source-debug-lineno* - with cfsdo = cmp::*compile-file-source-debug-offset* - for core:*current-source-pos-info* - = (core:input-stream-source-pos-info input cfsdp cfsdl cfsdo) - for cmp:*source-locations* = (make-hash-table :test #'eq) - for form = (eclector.parse-result:read eclector.reader:*client* input nil eof) - until (eq form eof) - do (when *compile-print* - (cmp::describe-form form)) - (bytecode-compile-toplevel form environment)) + (progv '(*native-compile-thread-pool*) + (if (and cmp:*compile-file-native* cmp::*compile-file-parallel*) + (list (cmp::make-nc-thread-pool)) + nil) ; don't bind + ;; Read and compile the forms. + (loop with eof = (gensym "EOF") + with *native-module-id* = 0 + with *compile-time-too* = nil + with eclector.reader:*client* + = (if *environment* + (make-instance 'cmp::clasp-alternate-env-client + :environment *environment*) + *reader-client*) + with cfsdp = (core:file-scope cmp::*compile-file-source-debug-pathname*) + with cfsdl = cmp::*compile-file-source-debug-lineno* + with cfsdo = cmp::*compile-file-source-debug-offset* + ;; Force this into a lexenv so macroexpand etc. work correctly + ;; with arbitrary global environments. + with env = (cmp:make-null-lexical-environment *environment*) + for core:*current-source-pos-info* + = (core:input-stream-source-pos-info input cfsdp cfsdl cfsdo) + for cmp:*source-locations* = (make-hash-table :test #'eq) + for form = (eclector.parse-result:read eclector.reader:*client* input nil eof) + until (eq form eof) + do (when *compile-print* + (cmp::describe-form form)) + (bytecode-compile-toplevel form env)) + ;; If we're native compile filing in parallel, write out those insts + (when (and cmp:*compile-file-native* cmp::*compile-file-parallel*) + (loop for (module nmodule) + in (cmp::thread-pool-finish *native-compile-thread-pool*) + unless (null nmodule) + do (add-native-module-instructions module nmodule)))) ;; Write out the FASL bytecode. (cmp:with-atomic-file-rename (temp-output-path output-path) (with-open-file (output temp-output-path diff --git a/src/lisp/kernel/cmp/cmpref-package.lisp b/src/lisp/kernel/cmp/cmpref-package.lisp new file mode 100644 index 0000000000..26d19c2364 --- /dev/null +++ b/src/lisp/kernel/cmp/cmpref-package.lisp @@ -0,0 +1,7 @@ +(defpackage #:cmpref + (:use #:cl) + (:export #:generate-virtual-machine-header) + (:export #:*dtree-ops-as-list* + #:+bytecode-ltv-ops+ #:+uaet-codes+ #:+debug-info-ops+) + (:export #:constant-arg-p #:label-arg-p #:keys-arg-p #:unmask-arg + #:decode-instr)) diff --git a/src/lisp/kernel/cmp/cmprunall.lisp b/src/lisp/kernel/cmp/cmprunall.lisp index c5974a9923..e87f98a714 100644 --- a/src/lisp/kernel/cmp/cmprunall.lisp +++ b/src/lisp/kernel/cmp/cmprunall.lisp @@ -1,82 +1,6 @@ (in-package :cmp) - - -(defvar *generate-compile-file-load-time-values* nil - "This variable controls whether literals are compiled into the -load-time-value manager (true - in COMPILE-FILE) or not (false - in COMPILE)." -) - - - -;;; Contains the current RUN-ALL, initialization function -;;; for the current module -(defvar *run-all-function*) - (defvar *load-time-value-holder-global-var-type* nil "Store the current load-time-value data structure type for COMPILE-FILE") (defvar *load-time-value-holder-global-var* nil "Store the current load-time-value data structure for COMPILE-FILE") - -(defvar *irbuilder-run-all-alloca* nil - "Maintains an IRBuilder for the load-time-value function alloca area") -(defvar *irbuilder-run-all-body* nil - "Maintain an IRBuilder for the load-time-value body area") - - -(defun do-make-new-run-all (body name-suffix) - (let ((run-all-fn (irc-simple-function-create (core:fmt nil "{}{}" core:+run-all-function-name+ name-suffix) - %fn-start-up% - 'llvm-sys:internal-linkage - *the-module* - :argument-names +fn-start-up-argument-names+ - :function-attributes (list* #|"optnone"|# *default-function-attributes*) - )) - (irbuilder-alloca (llvm-sys:make-irbuilder (thread-local-llvm-context))) - (irbuilder-body (llvm-sys:make-irbuilder (thread-local-llvm-context)))) - (let* ((*run-all-function* run-all-fn) - (*irbuilder-run-all-alloca* irbuilder-alloca) - (*irbuilder-run-all-body* irbuilder-body) - (*current-function* run-all-fn)) - (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)) - (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) - (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) - "Set up a run-all function in the current module, return the run-all-fn" - `(do-make-new-run-all (lambda (,run-all-fn) - (declare (ignorable ,run-all-fn)) - (progn ,@body)) - ,name-suffix)) - -(defmacro with-run-all-entry-codegen (&body form) - "Generate code within the ltv-function - used by codegen-load-time-value" - `(let ((*irbuilder-function-alloca* *irbuilder-run-all-alloca*) - (*current-function* *run-all-function*)) - (cmp:with-landing-pad nil - (cmp:with-irbuilder (*irbuilder-run-all-alloca*) - ,@form)))) - -(defmacro with-run-all-body-codegen ( &body form) - "Generate code within the ltv-function - used by codegen-load-time-value" - `(let ((*irbuilder-function-alloca* *irbuilder-run-all-alloca*) - (*current-function* *run-all-function*)) - (cmp:with-landing-pad nil - (cmp:with-irbuilder (*irbuilder-run-all-body*) - ,@form)))) - -(defun generate-load-time-values () *generate-compile-file-load-time-values*) diff --git a/src/lisp/kernel/cmp/cmpsetup.lisp b/src/lisp/kernel/cmp/cmpsetup.lisp index 6c0d1cc866..2c25e0680e 100644 --- a/src/lisp/kernel/cmp/cmpsetup.lisp +++ b/src/lisp/kernel/cmp/cmpsetup.lisp @@ -64,12 +64,6 @@ So don't make this external-linkage until you understand where this is coming fr (defvar *track-inlined-functions* nil "Keep track of cleavir inlined functions") -;; Generate C++ destructors for reference-counting otherwise don't -;; - -(defvar *compiler-suppress-dtors* #+use-refcount nil #-use-refcount t) -(export '*compiler-suppress-dtors*) - ;; ;; ;; Insert low-level tracing calls within the generated code at specific points @@ -116,5 +110,3 @@ Options are :tagbody :go :all :eh-landing-pads ;; current *module* for the form. The lambda returns T if cleavir succeeded in compiling the form ;; and nil otherwise (defvar *cleavir-compile-hook* nil) -(defvar *cleavir-compile-file-hook* nil) - diff --git a/src/lisp/kernel/cmp/cmputil.lisp b/src/lisp/kernel/cmp/cmputil.lisp index 5beca73c3a..7a656a4130 100644 --- a/src/lisp/kernel/cmp/cmputil.lisp +++ b/src/lisp/kernel/cmp/cmputil.lisp @@ -29,14 +29,11 @@ ;;;; in compiler-conditions.lisp. -(in-package :cmp) +(in-package #:cmp) (defvar *global-function-defs*) (defvar *global-function-refs*) -(defvar *warnings-p*) -(defvar *failure-p*) - ;;; The policy is computed later in cleavir/setup.lisp. (defvar *policy* ()) @@ -51,12 +48,12 @@ (defvar *active-protection* nil) -(defstruct (global-function-def (:type vector) :named) +(defstruct global-function-def type name source-pos-info) -(defstruct (global-function-ref (:type vector) :named) +(defstruct global-function-ref name source-pos-info) @@ -64,8 +61,6 @@ (and (boundp '*global-function-defs*) (gethash name *global-function-defs*))) -(export '(known-function-p)) ; FIXME MOVE - (defun register-global-function-def (type name) (when (boundp '*global-function-defs*) (let ((existing (gethash name *global-function-defs*)) @@ -104,30 +99,9 @@ (defmacro with-compilation-results ((&rest options) &body body) `(call-with-compilation-results (lambda () ,@body) ,@options)) -(export 'with-atomic-file-rename) (defmacro with-atomic-file-rename ((temp-pathname final-pathname) &body body) `(let ((,temp-pathname (core:mkstemp (namestring ,final-pathname)))) (unwind-protect - (progn - ,@body) + (progn ,@body) (when (core:file-kind ,temp-pathname t) (rename-file ,temp-pathname ,final-pathname :if-exists t))))) - -(defun write-bitcode (module output-path &key output-type) - ;; Write bitcode as either .bc files or .ll files - (ecase output-type - (:fasoll - (with-atomic-file-rename (temp-pathname output-path) - (with-open-file (fout temp-pathname :direction :output - :if-does-not-exist :create) - (llvm-sys:dump-module module fout)))) - (:fasobc - (with-atomic-file-rename (temp-pathname output-path) - (llvm-sys:write-bitcode-to-file module (namestring temp-pathname))))) - (let ((file-length 0)) - (with-open-file (fin output-path :direction :input) - (setf file-length (file-length fin))) - (if (= file-length 0) - (error "A zero length ~a file was written" output-type)))) - -;;;(setq core::*echo-repl-read* t) diff --git a/src/lisp/kernel/cmp/codegen-special-form.lisp b/src/lisp/kernel/cmp/codegen-special-form.lisp index 39968b6a50..2a8ab894a5 100644 --- a/src/lisp/kernel/cmp/codegen-special-form.lisp +++ b/src/lisp/kernel/cmp/codegen-special-form.lisp @@ -11,6 +11,7 @@ (lambda () (declare (core:lambda-name core::progv-lambda)) (progn ,@forms)))) +;;; progv-env defined in compile-file, since that's where we use it ;;; CORE::VECTOR-LENGTH diff --git a/src/lisp/kernel/cmp/compile-file-parallel.lisp b/src/lisp/kernel/cmp/compile-file-parallel.lisp index cbdb6dd647..7e70bdd984 100644 --- a/src/lisp/kernel/cmp/compile-file-parallel.lisp +++ b/src/lisp/kernel/cmp/compile-file-parallel.lisp @@ -1,389 +1,4 @@ - (in-package :cmp) -(defclass thread-pool () - ((%queue :initarg :queue :reader thread-pool-queue) - (%threads :initarg :threads :reader thread-pool-threads))) - -(defclass job () - ((%serious-condition :initform nil :accessor job-serious-condition - :type (or null serious-condition)) - (%warnings :initform nil :accessor job-warnings :type list) - (%notes :initform nil :accessor job-notes :type list) - (%other-conditions :initform nil :accessor job-other-conditions :type list))) - -(defun thread-pool-jobber (queue function arguments) - (lambda () - (unwind-protect - (loop for job = (core:dequeue queue :timeout 1.0 :timeout-val nil) - until (eq job :quit) - when job - do (block nil - (handler-bind - ((serious-condition - (lambda (e) - (setf (job-serious-condition job) e) - ;; Cannot continue with this job, - ;; so return to the loop to wait for more jobs. - (return))) - ;; Other conditions are suppressed and saved for the manager. - (warning - (lambda (w) (push w (job-warnings job)) (muffle-warning w))) - (ext:compiler-note - (lambda (n) (push n (job-notes job)) (muffle-note n))) - ((not (or ext:compiler-note serious-condition warning)) - (lambda (c) (push c (job-other-conditions job))))) - (apply function job arguments))))))) - -(defgeneric report-job-conditions (job) - (:method ((job job)) - (mapc #'signal (job-other-conditions job)) - ;; The WARN calls here never actually print warnings - the - ;; with-compilation-results handlers do, and then muffle the warnings - ;; (which is why we use WARN and not SIGNAL). Kind of ugly. - (mapc #'warn (job-warnings job)) - (mapc #'cmp:note (job-notes job)) - (when (job-serious-condition job) - ;; We use SIGNAL rather than ERROR although the condition is serious. - ;; This is because the job has already exited and therefore there - ;; is no way to debug the problem. with-compilation-results will - ;; still understand that it's an error and report compilation failure. - ;; It's possible we could save the original backtrace and so on, but - ;; if you want to debug problems, it would probably be easier to - ;; use the serial compiler and debug them as they appear. - (signal (job-serious-condition job))))) - -(defun make-thread-pool (function &key arguments (name 'thread-pool) - (nthreads (core:num-logical-processors)) - special-bindings) - (loop with queue = (core:make-queue name) - with conc-name = (format nil "~(~a~)-" (symbol-name name)) - for thread-num below nthreads - collect (mp:process-run-function - (format nil "~a-~d" conc-name thread-num) - (thread-pool-jobber queue function arguments) - special-bindings) - into threads - finally (return (make-instance 'thread-pool - :queue queue :threads threads)))) - -(defun thread-pool-enqueue (pool job) - (core:atomic-enqueue (thread-pool-queue pool) job)) - -(defun thread-pool-quit (pool) - (loop with queue = (thread-pool-queue pool) - for thread in (thread-pool-threads pool) - do (core:atomic-enqueue queue :quit) - (core:atomic-enqueue queue :quit))) - -(defun thread-pool-join (pool) - (loop for thread in (thread-pool-threads pool) - do (mp:process-join thread))) - -;;; - -(defclass ast-job (job) - ((%form :initarg :form :reader ast-job-form) - (%ast :initarg :ast :reader ast-job-ast) - (%output-object :initarg :output-object :accessor ast-job-output-object) - (%form-index :initarg :form-index :reader ast-job-form-index) - (%form-counter :initarg :form-counter :reader ast-job-form-counter) - (%module :accessor ast-job-module) - (%source-pos-info :initarg :source-pos-info :reader ast-job-source-pos-info) - (%startup-function-name :accessor ast-job-startup-function-name) - (%form-output-path :initarg :form-output-path :reader ast-job-form-output-path))) - -(defmethod report-job-conditions :around ((job ast-job)) - (let ((*default-condition-origin* - (ignore-errors - (loop for origin = (cleavir-ast:origin (ast-job-ast job)) - then (cst:source origin) - while (typep origin 'cst:cst) - finally (return origin))))) - (call-next-method))) - -;;; - -(defun compile-from-module (job - &key optimize - optimize-level - intermediate-output-type) - (declare (ignore optimize optimize-level)) - (let ((module (ast-job-module job))) - (ecase intermediate-output-type - (:in-memory-object - (let ((output (generate-obj-asm-stream - module (ast-job-output-object job) - 'llvm-sys:code-gen-file-type-object-file *default-reloc-model*))) - (when output (setf (ast-job-output-object job) output)))) - (:in-memory-module - (let ((llvm-ir (with-output-to-string (sout) - (llvm-sys:dump-module module sout)))) - (setf (ast-job-output-object job) llvm-ir)))) - (gctools:thread-local-cleanup)) - (values)) - -(defun ast-job-to-module (job &key optimize optimize-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-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)))) -;;; (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) - ))) - (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))) - -(defun compile-from-ast (job &key - optimize - optimize-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 - :intermediate-output-type intermediate-output-type)) - -(defun read-one-ast (source-sin environment eof-value) - ;; 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* ((current-source-pos-info (compile-file-source-pos-info source-sin)) - (core:*current-source-pos-info* current-source-pos-info) - ;; since cst-read returns a cst normally, we can use eof = nil. - ;; ...except that eclector.cst:read of "#+(or) 4 #.(or)" returns nil. - ;; Not sure if bug. - (cst (eclector.concrete-syntax-tree:read source-sin nil eof-value)) - (_ (when (eq cst eof-value) - (return-from read-one-ast (values nil nil nil)))) - (form (cst:raw cst)) - (pre-ast - (if *debug-compile-file* - (with-compiler-timer () - (clasp-cleavir-translate-bir::cst->ast cst environment)) - (clasp-cleavir-translate-bir::cst->ast cst environment)))) - (declare (ignore _)) - (when *compile-print* (describe-form form)) - (values (clasp-cleavir-translate-bir::wrap-ast pre-ast) - form current-source-pos-info))) - -(defun ast-job-special-bindings () - `((*compile-print* . ',*compile-print*) - (*compile-file-parallel* . ',*compile-file-parallel*) - (*default-output-type* . ',*default-output-type*) - (*compile-verbose* . ',*compile-verbose*) - (*compile-file-output-pathname* . ',*compile-file-output-pathname*) - (*package* . ',*package*) - (*compile-file-pathname* . ',*compile-file-pathname*) - (*compile-file-truename* . ',*compile-file-truename*) - (*compile-file-source-debug-pathname* - . ',*compile-file-source-debug-pathname*) - (*compile-file-source-debug-offset* - . ',*compile-file-source-debug-offset*) - (*compile-file-source-debug-lineno* - . ',*compile-file-source-debug-lineno*) - (*compile-file-file-scope* . ',*compile-file-file-scope*) - #+(or cclasp eclasp)(cleavir-cst-to-ast:*compiler* - . ',cleavir-cst-to-ast:*compiler*) - (*global-function-refs* . ',*global-function-refs*))) - -(defun cclasp-loop2 (source-sin - 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 - - ast-only) - "The loop that creates parallel jobs (ast-job). The jobs can be setup -to build the source->AST->HIR->LLVM-IR in serial mode and then compile the Module in parallel threads. -This is controlled using the :compile-from-module option. When it is T then -AST->HIR->LLVM-IR is done in serial and in parallel it compiles LLVM-IR->Object files. -Or it can go from source->AST and then compile the AST->HIR->LLVM-IR->ObjectFiles -in parallel threads. The reason for the two methods is that the AST->HIR uses the -garbage collector heavily and Boehm doesn't work well in multithreaded mode. -Boehm has a mutex and stack unwinding involves a mutex on linux. -So as an experiment I tried doing AST->HIR and HIR->LLVM-IR in serial and -then leave the LLVM stuff to be done in parallel. That slows down so much -that it's not worth it either. It would be better to improve the garbage collector (MPS) -to work better in a multithreaded way. There are also options for Boehm to improve -multithreaded performance that we should explore." - (let* ((output-object - (cond - ((eq intermediate-output-type :in-memory-object) - :simple-vector-byte8) - ((eq intermediate-output-type :in-memory-module) - nil) - (t - (error "Handle intermediate-output-type ~a" intermediate-output-type)))) - #+(or cclasp eclasp) (cleavir-cst-to-ast:*compiler* - 'cl:compile-file) - #+(or cclasp eclasp)(eclector.reader:*client* cmp:*cst-client*) - ast-jobs - (job-args `(:optimize ,optimize :optimize-level ,optimize-level - :intermediate-output-type ,intermediate-output-type)) - (pool (make-thread-pool (if compile-from-module - 'compile-from-module - 'compile-from-ast) - :arguments job-args - :name 'compile-file-parallel - :special-bindings (ast-job-special-bindings))) - (output-path-name (pathname-name output-path))) - (declare (ignore _)) - (unwind-protect - (loop with eof-value = (gensym "EOF") - for form-counter from 0 - for form-index = (core:next-startup-position) - for form-output-path = (make-pathname - :name (format nil "~a_~d" output-path-name - form-counter) - :defaults output-path) - do (multiple-value-bind (ast form cspi) - (read-one-ast source-sin environment eof-value) - (when (null ast) (return nil)) ; EOF - (let ((ast-job (make-instance 'ast-job - :form form :ast ast - :source-pos-info cspi - :form-output-path form-output-path - :output-object output-object - :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))) - (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. - ;; It's important to do this in the unwind-protect cleanup, - ;; so that if there is a read error we actually clean up the threads. - (thread-pool-quit pool)) - ;; Now wait for all threads to join - (thread-pool-join pool) - (mapc #'report-job-conditions ast-jobs) - ;; Now print the names of the startup ctor functions - ;; Next we need to compile a new module that declares these ctor functions and puts them in a ctor list - ;; then it should add this new module to the result list so it can be linked with the others. - #+(or) - (dolist (job ast-jobs) - (format t "ast-job ctor: ~a~%" (ast-job-startup-function-name job))) - ;; Now return the results - ast-jobs)) - - -(defun compile-stream-to-result (input-stream - &key - output-type - output-path - environment - (optimize t) - (optimize-level *optimization-level*) - ast-only) - "* Arguments -- given-input-pathname :: A pathname. -- output-path :: A pathname. -- 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 - (:faso :in-memory-object) - (:fasoll :in-memory-module) - (:fasobc :in-memory-module) - (:bytecode :in-memory-module)) - :ast-only ast-only)) - -(defun link-compile-file-parallel-modules (output-pathname parts) - "Link a bunch of modules together, return the linked module" - (let* ((link-module (llvm-create-module (pathname-name output-pathname)))) - ;; Don't enforce .bc extension for additional-bitcode-pathnames - ;; This is where I used to link the additional-bitcode-pathnames - (loop for part-llvm-ir in parts - for module = (llvm-sys:parse-irstring part-llvm-ir (thread-local-llvm-context) "") - do (multiple-value-bind (failure error-msg) - (llvm-sys:link-modules link-module module) - (when failure - (format t "While linking part module encountered error: ~a~%" error-msg)))) - link-module)) - -(defun output-cfp-result (ast-jobs output-path output-type) - (ensure-directories-exist output-path) - (case output-type - (:faso - (core:write-faso output-path - (mapcar #'ast-job-output-object - (sort (copy-list ast-jobs) #'< - :key #'ast-job-form-index)))) - (:fasoll - (with-open-file (fout output-path :direction :output :if-exists :supersede) - (llvm-sys:dump-module (link-compile-file-parallel-modules - (namestring output-path) - (mapcar #'ast-job-output-object ast-jobs)) - fout))) - (:fasobc - (llvm-sys:write-bitcode-to-file - (link-compile-file-parallel-modules (namestring output-path) - (mapcar #'ast-job-output-object ast-jobs)) - (namestring (translate-logical-pathname output-path)))) - (otherwise ;; unknown - (error "Add support for output-type: ~a" output-type)))) - -(defun compile-stream/parallel (input-stream output-path - &key (optimize t) - (optimize-level *optimization-level*) - (output-type *default-output-type*) - environment - ;; Use as little llvm as possible for timing - dry-run ast-only - &allow-other-keys) - (with-compiler-timer (:message "Compile-file-parallel" :report-link-time t :verbose *compile-verbose*) - (let ((ast-jobs - (compile-stream-to-result - input-stream - :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) - ((some #'job-serious-condition ast-jobs) - ;; There was an insurmountable error - fail. - nil) - ;; Usual result - (t (output-cfp-result ast-jobs output-path output-type) - (truename output-path)))))) - (eval-when (:load-toplevel) (setf *compile-file-parallel* *use-compile-file-parallel*)) diff --git a/src/lisp/kernel/cmp/compile-file.lisp b/src/lisp/kernel/cmp/compile-file.lisp index 612fb2fc65..fc1e4508ee 100644 --- a/src/lisp/kernel/cmp/compile-file.lisp +++ b/src/lisp/kernel/cmp/compile-file.lisp @@ -1,18 +1,7 @@ (in-package #:cmp) -#+(or) -(eval-when (:execute) - (setq core:*echo-repl-read* t)) - ;;;; Top level interface: COMPILE-FILE, etc. -;;; Use the *cleavir-compile-file-hook* to determine which compiler to use -;;; if nil == bclasp. Code for the bclasp compiler is in codegen-toplevel.lisp; -;;; look for t1expr. - -(defvar *compile-verbose* t) -(defvar *compile-print* t) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Describing top level forms (for compile-print) @@ -27,74 +16,22 @@ (terpri) (values)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Compilation units - -(defvar *compiler-real-time*) -(defvar *compiler-run-time*) -(defvar *compiler-timer-protection* nil) - -(defun do-compiler-timer (closure &rest args &key message report-link-time verbose override) - (declare (ignorable message report-link-time verbose)) - (cond (override - (let* ((*compiler-timer-protection* nil)) - (apply #'do-compiler-timer closure args))) - ((null *compiler-timer-protection*) - (let* ((*compiler-timer-protection* t) - (llvm-sys:*accumulated-llvm-finalization-time* 0) - (llvm-sys:*number-of-llvm-finalizations* 0) - (*compiler-real-time* (get-internal-real-time)) - (*compiler-run-time* (get-internal-run-time)) - (llvm-sys:*accumulated-clang-link-time* 0) - (llvm-sys:*number-of-clang-links* 0)) - (multiple-value-prog1 - (do-compiler-timer closure) - #+(or) - (when verbose - (let ((llvm-finalization-time llvm-sys:*accumulated-llvm-finalization-time*) - (compiler-real-time (/ (- (get-internal-real-time) *compiler-real-time*) (float internal-time-units-per-second))) - (compiler-run-time (/ (- (get-internal-run-time) *compiler-run-time*) (float internal-time-units-per-second))) - (link-time llvm-sys:*accumulated-clang-link-time*)) - (let* ((link-string (if report-link-time - (core:fmt nil " link({:.1f})" link-time) - "")) - (total-llvm-time (+ llvm-finalization-time (if report-link-time - link-time - 0.0))) - (percent-llvm-time (if (zerop compiler-real-time) - 0.0 - (* 100.0 (/ total-llvm-time compiler-real-time)))) - (percent-time-string - (if report-link-time - (core:fmt nil "(llvm+link)/real({:1.0f}%)" percent-llvm-time) - (core:fmt nil "llvm/real({:2.0f}%)" percent-llvm-time)))) - (core:fmt t " {} seconds real({:.1f}) run({:.1f}) llvm({:.1f}){} {}%N" - message - compiler-real-time - compiler-run-time - llvm-finalization-time - link-string - percent-time-string) - (finish-output))))))) - (t (funcall closure)))) - -(defmacro with-compiler-timer ((&key message report-link-time verbose) - &body body) - `(do-compiler-timer (lambda () (progn ,@body)) - :message ,message :report-link-time ,report-link-time :verbose ,verbose)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Compile-file pathnames -(defun cfp-output-file-default (input-file output-type &key target-backend) - (let* ((defaults (merge-pathnames input-file *default-pathname-defaults*))) - (when target-backend - (setq defaults (make-pathname :host target-backend :defaults defaults))) - (make-pathname :type (core:build-extension output-type) - :defaults defaults))) - +(defun build-extension (type) + (cond ((or (eq type :bytecode) + (member :bytecode *features*)) + "fasl") + ((eq type :faso) + "faso") + ((eq type :fasoll) + "fasoll") + ((eq type :fasobc) + "fasobc") + (t + (error "Unsupported build-extension type ~a" type)))) ;;; Copied from sbcl sb!xc:compile-file-pathname ;;; If INPUT-FILE is a logical pathname and OUTPUT-FILE is unsupplied, @@ -109,42 +46,38 @@ (output-type *default-output-type* output-type-p) target-backend &allow-other-keys) - (let ((pn (if output-file-p - (merge-pathnames output-file (translate-logical-pathname (cfp-output-file-default input-file output-type :target-backend target-backend))) - (cfp-output-file-default input-file output-type :target-backend target-backend))) - (ext (core:build-extension output-type))) - (if (or output-type-p (not output-file-p)) - (make-pathname :type ext :defaults pn :version nil) - pn))) + (let* ((input (pathname input-file)) + (output (if output-file-p (pathname output-file) nil)) + (host/dev/dir + (if (or (not output) + (member (pathname-directory output) '(nil :unspecific))) + input + output))) + (merge-pathnames + (flet ((pick (slot default &aux (specified (if output (funcall slot output)))) + ;; :unspecific is left alone, "as if the field were 'filled'" + ;; (http://www.lispworks.com/documentation/HyperSpec/Body/19_bbbca.htm) + ;; which makes little to zero sense at all for the PATHNAME-NAME + ;; of a fasl file, but is allowable for its PATHNAME-TYPE. + (cond ((or (not specified) + (and (eq specified :unspecific) (eq slot 'pathname-name))) + default) + (t + specified)))) + (make-pathname :host (pathname-host host/dev/dir) + :device (pathname-device host/dev/dir) + :directory (pathname-directory host/dev/dir) + ;; if the output exists and has a name, use it, otherwise + ;; use the input name + :name (pick 'pathname-name (pathname-name input)) + ;; if the output has a type that isn't :unspecific use it, + ;; otherwise use the default fasl type + :type (pick 'pathname-type (build-extension output-type))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Compile-file proper -(defun generate-obj-asm-stream (module output-stream file-type reloc-model &key (output-type *default-output-type*)) - (with-track-llvm-time - (progn - (let* ((triple-string (llvm-sys:get-target-triple module)) - (normalized-triple-string (llvm-sys:triple-normalize triple-string)) - (triple (llvm-sys:make-triple normalized-triple-string)) - (target-options (llvm-sys:make-target-options))) - (multiple-value-bind (target msg) - (llvm-sys:target-registry-lookup-target "" triple) - (unless target - (error msg)) - (llvm-sys:emit-module (llvm-sys:create-target-machine target - (llvm-sys:get-triple triple) - "" - "" - target-options - reloc-model - (code-model :jit nil :output-type output-type) - 'llvm-sys:code-gen-opt-default - nil) - output-stream - nil ; dwo-stream for dwarf objects - file-type module)))))) - (defvar *debug-compile-file* nil) (defvar *debug-compile-file-counter* 0) @@ -155,49 +88,6 @@ stream *compile-file-file-scope* *compile-file-source-debug-lineno* *compile-file-source-debug-offset*)) -(defun loop-read-and-compile-file-forms (source-sin environment) - ;; If the Cleavir compiler hook is set up then use that - ;; to generate code - (if *cleavir-compile-file-hook* - (funcall *cleavir-compile-file-hook* source-sin environment) - (error "BUG: No compiler in loop-read-and-compile-forms"))) - -(defun compile-stream-to-module (source-sin - &key - environment - image-startup-position - (optimize t) - (optimize-level *optimization-level*)) - "* Arguments -- source-sin :: An input stream to read forms from. -- environment :: A compilation environment. -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")) - (with-module (:module module - :optimize (when optimize #'llvm-sys:optimize-module) - :optimize-level optimize-level) - ;; (1) Generate the code - (with-debug-info-generator (:module *the-module* - :pathname *compile-file-source-debug-pathname*) - (with-make-new-run-all (run-all-function name) - (with-literal-table (:id 0) - (loop-read-and-compile-file-forms source-sin environment)) - (setf run-all-name (llvm-sys:get-name run-all-function)))) - (irc-verify-module-safe *the-module*) - (quick-module-dump *the-module* "preoptimize") - ;; (2) Add the CTOR next - (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 ---- - (quick-module-dump module "postoptimize") - module)) - (defun enable-bytecode-file-compiler () (setf *default-output-type* :bytecode)) @@ -213,23 +103,15 @@ Compile a Lisp source stream and return a corresponding LLVM module." ((:print *compile-print*) *compile-print*) (external-format :default) ;; Extensions - (execution (if *compile-file-parallel* - :parallel - :serial)) + ((:parallel *compile-file-parallel*) + *compile-file-parallel*) environment ; compilation environment + ;; Compile native versions of functions + ;; into bytecode fasls? + ((:native *compile-file-native*) + *compile-file-native*) ;; output-type can be (or :faso :fasobc :fasoll :bytecode) (output-type *default-output-type*) - ;; type can be either :kernel or :user - ;; FIXME: What does this do. - (type :user) - ;; A unique prefix for symbols of compile-file'd files that - ;; will be linked together - ;; FIXME: Only relevant for object files, I think. - ((:unique-symbol-prefix - *compile-file-unique-symbol-prefix*) - "") - ;; Control the order of startup functions (FIXME: ditto above) - (image-startup-position (core:next-startup-position)) (source-debug-pathname nil cfsdpp) ((:source-debug-lineno *compile-file-source-debug-lineno*) @@ -244,94 +126,41 @@ Compile a Lisp source stream and return a corresponding LLVM module." (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)) + (declare (ignore output-file optimize optimize-level)) "See CLHS compile-file." (with-compilation-unit () (let* ((output-path (apply #'compile-file-pathname input-file args)) - (*compilation-module-index* 0) ; FIXME: necessary? - (*readtable* *readtable*) (*package* *package*) (*optimize* *optimize*) (*policy* *policy*) - (*compile-file-pathname* + (compile-file-pathname (pathname (merge-pathnames input-file))) - (*compile-file-truename* - (translate-logical-pathname *compile-file-pathname*)) + (compile-file-truename + (translate-logical-pathname compile-file-pathname)) (*compile-file-source-debug-pathname* - (if cfsdpp source-debug-pathname *compile-file-truename*)) + (if cfsdpp source-debug-pathname compile-file-truename)) (*compile-file-file-scope* - (core:file-scope *compile-file-source-debug-pathname*)) - ;; bytecode compilation can't be done in parallel at the moment. - ;; we could possibly warn about it if execution was specified, - ;; but practically speaking it would mostly be noise. - (execution (if (eq output-type :bytecode) - :serial - execution))) - (with-open-file (source-sin input-file - :external-format external-format) - (with-compilation-results () - (when *compile-verbose* - (format t "~&; Compiling file: ~a~%" - (namestring input-file))) - (ecase execution - (:serial - (apply #'compile-stream/serial source-sin output-path args)) - (:parallel - ;; defined later in compile-file-parallel.lisp. - (apply #'compile-stream/parallel source-sin output-path - args)))))))) - -(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 - (type :user) - ;; Control the order of startup functions - (image-startup-position (core:next-startup-position)) - environment - &allow-other-keys) - (let ((*compile-file-parallel* nil)) - (if (eq output-type :bytecode) - (apply #'cmpltv:bytecode-compile-stream input-stream output-path args) - (with-compiler-timer (:message "Compile-file" - :report-link-time t - :verbose *compile-verbose*) - (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 - :position image-startup-position))))) + (core:file-scope *compile-file-source-debug-pathname*))) + ;; Many of the special variables (e.g. *optimize*) are not expected to be + ;; used by macroexpanders or other user code, so they can just always be + ;; bound in the usual environment. But a few are user-accessible. + (progv-env environment + '(*readtable* *package* *compile-file-pathname* *compile-file-truename*) + ;; FIXME: probably should read *readtable* and *package* from the env + (list *readtable* *package* compile-file-pathname compile-file-truename) + (with-open-file (source-sin input-file + :external-format external-format) + (with-compilation-results () + (when *compile-verbose* + (format t "~&; Compiling file: ~a~%" + (namestring input-file))) + (apply #'compile-stream source-sin output-path args))))))) + +(defun compile-stream (input-stream output-path &rest args + &key + (optimize t) + (optimize-level *optimization-level*) + (output-type *default-output-type*) + environment + &allow-other-keys) + (declare (ignore environment optimize-level optimize)) + (apply #'cmpltv:bytecode-compile-stream input-stream output-path args) (truename output-path)) - -(defun compile-file-output-module (module output-file output-type type - &key position) - (declare (ignore type)) - (setq output-file (make-pathname :defaults output-file :version nil - :type (core:build-extension output-type))) - (ensure-directories-exist output-file) - (when *compile-verbose* - (format t "~&; Writing ~a file to: ~a~%" output-type output-file)) - (ecase output-type - (:faso - (core:write-faso output-file - (list (generate-obj-asm-stream - module :simple-vector-byte8 - 'llvm-sys:code-gen-file-type-object-file - *default-reloc-model*)) - :start-object-id position)) - (:fasoll - (with-atomic-file-rename (temp-pathname output-file) - (with-open-file (fout temp-pathname :direction :output - :if-exists :supersede) - (llvm-sys:dump-module module fout)))) - (:fasobc - (with-atomic-file-rename (temp-pathname output-file) - (llvm-sys:write-bitcode-to-file module - (namestring temp-pathname))))) - (with-track-llvm-time (llvm-sys:module-delete module))) - -(export 'compile-file) diff --git a/src/lisp/kernel/cmp/compile.lisp b/src/lisp/kernel/cmp/compile.lisp index a9eb268bce..3fdb90c948 100644 --- a/src/lisp/kernel/cmp/compile.lisp +++ b/src/lisp/kernel/cmp/compile.lisp @@ -2,24 +2,24 @@ ;;;; Top-level interface: CL:COMPILE -(defparameter *lambda-args-num* 0) - -(defmacro with-module (( &key module - (optimize nil) - (optimize-level '*optimization-level*) - dry-run) &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) - (when (and ,optimize ,optimize-level (null ,dry-run)) (funcall ,optimize ,module ,optimize-level ))))) +;; When Cleavir is installed set the value of *cleavir-compile-hook* to use it to compile forms +;; It expects a function of one argument (lambda (form) ...) that will generate code in the +;; current *module* for the form. The lambda returns T if cleavir succeeded in compiling the form +;; and nil otherwise +(defvar *cleavir-compile-hook* nil) (defun compile-with-hook (compile-hook definition env) (with-compilation-unit () (with-compilation-results () (funcall compile-hook definition env)))) +(defun coerce-to-lexenv (thing) + (typecase thing + (null (make-null-lexical-environment)) + (lexenv thing) + (t ; assume cleavir. FIXME + (funcall (find-symbol "CLEAVIR-ENV->BYTECODE" "CLASP-CLEAVIR") thing)))) + ;;; This implements the pure functional part of CL:COMPILE, i.e. ;;; it computes and returns a compiled definition. It also accepts ;;; an environment argument. CL:COMPILE is defined in terms of this. @@ -58,7 +58,9 @@ (funcall *btb-compile-hook* bc nil) bc)) #-(or) - (funcall cmp:*cleavir-compile-hook* definition environment)))) + (if *cleavir-compile-hook* + (funcall *cleavir-compile-hook* definition environment) + (bytecompile definition (coerce-to-lexenv environment)))))) (t (error "COMPILE doesn't know how to handle ~a" definition)))) (defun compile (name &optional definition) @@ -78,10 +80,3 @@ (setf (fdefinition name) function) (values name warnp failp)) (t (values function warnp failp))))) - -(defun compiler-stats () - (core:fmt t "Accumulated finalization time {}%N" llvm-sys:*accumulated-llvm-finalization-time*) - (core:fmt t "Most recent finalization time {}%N" llvm-sys:*most-recent-llvm-finalization-time*) - (core:fmt t "Number of compilations {}%N" llvm-sys:*number-of-llvm-finalizations*)) - -(export 'compiler-stats) diff --git a/src/lisp/kernel/cmp/compiler-conditions.lisp b/src/lisp/kernel/cmp/compiler-conditions.lisp index 9620d6985a..a9f1bc948c 100644 --- a/src/lisp/kernel/cmp/compiler-conditions.lisp +++ b/src/lisp/kernel/cmp/compiler-conditions.lisp @@ -1,7 +1,6 @@ (in-package "CMP") -;;;; The final compiler condition system, replacing (and largely redefining) -;;;; the one in cmputil.lisp. +;;;; The final compiler condition system. ;;;; Much or most of this was originally cribbed from SBCL, ;;;; especially ir1report.lisp and main.lisp. @@ -62,15 +61,15 @@ (define-condition undefined-variable-warning (warning undefined-warning) - ((%kind :initform 'variable))) + ((%kind :initform 'variable :allocation :class))) (define-condition undefined-function-warning (style-warning undefined-warning) - ((%kind :initform 'function))) + ((%kind :initform 'function :allocation :class))) (define-condition undefined-type-warning (style-warning undefined-warning) - ((%kind :initform 'type))) + ((%kind :initform 'type :allocation :class))) (define-condition redefined-function-warning (warning compiler-condition) @@ -85,10 +84,10 @@ (redefinition-new-type condition) (compiler-warning-name condition) (redefinition-old-type condition) - (file-scope-pathname - (file-scope origin)) - (source-pos-info-lineno origin) - (source-pos-info-column origin)))))) + (core:file-scope-pathname + (core:file-scope origin)) + (core:source-pos-info-lineno origin) + (core:source-pos-info-column origin)))))) (define-condition wrong-argcount-warning (warning compiler-condition) @@ -122,8 +121,8 @@ ;; to survive compiler macros signaling errors. ;; This is kind of a KLUDGE, and doesn't do all the nice encapsulation ;; that we do in Cleavir. Plus we have no source location. -(defun cmp:expand-compiler-macro-safely (expander form env - &optional (origin (ext:current-source-location))) +(defun expand-compiler-macro-safely (expander form env + &optional (origin (ext:current-source-location))) (handler-case (funcall *macroexpand-hook* expander form env) (error (c) @@ -134,8 +133,7 @@ ;; These conditions are signaled by the bytecode compiler. ;; They are NOT signaled by Cleavir which uses its own conditions, ;; so that's kind of ugly. FIXME. -(define-condition cmp:unused-variable (style-warning - compiler-condition) +(define-condition unused-variable (style-warning compiler-condition) ((%name :initarg :name :reader name) (%setp :initarg :setp :reader setp)) (:report @@ -145,8 +143,7 @@ (symbolp name) (if (symbolp name) name (second name)) (setp condition)))))) -(define-condition cmp:used-variable (style-warning - compiler-condition) +(define-condition used-variable (style-warning compiler-condition) ((%name :initarg :name :reader name)) (:report (lambda (condition stream) @@ -156,7 +153,7 @@ (if (symbolp name) name (second name)) 'ignore))))) -(define-condition cmp:malformed-binding (program-error compiler-condition) +(define-condition malformed-binding (program-error compiler-condition) ((%operator :initarg :operator :reader operator) (%binding :initarg :binding :reader binding)) (:report @@ -165,14 +162,14 @@ (operator condition) (binding condition))))) ;;; redefined from bytecode_compiler.cc. -(defun cmp:warn-unused-variable (name &optional (origin (ext:current-source-location))) - (warn 'cmp:unused-variable :origin origin :name name :setp nil)) -(defun cmp:warn-used-ignored-variable (name &optional (origin (ext:current-source-location))) - (warn 'cmp:used-variable :origin origin :name name)) -(defun cmp:warn-set-unused-variable (name &optional (origin (ext:current-source-location))) - (warn 'cmp:unused-variable :origin origin :name name :setp t)) -(defun cmp:malformed-binding (operator binding &optional (origin (ext:current-source-location))) - (error 'cmp:malformed-binding :origin origin +(defun warn-unused-variable (name &optional (origin (ext:current-source-location))) + (warn 'unused-variable :origin origin :name name :setp nil)) +(defun warn-used-ignored-variable (name &optional (origin (ext:current-source-location))) + (warn 'used-variable :origin origin :name name)) +(defun warn-set-unused-variable (name &optional (origin (ext:current-source-location))) + (warn 'unused-variable :origin origin :name name :setp t)) +(defun malformed-binding (operator binding &optional (origin (ext:current-source-location))) + (error 'malformed-binding :origin origin :operator operator :binding binding)) ;; This condition is signaled when an attempt at constant folding fails @@ -200,14 +197,18 @@ Operation was (~s~{ ~s~})." (core::simple-style-warning compiler-condition) ()) +(in-package #:ext) ; KLUDGE: Survive package lock + ;;; These conditions are signaled when the compiler wants to tell the ;;; programmer something, but that something doesn't warrant even a style ;;; warning. For example, a note that the compiler cannot optimize something ;;; could be a note, since this inability is not a problem per se with the ;;; code, and it may just be that the compiler is inadequate. -(define-condition ext:compiler-note (compiler-condition) +(define-condition ext:compiler-note (cmp::compiler-condition) ()) +(in-package #:cmp) + (defun note (datum &rest arguments) ;; We don't use coerce-to-condition because there is no simple-note type ;; for cleanliness reasons. @@ -226,6 +227,19 @@ Operation was (~s~{ ~s~})." ;; somehow the restart is not active (this would be a bug) (invoke-restart (si::coerce-restart-designator 'muffle-note condition))) +;;; The native compiler has bugged out on some bytecode. +;;; This is not fatal, since we can just continue on without +;;; a native version. It indicates a compiler bug rather than +;;; anything wrong with the user code, so it shouldn't be a warning. +;;; (It's debatable if we should even signal it normally, but a note +;;; is at least harmless.) +(define-condition native-compilation-failure (ext:compiler-note) + ((%original-condition :reader original-condition :initarg :condition)) + (:report (lambda (condition stream) + (format stream "Unhandled serious condition while compiling native module:~%~a +Abandoning further work on it and moving on." + (original-condition condition))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Redefining some earlier error-noting calls, so that they @@ -290,10 +304,10 @@ 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-lineno origin) - (source-pos-info-column origin)) + (core:file-scope-pathname + (core:file-scope origin)) + (core:source-pos-info-lineno origin) + (core:source-pos-info-column origin)) (error (e) ;; Recursive errors are annoying. Therefore, (format *error-output* "~& at #~%" @@ -321,6 +335,9 @@ Operation was (~s~{ ~s~})." (defvar *compiler-style-warning-count* 0) (defvar *compiler-note-count* 0) +(defvar *warnings-p*) +(defvar *failure-p*) + ;;; Let errors through - lower level code should handle them if able, and otherwise ;;; it's a compiler bug and we ought to enter the debugger. ;;; This does mean that even if a higher level handler handles the condition, @@ -352,7 +369,6 @@ Operation was (~s~{ ~s~})." (print-compiler-condition condition) (muffle-note condition)) -;;; Redefinition. Used in e.g. compile-file. (defun call-with-compilation-results (thunk &rest options) (declare (ignore options)) (let ((*warnings-p* nil) (*failure-p* nil)) @@ -391,6 +407,8 @@ Operation was (~s~{ ~s~})." (handler-bind ((style-warning #'compiler-style-warning-handler) (warning #'compiler-warning-handler)) (maphash (lambda (name references) + ;; FIXME: FBOUNDP is not appropriate if we are compiling + ;; in some other environment. (unless (or (fboundp name) (gethash name *global-function-defs*)) (dolist (ref references) diff --git a/src/lisp/kernel/cmp/compiler-macro.lisp b/src/lisp/kernel/cmp/compiler-macro.lisp new file mode 100644 index 0000000000..01e360716e --- /dev/null +++ b/src/lisp/kernel/cmp/compiler-macro.lisp @@ -0,0 +1,52 @@ +(in-package #:core) + +(defun check-package-lock (name operation) ;; testing + (let ((package (symbol-package name))) + (when (and package (ext:package-locked-p package) + (not (member + *package* + (ext:package-implemented-by-list package)))) + (package-lock-violation package + "trying to ~s ~s" + operation name)))) + +(defvar *compiler-macros* (make-hash-table :test #'equal :thread-safe t)) + +(defun compiler-macro-function (name &optional environment) + (declare (ignore environment)) + (values (gethash name *compiler-macros*))) + +(defun (setf compiler-macro-function) (cmf name &optional environment) + (declare (ignore environment)) + (check-package-lock (function-block-name name) + 'define-compiler-macro) + ;; Basically ETYPECASE. + (if (functionp cmf) + (setf (gethash name *compiler-macros*) cmf) + (if (null cmf) + (progn (remhash name *compiler-macros*) nil) + (error 'type-error :datum cmf :expected-type '(or function null))))) + +(defun compiler-macroexpand-1 (form &optional env) + (if (atom form) + form + (or + (and (eq (car form) 'cl:funcall) + (listp (cadr form)) + (eq (car (cadr form)) 'cl:function) + (let ((expander (compiler-macro-function (cadr (cadr form)) env))) + (if expander + (funcall *macroexpand-hook* expander form env) + form))) + (let ((expander (compiler-macro-function (car form) env))) + (if expander + (funcall *macroexpand-hook* expander form env) + form))))) + +(defun compiler-macroexpand (form &optional env) + (let ((expansion (compiler-macroexpand-1 form env))) + (if (eq expansion form) + (return-from compiler-macroexpand form) + (compiler-macroexpand expansion env)))) + +(export '(compiler-macroexpand-1 compiler-macroexpand)) diff --git a/src/lisp/kernel/cmp/debuginfo.lisp b/src/lisp/kernel/cmp/debuginfo.lisp index c39f1853a4..5944106c0b 100644 --- a/src/lisp/kernel/cmp/debuginfo.lisp +++ b/src/lisp/kernel/cmp/debuginfo.lisp @@ -30,7 +30,7 @@ ;;; 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-generate-dwarf* (not (member :disable-dbg-generate-dwarf *features*))) (defvar *dbg-compile-unit*) (defvar *dbg-current-file*) (defvar *dbg-current-function-metadata*) @@ -59,7 +59,7 @@ (core:enum-logical-or llvm-sys:diflags-enum '(llvm-sys:diflags-zero)) 0))) -(defmacro with-dibuilder ((module) &rest body) +(defmacro with-dibuilder ((module) &body body) `(let ((*the-module-dibuilder* (llvm-sys:make-dibuilder ,module))) (unwind-protect (progn ,@body) @@ -78,7 +78,7 @@ (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) +(defmacro with-dbg-compile-unit ((source-pathname) &body body) (let ((path (gensym)) (file (gensym))) `(let* ((,path (pathname ,source-pathname)) @@ -140,11 +140,11 @@ (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) +(defmacro with-dbg-file-descriptor ((source-pathname) &body body) `(let ((*dbg-current-file* (make-file-metadata (pathname ,source-pathname)))) ,@body)) -(defmacro with-debug-info-generator ((&key module pathname) &rest body) +(defmacro with-debug-info-generator ((&key module pathname) &body body) "One macro that uses three other macros" (let ((body-func (gensym))) `(flet ((,body-func () ,@body)) @@ -190,7 +190,7 @@ (defun do-dbg-function (closure lineno function-type function) (declare (ignore function-type)) - (unless *current-source-pos-info* + (unless core:*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) @@ -205,14 +205,14 @@ (funcall closure)) (funcall closure))))) -(defmacro with-guaranteed-*current-source-pos-info* (() &rest body) +(defmacro with-guaranteed-*current-source-pos-info* (() &body 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) +(defmacro with-dbg-function ((&key lineno function-type function) &body body) `(do-dbg-function (lambda () (progn ,@body)) ,lineno ,function-type ,function)) @@ -243,7 +243,7 @@ (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)))) + (make-file-metadata (core:file-scope-pathname (core:file-scope file-handle)))) (defun cached-function-scope (function-scope-info &optional function-type) ;; See production in cleavir/inline-prep.lisp diff --git a/src/lisp/kernel/cmp/disassemble.lisp b/src/lisp/kernel/cmp/disassemble.lisp index af22d2aa48..ab4e369aa0 100644 --- a/src/lisp/kernel/cmp/disassemble.lisp +++ b/src/lisp/kernel/cmp/disassemble.lisp @@ -25,48 +25,7 @@ ;; -^- ;; -(in-package :cmp) - -(defun safe-llvm-get-name (what) - (llvm-sys:get-name what)) - -;;; Used by debugger - see clasp-debug:disassemble-frame -(defun disassemble-assembly (start end) - (format t "~&; disassemble-assembly Size: ~s Origin: ~s~%" (- (core:pointer-integer end) (core:pointer-integer start)) start) - (llvm-sys:disassemble-instructions (get-builtin-target-triple-and-data-layout) - start end)) - -(defun disassemble-function-to-asm (function) - (let ((function-pointers (core:function-pointer-alist function))) - (dolist (fp function-pointers) - (let ((entry-point-name (car fp)) - (address (cdr fp))) - (when address - (multiple-value-bind (symbol start end) - (core:lookup-address address) - (if symbol - (progn - (format t "Entry point ~a~%" (if (fixnump entry-point-name) - (format nil "xep~a" entry-point-name) - (string entry-point-name))) - (disassemble-assembly start end)) - (format t "; could not locate code object (bug?)~%")))))))) - -(defun potentially-save-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*))))) - -;;; should work for both lambda expressions and interpreted functions. -(defun disassemble-to-ir (thing) - (let* ((*save-module-for-disassemble* t) - (cmp:*saved-module-from-clasp-jit* nil)) - (compile nil thing) - (if cmp:*saved-module-from-clasp-jit* - (format t "~&Disassembly: ~a~%" cmp:*saved-module-from-clasp-jit*) - (error "Could not recover jitted module for ~a" thing))) - (values)) +(in-package #:cmp) (defun disassemble (desig &key (type :asm)) "If type is :ASM (the default) then disassemble to assembly language. @@ -80,10 +39,10 @@ If type is :IR then dump the LLVM-IR for all of the associated functions. ;; disassembled correctly. (disassemble (core:function/entry-point desig) :type type)) (core:bytecode-simple-fun - (unless (eq type :asm) - (error "Only disassembly to bytecode is supported for bytecode function: ~a" desig)) - (cmpref:disassemble-bytecode-function desig)) - (core:funcallable-instance + (ecase type + ((:asm) (disassemble-bytecode-function desig)) + ((:ir) (disassemble-to-ir desig)))) + (clos:funcallable-standard-object (disassemble (clos:get-funcallable-instance-function desig) :type type)) (core:gfbytecode-simple-fun (unless (eq type :asm) @@ -97,11 +56,11 @@ If type is :IR then dump the LLVM-IR for all of the associated functions. desig)) ((:asm) (disassemble-function-to-asm desig)))) ((or symbol (cons (eql setf) (cons symbol null))) ; function name - (core:fmt t "Disassembling function: {}%N" desig) + (format t "Disassembling function: ~a~%" desig) ;; This will (correctly) signal an error if the name is unbound. (disassemble (fdefinition desig) :type type)) ((cons (eql lambda)) ; lambda expression (roughly) (ecase type ((:ir) (disassemble-to-ir desig)) - ((:asm) (disassemble-function-to-asm (compile nil desig)))))) + ((:asm) (disassemble (compile nil desig) :type type))))) nil) diff --git a/src/lisp/kernel/cmp/eclector-client.lisp b/src/lisp/kernel/cmp/eclector-client.lisp deleted file mode 100644 index c0777d84ef..0000000000 --- a/src/lisp/kernel/cmp/eclector-client.lisp +++ /dev/null @@ -1,48 +0,0 @@ -(cl:in-package #:cmp) - -;;; So that non-cst-client can inherit behaviour -(defclass clasp-eclector-client-mixin ()()) - -(defclass clasp-cst-client (eclector.concrete-syntax-tree:cst-client clasp-eclector-client-mixin) ()) - -;; singleton- don't bother with constructor -(defvar *cst-client* - (locally (declare (notinline make-instance)) - (make-instance 'clasp-cst-client))) - -(defmethod eclector.base:source-position - ((client clasp-cst-client) stream) - (cmp:compile-file-source-pos-info stream)) - -(defmethod eclector.reader:find-character ((client clasp-eclector-client-mixin) name) - ;; This variable is defined in define-unicode-tables, which is loaded later. - (declare (special *additional-clasp-character-names*)) - (or (call-next-method) - (gethash name *additional-clasp-character-names*) - (simple-unicode-name name))) - -(defun map-make-structure-arguments (initargs) - (loop for all = initargs then (cddr all) - for key = (first all) and value = (second all) - while all - append (list - (if (keywordp key) key (intern (string key) :keyword)) - value))) - -(defmethod eclector.reader:make-structure-instance - ((client clasp-eclector-client-mixin) name initargs) - ;;; see discussion in https://github.com/s-expressionists/Eclector/issues/63 - ;;; initargs might be string-designators, not keywords, need to transform - (core::make-structure - name - (map-make-structure-arguments initargs))) - -(defmethod eclector.reader:wrap-in-quasiquote - ((client clasp-eclector-client-mixin) form) - (list 'core:quasiquote form)) -(defmethod eclector.reader:wrap-in-unquote - ((client clasp-eclector-client-mixin) form) - (list 'core::unquote form)) -(defmethod eclector.reader:wrap-in-unquote-splicing - ((client clasp-eclector-client-mixin) form) - (list 'core::unquote-splice form)) diff --git a/src/lisp/kernel/cmp/eclector.lisp b/src/lisp/kernel/cmp/eclector.lisp new file mode 100644 index 0000000000..ee66d5e69f --- /dev/null +++ b/src/lisp/kernel/cmp/eclector.lisp @@ -0,0 +1,296 @@ +(in-package #:cmp) + +;;; So that non-cst-client can inherit behaviour +(defclass clasp-eclector-client-mixin ()()) + +(defclass clasp-cst-client (eclector.concrete-syntax-tree:cst-client clasp-eclector-client-mixin) ()) + +;; singleton- don't bother with constructor +(defvar *cst-client* + (locally (declare (notinline make-instance)) + (make-instance 'clasp-cst-client))) + +;; Copy from build environment +(defvar *additional-clasp-character-names* '#.*additional-clasp-character-names*) +(defvar *mapping-char-code-to-char-names* '#.*mapping-char-code-to-char-names*) + +(defmethod eclector.base:source-position + ((client clasp-cst-client) stream) + (compile-file-source-pos-info stream)) + +(defun simple-unicode-name (name) + "If NAME is a string from \"U00\" to \"U10FFFF\", return the corresponding Unicode character." + (if (and (>= (length name) 3) (char-equal (char name 0) #\U)) + (let ((number (parse-integer name :start 1 :radix 16 :junk-allowed t))) + (if (and (numberp number) (<= #X00 number #X10FFFF)) + (code-char number) + nil)) + nil)) + +(defmethod eclector.reader:find-character ((client clasp-eclector-client-mixin) name) + ;; This variable is defined in define-unicode-tables, which is loaded later. + (declare (special *additional-clasp-character-names*)) + (or (call-next-method) + (gethash name *additional-clasp-character-names*) + (simple-unicode-name name))) + +(defun map-char-to-char-name (char) + (gethash char cmp::*mapping-char-code-to-char-names*)) + +(defun minimal-unicode-name (char) + (let ((code (char-code char))) + (format nil "U~x" code))) + +(defun cl:name-char (string-designator) + (let ((name (etypecase string-designator + (string string-designator) + (symbol (symbol-name string-designator)) + (character (string string-designator))))) + (eclector.reader:find-character *cst-client* name))) + +(defun cl:char-name (char) + (or + (values (map-char-to-char-name char)) + ;;; If there is no mapping, at least return "U" + ;;; Should be the exception + (minimal-unicode-name char))) + +(defun map-make-structure-arguments (initargs) + (loop for all = initargs then (cddr all) + for key = (first all) and value = (second all) + while all + append (list + (if (keywordp key) key (intern (string key) :keyword)) + value))) + +(defmethod eclector.reader:make-structure-instance + ((client clasp-eclector-client-mixin) name initargs) + ;;; see discussion in https://github.com/s-expressionists/Eclector/issues/63 + ;;; initargs might be string-designators, not keywords, need to transform + (core::make-structure + name + (map-make-structure-arguments initargs))) + +(defmethod eclector.reader:wrap-in-quasiquote + ((client clasp-eclector-client-mixin) form) + (list 'core:quasiquote form)) +(defmethod eclector.reader:wrap-in-unquote + ((client clasp-eclector-client-mixin) form) + (list 'core::unquote form)) +(defmethod eclector.reader:wrap-in-unquote-splicing + ((client clasp-eclector-client-mixin) form) + (list 'core::unquote-splice form)) + +(defmethod eclector.readtable:syntax-type ((readtable cl:readtable) char) + (core:syntax-type readtable char)) + +(defmethod eclector.readtable:get-macro-character ((readtable cl:readtable) char) + (cl:get-macro-character char readtable)) + +(defmethod eclector.readtable:set-macro-character + ((readtable cl:readtable) char function &optional non-terminating-p) + (cl:set-macro-character char function non-terminating-p readtable)) + +(defmethod eclector.readtable:get-dispatch-macro-character ((readtable cl:readtable) disp sub) + (cl:get-dispatch-macro-character disp sub readtable)) + +(defmethod eclector.readtable:set-dispatch-macro-character + ((readtable cl:readtable) disp sub function) + (cl:set-dispatch-macro-character disp sub function readtable)) + +(defmethod eclector.readtable:copy-readtable ((readtable cl:readtable)) + (cl:copy-readtable readtable)) + +(defmethod eclector.readtable:copy-readtable-into ((from cl:readtable) (to cl:readtable)) + (cl:copy-readtable from to)) + +(defmethod eclector.readtable:make-dispatch-macro-character + ((readtable cl:readtable) char &optional non-terminating-p) + (cl:make-dispatch-macro-character char non-terminating-p readtable)) + +(defmethod eclector.readtable:readtable-case (readtable) + (error 'type-error :datum readtable :EXPECTED-TYPE 'cl:readtable)) + +(defmethod eclector.readtable:readtable-case ((readtable cl:readtable)) + (cl:readtable-case readtable)) + +(defmethod (setf eclector.readtable:readtable-case) (mode (readtable cl:readtable)) + (setf (cl:readtable-case readtable) mode)) + +(defmethod (setf eclector.readtable:readtable-case) (mode readtable) + (declare (ignore mode)) + (error 'type-error :datum readtable :EXPECTED-TYPE 'cl:readtable)) + +(defmethod eclector.readtable:readtablep ((object cl:readtable)) t) + +(defvar core:*read-hook*) +(defvar core:*read-preserving-whitespace-hook*) + +;;; to avoid eclector.parse-result::*stack* being unbound, when *client* is bound to a parse-result-client +;;; Not sure whether this a a fortunate design in eclector + +(defclass clasp-non-cst-eclector-client (clasp-eclector-client-mixin) ()) +(defvar *clasp-normal-eclector-client* (make-instance 'clasp-non-cst-eclector-client)) + +(defclass clasp-tracking-eclector-client (clasp-eclector-client-mixin eclector.parse-result:parse-result-client) ()) + +;;; Used when compiling in a provided first-class global environment. +(defclass clasp-alternate-env-client (clasp-tracking-eclector-client) + ((%environment :initarg :environment :reader client-environment))) + +(defmethod eclector.base:source-position + ((client clasp-tracking-eclector-client) stream) + (compile-file-source-pos-info stream)) + +(defmethod eclector.parse-result:make-expression-result + ((client clasp-tracking-eclector-client) result children source) + (declare (ignore children)) + (when *source-locations* + (setf (gethash result *source-locations*) (car source))) + result) + +(defmethod eclector.reader:state-value + ((client clasp-eclector-client-mixin) (aspect (eql 'cl:*readtable*))) + cl:*readtable*) + +(defmethod eclector.reader:call-with-state-value + ((client clasp-eclector-client-mixin) thunk (aspect (eql 'cl:*readtable*)) value) + (let ((cl:*readtable* value)) + (funcall thunk))) + +(defmethod eclector.reader:state-value + ((client clasp-alternate-env-client) aspect) + (core:variable-cell/value + (core:fcge-ensure-vcell (client-environment client) aspect))) + +(defmacro progv-env (environment symbols values &body forms) + `(core:progv-env-function ,environment ,symbols ,values + (lambda () + (declare (core:lambda-name core::progv-env-lambda)) + (progn ,@forms)))) + +;;; Check local packages then defer to fcge-find-package. +;;; Also do the string coercion. +(defun env-find-package (environment name) + (let ((name (string name)) + (package (core:variable-cell/value + (core:fcge-ensure-vcell environment '*package*)))) + (or (cdr (assoc name (ext:package-local-nicknames package) :test #'string=)) + (core::fcge-find-package environment name)))) + +(defmethod eclector.reader:call-with-state-value + ((client clasp-alternate-env-client) thunk aspect value) + (progv-env (client-environment client) + (list aspect) (list value) + (funcall thunk))) +;; *package* has to have its designator coerced +(defmethod eclector.reader:call-with-state-value + ((client clasp-alternate-env-client) thunk (aspect (eql 'cl:*package*)) + value) + (let ((package (env-find-package (client-environment client) value))) + (assert (packagep package)) + (progv-env (client-environment client) + (list aspect) (list package) + (funcall thunk)))) + +(defmethod eclector.reader:evaluate-expression + ((client clasp-alternate-env-client) expression) + (core:interpret expression (client-environment client))) + +(defun find-package-or-err (environment name) + (or (env-find-package environment name) + (error 'package-error :package name))) + +(defmethod eclector.reader:interpret-symbol ((client clasp-alternate-env-client) + input-stream package-indicator + symbol-name internp) + (declare (ignore input-stream)) + (if (null package-indicator) + (make-symbol symbol-name) + (let ((package (case package-indicator + (:current + (let ((cur (eclector.reader:state-value + client '*package*))) + ;; We disallow this through Eclector above, but + ;; there are other ways we can't control in which + ;; *package* could be set to something illegal. + (assert (packagep cur) () + "~s is not bound to a package" '*package*) + cur)) + (:keyword (find-package-or-err (client-environment client) + "KEYWORD")) + (t (find-package-or-err (client-environment client) + package-indicator))))) + (if internp + (intern symbol-name package) + (multiple-value-bind (symbol status) + (find-symbol symbol-name package) + (ecase status + ((:external) symbol) + ((:internal :inherited) + (error "~a is not external in ~a" + symbol-name package-indicator)) + ((nil) + (error "No symbol ~a:~a" package-indicator symbol-name)))))))) + +(defun read-with-eclector (&optional (input-stream *standard-input*) + (eof-error-p t) + (eof-value nil) + (recursive-p nil)) + (let ((eclector.reader:*client* *clasp-normal-eclector-client*)) + (eclector.reader:read input-stream eof-error-p eof-value recursive-p))) + +(defun read-preserving-whitespace-with-eclector + (&optional (input-stream *standard-input*) + (eof-error-p t) + (eof-value nil) + (recursive-p nil)) + (let ((eclector.reader:*client* *clasp-normal-eclector-client*)) + (eclector.reader:read-preserving-whitespace input-stream eof-error-p + eof-value recursive-p))) + +(defun cl:read-from-string (string + &optional (eof-error-p t) eof-value + &key (start 0) (end (length string)) + preserve-whitespace) + (let ((eclector.reader:*client* *clasp-normal-eclector-client*)) + (eclector.reader:read-from-string string eof-error-p eof-value + :start start :end end + :preserve-whitespace preserve-whitespace))) + +;;; Fixed in https://github.com/s-expressionists/Eclector/commit/19d2d903bb04e3e59ff0557051e134e8ee6195c7 +(defun cl:read-delimited-list (char &optional (input-stream *standard-input*) recursive-p) + (let ((eclector.reader:*client* *clasp-normal-eclector-client*)) + (eclector.reader:read-delimited-list char input-stream recursive-p))) + +(defun core::set-eclector-reader-readmacros (readtable) + (eclector.reader:set-standard-macro-characters readtable) + (eclector.reader:set-standard-dispatch-macro-characters readtable) + (cl:set-dispatch-macro-character #\# #\A 'core:sharp-a-reader readtable) + (cl:set-dispatch-macro-character #\# #\D 'core::do-read-dense-specialized-array readtable) + (cl:set-dispatch-macro-character #\# #\I 'core::read-cxx-object readtable)) + +(defun init-clasp-as-eclector-reader () + (core::set-eclector-reader-readmacros cl:*readtable*) + (core::set-eclector-reader-readmacros (symbol-value 'core:+standard-readtable+)) + ;;; also change read + ;;; read-from-string is overwritten above + (setq core:*read-hook* 'read-with-eclector) + (setq core:*read-preserving-whitespace-hook* 'read-preserving-whitespace-with-eclector)) + +(init-clasp-as-eclector-reader) + +(defun patch-object (client value-old seen-objects) + (multiple-value-bind (state object*) + (eclector.reader:labeled-object-state client value-old) + (case state + ((nil) ; normal object + (eclector.reader:fixup client value-old seen-objects) + value-old) + ((:final :final/circular) object*) ; fully resolved circular reference + (otherwise value-old)))) ; unresolved reference - leave for later + +(defmethod eclector.reader:fixup (client (object core:cxx-object) seen-objects) + (let ((patcher (core:make-record-patcher (lambda (object) + (patch-object client object seen-objects))))) + (core:patch-object object patcher))) diff --git a/src/lisp/kernel/cmp/exports.lisp b/src/lisp/kernel/cmp/exports.lisp new file mode 100644 index 0000000000..ce3f60d28a --- /dev/null +++ b/src/lisp/kernel/cmp/exports.lisp @@ -0,0 +1,395 @@ +(in-package :cmp) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(export '(with-debug-info-source-position + code-walk + calculate-cleavir-lambda-list-analysis + module-report + transform-lambda-parts + codegen-startup-shutdown + jit-startup-shutdown-function-names jit-repl-function-name + unescape-and-split-jit-name + irc-simple-function-create + find-intrinsic-name + +intrinsic/llvm.eh.typeid.for.p0+ + +intrinsic/llvm.stacksave.p0+ + +intrinsic/llvm.stackrestore.p0+ + *primitives* + primitive-argument-types + primitive-varargs + *track-inlined-functions* + *track-inlinee-name* + *debug-link-options* ;; A list of strings to inject into link commands + *compile-file-debug-dump-module* ;; Dump intermediate modules + *compile-debug-dump-module* ;; Dump intermediate modules + *default-linkage* + *compile-file-parallel-write-bitcode* + *default-compile-linkage* + quick-module-dump + code-model + write-bitcode + parse-bitcode + link-bitcode-modules-together + *irbuilder* + *compile-file-unique-symbol-prefix* + *optimize* *policy* + policy ; used as a doc-type + %ltv*% + irc-function-create + irc-make-function-description + irc-local-function-create + irc-xep-functions-create + make-xep-group + xep-group-p + xep-group-arities + xep-group-name + xep-group-generator + xep-group-cleavir-lambda-list-analysis + +c++-stamp-max+ + %opaque-fn-prototype*% + fn-prototype + *cleavir-compile-hook* + *btb-compile-hook* + *compile-print* + *current-function* + *current-function-name* + *current-unwind-landing-pad-dest* + *debug-compile-file* + *debug-compile-file-counter* + *generate-compile-file-load-time-values* + *gv-current-function-name* + *thread-safe-context* + thread-local-llvm-context + *load-time-value-holder-global-var-type* + *load-time-value-holder-global-var* + *low-level-trace* + *low-level-trace-print* + *the-module* + +header-size+ + +header-stamp-size+ + +header-stamp-offset+ + +ptag-mask+ +immediate-mask+ + +cons-tag+ + +fixnum-mask+ + +fixnum-shift+ + +fixnum00-tag+ + +fixnum01-tag+ + #+tag-bits4 +fixnum10-tag+ + #+tag-bits4 +fixnum11-tag+ + +character-shift+ + +character-tag+ + +alignment+ + #+tag-bits4 +vaslist-ptag-mask+ + +vaslist0-tag+ + #+tag-bits4 +vaslist1-tag+ + +single-float-tag+ + +character-tag+ + +general-tag+ + +where-tag-mask+ + +derivable-where-tag+ + +rack-where-tag+ + +wrapped-where-tag+ + +header-where-tag+ + +literal-tag-char-code+ + +cons-size+ + +vaslist-size+ +vaslist-alignment+ + +unwind-protect-dynenv-size+ + +binding-dynenv-size+ + +void*-size+ + %void% + %i1% + %exception-struct% + %i16% + %i32% + %i32*% + %i64% + %i8**% + %i8*% + %i8% + %exn% + %ehselector% + %go-index% + %fixnum% + %word% + %mv-struct% + %size_t% + %t*% + %t*[0]% + %tsp% + %t*[0]*% + %tsp*% + %t**% + %t*[DUMMY]% + %t*[DUMMY]*% + %tmv% + %symbol% + %float% + %double% + %function-description% + %function-description*% + irc-funcall-results-in-registers + 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 + make-file-metadata + make-function-metadata + function-info + function-info-cleavir-lambda-list-analysis + make-function-info + generate-function-for-arity-p + + irc-create-call-wft + irc-calculate-entry + compile-definition + codegen + compile-error-if-not-enough-arguments + compile-lambda-function + compile-lambda-list-code + make-calling-convention + compiler-error + compiler-warn + compiler-style-warn + note + define-primitive + warn-undefined-global-variable + warn-undefined-type + warn-cannot-coerce + warn-invalid-number-type + warn-icsp-iesp-both-specified + register-global-function-def + register-global-function-ref + known-function-p + safe-system + system-data-layout + jit-constant-uintptr_t + irc-const-gep2-64 + irc-sext + irc-zext + irc-int-to-ptr + irc-ptr-to-int + irc-verify-module-safe + irc-verify-function + *suppress-llvm-output* + *optimization-level* + with-track-llvm-time + irc-add + irc-sub + irc-mul + irc-sdiv irc-srem + irc-udiv irc-urem + irc-shl irc-lshr irc-ashr + irc-add-clause + alloca + alloca-t* + alloca-exn + alloca-ehselector + alloca-go-index + alloca-i8 + alloca-i8* + alloca-i32 + alloca-size_t + alloca-return + alloca-vaslist + alloca-temp-values + alloca-arguments + irc-and + irc-or + irc-xor + irc-not + irc-basic-block-create + irc-begin-block + irc-br + irc-branch-to-and-begin-block + irc-cond-br + irc-call-or-invoke + irc-intrinsic-call-or-invoke + irc-bit-cast + irc-pointer-cast + irc-maybe-cast-integer-to-t* + irc-create-landing-pad + irc-exception-typeid* + irc-insert-value + irc-extract-value + irc-typed-gep + irc-typed-gep-variable + irc-smart-ptr-extract + irc-get-insert-block + irc-set-insert-point-basic-block + irc-size_t-*current-source-pos-info*-filepos + irc-size_t-*current-source-pos-info*-column + irc-size_t-*current-source-pos-info*-lineno + irc-icmp-eq + irc-icmp-ne + irc-icmp-ule + irc-icmp-ult + irc-icmp-uge + irc-icmp-ugt + irc-icmp-sle + irc-icmp-slt + irc-icmp-sge + irc-icmp-sgt + irc-intrinsic + irc-typed-load + irc-t*-load + irc-typed-load-atomic + irc-t*-load-atomic + irc-phi + irc-personality-function + irc-phi-add-incoming + irc-ret-void + irc-ret-null-t* + irc-ret + irc-undef-value-get + irc-store + irc-store-atomic + irc-cmpxchg + irc-struct-gep + vaslist-start + irc-read-slot + irc-write-slot + irc-make-tmv + irc-tmv-primary + irc-tmv-nret + irc-t*-result + irc-tmv-result + irc-make-vaslist + irc-vaslist-nvals + irc-vaslist-values + irc-vaslist-nth + irc-vaslist-nthcdr + irc-vaslist-last + irc-vaslist-butlast + irc-tag-vaslist + irc-unbox-vaslist + irc-header-stamp + irc-rack-stamp + irc-wrapped-stamp + irc-derivable-stamp + irc-switch + irc-add-case + irc-tag-fixnum + irc-tag-base-char + irc-untag-base-char + irc-tag-character + irc-untag-character + irc-trunc + irc-unreachable + irc-untag-fixnum + irc-untag-general + irc-untag-cons + irc-untag-vaslist + irc-tag-vaslist + irc-unbox-vaslist + irc-unbox-single-float + irc-box-single-float + irc-unbox-double-float + irc-box-double-float + irc-fdefinition + irc-setf-fdefinition + irc-real-array-displacement + irc-real-array-index-offset + irc-array-total-size + irc-array-rank + gen-%array-dimension + gen-instance-rack + gen-instance-rack-set + gen-rack-ref + gen-rack-set + gen-vaslist-pop + gen-vaslist-length + jit-constant-i1 + jit-constant-i8 + jit-constant-i32 + jit-constant-i64 + *default-function-attributes* + ensure-jit-constant-i64 + jit-constant-size_t + jit-constant-unique-string-ptr + module-make-global-string + make-boot-function-global-variable + setup-calling-convention + initialize-calling-convention + ensure-cleavir-lambda-list-analysis + process-cleavir-lambda-list-analysis + cleavir-lambda-list-analysis-cleavir-lambda-list + 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 + c++-struct-type + c++-struct*-type + c++-field-ptr + %closure%.offset-of[n]/t* + with-debug-info-generator + with-irbuilder + with-landing-pad + make-uintptr_t + +cons-car-offset+ + +cons-cdr-offset+ + +simple-vector._length-offset+ + +entry-point-arity-begin+ + +entry-point-arity-end+ + +number-of-entry-points+ + %uintptr_t% + %return-type% + %vaslist% + null-t-ptr + compile-error-if-too-many-arguments + *irbuilder-function-alloca* + irc-calculate-call-info + %RUN-AND-LOAD-TIME-VALUE-HOLDER-GLOBAL-VAR-TYPE% + compute-rest-alloc + tag-check-cond + header-check-cond + compile-tag-check + compile-header-check + general-entry-point-redirect-name + get-or-declare-function-or-error + )) + +;;; exports for conditions +(export '(deencapsulate-compiler-condition + *default-condition-origin* + compiler-condition-origin + compiled-program-error + compiler-condition + undefined-variable-warning + undefined-function-warning + undefined-type-warning + redefined-function-warning + wrong-argcount-warning + compiler-macro-expansion-error-warning + unused-variable used-variable + fold-failure + native-compilation-failure)) + +;;; save hooks +(export '(register-save-hook)) + +;;; bundle +(export '(builder build-fasl)) + +;;; Eclector +(export '(*cst-client* + clasp-eclector-client-mixin + clasp-cst-client)) + +;;; bytecode +(export '(*compile-file-native*)) +) ; eval-when diff --git a/src/lisp/kernel/cmp/external-clang.lisp b/src/lisp/kernel/cmp/external-clang.lisp index 2a56cb45d4..e1bccae0e2 100644 --- a/src/lisp/kernel/cmp/external-clang.lisp +++ b/src/lisp/kernel/cmp/external-clang.lisp @@ -46,7 +46,7 @@ (let ((file (probe-file cp))) (when file (return-from discover-clang file)))))))) -(defvar core:*clang-bin* (discover-clang)) +(defvar *clang-bin* (discover-clang)) ;; This would only work after kernel/clos/conditions #+(or) @@ -55,7 +55,7 @@ (:report (lambda (c s) (format s "Could not find clang~@[ on path ~s~]." (tried-path c))))) -(defun run-clang (args &key (clang core:*clang-bin*) output-file-name) +(defun run-clang (args &key (clang *clang-bin*) output-file-name) "Run the discovered clang compiler on the arguments. This replaces a simpler version of run-clang." (unless clang (error "There is no clang compiler path defined!!!!")) @@ -99,11 +99,11 @@ #+darwin -(defun run-dsymutil (args &key (clang core:*clang-bin*) output-file-name) +(defun run-dsymutil (args &key (clang *clang-bin*) output-file-name) "Run the discovered clang compiler on the arguments. This replaces a simpler version of run-clang." (unless clang (error "There is no clang compiler path defined!!!!")) - (let ((dsymutil (make-pathname :name "dsymutil" :type nil :defaults core:*clang-bin*))) + (let ((dsymutil (make-pathname :name "dsymutil" :type nil :defaults *clang-bin*))) (unless (probe-file dsymutil) (error "Could not find dsymutil at ~a" dsymutil)) (when (member :debug-run-clang *features*) @@ -119,3 +119,42 @@ #+darwin (export '(run-clang run-dsymutil)) + +(in-package #:cmp) + +(defun as-shell-command (list-of-args) + (with-output-to-string (sout) + (princ (car list-of-args) sout) + (dolist (c (cdr list-of-args)) + (core:fmt sout " {}" c)))) + +(defvar *safe-system-echo* nil) +(defvar *safe-system-max-retries* 4) +(defvar *safe-system-retry-wait-time* 0.1d0) ;; 100 milliseconds +;; The wait time will be doubled at each retry! + +(defun safe-system (cmd-list &key output-file-name) + (if *safe-system-echo* + (core:fmt t "safe-system: {}%N" cmd-list)) + + (multiple-value-bind (retval error-message) + (ext:vfork-execvp cmd-list) + + (unless (eql retval 0) + (error "Could not execute command with ext:vfork-execvp with ~s~% return-value: ~d error-message: ~s~%" cmd-list retval error-message))) + + (when output-file-name + (let ((sleep-time *safe-system-retry-wait-time*)) + (dotimes (nm1 (- *safe-system-max-retries* 1)) + (let ((n (+ nm1 1))) + (unless (probe-file output-file-name) + (if (>= n *safe-system-max-retries*) + (error "The file ~a was not created by shell command: ~a" output-file-name (as-shell-command cmd-list)) + (progn + (if *safe-system-echo* + (core:fmt t "safe-system: Retry count = {} of {}%N" n *safe-system-max-retries*)) + (core::sleep sleep-time) + (setq sleep-time (* 2 sleep-time))))))))) + + ;; Return T if all went well + t) diff --git a/src/lisp/kernel/cmp/fixup-eclector-readtables.lisp b/src/lisp/kernel/cmp/fixup-eclector-readtables.lisp deleted file mode 100644 index 3f47c69fbb..0000000000 --- a/src/lisp/kernel/cmp/fixup-eclector-readtables.lisp +++ /dev/null @@ -1,94 +0,0 @@ -(cl:in-package #:eclector.readtable.simple) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,readtable_case); -(defmethod eclector.readtable:readtable-case ((readtable t)) - (error 'type-error :datum readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,setf_readtable_case); -;;; need to dispach to (setf) -(defun ECLECTOR.READTABLE::SETF-READTABLE-CASE (mode readtable) - ;;; Check that the readtable is of a type understood by eclector - ;;; mode can be :upcase :downcase :invert :preserve - (unless (member mode '(:upcase :downcase :invert :preserve)) - (error 'type-error :datum mode :EXPECTED-TYPE '(member :upcase :downcase :invert :preserve))) - (unless (typep readtable 'ECLECTOR.READTABLE.SIMPLE:READTABLE) - (error 'type-error :datum readtable :EXPECTED-TYPE 'ECLECTOR.READTABLE.SIMPLE:READTABLE)) - (setf (eclector.readtable:readtable-case readtable) mode)) - -#+(or) -(defmethod (setf eclector.readtable:readtable-case) (mode (readtable t)) - (error 'type-error :datum readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,make_dispatch_macro_character); -(defmethod eclector.readtable:make-dispatch-macro-character - ((readtable t) char &optional non-terminating-p) - (declare (ignore char non-terminating-p)) - (error 'type-error :datum readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,get_macro_character); - -;;; to avoid breaking (get-macro-character c nil) -(defmethod eclector.readtable:get-macro-character ((readtable null) char) - (cl:get-macro-character char cl:*readtable*)) - -(defmethod eclector.readtable:get-macro-character ((readtable t) char) - (declare (ignore char)) - (error 'type-error :datum readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,set_macro_character); -(defmethod eclector.readtable:set-macro-character - ((readtable t) char function &optional non-terminating-p) - (declare (ignore char function non-terminating-p)) - (error 'type-error :datum readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,get_dispatch_macro_character); -(defmethod eclector.readtable:get-dispatch-macro-character - ((readtable t) disp-char sub-char) - (declare (ignore disp-char sub-char)) - (error 'type-error :datum readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,set_dispatch_macro_character); -(defmethod eclector.readtable:set-dispatch-macro-character - ((readtable t) disp-char sub-char function) - (declare (ignore disp-char sub-char function)) - (error 'type-error :datum readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,syntax_type); -(defmethod eclector.readtable:syntax-type ((readtable t) char) - (declare (ignore char)) - (error 'type-error :datum readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,setf_syntax_type); -(defmethod (setf eclector.readtable:syntax-type) - (syntax-type (readtable t) char) - (declare (ignore syntax-type char)) - (error 'type-error :datum readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,copy_readtable_into); -(defmethod eclector.readtable:copy-readtable-into - ((from-readtable t) (to-readtable readtable)) - (error 'type-error :datum from-readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -(defmethod eclector.readtable:copy-readtable-into - ((from-readtable readtable) (to-readtable t)) - (error 'type-error :datum to-readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -(defmethod eclector.readtable:copy-readtable-into - ((from-readtable t) (to-readtable t)) - (error 'type-error :datum from-readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,copy_readtable); -(defmethod eclector.readtable:copy-readtable ((readtable t)) - (error 'type-error :datum readtable :EXPECTED-TYPE 'eclector.readtable.simple:readtable)) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,readtablep); -(defmethod eclector.readtable:readtablep ((readtable t)) - nil) - -;;; was forgotten in Eclector, fixed in de134e75ddee442a1811f5f9561133836e36fcf8 -(defmethod eclector.readtable:readtablep ((readtable ECLECTOR.READTABLE.SIMPLE:READTABLE)) - t) - -;;; SYMBOL_EXPORT_SC_(EclectorReadtablePkg,set_syntax_from_char); -;;; ECLECTOR.READTABLE:SET-SYNTAX-FROM-CHAR is a defun - diff --git a/src/lisp/kernel/cmp/opt/opt-array.lisp b/src/lisp/kernel/cmp/opt/opt-array.lisp index 40f71264d4..ff9cb98a6f 100644 --- a/src/lisp/kernel/cmp/opt/opt-array.lisp +++ b/src/lisp/kernel/cmp/opt/opt-array.lisp @@ -6,6 +6,7 @@ ;;; buuuuut I'm not sure. That would involve folding upgraded-array-element-type. ;; returns names of a simple vector constructor and a simple mdarray constructor. +(eval-when (:compile-toplevel :load-toplevel :execute) (defun uaet-info (uaet) (case uaet ((t) (values 'core:make-simple-vector-t 'core:make-simple-mdarray-t)) @@ -33,6 +34,7 @@ ((fixnum) (values 'core:make-simple-vector-fixnum 'core:make-simple-mdarray-fixnum)) ;; size_t? (t (values nil nil)))) +) ; eval-when (define-compiler-macro make-array (&whole form dimensions &key (element-type t) diff --git a/src/lisp/kernel/cmp/opt/opt-cons.lisp b/src/lisp/kernel/cmp/opt/opt-cons.lisp index cf5e9699a9..1beac52a19 100644 --- a/src/lisp/kernel/cmp/opt/opt-cons.lisp +++ b/src/lisp/kernel/cmp/opt/opt-cons.lisp @@ -50,6 +50,7 @@ ;;; MEMBER ;;; +(eval-when (:compile-toplevel :load-toplevel :execute) ;;; (member foo '(...)) is a common idiom. Notably, our *CASE expand into it. ;;; So we put something in so it won't actually iterate. (defun expand-constant-member (valuef list key-function test-function init) @@ -90,6 +91,7 @@ (when ,(funcall test-function %value (funcall key-function %elt)) (return ,%sublist))))))) +) ; eval-when (define-compiler-macro member (&whole whole value list &rest sequence-args &environment env) ;; FIXME: pay attention to policy, e.g. don't inline for high SPACE. @@ -100,6 +102,7 @@ ;;; ASSOC ;;; +(eval-when (:compile-toplevel :load-toplevel :execute) (defun expand-assoc (env value list &rest sequence-args) (multiple-value-bind (key-function test-function init ignores key-flag test-flag) @@ -119,6 +122,7 @@ (return ,%elt))) (when ,%elt (error 'type-error :datum ,%elt :expected-type 'list))))))))) +) ; eval-when (define-compiler-macro assoc (&whole whole value list &rest sequence-args &environment env) (or (apply #'expand-assoc env value list sequence-args) @@ -128,6 +132,7 @@ ;;; ADJOIN ;;; +(eval-when (:compile-toplevel :load-toplevel :execute) (defun expand-adjoin (env value list &rest sequence-args) (multiple-value-bind (key-function test-function init ignores key-flag test-flag) @@ -145,6 +150,7 @@ (when ,(funcall test-function %value-after-key-function- (funcall key-function %elt)) (return ,%list))))))))) +) ; eval-when (define-compiler-macro adjoin (&whole whole value list &rest sequence-args &environment env) (declare (ignore value list sequence-args)) diff --git a/src/lisp/kernel/cmp/opt/opt-control.lisp b/src/lisp/kernel/cmp/opt/opt-control.lisp index d71f3dc334..03fb47ecbd 100644 --- a/src/lisp/kernel/cmp/opt/opt-control.lisp +++ b/src/lisp/kernel/cmp/opt/opt-control.lisp @@ -25,11 +25,13 @@ ,@(mapcar #'list syms fixed)) (,op ,fsym ,last ,@syms)))))) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun function-form-p (form) (and (consp form) (eq (car form) 'function) (consp (cdr form)) (null (cddr form)))) +) ;;; Collapse (coerce-fdesignator #'foo) to #'foo, ;;; (coerce-fdesignator 'foo) to (fdefinition 'foo), diff --git a/src/lisp/kernel/cmp/opt/opt-number.lisp b/src/lisp/kernel/cmp/opt/opt-number.lisp index 158131819c..af5c9dee41 100644 --- a/src/lisp/kernel/cmp/opt/opt-number.lisp +++ b/src/lisp/kernel/cmp/opt/opt-number.lisp @@ -8,8 +8,7 @@ (let ((arg0 (first args)) (args (rest args))) (if (null args) ;; preserve nontoplevelness and eliminate extra values - #+bytecode `(core::the-single real ,arg0) - #-bytecode `(the (values real &rest nil) (values ,arg0)) + `(core::the-single real ,arg0) (let ((s (gensym))) `(let ((,s ,arg0) (minrest (min ,@args))) @@ -19,8 +18,7 @@ form (let ((arg0 (first args)) (args (rest args))) (if (null args) - #+bytecode `(core::the-single real ,arg0) - #-bytecode `(the (values real &rest nil) (values ,arg0)) ; preserve nontoplevelness + `(core::the-single real ,arg0) ; preserve nontoplevelness (let ((s (gensym))) `(let ((,s ,arg0) (maxrest (max ,@args))) @@ -97,6 +95,7 @@ (in-package #:core) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun parse-bytespec (bytespec) (when (and (consp bytespec) (eql (car bytespec) 'byte) @@ -104,6 +103,7 @@ (consp (cddr bytespec)) (null (cdddr bytespec))) (values (cadr bytespec) (caddr bytespec)))) +) (define-compiler-macro ldb (&whole whole bytespec integer) (multiple-value-bind (size position) (parse-bytespec bytespec) diff --git a/src/lisp/kernel/cmp/opt/opt-type.lisp b/src/lisp/kernel/cmp/opt/opt-type.lisp index 55d77a490f..e29684a7f0 100644 --- a/src/lisp/kernel/cmp/opt/opt-type.lisp +++ b/src/lisp/kernel/cmp/opt/opt-type.lisp @@ -11,6 +11,7 @@ ;;; We should DEFINITELY NOT cause compile time errors ;;; We COULD signal warnings on types like (standard-char foo) +(eval-when (:compile-toplevel :load-toplevel :execute) ;;; Array type map. ;;; The array hierarchy is defined in array.h. Basically here's how it goes: ;;; Arrays are divided by element type, and then in two other ways: @@ -398,7 +399,7 @@ ;; for anything that could be subclassed. The most likely candidate ;; for this problem is STREAM, but it's caught by the previous case. ((and (null args) (gethash head core:+type-header-value-map+)) - `(if (headerp object ',type) t nil)) + `(if (headerp object ',head) t nil)) ;; Maybe it's a class name? (See also, comment in clos/defclass.lisp.) ((and (null args) (symbolp head) (class-info head env)) ;; By semantic constraints, classes that are defined at compile time @@ -416,6 +417,7 @@ (when (fboundp 'cmp:warn-undefined-type) (cmp:warn-undefined-type nil type)) (default))))))))) +) ; eval-when (define-compiler-macro typep (&whole whole object type &optional environment &environment macro-env) @@ -434,6 +436,7 @@ ;;; COERCE ;;; +(eval-when (:compile-toplevel :load-toplevel :execute) (defun maybe-sequence-coercion-form (type env) (multiple-value-bind (kind length exactp success) (si::sequence-type-maker-info type env) @@ -511,8 +514,9 @@ ;; "no coercion behavior", though. ;; And maybe "can't figure it out at compile time but ;; will at runtime". - (cmp:warn-cannot-coerce nil type) + (cmp:warn-cannot-coerce nil type) ; FIXME whole))))))))) +) ; eval-when (define-compiler-macro coerce (&whole form object type &environment env) (if (constantp type env) diff --git a/src/lisp/kernel/cmp/opt/opt.lisp b/src/lisp/kernel/cmp/opt/opt.lisp index 0528689128..009565aab0 100644 --- a/src/lisp/kernel/cmp/opt/opt.lisp +++ b/src/lisp/kernel/cmp/opt/opt.lisp @@ -1,6 +1,7 @@ ;;; Stuff used by all the opt- files (in-package #:cmp) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun gensym-list (list &optional x) (loop :for _ :in list @@ -164,3 +165,4 @@ test-flag start end)))) +) ; eval-when diff --git a/src/lisp/kernel/cmp/startup-primitives.lisp b/src/lisp/kernel/cmp/startup-primitives.lisp index 7d47e31be5..140a979943 100644 --- a/src/lisp/kernel/cmp/startup-primitives.lisp +++ b/src/lisp/kernel/cmp/startup-primitives.lisp @@ -1,74 +1,5 @@ -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package "CMPREF") - (make-package "CMPREF" :use '("CL"))) - (in-package #:cmpref)) - -(export '(*startup-primitives-as-list* - +bytecode-ltv-ops+ - +uaet-codes+ - +debug-info-ops+ - generate-virtual-machine-header)) - (in-package #:cmpref) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; ltvc intrinsics are for initialization of memory at load time -;;; ltvc stands for Load Time Virtual machine Call -;;; They are used to construct the a byte-code machine -;;; Each function takes arguments ( GCRootsInModule* gcroots, char tag, size_t targetIndex, ...args...) -;;; The gcroots, tag, targetIndex are used to get a reference to a cell in the gcroots -;;; and the ...args... are used to construct the object. -;;; If you add a new ltvc_xxxx function then do the following to rebuild the virtual machine -;;; To build the machine in the src/core/byte-code-interpreter.cc file manually use: -;;; (0) Erase the code in byte-code-interpreter.cc -;;; (1) ./waf build_rboehm -;;; (2) (literal::build-c++-machine) -;;; (3) copy the result into byte-code-interpreter.cc -;;; But the build system will rebuild the interpreter automatically. -;;; -(defvar *startup-primitives-as-list* - ;; (unwindsp name argtypes &key varargs) - '(( 65 nil "ltvc_make_nil" (:i8 :size_t)) - ( 66 nil "ltvc_make_t" (:i8 :size_t)) - ( 67 nil "ltvc_make_ratio" (:i8 :size_t :t* :t*)) - ( 68 nil "ltvc_make_complex" (:i8 :size_t :t* :t*)) - ( 69 nil "ltvc_make_cons" (:i8 :size_t)) - ( 70 nil "ltvc_rplaca" (:t* :t*)) - ( 71 nil "ltvc_rplacd" (:t* :t*)) - ( 72 nil "ltvc_make_list" (:i8 :size_t :size_t)) - ( 73 nil "ltvc_fill_list" (:t* :size_t) :varargs t) - ( 74 nil "ltvc_make_array" (:i8 :size_t :t* :t*)) - ( 75 nil "ltvc_setf_row_major_aref" (:t* :size_t :t*)) - ( 76 nil "ltvc_make_hash_table" (:i8 :size_t :t*)) - ( 77 nil "ltvc_setf_gethash" (:t* :t* :t*)) - ( 78 nil "ltvc_make_fixnum" (:i8 :size_t :uintptr_t)) - ( 79 nil "ltvc_make_package" (:i8 :size_t :t*)) - ( 80 nil "ltvc_make_next_bignum" (:i8 :size_t :bignum)) - ( 81 nil "ltvc_make_bitvector" (:i8 :size_t :t*)) - ( 82 nil "ltvc_make_symbol" (:i8 :size_t :t* :t*)) - ( 83 nil "ltvc_make_character" (:i8 :size_t :uintptr_t)) - ( 84 nil "ltvc_make_base_string" (:i8 :size_t :i8*)) - ( 85 nil "ltvc_make_pathname" (:i8 :size_t :t* :t* :t* :t* :t* :t*)) - ( 86 nil "ltvc_make_function_description" (:i8 :size_t :t* :t* :t* :t* :t* :size_t - :size_t :size_t)) - ( 87 nil "ltvc_make_global_entry_point" (:i8 :size_t :size_t :t* :size_t)) - ( 88 nil "ltvc_make_local_entry_point" (:i8 :size_t :size_t :t*)) - ( 89 nil "ltvc_ensure_fcell" (:i8 :size_t :t*)) - ( 90 nil "ltvc_ensure_vcell" (:i8 :size_t :t*)) - ( 91 nil "ltvc_make_random_state" (:i8 :size_t :t*)) - ( 92 nil "ltvc_make_binary32" (:i8 :size_t :single-float)) - ( 93 nil "ltvc_make_binary64" (:i8 :size_t :double-float)) - ( 94 nil "ltvc_make_binary80" (:i8 :size_t :binary80)) - ( 95 t "ltvc_set_mlf_creator_funcall" (:i8 :size_t :size_t :i8*)) - ( 96 t "ltvc_mlf_init_funcall" (:size_t :i8*)) - ( 97 t "ltvc_mlf_init_basic_call" (:t* :size_t) :varargs t) - ( 98 t "ltvc_mlf_create_basic_call" (:i8 :size_t :t* :size_t) :varargs t) - ( 99 t "ltvc_set_ltv_funcall" (:i8 :size_t :size_t :i8*)) - (100 t "ltvc_toplevel_funcall" (:size_t :i8*)) - (102 nil "ltvc_make_binary16" (:i8 :size_t :short-float)) - (103 nil "ltvc_make_binary128" (:i8 :size_t :binary128)))) - ;;; Bytecode LTV Ops ;;; Instruction set is copied from Clasp for now. "sind" in the below means an ;;; index that the allocated object will be stored into. This may need some diff --git a/src/lisp/kernel/cmp/variables.lisp b/src/lisp/kernel/cmp/variables.lisp new file mode 100644 index 0000000000..573a9441cc --- /dev/null +++ b/src/lisp/kernel/cmp/variables.lisp @@ -0,0 +1,22 @@ +(in-package #:cmp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Setup dynamic variables +;;; + +(defvar *compile-verbose* t) +(defvar *compile-print* t) + +(defvar *compile-file-pathname* nil "The pathname of the currently compiled file") +(defvar *compile-file-truename* nil "The truename of the currently compiled file") +;;; These variables are used to let compile-file insert debug information that does not +;;; correspond to the actual file being compiled. This is useful for editors (SLIME) that +;;; may present Clasp with a temporary file containing a portion of some other file; we want +;;; the debug data in the compilation of this file to reflect the other file, not the temp. +(defvar *compile-file-source-debug-pathname*) ; Pathname for source info +(defvar *compile-file-file-scope*) ; File scope bound by compile-file etc for source file info +(defvar *compile-file-source-debug-offset*) ; Offset bound by compile-file etc for SFIs +(defvar *compile-file-source-debug-lineno*) ; ditto + +(defvar *compile-file-parallel* nil) diff --git a/src/lisp/kernel/cmp/cmpwalk.lisp b/src/lisp/kernel/cmp/walk.lisp similarity index 92% rename from src/lisp/kernel/cmp/cmpwalk.lisp rename to src/lisp/kernel/cmp/walk.lisp index 238b244ec2..b1764f899c 100644 --- a/src/lisp/kernel/cmp/cmpwalk.lisp +++ b/src/lisp/kernel/cmp/walk.lisp @@ -41,7 +41,7 @@ (t ; assume it's a cleavir environment. KLUDGE (funcall (find-symbol "CLEAVIR-ENV->BYTECODE" "CLASP-CLEAVIR") env)))) - (module (cmp:module/make))) + (module (module/make))) (compile-lambda nil `(progn ,form) env module nil))) (defun code-walk (code-walker-function form env) @@ -49,8 +49,4 @@ within env and call the code-walker-function on each internal form. code-walker-function takes two arguments (form env). Returns T if walked, NIL if not (e.g. because the compiler signaled an error)." - (let ((*code-walking* t)) - (code-walk-using-bytecode code-walker-function form env))) - -(export '(code-walk code-walk-using-bclasp)) - + (code-walk-using-bytecode code-walker-function form env)) diff --git a/src/lisp/kernel/cmp/workbench.lisp b/src/lisp/kernel/cmp/workbench.lisp deleted file mode 100644 index 15b4e896a6..0000000000 --- a/src/lisp/kernel/cmp/workbench.lisp +++ /dev/null @@ -1,113 +0,0 @@ -(progn - (setf cmp::*debug-compiler* t) - (setf cmp::*use-human-readable-bitcode* t) - (trace COMPILER:SETUP-CALLING-CONVENTION - 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 - cmp::t1expr - cmp::t1eval-when - cmp::t1progn - cmp::compile-top-level - literal:arrange-thunk-as-top-level - cmp::compile-thunk - cmp::codegen-symbol-value - cmp::codegen - cmp::codegen-progn - cmp::codegen-let/let* - cmp::codegen-let - cmp::codegen-let* - cmp::codegen-special-operator - cmp::codegen-cons - cmp::codegen-var-lookup - cmp::codegen-lexical-var-lookup - cmp::codegen-alloca-var-lookup - cmp::variable-info - cmp::classify-variable - cmp::compile-lambda-list-code - cmp::compile-general-lambda-list-code - cmp::compile-only-req-and-opt-arguments - cmp::compile-required-arguments - cmp::compile-optional-arguments - cmp::compile-key-arguments - cmp::add-global-ctor-function - cmp::codegen-lexical-var-reference - cmp::irc-intrinsic-call-or-invoke - cmp::irc-arity-info - cmp::do-make-new-run-all - cmp::irc-ret - cmp::irc-ret-void - cmp::irc-ret-null-t* - cmp::irc-funcall-results-in-registers - cmp::irc-function-create - cmp::irc-create-local-entry-point-reference - cmp::irc-create-global-entry-point-reference - cmp::make-xep-group - cmp::irc-calculate-entry - 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 - cmp::irc-store - literal::do-literal-table - literal::do-rtv - literal::constants-table-value - literal::constants-table-reference - cmp::irc-phi-add-incoming - cmp::cleavir-lambda-list-analysis-lambda-list-arguments - cmp::process-cleavir-lambda-list-analysis - cmp::ensure-cleavir-lambda-list - cmp::ensure-cleavir-lambda-list-analysis - cmp::process-bir-lambda-list - cmp::generate-function-for-arity-p - - cmp:xep-group-p - cmp:xep-group-arities - cmp:xep-arity-function-or-placeholder - literal::register-function->function-datum-impl - cmp::make-entry-point-reference - literal::reference-literal - literal::register-local-function-index - literal::register-xep-function-indices - literal::register-local-function->function-datum - literal::register-xep-function->function-datums - sys:make-simple-core-fun-generator - sys:make-local-simple-fun-generator - ) - (compile 'foo '(lambda (x) x)) - #+(or)(compile-file "/tmp/xxx.lisp") - ) - diff --git a/src/lisp/kernel/lsp/xref.lisp b/src/lisp/kernel/cmp/xref.lisp similarity index 91% rename from src/lisp/kernel/lsp/xref.lisp rename to src/lisp/kernel/cmp/xref.lisp index 8e27fc46b2..fcaa0377cf 100644 --- a/src/lisp/kernel/lsp/xref.lisp +++ b/src/lisp/kernel/cmp/xref.lisp @@ -1,4 +1,4 @@ -(in-package #:core) +(in-package #:cmp) (defmacro do-bytecode-modules ((modname &optional result) &body body) `(block nil @@ -34,10 +34,18 @@ ;;; Return (function-name . spi) for an IP, or NIL if not available. (defun xref-at-ip (ip module) - (let ((fun (function-at-ip ip module)) - (spi (spi-at-ip ip module))) + (let ((fun (function-at-ip ip module))) (if fun - (cons (core:function-name fun) spi) + (cons (core:function-name fun) + (or (spi-at-ip ip module) + ;; get one from the function + (multiple-value-bind (file pos line col) + (core:function-source-pos fun) + (if file + (core:make-source-pos-info :filename (namestring file) + :filepos pos + :lineno line :column col) + nil)))) nil))) ;;; Iterate through a module's instructions and return xrefs for all @@ -152,9 +160,10 @@ Returns an alist. Each CAR is the name of the called function, and the CDR is a (defun %method-spi (method) (or (clos::method-source-position method) - (%function-spi (clos::fast-method-function method)) - (%function-spi (clos::contf-method-function method)) - (%function-spi (clos:method-function method)))) + (let ((mf (clos:method-function method))) + (or (%function-spi (clos::fmf method)) + (%function-spi (clos::contf method)) + (%function-spi mf))))) (defun ext:who-specializes-directly (class-designator) "Find methods that directly specialize a given class. diff --git a/src/lisp/kernel/contrib-packages.lisp b/src/lisp/kernel/contrib-packages.lisp new file mode 100644 index 0000000000..434af230f5 --- /dev/null +++ b/src/lisp/kernel/contrib-packages.lisp @@ -0,0 +1,3 @@ +(in-package #:core) + +(make-package "ECCLESIA" :use '("CL")) diff --git a/src/lisp/kernel/init.lisp b/src/lisp/kernel/init.lisp deleted file mode 100644 index 5140bd046d..0000000000 --- a/src/lisp/kernel/init.lisp +++ /dev/null @@ -1,907 +0,0 @@ -;; Set features :clasp-min for minimal system without CLOS -;; :clos to compile with CLOS -;; - - -;;;#-darwin -#+(or)(cmp:trampoline "bytecode") - -#+(or) -(eval-when (:compile-toplevel :execute) - (setq core:*debug-eval* t)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (core:select-package "CORE")) - -#+(or)(setq *features* (cons :dbg-print *features*)) -(SYS:*MAKE-SPECIAL '*echo-repl-tpl-read*) -(export '(*echo-repl-tpl-read* - ihs-top ; for asdf compatibility only; remove soon - cons-car - cons-cdr - debug-break)) -(export '*trace-startup*) - - -;;; ------------------------------------------------------------ -;;; -;;; Set *echo-repl-read* to t to print each repl form -;;; -(setq *echo-repl-read* nil) - -;;; ------------------------------------------------------------ -;;; Turn on printing messages as object files are converted to runnable code -;;; -(if (member :dump-repl-object-files *features*) - (llvm-sys:debug-object-files 'llvm-sys:debug-object-files-print) - (if (member :debug-object-files *features*) - (llvm-sys:debug-object-files 'llvm-sys:debug-object-files-print-save))) - -(setq *echo-repl-tpl-read* (member :emacs-inferior-lisp *features*)) -;;;(setq *load-print* nil) - -(setq cl:*print-circle* nil) - -(sys:*make-special 'core::*clang-bin*) -(export 'core::*clang-bin*) - - -;;; -------------------------------------------------- -;;; -;;; Use force-compile-file-serial feature to -;;; shutdown compile-file-parallel. -;;; -(if (member :force-compile-file-serial *features*) - (setq cmp:*use-compile-file-parallel* nil)) - -#+clasp-min -(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) - (CORE:SETF-LAMBDA-LIST - (FUNCALL #'(SETF MACRO-FUNCTION) - #'(LAMBDA - (whole env - &AUX (CLAUSES (CDR (THE CONS whole)))) - (DECLARE (IGNORABLE rest whole) - (CORE:LAMBDA-NAME (MACRO-FUNCTION COND))) - (DECLARE (IGNORE env)) - (BLOCK COND - (IF (CONSP CLAUSES) - (LET* ((clauses1 CLAUSES) - (clauses2 clauses1) - (XXX - (PROGN - (IF (NULL clauses2) - (error "too few arguments ~a ~a" clauses1 - '((PRED . FORMS) . REST-CLAUSES))) - (let ((prog1-val (CAR (THE CONS clauses2)))) - (SETQ clauses2 (CDR (THE CONS clauses2))) - prog1-val))) - (YYY XXX) - (PRED - (PROGN - (IF (NULL YYY) - (error "too few arguments ~a ~a" clauses1 '(PRED . FORMS))) - (let ((PROG1-val (CAR (THE CONS YYY)))) - (SETQ YYY (CDR (THE CONS YYY))) - prog1-val))) - (FORMS YYY) - (REST-CLAUSES clauses2)) - (DECLARE (IGNORABLE YYY XXX clauses2 clauses1)) - (IF (EQ PRED T) - (core:quasiquote - (PROGN (core::UNQUOTE-SPLICE FORMS))) - (core:QUASIQUOTE - (IF (core::UNQUOTE PRED) - (PROGN (core::UNQUOTE-SPLICE FORMS)) - (COND (core::UNQUOTE-SPLICE REST-CLAUSES)))))) - NIL))) - 'COND) - '(&REST CLAUSES)) - 'COND) - -(cond ((member :generate-bytecode *features*) - (setq cmp:*default-output-type* :bytecode)) - ((member :generate-faso *features*) - (setq cmp:*default-output-type* :faso)) - ((member :generate-fasoll *features*) - (setq cmp:*default-output-type* :fasoll)) - ((member :generate-fasobc *features*) - (setq cmp:*default-output-type* :fasobc))) - -;;; ------------------------------------------------------------ -;;; -;;; Sanity check that stamps are working properly -;;; - -(eval-when (:compile-toplevel :execute) - (let* ((obj "dummy-object-string") - (obj-class (core:instance-class obj)) - (obj-class-name (core:name-of-class obj-class)) - (stamp (core:instance-stamp obj)) - (class-stamp (core:class-stamp-for-instances obj-class)) - (map-stamp (gethash obj-class-name core:+type-header-value-map+))) - (if (not (numberp stamp)) - (progn - (core:fmt t "Sanity check failure stamp {} must be a number%N" stamp) - (core:cabort)) - (if (not (numberp class-stamp)) - (progn - (core:fmt t "Sanity check failure class-stamp {} must be a number%N" class-stamp) - (core:cabort)) - (if (not (numberp map-stamp)) - (progn - (core:fmt t "Sanity check failure map-stamp {} must be a number%N" map-stamp) - (finish-output) - (core:cabort))))) - (if (not (= stamp class-stamp)) - (progn - (core:fmt t "For object {} class {} class-name {} there is a mismatch between the stamp {} and the class-stamp {}%N" - obj obj-class obj-class-name stamp class-stamp) - (finish-output) - (core:cabort)) - (if (not (= stamp map-stamp)) - (progn - (core:fmt t "For object {} class {} class-name {} there is a mismatch between the stamp {} and the map-stamp {}%N" - obj obj-class obj-class-name stamp map-stamp) - (finish-output) - (core:cabort)))))) - -;;; fixme2022 - We shouldn't need the varest feature -(setq *features* (cons :varest *features*)) - -;; Set up a few things for the CLOS package -(export '(clos::standard-class) "CLOS") - -;; Setup a few things for the GRAY streams package -(eval-when (:execute :compile-toplevel :load-toplevel) - (core::select-package :gray)) -(shadow '(STREAM-ELEMENT-TYPE OPEN-STREAM-P OUTPUT-STREAM-P INPUT-STREAM-P STREAMP CLOSE)) - -;; 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*) -(setq *activation-frame-optimize* t) -(sys:*make-special '*use-human-readable-bitcode*) -(setq *use-human-readable-bitcode* (member :use-human-readable-bitcode *features*)) -(sys:*make-special '*compile-file-debug-dump-module*) -(sys:*make-special '*debug-compile-file*) -(if (boundp '*compile-file-debug-dump-module*) - nil - (setq *compile-file-debug-dump-module* t)) -(sys:*make-special '*compile-debug-dump-module*) -(if (boundp '*compile-debug-dump-module*) - nil - (setq *compile-debug-dump-module* nil)) -(setq *debug-compile-file* (member :debug-compile-file *features*)) -(sys:*make-special '*debug-cclasp-cmp*) -(setq *debug-cclasp-cmp* nil) -(export '*debug-cclasp-cmp*) - -(export '(*compile-file-debug-dump-module* *compile-debug-dump-module* *use-human-readable-bitcode*)) -(use-package :core) - -(eval-when (:execute :compile-toplevel :load-toplevel) - (select-package :core)) - -(eval-when (:execute :compile-toplevel :load-toplevel) - (if (find-package "SEQUENCE") - nil - (make-package "SEQUENCE" :use '()))) - -(eval-when (:execute :compile-toplevel :load-toplevel) - (if (find-package "LITERAL") - nil - (make-package "LITERAL" :use '(:cl :core)))) - -(eval-when (:execute :compile-toplevel :load-toplevel) - (if (find-package "CLASP-CLEAVIR") - nil - (make-package "CLASP-CLEAVIR" :use '(:CL)))) - -;;; Setup a few things for the EXT package - -;;; EXT exports are now in packages.lisp -(eval-when (:execute :compile-toplevel :load-toplevel) - (select-package :ext)) - -(core:*make-special '*module-provider-functions*) -(core:*make-special '*source-location*) -(setq *source-location* nil) -(export 'current-source-location) -;;; Function: (EXT:CURRENT-SOURCE-LOCATION) -;;; - Returns the source location of the current top-level form -;;; or nil if it's not known. -(core:fset - 'current-source-location - #'(lambda () core:*current-source-pos-info*)) - -(eval-when (:execute :compile-toplevel :load-toplevel) - (core:select-package :core)) - -(si:fset 'core::defvar #'(lambda (whole env) - (declare (ignore env)) - (let ((var (cadr whole)) - (formp (cddr whole)) - (form (caddr whole))) - "Syntax: (defvar name form [doc]) -Declares the global variable named by NAME as a special variable and assigns -the value of FORM to the variable. The doc-string DOC, if supplied, is saved -as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." - `(LOCALLY (DECLARE (SPECIAL ,var)) - (SYS:*MAKE-SPECIAL ',var) - ,@(if formp - `((if (boundp ',var) - ',var - (progn - (setq ,var ,form) - ',var))))))) - t) -(export 'defvar) - -(si:fset 'core::defparameter #'(lambda (whole env) - (declare (ignore env)) - (let ((var (cadr whole)) - (form (caddr whole))) - "Syntax: (defparameter name form [doc]) -Declares the global variable named by NAME as a special variable and assigns -the value of FORM to the variable. The doc-string DOC, if supplied, is saved -as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." - `(LOCALLY (DECLARE (SPECIAL ,var)) - (SYS:*MAKE-SPECIAL ',var) - (SETQ ,var ,form) - ',var))) - t) -(export 'defparameter) - - - -(si:fset 'core::defconstant #'(lambda (whole env) - (declare (ignore env)) - (let ((var (cadr whole)) - (form (caddr whole))) - "Syntax: (defconstant name form [doc]) -Declares the global variable named by NAME as a special variable and assigns -the value of FORM to the variable. The doc-string DOC, if supplied, is saved -as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." - `(if (core:symbol-constantp ',var) - nil - (progn - (set ',var ,form) - (funcall #'(setf core:symbol-constantp) t ',var))))) - t) -(export 'defconstant) - -(if (boundp '+ecl-safe-declarations+) - nil ; don't redefine constant - (defconstant +ecl-safe-declarations+ - '(optimize (safety 2) (speed 1) (debug 1) (space 1)))) - -(defvar +io-syntax-progv-list+ - (list - '( - *print-pprint-dispatch* #| See end of pprint.lisp |# - *print-array* - *print-base* - *print-case* - *print-circle* - *print-escape* - *print-gensym* - *print-length* - *print-level* - *print-lines* - *print-miser-width* - *print-pretty* - *print-radix* - *print-readably* - *print-right-margin* - *read-base* - *read-default-float-format* - *read-eval* - *read-suppress* - *readtable* - *package* - si::*sharp-eq-context* - si::*circle-counter*) ; - nil ;; *pprint-dispatch-table* - t ;; *print-array* - 10 ;; *print-base* - :upcase ;; *print-case* - nil ;; *print-circle* - t ;; *print-escape* - t ;; *print-gensym* - nil ;; *print-length* - nil ;; *print-level* - nil ;; *print-lines* - nil ;; *print-miser-width* - nil ;; *print-pretty* - nil ;; *print-radix* - t ;; *print-readably* - nil ;; *print-right-margin* - 10 ;; *read-base* - 'single-float ;; *read-default-float-format* - t ;; *read-eval* - nil ;; *read-suppress* - *readtable* ;; *readtable* - (find-package :CL-USER) ;; *package* - nil ;; si::*sharp-eq-context* - nil ;; si::*circle-counter* - )) - -(eval-when (:execute :compile-toplevel :load-toplevel) - (core::select-package :cl)) -(defvar *print-pretty* nil) ;; Turn this on by default -(defvar *print-level* nil) -(defvar *print-length* nil) -(defvar *print-base* 10) -(defvar *print-radix* nil) -(defvar *read-default-float-format* 'double-float) - - - -(core::export 'defun) -(eval-when (:execute :compile-toplevel :load-toplevel) - (core::select-package :core)) - -(defparameter *debug-bclasp* (if (member :debug-bclasp-lisp *features*) t nil)) - -(defvar *special-init-defun-symbol* (gensym "special-init-defun-symbol")) - -;;; A temporary definition of defun - the real one is in evalmacros -#+clasp-min -(eval-when (:execute) - (si:fset 'defun - #'(lambda (def env) - (let ((name (second def)) ;cadr - (lambda-list (third def)) ; caddr - (lambda-body (cdddr def))) ; cdddr - (multiple-value-call - (function (lambda (&optional (decl) (body) (doc) &rest rest) - (declare (ignore rest)) - (let ((func `#'(lambda ,lambda-list (declare (core:lambda-name ,name) ,@decl) ,@doc (block ,(si::function-block-name name) ,@body)))) - ;;(core:fmt t "PRIMITIVE DEFUN defun --> {}%N" func ) - `(progn (eval-when (:compile-toplevel) - (cmp::register-global-function-def 'defun ',name)) - (si:fset ',name ,func nil ',lambda-list))))) - (si::process-declarations lambda-body nil #| No documentation until the real DEFUN is defined |#)))) - t)) - -(export '(defun)) - -;;; Define these here so that Cleavir can do inlining -(defvar *defun-inline-hook* nil) -(defvar *do-inline-hook* nil) -(defvar *proclaim-hook* nil) -(export '(*defun-inline-hook* - *do-inline-hook* - *proclaim-hook*)) - -;; Discard documentation until helpfile.lisp is loaded -(defun set-documentation (o d s) (declare (ignore o d s)) nil) - -(defun proclaim (decl) - "Args: (decl-spec) -Gives a global declaration. See DECLARE for possible DECL-SPECs." - ;;decl must be a proper list - (if (not (core:proper-list-p decl)) - (error 'type-error - :datum decl - :expected-type '(and list (satisfies core:proper-list-p)))) - (cond - ((eq (car decl) 'SPECIAL) - (mapc #'sys::*make-special (cdr decl))) - ((eq (car decl) 'cl:inline) - (dolist (name (cdr decl)) - (funcall #'(setf gethash) t name *functions-to-inline*) - (remhash name *functions-to-notinline*))) - ((eq (car decl) 'cl:notinline) - (dolist (name (cdr decl)) - (funcall #'(setf gethash) t name *functions-to-notinline*) - (remhash name *functions-to-inline*))) - (*proclaim-hook* - (funcall *proclaim-hook* decl)))) - -(defun global-inline-status (name) - "Return 'cl:inline 'cl:notinline or nil" - (cond - ((declared-global-inline-p name) 'cl:inline) - ((declared-global-notinline-p name) 'cl:notinline) - (t nil))) - -(export '(global-inline-status - declared-global-notinline-p - declared-global-inline-p)) - -;; This is used extensively in the ecl compiler and once in predlib.lisp -(defvar *alien-declarations* ()) -(export '*alien-declarations*) - -(defun split-at-white-space (s) (split s " ")) - -(defun default-link-flags () - "Return the link flags and the library dir where libLTO. can be found and the library extension" - (let ((stream (nth-value 2 (ext:vfork-execvp (list "llvm-config" "--ldflags" "--libdir" "--libs") t)))) - (let* ((ldflags (split-at-white-space (read-line stream))) - (libdir (read-line stream)) - (libdir-flag (list (core:fmt nil "-L{}" libdir))) - (libs (split-at-white-space (read-line stream))) - (build-lib (split-at-white-space *build-lib*)) - (build-stlib (split-at-white-space *build-stlib*)) - (build-linkflags (split-at-white-space *build-linkflags*)) - (link-flags (append ldflags #+(or)(list clasp-lib-dir) build-linkflags libdir-flag libs build-stlib build-lib))) - (close stream) - (if (member :use-boehm *features*) - (setq link-flags (cons "-lgc" link-flags))) - (let ((library-extension (if (member :darwin *features*) - "dylib" - "so"))) - (values link-flags libdir library-extension))))) - -(defun link-flags () - (default-link-flags)) -(export 'link-flags) - - -(si:fset 'and - #'(lambda (whole env) - (declare (ignore env)) - (let ((forms (cdr whole))) - (if (null forms) - t - (if (null (cdr forms)) - (car forms) - `(if ,(car forms) - (and ,@(cdr forms))))))) - t) - -(si:fset 'or - #'(lambda (whole env) - (declare (ignore env)) - (let ((forms (cdr whole))) - (if (null forms) - nil - (if ( null (cdr forms)) - (car forms) - (let ((tmp (gensym))) - `(let ((,tmp ,(car forms))) - (if ,tmp - ,tmp - (or ,@(cdr forms))))))))) - t ) -(export '(and or)) - -(defun 1- (num) (- num 1)) -(defun 1+ (num) (+ num 1)) - -;;; These definitions do not use setf, and are replaced in setf.lisp. -#+clasp-min -(si::fset 'incf - #'(lambda (args env) - (declare (core:lambda-name incf)) - (let* ((where (second args)) - (what (caddr args))) - (if what - `(setq ,where (+ ,where ,what)) - `(setq ,where (1+ ,where))))) - t) - -#+clasp-min -(si::fset 'decf - #'(lambda (args env) - (declare (core:lambda-name decf)) - (let* ((where (second args)) - (what (caddr args))) - (if what - `(setq ,where (- ,where ,what)) - `(setq ,where (1- ,where))))) - t) - -(defun build-target-dir (type &optional stage) - (declare (ignore type)) - (let* ((stage (if stage - stage - (default-target-stage))) - (type-modified-host-suffix (build-configuration)) - (bitcode-host (core:fmt nil "{}{}-bitcode" stage type-modified-host-suffix))) - bitcode-host)) - -(defun default-target-stage () - (if (member :eclasp *features*) - "e" - (if (member :mclasp *features*) - "m" - (if (member :vclasp *features*) - "v" - (if (member :cclasp *features*) - "c" - (if (member :bclasp *features*) - (if (member :compiling-cleavir *features*) - "pre" - "b") - "a")))))) - -(defun build-configuration () - (let ((gc (cond - ((member :use-mps *features*) "mps") - ((member :use-mmtk *features*) - (if (member :use-precise-gc *features*) - "mmtkprecise" - "mmtk")) - ((member :use-boehm *features*) - (if (member :use-precise-gc *features*) - "boehmprecise" - "boehm")) - (t (error "Unknown clasp configuration")))) - (mpi (if (member :use-mpi *features*) "-mpi" ""))) - (core:fmt nil "{}-{}{}" (lisp-implementation-type) gc mpi))) - -(defun build-inline-bitcode-pathname (link-type &optional (filetype :intrinsics)) - (let ((name (cond - ((eq filetype :intrinsics) "intrinsics") - ((eq filetype :builtins) "builtins-no-debug-info") - (t (error "illegal filetype - only :intrinsics or :builtins allowed"))))) - (cond ((eq link-type :fasl) - (make-pathname :host "SYS" - :directory '(:absolute "LIB") - :name (core:fmt nil "{}-cxx.a" name) - :type "a")) - ((eq link-type :compile) - (make-pathname :host "SYS" - :directory '(:absolute "LIB") - :name (core:fmt nil "{}-cxx.bc" name) - :type "a")) - ((eq link-type :executable) - (make-pathname :host "SYS" - :directory '(:absolute "LIB") - :name (core:fmt nil "{}-all-cxx.a" name) - :type "a")) - (t - (error "Provide a bitcode file for the link-type ~a" link-type))))) - -(defun build-common-lisp-bitcode-pathname () - (make-pathname :host "SYS" - :directory '(:absolute "LIB") - :name "common-lisp-cxx.a" - :type "a")) - -(export '(build-inline-bitcode-pathname build-common-lisp-bitcode-pathname)) - -#+(or) -(progn - (defconstant +image-pathname+ (make-pathname :directory '(:relative) :name "image" :type "fasl")) - (export '(+image-pathname+ ))) - -(defun bitcode-extension () - (if cmp::*use-human-readable-bitcode* - "ll" - "bc")) - -(export 'bitcode-extension) - -(defun build-extension (type) - (cond ((or (eq type :bytecode) - (member :bytecode *features*)) - "fasl") - ((eq type :faso) - "faso") - ((eq type :fasoll) - "fasoll") - ((eq type :fasobc) - "fasobc") - (t - (error "Unsupported build-extension type ~a" type)))) - -(defun bitcode-pathname (pathname &optional (type cmp:*default-output-type*) stage) - (declare (ignore stage)) - (make-pathname :host "sys" - :directory (list* :absolute - "LIB" - (cdr (pathname-directory pathname))) - :name (pathname-name pathname) - :type (build-extension type))) - -(export '(build-extension)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; -;;; Early macros .... -;;; -;;; - - -#-staging -(eval-when (:execute) - (eval-when (eval compile load) - (si::select-package "SI")) - - ;; This is needed only when bootstrapping CLASP using CLASP-MIN - (eval-when (eval) - (si::fset 'in-package - #'(lambda (def env) - (declare (core:lambda-name in-package)) - `(eval-when (eval compile load) - (si::select-package ,(string (second def))))) - t) - ) - - ;; - ;; This is also needed for booting Clasp. In particular it is required in - ;; defmacro.lisp. - ;; - - ;; Required by REGISTER-GLOBAL in cmp/cmpvar.lisp - (si::fset 'pushnew #'(lambda (w e) - (declare (ignore e)) - (let ((item (cadr w)) - (place (caddr w))) - `(setq ,place (adjoin ,item ,place)))) - t) - - (si::fset 'push #'(lambda (w e) - (declare (ignore e)) - (let ((item (cadr w)) - (place (caddr w))) - `(setq ,place (cons ,item ,place)))) - t) - - - - (fset 'when #'(lambda (def env) - (declare (ignore env)) - `(if ,(cadr def) (progn ,@(cddr def)))) - t) - - - (fset 'unless #'(lambda (def env) - (declare (ignore env)) - `(if ,(cadr def) nil (progn ,@(cddr def)))) - t) - - - (defun si::while-until (test body jmp-op) - (let ((label (gensym)) - (exit (gensym))) - `(TAGBODY - (GO ,exit) - ,label - ,@body - ,exit - (,jmp-op ,test (GO ,label))))) - - (fset 'si::while #'(lambda (def env) - (declare (ignore env)) - (si::while-until (cadr def) (cddr def) 'when)) - t) - - - (fset 'si::until #'(lambda (def env) - (declare (ignore env)) - (si::while-until (cadr def) (cddr def) 'unless)) - t) - - (core:fset 'multiple-value-bind - #'(lambda (whole env) - (declare (core:lambda-name multiple-value-bind-macro)) - (declare (ignore env)) - (let ((vars (cadr whole)) - (form (caddr whole)) - (body (cdddr whole)) - (restvar (gensym))) - `(multiple-value-call - #'(lambda (&optional ,@(mapcar #'list vars) &rest ,restvar) - (declare (ignore ,restvar)) - ,@body) - ,form))) - t) - - - (defun filter-dolist-declarations (declarations) - (let ((a nil)) - (mapc #'(lambda (clause) - (when (not (and (consp clause) - (or (eq (car clause) 'type) - (eq (car clause) 'ignore)))) - (setq a (cons clause a)))) - declarations) - (nreverse a))) - - (let ((f #'(lambda (whole env) - (declare (ignore env) (core:lambda-name dolist)) - (let (body control var expr exit) - (setq body (rest whole)) - (when (endp body) - (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) - (setq control (first body) body (rest body)) - (when (endp control) - (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) - (setq var (first control) control (rest control)) - (if (<= 1 (length control) 2) - (setq expr (first control) exit (rest control)) - (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) - (multiple-value-bind (declarations body) - (process-declarations body nil) - `(block nil - (let* ((%dolist-var ,expr)) - (si::while %dolist-var - (let ((,var (first %dolist-var))) - (declare ,@declarations) - (tagbody - ,@body - (setq %dolist-var (cdr %dolist-var)))))) - ,(when exit - `(let ((,var nil)) - (declare (ignorable ,var) - ,@(filter-dolist-declarations declarations)) - ,@exit)))))))) - (si::fset 'dolist f t '((var list-form &optional result-form) &body body))) - - (let ((f #'(lambda (whole env) - (declare (ignore env) (core:lambda-name dotimes)) - (let (body control var expr exit) - (setq body (rest whole)) - (when (endp body) - (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) - (setq control (first body) body (rest body)) - (when (endp control) - (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) - (setq var (first control) control (rest control)) - (if (<= 1 (length control) 2) - (setq expr (first control) exit (rest control)) - (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) - (multiple-value-bind (declarations body) - (process-declarations body nil) - (when (and (integerp expr) (>= expr 0)) - (setq declarations - (cons `(type (integer 0 ,expr) ,var) declarations))) - `(block nil - (let* ((%dotimes-var ,expr) - (,var 0)) - (declare ,@declarations) - (si::while (< ,var %dotimes-var) - ,@body - (setq ,var (1+ ,var))) - ,@exit))))))) - (si::fset 'dotimes f t '((var count-form &optional result-form) &body body))) - - (let ((f #'(lambda (whole env) - (declare (ignore env) (core:lambda-name do/do*-expand)) - (let (do/do* control test result vlexport step let psetq body) - (setq do/do* (first whole) body (rest whole)) - (if (eq do/do* 'do) - (setq let 'LET psetq 'PSETQ) - (setq let 'LET* psetq 'SETQ)) - (when (endp body) - (simple-program-error "Syntax error first (endp body) in ~A:~%~A" do/do* whole)) - (setq control (first body) body (rest body)) - (when (endp body) - (simple-program-error "Syntax error second (endp body) in ~A:~%~A" do/do* whole)) - (setq test (first body) body (rest body)) - (when (endp test) - (simple-program-error "Syntax error (endp test) in ~A:~%~A" do/do* whole)) - (setq result (rest test) test (first test)) - (dolist (c control) - (when (symbolp c) (setq c (list c))) - (let ((lenc (length c))) - (cond - ((or (eql lenc 1) (eql lenc 2)) - (setq vlexport (cons c vlexport))) - ((eql lenc 3) - (setq vlexport (cons (butlast c) vlexport) - step (list* (third c) (first c) step))) - (t - (simple-program-error "Syntax error (length not 1,2,3 - its ~a and c is ~s) in ~A:~%~A" (length c) c do/do* whole))))) - (multiple-value-bind (declarations real-body) - (process-declarations body nil) - `(BLOCK NIL - (,let ,(nreverse vlexport) - (declare ,@declarations) - (sys::until ,test - ,@real-body - ,@(when step (list (cons psetq (nreverse step))))) - ,@(or result '(nil))))))))) - (si::fset 'do f t '(vars test &body body)) - (si::fset 'do* f t '(vars test &body body))) - - (si::fset 'prog1 #'(lambda (whole env) - (declare (ignore env)) - (let ((sym (gensym)) - (first (cadr whole)) - (body (cddr whole))) - (if body - `(let ((,sym ,first)) - ,@body - ,sym) - first))) - t) - ) - - -#-staging -(eval-when (:execute) - (load #P"sys:src;lisp;kernel;cmp;jit-setup.lisp") - (load #P"sys:src;lisp;kernel;clsymbols.lisp")) - -(defun command-line-paths (&optional (start 0) - &aux (index (length core:*command-line-arguments*)) - paths) - (tagbody - next - (if (> index start) - (progn - (setq index (- index 1) - paths (cons (pathname (elt core:*command-line-arguments* index)) paths)) - (go next)))) - paths) - -;;; -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(export 'process-command-line-load-eval-sequence) -(defun process-command-line-load-eval-sequence () - (mapcar #'(lambda (entry) - (if (eq (car entry) :load) - (load (cdr entry)) - (if (eq (car entry) :script) - (core:load-source (cdr entry) nil nil nil t) - (eval (read-from-string (cdr entry)))))) - (core:command-line-load-eval-sequence))) - -(export 'maybe-load-clasprc) -(defun maybe-load-clasprc () - "Maybe load the users startup code" - (if (not (core:no-rc-p)) - (let ((clasprc (core:rc-file-name))) - (if (probe-file clasprc) - (progn - (if (not (core:noinform-p)) - (core:fmt t "Loading resource file {}%N" clasprc)) - (core:load-source clasprc)) - (if (not (core:noinform-p)) - (core:fmt t "Resource file {} not found, skipping loading of it.%N" clasprc)))))) - -(defun tpl-default-pathname-defaults-command () - (print *default-pathname-defaults*)) - -(defun tpl-change-default-pathname-defaults-dir-command (raw-dir) - (let* ((corrected-dir (format nil "~a/" (string-right-trim "/" (string raw-dir)))) - (dir (pathname-directory (parse-namestring corrected-dir))) - (pn-dir (mapcar #'(lambda (x) (if (eq x :up) :back x)) dir)) - (new-pathname (merge-pathnames (make-pathname :directory pn-dir) *default-pathname-defaults*)) - ) - (setq *default-pathname-defaults* new-pathname))) - - -;;; I moved the build system code out of init.lisp and -;;; put it in clasp-builder.lisp - -(when (member :clasp-builder *features*) - (load "sys:src;lisp;kernel;clasp-builder.lisp")) - - -(defun tpl-hook (cmd) - (cond - ((eq (car cmd) :pwd) (tpl-default-pathname-defaults-command)) - ((eq (car cmd) :cd) (tpl-change-default-pathname-defaults-dir-command (cadr cmd))) - (t (core:fmt t "Unknown command {}%N" cmd)))) - -(setq *top-level-command-hook* #'tpl-hook) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Start everything up -;; - -(export 'core:top-level) - -(defun init-toplevel () - (process-command-line-load-eval-sequence) - (core:low-level-repl)) - -;(eval-when (:load-toplevel) - (setq ext:*toplevel-hook* 'init-toplevel);) diff --git a/src/lisp/kernel/install-delayed-macros.lisp b/src/lisp/kernel/install-delayed-macros.lisp new file mode 100644 index 0000000000..eb616d142c --- /dev/null +++ b/src/lisp/kernel/install-delayed-macros.lisp @@ -0,0 +1,4 @@ +(in-package #:core) + +(eval-when (:compile-toplevel) + (install-delayed-macros)) diff --git a/src/lisp/kernel/lsp/all-cl-symbols.lisp b/src/lisp/kernel/lsp/all-cl-symbols.lisp deleted file mode 100644 index 46632f2baf..0000000000 --- a/src/lisp/kernel/lsp/all-cl-symbols.lisp +++ /dev/null @@ -1,477 +0,0 @@ -(make-package "CLSYMBOLS" :use '(:core :clos)) -(in-package :clsymbols) - -(defvar *all-cl-symbols* '(&allow-other-keys *print-miser-width* - &aux *print-pprint-dispatch* - &body *print-pretty* - &environment *print-radix* - &key *print-readably* - &optional *print-right-margin* - &rest *query-io* - &whole *random-state* - * *read-base* - ** *read-default-float-format* - *** *read-eval* - *break-on-signals* *read-suppress* - *compile-file-pathname* *readtable* - *compile-file-truename* *standard-input* - *compile-print* *standard-output* - *compile-verbose* *terminal-io* - *debug-io* *trace-output* - *debugger-hook* + - *default-pathname-defaults* ++ - *error-output* +++ - *features* - - *gensym-counter* / - *load-pathname* // - *load-print* /// - *load-truename* /= - *load-verbose* 1+ - *macroexpand-hook* 1- - *modules* < - *package* <= - *print-array* = - *print-base* > - *print-case* >= - *print-circle* abort - *print-escape* abs - *print-gensym* acons - *print-length* acos - *print-level* acosh - *print-lines* add-method - adjoin atom boundp - adjust-array base-char break - adjustable-array-p base-string broadcast-stream - allocate-instance bignum broadcast-stream-streams - alpha-char-p bit built-in-class - alphanumericp bit-and butlast - and bit-andc1 byte - append bit-andc2 byte-position - apply bit-eqv byte-size - apropos bit-ior caaaar - apropos-list bit-nand caaadr - aref bit-nor caaar - arithmetic-error bit-not caadar - arithmetic-error-operands bit-orc1 caaddr - arithmetic-error-operation bit-orc2 caadr - array bit-vector caar - array-dimension bit-vector-p cadaar - array-dimension-limit bit-xor cadadr - array-dimensions block cadar - array-displacement boole caddar - array-element-type boole-1 cadddr - array-has-fill-pointer-p boole-2 caddr - array-in-bounds-p boole-and cadr - array-rank boole-andc1 call-arguments-limit - array-rank-limit boole-andc2 call-method - array-row-major-index boole-c1 call-next-method - array-total-size boole-c2 car - array-total-size-limit boole-clr case - arrayp boole-eqv catch - ash boole-ior ccase - asin boole-nand cdaaar - asinh boole-nor cdaadr - assert boole-orc1 cdaar - assoc boole-orc2 cdadar - assoc-if boole-set cdaddr - assoc-if-not boole-xor cdadr - atan boolean cdar - atanh both-case-p cddaar - cddadr clear-input copy-tree - cddar clear-output cos - cdddar close cosh - cddddr clrhash count - cdddr code-char count-if - cddr coerce count-if-not - cdr compilation-speed ctypecase - ceiling compile debug - cell-error compile-file decf - cell-error-name compile-file-pathname declaim - cerror compiled-function declaration - change-class compiled-function-p declare - char compiler-macro decode-float - char-code compiler-macro-function decode-universal-time - char-code-limit complement defclass - char-downcase complex defconstant - char-equal complexp defgeneric - char-greaterp compute-applicable-methods define-compiler-macro - char-int compute-restarts define-condition - char-lessp concatenate define-method-combination - char-name concatenated-stream define-modify-macro - char-not-equal concatenated-stream-streams define-setf-expander - char-not-greaterp cond define-symbol-macro - char-not-lessp condition defmacro - char-upcase conjugate defmethod - char/= cons defpackage - char< consp defparameter - char<= constantly defsetf - char= constantp defstruct - char> continue deftype - char>= control-error defun - character copy-alist defvar - characterp copy-list delete - check-type copy-pprint-dispatch delete-duplicates - cis copy-readtable delete-file - class copy-seq delete-if - class-name copy-structure delete-if-not - class-of copy-symbol delete-package - denominator eq - deposit-field eql - describe equal - describe-object equalp - destructuring-bind error - digit-char etypecase - digit-char-p eval - directory eval-when - directory-namestring evenp - disassemble every - division-by-zero exp - do export - do* expt - do-all-symbols extended-char - do-external-symbols fboundp - do-symbols fceiling - documentation fdefinition - dolist ffloor - dotimes fifth - double-float file-author - double-float-epsilon file-error - double-float-negative-epsilon file-error-pathname - dpb file-length - dribble file-namestring - dynamic-extent file-position - ecase file-stream - echo-stream file-string-length - echo-stream-input-stream file-write-date - echo-stream-output-stream fill - ed fill-pointer - eighth find - elt find-all-symbols - encode-universal-time find-class - end-of-file find-if - endp find-if-not - enough-namestring find-method - ensure-directories-exist find-package - ensure-generic-function find-restart - find-symbol get-internal-run-time - finish-output get-macro-character - first get-output-stream-string - fixnum get-properties - flet get-setf-expansion - float get-universal-time - float-digits getf - float-precision gethash - float-radix go - float-sign graphic-char-p - floating-point-inexact handler-bind - floating-point-invalid-operation handler-case - floating-point-overflow hash-table - floating-point-underflow hash-table-count - floatp hash-table-p - floor hash-table-rehash-size - fmakunbound hash-table-rehash-threshold - force-output hash-table-size - format hash-table-test - formatter host-namestring - fourth identity - fresh-line if - fround ignorable - ftruncate ignore - ftype ignore-errors - funcall imagpart - function import - function-keywords in-package - function-lambda-expression incf - functionp initialize-instance - gcd inline - generic-function input-stream-p - gensym inspect - gentemp integer - get integer-decode-float - get-decoded-time integer-length - get-dispatch-macro-character integerp - get-internal-real-time interactive-stream-p - intern lisp-implementation-type - internal-time-units-per-second lisp-implementation-version - intersection list - invalid-method-error list* - invoke-debugger list-all-packages - invoke-restart list-length - invoke-restart-interactively listen - isqrt listp - keyword load - keywordp load-logical-pathname-translations - labels load-time-value - lambda locally - lambda-list-keywords log - lambda-parameters-limit logand - last logandc1 - lcm logandc2 - ldb logbitp - ldb-test logcount - ldiff logeqv - least-negative-double-float logical-pathname - least-negative-long-float logical-pathname-translations - least-negative-normalized-double-float logior - least-negative-normalized-long-float lognand - least-negative-normalized-short-float lognor - least-negative-normalized-single-float lognot - least-negative-short-float logorc1 - least-negative-single-float logorc2 - least-positive-double-float logtest - least-positive-long-float logxor - least-positive-normalized-double-float long-float - least-positive-normalized-long-float long-float-epsilon - least-positive-normalized-short-float long-float-negative-epsilon - least-positive-normalized-single-float long-site-name - least-positive-short-float loop - least-positive-single-float loop-finish - length lower-case-p - let machine-instance - let* machine-type - machine-version mask-field - macro-function max - macroexpand member - macroexpand-1 member-if - macrolet member-if-not - make-array merge - make-broadcast-stream merge-pathnames - make-concatenated-stream method - make-condition method-combination - make-dispatch-macro-character method-combination-error - make-echo-stream method-qualifiers - make-hash-table min - make-instance minusp - make-instances-obsolete mismatch - make-list mod - make-load-form most-negative-double-float - make-load-form-saving-slots most-negative-fixnum - make-method most-negative-long-float - make-package most-negative-short-float - make-pathname most-negative-single-float - make-random-state most-positive-double-float - make-sequence most-positive-fixnum - make-string most-positive-long-float - make-string-input-stream most-positive-short-float - make-string-output-stream most-positive-single-float - make-symbol muffle-warning - make-synonym-stream multiple-value-bind - make-two-way-stream multiple-value-call - makunbound multiple-value-list - map multiple-value-prog1 - map-into multiple-value-setq - mapc multiple-values-limit - mapcan name-char - mapcar namestring - mapcon nbutlast - maphash nconc - mapl next-method-p - maplist nil - nintersection package-error - ninth package-error-package - no-applicable-method package-name - no-next-method package-nicknames - not package-shadowing-symbols - notany package-use-list - notevery package-used-by-list - notinline packagep - nreconc pairlis - nreverse parse-error - nset-difference parse-integer - nset-exclusive-or parse-namestring - nstring-capitalize pathname - nstring-downcase pathname-device - nstring-upcase pathname-directory - nsublis pathname-host - nsubst pathname-match-p - nsubst-if pathname-name - nsubst-if-not pathname-type - nsubstitute pathname-version - nsubstitute-if pathnamep - nsubstitute-if-not peek-char - nth phase - nth-value pi - nthcdr plusp - null pop - number position - numberp position-if - numerator position-if-not - nunion pprint - oddp pprint-dispatch - open pprint-exit-if-list-exhausted - open-stream-p pprint-fill - optimize pprint-indent - or pprint-linear - otherwise pprint-logical-block - output-stream-p pprint-newline - package pprint-pop - pprint-tab read-char - pprint-tabular read-char-no-hang - prin1 read-delimited-list - prin1-to-string read-from-string - princ read-line - princ-to-string read-preserving-whitespace - print read-sequence - print-not-readable reader-error - print-not-readable-object readtable - print-object readtable-case - print-unreadable-object readtablep - probe-file real - proclaim realp - prog realpart - prog* reduce - prog1 reinitialize-instance - prog2 rem - progn remf - program-error remhash - progv remove - provide remove-duplicates - psetf remove-if - psetq remove-if-not - push remove-method - pushnew remprop - quote rename-file - random rename-package - random-state replace - random-state-p require - rassoc rest - rassoc-if restart - rassoc-if-not restart-bind - ratio restart-case - rational restart-name - rationalize return - rationalp return-from - read revappend - read-byte reverse - room simple-bit-vector - rotatef simple-bit-vector-p - round simple-condition - row-major-aref simple-condition-format-arguments - rplaca simple-condition-format-control - rplacd simple-error - safety simple-string - satisfies simple-string-p - sbit simple-type-error - scale-float simple-vector - schar simple-vector-p - search simple-warning - second sin - sequence single-float - serious-condition single-float-epsilon - set single-float-negative-epsilon - set-difference sinh - set-dispatch-macro-character sixth - set-exclusive-or sleep - set-macro-character slot-boundp - set-pprint-dispatch slot-exists-p - set-syntax-from-char slot-makunbound - setf slot-missing - setq slot-unbound - seventh slot-value - shadow software-type - shadowing-import software-version - shared-initialize some - shiftf sort - short-float space - short-float-epsilon special - short-float-negative-epsilon special-operator-p - short-site-name speed - signal sqrt - signed-byte stable-sort - signum standard - simple-array standard-char - simple-base-string standard-char-p - standard-class sublis - standard-generic-function subseq - standard-method subsetp - standard-object subst - step subst-if - storage-condition subst-if-not - store-value substitute - stream substitute-if - stream-element-type substitute-if-not - stream-error subtypep - stream-error-stream svref - stream-external-format sxhash - streamp symbol - string symbol-function - string-capitalize symbol-macrolet - string-downcase symbol-name - string-equal symbol-package - string-greaterp symbol-plist - string-left-trim symbol-value - string-lessp symbolp - string-not-equal synonym-stream - string-not-greaterp synonym-stream-symbol - string-not-lessp t - string-right-trim tagbody - string-stream tailp - string-trim tan - string-upcase tanh - string/= tenth - string< terpri - string<= the - string= third - string> throw - string>= time - stringp trace - structure translate-logical-pathname - structure-class translate-pathname - structure-object tree-equal - style-warning truename - truncate values-list - two-way-stream variable - two-way-stream-input-stream vector - two-way-stream-output-stream vector-pop - type vector-push - type-error vector-push-extend - type-error-datum vectorp - type-error-expected-type warn - type-of warning - typecase when - typep wild-pathname-p - unbound-slot with-accessors - unbound-slot-instance with-compilation-unit - unbound-variable with-condition-restarts - undefined-function with-hash-table-iterator - unexport with-input-from-string - unintern with-open-file - union with-open-stream - unless with-output-to-string - unread-char with-package-iterator - unsigned-byte with-simple-restart - untrace with-slots - unuse-package with-standard-io-syntax - unwind-protect write - update-instance-for-different-class write-byte - update-instance-for-redefined-class write-char - upgraded-array-element-type write-line - upgraded-complex-part-type write-sequence - upper-case-p write-string - use-package write-to-string - use-value y-or-n-p - user-homedir-pathname yes-or-no-p - values zerop - )) - - -(defvar *cl-symbol-ht* (make-hash-table :test #'equal)) -(dolist (s *all-cl-symbols*) - (setf (gethash (symbol-name s) *cl-symbol-ht*) s)) - -(defun identify-symbols-for-export (pkg) - (let (symbols) - (do-symbols (s (find-package pkg)) - (when (gethash (symbol-name s) *cl-symbol-ht*) - (push s symbols))) - symbols)) - - -(defun create-export-file (file-name pkg) - (let ((symbols (identify-symbols-for-export pkg))) - (with-open-file (fout file-name :direction :output :if-exists :supersede) - (format fout "~A" symbols)))) - -(export 'mine-symbols) - - diff --git a/src/lisp/kernel/lsp/arraylib.lisp b/src/lisp/kernel/lsp/arraylib.lisp index a031df89d8..3e9df88cc4 100644 --- a/src/lisp/kernel/lsp/arraylib.lisp +++ b/src/lisp/kernel/lsp/arraylib.lisp @@ -116,13 +116,13 @@ INDEXes must be equal to the rank of ARRAY." (declare (type array array) (optimize (safety 0)) #+(or)(ext:check-arguments-type)) - (do* ((indices indices (cons-cdr indices)) + (do* ((indices indices (cdr indices)) (r (array-rank array)) (i 0 (1+ i))) ((>= i r) t) (declare (type index r i)) (if indices - (let* ((index (cons-car indices))) + (let* ((index (car indices))) (when (or (not (si::fixnump index)) (minusp (the fixnum index)) (>= (the fixnum index) (array-dimension array i))) @@ -140,7 +140,7 @@ INDEXes must be equal to the rank of ARRAY." (do* ((r (array-rank array)) (i 0 (1+ i)) (j 0) - (s indices (cons-cdr s))) + (s indices (cdr (the cons s)))) ((null s) (when (< i r) (indexing-error array indices)) @@ -148,7 +148,7 @@ INDEXes must be equal to the rank of ARRAY." (declare (ext:array-index j) (fixnum i r)) (let* ((d (array-dimension array i)) - (o (cons-car s)) + (o (car (the cons s))) (ndx 0)) (declare (ext:array-index ndx)) (unless (and (typep o 'fixnum) @@ -162,7 +162,6 @@ INDEXes must be equal to the rank of ARRAY." "Args: (bit-array &rest indexes) Returns the bit of BIT-ARRAY specified by INDEXes." (declare (type (array bit) bit-array)) - #+(not clasp-min) (check-type bit-array (array bit)) (row-major-aref bit-array (row-major-index-inner bit-array indices))) @@ -170,7 +169,6 @@ Returns the bit of BIT-ARRAY specified by INDEXes." "Args: (simple-bit-array &rest subscripts) Returns the specified bit in SIMPLE-BIT-ARRAY." (declare (type (simple-array bit) bit-array)) - #+(not clasp-min) (check-type bit-array (simple-array bit)) (row-major-aref bit-array (row-major-index-inner bit-array indices))) @@ -178,13 +176,17 @@ Returns the specified bit in SIMPLE-BIT-ARRAY." `(let ((,vectorname ,vector) (,indexname 0)) (cond ((core:data-vector-p ,vectorname)) ((arrayp ,vectorname) + #+(or) + (loop until (core:data-vector-p ,vectorname) + do (incf ,indexname (%displaced-index-offset ,vectorname)) + (setf ,vectorname (%displacement ,vectorname))) (tagbody loop (setq ,indexname (+ ,indexname (%displaced-index-offset ,vectorname)) ,vectorname (%displacement ,vectorname)) (if (core:data-vector-p ,vectorname) (go done) (go loop)) done)) - (t (signal-type-error ,vectorname 'array))) + (t (error 'type-error :datum ,vectorname :expected-type 'array))) ,@body)) ;;; (equal (array-dimensions a1) (array-dimensions a2)), but without consing @@ -303,7 +305,7 @@ pointer is 0 already." (optimize (safety 0))) (when (zerop fp) (error "The fill pointer of the vector ~S zero." vector)) - (funcall #'(setf fill-pointer) (decf fp) vector) + (setf (fill-pointer vector) (decf fp)) (aref vector fp))) (defun copy-array-contents (dest orig) diff --git a/src/lisp/kernel/lsp/assert.lisp b/src/lisp/kernel/lsp/assert.lisp index 376038e8b3..1dded39d09 100644 --- a/src/lisp/kernel/lsp/assert.lisp +++ b/src/lisp/kernel/lsp/assert.lisp @@ -17,7 +17,6 @@ (format *query-io* "~&Type a form to be evaluated:~%") (list (eval (read *query-io*)))) -#-clasp-min (defun wrong-type-argument (object type &optional place function) (tagbody again (restart-case @@ -54,7 +53,6 @@ value is used to indicate the expected type in the error message." (setf ,place (do-check-type ,aux ',type ',type-string ',place))) nil))) -#-clasp-min (defun do-check-type (value type type-string place) (tagbody again (unless (typep value type) @@ -81,20 +79,21 @@ until FORM returns a non-NIL value. Returns NIL. DATUM and ARGs designate the error to signal." `(while (not ,test-form) (setf (values ,@places) - ;; Defined later in clos/conditions.lisp + ;; Defined in clos/conditions.lisp (assert-failure ',test-form ',places (list ,@places) ;; If DATUM is provided, it must be for a ;; condition; NIL is not acceptable. ,(if datump datum nil) ,@arguments)))) -(defun accumulate-cases (cases list-is-atom-p) - (do ((c cases (cdr c)) - (l '())) - ((null c) (nreverse l)) - (let ((keys (caar c))) - (cond ((atom keys) (unless (null keys) (push keys l))) - (list-is-atom-p (push keys l)) - (t (setq l (append keys l))))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun accumulate-cases (cases list-is-atom-p) + (do ((c cases (cdr c)) + (l '())) + ((null c) (nreverse l)) + (let ((keys (caar c))) + (cond ((atom keys) (unless (null keys) (push keys l))) + (list-is-atom-p (push keys l)) + (t (setq l (append keys l)))))))) (defun ecase-error (value values) (error 'CASE-FAILURE :name 'ECASE @@ -114,7 +113,6 @@ signals an error." (case ,key ,@clauses (t (si::ecase-error ,key ',(accumulate-cases clauses nil))))))) -#-clasp-min (defun ccase-error (keyform key values) (restart-case (error 'CASE-FAILURE :name 'CCASE @@ -127,13 +125,14 @@ signals an error." :INTERACTIVE read-evaluated-form (return-from ccase-error value)))) -(defun remove-otherwise-from-clauses (clauses) - (mapcar #'(lambda (clause) - (let ((options (first clause))) - (if (member options '(t otherwise)) - (cons (list options) (rest clause)) - clause))) - clauses)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun remove-otherwise-from-clauses (clauses) + (mapcar #'(lambda (clause) + (let ((options (first clause))) + (if (member options '(t otherwise)) + (cons (list options) (rest clause)) + clause))) + clauses))) (defmacro ccase (keyplace &rest clauses) "Syntax: (ccase place {({key | ({key}*)} {form}*)}*) @@ -196,7 +195,6 @@ the last FORM. If not, signals an error." (progn ,@(cdr clause)) ,form)))))) -#-clasp-min (defun ctypecase-error (keyplace value types) (restart-case (error 'CASE-FAILURE :name 'CTYPECASE diff --git a/src/lisp/kernel/lsp/assorted.lisp b/src/lisp/kernel/lsp/assorted.lisp index 69d0c5b5d0..41800b6e4f 100644 --- a/src/lisp/kernel/lsp/assorted.lisp +++ b/src/lisp/kernel/lsp/assorted.lisp @@ -144,7 +144,6 @@ the file system." (code-char (+ weight (if (< weight 10) 48 55))))) ;; Donated by Shinmera in #clasp on April 2015 "free of charge" -(in-package :cl) (defun nstring-capitalize (string &key (start 0) end) (loop with capitalize = t diff --git a/src/lisp/kernel/lsp/atomics.lisp b/src/lisp/kernel/lsp/atomics.lisp index 566b488fc4..63ba0fb080 100644 --- a/src/lisp/kernel/lsp/atomics.lisp +++ b/src/lisp/kernel/lsp/atomics.lisp @@ -5,11 +5,23 @@ ;;; DEFINE-ATOMIC-EXPANSION, GET-ATOMIC-EXPANSION ;;; -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun atomic-expander (symbol) - (core:get-sysprop symbol 'atomic-expander)) - (defun (setf atomic-expander) (expander symbol) - (setf (core:get-sysprop symbol 'atomic-expander) expander))) +(defun atomic-expander (symbol) + (core:get-sysprop symbol 'atomic-expander)) +(defun (setf atomic-expander) (expander symbol) + (setf (core:get-sysprop symbol 'atomic-expander) expander)) + +(defgeneric %get-atomic-expansion (place environment keys)) +(defmethod %get-atomic-expansion ((place cons) environment keys) + (let* ((name (car place)) + (expander (atomic-expander name))) + (if expander + (apply expander place keys) + (multiple-value-bind (expansion expanded) + (macroexpand-1 place environment) + (if expanded + (apply #'get-atomic-expansion expansion keys) + (error 'not-atomic :place place)))))) +;;; symbol method defined later in kernel2/cleavir/atomics.lisp (defun get-atomic-expansion (place &rest keys &key environment (order nil orderp) @@ -27,51 +39,18 @@ defaulting of ORDER is applied." (declare (ignore order)) ;; Default the order parameter. KLUDGEy. (unless orderp (setf keys (list* :order :sequentially-consistent keys))) - (etypecase place - (symbol - ;; KLUDGE: This will not work in bclasp at all, and the cleavir interface - ;; may not be great for this. - #-(or cclasp eclasp) - (multiple-value-bind (expansion expanded) - (macroexpand-1 place environment) - (if expanded - (apply #'get-atomic-expansion expansion keys) - (error "Atomic operations on lexical variables not supported yet"))) - #+(or cclasp eclasp) - (let ((info (cleavir-env:variable-info - clasp-cleavir:*clasp-system* environment place))) - (etypecase info - (cleavir-env:symbol-macro-info - (apply #'get-atomic-expansion (macroexpand-1 place environment) keys)) - (cleavir-env:special-variable-info - (apply #'get-atomic-expansion `(symbol-value ',place) keys)) - (cleavir-env:lexical-variable-info - ;; TODO - (error 'not-atomic :place place)) - (null - (error "Unknown variable ~a" place))))) - (cons - (let* ((name (car place)) - (expander (atomic-expander name))) - (if expander - (apply expander place keys) - (multiple-value-bind (expansion expanded) - (macroexpand-1 place environment) - (if expanded - (apply #'get-atomic-expansion expansion keys) - (error 'not-atomic :place place)))))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun expand-atomic-expander (name place-ll expander-ll body) - (let ((place (gensym "PLACE"))) - (multiple-value-bind (decls body doc) - (core:process-declarations body t) - ;; FIXME: probably have to sort the decls by lambda list (ugh) - `(lambda (,place ,@expander-ll) - (declare ,@decls) - ,@(when doc (list doc)) - (destructuring-bind ,place-ll (rest ,place) - (block ,name ,@body))))))) + (%get-atomic-expansion place environment keys)) + +(defun expand-atomic-expander (name place-ll expander-ll body) + (let ((place (gensym "PLACE"))) + (multiple-value-bind (decls body doc) + (core:process-declarations body t) + ;; FIXME: probably have to sort the decls by lambda list (ugh) + `(lambda (,place ,@expander-ll) + (declare ,@decls) + ,@(when doc (list doc)) + (destructuring-bind ,place-ll (rest ,place) + (block ,name ,@body)))))) (defmacro define-atomic-expander (accessor place-lambda-list expander-lambda-list diff --git a/src/lisp/kernel/lsp/bytecode-introspect.lisp b/src/lisp/kernel/lsp/bytecode-introspect.lisp deleted file mode 100644 index d2b9b4c41a..0000000000 --- a/src/lisp/kernel/lsp/bytecode-introspect.lisp +++ /dev/null @@ -1,99 +0,0 @@ -(in-package #:core) - -(defun bytecode-next-arg (argspec bytecode opip ip nbytes) - (cond - ((cmpref::constant-arg-p argspec) - (cons :constant (cmpref::bc-unsigned bytecode ip nbytes))) - ((cmpref::label-arg-p argspec) - (cons :label (+ opip (cmpref::bc-signed bytecode ip nbytes)))) - ((cmpref::keys-arg-p argspec) - (cons :keys (cmpref::bc-unsigned bytecode ip nbytes))) - (t (cons :operand (cmpref::bc-unsigned bytecode ip nbytes))))) - -(defun collect-pka-args (bytecode ip nbytes) - ;; parse-key-args is eccentric, so we special case it. - ;; we have more-start, key-count-info, key-literal-start, key-frame-start. - ;; the first is an index into the arguments, the second is weird, the third - ;; is an index into the literals that's used a bit differently than usual, - ;; and the last is an index into the frame. - (let* ((more-start - (prog1 (cmpref::bc-unsigned bytecode ip nbytes) - (incf ip nbytes))) - (key-count-info - (prog1 (cmpref::bc-unsigned bytecode ip nbytes) - (incf ip nbytes))) - (key-count (ash key-count-info -1)) - (aokp (logbitp 0 key-count-info)) - (key-literal-start - (prog1 (cmpref::bc-unsigned bytecode ip nbytes) - (incf ip nbytes)))) - (list (cons :operand more-start) - (cons :key-count-info (cons key-count aokp)) - (cons :keys key-literal-start)))) - -;;; Compute a list of annotations that start at the given IP. -;;; Return the list, and the index of the next annotation. -(defun new-annotations (annotations index ip) - (values - (loop with len = (length annotations) - while (< index len) - while (<= (core:bytecode-debug-info/start (aref annotations index)) ip) - when (= (core:bytecode-debug-info/start (aref annotations index)) ip) - collect (aref annotations index) - do (incf index)) - index)) - -(defmacro do-instructions ((mnemonic args opip ip - &optional (annots (gensym "ANNOTATIONS"))) - (bytecode &key (start 0) end annotations) - &body body) - (let ((bsym (gensym "BYTECODE")) - (gend (gensym "END")) - (longp (gensym "LONGP")) - (gannotations (gensym "ANNOTATIONS")) - (next-annotation-index (gensym "NEXT-ANNOTATION-INDEX")) - (op (gensym "OP"))) - `(loop with ,bsym = ,bytecode - with ,ip = ,start - with ,longp = nil - with ,gend = ,(or end `(+ ,ip (length ,bsym))) - with ,gannotations = ,annotations - with ,next-annotation-index = 0 - with ,annots = nil - for ,op = (cmpref::decode-instr (aref ,bsym ,ip)) - for ,mnemonic = (intern (string-upcase (first ,op)) "KEYWORD") - if (eql ,mnemonic :long) - do (setf ,longp t ,ip (1+ ,ip)) - else - do (let ((,opip ,ip)) - (incf ,ip) - (let ((,args - (if (eq ,mnemonic :parse-key-args) - (let ((nbytes (if ,longp 2 1))) - (prog1 (collect-pka-args ,bsym ,ip nbytes) - (incf ,ip (* 3 nbytes)))) - (loop for argspec - in (if ,longp (fourth ,op) (third ,op)) - for nbytes = (logandc2 argspec - cmpref::+mask-arg+) - collect (bytecode-next-arg argspec ,bsym ,opip ,ip - nbytes) - do (incf ,ip nbytes))))) - (declare (ignorable ,args ,ip)) - (setf (values ,annots ,next-annotation-index) - (new-annotations ,gannotations - ,next-annotation-index ,ip)) - ,@body - (setf ,longp nil))) - until (>= ,ip ,gend)))) - -(defmacro do-module-instructions ((mnemonic args opip ip - &optional (annots (gensym "ANNOTATIONS"))) - (module) - &body body) - (let ((gmodule (gensym "MODULE"))) - `(let ((,gmodule ,module)) - (do-instructions (,mnemonic ,args ,opip ,ip ,annots) - ((core:bytecode-module/bytecode ,gmodule) - :annotations (core:bytecode-module/debug-info ,gmodule)) - ,@body)))) diff --git a/src/lisp/kernel/lsp/cdr-5.lisp b/src/lisp/kernel/lsp/cdr-5.lisp index 130a94d999..322eec872a 100644 --- a/src/lisp/kernel/lsp/cdr-5.lisp +++ b/src/lisp/kernel/lsp/cdr-5.lisp @@ -11,9 +11,6 @@ ;;;; ;;;; https://common-lisp.net/project/cdr/document/5/index.html -;;;(setq *echo-repl-read* t) - - (pushnew :cdr-5 *features*) (in-package "EXT") diff --git a/src/lisp/kernel/lsp/claspmacros.lisp b/src/lisp/kernel/lsp/claspmacros.lisp deleted file mode 100644 index 68294ac987..0000000000 --- a/src/lisp/kernel/lsp/claspmacros.lisp +++ /dev/null @@ -1,249 +0,0 @@ -(in-package :ext) -(defmacro ext::special-var (name) - `(ext::special-var ,name)) - -(defmacro ext::lexical-var (name depth index) - `(ext::lexical-var ,name ,depth ,index)) - -(defmacro ext:with-float-traps-masked (traps &body body) - (let ((previous (gensym "PREVIOUS")) - (mask (reduce (lambda (bits trap) - (logior bits - (ecase trap - (:underflow core:+fe-underflow+) - (:overflow core:+fe-overflow+) - (:invalid core:+fe-invalid+) - (:inexact core:+fe-inexact+) - (:divide-by-zero core:+fe-divbyzero+) - (:denormalized-operand 0)))) - traps - :initial-value 0))) - `(let ((,previous (core:fe-disable-except ,mask))) - (unwind-protect - (progn ,@body) - (core:fe-restore-except ,previous))))) - -;; -;; Some helper macros for working with iterators -;; -;; - -(in-package :ext) - -(defmacro do-c++-iterator ((i iterator &optional result) &rest body) - (let ((cur (gensym)) (begin (gensym)) (end (gensym))) - `(multiple-value-bind (,begin ,end) - ,iterator - (do* ((,cur ,begin (core:iterator-step ,cur)) - (,i (core:iterator-unsafe-element ,cur) (core:iterator-unsafe-element ,cur))) - ((core:iterator= ,cur ,end) - (let ((,i nil)) - (declare (ignorable ,i)) - ,result)) - ,@body)))) - -(defmacro map-c++-iterator (code iterator) - (let ((val (gensym))) - `(progn - (do-c++-iterator (,val ,iterator) (funcall ,code ,val)) - nil))) - -(export '(do-c++-iterator map-c++-iterator)) - - -(defmacro with-locked-hash-table (ht &body body) - "If the hash table is thread safe - then turn on the lock" - (let ((htlock (gensym))) - `(let ((,htlock (hash-table-shared-mutex ,ht))) - (if ,htlock - (unwind-protect - (progn - (mp:shared-lock ,htlock) - ,@body) - (mp:shared-unlock ,htlock)) - (progn - ,@body))))) - -(export '(with-locked-hash-table)) - -(in-package :core) - -;;; We use progn in these expansions so that the programmer can't DECLARE anything. -(defmacro cl:unwind-protect (protected-form &rest cleanup-forms) - `(core:funwind-protect - (lambda () (declare (core:lambda-name unwind-protected-lambda)) (progn ,protected-form)) - (lambda () (declare (core:lambda-name unwind-cleanup-lambda)) (progn ,@cleanup-forms)))) - -(defmacro cl:catch (tag &rest forms) - `(core:catch-function - ,tag (lambda () (declare (core:lambda-name catch-lambda)) (progn ,@forms)))) - -(defmacro cl:throw (tag result-form) - `(core:throw-function - ,tag (lambda () (declare (core:lambda-name throw-lambda)) (progn ,result-form)))) - -#+(or) -(defmacro cl:progv (symbols values &rest forms) - `(core:progv-function ,symbols ,values #'(lambda () ,@forms))) - - -;;;;;;;; -;;; Validate vaslists -;;;;;;;; - -#+validate-vaslists -(defmacro validate-vaslist (vaslist) - `(core:do-validate-vaslist ,vaslist)) - -#-validate-vaslists -(defmacro validate-vaslist (vaslist) - `(progn - ,vaslist)) - -(export 'validate-vaslist :core) - -;;;;;;;; -;;;;;;;; - -#-clasp-min -(defmacro core::header-stamp-case (stamp derivable rack wrapped header) - `(case (logand (ash ,stamp 2) ,cmp:+where-tag-mask+) - (,cmp:+derivable-where-tag+ ,derivable) - (,cmp:+rack-where-tag+ ,rack) - (,cmp:+wrapped-where-tag+ ,wrapped) - (,cmp:+header-where-tag+ ,header))) - -;;; Sham function for bytecode; cleavir special cases away calls -(defun cleavir-primop:unreachable () - (error "BUG: Reached code marked unreachable")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; core:debug-message is a macro to mimic the core:debug-message special operator -;;; -(defmacro debug-message (msg) (declare (ignore msg)) nil) -(export 'debug-message) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Set the fdefinition for all special operators to something more reasonable than T -;;; For known operators, put in a function with correct lambda list for the sake of -;;; documentation. -;;; -(defmacro def-special-operator-function (name lambda-list &optional (vars lambda-list)) - `(unless (fboundp ',name) - (core:fset ',name - (lambda ,lambda-list - (declare (ignore ,@vars)) - (error 'do-not-funcall-special-operator :operator ',name))))) -(def-special-operator-function progn (&rest forms) (forms)) -(def-special-operator-function block (name &rest forms) (name forms)) -(def-special-operator-function catch (tag &rest forms) (tag forms)) -(def-special-operator-function eval-when (situations &rest forms) (situations forms)) -(def-special-operator-function flet (bindings &rest body) (bindings body)) -(def-special-operator-function function (thing)) -(def-special-operator-function the (values-type form)) -(def-special-operator-function go (tag)) -(def-special-operator-function if (condition then else)) -(def-special-operator-function labels (bindings &rest body) (bindings body)) -(def-special-operator-function let (bindings &rest body) (bindings body)) -(def-special-operator-function let* (bindings &rest body) (bindings body)) -(def-special-operator-function locally (&rest body) (body)) -(def-special-operator-function macrolet (bindings &rest body) (bindings body)) -(def-special-operator-function multiple-value-prog1 (values-form &rest forms) (values-form forms)) -(def-special-operator-function multiple-value-call (function &rest args) (function args)) -(def-special-operator-function progv (symbols values &rest forms) (symbols values forms)) -(def-special-operator-function quote (object)) -(def-special-operator-function return-from (name &optional value) (name value)) -(def-special-operator-function setq (&rest pairs) (pairs)) -(def-special-operator-function tagbody (&rest statements) (statements)) -(def-special-operator-function throw (tag result-form)) -(def-special-operator-function unwind-protect (protected &rest cleanup) (protected cleanup)) -(def-special-operator-function symbol-macrolet (bindings &rest body) (bindings body)) -(def-special-operator-function load-time-value (form &optional read-only-p) (form read-only-p)) -(dolist (so (core::aclasp-list-of-all-special-operators)) - (when (null (fboundp so)) - (core:fset so - (let ((so so)) - (lambda (&rest args) - (declare (ignore args)) - (error 'do-not-funcall-special-operator :operator so)))))) - -(export 'do-not-funcall-special-operator) - -(defmacro with-print-readably (&rest body) - `(with-standard-io-syntax - (let ((*print-circle* t)) - ,@body))) - - -(defun do-memory-ramp (closure pattern) - (unwind-protect - (progn - (gctools:alloc-pattern-begin pattern) - (funcall closure)) - (gctools:alloc-pattern-end))) - -(defmacro with-memory-ramp ((&key (pattern 'gctools:ramp)) &body body) - `(if (member :disable-memory-ramp *features*) - (progn - (core:fmt t "Compiling with memory-ramp DISABLED%N") - (funcall (lambda () (progn ,@body)))) - (do-memory-ramp (lambda () (progn ,@body)) ,pattern))) - -;;; -;;; When threading is supported this macro should replicate the ECL mp:with-lock macro -;;; -(eval-when (:compile-toplevel :load-toplevel :execute) - (if (find-package "MP") - nil - (make-package "MP" :use '(common-lisp)))) - -(in-package :mp) -(defmacro with-lock ((sym) &rest body) - (declare (ignore sym)) - #+threading(warn "Make the mp:with-lock macro actually lock a symbol") - `(progn ,@body)) -(export 'with-lock) -(in-package :core) - -(defmacro with-monitor-message-scope ((fmt &rest args) &body body) - #-debug-monitor - (declare (ignore fmt args body)) - #+debug-monitor - (let ((msg (gensym))) - `(let ((,msg (format nil ,fmt ,@args))) - (unwind-protect - (progn - (core:monitor-write (core:fmt nil "((( ;;; {}%N" ,msg)) - ,@body) - (core:monitor-write (core:fmt nil "))) ;;; {}%N" ,msg))))) - #-debug-monitor - nil) - -(defmacro monitor-message (fmt &rest args) - #-debug-monitor - (declare (ignore fmt args)) - #+debug-monitor - `(sys:monitor-write (core:fmt nil "{}%N" (format nil ,fmt ,@args))) - #-debug-monitor - nil) - -(export '(with-monitor-message-scope monitor-message)) - -(defmacro ext:defun/typed (name ( &rest llargs ) arrow return-types &body body) - ;; args are of the form (var type) - (unless (and (symbolp arrow) (string= (symbol-name arrow) "->")) - (error "For defun/typed ~s - make sure there is an -> between the arguments and return-types" name)) - (let* ((args (loop for arg in llargs - until (member arg '(&optional &rest &key)) - collect arg)) - (vars (mapcar #'car args)) - (types (mapcar #'cadr args)) - (rtypes (if (listp return-types) - `(values ,@return-types) - return-types))) - `(progn - (declaim (ftype (function ,types ,rtypes) ,name)) - (defun ,name ,vars - ,@body)))) diff --git a/src/lisp/kernel/lsp/cltl2.lisp b/src/lisp/kernel/lsp/cltl2.lisp index b391870442..58d23e71a3 100644 --- a/src/lisp/kernel/lsp/cltl2.lisp +++ b/src/lisp/kernel/lsp/cltl2.lisp @@ -70,8 +70,8 @@ Clasp reports IGNORE declarations on local functions analogously to variables." (defun declaration-information (decl-name &optional env) "Retrieve information about a declaration in an environment. See CLTL2 8.5 for more information. Only the OPTIMIZE and DECLARATION declarations are supported." (ecase decl-name - ((optimize) (env:optimize (env:optimize-info env))) - ((declaration) (env:declarations env)))) + ((optimize) (env:optimize (env:optimize-info clasp-cleavir:*clasp-system* env))) + ((declaration) (env:declarations clasp-cleavir:*clasp-system* env)))) (defun augment-environment-with-blocks (env blocknames) (loop for blockname in blocknames @@ -239,14 +239,14 @@ Clasp reports IGNORE declarations on local functions analogously to variables." (setf env (env:add-special-variable env name))))) ((optimize) (setf env (cleavir-cst-to-ast::augment-environment-with-optimize - data env)))))) + data env clasp-cleavir:*clasp-system*)))))) (defun augment-environment-with-variables-and-decls (env variables declarations) (multiple-value-bind (var-dspecs other-dspecs) (itemize-declaration-specifiers variables (canonicalize-declarations - (env:declarations env) + (env:declarations clasp-cleavir:*clasp-system* env) declarations)) (loop for var in variables for idspecs in var-dspecs do (setf env diff --git a/src/lisp/kernel/lsp/cmuutil.lisp b/src/lisp/kernel/lsp/cmuutil.lisp index 0e020ae3b3..4c969cf6a8 100644 --- a/src/lisp/kernel/lsp/cmuutil.lisp +++ b/src/lisp/kernel/lsp/cmuutil.lisp @@ -9,10 +9,6 @@ (in-package "SI") (eval-when (:compile-toplevel :execute :load-toplevel) - - #+clasp-min - (defmacro handler-bind (bindings &body body) - `(progn ,@body)) ;;;; The Collect macro: @@ -160,12 +156,28 @@ Example: symbols) ,@body)) -(import 'with-unique-names :ext) -(export 'ext::with-unique-names :ext) - (defmacro with-clean-symbols (symbols &body body) "Rewrites the given forms replacing the given symbols with uninterned ones, which is useful for creating hygienic macros." `(progn ,@(sublis (mapcar #'(lambda (s) (cons s (make-symbol (symbol-name s)))) symbols) body))) + +(in-package #:ext) + +(defmacro ext:defun/typed (name ( &rest llargs ) arrow return-types &body body) + ;; args are of the form (var type) + (unless (and (symbolp arrow) (string= (symbol-name arrow) "->")) + (error "For defun/typed ~s - make sure there is an -> between the arguments and return-types" name)) + (let* ((args (loop for arg in llargs + until (member arg '(&optional &rest &key)) + collect arg)) + (vars (mapcar #'car args)) + (types (mapcar #'cadr args)) + (rtypes (if (listp return-types) + `(values ,@return-types) + return-types))) + `(progn + (declaim (ftype (function ,types ,rtypes) ,name)) + (defun ,name ,vars + ,@body)))) diff --git a/src/lisp/kernel/lsp/debug.lisp b/src/lisp/kernel/lsp/debug.lisp index e64297e677..1c8b0184f1 100644 --- a/src/lisp/kernel/lsp/debug.lisp +++ b/src/lisp/kernel/lsp/debug.lisp @@ -1,52 +1,50 @@ -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package "CLASP-DEBUG") - (make-package "CLASP-DEBUG" :use '("CL"))) - (in-package #:clasp-debug) - ;; we intern several symbols below - (ext:add-implementation-package "CLASP-DEBUG" "CLOS") - (flet ((%export (names) - (export (mapcar (lambda (s) (intern (symbol-name s))) names)))) - (%export '(#:code-source-line-pathname - #:code-source-line-line-number - #:code-source-line-column)) - ;; TODO: Rename core:debugger-frame to frame, reexport that - (%export '(#:frame)) - (%export '(#:frame-up #:frame-down)) - (%export '(#:frame-function #:frame-arguments - #:frame-locals #:frame-source-position - #:frame-language)) - (%export '(#:frame-function-name - #:frame-function-lambda-list - #:frame-function-source-position - #:frame-function-form - #:frame-function-documentation)) - (%export '(#:disassemble-frame)) - ;; frame selection - (%export '(#:with-truncated-stack #:truncation-frame-p - #:with-capped-stack #:cap-frame-p)) - (%export '(#:*frame-filters*)) - ;; mid level - (%export '(#:call-with-stack #:with-stack)) - (%export '(#:up #:down #:visible)) - (%export '(#:map-stack #:list-stack)) - ;; defined later in conditions.lisp - (%export '(#:safe-prin1 #:prin1-frame-call - #:princ-code-source-line - #:print-stack)) - ;; high level - (%export '(#:map-indexed-stack #:goto)) - (%export '(#:print-backtrace ; in conditions.lisp - #:map-backtrace - #:map-indexed-backtrace)) - (%export '(#:hide-package #:unhide-package - #:hide #:unhide #:unhide-all)) - ;; misc - (%export '(#:function-name-package)) - ;; stepper - (%export '(#:step-condition #:step-form #:step-call - #:step-into #:step-over)) - (import '(core:set-breakstep core:unset-breakstep core:breakstepping-p)) - (export '(core:set-breakstep core:unset-breakstep core:breakstepping-p)))) +(in-package "CORE") + +(defpackage #:clasp-debug + (:use #:cl) + (:export #:code-source-line-pathname + #:code-source-line-line-number + #:code-source-line-column) + ;; TODO: Rename core:debugger-frame to frame, reexport that + (:export #:frame) + (:export #:frame-up #:frame-down) + (:export #:frame-function #:frame-arguments + #:frame-locals #:frame-source-position + #:frame-language) + (:export #:frame-function-name + #:frame-function-lambda-list + #:frame-function-source-position + #:frame-function-form + #:frame-function-documentation) + (:export #:disassemble-frame) + ;; frame selection + (:export #:with-truncated-stack #:truncation-frame-p + #:with-capped-stack #:cap-frame-p) + (:export #:*frame-filters*) + ;; mid level + (:export #:call-with-stack #:with-stack) + (:export #:up #:down #:visible) + (:export #:map-stack #:list-stack) + ;; defined later in conditions.lisp + (:export #:safe-prin1 #:prin1-frame-call + #:princ-code-source-line + #:print-stack) + ;; high level + (:export #:map-indexed-stack #:goto) + (:export #:print-backtrace ; in conditions.lisp + #:map-backtrace + #:map-indexed-backtrace) + (:export #:hide-package #:unhide-package + #:hide #:unhide #:unhide-all) + ;; misc + (:export #:function-name-package) + ;; stepper + (:export #:step-condition #:step-form #:step-call + #:step-into #:step-over) + (:import-from #:core #:set-breakstep #:unset-breakstep #:breakstepping-p) + (:export #:set-breakstep #:unset-breakstep #:breakstepping-p)) + +(in-package #:clasp-debug) ;;; Low level interface @@ -453,17 +451,13 @@ Note that as such, the frame returned may not be visible." (defparameter *hidden-fnames* '(apply funcall invoke-debugger - core:universal-error-handler - core:apply0 core:apply1 core:apply2 core:apply3 core:apply4 + core::universal-error-handler + core::apply0 core::apply1 core::apply2 core::apply3 core::apply4 core::catch-lambda core::throw-lambda core::unwind-protected-lambda core::unwind-cleanup-lambda core::mvc-argument-lambda core::progv-lambda - clos::dispatch-miss-va - clos::perform-outcome - clos::dispatch-miss clos::invalidated-dispatch-function - clos::invalidated-discriminating-function - clos::combine-method-functions.lambda - clos::interpreted-discriminating-function)) + clos::dispatch-miss clos::dispatch-miss-va + clos::perform-outcome clos::invalidated-discriminator)) (defun hide (function-name) "Mark frames whose functions have the given name as invisible." diff --git a/src/lisp/kernel/lsp/defmacro.lisp b/src/lisp/kernel/lsp/defmacro.lisp index 66899bb6b9..4ec5732b9d 100644 --- a/src/lisp/kernel/lsp/defmacro.lisp +++ b/src/lisp/kernel/lsp/defmacro.lisp @@ -14,27 +14,7 @@ (in-package "SYSTEM") -#+clasp-min -(si::fset 'push - #'(lambda (args env) - (declare (core:lambda-name push)) - (let* ((what (second args)) - (where (caddr args))) - `(setq ,where (cons ,what ,where)))) - t) - -#+clasp-min -(si::fset 'pop - #'(lambda (args env) - (declare (core:lambda-name pop)) - (let ((where (cadr args))) - `(let* ((l ,where) - (v (car l))) - (setq ,where (cdr l)) - v))) - t) - -(defun sys::search-keyword (list key) +(defun search-keyword (list key) (cond ((atom list) 'missing-keyword) ((atom (cdr list)) 'missing-keyword) ((eq (car list) key) (cadr list)) @@ -103,10 +83,10 @@ :macro-name macro-name :lambda-list vl :arguments current-form :problem :too-few)) -(defun sys::destructure (vldestructure context - &optional display-name cm-name - &aux dl arg-check (basis-form (gensym)) - (destructure-symbols (list basis-form))) +(defun destructure (vldestructure context + &optional display-name cm-name + &aux dl arg-check (basis-form (gensym)) + (destructure-symbols (list basis-form))) (labels ((tempsym () (let ((x (gensym))) (push x destructure-symbols) @@ -265,7 +245,6 @@ (process-declarations body t) (when decls (push `(declare ,@decls) body)) (values body doc))) -#+clasp(export 'remove-documentation) (defun find-declarations (body &optional (docp t)) (multiple-value-bind (decls body doc) @@ -315,24 +294,6 @@ ,@body)) doc)))))) -#+clasp-min -(si::fset 'defmacro - #'(lambda (def env) - (declare (ignore env) (core:lambda-name defmacro)) - (let* ((name (second def)) - (vldm (third def)) - (body (cdddr def)) - (function)) - (multiple-value-bind (function doc) - (sys::expand-defmacro name vldm body) - (declare (ignore doc)) - (setq function `(function ,function)) - `(si::fset ',name ,function - t ; macro - ',vldm ; lambda-list - )))) - t) - ;;; Like EXPAND-DEFMACRO, but is slightly nicer about invalid arguments. (defun expand-define-compiler-macro (name vldm body &optional (block-name (function-block-name name))) @@ -383,7 +344,3 @@ (defun parse-define-setf-expander (name lambda-list body &optional env) (declare (ignore env)) (sys::expand-defmacro name lambda-list body 'setf-expander)) - -;; FIXME: move -(export '(parse-macro parse-compiler-macro parse-deftype - parse-define-setf-expander)) diff --git a/src/lisp/kernel/lsp/defstruct.lisp b/src/lisp/kernel/lsp/defstruct.lisp index f4cd5de8b8..4f9fe282e5 100644 --- a/src/lisp/kernel/lsp/defstruct.lisp +++ b/src/lisp/kernel/lsp/defstruct.lisp @@ -14,9 +14,6 @@ (in-package "SYSTEM") -#+(or)(eval-when (:load-toplevel :compile-toplevel :execute) - (setq *echo-repl-read* t) -) (defun structure-type-error (value slot-type struct-name slot-name) (error 'simple-type-error :format-control "Slot ~A in structure ~A only admits values of type ~A." @@ -35,34 +32,42 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Environment access and structure descriptions -;;; A structure description is a list -;;; (TYPE CONSTRUCTOR SLOT*) -;;; TYPE is STRUCTURE-OBJECT, VECTOR, or LIST. -;;; CONSTRUCTOR is a function name or NIL for no constructor. -;;; Slot descriptions are as described down this file. +;;; Environment access ;;; -(defun make-structure-description (type constructor slotds) - (list* type constructor slotds)) -(defun structure-description-type (description) (first description)) -(defun structure-description-constructor (description) (second description)) -(defun structure-description-slot-descriptions (description) - (cddr description)) - ;;; FIXME: these should take environments -(defun structure-description (name) - (get-sysprop name 'structure-description)) -(defun (setf structure-description) (description name) - (setf (get-sysprop name 'structure-description) description)) (defun structure-type (name) - (structure-description-type (structure-description name))) + (get-sysprop name 'structure-type)) +(defun (setf structure-type) (type name) + (setf (get-sysprop name 'structure-type) type)) (defun structure-slot-descriptions (name) - (structure-description-slot-descriptions (structure-description name))) + (get-sysprop name 'structure-slot-descriptions)) +(defun (setf structure-slot-descriptions) (descriptions name) + (setf (get-sysprop name 'structure-slot-descriptions) descriptions)) (defun structure-constructor (name) - (structure-description-constructor (structure-description name))) -(defun names-structure-p (name) - (not (not (structure-description name)))) + (get-sysprop name 'structure-constructor)) +(defun (setf structure-constructor) (constructor name) + (setf (get-sysprop name 'structure-constructor) constructor)) + +(eval-when (:compile-toplevel) + (defparameter *structure-types* (make-hash-table)) + (defparameter *structure-slot-descriptions* (make-hash-table)) + (defparameter *structure-constructors* (make-hash-table))) +(eval-when (:compile-toplevel) + (defun structure-type (name) (gethash name *structure-types*)) + (defun (setf structure-type) (type name) + (setf (gethash name *structure-types*) type)) + (defun structure-slot-descriptions (name) + (gethash name *structure-slot-descriptions*)) + (defun (setf structure-slot-descriptions) (descs name) + (setf (gethash name *structure-slot-descriptions*) descs)) + (defun structure-constructor (name) (gethash name *structure-constructors*)) + (defun (setf structure-constructor) (cons name) + (setf (gethash name *structure-constructors*) cons))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun names-structure-p (name) + (structure-type name))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -70,8 +75,7 @@ ;;; Used by #S reader (defun make-structure (name initargs) - (unless (names-structure-p name) - (error "~s is not a structure class." name)) + (unless (names-structure-p name) (error "~s is not a structure class." name)) (let ((constructor (structure-constructor name))) (if constructor (apply constructor initargs) @@ -115,6 +119,7 @@ ;;; Part of the idea here is we make things independent of conc-name ;;; (and thereby, interning) before we do much susbstantial processing. +(eval-when (:compile-toplevel :load-toplevel :execute) (defun error-defstruct-slot-syntax (slot-description) (simple-program-error "~a is not a valid DEFSTRUCT slot specification." slot-description)) @@ -123,7 +128,7 @@ ;; NOTE: No conc-name is not the same as a conc-name of "", ;; because in the first case the symbol could be in a different package. (if conc-name - (intern (base-string-concatenate conc-name slot-name)) + (intern (concatenate 'base-string (string conc-name) (string slot-name))) slot-name)) (defun parse-slot-description (slot-description conc-name) @@ -173,6 +178,7 @@ (defun slot-description-parser (conc-name) (lambda (slot-description) (parse-slot-description slot-description conc-name))) +) ; eval-when ;;; UNPARSE-SLOT-DESCRIPTION does the opposite, turning one of the above into ;;; something that would work in DEFSTRUCT. @@ -188,6 +194,7 @@ slot-name `(,slot-name ,initform :read-only ,read-only :type ,type))))) +(eval-when (:compile-toplevel :load-toplevel :execute) ;;; Apply an :INCLUDE slot override. (defun override-slotd (slot-name over-plist old-plist) (destructuring-bind (&key (initform nil initformp) @@ -295,7 +302,7 @@ (defun defstruct-class-reader-body (structure-name element-type location) (declare (ignore element-type)) `(if (typep object ',structure-name) - (si:instance-ref object ,location) + (clos:standard-instance-access object ,location) (error 'type-error :datum object :expected-type ',structure-name))) @@ -303,7 +310,7 @@ (defun defstruct-class-writer-body (structure-name element-type location) (declare (ignore element-type)) `(if (typep object ',structure-name) - (setf (si:instance-ref object ,location) new) + (setf (clos:standard-instance-access object ,location) new) (error 'type-error :datum object :expected-type ',structure-name))) @@ -497,7 +504,7 @@ (or (car class) (car (rplaca class (find-class ',structure-name)))))) (lambda (obj var loc) - `(setf (si:instance-ref ,obj ,loc) ,var)))) + `(setf (clos:standard-instance-access ,obj ,loc) ,var)))) ((:print-function :print-object) (let ((obj (gensym "OBJ")) (stream (gensym "STREAM"))) `(defmethod print-object ((,obj ,structure-name) ,stream) @@ -577,6 +584,7 @@ name element-type included-size slot-descriptions)) (list (defstruct-list-option-expander name included-size slot-descriptions)))) +) ; eval-when (defmacro %%defstruct (name type (include included-size) (&rest slot-descriptions) @@ -597,11 +605,8 @@ type name))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (structure-description ',name) - ',(make-structure-description - type-base - (second (assoc :kw-constructor options)) - slot-descriptions))) + (setf (structure-type ',name) ',type-base + (structure-slot-descriptions ',name) ',slot-descriptions)) ,@(when (eq type-base 'structure-object) `((defclass ,name ,(if include (list include) nil) (,@(mapcar #'defstruct-slotd->defclass-slotd slot-descriptions)) @@ -613,9 +618,7 @@ (case type-base (structure-object (values #'defstruct-class-reader-body #'defstruct-class-writer-body - #-clasp-min #'defstruct-class-cas-body - #+clasp-min nil name)) (vector (values #'defstruct-vector-reader-body #'defstruct-vector-writer-body @@ -639,6 +642,9 @@ ,@(mapcar (defstruct-option-expander name type-base element-type included-size slot-descriptions) options) + ,@(let ((kwcon (second (assoc :kw-constructor options)))) + (when kwcon + `((setf (structure-constructor ',name) ',kwcon)))) ',name))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -677,6 +683,7 @@ ;;; The DEFSTRUCT macro. ;;; +(eval-when (:compile-toplevel :load-toplevel :execute) (defun check-defstruct-option-too-many-args (name extra) (unless (null extra) (simple-program-error "Too many options to ~a" name))) @@ -692,13 +699,13 @@ (simple-program-error "~a is not a valid option to defstruct" name)) (defun default-constructor-name (name) - (intern (base-string-concatenate "MAKE-" name))) + (intern (concatenate 'base-string "MAKE-" (string name)))) (defun default-copier-name (name) - (intern (base-string-concatenate "COPY-" name))) + (intern (concatenate 'base-string "COPY-" (string name)))) (defun default-predicate-name (name) - (intern (base-string-concatenate name "-P"))) + (intern (concatenate 'base-string (string name) "-P"))) ;;; Given the second of a defstruct, returns values: ;;; name, type, include or NIL, overriding slot specs, @@ -865,7 +872,7 @@ (setq predicate (default-predicate-name name)))) ;; default conc-name (unless seen-conc-name - (setq conc-name (base-string-concatenate name "-"))) + (setq conc-name (concatenate 'base-string (string name) "-"))) ;; check initial-offset and type consistency. (when initial-offset (unless type @@ -895,6 +902,7 @@ copier predicate named print-function print-object initial-offset)))) +) ; eval-when (defmacro defstruct (name&opts &rest slots &environment env) "Syntax: (defstruct @@ -963,3 +971,15 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." ,@(when copier `((:copier ,copier))) ,@(when documentation `((:documentation ,documentation))))))) + +(defun copy-structure (structure) + ;; This could be done slightly faster by making copy-structure generic, + ;; and having defstruct define a copy-structure method that works without a loop + ;; or checking the size. + (let* ((class (class-of structure)) + (copy (allocate-instance class)) + (size (clos::class-size class))) + (loop for i below size + do (setf (clos:standard-instance-access copy i) + (clos:standard-instance-access structure i))) + copy)) diff --git a/src/lisp/kernel/lsp/describe.lisp b/src/lisp/kernel/lsp/describe.lisp index 8f107b3292..680cf47ab2 100644 --- a/src/lisp/kernel/lsp/describe.lisp +++ b/src/lisp/kernel/lsp/describe.lisp @@ -417,9 +417,45 @@ q (or Q): quits the inspection.~%~ (format t "~&Documentation:~% ~a" docstring))) (when (core:instancep function) ; funcallable instance (terpri) (terpri) - (clos::describe-slots function *standard-output*))) + (describe-slots function *standard-output*))) + +(defgeneric describe-object (object stream)) + +(defun describe-slots (object stream) + (let* ((class (class-of object)) + (slotds (clos:class-slots class)) + (max-slot-name-length 24) + (plist nil)) + ;; Go through the slots getting a max slot name length, + ;; and also sorting the slots by :allocation. + ;; (This code is based off of SBCL's SB-IMPL::DESCRIBE-INSTANCE.) + (dolist (slotd slotds) + (setf max-slot-name-length + (max max-slot-name-length + (length (symbol-name + (clos:slot-definition-name slotd))))) + (push slotd (getf plist (clos:slot-definition-allocation slotd)))) + ;; Now dump the info. + (loop for (allocation slotds) on plist by #'cddr + do (format stream "~&Slots with ~s allocation:" allocation) + (dolist (slotd (nreverse slotds)) ; keep original order + (let ((slot-name (clos:slot-definition-name slotd))) + (format stream "~& ~va: ~a" + max-slot-name-length slot-name + (if (slot-boundp object slot-name) + (slot-value object slot-name) + "Unbound")))))) + object) + +(defmethod describe-object ((object standard-object) stream) + (format stream "~&~S - ~S" object (class-name (class-of object))) + (describe-slots object stream)) + +(defmethod describe-object ((obj t) (stream t)) + (format stream "~%~S is an instance of class ~S" + obj (class-name (class-of obj))) + obj) -#+CLOS (defun inspect-instance (instance) (if *inspect-mode* (clos::inspect-obj instance) @@ -449,7 +485,6 @@ q (or Q): quits the inspection.~%~ ;; Note that this needs to get generic functions, ;; so keep it before the instancep test. ((functionp object) (inspect-function object)) - #+clos ((sys:instancep object) (inspect-instance object)) ((sys:cxx-object-p object) (describe-object object *standard-output*)) (t (format t "~S - ~S" object (type-of object))))))) @@ -514,7 +549,7 @@ Prints information about OBJECT to STREAM." (describe-symbol (category-string) (doc-separation category-string) (doc-value (or (documentation symbol 'FUNCTION) "") "Documentation:" t) - #+(or cclasp eclasp) (doc-value (or (core:function-lambda-list symbol) "") "Arguments:") + (doc-value (or (ext:function-lambda-list symbol) "") "Arguments:") (mapcar #'(lambda(location) (doc-value (ext:source-location-pathname location) "Source:")) (EXT:SOURCE-LOCATION symbol :function))) diff --git a/src/lisp/kernel/lsp/do.lisp b/src/lisp/kernel/lsp/do.lisp new file mode 100644 index 0000000000..17f54868b8 --- /dev/null +++ b/src/lisp/kernel/lsp/do.lisp @@ -0,0 +1,94 @@ +(in-package #:core) + +;;; based on the stupidly named export.lisp in clasp sources + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun expand-while-until (test body jmp-op) + (let ((label (gensym)) + (exit (gensym))) + `(TAGBODY + (GO ,exit) + ,label + ,@body + ,exit + (,jmp-op ,test (GO ,label)))))) + +(defmacro while (test &body body) (expand-while-until test body 'when)) +(defmacro until (test &body body) (expand-while-until test body 'unless)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun filter-dolist-declarations (declarations) + (let ((a nil)) + (mapc #'(lambda (clause) + (when (not (and (consp clause) + (or (eq (car clause) 'type) + (eq (car clause) 'ignore)))) + (setq a (cons clause a)))) + declarations) + (nreverse a)))) + +(defmacro dolist ((var list-form &optional result-form) &body body) + (multiple-value-bind (declarations body) + (process-declarations body nil) + `(block nil + (let ((%dolist-var ,list-form)) + (while %dolist-var + (let ((,var (first %dolist-var))) + (declare ,@declarations) + (tagbody + ,@body + (setq %dolist-var (cdr %dolist-var))))) + ,(when result-form + `(let ((,var nil)) + (declare (ignorable ,var) + ,@(filter-dolist-declarations declarations)) + ,result-form)))))) + +(defmacro dotimes ((var count-form &optional result-form) &body body) + (multiple-value-bind (declarations body) + (process-declarations body nil) + (when (and (integerp count-form) (>= count-form 0)) + (setq declarations + (cons `(type (integer 0 ,count-form) ,var) declarations))) + `(block nil + (let ((%dotimes-var ,count-form) + (,var 0)) + (declare ,@declarations) + (while (< ,var %dotimes-var) + ,@body + (setq ,var (1+ ,var))) + ,result-form)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun expand-do/do* (op vars test result body) + (multiple-value-bind (let psetq) + (ecase op + ((do) (values 'let 'psetq)) + ((do*) (values 'let* 'setq))) + (multiple-value-bind (declarations body) + (process-declarations body nil) + (multiple-value-bind (inits set) + (loop for var in vars + if (symbolp var) + collect `(,var nil) into inits + else if (and (consp var) (null (cdr var))) + collect `(,(first var) nil) into inits + else if (and (consp var) (consp (cdr var)) (null (cddr var))) + collect `(,(first var) ,(second var)) into inits + else if (and (consp var) (consp (cdr var)) (consp (cddr var)) + (null (cdddr var))) + collect `(,(first var) ,(second var)) into inits + and nconc (list (first var) (third var)) into set + else do (simple-program-error "Invalid ~s var clause: ~s" + op var) + finally (return (values inits set))) + `(block nil + (,let (,@inits) + (declare ,@declarations) + (until ,test ,@body (,psetq ,@set)) + ,@(or result '(nil))))))))) + +(defmacro do ((&rest vars) (test &rest result) &body body) + (expand-do/do* 'do vars test result body)) +(defmacro do* ((&rest vars) (test &rest result) &body body) + (expand-do/do* 'do* vars test result body)) diff --git a/src/lisp/kernel/lsp/encodings.lisp b/src/lisp/kernel/lsp/encodings.lisp index db9d640823..2e5189fb85 100644 --- a/src/lisp/kernel/lsp/encodings.lisp +++ b/src/lisp/kernel/lsp/encodings.lisp @@ -1,5 +1,7 @@ (in-package :ext) +(export '(all-encodings)) + (let* ((basic-encodings #+unicode '(:UTF-8 :UCS-2 :UCS-2BE :UCS-2LE :UCS-4 :UCS-4BE :UCS-4LE @@ -72,6 +74,11 @@ (setf all-encodings (append all-encodings unicode-encodings))) all-encodings)))) +(defun lookup-encoding (encoding) + (or (gethash encoding *encoding-data*) + (error "BUG: Unknown encoding ~a" encoding))) + +;;; Called from C++ when an external format is used. (defun ext:make-encoding (encoding) (ecase encoding ((:US-ASCII @@ -109,190 +116,41 @@ :windows-cp936 :windows-cp949 :windows-cp950) - (ext:generate-encoding-hashtable encoding)) - (:latin-2 (ext:generate-encoding-hashtable :iso-8859-2)) - (:latin-3 (ext:generate-encoding-hashtable :iso-8859-3)) - (:latin-4 (ext:generate-encoding-hashtable :iso-8859-4)) - (:latin-5 (ext:generate-encoding-hashtable :iso-8859-9)) - (:latin-6 (ext:generate-encoding-hashtable :iso-8859-10)) - (:latin-7 (ext:generate-encoding-hashtable :iso-8859-13)) - (:latin-8 (ext:generate-encoding-hashtable :iso-8859-14)) - (:latin-9 (ext:generate-encoding-hashtable :iso-8859-15)) + (lookup-encoding encoding)) + (:latin-2 (lookup-encoding :iso-8859-2)) + (:latin-3 (lookup-encoding :iso-8859-3)) + (:latin-4 (lookup-encoding :iso-8859-4)) + (:latin-5 (lookup-encoding :iso-8859-9)) + (:latin-6 (lookup-encoding :iso-8859-10)) + (:latin-7 (lookup-encoding :iso-8859-13)) + (:latin-8 (lookup-encoding :iso-8859-14)) + (:latin-9 (lookup-encoding :iso-8859-15)) - (:cyrillic (ext:generate-encoding-hashtable :iso-8859-5)) - ((:arabic :asmo-708 :ecma-114) (ext:generate-encoding-hashtable :iso-8859-6)) - ((:greek :greek8 :ecma-118) (ext:generate-encoding-hashtable :iso-8859-7)) - (:hebrew (ext:generate-encoding-hashtable :iso-8859-8)) + (:cyrillic (lookup-encoding :iso-8859-5)) + ((:arabic :asmo-708 :ecma-114) (lookup-encoding :iso-8859-6)) + ((:greek :greek8 :ecma-118) (lookup-encoding :iso-8859-7)) + (:hebrew (lookup-encoding :iso-8859-8)) - (:ibm437 (ext:generate-encoding-hashtable :dos-cp437)) - ((:ibm850 :cp850) (ext:generate-encoding-hashtable :dos-cp850)) - (:ibm852 (ext:generate-encoding-hashtable :dos-cp852)) - (:ibm855 (ext:generate-encoding-hashtable :dos-cp855)) - (:ibm857 (ext:generate-encoding-hashtable :dos-cp857)) - (:ibm860 (ext:generate-encoding-hashtable :dos-cp860)) - (:ibm861 (ext:generate-encoding-hashtable :dos-cp861)) - ((:ibm862 :cp862) (ext:generate-encoding-hashtable :dos-cp862)) - (:ibm863 (ext:generate-encoding-hashtable :dos-cp863)) - (:ibm864 (ext:generate-encoding-hashtable :dos-cp864)) - (:ibm865 (ext:generate-encoding-hashtable :dos-cp865)) - ((:ibm866 :cp866) (ext:generate-encoding-hashtable :dos-cp866)) - (:ibm869 (ext:generate-encoding-hashtable :dos-cp869)) + (:ibm437 (lookup-encoding :dos-cp437)) + ((:ibm850 :cp850) (lookup-encoding :dos-cp850)) + (:ibm852 (lookup-encoding :dos-cp852)) + (:ibm855 (lookup-encoding :dos-cp855)) + (:ibm857 (lookup-encoding :dos-cp857)) + (:ibm860 (lookup-encoding :dos-cp860)) + (:ibm861 (lookup-encoding :dos-cp861)) + ((:ibm862 :cp862) (lookup-encoding :dos-cp862)) + (:ibm863 (lookup-encoding :dos-cp863)) + (:ibm864 (lookup-encoding :dos-cp864)) + (:ibm865 (lookup-encoding :dos-cp865)) + ((:ibm866 :cp866) (lookup-encoding :dos-cp866)) + (:ibm869 (lookup-encoding :dos-cp869)) - ((:windows-1250 :ms-ee)(ext:generate-encoding-hashtable :windows-cp1250)) - ((:windows-1251 :ms-cyrl)(ext:generate-encoding-hashtable :windows-cp1251)) - ((:windows-1252 :ms-ansi)(ext:generate-encoding-hashtable :windows-cp1252)) - ((:windows-1253 :ms-greek)(ext:generate-encoding-hashtable :windows-cp1253)) - ((:windows-1254 :ms-turk)(ext:generate-encoding-hashtable :windows-cp1254) ) - ((:windows-1255 :ms-hebr)(ext:generate-encoding-hashtable :windows-cp1255)) - ((:windows-1256 :ms-arab)(ext:generate-encoding-hashtable :windows-cp1256)) - ((:windows-1257 :winbaltrim)(ext:generate-encoding-hashtable :windows-cp1257) ) - (:windows-1258 (ext:generate-encoding-hashtable :windows-cp1258)))) - -;;; load this in ecl to generate generated-encodings.lisp -;;; e.g. (create-encodings-from-ecl "~/lisp/compiler/clasp-karsten/src/lisp/kernel/lsp/generated-encodings.lisp") -#+ecl -(defun create-encodings-from-ecl (path) - (let ((encodings - (list :iso-8859-2 :iso-8859-3 :iso-8859-4 :iso-8859-5 - :iso-8859-6 :iso-8859-7 :iso-8859-8 :iso-8859-9 - :iso-8859-10 :iso-8859-13 :iso-8859-14 :iso-8859-15 - - :koi8-r - - :dos-cp437 - :dos-cp850 - :dos-cp852 - :dos-cp855 - :dos-cp857 - :dos-cp860 - :dos-cp861 - :dos-cp862 - :dos-cp863 - :dos-cp864 - :dos-cp865 - :dos-cp866 - :dos-cp869 - - ;;; :windows-cp932 - ;;; :windows-cp936 - ;;; :windows-cp949 - ;;; :windows-cp950 - - :windows-cp1250 - :windows-cp1251 - :windows-cp1252 - :windows-cp1253 - :windows-cp1254 - :windows-cp1255 - :windows-cp1256 - :windows-cp1257 - :windows-cp1258 - )) - (result-alist nil)) - (dolist (name encodings) - (let ((table (ext:make-encoding name)) - (mappings nil)) - (maphash #'(lambda(key value) - (when (and (numberp key)(characterp value)) - (push (list key value) mappings))) - table) - ;;; note the result table - (push (list name mappings) result-alist))) - ;;; note generate the mapping function - (let ((file path)) - (when (probe-file file) - (delete-file file)) - (with-open-file (stream file - :direction :output - :if-does-not-exist :create) - (format stream "(in-package :ext)~2%") - (format stream "(defvar *encoding-data* ~% (list~%") - (dolist (specs (reverse result-alist)) - (let ((name (first specs)) - (mappings (second specs))) - (format stream " (list ~s ~% (list ~%" name) - (dolist (mapping (reverse mappings)) - (format stream " (cons ~s (code-char ~s))~%" (first mapping)(char-code (second mapping)))) - (format stream " ))~%"))) - (format stream " ))~2%") - (format stream - "(defvar *encoding-cache* (make-hash-table)) - -(defun generate-encoding-hashtable (encoding) - (let ((hash (gethash encoding *encoding-cache*))) - (if hash - hash - (let ((spec (assoc encoding *encoding-data*))) - (when spec - (let ((table (make-hash-table))) - (dolist (pair (second spec)) - (let ((key (first pair)) - (value (rest pair))) - (setf (gethash key table) value) - (setf (gethash value table) key))) - (setf (gethash encoding *encoding-cache*) table) - table))))))"))))) - -;;; load this in ecl to generate generated-encodings.lisp -;;; (create-encodings-file-from-ecl "/Users/karstenpoeck/lisp/compiler/clasp-karsten/tools-for-build/encodingdata.txt") -#+ecl -(defun create-encodings-file-from-ecl (path) - (let ((encodings - (list :iso-8859-2 :iso-8859-3 :iso-8859-4 :iso-8859-5 - :iso-8859-6 :iso-8859-7 :iso-8859-8 :iso-8859-9 - :iso-8859-10 :iso-8859-13 :iso-8859-14 :iso-8859-15 - - :koi8-r - - :dos-cp437 - :dos-cp850 - :dos-cp852 - :dos-cp855 - :dos-cp857 - :dos-cp860 - :dos-cp861 - :dos-cp862 - :dos-cp863 - :dos-cp864 - :dos-cp865 - :dos-cp866 - :dos-cp869 - - :windows-cp932 - :windows-cp936 - :windows-cp949 - :windows-cp950 - - :windows-cp1250 - :windows-cp1251 - :windows-cp1252 - :windows-cp1253 - :windows-cp1254 - :windows-cp1255 - :windows-cp1256 - :windows-cp1257 - :windows-cp1258 - )) - (result-alist nil)) - (dolist (name encodings) - (let ((table (ext:make-encoding name)) - (mappings nil)) - (maphash #'(lambda(key value) - (when (and (numberp key)(characterp value)) - (push (list key value) mappings))) - table) - ;;; note the result table - (push (list name mappings) result-alist))) - ;;; note generate the mapping function - (let ((file path)) - (when (probe-file file) - (delete-file file)) - (with-open-file (stream file - :direction :output - :if-does-not-exist :create) - (dolist (specs (reverse result-alist)) - (let ((name (first specs)) - (mappings (second specs))) - (dolist (mapping (reverse mappings)) - (format stream "~s;~s;~s;~%" name (first mapping)(char-code (second mapping)))))))))) - + ((:windows-1250 :ms-ee)(lookup-encoding :windows-cp1250)) + ((:windows-1251 :ms-cyrl)(lookup-encoding :windows-cp1251)) + ((:windows-1252 :ms-ansi)(lookup-encoding :windows-cp1252)) + ((:windows-1253 :ms-greek)(lookup-encoding :windows-cp1253)) + ((:windows-1254 :ms-turk)(lookup-encoding :windows-cp1254) ) + ((:windows-1255 :ms-hebr)(lookup-encoding :windows-cp1255)) + ((:windows-1256 :ms-arab)(lookup-encoding :windows-cp1256)) + ((:windows-1257 :winbaltrim)(lookup-encoding :windows-cp1257) ) + (:windows-1258 (lookup-encoding :windows-cp1258)))) diff --git a/src/lisp/kernel/lsp/evalmacros.lisp b/src/lisp/kernel/lsp/evalmacros.lisp index b4a04ddcbc..ba1fe87f40 100644 --- a/src/lisp/kernel/lsp/evalmacros.lisp +++ b/src/lisp/kernel/lsp/evalmacros.lisp @@ -13,27 +13,41 @@ (in-package :sys) -(defun check-package-lock (name operation) ;; testing - (let ((package (symbol-package name))) - (when (and package (ext:package-locked-p package) - (not (member - *package* - (ext:package-implemented-by-list package)))) - (core:package-lock-violation package - "trying to ~s ~s" - operation name)))) +(defun (setf ext:symbol-macro) (expander name &optional env) + (when env + (error "Non-NIL environment passed to (setf ext:symbol-macro)")) + (setf (get-sysprop name 'ext:symbol-macro) expander)) + +(defvar *defun-inline-hook* nil) +(defmacro when (condition &body forms) + "Syntax: (when test {form}*) +If TEST evaluates to true, then evaluates FORMs and returns all values of the +last FORM. If not (i.e. the TEST evaluates to NIL), simply returns NIL." + `(if ,condition (progn ,@forms) nil)) (defmacro unless (pred &rest body) "Syntax: (unless test {form}*) If TEST evaluates to NIL, then evaluates FORMs and returns all values of the last FORM. If not, simply returns NIL." `(IF (NOT ,pred) (PROGN ,@body))) +(defmacro and (&rest forms) + (cond ((null forms) 't) + ((null (cdr forms)) (car forms)) + (t `(if ,(car forms) (and ,@(cdr forms)) nil)))) + +(defmacro or (&rest forms) + (cond ((null forms) 'nil) + ((null (cdr forms)) (car forms)) + (t (let ((tmp (gensym))) + `(let ((,tmp ,(car forms))) + (if ,tmp + ,tmp + (or ,@(cdr forms)))))))) + (defmacro defmacro (name lambda-list &body body &environment env) `(eval-when (:compile-toplevel :load-toplevel :execute) - (funcall #'(setf macro-function) - #',(ext:parse-macro name lambda-list body env) - ',name) + (setf (macro-function ',name) #',(ext:parse-macro name lambda-list body env)) ',name)) (defmacro destructuring-bind (vl list &body body) @@ -59,15 +73,11 @@ as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." ,@(when form-sp `((UNLESS (BOUNDP ',var) (SETQ ,var ,form)))) - ,@(when (and core:*current-source-pos-info* - ;; KLUDGE so that we can bootstrap this. - ;; FIXME: Special case source pos infos in the literal - ;; compiler, maybe? - (fboundp 'make-load-form)) - `((setf (gethash ',var core:*variable-source-infos*) - ',core:*current-source-pos-info*))) + ,@(when (ext:current-source-location) + `((setf (core:variable-source-info ',var) + ',(ext:current-source-location)))) ,@(when doc-string - `((ext:annotate ',var 'documentation 'variable ',doc-string))) + `((ext:annotate ',var 'documentation 'variable ,doc-string))) ',var)) (defmacro defparameter (var form &optional doc-string) @@ -79,15 +89,15 @@ as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." (eval-when (:compile-toplevel :load-toplevel :execute) (SYS:*MAKE-SPECIAL ',var)) (SETQ ,var ,form) - ,@(when (and core:*current-source-pos-info* - (fboundp 'make-load-form)) - `((setf (gethash ',var core:*variable-source-infos*) - ',core:*current-source-pos-info*))) + ,@(when (ext:current-source-location) + `((setf (core:variable-source-info ',var) + ',(ext:current-source-location)))) ,@(when doc-string - `((ext:annotate ',var 'documentation 'variable ',doc-string))) - ',var)) + `((ext:annotate ',var 'documentation 'variable ,doc-string))) + ',var)) ;; export as extension? + (defmacro defconstant-eqx (var form test &optional doc-string) "Like DEFCONSTANT, but doesn't fire if the form is equal under TEST to an existing value." @@ -95,18 +105,17 @@ existing value." `(PROGN (eval-when (:compile-toplevel :load-toplevel :execute) (let ((,value ,form)) - (cond ((core:symbol-constantp ',var) + (cond ((symbol-constantp ',var) (unless (,test ,value (symbol-value ',var)) ;; This will just trigger the error in SET. (set ',var ,value))) ((ext:specialp ',var) (error "Cannot redefine special variable ~a as constant" ',var)) (t (set ',var ,value) - (funcall #'(setf core:symbol-constantp) t ',var))))) - ,@(when (and core:*current-source-pos-info* - (fboundp 'make-load-form)) - `((setf (gethash ',var core:*variable-source-infos*) - ',core:*current-source-pos-info*))) + (setf (symbol-constantp ',var) t))))) + ,@(when (ext:current-source-location) + `((setf (core:variable-source-info ',var) + ',(ext:current-source-location)))) ,@(when doc-string `((ext:annotate ',var 'documentation 'variable ',doc-string))) ',var))) @@ -121,8 +130,6 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." (defmacro defconstant-equal (var form &optional doc-string) `(defconstant-eqx ,var ,form equal ,doc-string)) -(export '(defconstant-equal)) - (defmacro defun (name lambda-list &body body &environment env) ;; Documentation in help.lisp (multiple-value-bind (decls body doc-string) @@ -131,7 +138,7 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." (sname (si::function-block-name name)) (global-function `#'(lambda ,lambda-list - (declare (core:lambda-name ,name) ,@decls) + (declare (lambda-name ,name) ,@decls) ,@doclist (block ,sname ,@body)))) `(progn @@ -139,101 +146,20 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." ;; this function won't be ready for a while, but it's okay as there's no ;; compiler to run :compile-toplevel forms anyway. (cmp::register-global-function-def 'defun ',name)) - (funcall #'(setf fdefinition) ,global-function ',name) + (setf (fdefinition ',name) ,global-function) ,@(and *defun-inline-hook* (list (funcall *defun-inline-hook* name global-function env))) ',name)))) -(defvar *compiler-macros* (make-hash-table :test #'equal :thread-safe t)) - -(defun compiler-macro-function (name &optional environment) - (declare (ignore environment)) - (values (gethash name *compiler-macros*))) - -(defun (setf compiler-macro-function) (cmf name &optional environment) - (declare (ignore environment)) - (check-package-lock (core::function-block-name name) - 'define-compiler-macro) - ;; Basically ETYPECASE. - (if (functionp cmf) - (funcall #'(setf gethash) cmf name *compiler-macros*) - (if (null cmf) - (progn (remhash name *compiler-macros*) nil) - (error 'type-error :datum cmf :expected-type '(or function null))))) - (defmacro define-compiler-macro (name vl &rest body &environment env) ;; CLHS doesn't actually say d-c-m has compile time effects, but it's nice to match defmacro `(eval-when (:compile-toplevel :load-toplevel :execute) - (funcall #'(setf compiler-macro-function) - (function ,(ext:parse-compiler-macro name vl body env)) - ',name) + (setf (compiler-macro-function ',name) + (function ,(ext:parse-compiler-macro name vl body env))) ',name)) -(defun compiler-macroexpand-1 (form &optional env) - (if (atom form) - form - (or - (and (eq (car form) 'cl:funcall) - (listp (cadr form)) - (eq (car (cadr form)) 'cl:function) - (let ((expander (compiler-macro-function (cadr (cadr form)) env))) - (if expander - (funcall *macroexpand-hook* expander form env) - form))) - (let ((expander (compiler-macro-function (car form) env))) - (if expander - (funcall *macroexpand-hook* expander form env) - form))))) - -(defun compiler-macroexpand (form &optional env) - (let ((expansion (compiler-macroexpand-1 form env))) - (if (eq expansion form) - (return-from compiler-macroexpand form) - (compiler-macroexpand expansion env)))) - -(export '(compiler-macroexpand-1 compiler-macroexpand)) - -;;; Each of the following macros is also defined as a special form, -;;; as required by CLtL. Some of them are used by the compiler (e.g. -;;; dolist), some not at all (e.g. defun). -;;; Thus their names need not be exported. - -(let () - ;; We enclose the macro in a LET form so that it is no longer - ;; a toplevel form. This solves the problem of this simple LOOP - ;; replacing the more complex form in loop2.lisp when evalmacros.lisp - ;; gets compiled. -(defmacro loop (&rest body &aux (tag (gensym))) - "Syntax: (loop {form}*) -Establishes a NIL block and executes FORMs repeatedly. The loop is normally -terminated by a non-local exit." - `(BLOCK NIL (TAGBODY ,tag (PROGN ,@body) (GO ,tag))))) - (defmacro lambda (&rest body) `(function (lambda ,@body))) -; assignment - -#-clasp-min -(defmacro psetq (&rest args) - "Syntax: (psetq {var form}*) -Similar to SETQ, but evaluates all FORMs first, and then assigns each value to -the corresponding VAR. Returns NIL." - (BLOCK NIL - (LET ((L ARGS) (FORMS NIL) (BINDINGS NIL)) - (TAGBODY - (GO bot) - top - (TAGBODY - (LET ((SYM (GENSYM))) - (PUSH (LIST SYM (CADR L)) BINDINGS) - (PUSH (LIST 'SETQ (CAR L) SYM) FORMS))) - (SETQ L (CDDR L)) - bot - (UNLESS (ENDP L) (GO top)) - (RETURN-FROM NIL - (PROGN - (LIST* 'LET* (NREVERSE BINDINGS) (NREVERSE (CONS NIL FORMS))))))))) - ;; Augmented by a compiler macro once cleavir is loaded. (defmacro ext:with-current-source-form ((&rest forms) &body body) "Within BODY, the \"current source form\" will be the first element of FORMS @@ -333,27 +259,6 @@ values of the last FORM. If no FORM is given, returns NIL." ,@body) ,form)))) -(defun while-until (test body jmp-op) - (let ((label (gensym)) - (exit (gensym))) - `(TAGBODY - (GO ,exit) - ,label - ,@body - ,exit - (,jmp-op ,test (GO ,label))))) - -(defmacro sys::while (test &body body) - (while-until test body 'when)) - -(defmacro sys::until (test &body body) - (while-until test body 'unless)) - -(export 'sys::until) - -(defun si::simple-program-error (datum &rest arguments) - (signal-simple-error 'simple-program-error nil datum arguments)) - (defmacro case (keyform &rest clauses) (let* ((last t) (form nil) @@ -398,11 +303,6 @@ values of the last FORM. If no FORM is given, returns NIL." (si::select-package ,(string name)) *package*)) -(defun (setf ext:symbol-macro) (expander name &optional env) - (when env - (error "Non-NIL environment passed to (setf ext:symbol-macro)")) - (funcall #'(setf get-sysprop) expander name 'ext:symbol-macro)) - (defmacro define-symbol-macro (symbol expansion) (cond ((not (symbolp symbol)) (simple-program-error "DEFINE-SYMBOL-MACRO: ~A is not a symbol" @@ -413,51 +313,25 @@ values of the last FORM. If no FORM is given, returns NIL." (t `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (funcall #'(setf ext:symbol-macro) - #'(lambda (form env) - (declare (ignore form env)) - ',expansion) - ',symbol)) - ,@(when (and core:*current-source-pos-info* - (fboundp 'make-load-form)) - `((setf (gethash ',symbol core:*variable-source-infos*) - ',core:*current-source-pos-info*))) + (setf (ext:symbol-macro ',symbol) + #'(lambda (form env) + (declare (ignore form env)) + ',expansion))) + ,@(when (ext:current-source-location) + `((setf (core:variable-source-info ',symbol) + ',(ext:current-source-location)))) ',symbol)))) (defmacro nth-value (n expr) `(nth ,n (multiple-value-list ,expr))) -(defun maybe-unquote (form) - (if (and (consp form) (eq (car form) 'quote)) - (second form) - form)) - -#| -CLHS specifies that - -"If a defclass form appears as a top level form, the compiler must make the class name be recognized as a valid type name in subsequent declarations (as for deftype) and be recognized as a valid class name for defmethod parameter specializers and for use as the :metaclass option of a subsequent defclass. The compiler must make the class definition available to be returned by find-class when its environment argument is a value received as the environment parameter of a macro." - -Our DEFMETHOD and :metaclass do not need any compile time info. We do want to know what classes are classes for the TYPEP compiler macro. - -The CLHS's last requirement about find-class is a problem. We can't fully make classes at compile time. There might be methods on validate-superclass, ensure-class-using-class, *-slot-definition-class, etc., without which a class definition will be invalid, and which won't necessarily be defined at compile time. I am writing this comment because of such a problem with validate-superclass in a real library (bug #736). - -Partway making a class probably isn't valid either. We definitely can't make an actual instance of any specified metaclass, or actual slot definitions, for the above reasons, etc, etc. - -So we just ignore the CLHS requirement here and use a CLASS-INFO mechanism. This is a function that returns compile-time information about a class. A toplevel DEFCLASS form will, at compile time, register the class in the class-info table. - -Right now the only such information is that it exists. In the future I'd like to include real information (e.g. unparsed class options or slot definitions) for use in optimization or to the user. - -(This is early on here because bootstrapping sucks) -|# - -(defvar *class-infos* (make-hash-table :test #'eq :thread-safe t)) +;;; These are not needed by the bytecode compiler, and it in fact ignores them, +;;; but they are needed by clasp-cleavir. -(defun class-info (name &optional env) - (or (find-class name nil env) - (values (gethash name *class-infos*)))) +(defmacro cl:catch (tag &rest forms) + `(core:catch-function + ,tag (lambda () (declare (core:lambda-name catch-lambda)) (progn ,@forms)))) -(defun (setf class-info) (value name &optional env) - (declare (ignore env)) - (if (null value) - (progn (remhash name *class-infos*) value) - (funcall #'(setf gethash) value name *class-infos*))) +(defmacro cl:throw (tag result-form) + `(core:throw-function + ,tag (lambda () (declare (core:lambda-name throw-lambda)) (progn ,result-form)))) diff --git a/src/lisp/kernel/lsp/export.lisp b/src/lisp/kernel/lsp/export.lisp deleted file mode 100644 index 0b7bf2f48e..0000000000 --- a/src/lisp/kernel/lsp/export.lisp +++ /dev/null @@ -1,222 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*- -;;;; -;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. -;;;; Copyright (c) 1990, Giuseppe Attardi. -;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll. -;;;; -;;;; This program 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 file '../Copyright' for full details. -;;;; Exporting external symbols of LISP package - -(eval-when (eval compile load) - (si::select-package "SI")) - - -;; This is needed only when bootstrapping CLASP using CLASP-MIN -(eval-when (eval) - (si::fset 'in-package - #'(lambda (def env) - (declare (core:lambda-name in-package)) - `(eval-when (eval compile load) - (si::select-package ,(string (second def))))) - t) -) - -;; -;; This is also needed for booting Clasp. In particular it is required in -;; defmacro.lisp. -;; - -;; Required by REGISTER-GLOBAL in cmp/cmpvar.lisp -(si::fset 'pushnew #'(lambda (w e) - (declare (ignore e)) - (let ((item (cadr w)) - (place (caddr w))) - `(setq ,place (adjoin ,item ,place)))) - t) - -(si::fset 'push #'(lambda (w e) - (declare (ignore e)) - (let ((item (cadr w)) - (place (caddr w))) - `(setq ,place (cons ,item ,place)))) - t) - - - -(fset 'when #'(lambda (def env) - (declare (ignore env)) - `(if ,(cadr def) (progn ,@(cddr def)))) - t) - - -(fset 'unless #'(lambda (def env) - (declare (ignore env)) - `(if ,(cadr def) nil (progn ,@(cddr def)))) - t) - - -(defun si::while-until (test body jmp-op) - (let ((label (gensym)) - (exit (gensym))) - `(TAGBODY - (GO ,exit) - ,label - ,@body - ,exit - (,jmp-op ,test (GO ,label))))) - -(fset 'si::while #'(lambda (def env) - (declare (ignore env)) - (si::while-until (cadr def) (cddr def) 'when)) - t) - - -(fset 'si::until #'(lambda (def env) - (declare (ignore env)) - (si::while-until (cadr def) (cddr def) 'unless)) - t) - - -;; We do not use this macroexpansion, and thus we do not care whether -;; it is efficiently compiled by ECL or not. -(core:fset 'multiple-value-bind - #'(lambda (whole env) - (declare (core:lambda-name multiple-value-bind-macro)) - (declare (ignore env)) - (let ((vars (cadr whole)) - (form (caddr whole)) - (body (cdddr whole)) - (restvar (gensym))) - `(multiple-value-call - #'(lambda (&optional ,@(mapcar #'list vars) &rest ,restvar) - (declare (ignore ,restvar)) - ,@body) - ,form))) - t) - - -(defun filter-dolist-declarations (declarations) - (let ((a nil)) - (mapc #'(lambda (clause) - (when (not (and (consp clause) - (or (eq (car clause) 'type) - (eq (car clause) 'ignore)))) - (setq a (cons clause a)))) - declarations) - (nreverse a))) - -(let ((f #'(lambda (whole env) - (declare (ignore env) (core:lambda-name dolist)) - (let (body control var expr exit) - (setq body (rest whole)) - (when (endp body) - (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) - (setq control (first body) body (rest body)) - (when (endp control) - (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) - (setq var (first control) control (rest control)) - (if (<= 1 (length control) 2) - (setq expr (first control) exit (rest control)) - (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) - (multiple-value-bind (declarations body) - (process-declarations body nil) - `(block nil - (let* ((%dolist-var ,expr)) - (si::while %dolist-var - (let ((,var (first %dolist-var))) - (declare ,@declarations) - (tagbody - ,@body - (setq %dolist-var (cdr %dolist-var)))))) - ,(when exit - `(let ((,var nil)) - (declare (ignorable ,var) - ,@(filter-dolist-declarations declarations)) - ,@exit)))))))) - (si::fset 'dolist f t '((var list-form &optional result-form) &body body))) - -(let ((f #'(lambda (whole env) - (declare (ignore env) (core:lambda-name dotimes)) - (let (body control var expr exit) - (setq body (rest whole)) - (when (endp body) - (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) - (setq control (first body) body (rest body)) - (when (endp control) - (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) - (setq var (first control) control (rest control)) - (if (<= 1 (length control) 2) - (setq expr (first control) exit (rest control)) - (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) - (multiple-value-bind (declarations body) - (process-declarations body nil) - (when (and (integerp expr) (>= expr 0)) - (setq declarations - (cons `(type (integer 0 ,expr) ,var) declarations))) - `(block nil - (let* ((%dotimes-var ,expr) - (,var 0)) - (declare ,@declarations) - (si::while (< ,var %dotimes-var) - ,@body - (setq ,var (1+ ,var))) - ,@exit))))))) - (si::fset 'dotimes f t '((var count-form &optional result-form) &body body))) - -(let ((f #'(lambda (whole env) - (declare (ignore env) (core:lambda-name do/do*-expand)) - (let (do/do* control test result vlexport step let psetq body) - (setq do/do* (first whole) body (rest whole)) - (if (eq do/do* 'do) - (setq let 'LET psetq 'PSETQ) - (setq let 'LET* psetq 'SETQ)) - (when (endp body) - (simple-program-error "Syntax error first (endp body) in ~A:~%~A" do/do* whole)) - (setq control (first body) body (rest body)) - (when (endp body) - (simple-program-error "Syntax error second (endp body) in ~A:~%~A" do/do* whole)) - (setq test (first body) body (rest body)) - (when (endp test) - (simple-program-error "Syntax error (endp test) in ~A:~%~A" do/do* whole)) - (setq result (rest test) test (first test)) - (dolist (c control) - (when (symbolp c) (setq c (list c))) - (let ((lenc (length c))) - (cond - ((or (eql lenc 1) (eql lenc 2)) - (setq vlexport (cons c vlexport))) - ((eql lenc 3) - (setq vlexport (cons (butlast c) vlexport) - step (list* (third c) (first c) step))) - (t - (simple-program-error "Syntax error (length not 1,2,3 - its ~a and c is ~s) in ~A:~%~A" (length c) c do/do* whole))))) - (multiple-value-bind (declarations real-body) - (process-declarations body nil) - `(BLOCK NIL - (,let ,(nreverse vlexport) - (declare ,@declarations) - (sys::until ,test - ,@real-body - ,@(when step (list (cons psetq (nreverse step))))) - ,@(or result '(nil))))))))) - (si::fset 'do f t '(vars test &body body)) - (si::fset 'do* f t '(vars test &body body))) - -(si::fset 'prog1 #'(lambda (whole env) - (declare (ignore env)) - (let ((sym (gensym)) - (first (cadr whole)) - (body (cddr whole))) - (if body - `(let ((,sym ,first)) - ,@body - ,sym) - first))) - t) - - diff --git a/src/lisp/kernel/lsp/exportcore.lisp b/src/lisp/kernel/lsp/exportcore.lisp deleted file mode 100644 index ce93f781ad..0000000000 --- a/src/lisp/kernel/lsp/exportcore.lisp +++ /dev/null @@ -1,717 +0,0 @@ -(in-package :CORE) -(export '( - CORE:CDDR - CORE:CDR - CORE:CADR - CORE:SETQ - CORE:ENDP - CORE:DO - CORE:LENGTH - CORE:*READ-DEFAULT-FLOAT-FORMAT* - CORE:NTH - CORE:CELL-ERROR-NAME - CORE:DO-ALL-SYMBOLS - CORE:GETF - CORE:SETF - CORE:RETURN - CORE:SHIFTF - CORE:LDB - CORE:*PRINT-LENGTH* - CORE:STANDARD-CHAR-P - CORE:ARRAY-DIMENSION - CORE:MAKE-PACKAGE - CORE:PROGN - CORE:SIMPLE-VECTOR - CORE:OUTPUT-STREAM-P - CORE:LET* - CORE:FORMAT - CORE:WRITE-CHAR - CORE:ROW-MAJOR-AREF - CORE:MAPCAR - CORE:CHAR-LESSP - CORE:FOURTH - CORE:VECTORP - CORE:&BODY - CORE:VARIABLE - CORE:PROVIDE - CORE:APROPOS-LIST - CORE:EXTENDED-CHAR - CORE:EIGHTH - CORE:UNWIND-PROTECT - CORE:READ-PRESERVING-WHITESPACE - CORE:CONCATENATED-STREAM - CORE:STRING-NOT-LESSP - CORE:SEARCH - CORE:COMPILE - CORE:PRIN1-TO-STRING - CORE:INTERN - CORE:PRIN1 - CORE:IN-PACKAGE - CORE:SHADOW - CORE:DEFPACKAGE - CORE:*MACROEXPAND-HOOK* - CORE:DOUBLE-FLOAT - CORE:TYPE-ERROR-DATUM - CORE:COMPILER-MACRO - CORE:READER-ERROR - CORE:STANDARD-GENERIC-FUNCTION - CORE:DEFVAR - CORE:REST - CORE:LAST - CORE:LIST - CORE:MULTIPLE-VALUE-BIND - CORE:DEFSETF - CORE:COMPUTE-RESTARTS - CORE:CDDDAR - CORE:CDDAAR - CORE:CDADAR - CORE:CDAAAR - CORE:CADDAR - CORE:CADAAR - CORE:CAADAR - CORE:CAAAAR - CORE:ASH - CORE:PUSH - CORE:INCF - CORE:DECF - CORE:CASE - CORE:GET-DECODED-TIME - CORE:*MODULES* - CORE:TERPRI - CORE:HASH-TABLE-TEST - CORE:STREAM - CORE:READTABLE - CORE:BOOLEAN - CORE:DELETE - CORE:STREAM-ERROR - CORE:*PRINT-RADIX* - CORE:RETURN-FROM - CORE:SET-DISPATCH-MACRO-CHARACTER - CORE:MAPCAN - CORE:REDUCE - CORE:GET-DISPATCH-MACRO-CHARACTER - CORE:STREAM-EXTERNAL-FORMAT - CORE:REMHASH - CORE:WITH-STANDARD-IO-SYNTAX - CORE:&OPTIONAL - CORE:NOTANY - CORE:SYMBOL-PLIST - CORE:SIMPLE-BASE-STRING - CORE:DEFPARAMETER - CORE:ARRAY-HAS-FILL-POINTER-P - CORE:RPLACD - CORE:CHAR-UPCASE - CORE:TYPEP - CORE:NTH-VALUE - CORE:VECTOR - CORE:LAMBDA - CORE:NEXT-METHOD-P - CORE:COMPLEXP - CORE:STANDARD-CHAR - CORE:WRITE-LINE - CORE:LOGNOT - CORE:SQRT - CORE:SORT - CORE:ABS - CORE:DELETE-FILE - CORE:WARN - CORE:ADJUSTABLE-ARRAY-P - CORE:CDDDR - CORE:CDADR - CORE:CADDR - CORE:CAADR - CORE:OTHERWISE - CORE:REVERSE - CORE:NREVERSE - CORE:DEFUN - CORE:REPLACE - CORE:STRUCTURE - CORE:*PRINT-ESCAPE* - CORE:FILE-STREAM - CORE:WRITE-STRING - CORE:STRING-EQUAL - CORE:COERCE - CORE:CONSTANTLY - CORE:EVERY - CORE:RPLACA - CORE:LOGIOR - CORE:LOGXOR - CORE:LOGNOR - CORE:PSETQ - CORE:BASE-STRING-P - CORE:STRINGP - CORE:LOAD-TIME-VALUE - CORE:MERGE - CORE:GET-SETF-EXPANSION - CORE:BIT-XOR - CORE:SUBST - CORE:PPRINT - CORE:FIRST - CORE:&REST - CORE:LISTP - CORE:COMPLEX - CORE:FILL-POINTER - CORE:DO-EXTERNAL-SYMBOLS - CORE:INPUT-STREAM-P - CORE:ECHO-STREAM - CORE:LOOP-FINISH - CORE:MOST-POSITIVE-FIXNUM - CORE:MAX - CORE:CLASS - CORE:SYMBOL-NAME - CORE:CDAR - CORE:CAAR - CORE:CAR - CORE:CHAR - CORE:COUNT-IF - CORE:RENAME-FILE - CORE:IGNORE - CORE:CONCATENATE - CORE:MAP - CORE:CERROR - CORE:VECTOR-PUSH-EXTEND - CORE:EQL - CORE:REAL - CORE:EVAL - CORE:LOAD - CORE:READ - CORE:RASSOC-IF - CORE:ASSOC-IF - CORE:SIMPLE-VECTOR-P - CORE:*QUERY-IO* - CORE:REQUIRE - CORE:DECLARE - CORE:1- - CORE:1+ - CORE:LDIFF - CORE:WITH-OUTPUT-TO-STRING - CORE:NUNION - CORE:REMOVE-IF - CORE:RANDOM - CORE:CELL-ERROR - CORE:LAMBDA-LIST-KEYWORDS - CORE:PARSE-ERROR - CORE:NSUBSTITUTE-IF - CORE:ARRAY - CORE:DOCUMENTATION - CORE:MAPCON - CORE:COMPLEMENT - CORE:LOCALLY - CORE:UPGRADED-COMPLEX-PART-TYPE - CORE:STRING-DOWNCASE - CORE:CHAR-NOT-GREATERP - CORE:SYMBOL - CORE:ABORT - CORE:PLUSP - CORE:CONSP - CORE:FRESH-LINE - CORE:SINGLE-FLOAT - CORE:&ALLOW-OTHER-KEYS - CORE:EXPT - CORE:T - CORE:MAPL - CORE:DEBUG - CORE:CHARACTER - CORE:TYPE - CORE:MAPC - CORE:DPB - CORE:> - CORE:= - CORE:< - CORE:SUBST-IF - CORE:NSUBST-IF - CORE:MEMBER-IF - CORE:RANDOM-STATE - CORE:/ - CORE:- - CORE:SVREF - CORE:+ - CORE:* - CORE:DEFINE-MODIFY-MACRO - CORE:INTEGER - CORE:LIST-ALL-PACKAGES - CORE:MACROEXPAND-1 - CORE:CHAR-EQUAL - CORE:COPY-SEQ - CORE:SUBSTITUTE - CORE:MACROLET - CORE:FUNCTIONP - CORE:GET-UNIVERSAL-TIME - CORE:GENERIC-FUNCTION - CORE:FLOAT - CORE:REMOVE-DUPLICATES - CORE:HASH-TABLE - CORE:SUBSTITUTE-IF-NOT - CORE:NSUBSTITUTE-IF-NOT - CORE:TYPE-OF - CORE:DELETE-DUPLICATES - CORE:TENTH - CORE:SIXTH - CORE:NINTH - CORE:FIFTH - CORE:SIMPLE-STRING - CORE:SPEED - CORE:STABLE-SORT - CORE:TWO-WAY-STREAM-INPUT-STREAM - CORE:INTERSECTION - CORE:MAKE-STRING - CORE:NINTERSECTION - CORE:DEFINE-METHOD-COMBINATION - CORE:ARRAY-TOTAL-SIZE - CORE:LEAST-POSITIVE-NORMALIZED-LONG-FLOAT - CORE:NOT - CORE:MOST-NEGATIVE-FIXNUM - CORE:OR - CORE:POP - CORE:LOOP - CORE:BLOCK - CORE:ATOM - CORE:MAKE-HASH-TABLE - CORE:DEFCONSTANT - CORE:COPY-STRUCTURE - CORE:LOG - CORE:PROG - CORE:SET-MACRO-CHARACTER - CORE:MOD - CORE:KEYWORDP - CORE:NOTEVERY - CORE:/= - CORE:WITH-PACKAGE-ITERATOR - CORE:SCHAR - CORE:LABELS - CORE:CDDAR - CORE:CDAAR - CORE:CADAR - CORE:CAAAR - CORE:DEFTYPE - CORE:STRING-GREATERP - CORE:DEFINE-SYMBOL-MACRO - CORE:*DEBUG-IO* - CORE:PSETF - CORE:DO* - CORE:SUBSETP - CORE:DEPOSIT-FIELD - CORE:ARITHMETIC-ERROR-OPERATION - CORE:MASK-FIELD - CORE:BROADCAST-STREAM - CORE:EVAL-WHEN - CORE:ARRAY-ELEMENT-TYPE - CORE:*READ-SUPPRESS* - CORE:PACKAGEP - CORE:WRITE - CORE:QUOTE - CORE:SUBTYPEP - CORE:SYMBOL-MACROLET - CORE:*STANDARD-INPUT* - CORE:STRING-NOT-EQUAL - CORE:*READ-EVAL* - CORE:VECTOR-PUSH - CORE:STRING-NOT-GREATERP - CORE:CATCH - CORE:FIND-ALL-SYMBOLS - CORE:STRING - CORE:THROW - CORE:RASSOC - CORE:SET-EXCLUSIVE-OR - CORE:NSET-EXCLUSIVE-OR - CORE:MAKE-SEQUENCE - CORE:CONS - CORE:MAP-INTO - CORE:METHOD - CORE:DEFMETHOD - CORE:FIND - CORE:COND - CORE:AND - CORE:YES-OR-NO-P - CORE:SUBST-IF-NOT - CORE:NSUBST-IF-NOT - CORE:>= - CORE:RATIONALP - CORE:USE-PACKAGE - CORE:COMPILED-FUNCTION - CORE:UNUSE-PACKAGE - CORE:CLASS-OF - CORE:CHAR-CODE-LIMIT - CORE:FDEFINITION - CORE:STANDARD-OBJECT - CORE:MAKE-LIST - CORE:EQUALP - CORE:FUNCALL - CORE:WRITE-TO-STRING - CORE:LOGORC2 - CORE:SPACE - CORE:CLOSE - CORE:ECASE - CORE:CCASE - CORE:DEFCLASS - CORE:MAPLIST - CORE:SECOND - CORE:ARRAY-DIMENSIONS - CORE:SIMPLE-STRING-P - CORE:PRINT-UNREADABLE-OBJECT - CORE:EQUAL - CORE:LOGORC1 - CORE:BIT-VECTOR - CORE:MAKE-BROADCAST-STREAM - CORE:SIMPLE-ERROR - CORE:SHORT-FLOAT - CORE:FIND-CLASS - CORE:LOGNAND - CORE:SIMPLE-BIT-VECTOR - CORE:MOST-POSITIVE-SINGLE-FLOAT - CORE:NRECONC - CORE:NOTINLINE - CORE:RASSOC-IF-NOT - CORE:ASSOC-IF-NOT - CORE:LOGAND - CORE:REMF - CORE:SOME - CORE:STRING> - CORE:HANDLER-BIND - CORE:STRUCTURE-CLASS - CORE:FLOOR - CORE:ERROR - CORE:PRINT-OBJECT - CORE:BIT-AND - CORE:STRING= - CORE:PROG2 - CORE:*STANDARD-OUTPUT* - CORE:STRING/= - CORE:STRING< - CORE:IMAGPART - CORE:REALPART - CORE:PRINC-TO-STRING - CORE:PRINT - CORE:COUNT - CORE:PROG1 - CORE:ZEROP - CORE:REVAPPEND - CORE:APPEND - CORE:THIRD - CORE:*BREAK-ON-SIGNALS* - CORE:MAKE-STRING-INPUT-STREAM - CORE:ACONS - CORE:ELT - CORE:PARSE-INTEGER - CORE:NULL - CORE:FILL - CORE:CHARACTERP - CORE:<= - CORE:*TRACE-OUTPUT* - CORE:TWO-WAY-STREAM - CORE:UNION - CORE:SYNONYM-STREAM - CORE:MAKE-CONDITION - CORE:MOST-POSITIVE-LONG-FLOAT - CORE:LONG-FLOAT - CORE:*DEBUGGER-HOOK* - CORE:UPGRADED-ARRAY-ELEMENT-TYPE - CORE:APPLY - CORE:SYMBOL-PACKAGE - CORE:CHAR/= - CORE:DRIBBLE - CORE:CHAR-CODE - CORE:SEVENTH - CORE:STRING>= - CORE:MOST-NEGATIVE-LONG-FLOAT - CORE:MISMATCH - CORE:DEFMACRO - CORE:IGNORABLE - CORE:GET-OUTPUT-STREAM-STRING - CORE:COMPILER-MACRO-FUNCTION - CORE:MAKE-ECHO-STREAM - CORE:BASE-CHAR - CORE:NAME-CHAR - CORE:WITH-OPEN-FILE - CORE:RESTART-BIND - CORE:CLRHASH - CORE:FILE-POSITION - CORE:COUNT-IF-NOT - CORE:FIND-RESTART - CORE:RENAME-PACKAGE - CORE:SIMPLE-ARRAY - CORE:MAKE-SYMBOL - CORE:CHAR> - CORE:CHAR>= - CORE:WITH-HASH-TABLE-ITERATOR - CORE:GETHASH - CORE:SEQUENCE - CORE:RATIONAL - CORE:PROG* - CORE:PROCLAIM - CORE:TYPECASE - CORE:ETYPECASE - CORE:CTYPECASE - CORE:SHADOWING-IMPORT - CORE:READ-FROM-STRING - CORE:ARRAY-ROW-MAJOR-INDEX - CORE:CHAR= - CORE:MOST-POSITIVE-DOUBLE-FLOAT - CORE:*PRINT-BASE* - CORE:ARRAYP - CORE:WITH-OPEN-STREAM - CORE:MAPHASH - CORE:CHAR-NOT-LESSP - CORE:*PRINT-LEVEL* - CORE:SPECIAL - CORE:POSITION-IF-NOT - CORE:PACKAGE-ERROR - CORE:CHAR< - CORE:APROPOS - CORE:GENSYM - CORE:REMOVE-IF-NOT - CORE:MEMBER-IF-NOT - CORE:PACKAGE-SHADOWING-SYMBOLS - CORE:ADJOIN - CORE:MOST-NEGATIVE-SINGLE-FLOAT - CORE:DECLAIM - CORE:STRING-UPCASE - CORE:PRINT-NOT-READABLE-OBJECT - CORE:OPTIMIZE - CORE:*PRINT-PRETTY* - CORE:HASH-TABLE-REHASH-SIZE - CORE:BASE-STRING - CORE:DESCRIBE - CORE:DESTRUCTURING-BIND - CORE:STRING<= - CORE:PACKAGE-NAME - CORE:PUSHNEW - CORE:DELETE-IF-NOT - CORE:&ENVIRONMENT - CORE:REALP - CORE:TAILP - CORE:MULTIPLE-VALUE-CALL - CORE:BIT - CORE:ALPHA-CHAR-P - CORE:SBIT - CORE:ARRAY-DIMENSION-LIMIT - CORE:MIN - CORE:SIN - CORE:POSITION - CORE:ASSOC - CORE:IF - CORE:*FEATURES* - CORE:DO-SYMBOLS - CORE:*GENSYM-COUNTER* - CORE:&WHOLE - CORE:SAFETY - CORE:MACROEXPAND - CORE:NAMESTRING - CORE:TYPE-ERROR - CORE:INVOKE-RESTART - CORE:READ-DELIMITED-LIST - CORE:FUNCTION - CORE:FILE-ERROR - CORE:READTABLE-CASE - CORE:CHAR<= - CORE:KEYWORD - CORE:LOGICAL-PATHNAME - CORE:TYPE-ERROR-EXPECTED-TYPE - CORE:VALUES - CORE:*LOAD-VERBOSE* - CORE:CHECK-TYPE - CORE:DEFINE-SETF-EXPANDER - CORE:SUBSTITUTE-IF - CORE:SLOT-VALUE - CORE:FIND-IF - CORE:MULTIPLE-VALUE-LIST - CORE:*TERMINAL-IO* - CORE:RANDOM-STATE-P - CORE:SYMBOL-FUNCTION - CORE:DELETE-IF - CORE:EXP - CORE:DOTIMES - CORE:PRINC - CORE:NCONC - CORE:IDENTITY - CORE:THE - CORE:COMPUTE-APPLICABLE-METHODS - CORE:FIND-PACKAGE - CORE:BIT-VECTOR-P - CORE:*READTABLE* - CORE:*LOAD-PRINT* - CORE:SUBSEQ - CORE:STRING-STREAM - CORE:CONTROL-ERROR - CORE:NUMBER - CORE:TAGBODY - CORE:SATISFIES - CORE:MEMBER - CORE:FMAKUNBOUND - CORE:FORMATTER - CORE:STREAMP - CORE:COMPILE-FILE - CORE:LIST* - CORE:UNSIGNED-BYTE - CORE:SIGNED-BYTE - CORE:HASH-TABLE-P - CORE:DISASSEMBLE - CORE:*READ-BASE* - CORE:FIND-SYMBOL - CORE:Y-OR-N-P - CORE:MACRO-FUNCTION - CORE:MOST-NEGATIVE-DOUBLE-FLOAT - CORE:MULTIPLE-VALUE-PROG1 - CORE:GO - CORE:NSET-DIFFERENCE - CORE:HASH-TABLE-REHASH-THRESHOLD - CORE:COPY-LIST - CORE:SYMBOLP - CORE:PATHNAMEP - CORE:BUILT-IN-CLASS - CORE:SIGNUM - CORE:NTHCDR - CORE:NBUTLAST - CORE:BUTLAST - CORE:GENTEMP - CORE:NSUBSTITUTE - CORE:DEFSTRUCT - CORE:VALUES-LIST - CORE:COMPILED-FUNCTION-P - CORE:CONSTANTP - CORE:FIND-IF-NOT - CORE:UNLESS - CORE:HASH-TABLE-SIZE - CORE:POSITION-IF - CORE:CALL-NEXT-METHOD - CORE:ARRAY-RANK - CORE:MAKE-ARRAY - CORE:NSUBST - CORE:MULTIPLE-VALUE-SETQ - CORE:READTABLEP - CORE:RATIO - CORE:SPECIAL-OPERATOR-P - CORE:CDDDDR - CORE:CDDADR - CORE:CDADDR - CORE:CDAADR - CORE:CADDDR - CORE:CADADR - CORE:CAADDR - CORE:CAAADR - CORE:HASH-TABLE-COUNT - CORE:DIRECTORY - CORE:FIXNUM - CORE:CLASS-NAME - CORE:PROGV - CORE:COPY-SYMBOL - CORE:NO-APPLICABLE-METHOD - CORE:STRING-LESSP - CORE:FLOATP - CORE:STANDARD-CLASS - CORE:BIGNUM - CORE:REMOVE - CORE:DOLIST - CORE:PACKAGE - CORE:PACKAGE-USE-LIST - CORE:BOUNDP - CORE:FBOUNDP - CORE:MAKE-TWO-WAY-STREAM - CORE:MOST-POSITIVE-SHORT-FLOAT - CORE:LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT - CORE:ARITHMETIC-ERROR-OPERANDS - CORE:CEILING - CORE:CHAR-NOT-EQUAL - CORE:ENSURE-DIRECTORIES-EXIST - CORE:CHAR-DOWNCASE - CORE:MINUSP - CORE:&KEY - CORE:&AUX - CORE:SET - CORE:GET - CORE:LET - CORE:FLET - CORE:EQ - CORE:STEP - CORE:COPY-TREE - CORE:LOGANDC2 - CORE:OPEN - CORE:WHEN - CORE:AREF - CORE:DECLARATION - CORE:WITH-INPUT-FROM-STRING - CORE:IMPORT - CORE:SIMPLE-BIT-VECTOR-P - CORE:SYMBOL-VALUE - CORE:LOGANDC1 - CORE:PATHNAME - CORE:READ-LINE - CORE:*PACKAGE* - CORE:CHAR-GREATERP - CORE:ROTATEF - CORE:EXPORT - CORE:RESTART - CORE:MAKUNBOUND - CORE:NUMBERP - CORE:LOGEQV - CORE:CHAR-NAME - CORE:SET-DIFFERENCE - CORE:TWO-WAY-STREAM-OUTPUT-STREAM - CORE:INTEGERP - CORE:DEFGENERIC - CORE:ASSERT - CORE:MAKE-SYNONYM-STREAM - CORE:MOST-NEGATIVE-SHORT-FLOAT - CORE:ARRAY-RANK-LIMIT - CORE:STRUCTURE-OBJECT - CORE:ARRAY-DISPLACEMENT - CORE::FLOATING-POINT-INVALID-OPERATION - CORE::RESTART-NAME - CORE::*PRINT-CIRCLE* - CORE::NSTRING-UPCASE - CORE::PROGRAM-ERROR - CORE::STYLE-WARNING - CORE::UNBOUND-SLOT-INSTANCE - CORE::DECODE-FLOAT - CORE::IGNORE-ERRORS - CORE::STRING-LEFT-TRIM - CORE::SIMPLE-CONDITION-FORMAT-CONTROL - CORE::CONTINUE - CORE::STREAM-ERROR-STREAM - CORE::HANDLER-CASE - CORE::UNTRACE - CORE::STORE-VALUE - CORE::WITH-CONDITION-RESTARTS - CORE::SERIOUS-CONDITION - CORE::SIMPLE-TYPE-ERROR - CORE::UNBOUND-VARIABLE - CORE::GRAPHIC-CHAR-P - CORE::ROUND - CORE::ARITHMETIC-ERROR - CORE::PACKAGE-ERROR-PACKAGE - CORE::FILE-ERROR-PATHNAME - CORE::PRINT-NOT-READABLE - CORE::*ERROR-OUTPUT* - CORE::INVOKE-DEBUGGER - CORE::WARNING - CORE::REM - CORE::DIVISION-BY-ZERO - CORE::TRUNCATE - CORE::WITH-SIMPLE-RESTART - CORE::SIGNAL - CORE::CONDITION - CORE::PPRINT-LOGICAL-BLOCK - CORE::INVOKE-RESTART-INTERACTIVELY - CORE::PPRINT-NEWLINE - CORE::STORAGE-CONDITION - CORE::DEFINE-CONDITION - CORE::FUNCTION-LAMBDA-EXPRESSION - CORE::TRACE - CORE::BREAK - CORE::END-OF-FILE - CORE::PPRINT-POP - CORE::PPRINT-INDENT - CORE::SIMPLE-WARNING - CORE::NSTRING-CAPITALIZE - CORE::USE-VALUE - CORE::SIMPLE-CONDITION - CORE::NSTRING-DOWNCASE - CORE::RESTART-CASE - CORE::FLOATING-POINT-UNDERFLOW - CORE::FLOATING-POINT-OVERFLOW - CORE::UNBOUND-SLOT - CORE::PPRINT-TAB - CORE::MUFFLE-WARNING - CORE::SIMPLE-CONDITION-FORMAT-ARGUMENTS - CORE::FLOATING-POINT-INEXACT -)) diff --git a/src/lisp/kernel/lsp/ext-package.lisp b/src/lisp/kernel/lsp/ext-package.lisp new file mode 100644 index 0000000000..9e15ce0b1c --- /dev/null +++ b/src/lisp/kernel/lsp/ext-package.lisp @@ -0,0 +1,134 @@ +(in-package #:ext) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(import '(cmp::muffle-note + core:argc + core:argv + core:getpid + core:hash-table-weakness + core:list-all-logical-hosts + core:logical-host-p + core:make-weak-pointer + core:temporary-directory + core:mkstemp + core:printing-char-p + core:quit + core:rmdir + core:weak-pointer-valid + core:weak-pointer-value + core:num-logical-processors + core:quasiquote + core:unquote + core:unquote-splice + core:unquote-nsplice + gctools:finalize + gctools:garbage-collect + gctools:save-lisp-and-die)) +) + +;;; must be a separate top level form so that the symbols +;;; are imported before they are read. +(eval-when (:compile-toplevel :load-toplevel :execute) +(export '(*module-provider-functions* + *source-location-kinds* + current-source-location + source-location + source-location-pathname + source-location-offset + source-location-definer + source-location-description + compiled-function-name + compiled-function-file + who-calls + who-binds + who-sets + who-references + who-macroexpands + who-specializes-directly + list-callers + list-callees + macroexpand-all + list-all-logical-hosts + logical-host-p + array-index + byte8 + integer8 + byte16 + integer16 + byte32 + integer32 + byte64 + integer64 + assume-no-errors + all-encodings + make-encoding + assert-error + float-nan-p + float-infinity-p + character-coding-error + character-encoding-error + character-decoding-error + stream-encoding-error + stream-decoding-error + generate-encoding-hashtable + quit + with-float-traps-masked + defun/typed + enable-interrupt default-interrupt ignore-interrupt + get-signal-handler set-signal-handler + *ed-functions* + ;;; for asdf and slime and trivial-garbage to use ext: + getpid argc argv rmdir temporary-directory mkstemp weak-pointer-value + make-weak-pointer weak-pointer-valid hash-table-weakness + num-logical-processors + quasiquote + unquote + unquote-splice + unquote-nsplice + compiler-note + muffle-note + segmentation-violation + stack-overflow + stack-overflow-size + stack-overflow-type + storage-exhausted + illegal-instruction + unix-signal-received + unix-signal-received-code + unix-signal-received-handler + interactive-interrupt + getcwd + chdir + +process-standard-input+ + system + float-nan-string + package-local-nicknames + add-package-local-nickname + remove-package-local-nickname + package-locally-nicknamed-by-list + package-implements-list + with-unlocked-packages + keep-old change-nick ; restarts for add-package-local-nicknames + ;; symbol name conflicts + name-conflict name-conflict-candidates resolve-conflict + ;; Readers of RESTART objects + restart-function restart-report-function + restart-interactive-function restart-test-function + restart-associated-conditions + ;; Debugger + tpl-frame tpl-argument tpl-arguments + ;; GC + garbage-collect finalize save-lisp-and-die + ;; Compiler + describe-compiler-policy + with-current-source-form + start-autocompilation + stop-autocompilation + deoptimize reoptimize + ;; Macro parsing & acccess + parse-deftype type-expander typexpand-1 typexpand + ;; C++ iterators + do-c++-iterator map-c++-iterator + ;; Misc + printing-char-p)) +) ; eval-when diff --git a/src/lisp/kernel/lsp/fli.lisp b/src/lisp/kernel/lsp/fli.lisp index ca35c31233..643768a4b8 100644 --- a/src/lisp/kernel/lsp/fli.lisp +++ b/src/lisp/kernel/lsp/fli.lisp @@ -8,13 +8,11 @@ ;;; .../include/clasp/core/fli.h - corresponding .h file ;;; .../src/lisp/kernel/fli.lisp - this file ;;; +;;; fli-specs.lisp, generated by the build, communicates the information in +;;; the C++ runtime to Lisp by defining the *foreign-type-specs* variable. +;;; ;;; --- END OF IMPLEMEMTATION NOTES --- -#+(or) -(eval-when (:execute) - (format t "!~%!~%!~%!~%!~%In fli.lisp !~%") - (setq core:*echo-repl-read* t)) - (in-package "CLASP-FFI") ;;;---------------------------------------------------------------------------- @@ -68,6 +66,8 @@ ;;; - alignment ;;; - C++ name ;;; Adding built-in foreign types requires adding a type spec to this table! +;;; *foreign-type-specs* is defined by the build only at compilation time, +;;; and is an alist of Lisp symbols to indices in the table. (defun dbg-print-*foreign-type-spec-table* () (loop @@ -80,50 +80,18 @@ ;;; %LISP-TYPE->TYPE-SPEC (defgeneric %lisp-type->type-spec (lisp-type-kw)) -(defmacro generate-type-spec-accessor-functions () - `(progn - ;; type -> type spec - ,@(loop for spec across *foreign-type-spec-table* - for idx from 0 to (1- (length *foreign-type-spec-table*)) - when spec - collect - `(progn -;;; (core:fmt t "Defining lisp-type->type-spec for {}%N" ,(%lisp-symbol spec)) - (defmethod %lisp-type->type-spec ((lisp-type-kw (eql ',(%lisp-symbol spec)))) - (elt *foreign-type-spec-table* ,idx)))))) - (defmethod %lisp-type->type-spec (lisp-type-kw) (error "Unknown FLI lisp type ~S - cannot determine type spec." lisp-type-kw)) ;;; %FOREIGN-TYPE-SIZE (defgeneric %foreign-type-size (lisp-type-kw)) -(defmacro generate-foreign-type-size-functions () - `(progn - ;; type -> type spec - ,@(loop for spec across *foreign-type-spec-table* - for idx from 0 to (1- (length *foreign-type-spec-table*)) - when spec - collect - `(defmethod %foreign-type-size ((lisp-type-kw (eql ',(%lisp-symbol spec)))) - (%size (elt *foreign-type-spec-table* ,idx)))))) - (defmethod %foreign-type-size (lisp-type-kw) (error "Unknown FLI lisp type ~S - cannot determine foreign size." lisp-type-kw)) ;;; %FOREIGN-TYPE-ALIGNMENT (defgeneric %foreign-type-alignment (lisp-type-kw)) -(defmacro generate-foreign-type-alignment-functions () - `(progn - ;; type -> type spec - ,@(loop for spec across *foreign-type-spec-table* - for idx from 0 to (1- (length *foreign-type-spec-table*)) - when spec - collect - `(defmethod %foreign-type-alignment ((lisp-type-kw (eql ',(%lisp-symbol spec)))) - (%alignment (elt *foreign-type-spec-table* ,idx)))))) - (defmethod %foreign-type-alignment (lisp-type-kw) (error "Unknown FLI lisp type ~S - cannot determine foreign alignment." lisp-type-kw)) @@ -131,17 +99,6 @@ (defgeneric %lisp-type->llvm-type-symbol-fn (lisp-type-kw)) -(defmacro generate-llvm-type-symbol-fn-accessor-functions () - `(progn - ;; type -> llvm type symbol - ,@(loop for spec across *foreign-type-spec-table* - for idx from 0 to (1- (length *foreign-type-spec-table*)) - when spec - collect - `(defmethod %lisp-type->llvm-type-symbol-fn ((lisp-type-kw (eql ',(%lisp-symbol spec)))) - (%llvm-type-symbol-fn (elt *foreign-type-spec-table* ,idx)))) - )) - (defmethod %lisp-type->llvm-type-symbol-fn (lisp-type-kw) (error "Unknown FLI lisp type ~S - cannot determine llvm type symbol function." lisp-type-kw)) @@ -155,17 +112,12 @@ collecting `(set1 ,key ,ll))))) (setall :short cmp::%i16% :unsigned-short cmp::%i16% - :ushort cmp::%i16% :int cmp::%i32% :unsigned-int cmp::%i32% - :uint cmp::%i32% :long cmp::%i64% :unsigned-long cmp::%i64% - :ulong cmp::%i64% :long-long cmp::%i64% - :llong cmp::%i64% :unsigned-long-long cmp::%i64% - :ullong cmp::%i64% :int8 cmp::%i8% :uint8 cmp::%i8% :int16 cmp::%i16% @@ -179,7 +131,6 @@ :size cmp::%size_t% :ssize cmp::%size_t% ;#+short-float :short-float #+short-float cmp::%short-float% - :single-float cmp::%float% :float cmp::%float% :double cmp::%double% ;#+long-float :long-float #+long-float cmp::%long-float% @@ -187,7 +138,6 @@ :void cmp::%void% :char cmp::%i8% :unsigned-char cmp::%i8% - :uchar cmp::%i8% ;; TODO: CHECK & IMPLEMEMT ! ;; :time cmp::+time_t+ ;; :ptrdiff cmp::+ptrdiff_t+ @@ -234,15 +184,6 @@ (defgeneric %mem-ref (ptr type &optional offset)) -(defmacro generate-mem-ref-accessor-functions () - `(progn - ,@(loop for spec across *foreign-type-spec-table* - when spec - collect - `(defmethod %mem-ref (ptr (type (eql ',(%lisp-symbol spec))) &optional (offset 0)) - (funcall ',(intern (concatenate 'string "%MEM-REF-" (string (%lisp-symbol spec))) 'clasp-ffi) - (%offset-address-as-integer ptr offset)))))) - (defmethod %mem-ref (ptr type &optional offset) (declare (ignore ptr offset)) (error "Unknown lisp type ~S for %mem-ref." type)) @@ -251,31 +192,10 @@ (defgeneric %mem-set (ptr type value &optional offset)) -(defmacro generate-mem-set-accessor-functions () - `(progn - ,@(loop for spec across *foreign-type-spec-table* - when spec - collect - `(defmethod %mem-set (ptr (type (eql ',(%lisp-symbol spec))) value &optional (offset 0)) - (funcall ',(intern (concatenate 'string "%MEM-SET-" (string (%lisp-symbol spec))) 'clasp-ffi) - (%offset-address-as-integer ptr offset) value))))) - (defmethod %mem-set (ptr type value &optional offset) (declare (ignore ptr offset value)) (error "Unknown lisp type ~S for %mem-set." type)) -;;; === S A T I A T I O N === -(defmacro generate-satiation () - (let ((to-satiate - (loop for spec across *foreign-type-spec-table* - when spec - collect `'((eql ,(%lisp-symbol spec)))))) - `(eval-when (:load-toplevel) ; don't need to do it while loading as source - (clos:satiate #'%lisp-type->type-spec ,@to-satiate) - (clos:satiate #'%foreign-type-size ,@to-satiate) - (clos:satiate #'%foreign-type-alignment ,@to-satiate) - (clos:satiate #'%lisp-type->llvm-type-symbol-fn ,@to-satiate)))) - ;;; === F O R E I G N F U N C T I O N C A L L I N G === ;;; This code has been invented on-the-fly by drmeister on 2016-10-13 ... @@ -292,6 +212,7 @@ (defun from-translator-name (type) (translator-name "" "from" type)) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun split-list (list) (do ((list list (rest (rest list))) (left '() (list* (first list) left)) @@ -306,6 +227,7 @@ (arg-types (butlast types)) (last (car (last types)))) (values (list last arg-types) args))) +) (defmacro %foreign-funcall (name &rest arguments) (multiple-value-bind (signature args) @@ -396,13 +318,38 @@ ;;; ;;; F L I I N I T I A L I Z A T I O N -(generate-type-spec-accessor-functions) -(generate-llvm-type-symbol-fn-accessor-functions) -(generate-mem-ref-accessor-functions) -(generate-mem-set-accessor-functions) -(generate-foreign-type-size-functions) -(generate-foreign-type-alignment-functions) -(generate-satiation) +(macrolet ((generate-methods () + `(progn + ,@(loop for (type . index) in *foreign-type-specs* + for specform = `(load-time-value + (elt *foreign-type-spec-table* ,index) + t) + collect + `(defmethod %lisp-type->type-spec ((type (eql ',type))) + ,specform) + collect + `(defmethod %foreign-type-size ((type (eql ',type))) + (%size ,specform)) + collect + `(defmethod %foreign-type-alignment ((type (eql ',type))) + (%alignment ,specform)) + collect + `(defmethod %lisp-type->llvm-type-symbol-fn ((type (eql ',type))) + (%llvm-type-symbol-fn ,specform)) + unless (eq type :void) + collect + `(defmethod %mem-ref (ptr (type (eql ',type)) &optional (offset 0)) + (,(intern (concatenate 'string "%MEM-REF-" (string type)) + "CLASP-FFI") + (%offset-address-as-integer ptr offset))) + unless (eq type :void) + collect + `(defmethod %mem-set (ptr (type (eql ',type)) value &optional offset) + (,(intern (concatenate 'string "%MEM-SET-" (string type)) + "CLASP-FFI") + (%offset-address-as-integer ptr offset) value)))))) + (generate-methods)) + (init-translators) ;;;---------------------------------------------------------------------------- @@ -422,9 +369,9 @@ (defun codegen-callback (signature var &key (c-name "callback")) (let* ((rett-kw (signature-return-type signature)) - (rett (clasp-ffi:safe-translator-type rett-kw)) + (rett (safe-translator-type rett-kw)) (args-kws (signature-argument-types signature)) - (argsts (mapcar #'clasp-ffi:safe-translator-type args-kws)) + (argsts (mapcar #'safe-translator-type args-kws)) (type (llvm-sys:function-type-get rett argsts)) (llfun (cmp:irc-function-create type 'llvm-sys:external-linkage c-name cmp:*the-module*)) diff --git a/src/lisp/kernel/lsp/format-pprint.lisp b/src/lisp/kernel/lsp/format-pprint.lisp index 557731717d..d055ed0ff5 100644 --- a/src/lisp/kernel/lsp/format-pprint.lisp +++ b/src/lisp/kernel/lsp/format-pprint.lisp @@ -69,7 +69,7 @@ (write-string spaces stream :end n))) (defun format-relative-tab (stream colrel colinc) - (if (#-(or ecl clasp) pp:pretty-stream-p #+(or ecl clasp) sys::pretty-stream-p stream) + (if (sys::pretty-stream-p stream) (pprint-tab :line-relative colrel colinc stream) (let* ((cur (stream-output-column stream)) (spaces (if (and cur (plusp colinc)) @@ -78,7 +78,7 @@ (output-spaces stream spaces)))) (defun format-absolute-tab (stream colnum colinc) - (if (#-(or ecl clasp) pp:pretty-stream-p #+(or ecl clasp) sys::pretty-stream-p stream) + (if (sys::pretty-stream-p stream) (pprint-tab :line colnum colinc stream) (let ((cur (stream-output-column stream))) (cond ((null cur) @@ -210,25 +210,22 @@ remaining)) (defun parse-format-justification (directives) - (let ((first-semi nil) - (close nil) - (remaining directives)) - (collect ((segments)) - (loop - (let ((close-or-semi (find-directive remaining #\> t))) - (unless close-or-semi - (error 'format-error - :complaint "No corresponding close bracket.")) - (let ((posn (position close-or-semi remaining))) - (segments (subseq remaining 0 posn)) - (setf remaining (nthcdr (1+ posn) remaining))) - (when (char= (format-directive-character close-or-semi) - #\>) - (setf close close-or-semi) - (return)) - (unless first-semi - (setf first-semi close-or-semi)))) - (values (segments) first-semi close remaining)))) + (loop with first-semi = nil + with close = nil + with remaining = directives + for close-or-semi = (find-directive remaining #\> t) + unless close-or-semi + do (error 'format-error + :complaint "No corresponding close bracket.") + collect (let ((posn (position close-or-semi remaining))) + (prog1 (subseq remaining 0 posn) + (setf remaining (nthcdr (1+ posn) remaining)))) + into segments + when (char= (format-directive-character close-or-semi) #\>) + do (setf close close-or-semi) (loop-finish) + unless first-semi + do (setf first-semi close-or-semi) + finally (return (values segments first-semi close remaining)))) (defun expand-format-justification (segments colonp atsignp first-semi params) (let ((newline-segment-p @@ -426,26 +423,23 @@ (t nil))) (defun add-fill-style-newlines-aux (literal string offset) - (let ((end (length literal)) - (posn 0)) - (collect ((results)) - (loop - (let ((blank (position #\space literal :start posn))) - (when (null blank) - (results (subseq literal posn)) - (return)) - (let ((non-blank (or (position #\space literal :start blank - :test #'char/=) - end))) - (results (subseq literal posn non-blank)) - (results (make-format-directive - :string string :character #\_ - :start (+ offset non-blank) :end (+ offset non-blank) - :colonp t :atsignp nil :params nil)) - (setf posn non-blank)) - (when (= posn end) - (return)))) - (results)))) + (loop with end = (length literal) + for posn = 0 then non-blank + for blank = (position #\space literal :start posn) + for non-blank = (if blank + (or (position #\space literal :start blank + :test #'char/=) + end) + nil) + when (null blank) + collect (subseq literal posn) + and do (loop-finish) + until (= posn end) + collect (subseq literal posn non-blank) + collect (make-format-directive + :string string :character #\_ + :start (+ offset non-blank) :end (+ offset non-blank) + :colonp t :atsignp nil :params nil))) (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp) `(let ((arg ,(if atsignp 'args (expand-next-arg)))) @@ -543,7 +537,7 @@ (write-object-with-circle array stream #'(lambda (array stream) - (funcall (formatter "#~DA") stream (array-rank array)) + (format stream "#~DA" (array-rank array)) (pprint-array-contents stream array)))) (defun pprint-raw-array (stream array) @@ -616,23 +610,20 @@ (defun pprint-lambda (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") - stream list)) + (format stream "~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>" list)) (defun pprint-block (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list)) + (format stream "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>" list)) (defun pprint-flet (stream list &rest noise) (declare (ignore noise)) (if (and (consp list) (consp (cdr list)) (not (null (cddr list)))) - (funcall (formatter - "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>") - stream - list) + (format stream + "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>" + list) ;; Things like (labels foo) function names. (pprint-logical-block (stream list :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) @@ -643,18 +634,18 @@ (defun pprint-let (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>") - stream - list)) + (format stream + "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>" + list)) (defun pprint-progn (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list)) + (format stream "~:<~^~W~@{ ~_~W~}~:>" list)) (defun pprint-progv (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>") - stream list)) + (format stream "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>" + list)) (defun pprint-quote (stream list &rest noise) (declare (ignore noise)) @@ -721,7 +712,6 @@ (pprint-newline :linear stream) (write-object (pprint-pop) stream))))) -;;#+clasp-min (defmacro pprint-tagbody-guts (stream) `(loop (pprint-exit-if-list-exhausted) @@ -742,23 +732,21 @@ (defun pprint-case (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SI:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>") - stream - list)) + (format stream + "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SI:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>" + list)) (defun pprint-defun (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") - stream - list)) + (format stream + "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>" + list)) (defun pprint-destructuring-bind (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^~3I ~_~:/SI:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>") - stream list)) + (format stream + "~:<~^~W~^~3I ~_~:/SI:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>" + list)) (defun pprint-do (stream list &rest noise) (declare (ignore noise)) @@ -768,9 +756,8 @@ (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-indent :current 0 stream) - (funcall (formatter "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>") - stream - (pprint-pop)) + (format stream "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>" + (pprint-pop)) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :linear stream) @@ -786,17 +773,15 @@ (pprint-indent :block 3 stream) (write-char #\space stream) (pprint-newline :fill stream) - (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>") - stream - (pprint-pop)) + (format stream "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>" + (pprint-pop)) (pprint-tagbody-guts stream))) (defun pprint-typecase (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>") - stream - list)) + (format stream + "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>" + list)) (defun pprint-prog (stream list &rest noise) (declare (ignore noise)) @@ -811,100 +796,11 @@ (defun pprint-function-call (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>") - stream - list)) + (format stream "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>" list)) ;;;; Interface seen by regular (ugly) printer and initialization routines. -(eval-when (:compile-toplevel :execute) -(defparameter +magic-forms+ - '((lambda pprint-lambda) - ;; Special forms. - (block pprint-block) - (catch pprint-block) - (compiler-let pprint-let) - (eval-when pprint-block) - (flet pprint-flet) - (function pprint-quote) - (labels pprint-flet) - (let pprint-let) - (let* pprint-let) - (locally pprint-progn) - (macrolet pprint-flet) - (multiple-value-call pprint-block) - (multiple-value-prog1 pprint-block) - (progn pprint-progn) - (progv pprint-progv) - (quote pprint-quote) - (return-from pprint-block) - (setq pprint-setq) - (symbol-macrolet pprint-let) - (tagbody pprint-tagbody) - (throw pprint-block) - (unwind-protect pprint-block) - (core:quasiquote pprint-quote) - (core:unquote pprint-quote) - (core:unquote-splice pprint-quote) - (core:unquote-nsplice pprint-quote) - - ;; Macros. - (case pprint-case) - (ccase pprint-case) - (ctypecase pprint-typecase) - (defconstant pprint-block) - (define-modify-macro pprint-defun) - (define-setf-expander pprint-defun) - (defmacro pprint-defun) - (defparameter pprint-block) - (defsetf pprint-defun) - (defstruct pprint-block) - (deftype pprint-defun) - (defun pprint-defun) - (defvar pprint-block) - (destructuring-bind pprint-destructuring-bind) - (do pprint-do) - (do* pprint-do) - (do-all-symbols pprint-dolist) - (do-external-symbols pprint-dolist) - (do-symbols pprint-dolist) - (dolist pprint-dolist) - (dotimes pprint-dolist) - (ecase pprint-case) - (etypecase pprint-typecase) - #+nil (handler-bind ...) - #+nil (handler-case ...) - #+nil (loop ...) - (multiple-value-bind pprint-progv) - (multiple-value-setq pprint-block) - (pprint-logical-block pprint-block) - (print-unreadable-object pprint-block) - (prog pprint-prog) - (prog* pprint-prog) - (prog1 pprint-block) - (prog2 pprint-progv) - (psetf pprint-setq) - (psetq pprint-setq) - #+nil (restart-bind ...) - #+nil (restart-case ...) - (setf pprint-setq) - (step pprint-progn) - (time pprint-progn) - (typecase pprint-typecase) - (unless pprint-block) - (when pprint-block) - (with-compilation-unit pprint-block) - #+nil (with-condition-restarts ...) - (with-hash-table-iterator pprint-block) - (with-input-from-string pprint-block) - (with-open-file pprint-block) - (with-open-stream pprint-block) - (with-output-to-string pprint-block) - (with-package-iterator pprint-block) - (with-simple-restart pprint-block) - (with-standard-io-syntax pprint-progn)))) - (progn (let ((*print-pprint-dispatch* (make-pprint-dispatch-table))) ;; Printers for regular types. @@ -913,14 +809,97 @@ #'pprint-function-call -1) (set-pprint-dispatch 'cons #'pprint-fill -2) ;; Cons cells with interesting things for the car. - (dolist (magic-form '#.+magic-forms+) - (set-pprint-dispatch `(cons (eql ,(first magic-form))) - (symbol-function (second magic-form)))) + (loop for (operator f) + in '((lambda pprint-lambda) + ;; Special forms. + (block pprint-block) + (catch pprint-block) + (compiler-let pprint-let) + (eval-when pprint-block) + (flet pprint-flet) + (function pprint-quote) + (labels pprint-flet) + (let pprint-let) + (let* pprint-let) + (locally pprint-progn) + (macrolet pprint-flet) + (multiple-value-call pprint-block) + (multiple-value-prog1 pprint-block) + (progn pprint-progn) + (progv pprint-progv) + (quote pprint-quote) + (return-from pprint-block) + (setq pprint-setq) + (symbol-macrolet pprint-let) + (tagbody pprint-tagbody) + (throw pprint-block) + (unwind-protect pprint-block) + (core:quasiquote pprint-quote) + (core:unquote pprint-quote) + (core:unquote-splice pprint-quote) + (core:unquote-nsplice pprint-quote) + + ;; Macros. + (case pprint-case) + (ccase pprint-case) + (ctypecase pprint-typecase) + (defconstant pprint-block) + (define-modify-macro pprint-defun) + (define-setf-expander pprint-defun) + (defmacro pprint-defun) + (defparameter pprint-block) + (defsetf pprint-defun) + (defstruct pprint-block) + (deftype pprint-defun) + (defun pprint-defun) + (defvar pprint-block) + (destructuring-bind pprint-destructuring-bind) + (do pprint-do) + (do* pprint-do) + (do-all-symbols pprint-dolist) + (do-external-symbols pprint-dolist) + (do-symbols pprint-dolist) + (dolist pprint-dolist) + (dotimes pprint-dolist) + (ecase pprint-case) + (etypecase pprint-typecase) + #+nil (handler-bind ...) + #+nil (handler-case ...) + #+nil (loop ...) + (multiple-value-bind pprint-progv) + (multiple-value-setq pprint-block) + (pprint-logical-block pprint-block) + (print-unreadable-object pprint-block) + (prog pprint-prog) + (prog* pprint-prog) + (prog1 pprint-block) + (prog2 pprint-progv) + (psetf pprint-setq) + (psetq pprint-setq) + #+nil (restart-bind ...) + #+nil (restart-case ...) + (setf pprint-setq) + (step pprint-progn) + (time pprint-progn) + (typecase pprint-typecase) + (unless pprint-block) + (when pprint-block) + (with-compilation-unit pprint-block) + #+nil (with-condition-restarts ...) + (with-hash-table-iterator pprint-block) + (with-input-from-string pprint-block) + (with-open-file pprint-block) + (with-open-stream pprint-block) + (with-output-to-string pprint-block) + (with-package-iterator pprint-block) + (with-simple-restart pprint-block) + (with-standard-io-syntax pprint-progn)) + do (set-pprint-dispatch `(cons (eql ,operator)) + (symbol-function f))) (setf *initial-pprint-dispatch* *print-pprint-dispatch*) ) (setf *print-pprint-dispatch* (copy-pprint-dispatch nil) *standard-pprint-dispatch* *initial-pprint-dispatch*) (setf (pprint-dispatch-table-read-only-p *standard-pprint-dispatch*) t) (setf (first (cdr si::+io-syntax-progv-list+)) *standard-pprint-dispatch*) - #-clasp-min (setf *print-pretty* t)) diff --git a/src/lisp/kernel/lsp/format.lisp b/src/lisp/kernel/lsp/format.lisp index 5b6fe9e38d..1bba9edd30 100644 --- a/src/lisp/kernel/lsp/format.lisp +++ b/src/lisp/kernel/lsp/format.lisp @@ -193,9 +193,7 @@ (1+ (floor (log (abs x) 10))))) (defstruct (format-directive - #-(or ecl clasp)(:print-function %print-format-directive) - #+(or ecl clasp) :named - #+(or ecl clasp) (:type vector)) + (:print-function %print-format-directive)) (string t :type simple-string) (start 0 :type (and unsigned-byte fixnum)) (end 0 :type (and unsigned-byte fixnum)) @@ -204,9 +202,6 @@ (atsignp nil :type (member t nil)) (params nil :type list)) -(deftype format-directive () 'vector) - -#-(or ecl clasp) (defun %print-format-directive (struct stream depth) (declare (ignore depth)) (print-unreadable-object (struct stream) @@ -229,7 +224,26 @@ ;; NIL otherwise. (defparameter *output-layout-mode* nil) -;; The condition FORMAT-ERROR is found later in conditions.lisp +(define-condition format-error (simple-error) + ((format-control :initarg :complaint) + (format-arguments :initarg :arguments) + (control-string :reader format-error-control-string + :initarg :control-string + :initform *default-format-error-control-string*) + (offset :reader format-error-offset :initarg :offset + :initform *default-format-error-offset*) + (print-banner :reader format-error-print-banner :initarg :print-banner + :initform t)) + (:report (lambda (condition stream) + (format + stream + "~:[~;Error in format: ~]~ + ~?~@[~% ~A~% ~V@T^~]" + (format-error-print-banner condition) + (simple-condition-format-control condition) + (simple-condition-format-arguments condition) + (format-error-control-string condition) + (format-error-offset condition))))) ;;;; TOKENIZE-CONTROL-STRING @@ -452,7 +466,7 @@ (simple-string (write-string directive stream) (interpret-directive-list stream (cdr directives) orig-args args)) - (#-(or ecl clasp) format-directive #+(or ecl clasp) vector + (format-directive (multiple-value-bind (new-directives new-args) (let* ((code (char-code (format-directive-character directive))) @@ -650,34 +664,32 @@ (defmacro expand-bind-defaults (specs params &body body) (once-only ((params params)) (if specs - (collect ((expander-bindings) (runtime-bindings)) - (dolist (spec specs) - (destructuring-bind (var default) spec - (let ((symbol (gensym))) - (expander-bindings - `(,var ',symbol)) - (runtime-bindings - `(list ',symbol - (let* ((param-and-offset (pop ,params)) - (offset (car param-and-offset)) - (param (cdr param-and-offset))) - (case param - (:arg `(or ,(expand-next-arg offset) - ,,default)) - (:remaining - (setf *only-simple-args* nil) - '(length args)) - ((nil) ,default) - (t param)))))))) - `(let ,(expander-bindings) - `(let ,(list ,@(runtime-bindings)) - ,@(if ,params - (error 'format-error - :complaint - "Too many parameters, expected no more than ~D" - :arguments (list ,(length specs)) - :offset (caar ,params))) - ,,@body))) + (loop for (var default) in specs + for symbol = (gensym) + collect `(,var ',symbol) into expander-bindings + collect `(list ',symbol + (let* ((param-and-offset (pop ,params)) + (offset (car param-and-offset)) + (param (cdr param-and-offset))) + (case param + (:arg `(or ,(expand-next-arg offset) + ,,default)) + (:remaining + (setf *only-simple-args* nil) + '(length args)) + ((nil) ,default) + (t param)))) + into runtime-bindings + finally (return + `(let ,expander-bindings + `(let ,(list ,@runtime-bindings) + ,@(if ,params + (error 'format-error + :complaint + "Too many parameters, expected no more than ~D" + :arguments (list ,(length specs)) + :offset (caar ,params))) + ,,@body)))) `(progn (when ,params (error 'format-error @@ -715,25 +727,22 @@ (defmacro interpret-bind-defaults (specs params &body body) (once-only ((params params)) - (collect ((bindings)) - (dolist (spec specs) - (destructuring-bind (var default) spec - (bindings `(,var (let* ((param-and-offset (pop ,params)) - (offset (car param-and-offset)) - (param (cdr param-and-offset))) - (case param - (:arg (or (next-arg offset) ,default)) - (:remaining (length args)) - ((nil) ,default) - (t param))))))) - `(let* ,(bindings) - (when ,params - (error 'format-error - :complaint - "Too many parameters, expected no more than ~D" - :arguments (list ,(length specs)) - :offset (caar ,params))) - ,@body)))) + `(let* ,(loop for (var default) in specs + collect `(,var (let* ((param-and-offset (pop ,params)) + (offset (car param-and-offset)) + (param (cdr param-and-offset))) + (case param + (:arg (or (next-arg offset) ,default)) + (:remaining (length args)) + ((nil) ,default) + (t param))))) + (when ,params + (error 'format-error + :complaint + "Too many parameters, expected no more than ~D" + :arguments (list ,(length specs)) + :offset (caar ,params))) + ,@body))) (defun %set-format-directive-expander (char fn) (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn) @@ -2235,30 +2244,28 @@ (def-format-directive #\/ (string start end colonp atsignp params) (let ((symbol (extract-user-function-name string start end))) - (collect ((param-names) (bindings)) - (dolist (param-and-offset params) - (let ((param (cdr param-and-offset))) - (let ((param-name (gensym))) - (param-names param-name) - (bindings `(,param-name - ,(case param - (:arg (expand-next-arg)) - (:remaining '(length args)) - (t param))))))) - `(let ,(bindings) - (,symbol stream ,(expand-next-arg) ,colonp ,atsignp - ,@(param-names)))))) + (loop for (_ . param) in params + for param-name = (gensym) + collect param-name into param-names + collect `(,param-name + ,(case param + (:arg (expand-next-arg)) + (:remaining '(length args)) + (t param))) + into bindings + finally (return + `(let ,bindings + (,symbol stream ,(expand-next-arg) ,colonp ,atsignp + ,@param-names)))))) (def-format-interpreter #\/ (string start end colonp atsignp params) - (let ((symbol (extract-user-function-name string start end))) - (collect ((args)) - (dolist (param-and-offset params) - (let ((param (cdr param-and-offset))) - (case param - (:arg (args (next-arg))) - (:remaining (args (length args))) - (t (args param))))) - (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args))))) + (let ((symbol (extract-user-function-name string start end)) + (fargs (loop for (_ . param) in params + collect (case param + (:arg (next-arg)) + (:remaining (length args)) + (t param))))) + (apply (fdefinition symbol) stream (next-arg) colonp atsignp fargs))) (defun extract-user-function-name (string start end) (let ((slash (position #\/ string :start start :end (1- end) @@ -2290,7 +2297,7 @@ package)))) ;;; Originally contributed by stassats May 24, 2016 -#+(or cclasp eclasp) +(let () ; FIXME: Use during build (define-compiler-macro format (&whole whole destination control-string &rest args &environment env) ;; Be especially nice about the common programmer error of @@ -2348,7 +2355,7 @@ (if (null ,dest-sym) (get-output-stream-string ,stream-sym) nil))))))) - whole))) + whole)))) ;;; Given a formatter form that doesn't do anything fancy with arguments, ;;; expand into some code to execute it with the given args. @@ -2383,6 +2390,33 @@ ;;;; Compile-time checking of format arguments and control string +;;; Conditions the FORMAT compiler macro signals if there's an argument count mismatch. +;;; CLHS 22.3.10.2 says that having too few arguments is undefined, so that's a warning, +;;; but having too many just means they're ignored, so that's a style-warning. +;;; (Alternately we could not complain at all.) +(define-condition format-warning-too-few-arguments (warning) + ((control-string :initarg :control :reader format-warning-control-string) + (expected :initarg :expected :reader format-warning-expected) + (observed :initarg :observed :reader format-warning-observed)) + (:report (lambda (condition stream) + (format stream + "Format string ~s expects at least ~d arguments,~@ + but is only provided ~d." + (format-warning-control-string condition) + (format-warning-expected condition) + (format-warning-observed condition))))) +(define-condition format-warning-too-many-arguments (style-warning) + ((control-string :initarg :control :reader format-warning-control-string) + (expected :initarg :expected :reader format-warning-expected) + (observed :initarg :observed :reader format-warning-observed)) + (:report (lambda (condition stream) + (format stream + "Format string ~s expects at most ~d arguments,~@ + but is provided ~d." + (format-warning-control-string condition) + (format-warning-expected condition) + (format-warning-observed condition))))) + ;;; ;;; Signal a warning if the given control string will not work with ;;; the given number of arguments. Assumes the control string's validity. diff --git a/src/lisp/kernel/lsp/foundation.lisp b/src/lisp/kernel/lsp/foundation.lisp deleted file mode 100644 index 4cd129a8e5..0000000000 --- a/src/lisp/kernel/lsp/foundation.lisp +++ /dev/null @@ -1,323 +0,0 @@ -;;(in-package :core) -(eval-when (eval compile load) (core:select-package :core)) - - -(if (boundp 'lambda-list-keywords) - nil ; don't redefine - (defconstant lambda-list-keywords - '(&ALLOW-OTHER-KEYS - &AUX &BODY &ENVIRONMENT &KEY - &OPTIONAL &REST - &VA-REST - &WHOLE) )) - - -;; Temporary check-type - everything is true -(fset 'check-type - #'(lambda (whole env) (declare (ignore whole env)) t) - t) - -(defun 1- (num) (- num 1)) -(defun 1+ (num) (+ num 1)) - - - -#|| -(si::fset 'and - #'(lambda (whole env) - (declare (ignore env)) - (let ((forms (cdr whole))) - (if (null forms) - t - (if (null (cdr forms)) - (car forms) - `(if ,(car forms) - (and ,@(cdr forms))))))) - t) - - -(si::fset 'or - #'(lambda (whole env) - (declare (ignore env)) - (let ((forms (cdr whole))) - (if (null forms) - nil - (if ( null (cdr forms)) - (car forms) - (let ((tmp (gensym))) - `(let ((,tmp ,(car forms))) - (if ,tmp - ,tmp - (or ,@(cdr forms))))))))) - t ) -||# - - - -(defun constantly (object) - #'(lambda (&rest arguments) (declare (ignore arguments)) object)) - - -(defun simple-program-error (e1 &rest args) - (apply 'error e1 args)) - -(defun simple-reader-error (stream e1 &rest args) - (declare (ignore stream)) - (apply 'error e1 args)) - - -(fset 'return #'(lambda (whole env) - (declare (ignore env)) - (let ((val (cadr whole))) - `(return-from nil ,val))) - t) - -#| --- loose this - its in evalmacros where ecl had it |# -#+clasp-min -(si::fset 'psetq #'(lambda (whole env) - (declare (ignore env)) - "Syntax: (psetq {var form}*) -Similar to SETQ, but evaluates all FORMs first, and then assigns each value to -the corresponding VAR. Returns NIL." - (let ((l (cdr whole)) - (forms nil) - (bindings nil)) - (block nil - (tagbody - top - (if (endp l) (return (list* 'LET* (nreverse bindings) (nreverse (cons nil forms))))) - (let ((sym (gensym))) - (push (list sym (cadr l)) bindings) - (push (list 'setq (car l) sym) forms)) - (setq l (cddr l)) - (go top))))) - t ) - - - -(fset 'cons-car #'(lambda (def env) - (declare (ignore env)) - `(car (the cons ,(cadr def)))) - t) -(fset 'cons-cdr #'(lambda (def env) - (declare (ignore env)) - `(cdr (the cons ,(cadr def)))) - t) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (select-package :ext)) - -(core:fset 'checked-value - #'(lambda (whole env) - (declare (ignore env)) - `(the ,@(cdr whole))) - t) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (core:select-package :core)) - - -(defvar *bytecodes-compiler* nil) - - - -;; -;; TODO: Rewrite this in C++ when you get the chance - a lot of stuff depends on it -;; "Concatenate LISTS by changing them." - -#+(or)(defun nconc (&rest lists) - (setq lists (do ((p lists (cdr p))) - ((or (car p) (null p)) p))) - (do* ((top (car lists)) - (splice top) - (here (cdr lists) (cdr here))) - ((null here) top) - (rplacd (last splice) (car here)) - (if (car here) - (setq splice (car here))))) - -;; -;; "Return true if OBJECT is the same as some tail of LIST, otherwise false." -;; -(defun tailp (object list) - (if (null list) - (null object) - (do ((list list (cdr list))) - ((atom (cdr list)) (or (eql object list) (eql object (cdr list)))) - (if (eql object list) - (return t))))) -;; -;; "Return a copy of LIST before the part which is the same as OBJECT." -;; - -;;; Definition from CLHS 14.2.30 (LDIFF, TAILP) -(defun ldiff (list object) - (unless (listp list) - (error 'simple-type-error - :format-control "Not a proper list or a dotted list.; ~s." - :format-arguments (list list) - :datum list - :expected-type 'list)) - (do ((list list (cdr list)) - (r '() (cons (car list) r))) - ((atom list) - (if (eql list object) (nreverse r) (nreconc r list))) - (when (eql object list) - (return (nreverse r))))) - - -;; in-package macro is re-defined in evalmacros.lisp -(si::fset 'in-package #'(lambda (whole env) - (declare (ignore env)) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (si::select-package ,(string (cadr whole))) - *package*)) - t) - - - - - - -(fset 'apply-key #'(lambda (w e) - (declare (ignore e)) - (let ((key (cadr w)) - (element (caddr w))) - `(if ,key - (funcall ,key ,element) - ,element))) - t) - -;; "Add ITEM to LIST unless it is already a member." -(defun adjoin (item list &key key (test #'eql) test-not) - (when test-not - (setq test (complement test-not))) - (if (member (apply-key key item) list :key key :test test) - list - (cons item list))) - - - - -;; -;; This is defined in ecl>>lsp>>load.d -;; It keeps track of the current source location -;; I should use it. -(defparameter *source-location* '("-no-file-" 0 . 0)) - - -;; Required by REGISTER-GLOBAL in cmp/cmpvar.lisp -(si::fset 'pushnew #'(lambda (w e) - (declare (ignore e)) - (let ((item (cadr w)) - (place (caddr w))) - `(setq ,place (adjoin ,item ,place)))) - t) - - -(defun hash-table-iterator (hash-table) - (let ((pairs (core:hash-table-pairs hash-table)) - (hash-index 0)) - (function (lambda () - (if (>= hash-index (length pairs)) - nil - (let* ((key (elt pairs hash-index)) - (val (elt pairs (incf hash-index)))) - (incf hash-index) - (values t key val))))))) - -#+(or) -(defun hash-table-iterator (hash-table) - (let ((number-of-buckets (hash-table-size hash-table)) - (hash 0)) - (labels ((advance-hash-table-iterator () - (declare (core:lambda-name advance-hash-table-iterator)) - #+(or)(core:fmt t "Starting with hash -> {}%N" hash) - (tagbody - top - (let ((entry (core:hash-table-bucket hash-table hash))) - #+(or)(core:fmt t " entry -> {}%N" entry) - (if (and (null entry) (< hash number-of-buckets)) - (progn - #+(or)(core:fmt t "Empty - incrementing hash%N") - (incf hash) - (if (< hash number-of-buckets) - (go top)) - #+(or)(core:fmt t "a-h-t-i returning NIL%N") - (return-from advance-hash-table-iterator nil)) - (progn - #+(or)(core:fmt t "expr was nil entry -> {}%N" entry) - (incf hash) - (return-from advance-hash-table-iterator entry))))))) - (function (lambda () - (if (>= hash number-of-buckets) - nil - (let ((entry (advance-hash-table-iterator))) - #+(or)(core:fmt t " returned entry -> {}%N" entry) - (if entry - (values t (car entry) (cdr entry)) - nil)))))))) - -; "Substitute data of ALIST for subtrees matching keys of ALIST." -(defun sublis (alist tree &key key (test #'eql) test-not) - (when test-not - (setq test (complement test-not))) - (labels ((sub (subtree) - (let ((assoc (assoc (apply-key key subtree) alist :test test))) - (cond - (assoc (cdr assoc)) - ((atom subtree) subtree) - (t (let ((car (sub (car subtree))) - (cdr (sub (cdr subtree)))) - (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) - subtree - (cons car cdr)))))))) - (sub tree))) -; "Substitute data of ALIST for subtrees matching keys of ALIST destructively." -(defun nsublis (alist tree &key key (test #'eql) test-not) - (when test-not - (setq test (complement test-not))) - (labels ((sub (subtree) - (let ((assoc (assoc (apply-key key subtree) alist :test test))) - (cond - (assoc (cdr assoc)) - ((atom subtree) subtree) - (t - (rplaca subtree (sub (car subtree))) - (rplacd subtree (sub (cdr subtree))) - subtree))))) - (sub tree))) - - -(defun invoke-unix-debugger () - (gdb "invoking unix debugger")) - - -(defun signal-type-error (datum expected-type) - (error 'type-error :datum datum :expected-type expected-type)) - -#+(or) -(defun inform (fmt &rest args) - (apply #'fmt t fmt args)) - -(in-package :cl) - -(defun warn (x &rest args) - (core:fmt t "WARN: {} {}%N" x args)) - - -(defun class-name (x) - (core:name-of-class x)) - -(defun invoke-debugger (cond) - (core:invoke-internal-debugger cond)) - -(export 'class-name) - -(in-package :core) - -(defun warn-or-ignore (x &rest args) - (declare (ignore x args)) - nil) -(export 'warn-or-ignore) - diff --git a/src/lisp/kernel/lsp/generated-encodings.lisp b/src/lisp/kernel/lsp/generated-encodings.lisp deleted file mode 100644 index c7bcd8cba4..0000000000 --- a/src/lisp/kernel/lsp/generated-encodings.lisp +++ /dev/null @@ -1,105 +0,0 @@ -(in-package :ext) - -;;; file is loaded first, than compiled -(defvar *encoding-data* nil) - -(defvar *encoding-cache* nil) - -(defun encoding-string-to-encoding-symbol (encoding-string) - (cond ((STRING= ":DOS-CP857" encoding-string) :DOS-CP857) - ((STRING= ":ISO-8859-9" encoding-string) :ISO-8859-9) - ((STRING= ":ISO-8859-8" encoding-string) :ISO-8859-8) - ((STRING= ":DOS-CP852" encoding-string) :DOS-CP852) - ((STRING= ":WINDOWS-CP949" encoding-string) :WINDOWS-CP949) - ((STRING= ":WINDOWS-CP932" encoding-string) :WINDOWS-CP932) - ((STRING= ":WINDOWS-CP1253" encoding-string) :WINDOWS-CP1253) - ((STRING= ":ISO-8859-14" encoding-string) :ISO-8859-14) - ((STRING= ":WINDOWS-CP950" encoding-string) :WINDOWS-CP950) - ((STRING= ":DOS-CP863" encoding-string) :DOS-CP863) - ((STRING= ":WINDOWS-CP1250" encoding-string) :WINDOWS-CP1250) - ((STRING= ":ISO-8859-3" encoding-string) :ISO-8859-3) - ((STRING= ":WINDOWS-CP1258" encoding-string) :WINDOWS-CP1258) - ((STRING= ":DOS-CP862" encoding-string) :DOS-CP862) - ((STRING= ":ISO-8859-2" encoding-string) :ISO-8859-2) - ((STRING= ":KOI8-R" encoding-string) :KOI8-R) - ((STRING= ":ISO-8859-6" encoding-string) :ISO-8859-6) - ((STRING= ":WINDOWS-CP1252" encoding-string) :WINDOWS-CP1252) - ((STRING= ":DOS-CP860" encoding-string) :DOS-CP860) - ((STRING= ":DOS-CP864" encoding-string) :DOS-CP864) - ((STRING= ":ISO-8859-5" encoding-string) :ISO-8859-5) - ((STRING= ":ISO-8859-4" encoding-string) :ISO-8859-4) - ((STRING= ":DOS-CP850" encoding-string) :DOS-CP850) - ((STRING= ":DOS-CP855" encoding-string) :DOS-CP855) - ((STRING= ":WINDOWS-CP1257" encoding-string) :WINDOWS-CP1257) - ((STRING= ":DOS-CP869" encoding-string) :DOS-CP869) - ((STRING= ":DOS-CP866" encoding-string) :DOS-CP866) - ((STRING= ":WINDOWS-CP1256" encoding-string) :WINDOWS-CP1256) - ((STRING= ":WINDOWS-CP1251" encoding-string) :WINDOWS-CP1251) - ((STRING= ":ISO-8859-10" encoding-string) :ISO-8859-10) - ((STRING= ":ISO-8859-13" encoding-string) :ISO-8859-13) - ((STRING= ":DOS-CP861" encoding-string) :DOS-CP861) - ((STRING= ":DOS-CP865" encoding-string) :DOS-CP865) - ((STRING= ":ISO-8859-7" encoding-string) :ISO-8859-7) - ((STRING= ":WINDOWS-CP1255" encoding-string) :WINDOWS-CP1255) - ((STRING= ":WINDOWS-CP936" encoding-string) :WINDOWS-CP936) - ((STRING= ":DOS-CP437" encoding-string) :DOS-CP437) - ((STRING= ":ISO-8859-15" encoding-string) :ISO-8859-15) - ((STRING= ":WINDOWS-CP1254" encoding-string) :WINDOWS-CP1254) - (T (break "")))) - -(defun generate-encoding-hashtable (encoding) - (let ((hash (gethash encoding *encoding-cache*))) - (if hash - hash - (let ((spec (assoc encoding *encoding-data*))) - (when spec - (let ((table (make-hash-table))) - (dolist (pair (rest spec)) - (let ((key (first pair)) - (value (rest pair))) - (setf (gethash key table) value) - (setf (gethash value table) key))) - (setf (gethash encoding *encoding-cache*) table) - table)))))) - -;;; format per line :ISO-8859-2;0;0; -(defun process-encodings-file () - (setq *encoding-data* nil *encoding-cache* (make-hash-table)) - (let ((file (translate-logical-pathname #P"sys:tools-for-build;encodingdata.txt")) - (old-encoding nil) - (alist nil)) - (with-open-file (stream file :element-type 'character :direction :input :external-format :utf-8) - (loop - (let ((line (read-line stream nil :end))) - (when (eq line :end) - ;;; store the last encodings - (when old-encoding - (push (cons old-encoding (nreverse alist)) *encoding-data*)) - - (return)) - (let* ((pos-semicolon-1 (position #\; line :test #'char=)) - (encoding-string (subseq line 0 pos-semicolon-1)) - (encoding (encoding-string-to-encoding-symbol encoding-string)) - (pos-semicolon-2 (position #\; line :test #'char= :start (1+ pos-semicolon-1))) - (index (parse-integer (subseq line (1+ pos-semicolon-1) pos-semicolon-2))) - (pos-semicolon-3 (position #\; line :test #'char= :start (1+ pos-semicolon-2))) - (char-code (parse-integer (subseq line (1+ pos-semicolon-2) pos-semicolon-3)))) - ;;; Read a line - (cond ((null old-encoding) - (setq old-encoding encoding) - (push (cons index (code-char char-code)) alist)) - ((not (eq old-encoding encoding)) - ;;; Store current data - (push (cons old-encoding (nreverse alist)) *encoding-data*) - (setq old-encoding encoding) - ;;; reset alist - (setq alist (list (cons index (code-char char-code))))) - (t - (push (cons index (code-char char-code)) alist))))))) - (mapcar #'generate-encoding-hashtable (mapcar #'first *encoding-data*))) - (values)) - -(eval-when (:compile-toplevel) - (process-encodings-file)) - -(setq *encoding-cache* #.*encoding-cache*) diff --git a/src/lisp/kernel/lsp/helpfile.lisp b/src/lisp/kernel/lsp/helpfile.lisp index 85c5b3c7e0..cd82814f92 100644 --- a/src/lisp/kernel/lsp/helpfile.lisp +++ b/src/lisp/kernel/lsp/helpfile.lisp @@ -67,7 +67,7 @@ (let ((record (rem-record-field (gethash object dict) key sub-key))) (if record - (funcall #'(setf gethash) record object dict) + (setf (gethash object dict) record) (remhash object dict)))))) (defun get-annotation (object key &optional (sub-key :all)) @@ -84,7 +84,6 @@ (push (cons (cdr key-sub-key) (cdr i)) output)))) (if (setq output (record-field record key sub-key)) (return output)))))))) -(export 'get-annotation) ;; "Args: (filespec &optional (merge nil)) ;;Saves the current hash table for documentation strings to the specificed file. @@ -100,7 +99,7 @@ (defun get-documentation (object doc-type) (when (functionp object) - (when (null (setq object (ext:compiled-function-name object))) + (when (null (setq object (core:function-name object))) (return-from get-documentation nil))) (if (and object (listp object) (si::valid-function-name-p object)) (get-annotation (second object) 'setf-documentation doc-type) diff --git a/src/lisp/kernel/lsp/iolib.lisp b/src/lisp/kernel/lsp/iolib.lisp index 9de369c1ce..01ac59baa9 100644 --- a/src/lisp/kernel/lsp/iolib.lisp +++ b/src/lisp/kernel/lsp/iolib.lisp @@ -291,6 +291,59 @@ is not given, ends the recording." ;(provide 'iolib) +(eval-when (:compile-toplevel :load-toplevel :execute) +(defvar +io-syntax-progv-list+ + (list + '( + *print-pprint-dispatch* #| See end of pprint.lisp |# + *print-array* + *print-base* + *print-case* + *print-circle* + *print-escape* + *print-gensym* + *print-length* + *print-level* + *print-lines* + *print-miser-width* + *print-pretty* + *print-radix* + *print-readably* + *print-right-margin* + *read-base* + *read-default-float-format* + *read-eval* + *read-suppress* + *readtable* + *package* + si::*sharp-eq-context* + si::*circle-counter*) ; + nil ;; *pprint-dispatch-table* + t ;; *print-array* + 10 ;; *print-base* + :upcase ;; *print-case* + nil ;; *print-circle* + t ;; *print-escape* + t ;; *print-gensym* + nil ;; *print-length* + nil ;; *print-level* + nil ;; *print-lines* + nil ;; *print-miser-width* + nil ;; *print-pretty* + nil ;; *print-radix* + t ;; *print-readably* + nil ;; *print-right-margin* + 10 ;; *read-base* + 'single-float ;; *read-default-float-format* + t ;; *read-eval* + nil ;; *read-suppress* + *readtable* ;; *readtable* + (find-package :CL-USER) ;; *package* + nil ;; si::*sharp-eq-context* + nil ;; si::*circle-counter* + )) +) ; eval-when + (defmacro with-standard-io-syntax (&body body) "Syntax: ({forms}*) The forms of the body are executed in a print environment that corresponds to @@ -298,8 +351,8 @@ the one defined in the ANSI standard. *print-base* is 10, *print-array* is t, *package* is \"CL-USER\", etc." (with-clean-symbols (%progv-list) `(let ((%progv-list +io-syntax-progv-list+)) - (progv (si:cons-car %progv-list) - (si:cons-cdr %progv-list) + (progv (car %progv-list) + (cdr %progv-list) ,@body)))) (defun print-unreadable-object-contents (object stream type identity body) @@ -333,8 +386,3 @@ the one defined in the ANSI standard. *print-base* is 10, *print-array* is t, (print-unreadable-object-contents object stream type identity body) (write-char #\> stream)))) nil) - -(defmacro print-unreadable-object ((object stream &key type identity) &body body) - `(%print-unreadable-object ,object ,stream ,type ,identity - ,(when body - `(lambda () ,@body)))) diff --git a/src/lisp/kernel/lsp/listlib.lisp b/src/lisp/kernel/lsp/listlib.lisp index 83f1c59552..569d7ee895 100644 --- a/src/lisp/kernel/lsp/listlib.lisp +++ b/src/lisp/kernel/lsp/listlib.lisp @@ -19,6 +19,66 @@ (funcall ,key ,element) ,element)) +(defun tailp (object list) + (if (null list) + (null object) + (do ((list list (cdr list))) + ((atom (cdr list)) (or (eql object list) (eql object (cdr list)))) + (if (eql object list) + (return t))))) + +;;; Definition from CLHS 14.2.30 (LDIFF, TAILP) +(defun ldiff (list object) + (unless (listp list) + (error 'simple-type-error + :format-control "Not a proper list or a dotted list.; ~s." + :format-arguments (list list) + :datum list + :expected-type 'list)) + (do ((list list (cdr list)) + (r '() (cons (car list) r))) + ((atom list) + (if (eql list object) (nreverse r) (nreconc r list))) + (when (eql object list) + (return (nreverse r))))) + +; "Substitute data of ALIST for subtrees matching keys of ALIST." +(defun sublis (alist tree &key key (test #'eql) test-not) + (when test-not + (setq test (complement test-not))) + (labels ((sub (subtree) + (let ((assoc (assoc (apply-key key subtree) alist :test test))) + (cond + (assoc (cdr assoc)) + ((atom subtree) subtree) + (t (let ((car (sub (car subtree))) + (cdr (sub (cdr subtree)))) + (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) + subtree + (cons car cdr)))))))) + (sub tree))) +; "Substitute data of ALIST for subtrees matching keys of ALIST destructively." +(defun nsublis (alist tree &key key (test #'eql) test-not) + (when test-not + (setq test (complement test-not))) + (labels ((sub (subtree) + (let ((assoc (assoc (apply-key key subtree) alist :test test))) + (cond + (assoc (cdr assoc)) + ((atom subtree) subtree) + (t + (rplaca subtree (sub (car subtree))) + (rplacd subtree (sub (cdr subtree))) + subtree))))) + (sub tree))) + +;; "Add ITEM to LIST unless it is already a member." +(defun adjoin (item list &key key (test #'eql) test-not) + (when test-not + (setq test (complement test-not))) + (if (member (apply-key key item) list :key key :test test) + list + (cons item list))) (defun union (list1 list2 &key test test-not key) "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not) diff --git a/src/lisp/kernel/lsp/loadltv.lisp b/src/lisp/kernel/lsp/loadltv.lisp deleted file mode 100644 index 22cc713c66..0000000000 --- a/src/lisp/kernel/lsp/loadltv.lisp +++ /dev/null @@ -1,746 +0,0 @@ -(defpackage #:loadltv - (:use #:cl) - (:export #:load-bytecode)) - -(in-package #:loadltv) - -;;; Read an unsigned n-byte integer from a ub8 stream, big-endian. -(defun read-ub (n stream) - ;; read-sequence might be better but bla bla consing - (loop with int = 0 - repeat n - do (setf int (logior (ash int 8) (read-byte stream))) - finally (return int))) - -(defun read-ub64 (stream) (read-ub 8 stream)) -(defun read-ub32 (stream) (read-ub 4 stream)) -(defun read-ub16 (stream) (read-ub 2 stream)) - -;;; Read a signed n-byte integer from a ub8 stream, big-endian. -(defun read-sb (n stream) - (let ((word (read-ub n stream)) - (nbits (* n 8))) - (declare (type (integer 1 64) nbits)) - ;; Read sign bit and make this negative if it's set. - ;; FIXME: Do something more efficient probably. - (- word (ash (ldb (byte 1 (1- nbits)) word) nbits)))) - -(defun read-sb64 (stream) (read-sb 8 stream)) -(defun read-sb32 (stream) (read-sb 4 stream)) -(defun read-sb16 (stream) (read-sb 2 stream)) -(defun read-sb8 (stream) (read-sb 1 stream)) - -(defconstant +magic+ #x8d7498b1) ; randomly chosen bytes. - -(defmacro verboseprint (message &rest args) - `(when *load-verbose* - (format t ,(concatenate 'string "~&; " message "~%") ,@args))) -(defmacro printprint (message &rest args) - `(when *load-print* - (format t ,(concatenate 'string "~&; " message "~%") ,@args))) - -(defvar *debug-loader* nil) - -(defmacro dbgprint (message &rest args) - `(when *debug-loader* - (format *error-output* ,(concatenate 'string "~&; " message "~%") ,@args))) - -(defun load-magic (stream) - (let ((magic (read-ub32 stream))) - (unless (= magic +magic+) - (error "~s is not a valid bytecode FASL: invalid magic identifier ~d" - stream magic)) - (dbgprint "Magic number matches: ~x" magic))) - -;; Bounds for major and minor version understood by this loader. -(defparameter *min-version* '(0 0)) -(defparameter *max-version* '(0 9)) - -(defun loadable-version-p (major minor) - (and - ;; minimum - (if (= major (first *min-version*)) - (>= minor (second *min-version*)) - (> major (first *min-version*))) - ;; maximum - (if (= major (first *max-version*)) - (<= minor (second *max-version*)) - (< major (first *max-version*))))) - -(defun load-version (stream) - (let ((major (read-ub16 stream)) (minor (read-ub16 stream))) - (unless (loadable-version-p major minor) - (error "Don't know how to load bytecode FASL format version ~d.~d -(This loader only understands ~d.~d to ~d.~d)" - major minor (first *min-version*) (second *min-version*) - (first *max-version*) (second *max-version*))) - (dbgprint "File version ~d.~d (loader accepts ~d.~d-~d.~d)" - major minor (first *min-version*) (second *min-version*) - (first *max-version*) (second *max-version*)) - (values major minor))) - -;; Major and minor version of the file being read. -(defvar *major*) -(defvar *minor*) - -;; Module of Lisp bytecode (only used for 0.1). -(defvar *module*) - -;; how many bytes are needed to represent an index? -(defvar *index-bytes*) - -(defun read-index (stream) - (ecase *index-bytes* - ((1) (read-byte stream)) - ((2) (read-ub16 stream)) - ((4) (read-ub32 stream)) - ((8) (read-ub64 stream)))) - -(defun read-mnemonic (stream) - (let* ((opcode (read-byte stream)) - (info (find opcode cmpref:+bytecode-ltv-ops+ :key #'second))) - (if info - (first info) - (error "BUG: Unknown opcode #x~x" opcode)))) - -;; Constants vector we're producing. -(defvar *constants*) -(declaim (type simple-vector *constants*)) - -;; Bit vector that is 1 only at indices that have been initialized. -(defvar *initflags*) -(declaim (type (simple-array bit (*)) *initflags*)) - -(define-condition loader-error (file-error) - () - (:default-initargs :pathname *load-pathname*)) - -(define-condition invalid-fasl (loader-error) ()) - -(define-condition uninitialized-constant (invalid-fasl) - ((%index :initarg :index :reader offending-index)) - (:report (lambda (condition stream) - (format stream "FASL ~s is invalid: -Tried to read constant #~d before initializing it" - (file-error-pathname condition) - (offending-index condition))))) - -(define-condition index-out-of-range (invalid-fasl) - ((%index :initarg :index :reader offending-index) - (%nobjs :initarg :nobjs :reader nobjs)) - (:report (lambda (condition stream) - (format stream "FASL ~s is invalid: -Tried to access constant #~d, but there are only ~d constants in the FASL." - (file-error-pathname condition) - (offending-index condition) (nobjs condition))))) - -(define-condition not-all-initialized (invalid-fasl) - ((%indices :initarg :indices :reader offending-indices)) - (:report (lambda (condition stream) - (format stream "FASL ~s is invalid: -Did not initialize constants~{ #~d~}" - (file-error-pathname condition) - (offending-indices condition))))) - -(defun check-initialization (flags) - (when (find 0 flags) - (error 'not-all-initialized - :indices (loop for i from 0 - for e across flags - when (zerop e) collect i))) - (values)) - -(defun constant (index) - (cond ((not (array-in-bounds-p *initflags* index)) - (error 'index-out-of-range :index index - :nobjs (length *initflags*))) - ((zerop (sbit *initflags* index)) - (error 'uninitialized-constant :index index)) - (t (aref *constants* index)))) - -(define-condition set-uninitialized-constant (invalid-fasl) - ((%index :initarg :index :reader offending-index)) - (:report (lambda (condition stream) - (format stream "FASL ~s is invalid: -Tried to define constant #~d, but it was already defined" - (file-error-pathname condition) - (offending-index condition))))) - -(defun (setf constant) (value index) - (cond ((not (array-in-bounds-p *initflags* index)) - (error 'index-out-of-range :index index - :nobjs (length *initflags*))) - ((zerop (sbit *initflags* index)) - (setf (aref *constants* index) value - (sbit *initflags* index) 1)) - (t (error 'set-uninitialized-constant :index index)))) - -;; Versions 0.0-0.2: Return how many bytes were read. -;; Versions 0.3-: Return value irrelevant. -(defgeneric %load-instruction (mnemonic stream)) - -(defmethod %load-instruction ((mnemonic (eql :nil)) stream) - (let ((index (read-index stream))) - (dbgprint " (nil ~d)" index) - (setf (constant index) nil)) - *index-bytes*) - -(defmethod %load-instruction ((mnemonic (eql :t)) stream) - (let ((index (read-index stream))) - (dbgprint " (t ~d)" index) - (setf (constant index) t)) - *index-bytes*) - -(defmethod %load-instruction ((mnemonic (eql :cons)) stream) - (let ((index (read-index stream))) - (dbgprint " (cons ~d)" index) - (setf (constant index) (cons nil nil))) - *index-bytes*) - -(defmethod %load-instruction ((mnemonic (eql :rplaca)) stream) - (let ((cons (read-index stream)) (value (read-index stream))) - (dbgprint " (rplaca ~d ~d)" cons value) - (setf (car (constant cons)) (constant value))) - (* 2 *index-bytes*)) - -(defmethod %load-instruction ((mnemonic (eql :rplacd)) stream) - (let ((cons (read-index stream)) (value (read-index stream))) - (dbgprint " (rplacd ~d ~d)" cons value) - (setf (cdr (constant cons)) (constant value))) - (* 2 *index-bytes*)) - -(defmacro read-sub-byte (array stream nbits) - (let ((perbyte (floor 8 nbits)) - (a (gensym "ARRAY")) (s (gensym "STREAM"))) - `(let* ((,a ,array) (,s ,stream) - (total-size (array-total-size ,a))) - (multiple-value-bind (full-bytes remainder) (floor total-size 8) - (loop for byteindex below full-bytes - for index = (* ,perbyte byteindex) - for byte = (read-byte ,s) - do ,@(loop for j below perbyte - for bit-index - = (* nbits (- perbyte j 1)) - for bits = `(ldb (byte ,nbits ,bit-index) - byte) - for arrindex = `(+ index ,j) - collect `(setf (row-major-aref array ,arrindex) ,bits))) - ;; write remainder - (let* ((index (* ,perbyte full-bytes)) - (byte (read-byte ,s))) - (loop for j below remainder - for bit-index = (* ,nbits (- ,perbyte j 1)) - for bits = (ldb (byte ,nbits bit-index) byte) - do (setf (row-major-aref ,a (+ index j)) bits))))))) - -(defmethod %load-instruction ((mnemonic (eql :make-array)) stream) - (if (<= *minor* 2) - (let ((index (read-index stream)) (rank (read-byte stream))) - (dbgprint " (make-array ~d ~d)" index rank) - (let ((dimensions (loop repeat rank collect (read-ub16 stream)))) - (dbgprint " dimensions ~a" dimensions) - (setf (constant index) (make-array dimensions))) - (+ *index-bytes* 1 (* rank 2))) - (let* ((index (read-index stream)) (uaet-code (read-byte stream)) - (uaet (decode-uaet uaet-code)) - (packing-code (read-byte stream)) - (packing-type (decode-packing packing-code)) - (rank (read-byte stream)) - (dimensions (loop repeat rank collect (read-ub16 stream))) - (array (make-array dimensions :element-type uaet))) - (dbgprint " (make-array ~d ~x ~x ~d)" index uaet-code packing-code rank) - (dbgprint " dimensions ~a" dimensions) - (setf (constant index) array) - (macrolet ((undump (form) - `(loop for i below (array-total-size array) - for elem = ,form - do (setf (row-major-aref array i) elem)))) - (cond ((equal packing-type 'nil)) - ((equal packing-type 'base-char) - (undump (code-char (read-byte stream)))) - ((equal packing-type 'character) - (undump (code-char (read-ub32 stream)))) - ((equal packing-type 'single-float) - (undump (ext:bits-to-single-float (read-ub32 stream)))) - ((equal packing-type 'double-float) - (undump (ext:bits-to-double-float (read-ub64 stream)))) - ((equal packing-type '(complex single-float)) - (undump - (complex (ext:bits-to-single-float (read-ub32 stream)) - (ext:bits-to-single-float (read-ub32 stream))))) - ((equal packing-type '(complex double-float)) - (undump - (complex (ext:bits-to-double-float (read-ub64 stream)) - (ext:bits-to-double-float (read-ub64 stream))))) - ((equal packing-type 'bit) (read-sub-byte array stream 1)) - ((equal packing-type '(unsigned-byte 2)) - (read-sub-byte array stream 2)) - ((equal packing-type '(unsigned-byte 4)) - (read-sub-byte array stream 4)) - ((equal packing-type '(unsigned-byte 8)) - (read-sequence array stream)) - ((equal packing-type '(unsigned-byte 16)) - (undump (read-ub16 stream))) - ((equal packing-type '(unsigned-byte 32)) - (undump (read-ub32 stream))) - ((equal packing-type '(unsigned-byte 64)) - (undump (read-ub64 stream))) - ((equal packing-type '(signed-byte 8)) - (undump (read-sb8 stream))) - ((equal packing-type '(signed-byte 16)) - (undump (read-sb16 stream))) - ((equal packing-type '(signed-byte 32)) - (undump (read-sb32 stream))) - ((equal packing-type '(signed-byte 64)) - (undump (read-sb64 stream))) - ;; TODO: signed bytes - ((equal packing-type 't)) ; setf-aref takes care of it - (t (error "BUG: Unknown packing-type ~s" packing-type))))))) - -(defmethod %load-instruction ((mnemonic (eql :setf-row-major-aref)) stream) - (let ((index (read-index stream)) (aindex (read-ub16 stream)) - (value (read-index stream))) - (dbgprint " ((setf row-major-aref) ~d ~d ~d" index aindex value) - (setf (row-major-aref (constant index) aindex) - (constant value))) - (+ *index-bytes* 2 *index-bytes*)) - -(defmethod %load-instruction ((mnemonic (eql :make-hash-table)) stream) - (let ((index (read-index stream))) - (dbgprint " (make-hash-table ~d)" index) - (let* ((testcode (read-byte stream)) - (test (ecase testcode - ((#b00) 'eq) - ((#b01) 'eql) - ((#b10) 'equal) - ((#b11) 'equalp))) - (count (read-ub16 stream))) - (dbgprint " test = ~a, count = ~d" test count) - (setf (constant index) (make-hash-table :test test :size count)))) - (+ *index-bytes* 1 2)) - -(defmethod %load-instruction ((mnemonic (eql :setf-gethash)) stream) - (let ((htind (read-index stream)) - (keyind (read-index stream)) (valind (read-index stream))) - (dbgprint " ((setf gethash) ~d ~d ~d)" htind keyind valind) - (setf (gethash (constant keyind) (constant htind)) - (constant valind))) - (+ *index-bytes* *index-bytes* *index-bytes*)) - -(defmethod %load-instruction ((mnemonic (eql :make-sb64)) stream) - (let ((index (read-index stream)) (sb64 (read-sb64 stream))) - (dbgprint " (make-sb64 ~d ~d)" index sb64) - (setf (constant index) sb64)) - (+ *index-bytes* 8)) - -(defmethod %load-instruction ((mnemonic (eql :find-package)) stream) - (let ((index (read-index stream)) (name (read-index stream))) - (dbgprint " (find-package ~d ~d)" index name) - (setf (constant index) (find-package (constant name)))) - (+ *index-bytes* *index-bytes*)) - -(defmethod %load-instruction ((mnemonic (eql :make-bignum)) stream) - (let ((index (read-index stream)) (ssize (read-sb64 stream))) - (dbgprint " (make-bignum ~d ~d)" index ssize) - (setf (constant index) - (let ((result 0) (size (abs ssize)) (negp (minusp ssize))) - (loop repeat size - do (let ((word (read-ub64 stream))) - (dbgprint "#x~8,'0x" word) - (setf result (logior (ash result 64) word))) - finally (return (if negp (- result) result))))) - (+ *index-bytes* 8 (* 8 (abs ssize))))) - -(defmethod %load-instruction ((mnemonic (eql :make-binary32)) stream) - (let ((index (read-index stream)) (bits (read-ub32 stream))) - (dbgprint " (make-single-float ~d #x~4,'0x)" index bits) - (setf (constant index) (ext:bits-to-single-float bits))) - (+ *index-bytes* 4)) - -(defmethod %load-instruction ((mnemonic (eql :make-binary64)) stream) - (let ((index (read-index stream)) (bits (read-ub64 stream))) - (dbgprint " (make-double-float ~d #x~8,'0x)" index bits) - (setf (constant index) (ext:bits-to-double-float bits))) - (+ *index-bytes* 8)) - -(defmethod %load-instruction ((mnemonic (eql :ratio)) stream) - (let ((index (read-index stream)) - (numi (read-index stream)) (deni (read-index stream))) - (dbgprint " (ratio ~d ~d ~d)" index numi deni) - (setf (constant index) - ;; a little inefficient. - (/ (constant numi) (constant deni)))) - (* 3 *index-bytes*)) - -(defmethod %load-instruction ((mnemonic (eql :complex)) stream) - (let ((index (read-index stream)) - (reali (read-index stream)) (imagi (read-index stream))) - (dbgprint " (complex ~d ~d ~d)" index reali imagi) - (setf (constant index) - (complex (constant reali) (constant imagi)))) - (* 3 *index-bytes*)) - -(defmethod %load-instruction ((mnemonic (eql :make-symbol)) stream) - (let ((index (read-index stream)) - (namei (read-index stream))) - (dbgprint " (make-symbol ~d ~d)" index namei) - (setf (constant index) (make-symbol (constant namei)))) - (+ *index-bytes* *index-bytes*)) - -(defmethod %load-instruction ((mnemonic (eql :intern)) stream) - (let ((index (read-index stream)) - (package (read-index stream)) (name (read-index stream))) - (dbgprint " (intern ~d ~d ~d)" index package name) - (setf (constant index) - (intern (constant name) (constant package)))) - (+ *index-bytes* *index-bytes* *index-bytes*)) - -(defmethod %load-instruction ((mnemonic (eql :make-character)) stream) - (let* ((index (read-index stream)) (code (read-ub32 stream)) - (char (code-char code))) - (dbgprint " (make-character ~d #x~x) ; ~c" index code char) - (setf (constant index) char)) - (+ *index-bytes* 4)) - -(defmethod %load-instruction ((mnemonic (eql :make-pathname)) stream) - (let ((index (read-index stream)) - (hosti (read-index stream)) (devicei (read-index stream)) - (directoryi (read-index stream)) (namei (read-index stream)) - (typei (read-index stream)) (versioni (read-index stream))) - (dbgprint " (make-pathname ~d ~d ~d ~d ~d ~d ~d)" - index hosti devicei directoryi namei typei versioni) - (setf (constant index) - (make-pathname :host (constant hosti) - :device (constant devicei) - :directory (constant directoryi) - :name (constant namei) - :type (constant typei) - :version (constant versioni)))) - (* *index-bytes* 7)) - -(defvar +array-packing-infos+ - '((nil #b00000000) - (base-char #b10000000) - (character #b11000000) - ;;(short-float #b10100000) ; i.e. binary16 - (single-float #b00100000) ; binary32 - (double-float #b01100000) ; binary64 - ;;(long-float #b11100000) ; binary128? - ;;((complex short...) #b10110000) - ((complex single-float) #b00110000) - ((complex double-float) #b01110000) - ;;((complex long...) #b11110000) - (bit #b00000001) ; (2^(code-1)) bits - ((unsigned-byte 2) #b00000010) - ((unsigned-byte 4) #b00000011) - ((unsigned-byte 8) #b00000100) - ((unsigned-byte 16) #b00000101) - ((unsigned-byte 32) #b00000110) - ((unsigned-byte 64) #b00000111) - ;;((unsigned-byte 128) ??) - ((signed-byte 8) #b10000100) - ((signed-byte 16) #b10000101) - ((signed-byte 32) #b10000110) - ((signed-byte 64) #b10000111) - (t #b11111111))) - -(defun decode-uaet (uaet-code) - (or (first (find uaet-code +array-packing-infos+ :key #'second)) - (error "BUG: Unknown UAET code ~x" uaet-code))) - -(defun decode-packing (code) (decode-uaet code)) ; same for now - -(defmethod %load-instruction ((mnemonic (eql :make-specialized-array)) stream) - (let ((index (read-index stream)) - (rank (read-byte stream))) - (dbgprint " (make-specialized-array ~d ~d)" index rank) - (let* ((dims (loop repeat rank collect (read-ub16 stream))) - (total-size (reduce #'* dims)) - (etype-code (read-byte stream)) - (etype (decode-uaet etype-code)) - (arr (make-array dims :element-type etype))) - (dbgprint " dimensions ~a" dims) - (dbgprint " element type ~a" etype) - (setf (constant index) arr) - (ecase etype - (base-char - (dotimes (i total-size) - (setf (row-major-aref arr i) (code-char (read-byte stream))))) - (character - (dotimes (i total-size) - (setf (row-major-aref arr i) (code-char (read-ub32 stream)))))) - (dbgprint " array ~s" arr) - (+ *index-bytes* 1 (* rank 2) - 1 (* (ecase etype (base-char 1) (character 4)) total-size))))) - -(defmethod %load-instruction ((mnemonic (eql :make-bytecode-function)) stream) - (let ((index (read-index stream)) - (entry-point (read-ub32 stream)) - (size (if (and (= *major* 0) (< *minor* 8)) 0 (read-ub32 stream))) - (nlocals (read-ub16 stream)) - (nclosed (read-ub16 stream)) - (modulei (when (>= *minor* 2) (read-index stream))) - (namei (read-index stream)) - (lambda-listi (read-index stream)) - (docstringi (read-index stream))) - (dbgprint " (make-bytecode-function ~d ~d ~d ~d~@[ ~d~] ~d ~d ~d)" - index entry-point nlocals nclosed - modulei namei lambda-listi docstringi) - (let ((module (if (<= *minor* 1) *module* (constant modulei))) - (name (constant namei)) - (lambda-list (constant lambda-listi)) - (docstring (constant docstringi)) - ;; See 'source-pos-info attribute for one way to do this. - (source-pathname nil) - (lineno -1) (column -1) (filepos -1)) - (dbgprint " entry-point = ~d, nlocals = ~d, nclosed = ~d" - entry-point nlocals nclosed) - (dbgprint " module-index = ~d" modulei) - (dbgprint " name = ~a, lambda-list = ~a, docstring = ~a" - name lambda-list docstring) - (setf (constant index) - (core:bytecode-simple-fun/make - (core:function-description/make - :function-name name :lambda-list lambda-list :docstring docstring - :source-pathname source-pathname - :lineno lineno :column column :filepos filepos) - module nlocals nclosed entry-point size - (cmp:compile-trampoline name))))) - (+ *index-bytes* 4 2 2 *index-bytes* *index-bytes* *index-bytes*)) - -(defmethod %load-instruction ((mnemonic (eql :make-bytecode-module)) stream) - (let* ((index (read-index stream)) - (len (read-ub32 stream)) - (bytecode (make-array len :element-type '(unsigned-byte 8))) - (module (core:bytecode-module/make bytecode))) - (dbgprint " (make-bytecode-module ~d ~d)" index len) - (read-sequence bytecode stream) - (dbgprint " bytecode:~{ ~2,'0x~}" (coerce bytecode 'list)) - (setf (constant index) module) - ;; pointless but harmless if followed by a setf-literals instruction. - (core:bytecode-module/setf-literals module *constants*) - (+ *index-bytes* 4 len))) - -(defmethod %load-instruction ((mnemonic (eql :setf-literals)) stream) - (if (and (= *major* 0) (<= *minor* 6)) - (let ((modi (read-index stream)) (litsi (read-index stream))) - (dbgprint " (setf-literals ~d ~d)" modi litsi) - (core:bytecode-module/setf-literals - (constant modi) (constant litsi))) - (let* ((mod (constant (read-index stream))) (nlits (read-ub16 stream)) - (lits (make-array nlits))) - (loop for i below nlits - do (setf (aref lits i) (constant (read-index stream)))) - (dbgprint " (setf-literals ~s ~s)" mod lits) - (core:bytecode-module/setf-literals mod lits)))) - -(defmethod %load-instruction ((mnemonic (eql :fdefinition)) stream) - (let ((find (read-index stream)) (namei (read-index stream))) - (dbgprint " (fdefinition ~d ~d)" find namei) - (setf (constant find) (fdefinition (constant namei))))) - -(defmethod %load-instruction ((mnemonic (eql :funcall-create)) stream) - (let ((index (read-index stream)) (funi (read-index stream)) - (args (if (and (= *major* 0) (<= *minor* 4)) - () - (loop repeat (read-ub16 stream) - collect (read-index stream))))) - (dbgprint " (funcall-create ~d ~d~{ ~d~})" index funi args) - (setf (constant index) - (apply (constant funi) (mapcar #'constant args)))) - (* 2 *index-bytes*)) - -(defmethod %load-instruction ((mnemonic (eql :funcall-initialize)) stream) - (let ((funi (read-index stream)) - (args (if (and (= *major* 0) (<= *minor* 4)) - () - (loop repeat (read-ub16 stream) - collect (read-index stream))))) - (dbgprint " (funcall-initialize ~d~{ ~d~})" funi args) - (dbgprint " calling ~s" (constant funi)) - (apply (constant funi) (mapcar #'constant args))) - *index-bytes*) - -(defmethod %load-instruction ((mnemonic (eql :find-class)) stream) - (let ((index (read-index stream)) (cni (read-index stream))) - (dbgprint " (find-class ~d ~d)" index cni) - (setf (constant index) (find-class (constant cni))))) - -(defmethod %load-instruction ((mnemonic (eql :init-object-array)) stream) - (check-initialization *initflags*) - (let ((nobjs (read-ub64 stream))) - (dbgprint " (init-object-array ~d)" nobjs) - (setf *index-bytes* (max 1 (ash 1 (1- (ceiling (integer-length nobjs) 8)))) - *constants* (make-array nobjs) - *initflags* (make-array nobjs :element-type 'bit :initial-element 0)))) - -;; Return how many bytes were read (for early versions, anyway) -(defun load-instruction (stream) - (if (<= *minor* 2) - (1+ (%load-instruction (read-mnemonic stream) stream)) - (%load-instruction (read-mnemonic stream) stream))) - -(defparameter *attributes* - (let ((ht (make-hash-table :test #'equal))) - #+clasp (setf (gethash "clasp:source-pos-info" ht) 'source-pos-info) - #+clasp (setf (gethash "clasp:module-debug-info" ht) 'module-debug-info) - ht)) - -(defgeneric %load-attribute (mnemonic stream)) - -(defmethod %load-attribute ((mnemonic string) stream) - (let ((nbytes (read-ub32 stream))) - (dbgprint " (unknown-attribute ~s ~d)" mnemonic nbytes) - ;; FIXME: would file-position be better? Is it guaranteed to work here? - (loop repeat nbytes do (read-byte stream)))) - -#+clasp -(defmethod %load-attribute ((mnemonic (eql :source-pos-info)) stream) - ;; read and ignore nbytes. - (read-ub32 stream) - ;; now the actual code. - (let ((function (constant (read-index stream))) - (path (constant (read-index stream))) - (lineno (read-ub64 stream)) - (column (read-ub64 stream)) - (filepos (read-ub64 stream))) - (dbgprint " (source-pos-info ~s ~s ~d ~d ~d)" - function path lineno column filepos) - (core:function/set-source-pos-info function path filepos lineno column))) - -(defun read-debug-bindings (stream) - (let ((nbinds (read-ub16 stream))) - (loop repeat nbinds - collect (let ((name (constant (read-index stream))) - (flag (read-byte stream)) - (framei (read-ub16 stream))) - (cons name (ecase flag - (0 framei) - (1 (list framei)))))))) - -#+clasp -(defmethod %load-attribute ((mnemonic (eql :module-debug-info)) stream) - (read-ub32 stream) ; ignore size - (let* ((mod (constant (read-index stream))) - (ncfunctions (read-ub16 stream)) - (cfunctions (loop repeat ncfunctions - collect (constant (read-index stream)))) - (nvars (read-ub32 stream)) - (vars (loop repeat nvars - collect (let* ((start (read-ub32 stream)) - (end (read-ub32 stream)) - (binds (read-debug-bindings stream))) - (core:bytecode-debug-vars/make start end binds))))) - (core:bytecode-module/setf-debug-info - mod - (concatenate 'simple-vector cfunctions vars)))) - -(defun load-attribute (stream) - (let ((aname (constant (read-index stream)))) - (%load-attribute (or (gethash aname *attributes*) aname) stream))) - -(defmethod %load-instruction ((mnemonic (eql :attribute)) stream) - (load-attribute stream)) - -;; TODO: Check that the FASL actually defines all of the constants. -;; Make sure it defines them in order, i.e. not reading from uninitialized -;; portions of the vector. -;; Shrink the constants after loading. - -(defun load-bytecode-module (constants stream) - (dbgprint "Loading Lisp bytecode") - (let ((nbytes (read-ub32 stream))) - (dbgprint "File reports ~d bytes." nbytes) - (let ((bytes (make-array nbytes :element-type '(unsigned-byte 8)))) - (read-sequence bytes stream) - ;;(core:bytecode-module/setf-bytecode *module* bytes) - (core:bytecode-module/setf-literals *module* constants) - (dbgprint "Loaded Lisp bytecode module") - *module*))) - -(defun load-toplevels (stream) - (dbgprint "Loading toplevels") - (let ((ntops (read-ub32 stream))) - (dbgprint "File reports ~d toplevel forms." ntops) - (loop repeat ntops - for i from 0 - for index = (read-index stream) - for tl = (constant index) - do (dbgprint "Calling toplevel #~d" i) - (funcall tl)))) - -(defun load-bytecode-stream (stream - &key ((:verbose *load-verbose*) *load-verbose*)) - (load-magic stream) - (multiple-value-bind (*major* *minor*) (load-version stream) - (let* ((nobjs (if (and (= *major* 0) (<= *minor* 8)) - (read-ub64 stream) - 0)) - (nfbytes (when (<= 1 *minor* 2) (read-ub64 stream))) - (ninsts (when (>= *minor* 3) (read-ub64 stream))) - ;; Next power of two. - (*index-bytes* (max 1 (ash 1 (1- (ceiling (integer-length nobjs) 8))))) - (*module* (when (= *minor* 1) (core:bytecode-module/make))) - (*constants* (make-array nobjs)) - (*initflags* (make-array nobjs - :element-type 'bit :initial-element 0))) - (dbgprint "File reports ~d objects. Index length = ~d bytes." - nobjs *index-bytes*) - (dbgprint "Executing FASL bytecode") - (cond ((<= 1 *minor* 2) - (dbgprint "File reports bytecode is ~d bytes" nfbytes)) - ((>= *minor* 3) - (dbgprint "File reports ~d instructions" ninsts))) - ;; CLHS is sort of written like LISTEN only works on character streams, - ;; but that would be pretty pointless. Clasp and SBCL at least allow it - ;; on byte streams. - (cond ((<= 1 *minor* 2) - (loop for bytes-read = 0 - then (+ bytes-read (load-instruction stream)) - do (dbgprint " read ~d bytes" bytes-read) - while (< bytes-read nfbytes) - finally - (unless (= bytes-read nfbytes) - (error "Mismatch in bytecode between reported length ~d and actual length ~d" - nfbytes bytes-read)))) - ((>= *minor* 3) - (loop repeat ninsts - do (load-instruction stream)) - (when (<= 4 *minor* 5) - (let ((nattrs (read-ub32 stream))) - (dbgprint "File reports ~d attributes" nattrs) - (loop repeat nattrs - do (load-attribute stream)))) - (when (listen stream) - (error "Bytecode continues beyond end of instructions")))) - (when (= *minor* 1) - (load-bytecode-module *constants* stream) - (load-toplevels stream)) - (check-initialization *initflags*))) - (values)) - -(defun load-bytecode (filespec - &key - ((:verbose *load-verbose*) *load-verbose*) - ((:print *load-print*) *load-print*) - ((:debug *debug-loader*) *debug-loader*) - (if-does-not-exist :error) - (external-format :default)) - (let ((*load-pathname* (pathname (merge-pathnames filespec)))) - (with-open-file (input filespec :element-type '(unsigned-byte 8) - :if-does-not-exist if-does-not-exist - :external-format external-format) - ;; check for :if-does-not-exist nil failure - (unless input (return-from load-bytecode nil)) - (verboseprint "Loading ~a as FASL" filespec) - (load-bytecode-stream input) - t))) - -#+clasp -(defun load-hook (source &optional verbose print - (external-format :default)) - (load-bytecode source :verbose verbose :print print - :external-format external-format)) - -#+(or) -(pushnew '("fasl" . load-hook) core:*load-hooks* :test #'equal) diff --git a/src/lisp/kernel/lsp/loop2.lisp b/src/lisp/kernel/lsp/loop2.lisp deleted file mode 100644 index f0913a198e..0000000000 --- a/src/lisp/kernel/lsp/loop2.lisp +++ /dev/null @@ -1,2060 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*- -;;;; -;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase:T -*- -;;;> -;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology. -;;;> All Rights Reserved. -;;;> -;;;> Permission to use, copy, modify and distribute this software and its -;;;> documentation for any purpose and without fee is hereby granted, -;;;> provided that the M.I.T. copyright notice appear in all copies and that -;;;> both that copyright notice and this permission notice appear in -;;;> supporting documentation. The names "M.I.T." and "Massachusetts -;;;> Institute of Technology" may not be used in advertising or publicity -;;;> pertaining to distribution of the software without specific, written -;;;> prior permission. Notice must be given in supporting documentation that -;;;> copying distribution is by permission of M.I.T. M.I.T. makes no -;;;> representations about the suitability of this software for any purpose. -;;;> It is provided "as is" without express or implied warranty. -;;;> -;;;> Massachusetts Institute of Technology -;;;> 77 Massachusetts Avenue -;;;> Cambridge, Massachusetts 02139 -;;;> United States of America -;;;> +1-617-253-1000 -;;;> -;;;> Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, Inc. -;;;> All Rights Reserved. -;;;> -;;;> Permission to use, copy, modify and distribute this software and its -;;;> documentation for any purpose and without fee is hereby granted, -;;;> provided that the Symbolics copyright notice appear in all copies and -;;;> that both that copyright notice and this permission notice appear in -;;;> supporting documentation. The name "Symbolics" may not be used in -;;;> advertising or publicity pertaining to distribution of the software -;;;> without specific, written prior permission. Notice must be given in -;;;> supporting documentation that copying distribution is by permission of -;;;> Symbolics. Symbolics makes no representations about the suitability of -;;;> this software for any purpose. It is provided "as is" without express -;;;> or implied warranty. -;;;> -;;;> Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera, -;;;> and Zetalisp are registered trademarks of Symbolics, Inc. -;;;> -;;;> Symbolics, Inc. -;;;> 8 New England Executive Park, East -;;;> Burlington, Massachusetts 01803 -;;;> United States of America -;;;> +1-617-221-1000 - -;; $aclHeader: loop.cl,v 1.5 91/12/04 01:13:48 cox acl4_1 $ - -#+staging -(progn - -;;;; LOOP Iteration Macro - -(in-package "SYSTEM") - -;;; Technology. -;;; -;;; The LOOP iteration macro is one of a number of pieces of code -;;; originally developed at MIT for which free distribution has been -;;; permitted, as long as the code is not sold for profit, and as long -;;; as notification of MIT's interest in the code is preserved. -;;; -;;; This version of LOOP, which is almost entirely rewritten both as -;;; clean-up and to conform with the ANSI Lisp LOOP standard, started -;;; life as MIT LOOP version 829 (which was a part of NIL, possibly -;;; never released). -;;; -;;; A "light revision" was performed by me (Glenn Burke) while at -;;; Palladian Software in April 1986, to make the code run in Common -;;; Lisp. This revision was informally distributed to a number of -;;; people, and was sort of the "MIT" version of LOOP for running in -;;; Common Lisp. -;;; -;;; A later more drastic revision was performed at Palladian perhaps a -;;; year later. This version was more thoroughly Common Lisp in style, -;;; with a few miscellaneous internal improvements and extensions. I -;;; have lost track of this source, apparently never having moved it to -;;; the MIT distribution point. I do not remember if it was ever -;;; distributed. -;;; -;;; This revision for the ANSI standard is based on the code of my April -;;; 1986 version, with almost everything redesigned and/or rewritten. - - -;;; The design of this LOOP is intended to permit, using mostly the same -;;; kernel of code, up to three different "loop" macros: -;;; -;;; (1) The unextended, unextensible ANSI standard LOOP; -;;; -;;; (2) A clean "superset" extension of the ANSI LOOP which provides -;;; functionality similar to that of the old LOOP, but "in the style of" -;;; the ANSI LOOP. For instance, user-definable iteration paths, with a -;;; somewhat cleaned-up interface. -;;; -;;; (3) Extensions provided in another file which can make this LOOP -;;; kernel behave largely compatibly with the Genera-vintage LOOP macro, -;;; with only a small addition of code (instead of two whole, separate, -;;; LOOP macros). -;;; -;;; Each of the above three LOOP variations can coexist in the same LISP -;;; environment. -;;; - - -;;;; Miscellaneous Environment Things - -(defmacro loop-unsafe (&rest x) - ;; This is mostly in so as to elide type checks. - ;; See cleavir/policy.lisp for details of when Clasp inserts type checks. - `(locally (declare (optimize (safety 0))) ,@x)) - -(defun loop-optimization-quantities (env) - ;; The ANSI conditionalization here is for those lisps that implement - ;; DECLARATION-INFORMATION (from cleanup SYNTACTIC-ENVIRONMENT-ACCESS). - ;; It is really commentary on how this code could be written. I don't - ;; actually expect there to be an ANSI #+-conditional -- it should be - ;; replaced with the appropriate conditional name for your - ;; implementation/dialect. - (declare #-ANSI (ignore env) - #+Genera (values speed space safety compilation-speed debug)) - #+ANSI (let ((stuff (declaration-information 'optimize env))) - (values (or (cdr (assoc 'speed stuff)) 1) - (or (cdr (assoc 'space stuff)) 1) - (or (cdr (assoc 'safety stuff)) 1) - (or (cdr (assoc 'compilation-speed stuff)) 1) - (or (cdr (assoc 'debug stuff)) 1))) - #+CLOE-Runtime (values compiler::time compiler::space - compiler::safety compiler::compilation-speed 1) - #-(or ANSI CLOE-Runtime) (values 1 1 1 1 1)) - - -;;; The following form takes a list of variables and a form which presumably -;;; references those variables, and wraps it somehow so that the compiler does not -;;; consider those variables have been referenced. The intent of this is that -;;; iteration variables can be flagged as unused by the compiler, e.g. I in -;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage -;;; of it is "invisible" or "not to be considered". -;;;We implicitly assume that a setq does not count as a reference. That is, the -;;; kind of form generated for the above loop construct to step I, simplified, is -;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))). -(defun hide-variable-references (variable-list form) - (declare #-Genera (ignore variable-list)) - #+Genera (if variable-list `(compiler:invisible-references ,variable-list ,form) form) - #-Genera form) - - -;;; The following function takes a flag, a variable, and a form which presumably -;;; references that variable, and wraps it somehow so that the compiler does not -;;; consider that variable to have been referenced. The intent of this is that -;;; iteration variables can be flagged as unused by the compiler, e.g. I in -;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage -;;; of it is "invisible" or "not to be considered". -;;;We implicitly assume that a setq does not count as a reference. That is, the -;;; kind of form generated for the above loop construct to step I, simplified, is -;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))). -;;;Certain cases require that the "invisibility" of the reference be conditional upon -;;; something. This occurs in cases of "named" variables (the USING clause). For instance, -;;; we want IDX in (LOOP FOR E BEING THE VECTOR-ELEMENTS OF V USING (INDEX IDX) ...) -;;; to be "invisible" when it is stepped, so that the user gets informed if IDX is -;;; not referenced. However, if no USING clause is present, we definitely do not -;;; want to be informed that some random gensym is not used. -;;;It is easier for the caller to do this conditionally by passing a flag (which -;;; happens to be the second value of NAMED-VARIABLE, q.v.) to this function than -;;; for all callers to contain the conditional invisibility construction. -(defun hide-variable-reference (really-hide variable form) - (declare #-Genera (ignore really-hide variable)) - #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns - `(compiler:invisible-references (,variable) ,form) - form) - #-Genera form) - - -;;;; List Collection Macrology - - -(defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var) - &body body) - (let ((l (and user-head-var (list (list user-head-var nil))))) - `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l) - ,@body))) - - -(defmacro loop-collect-rplacd (&environment env - (head-var tail-var &optional user-head-var) form) - (setq form (macroexpand form env)) - (flet ((cdr-wrap (form n) - (declare (fixnum n)) - (do () ((<= n 4) (setq form `(,(case n - (1 'cdr) - (2 'cddr) - (3 'cdddr) - (4 'cddddr)) - ,form))) - (setq form `(cddddr ,form) n (- n 4))))) - (let ((tail-form form) (ncdrs nil)) - ;;Determine if the form being constructed is a list of known length. - (when (consp form) - (cond ((eq (car form) 'list) - (setq ncdrs (1- (length (cdr form))))) - ((member (car form) '(list* cons)) - (when (and (cddr form) (member (car (last form)) '(nil 'nil))) - (setq ncdrs (- (length (cdr form)) 2)))))) - (let ((answer - (cond ((null ncdrs) - `(when (setf (cdr ,tail-var) ,tail-form) - (setq ,tail-var (last (cdr ,tail-var))))) - ((< ncdrs 0) (return-from loop-collect-rplacd nil)) - ((= ncdrs 0) - ;; Here we have a choice of two idioms: - ;; (rplacd tail (setq tail tail-form)) - ;; (setq tail (setf (cdr tail) tail-form)). - ;;Genera and most others I have seen do better with the former. - `(rplacd ,tail-var (setq ,tail-var ,tail-form))) - (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) - ncdrs)))))) - ;;If not using locatives or something similar to update the user's - ;; head variable, we've got to set it... It's harmless to repeatedly set it - ;; unconditionally, and probably faster than checking. - (when user-head-var - (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) - answer)))) - - -(defmacro loop-collect-answer (head-var &optional user-head-var) - (or user-head-var - `(cdr ,head-var))) - - -;;;; Maximization Technology - - -#| -The basic idea of all this minimax randomness here is that we have to -have constructed all uses of maximize and minimize to a particular -"destination" before we can decide how to code them. The goal is to not -have to have any kinds of flags, by knowing both that (1) the type is -something which we can provide an initial minimum or maximum value for -and (2) know that a MAXIMIZE and MINIMIZE are not being combined. - -SO, we have a datastructure which we annotate with all sorts of things, -incrementally updating it as we generate loop body code, and then use -a wrapper and internal macros to do the coding when the loop has been -constructed. -|# - - -(defstruct (loop-minimax - #+(or ecl clasp) (:type vector) - (:constructor make-loop-minimax-internal)) - answer-variable - type - temp-variable - flag-variable - operations - infinity-data) - - -(defparameter *loop-minimax-type-infinities-alist* - ;; This is the sort of value this should take on for a Lisp that has - ;; "eminently usable" infinities. n.b. there are neither constants nor - ;; printed representations for infinities defined by CL. - ;; conditionalized out. - ;;This is how the alist should look for a lisp that has no infinities. In - ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive. - '((fixnum most-positive-fixnum most-negative-fixnum) - (short-float most-positive-short-float most-negative-short-float) - (single-float most-positive-single-float most-negative-single-float) - (double-float most-positive-double-float most-negative-double-float) - (long-float most-positive-long-float most-negative-long-float)) - ;; FIXME: When? we do have float infinities: - #+CMU - '((fixnum most-positive-fixnum most-negative-fixnum) - (short-float ext:single-float-positive-infinity ext:single-float-negative-infinity) - (single-float ext:single-float-positive-infinity ext:single-float-negative-infinity) - (double-float ext:double-float-positive-infinity ext:double-float-negative-infinity) - (long-float ext:long-float-positive-infinity ext:long-float-negative-infinity))) - - -(defun make-loop-minimax (answer-variable type) - (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep)))) - (make-loop-minimax-internal - :answer-variable answer-variable - :type type - :temp-variable (gensym "LOOP-MAXMIN-TEMP-") - :flag-variable (and (not infinity-data) (gensym "LOOP-MAXMIN-FLAG-")) - :operations nil - :infinity-data infinity-data))) - - -(defun loop-note-minimax-operation (operation minimax) - (pushnew (the symbol operation) (loop-minimax-operations minimax)) - (when (and (cdr (loop-minimax-operations minimax)) - (not (loop-minimax-flag-variable minimax))) - (setf (loop-minimax-flag-variable minimax) (gensym "LOOP-MAXMIN-FLAG-"))) - operation) - - -(defmacro with-minimax-value (lm &body body) - (let ((init (loop-typed-init (loop-minimax-type lm))) - (which (car (loop-minimax-operations lm))) - (infinity-data (loop-minimax-infinity-data lm)) - (answer-var (loop-minimax-answer-variable lm)) - (temp-var (loop-minimax-temp-variable lm)) - (flag-var (loop-minimax-flag-variable lm)) - (type (loop-minimax-type lm))) - (if flag-var - `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) - (declare (type ,type ,answer-var ,temp-var)) - ,@body) - `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data))) - (,temp-var ,init)) - (declare (type ,type ,answer-var ,temp-var)) - ,@body)))) - - -(defmacro loop-accumulate-minimax-value (lm operation form) - (let* ((answer-var (loop-minimax-answer-variable lm)) - (temp-var (loop-minimax-temp-variable lm)) - (flag-var (loop-minimax-flag-variable lm)) - (test - (hide-variable-reference - t (loop-minimax-answer-variable lm) - `(,(ecase operation - (min '<) - (max '>)) - ,temp-var ,answer-var)))) - `(progn - (setq ,temp-var ,form) - (when ,(if flag-var `(or (not ,flag-var) ,test) test) - (setq ,@(and flag-var `(,flag-var t)) - ,answer-var ,temp-var))))) - - - -;;;; Loop Keyword Tables - - -#| -LOOP keyword tables are hash tables string keys and a test of EQUAL. - -The actual descriptive/dispatch structure used by LOOP is called a "loop -universe" contains a few tables and parameterizations. The basic idea is -that we can provide a non-extensible ANSI-compatible loop environment, -an extensible ANSI-superset loop environment, and (for such environments -as CLOE) one which is "sufficiently close" to the old Genera-vintage -LOOP for use by old user programs without requiring all of the old LOOP -code to be loaded. -|# - - -;;;; Token Hackery - - -;;;Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*, -;;; the second a symbol to check against. -(defun loop-tequal (x1 x2) - (and (symbolp x1) (string= x1 x2))) - - -(defun loop-tassoc (kwd alist) - (and (symbolp kwd) (assoc kwd alist :test #'string=))) - - -(defun loop-tmember (kwd list) - (and (symbolp kwd) (member kwd list :test #'string=))) - - -(defun loop-lookup-keyword (loop-token table) - (and (symbolp loop-token) - (values (gethash (symbol-name loop-token) table)))) - - -(defmacro loop-store-table-data (symbol table datum) - `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) - - -(defstruct (loop-universe - #+(or ecl clasp) (:type vector) - #-(or ecl clasp)(:print-function print-loop-universe)) - keywords ;hash table, value = (fn-name . extra-data). - iteration-keywords ;hash table, value = (fn-name . extra-data). - for-keywords ;hash table, value = (fn-name . extra-data). - path-keywords ;hash table, value = (fn-name . extra-data). - type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. - type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. - ansi ;NIL, T, or :EXTENDED. - implicit-for-required ;see loop-hack-iteration - ) - - -#-(or ecl clasp) -(defun print-loop-universe (u stream level) - (declare (ignore level)) - (let ((str (case (loop-universe-ansi u) - ((nil) "Non-ANSI") - ((t) "ANSI") - (:extended "Extended-ANSI") - (t (loop-universe-ansi u))))) - ;;Cloe could be done with the above except for bootstrap lossage... - #+CLOE - (format stream "#<~S ~A ~X>" (type-of u) str (sys::address-of u)) - #+Genera ; This is reallly the ANSI definition. - (print-unreadable-object (u stream :type t :identity t) - (princ str stream)) - #-(or Genera CLOE) - (format stream "#<~S ~A>" (type-of u) str) - )) - - -;;;This is the "current" loop context in use when we are expanding a -;;;loop. It gets bound on each invocation of LOOP. -(defvar *loop-universe*) - - -(defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords - type-keywords type-symbols ansi) - (flet ((maketable (entries) - (let* ((size (length entries)) - (ht (make-hash-table :size (if (< size 10) 10 size) :test #'equal))) - (dolist (x entries) (setf (gethash (symbol-name (car x)) ht) (cadr x))) - ht))) - (make-loop-universe - :keywords (maketable keywords) - :for-keywords (maketable for-keywords) - :iteration-keywords (maketable iteration-keywords) - :path-keywords (maketable path-keywords) - :ansi ansi - :implicit-for-required (not (null ansi)) - :type-keywords (maketable type-keywords) - :type-symbols (let* ((size (length type-symbols)) - (ht (make-hash-table :size (if (< size 10) 10 size) :test #'eq))) - (dolist (x type-symbols) - (if (atom x) (setf (gethash x ht) x) (setf (gethash (car x) ht) (cadr x)))) - ht)))) - - -;;;; Setq Hackery - - -(defparameter *loop-destructuring-hooks* - nil - "If not NIL, this must be a list of two things: -a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.") - - -(defun loop-make-psetq (frobs) - (and frobs - (loop-make-desetq - (list (car frobs) - (if (null (cddr frobs)) (cadr frobs) - `(prog1 ,(cadr frobs) - ,(loop-make-psetq (cddr frobs)))))))) - - -(defun loop-make-desetq (var-val-pairs) - (if (null var-val-pairs) - nil - (cons (if *loop-destructuring-hooks* - (cadr *loop-destructuring-hooks*) - 'loop-really-desetq) - var-val-pairs))) - - -(defparameter *loop-desetq-temporary* - (make-symbol "LOOP-DESETQ-TEMP")) - - -(defmacro loop-really-desetq (&environment env &rest var-val-pairs) - (labels ((find-non-null (var) - ;; see if there's any non-null thing here - ;; recurse if the list element is itself a list - (do ((tail var)) ((not (consp tail)) tail) - (when (find-non-null (pop tail)) (return t)))) - (loop-desetq-internal (var val &optional temp) - ;; if the value is declared 'unsafe', then the assignment - ;; is also unsafe. - (when (and (consp val) - (eq (first val) 'LOOP-UNSAFE)) - (let ((forms (rest val))) - (setf forms (if (rest forms) `(progn ,@forms) (first forms))) - (return-from loop-desetq-internal - `((LOOP-UNSAFE ,@(loop-desetq-internal var forms)))))) - ;; returns a list of actions to be performed - (typecase var - (null - (when (consp val) - ;; don't lose possible side-effects - (if (eq (car val) 'prog1) - ;; these can come from psetq or desetq below. - ;; throw away the value, keep the side-effects. - ;;Special case is for handling an expanded POP. - (mapcan #'(lambda (x) - (and (consp x) - (or (not (eq (car x) 'car)) - (not (symbolp (cadr x))) - (not (symbolp (setq x (macroexpand x env))))) - (cons x nil))) - (cdr val)) - `(,val)))) - (cons - (let* ((car (car var)) - (cdr (cdr var)) - (car-non-null (find-non-null car)) - (cdr-non-null (find-non-null cdr))) - (when (or car-non-null cdr-non-null) - (if cdr-non-null - (let* ((temp-p temp) - (temp (or temp *loop-desetq-temporary*)) - (body `(,@(loop-desetq-internal car `(car ,temp)) - (setq ,temp (cdr ,temp)) - ,@(loop-desetq-internal cdr temp temp)))) - (if temp-p - `(,@(unless (eq temp val) - `((setq ,temp ,val))) - ,@body) - `((let ((,temp ,val)) - ,@body)))) - ;; no cdring to do - (loop-desetq-internal car `(car ,val) temp))))) - (otherwise - (unless (eq var val) - `((setq ,var ,val))))))) - (do ((actions)) - ((null var-val-pairs) - (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) - (setq actions (revappend - (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs)) - actions))))) - - -;;;; LOOP-local variables - -;;;This is the "current" pointer into the LOOP source code. -(defvar *loop-source-code*) - - -;;;This is the pointer to the original, for things like NAMED that -;;;insist on being in a particular position -(defvar *loop-original-source-code*) - - -;;;This is *loop-source-code* as of the "last" clause. It is used -;;;primarily for generating error messages (see loop-error, loop-warn). -(defvar *loop-source-context*) - - -;;;List of names for the LOOP, supplied by the NAMED clause. -(defvar *loop-names*) - -;;;The macroexpansion environment given to the macro. -(defvar *loop-macro-environment*) - -;;;This holds variable names specified with the USING clause. -;;; See LOOP-NAMED-VARIABLE. -(defvar *loop-named-variables*) - -;;; LETlist-like list being accumulated for one group of parallel bindings. -(defvar *loop-variables*) - -;;;List of declarations being accumulated in parallel with -;;;*loop-variables*. -(defvar *loop-declarations*) - -;;;Used by LOOP for destructuring binding, if it is doing that itself. -;;; See loop-make-variable. -(defvar *loop-desetq-crocks*) - -;;; List of wrapping forms, innermost first, which go immediately inside -;;; the current set of parallel bindings being accumulated in -;;; *loop-variables*. The wrappers are appended onto a body. E.g., -;;; this list could conceivably has as its value ((with-open-file (g0001 -;;; g0002 ...))), with g0002 being one of the bindings in -;;; *loop-variables* (this is why the wrappers go inside of the variable -;;; bindings). -(defvar *loop-wrappers*) - -;;;This accumulates lists of previous values of *loop-variables* and the -;;;other lists above, for each new nesting of bindings. See -;;;loop-bind-block. -(defvar *loop-bind-stack*) - -;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause -;;;which inhibits LOOP from actually outputting a type declaration for -;;;an iteration (or any) variable. -(defvar *loop-nodeclare*) - -;;;This is simply a list of LOOP iteration variables, used for checking -;;;for duplications. -(defvar *loop-iteration-variables*) - - -;;;List of prologue forms of the loop, accumulated in reverse order. -(defvar *loop-prologue*) - -(defvar *loop-before-loop*) -(defvar *loop-body*) -(defvar *loop-after-body*) - -;;;This is T if we have emitted any body code, so that iteration driving -;;;clauses can be disallowed. This is not strictly the same as -;;;checking *loop-body*, because we permit some clauses such as RETURN -;;;to not be considered "real" body (so as to permit the user to "code" -;;;an abnormal return value "in loop"). -(defvar *loop-emitted-body*) - - -;;;List of epilogue forms (supplied by FINALLY generally), accumulated -;;; in reverse order. -(defvar *loop-epilogue*) - -;;;List of epilogue forms which are supplied after the above "user" -;;;epilogue. "normal" termination return values are provide by putting -;;;the return form in here. Normally this is done using -;;;loop-emit-final-value, q.v. -(defvar *loop-after-epilogue*) - -;;;The "culprit" responsible for supplying a final value from the loop. -;;;This is so loop-emit-final-value can moan about multiple return -;;;values being supplied. -(defvar *loop-final-value-culprit*) - -;;;If not NIL, we are in some branch of a conditional. Some clauses may -;;;be disallowed. -(defvar *loop-inside-conditional*) - -;;;If not NIL, this is a temporary bound around the loop for holding the -;;;temporary value for "it" in things like "when (f) collect it". It -;;;may be used as a supertemporary by some other things. -(defvar *loop-when-it-variable*) - -;;;Sometimes we decide we need to fold together parts of the loop, but -;;;some part of the generated iteration code is different for the first -;;;and remaining iterations. This variable will be the temporary which -;;;is the flag used in the loop to tell whether we are in the first or -;;;remaining iterations. -(defvar *loop-never-stepped-variable*) - -;;;List of all the value-accumulation descriptor structures in the loop. -;;; See loop-get-collection-info. -(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) - - -;;;; Code Analysis Stuff - - -(defun loop-constant-fold-if-possible (form &optional expected-type) - ;; FIXME: Get the environment down here so we can do constantp right. - (let ((new-form form) (constantp nil) (constant-value nil)) - (when (setq constantp (constantp new-form)) - (setq constant-value (eval new-form))) - (when (and constantp expected-type) - (unless (typep constant-value expected-type) - (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." - form constant-value expected-type) - (setq constantp nil constant-value nil))) - (values new-form constantp constant-value))) - - -(defmacro loop-body (prologue - before-loop - main-body - after-loop - epilogue) - (unless (= (length before-loop) (length after-loop)) - (error "LOOP-BODY called with non-synched before- and after-loop lists.")) - ;; All our work is done from these copies, working backwards from the end - (let ((rbefore (reverse before-loop)) - (rafter (reverse after-loop))) - ;; Go backwards from the ends of before-loop and after-loop - ;; merging all the equivalent forms into the boyd. - (do () - ((or (null rbefore) - (not (equal (car rbefore) (car rafter))))) - (push (pop rbefore) main-body) - (pop rafter)) - `(tagbody - ,@(remove nil prologue) - ,@(nreverse (remove nil rbefore)) - next-loop - ,@(remove nil main-body) - ,@(nreverse (remove nil rafter)) - (go next-loop) - end-loop - ,@(remove nil epilogue)))) - - -;;;; Loop Errors - - -(defun loop-context () - (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new))) - ((eq l (cdr *loop-source-code*)) (nreverse new)))) - - -(defun loop-error (format-string &rest format-args) - (si::simple-program-error "~?~%Current LOOP context:~{ ~S~}." - format-string format-args (loop-context))) - - -(defun loop-warn (format-string &rest format-args) - (warn 'sys::simple-style-warning - :format-control "~?~%Current LOOP context:~{ ~S~}." - :format-arguments (list format-string format-args (loop-context)))) - - -(defun loop-check-data-type (specified-type required-type - &optional (default-type required-type)) - (if (null specified-type) - default-type - (multiple-value-bind (a b) (subtypep specified-type required-type) - (cond ((not b) - (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." - specified-type required-type)) - ((not a) - (loop-error "Specified data type ~S is not a subtype of ~S." - specified-type required-type))) - specified-type))) - - -;;;INTERFACE: Traditional, ANSI, Lucid. -(defmacro loop-finish () - "Causes the iteration to terminate \"normally\", the same as implicit -termination by an iteration driving clause, or by use of WHILE or -UNTIL -- the epilogue code (if any) will be run, and any implicitly -collected result will be returned as the value of the LOOP." - '(go end-loop)) - - - -(defvar *ignores* nil) -(defun subst-gensyms-for-nil (tree) - (declare (special *ignores*)) - (cond - ((null tree) (car (push (gensym) *ignores*))) - ((atom tree) tree) - (t (cons (subst-gensyms-for-nil (car tree)) - (subst-gensyms-for-nil (cdr tree)))))) - -;;; taken over from sbcls loop implementation -(defun transform-destructuring (tree) - (let (ignores) - (labels ((transform (tree) - (do ((result (list '&optional)) - (cdr tree (cdr cdr))) - (()) - (cond ((null cdr) - (return (nreconc result - (car (push (gensym "LOOP-IGNORED-") - ignores))))) - ((atom cdr) - (return (nreconc result cdr))) - ((consp (car cdr)) - (push (list (transform (car cdr))) result)) - ((null (car cdr)) - (push (car (push (gensym "LOOP-IGNORED-") - ignores)) - result)) - (t - (push (car cdr) result)))))) - (values (transform tree) ignores)))) - -;;; taken over from sbcls loop implementation -(defmacro loop-destructuring-bind - (lambda-list args &rest body) - (multiple-value-bind (d-lambda-list ignores) - (transform-destructuring lambda-list) - `(destructuring-bind ,d-lambda-list ,args - (declare (ignore ,@ignores)) - ,@body))) - -;;; taken over from sbcls loop implementation (usage of loop-destructuring-bind) -(defun loop-build-destructuring-bindings (crocks forms) - (if crocks - (let ((*ignores* ())) - (declare (special *ignores*)) - `((loop-destructuring-bind ,(subst-gensyms-for-nil (car crocks)) - ,(cadr crocks) - (declare (ignore ,@*ignores*)) - ,@(loop-build-destructuring-bindings (cddr crocks) forms)))) - forms)) - -(defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) - (let ((*loop-original-source-code* *loop-source-code*) - (*loop-source-context* nil) - (*loop-iteration-variables* nil) - (*loop-variables* nil) - (*loop-nodeclare* nil) - (*loop-named-variables* nil) - (*loop-declarations* nil) - (*loop-desetq-crocks* nil) - (*loop-bind-stack* nil) - (*loop-prologue* nil) - (*loop-wrappers* nil) - (*loop-before-loop* nil) - (*loop-body* nil) - (*loop-emitted-body* nil) - (*loop-after-body* nil) - (*loop-epilogue* nil) - (*loop-after-epilogue* nil) - (*loop-final-value-culprit* nil) - (*loop-inside-conditional* nil) - (*loop-when-it-variable* nil) - (*loop-never-stepped-variable* nil) - (*loop-names* nil) - (*loop-collection-cruft* nil)) - (loop-iteration-driver) - (loop-bind-block) - (let ((answer `(loop-body - ,(nreverse *loop-prologue*) - ,(nreverse *loop-before-loop*) - ,(nreverse *loop-body*) - ,(nreverse *loop-after-body*) - ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*))))) - (dolist (entry *loop-bind-stack*) - (let ((vars (first entry)) - (dcls (second entry)) - (crocks (third entry)) - (wrappers (fourth entry))) - (dolist (w wrappers) - (setq answer (append w (list answer)))) - (when (or vars dcls crocks) - (let ((forms (list answer))) - ;;(when crocks (push crocks forms)) - (when dcls (push `(declare ,@dcls) forms)) - (setq answer `(,(cond ((not vars) 'locally) - (*loop-destructuring-hooks* (first *loop-destructuring-hooks*)) - (t 'let)) - ,vars - ,@(loop-build-destructuring-bindings crocks forms))))))) - (if *loop-names* - (do () ((null (car *loop-names*)) answer) - (setq answer `(block ,(pop *loop-names*) ,answer))) - `(block nil ,answer))))) - - -(defun loop-iteration-driver () - (do () ((null *loop-source-code*)) - (let ((keyword (car *loop-source-code*)) (tem nil)) - (cond ((not (symbolp keyword)) - (loop-error "~S found where LOOP keyword expected." keyword)) - (t (setq *loop-source-context* *loop-source-code*) - (loop-pop-source) - (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*))) - ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.) - (apply (symbol-function (first tem)) (rest tem))) - ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*))) - (loop-hack-iteration tem)) - ((loop-tmember keyword '(and else)) - ;; Alternative is to ignore it, ie let it go around to the next keyword... - (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." - keyword (car *loop-source-code*) (cadr *loop-source-code*))) - (t (loop-error "~S is an unknown keyword in LOOP macro." keyword)))))))) - - - -(defun loop-pop-source () - (if *loop-source-code* - (pop *loop-source-code*) - (loop-error "LOOP source code ran out when another token was expected."))) - - -(defun loop-get-compound-form () - (let ((form (loop-get-form))) - (unless (consp form) - (loop-error "Compound form expected, but found ~A." form)) - form)) - -(defun loop-get-progn () - (do ((forms (list (loop-get-compound-form)) - (cons (loop-get-compound-form) forms)) - (nextform (car *loop-source-code*) - (car *loop-source-code*))) - ((atom nextform) - (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) - - -(defun loop-get-form () - (if *loop-source-code* - (loop-pop-source) - (loop-error "LOOP code ran out where a form was expected."))) - - -(defun loop-construct-return (form) - `(return-from ,(car *loop-names*) ,form)) - -(defun loop-emit-body (form) - (setq *loop-emitted-body* t) - (push form *loop-body*)) - -(defun loop-emit-final-value (&optional (form nil form-supplied-p)) - (when form-supplied-p - (push (loop-construct-return form) *loop-after-epilogue*)) - (when *loop-final-value-culprit* - (loop-warn "LOOP clause is providing a value for the iteration,~@ - however one was already established by a ~S clause." - *loop-final-value-culprit*)) - (setq *loop-final-value-culprit* (car *loop-source-context*))) - - -(defun loop-disallow-conditional (&optional kwd) - #+(or Genera CLOE) (declare (dbg:error-reporter)) - (when *loop-inside-conditional* - (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) - -(defun loop-disallow-anonymous-collectors () - (when (find-if-not 'loop-collector-name *loop-collection-cruft*) - (loop-error "This LOOP clause is not permitted with anonymous collectors."))) - -(defun loop-disallow-aggregate-booleans () - (when (loop-tmember *loop-final-value-culprit* '(always never thereis)) - (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans."))) - - - -;;;; Loop Types - - -(defun loop-typed-init (data-type) - (cond ((null data-type) - nil) - ((subtypep data-type 'character) - #\0) - ((not (subtypep data-type 'number)) - nil) - ((subtypep data-type '(or float (complex float))) - (coerce 0 data-type)) - (t - 0))) - -(defun loop-optional-type (&optional variable) - ;;No variable specified implies that no destructuring is permissible. - (and *loop-source-code* ;Don't get confused by NILs... - (let ((z (car *loop-source-code*))) - (cond ((loop-tequal z 'of-type) - ;;This is the syntactically unambigous form in that the form of the - ;; type specifier does not matter. Also, it is assumed that the - ;; type specifier is unambiguously, and without need of translation, - ;; a common lisp type specifier or pattern (matching the variable) thereof. - (loop-pop-source) - (loop-pop-source)) - - ((symbolp z) - ;;This is the (sort of) "old" syntax, even though we didn't used to support all of - ;; these type symbols. - (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) - (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*))))) - (when type-spec - (loop-pop-source) - type-spec))) - (t - ;;This is our sort-of old syntax. But this is only valid for when we are destructuring, - ;; so we will be compulsive (should we really be?) and require that we in fact be - ;; doing variable destructuring here. We must translate the old keyword pattern typespec - ;; into a fully-specified pattern of real type specifiers here. - (if (consp variable) - (unless (consp z) - (loop-error - "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected." - z)) - (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z)) - (loop-pop-source) - (labels ((translate (k v) - (cond ((null k) nil) - ((atom k) - (replicate - (or (gethash k (loop-universe-type-symbols *loop-universe*)) - (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*)) - (loop-error - "Destructuring type pattern ~S contains unrecognized type keyword ~S." - z k)) - v)) - ((atom v) - (loop-error - "Destructuring type pattern ~S doesn't match variable pattern ~S." - z variable)) - (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v)))))) - (replicate (typ v) - (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v)))))) - (translate z variable))))))) - - - -;;;; Loop Variables - - -(defun loop-bind-block () - (when (or *loop-variables* *loop-declarations* *loop-wrappers*) - (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*) - *loop-bind-stack*) - (setq *loop-variables* nil - *loop-declarations* nil - *loop-desetq-crocks* nil - *loop-wrappers* nil))) - -(defun loop-variable-p (name) - (do ((entry *loop-bind-stack* (cdr entry))) (nil) - (cond ((null entry) - (return nil)) - ((assoc name (caar entry) :test #'eq) - (return t))))) - -(defun loop-make-variable (name initialization dtype &optional iteration-variable-p) - (cond ((null name) - (cond ((not (null initialization)) - (push (list (setq name (gensym "LOOP-IGNORE-")) - initialization) - *loop-variables*) - (push `(ignore ,name) *loop-declarations*)))) - ((atom name) - (cond (iteration-variable-p - (if (member name *loop-iteration-variables*) - (loop-error "Duplicated LOOP iteration variable ~S." name) - (push name *loop-iteration-variables*))) - ((assoc name *loop-variables*) - (loop-error "Duplicated variable ~S in LOOP parallel binding." name))) - (unless (symbolp name) - (loop-error "Bad variable ~S somewhere in LOOP." name)) - ;; Mark every variable ignorable. There's no way to - ;; affirmatively declare ignorability, and we default to silence - ;; to avoid pointless compiler diagnostics. - ;; Most obviously, without this, for-as-hash will result in - ;; style-warnings for our internal variables. - (push `(ignorable ,name) *loop-declarations*) - (let ((init (or initialization (loop-typed-init dtype)))) - ;;; the init-value of the loop variable better fits the dtype - ;;; verify in loop-declare-variable - (loop-declare-variable name dtype init) - ;; We use ASSOC on this list to check for duplications (above), - ;; so don't optimize out this list: - (push (list name init) - *loop-variables*))) - (initialization - (cond (*loop-destructuring-hooks* - (loop-declare-variable name dtype) - (push (list name initialization) *loop-variables*)) - (t (let ((newvar (gensym "LOOP-DESTRUCTURE-"))) - (loop-declare-variable name dtype) - (push (list newvar initialization) *loop-variables*) - ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. - (setq *loop-desetq-crocks* - (list* name newvar *loop-desetq-crocks*)))))) - (t (let ((tcar nil) (tcdr nil)) - (if (atom dtype) (setq tcar (setq tcdr dtype)) - (setq tcar (car dtype) tcdr (cdr dtype))) - (loop-make-variable (car name) nil tcar iteration-variable-p) - (loop-make-variable (cdr name) nil tcdr iteration-variable-p)))) - name) - - -(defun loop-make-iteration-variable (name initialization dtype) - (loop-make-variable name initialization dtype t)) - - -(defun loop-declare-variable (name dtype &optional (initialization nil initialization-p)) - (cond ((or (null name) (null dtype) (eq dtype t)) nil) - ((symbolp name) - (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) - (when (and initialization-p (constantp initialization)) - (let ((init-type (type-of initialization))) - (unless (subtypep init-type dtype) - (setf dtype `(or ,dtype ,init-type))))) - ;; Allow redeclaration of a variable. This can be used by - ;; the loop constructors to make the type more and more - ;; precise as we add keywords - (let ((previous (find name *loop-declarations* - :key #'(lambda (d) - (and (consp d) - (= (length d) 3) - (eq (cons-car d) 'type) - (third d)))))) - (if previous - (setf (second previous) dtype) - (push `(type ,dtype ,name) *loop-declarations*))))) - ((consp name) - ;; to be on the safe side, we always assume that - ;; destructuring variable bindings initialize to nil - (cond ((consp dtype) - (loop-declare-variable (car name) (car dtype) nil) - (loop-declare-variable (cdr name) (cdr dtype))) - (t (loop-declare-variable (car name) dtype nil) - (loop-declare-variable (cdr name) dtype)))) - (t (error "Invalid LOOP variable passed in: ~S." name)))) - - - -(defun loop-do-if (for negatep) - (let ((form (loop-get-form)) - (*loop-inside-conditional* t) - (it-p nil) - (first-clause-p t)) - (flet ((get-clause (for) - (do ((body nil)) (nil) - (let ((key (car *loop-source-code*)) (*loop-body* nil) data) - (cond ((not (symbolp key)) - (loop-error - "~S found where keyword expected getting LOOP clause after ~S." - key for)) - (t (setq *loop-source-context* *loop-source-code*) - (loop-pop-source) - (when (and (loop-tequal (car *loop-source-code*) 'it) - first-clause-p) - (setq *loop-source-code* - (cons (or it-p (setq it-p (loop-when-it-variable))) - (cdr *loop-source-code*)))) - (cond ((or (not (setq data (loop-lookup-keyword - key (loop-universe-keywords *loop-universe*)))) - (progn (apply (symbol-function (car data)) (cdr data)) - (null *loop-body*))) - (loop-error - "~S does not introduce a LOOP clause that can follow ~S." - key for)) - (t (setq body (nreconc *loop-body* body))))))) - (setq first-clause-p nil) - (if (loop-tequal (car *loop-source-code*) :and) - (loop-pop-source) - (return (if (cdr body) `(progn ,@(nreverse body)) (car body))))))) - (let ((then (get-clause for)) - (else (when (loop-tequal (car *loop-source-code*) :else) - (loop-pop-source) - (list (get-clause :else))))) - (when (loop-tequal (car *loop-source-code*) :end) - (loop-pop-source)) - (when it-p (setq form `(setq ,it-p ,form))) - (loop-emit-body - `(if ,(if negatep `(not ,form) form) - ,then - ,@else)))))) - - -(defun loop-do-initially () - (loop-disallow-conditional :initially) - (push (loop-get-progn) *loop-prologue*)) - -(defun loop-do-finally () - (loop-disallow-conditional :finally) - (push (loop-get-progn) *loop-epilogue*)) - -(defun loop-do-do () - (loop-emit-body (loop-get-progn))) - -(defun loop-do-named () - (let ((name (loop-pop-source))) - (unless (symbolp name) - (loop-error "~S is an invalid name for your LOOP." name)) - (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*) - (loop-error "The NAMED ~S clause occurs too late." name)) - (when *loop-names* - (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S." - (car *loop-names*) name)) - (setq *loop-names* (list name nil)))) - -(defun loop-do-return () - (loop-emit-body (loop-construct-return (loop-get-form)))) - - -;;;; Value Accumulation: List - - -(defstruct (loop-collector - #+(or ecl clasp) (:type vector)) - name - class - (history nil) - (tempvars nil) - dtype - (data nil)) ;collector-specific data - - -(defun loop-get-collection-info (collector class default-type) - (let ((form (loop-get-form)) - (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) - (name (when (loop-tequal (car *loop-source-code*) 'into) - (loop-pop-source) - (loop-pop-source)))) - (when (not (symbolp name)) - (loop-error "Value accumulation recipient name, ~S, is not a symbol." name)) - (unless name - (loop-disallow-aggregate-booleans)) - (unless dtype - (setq dtype (or (loop-optional-type) default-type))) - (let ((cruft (find (the symbol name) *loop-collection-cruft* - :key #'loop-collector-name))) - (cond ((not cruft) - (when (and name (loop-variable-p name)) - (loop-error "Variable ~S cannot be used in INTO clause" name)) - (push (setq cruft (make-loop-collector - :name name :class class - :history (list collector) :dtype dtype)) - *loop-collection-cruft*)) - (t (unless (eq (loop-collector-class cruft) class) - (loop-error - "Incompatible kinds of LOOP value accumulation specified for collecting~@ - ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S." - name (car (loop-collector-history cruft)) collector)) - (unless (equal dtype (loop-collector-dtype cruft)) - (loop-warn - "Unequal datatypes specified in different LOOP value accumulations~@ - into ~S: ~S and ~S." - name dtype (loop-collector-dtype cruft)) - (when (eq (loop-collector-dtype cruft) t) - (setf (loop-collector-dtype cruft) dtype))) - (push collector (loop-collector-history cruft)))) - (values cruft form)))) - - -(defun loop-list-collection (specifically) ;NCONC, LIST, or APPEND - (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list) - (let ((tempvars (loop-collector-tempvars lc))) - (unless tempvars - (setf (loop-collector-tempvars lc) - (setq tempvars (list* (gensym "LOOP-LIST-HEAD") - (gensym "LOOP-LIST-TAIL") - (and (loop-collector-name lc) - (list (loop-collector-name lc)))))) - (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) - (unless (loop-collector-name lc) - (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars))))) - (ecase specifically - (list (setq form `(list ,form))) - (nconc nil) - (append (unless (and (consp form) (eq (car form) 'list)) - (setq form `(copy-list ,form))))) - (loop-emit-body `(loop-collect-rplacd ,tempvars ,form))))) - - -;;;; Value Accumulation: max, min, sum, count. - - - -(defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT - (multiple-value-bind (lc form) - (loop-get-collection-info specifically 'sum default-type) - (loop-check-data-type (loop-collector-dtype lc) required-type) - (let ((tempvars (loop-collector-tempvars lc))) - (unless tempvars - (setf (loop-collector-tempvars lc) - (setq tempvars (list (loop-make-variable - (or (loop-collector-name lc) - (gensym "LOOP-SUM-")) - nil (loop-collector-dtype lc))))) - (unless (loop-collector-name lc) - (loop-emit-final-value (car (loop-collector-tempvars lc))))) - (loop-emit-body - (if (eq specifically 'count) - `(when ,form - (setq ,(car tempvars) - ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars))))) - `(setq ,(car tempvars) - (+ ,(hide-variable-reference t (car tempvars) (car tempvars)) - ,form))))))) - - - -(defun loop-maxmin-collection (specifically) - (multiple-value-bind (lc form) - (loop-get-collection-info specifically 'maxmin 'real) - (loop-check-data-type (loop-collector-dtype lc) 'real) - (let ((data (loop-collector-data lc))) - (unless data - (setf (loop-collector-data lc) - (setq data (make-loop-minimax - (or (loop-collector-name lc) (gensym "LOOP-MAXMIN-")) - (loop-collector-dtype lc)))) - (unless (loop-collector-name lc) - (loop-emit-final-value (loop-minimax-answer-variable data)))) - (loop-note-minimax-operation specifically data) - (push `(with-minimax-value ,data) *loop-wrappers*) - (loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form)) - ))) - - -;;;; Value Accumulation: Aggregate Booleans - -;;;ALWAYS and NEVER. -;;; Under ANSI these are not permitted to appear under conditionalization. -(defun loop-do-always (restrictive negate) - (let ((form (loop-get-form))) - (when restrictive (loop-disallow-conditional)) - (loop-disallow-anonymous-collectors) - (loop-emit-body `(,(if negate 'when 'unless) ,form - ,(loop-construct-return nil))) - (loop-emit-final-value t))) - - - -;;;THERIS. -;;; Under ANSI this is not permitted to appear under conditionalization. -(defun loop-do-thereis (restrictive) - (when restrictive (loop-disallow-conditional)) - (loop-disallow-anonymous-collectors) - (loop-emit-final-value) - (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form)) - ,(loop-construct-return *loop-when-it-variable*)))) - - -(defun loop-do-while (negate kwd &aux (form (loop-get-form))) - (loop-disallow-conditional kwd) - (loop-emit-body `(,(if negate 'when 'unless) ,form (go end-loop)))) - - -(defun loop-do-with () - (loop-disallow-conditional :with) - (do ((var) (val) (dtype)) (nil) - (setq var (loop-pop-source) - dtype (loop-optional-type var) - val (cond ((loop-tequal (car *loop-source-code*) :=) - (loop-pop-source) - (loop-get-form)) - (t nil))) - (when (and var (loop-variable-p var)) - (loop-error "Variable ~S has already been used" var)) - (loop-make-variable var val dtype) - (if (loop-tequal (car *loop-source-code*) :and) - (loop-pop-source) - (return (loop-bind-block))))) - - -;;;; The iteration driver - -(defun loop-hack-iteration (entry) - (flet ((make-endtest (list-of-forms) - (cond ((null list-of-forms) nil) - ((member t list-of-forms) '(go end-loop)) - (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) - (car list-of-forms) - (cons 'or list-of-forms)) - (go end-loop)))))) - (do ((pre-step-tests nil) - (steps nil) - (post-step-tests nil) - (pseudo-steps nil) - (pre-loop-pre-step-tests nil) - (pre-loop-steps nil) - (pre-loop-post-step-tests nil) - (pre-loop-pseudo-steps nil) - (tem) (data)) - (nil) - ;; Note we collect endtests in reverse order, but steps in correct - ;; order. MAKE-ENDTEST does the nreverse for us. - (setq tem (setq data (apply (symbol-function (first entry)) (rest entry)))) - (and (car tem) (push (car tem) pre-step-tests)) - (setq steps (nconc steps (copy-list (car (setq tem (cdr tem)))))) - (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) - (setq pseudo-steps (nconc pseudo-steps (copy-list (car (setq tem (cdr tem)))))) - (setq tem (cdr tem)) - (when *loop-emitted-body* - (loop-warn "Iteration in LOOP follows body code.")) - (unless tem (setq tem data)) - (when (car tem) (push (car tem) pre-loop-pre-step-tests)) - (setq pre-loop-steps (nconc pre-loop-steps (copy-list (car (setq tem (cdr tem)))))) - (when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests)) - (setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (copy-list (cadr tem)))) - (unless (loop-tequal (car *loop-source-code*) :and) - (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps) - (make-endtest pre-loop-post-step-tests) - (loop-make-psetq pre-loop-steps) - (make-endtest pre-loop-pre-step-tests) - *loop-before-loop*) - *loop-after-body* (list* (loop-make-desetq pseudo-steps) - (make-endtest post-step-tests) - (loop-make-psetq steps) - (make-endtest pre-step-tests) - *loop-after-body*)) - (loop-bind-block) - (return nil)) - (loop-pop-source) ; flush the "AND" - (when (and (not (loop-universe-implicit-for-required *loop-universe*)) - (setq tem (loop-lookup-keyword - (car *loop-source-code*) - (loop-universe-iteration-keywords *loop-universe*)))) - ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied. - (loop-pop-source) - (setq entry tem))))) - - -;;;; Main Iteration Drivers - - -;FOR variable keyword ..args.. -(defun loop-do-for () - (let* ((var (loop-pop-source)) - (data-type (loop-optional-type var)) - (keyword (loop-pop-source)) - (first-arg nil) - (tem nil)) - (setq first-arg (loop-get-form)) - (unless (and (symbolp keyword) - (setq tem (loop-lookup-keyword - keyword - (loop-universe-for-keywords *loop-universe*)))) - (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." keyword)) - (apply (car tem) var first-arg data-type (cdr tem)))) - -(defun loop-do-repeat () - (loop-disallow-conditional :repeat) - (let* ((form0 (loop-get-form)) - (type (if (fixnump form0) 'fixnum 'real)) - (var (loop-make-variable (gensym) form0 type)) - (form `(loop-unsafe (when (minusp (decf ,var)) (go end-loop))))) - (push form *loop-before-loop*) - (push form *loop-after-body*) - ;; FIXME: What should - ;; (loop count t into a - ;; repeat 3 - ;; count t into b - ;; finally (return (list a b))) - ;; return: (3 3) or (4 3)? PUSHes above are for the former - ;; variant, L-P-B below for the latter. - #+nil (loop-pseudo-body form) - ) - ) - -(defun loop-when-it-variable () - (or *loop-when-it-variable* - (setq *loop-when-it-variable* - (loop-make-variable (gensym "LOOP-IT-") nil nil)))) - - -;;;; Various FOR/AS Subdispatches - - -;;;ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN -;;; is omitted (other than being more stringent in its placement), and like -;;; the old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first -;;; initialization occurs in the loop body (first-step), not in the variable binding -;;; phase. -(defun loop-ansi-for-equals (var val data-type) - (loop-make-iteration-variable var nil data-type) - (cond ((loop-tequal (car *loop-source-code*) :then) - ;;Then we are the same as "FOR x FIRST y THEN z". - (loop-pop-source) - `(() (,var ,(loop-get-form)) () () - () (,var ,val) () ())) - (t ;;We are the same as "FOR x = y". - `(() (,var ,val) () ())))) - - -(defun loop-for-across (var val data-type) - (loop-make-iteration-variable var nil data-type) - (let ((vector-var (gensym "LOOP-ACROSS-VECTOR-")) - (index-var (gensym "LOOP-ACROSS-INDEX-"))) - (multiple-value-bind (vector-form constantp vector-value) - (loop-constant-fold-if-possible val 'vector) - (loop-make-variable - vector-var vector-form - (if (and (consp vector-form) (eq (car vector-form) 'the)) - (cadr vector-form) - 'vector)) - (loop-make-variable index-var 0 'fixnum) - (let* ((length 0) - (length-form (cond ((not constantp) - (let ((v (gensym "LOOP-ACROSS-LIST"))) - (push `(setq ,v (length ,vector-var)) *loop-prologue*) - (loop-make-variable v 0 'fixnum))) - (t (setq length (length vector-value))))) - (first-test `(>= ,index-var ,length-form)) - (other-test first-test) - ;; FIXME: We could do even better by extracting - ;; the underlying (simple-array * (*)) outside of the loop. - (step `(,var (locally (declare (optimize (core::insert-array-bounds-checks nil))) - (aref ,vector-var ,index-var)))) - (pstep `(,index-var (1+ ,index-var)))) - (declare (fixnum length)) - (when constantp - (setq first-test (= length 0)) - (when (<= length 1) - (setq other-test t))) - `(,other-test ,step () ,pstep - ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep))))))) - - - -;;;; List Iteration - - -(defun loop-list-step (listvar) - ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any - ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used - ;; as the stepping function. - ;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not - ;; recognizing FOO may defeat some LOOP optimizations. - (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by) - (loop-pop-source) - (loop-get-form)) - (t '(function cons-cdr))))) - (cond ((and (consp stepper) (eq (car stepper) 'quote)) - (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") - (values `(funcall ,stepper ,listvar) nil)) - ((and (consp stepper) (eq (car stepper) 'function)) - (values (list (cadr stepper) listvar) (cadr stepper))) - (t (values `(funcall ,(loop-make-variable (gensym "LOOP-FN") stepper 'function) - ,listvar) - nil))))) - - -(defun loop-for-on (var val data-type) - (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) - (let ((listvar var)) - (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type)) - (t (loop-make-variable (setq listvar (gensym)) list 'list) - (loop-make-iteration-variable var nil data-type))) - (multiple-value-bind (list-step step-function) (loop-list-step listvar) - (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function)) - ;; The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind. - (let* ((first-endtest - (hide-variable-reference - (eq var listvar) - listvar - ;; the following should use `atom' instead of `endp', per - ;; [bug2428] - `(atom ,listvar))) - (other-endtest first-endtest)) - (when (and constantp (listp list-value)) - (setq first-endtest (null list-value))) - (cond ((eq var listvar) - ;;Contour of the loop is different because we use the user's variable... - `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest - () () () ,first-endtest ())) - (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step))) - `(,other-endtest ,step () ,pseudo - ,@(and (not (eq first-endtest other-endtest)) - `(,first-endtest ,step () ,pseudo))))))))))) - - -(defun loop-for-in (var val data-type) - (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) - (let ((listvar (gensym "LOOP-LIST"))) - (loop-make-iteration-variable var nil data-type) - (loop-make-variable listvar list 'list) - (multiple-value-bind (list-step step-function) (loop-list-step listvar) - #-LOOP-Prefer-POP (declare (ignore step-function)) - (let* ((first-endtest `(endp ,listvar)) - (other-endtest first-endtest) - (step `(,var (cons-car ,listvar))) - (pseudo-step `(,listvar ,list-step))) - (when (and constantp (listp list-value)) - (setq first-endtest (null list-value))) - `(,other-endtest ,step () ,pseudo-step - ,@(and (not (eq first-endtest other-endtest)) - `(,first-endtest ,step () ,pseudo-step)))))))) - - -;;;; Iteration Paths - - -(defstruct (loop-path - #+(or ecl clasp) (:type vector) - (:copier nil) - (:predicate nil)) - names - preposition-groups - inclusive-permitted - function - user-data) - - -(defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data) - (unless (listp names) (setq names (list names))) - ;; Can't do this due to CLOS bootstrapping problems. - #-(or Genera (and CLOE Source-Bootstrap) ecl clasp) (check-type universe loop-universe) - (let ((ht (loop-universe-path-keywords universe)) - (lp (make-loop-path - :names (mapcar #'symbol-name names) - :function function - :user-data user-data - :preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups) - :inclusive-permitted inclusive-permitted))) - (dolist (name names) (setf (gethash (symbol-name name) ht) lp)) - lp)) - - -;;; Note: path functions are allowed to use loop-make-variable, hack -;;; the prologue, etc. -(defun loop-for-being (var val data-type) - ;; FOR var BEING each/the pathname prep-phrases using-stuff... - ;; each/the = EACH or THE. Not clear if it is optional, so I guess we'll warn. - (let ((path nil) - (data nil) - (inclusive nil) - (stuff nil) - (initial-prepositions nil)) - (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source))) - ((loop-tequal (car *loop-source-code*) :and) - (loop-pop-source) - (setq inclusive t) - (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her)) - (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax." - (car *loop-source-code*))) - (loop-pop-source) - (setq path (loop-pop-source)) - (setq initial-prepositions `((:in ,val)))) - (t (loop-error "Unrecognizable LOOP iteration path syntax. Missing EACH or THE?"))) - (cond ((not (symbolp path)) - (loop-error "~S found where a LOOP iteration path name was expected." path)) - ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) - (loop-error "~S is not the name of a LOOP iteration path." path)) - ((and inclusive (not (loop-path-inclusive-permitted data))) - (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) - (let ((fun (loop-path-function data)) - (preps (nconc initial-prepositions - (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t))) - (user-data (loop-path-user-data data))) - (when (symbolp fun) (setq fun (symbol-function fun))) - (setq stuff (if inclusive - (apply fun var data-type preps :inclusive t user-data) - (apply fun var data-type preps user-data)))) - (when *loop-named-variables* - (loop-error "Unused USING variables: ~S." *loop-named-variables*)) - ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the system from the user - ;; and the user from himself. - (unless (member (length stuff) '(6 10)) - (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." - path)) - (do ((l (car stuff) (cdr l)) (x)) ((null l)) - (if (atom (setq x (car l))) - (loop-make-iteration-variable x nil nil) - (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) - (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) - (cddr stuff))) - - - -;;;INTERFACE: Lucid, exported. -;;; i.e., this is part of our extended ansi-loop interface. -(defun named-variable (name) - (let ((tem (loop-tassoc name *loop-named-variables*))) - (declare (list tem)) - (cond ((null tem) (values (gensym) nil)) - (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) - (values (cdr tem) t))))) - - -(defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases) - (flet ((in-group-p (x group) (car (loop-tmember x group)))) - (do ((token nil) - (prepositional-phrases initial-phrases) - (this-group nil nil) - (this-prep nil nil) - (disallowed-prepositions - (mapcan #'(lambda (x) - (copy-list - (find (car x) preposition-groups :test #'in-group-p))) - initial-phrases)) - (used-prepositions (mapcar #'car initial-phrases))) - ((null *loop-source-code*) (nreverse prepositional-phrases)) - (declare (symbol this-prep)) - (setq token (car *loop-source-code*)) - (dolist (group preposition-groups) - (when (setq this-prep (in-group-p token group)) - (return (setq this-group group)))) - (cond (this-group - (when (member this-prep disallowed-prepositions) - (loop-error - (if (member this-prep used-prepositions) - "A ~S prepositional phrase occurs multiply for some LOOP clause." - "Preposition ~S used when some other preposition has subsumed it.") - token)) - (setq used-prepositions (if (listp this-group) - (append this-group used-prepositions) - (cons this-group used-prepositions))) - (loop-pop-source) - (push (list this-prep (loop-get-form)) prepositional-phrases)) - ((and USING-allowed (loop-tequal token 'using)) - (loop-pop-source) - (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) - (when (cadr z) - (if (setq tem (loop-tassoc (car z) *loop-named-variables*)) - (loop-error - "The variable substitution for ~S occurs twice in a USING phrase,~@ - with ~S and ~S." - (car z) (cadr z) (cadr tem)) - (push (cons (car z) (cadr z)) *loop-named-variables*))) - (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*))) - (return nil)))) - (t (return (nreverse prepositional-phrases))))))) - - -;;;; Master Sequencer Function - -(defun loop-sequencer (indexv indexv-type indexv-user-specified-p - variable variable-type - sequence-variable sequence-type - step-hack default-top - prep-phrases) - (let ((endform nil) ;Form (constant or variable) with limit value. - (sequencep nil) ;T if sequence arg has been provided. - (testfn nil) ;endtest function - (test nil) ;endtest form. - (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment. - (stepby-constantp t) - (step nil) ;step form. - (dir nil) ;Direction of stepping: NIL, :UP, :DOWN. - (inclusive-iteration nil) ;T if include last index. - (start-given nil) ;T when prep phrase has specified start - (start-value nil) - (start-constantp nil) - (limit-given nil) ;T when prep phrase has specified end - (limit-constantp nil) - (limit-value nil) - ) - (when variable (loop-make-iteration-variable variable nil variable-type)) - (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) - (setq prep (caar l) form (cadar l)) - (case prep - ((:of :in) - (setq sequencep t) - (loop-make-variable sequence-variable form sequence-type)) - ((:from :downfrom :upfrom) - (setq start-given t) - (cond ((eq prep :downfrom) (setq dir ':down)) - ((eq prep :upfrom) (setq dir ':up))) - (multiple-value-setq (form start-constantp start-value) - (loop-constant-fold-if-possible form indexv-type)) - (loop-make-iteration-variable indexv form indexv-type)) - ((:upto :to :downto :above :below) - (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up))) - ((loop-tequal prep :to) (setq inclusive-iteration t)) - ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down))) - ((loop-tequal prep :above) (setq dir ':down)) - ((loop-tequal prep :below) (setq dir ':up))) - (setq limit-given t) - (multiple-value-setq (form limit-constantp limit-value) - (loop-constant-fold-if-possible form indexv-type)) - (setq endform (if limit-constantp - `',limit-value - (loop-make-variable - (gensym "LOOP-LIMIT") form indexv-type)))) - (:by - (multiple-value-setq (form stepby-constantp stepby) - (loop-constant-fold-if-possible form indexv-type)) - (unless stepby-constantp - (loop-make-variable (setq stepby (gensym "LOOP-STEP-BY")) form indexv-type))) - (t (loop-error - "~S invalid preposition in sequencing or sequence path.~@ - Invalid prepositions specified in iteration path descriptor or something?" - prep))) - (when (and odir dir (not (eq dir odir))) - (loop-error "Conflicting stepping directions in LOOP sequencing path")) - (setq odir dir)) - (when (and sequence-variable (not sequencep)) - (loop-error "Missing OF or IN phrase in sequence path")) - ;; Now fill in the defaults. - (unless start-given - (loop-make-iteration-variable - indexv - (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0)) - indexv-type)) - (cond ((member dir '(nil :up)) - (when (or limit-given default-top) - (unless limit-given - (loop-make-variable (setq endform (gensym "LOOP-SEQ-LIMIT-")) - nil indexv-type) - (push `(setq ,endform ,default-top) *loop-prologue*)) - (setq testfn (if inclusive-iteration '> '>=))) - (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) - (t (unless start-given - (unless default-top - (loop-error "Don't know where to start stepping.")) - (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) - (when (and default-top (not endform)) - (setq endform (loop-typed-init indexv-type) inclusive-iteration t)) - (when endform (setq testfn (if inclusive-iteration '< '<=))) - (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) - (setq step `(loop-unsafe ,step)) - (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform)))) - (when step-hack - (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack)))) - (let ((first-test test) (remaining-tests test)) - (when (and stepby-constantp start-constantp) - ;; We can make the number type more precise when we know the - ;; start, end and step values. - (let ((new-type (typecase (+ start-value stepby) - (integer (if (and (fixnump start-value) - limit-constantp - (< limit-value most-positive-fixnum) - (> limit-value most-negative-fixnum)) - 'fixnum - 'integer)) - (single-float 'single-float) - (double-float 'double-float) - (long-float 'long-float) - (short-float 'short-float) - (t indexv-type)))) - (unless (subtypep (type-of start-value) new-type) - ;; The start type may not be a subtype of the type during - ;; iteration. Happens e.g. when stepping a fixnum start - ;; value by a float. - (setf new-type `(or ,(type-of start-value) ,new-type))) - (unless (subtypep indexv-type new-type) - (loop-declare-variable indexv new-type))) - (when (and limit-constantp - (setq first-test (funcall (symbol-function testfn) - start-value - limit-value))) - (setq remaining-tests t))) - `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack - () () ,first-test ,step-hack)))) - - -;;;; Interfaces to the Master Sequencer - - - -(defun loop-for-arithmetic (var val data-type kwd) - (unless var - (setf var (gensym))) - (loop-sequencer - var (loop-check-data-type data-type 'number) t - nil nil nil nil nil nil - (loop-collect-prepositional-phrases - '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) - nil (list (list kwd val))))) - -#+nil ; may be adaptable into crhodes' SEQUENCES extension? -(defun loop-sequence-elements-path (variable data-type prep-phrases - &key fetch-function size-function sequence-type element-type) - (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index) - (let ((sequencev (named-variable 'sequence))) - #+Genera (when (and sequencev - (symbolp sequencev) - sequence-type - (subtypep sequence-type 'vector) - (not (member (the symbol sequencev) *loop-nodeclare*))) - (push `(sys:array-register ,sequencev) *loop-declarations*)) - (list* nil nil ; dummy bindings and prologue - (loop-sequencer - indexv 'fixnum indexv-user-specified-p - variable (or data-type element-type) - sequencev sequence-type - `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev) - prep-phrases))))) - - -;;;; Builtin LOOP Iteration Paths - - -#|| -(loop for v being the hash-values of ht do (print v)) -(loop for k being the hash-keys of ht do (print k)) -(loop for v being the hash-values of ht using (hash-key k) do (print (list k v))) -(loop for k being the hash-keys of ht using (hash-value v) do (print (list k v))) -||# - -(defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which) - (check-type which (member hash-key hash-value)) - (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) - (loop-error "Too many prepositions!")) - ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path."))) - (let ((ht-var (gensym "LOOP-HASHTAB-")) - (next-fn (gensym "LOOP-HASHTAB-NEXT-")) - (dummy-predicate-var nil) - (post-steps nil)) - (multiple-value-bind (other-var other-p) - (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) - ;; named-variable returns a second value of T if the name was actually - ;; specified, so clever code can throw away the gensym'ed up variable if - ;; it isn't really needed. - ;;The following is for those implementations in which we cannot put dummy NILs - ;; into multiple-value-setq variable lists. - #-Genera (setq other-p t - dummy-predicate-var (loop-when-it-variable)) - (let* ((key-var nil) - (val-var nil) - (temp-val-var (gensym "LOOP-HASH-VAL-TEMP-")) - (temp-key-var (gensym "LOOP-HASH-KEY-TEMP-")) - (temp-predicate-var (gensym "LOOP-HASH-PREDICATE-VAR-")) - (variable (or variable (gensym))) - (bindings `((,variable nil ,data-type) - (,ht-var ,(cadar prep-phrases)) - ,@(and other-p other-var `((,other-var nil)))))) - (if (eq which 'hash-key) - (setq key-var variable val-var (and other-p other-var)) - (setq key-var (and other-p other-var) val-var variable)) - (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) - (when (consp key-var) - (setq post-steps `(,key-var ,(setq key-var (gensym "LOOP-HASH-KEY-TEMP-")) - ,@post-steps)) - (push `(,key-var nil) bindings)) - (when (consp val-var) - (setq post-steps `(,val-var ,(setq val-var (gensym "LOOP-HASH-VAL-TEMP-")) - ,@post-steps)) - (push `(,val-var nil) bindings)) - `(,bindings ;bindings - () ;prologue - () ;pre-test - () ;parallel steps - (not - (multiple-value-bind (,temp-predicate-var ,temp-key-var ,temp-val-var) - (,next-fn) - ;; We use M-V-BIND instead of M-V-SETQ because we only - ;; want to assign values to the key and val vars when we - ;; are in the hash table. When we reach the end, - ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and - ;; temp-val-var. This might break any type declarations - ;; on the key and val vars. - (when ,temp-predicate-var - (setq ,val-var ,temp-val-var) - (setq ,key-var ,temp-key-var)) - (setq ,dummy-predicate-var ,temp-predicate-var) - )) ;post-test - ,post-steps))))) - - -(defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types) - (cond ((and prep-phrases (cdr prep-phrases)) - (loop-error "Too many prepositions!")) - ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) - (loop-error "Unknow preposition ~S" (caar prep-phrases)))) - (unless (symbolp variable) - (loop-error "Destructuring is not valid for package symbol iteration.")) - (let ((pkg-var (gensym "LOOP-PKGSYM-")) - (next-fn (gensym "LOOP-PKGSYM-NEXT-")) - (variable (or variable (gensym))) - (pkg (or (cadar prep-phrases) '*package*))) - (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) - `(((,variable nil ,data-type) (,pkg-var ,pkg)) - () - () - () - (not (multiple-value-setq (,(progn - ;;@@@@ If an implementation can get away without actually - ;; using a variable here, so much the better. - ;; (I.e., we need the first two values- T if a symbol was - ;; returned, and the symbol- but only use the first - ;; for this conditional.) - #+Genera NIL - #-Genera (loop-when-it-variable)) - ,variable) - (,next-fn))) - ()))) - -;;; Extension: for x being the elements of sequence -(defun loop-sequence-iteration-path (variable data-type prep-phrases) - (let (of-phrase) - (dolist (prep-phrase prep-phrases) - (let ((prep (car prep-phrase)) (rest (cdr prep-phrase))) - (ecase prep - ((:of :in) - (if of-phrase - (loop-error "Too many prepositions") - (setq of-phrase rest)))))) - (let ((it (gensym "ITER")) - (lim (gensym "LIMIT")) - (f-e (gensym "FROM-END")) - (step (gensym "STEP")) - (endp (gensym "ENDP")) - (elt (gensym "ELT")) - (seq (gensym "SEQ"))) - (push `(let ((,seq ,(car of-phrase)))) *loop-wrappers*) - (push `(sequence:with-sequence-iterator (,it ,lim ,f-e ,step ,endp ,elt) (,seq)) - *loop-wrappers*) - `(((,variable nil ,data-type)) () () nil (funcall ,endp ,seq ,it ,lim ,f-e) - (,variable (funcall ,elt ,seq ,it) ,it (funcall ,step ,seq ,it ,f-e)))))) - - -;;;; ANSI Loop - -(defun make-ansi-loop-universe (extended-p) - (let ((w (make-standard-loop-universe - :keywords `((named (loop-do-named)) - (initially (loop-do-initially)) - (finally (loop-do-finally)) - (do (loop-do-do)) - (doing (loop-do-do)) - (return (loop-do-return)) - (collect (loop-list-collection list)) - (collecting (loop-list-collection list)) - (append (loop-list-collection append)) - (appending (loop-list-collection append)) - (nconc (loop-list-collection nconc)) - (nconcing (loop-list-collection nconc)) - (count (loop-sum-collection count real fixnum)) - (counting (loop-sum-collection count real fixnum)) - (sum (loop-sum-collection sum number number)) - (summing (loop-sum-collection sum number number)) - (maximize (loop-maxmin-collection max)) - (minimize (loop-maxmin-collection min)) - (maximizing (loop-maxmin-collection max)) - (minimizing (loop-maxmin-collection min)) - (always (loop-do-always t nil)) ; Normal, do always - (never (loop-do-always t t)) ; Negate the test on always. - (thereis (loop-do-thereis t)) - (while (loop-do-while nil :while)) ; Normal, do while - (until (loop-do-while t :until)) ; Negate the test on while - (when (loop-do-if when nil)) ; Normal, do when - (if (loop-do-if if nil)) ; synonymous - (unless (loop-do-if unless t)) ; Negate the test on when - (with (loop-do-with)) - (repeat (loop-do-repeat))) - :for-keywords '((= (loop-ansi-for-equals)) - (across (loop-for-across)) - (in (loop-for-in)) - (on (loop-for-on)) - (from (loop-for-arithmetic :from)) - (downfrom (loop-for-arithmetic :downfrom)) - (upfrom (loop-for-arithmetic :upfrom)) - (below (loop-for-arithmetic :below)) - (above (loop-for-arithmetic :above)) - (to (loop-for-arithmetic :to)) - (upto (loop-for-arithmetic :upto)) - (downto (loop-for-arithmetic :downto)) - (by (loop-for-arithmetic :by)) - (being (loop-for-being))) - :iteration-keywords '((for (loop-do-for)) - (as (loop-do-for))) - :type-symbols '(array atom bignum bit bit-vector character compiled-function - complex cons double-float fixnum float - function hash-table integer keyword list long-float - nil null number package pathname random-state - ratio rational readtable sequence short-float - simple-array simple-bit-vector simple-string - simple-vector single-float standard-char - stream string base-char - symbol t vector) - :type-keywords nil - :ansi (if extended-p :extended t)))) - (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:which hash-key)) - (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:which hash-value)) - (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:symbol-types (:internal :external :inherited))) - (add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:symbol-types (:external))) - (add-loop-path '(present-symbol present-symbols) 'loop-package-symbols-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:symbol-types (:internal :external))) - (add-loop-path '(element elements) 'loop-sequence-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil) - w)) - - -(defparameter *loop-ansi-universe* - (make-ansi-loop-universe nil)) - - -(defun loop-standard-expansion (keywords-and-forms environment universe) - (if (and keywords-and-forms (symbolp (car keywords-and-forms))) - (loop-translate keywords-and-forms environment universe) - (let ((tag (gensym))) - `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) - -;;;INTERFACE: ANSI -(defmacro loop (&environment env &rest keywords-and-forms) - (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*)) - -) diff --git a/src/lisp/kernel/lsp/mislib.lisp b/src/lisp/kernel/lsp/mislib.lisp index 165c9051ac..8803301b04 100644 --- a/src/lisp/kernel/lsp/mislib.lisp +++ b/src/lisp/kernel/lsp/mislib.lisp @@ -13,6 +13,38 @@ (in-package "SYSTEM") +(defconstant lambda-list-keywords + (if (boundp 'lambda-list-keywords) + (symbol-value 'lambda-list-keywords) + '(&ALLOW-OTHER-KEYS + &AUX &BODY &ENVIRONMENT &KEY + &OPTIONAL &REST + &VA-REST + &WHOLE))) + +(defvar *proclaim-hook* nil) +(defun proclaim (decl) + "Args: (decl-spec) +Gives a global declaration. See DECLARE for possible DECL-SPECs." + ;;decl must be a proper list + (unless (core:proper-list-p decl) + (error 'type-error + :datum decl + :expected-type '(and list (satisfies core:proper-list-p)))) + (cond + ((eq (car decl) 'SPECIAL) + (mapc #'sys::*make-special (cdr decl))) + ((eq (car decl) 'cl:inline) + (dolist (name (cdr decl)) + (setf (gethash name *functions-to-inline*) t) + (remhash name *functions-to-notinline*))) + ((eq (car decl) 'cl:notinline) + (dolist (name (cdr decl)) + (setf (gethash name *functions-to-notinline*) t) + (remhash name *functions-to-inline*))) + (*proclaim-hook* + (funcall *proclaim-hook* decl)))) + ;;; This could be improved, e.g. getting the lambda expression of ;;; interpreted functions, but there are better introspection designs. ;;; For the second value we unconditionally return T, as the standard @@ -49,21 +81,21 @@ successfully, T is returned, else error." (defun do-time (closure) (let* ((real-start (get-internal-real-time)) - (run-start (get-internal-run-time)) + (run-start (get-internal-run-time)) (start-unwinds (gctools:thread-local-unwind-counter)) end-unwinds clasp-bytes-start clasp-bytes-end - real-end - run-end) + real-end + run-end) ;; Garbage collection forces counters to be updated (multiple-value-setq (clasp-bytes-start) (gctools:bytes-allocated)) (multiple-value-prog1 - (funcall closure) + (funcall closure) (multiple-value-setq (clasp-bytes-end) (gctools:bytes-allocated)) (setq run-end (get-internal-run-time) - real-end (get-internal-real-time) + real-end (get-internal-real-time) ) (setf end-unwinds (gctools:thread-local-unwind-counter)) (core:fmt *trace-output* "Time real({:.3f} secs) run({:.3f} secs) consed({} bytes) unwinds({})%N" @@ -91,19 +123,17 @@ Evaluates FORM, outputs the realtime and runtime used for the evaluation to (defconstant-eqx month-startdays #(0 31 59 90 120 151 181 212 243 273 304 334 365) equalp) -#-clasp-min (defun get-local-time-zone () "Returns the number of hours West of Greenwich for the local time zone." (core:unix-get-local-time-zone)) (defun recode-universal-time (sec min hour day month year tz dst) (let ((days (+ (if (and (leap-year-p year) (> month 2)) 1 0) - (1- day) - (svref month-startdays (1- month)) - (number-of-days-from-1900 year)))) + (1- day) + (svref month-startdays (1- month)) + (number-of-days-from-1900 year)))) (+ sec (* 60 (+ min (* 60 (+ tz dst hour (* 24 days)))))))) -#-clasp-min (defun check-tz (tz) ;; According to the CLHS glossary, a time zone is "a rational multiple of ;; 1/3600 between -24 (inclusive) and 24 (inclusive)". The multiple of 1/3600 @@ -120,9 +150,6 @@ Evaluates FORM, outputs the realtime and runtime used for the evaluation to (error "~a is not a valid time zone: Must be a rational multiple of 1/3600" tz))) -#+clasp-min (defun check-tz (tz) tz) ; typep not available yet - -#-clasp-min (defun decode-universal-time (orig-ut &optional (tz (get-local-time-zone) tz-p) &aux (dstp nil)) "Args: (integer &optional (timezone (si::get-local-time-zone))) @@ -144,13 +171,13 @@ DECODED-TIME." (incf year)) (when (leap-year-p year) (cond ((= day 60) (setf month 2 day 29)) - ((> day 60) (decf day)))) + ((> day 60) (decf day)))) (unless month (setq month (position day month-startdays :test #'<=) - day (- day (svref month-startdays (1- month))))) + day (- day (svref month-startdays (1- month))))) (if (and (not tz-p) (daylight-saving-time-p orig-ut year)) - (setf tz-p t dstp t) - (return (values sec min hour day month year dow dstp tz)))))) + (setf tz-p t dstp t) + (return (values sec min hour day month year dow dstp tz)))))) (defun encode-universal-time (sec min hour day month year &optional (tz (get-local-time-zone) tz-p)) @@ -162,18 +189,18 @@ GET-DECODED-TIME." (when (<= 0 year 99) ;; adjust to year in the century within 50 years of this year (multiple-value-bind (sec min hour day month this-year dow dstp tz) - (get-decoded-time) + (get-decoded-time) (declare (ignore sec min hour day month dow dstp tz)) (incf year (* 100 (ceiling (- this-year year 50) 100))))) (let ((dst 0)) (unless tz-p (when (daylight-saving-time-p (recode-universal-time sec min hour day month year tz -1) year) - ;; assume DST applies, and check if at corresponging UT it applies. - ;; There is an ambiguity between midnight and 1 o'clock on the day - ;; when time reverts from DST to solar: - ;; 12:01 on that day could be either 11:01 UT (before the switch) or - ;; 12:01 UT (after the switch). We opt for the former. - (setf dst -1))) + ;; assume DST applies, and check if at corresponging UT it applies. + ;; There is an ambiguity between midnight and 1 o'clock on the day + ;; when time reverts from DST to solar: + ;; 12:01 on that day could be either 11:01 UT (before the switch) or + ;; 12:01 UT (after the switch). We opt for the former. + (setf dst -1))) (recode-universal-time sec min hour day month year tz dst))) (defun daylight-saving-time-p (universal-time year) @@ -184,76 +211,85 @@ Universal Time UT, which defaults to the current time." ;; therefore restrict the time to the interval that can handled by ;; the timezone database. (let* ((utc-1-1-1970 2208988800) - (unix-time (- universal-time utc-1-1-1970))) + (unix-time (- universal-time utc-1-1-1970))) (cond ((minusp unix-time) - ;; For dates before 1970 we shift to 1980/81 to guess the daylight - ;; saving times. - (setf unix-time - (+ (if (leap-year-p year) - #.(encode-universal-time 0 0 0 1 1 1980 0) - #.(encode-universal-time 0 0 0 1 1 1981 0)) - (- universal-time (encode-universal-time 0 0 0 1 1 year 0) utc-1-1-1970)))) - ((not (fixnump unix-time)) - ;; Same if date is too big: we shift to year 2035/36, like SBCL does. - (setf unix-time - (+ (if (leap-year-p year) - #.(encode-universal-time 0 0 0 1 1 2032 0) - #.(encode-universal-time 0 0 0 1 1 2033 0)) - (- universal-time (encode-universal-time 0 0 0 1 1 year 0) utc-1-1-1970))))) - #-clasp-min + ;; For dates before 1970 we shift to 1980/81 to guess the daylight + ;; saving times. + (setf unix-time + (+ (if (leap-year-p year) + #.(encode-universal-time 0 0 0 1 1 1980 0) + #.(encode-universal-time 0 0 0 1 1 1981 0)) + (- universal-time (encode-universal-time 0 0 0 1 1 year 0) utc-1-1-1970)))) + ((not (fixnump unix-time)) + ;; Same if date is too big: we shift to year 2035/36, like SBCL does. + (setf unix-time + (+ (if (leap-year-p year) + #.(encode-universal-time 0 0 0 1 1 2032 0) + #.(encode-universal-time 0 0 0 1 1 2033 0)) + (- universal-time (encode-universal-time 0 0 0 1 1 year 0) utc-1-1-1970))))) (core:unix-daylight-saving-time unix-time))) (defun get-decoded-time () "Args: () Returns the current day-and-time as nine values: - second (0 - 59) - minute (0 - 59) - hour (0 - 23) - date (1 - 31) - month (1 - 12) - year (A.D.) - day of week (0 for Mon, .. 6 for Sun) - daylight saving time or not (T or NIL) - time zone (Offset from GMT in hours)" + second (0 - 59) + minute (0 - 59) + hour (0 - 23) + date (1 - 31) + month (1 - 12) + year (A.D.) + day of week (0 for Mon, .. 6 for Sun) + daylight saving time or not (T or NIL) + time zone (Offset from GMT in hours)" (decode-universal-time (get-universal-time))) (defun ensure-directories-exist (pathname &key verbose (mode #o777)) - "Args: (ensure-directories pathname &key :verbose) +"Args: (ensure-directories pathname &key :verbose) Creates tree of directories specified by the given pathname. Outputs - (VALUES pathname created) + (VALUES pathname created) where CREATED is true only if we succeeded on creating all directories." (let* ((created nil) - (full-pathname (merge-pathnames pathname)) - d) + (full-pathname (merge-pathnames pathname)) + d) (when (typep full-pathname 'logical-pathname) (setf full-pathname (translate-logical-pathname full-pathname))) (when (or (wild-pathname-p full-pathname :directory) - (wild-pathname-p full-pathname :host) - (wild-pathname-p full-pathname :device)) + (wild-pathname-p full-pathname :host) + (wild-pathname-p full-pathname :device)) (error 'file-error :pathname pathname)) ;; Here we have already a full pathname. We set our own ;; *default-pathname-defaults* to avoid that the user's value, ;; which may contain names or types, clobbers our computations. (let ((*default-pathname-defaults* - (make-pathname :name nil :type nil :directory nil - :defaults full-pathname))) + (make-pathname :name nil :type nil :directory nil + :defaults full-pathname))) (dolist (item (pathname-directory full-pathname)) - (setf d (nconc d (list item))) - (let* ((p (make-pathname :directory d :defaults *default-pathname-defaults*))) - (unless (or (symbolp item) (si::file-kind p nil)) - (setf created t) - (let ((ps (namestring p))) - (when verbose - (format t "~%;;; Making directory ~A" ps)) - (unless (si:ensure-directory ps mode) - (setf created nil)))))) + (setf d (nconc d (list item))) + (let* ((p (make-pathname :directory d :defaults *default-pathname-defaults*))) + (unless (or (symbolp item) (si::file-kind p nil)) + (setf created t) + (let ((ps (namestring p))) + (when verbose + (format t "~%;;; Making directory ~A" ps)) + (si::mkdir ps mode))))) (values pathname created)))) +(defun hash-table-iterator (hash-table) + (let ((pairs (core:hash-table-pairs hash-table)) + (hash-index 0)) + (function (lambda () + (if (>= hash-index (length pairs)) + nil + (let* ((key (elt pairs hash-index)) + (val (elt pairs (incf hash-index)))) + (incf hash-index) + (values t key val))))))) + (defmacro with-hash-table-iterator ((iterator package) &body body) "Syntax: (with-hash-table-iterator (iterator package) &body body) Loop over the elements of a hash table. ITERATOR is a lexically bound function that outputs three values - (VALUES entry-p key value) + (VALUES entry-p key value) ENTRY-P is true only if KEY and VALUE denote a pair of key and value of the hash table; otherwise it signals that we have reached the end of the hash table." `(let ((,iterator (hash-table-iterator ,package))) @@ -318,3 +354,20 @@ Evaluates FORM, outputs the allocations that took place for the evaluation to #+debug-count-allocations (export '(allocations collect-backtraces-for-allocations-by-stamp)) + +(defun do-memory-ramp (closure pattern) + (unwind-protect + (progn + (gctools:alloc-pattern-begin pattern) + (funcall closure)) + (gctools:alloc-pattern-end))) + +(defmacro with-memory-ramp ((&key (pattern 'gctools:ramp)) &body body) + `(if (member :disable-memory-ramp *features*) + (progn + (core:fmt t "Compiling with memory-ramp DISABLED%N") + (funcall (lambda () (progn ,@body)))) + (do-memory-ramp (lambda () (progn ,@body)) ,pattern))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(with-memory-ramp))) diff --git a/src/lisp/kernel/lsp/mp-package.lisp b/src/lisp/kernel/lsp/mp-package.lisp new file mode 100644 index 0000000000..70e9c24f37 --- /dev/null +++ b/src/lisp/kernel/lsp/mp-package.lisp @@ -0,0 +1,25 @@ +(in-package #:mp) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(export '(;; locks + with-lock with-rwlock + ;; processes + abort-process + ;; atomic operations + atomic fence cas get-atomic-expansion define-atomic-expander + not-atomic not-atomic-place + atomic-update atomic-update-explicit + atomic-incf atomic-decf atomic-incf-explicit atomic-decf-explicit + atomic-push atomic-push-explicit atomic-pop atomic-pop-explicit + atomic-pushnew atomic-pushnew-explicit + ;; interrupts + interrupt service-interrupt interrupt-process + process-kill process-cancel process-suspend + simple-interrupt simple-interactive-interrupt + cancellation-interrupt suspension-interrupt + call-interrupt call-interrupt-function + signal-pending-interrupts raise + without-interrupts with-interrupts with-local-interrupts + with-restored-interrupts allow-with-interrupts interruptiblep + )) +) ; eval-when diff --git a/src/lisp/kernel/lsp/mp.lisp b/src/lisp/kernel/lsp/mp.lisp index 301815e337..ea45cc08eb 100644 --- a/src/lisp/kernel/lsp/mp.lisp +++ b/src/lisp/kernel/lsp/mp.lisp @@ -13,15 +13,6 @@ ;;;; ;;;; See file '../Copyright' for full details. -#+threads -(defpackage "MP" - (:use "CL") - (:import-from :CORE "WITH-UNIQUE-NAMES") - (:export "WITH-LOCK" "WITH-RWLOCK" "WITHOUT-INTERRUPTS" "WITH-INTERRUPTS" - "WITH-LOCAL-INTERRUPTS" "WITH-RESTORED-INTERRUPTS" "ALLOW-WITH-INTERRUPTS" - "INTERRUPTIBLEP" - "ABORT-PROCESS")) - #+threads (in-package "MP") @@ -66,20 +57,27 @@ WITHOUT-INTERRUPTS in: ;; regardless of the interrupt policy in effect when it is called. (lambda () (with-local-interrupts ...))) " - (with-unique-names (outer-allow-with-interrupts outer-interrupts-enabled) + (core::with-unique-names (outer-allow-with-interrupts outer-interrupts-enabled) `(multiple-value-prog1 (macrolet ((allow-with-interrupts (&body allow-forms) - `(let ((si:*allow-with-interrupts* ,',outer-allow-with-interrupts)) - ,@allow-forms)) + (list* 'let + (list (list 'core::*allow-with-interrupts* + ',outer-allow-with-interrupts)) + allow-forms)) (with-restored-interrupts (&body with-forms) - `(let ((si:*interrupts-enabled* ,',outer-interrupts-enabled)) - ,@with-forms)) + (list* 'let + (list (list 'core::*interrupts-enabled* + ',outer-interrupts-enabled)) + with-forms)) (with-local-interrupts (&body with-forms) - `(let* ((si:*allow-with-interrupts* ,',outer-allow-with-interrupts) - (si:*interrupts-enabled* ,',outer-allow-with-interrupts)) - (when ,',outer-allow-with-interrupts - (si::check-pending-interrupts)) - (locally ,@with-forms)))) + (list 'let* + (list (list 'core::*allow-with-interrupts* + ',outer-allow-with-interrupts) + (list 'core::*interrupts-enabled* + ',outer-allow-with-interrupts)) + (list 'when ',outer-allow-with-interrupts + '(core::check-pending-interrupts)) + (list* 'locally with-forms)))) (let* ((,outer-interrupts-enabled si:*interrupts-enabled*) (si:*interrupts-enabled* nil) (,outer-allow-with-interrupts si:*allow-with-interrupts*) @@ -90,7 +88,7 @@ WITHOUT-INTERRUPTS in: (when si:*interrupts-enabled* (si::check-pending-interrupts))))) -(defun mp:interruptiblep () +(defun interruptiblep () "Returns true iff the current process is interruptible (i.e. not in a WITHOUT-INTERRUPTS block)." si:*interrupts-enabled*) @@ -103,7 +101,7 @@ As interrupts are normally allowed WITH-INTERRUPTS only makes sense if there is an outer WITHOUT-INTERRUPTS with a corresponding ALLOW-WITH-INTERRUPTS: interrupts are not enabled if any outer WITHOUT-INTERRUPTS is not accompanied by ALLOW-WITH-INTERRUPTS." - (with-unique-names (allowp enablep) + (core::with-unique-names (allowp enablep) ;; We could manage without ENABLEP here, but that would require ;; taking extra care not to ever have *ALLOW-WITH-INTERRUPTS* NIL ;; and *INTERRUPTS-ENABLED* T -- instead of risking future breakage @@ -120,13 +118,13 @@ by ALLOW-WITH-INTERRUPTS." #-threads `(progn ,@body) #+threads - (with-unique-names (lock) + (core::with-unique-names (lock) `(let ((,lock ,lock-form)) (unwind-protect (progn - (mp:get-lock ,lock) + (get-lock ,lock) (locally ,@body)) - (mp:giveup-lock ,lock))))) + (giveup-lock ,lock))))) #+threads (defmacro with-rwlock ((lock op) &body body) @@ -140,15 +138,15 @@ Valid values of argument OP are :READ or :WRITE (let ((s-lock (gensym))) `(let ((,s-lock ,lock)) (,(if (eq :read op) - 'mp:shared-lock - 'mp:write-lock) + 'shared-lock + 'write-lock) ,s-lock) (unwind-protect (progn ,@body) (,(if (eq :read op) - 'mp:shared-unlock - 'mp:write-unlock) + 'shared-unlock + 'write-unlock) ,s-lock))))) #+threads @@ -156,7 +154,6 @@ Valid values of argument OP are :READ or :WRITE "Immediately end the current process abnormally. If PROCESS-JOIN is called on this process thereafter, it will signal an error of type PROCESS-JOIN-ERROR. If DATUM is provided, it and ARGUMENTS designate a condition of default type SIMPLE-ERROR. This condition will be attached to the PROCESS-JOIN-ERROR." - ;; Bootstrap note: coerce-to-condition won't be defined until CLOS is up. (%abort-process (if datum (core::coerce-to-condition datum arguments 'simple-error 'abort-process) diff --git a/src/lisp/kernel/lsp/numlib.lisp b/src/lisp/kernel/lsp/numlib.lisp index 7ae200fda4..f774cd267f 100644 --- a/src/lisp/kernel/lsp/numlib.lisp +++ b/src/lisp/kernel/lsp/numlib.lisp @@ -15,55 +15,26 @@ (in-package "SYSTEM") -(eval-when (:compile-toplevel :execute) - (defun binary-search (f min max) - (do ((new (/ (+ min max) 2) (/ (+ min max) 2))) - ((>= min max) - max) - (if (funcall f new) - (if (= new max) - (return max) - (setq max new)) - (if (= new min) - (return max) - (setq min new))))) - (defun epsilon+ (x) - (/= (float 1 x) (+ (float 1 x) x))) - (defun epsilon- (x) - (/= (float 1 x) (- (float 1 x) x)))) - -(defconstant short-float-epsilon - #.(binary-search #'epsilon+ (coerce 0 'short-float) (coerce 1 'short-float)) - "The smallest postive short-float E that satisfies - (not (= (float 1 E) (+ (float 1 E) E)))") -(defconstant single-float-epsilon - #.(binary-search #'epsilon+ (coerce 0 'single-float) (coerce 1 'single-float)) - "The smallest postive single-float E that satisfies - (not (= (float 1 E) (+ (float 1 E) E)))") -(defconstant double-float-epsilon - #.(binary-search #'epsilon+ (coerce 0 'double-float) (coerce 1 'double-float)) - "The smallest postive double-float E that satisfies - (not (= (float 1 E) (+ (float 1 E) E)))") -(defconstant long-float-epsilon - #.(binary-search #'epsilon+ (coerce 0 'long-float) (coerce 1 'long-float)) - "The smallest postive long-float E that satisfies - (not (= (float 1 E) (+ (float 1 E) E)))") -(defconstant short-float-negative-epsilon - #.(binary-search #'epsilon- (coerce 0 'short-float) (coerce 1 'short-float)) - "The smallest positive short-float E that satisfies - (not (= (float 1 E) (- (float 1 E) E)))") -(defconstant single-float-negative-epsilon - #.(binary-search #'epsilon- (coerce 0 'single-float) (coerce 1 'single-float)) - "The smallest positive single-float E that satisfies - (not (= (float 1 E) (- (float 1 E) E)))") -(defconstant double-float-negative-epsilon - #.(binary-search #'epsilon- (coerce 0 'double-float) (coerce 1 'double-float)) - "The smallest positive double-float E that satisfies - (not (= (float 1 E) (- (float 1 E) E)))") -(defconstant long-float-negative-epsilon - #.(binary-search #'epsilon- (coerce 0 'long-float) (coerce 1 'long-float)) - "The smallest positive long-float E that satisfies - (not (= (float 1 E) (- (float 1 E) E)))") +(defmacro ext::with-float-traps-masked (traps &body body) + (let ((previous (gensym "PREVIOUS")) + (mask (reduce (lambda (bits trap) + (logior bits + (ecase trap + (:underflow core:+fe-underflow+) + (:overflow core:+fe-overflow+) + (:invalid core:+fe-invalid+) + (:inexact core:+fe-inexact+) + (:divide-by-zero core:+fe-divbyzero+) + (:denormalized-operand 0)))) + traps + :initial-value 0))) + `(let ((,previous (core:fe-disable-except ,mask))) + (unwind-protect + (progn ,@body) + (core:fe-restore-except ,previous))))) + +(defun 1- (num) (- num 1)) +(defun 1+ (num) (+ num 1)) (defun isqrt (i) "Args: (integer) @@ -88,58 +59,20 @@ Returns zero for non-complex numbers." (if (eq x 0) 0.0 (float 0 (realpart x))) (atan (imagpart x) (realpart x)))) -;;; this is defined in numbers.h -#+(or) -(defun signum (x) - "Args: (number) -Returns a number that represents the sign of NUMBER. Returns NUMBER If it is -zero. Otherwise, returns the value of (/ NUMBER (ABS NUMBER))" - (if (zerop x) x (/ x (abs x)))) - (defun cis (theta) "Args: (theta) Returns a complex number whose realpart and imagpart are the values of (COS THETA) and (SIN THETA) respectively." (complex (cos theta) (sin theta))) -;;; this is defined in numbers.h -#+(or) -(defun asin (x) - "Args: (number) -Returns the arc sine of NUMBER." - (if #+clasp-min t #-clasp-min (complexp x) - (complex-asin x) - #-clasp-min - (let* ((x (float x)) - (xr (float x 1l0))) - (declare (long-float xr)) - (if (and (<= -1.0 xr) (<= xr 1.0)) - (float (core:num-op-asin xr) x) - (complex-asin x))))) - ;; Ported from CMUCL (defun complex-asin (z) (declare (number z)) (let ((sqrt-1-z (sqrt (- 1 z))) - (sqrt-1+z (sqrt (+ 1 z)))) + (sqrt-1+z (sqrt (+ 1 z)))) (complex (atan (realpart z) (realpart (* sqrt-1-z sqrt-1+z))) - (asinh (imagpart (* (conjugate sqrt-1-z) - sqrt-1+z)))))) - -;;; this is defined in numbers.h -#+(or) -(defun acos (x) - "Args: (number) -Returns the arc cosine of NUMBER." - (if #+clasp-min t #-clasp-min (complexp x) - (complex-acos x) - #-clasp-min - (let* ((x (float x)) - (xr (float x 1l0))) - (declare (long-float xr)) - (if (and (<= -1.0 xr) (<= xr 1.0)) - (float (core:num-op-acos xr) (float x)) - (complex-acos x))))) + (asinh (imagpart (* (conjugate sqrt-1-z) + sqrt-1+z)))))) ;; Ported from CMUCL (defun complex-acos (z) @@ -155,27 +88,25 @@ Returns the arc cosine of NUMBER." "Args: (number) Returns the hyperbolic arc sine of NUMBER." ;(log (+ x (sqrt (+ 1.0 (* x x))))) - (if #+clasp-min t #-clasp-min (complexp x) + (if (complexp x) (let* ((iz (complex (- (imagpart x)) (realpart x))) (result (complex-asin iz))) (complex (imagpart result) (- (realpart result)))) - #-clasp-min - (float (core:num-op-asinh x) (float x)))) + (float (core:num-op-asinh (float x 1l0)) (float x)))) ;; Ported from CMUCL (defun acosh (x) "Args: (number) Returns the hyperbolic arc cosine of NUMBER." ;(log (+ x (sqrt (* (1- x) (1+ x))))) - (if #+clasp-min t #-clasp-min (complexp x) + (if (complexp x) (complex-acosh x) - #-clasp-min (let* ((x (float x)) (xr (float x 1d0))) (declare (double-float xr)) - (if (<= 1.0 xr) - (float (core:num-op-acosh xr) (float x)) + (if (<= 1l0 xr) + (float (core:num-op-acosh xr) x) (complex-acosh x))))) (defun complex-acosh (z) @@ -190,14 +121,13 @@ Returns the hyperbolic arc cosine of NUMBER." "Args: (number) Returns the hyperbolic arc tangent of NUMBER." ;(/ (- (log (1+ x)) (log (- 1 x))) 2) - (if #+clasp-min t #-clasp-min (complexp x) + (if (complexp x) (complex-atanh x) - #-clasp-min (let* ((x (float x)) - (xr (float x 1d0))) - (declare (double-float xr)) - (if (and (<= -1.0 xr) (<= xr 1.0)) - (float (core:num-op-atanh xr) (float x)) + (xr (float x 1l0))) + (declare (long-float xr)) + (if (and (<= -1l0 xr) (<= xr 1l0)) + (float (core:num-op-atanh xr) x) (complex-atanh x))))) (defun complex-atanh (z) diff --git a/src/lisp/kernel/lsp/packages.lisp b/src/lisp/kernel/lsp/packages.lisp deleted file mode 100644 index 77d48930ed..0000000000 --- a/src/lisp/kernel/lsp/packages.lisp +++ /dev/null @@ -1,267 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Export symbols in CORE package -;;; -(eval-when (:compile-toplevel :load-toplevel :execute) - (core:select-package "CORE")) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(single-dispatch-missing-dispatch-argument-error - unrecognized-keyword-argument-error - argc - argv - rmdir - select-source-files - compile-kernel-file - load-system - compile-system - maybe-load-clasprc - process-command-line-load-eval-sequence - top-level - *defun-inline-hook* - *proclaim-hook* - proper-list-p - expand-associative - expand-compare - expand-uncompare - with-memory-ramp - ;; bytecode - do-instructions do-module-instructions - ;;;;MISSING SYMBOLS!!!!! - set-symbol-plist - structure-name - ))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Export symbols in GRAY package -;;; -(eval-when (:compile-toplevel :load-toplevel :execute) - (core:select-package "GRAY")) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(fundamental-stream - fundamental-input-stream - fundamental-output-stream - fundamental-character-stream - fundamental-binary-stream - fundamental-character-input-stream - fundamental-character-output-stream - fundamental-binary-input-stream - fundamental-binary-output-stream))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Export symbols in SEQUENCE package -;;; - -(eval-when (:compile-toplevel :load-toplevel :execute) - (core:select-package "SEQUENCE")) - -;;; SEQUENCE does not :use CL, so qualify CL symbols. -(cl:eval-when (:compile-toplevel :load-toplevel :execute) - (cl:export '(;; core protocol - adjust-sequence - elt - length - make-sequence-like - ;; iterator protocol - iterator-step - iterator-endp - iterator-element - iterator-index - iterator-copy - make-simple-sequence-iterator - make-sequence-iterator - ;; may be customized or derived - emptyp - ;; ditto, but are CL symbols too - count count-if count-if-not - copy-seq - delete delete-if delete-if-not - delete-duplicates - fill - find find-if find-if-not - mismatch - nsubstitute nsubstitute-if nsubstitute-if-not - nreverse - position position-if position-if-not - reduce - remove remove-if remove-if-not - remove-duplicates - replace - reverse - search - sort stable-sort - subseq - substitute substitute-if substitute-if-not - ;; helper macros - dosequence - with-sequence-iterator - ;; clasp extensions - protocol-unimplemented - protocol-unimplemented-operation - make-sequence - define-random-access-sequence - make-random-access-iterator - define-iterative-sequence - )) - (core:select-package "CORE")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Export symbols in MP package -;;; - -(eval-when (:compile-toplevel :load-toplevel :execute) - (core:select-package "MP")) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(;; atomic operations - atomic fence cas get-atomic-expansion define-atomic-expander - not-atomic not-atomic-place - atomic-update atomic-update-explicit - atomic-incf atomic-decf atomic-incf-explicit atomic-decf-explicit - atomic-push atomic-push-explicit atomic-pop atomic-pop-explicit - atomic-pushnew atomic-pushnew-explicit - ;; interrupts - interrupt service-interrupt interrupt-process - process-kill process-cancel process-suspend - simple-interrupt simple-interactive-interrupt - cancellation-interrupt suspension-interrupt - call-interrupt call-interrupt-function - signal-pending-interrupts raise - )) - (core:select-package "CORE")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Export symbols in EXT package -;;; -(eval-when (:execute :compile-toplevel :load-toplevel) - (core:select-package :ext)) - -(import '(cmp::muffle-note - core:argc - core:argv - core:getpid - core:hash-table-weakness - core:list-all-logical-hosts - core:logical-host-p - core:make-weak-pointer - core:temporary-directory - core:mkstemp - core:printing-char-p - core:quit - core:rmdir - core:weak-pointer-valid - core:weak-pointer-value - core:num-logical-processors - core:quasiquote - core:unquote - core:unquote-splice - core:unquote-nsplice - gctools:finalize - gctools:garbage-collect - gctools:save-lisp-and-die) - :ext) - -(eval-when (:execute :compile-toplevel :load-toplevel) - (export '(*module-provider-functions* - *source-location-kinds* - current-source-location - source-location - source-location-pathname - source-location-offset - source-location-definer - source-location-description - compiled-function-name - compiled-function-file - who-calls - who-binds - who-sets - who-references - who-macroexpands - who-specializes-directly - list-callers - list-callees - macroexpand-all - list-all-logical-hosts - logical-host-p - array-index - byte8 - integer8 - byte16 - integer16 - byte32 - integer32 - byte64 - integer64 - assume-no-errors - all-encodings - make-encoding - assert-error - float-nan-p - float-infinity-p - character-coding-error - character-encoding-error - character-decoding-error - stream-encoding-error - stream-decoding-error - generate-encoding-hashtable - quit - with-float-traps-masked - defun/typed - enable-interrupt default-interrupt ignore-interrupt - get-signal-handler set-signal-handler - *ed-functions* - ;;; for asdf and slime and trivial-garbage to use ext: - getpid argc argv rmdir temporary-directory mkstemp weak-pointer-value - make-weak-pointer weak-pointer-valid hash-table-weakness - num-logical-processors - quasiquote - unquote - unquote-splice - unquote-nsplice - compiler-note - muffle-note - segmentation-violation - stack-overflow - stack-overflow-size - stack-overflow-type - storage-exhausted - illegal-instruction - unix-signal-received - unix-signal-received-code - unix-signal-received-handler - interactive-interrupt - getcwd - chdir - +process-standard-input+ - system - float-nan-string - float-infinity-string - package-local-nicknames - add-package-local-nickname - remove-package-local-nickname - package-locally-nicknamed-by-list - package-implements-list - with-unlocked-packages - keep-old change-nick ; restarts for add-package-local-nicknames - ;; symbol name conflicts - name-conflict name-conflict-candidates resolve-conflict - ;; Readers of RESTART objects - restart-function restart-report-function - restart-interactive-function restart-test-function - restart-associated-conditions - ;; Debugger - tpl-frame tpl-argument tpl-arguments - ;; GC - garbage-collect finalize save-lisp-and-die - ;; Compiler - describe-compiler-policy - with-current-source-form - start-autocompilation - stop-autocompilation - ;; Misc - printing-char-p))) diff --git a/src/lisp/kernel/lsp/packlib.lisp b/src/lisp/kernel/lsp/packlib.lisp index 0c739eff82..e31046159b 100644 --- a/src/lisp/kernel/lsp/packlib.lisp +++ b/src/lisp/kernel/lsp/packlib.lisp @@ -89,19 +89,20 @@ is used." (macrolet ((,iterator () (list 'funcall ',iterator))) ,@body))) -(defun expand-do-symbols (var package result-form body options) - (let* ((i (gensym)) - (found (gensym)) - declaration) - (multiple-value-setq (declaration body) - (find-declarations body nil)) - `(do* ((,i (packages-iterator ,package ',options t)) - ,found ,var) - (nil) - ,@declaration - (multiple-value-setq (,found ,var) (funcall ,i)) - (unless ,found (return ,result-form)) - ,@body))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun expand-do-symbols (var package result-form body options) + (let* ((i (gensym)) + (found (gensym)) + declaration) + (multiple-value-setq (declaration body) + (find-declarations body nil)) + `(do* ((,i (packages-iterator ,package ',options t)) + ,found ,var) + (nil) + ,@declaration + (multiple-value-setq (,found ,var) (funcall ,i)) + (unless ,found (return ,result-form)) + ,@body)))) (defmacro do-symbols ((var &optional (package '*package*) (result-form nil)) &rest body) @@ -186,3 +187,112 @@ If PACKAGE is non-NIL, then only the specified PACKAGE is searched." (when (search string (string symbol) :test #'char-equal) (setq list (cons symbol list)))))) list)) + +(in-package #:ext) + +(defmacro with-package-read-lock ((package) &body body) + `(core:call-with-package-read-lock ,package (lambda () ,@body))) +(defmacro with-package-read-write-lock ((package) &body body) + `(core:call-with-package-read-write-lock ,package (lambda () ,@body))) + +(defmacro with-unlocked-packages ((&rest packages) &body body) + ;; FIXME? technically prone to TOCTOU races, + ;; since package locks don't use the package lock (confusing, yes) + (let ((unlocked-packages (gensym "UNLOCKED-PACKAGES"))) + `(let ((,unlocked-packages ())) + (unwind-protect + (progn + (dolist (p ',packages) + (let ((p (find-package p))) + (when (package-locked-p p) + (push p ,unlocked-packages) + (unlock-package p)))) + ,@body) + (dolist (p ,unlocked-packages) + (when (package-name p) ; make sure it hasn't been deleted + (lock-package p))))))) + +(defun package-local-nicknames (package-designator) + "Return an alist (string . package) of local nicknames in the given package. +See also: :LOCAL-NICKNAMES option to DEFPACKAGE." + (let ((package (find-package package-designator))) + (when (null package) (error 'package-error :package package)) + (with-package-read-lock (package) + (core:package-local-nicknames-internal package)))) + +(defun add-package-local-nickname (nickname-designator actual-package &optional (package-designator *package*)) + "Add a nickname for actual-package, local to the designated package. +Signals a continuable error if the new nickname is already a nickname in the designated package +for a different package. +See also: :LOCAL-NICKNAMES option to DEFPACKAGE." + (let* ((nickname (string nickname-designator)) + (actual (find-package actual-package)) + (package (find-package package-designator)) + old + (force nil)) + (when (null actual) (error 'package-error :package actual-package)) + (when (null package) (error 'package-error :package package-designator)) + (tagbody + loop + (with-package-read-write-lock (package) + (let* ((locals (core:package-local-nicknames-internal package)) + (existing (assoc nickname locals :test #'string=))) + (cond ((null existing) + (push (cons nickname actual) (core:package-local-nicknames-internal package))) + ((eq (cdr existing) actual)) ; already in there; do nothing. + (force (setf (cdr existing) actual)) + (t (setf old (cdr existing)) (go err))))) + (go done) + err ; signal errors without holding the lock. + (restart-case + (error 'core:simple-package-error + :package package + :format-control "Cannot add ~a as local nickname for ~a in ~a: ~ +it's already a local nickname for ~a." + :format-arguments (list nickname (package-name actual) (package-name package) (package-name old))) + (keep-old () + :report (lambda (s) + (format s "Keep ~a as local nickname for ~a." + nickname (package-name old)))) + (change-nick () + :report (lambda (s) + (format s "Use ~a as local nickname for ~a instead." + nickname (package-name actual))) + (setf force t) + (go loop))) + done) + package)) + +(defun remove-package-local-nickname (nickname-designator &optional (package-designator *package*)) + "If the designated package has the nickname locally, it is removed and a true value is returned. +Otherwise NIL is returned. +See also: :LOCAL-NICKNAMES option to DEFPACKAGE." + (let ((package (find-package package-designator)) + (nickname (string nickname-designator))) + (when (null package) (error 'package-error :package package)) + (with-package-read-write-lock (package) + (let* ((locals (core:package-local-nicknames-internal package)) + (pair (assoc nickname locals :test #'string=))) + (when pair ; else return NIL + (setf (core:package-local-nicknames-internal package) (remove pair locals :test #'eq)) + t))))) + +(defun package-locally-nicknamed-by-list (package-designator) + "Return a list of packages that have a local nickname for the designated package. +See also: :LOCAL-NICKNAMES option to DEFPACKAGE." + (let ((package (find-package package-designator)) + (result nil)) + (when (null package) (error 'package-error :package package)) + (dolist (p (list-all-packages) result) + (when (find package (package-local-nicknames p) :key #'cdr :test #'eq) + (push p result))))) + +(defun package-implements-list (package-designator) + "Return a list of packages that the designated package implements. +See also: :IMPLEMENT option to DEFPACKAGE." + (let ((package (find-package package-designator)) + (result nil)) + (when (null package) (error 'package-error :package package)) + (dolist (p (list-all-packages) result) + (when (find package (package-implemented-by-list p)) + (push p result))))) diff --git a/src/lisp/kernel/lsp/packlib2.lisp b/src/lisp/kernel/lsp/packlib2.lisp deleted file mode 100644 index 9b50479ffc..0000000000 --- a/src/lisp/kernel/lsp/packlib2.lisp +++ /dev/null @@ -1,115 +0,0 @@ -;;;; Package functions that need the condition system to be up -;;;; so that we can have restarts etc. -;;;; This is actually more of them than we have here- there are -;;;; some places where we need to be signaling continuable -;;;; errors and aren't. -;;;; package lock macros also go here because why not. - -(in-package #:ext) - -(defmacro with-package-read-lock ((package) &body body) - `(core:call-with-package-read-lock ,package (lambda () ,@body))) -(defmacro with-package-read-write-lock ((package) &body body) - `(core:call-with-package-read-write-lock ,package (lambda () ,@body))) - -(defmacro ext:with-unlocked-packages ((&rest packages) &body body) - ;; FIXME? technically prone to TOCTOU races, - ;; since package locks don't use the package lock (confusing, yes) - (let ((unlocked-packages (gensym "UNLOCKED-PACKAGES"))) - `(let ((,unlocked-packages ())) - (unwind-protect - (progn - (dolist (p ',packages) - (let ((p (find-package p))) - (when (ext:package-locked-p p) - (push p ,unlocked-packages) - (ext:unlock-package p)))) - ,@body) - (dolist (p ,unlocked-packages) - (when (package-name p) ; make sure it hasn't been deleted - (ext:lock-package p))))))) - -(defun package-local-nicknames (package-designator) - "Return an alist (string . package) of local nicknames in the given package. -See also: :LOCAL-NICKNAMES option to DEFPACKAGE." - (let ((package (find-package package-designator))) - (when (null package) (error 'package-error :package package)) - (with-package-read-lock (package) - (core:package-local-nicknames-internal package)))) - -(defun add-package-local-nickname (nickname-designator actual-package &optional (package-designator *package*)) - "Add a nickname for actual-package, local to the designated package. -Signals a continuable error if the new nickname is already a nickname in the designated package -for a different package. -See also: :LOCAL-NICKNAMES option to DEFPACKAGE." - (let* ((nickname (string nickname-designator)) - (actual (find-package actual-package)) - (package (find-package package-designator)) - old - (force nil)) - (when (null actual) (error 'package-error :package actual-package)) - (when (null package) (error 'package-error :package package-designator)) - (tagbody - loop - (with-package-read-write-lock (package) - (let* ((locals (core:package-local-nicknames-internal package)) - (existing (assoc nickname locals :test #'string=))) - (cond ((null existing) - (push (cons nickname actual) (core:package-local-nicknames-internal package))) - ((eq (cdr existing) actual)) ; already in there; do nothing. - (force (setf (cdr existing) actual)) - (t (setf old (cdr existing)) (go err))))) - (go done) - err ; signal errors without holding the lock. - (restart-case - (error 'core:simple-package-error - :package package - :format-control "Cannot add ~a as local nickname for ~a in ~a: ~ -it's already a local nickname for ~a." - :format-arguments (list nickname (package-name actual) (package-name package) (package-name old))) - (keep-old () - :report (lambda (s) - (format s "Keep ~a as local nickname for ~a." - nickname (package-name old)))) - (change-nick () - :report (lambda (s) - (format s "Use ~a as local nickname for ~a instead." - nickname (package-name actual))) - (setf force t) - (go loop))) - done) - package)) - -(defun remove-package-local-nickname (nickname-designator &optional (package-designator *package*)) - "If the designated package has the nickname locally, it is removed and a true value is returned. -Otherwise NIL is returned. -See also: :LOCAL-NICKNAMES option to DEFPACKAGE." - (let ((package (find-package package-designator)) - (nickname (string nickname-designator))) - (when (null package) (error 'package-error :package package)) - (with-package-read-write-lock (package) - (let* ((locals (core:package-local-nicknames-internal package)) - (pair (assoc nickname locals :test #'string=))) - (when pair ; else return NIL - (setf (core:package-local-nicknames-internal package) (remove pair locals :test #'eq)) - t))))) - -(defun package-locally-nicknamed-by-list (package-designator) - "Return a list of packages that have a local nickname for the designated package. -See also: :LOCAL-NICKNAMES option to DEFPACKAGE." - (let ((package (find-package package-designator)) - (result nil)) - (when (null package) (error 'package-error :package package)) - (dolist (p (list-all-packages) result) - (when (find package (package-local-nicknames p) :key #'cdr :test #'eq) - (push p result))))) - -(defun package-implements-list (package-designator) - "Return a list of packages that the designated package implements. -See also: :IMPLEMENT option to DEFPACKAGE." - (let ((package (find-package package-designator)) - (result nil)) - (when (null package) (error 'package-error :package package)) - (dolist (p (list-all-packages) result) - (when (find package (package-implemented-by-list p)) - (push p result))))) diff --git a/src/lisp/kernel/lsp/posix.lisp b/src/lisp/kernel/lsp/posix.lisp index 004b78ae9e..798ce88a7a 100644 --- a/src/lisp/kernel/lsp/posix.lisp +++ b/src/lisp/kernel/lsp/posix.lisp @@ -1,4 +1,4 @@ -(in-package :core) +(in-package #:core) (defpackage "CLASP-POSIX" (:use) diff --git a/src/lisp/kernel/lsp/pprint.lisp b/src/lisp/kernel/lsp/pprint.lisp index bbba925ec1..0cb8b76f94 100644 --- a/src/lisp/kernel/lsp/pprint.lisp +++ b/src/lisp/kernel/lsp/pprint.lisp @@ -12,6 +12,11 @@ (in-package "SI") +(defconstant +ecl-safe-declarations+ + (if (boundp '+ecl-safe-declarations+) + (symbol-value '+ecl-safe-declarations+) + '(optimize (safety 2) (speed 1) (debug 1) (space 1)))) + ;;; FIXME: Move? ;;; FIXME: Better error (though these are internal structures, so it being signaled is a bug) (defun required-argument () @@ -1147,16 +1152,18 @@ (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) - (declare (type (or pprint-dispatch-table null) table) - #.+ecl-safe-declarations+) - (let* ((orig (or table *initial-pprint-dispatch*))) - (let* ((new (make-pprint-dispatch-table - :entries (copy-list (pprint-dispatch-table-entries orig)))) - (new-cons-entries (pprint-dispatch-table-cons-entries new))) - (maphash #'(lambda (key value) - (setf (gethash key new-cons-entries) value)) - (pprint-dispatch-table-cons-entries orig)) - new))) + (declare #.+ecl-safe-declarations+) + (unless (typep table '(or null pprint-dispatch-table)) + (error 'type-error :datum table + :expected-type '(or null pprint-dispatch-table))) + (let* ((orig (or table *initial-pprint-dispatch*)) + (new (make-pprint-dispatch-table + :entries (copy-list (pprint-dispatch-table-entries orig)))) + (new-cons-entries (pprint-dispatch-table-cons-entries new))) + (maphash #'(lambda (key value) + (setf (gethash key new-cons-entries) value)) + (pprint-dispatch-table-cons-entries orig)) + new)) (defun default-pprint-dispatch (stream object) (write-ugly-object object stream)) diff --git a/src/lisp/kernel/lsp/predlib.lisp b/src/lisp/kernel/lsp/predlib.lisp index 7086968ce9..85bfb63e01 100644 --- a/src/lisp/kernel/lsp/predlib.lisp +++ b/src/lisp/kernel/lsp/predlib.lisp @@ -23,7 +23,7 @@ (declare (ignore foo)) nil) -(declaim (inline constantly)) +;;(declaim (inline constantly)) (defun constantly (n) "Args: (n) Builds a new function which accepts any number of arguments but always outputs N." @@ -33,21 +33,29 @@ Builds a new function which accepts any number of arguments but always outputs N (t #'(lambda (&rest x) (declare (ignore x)) n)))) (defparameter *subtypep-cache* (core:make-simple-vector-t 256 nil nil)) - -(defparameter *upgraded-array-element-type-cache* (core:make-simple-vector-t 128 nil nil)) +(defparameter *upgraded-array-element-type-cache* + (core:make-simple-vector-t 128 nil nil)) +#+(or) +(defparameter *subtypep-cache* (make-array 256 :initial-element nil)) +#+(or) +(defparameter *upgraded-array-element-type-cache* + (make-array 128 :initial-element nil)) (defun subtypep-clear-cache () (fill-array-with-elt *subtypep-cache* nil 0 nil) (fill-array-with-elt *upgraded-array-element-type-cache* nil 0 nil)) (defun create-type-name (name) + (declare (ignore name)) + #+(or) (when (member name *alien-declarations*) (error "Symbol ~s is a declaration specifier and cannot be used to name a new type" name))) -(export 'create-type-name) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(create-type-name))) (defvar *type-expanders* (make-hash-table :test #'eq :thread-safe t)) -(export 'ext::type-expander "EXT") (defun ext:type-expander (name) (values (gethash name *type-expanders*))) @@ -55,11 +63,11 @@ Builds a new function which accepts any number of arguments but always outputs N (unless (symbolp name) (error "~s is not a valid type specifier" name)) (create-type-name name) - (funcall #'(setf gethash) function name *type-expanders*) + (setf (gethash name *type-expanders*) function) (subtypep-clear-cache) function) -(export 'ext::typexpand-1 "EXT") + (defun ext:typexpand-1 (type-specifier &optional env) (let ((expander (ext:type-expander (if (consp type-specifier) (first type-specifier) @@ -68,7 +76,6 @@ Builds a new function which accepts any number of arguments but always outputs N (values (funcall expander type-specifier env) t) (values type-specifier nil)))) -(export 'ext::typexpand "EXT") (defun ext:typexpand (type-specifier &optional env) (multiple-value-bind (expansion expandedp) (ext:typexpand-1 type-specifier env) @@ -91,9 +98,8 @@ expansion function is called with no argument. The doc-string DOC, if supplied, is saved as a TYPE doc and can be retrieved by (documentation 'NAME 'type)." `(eval-when (:compile-toplevel :load-toplevel :execute) - (funcall #'(setf ext:type-expander) - ,(ext:parse-deftype name lambda-list body env) - ',name) + (setf (ext:type-expander ',name) + ,(ext:parse-deftype name lambda-list body env)) ',name)) ;;; Some DEFTYPE definitions. @@ -337,6 +343,7 @@ and is not adjustable." (array-has-fill-pointer-p x) (array-displacement x)))))) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun simple-type-predicate (name) ;; For some built in types, returns the name of an indicator function. ;; That is, (typep object name) = (funcall (simple-type-predicate name) object) @@ -355,8 +362,6 @@ and is not adjustable." (COMPLEX-ARRAY 'COMPLEX-ARRAY-P) (CONS 'CONSP) (DOUBLE-FLOAT 'CORE:DOUBLE-FLOAT-P) - #+long-float - (LONG-FLOAT 'CORE:LONG-FLOAT-P) (FLOAT 'FLOATP) (FUNCTION 'FUNCTIONP) (HASH-TABLE 'HASH-TABLE-P) @@ -385,19 +390,18 @@ and is not adjustable." ((T) 'CONSTANTLY-T) (VECTOR 'VECTORP) (t nil))) +) ; eval-when (defconstant-equal +upgraded-array-element-types+ - '#.(append '(nil base-char #+unicode character bit) + '#.(append '(NIL BASE-CHAR #+unicode CHARACTER BIT) '(ext:byte2 ext:integer2) '(ext:byte4 ext:integer4) - '(ext:byte8 ext:integer8) - '(ext:byte16 ext:integer16) - '(ext:byte32 ext:integer32) + '(EXT:BYTE8 EXT:INTEGER8) + '(EXT:BYTE16 EXT:INTEGER16) + '(EXT:BYTE32 EXT:INTEGER32) '(fixnum) - '(ext:byte64 ext:integer64) - '(#+short-float short-float - #+long-float long-float - single-float double-float t))) + '(EXT:BYTE64 EXT:INTEGER64) + '(SINGLE-FLOAT DOUBLE-FLOAT T))) (defun upgraded-array-element-type (element-type &optional env) (declare (ignore env)) @@ -465,7 +469,7 @@ and is not adjustable." ;; Actually used way later in CLOS. ;; Inlining doesn't work here for bootstrap reasons, so we just use ;; subclassp directly within this file. -(declaim (inline of-class-p)) +;;(declaim (inline of-class-p)) (defun of-class-p (object class) (si::subclassp (class-of object) class)) @@ -615,7 +619,7 @@ Returns T if X belongs to TYPE; NIL otherwise." (defun error-coerce (object type) (error "Cannot coerce ~S to type ~S." object type)) -(declaim (inline character)) +;;(declaim (inline character)) (defun character (character-designator) (if (characterp character-designator) character-designator @@ -650,10 +654,8 @@ if not possible." ((float) (float object)) #+short-float ((short-float) (core:to-short-float object)) - ((#+short-float short-float single-float) - (core:to-single-float object)) - ((double-float #-long-float long-float) - (core:to-double-float object)) + ((single-float) (core:to-single-float object)) + ((double-float) (core:to-double-float object)) #+long-float ((long-float) (core:to-long-float object)) ((function) (coerce-to-function object)) @@ -861,8 +863,7 @@ if not possible." ;;---------------------------------------------------------------------- ;; CLOS classes and structures. ;; -#+clos(defun register-class (class) - (declare (notinline class-name)) +(defun register-class (class) (or (find-registered-tag class) ;; We do not need to register classes which belong to the core type ;; system of LISP (ARRAY, NUMBER, etc). @@ -1115,8 +1116,8 @@ if not possible." (RATIO (RATIO * *)) (RATIONAL (OR INTEGER RATIO)) - (FLOAT (OR #+short-float SHORT-FLOAT SINGLE-FLOAT - DOUBLE-FLOAT #+long-float LONG-FLOAT)) + (FLOAT (OR SINGLE-FLOAT DOUBLE-FLOAT + #+long-float LONG-FLOAT)) (REAL (OR INTEGER #+short-float SHORT-FLOAT SINGLE-FLOAT @@ -1144,99 +1145,83 @@ if not possible." (SIMPLE-BIT-VECTOR (SIMPLE-ARRAY BIT (*))) (VECTOR (ARRAY * (*))) - (core:simple-vector-byte2-t (simple-array ext:byte2 (*))) - (core:simple-vector-byte4-t (simple-array ext:byte4 (*))) - (core:simple-vector-byte8-t (simple-array ext:byte8 (*))) - (core:simple-vector-byte16-t (simple-array ext:byte16 (*))) - (core:simple-vector-byte32-t (simple-array ext:byte32 (*))) - (core:simple-vector-byte64-t (simple-array ext:byte64 (*))) - (core:simple-vector-int2-t (simple-array ext:integer2 (*))) - (core:simple-vector-int4-t (simple-array ext:integer4 (*))) - (core:simple-vector-int8-t (simple-array ext:integer8 (*))) - (core:simple-vector-int16-t (simple-array ext:integer16 (*))) - (core:simple-vector-int32-t (simple-array ext:integer32 (*))) - (core:simple-vector-int64-t (simple-array ext:integer64 (*))) - (core:simple-vector-fixnum (simple-array fixnum (*))) - #+short-float - (core:simple-vector-short-float (simple-array short-float (*))) - #+long-float - (core:simple-vector-long-float (simple-array long-float (*))) - (core:simple-vector-double (simple-array double-float (*))) - (core:simple-vector-float (simple-array single-float (*))) - (core:str8ns (complex-array base-char (*))) - (core:bit-vector-ns (complex-array bit (*))) - (core:complex-vector-byte2-t (complex-array ext:byte2 (*))) - (core:complex-vector-byte4-t (complex-array ext:byte4 (*))) - (core:complex-vector-byte8-t (complex-array ext:byte8 (*))) - (core:complex-vector-byte16-t (complex-array ext:byte16 (*))) - (core:complex-vector-byte32-t (complex-array ext:byte32 (*))) - (core:complex-vector-byte64-t (complex-array ext:byte64 (*))) - (core:str-wns (complex-array character (*))) - (core:complex-vector-int2-t (complex-array ext:integer2 (*))) - (core:complex-vector-int4-t (complex-array ext:integer4 (*))) - (core:complex-vector-int8-t (complex-array ext:integer8 (*))) - (core:complex-vector-int16-t (complex-array ext:integer16 (*))) - (core:complex-vector-int32-t (complex-array ext:integer32 (*))) - (core:complex-vector-int64-t (complex-array ext:integer64 (*))) - (core:complex-vector-fixnum (complex-array fixnum (*))) - #+short-float - (core:complex-vector-dhort-float (complex-array short-float (*))) - #+long-float - (core:complex-vector-long-float (complex-array long-float (*))) - (core:complex-vector-double (complex-array double-float (*))) - (core:complex-vector-float (complex-array single-float (*))) - (core:complex-vector-t (complex-array t (*))) - (core:MDARRAY-BASE-CHAR (%complex-mdarray base-char)) - (core:MDARRAY-BIT (%complex-mdarray bit)) - (core:mdarray-byte2-t (%complex-mdarray ext:byte2)) - (core:mdarray-byte4-t (%complex-mdarray ext:byte4)) - (core:mdarray-byte8-t (%complex-mdarray ext:byte8)) - (core:MDARRAY-BYTE16-T (%complex-mdarray ext:BYTE16)) - (core:MDARRAY-BYTE32-T (%complex-mdarray ext:BYTE32)) - (core:MDARRAY-BYTE64-T (%complex-mdarray ext:BYTE64)) - (core:MDARRAY-CHARACTER (%complex-mdarray character)) - #+short-float - (core:MDARRAY-SHORT-FLOAT (%complex-mdarray long-float)) - #+long-float - (core:MDARRAY-LONG-FLOAT (%complex-mdarray long-float)) - (core:MDARRAY-DOUBLE (%complex-mdarray double-float)) - (core:MDARRAY-FIXNUM (%complex-mdarray fixnum)) - (core:MDARRAY-FLOAT (%complex-mdarray single-float)) - (core:mdarray-int2-t (%complex-mdarray ext:integer2)) - (core:mdarray-int4-t (%complex-mdarray ext:integer4)) - (core:mdarray-int8-t (%complex-mdarray ext:integer8)) - (core:MDARRAY-INT16-T (%complex-mdarray ext:integer16)) - (core:MDARRAY-INT32-T (%complex-mdarray ext:integer32)) - (core:MDARRAY-INT64-T (%complex-mdarray ext:integer64)) - (core:MDARRAY-T (%complex-mdarray T)) - (core:SIMPLE-MDARRAY-BASE-CHAR (%simple-mdarray base-char)) - (core:SIMPLE-MDARRAY-BIT (%simple-mdarray bit)) - (core:simple-mdarray-byte2-t (%simple-mdarray ext:byte2)) - (core:simple-mdarray-byte4-t (%simple-mdarray ext:byte4)) - (core:SIMPLE-MDARRAY-BYTE8-T (%simple-mdarray ext:BYTE8)) - (core:SIMPLE-MDARRAY-BYTE16-T (%simple-mdarray ext:byte16)) - (core:SIMPLE-MDARRAY-BYTE32-T (%simple-mdarray ext:BYTE32)) - (core:SIMPLE-MDARRAY-BYTE64-T (%simple-mdarray ext:BYTE64)) - (core:SIMPLE-MDARRAY-CHARACTER (%simple-mdarray CHARACTER)) - #+short-float - (core:SIMPLE-MDARRAY-SHORT-FLOAT (%simple-mdarray SHORT-FLOAT)) - #+long-float - (core:SIMPLE-MDARRAY-LONG-FLOAT (%simple-mdarray LONG-FLOAT)) - (core:SIMPLE-MDARRAY-DOUBLE (%simple-mdarray DOUBLE-FLOAT)) - (core:SIMPLE-MDARRAY-FIXNUM (%simple-mdarray fixnum)) - (core:SIMPLE-MDARRAY-FLOAT (%simple-mdarray SINGLE-FLOAT)) - (core:simple-mdarray-int2-t (%simple-mdarray ext:integer2)) - (core:simple-mdarray-int4-t (%simple-mdarray ext:integer4)) - (core:SIMPLE-MDARRAY-INT8-T (%simple-mdarray ext:INTEGER8)) - (core:SIMPLE-MDARRAY-INT16-T (%simple-mdarray ext:INTEGER16)) - (core:SIMPLE-MDARRAY-INT32-T (%simple-mdarray ext:INTEGER32)) - (core:SIMPLE-MDARRAY-INT64-T (%simple-mdarray ext:INTEGER64)) - (core:SIMPLE-MDARRAY-T (%simple-mdarray T)) - - (core:abstract-simple-vector (simple-array * (*))) - (core:simple-mdarray (%simple-mdarray *)) - (core:complex-vector (complex-array * (*))) - (core:mdarray (%complex-mdarray *)) + (simple-vector-byte2-t (simple-array ext:byte2 (*))) + (simple-vector-byte4-t (simple-array ext:byte4 (*))) + (simple-vector-byte8-t (simple-array ext:byte8 (*))) + (simple-vector-byte16-t (simple-array ext:byte16 (*))) + (simple-vector-byte32-t (simple-array ext:byte32 (*))) + (simple-vector-byte64-t (simple-array ext:byte64 (*))) + (simple-vector-int2-t (simple-array ext:integer2 (*))) + (simple-vector-int4-t (simple-array ext:integer4 (*))) + (simple-vector-int8-t (simple-array ext:integer8 (*))) + (simple-vector-int16-t (simple-array ext:integer16 (*))) + (simple-vector-int32-t (simple-array ext:integer32 (*))) + (simple-vector-int64-t (simple-array ext:integer64 (*))) + (simple-vector-fixnum (simple-array fixnum (*))) + (simple-vector-double (simple-array double-float (*))) + (simple-vector-float (simple-array single-float (*))) + (str8ns (complex-array base-char (*))) + (bit-vector-ns (complex-array bit (*))) + (complex-vector-byte2-t (complex-array ext:byte2 (*))) + (complex-vector-byte4-t (complex-array ext:byte4 (*))) + (complex-vector-byte8-t (complex-array ext:byte8 (*))) + (complex-vector-byte16-t (complex-array ext:byte16 (*))) + (complex-vector-byte32-t (complex-array ext:byte32 (*))) + (complex-vector-byte64-t (complex-array ext:byte64 (*))) + (str-wns (complex-array character (*))) + (complex-vector-int2-t (complex-array ext:integer2 (*))) + (complex-vector-int4-t (complex-array ext:integer4 (*))) + (complex-vector-int8-t (complex-array ext:integer8 (*))) + (complex-vector-int16-t (complex-array ext:integer16 (*))) + (complex-vector-int32-t (complex-array ext:integer32 (*))) + (complex-vector-int64-t (complex-array ext:integer64 (*))) + (complex-vector-fixnum (complex-array fixnum (*))) + (complex-vector-double (complex-array double-float (*))) + (complex-vector-float (complex-array single-float (*))) + (complex-vector-t (complex-array t (*))) + (MDARRAY-BASE-CHAR (%complex-mdarray base-char)) + (MDARRAY-BIT (%complex-mdarray bit)) + (mdarray-byte2-t (%complex-mdarray ext:byte2)) + (mdarray-byte4-t (%complex-mdarray ext:byte4)) + (mdarray-byte8-t (%complex-mdarray ext:byte8)) + (MDARRAY-BYTE16-T (%complex-mdarray ext:BYTE16)) + (MDARRAY-BYTE32-T (%complex-mdarray ext:BYTE32)) + (MDARRAY-BYTE64-T (%complex-mdarray ext:BYTE64)) + (MDARRAY-CHARACTER (%complex-mdarray character)) + (MDARRAY-DOUBLE (%complex-mdarray double-float)) + (MDARRAY-FIXNUM (%complex-mdarray fixnum)) + (MDARRAY-FLOAT (%complex-mdarray single-float)) + (mdarray-int2-t (%complex-mdarray ext:integer2)) + (mdarray-int4-t (%complex-mdarray ext:integer4)) + (mdarray-int8-t (%complex-mdarray ext:integer8)) + (MDARRAY-INT16-T (%complex-mdarray ext:integer16)) + (MDARRAY-INT32-T (%complex-mdarray ext:integer32)) + (MDARRAY-INT64-T (%complex-mdarray ext:integer64)) + (MDARRAY-T (%complex-mdarray T)) + (SIMPLE-MDARRAY-BASE-CHAR (%simple-mdarray base-char)) + (SIMPLE-MDARRAY-BIT (%simple-mdarray bit)) + (simple-mdarray-byte2-t (%simple-mdarray ext:byte2)) + (simple-mdarray-byte4-t (%simple-mdarray ext:byte4)) + (SIMPLE-MDARRAY-BYTE8-T (%simple-mdarray ext:BYTE8)) + (SIMPLE-MDARRAY-BYTE16-T (%simple-mdarray ext:byte16)) + (SIMPLE-MDARRAY-BYTE32-T (%simple-mdarray ext:BYTE32)) + (SIMPLE-MDARRAY-BYTE64-T (%simple-mdarray ext:BYTE64)) + (SIMPLE-MDARRAY-CHARACTER (%simple-mdarray CHARACTER)) + (SIMPLE-MDARRAY-DOUBLE (%simple-mdarray DOUBLE-FLOAT)) + (SIMPLE-MDARRAY-FIXNUM (%simple-mdarray fixnum)) + (SIMPLE-MDARRAY-FLOAT (%simple-mdarray SINGLE-FLOAT)) + (simple-mdarray-int2-t (%simple-mdarray ext:integer2)) + (simple-mdarray-int4-t (%simple-mdarray ext:integer4)) + (SIMPLE-MDARRAY-INT8-T (%simple-mdarray ext:INTEGER8)) + (SIMPLE-MDARRAY-INT16-T (%simple-mdarray ext:INTEGER16)) + (SIMPLE-MDARRAY-INT32-T (%simple-mdarray ext:INTEGER32)) + (SIMPLE-MDARRAY-INT64-T (%simple-mdarray ext:INTEGER64)) + (SIMPLE-MDARRAY-T (%simple-mdarray T)) + + (abstract-simple-vector (simple-array * (*))) + (simple-mdarray (%simple-mdarray *)) + (complex-vector (complex-array * (*))) + (mdarray (%complex-mdarray *)) (STRING (ARRAY CHARACTER (*))) #+unicode @@ -1244,7 +1229,7 @@ if not possible." (SIMPLE-STRING (SIMPLE-ARRAY CHARACTER (*))) #+unicode (SIMPLE-BASE-STRING (SIMPLE-ARRAY BASE-CHAR (*))) - (core:simple-character-string (SIMPLE-ARRAY CHARACTER (*))) + (simple-character-string (SIMPLE-ARRAY CHARACTER (*))) (BIT-VECTOR (ARRAY BIT (*))) (SEQUENCE (OR CONS (MEMBER NIL) (ARRAY * (*)))) @@ -1284,12 +1269,13 @@ if not possible." (CODE-BLOCK) )) -(defun hash-table-fill (ht values) - (dolist (pair values) - (let ((key (car pair)) - (value (cdr pair))) - (funcall #'(setf gethash) value key ht))) - ht) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun hash-table-fill (ht values) + (dolist (pair values) + (let ((key (car pair)) + (value (cdr pair))) + (setf (gethash key ht) value))) + ht)) (defconstant-eqx +built-in-types+ (hash-table-fill @@ -1335,66 +1321,61 @@ if not possible." (defun canonical-type (type) (declare (notinline clos::classp)) (cond ((find-registered-tag type)) - ((eq type 'T) -1) - ((eq type 'NIL) 0) + ((eq type 'T) -1) + ((eq type 'NIL) 0) ((symbolp type) - (let ((expander (ext:type-expander type))) - (cond (expander - (canonical-type (funcall expander type nil))) - ((find-built-in-tag type)) - (t (let ((class (find-class type nil))) - (if class - (progn - (register-class class)) - (progn - (throw '+canonical-type-failure+ nil)) - )))))) - ((consp type) - (case (first type) - (AND (apply #'logand (mapcar #'canonical-type (rest type)))) - (OR (apply #'logior (mapcar #'canonical-type (rest type)))) - (NOT (lognot (canonical-type (second type)))) - ((EQL MEMBER) (apply #'logior (mapcar #'register-member-type (rest type)))) - (SATISFIES (register-satisfies-type type)) - ((INTEGER #+short-float SHORT-FLOAT SINGLE-FLOAT - DOUBLE-FLOAT RATIO #+long-float LONG-FLOAT) - (register-interval-type type)) - ((FLOAT) - (canonical-type `(OR #+short-float - (SHORT-FLOAT ,@(rest type)) - (SINGLE-FLOAT ,@(rest type)) - (DOUBLE-FLOAT ,@(rest type)) - #+long-float - (LONG-FLOAT ,@(rest type))))) - ((REAL) - (canonical-type `(OR (INTEGER ,@(rest type)) - (RATIO ,@(rest type)) - #+short-float - (SHORT-FLOAT ,@(rest type)) - (SINGLE-FLOAT ,@(rest type)) - (DOUBLE-FLOAT ,@(rest type)) - #+long-float - (LONG-FLOAT ,@(rest type))))) - ((RATIONAL) - (canonical-type `(OR (INTEGER ,@(rest type)) - (RATIO ,@(rest type))))) - (COMPLEX - (or (find-built-in-tag type) - (canonical-complex-type (second type)))) - (CONS (apply #'register-cons-type (rest type))) - (ARRAY (logior (register-array-type `(COMPLEX-ARRAY ,@(rest type))) - (register-array-type `(SIMPLE-ARRAY ,@(rest type))))) - ((COMPLEX-ARRAY SIMPLE-ARRAY) (register-array-type type)) - (FUNCTION (canonical-type 'FUNCTION)) - (t (let ((expander (ext:type-expander (first type)))) - (if expander - (canonical-type (funcall expander type nil)) - (unless (assoc (first type) *elementary-types*) - (throw '+canonical-type-failure+ nil))))))) - ((clos::classp type) - (register-class type)) - (t - (error-type-specifier type)))) + (let ((expander (ext:type-expander type))) + (cond (expander + (canonical-type (funcall expander type nil))) + ((find-built-in-tag type)) + (t (let ((class (find-class type nil))) + (if class + (progn + (register-class class)) + (progn + (throw '+canonical-type-failure+ nil)) + )))))) + ((consp type) + (case (first type) + (AND (apply #'logand (mapcar #'canonical-type (rest type)))) + (OR (apply #'logior (mapcar #'canonical-type (rest type)))) + (NOT (lognot (canonical-type (second type)))) + ((EQL MEMBER) (apply #'logior (mapcar #'register-member-type (rest type)))) + (SATISFIES (register-satisfies-type type)) + ((INTEGER SINGLE-FLOAT DOUBLE-FLOAT RATIO #+long-float LONG-FLOAT) + (register-interval-type type)) + ((FLOAT) + (canonical-type `(OR (SINGLE-FLOAT ,@(rest type)) + (DOUBLE-FLOAT ,@(rest type)) + #+long-float + (LONG-FLOAT ,@(rest type))))) + ((REAL) + (canonical-type `(OR (INTEGER ,@(rest type)) + (RATIO ,@(rest type)) + (SINGLE-FLOAT ,@(rest type)) + (DOUBLE-FLOAT ,@(rest type)) + #+long-float + (LONG-FLOAT ,@(rest type))))) + ((RATIONAL) + (canonical-type `(OR (INTEGER ,@(rest type)) + (RATIO ,@(rest type))))) + (COMPLEX + (or (find-built-in-tag type) + (canonical-complex-type (second type)))) + (CONS (apply #'register-cons-type (rest type))) + (ARRAY (logior (register-array-type `(COMPLEX-ARRAY ,@(rest type))) + (register-array-type `(SIMPLE-ARRAY ,@(rest type))))) + ((COMPLEX-ARRAY SIMPLE-ARRAY) (register-array-type type)) + (FUNCTION (canonical-type 'FUNCTION)) + (t (let ((expander (ext:type-expander (first type)))) + (if expander + (canonical-type (funcall expander type nil)) + (unless (assoc (first type) *elementary-types*) + (throw '+canonical-type-failure+ nil))))))) + ((clos::classp type) + (register-class type)) + (t + (error-type-specifier type)))) (defun safe-canonical-type (type) (catch '+canonical-type-failure+ @@ -1425,7 +1406,6 @@ if not possible." (return-from subtypep (values (subclassp t1 t2) t))) ;; Finally, cached results. (let* ((cache *subtypep-cache*) - ;; FIXME: mixing could be improved (hash (the (integer 0 255) (logand (core:hash-equal t1 t2) 255))) (elt (aref cache hash))) (when (and elt (eq (caar elt) t1) (eq (cdar elt) t2)) diff --git a/src/lisp/kernel/lsp/process.lisp b/src/lisp/kernel/lsp/process.lisp index 0adea24364..7285d19168 100644 --- a/src/lisp/kernel/lsp/process.lisp +++ b/src/lisp/kernel/lsp/process.lisp @@ -19,7 +19,7 @@ (defmacro with-process-lock ((process &optional (wait t)) &body body) #+threads - (with-unique-names (lock wait-p) + (core::with-unique-names (lock wait-p) `(let ((,lock (external-process-%lock ,process)) (,wait-p ,wait)) (mp:without-interrupts @@ -167,14 +167,14 @@ (when (eq type :input) (close output)) (push pipe to-remove))))) - (si:until (or (null pipes) + (loop until (or (null pipes) (member (external-process-wait process nil) '(:exited :signaled :abort :error))) - (thunk) - ;; remove from the list exhausted streams - (when to-remove - (setf pipes (set-difference pipes to-remove))) - (sleep 0.001)) + do (thunk) + ;; remove from the list exhausted streams + (when to-remove + (setf pipes (set-difference pipes to-remove))) + (sleep 0.001)) ;; something may still be in pipes after child termination (thunk))) @@ -315,7 +315,7 @@ (warn "EXT:RUN-PROGRAM: Ignoring virtual stream I/O argument."))) (if wait - (ext:external-process-wait process t) + (external-process-wait process t) (gctools:finalize process #'finalize-external-process)) (values (if (and stream-read stream-write) diff --git a/src/lisp/kernel/lsp/profiling.lisp b/src/lisp/kernel/lsp/profiling.lisp deleted file mode 100644 index ee07a5b9ca..0000000000 --- a/src/lisp/kernel/lsp/profiling.lisp +++ /dev/null @@ -1,93 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Do microprofiling to assess the GC speed under different stack conditions -;; -;; Use (micro-profile-ops) to generate timings for different low-level operations -;; -;; I added a special-operator to the compiler called cmp::gc-profiling -;; - -(eval-when (:compile-toplevel :load-toplevel :execute) - (if (not (find-package "MICRO-PROFILING")) - (make-package "MICRO-PROFILING" :use '("CORE" "CL")))) - - -(in-package "MICRO-PROFILING") - -(defun ns-per-partial-apply (stage fn args) - (let ((rate (core:partial-applys-per-second stage fn args))) - (* (/ 1.0 rate) 1.0d9))) - -(defparameter *parts* '( - "C++ call-by-val" - "fn lookup" - "length of args" - "alloc frame" - "fill frame" - "apply")) - -(defun prof-apply (parts analyzer fn args) - (gctools:garbage-collect) - (let (rev-times) - (dotimes (i (length parts)) - (push (funcall analyzer i fn args) rev-times)) - (let ((times (reverse rev-times))) - (do* ((stage 0 (1+ stage)) - (prev-time nil (car time-cur)) - (time-cur times (cdr time-cur)) - (part-cur parts (cdr part-cur))) - ((null time-cur)) - (format t "stage~d (~20a) ~6,1f ns" stage (car part-cur) (car time-cur)) - (when prev-time - (format t " delta ~6,1f ns" (- (car time-cur) prev-time))) - (terpri) - )))) - -#+(or)(defun test-b () - (format t "test-b~%") - (prof-apply *parts* #'ns-per-partial-apply #'b (list 1 2 3))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Time a single operation. op is an integer index that indicates -;; which operation is timed. Check compiler.cc core::operations-per-second to -;; see which integer value corresponds to what operation. -;; -(defun time-operation (op) - (gctools:garbage-collect) - (let ((op0 (* (/ 1.0 (core:operations-per-second 0)) 1.0d9))) - (multiple-value-bind (time-or-nil op-name) - (core:operations-per-second op) - (if time-or-nil - (let* ((total-op-time (* (/ 1.0 time-or-nil) 1.0d9)) - (rel-op-time (- total-op-time op0))) - (format nil "Operation ~2d ~@40a --> ~6,1f ns (uncorrected ~6,1f)" op op-name rel-op-time total-op-time )) - nil)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Generate timings for all of the operations -;; -(defun micro-profile-ops () - (do* ((i 1 (1+ i)) - (res (time-operation i) (time-operation i))) - ((null res)) - (format t "~a~%" res))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Fill the stack to a given recursive depth and then do the timings. -;; The MPS library slows down as the stack gets larger because there -;; are more pinned objects to deal with. Boehm doesn't have this problem -;; because all objects are pinned all the time (non-moving GC). -;; -(defun deep-stack-micro-profile-ops (depth) - (if (eql depth 0) - (micro-profile-ops) - (deep-stack-micro-profile-ops (1- depth)))) - -(export '(micro-profile-ops deep-stack-micro-profile-ops)) - diff --git a/src/lisp/kernel/lsp/prologue.lisp b/src/lisp/kernel/lsp/prologue.lisp deleted file mode 100644 index e769e72929..0000000000 --- a/src/lisp/kernel/lsp/prologue.lisp +++ /dev/null @@ -1,15 +0,0 @@ -#-clasp-min -(eval-when (:load-toplevel) - (dolist (pkg '("CLEAVIR-AST" "CLASP-CLEAVIR-AST" "CLASP-CLEAVIR")) - (unless (find-package pkg) - (make-package pkg))) - (unless (member :staging *features*) - (unless (or (member :cclasp *features*) - (member :eclasp *features*)) - (setq *features* (cons #+extensions (if (member :ignore-extensions *features*) - :cclasp - :eclasp) - #-extensions :cclasp - *features*))) - (unless (member :clos *features*) - (setq *features* (cons :clos *features*))))) diff --git a/src/lisp/kernel/lsp/queue.lisp b/src/lisp/kernel/lsp/queue.lisp index 04ceaaf9bc..e2e574ac94 100644 --- a/src/lisp/kernel/lsp/queue.lisp +++ b/src/lisp/kernel/lsp/queue.lisp @@ -44,7 +44,9 @@ (setf *readtable* (copy-readtable nil))) (in-package :core) -(export '(make-queue queuep atomic-enqueue dequeue dequeue-timed queue-count queue-emptyp)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(make-queue queuep atomic-enqueue dequeue dequeue-timed queue-count queue-emptyp)) + ) ; eval-when #+(or) (eval-when (:compile-toplevel :execute) @@ -61,28 +63,27 @@ (:predicate queuep)) name (head nil) (tail nil) lock not-empty) -(eval-when (:compile-toplevel :load-toplevel :execute) - (setf (documentation 'make-queue 'function) " +(setf (documentation 'make-queue 'function) " RETURN: A new queue named NAME " - (documentation 'queue-name 'function) " + (documentation 'queue-name 'function) " RETURN: The name of the QUEUE. " - (documentation 'queue-head 'function) " + (documentation 'queue-head 'function) " RETURN: the head CONS cell of the QUEUE. " - (documentation 'queue-tail 'function) " + (documentation 'queue-tail 'function) " RETURN: the tail CONS cell of the QUEUE. " - (documentation 'queuep 'function) " + (documentation 'queuep 'function) " RETURN: Predicate for the QUEUE type. " - (documentation 'queue-lock 'function) " + (documentation 'queue-lock 'function) " RETURN: The lock of the QUEUE. " - (documentation 'queue-not-empty 'function) " + (documentation 'queue-not-empty 'function) " RETURN: The NOT-EMPTY condition variable of the QUEUE. -")) +") (defun atomic-enqueue (queue message) " diff --git a/src/lisp/kernel/lsp/seq.lisp b/src/lisp/kernel/lsp/seq.lisp index e9fa06539d..ec2527ef92 100644 --- a/src/lisp/kernel/lsp/seq.lisp +++ b/src/lisp/kernel/lsp/seq.lisp @@ -17,7 +17,7 @@ (defun error-not-a-sequence (value) - (signal-type-error value 'sequence)) + (error 'type-error :datum value :expected-type 'sequence)) (defun error-sequence-index (sequence index) (error 'simple-type-error @@ -48,6 +48,8 @@ ;;; a list (VECTOR symbol) where symbol is an upgraded array element type, ;;; or a class (a user-defined sequence class). ;;; The length is a minimum, and if the third value is true, also a maximum. +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; used at compile time in compiler macros (defun sequence-type-maker-info (type &optional env) (let (name args) (cond ((consp type) @@ -135,6 +137,7 @@ (values class nil nil t))))) ;; Dunno. (values nil nil nil nil)))))) +) ; eval-when (defun make-sequence (type size &key (initial-element nil iesp)) "Args: (type length &key initial-element) @@ -286,9 +289,8 @@ default value of INITIAL-ELEMENT depends on TYPE." ((vectorp sequence) (make-vector-iterator sequence from-end start end)) (t - #-clasp-min(sequence:make-sequence-iterator - sequence :from-end from-end :start start :end end) - #+clasp-min(error "The arg passed as a sequence to %make-sequence-iterator is ~a - in aclasp make-sequence-iterator is not available to use this" sequence)))) + (sequence:make-sequence-iterator + sequence :from-end from-end :start start :end end)))) ;;; Given a list of sequences, return two lists of the same length: ;;; one with irrelevant elements, and one with "iterators" for the sequences. @@ -330,8 +332,8 @@ default value of INITIAL-ELEMENT depends on TYPE." (s-list seq-list (cdr s-list)) (i-list iterator-list (cdr i-list))) ((null v-list) t) - (let ((sequence (cons-car s-list)) - (iterator (cons-car i-list))) + (let ((sequence (car (the cons s-list))) + (iterator (car (the cons i-list)))) (destructuring-bind (it limit from-end step endp elt) iterator (declare (type function step endp elt)) @@ -435,19 +437,12 @@ SEQUENCEs, where K is the minimum length of the given SEQUENCEs." (error-sequence-length result result-type l)))) result) ;; ditto note in CONCATENATE above - (let ((result - (apply #'map-into - (make-sequence result-type - (reduce #'min more-sequences - :initial-value (length sequence) - :key #'length)) - function sequence more-sequences))) - (if (or (not (consp result-type)) - (typep result result-type)) - result - (error 'type-error - :datum result - :expected-type result-type))))) + (let ((length + (reduce #'min more-sequences + :initial-value (length sequence) + :key #'length))) + (apply #'map-into (make-sequence result-type length) + function sequence more-sequences)))) (apply #'map-for-effect function sequence more-sequences)))) (defun map-to-list (function &rest sequences) diff --git a/src/lisp/kernel/lsp/seqlib.lisp b/src/lisp/kernel/lsp/seqlib.lisp index cd2e6c1a00..79ead4862d 100644 --- a/src/lisp/kernel/lsp/seqlib.lisp +++ b/src/lisp/kernel/lsp/seqlib.lisp @@ -15,10 +15,6 @@ (in-package "SYSTEM") -#+ecl-min -(eval-when (:execute) - (load (merge-pathnames "seqmacros.lisp" *load-truename*))) - (defun sequence-count (count) (cond ((null count) most-positive-fixnum) @@ -862,7 +858,6 @@ subsequence is found. Returns NIL otherwise." (key (funcall elt2 sequence2 it2))) (return)))))))))) -#-clasp-min (defun sort (sequence predicate &key key) "Args: (sequence test &key key) Destructively sorts SEQUENCE and returns the result. TEST should return non- @@ -931,7 +926,6 @@ evaluates to NIL. See STABLE-SORT." (setq key-right (funcall key (car right))) (go loop))) -#-clasp-min (defun quick-sort (seq start end pred key) (declare (fixnum start end) (function pred key) @@ -1118,6 +1112,9 @@ the sense of TEST." (setf (elt newseq j) v1 i1 (1+ i1)))))))))))) +(defun constantly (object) + (lambda (&rest arguments) (declare (ignore arguments)) object)) + (defun complement (f) "Args: (f) Returns a new function which first applies F to its arguments and then negates diff --git a/src/lisp/kernel/lsp/seqmacros.lisp b/src/lisp/kernel/lsp/seqmacros.lisp index 9521131dc2..b6fdd4cd21 100644 --- a/src/lisp/kernel/lsp/seqmacros.lisp +++ b/src/lisp/kernel/lsp/seqmacros.lisp @@ -269,3 +269,25 @@ ((not (seq-iterator-list-pop ,elt-list ,%sequences ,%iterators)) ,@(and output (list output))) ,@body))))) + +;;; C++ iterators. +;;; These are not true sequences even though we have the sequences extension. FIXME +(in-package :ext) + +(defmacro do-c++-iterator ((i iterator &optional result) &rest body) + (let ((cur (gensym)) (begin (gensym)) (end (gensym))) + `(multiple-value-bind (,begin ,end) + ,iterator + (do* ((,cur ,begin (core:iterator-step ,cur)) + (,i (core:iterator-unsafe-element ,cur) (core:iterator-unsafe-element ,cur))) + ((core:iterator= ,cur ,end) + (let ((,i nil)) + (declare (ignorable ,i)) + ,result)) + ,@body)))) + +(defmacro map-c++-iterator (code iterator) + (let ((val (gensym))) + `(progn + (do-c++-iterator (,val ,iterator) (funcall ,code ,val)) + nil))) diff --git a/src/lisp/kernel/lsp/setf.lisp b/src/lisp/kernel/lsp/setf.lisp index ec003c5c53..05f28ff3d3 100644 --- a/src/lisp/kernel/lsp/setf.lisp +++ b/src/lisp/kernel/lsp/setf.lisp @@ -25,11 +25,6 @@ (in-package "EXT") -#+(or) ;;#+(or cclasp eclasp) -(eval-when (:compile-toplevel :execute) - (format t "~%~%~%~% Turning on cmp::*compile-debug-dump-module* ~%~%~%") - (setq cmp::*compile-debug-dump-module* t)) - (defvar *setf-expanders* (make-hash-table :test #'eq :thread-safe t)) (defun setf-expander (symbol &optional environment) @@ -39,16 +34,27 @@ (defun (setf setf-expander) (expander symbol &optional environment) (unless (null environment) (error "(setf setf-expander) was passed a non-null environment")) - (funcall #'(setf gethash) expander symbol *setf-expanders*)) -(export 'setf-expander) + (setf (gethash symbol *setf-expanders*) expander)) (in-package "SYSTEM") +;; used in setf expansions below +(defun parse-bytespec (bytespec) + (when (and (consp bytespec) + (eql (car bytespec) 'byte) + (consp (cdr bytespec)) + (consp (cddr bytespec)) + (null (cdddr bytespec))) + (values (cadr bytespec) (caddr bytespec)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; DEFSETF ;;; ;;; Actually kind of complicated to implement. +;;; We do create this macro in the builder environment, because the definition +;;; in common-macro-definitions has an environmental contamination problem +;;; due to the nested backquote. ;;; As I understand CLHS 3.4.7, a defsetf lambda list is an ordinary lambda list, ;;; except it can have &environment [name] on the end and no &aux. @@ -56,6 +62,7 @@ ;;; the environment variable if there was one. ;;; FIXME: This is not very error-tolerant. In particular we don't check for &aux. ;;; But fixing it will require a more robust lambda list system. +(eval-when (:compile-toplevel :load-toplevel :execute) (defun extract-defsetf-lambda-list (lambda-list) (ext:with-current-source-form (lambda-list) (if (or (null lambda-list) (null (rest lambda-list))) ; trivial case @@ -64,6 +71,7 @@ (if (eq (first last-two) '&environment) (values (ldiff lambda-list last-two) (second last-two)) (values lambda-list nil)))))) +) ; eval-when (defmacro defsetf (access-fn &rest rest) "Syntax: (defsetf symbol update-fun [doc]) @@ -115,17 +123,16 @@ SETF doc and can be retrieved by (documentation 'SYMBOL 'setf)." (let ((real-env-var (or env-var (gensym "ENV"))) (wholesym (gensym "WHOLE"))) `(eval-when (:compile-toplevel :load-toplevel :execute) - (funcall #'(setf ext:setf-expander) - (lambda (,wholesym ,real-env-var) - ,@(when doc (list doc)) - (declare (core:lambda-name ,access-fn) - ,@(unless env-var `((ignore ,real-env-var)))) - (let ((,tempsvar (mapcar (lambda (f) (declare (ignore f)) (gensym)) - (rest ,wholesym))) - (,storesvar (list ,@(make-list nstores :initial-element '(gensym "STORE"))))) - (values ,tempsvar (rest ,wholesym) ,storesvar ,store-form-maker - (list* ',access-fn ,tempsvar)))) - ',access-fn) + (setf (ext:setf-expander ',access-fn) + (lambda (,wholesym ,real-env-var) + ,@(when doc (list doc)) + (declare (core:lambda-name (ext:setf-expander ,access-fn)) + ,@(unless env-var `((ignore ,real-env-var)))) + (let ((,tempsvar (mapcar (lambda (f) (declare (ignore f)) (gensym)) + (rest ,wholesym))) + (,storesvar (list ,@(make-list nstores :initial-element '(gensym "STORE"))))) + (values ,tempsvar (rest ,wholesym) ,storesvar ,store-form-maker + (list* ',access-fn ,tempsvar))))) ',access-fn))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -155,9 +162,8 @@ expanded into The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'SETF)." `(eval-when (:compile-toplevel :load-toplevel :execute) - (funcall #'(setf ext:setf-expander) - ,(ext:parse-define-setf-expander access-fn lambda-list body env) - ',access-fn) + (setf (ext:setf-expander ',access-fn) + ,(ext:parse-define-setf-expander access-fn lambda-list body env)) ',access-fn)) (defun get-setf-expansion (place &optional env) @@ -380,12 +386,13 @@ by (DOCUMENTATION 'SYMBOL 'SETF)." (get-setf-expansion place env) (let* ((itemp (gensym "itemp")) (store (gensym "store")) (def (gensym "def"))) (values `(,@vars ,itemp ,@(if default-p (list def) nil)) - `(,@vals ,indicator ,@(and default-p (list default))) + `(,@vals ,indicator ,@(if default-p (list default) nil)) `(,store) `(let ((,(car stores) (sys:put-f ,access-form ,store ,itemp))) + ,@(if default-p (list def) nil) ; prevent unused variable warning ,store-form ,store) - `(getf ,access-form ,itemp ,default))))) + `(getf ,access-form ,itemp ,@(if default-p (list def) nil)))))) (defsetf subseq (sequence1 start1 &optional end1) (sequence2) @@ -649,6 +656,7 @@ Similar to SETQ, but evaluates all FORMs first, and then assigns each value to the corresponding VAR. Returns NIL." (expand args env 'psetq 'setq))) +;;; Defined in build because common-macro-definitions lacks it. ;;; DEFINE-MODIFY-MACRO macro, by Bruno Haible. (defmacro define-modify-macro (name lambdalist function &optional docstring) "Syntax: (define-modify-macro symbol lambda-list function-name [doc]) @@ -752,12 +760,6 @@ makes it the new value of PLACE. Returns the new value of PLACE." (append vals (list (list 'cons item access-form)))) ,store-form))) -#+(or) -(eval-when (:compile-toplevel :execute) - (gctools:wait-for-user-signal "Waiting") - (setq *echo-repl-read* t)) - - (defmacro pushnew (&environment env item place &rest rest &key test test-not key) "Syntax: (pushnew form place {keyword-form value-form}*) diff --git a/src/lisp/kernel/lsp/sharpmacros.lisp b/src/lisp/kernel/lsp/sharpmacros.lisp index 6da0f50933..1f077ca0bf 100644 --- a/src/lisp/kernel/lsp/sharpmacros.lisp +++ b/src/lisp/kernel/lsp/sharpmacros.lisp @@ -1,15 +1,14 @@ ;;;; reading circular data: the #= and ## readmacros -(eval-when (:compile-toplevel :load-toplevel :execute) - (core:select-package :core)) +(in-package #:core) ;;; Based on the SBCL version (defconstant +sharp-marker+ '+sharp-marker+) (defun circle-subst (circle-table tree) - (cond ((and (core:sharp-equal-wrapper-p tree) - (not (eq (core:sharp-equal-wrapper-value tree) +sharp-marker+))) - (core:sharp-equal-wrapper-value tree)) + (cond ((and (sharp-equal-wrapper-p tree) + (not (eq (sharp-equal-wrapper-value tree) +sharp-marker+))) + (sharp-equal-wrapper-value tree)) ((null (gethash tree circle-table)) (setf (gethash tree circle-table) t) (cond ((consp tree) @@ -47,21 +46,16 @@ (dolist (pair to-add) (setf (gethash (car pair) tree) (cdr pair))))) ;; Do something for builtin objects - ((core:cxx-object-p tree) - #+(or)(error "Handle cxx-object in circle-subst tree: ~s" tree) + ((cxx-object-p tree) (let ((record (make-record-patcher (lambda (object) (circle-subst circle-table object))))) (patch-object tree record))) - ;; These next two are #+(or cclasp eclasp) since they need the classes to be defined, etc. - ;; For structure objects use raw slots. - #+(or cclasp eclasp) ((typep tree 'structure-object) (dotimes (i (clos::class-size (class-of tree))) - (setf (si:instance-ref tree i) + (setf (clos:standard-instance-access tree i) (circle-subst circle-table - (si:instance-ref tree i))))) + (clos:standard-instance-access tree i))))) ;; For general objects go full MOP - #+(or cclasp eclasp) ((typep tree 'standard-object) (let ((class (class-of tree))) (dolist (slotd (clos:class-slots class)) @@ -78,25 +72,18 @@ (unless label (simple-reader-error stream "missing label for #=" label)) (cond ((not *sharp-equal-final-table*) - #+(or)(format t "About to set *sharp-equal-final-table*~%") (setf *sharp-equal-final-table* (make-hash-table))) ((gethash label *sharp-equal-final-table*) (simple-reader-error stream "multiply defined label: #~D=" label))) - (let ((tag (progn - #+(or)(format t "{{{ Handling sharp-equal label: ~a~%" label) - (setf (gethash label *sharp-equal-final-table*) - (core:make-sharp-equal-wrapper label)))) + (let ((tag (setf (gethash label *sharp-equal-final-table*) + (make-sharp-equal-wrapper label))) (obj (read stream t nil t))) (when (eq obj tag) (simple-reader-error stream "must tag something more than just #~D#" label)) - #+(or)(format t "{{{ About to circle-subst for sharp-equal label: ~a~%" label) - (setf (core:sharp-equal-wrapper-value tag) obj) - (prog1 - (circle-subst (make-hash-table :test 'eq) obj) - #+(or)(format t "Done circle-subst with sharp-equal label: ~a}}}~%" label) - #+(or)(format t "}}}Done handling sharp-equal label: ~a~%" label)))) + (setf (sharp-equal-wrapper-value tag) obj) + (circle-subst (make-hash-table :test 'eq) obj))) (defun sharp-sharp (stream ignore label) (declare (ignore ignore)) @@ -115,10 +102,10 @@ (simple-reader-error stream "reference to undefined label #~D#" label)) - ((eq (core:sharp-equal-wrapper-value entry) +sharp-marker+) + ((eq (sharp-equal-wrapper-value entry) +sharp-marker+) entry) (t - (core:sharp-equal-wrapper-value entry))))) + (sharp-equal-wrapper-value entry))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -127,7 +114,7 @@ (defun read-cxx-object (stream char n) (declare (ignore char n)) (let ((description (read stream t nil t))) - (apply #'core:load-cxx-object (car description) (cdr description)))) + (apply #'load-cxx-object (car description) (cdr description)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -135,28 +122,13 @@ ;; (defun do-read-dense-specialized-array (stream char n) (declare (ignore char)) - (core:read-dense-specialized-array stream n)) + (read-dense-specialized-array stream n)) -(defun sharpmacros-enhance () - (set-dispatch-macro-character #\# #\= #'sharp-equal) - (set-dispatch-macro-character #\# #\# #'sharp-sharp) - (set-dispatch-macro-character #\# #\I #'read-cxx-object) - (set-dispatch-macro-character #\# #\D #'read-dense-specialized-array)) +(defun sharpmacros-enhance (readtable) + (set-dispatch-macro-character #\# #\= #'sharp-equal readtable) + (set-dispatch-macro-character #\# #\# #'sharp-sharp readtable) + (set-dispatch-macro-character #\# #\I #'read-cxx-object readtable) + (set-dispatch-macro-character #\# #\D #'read-dense-specialized-array readtable)) - -(defun sharpmacros-lisp-redefine (readtable) - (cond ((boundp '*read-hook*) - #+(or cclasp eclasp) (set-eclector-reader-readmacros readtable)) - (t - (set-dispatch-macro-character #\# #\= #'sharp-equal readtable) - (set-dispatch-macro-character #\# #\# #'sharp-sharp readtable) - (set-dispatch-macro-character #\# #\I #'read-cxx-object readtable) - (set-dispatch-macro-character #\# #\a 'sharp-a-reader readtable) - (set-dispatch-macro-character #\# #\A 'sharp-a-reader readtable) - (set-dispatch-macro-character #\# #\D 'do-read-dense-specialized-array readtable) - (set-dispatch-macro-character #\# #\s 'sharp-s-reader readtable) - (set-dispatch-macro-character #\# #\S 'sharp-s-reader readtable))) - (values)) - - -(sharpmacros-enhance) +(sharpmacros-enhance *readtable*) +(sharpmacros-enhance (symbol-value 'core:+standard-readtable+)) diff --git a/src/lisp/kernel/lsp/shiftf-rotatef.lisp b/src/lisp/kernel/lsp/shiftf-rotatef.lisp index b7e8e3e0c9..14daf3f0ea 100644 --- a/src/lisp/kernel/lsp/shiftf-rotatef.lisp +++ b/src/lisp/kernel/lsp/shiftf-rotatef.lisp @@ -1,4 +1,4 @@ -(in-package :cl) +(in-package #:core) ;;; Macro SHIFTF. diff --git a/src/lisp/kernel/lsp/source-location.lisp b/src/lisp/kernel/lsp/source-location.lisp index 3ec816aff8..6da7357bee 100644 --- a/src/lisp/kernel/lsp/source-location.lisp +++ b/src/lisp/kernel/lsp/source-location.lisp @@ -9,6 +9,8 @@ (in-package :ext) +(defun current-source-location () core:*current-source-pos-info*) + (defun compiled-function-name (x) (core:function-name x)) @@ -104,9 +106,14 @@ 'defmethod)) nil)) (sls (or method-sls - (source-location (clos::fast-method-function method) t) - (source-location (clos::contf-method-function method) t) - (source-location (clos:method-function method) t))) + (let ((mf (clos:method-function method))) + ;; FIXME: Move into CLOS somehow + (typecase mf + (clos::%leaf-method-function + (source-location (clos::fmf mf) t)) + (clos::%contf-method-function + (source-location (clos::contf mf) t)) + (t (source-location mf t)))))) (description (ignore-errors (append (method-qualifiers method) @@ -140,7 +147,9 @@ - kind : A symbol (:function :method :class) Return the source-location for the name/kind pair" (labels ((fix-paths-and-make-source-locations (rels) - (let ((sys-dir (translate-logical-pathname #P"sys:"))) + (let ((sys-dir (translate-logical-pathname + ;; FIXME? #P hosts can't be dumped from arbitrary Lisps. + (load-time-value (pathname "sys:") t)))) (mapcar (lambda (dir-pos) (let ((dir (first dir-pos)) (pos (second dir-pos))) @@ -152,10 +161,10 @@ Return the source-location for the name/kind pair" (get-source-info-for-function-object (func) (cond ((core:single-dispatch-generic-function-p func) (source-location name :method)) - ((typep func 'generic-function) - (generic-function-source-locations func)) - (t ; normal function - (function-source-locations func))))) + ((typep func 'generic-function) + (generic-function-source-locations func)) + (t ; normal function + (function-source-locations func))))) (case kind (:class (when (symbolp name) @@ -210,7 +219,7 @@ Return the source-location for the name/kind pair" 'deftype)))) (:variable (when (symbolp name) - (let ((spi (gethash name core:*variable-source-infos*)) + (let ((spi (core:variable-source-info name)) (definer (cond ((ext:specialp name) 'defvar) ((constantp name) 'defconstant) (t 'define-symbol-macro)))) diff --git a/src/lisp/kernel/lsp/source-transformations.lisp b/src/lisp/kernel/lsp/source-transformations.lisp index c77fdc27d7..80675703a8 100644 --- a/src/lisp/kernel/lsp/source-transformations.lisp +++ b/src/lisp/kernel/lsp/source-transformations.lisp @@ -2,8 +2,8 @@ ;;; Must be synced with constantp in primitives.cc (defun constant-form-value (form &optional env) + (declare (ignore env)) ; FIXME: alternate envs! "If (constantp form env) is true, returns the constant value of the form in the environment." - (declare (ignore env)) (cond ((symbolp form) (symbol-value form)) ((consp form) ;; (assert (eql (first form) 'quote)) @@ -36,12 +36,35 @@ (setq slow (cdr slow)) (go again)))))) - #+bytecode + ;;; Some operators "should signal a type error", meaning that in safe code + ;;; they _must_ signal a type error, and otherwise the behavior is undefined. + ;;; The bytecode compiler is not smart enough to do this in a nuanced way, + ;;; in that it just ignores THE rather than type checking (which is allowed), + ;;; but Cleavir's is. So to implement this behavior we use + ;;; this THE-SINGLE macro. + ;;; The bytecode will have an actual call to a %the-single function, + ;;; defined below, which just does a type test. So in safe and unsafe code + ;;; there is a test. + ;;; When compiling with Cleavir, this call will be transformed into a THE, + ;;; so there's no actual call and the compiler can do its usual processing + ;;; on THE forms based to the safety level. + ;;; This setup also means we extract only the primary value, so e.g. + ;;; (+ (values 1 2)) => 1 and not 1 2 as we want. Additionally it properly + ;;; removes toplevelness. (defmacro the-single (type form &optional (return nil returnp)) - (let ((var (gensym))) - `(let ((,var ,form)) - (check-type ,var ,type) - ,(if returnp return var)))) + (if returnp + `(%the-single-return ',type (values ,form) ,return) + `(%the-single ',type (values ,form)))) + + (defun %the-single (type value) + (unless (typep value type) + (error 'type-error :datum value :expected-type type)) + value) + + (defun %the-single-return (type value return) + (unless (typep value type) + (error 'type-error :datum value :expected-type type)) + return) (defun simple-associate-args (fun first-arg more-args) (or more-args (error "more-args cannot be nil")) @@ -56,18 +79,10 @@ (declare (ignore fun)) (case (length args) (0 identity) - ;; We use these values &rest nil types here and below because they are - ;; easier to check in cclasp (where THEs usually become checks). - ;; See cleavir/convert-special.lisp. - ;; Also note that we only use the type information in the one argument + ;; Note that we only use the type information in the one argument ;; case because we need that check. With more arguments, the two-arg-fun ;; will do checks. This also applies to EXPAND-COMPARE below. - ;; Also also note that we have to use VALUES or else we'll get - ;; (+ (values 1 nil)) => 1 NIL - ;; which is unlikely in practice, but a bug. - (1 - #+bytecode `(the-single ,one-arg-result-type ,(first args)) - #-bytecode `(the (values ,one-arg-result-type &rest nil) (values ,(first args)))) + (1 `(the-single ,one-arg-result-type ,(first args))) (2 (values `(,two-arg-fun ,@args) t)) (t (simple-associate-args two-arg-fun (first args) (rest args))))) @@ -88,8 +103,7 @@ form) ((1) ;; preserve nontoplevelness and side effects - #+bytecode `(the-single ,arg-type ,(first args) t) - #-bytecode `(progn (the (values ,arg-type &rest nil) (values ,(first args))) t)) + `(the-single ,arg-type ,(first args) t)) ((2) `(,fun ,(first args) ,(second args))) (otherwise @@ -108,9 +122,9 @@ (case (length args) ((1) ;; preserve nontoplevelness and side effects. - #+bytecode `(the-single ,arg-type ,(first args) t) - #-bytecode `(progn (the (values ,arg-type &rest nil) (values ,(first args))) t)) + `(the-single ,arg-type ,(first args) t)) ((2) `(not (,fun ,(first args) ,(second args)))) (otherwise form)) form)) + (export '(expand-associative expand-compare expand-uncompare) "CORE") ) diff --git a/src/lisp/kernel/lsp/source-transformations2.lisp b/src/lisp/kernel/lsp/source-transformations2.lisp deleted file mode 100644 index 31964f6293..0000000000 --- a/src/lisp/kernel/lsp/source-transformations2.lisp +++ /dev/null @@ -1,286 +0,0 @@ -;; See the middle of the file - - - - -;;;; This file contains macro-like source transformations which -;;;; convert uses of certain functions into the canonical form desired -;;;; within the compiler. FIXME: and other IR1 transforms and stuff. - -(in-package :core) - -;;; These will be useful once inlining of the -;;; two-arg-XXX functions is possible - -(define-source-transform logior (&rest args) - (source-transform-transitive 'logior args 0 'integer)) -(define-source-transform logxor (&rest args) - (source-transform-transitive 'logxor args 0 'integer)) -(define-source-transform logand (&rest args) - (source-transform-transitive 'logand args -1 'integer)) -(define-source-transform logeqv (&rest args) - (source-transform-transitive 'logeqv args -1 'integer)) -(define-source-transform gcd (&rest args) - (source-transform-transitive 'gcd args 0 'integer '(abs))) -(define-source-transform lcm (&rest args) - (source-transform-transitive 'lcm args 1 'integer '(abs))) - - - - - - - -;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; The code below is the same as that above but it has some newer features -;;; Replace the stuff above with the equivalents from below -;;; - - -(defun find-two-arg-function (name) - (let ((full-name (core:fmt nil "TWO-ARG-{}" (string name)))) - (multiple-value-bind (sym foundp) - (find-symbol full-name :core) - (if foundp - sym - (error "Could not find symbol with name ~a" full-name))))) - - -(declaim (inline singleton-p)) -(defun singleton-p (list) - (and (listp list) (null (rest list)) list)) - -;;;; In Clasp source-transforms are implemented as compiler macros -(defmacro define-source-transform (name lambda-list &body body) - (multiple-value-bind (func pprint doc-string) - (sys::expand-defmacro name lambda-list body 'cl:core:bclasp-define-compiler-macro) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setf (compiler-macro-function ',name) - (lambda (whole env) - (declare (core:lambda-name - ,(intern (format nil "SOURCE-TRANSFORM-~a" name) :core))) - (or (proper-list-p whole) - (error "Arguments for ~a must be a proper list" name)) - (multiple-value-bind (expansion done) - (funcall ,func whole env) - (if (or expansion (not done)) - expansion - whole))))))) - -(defmacro /show0 (&rest args) nil) - -;;; LIST with one arg is an extremely common operation (at least inside -;;; SBCL itself); translate it to CONS to take advantage of common -;;; allocation routines. -(define-source-transform list (&rest args) - (case (length args) - (1 `(cons ,(first args) nil)) - (t (values nil t)))) - -;;; And similarly for LIST*. -(define-source-transform list* (arg &rest others) - (cond ((not others) arg) - ((not (cdr others)) `(cons ,arg ,(car others))) - (t (values nil t)))) - - -(define-source-transform nconc (&rest args) - (case (length args) - (0 ()) - (1 (car args)) - (t (values nil t)))) - - -;;;; converting N-arg arithmetic functions -;;;; -;;;; N-arg arithmetic and logic functions are associated into two-arg -;;;; versions, and degenerate cases are flushed. - -;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION. -(declaim (ftype (sfunction (symbol t list t) list) associate-args)) -(defun associate-args (fun first-arg more-args) - (assert more-args) - (let ((next (rest more-args)) - (arg (first more-args))) - (if (null next) - `(,fun ,first-arg ,arg) - (associate-args fun `(,fun ,first-arg ,arg) next)))) - -;;; Reduce constants in ARGS list. -(declaim (ftype (sfunction (symbol list symbol) list) reduce-constants)) -(defun reduce-constants (fun args one-arg-result-type) - (let ((one-arg-constant-p - (cond - ((eq one-arg-result-type 'number) #'numberp) - ((eq one-arg-result-type 'integer) #'integerp) - (t (error "illegal one-arg-result-type ~a" one-arg-result-type)))) - (reduced-value) - (reduced-p nil)) - (core::collect ((not-constants)) - (dolist (arg args) - (let ((value (if (constantp arg) - arg ;;(constant-form-value arg) - arg))) - (cond ((not (funcall one-arg-constant-p value)) - (not-constants arg)) - (reduced-value - (setf reduced-value (funcall fun reduced-value value) - reduced-p t)) - (t - (setf reduced-value value))))) - ;; It is tempting to drop constants reduced to identity here, - ;; but if X is SNaN in (* X 1), we cannot drop the 1. - (if (not-constants) - (if reduced-p - `(,reduced-value ,@(not-constants)) - args) - `(,reduced-value))))) - -;;; Do source transformations for transitive functions such as +. -;;; One-arg cases are replaced with the arg and zero arg cases with -;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE) -;;; that the argument in one-argument calls is. -(declaim (ftype (function (symbol list t &optional symbol list) - (values t &optional (member nil t))) - source-transform-transitive)) -(defun source-transform-transitive (fun args identity - &optional (one-arg-result-type 'number) - (one-arg-prefixes '(values))) - (let ((two-arg-fun (find-two-arg-function fun))) - (case (length args) - (0 identity) - (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args)))) - (2 (values `(,two-arg-fun ,@args) t)) - (t - (let* ((reduced-args (reduce-constants fun args one-arg-result-type)) - (first (first reduced-args)) - (rest (rest reduced-args))) - (if rest - (associate-args two-arg-fun first rest) - first)))))) - - -(define-source-transform + (&rest args) - (source-transform-transitive '+ args 0)) -(define-source-transform * (&rest args) - (source-transform-transitive '* args 1)) - - - - -;;;; converting N-arg comparisons -;;;; -;;;; We convert calls to N-arg comparison functions such as < into -;;;; two-arg calls. This transformation is enabled for all such -;;;; comparisons in this file. If any of these predicates are not -;;;; open-coded, then the transformation should be removed at some -;;;; point to avoid pessimization. - -;;; This function is used for source transformation of N-arg -;;; comparison functions other than inequality. We deal both with -;;; converting to two-arg calls and inverting the sense of the test, -;;; if necessary. If the call has two args, then we pass or return a -;;; negated test as appropriate. If it is a degenerate one-arg call, -;;; then we transform to code that returns true. Otherwise, we bind -;;; all the arguments and expand into a bunch of IFs. -(defun multi-compare (orig-predicate args not-p type &optional force-two-arg-p) - (let ((nargs (length args)) - (predicate (find-two-arg-function orig-predicate))) - (cond ((< nargs 1) (values nil t)) - ((= nargs 1) - #+bytecode `(the-single ,type ,(first args) t) - #-bytecode `(progn (the ,type ,@args) t)) - ((= nargs 2) - (if not-p - `(if (,predicate ,(first args) ,(second args)) nil t) - (if force-two-arg-p - `(,predicate ,(first args) ,(second args)) - (values nil t)))) - (t - (do* ((i (1- nargs) (1- i)) - (last nil current) - (current (gensym) (gensym)) - (vars (list current) (cons current vars)) - (result t (if not-p - `(if (,predicate ,current ,last) - nil ,result) - `(if (,predicate ,current ,last) - ,result nil)))) - ((zerop i) - `(let ,(mapcar #'list vars args) (declare (type ,type ,@vars)) ,result))))))) - -(define-source-transform = (&rest args) (multi-compare '= args nil 'number)) -(define-source-transform < (&rest args) (multi-compare '< args nil 'real)) -(define-source-transform > (&rest args) (multi-compare '> args nil 'real)) -;;; We cannot do the inversion for >= and <= here, since both -;;; (< NaN X) and (> NaN X) -;;; are false, and we don't have type-information available yet. The -;;; deftransforms for two-argument versions of >= and <= takes care of -;;; the inversion to > and < when possible. -(define-source-transform <= (&rest args) (multi-compare '<= args nil 'real)) -(define-source-transform >= (&rest args) (multi-compare '>= args nil 'real)) - - -(declaim (inline canonicalize-test)) -(defun canonicalize-test (test test-p test-not test-not-p default) - (if test-p - (if test-not-p - (values nil nil) - (values test nil)) - (if test-not-p - (values test-not t) - (values default nil)))) - -(defun name-from-function-form (function-form &optional env) - (declare (ignore env)) - (if (constantp function-form) - (let ((fun (eval function-form))) ; constant-form-value - (cond ((symbolp fun) fun) - ((and (consp fun) - (eq (car fun) 'function) - (consp (cdr fun)) - (null (cddr fun))) - ;; (function x) - (second fun)) - (t nil))) - nil)) - -(declaim (inline satisfies-two-arg-test-p)) -(defun satisfies-two-arg-test-p (O Ei key test negate) - (let* ((Zi (funcall key Ei)) - (test-result (funcall test O Zi))) - (if negate (not test-result) test-result))) - -(defun two-arg-test-form (O-form Ei-form key key-p test test-p test-not test-not-p) - (multiple-value-bind (test negate) - (canonicalize-test test test-p test-not test-not-p) - (let* ((Zi-form - (if key-p - (let ((maybe-key (name-from-function-form key))) - (if maybe-key - `(,maybe-key ,Ei-form) - ;; multiple evaluation possibility! - `(funcall ,key ,Ei-form))) - Ei-form)) - (maybe-test (name-from-function-form test)) - ;; multiple evaluation possibiliy! - (test-form (if maybe-test - `(,maybe-test ,O-form ,Ei-form) - `(funcall ,test ,O-form ,Ei-form)))) - (if negate `(not ,test-form) test-form)))) - -(core:bclasp-define-compiler-macro assoc (item alist &key (key #'identity) (test nil test-p) (test-not nil test-not-p)) - (multiple-value-bind (test negate) - (canonicalize-test test test-p test-not test-not-p '#'eql) - (let ((S (gensym "S")) (pair (gensym "PAIR")) - (stest (gensym "TEST")) (skey (gensym "KEY")) (sitem (gensym "ITEM"))) - `(do ((,S ,alist ,(cdr S)) - (,skey ,key) - (,stest ,test)) - ((endp ,S) nil) - (let ((,pair (car ,S))) - (when ,(if negate - `(not (funcall ,stest ,sitem (funcall ,skey (car ,pair)))) - `(funcall ,stest ,sitem (funcall ,skey (car ,pair)))) - (return ,pair))))))) diff --git a/src/lisp/kernel/lsp/special-operators.lisp b/src/lisp/kernel/lsp/special-operators.lisp new file mode 100644 index 0000000000..dbdc200d20 --- /dev/null +++ b/src/lisp/kernel/lsp/special-operators.lisp @@ -0,0 +1,40 @@ +(in-package #:core) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Set the fdefinition for all special operators to something more reasonable than T +;;; For known operators, put in a function with correct lambda list for the sake of +;;; documentation. +;;; +(macrolet + ((def-special-operator-function (name lambda-list &optional (vars lambda-list)) + `(unless (fboundp ',name) + (setf (fdefinition ',name) + (lambda ,lambda-list + (declare (ignore ,@vars)) + (error 'do-not-funcall-special-operator :operator ',name)))))) + (def-special-operator-function progn (&rest forms) (forms)) + (def-special-operator-function block (name &rest forms) (name forms)) + (def-special-operator-function catch (tag &rest forms) (tag forms)) + (def-special-operator-function eval-when (situations &rest forms) (situations forms)) + (def-special-operator-function flet (bindings &rest body) (bindings body)) + (def-special-operator-function function (thing)) + (def-special-operator-function the (values-type form)) + (def-special-operator-function go (tag)) + (def-special-operator-function if (condition then else)) + (def-special-operator-function labels (bindings &rest body) (bindings body)) + (def-special-operator-function let (bindings &rest body) (bindings body)) + (def-special-operator-function let* (bindings &rest body) (bindings body)) + (def-special-operator-function locally (&rest body) (body)) + (def-special-operator-function macrolet (bindings &rest body) (bindings body)) + (def-special-operator-function multiple-value-prog1 (values-form &rest forms) (values-form forms)) + (def-special-operator-function multiple-value-call (function &rest args) (function args)) + (def-special-operator-function progv (symbols values &rest forms) (symbols values forms)) + (def-special-operator-function quote (object)) + (def-special-operator-function return-from (name &optional value) (name value)) + (def-special-operator-function setq (&rest pairs) (pairs)) + (def-special-operator-function tagbody (&rest statements) (statements)) + (def-special-operator-function throw (tag result-form)) + (def-special-operator-function unwind-protect (protected &rest cleanup) (protected cleanup)) + (def-special-operator-function symbol-macrolet (bindings &rest body) (bindings body)) + (def-special-operator-function load-time-value (form &optional read-only-p) (form read-only-p))) diff --git a/src/lisp/kernel/lsp/top-hook.lisp b/src/lisp/kernel/lsp/top-hook.lisp index 45a73b4470..f9fda6743e 100644 --- a/src/lisp/kernel/lsp/top-hook.lisp +++ b/src/lisp/kernel/lsp/top-hook.lisp @@ -1,4 +1,6 @@ -(defun sys::load-foreign-libraries () +(in-package #:core) + +(defun load-foreign-libraries () (when (find-package :cffi) (loop with list-foreign-libraries = (find-symbol "LIST-FOREIGN-LIBRARIES" :cffi) with load-foreign-library = (find-symbol "LOAD-FOREIGN-LIBRARY" :cffi) @@ -7,43 +9,62 @@ for name = (ignore-errors (funcall foreign-library-name lib)) do (ignore-errors (funcall load-foreign-library name))))) -(defun sys::load-extensions () - (when (and core:*extension-systems* +(defun load-extensions () + (when (and *extension-systems* (notany (lambda (feature) (member feature '(:ignore-extensions :ignore-extension-systems))) *features*)) (require :asdf) (loop with load-system = (or (ignore-errors (find-symbol "QUICKLOAD" :quicklisp)) (find-symbol "LOAD-SYSTEM" :asdf)) - for system in core:*extension-systems* + for system in *extension-systems* do (funcall load-system system)))) -(defun sys::call-initialize-hooks () - (loop for hook in core:*initialize-hooks* +(defun call-initialize-hooks () + (loop for hook in *initialize-hooks* do (funcall hook))) -(defun sys::call-terminate-hooks () - (loop for hook in core:*terminate-hooks* +(defun call-terminate-hooks () + (loop for hook in *terminate-hooks* do (funcall hook))) -(defun sys::standard-toplevel () +(defun maybe-load-clasprc () + "Maybe load the users startup code" + (unless (no-rc-p) + (let ((clasprc (rc-file-name))) + (if (probe-file clasprc) + (progn + (unless (noinform-p) + (format t "Loading resource file ~a~%" clasprc)) + (load-source clasprc)) + (unless (noinform-p) + (format t "Resource file ~a not found, skipping loading of it.~%" clasprc)))))) + +(defun process-command-line-load-eval-sequence () + (loop for (cmd . arg) in (command-line-load-eval-sequence) + do (ecase cmd + (:load (load arg)) + (:script (load-source arg nil nil nil t)) + (:eval (eval (read-from-string arg)))))) + +(defun standard-toplevel () (ext:lock-package "CORE") #-staging (when (ext:getenv "CLASP_AUTOCOMPILATION") (funcall 'ext:start-autocompilation)) - (case (core:startup-type) + (case (startup-type) ((:snapshot-file :embedded-snapshot) - (sys::load-foreign-libraries)) + (load-foreign-libraries)) (otherwise - (core:maybe-load-clasprc) - (sys::load-extensions))) - (sys::call-initialize-hooks) + (maybe-load-clasprc) + (load-extensions))) + (call-initialize-hooks) (unwind-protect (progn - (core:process-command-line-load-eval-sequence) - (if (core:is-interactive-lisp) - (core:top-level) - (core:exit 0))) - (sys::call-terminate-hooks))) + (process-command-line-load-eval-sequence) + (if (is-interactive-lisp) + (top-level) + (exit 0))) + (call-terminate-hooks))) -(setf ext:*toplevel-hook* 'sys::standard-toplevel) +(setf ext:*toplevel-hook* 'standard-toplevel) diff --git a/src/lisp/kernel/lsp/top.lisp b/src/lisp/kernel/lsp/top.lisp index b5dc6e18eb..a1b3cc21ca 100644 --- a/src/lisp/kernel/lsp/top.lisp +++ b/src/lisp/kernel/lsp/top.lisp @@ -25,6 +25,17 @@ (export '(*break-readtable* *tpl-prompt-hook* *allow-recursive-debug*)) +(defparameter * nil) +(defparameter ** nil) +(defparameter *** nil) +(defparameter + nil) +(defparameter ++ nil) +(defparameter +++ nil) +(defparameter - nil) +(defparameter / nil) +(defparameter // nil) +(defparameter /// nil) + (defvar sys:*echo-repl-tpl-read* nil "Set to t if you want to echo what was typed at the REPL top-level") (defparameter *quit-tag* (cons nil nil)) (defparameter *quit-tags* nil) diff --git a/src/lisp/kernel/lsp/trace.lisp b/src/lisp/kernel/lsp/trace.lisp index bdb7a7b35e..7dc9f8b4b0 100644 --- a/src/lisp/kernel/lsp/trace.lisp +++ b/src/lisp/kernel/lsp/trace.lisp @@ -17,10 +17,6 @@ (defparameter *trace-list* nil) (defparameter *trace-max-indent* 20) -#+clasp-min -(eval-when (:load-toplevel :execute) - (setq core::*trace-output* *standard-output*)) - (defun currently-traced () (mapcar #'first *trace-list*)) @@ -175,9 +171,7 @@ all functions." ;;; just broke the compiler and want to do some tracing to find the problem. (defun simple-trace (fname safe) (let ((oldf (fdefinition fname))) - (funcall #'(setf fdefinition) - (make-trace-closure fname oldf safe) - fname) + (setf (fdefinition fname) (make-trace-closure fname oldf safe)) (add-to-trace-list fname oldf)) (list fname)) @@ -192,7 +186,7 @@ all functions." (trace-safe-print 'enter fname args) (let ((results (let ((*inside-trace* nil)) - (multiple-value-list (core:trace-apply0 oldf args))))) + (multiple-value-list (apply oldf args))))) (trace-safe-print 'exit fname results) (values-list results)))))) (lambda (&rest args) @@ -204,7 +198,7 @@ all functions." (trace-print 'enter fname args) (let ((results (let ((*inside-trace* nil)) - (multiple-value-list (core:trace-apply0 oldf args))))) + (multiple-value-list (apply oldf args))))) (trace-print 'exit fname results) (values-list results)))))))) @@ -253,39 +247,22 @@ all functions." (multiple-value-bind (bars rem) (floor indent 4) (dotimes (i bars) (princ (if (< i 10) "| " "| ") *trace-output*)) - (when (plusp rem) (progn - #-clasp-min (format *trace-output* "~V,,,' A" rem "|") - #+clasp-min (format *trace-output* " | ")))) - #-clasp-min - (format *trace-output* - "~D> (~S~{ ~S~})~%" *trace-level* fname vals) - #+clasp-min + (when (plusp rem) (format *trace-output* "~V,,,' A" rem "|"))) (format *trace-output* - "~D> (~S ~S)~%" *trace-level* fname vals)) + "~D> (~S~{ ~S~})~%" *trace-level* fname vals)) (EXIT (multiple-value-bind (bars rem) (floor indent 4) (dotimes (i bars) (princ "| " *trace-output*)) - (when (plusp rem) (progn - #-clasp-min (format *trace-output* "~V,,,' A" rem "|") - #+clasp-min (format *trace-output* " | ")))) - #-clasp-min - (format *trace-output* - "<~D (~S~{ ~S~})~%" *trace-level* fname vals) - #+clasp-min + (when (plusp rem) (format *trace-output* "~V,,,' A" rem "|"))) (format *trace-output* - "<~D (~S ~S)~%" *trace-level* fname vals))) + "<~D (~S~{ ~S~})~%" *trace-level* fname vals))) (when extras (multiple-value-bind (bars rem) (floor indent 4) (dotimes (i bars) (princ "| " *trace-output*)) - (when (plusp rem) (progn - #-clasp-min (format *trace-output* "~V,,,' A" rem "|") - #+clasp-min (format *trace-output* " | ")))) - #-clasp-min(format *trace-output* - "~0,4@T\\\\ ~{ ~S~}~%" extras) - #+clasp-min(format *trace-output* - " ~s " extras)) + (when (plusp rem) (format *trace-output* "~V,,,' A" rem "|"))) + (format *trace-output* "~0,4@T\\\\ ~{ ~S~}~%" extras)) *trace-output*) *trace-output*))) @@ -294,7 +271,6 @@ all functions." (*print-circle* t)) (core:fmt *trace-output* "{}" (with-output-to-string (*trace-output*) - #+(or)(core:fmt *trace-output* "%N") (case direction (ENTER (multiple-value-bind (bars rem) @@ -357,7 +333,7 @@ all functions." ((traced-and-redefined-p record) (warn "The function ~S was traced, but redefined." fname)) (t - (funcall #'(setf fdefinition) (trace-record-old-definition record) fname))) + (setf (fdefinition fname) (trace-record-old-definition record)))) (delete-from-trace-list fname) (values))) @@ -368,6 +344,6 @@ Evaluates FORM in the Stepper mode and returns all its values." (progn (core:set-breakstep) (locally - #+(or cclasp eclasp) (declare (optimize clasp-cleavir::insert-step-conditions)) - ,form)) + (declare (optimize core::insert-step-conditions)) + ,form)) (core:unset-breakstep))) diff --git a/src/lisp/kernel/lsp/util.lisp b/src/lisp/kernel/lsp/util.lisp deleted file mode 100644 index 9f8b763c7c..0000000000 --- a/src/lisp/kernel/lsp/util.lisp +++ /dev/null @@ -1,42 +0,0 @@ - -(in-package :core) - -;; -;; TODO: Rewrite this in C++ when you get the chance - a lot of stuff depends on it -;; -(defun nconc (&rest lists) - "Concatenate LISTS by changing them." - (setq lists (do ((p lists (cdr p))) - ((or (car p) (null p)) p))) - (do* ((top (car lists)) - (splice top) - (here (cdr lists) (cdr here))) - ((null here) top) - (rplacd (last splice) (car here)) - (if (car here) - (setq splice (car here))))) - -(defun tailp (object list) - "Return true if OBJECT is the same as some tail of LIST, otherwise false." - (if (null list) - (null object) - (do ((list list (cdr list))) - ((atom (cdr list)) (or (eql object list) (eql object (cdr list)))) - (if (eql object list) - (return t))))) - -(defun ldiff (list object) - "Return a copy of LIST before the part which is the same as OBJECT." - (unless (eql list object) - (do* ((result (list (car list))) - (splice result) - (list (cdr list) (cdr list))) - ((atom list) (if (eql list object) (rplacd splice nil)) result) - (if (eql list object) - (return result) - (setq splice (cdr (rplacd splice (list (car list))))))))) - -;; stuff - - - diff --git a/src/lisp/modules/clang-tool/clang-tool.lisp b/src/lisp/modules/clang-tool/clang-tool.lisp index 78cc28947f..a0b9fa9747 100644 --- a/src/lisp/modules/clang-tool/clang-tool.lisp +++ b/src/lisp/modules/clang-tool/clang-tool.lisp @@ -13,7 +13,7 @@ Find directories that look like them and replace the ones defined in the constan (defpackage #:clang-tool (:shadow #:function-info #:function-type) (:use #:common-lisp #:core #:ast-tooling #:clang-ast) - (:shadow #:dump #:get-string #:size #:type #:source-manager) + (:shadow #:ensure-directory #:dump #:get-string #:size #:type #:source-manager) (:export #:with-compilation-tool-database #:match-in-compilation-tool-database-source-tree @@ -71,10 +71,8 @@ Find directories that look like them and replace the ones defined in the constan (defparameter *current-multitool* nil "Keep track of the current multitool") -(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *externals-clasp-pathname* (make-pathname :directory (pathname-directory (pathname ext:*clasp-clang-path*)))) - #+(or linux freebsd) (defparameter *externals-clasp-include-dir* (namestring (car (directory (pathname (format nil "~a../lib/clang/*/" *externals-clasp-pathname*)))))) - ) +(defparameter *externals-clasp-pathname* (make-pathname :directory (pathname-directory (pathname ext:*clasp-clang-path*)))) +#+(or linux freebsd) (defparameter *externals-clasp-include-dir* (namestring (car (directory (pathname (format nil "~a../lib/clang/*/" *externals-clasp-pathname*)))))) (defvar +resource-dir+ #+darwin (namestring (car (directory "/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/lib/clang/*/"))) diff --git a/src/lisp/modules/clasp-analyzer/clasp-analyzer.lisp b/src/lisp/modules/clasp-analyzer/clasp-analyzer.lisp index 2ea0f965d9..3c3982717b 100644 --- a/src/lisp/modules/clasp-analyzer/clasp-analyzer.lisp +++ b/src/lisp/modules/clasp-analyzer/clasp-analyzer.lisp @@ -1333,9 +1333,10 @@ can be saved and reloaded within the project for later analysis" (read fin))) (defun save-project (project) - (core::with-print-readably + (with-standard-io-syntax + (let ((*print-circle* t)) (with-open-file (fout (project-pathname "project" "dat") :direction :output) - (prin1 project fout)))) + (prin1 project fout))))) (defvar *project*) diff --git a/src/lisp/modules/encoding-generator/encoding-generator.asd b/src/lisp/modules/encoding-generator/encoding-generator.asd new file mode 100644 index 0000000000..47a9a7b582 --- /dev/null +++ b/src/lisp/modules/encoding-generator/encoding-generator.asd @@ -0,0 +1,8 @@ +(asdf:defsystem #:encoding-generator + :version "1.0.0" + :author ("Bike " "Karsten Poeck") + :maintainer "Bike " + :license "LGPL-3.0" + :depends-on (#:alexandria) + :components ((:file "packages") + (:file "generate" :depends-on ("packages")))) diff --git a/src/lisp/modules/encoding-generator/generate.lisp b/src/lisp/modules/encoding-generator/generate.lisp new file mode 100644 index 0000000000..c5d01b7805 --- /dev/null +++ b/src/lisp/modules/encoding-generator/generate.lisp @@ -0,0 +1,42 @@ +(in-package #:encoding-generator) + +;;;; process-encodings-file is the main entry point. + +(defun encoding-string-to-encoding-symbol (encoding-string) + ;; encodingdata.txt is assumed to only hold valid encoding names. + (intern encoding-string "KEYWORD")) + +;;; format per line :ISO-8859-2;0;0; +;;; name of the encoding, the encoding's char-code, and unicode code point. +;;; So, :ISO-8859-5;161;1025; expresses that in the ISO-8859-5 encoding, +;;; 161 maps to Unicode codepoint 1025 (CYRILLIC CAPITAL LETTER IO). +(defun parse-line (line) + (let* ((pos-colon (position #\: line :test #'char=)) + (pos-semicolon-1 (position #\; line :test #'char=)) + (encoding-string (subseq line (1+ pos-colon) pos-semicolon-1)) + (pos-semicolon-2 (position #\; line :test #'char= :start (1+ pos-semicolon-1))) + (encoding-point (parse-integer (subseq line (1+ pos-semicolon-1) pos-semicolon-2))) + (pos-semicolon-3 (position #\; line :test #'char= :start (1+ pos-semicolon-2))) + (unicode-codepoint (parse-integer (subseq line (1+ pos-semicolon-2) pos-semicolon-3)))) + (values (encoding-string-to-encoding-symbol encoding-string) + encoding-point + unicode-codepoint))) + +;;; Creates and returns an encoding cache based on an input encodingdata.txt. +;;; An encoding cache is an alist mapping encoding names, i.e. keywords +;;; returned from encoding-string-to-encoding-symbol, to encoding tables. +;;; An encoding table is an alist mapping encoding code points to +;;; characters. +(defun process-encodings-file (file) + (with-open-file (stream file :element-type 'character :direction :input + :external-format :utf-8) + (loop with encodings = () + for line = (read-line stream nil :end) + until (eq line :end) + do (multiple-value-bind (encoding point unipoint) + (parse-line line) + (setf (alexandria:assoc-value + (alexandria:assoc-value encodings encoding) + point) + unipoint)) + finally (return encodings)))) diff --git a/src/lisp/modules/encoding-generator/packages.lisp b/src/lisp/modules/encoding-generator/packages.lisp new file mode 100644 index 0000000000..c7bec3776f --- /dev/null +++ b/src/lisp/modules/encoding-generator/packages.lisp @@ -0,0 +1,3 @@ +(defpackage #:encoding-generator + (:use #:cl) + (:export #:process-encodings-file)) diff --git a/src/lisp/regression-tests/debug.lisp b/src/lisp/regression-tests/debug.lisp index 5ddc724799..8f934266bd 100644 --- a/src/lisp/regression-tests/debug.lisp +++ b/src/lisp/regression-tests/debug.lisp @@ -291,7 +291,6 @@ ;; FIXME: Export declaration? DEBUG 3 instead? ;; We are of course assuming cclasp is being used ;; to compile the tests. - (declare (optimize - clasp-cleavir::insert-step-conditions)) + (declare (optimize core::insert-step-conditions)) (print 4)) (clasp-debug:unset-breakstep))))) diff --git a/src/lisp/regression-tests/encodings.lisp b/src/lisp/regression-tests/encodings.lisp index 7f90161758..b56f97b1b7 100644 --- a/src/lisp/regression-tests/encodings.lisp +++ b/src/lisp/regression-tests/encodings.lisp @@ -85,8 +85,8 @@ (test-true compile-file-with-lambda (let () - (compile-file #P"sys:src;lisp;regression-tests;latin2-check.lisp" :external-format :iso-8859-1 :execution :serial) - (compile-file #P"sys:src;lisp;regression-tests;latin2-check.lisp" :external-format :iso-8859-1 :execution :parallel))) + (compile-file #P"sys:src;lisp;regression-tests;latin2-check.lisp" :external-format :iso-8859-1 :parallel nil) + (compile-file #P"sys:src;lisp;regression-tests;latin2-check.lisp" :external-format :iso-8859-1 :parallel t))) (test-expect-error compile-file-with-lambda-default-encoding (compile-file #P"sys:src;lisp;regression-tests;latin2-check.lisp" :external-format :us-ascii) diff --git a/src/lisp/regression-tests/extensions.lisp b/src/lisp/regression-tests/extensions.lisp index 3648c027be..c442ca5182 100644 --- a/src/lisp/regression-tests/extensions.lisp +++ b/src/lisp/regression-tests/extensions.lisp @@ -25,7 +25,7 @@ (ext::source-location-p (first (ext:source-location 'fixnum :type)))) (test-true source-location-variable - (ext::source-location-p (first (ext:source-location '*print-pretty* :variable)))) + (ext::source-location-p (first (ext:source-location 'ext:*source-location-kinds* :variable)))) (test-true run-program-hello-world diff --git a/src/lisp/regression-tests/framework.lisp b/src/lisp/regression-tests/framework.lisp index 954ef1db79..15d62c47da 100644 --- a/src/lisp/regression-tests/framework.lisp +++ b/src/lisp/regression-tests/framework.lisp @@ -73,7 +73,7 @@ Successes: ~d" (push name *expected-failed-tests*) (push name *unexpected-failed-tests*)) (message :err "Failed ~s" name) - (message :warn "Unexpected error~%~t~a~%while evaluating~%~t~a" + (message :warn "Unexpected error~%~t~a~%while evaluating~%~t~s" error form) (when description (message :info "~s" description))) @@ -84,7 +84,7 @@ Successes: ~d" (message :err "Failed ~s" name) (message :warn "Wanted values ~s to~%~{~t~a~%~}but got~%~{~t~a~%~}" test expected actual) - (message :warn "while evaluating~%~t~a~%" form) + (message :warn "while evaluating~%~t~s~%" form) (when description (message :info "~s" description))) (defun %succeed-test (name) diff --git a/src/lisp/regression-tests/interrupt.lisp b/src/lisp/regression-tests/interrupt.lisp index a035558907..bf095877bf 100644 --- a/src/lisp/regression-tests/interrupt.lisp +++ b/src/lisp/regression-tests/interrupt.lisp @@ -87,3 +87,28 @@ (ignore-errors (mp:process-join proc)) cell) (t)) + +;;; Check unwind-protect semantics: Interrupts are disabled while unwinding, +;;; but restored afterwards. +(defun call-with-uwp (function cleanup) + ;; separate to try to avoid compiler optimizations. + (unwind-protect (funcall function) (funcall cleanup))) + +(test unwind-protect.interrupt.1 + (mp:with-interrupts + (let ((outer-interruptiblep (mp:interruptiblep)) + unwinding-interruptiblep) + (call-with-uwp (lambda ()) (lambda () (setf unwinding-interruptiblep + (mp:interruptiblep)))) + (values unwinding-interruptiblep (eq outer-interruptiblep + (mp:interruptiblep))))) + (nil t)) + +(test unwind-protect.interrupt.2 + (mp:with-interrupts + (let ((outer-interruptiblep (mp:interruptiblep))) + (values (block nil + (call-with-uwp (lambda ()) + (lambda () (return (mp:interruptiblep))))) + (eq outer-interruptiblep (mp:interruptiblep))))) + (nil t)) diff --git a/src/lisp/regression-tests/snapshot.lisp b/src/lisp/regression-tests/snapshot.lisp index 832b3d16d5..a0d7a20fa9 100644 --- a/src/lisp/regression-tests/snapshot.lisp +++ b/src/lisp/regression-tests/snapshot.lisp @@ -10,6 +10,7 @@ (multiple-value-bind (stream dump-code) (ext:run-program binary (list "--norc" "--base" "--feature" "ignore-extensions" + "--non-interactive" "--eval" "(defparameter *foo* 89)" "--eval" (format nil "(ext:save-lisp-and-die \"~a\")" snap-fname)) @@ -41,6 +42,7 @@ (multiple-value-bind (stream dump-code) (ext:run-program binary (list "--norc" "--base" "--feature" "ignore-extensions" + "--non-interactive" "--eval" "(defparameter *foo* 90)" "--eval" (format nil "(ext:save-lisp-and-die \"~a\" :executable t)" diff --git a/src/lisp/regression-tests/unwind.lisp b/src/lisp/regression-tests/unwind.lisp index cd330df488..7ac6ec28b4 100644 --- a/src/lisp/regression-tests/unwind.lisp +++ b/src/lisp/regression-tests/unwind.lisp @@ -5,7 +5,7 @@ (let ((unwinds (gctools:thread-local-unwinds))) (ext:with-unlocked-packages ("CL" "CORE") (compile-file "sys:src;lisp;kernel;lsp;predlib.lisp" - :execution :serial + :parallel nil :output-file (make-pathname :type (pathname-type (compile-file-pathname "foo.lisp")) :defaults (core:mkstemp "/tmp/predlib"))) diff --git a/src/llvmo/code.cc b/src/llvmo/code.cc index 430fdf8b7a..88f1b9600c 100644 --- a/src/llvmo/code.cc +++ b/src/llvmo/code.cc @@ -143,12 +143,6 @@ size_t ObjectFile_O::sizeofInState(ObjectFile_O* code, CodeState_t state) { return gctools::sizeof_container(code->_DataCode.size()); } -std::string ObjectFile_O::filename() const { - stringstream ss; - ss << this->_FasoName->get_std_string() << ":" << this->_ObjectId; - return ss.str(); -} - void ObjectFile_O::writeToFile(const std::string& fileName, const char* start, size_t size) { std::ofstream outfile; outfile.open(fileName, std::ios::binary | std::ios::out); diff --git a/src/llvmo/link_intrinsics.cc b/src/llvmo/link_intrinsics.cc index ab4af6b67b..578bf27208 100644 --- a/src/llvmo/link_intrinsics.cc +++ b/src/llvmo/link_intrinsics.cc @@ -116,381 +116,6 @@ namespace llvmo { extern "C" { -void cc_initialize_gcroots_in_module(gctools::GCRootsInModule* holder, core::T_O** root_address, size_t num_roots, - gctools::Tagged initial_data, SimpleVector_O** transientAlloca, size_t transient_entries, - size_t function_pointer_count, ClaspXepAnonymousFunction* fptrs) { - NO_UNWIND_BEGIN(); - DEBUG_OBJECT_FILES_PRINT(("%s:%d:%s GCRootsInModule@%p root_address@%p num_roots %lu initial_data = %p\n", __FILE__, __LINE__, - __FUNCTION__, (void*)holder, (void*)root_address, num_roots, (void*)initial_data)); - initialize_gcroots_in_module(holder, root_address, num_roots, initial_data, transientAlloca, transient_entries, - function_pointer_count, (void**)fptrs); - NO_UNWIND_END(); -} - -void cc_finish_gcroots_in_module(gctools::GCRootsInModule* holder) { - NO_UNWIND_BEGIN(); - llvmo::JITDataReadWriteMaybeExecute(); - holder->_TransientAlloca = NULL; - llvmo::JITDataReadExecute(); - NO_UNWIND_END(); -} - -void cc_remove_gcroots_in_module(gctools::GCRootsInModule* holder) { - NO_UNWIND_BEGIN(); - shutdown_gcroots_in_module(holder); - NO_UNWIND_END(); -} - -// Define what ltvc_xxxx functions return - this must match what is -// in cmpintrinsics.lisp -typedef void LtvcReturnVoid; -#define LTVCRETURN /* Nothing return for void */ - -LtvcReturnVoid ltvc_make_nil(gctools::GCRootsInModule* holder, char tag, size_t index) { - NO_UNWIND_BEGIN(); - core::T_sp val = nil(); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_t(gctools::GCRootsInModule* holder, char tag, size_t index) { - NO_UNWIND_BEGIN(); - core::T_sp val = _lisp->_true(); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -T_O* ltvc_lookup_transient(gctools::GCRootsInModule* holder, char tag, size_t index) { - NO_UNWIND_BEGIN(); - return (T_O*)holder->getTransient(index); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_ratio(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* num, core::T_O* denom) { - NO_UNWIND_BEGIN(); - Integer_sp inum((gc::Tagged)num); - Integer_sp idenom((gc::Tagged)denom); - core::T_sp val = core::Ratio_O::create(inum, idenom); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_complex(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* real, core::T_O* imag) { - NO_UNWIND_BEGIN(); - core::Real_sp nreal((gctools::Tagged)real); - core::Real_sp nimag((gctools::Tagged)imag); - // Do not convert nreal and nimag to double, can be all types of Real_sp - core::T_sp val = core::Complex_O::create(nreal, nimag); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_cons(gctools::GCRootsInModule* holder, char tag, size_t index) { - NO_UNWIND_BEGIN(); - core::T_sp val = core::Cons_O::create(nil(), nil()); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_rplaca(gctools::GCRootsInModule* holder, core::T_O* cons_t, core::T_O* car_t) { - NO_UNWIND_BEGIN(); - core::T_sp tcons((gctools::Tagged)cons_t); - core::Cons_sp cons = gc::As(tcons); - cons->rplaca(core::T_sp(car_t)); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_rplacd(gctools::GCRootsInModule* holder, core::T_O* cons_t, core::T_O* cdr_t) { - NO_UNWIND_BEGIN(); - core::T_sp tcons((gctools::Tagged)cons_t); - core::Cons_sp cons = gc::As(tcons); - cons->rplacd(core::T_sp(cdr_t)); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_list(gctools::GCRootsInModule* holder, char tag, size_t index, size_t len) { - NO_UNWIND_BEGIN(); - // Makes a list of length LEN where all elements are NIL. - // (ltvc_fill_list will be immediately after, so they could be undefined just as well.) - ql::list result; - for (; len != 0; --len) - result << nil(); - LTVCRETURN holder->setTaggedIndex(tag, index, result.result().tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_fill_list(gctools::GCRootsInModule* holder, core::T_O* list, size_t len, ...) { - NO_UNWIND_BEGIN(); - core::T_sp cur((gctools::Tagged)list); - va_list va; - va_start(va, len); - for (; len != 0; --len) { - core::Cons_sp cons = gc::As(cur); - cons->rplaca(core::T_sp(va_arg(va, T_O*))); - cur = cons->cdr(); - } - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_array(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* telement_type, - core::T_O* tdimensions) { - NO_UNWIND_BEGIN(); - core::T_sp element_type(telement_type); - core::List_sp dimensions((gctools::Tagged)tdimensions); - core::T_sp val; - if (core::cl__length(dimensions) == 1) // vector - { - val = core::core__make_vector(element_type, oCar(dimensions).unsafe_fixnum()); - } else { - val = core::core__make_mdarray(dimensions, element_type); - } - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -void ltvc_setf_row_major_aref(gctools::GCRootsInModule* holder, core::T_O* array_t, size_t row_major_index, core::T_O* value_t) { - NO_UNWIND_BEGIN(); - core::T_sp tarray((gctools::Tagged)array_t); - core::Array_sp array = gc::As(tarray); - array->rowMajorAset(row_major_index, core::T_sp(value_t)); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_hash_table(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* test_t) { - NO_UNWIND_BEGIN(); - LTVCRETURN holder->setTaggedIndex(tag, index, core::HashTable_O::create(core::T_sp(test_t)).tagged_()); - NO_UNWIND_END(); -} - -void ltvc_setf_gethash(gctools::GCRootsInModule* holder, core::T_O* hash_table_t, core::T_O* key_index_t, - core::T_O* value_index_t) { - NO_UNWIND_BEGIN(); - core::HashTable_sp hash_table = gctools::As(core::T_sp(hash_table_t)); - core::T_sp key(key_index_t); - core::T_sp value(value_index_t); - hash_table->hash_table_setf_gethash(key, value); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_fixnum(gctools::GCRootsInModule* holder, char tag, size_t index, int64_t val) { - NO_UNWIND_BEGIN(); - core::T_sp v = clasp_make_fixnum(val); - LTVCRETURN holder->setTaggedIndex(tag, index, v.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_next_bignum(gctools::GCRootsInModule* holder, char tag, size_t index, T_O* bignum) { - NO_UNWIND_BEGIN(); - core::T_sp val = core::T_sp(bignum); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_bitvector(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* bitvector_string_t) { - NO_UNWIND_BEGIN(); - core::SimpleBaseString_sp bitvector_string = gctools::As(core::T_sp(bitvector_string_t)); - core::T_sp val = core::SimpleBitVector_O::make(bitvector_string->get_std_string()); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_symbol(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* name_t, core::T_O* package_t) { - NO_UNWIND_BEGIN(); - core::T_sp package((gctools::Tagged)package_t); - core::SimpleString_sp symbol_name((gctools::Tagged)name_t); - core::Symbol_sp sym; - if (package.notnilp()) { - sym = gctools::As(package)->intern(symbol_name); - } else { - sym = core::Symbol_O::create(symbol_name); - } - core::T_sp val = sym; - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_character(gctools::GCRootsInModule* holder, char tag, size_t index, uintptr_t val) { - NO_UNWIND_BEGIN(); - core::T_sp v = clasp_make_character(val); - LTVCRETURN holder->setTaggedIndex(tag, index, v.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_base_string(gctools::GCRootsInModule* holder, char tag, size_t index, const char* str) { - NO_UNWIND_BEGIN(); - core::T_sp v = core::SimpleBaseString_O::make(str); - LTVCRETURN holder->setTaggedIndex(tag, index, v.tagged_()); - NO_UNWIND_END(); -} -}; - -extern "C" { - -LtvcReturnVoid ltvc_make_pathname(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* host_t, core::T_O* device_t, - core::T_O* directory_t, core::T_O* name_t, core::T_O* type_t, core::T_O* version_t) { - NO_UNWIND_BEGIN(); - core::T_sp val = - core::Pathname_O::makePathname(core::T_sp(host_t), core::T_sp(device_t), core::T_sp(directory_t), core::T_sp(name_t), - core::T_sp(type_t), core::T_sp(version_t), kw::_sym_local, core::T_sp(host_t).notnilp()); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_function_description(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* sourcePathname_t, - core::T_O* functionName_t, core::T_O* lambdaList_t, core::T_O* docstring_t, - core::T_O* declares_t, size_t lineno, size_t column, size_t filepos) { - NO_UNWIND_BEGIN(); - core::FunctionDescription_sp val = - core::makeFunctionDescription(core::T_sp(functionName_t), core::T_sp(lambdaList_t), core::T_sp(docstring_t), - core::T_sp(declares_t), core::T_sp(sourcePathname_t), lineno, column, filepos); - // printf("%s:%d:%s Created FunctionDescription_sp @%p entry_point = %p\n", __FILE__, __LINE__, __FUNCTION__, (void*)val.raw_(), - // (void*)llvm_func); - if (!gc::IsA(val)) { - SIMPLE_ERROR("The object is not a FunctionDescription {}", core::_rep_(val)); - } - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_local_entry_point(gctools::GCRootsInModule* holder, char tag, size_t index, size_t functionIndex, - core::T_O* functionDescription_t) { - NO_UNWIND_BEGIN(); - ClaspCoreFunction llvm_func = (ClaspCoreFunction)holder->lookup_function(functionIndex); - core::FunctionDescription_sp fdesc((gctools::Tagged)functionDescription_t); - core::CoreFun_sp simpleFun = core::makeCoreFun(fdesc, llvm_func); - LTVCRETURN holder->setTaggedIndex(tag, index, simpleFun.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_global_entry_point(gctools::GCRootsInModule* holder, char tag, size_t index, size_t functionIndex0, - core::T_O* functionDescription_t, size_t localEntryPointIndex) { - NO_UNWIND_BEGIN(); - core::CoreFun_sp localEntryPoint((gctools::Tagged)holder->getLiteral(localEntryPointIndex)); - core::FunctionDescription_sp fdesc((gctools::Tagged)functionDescription_t); - core::ClaspXepTemplate xep; - for (size_t ii = 0; ii < core::ClaspXepFunction::Entries; ++ii) { - xep._EntryPoints[ii] = (ClaspXepAnonymousFunction)holder->lookup_function(functionIndex0 + ii); - } - core::SimpleCoreFun_sp simpleFun = core::makeSimpleCoreFun(fdesc, xep, localEntryPoint); - LTVCRETURN holder->setTaggedIndex(tag, index, simpleFun.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_ensure_fcell(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* fname) { - NO_UNWIND_BEGIN(); - T_sp tfname((gctools::Tagged)fname); - FunctionCell_sp fcell = core__ensure_function_cell(tfname); - LTVCRETURN holder->setTaggedIndex(tag, index, fcell.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_ensure_vcell(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* vname) { - NO_UNWIND_BEGIN(); - T_sp tvname((gctools::Tagged)vname); - VariableCell_sp vcell = gc::As_assert(tvname)->ensureVariableCell(); - LTVCRETURN holder->setTaggedIndex(tag, index, vcell.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_package(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* package_name_t) { - NO_UNWIND_BEGIN(); - core::SimpleString_sp package_name((gctools::Tagged)package_name_t); - core::T_sp tpkg = _lisp->findPackage(package_name, false); - if (tpkg.nilp()) { - // If we don't find the package - just make it - // a more comprehensive defpackage should be coming - tpkg = _lisp->makePackage(package_name->get_std_string(), std::list(), std::list()); - } - core::T_sp val = tpkg; - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_random_state(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* random_state_string_t) { - NO_UNWIND_BEGIN(); - core::SimpleBaseString_sp random_state_string((gctools::Tagged)random_state_string_t); - core::RandomState_sp rs = core::RandomState_O::create(); - rs->random_state_set(random_state_string->get_std_string()); - core::T_sp val = rs; - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_binary16(gctools::GCRootsInModule* holder, char tag, size_t index, core::short_float_t f) { - NO_UNWIND_BEGIN(); - core::T_sp val = clasp_make_single_float(f); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_binary32(gctools::GCRootsInModule* holder, char tag, size_t index, core::single_float_t f) { - NO_UNWIND_BEGIN(); - core::T_sp val = clasp_make_single_float(f); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_binary64(gctools::GCRootsInModule* holder, char tag, size_t index, core::double_float_t f) { - NO_UNWIND_BEGIN(); - core::T_sp val = DoubleFloat_O::create(f); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_binary80(gctools::GCRootsInModule* holder, char tag, size_t index, core::long_float_t f) { - NO_UNWIND_BEGIN(); - core::T_sp val = LongFloat_O::create(f); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -LtvcReturnVoid ltvc_make_binary128(gctools::GCRootsInModule* holder, char tag, size_t index, core::long_float_t f) { - NO_UNWIND_BEGIN(); - core::T_sp val = LongFloat_O::create(f); - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); - NO_UNWIND_END(); -} - -gctools::Tagged ltvc_lookup_literal(gctools::GCRootsInModule* holder, size_t index) { - return holder->getTaggedIndex(LITERAL_TAG_CHAR, index); -} - -LtvcReturnVoid ltvc_set_mlf_creator_funcall(gctools::GCRootsInModule* holder, char tag, size_t index, size_t simpleFunIndex, - const char* name) { - return ltvc_set_ltv_funcall(holder, tag, index, simpleFunIndex, name); -} - -LtvcReturnVoid ltvc_mlf_init_funcall(gctools::GCRootsInModule* holder, size_t simpleFunIndex, const char* name) { - // printf("%s:%d:%s make entry-point-index got simpleFunIndex %lu name: %s\n", __FILE__, __LINE__, __FUNCTION__, simpleFunIndex, - // name ); - core::Function_sp ep((gctools::Tagged)holder->getLiteral(simpleFunIndex)); - [[maybe_unused]] auto ret = ep->funcall(); -} - -// Similar to the above, but puts value in the table. -LtvcReturnVoid ltvc_set_ltv_funcall(gctools::GCRootsInModule* holder, char tag, size_t index, size_t simpleFunIndex, - const char* name) { - core::SimpleFun_sp ep((gctools::Tagged)holder->getLiteral(simpleFunIndex)); -#ifdef DEBUG_SLOW - MaybeDebugStartup startup((void*)ep->_EntryPoints[1], name); -#endif - LCC_RETURN ret = ep->funcall(); - core::T_sp res((gctools::Tagged)ret.ret0[0]); - core::T_sp val = res; - LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); -} - -LtvcReturnVoid ltvc_toplevel_funcall(gctools::GCRootsInModule* holder, size_t simpleFunIndex, const char* name) { - core::SimpleFun_sp ep((gctools::Tagged)holder->getLiteral(simpleFunIndex)); -#ifdef DEBUG_SLOW - MaybeDebugStartup startup((void*)ep->_EntryPoints[1], name); -#endif - [[maybe_unused]] LCC_RETURN ret = ep->funcall(); -} -}; - -extern "C" { - const std::type_info& typeidCoreCatchThrow = typeid(core::CatchThrow); const std::type_info& typeidCoreUnwind = typeid(core::Unwind); @@ -645,25 +270,6 @@ void cc_register_startup_function(size_t index, T_OStartUp fptr) { /*! Call this with an alloca pointer to keep the alloca from being optimized away */ __attribute__((optnone, noinline)) void cc_protect_alloca(char* ptr) { (void)ptr; } - -void cc_invoke_start_code_interpreter(gctools::GCRootsInModule* roots, char* start_code, size_t bytes, void* caller) { - bool log = false; - if (core::global_debug_start_code) { - log = true; - llvmo::ObjectFile_sp objectFile; - bool found = lookupObjectFileFromEntryPoint((uintptr_t)caller, objectFile); - if (found) { - llvmo::SectionedAddress_sp sa = object_file_sectioned_address(caller, objectFile, false); - llvmo::DWARFContext_sp dcontext = llvmo::DWARFContext_O::createDWARFContext(objectFile); - const char* functionName = getFunctionNameForAddress(dcontext, sa); - printf("%s:%d:%s start-code interpreter from caller %p -------------------------\n -------- Running start-code for %s\n", - __FILE__, __LINE__, __FUNCTION__, caller, functionName); - } else { - printf("%s:%d:%s for caller %p - could not match to ObjectFile_O object\n", __FILE__, __LINE__, __FUNCTION__, caller); - } - } - start_code_interpreter(roots, start_code, bytes, log); -} }; extern "C" { @@ -1055,7 +661,7 @@ NEVER_OPTIMIZE void cc_etypecase_error(T_O* datum, T_O* possibilities) { core::T_O* cc_enclose(core::T_O* simpleFunInfo, std::size_t numCells) { core::T_sp tsimpleFun((gctools::Tagged)simpleFunInfo); - core::SimpleCoreFun_sp simpleFun = gc::As(tsimpleFun); + core::SimpleFun_sp simpleFun = gc::As(tsimpleFun); gctools::smart_ptr functoid = gctools::GC::allocate_container(false, numCells, simpleFun); return functoid.raw_(); diff --git a/src/llvmo/llvmoExpose.cc b/src/llvmo/llvmoExpose.cc index 2e7796e362..ea59594d14 100644 --- a/src/llvmo/llvmoExpose.cc +++ b/src/llvmo/llvmoExpose.cc @@ -1821,6 +1821,14 @@ CL_DEFUN Constant_sp ConstantExpr_O::getInBoundsGetElementPtr(llvm::Type* elemen res->set_wrapped(llvm_res); return res; } + +CL_LISPIFY_NAME(constant-expr/get-int-to-ptr); +CL_DEFUN Constant_sp ConstantExpr_O::getIntToPtr(llvm::Constant* c, llvm::Type* ty, + bool only_if_reduced_p) { + auto res = gctools::GC::allocate_with_default_constructor(); + res->set_wrapped(llvm::ConstantExpr::getIntToPtr(c, ty, only_if_reduced_p)); + return res; +} }; // namespace llvmo namespace llvmo { @@ -4270,72 +4278,10 @@ CL_DEFUN void llvm_sys__optimizeModule(llvm::Module* module, int level) { MPM.run(*module, MAM); } -SYMBOL_EXPORT_SC_(CorePkg, repl); -SYMBOL_EXPORT_SC_(KeywordPkg, dump_repl_object_files); -DOCGROUP(clasp); -CL_DEFUN core::Function_sp llvm_sys__jitFinalizeReplFunction(ClaspJIT_sp jit, const string& startupName, const string& shutdownName, - core::T_sp initialData) { - DEBUG_OBJECT_FILES_PRINT(("%s:%d:%s Entered\n", __FILE__, __LINE__, __FUNCTION__)); -#ifdef DEBUG_MONITOR - if (core::_sym_STARdebugStartupSTAR->symbolValue().notnilp()) { - MONITOR(BF("startup llvm_sys__jitFinalizeReplFunction startupName-> %s\n"), startupName); - } -#endif - void* replPtrRaw; - // Run the startup code by looking up a symbol - DEBUG_OBJECT_FILES_PRINT( - ("%s:%d:%s About to runStartupCode name = %s\n", __FILE__, __LINE__, __FUNCTION__, startupName.c_str())); - ObjectFile_sp codeObject; - DEBUG_OBJECT_FILES_PRINT(("%s:%d:%s Lookup %s in JITDylib_sp %p JITDylib* %p JITLINKDylib* %p\n", __FILE__, __LINE__, - __FUNCTION__, startupName.c_str(), jit->getMainJITDylib().raw_(), jit->getMainJITDylib()->wrappedPtr(), - llvm::cast(jit->getMainJITDylib()->wrappedPtr()))); - replPtrRaw = jit->runStartupCode(jit->getMainJITDylib(), startupName, initialData); - core::Function_sp functoid((gctools::Tagged)replPtrRaw); - DEBUG_OBJECT_FILES_PRINT( - ("%s:%d:%s We should have captured the ObjectFile_O and Code_O object\n", __FILE__, __LINE__, __FUNCTION__)); - return functoid; -} - -DOCGROUP(clasp); -CL_DEFUN void llvm_sys__jitFinalizeRunCxxFunction(ClaspJIT_sp jit, JITDylib_sp dylib, const string& cxxName) { - DEPRECATED(); -#if 0 - // Run the static constructors - // The static constructor should call the startup function - // but ORC doesn't seem to do this as of llvm9 - // So use the code below - llvm::ExitOnError ExitOnErr; - ExitOnErr(jit->_Jit->runConstructors()); - gctools::smart_ptr functoid; - if (core::startup_functions_are_waiting()) { - core::T_O* replPtrRaw = core::startup_functions_invoke(initialData.raw_()); - core::CompiledClosure_fptr_type lisp_funcPtr = (core::CompiledClosure_fptr_type)(replPtrRaw); - functoid = core::Closure_O::make_bclasp_closure( core::_sym_repl, - lisp_funcPtr, - kw::_sym_function, - nil(), - nil() ); - } else { - printf("%s:%d No startup functions were available!!!\n", __FILE__, __LINE__); - abort(); - } -#else - // So the cxxName is of an external linkage function that is - // always unique - core::Pointer_sp startupPtr; - void* ptr; - bool found = jit->do_lookup(dylib, cxxName, ptr); - if (!found) { - SIMPLE_ERROR("Could not find function {}", cxxName); - } - voidStartUp startup = reinterpret_cast(ptr); - // printf("%s:%d:%s About to invoke startup @p=%p\n", __FILE__, __LINE__, __FUNCTION__, (void*)startup); - startup(); - // If we load a bitcode file generated by clasp - then startup_functions will be waiting - so run them - if (core::startup_functions_are_waiting()) { - core::startup_functions_invoke(NULL); - } -#endif +CL_DEFUN void llvm_sys__jitFinalize(ClaspJIT_sp jit, + const string& startup, const string& shutdown, + core::T_sp initialData) { + jit->runStartupCode(jit->getMainJITDylib(), startup, initialData); } }; // namespace llvmo diff --git a/src/llvmo/llvmoPackage.cc b/src/llvmo/llvmoPackage.cc index b1b9f4f9da..7251b306ab 100644 --- a/src/llvmo/llvmoPackage.cc +++ b/src/llvmo/llvmoPackage.cc @@ -87,6 +87,11 @@ SYMBOL_EXPORT_SC_(LlvmoPkg, STARrunTimeExecutionEngineSTAR); SYMBOL_EXPORT_SC_(LlvmoPkg, load_bc); SYMBOL_EXPORT_SC_(LlvmoPkg, load_ll); SYMBOL_SHADOW_EXPORT_SC_(LlvmoPkg, function); +SYMBOL_SHADOW_EXPORT_SC_(LlvmoPkg, type); +SYMBOL_SHADOW_EXPORT_SC_(LlvmoPkg, min); +SYMBOL_SHADOW_EXPORT_SC_(LlvmoPkg, max); +SYMBOL_SHADOW_EXPORT_SC_(LlvmoPkg, and); +SYMBOL_SHADOW_EXPORT_SC_(LlvmoPkg, or); void redirect_llvm_interface_addSymbol() { // llvm_interface::addSymbol = &addSymbolAsGlobal; @@ -385,12 +390,12 @@ CL_DEFUN core::T_sp llvm_sys__cxxDataStructuresInfo() { return list; } -CL_LAMBDA(&key tsp tmv symbol symbol-function-offset symbol-setf-function-offset function function-description-offset gcroots-in-module vaslist function-description); +CL_LAMBDA(&key tsp tmv symbol symbol-function-offset symbol-setf-function-offset function function-description-offset vaslist function-description); DOCGROUP(clasp); CL_DEFUN void llvm_sys__throwIfMismatchedStructureSizes(core::Fixnum_sp tspSize, core::Fixnum_sp tmvSize, core::Fixnum_sp symbolSize, core::Fixnum_sp symbol_function_offset, core::Fixnum_sp symbol_setf_function_offset, core::Fixnum_sp functionSize, - core::Fixnum_sp function_description_offset, core::T_sp gcRootsInModuleSize, + core::Fixnum_sp function_description_offset, core::T_sp tvaslistsize, core::T_sp tFunctionDescriptionSize) { int T_sp_size = sizeof(core::T_sp); if (unbox_fixnum(tspSize) != T_sp_size) { @@ -421,17 +426,6 @@ CL_DEFUN void llvm_sys__throwIfMismatchedStructureSizes(core::Fixnum_sp tspSize, SIMPLE_ERROR("Mismatch between function description offset[{}] and core::SimpleFun_O._FunctionDescription offset[{}]", function_description_offset.unsafe_fixnum(), offsetof(core::SimpleFun_O, _FunctionDescription)); } - if (gcRootsInModuleSize.notnilp()) { - int gcRootsInModule_size = sizeof(gctools::GCRootsInModule); - if (gcRootsInModuleSize.fixnump()) { - if (gcRootsInModule_size != gcRootsInModuleSize.unsafe_fixnum()) { - SIMPLE_ERROR("GCRootsInModule size {} mismatch with Common Lisp code {}", gcRootsInModule_size, - gcRootsInModuleSize.unsafe_fixnum()); - } - } else { - SIMPLE_ERROR("gcRootsInModule keyword argument expects a fixnum"); - } - } if (tvaslistsize.fixnump()) { size_t vaslistsize = tvaslistsize.unsafe_fixnum(); if (vaslistsize != sizeof(Vaslist)) { diff --git a/src/llvmo/runtimeJit.cc b/src/llvmo/runtimeJit.cc index 28b0764a3d..e348b4274d 100644 --- a/src/llvmo/runtimeJit.cc +++ b/src/llvmo/runtimeJit.cc @@ -136,7 +136,6 @@ using namespace llvm::jitlink; std::atomic global_object_file_number; std::atomic global_JITDylibCounter; -std::string gcroots_in_module_name = OS_GCROOTS_IN_MODULE_NAME; std::string literals_name = OS_LITERALS_NAME; core::SimpleBaseString_sp createSimpleBaseStringForStage(const std::string& sname) { @@ -401,9 +400,7 @@ class ClaspPlugin : public llvm::orc::ObjectLinkingLayer::Plugin { // if (ssym->getName().str() != "") {printf("%s:%d:%s Symbol: %s\n", __FILE__, __LINE__, // __FUNCTION__, ssym->getName().str().c_str() ); }; #endif - if (sname.find(gcroots_in_module_name) != std::string::npos) { - keptAlive = true; - } else if (sname.find(literals_name) != std::string::npos) { + if (sname.find(literals_name) != std::string::npos) { keptAlive = true; #if 0 // I'd like to do this on linux because jit symbols need to be exposed @@ -552,8 +549,6 @@ class ClaspPlugin : public llvm::orc::ObjectLinkingLayer::Plugin { } } // - bool found_gcroots_in_module = false; - gctools::GCRootsInModule* roots; bool found_literals = false; for (auto ssym : G.defined_symbols()) { if (ssym->getName() == "DW.ref.__gxx_personality_v0") { @@ -576,12 +571,6 @@ class ClaspPlugin : public llvm::orc::ObjectLinkingLayer::Plugin { if (ssym->hasName()) { std::string sname = ssym->getName().str(); size_t pos; - pos = sname.find(gcroots_in_module_name); - if (pos != std::string::npos) { - found_gcroots_in_module = true; - roots = (gctools::GCRootsInModule*)ssym->getAddress().getValue(); - continue; - } pos = sname.find(literals_name); if (pos != std::string::npos) { found_literals = true; @@ -627,12 +616,6 @@ class ClaspPlugin : public llvm::orc::ObjectLinkingLayer::Plugin { // void* literalStart = (void*)currentCode->getLiteralVectorStart(); size_t literalCount = currentCode->_LiteralVectorSizeBytes / sizeof(void*); - if (found_gcroots_in_module) { - // if we have a GCRoots object, set it up properly. - // Note that BTB compilation will _not_ have a GCRoots. This is OK. - roots->_module_memory = literalStart; - roots->_num_entries = literalCount; - } gctools::clasp_gc_registerRoots(literalStart, literalCount); #ifdef DEBUG_OBJECT_FILES for (auto* Sym : G.external_symbols()) @@ -834,7 +817,7 @@ ObjectFile_sp ClaspJIT_O::addObjectFile(JITDylib_sp dylib, std::unique_ptr %s\n", __FILE__, __LINE__, __FUNCTION__, - // core::_rep_(initialDataOrUnbound).c_str()); - DEBUG_OBJECT_FILES_PRINT(("%s:%d:%s Returned from startup function with %p\n", __FILE__, __LINE__, __FUNCTION__, replPtrRaw)); - // Clear out the current ObjectFile and Code - // printf("%s:%d:%s I need the name of the object file and then look it up\n", __FILE__, __LINE__, __FUNCTION__ ); - return (void*)replPtrRaw; + return; } // Running the ObjectFileStartUp function registers the startup functions - now we can invoke them if (core::startup_functions_are_waiting()) { // This is where we can take the my_thread->_ObjectFile and my_thread->_Code and write it into the FunctionDescription_O objects // that are bound to functions. - void* result = core::startup_functions_invoke(NULL); + core::startup_functions_invoke(NULL); DEBUG_OBJECT_FILES_PRINT(("%s:%d:%s The startup functions were INVOKED\n", __FILE__, __LINE__, __FUNCTION__)); // Clear out the current ObjectFile and Code // printf("%s:%d:%s I need the name of the object file and then look it up\n", __FILE__, __LINE__, __FUNCTION__ ); - return result; + return; } SIMPLE_ERROR("No startup functions are waiting after runInitializers\n"); }