Merge pull request #1618 from clasp-developers/package-locks

Package locks

.gitignore

@@ -59,3 +59,4 @@ src/analysis/*.lst
 src/analysis/*.cc
 bench/
 repos-*.sexp
+*__pycache__*

RELEASE_NOTES.md

@@ -1,5 +1,9 @@
 # Version 2.7.0 (LLVM15-18) Pending
 
+## Added
+* Package lock support, based on SBCL's. Currently ignores local
+  bindings. Thanks @bumblingbats.
+
 ## Fixed
 * Pathnames and filesystem operations support Unicode (#1595).
 * Package names support Unicode (#1596).

include/clasp/core/exceptions.h

@@ -166,9 +166,6 @@ extern core::Symbol_sp& _sym_name;
 #define ERROR_WRONG_TYPE_NTH_ARG(_fn_, _nth_, _datum_, _expectedType_)                                                             \
   core__wrong_type_nth_arg(__FILE__, __LINE__, _fn_, _nth_, _datum_, _expectedType_)
 
-#define QERROR_WRONG_TYPE_NTH_ARG(_nth_, _datum_, _expectedType_)                                                                  \
-  core__wrong_type_nth_arg(__FILE__, __LINE__, core::lisp_intern(__FUNCTION__, CurrentPkg), _nth_, _datum_, _expectedType_)
-
 #define ARITHMETIC_ERROR(_operation_, _operands_)                                                                                  \
   ERROR(cl::_sym_arithmeticError, core::lisp_createList(kw::_sym_operation, _operation_, kw::_sym_operands, _operands_))
 
@@ -629,6 +626,7 @@ void FEargument_number_error(T_sp supplied, T_sp min, T_sp max);
 T_sp CEerror(T_sp c, const char* fmt, int numArgs, ...);
 
 void FEpackage_error(const char* fmt, T_sp package, int nargs, ...);
+void CEpackage_lock_violation(T_sp pkg, const char* fmt, int nargs, ...);
 void CEpackage_error(const char* fmt, const char* continue_message, T_sp package, int nargs, ...);
 void Warn(T_sp datum, List_sp arguments);
 

include/clasp/core/keywordPackage.h

@@ -31,5 +31,4 @@ THE SOFTWARE.
 
 namespace kw {
 
-core::Package_sp initialize_keywordPackage();
 };

include/clasp/core/package.h

@@ -59,18 +59,14 @@ class Package_O : public General_O {
   SimpleString_sp _Name;
   gctools::Vec0<Package_sp> _UsingPackages;
   gctools::Vec0<Package_sp> _PackagesUsedBy;
-  std::atomic<bool> _KeywordPackage;
-  std::atomic<bool> _AmpPackage;
-  std::atomic<bool> _ActsLikeKeywordPackage;
   List_sp _Nicknames;
   List_sp _LocalNicknames;
+  gctools::Vec0<Package_sp> _Implementors;
   T_sp _Documentation;
 #ifdef CLASP_THREADS
   mutable mp::SharedMutex _Lock;
 #endif
-  bool systemLockedP = false;
-  bool userLockedP = false;
-  bool zombieP = false;
+  std::atomic<uint16_t> _Flags;
 
 public: // Creation class functions
   static Package_sp create(const string& p);
@@ -86,6 +82,15 @@ class Package_O : public General_O {
 private:
   // Returns a list of packages that will newly conflict.
   List_sp export_conflicts(SimpleString_sp nameKey, Symbol_sp sym);
+  // flag masks.
+  static const uint16_t flag_zombie = 0x01; // is the package deleted?
+  // is it a system package? (unused for now)
+  static const uint16_t flag_sys = 0x02;
+  // is it locked? (i.e. unintern blocked, etc., not the mutex)
+  static const uint16_t flag_lock = 0x04;
+  // is this the keyword package?
+  static const uint16_t flag_keyword = 0x08;
+  static const uint16_t flag_actskw = 0x10;
 
 public:
   string packageName() const;
@@ -105,11 +110,6 @@ class Package_O : public General_O {
   void setLocalNicknames(List_sp localNicknames) { this->_LocalNicknames = localNicknames; }
   List_sp getLocalNicknames() const { return this->_LocalNicknames; }
   T_sp findPackageByLocalNickname(String_sp);
-  void setKeywordPackage(bool b) { this->_KeywordPackage = b; };
-  bool isKeywordPackage() const { return this->_KeywordPackage; };
-  // Cando makes a package that acts like the keyword package (symbol values are symbols and all symbols extern)
-  void setActsLikeKeywordPackage(bool b) { this->_ActsLikeKeywordPackage = b; };
-  bool actsLikeKeywordPackage() const { return this->_KeywordPackage || this->_ActsLikeKeywordPackage; };
 
   string allSymbols();
 
@@ -177,6 +177,9 @@ class Package_O : public General_O {
   bool unusePackage_no_outer_lock(Package_sp usePackage);
   bool unusePackage_no_inner_lock(Package_sp usePackage);
 
+  void addImplementationPackage(Package_sp);
+  void removeImplementationPackage(Package_sp);
+
   bool usingPackageP_no_lock(Package_sp pkg) const;
   /*! Return true if we are using the package */
   bool usingPackageP(Package_sp pkg) const;
@@ -195,24 +198,43 @@ class Package_O : public General_O {
 
   /*! Map over the Internal key/value pairs */
   void mapInternals(KeyValueMapper* mapper);
+private:
+  inline uint16_t flags() const { return _Flags.load(std::memory_order_relaxed); }
+  inline bool getFlag(uint16_t n) const { return !!(flags() & n); }
+  inline void setFlag(bool flag, uint16_t n) {
+    if (flag) _Flags.fetch_or(n, std::memory_order_relaxed);
+    else _Flags.fetch_and(~n, std::memory_order_relaxed);
+  }
+public:
+  void setSystemPackageP(bool value) { setFlag(value, flag_sys); }
+  bool getSystemPackageP() const { return getFlag(flag_sys); }
+  void setLockedP(bool value) { setFlag(value, flag_lock); }
+  bool getLockedP() const { return getFlag(flag_lock); }
+
+  // is this package locked? accounting for implementation packages
+  // (use this instead of getLockedP most of the time)
+  bool lockedP() const;
+
+  void setZombieP(bool value) { setFlag(value, flag_zombie); }
+  bool getZombieP() { return getFlag(flag_zombie); }
+  void setKeywordPackage(bool b) { setFlag(b, flag_keyword); }
+  bool isKeywordPackage() const { return getFlag(flag_keyword); }
+  // Cando makes a package that acts like the keyword package (symbol values are symbols and all symbols extern)
+  void setActsLikeKeywordPackage(bool b) { setFlag(b, flag_actskw); }
+  bool actsLikeKeywordPackage() const {
+    return isKeywordPackage() || getFlag(flag_actskw);
+  }
 
-  void setSystemLockedP(bool value) { this->systemLockedP = value; }
-
-  bool getSystemLockedP() { return this->systemLockedP; }
-
-  void setUserLockedP(bool value) { this->userLockedP = value; }
-
-  bool getUserLockedP() { return this->userLockedP; }
-
-  void setZombieP(bool value) { this->zombieP = value; }
-
-  bool getZombieP() { return this->zombieP; }
 
 public:
   // Not default constructable
   Package_O()
-      : _ActsLikeKeywordPackage(false), _Nicknames(nil<T_O>()), _LocalNicknames(nil<T_O>()), _Documentation(nil<T_O>()),
-        _Lock(PACKAGE__NAMEWORD){};
+      : _Flags(0), _Nicknames(nil<T_O>()), _LocalNicknames(nil<T_O>()), _Documentation(nil<T_O>()),
+        _Lock(PACKAGE__NAMEWORD){
+    // by default, packages implement themselves.
+    // this can be changed later.
+    this->_Implementors.push_back(this->asSmartPtr());
+  };
 
   virtual void fixupInternalsForSnapshotSaveLoad(snapshotSaveLoad::Fixup* fixup) {
     if (snapshotSaveLoad::operation(fixup) == snapshotSaveLoad::LoadOp) {

include/clasp/core/symbol.h

@@ -385,6 +385,9 @@ class Symbol_O : public General_O {
   /*! Convenience function, export yourself and return yourself */
   Symbol_sp exportYourself(bool doit = true);
 
+  // Error if our package is locked. fmt takes one argument (the sym)
+  void check_package_lock(const char* fmt);
+
   void dump() override;
 
   void __write__(T_sp stream) const override; // in write_symbol.cc

src/analysis/clasp_gc.sif

@@ -5498,30 +5498,24 @@
              :offset-ctype "gctools::tagged_pointer<gctools::GCVector_moveable<gctools::smart_ptr<core::Package_O>>>"
              :offset-base-ctype "core::Package_O"
              :layout-offset-field-names ("_PackagesUsedBy" "._Vector" "._Contents")}
-{fixed-field :offset-type-cxx-identifier "ATOMIC_POD_OFFSET__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O" :layout-offset-field-names ("_KeywordPackage")}
-{fixed-field :offset-type-cxx-identifier "ATOMIC_POD_OFFSET__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O" :layout-offset-field-names ("_AmpPackage")}
-{fixed-field :offset-type-cxx-identifier "ATOMIC_POD_OFFSET__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O"
-             :layout-offset-field-names ("_ActsLikeKeywordPackage")}
 {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
              :offset-ctype "gctools::smart_ptr<core::List_V>" :offset-base-ctype "core::Package_O"
              :layout-offset-field-names ("_Nicknames")}
 {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
              :offset-ctype "gctools::smart_ptr<core::List_V>" :offset-base-ctype "core::Package_O"
              :layout-offset-field-names ("_LocalNicknames")}
+{fixed-field :offset-type-cxx-identifier "TAGGED_POINTER_OFFSET"
+             :offset-ctype "gctools::tagged_pointer<gctools::GCVector_moveable<gctools::smart_ptr<core::Package_O>>>"
+             :offset-base-ctype "core::Package_O"
+             :layout-offset-field-names ("_Implementors" "._Vector" "._Contents")}
 {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
              :offset-ctype "gctools::smart_ptr<core::T_O>" :offset-base-ctype "core::Package_O"
              :layout-offset-field-names ("_Documentation")}
 {fixed-field :offset-type-cxx-identifier "CXX_SHARED_MUTEX_OFFSET" :offset-ctype "mp::SharedMutex"
              :offset-base-ctype "core::Package_O" :layout-offset-field-names ("_Lock")}
-{fixed-field :offset-type-cxx-identifier "ctype__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O" :layout-offset-field-names ("systemLockedP")}
-{fixed-field :offset-type-cxx-identifier "ctype__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O" :layout-offset-field-names ("userLockedP")}
-{fixed-field :offset-type-cxx-identifier "ctype__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O" :layout-offset-field-names ("zombieP")}
+{fixed-field :offset-type-cxx-identifier "ATOMIC_POD_OFFSET_unsigned_short"
+             :offset-ctype "unsigned short" :offset-base-ctype "core::Package_O"
+             :layout-offset-field-names ("_Flags")}
 {class-kind :stamp-name "STAMPWTAG_core__FileStatus_O" :stamp-key "core::FileStatus_O"
             :parent-class "core::General_O" :lisp-class-base "core::General_O"
             :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"}

src/analysis/clasp_gc_cando.sif

@@ -10336,30 +10336,24 @@
              :offset-ctype "gctools::tagged_pointer<gctools::GCVector_moveable<gctools::smart_ptr<core::Package_O>>>"
              :offset-base-ctype "core::Package_O"
              :layout-offset-field-names ("_PackagesUsedBy" "._Vector" "._Contents")}
-{fixed-field :offset-type-cxx-identifier "ATOMIC_POD_OFFSET__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O" :layout-offset-field-names ("_KeywordPackage")}
-{fixed-field :offset-type-cxx-identifier "ATOMIC_POD_OFFSET__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O" :layout-offset-field-names ("_AmpPackage")}
-{fixed-field :offset-type-cxx-identifier "ATOMIC_POD_OFFSET__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O"
-             :layout-offset-field-names ("_ActsLikeKeywordPackage")}
 {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
              :offset-ctype "gctools::smart_ptr<core::List_V>" :offset-base-ctype "core::Package_O"
              :layout-offset-field-names ("_Nicknames")}
 {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
              :offset-ctype "gctools::smart_ptr<core::List_V>" :offset-base-ctype "core::Package_O"
              :layout-offset-field-names ("_LocalNicknames")}
+{fixed-field :offset-type-cxx-identifier "TAGGED_POINTER_OFFSET"
+             :offset-ctype "gctools::tagged_pointer<gctools::GCVector_moveable<gctools::smart_ptr<core::Package_O>>>"
+             :offset-base-ctype "core::Package_O"
+             :layout-offset-field-names ("_Implementors" "._Vector" "._Contents")}
 {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET"
              :offset-ctype "gctools::smart_ptr<core::T_O>" :offset-base-ctype "core::Package_O"
              :layout-offset-field-names ("_Documentation")}
 {fixed-field :offset-type-cxx-identifier "CXX_SHARED_MUTEX_OFFSET" :offset-ctype "mp::SharedMutex"
              :offset-base-ctype "core::Package_O" :layout-offset-field-names ("_Lock")}
-{fixed-field :offset-type-cxx-identifier "ctype__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O" :layout-offset-field-names ("systemLockedP")}
-{fixed-field :offset-type-cxx-identifier "ctype__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O" :layout-offset-field-names ("userLockedP")}
-{fixed-field :offset-type-cxx-identifier "ctype__Bool" :offset-ctype "_Bool"
-             :offset-base-ctype "core::Package_O" :layout-offset-field-names ("zombieP")}
+{fixed-field :offset-type-cxx-identifier "ATOMIC_POD_OFFSET_unsigned_short"
+             :offset-ctype "unsigned short" :offset-base-ctype "core::Package_O"
+             :layout-offset-field-names ("_Flags")}
 {class-kind :stamp-name "STAMPWTAG_core__FileStatus_O" :stamp-key "core::FileStatus_O"
             :parent-class "core::General_O" :lisp-class-base "core::General_O"
             :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"}

src/core/character.cc

@@ -636,7 +636,7 @@ DOCGROUP(clasp);
 CL_DEFUN T_sp cl__digit_char_p(Character_sp c, Fixnum_sp radix) {
   Fixnum basis = unbox_fixnum(radix);
   if (basis < 2 || basis > 36) {
-    QERROR_WRONG_TYPE_NTH_ARG(2, radix, Integer_O::makeIntegerType(2, 36));
+    ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_digitCharP, 2, radix, Integer_O::makeIntegerType(2, 36));
   }
   Fixnum value = clasp_digitp(clasp_as_claspCharacter(c), basis);
   if (value < 0)

src/core/exceptions.cc

@@ -796,6 +796,18 @@ void FEpackage_error(const char* fmt, T_sp package, int nargs, ...) {
                 fmtargs, kw::_sym_package, package);
 }
 
+void CEpackage_lock_violation(T_sp pkg, const char* fmt,
+                              int nargs, ...) {
+  va_list args;
+  va_start(args, nargs);
+  List_sp fmtargs = clasp_grab_rest_args(args, nargs);
+  va_end(args);
+  eval::funcall(core::_sym_signalSimpleError, core::_sym_package_lock_violation,
+                SimpleBaseString_O::make("Ignore the package lock."),
+                SimpleBaseString_O::make(fmt), fmtargs,
+                kw::_sym_package, pkg);
+}
+
 void Warn(T_sp datum, List_sp arguments) { core__apply1(core::coerce::calledFunctionDesignator(cl::_sym_warn), arguments, datum); }
 
 void clasp_internal_error(const char* msg) {

src/core/keywordPackage.cc

@@ -155,12 +155,4 @@ SYMBOL_EXPORT_SC_(KeywordPkg, use_mps);
 SYMBOL_EXPORT_SC_(KeywordPkg, utf_8);
 SYMBOL_EXPORT_SC_(KeywordPkg, verbose);
 
-core::Package_sp initialize_keywordPackage() {
-  list<string> lnicknames = {"KW"};
-  ;
-  list<string> luse;
-  core::Package_sp keywordPackage = _lisp->makePackage("KEYWORD", lnicknames, luse);
-  keywordPackage->setKeywordPackage(true);
-  return keywordPackage;
-}
 }; // namespace kw

src/core/lisp.cc

@@ -455,9 +455,25 @@ void Lisp::startupLispEnvironment() {
     _lisp->_Roots._CorePackage = gc::As<Package_sp>(_lisp->findPackage(CorePkg));
     _lisp->_Roots._KeywordPackage = gc::As<Package_sp>(_lisp->findPackage(KeywordPkg));
     _lisp->_Roots._CommonLispPackage = gc::As<Package_sp>(_lisp->findPackage(ClPkg));
-    _lisp->_Roots._CorePackage->setSystemLockedP(true);
-    _lisp->_Roots._KeywordPackage->setSystemLockedP(true);
-    _lisp->_Roots._CommonLispPackage->setSystemLockedP(true);
+    _lisp->_Roots._CorePackage->setSystemPackageP(true);
+    _lisp->_Roots._KeywordPackage->setSystemPackageP(true);
+    _lisp->_Roots._CommonLispPackage->setSystemPackageP(true);
+    // Set up implementation packages
+    _lisp->_Roots._CommonLispPackage->addImplementationPackage(_lisp->_Roots._CorePackage);
+    _lisp->_Roots._CommonLispPackage->addImplementationPackage(_lisp->findPackage(ClosPkg).as<Package_O>());
+    _lisp->_Roots._CommonLispPackage->addImplementationPackage(_lisp->findPackage(CompPkg).as<Package_O>());
+
+    _lisp->findPackage(ClosPkg).as<Package_O>()->addImplementationPackage(_lisp->_Roots._CorePackage);
+    _lisp->findPackage(ClosPkg).as<Package_O>()->addImplementationPackage(_lisp->findPackage(CompPkg).as<Package_O>());
+
+    _lisp->findPackage(ExtPkg).as<Package_O>()->addImplementationPackage(_lisp->_Roots._CorePackage);
+    _lisp->findPackage(ExtPkg).as<Package_O>()->addImplementationPackage(_lisp->findPackage(ClosPkg).as<Package_O>());
+
+    _lisp->_Roots._CommonLispPackage->setLockedP(true);
+    //_lisp->_Roots._CorePackage->setLockedP(true);
+    //_lisp->findPackage(CompPkg).as<Package_O>()->setLockedP(true);
+    _lisp->findPackage(ClosPkg).as<Package_O>()->setLockedP(true);
+    _lisp->findPackage(ExtPkg).as<Package_O>()->setLockedP(true);
     //
     // fixme2022 Rip this package out if we don't need it to store the reference compiler
     //
@@ -1457,7 +1473,7 @@ CL_DEFUN List_sp cl__member(T_sp item, T_sp tlist, T_sp key, T_sp test, T_sp tes
   }
   if (tlist.nilp())
     return nil<T_O>();
-  QERROR_WRONG_TYPE_NTH_ARG(2, tlist, cl::_sym_list);
+  ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_member, 2, tlist, cl::_sym_list);
   UNREACHABLE();
 }