Cross

include/clasp/core/bytecode_compiler.h

@@ -352,36 +352,47 @@ 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<T_O>())
+    : _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<Lexenv_O>::allocate<gctools::RuntimeStage>(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<Lexenv_O>::allocate<gctools::RuntimeStage>(vars, tags, blocks, funs, decls, frame_end, global);
   }
-  static Lexenv_sp make_top_level() {
-    return make(nil<core::T_O>(), nil<core::T_O>(), nil<core::T_O>(), nil<core::T_O>(), nil<core::T_O>(), 0);
+  static Lexenv_sp make_top_level(T_sp global = nil<T_O>()) {
+    return make(nil<core::T_O>(), nil<core::T_O>(), nil<core::T_O>(), nil<core::T_O>(), nil<core::T_O>(), 0, global);
   }
   CL_DEFMETHOD List_sp vars() const { return this->_vars; }
   CL_DEFMETHOD List_sp tags() const { return this->_tags; }
   CL_DEFMETHOD List_sp blocks() const { return this->_blocks; }
   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,15 +1054,15 @@ 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;
   T_sp end() const;
 };
 
 // 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);

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<void*, string> do_dlopen(const string& str_path, const int n_mode);
 std::tuple<int, string> 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();

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

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 <atomic>
 #endif

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_O>(), T_sp docstring = nil<T_O>(),
@@ -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;
 

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;

include/clasp/core/symbol.h

@@ -91,6 +91,8 @@ class VariableCell_O : public General_O {
   mutable std::atomic<uint32_t> _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<T_O>()); }
+  CL_LISPIFY_NAME(VariableCell/makunbound)
+  CL_DEFMETHOD
+  void makunbound() { set_value(unbound<T_O>()); }
   inline T_sp valueSeqCst() const {
     T_sp val = valueUnsafeSeqCst();
     if (val.unboundp())

include/clasp/core/unwind.h

@@ -5,6 +5,7 @@
 #include <clasp/core/object.h>
 #include <clasp/core/symbol.h>
 #include <clasp/core/arguments.h> // DynamicScopeManager
+#include <clasp/core/evaluator.h> // eval::funcall
 
 namespace core {
 
@@ -337,7 +338,7 @@ template <typename Catchf> T_mv call_with_catch(T_sp tag, Catchf&& cf) {
     }
 }
 
-template <typename Boundf> __attribute__((optnone)) T_mv fprogv(List_sp symbols, List_sp values, Boundf&& bound) {
+template <typename Boundf> T_mv fprogv(List_sp symbols, List_sp values, Boundf&& bound) {
   if (symbols.consp()) {
     Symbol_sp sym = CONS_CAR(symbols).as<Symbol_O>();
     List_sp nsymbols = CONS_CDR(symbols);
@@ -353,4 +354,35 @@ template <typename Boundf> __attribute__((optnone)) T_mv fprogv(List_sp symbols,
   }
 }
 
+template <typename Boundf> 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<Symbol_O>();
+    T_sp rcell = eval::funcall(_sym_fcge_ensure_vcell, env, sym);
+    VariableCell_sp cell = rcell.as<VariableCell_O>();
+    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<T_O>(),
+                                  [&]() { return fprogv_env_aux(env, nsymbols, nil<T_O>(), bound); });
+    }
+  } else { // no symbols
+    return bound();
+  }
+}
+
+template <typename Boundf> 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