structs: deal with initialization diamond problem.

Until now it has been documented that if a struct type
inherits a supertype two or more times, then the supertype
initialization occurs that many times.

This change fixes the behavior: bases are initialized once.

* struct.c (struct struct_type): New members, ndsupers, dsus
providing a flat array for tracking duplicate supertypes.
(get_all_supers, get_duplicate_supers): New static functions.
(make_struct_type): Calculate the duplicate supers, and store
them in the dsus array. Under 242 or lower compat mode,
pretend there are duplicates, which defeats the duplicate
detecting mechanism
(struct_type_destroy): Free the dsus array.
(call_inittfun_chain, call_postinitfun_chain): Take new
arguments: the root type from which the recursion started, and
a stack-allocated bit vector indicating which duplicate bases
have already been initialized. If the given type appears in
the duplicate bases list of the root type, and its bit is
already set, then skip all initialization for it. Otherwise
set its bit and proceed.
(alloc_seen, clear_seen): New macros to help with allocating
the bitvector of duplicate bases.
(make_struct_impl, lazy_struct_init, reset_struct): Use
alloc_seen and clear_seen macros to manage the bitvector of
duplicate bases for calling call_initfun_chain and
call_postinitfun_chain.

* txr.1: Updated doc with new paragraph about duplicated
supertypes, and compat note added.

2 files changed, 201 insertions, 13 deletions

diff --git a/struct.c b/struct.c
index 268b9a40..5564f3c4 100644
--- a/struct.c
+++ b/struct.c
@@ -79,8 +79,10 @@ struct struct_type {
   cnum nslots;
   cnum nstslots;
   cnum nsupers;
+  cnum ndsupers;
   val supers;
   struct struct_type **sus;
+  struct struct_type **dsus;
   val slots;
   val stinitfun;
   val initfun;
@@ -297,6 +299,52 @@ static void static_slot_home_fixup(struct struct_type *st)
   }
 }
 
+static val get_all_supers(val supers, val self)
+{
+  list_collect_decl (all_supers, ptail);
+
+  ptail = list_collect_append(ptail, supers);
+
+  for (; supers; supers = us_cdr(supers)) {
+    val super = us_car(supers);
+    struct struct_type *su = stype_handle(&super, self);
+    int i;
+
+    ptail = list_collect_append(ptail, su->supers);
+
+    for (i = 0; i < su->nsupers; i++) {
+      struct struct_type *ssu = su->sus[i];
+      ptail = list_collect_append(ptail, get_all_supers(ssu->supers, self));
+    }
+  }
+
+  return all_supers;
+}
+
+static val get_duplicate_supers(val supers, val self)
+{
+  list_collect_decl (dup_supers, ptail);
+  val all_supers = get_all_supers(supers, self);
+  ucnum bloom = 0;
+  val iter;
+
+  for (iter = all_supers; iter; iter = us_cdr(iter)) {
+    val super = us_car(iter);
+    struct struct_type *st = stype_handle(&super, self);
+    int pos = st->id % (sizeof bloom * CHAR_BIT);
+    ucnum mask = (ucnum) 1 << pos;
+
+    if ((mask & bloom) != 0) {
+      if (memq(super, all_supers) != iter && !memq(super, dup_supers))
+        ptail = list_collect(ptail, super);
+    }
+
+    bloom |= mask;
+  }
+
+  return dup_supers;
+}
+
 static struct struct_type **get_struct_handles(cnum nsupers, val supers,
                                                val self)
 {
@@ -396,8 +444,12 @@ val make_struct_type(val name, val supers,
   } else {
     struct struct_type *st = coerce(struct struct_type *,
                                     chk_malloc(sizeof *st));
+    val dup_supers = if3(opt_compat && opt_compat <= 242,
+                         nil, get_duplicate_supers(supers, self));
     cnum nsupers = c_num(length(supers), self);
+    cnum ndsupers = c_num(length(dup_supers), self);
     struct struct_type **sus = get_struct_handles(nsupers, supers, self);
+    struct struct_type **dsus = get_struct_handles(ndsupers, dup_supers, self);
     val id = num_fast(coerce(ucnum, st) / (uptopow2(sizeof *st) / 2));
     val super_slots = get_super_slots(nsupers, sus);
     val all_slots = uniq(append2(super_slots, append2(static_slots, slots)));
@@ -415,9 +467,11 @@ val make_struct_type(val name, val supers,
     st->nslots = st->nstslots = 0;
     st->slots = all_slots;
     st->nsupers = nsupers;
+    st->ndsupers = ndsupers;
     st->supers = supers;
     st->stslot = 0;
     st->sus = sus;
+    st->dsus = dsus;
     st->stinitfun = static_initfun;
     st->initfun = initfun;
     st->boactor = boactor;
@@ -588,6 +642,7 @@ static void struct_type_destroy(val obj)
   free(st->stslot);
   free(st->spslot);
   free(st->sus);
+  free(st->dsus);
   free(st);
 }
 
@@ -615,28 +670,56 @@ static void struct_type_mark(val obj)
   }
 }
 
-static void call_initfun_chain(struct struct_type *st, val strct)
+static void call_initfun_chain(struct struct_type *st, val strct,
+                               struct struct_type *root, ucnum *seen)
 {
   if (st) {
     cnum i;
 
+    if (st != root)
+      for (i = 0; i < root->ndsupers; i++) {
+        if (st == root->dsus[i]) {
+          const int bits_ucnum = sizeof *seen * CHAR_BIT;
+          cnum index = i / bits_ucnum;
+          cnum bit = i % bits_ucnum;
+          ucnum mask = (ucnum) 1 << bit;
+          if ((seen[index] & mask) != 0)
+            return;
+          seen[index] |= mask;
+        }
+      }
+
     for (i = st->nsupers - 1; i >= 0; i--)
-      call_initfun_chain(st->sus[i], strct);
+      call_initfun_chain(st->sus[i], strct, root, seen);
     if (st->initfun)
       funcall1(st->initfun, strct);
   }
 }
 
-static void call_postinitfun_chain(struct struct_type *st, val strct)
+static void call_postinitfun_chain(struct struct_type *st, val strct,
+                                   struct struct_type *root, ucnum *seen)
 {
   if (st) {
     int derived_first = (opt_compat && opt_compat <= 148);
     cnum i;
 
+    if (st != root)
+      for (i = 0; i < root->ndsupers; i++) {
+        if (st == root->dsus[i]) {
+          const int bits_ucnum = sizeof *seen * CHAR_BIT;
+          cnum index = i / bits_ucnum;
+          cnum bit = i % bits_ucnum;
+          ucnum mask = (ucnum) 1 << bit;
+          if ((seen[index] & mask) != 0)
+            return;
+          seen[index] |= mask;
+        }
+      }
+
     if (derived_first && st->postinitfun)
       funcall1(st->postinitfun, strct);
     for (i = st->nsupers - 1; i >= 0; i--)
-      call_postinitfun_chain(st->sus[i], strct);
+      call_postinitfun_chain(st->sus[i], strct, root, seen);
     if (!derived_first && st->postinitfun)
       funcall1(st->postinitfun, strct);
   }
@@ -657,6 +740,15 @@ val allocate_struct(val type)
   return cobj(coerce(mem_t *, si), st->name, &struct_inst_ops);
 }
 
+#define alloc_seen(name, size_name)                                     \
+  const int bits_ucnum = sizeof (ucnum) * CHAR_BIT;                     \
+  size_t size_name = (st->ndsupers + bits_ucnum - 1) / bits_ucnum;      \
+  ucnum *name ## tmp = coerce(ucnum *, alloca(size_name));              \
+  ucnum *name = (memset(name ## tmp, 0, size_name), name ## tmp)
+
+#define clear_seen(name, size_name)                                     \
+  memset(name, 0, size_name)
+
 static val make_struct_impl(val self, val type,
                             struct args *plist, struct args *args)
 {
@@ -666,6 +758,7 @@ static val make_struct_impl(val self, val type,
   struct struct_inst *si = coerce(struct struct_inst *, chk_malloc(size));
   val sinst;
   volatile val inited = nil;
+  alloc_seen (seen, seensz);
 
   if (args_more(args, 0) && !st->boactor) {
     free(si);
@@ -687,7 +780,7 @@ static val make_struct_impl(val self, val type,
 
   uw_simple_catch_begin;
 
-  call_initfun_chain(st, sinst);
+  call_initfun_chain(st, sinst, st, seen);
 
   {
     cnum index = 0;
@@ -705,7 +798,9 @@ static val make_struct_impl(val self, val type,
     generic_funcall(st->boactor, args_copy);
   }
 
-  call_postinitfun_chain(st, sinst);
+  clear_seen(seen, seensz);
+
+  call_postinitfun_chain(st, sinst, st, seen);
 
   inited = t;
 
@@ -744,6 +839,7 @@ static void lazy_struct_init(val sinst, struct struct_inst *si)
   volatile val inited = nil;
   val cell = funcall(si->slot[0]);
   cons_bind (plist, args, cell);
+  alloc_seen (seen, seensz);
 
   si->slot[0] = nil;
 
@@ -755,7 +851,7 @@ static void lazy_struct_init(val sinst, struct struct_inst *si)
 
   uw_simple_catch_begin;
 
-  call_initfun_chain(st, sinst);
+  call_initfun_chain(st, sinst, st, seen);
 
   for (; plist; plist = cddr(plist))
     slotset(sinst, car(plist), cadr(plist));
@@ -765,7 +861,9 @@ static void lazy_struct_init(val sinst, struct struct_inst *si)
     generic_funcall(st->boactor, argv);
   }
 
-  call_postinitfun_chain(st, sinst);
+  clear_seen(seen, seensz);
+
+  call_postinitfun_chain(st, sinst, st, seen);
 
   inited = t;
 
@@ -909,6 +1007,7 @@ val reset_struct(val strct)
   cnum i;
   volatile val inited = nil;
   int compat_190 = opt_compat && opt_compat <= 190;
+  alloc_seen (seen, seensz);
 
   check_init_lazy_struct(strct, si);
 
@@ -917,10 +1016,12 @@ val reset_struct(val strct)
   for (i = 0; i < st->nslots; i++)
     si->slot[i] = nil;
 
-  call_initfun_chain(st, strct);
+  call_initfun_chain(st, strct, st, seen);
 
-  if (!compat_190)
-    call_postinitfun_chain(st, strct);
+  if (!compat_190) {
+    clear_seen(seen, seensz);
+    call_postinitfun_chain(st, strct, st, seen);
+  }
 
   inited = t;
 
diff --git a/txr.1 b/txr.1
index dea21da5..3d4c645b 100644
--- a/txr.1
+++ b/txr.1
@@ -26248,8 +26248,80 @@ methods are similarly invoked in right-to-left order, before the
 .code :postinit
 methods of the new type itself.
 Thus the order is: supertype inits, own inits, supertype post-inits,
-own post-inits.  If a supertype is referenced, directly or indirectly, two or
-more times, then its initializing expressions are evaluated that many times.
+own post-inits.
+
+.NP* Duplicate Supertypes
+Multiple inheritance makes it possible for a type to inherit the
+same supertype more than once, either directly (by naming it more than
+once as a direct supertype) or indirectly (by inheriting two or
+more different types, which have a common ancestor).
+The latter situation is sometimes referred to as the
+.IR "diamond problem" .
+
+Until \*(TX 242, the situation of duplicate supertypes was
+ignored for the purposes of object initialization. It was documented that if a
+supertype is referenced by inheritance, directly or indirectly, two or more
+times, then its initializing expressions are evaluated that many times.
+
+Starting in \*(TX 243, duplicate supertypes no longer give rise to duplicate
+initialization. When an object is instantiated, only one initialization of a
+duplicated supertype occurs. The subsequent initializations that would take
+place in the absence of duplicate detection are suppressed.
+
+.TP* Examples:
+
+Consider following program:
+
+.verb
+  (defstruct base ()
+    (:init (me) (put-line "base init")))
+
+  (defstruct d1 (base)
+    (:init (me) (put-line "d1 init")))
+
+  (defstruct d2 (base)
+    (:init (me) (put-line "d2 init")))
+
+  (defstruct s (d1 d2))
+
+  (new s)
+.brev
+
+Under \*(TX 242, and earlier versions that support multiple inheritance, it
+produces the output:
+
+.verb
+  base init
+  d2 init
+  base init
+  d1 init
+.brev
+
+The supertypes are initialized in a right-to-left traversal of the
+type lattice, without regard for
+.code base
+being duplicated.
+
+Starting with \*(TX 243, the output is:
+
+.verb
+  base init
+  d2 init
+  d1 init
+.brev
+
+The rightmost duplicate of the base is initialized, so that the initialization
+is complete prior to the initializations of any dependent types.
+
+Note, however, that the
+.code derived
+function function mechanism is not required to detect duplicated direct
+supertypes.
+If a supertype implements the
+.code derived
+function to detect situations when it is the target of inheritance,
+and some subtype inherits that type more than once, that function
+may be called more than once. The behavior is unspecified.
 
 .NP* Dirty Flags
 All structure instances contain a Boolean flag called the
@@ -29367,6 +29439,13 @@ The function is not retroactively invoked. If it is defined for
 a structure type from which subtypes have already been derived,
 it is not invoked for those existing subtypes.
 
+If
+.meta derived
+directly inherits
+.meta supertype
+more than once, it is not specified whether this function is called
+once, or multiple times.
+
 Note: the
 .meta supertype
 parameter exists because the
@@ -75262,6 +75341,14 @@ Compatibility values of 237 or lower restore the destructive behavior of the
 and
 .code shuffle
 functions.
+.IP 242
+In \*(TX 242 and older, the instantiation of an object whose type inherits
+from the same supertype more than once resulted in duplicate execution
+of the supertype's initialization. This was a documented behavior.
+After 242, duplicate initialization is suppressed. For more information, see
+the section
+.BR "Duplicate Supertypes" . A compatibility value of 242 or lower restores
+the duplicate initialization behavior.
 .IP 234
 In \*(TX 234 and older versions, the exception throwing functions
 .code throw