Merge branch 'develop' into 'develop'

Various changes

Closes #433

See merge request embeddable-common-lisp/ecl!102

CHANGELOG

@@ -51,8 +51,14 @@
   =--with-libgc-incdir= and =--with-libgc-libdir= (these flags work the
   same as flags for =libffi= and =libgmp=)
 ** Issues fixed
+- ECL allocated too much space in lisp stack. Instead of the specified size
+  x in bytes, ECL allocated roughly x^2/p where p is defined in
+  LISP_PAGESIZE (2048 by default). If you're setting the value of
+  ECL_OPT_LISP_STACK_SIZE, please check whether you really have
+  set a high enough value.
 - ~block/return-from~ fixed (didn't work across some closure boundaries)
 - ~mp:semaphore-signal~ fixed (race when count was > 1)
+- Multiple native threads issues fixed by Marius Gerbershagen
 - ASDF systems like foo/base and bar/base doesn't have conflicts in bundles
 - interactive input stream in ext:run-program on Windows
 - removed race condition between waitpid and sigchld handler on UNIX
@@ -71,6 +77,8 @@ in C code
 - No more explicit option in ~main.d~ to trap SIGCHLD asynchronously
 - Zombie processes are cleaned in ~external-process~ finalizer. If process
   is still referenced in the memory, it's programmer duty to call wait.
+- The cleanup forms of an unwind-protect are now executed with interrupts
+  disabled.
 * 16.1.3 changes since 16.1.2
 ** Announcement
 Dear Community,

src/c/alloc_2.d

@@ -268,7 +268,7 @@ allocate_object_own(register struct ecl_type_information *type_info)
     if( (op = *opp) == 0 ) {
       UNLOCK();
       op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind);
-      if (0 == op){
+      if (0 == op) {
         ecl_enable_interrupts_env(the_env);
         return 0;
       }

src/c/big.d

@@ -273,13 +273,13 @@ _ecl_fix_divided_by_big(cl_fixnum x, cl_object y)
 static void *
 mp_alloc(size_t size)
 {
-  return ecl_alloc_uncollectable(size);
+  return ecl_alloc_atomic(size);
 }
 
 static void
 mp_free(void *ptr, size_t size)
 {
-  ecl_free_uncollectable(ptr);
+  ecl_dealloc(ptr);
 }
 
 static void *

src/c/interpreter.d

@@ -30,7 +30,7 @@ ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size)
   cl_index new_size = tentative_new_size + 2*safety_area;
 
   /* Round to page size */
-  new_size = (new_size + (LISP_PAGESIZE-1))/LISP_PAGESIZE * new_size;
+  new_size = ((new_size + LISP_PAGESIZE - 1) / LISP_PAGESIZE) * LISP_PAGESIZE;
 
   if (ecl_unlikely(top > new_size)) {
     FEerror("Internal error: cannot shrink stack below stack top.",0);

src/c/main.d

@@ -569,7 +569,7 @@ cl_boot(int argc, char **argv)
   /*
    * Initialize the per-thread data.
    * This cannot come later, because we need to be able to bind
-   * ext::*interrupts-enabled while creating packages.
+   * ext::*interrupts-enabled* while creating packages.
    */
   init_big();
   ecl_init_env(env);

src/c/threads/process.d

@@ -534,9 +534,11 @@ mp_process_yield(void)
 cl_object
 mp_process_enable(cl_object process)
 {
-  cl_env_ptr process_env = NULL;
+  /* process_env and ok are changed after the setjmp call in
+   * ECL_UNWIND_PROTECT_BEGIN, so they need to be declared volatile */
+  volatile cl_env_ptr process_env = NULL;
   cl_env_ptr the_env = ecl_process_env();
-  int ok = 0;
+  volatile int ok = 0;
   ECL_UNWIND_PROTECT_BEGIN(the_env) {
     /* Try to gain exclusive access to the process at the same
      * time we ensure that it is inactive. This prevents two
@@ -618,7 +620,7 @@ mp_process_enable(cl_object process)
                          @':disable', ECL_T);
       process->process.phase = ECL_PROCESS_INACTIVE;
       process->process.env = NULL;
-      if(process_env != NULL)
+      if (process_env != NULL)
         _ecl_dealloc_env(process_env);
     }
     /* Unleash the thread */

src/c/unixint.d

@@ -823,7 +823,7 @@ si_check_pending_interrupts(void)
 void
 ecl_check_pending_interrupts(cl_env_ptr env)
 {
-        if(env->interrupt_struct->pending_interrupt != ECL_NIL)
+        if (env->interrupt_struct->pending_interrupt != ECL_NIL)
                 handle_all_queued_interrupt_safe(env);
 }
 

src/cmp/cmpblock.lsp

@@ -60,6 +60,7 @@
           (let ((env-lvl *env-lvl*))
             (wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
         (bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var)
+        (wt-nl-open-brace)
         (wt-nl "ecl_frs_push(cl_env_copy," blk-var ");")
         (wt-nl "if (__ecl_frs_push_result!=0) {")
         (let ((*unwind-exit* (cons 'FRAME *unwind-exit*)))
@@ -67,6 +68,7 @@
           (wt-nl "} else {")
           (c2expr body)
           (wt "}"))
+        (wt-nl-close-brace)
         (when (var-ref-ccb blk-var) (decf *env*))
         (wt-nl-close-brace))
       (c2expr body)))

src/cmp/cmpcatch.lsp

@@ -30,6 +30,7 @@
       (c2expr* tag))
     (let* ((*destination* new-destination)
            (*unwind-exit* (cons 'FRAME *unwind-exit*)))
+      (wt-nl-open-brace)
       (if (member new-destination '(TRASH VALUES))
           (progn
             (wt-nl "ecl_frs_push(cl_env_copy," 'VALUE0 ");")
@@ -51,6 +52,7 @@
     (wt-nl "}")
     (wt-nl "ecl_frs_pop(cl_env_copy);")
     (wt-comment "END CATCH ~A" code)
+    (wt-nl-close-brace)
     (unwind-exit new-destination)))
 
 (defun c1unwind-protect (args)
@@ -85,14 +87,20 @@
           (*destination* 'VALUES))
       (c2expr* form))
     (wt-nl "}")
+    ;; Here we disable interrupts for the execution of the cleanup forms...
+    (wt-nl "ecl_bds_bind(cl_env_copy,ECL_INTERRUPTS_ENABLED,ECL_NIL);")
     (wt-nl "ecl_frs_pop(cl_env_copy);")
     ;; Here we save the values of the form which might have been
-    ;; aborted, and execute some cleanup code. This code may also
-    ;; be aborted by some control structure, but is not protected.
+    ;; aborted, and execute some cleanup code. This code may also be
+    ;; aborted by some control structure, it is only protected against
+    ;; interrupts from other threads.
     (wt-nl nargs "=ecl_stack_push_values(cl_env_copy);")
     (let ((*destination* 'TRASH))
       (c2expr* body))
     (wt-nl "ecl_stack_pop_values(cl_env_copy," nargs ");")
+    ;; ...and here we reenable the interrupts.
+    (wt-nl "ecl_bds_unwind1(cl_env_copy);")
+    (wt-nl "ecl_check_pending_interrupts(cl_env_copy);")
     ;; Finally, if the protected form was aborted, jump to the
     ;; next catch point...
     (wt-nl "if (unwinding) ecl_unwind(cl_env_copy,next_fr);")

src/cmp/cmptag.lsp

@@ -151,6 +151,7 @@
           (maybe-open-inline-block)
           (wt-nl "cl_object " tag-loc ";"))
         (bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc)
+        (wt-nl-open-brace)
         (wt-nl "ecl_frs_push(cl_env_copy," tag-loc ");")
         (wt-nl "if (__ecl_frs_push_result) {")
         ;; Allocate labels.
@@ -163,6 +164,7 @@
         (when (var-ref-ccb tag-loc)
           (wt-nl "ecl_internal_error(\"GO found an inexistent tag\");"))
         (wt-nl "}")
+        (wt-nl-close-brace)
         (c2tagbody-body body)
         (close-inline-blocks))))
 

src/tests/ecl-tests.lisp

@@ -21,12 +21,15 @@
 
 ;;;; Declare the suites
 (suite 'ecl-tests
-       '(executable eformat ieee-fp eprocess package-ext hash-tables ansi+ mixed
-         cmp emb ffi mop mp run-program))
+       '(executable ieee-fp eprocess package-ext hash-tables ansi+ mixed
+         cmp emb ffi mop mp run-program eformat))
 
 (suite 'make-check
-       '(executable ieee-fp eprocess package-ext hash-tables ansi+ mixed cmp emb
-         ffi mop run-program mp ieee-fp))
+       '(executable ieee-fp eprocess package-ext hash-tables ansi+ mixed
+         cmp emb ffi mop run-program mp))
+
+(suite 'stress)
+(test stress.all (finishes (1am-ecl:run)))
 
 
 (defmacro is-true (form)