diff --git a/include/clasp/core/bytecode.h b/include/clasp/core/bytecode.h index 8e17ece04a..8b00fda4b2 100644 --- a/include/clasp/core/bytecode.h +++ b/include/clasp/core/bytecode.h @@ -35,8 +35,16 @@ class BytecodeModule_O : public core::CxxObject_O { public: Literals_sp_Type _Literals; Bytecode_sp_Type _Bytecode; - T_sp _CompileInfo; + // A simple-vector of BytecodeDebugInfo_sp (below) + // ordered by start index T_sp _DebugInfo = nil(); + // A list of literal indices. + // This indicates the constant at that index is a mutable + // load-time-value (i.e. from (load-time-value foo [nil])) + // which is important to know for BTB compilation. + // Some kind of bit vector could be used instead, but it's + // expected that these load time values will be rare. + T_sp _MutableLiterals = nil(); public: BytecodeModule_O(){}; @@ -60,6 +68,9 @@ class BytecodeModule_O : public core::CxxObject_O { CL_DEFMETHOD T_sp debugInfo() const { return this->_DebugInfo; } CL_LISPIFY_NAME(BytecodeModule/setfDebugInfo) CL_DEFMETHOD void setf_debugInfo(T_sp info) { this->_DebugInfo = info; } + CL_LISPIFY_NAME(BytecodeModule/mutableLiterals) + CL_DEFMETHOD T_sp mutableLiterals() const { return this->_MutableLiterals; } + void setf_mutableLiterals(T_sp indices) { this->_MutableLiterals = indices; } // Add the module to *all-bytecode-modules* for the debugger. void register_for_debug(); diff --git a/include/clasp/core/bytecode_compiler.h b/include/clasp/core/bytecode_compiler.h index f07e6a576d..cab283ab8a 100644 --- a/include/clasp/core/bytecode_compiler.h +++ b/include/clasp/core/bytecode_compiler.h @@ -936,7 +936,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(T_sp compile_info); + CL_DEFMETHOD void link_load(); }; class Cfunction_O : public General_O { @@ -1038,7 +1038,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(T_sp compile_info); + CL_DEFMETHOD Function_sp link_function(); }; // Main entry point diff --git a/src/analysis/clasp_gc.sif b/src/analysis/clasp_gc.sif index 6ba4b0d2a5..4b8247e0aa 100644 --- a/src/analysis/clasp_gc.sif +++ b/src/analysis/clasp_gc.sif @@ -887,11 +887,11 @@ :offset-base-ctype "core::BytecodeModule_O" :layout-offset-field-names ("_Bytecode")} {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" :offset-ctype "gctools::smart_ptr" - :offset-base-ctype "core::BytecodeModule_O" - :layout-offset-field-names ("_CompileInfo")} + :offset-base-ctype "core::BytecodeModule_O" :layout-offset-field-names ("_DebugInfo")} {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" :offset-ctype "gctools::smart_ptr" - :offset-base-ctype "core::BytecodeModule_O" :layout-offset-field-names ("_DebugInfo")} + :offset-base-ctype "core::BytecodeModule_O" + :layout-offset-field-names ("_MutableLiterals")} {class-kind :stamp-name "STAMPWTAG_asttooling__PresumedLoc_O" :stamp-key "asttooling::PresumedLoc_O" :parent-class "core::CxxObject_O" :lisp-class-base "core::CxxObject_O" :root-class "core::T_O" :stamp-wtag 3 diff --git a/src/analysis/clasp_gc_cando.sif b/src/analysis/clasp_gc_cando.sif index 8739969bd1..dc3c607355 100644 --- a/src/analysis/clasp_gc_cando.sif +++ b/src/analysis/clasp_gc_cando.sif @@ -647,11 +647,11 @@ :offset-base-ctype "core::BytecodeModule_O" :layout-offset-field-names ("_Bytecode")} {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" :offset-ctype "gctools::smart_ptr" - :offset-base-ctype "core::BytecodeModule_O" - :layout-offset-field-names ("_CompileInfo")} + :offset-base-ctype "core::BytecodeModule_O" :layout-offset-field-names ("_DebugInfo")} {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" :offset-ctype "gctools::smart_ptr" - :offset-base-ctype "core::BytecodeModule_O" :layout-offset-field-names ("_DebugInfo")} + :offset-base-ctype "core::BytecodeModule_O" + :layout-offset-field-names ("_MutableLiterals")} {class-kind :stamp-name "STAMPWTAG_chem__NumericalFunction_O" :stamp-key "chem::NumericalFunction_O" :parent-class "core::CxxObject_O" :lisp-class-base "core::CxxObject_O" :root-class "core::T_O" :stamp-wtag 3 diff --git a/src/core/bytecode.cc b/src/core/bytecode.cc index e98140ffc9..d652065e30 100644 --- a/src/core/bytecode.cc +++ b/src/core/bytecode.cc @@ -67,12 +67,6 @@ BytecodeModule_O::Bytecode_sp_Type BytecodeModule_O::bytecode() const { return t CL_DEFMETHOD void BytecodeModule_O::setf_bytecode(BytecodeModule_O::Bytecode_sp_Type o) { this->_Bytecode = o; } -CL_DEFMETHOD -T_sp BytecodeModule_O::compileInfo() const { return this->_CompileInfo; } - -CL_DEFMETHOD -void BytecodeModule_O::setf_compileInfo(T_sp o) { this->_CompileInfo = o; } - void BytecodeModule_O::register_for_debug() { // An atomic push, as the variable is shared. T_sp old = _lisp->_Roots._AllBytecodeModules.load(std::memory_order_relaxed); diff --git a/src/core/bytecode_compiler.cc b/src/core/bytecode_compiler.cc index 0a8d9552a2..9cc68933af 100644 --- a/src/core/bytecode_compiler.cc +++ b/src/core/bytecode_compiler.cc @@ -1083,8 +1083,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(T_sp compile_info) { - this->module()->link_load(compile_info); +Function_sp Cfunction_O::link_function() { + this->module()->link_load(); // Linking installed the GBEP in this cfunction's info. Return that. return this->info(); } @@ -1126,7 +1126,7 @@ void Module_O::link() { cmodule->resolve_fixup_sizes(); } -void Module_O::link_load(T_sp compile_info) { +void Module_O::link_load() { Module_sp cmodule = this->asSmartPtr(); cmodule->link(); SimpleVector_byte8_t_sp bytecode = cmodule->create_bytecode(); @@ -1165,13 +1165,18 @@ void Module_O::link_load(T_sp compile_info) { // real bytecode functions in the module vector. // Also replace load-time-value infos with the evaluated forms, // and resolve cells. + // Also also record mutable LTVs. + ql::list mutableLTVs; for (size_t i = 0; i < literal_length; ++i) { T_sp lit = (*cmodule_literals)[i]; if (gc::IsA(lit)) (*literals)[i] = gc::As_unsafe(lit)->info(); - else if (gc::IsA(lit)) - (*literals)[i] = gc::As_unsafe(lit)->eval(); - else if (gc::IsA(lit)) + else if (gc::IsA(lit)) { + LoadTimeValueInfo_sp ltvinfo = gc::As_unsafe(lit); + (*literals)[i] = ltvinfo->eval(); + 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()); @@ -1192,7 +1197,7 @@ void Module_O::link_load(T_sp compile_info) { bytecode_module->setf_literals(literals); bytecode_module->setf_bytecode(bytecode); bytecode_module->setf_debugInfo(debug_info); - bytecode_module->setf_compileInfo(compile_info); + bytecode_module->setf_mutableLiterals(mutableLTVs.cons()); // Native-compile anything that really seems like it should be, // and install the resulting simple funs. // We can only do native compilations after the module is @@ -2754,7 +2759,7 @@ CL_LAMBDA(lambda-expression &optional (env (cmp::make-null-lexical-environment)) CL_DEFUN Function_sp bytecompile(T_sp lambda_expression, Lexenv_sp env) { Module_sp module = Module_O::make(); Cfunction_sp cf = bytecompile_into(module, lambda_expression, env); - return cf->link_function(Cons_O::create(lambda_expression, env)); + return cf->link_function(); } static Lexenv_sp coerce_lexenv_desig(T_sp env) { diff --git a/src/core/loadltv.cc b/src/core/loadltv.cc index 6605232c24..d68a11ea18 100644 --- a/src/core/loadltv.cc +++ b/src/core/loadltv.cc @@ -822,6 +822,16 @@ struct loadltv { mod->setf_debugInfo(SimpleVector_O::make(vargs)); } + void attr_clasp_module_mutable_ltv(uint32_t bytes) { + BytecodeModule_sp mod = gc::As(get_ltv(read_index())); + uint16_t nltvs = read_u16(); + ql::list mutableLTVs; + for (size_t i = 0; i < nltvs; ++i) { + mutableLTVs << Integer_O::create(read_u16()); + } + mod->setf_mutableLiterals(mutableLTVs.cons()); + } + void op_attribute() { std::string name = (gc::As(get_ltv(read_index())))->get_std_string(); uint32_t attrbytes = read_u32(); diff --git a/src/gctools/gc_interface.cc b/src/gctools/gc_interface.cc index a2354dfc7b..69066210a3 100644 --- a/src/gctools/gc_interface.cc +++ b/src/gctools/gc_interface.cc @@ -770,7 +770,6 @@ void dumpBoehmLayoutTables(std::ostream& fout) { Init_class_kind(core::BytecodeModule_O); Init__fixed_field(core::BytecodeModule_O, 0, SMART_PTR_OFFSET, _Literals); Init__fixed_field(core::BytecodeModule_O, 1, SMART_PTR_OFFSET, _Bytecode); - Init__fixed_field(core::BytecodeModule_O, 2, SMART_PTR_OFFSET, _CompileInfo); Init_class_kind(core::SimpleCoreFun_O); Init__fixed_field(core::SimpleCoreFun_O, 0, SMART_PTR_OFFSET, _TheSimpleFun); diff --git a/src/lisp/kernel/cleavir/bytecode-adaptor.lisp b/src/lisp/kernel/cleavir/bytecode-adaptor.lisp index 45b8461904..05319fca17 100644 --- a/src/lisp/kernel/cleavir/bytecode-adaptor.lisp +++ b/src/lisp/kernel/cleavir/bytecode-adaptor.lisp @@ -21,15 +21,9 @@ ;;; ;;; -(defun describe-wrappers() - (dolist (name sys:*builtin-function-names*) - (format t "About to compile ~a ~a~%" name (cmp:builtin-wrapper-form name)))) - (defun compile-wrappers () (dolist (name sys:*builtin-function-names*) - (when (cmp:builtin-wrapper-form name) - (format t "Compiling wrapper for ~a ~a~%" name (cmp:builtin-wrapper-form name)) - (compile name)))) + (setf (fdefinition name) (compile nil (fdefinition name))))) #-(and) (eval-when (:compile-toplevel :execute) diff --git a/src/lisp/kernel/cleavir/compile-bytecode.lisp b/src/lisp/kernel/cleavir/compile-bytecode.lisp index 87df31d1de..326b071dbf 100644 --- a/src/lisp/kernel/cleavir/compile-bytecode.lisp +++ b/src/lisp/kernel/cleavir/compile-bytecode.lisp @@ -36,6 +36,7 @@ (defun compile-bcmodule-into (bcmodule irmodule) (let* ((literals (core:bytecode-module/literals bcmodule)) + (mutables (core:bytecode-module/mutable-literals bcmodule)) (blockmap (make-blockmap)) (funmap (make-funmap)) (context (make-context irmodule blockmap funmap)) (inserter (make-instance 'build:inserter)) @@ -64,7 +65,7 @@ (when (reachablep context) (let ((args (if (eq mnemonic :parse-key-args) (compute-pka-args args literals) - (compute-args args literals)))) + (compute-args args literals mutables)))) (apply #'compile-instruction mnemonic inserter context args))) (setf annots (add-annotations annots next-annots) opannots next-annots))) @@ -77,10 +78,8 @@ ;; normally deletes unused blocks, doesn't even know about them. (loop for entry in (bmap blockmap) do (bir:maybe-delete-iblock (binfo-irblock entry))) - ;; Return a mapping from bcfuns to BIR functions. - (loop for entry in (fmap funmap) - for irfun = (finfo-irfun entry) - collect (cons (finfo-bcfun entry) irfun)))) + ;; Return the funmap. + funmap)) ;;; If the instruction begins a new iblock and/or function, ;;; set everything up for that. @@ -127,9 +126,24 @@ (let ((cleavir-cst-to-ast:*compiler* 'cl:compile) ;; necessary for bir->function debug info to work. KLUDGE (*load-pathname* (core:function-source-pos function)) - (bir (cdr (assoc function funmap)))) + ;; 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::bir->function bir :abi abi :linkage linkage)))) +(defun fixed-closures-map (fmap) + (loop for entry in fmap + for ir = (finfo-irfun entry) + for clos = (loop for thing in (finfo-closure entry) + when (consp thing) + collect (car thing) + else + collect thing) + collect (cons ir clos))) + ;;; Given a bytecode function, compile it into the given IR module. ;;; that is, this does NOT finish the compilation process. ;;; the BIR:FUNCTION is returned. @@ -137,7 +151,7 @@ (defun compile-bcfun-into (function irmodule) (let ((fmap (compile-bcmodule-into (core:simple-fun-code function) irmodule))) - (cdr (assoc function fmap)))) + (finfo-irfun (find-bcfun function fmap)))) ;;; Return a list of all annotations that start at IP 0. (defun initial-annotations (annotations) @@ -192,10 +206,13 @@ :blockmap (blockmap context) :funmap (funmap context) :reachablep (reachablep context))) -(defun compute-args (args literals) +(defun compute-args (args literals mutables) (loop for (type . value) in args collect (ecase type - ((:constant) (aref literals value)) + ((:constant) + ;; (values . mutablep) + (cons (aref literals value) + (if (member value mutables) t nil))) ((:label) value) ((:keys) ;; not actually used, so whatever @@ -385,8 +402,11 @@ (defmethod compile-instruction ((mnemonic (eql :const)) inserter context &rest args) - (destructuring-bind (value) args - (stack-push (compile-constant value inserter) context))) + (destructuring-bind ((value . mutablep)) args + (stack-push (if mutablep + (compile-load-time-value value nil inserter) + (compile-constant value inserter)) + context))) (defun compile-constant (value inserter) (let* ((const (build:constant inserter value)) @@ -395,6 +415,21 @@ :inputs (list const) :outputs (list cref-out)) cref-out)) +(defun compile-load-time-value (value read-only-p inserter) + ;; read-only-p is always nil since T will just end up as a + ;; normal constant, but it's included for completeness. + ;; FIXME: Define build:load-time-value + (let* ((module (bir:module inserter)) + ;; FIXME: Maybe change Cleavir LTV handling to not need + ;; a raw form. Using quote here is a little sketchy + ;; since the value is after all mutable. + (ltv (bir:load-time-value-in-module `',value read-only-p + module)) + (ltv-out (make-instance 'bir:output))) + (build:insert inserter 'bir:load-time-value-reference + :inputs (list ltv) :outputs (list ltv-out)) + ltv-out)) + (defmethod compile-instruction ((mnemonic (eql :closure)) inserter context &rest args) (destructuring-bind (index) args @@ -554,7 +589,7 @@ (defmethod compile-instruction ((mnemonic (eql :make-closure)) inserter context &rest args) - (destructuring-bind (template) args + (destructuring-bind ((template)) args (let* ((irfun (make-bir-function template inserter)) (enclose-out (make-instance 'bir:output :name (core:function-name template))) @@ -574,7 +609,7 @@ 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 + (destructuring-bind ((template)) args (let ((irfun (make-bir-function template inserter)) (enclose-out (make-instance 'bir:output :name (core:function-name template)))) @@ -947,7 +982,7 @@ (defmethod compile-instruction ((mnemonic (eql :special-bind)) inserter context &rest args) - (destructuring-bind (vcell) args + (destructuring-bind ((vcell)) args (let* ((vname (core:variable-cell/name vcell)) (bname (symbolicate '#:bind- vname)) (next (build:make-iblock inserter :name bname)) @@ -960,7 +995,7 @@ (defmethod compile-instruction ((mnemonic (eql :symbol-value)) inserter context &rest args) - (destructuring-bind (vcell) args + (destructuring-bind ((vcell)) args (let* ((vname (core:variable-cell/name vcell)) (const (build:vcell inserter vname)) (out (make-instance 'bir:output :name vname))) @@ -970,7 +1005,7 @@ (defmethod compile-instruction ((mnemonic (eql :symbol-value-set)) inserter context &rest args) - (destructuring-bind (vcell) args + (destructuring-bind ((vcell)) args (let ((const (build:vcell inserter (core:variable-cell/name vcell))) (in (stack-pop context))) (build:insert inserter 'bir:set-constant-symbol-value @@ -992,7 +1027,7 @@ (defmethod compile-instruction ((mnemonic (eql :fdefinition)) inserter context &rest args) - (destructuring-bind (fcell) args + (destructuring-bind ((fcell)) args (let* (;; FIXME: May not be a sufficiently reliable way to get ;; the name from the cell in all cases? Probably ok though (fname (core:function-name fcell)) @@ -1010,7 +1045,7 @@ ;; CONSTANT-CALLED-FDEFINITION for this. (defmethod compile-instruction ((mnemonic (eql :called-fdefinition)) inserter context &rest args) - (destructuring-bind (fcell) args + (destructuring-bind ((fcell)) args (let* ((fname (core:function-name fcell)) (const (build:fcell inserter fname)) (attributes (clasp-cleavir::function-attributes fname)) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 6c6345cc49..9493955101 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -118,21 +118,47 @@ function-description the-function local-fun) - :xep-unallocated))) + :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))))) (if (eq xep-group :xep-unallocated) (make-instance 'llvm-function-info - :environment (cleavir-set:set-to-list (bir:environment function)) + :environment env :main-function the-function :xep-function :xep-unallocated :xep-function-description :xep-unallocated :arguments arguments) (make-instance 'llvm-function-info - :environment (cleavir-set:set-to-list (bir:environment function)) + :environment env :main-function the-function :xep-function xep-group :xep-function-description function-description :arguments arguments))))))) +(defun fixed-closure (function) + (let ((fixed (cdr (assoc function *fixed-closures*)))) + (if fixed + ;; The fixed environment may have variables that aren't + ;; in the computed environment because they have been + ;; optimized out. In this case we put in NIL, which is + ;; understood by variable-as-argument. + (let ((env (bir:environment function))) + (loop for v in fixed + collect (if (cleavir-set:presentp v env) v nil))) + nil))) + +;;; Given an llvm function info environment, return local call +;;; arguments for the environment. +;;; This is just mapped variable-as-argument, except +;;; for excess NILs from fixed closures. We don't need those. +(defun environment-arguments (environment) + (loop for v in environment + when v + collect (variable-as-argument v))) + ;;; Return value is unspecified/irrelevant. (defgeneric translate-simple-instruction (instruction abi)) @@ -831,8 +857,8 @@ (subargs (parse-local-call-arguments req opt rest-id rest-vrtype arguments)) - (args (append (mapcar #'variable-as-argument - (environment callee-info)) + (args (append (environment-arguments + (environment callee-info)) subargs)) (function (main-function callee-info)) (function-type (llvm-sys:get-function-type function)) @@ -962,7 +988,7 @@ (cmp:irc-begin-block merge) (let* ((arguments (nconc - (mapcar #'variable-as-argument environment) + (environment-arguments environment) (loop for r in (rest req) for j from 0 collect (translate-cast (load-return-value j) '(:object) @@ -1787,8 +1813,9 @@ (loop for import in (environment llvm-function-info) for i from 0 for offset = (cmp:%closure%.offset-of[n]/t* i) - collect (cmp:irc-t*-load-atomic - (cmp::gen-memref-address closure-vec offset)))) + when import ; skip unused fixed closure entries + collect (cmp:irc-t*-load-atomic + (cmp::gen-memref-address closure-vec offset)))) (source-pos-info (function-source-pos-info ir))) ;; Tail call the real function. (cmp:with-debug-info-source-position (source-pos-info) @@ -1828,9 +1855,11 @@ ;; appropriately. (let ((llvm-function-info (find-llvm-function-info ir))) (loop for arg in (llvm-sys:get-argument-list the-function) - for lexical in (append (environment llvm-function-info) + ;; remove-if is to remove fixed closure params. + for lexical in (append (remove-if #'null (environment llvm-function-info)) (arguments llvm-function-info)) - do (setf (gethash lexical *datum-values*) arg))) + when lexical ; skip unused fixed + do (setf (gethash lexical *datum-values*) arg))) ;; Branch to the start block. (cmp:irc-br (iblock-tag (bir:start ir))) ;; Lay out blocks. diff --git a/src/lisp/kernel/cleavir/translation-environment.lisp b/src/lisp/kernel/cleavir/translation-environment.lisp index b6110e31ec..6e4be92268 100644 --- a/src/lisp/kernel/cleavir/translation-environment.lisp +++ b/src/lisp/kernel/cleavir/translation-environment.lisp @@ -12,6 +12,12 @@ (defvar *function-info*) (defvar *enclose-initializers*) +;; This is an alist from BIR:FUNCTIONs to closure environments +;; (i.e. lists of lexicals). It is used by the BTB compiler to +;; ensure that clasp-cleavir lays out a simple fun that can use +;; an existing closure layout. +(defvar *fixed-closures* nil) + ;;; In CSTs and stuff the origin is (spi . spi). Use the head. (defun origin-spi (origin) (if (consp origin) (car origin) origin)) @@ -101,17 +107,23 @@ ;; on whether it is immutable so we can close over the memory location ;; and implement the the cell indirection properly when the variable ;; is mutable and closed over. +;; We also allow a "variable" to be NIL. This indicates that the closure +;; has a slot unused by the code; this is used when we BTB compile +;; a bytecode function. In this case we just put in a nil. +;; (Not undef, since it still ought to be a valid object.) (defun variable-as-argument (variable) - (let ((value/cell (or (gethash variable *datum-values*) - (error "BUG: Variable or cell missing: ~a" variable)))) - (if (or (typep variable 'bir:come-from) - (bir:immutablep variable)) - value/cell - (ecase (bir:extent variable) - (:indefinite value/cell) - (:dynamic (cmp:irc-bit-cast value/cell cmp:%t*%)) - (:local - (error "Should not be passing the local variable ~a as an environment argument." variable)))))) + (if variable + (let ((value/cell (or (gethash variable *datum-values*) + (error "BUG: Variable or cell missing: ~a" variable)))) + (if (or (typep variable 'bir:come-from) + (bir:immutablep variable)) + value/cell + (ecase (bir:extent variable) + (:indefinite value/cell) + (:dynamic (cmp:irc-bit-cast value/cell cmp:%t*%)) + (:local + (error "Should not be passing the local variable ~a as an environment argument." variable))))) + (%nil))) (defun in (datum) (check-type datum (or bir:phi bir:ssa)) diff --git a/src/lisp/kernel/cmp/bytecode-reference.lisp b/src/lisp/kernel/cmp/bytecode-reference.lisp index a6d277393b..45bb750e9d 100644 --- a/src/lisp/kernel/cmp/bytecode-reference.lisp +++ b/src/lisp/kernel/cmp/bytecode-reference.lisp @@ -8,10 +8,9 @@ (defvar *bclog* (progn (format t "!~%!~%! Opening /tmp/allcode.log - logging all bytecode compilation~%!~%!~%") (open "/tmp/allcode.log" :direction :output :if-exists :supersede))) - (defun log-function (cfunction compile-info bytecode) + (defun log-function (cfunction bytecode) (format *bclog* "Name: ~s~%" (cfunction-name cfunction)) (let ((*print-circle* t)) - (format *bclog* "Form: ~s~%" (car compile-info)) (format *bclog* "Bytecode: ~s~%" bytecode) (finish-output *bclog*))) (defmacro logf (message &rest args) @@ -437,7 +436,7 @@ (body (cddr lambda-expression))) (logf "-------- About to link~%") (multiple-value-prog1 - (link-function (compile-lambda lambda-list body env module) (cons lambda-expression env)) + (link-function (compile-lambda lambda-list body env module)) (logf "^^^^^^^^^ Compile done~%")))) (export 'bytecompile) @@ -1495,7 +1494,7 @@ ;;; Run down the hierarchy and link the compile time representations ;;; of modules and functions together into runtime objects. Return the ;;; bytecode function corresponding to CFUNCTION. -(defun link-function (cfunction compile-info) +(defun link-function (cfunction) (declare (optimize debug)) (let ((cmodule (cfunction-cmodule cfunction))) (initialize-cfunction-positions cmodule) @@ -1544,9 +1543,7 @@ (progn (core:bytecode-module/setf-literals bytecode-module literals) ;; Now just install the bytecode and Bob's your uncle. - (core:bytecode-module/setf-bytecode bytecode-module bytecode) - (core:bytecode-module/setf-compile-info bytecode-module compile-info)) - #+(or)(log-function cfunction compile-info bytecode))) + (core:bytecode-module/setf-bytecode bytecode-module bytecode)))) (cfunction-info cfunction)) diff --git a/src/lisp/kernel/cmp/cmpltv.lisp b/src/lisp/kernel/cmp/cmpltv.lisp index 9ecd98fc58..9045b2209d 100644 --- a/src/lisp/kernel/cmp/cmpltv.lisp +++ b/src/lisp/kernel/cmp/cmpltv.lisp @@ -255,6 +255,12 @@ (%module :initarg :module :reader module) (%infos :initarg :infos :reader infos :type sequence))) +#+clasp +(defclass module-mutable-ltv-attr (attribute) + ((%name :initform (ensure-constant "clasp:module-mutable-ltv")) + (%module :initarg :module :reader module) + (%indices :initarg :indices :reader indices :type sequence))) + #+clasp (defclass debug-info-function () ((%function :initarg :function :reader di-function :type creator))) @@ -1384,6 +1390,13 @@ :macro-name (ensure-constant (core:bytecode-debug-macroexpansion/macro-name item)))) +(defun mutable-LTVs (literals) + (loop for lit across literals + for i from 0 + when (and (typep lit 'cmp:load-time-value-info) + (not (cmp:load-time-value-info/read-only-p lit))) + collect i)) + (defun add-module (value) ;; Add the module first to prevent recursion. (cmp:module/link value) @@ -1405,6 +1418,13 @@ (make-instance 'module-debug-attr :module mod :infos (map 'vector #'process-debug-info info))))) + #+clasp ; mutable LTVs + (let ((mutables (mutable-LTVs (cmp:module/literals value)))) + (when mutables + (add-instruction + (make-instance 'module-mutable-ltv-attr + :module mod + :indices mutables)))) mod)) (defun ensure-module (module) @@ -1594,6 +1614,15 @@ ;; The infos (map nil (lambda (info) (encode info stream)) infos))) +(defmethod encode ((attr module-mutable-ltv-attr) stream) + (let ((indices (indices attr))) + (write-b32 (+ 2 *index-bytes* (* 2 (length indices))) + stream) ; length of attr + (write-index (module attr) stream) + (write-b16 (length indices) stream) + (loop for index in indices + do (write-b16 index stream)))) + (defmethod encode ((init init-object-array) stream) (write-mnemonic 'init-object-array stream) (write-b64 (init-object-array-count init) stream)) diff --git a/src/lisp/kernel/cmp/compile.lisp b/src/lisp/kernel/cmp/compile.lisp index 24228debaf..c4390a3f87 100644 --- a/src/lisp/kernel/cmp/compile.lisp +++ b/src/lisp/kernel/cmp/compile.lisp @@ -34,20 +34,6 @@ We could do more fancy things here - like if cleavir-clasp fails, use the clasp (with-compilation-unit () (compile-with-hook compile-hook definition env))) -(defun builtin-wrapper-form (name) - (when (and (fboundp name) - (functionp (fdefinition name)) - (null (compiled-function-p (fdefinition name))) - (typep (sys:function/entry-point (fdefinition name)) 'sys:bytecode-simple-fun)) - (let* ((function (fdefinition name)) - (entry-point (sys:function/entry-point function)) - (module (sys:bytecode-simple-fun/code entry-point)) - (compile-info (sys:bytecode-module/compile-info module)) - (code (car compile-info))) - code))) - -(export 'builtin-wrapper-form :cmp) - (defun %compile (definition environment) (cond ((and (typep definition 'core:bytecode-simple-fun) diff --git a/src/lisp/regression-tests/btb.lisp b/src/lisp/regression-tests/btb.lisp new file mode 100644 index 0000000000..75eb4858f7 --- /dev/null +++ b/src/lisp/regression-tests/btb.lisp @@ -0,0 +1,109 @@ +(in-package #:clasp-tests) + +;;; BTB compilation is a little different from regular Lisp compilation. +;;; We want it to work on any function at all, including closures and +;;; stuff, and when it does it should allow seamless replacement. + +;;; Can we compile closures at all? +(test btb.closure-1 + (let ((c (funcall (cmp:bytecompile + '(lambda (x) (lambda () x))) + 119))) + (values (funcall c) + (funcall (compile nil c)))) + (119 119)) + +;;; Do compiled closures keep the same cell? +(test btb.closure-2 + (multiple-value-bind (read write) + (funcall (cmp:bytecompile + '(lambda (x) + (values (lambda () x) + (lambda (y) (setq x y))))) + 237) + (values (funcall read) + (funcall write 18) + (funcall (compile nil read)) + (funcall (compile nil write) 33) + (funcall read))) + (237 18 18 33 33)) + +;;; Do compiled closures order multiple variables correctly? +;;; As of this writing clasp-cleavir orders closure variables +;;; nondeterministically, so we do this a few times to be sure. +(test btb.closure-3 + (let ((c (funcall (cmp:bytecompile '(lambda (x y) + (lambda () (list x y)))) + 10 382))) + (loop repeat 7 collect (funcall (compile nil c)))) + (((10 382) (10 382) (10 382) (10 382) (10 382) (10 382) (10 382)))) + +;;; Can we handle variables that optimization deletes? +(test btb.closure-4 + (let ((c (funcall (cmp:bytecompile '(lambda (x y) + ;; Here we rely on + ;; bytecomp not optimizing. + (lambda () (if t x y)))) + 7 19))) + (multiple-value-bind (f warningp failurep) + (compile nil c) + (values (funcall f) warningp failurep))) + (7 nil nil)) + +;;; Does LOAD-TIME-VALUE with a normal object work OK? +(test btb.ltv-1 + (funcall + (compile nil (cmp:bytecompile + '(lambda () (load-time-value (+ 189 911)))))) + (1100)) +(test btb.ltv-1-readonly + (funcall + (compile nil (cmp:bytecompile + '(lambda () (load-time-value (+ 189 911) t))))) + (1100)) + +;;; An object being unserializable shouldn't matter +(defclass undumpable () ()) + +(test btb.ltv-2 + (class-name + (class-of + (funcall + (compile nil (cmp:bytecompile + '(lambda () (load-time-value + (make-instance 'undumpable)))))))) + (undumpable)) +(test btb.ltv-2-readonly + (class-name + (class-of + (funcall + (compile nil (cmp:bytecompile + '(lambda () (load-time-value + (make-instance 'undumpable) t))))))) + (undumpable)) + +;;; Compiled LTV gets the updated LTV, not whatever original value +(test btb.ltv-3 + (let ((c (cmp:bytecompile + '(lambda () (incf (car (load-time-value (list 0)))))))) + (funcall c) (funcall c) + (funcall (compile nil c))) + (3)) + +;;; And keeps updating +(test btb.ltv-4 + (let* ((c (cmp:bytecompile + '(lambda () (incf (car (load-time-value (list 0))))))) + (cc (compile nil c))) + (funcall cc) (funcall cc) + (funcall cc)) + (3)) + +;;; And updates are to the original object. +(test btb.ltv-5 + (let* ((c (cmp:bytecompile + '(lambda () (incf (car (load-time-value (list 0))))))) + (cc (compile nil c))) + (funcall cc) (funcall cc) + (funcall c)) + (3)) diff --git a/src/lisp/regression-tests/run-all.lisp b/src/lisp/regression-tests/run-all.lisp index 57d8fd7432..347f2f0cc0 100644 --- a/src/lisp/regression-tests/run-all.lisp +++ b/src/lisp/regression-tests/run-all.lisp @@ -62,6 +62,7 @@ #+(and)(load-if-compiled-correctly "sys:src;lisp;regression-tests;debug.lisp") (load-if-compiled-correctly "sys:src;lisp;regression-tests;mp.lisp") (load-if-compiled-correctly "sys:src;lisp;regression-tests;posix.lisp") +(load-if-compiled-correctly "sys:src;lisp;regression-tests;btb.lisp") ;;; When we have system construction before debug.lisp, debug.lisp will fail (load-if-compiled-correctly "sys:src;lisp;regression-tests;system-construction.lisp") (load-if-compiled-correctly "sys:src;lisp;regression-tests;extensions.lisp")