Circular lists (maybe)

[mnepveu]

Thanks for your answers to my previous post.

I have a data reporting application working with SBCL and CCL, which hangs with ABCL, with one CPU usage going to 100%. The culprit seems to be the "mapcar" call below.

(setq *print-circle* t)

(defun number-of-items (rtype datefrom dateto)
  10)

(defun circularlist (items)
  (setf (cdr (last items)) items)
  items)

(mapcar #'number-of-items '("abîmé" "administratif" "autre" "client insatisfait" "coin défecteux" "couleur / profil" "défectueux" "erreur créaction" "erreur du client" "erreur expédition" "impression" "mesure" "offset" "qualité" "transport" "égratignée")
                          (circularlist (list "2023-07-31"))
                          (circularlist (list "2023-08-07")))

SBCL

This is SBCL 2.3.7, an implementation of ANSI Common Lisp.
More information about SBCL is available at <http://www.sbcl.org/>.

SBCL is free software, provided as is, with absolutely no warranty.
It is mostly in the public domain; some portions are provided under
BSD-style licenses.  See the CREDITS and COPYING files in the
distribution for more information.
* (setq *print-circle* t)
T
* 
(defun number-of-items (rtype datefrom dateto)
  10)
; in: DEFUN NUMBER-OF-ITEMS
;     (SB-INT:NAMED-LAMBDA NUMBER-OF-ITEMS
;         (RTYPE DATEFROM DATETO)
;       (BLOCK NUMBER-OF-ITEMS 10))
; 
; caught STYLE-WARNING:
;   The variable RTYPE is defined but never used.
; 
; caught STYLE-WARNING:
;   The variable DATEFROM is defined but never used.
; 
; caught STYLE-WARNING:
;   The variable DATETO is defined but never used.
; 
; compilation unit finished
;   caught 3 STYLE-WARNING conditions
NUMBER-OF-ITEMS
* 
(defun circularlist (items)
  (setf (cdr (last items)) items)
  items)
CIRCULARLIST
* 
(mapcar #'number-of-items '("abîmé" "administratif" "autre" "client insatisfait" "coin défecteux" "couleur / profil" "défectueux" "erreur créaction" "erreur du client" "erreur expédition" "impression" "mesure" "offset" "qualité" "transport" "égratignée")
                          (circularlist (list "2023-07-31"))
                          (circularlist (list "2023-08-07")))
(10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10)
*

CCL

Clozure Common Lisp Version 1.12.1 (v1.12-41-g596fdacb) LinuxX8664

For more information about CCL, please see http://ccl.clozure.com.

CCL is free software.  It is distributed under the terms of the Apache
Licence, Version 2.0.
? (setq *print-circle* t)
T
? 
(defun number-of-items (rtype datefrom dateto)
  10)
;Compiler warnings :
;   In NUMBER-OF-ITEMS: Unused lexical variable DATETO
;   In NUMBER-OF-ITEMS: Unused lexical variable DATEFROM
;   In NUMBER-OF-ITEMS: Unused lexical variable RTYPE
NUMBER-OF-ITEMS
? 
(defun circularlist (items)
  (setf (cdr (last items)) items)
  items)
CIRCULARLIST
? 
(mapcar #'number-of-items '("abîmé" "administratif" "autre" "client insatisfait" "coin défecteux" "couleur / profil" "défectueux" "erreur créaction" "erreur du client" "erreur expédition" "impression" "mesure" "offset" "qualité" "transport" "égratignée")
                          (circularlist (list "2023-07-31"))
                          (circularlist (list "2023-08-07")))
(10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10)
?

ABCL (loops forever)

Armed Bear Common Lisp 1.9.3-dev
Java 1.8.0_342 Temurin
OpenJDK 64-Bit Server VM
Low-level initialization completed in 0.196 seconds.
Startup completed in 0.825 seconds.
Loading /home/sysrmn/.abclrc completed in 11.762 seconds.
Type ":help" for a list of available commands.
CL-USER(1): (setq *print-circle* t)
T
CL-USER(2): 
CL-USER(2): (defun number-of-items (rtype datefrom dateto)
  10)
NUMBER-OF-ITEMS
CL-USER(3): 
CL-USER(3): (defun circularlist (items)
  (setf (cdr (last items)) items)
  items)
CIRCULARLIST
CL-USER(4): 
CL-USER(4): (mapcar #'number-of-items '("abîmé" "administratif" "autre" "client insatisfait" "coin défecteux" "couleur / profil" "défectueux" "erreur créaction" "erreur du client" "erreur expédition" "impression" "mesure" "offset" "qualité" "transport" "égratignée")
                          (circularlist (list "2023-07-31"))
                          (circularlist (list "2023-08-07")))

[mnepveu]

Found a workaround by making sure "mapcar" doesn't receive an infinite list.

Guess: maybe, when given a circular list, mapcar doesn't stop after the shortest list is depleted.

(defun number-of-items (rtype datefrom dateto)
  10)

(defun circularlist (items)
  (setf (cdr (last items)) items)
  items)

(defun take-i (n lst)
  (subseq lst 0 n))

(let ((titles '("abîmé" "administratif" "autre" "client insatisfait" "coin défecteux" "couleur / profil" "défectueux"
                "erreur créaction" "erreur du client" "erreur expédition" "impression" "mesure" "offset" "qualité" "transport" "égratignée"))
      (datefrom (circularlist (list "2023-07-31")))
      (dateto   (circularlist (list "2023-08-07"))))

  (write (take-i 3 datefrom)) (terpri)

  (mapcar #'number-of-items
          titles
          (take-i (length titles) datefrom)
          (take-i (length titles) dateto)))

ABCL

Armed Bear Common Lisp 1.9.3-dev
Java 1.8.0_342 Temurin
OpenJDK 64-Bit Server VM
Low-level initialization completed in 0.188 seconds.
Startup completed in 1.065 seconds.
Loading /home/sysrmn/.abclrc completed in 11.567 seconds.
Type ":help" for a list of available commands.
CL-USER(1): (defun number-of-items (rtype datefrom dateto)
  10)
NUMBER-OF-ITEMS
CL-USER(2): 
CL-USER(2): (defun circularlist (items)
  (setf (cdr (last items)) items)
  items)
CIRCULARLIST
CL-USER(3): 
CL-USER(3): (defun take-i (n lst)
  (subseq lst 0 n))
TAKE-I
CL-USER(4): 
CL-USER(4): 
CL-USER(4): (let ((titles '("abîmé" "administratif" "autre" "client insatisfait" "coin défecteux" "couleur / profil" "défectueux"
                "erreur créaction" "erreur du client" "erreur expédition" "impression" "mesure" "offset" "qualité" "transport" "égratignée"))
      (datefrom (circularlist (list "2023-07-31")))
      (dateto   (circularlist (list "2023-08-07"))))
  (write (take-i 3 datefrom)) (terpri)
  (mapcar #'number-of-items
          titles
          (take-i (length titles) datefrom)
          (take-i (length titles) dateto)))
("2023-07-31" "2023-07-31" "2023-07-31")
(10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10)
CL-USER(5): 

[alanruttenberg]

Observation:

(mapcar (lambda(&rest x) t) '(1 2 3) (circularlist (list 1)))

doesn't hang, but adding one more list does hang.

(mapcar (lambda(&rest x) t) '(1 2 3) '(1 2 3) (circularlist (list 1)))

The order of arguments doesn't matter, and it doesn't need to be that case that there is more than one circular list as argument.

The implementation of mapcar uses 3 java methods, specializing the 1 and 2 argument cases in separate methods, and then uses a third method for more than 2 arguments, so presumably it's that method that is buggy.

        public LispObject execute(final LispObject[] args)

        {
            final int numArgs = args.length;
            if (numArgs < 2)
                return error(new WrongNumberOfArgumentsException(this, 2, -1));
            int commonLength = -1;
            for (int i = 1; i < numArgs; i++) {
                if (!args[i].listp())
                    type_error(args[i], Symbol.LIST);
                int len = args[i].length();
                if (commonLength < 0)
                    commonLength = len;
                else if (commonLength > len)
                    commonLength = len;
            }
            final LispThread thread = LispThread.currentThread();
            LispObject[] results = new LispObject[commonLength];
            final int numFunArgs = numArgs - 1;
            final LispObject[] funArgs = new LispObject[numFunArgs];
            for (int i = 0; i < commonLength; i++) {
                for (int j = 0; j < numFunArgs; j++)
                    funArgs[j] = args[j+1].car();
                results[i] = funcall(args[0], funArgs, thread);
                for (int j = 1; j < numArgs; j++)
                    args[j] = args[j].cdr();
            }
            thread._values = null;
            LispObject result = NIL;
            for (int i = commonLength; i-- > 0;)
                result = new Cons(results[i], result);
            return result;
        }

[alanruttenberg]

Looks to me like the problem is that the >2 arg method uses length

[alanruttenberg]

mapc has the same problem.

Possible fixes:

• Use the equivalent of sys:safe-length instead of length, ignoring cases where it would return nil, with the added benefit that you could detect calls that only had circular lists as arguments. Presumably have to rewrite sys:safe-length in java.
• Implement mapc and mapcar in lisp, using sys:map1 as is done for other mapping functions in map1.lisp. Downside would be probable performance hit, but would need to check - maybe not too bad.
• fix the loop (starting for (int i = 0; i < commonLength; i++)) to not use length, which would involve a check for any of the args[j] being nil at the beginning of the loop and quitting if so, as well as accumulating results by keeping a tail pointer to the growing result.

[alanruttenberg]

The implementation using map1:

CL-USER> (defun mapcar-safe (function &rest lists)
       (sys::map1 function lists :list t))
mapcar-safe
CL-USER> (mapcar-safe #'number-of-items '("abîmé" "administratif" "autre" "client insatisfait" "coin défecteux" "couleur / profil" "défectueux" "erreur créaction" "erreur du client" "erreur expédition" "impression" "mesure" "offset" "qualité" "transport" "égratignée")
                          (circularlist (list "2023-07-31"))
                          (circularlist (list "2023-08-07")))
(10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10)

[alanruttenberg]

patch because \<git disorganization>

diff --git a/src/org/armedbear/lisp/Primitives.java b/src/org/armedbear/lisp/Primitives.java
index 84d28cf8..6a199a2e 100644
--- a/src/org/armedbear/lisp/Primitives.java
+++ b/src/org/armedbear/lisp/Primitives.java
@@ -2914,31 +2914,36 @@ public final class Primitives {
             final int numArgs = args.length;
             if (numArgs < 2)
                 return error(new WrongNumberOfArgumentsException(this, 2, -1));
-            int commonLength = -1;
-            for (int i = 1; i < numArgs; i++) {
-                if (!args[i].listp())
-                    type_error(args[i], Symbol.LIST);
-                int len = args[i].length();
-                if (commonLength < 0)
-                    commonLength = len;
-                else if (commonLength > len)
-                    commonLength = len;
-            }
             final LispThread thread = LispThread.currentThread();
-            LispObject[] results = new LispObject[commonLength];
             final int numFunArgs = numArgs - 1;
             final LispObject[] funArgs = new LispObject[numFunArgs];
-            for (int i = 0; i < commonLength; i++) {
-                for (int j = 0; j < numFunArgs; j++)
+       LispObject result = NIL;
+       LispObject tail = NIL;
+       boolean done = false; 
+            while (!done) {
+         for (int j = 1; j < numArgs; j++)
+       if (args[j] == NIL)
+         done = true;
+         if (!done)
+                { for (int j = 0; j < numFunArgs; j++)
                     funArgs[j] = args[j+1].car();
-                results[i] = funcall(args[0], funArgs, thread);
-                for (int j = 1; j < numArgs; j++)
-                    args[j] = args[j].cdr();
-            }
+         
+         LispObject one = funcall(args[0], funArgs, thread);
+
+         if (result == NIL)
+           {result = new Cons(one,NIL);
+             tail = result;
+           }
+         else
+           { tail.setCdr(new Cons(one,NIL)) ;
+             tail = tail.cdr();
+           }
+         
+         for (int j = 1; j < numArgs; j++)
+           args[j] = args[j].cdr();
+       }
+       }
             thread._values = null;
-            LispObject result = NIL;
-            for (int i = commonLength; i-- > 0;)
-                result = new Cons(results[i], result);
             return result;
         }
     };
@@ -2990,27 +2995,23 @@ public final class Primitives {
             final int numArgs = args.length;
             if (numArgs < 2)
                 return error(new WrongNumberOfArgumentsException(this, 2, -1));
-            int commonLength = -1;
-            for (int i = 1; i < numArgs; i++) {
-                if (!args[i].listp())
-                    type_error(args[i], Symbol.LIST);
-                int len = args[i].length();
-                if (commonLength < 0)
-                    commonLength = len;
-                else if (commonLength > len)
-                    commonLength = len;
-            }
             final LispThread thread = LispThread.currentThread();
-            LispObject result = args[1];
             final int numFunArgs = numArgs - 1;
+       LispObject result = args[1];
+       boolean done = false;
             final LispObject[] funArgs = new LispObject[numFunArgs];
-            for (int i = 0; i < commonLength; i++) {
-                for (int j = 0; j < numFunArgs; j++)
+            while (!done) {
+         for (int j = 1; j < numArgs; j++)
+       if (args[j] == NIL)
+         done = true;
+         if (!done)
+                { for (int j = 0; j < numFunArgs; j++)
                     funArgs[j] = args[j+1].car();
-                funcall(args[0], funArgs, thread);
-                for (int j = 1; j < numArgs; j++)
-                    args[j] = args[j].cdr();
-            }
+         funcall(args[0], funArgs, thread);
+         for (int j = 1; j < numArgs; j++)
+           args[j] = args[j].cdr();
+       }
+       }
             thread._values = null;
             return result;
         }

[mnepveu]

Recompiled abcl.jar and tested with the original application: it works beautifully!

Thanks!