Btb ltv

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<T_O>();
+  // 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<T_O>();
 
 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();

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

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<core::T_O>"
-             :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<core::T_O>"
-             :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

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<core::T_O>"
-             :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<core::T_O>"
-             :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

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);

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<Cfunction_sp>(lit))
       (*literals)[i] = gc::As_unsafe<Cfunction_sp>(lit)->info();
-    else if (gc::IsA<LoadTimeValueInfo_sp>(lit))
-      (*literals)[i] = gc::As_unsafe<LoadTimeValueInfo_sp>(lit)->eval();
-    else if (gc::IsA<ConstantInfo_sp>(lit))
+    else if (gc::IsA<LoadTimeValueInfo_sp>(lit)) {
+      LoadTimeValueInfo_sp ltvinfo = gc::As_unsafe<LoadTimeValueInfo_sp>(lit);
+      (*literals)[i] = ltvinfo->eval();
+      if (!ltvinfo->read_only_p())
+        mutableLTVs << Integer_O::create(i);
+    } else if (gc::IsA<ConstantInfo_sp>(lit))
       (*literals)[i] = gc::As_unsafe<ConstantInfo_sp>(lit)->value();
     else if (gc::IsA<FunctionCellInfo_sp>(lit))
       (*literals)[i] = core__ensure_function_cell(gc::As_unsafe<FunctionCellInfo_sp>(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) {

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<BytecodeModule_sp>(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<String_sp>(get_ltv(read_index())))->get_std_string();
     uint32_t attrbytes = read_u32();

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);

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)

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,17 +126,32 @@
     (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.
 ;;; Used in compile-type-decl.
 (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))