Merge pull request #1500 from clasp-developers/xref

Implements cross-references (xref) for development. Only works with bytecode functions. Basically just exploits how simple the bytecode is: it grovels over all bytecode modules (Which we already have saved for backtrace purposes) looking for calls, bindings, whatever.
clasp-developers · Sep 27, 2023 · bda308b · bda308b
2 parents b61c990 + aa9d23b
commit bda308b
Show file tree

Hide file tree

Showing 20 changed files with 440 additions and 103 deletions.
diff --git a/RELEASE_NOTES.md b/RELEASE_NOTES.md
@@ -6,6 +6,7 @@
 * The bytecode compiler tracks source positions for error reporting.
 * Circle detection for load forms in bytecode FASL.
 * Bytecode functions can be compiled directly into native code with `cl:compile` (experimental).
+* Cross-reference (xref) capability: Search for callers of a given function with `ext:who-calls`, and etc. Only works for bytecode right now.
 * Support for Linux AARCH64.
 * LLVM17 support. LLVM15 and LLVM16 are still supported.
 

diff --git a/include/clasp/core/bytecode.h b/include/clasp/core/bytecode.h
@@ -221,6 +221,27 @@ class BytecodeDebugExit_O : public BytecodeDebugInfo_O {
     CL_DEFMETHOD Fixnum receiving() const { return this->_receiving; }
 };
 
+// Indicates that a macroexpansion occurred. This is used to
+// implement xref; see ext:who-macroexpands.
+// Only stored for global macros. Not stored for compiler macros.
+FORWARD(BytecodeDebugMacroexpansion);
+class BytecodeDebugMacroexpansion_O : public BytecodeDebugInfo_O {
+  LISP_CLASS(core, CorePkg, BytecodeDebugMacroexpansion_O, "BytecodeDebugMacroexpansion", BytecodeDebugInfo_O);
+public:
+  BytecodeDebugMacroexpansion_O(T_sp start, T_sp end, T_sp macro_name)
+    : BytecodeDebugInfo_O(start, end), _macro_name(macro_name) {}
+  CL_LISPIFY_NAME(BytecodeDebugMacroexpansion/make)
+    CL_DEF_CLASS_METHOD
+    static BytecodeDebugMacroexpansion_sp make(T_sp start, T_sp end, T_sp macro_name) {
+    return gctools::GC<BytecodeDebugMacroexpansion_O>::allocate<gctools::RuntimeStage>(start, end, macro_name);
+  }
+public:
+  T_sp _macro_name;
+public:
+  CL_LISPIFY_NAME(BytecodeDebugMacroexpansion/macro-name)
+    CL_DEFMETHOD T_sp macro_name() const { return this->_macro_name; }
+};
+
 
 // Dynenv used for VM call frames to ensure the unwinder properly
 // cleans up stack frames.

diff --git a/src/analysis/clasp_gc.sif b/src/analysis/clasp_gc.sif
@@ -79,7 +79,8 @@
                           "llvmo::TargetMachine_O" "core::SimpleVector_byte64_t_O" "llvmo::Value_O"
                           "core::SimpleBaseString_O" "core::Test_O" "llvmo::Metadata_O"
                           "core::BytecodeDebugInfo_O" "core::MDArray_O" "core::LocalSimpleFun_O"
-                          "clbind::ClassRep_O" "llvmo::ConstantInt_O" "comp::SpecialVarInfo_O"
+                          "clbind::ClassRep_O" "core::BytecodeDebugMacroexpansion_O"
+                          "llvmo::ConstantInt_O" "comp::SpecialVarInfo_O"
                           "core::SimpleMDArray_int16_t_O" "comp::ControlLabelFixup_O"
                           "llvmo::StructLayout_O" "core::SimpleMDArrayT_O" "llvmo::LoadInst_O"
                           "llvmo::ConstantStruct_O" "core::Exposer_O" "core::DirectoryIterator_O"
@@ -3560,6 +3561,22 @@
 {fixed-field :offset-type-cxx-identifier "ctype_int" :offset-ctype "int"
              :offset-base-ctype "core::BytecodeDebugBlock_O"
              :layout-offset-field-names ("_receiving")}
+{class-kind :stamp-name "STAMPWTAG_core__BytecodeDebugMacroexpansion_O"
+            :stamp-key "core::BytecodeDebugMacroexpansion_O"
+            :parent-class "core::BytecodeDebugInfo_O" :lisp-class-base "core::BytecodeDebugInfo_O"
+            :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"}
+{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
+             :offset-ctype "gctools::smart_ptr<core::T_O>"
+             :offset-base-ctype "core::BytecodeDebugMacroexpansion_O"
+             :layout-offset-field-names ("_start")}
+{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
+             :offset-ctype "gctools::smart_ptr<core::T_O>"
+             :offset-base-ctype "core::BytecodeDebugMacroexpansion_O"
+             :layout-offset-field-names ("_end")}
+{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
+             :offset-ctype "gctools::smart_ptr<core::T_O>"
+             :offset-base-ctype "core::BytecodeDebugMacroexpansion_O"
+             :layout-offset-field-names ("_macro_name")}
 {class-kind :stamp-name "STAMPWTAG_core__BytecodeDebugVars_O"
             :stamp-key "core::BytecodeDebugVars_O" :parent-class "core::BytecodeDebugInfo_O"
             :lisp-class-base "core::BytecodeDebugInfo_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
@@ -138,10 +138,10 @@
                           "chem::SuperposableConformationCollection_O" "core::MDArray_O"
                           "core::LocalSimpleFun_O" "units::UnitsExposer_O"
                           "chem::CoordinateSystem_O" "chem::AtomReference_O" "clbind::ClassRep_O"
-                          "chem::EnergyAngle" "chem::RigidBodyEnergyFunction_O"
-                          "llvmo::ConstantInt_O" "comp::SpecialVarInfo_O"
-                          "core::SimpleMDArray_int16_t_O" "chem::Logical_O"
-                          "comp::ControlLabelFixup_O" "llvmo::StructLayout_O"
+                          "core::BytecodeDebugMacroexpansion_O" "chem::EnergyAngle"
+                          "chem::RigidBodyEnergyFunction_O" "llvmo::ConstantInt_O"
+                          "comp::SpecialVarInfo_O" "core::SimpleMDArray_int16_t_O"
+                          "chem::Logical_O" "comp::ControlLabelFixup_O" "llvmo::StructLayout_O"
                           "core::SimpleMDArrayT_O" "chem::ConformationExplorer_O"
                           "chem::BondList_O" "llvmo::LoadInst_O" "core::Exposer_O"
                           "llvmo::ConstantStruct_O" "chem::MacroModelFile_O"
@@ -5583,6 +5583,22 @@
 {fixed-field :offset-type-cxx-identifier "ctype_int" :offset-ctype "int"
              :offset-base-ctype "core::BytecodeDebugThe_O"
              :layout-offset-field-names ("_receiving")}
+{class-kind :stamp-name "STAMPWTAG_core__BytecodeDebugMacroexpansion_O"
+            :stamp-key "core::BytecodeDebugMacroexpansion_O"
+            :parent-class "core::BytecodeDebugInfo_O" :lisp-class-base "core::BytecodeDebugInfo_O"
+            :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"}
+{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
+             :offset-ctype "gctools::smart_ptr<core::T_O>"
+             :offset-base-ctype "core::BytecodeDebugMacroexpansion_O"
+             :layout-offset-field-names ("_start")}
+{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
+             :offset-ctype "gctools::smart_ptr<core::T_O>"
+             :offset-base-ctype "core::BytecodeDebugMacroexpansion_O"
+             :layout-offset-field-names ("_end")}
+{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
+             :offset-ctype "gctools::smart_ptr<core::T_O>"
+             :offset-base-ctype "core::BytecodeDebugMacroexpansion_O"
+             :layout-offset-field-names ("_macro_name")}
 {class-kind :stamp-name "STAMPWTAG_core__BytecodeDebugLocation_O"
             :stamp-key "core::BytecodeDebugLocation_O" :parent-class "core::BytecodeDebugInfo_O"
             :lisp-class-base "core::BytecodeDebugInfo_O" :root-class "core::T_O" :stamp-wtag 3

diff --git a/src/core/backtrace.cc b/src/core/backtrace.cc
@@ -478,7 +478,7 @@ static DebuggerFrame_sp make_bytecode_frame(size_t frameIndex,
     fp = (T_O**)(*fp);
   }
   // Find the bytecode module containing the current pc.
-  List_sp modules = _lisp->_Roots._AllBytecodeModules.load();
+  List_sp modules = _lisp->_Roots._AllBytecodeModules.load(std::memory_order_relaxed);
   for (auto mods : modules) {
     BytecodeModule_sp mod = gc::As_assert<BytecodeModule_sp>(oCar(mods));
     if (bytecode_module_contains_address_p(mod, bpc)) {

diff --git a/src/core/bytecode.cc b/src/core/bytecode.cc
@@ -13,6 +13,7 @@
 #include <clasp/core/unwind.h>
 #include <clasp/core/ql.h>
 #include <clasp/core/designators.h> // calledFunctionDesignator
+#include <clasp/core/evaluator.h> // eval::funcall
 
 
 #define VM_CODES
@@ -77,9 +78,9 @@ void BytecodeModule_O::setf_compileInfo(T_sp o) {
 
 void BytecodeModule_O::register_for_debug() {
   // An atomic push, as the variable is shared.
-  T_sp old = _lisp->_Roots._AllBytecodeModules.load();
+  T_sp old = _lisp->_Roots._AllBytecodeModules.load(std::memory_order_relaxed);
   Cons_sp newc = Cons_O::create(this->asSmartPtr(), old);
-  while (!_lisp->_Roots._AllBytecodeModules.compare_exchange_weak(old, newc))
+  while (!_lisp->_Roots._AllBytecodeModules.compare_exchange_weak(old, newc, std::memory_order_relaxed))
     newc->setCdr(old);
 }
 
@@ -1519,4 +1520,14 @@ void* bytecode_pc() {
   return my_thread->_VM._pc;
 }
 
+CL_DOCSTRING(R"(Call a function on each registered bytecode module. Order is undefined. New modules created during the mapping process may be skipped; this function does not synchronize. Return value undefined.)")
+DOCGROUP(clasp);
+CL_DEFUN void core__map_bytecode_modules(Function_sp f) {
+  List_sp modules = _lisp->_Roots._AllBytecodeModules.load(std::memory_order_relaxed);
+  for (auto mods : modules) {
+    BytecodeModule_sp mod = gc::As_assert<BytecodeModule_sp>(oCar(mods));
+    eval::funcall(f, mod);
+  }
+}
+
 }; // namespace core
diff --git a/src/core/bytecode_compiler.cc b/src/core/bytecode_compiler.cc
@@ -2510,7 +2510,12 @@ void compile_combination(T_sp head, T_sp rest, Lexenv_sp env, const Context cont
       if (std::holds_alternative<GlobalMacroInfoV>(info)) {
         Function_sp expander = std::get<GlobalMacroInfoV>(info).expander();
         T_sp expansion = expand_macro(expander, Cons_O::create(head, rest), env);
+        Label_sp begin_label = Label_O::make(),
+          end_label = Label_O::make();
+        begin_label->contextualize(context);
+        context.push_debug_info(BytecodeDebugMacroexpansion_O::make(begin_label, end_label, head));
         compile_form(expansion, env, context);
+        end_label->contextualize(context);
       } else if (std::holds_alternative<LocalMacroInfoV>(info)) {
         Function_sp expander = std::get<LocalMacroInfoV>(info).expander();
         T_sp expansion = expand_macro(expander, Cons_O::create(head, rest), env);

diff --git a/src/core/corePackage.cc b/src/core/corePackage.cc
@@ -799,12 +799,9 @@ SYMBOL_EXPORT_SC_(ClPkg, progn);
 SYMBOL_EXPORT_SC_(ClPkg, multipleValueCall);
 SYMBOL_SC_(CorePkg, backquote);
 SYMBOL_SC_(CorePkg, double_backquote);
-SYMBOL_SC_(CorePkg, unquote);
-// was S Y M B O L _SC_(CorePkg,comma);
-SYMBOL_SC_(CorePkg, unquote_splice);
-// was S Y M B O L _SC_(CorePkg,comma_atsign);
-SYMBOL_SC_(CorePkg, unquote_nsplice);
-// was S Y M B O L _SC_(CorePkg,comma_dot);
+SYMBOL_EXPORT_SC_(CorePkg, unquote);
+SYMBOL_EXPORT_SC_(CorePkg, unquote_splice);
+SYMBOL_EXPORT_SC_(CorePkg, unquote_nsplice);
 SYMBOL_EXPORT_SC_(ClPkg, quote);
 SYMBOL_EXPORT_SC_(ClPkg, function);
 SYMBOL_SC_(CorePkg, slot);

diff --git a/src/core/loadltv.cc b/src/core/loadltv.cc
@@ -59,6 +59,7 @@
 #define LTV_DI_OP_THE 4
 #define LTV_DI_OP_BLOCK 5
 #define LTV_DI_OP_EXIT 6
+#define LTV_DI_OP_MACRO 7
 
 namespace core {
 
@@ -503,7 +504,7 @@ struct loadltv {
   void op_package() {
     size_t index = read_index();
     String_sp name = gc::As<String_sp>(get_ltv(read_index()));
-    set_ltv(_lisp->findPackage(name->get_std_string()), index);
+    set_ltv(_lisp->findPackage(name->get_std_string(), true), index);
   }
 
   void op_bignum() {
@@ -718,6 +719,13 @@ struct loadltv {
     return BytecodeDebugExit_O::make(start, end, receiving);
   }
 
+  T_sp di_op_macro() {
+    Integer_sp start = Integer_O::create(read_u32()),
+      end = Integer_O::create(read_u32());
+    T_sp macro_name = get_ltv(read_index());
+    return BytecodeDebugMacroexpansion_O::make(start, end, macro_name);
+  }
+
   void attr_clasp_module_debug_info(uint32_t bytes) {
     BytecodeModule_sp mod = gc::As<BytecodeModule_sp>(get_ltv(read_index()));
     gctools::Vec0<T_sp> vargs;
@@ -746,6 +754,9 @@ struct loadltv {
       case LTV_DI_OP_EXIT:
           vargs.push_back(di_op_exit());
           break;
+      case LTV_DI_OP_MACRO:
+          vargs.push_back(di_op_macro());
+          break;
       default:
           SIMPLE_ERROR("Unknown debug info opcode {:02x}", op);
       }

diff --git a/src/core/primitives.cc b/src/core/primitives.cc
@@ -1064,9 +1064,9 @@ CL_DEFUN_SETF T_sp setf_fdefinition(Function_sp function, T_sp name) {
 
 // Used by the FASL loaders.
 DOCGROUP(clasp);
-CL_DEFUN FunctionCell_sp core__ensure_function_cell(T_sp functionName) {
-  if (functionName.consp()) {
-    List_sp cname = functionName;
+CL_DEFUN FunctionCell_sp core__ensure_function_cell(T_sp function_name) {
+  if (function_name.consp()) {
+    List_sp cname = function_name;
     if (oCar(cname) == cl::_sym_setf) {
       T_sp dname = oCdr(cname);
       if (dname.consp()) {
@@ -1076,10 +1076,35 @@ CL_DEFUN FunctionCell_sp core__ensure_function_cell(T_sp functionName) {
         }
       }
     }
-  } else if (gc::IsA<Symbol_sp>(functionName)) {
-    return gc::As_unsafe<Symbol_sp>(functionName)->ensureFunctionCell();
+  } else if (gc::IsA<Symbol_sp>(function_name)) {
+    return gc::As_unsafe<Symbol_sp>(function_name)->ensureFunctionCell();
   }
-  TYPE_ERROR(functionName, Cons_O::createList(cl::_sym_satisfies, core::_sym_validFunctionNameP));
+  TYPE_ERROR(function_name, Cons_O::createList(cl::_sym_satisfies, core::_sym_validFunctionNameP));
+}
+
+// Used in xref.
+CL_DOCSTRING(R"(Return the function cell for FUNCTION-NAME if it exists already, or else NIL.)")
+DOCGROUP(clasp);
+CL_DEFUN T_sp core__function_cell(T_sp function_name) {
+  T_sp result = unbound<T_O>();
+  if (function_name.consp()) {
+    List_sp cname = function_name;
+    if (oCar(cname) == cl::_sym_setf) {
+      T_sp dname = oCdr(cname);
+      if (dname.consp()) {
+        Symbol_sp name = gc::As<Symbol_sp>(oCar(dname));
+        if (name.notnilp() && oCdr(dname).nilp()) {
+          result = name->setfFunctionCell();
+        }
+      }
+    }
+  } else if (gc::IsA<Symbol_sp>(function_name)) {
+    result = gc::As_unsafe<Symbol_sp>(function_name)->functionCell();
+  }
+  // Don't signal an error here - this function should be harmless
+  // since it's used for debugging type stuff.
+  if (result.unboundp()) return nil<T_O>();
+  else return result;
 }
 
 // reader in symbol.cc; this additionally involves function properties, so it's here

diff --git a/src/core/symbol.cc b/src/core/symbol.cc
@@ -291,6 +291,12 @@ CL_DEFUN VariableCell_sp core__ensure_variable_cell(Symbol_sp name) {
   return name->ensureVariableCell();
 }
 
+CL_DEFUN T_sp core__variable_cell(Symbol_sp name) {
+  VariableCell_sp vcell = name->variableCell();
+  if (vcell.unboundp()) return nil<T_O>();
+  else return vcell;
+}
+
 CL_LISPIFY_NAME(variable-cell/name);
 CL_DEFUN T_sp core__variable_cell_name(VariableCell_sp vcell) {
   return vcell->name();

diff --git a/src/lisp/cscript.lisp b/src/lisp/cscript.lisp
@@ -142,6 +142,7 @@
              #~"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"
@@ -154,6 +155,7 @@
              #~"kernel/lsp/process.lisp"
              #~"kernel/lsp/encodings.lisp"
              #~"kernel/lsp/cltl2.lisp"
+             #~"kernel/lsp/xref.lisp"
              #@"base-immutable.lisp"
              #~"kernel/stage/base/2-end.lisp"
              #~"kernel/cmp/compile-file-parallel.lisp"

diff --git a/src/lisp/kernel/cleavir/bytecode-tablegen.lisp b/src/lisp/kernel/cleavir/bytecode-tablegen.lisp
@@ -21,72 +21,10 @@
   start end (successors nil) (predecessors nil) function
   (name nil) (receiving 0) extra)
 
-(defun 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 new-annotations (annotations index ip)
-  ;; Compute a list of annotations that start at the given IP.
-  ;; Return the list, and the index of the next annotation.
-  (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") annotsp))
-                           (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)
-           else
-             do (let ((,opip ,ip))
-                  (incf ,ip)
-                  (let ((,args
-                          (loop for argspec
-                                  in (if ,longp (fourth ,op) (third ,op))
-                                for nbytes = (logandc2 argspec
-                                                       cmpref::+mask-arg+)
-                                collect (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))))
-
 (defun compute-block-starts (bytecode &rest entry-points)
   (assert (> (length entry-points) 0))
   (let ((block-starts ()))
-    (do-instructions (mnemonic args opip ip) (bytecode)
+    (core::do-instructions (mnemonic args opip ip) (bytecode)
       (when (eql opip (first entry-points))
         (pop entry-points)
         (pushnew opip block-starts))
@@ -117,7 +55,7 @@
          (function (pop functions)))
     (assert (eql (function-entry-start function) 0))
     (setf (block-entry-function block) function)
-    (do-instructions (mnemonic args opip ip annots)
+    (core::do-instructions (mnemonic args opip ip annots)
         (bytecode :annotations annotations)
       (when (and functions (eql ip (function-entry-start (first functions))))
         ;; Starting a new function.