Merging branch/2014-10-01/finalize.

Copied from Perforce
 Change: 188932
 ServerID: perforce.ravenbrook.com

mps/code/apss.c

@@ -87,6 +87,14 @@ static mps_res_t stress(mps_arena_t arena, mps_pool_debug_option_s *options,
     check_allocated_size(pool, ap, allocated);
   }
 
+  /* Check introspection functions */
+  for (i = 0; i < NELEMS(ps); ++i) {
+    mps_pool_t addr_pool = NULL;
+    Insist(mps_arena_has_addr(arena, ps[i]));
+    Insist(mps_addr_pool(&addr_pool, arena, ps[i]));
+    Insist(addr_pool == pool);
+  }
+
   mps_pool_check_fenceposts(pool);
 
   for (k=0; k<testLOOPS; ++k) {

mps/code/arena.c

@@ -1450,10 +1450,10 @@ static void ArenaTrivCompact(Arena arena, Trace trace)
 
 Bool ArenaHasAddr(Arena arena, Addr addr)
 {
-  Seg seg;
+  Tract tract;
 
   AVERT(Arena, arena);
-  return SegOfAddr(&seg, arena, addr);
+  return TractOfAddr(&tract, arena, addr);
 }
 
 

mps/code/finalcv.c

@@ -24,6 +24,9 @@
 #include "mps.h"
 #include "mpsavm.h"
 #include "mpscamc.h"
+#include "mpscams.h"
+#include "mpscawl.h"
+#include "mpsclo.h"
 #include "mpslib.h"
 #include "mpstd.h"
 #include "testlib.h"
@@ -37,6 +40,7 @@
 #define finalizationRATE 6
 #define gcINTERVAL ((size_t)150 * 1024)
 #define collectionCOUNT 3
+#define messageCOUNT 3
 
 /* 3 words:  wrapper  |  vector-len  |  first-slot */
 #define vectorSIZE (3*sizeof(mps_word_t))
@@ -95,35 +99,37 @@ enum {
 };
 
 
-static void *test(void *arg, size_t s)
+static void test(mps_arena_t arena, mps_pool_class_t pool_class)
 {
-  unsigned i;                        /* index */
+  size_t i;                     /* index */
   mps_ap_t ap;
   mps_fmt_t fmt;
   mps_chain_t chain;
-  mps_pool_t amc;
+  mps_pool_t pool;
   mps_res_t e;
   mps_root_t mps_root[2];
   mps_addr_t nullref = NULL;
   int state[rootCOUNT];
-  mps_arena_t arena;
-  void *p = NULL;
   mps_message_t message;
+  size_t messages = 0;
+  void *p;
 
-  arena = (mps_arena_t)arg;
-  (void)s;
+  printf("---- finalcv: pool class %s ----\n", pool_class->name);
 
   die(mps_fmt_create_A(&fmt, arena, dylan_fmt_A()), "fmt_create\n");
   die(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
-  die(mps_pool_create(&amc, arena, mps_class_amc(), fmt, chain),
-      "pool_create amc\n");
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_CHAIN, chain);
+    MPS_ARGS_ADD(args, MPS_KEY_FORMAT, fmt);
+    die(mps_pool_create_k(&pool, arena, pool_class, args), "pool_create\n");
+  } MPS_ARGS_END(args);
   die(mps_root_create_table(&mps_root[0], arena, mps_rank_exact(), (mps_rm_t)0,
                             root, (size_t)rootCOUNT),
       "root_create\n");
   die(mps_root_create_table(&mps_root[1], arena, mps_rank_exact(), (mps_rm_t)0,
                             &p, (size_t)1),
       "root_create\n");
-  die(mps_ap_create(&ap, amc, mps_rank_exact()), "ap_create\n");
+  die(mps_ap_create(&ap, pool, mps_rank_exact()), "ap_create\n");
 
   /* Make registered-for-finalization objects. */
   /* <design/poolmrg/#test.promise.ut.alloc> */
@@ -142,12 +148,10 @@ static void *test(void *arg, size_t s)
   }
   p = NULL;
 
-  die(ArenaDescribe(arena, mps_lib_get_stdout(), 0), "ArenaDescribe");
-
   mps_message_type_enable(arena, mps_message_type_finalization());
 
   /* <design/poolmrg/#test.promise.ut.churn> */
-  while (mps_collections(arena) < collectionCOUNT) {
+  while (messages < messageCOUNT && mps_collections(arena) < collectionCOUNT) {
     
     /* Perhaps cause (minor) collection */
     churn(ap);
@@ -197,36 +201,34 @@ static void *test(void *arg, size_t s)
       if (rnd() % 2 == 0)
         root[objind] = objaddr;
       mps_message_discard(arena, message);
+      ++ messages;
     }
   }
 
-  /* @@@@ <design/poolmrg/#test.promise.ut.nofinal.check> missing */
-
-  mps_arena_park(arena);
   mps_ap_destroy(ap);
   mps_root_destroy(mps_root[1]);
   mps_root_destroy(mps_root[0]);
-  mps_pool_destroy(amc);
+  mps_pool_destroy(pool);
   mps_chain_destroy(chain);
   mps_fmt_destroy(fmt);
-
-  return NULL;
 }
 
 
 int main(int argc, char *argv[])
 {
   mps_arena_t arena;
-  mps_thr_t thread;
-  void *r;
 
   testlib_init(argc, argv);
 
   die(mps_arena_create(&arena, mps_arena_class_vm(), testArenaSIZE),
       "arena_create\n");
-  die(mps_thread_reg(&thread, arena), "thread_reg\n");
-  mps_tramp(&r, test, arena, 0);
-  mps_thread_dereg(thread);
+
+  test(arena, mps_class_amc());
+  test(arena, mps_class_amcz());
+  test(arena, mps_class_awl());
+  test(arena, mps_class_ams());
+  test(arena, mps_class_lo());
+
   mps_arena_destroy(arena);
 
   printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);

mps/code/global.c

@@ -862,17 +862,19 @@ Bool ArenaStep(Globals globals, double interval, double multiplier)
 Res ArenaFinalize(Arena arena, Ref obj)
 {
   Res res;
+  Pool refpool;
 
   AVERT(Arena, arena);
-  AVER(ArenaHasAddr(arena, (Addr)obj));
+  AVER(PoolOfAddr(&refpool, arena, (Addr)obj));
+  AVER(PoolHasAttr(refpool, AttrGC));
 
   if (!arena->isFinalPool) {
-    Pool pool;
+    Pool finalpool;
 
-    res = PoolCreate(&pool, arena, PoolClassMRG(), argsNone);
+    res = PoolCreate(&finalpool, arena, PoolClassMRG(), argsNone);
     if (res != ResOK)
       return res;
-    arena->finalPool = pool;
+    arena->finalPool = finalpool;
     arena->isFinalPool = TRUE;
   }
 

mps/code/mpsicv.c

@@ -233,6 +233,7 @@ static void ap_create_v_test(mps_pool_t pool, ...)
 /* addr_pool_test
  *
  * intended to test:
+ *   mps_arena_has_addr
  *   mps_addr_pool
  *   mps_addr_fmt
  */
@@ -270,6 +271,7 @@ static void addr_pool_test(mps_arena_t arena,
   addr = obj1;
   pool = poolDistinguished;
   fmt = fmtDistinguished;
+  cdie(mps_arena_has_addr(arena, addr), "mps_arena_has_addr 0a");
   b = mps_addr_pool(&pool, arena, addr);
   /* printf("b %d; pool %p; sig %lx\n", b, (void *)pool,
             b ? ((mps_word_t*)pool)[0] : (mps_word_t)0); */
@@ -283,6 +285,7 @@ static void addr_pool_test(mps_arena_t arena,
   addr = obj2;
   pool = poolDistinguished;
   fmt = fmtDistinguished;
+  cdie(mps_arena_has_addr(arena, addr), "mps_arena_has_addr 0b");
   b = mps_addr_pool(&pool, arena, addr);
   /* printf("b %d; pool %p; sig %lx\n", b, (void *)pool,
             b ? ((mps_word_t*)pool)[0] : (mps_word_t)0); */
@@ -296,6 +299,7 @@ static void addr_pool_test(mps_arena_t arena,
   addr = &pool;  /* point at stack, not in any chunk */
   pool = poolDistinguished;
   fmt = fmtDistinguished;
+  cdie(mps_arena_has_addr(arena, addr) == FALSE, "mps_arena_has_addr 5");
   b = mps_addr_pool(&pool, arena, addr);
   cdie(b == FALSE && pool == poolDistinguished, "mps_addr_pool 5");
   b = mps_addr_fmt(&fmt, arena, addr);

mps/code/poolmrg.c

@@ -745,7 +745,12 @@ Res MRGRegister(Pool pool, Ref ref)
 }
 
 
-/* MRGDeregister -- deregister (once) an object for finalization */
+/* MRGDeregister -- deregister (once) an object for finalization
+ *
+ * TODO: Definalization loops over all finalizable objects in the heap,
+ * and so using it could accidentally be disastrous for performance.
+ * See job003953 and back out changelist 187123 if this is fixed.
+ */
 
 Res MRGDeregister(Pool pool, Ref obj)
 {

mps/design/poolmrg.txt

@@ -630,10 +630,6 @@ All objects from the MRG pool will then be freed (thus dropping all
 references to the AMC objects). This will test `.promise.faithful`_
 and `.promise.live`_.
 
-_`.test.promise.ut.not`: The following part of the test has not
-implemented. This is because the messaging system has not yet been
-implemented.
-
 _`.test.promise.ut.alloc`: A number of objects will be allocated in
 the AMC pool.
 

mps/example/scheme/scheme-advanced.c

@@ -991,22 +991,12 @@ static char *symbol_name(obj_t symbol)
 }
 
 
-/* port_close -- close and definalize a port                         %%MPS
- *
- * Ports objects are registered for finalization when they are created
- * (see make_port). When closed, we definalize them. This is purely an
- * optimization: it would be harmless to finalize them because setting
- * 'stream' to NULL prevents the stream from being closed multiple
- * times. See topic/finalization.
- */
 static void port_close(obj_t port)
 {
   assert(TYPE(port) == TYPE_PORT);
   if(port->port.stream != NULL) {
-    mps_addr_t port_ref = port;
     fclose(port->port.stream);
     port->port.stream = NULL;
-    mps_definalize(arena, &port_ref);
   }
 }
 

mps/example/scheme/scheme.c

@@ -1017,22 +1017,12 @@ static void table_delete(obj_t tbl, obj_t key)
 }
 
 
-/* port_close -- close and definalize a port                         %%MPS
- *
- * Ports objects are registered for finalization when they are created
- * (see make_port). When closed, we definalize them. This is purely an
- * optimization: it would be harmless to finalize them because setting
- * 'stream' to NULL prevents the stream from being closed multiple
- * times. See topic/finalization.
- */
 static void port_close(obj_t port)
 {
   assert(TYPE(port) == TYPE_PORT);
   if(port->port.stream != NULL) {
-    mps_addr_t port_ref = port;
     fclose(port->port.stream);
     port->port.stream = NULL;
-    mps_definalize(arena, &port_ref);
   }
 }
 

mps/manual/source/guide/advanced.rst

@@ -28,14 +28,6 @@ call ``close-input-file``, then the underlying file handle should still
 be closed when the port object :term:`dies <dead>`. This procedure is
 known as :term:`finalization`.
 
-.. note::
-
-    It's generally a bad idea to depend on finalization to release your
-    resources (see the :ref:`topic-finalization-cautions` section in
-    :ref:`topic-finalization`). Treat it as a last resort when more
-    reliable mechanisms for releasing resources (like Scheme's
-    ``with-open-input-file``) aren't available.
-
 Any block in an :term:`automatically managed <automatic memory
 management>` :term:`pool` can be registered for finalization by calling
 :c:func:`mps_finalize`. In the toy Scheme interpreter, this can be done
@@ -138,26 +130,37 @@ Here's an example session showing finalization taking place:
         not_condemned 0
         clock: 3807
 
-The toy Scheme interpreter :dfn:`definalizes` ports by calling
-:c:func:`mps_definalize` when they are closed. This is purely an
-optimization: setting ``stream`` to ``NULL`` ensures that the file
-handle wouldn't be closed more than once, even if the port object were
-later finalized.
+It's wise not to depend on finalization as the only method for
+releasing resources (see the :ref:`topic-finalization-cautions`
+section in :ref:`topic-finalization`), because the garbage collector
+does not promise to collect particular objects at particular times,
+and in any case it does so only when it can prove that the object is
+:term:`dead`. So it is best to provide a reliable mechanism for
+releasing the resource (here, the Scheme function
+``close-input-port``), and use finalization as a backup strategy.
+
+But this raises the possibility that a port will be closed twice: once
+via ``close-input-port`` and a second time via finalization. So it's
+necessary to make ports robust against be closed multiple times. The
+toy Scheme interpreter does so by setting ``stream`` to ``NULL``: this
+ensures that the file handle won't be closed more than once.
 
 .. code-block:: c
-    :emphasize-lines: 8
+    :emphasize-lines: 6
 
     static void port_close(obj_t port)
     {
         assert(TYPE(port) == TYPE_PORT);
         if(port->port.stream != NULL) {
-            mps_addr_t port_ref = port;
             fclose(port->port.stream);
             port->port.stream = NULL;
-            mps_definalize(arena, &port_ref);
         }
     }
 
+Note that because finalization messages are processed synchronously
+via the message queue (and the Scheme interpreter is single-threaded)
+there is no need for a lock here.
+
 It's still possible that the toy Scheme interpreter might run out of
 open file handles despite having some or all of its port objects being
 finalizable. That's because the arena's message queue is only polled

mps/manual/source/release.rst

@@ -65,6 +65,18 @@ Other changes
    
    .. _job003899: https://www.ravenbrook.com/project/mps/issue/job003899/
 
+#. Unfinalizable objects can no longer be registered for finalization.
+   Previously the objects would be registered but never finalized. See
+   job003865_.
+
+   .. _job003865: https://www.ravenbrook.com/project/mps/issue/job003865/
+
+#. :c:func:`mps_arena_has_addr` now returns the correct result for
+   objects allocated from the :ref:`pool-mfs`, :ref:`pool-mv`, and
+   :ref:`pool-mvff` pools. See job003866_.
+
+   .. _job003866: https://www.ravenbrook.com/project/mps/issue/job003866/
+
 
 .. _release-notes-1.114:
 

mps/manual/source/topic/error.rst

@@ -300,6 +300,13 @@ this documentation.
     It is necessary to call :c:func:`mps_pool_destroy` first.
 
 
+``global.c: PoolHasAttr(pool, AttrGC)``
+
+    The client program called :c:func:`mps_finalize` on a reference
+    that does not belong to an :term:`automatically managed <automatic
+    memory management>` :term:`pool`.
+
+
 ``lockix.c: res == 0``
 
 ``lockw3.c: lock->claims == 0``

mps/manual/source/topic/finalization.rst

@@ -221,10 +221,8 @@ Finalization interface
     :term:`result code` if not.
 
     This function registers the block pointed to by ``*ref_p`` for
-    finalization. This block must have been allocated from a
-    :term:`pool` in ``arena``. Violations of this constraint may not
-    be checked by the MPS, and may be unsafe, causing the MPS to crash
-    in undefined ways.
+    finalization. This block must have been allocated from an
+    automatically managed :term:`pool` in ``arena``.
 
     .. note::
 
@@ -252,6 +250,13 @@ Finalization interface
         avoid placing the restriction on the :term:`client program`
         that the C call stack be a :term:`root`.
 
+    .. warning::
+
+        Definalization is not yet efficient: the current
+        implementation just loops over all finalized objects. If you
+        need efficient definalization, please :ref:`contact us
+        <contact>`.
+
 
 .. index::
    pair: finalization; message

mps/test/function/228.c

@@ -0,0 +1,41 @@
+/* 
+TEST_HEADER
+ id = $Id$
+ summary = can't register unfinalizable objects for finalization
+ language = c
+ link = testlib.o
+OUTPUT_SPEC
+ assert = true
+ assertfile P= global.c
+ assertcond = PoolHasAttr(refpool, AttrGC)
+END_HEADER
+*/
+
+#include "testlib.h"
+#include "mpscmvff.h"
+#include "mpsavm.h"
+
+static void test(void)
+{
+  mps_arena_t arena;
+  mps_pool_t pool;
+  mps_addr_t p;
+
+  die(mps_arena_create_k(&arena, mps_arena_class_vm(), mps_args_none),
+      "arena_create");
+  die(mps_pool_create_k(&pool, arena, mps_class_mvff(), mps_args_none),
+      "pool_create");
+  die(mps_alloc(&p, pool, 4096), "alloc");
+  die(mps_finalize(arena, &p), "finalize");
+
+  mps_pool_destroy(pool);
+  mps_arena_destroy(arena);
+}
+
+
+int main(void)
+{
+  easy_tramp(test);
+  pass();
+  return 0;
+}

mps/test/testsets/passing

@@ -168,4 +168,5 @@ function/224.c
 % 225 -- no such test
 function/226.c
 function/227.c
-function/229.c
+function/228.c
+function/229.c