diff --git a/code/addrobj.c b/code/addrobj.c new file mode 100644 index 0000000000..f4fe524771 --- /dev/null +++ b/code/addrobj.c @@ -0,0 +1,240 @@ +/* addrobj.c: BASE ADDRESS FROM INTERIOR POINTER TEST + * + * Copyright (c) 2023 Ravenbrook Limited. See end of file for license. + * + * .overview This test is for mps_addr_object(). Its intention is to + * verify that the function returns the appropriate base pointer to an + * object when provided with an interior pointer. It also tests that the + * function fails appropriately when the provided with a pointer to + * unmanaged memory, or to an object in a pool that doesn't support this + * feature. + * + * .limitations Objects that have been moved should cause the function to + * fail with MPS_RES_FAIL, however this is not tested. It could be tested if + * a testbench deliberately created a forwarding object, however this might + * confuse a pool that does automatic garbage collection such as AMC or AMCZ, + * so any such test would need to be designed to handle that. + * This test only examines behaviour in AMCZ and MVFF pools, i.e. A pool (AMCZ) + * which currently implements mps_addr_object() and one (MVFF) that doesn't. + */ + +#include "mps.h" +#include "testlib.h" +#include "fmtdy.h" +#include "fmtdytst.h" +#include "mpsavm.h" +#include "mpscamc.h" +#include "mpscmvff.h" +#include "stdio.h" +#include + +/* Define an object size to allocate. The size chosen doesn't matter much, except that this testbench assumes + that the object is large enough that a pointer could point to the interior of the object, without also + pointing to the base pointer of the object at the same time. For char pointers, this is probably 2 bytes. + Since we are using the Dylan library, we define the size of the object in terms of Dylan slots. See + fmtdytst.c for details of the Dylan object structure.*/ +#define N_SLOT_TESTOBJ 100 + +static void test_main(void) +{ + mps_arena_t arena; + mps_pool_t amcz_pool, mvff_pool; + mps_ap_t obj_ap; + mps_fmt_t obj_fmt; + mps_root_t testobj_root; + mps_res_t res; + /* In another testbench (extcon.c) we observed unreliable failures to do with registering the cold end + of the stack. See GitHub issue #210 + . For now, we + declare this as a separate root. */ + static mps_addr_t testobj; + mps_addr_t out, in; + + /* Create arena */ + die(mps_arena_create_k(&arena, mps_arena_class_vm(), mps_args_none), "mps_arena_create_k"); + + + /* INTRO TO TESTS: There are several tests. They test the expected "normal" operation of the + function, using an interior pointer, also corner cases where the interior pointer equals the + base pointer, where it equals the limit pointer. We also test asking about an address in unmanaged + memory, and about an address in a pool which currently does not support mps_addr_object. If you write + more tests, describe them here.*/ + + + /* TEST 1: Test using an interior pointer in an object in an AMCZ pool. + At the time of writing this test, the AMCZ pool is the only pool where + there exists a requirement to provide base addresses from interior pointers. + Currently, the AMCZ pool (and by extension, the AMC pool which shares the same + module as AMCZ) is the only pool for which mps_addr_object is implemented */ + + /* Use the dylan format for convenience */ + die(dylan_fmt(&obj_fmt, arena), "dylan_fmt"); + + /* Create the pool */ + MPS_ARGS_BEGIN(args) { + MPS_ARGS_ADD(args, MPS_KEY_FORMAT, obj_fmt); + die(mps_pool_create_k(&amcz_pool, arena, mps_class_amcz(), args), "mps_pool_create_k amcz"); + } MPS_ARGS_END(args); + + /* Create an area of ambiguous pointers to keep the object alive and in place, in this case + the area only contains room for a single reference since we are only using one object to test */ + die(mps_root_create_area(&testobj_root, arena, + mps_rank_ambig(), (mps_rm_t)0, + &testobj, &testobj+1, + mps_scan_area, NULL), + "mps_root_create_area"); + + /* Create the allocation point */ + die(mps_ap_create_k(&obj_ap, amcz_pool, mps_args_none), "mps_ap_create_k"); + + /* Make a Dylan object, size = (N_SLOT_TESTOBJ+2) * sizeof(mps_word_t). + (See fmtdytst.c for size calculation) */ + { + /* Because make_dylan_vector returns its pointer-to-object as an mps_word_t rather than an + mps_addr_t, and commits the object, we need to somehow safely allocate our object without + type punning and without risking that our object be destroyed. + Rather than redefine our reference table with type mps_word_t, which hides the intention of the table, + park the arena to disable garbage collection. Allocate our dylan object on the (unregistered) stack + storing its address in an mps_word_t. Then store this mps_word_t as an mps_addr_t in our reference + table, and release the arena since our object is now safely pinned. + Another approach would be to create another static registered root for ambiguous references of type + mps_word_t and then copy to the mps_addr_t root, which would avoid needing to park the arena. + */ + mps_word_t p_word; + mps_arena_park(arena); + die(make_dylan_vector(&p_word, obj_ap, N_SLOT_TESTOBJ), "make_dylan_vector"); + /* If we hadn't parked the arena, our vector might have been GC'd here */ + testobj = (mps_addr_t)p_word; + mps_arena_release(arena); + } + + /* Construct a pointer to roughly halfway inside the object */ + in = (mps_addr_t)((char *)testobj + (N_SLOT_TESTOBJ/2) * sizeof(mps_word_t)); + + /* Ensure that this is an interior pointer, and not the base pointer, + since we want to make sure we are testing with a true interior pointer and not + one that also happens to be the base pointer. This Insist is intended to protect + against the testbench losing its ability to test "true" interior pointers (i.e. ones + which don't match the base pointer) if the test object sizes were changed to be very + small. Note that we don't currently consider the "limit" of the object as a corner case + (so we don't Insist(in != limit) ) but we do consider limit+1, i.e. the pointer to the + next object to be a corner case. This test could be updated to consider in == limit as a + corner case. */ + Insist(in > testobj); + + /* Do Test */ + res = mps_addr_object(&out, arena, in); + Insist(out == testobj); + Insist(res == MPS_RES_OK); + printf("Interior pointer input: passed\n"); + + + /* TEST 2: Test using the base pointer itself as an input*/ + + in = testobj; + + /* Do Test */ + res = mps_addr_object(&out, arena, in); + Insist(out == testobj); + Insist(res == MPS_RES_OK); + printf("Base pointer input: passed\n"); + + + + /* TEST 3: Test using a pointer one-off-the-end of the object*/ + + in = (mps_addr_t)((char *)testobj + (N_SLOT_TESTOBJ + 2) * sizeof(mps_word_t)); + + /* Do Test */ + res = mps_addr_object(&out, arena, in); + Insist(res == MPS_RES_FAIL); + printf("Pointer to next object input: passed\n"); + + + /* Clean up from above tests */ + mps_root_destroy(testobj_root); + mps_ap_destroy(obj_ap); + mps_pool_destroy(amcz_pool); + mps_fmt_destroy(obj_fmt); + + + /* TEST 4: Test using a pointer in unmanaged memory */ + + /* Use malloc to allocate non-mps-managed memory on the heap */ + in = malloc(sizeof(mps_word_t)); + Insist(NULL != in); + + /* Do the test */ + res = mps_addr_object(&out, arena, in); + + /* Expect MPS to fail to find a base pointer for addresses not in managed memory */ + Insist(res == MPS_RES_FAIL); + printf("Pointer to unmanaged memory input: passed\n"); + + /* clean up from this test */ + if (NULL != in) + free(in); + + + /* TEST 5: Test using a pointer in a pool which currently doesn't implement mps_addr_object */ + + /* Create mvff pool for which mps_addr_object is not implemented */ + die(mps_pool_create_k(&mvff_pool, arena, mps_class_mvff(), mps_args_none), "mps_pool_create_k mvff"); + + /* allocate an object (just some memory) in this pool */ + die(mps_alloc(&in, mvff_pool, sizeof(mps_word_t)), "mps_alloc"); + + /* Do the test */ + res = mps_addr_object(&out, arena, in); + + Insist(res == MPS_RES_UNIMPL); + printf("Pointer to object in pool where mps_addr_object not implemented: passed\n"); + + + /* If more tests are added here, briefly describe them above under "INTRO TO TESTS" comment */ + + /* Final clean up */ + mps_free(mvff_pool, in, sizeof(mps_word_t)); + mps_pool_destroy(mvff_pool); + mps_arena_destroy(arena); +} + +int main(int argc, char *argv[]) +{ + testlib_init(argc, argv); + + test_main(); + + printf("%s: Conculsion, failed to find any defects.\n", argv[0]); + + return 0; +} + +/* C. COPYRIGHT AND LICENSE + * + * Copyright (C) 2022-2023 Ravenbrook Limited . + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the + * distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + * HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ diff --git a/code/arena.c b/code/arena.c index 32de9f0aec..7139ff4bc8 100644 --- a/code/arena.c +++ b/code/arena.c @@ -1364,6 +1364,22 @@ Bool ArenaHasAddr(Arena arena, Addr addr) return TractOfAddr(&tract, arena, addr); } +/* ArenaAddrObject -- return base pointer of managed object */ +Res ArenaAddrObject(Addr *pReturn, Arena arena, Addr addr) +{ + Tract tract; + + AVER(pReturn != NULL); + AVERT(Arena, arena); + + if (!TractOfAddr(&tract, arena, addr)) { + /* address does not belong to the arena */ + return ResFAIL; + } + + return PoolAddrObject(pReturn, TractPool(tract), addr); +} + /* C. COPYRIGHT AND LICENSE * diff --git a/code/comm.gmk b/code/comm.gmk index 390ec78550..d702765bfc 100644 --- a/code/comm.gmk +++ b/code/comm.gmk @@ -254,6 +254,7 @@ LIB_TARGETS=mps.a mpsplan.a TEST_TARGETS=\ abqtest \ + addrobj \ airtest \ amcss \ amcsshe \ @@ -272,6 +273,7 @@ TEST_TARGETS=\ finalcv \ finaltest \ forktest \ + forth \ fotest \ gcbench \ landtest \ @@ -448,6 +450,9 @@ ifdef VARIETY $(PFM)/$(VARIETY)/abqtest: $(PFM)/$(VARIETY)/abqtest.o \ $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a +$(PFM)/$(VARIETY)/addrobj: $(PFM)/$(VARIETY)/addrobj.o \ + $(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a + $(PFM)/$(VARIETY)/airtest: $(PFM)/$(VARIETY)/airtest.o \ $(FMTSCMOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a @@ -502,6 +507,9 @@ $(PFM)/$(VARIETY)/finaltest: $(PFM)/$(VARIETY)/finaltest.o \ $(PFM)/$(VARIETY)/forktest: $(PFM)/$(VARIETY)/forktest.o \ $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a +$(PFM)/$(VARIETY)/forth: $(PFM)/$(VARIETY)/forth.o \ + $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a + $(PFM)/$(VARIETY)/fotest: $(PFM)/$(VARIETY)/fotest.o \ $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a diff --git a/code/commpost.nmk b/code/commpost.nmk index e3993899ba..0018bc4ad6 100644 --- a/code/commpost.nmk +++ b/code/commpost.nmk @@ -177,6 +177,9 @@ $(PFM)\cool\mps.lib: $(MPMOBJ) $(PFM)\$(VARIETY)\abqtest.exe: $(PFM)\$(VARIETY)\abqtest.obj \ $(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ) +$(PFM)\$(VARIETY)\addrobj.exe: $(PFM)\$(VARIETY)\addrobj.obj \ + $(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ) + $(PFM)\$(VARIETY)\airtest.exe: $(PFM)\$(VARIETY)\airtest.obj \ $(PFM)\$(VARIETY)\mps.lib $(FMTSCHEMEOBJ) $(TESTLIBOBJ) @@ -231,6 +234,9 @@ $(PFM)\$(VARIETY)\finalcv.exe: $(PFM)\$(VARIETY)\finalcv.obj \ $(PFM)\$(VARIETY)\finaltest.exe: $(PFM)\$(VARIETY)\finaltest.obj \ $(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ) +$(PFM)\$(VARIETY)\finaltest.exe: $(PFM)\$(VARIETY)\forth.obj \ + $(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ) + $(PFM)\$(VARIETY)\fotest.exe: $(PFM)\$(VARIETY)\fotest.obj \ $(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ) diff --git a/code/commpre.nmk b/code/commpre.nmk index 082ea5cc06..acc4bac1d0 100644 --- a/code/commpre.nmk +++ b/code/commpre.nmk @@ -59,6 +59,7 @@ LIB_TARGETS=mps.lib TEST_TARGETS=\ abqtest.exe \ + addrobj.exe \ airtest.exe \ amcss.exe \ amcsshe.exe \ @@ -76,6 +77,7 @@ TEST_TARGETS=\ extcon.exe \ finalcv.exe \ finaltest.exe \ + forth.exe \ fotest.exe \ gcbench.exe \ landtest.exe \ diff --git a/code/forth.c b/code/forth.c new file mode 100644 index 0000000000..6a737a6606 --- /dev/null +++ b/code/forth.c @@ -0,0 +1,658 @@ +/* ========= + * Fix Forth + * ========= + * + * :Author: Richard Brooksby + * :Date: 2023-05-16 + */ + +#include "mps.h" +#include "mpsavm.h" +#include "mpscamc.h" +#include "testlib.h" + +#include +#include +#include +#include +#include + + +/* Abstract machine core + ===================== */ + + +/* Objects + * ------- + * + * An object is any structure with a prefix compatible with obj_s, the + * first field of which is a pointer to a type object that describes + * it. Types, being objects, have a prefix compatible with obj_s + * whose first field points to the type of types. + */ + +#define OBJ_ALIGN sizeof(obj_t) + +typedef struct obj_s *obj_t; + +typedef struct type_s *type_t; +typedef struct type_s { + type_t type; /* == &type_type */ + const char *name; /* printable name of type */ + mps_res_t (*scan)(mps_ss_t, obj_t); + mps_addr_t (*skip)(mps_addr_t); +} type_s; + +typedef struct obj_s { + type_t type; /* object type */ +} obj_s; + +static mps_res_t obj_scan(mps_ss_t ss, obj_t obj) +{ + MPS_SCAN_BEGIN(ss) { + mps_res_t res; + mps_addr_t addr = obj->type; + res = MPS_FIX12(ss, &addr); + if (res != MPS_RES_OK) return res; + obj->type = addr; + } MPS_SCAN_END(ss); + return MPS_RES_OK; +} + +static mps_addr_t type_skip(mps_addr_t addr) +{ + return (char *)addr + sizeof(type_s); +} + +static type_s type_type = { + &type_type, + "type", + obj_scan, /* type_s has no other scannable fields */ + type_skip +}; + + +/* Object format for MPS */ + +static mps_addr_t fmt_skip(mps_addr_t addr) +{ + return ((obj_t)addr)->type->skip(addr); +} + +static mps_res_t fmt_scan(mps_ss_t ss, mps_addr_t base, mps_addr_t limit) +{ + while (base < limit) { + mps_res_t res = ((obj_t)base)->type->scan(ss, base); + if (res != MPS_RES_OK) + return res; + base = fmt_skip(base); + } + return MPS_RES_OK; +} + +typedef struct fwd_s *fwd_t; +typedef struct fwd_s { + type_t type; /* == &type_fwd */ + mps_addr_t new; /* where the object has been moved */ + size_t size; /* size of this fwd object */ +} fwd_s; + +static mps_addr_t fwd_skip(mps_addr_t addr) +{ + return (char *)addr + ((fwd_t)addr)->size; +} + +static type_s fwd_type = { + &type_type, + "fwd", + obj_scan, /* fwd has no scannable fields */ + fwd_skip +}; + +typedef struct fwd2_s *fwd2_t; +typedef struct fwd2_s { + type_t type; /* == &type_fwd */ + mps_addr_t new; /* where the object has been moved */ +} fwd2_s; + +static mps_addr_t fwd2_skip(mps_addr_t addr) +{ + return (char *)addr + sizeof(fwd2_s); +} + +static type_s fwd2_type = { + &type_type, + "fwd2", + obj_scan, /* fwd has no scannable fields */ + fwd2_skip +}; + +static void fmt_fwd(mps_addr_t old, mps_addr_t new) +{ + obj_t obj = old; + mps_addr_t limit = fmt_skip(old); + size_t size = (size_t)((char *)limit - (char *)old); + assert(size >= alignUp(sizeof(fwd2_s), OBJ_ALIGN)); + if (size == alignUp(sizeof(fwd2_s), OBJ_ALIGN)) { + obj->type = &fwd2_type; + ((fwd2_t)obj)->new = new; + } else { + obj->type = &fwd_type; + ((fwd_t)obj)->new = new; + ((fwd_t)obj)->size = size; + } +} + +static mps_addr_t fmt_isfwd(mps_addr_t addr) +{ + obj_t obj = addr; + if (obj->type == &fwd_type) + return ((fwd_t)obj)->new; + else if (obj->type == &fwd2_type) + return ((fwd2_t)obj)->new; + else + return NULL; +} + +typedef struct pad_s *pad_t; +typedef struct pad_s { + type_t type; /* == &type_pad */ + size_t size; /* size of padding object */ +} pad_s; + +static mps_addr_t pad_skip(mps_addr_t addr) +{ + return (char *)addr + ((pad_t)addr)->size; +} + +static type_s type_pad = { + &type_type, + "pad", + obj_scan, /* padding does not have scannable fields */ + pad_skip +}; + +static void fmt_pad(mps_addr_t addr, size_t size) +{ + obj_t obj = addr; + assert(size >= alignUp(sizeof(pad_s), OBJ_ALIGN)); + obj->type = &type_pad; + ((pad_t)obj)->size = size; +} + + +/* Abstract machine state objects + * + * A state is all that is required to run the abstract machine. It is + * equivalent to processor registers of a real machine. + * + * A state cannot be allocated on the garbage collected heap for two + * reasons: + * + * 1. it is the root for garbage collection + * + * 2. the compiled C code must be able to make transfers between + * state fields freely and safely, without the risk of losing a + * root to an incremental GC, just as a real processor can + * transfer values between registers without hitting a memory + * protection barrier. + * + * To ensure that access to state fields can't be optimised away and + * hidden from the GC, all state objects should be volatile: + * + * Since variables marked as volatile are prone to change outside + * the standard flow of code, the compiler has to perform every read + * and write to the variable as indicated by the code. Any access to + * volatile variables cannot be optimised away, e.g. by use of + * registers for storage of intermediate values. + * + * -- Wikipedia + * + * FIXME: mps_reserve discards the volatile qualifier. + */ + +#define STATE_NR 3 + +typedef /* volatile */ struct state_s *state_t; +typedef void (*entry_t)(state_t); +typedef struct state_s { + type_t type; /* == &type_state */ + obj_t rands; /* operand stack, a list of objects */ + obj_t rators; /* operator (return) stack, a list of closures */ + obj_t dictionary; /* dictonary of words (environment) */ + entry_t pc; /* program counter */ + mps_pool_t pool; /* heap memory pool */ + mps_ap_t ap; /* allocation point */ + void *baby; /* newly-born object pointer TODO: explain purpose */ + obj_t reg[STATE_NR]; /* registers */ +} state_s; + +static mps_res_t state_scan(mps_ss_t ss, obj_t obj) +{ + state_t state = (state_t)obj; + +#define FIX(ref) \ + do { \ + mps_addr_t _addr = (ref); \ + mps_res_t res = MPS_FIX12(ss, &_addr); \ + if (res != MPS_RES_OK) return res; \ + (ref) = _addr; \ + } while(0) + + MPS_SCAN_BEGIN(ss) { + size_t i; + FIX(state->type); + FIX(state->rands); + FIX(state->rators); + FIX(state->dictionary); + FIX(state->baby); + for (i = 0; i < sizeof(state->reg) / sizeof(state->reg[0]); ++i) + FIX(state->reg[i]); + } MPS_SCAN_END(ss); + +#undef FIX + + return MPS_RES_OK; +} + +static mps_addr_t state_skip(mps_addr_t addr) +{ + return (char *)addr + sizeof(state_s); +} + +static struct type_s type_state = { + &type_type, + "state", + state_scan, + state_skip +}; + +/* run -- run the abstract machine */ + +static void run(state_t state) +{ + for (;;) + state->pc(state); +} + + +/* Special objects + * + * Special objects are singleton types used for various special + * purposes. They contain their own name -- their printed + * representation. + * + * An example is the empty list, list_empty, printed "()". + */ + +typedef struct special_s *special_t; +typedef struct special_s { + type_t type; /* == &type_special */ + const char *name; /* printable name of special object */ +} special_s; + +static mps_addr_t special_skip(mps_addr_t addr) +{ + return (char *)addr + sizeof(special_s); +} + +static type_s type_special = { + &type_type, + "special", + obj_scan, /* special_s has no other scannable fields */ + special_skip +}; + +static special_s list_empty = { + &type_special, + "()" +}; + + +/* Pair objects, used to make Lisp-style lists */ + +typedef struct pair_s *pair_t; +typedef struct pair_s { + type_t type; /* == &type_pair */ + obj_t car; /* left / head of list */ + obj_t cdr; /* right / tail of list */ +} pair_s; + +static mps_res_t pair_scan(mps_ss_t ss, obj_t obj) +{ + pair_t pair = (pair_t)obj; + +#define FIX(ref) \ + do { \ + mps_addr_t _addr = (ref); \ + mps_res_t res = MPS_FIX12(ss, &_addr); \ + if (res != MPS_RES_OK) return res; \ + (ref) = _addr; \ + } while(0) + + MPS_SCAN_BEGIN(ss) { + FIX(pair->type); + FIX(pair->car); + FIX(pair->cdr); + } MPS_SCAN_END(ss); + +#undef FIX + + return MPS_RES_OK; +} + +static mps_addr_t pair_skip(mps_addr_t addr) +{ + return (char *)addr + sizeof(pair_s); +} + +static type_s type_pair = { + &type_type, + "pair", + pair_scan, + pair_skip +}; + + +/* Function objects */ + +typedef struct fun_s *fun_t; +typedef struct fun_s { + type_t type; /* == &type_fun */ + entry_t entry; /* entry point of function code */ + obj_t closure; /* whatever the function code needs */ +} fun_s; + +static mps_res_t fun_scan(mps_ss_t ss, obj_t obj) +{ + fun_t fun = (fun_t)obj; + +#define FIX(ref) \ + do { \ + mps_addr_t _addr = (ref); \ + mps_res_t res = MPS_FIX12(ss, &_addr); \ + if (res != MPS_RES_OK) return res; \ + (ref) = _addr; \ + } while(0) + + MPS_SCAN_BEGIN(ss) { + FIX(fun->type); + FIX(fun->closure); + } MPS_SCAN_END(ss); + +#undef FIX + + return MPS_RES_OK; +} + +static mps_addr_t fun_skip(mps_addr_t addr) +{ + return (char *)addr + sizeof(fun_s); +} + +static type_s type_fun = { + &type_type, + "fun", + fun_scan, + fun_skip +}; + +/* op_jump -- jump to a function + * + * Jumps to the function in register zero. Register zero can then be + * used by the function to access its own closure. + */ + +static void op_jump(state_t state) +{ + assert(state->reg[0]->type == &type_fun); + state->pc = ((fun_t)state->reg[0])->entry; +} + +/* op_call -- call a function + * + * Calls the function in register zero. + * + * op_call's ``link`` argument is where execution should continue when + * the function returns. + * + * Calling consists of constructing a continuation function that will + * continue at ``link`` when called, and pushing it on the operator + * stack for use by ``op_ret``, then jumping to the function. + */ + +static void op_call(state_t state, entry_t link) +{ + do { + die(mps_reserve(&state->baby, state->ap, sizeof(fun_s)), + "op_call / mps_reserve(fun)"); + state->reg[1] = state->baby; + ((fun_t)state->reg[1])->type = &type_fun; + ((fun_t)state->reg[1])->entry = link; + ((fun_t)state->reg[1])->closure = state->reg[0]; + } while (!mps_commit(state->ap, state->baby, sizeof(fun_s))); + + do { + die(mps_reserve(&state->baby, state->ap, sizeof(pair_s)), + "op_call / mps_reserve(pair)"); + state->reg[2] = state->baby; + ((pair_t)state->reg[2])->type = &type_pair; + ((pair_t)state->reg[2])->car = (obj_t)state->reg[1]; + ((pair_t)state->reg[2])->cdr = state->rators; + } while (!mps_commit(state->ap, state->baby, sizeof(pair_s))); + + state->rators = state->reg[2]; + + op_jump(state); +} + +/* op_ret -- return from a function + * + * op_ret pops a function from the operator stack, presumably put + * there by ``op_call``, and jumps to it. + */ + +static void op_ret(state_t state) +{ + assert(state->rators != (obj_t)&list_empty); + assert(state->rators->type == &type_pair); + state->reg[0] = ((pair_t)state->rators)->car; + state->rators = ((pair_t)state->rators)->cdr; + assert(state->reg[0]->type == &type_fun); + state->pc = ((fun_t)state->reg[0])->entry; +} + + +/* Operand stack */ + +/* op_push -- push a value on to the operand stack + * + * Pushes the contents of register 1 on to the operand stack by + * prepending to the list. + * + * Corrupts register 2. + */ + +static void op_push(state_t state) +{ + do { + die(mps_reserve(&state->baby, state->ap, sizeof(pair_s)), + "op_push / mps_reserve"); + state->reg[2] = state->baby; + ((pair_t)state->reg[2])->type = &type_pair; + ((pair_t)state->reg[2])->car = state->reg[1]; + ((pair_t)state->reg[2])->cdr = state->rands; + } while(!mps_commit(state->ap, state->baby, sizeof(pair_s))); + + state->rands = state->reg[2]; +} + +/* op_pop -- pop a value from the operand stack + * + * Pops the top value from the operand stack into register 1. + * + * FIXME: What about popping the empty stack? + */ + +static void op_pop(state_t state) +{ + assert(state->rands->type == &type_pair); + state->reg[1] = ((pair_t)state->rands)->car; + state->rands = ((pair_t)state->rands)->cdr; +} + + +/* Character strings */ + +typedef struct string_s *string_t; +typedef struct string_s { + type_t type; /* == &type_string */ + size_t n; /* length of c array (including NUL) */ + char c[1]; /* multibyte-encoded C string */ +} string_s; + +static mps_addr_t string_skip(mps_addr_t addr) +{ + string_t string = (string_t)addr; + size_t size = alignUp(offsetof(string_s, c) + string->n, OBJ_ALIGN); + return (char *)addr + size; +} + +static type_s type_string = { + &type_type, + "string", + obj_scan, /* string_s has no other scannable fields */ + string_skip +}; + + +/* Print function */ + +static void print_entry(state_t state) +{ + op_pop(state); + assert(state->reg[1]->type == &type_string); + fputs(((string_t)state->reg[1])->c, stdout); + op_ret(state); +} + +static struct fun_s fun_print = { + &type_fun, + print_entry, + (obj_t)&list_empty /* FIXME: should be a special unused value */ +}; + + +/* Exit continuations */ + +static void exit_entry(state_t state) +{ + (void)state; + exit(EXIT_SUCCESS); +} + +static void abort_entry(state_t state) +{ + (void)state; + abort(); +} + + +/* Make a state */ + +static void state_init(state_s *state, mps_arena_t arena, mps_fmt_t fmt) +{ + size_t i; + + state->type = &type_state; + state->rands = (obj_t)&list_empty; + state->rators = (obj_t)&list_empty; + state->dictionary = (obj_t)&list_empty; + state->pc = abort_entry; + for (i = 0; i < sizeof(state->reg) / sizeof(state->reg[0]); ++i) + state->reg[i] = NULL; + + MPS_ARGS_BEGIN(args) { + MPS_ARGS_ADD(args, MPS_KEY_FORMAT, fmt); + die(mps_pool_create_k(&state->pool, arena, mps_class_amc(), args), + "state_init / mps_pool_create_k"); + } MPS_ARGS_END(args); + + MPS_ARGS_BEGIN(args) { + die(mps_ap_create_k(&state->ap, state->pool, args), + "state_init / mps_ap_create_k"); + } MPS_ARGS_END(args); +} + + +/* Make a string + * + * Makes a string object out of a C string and pushes it on to the + * operand stack. + * + * Corrupts register 1. + */ + +static void make_string(state_t state, const char *s) +{ + size_t length = strlen(s); + size_t size = alignUp(offsetof(string_s, c) + length + 1, OBJ_ALIGN); + + do { + die(mps_reserve(&state->baby, state->ap, size), + "make_string / mps_reserve"); + state->reg[1] = state->baby; + ((string_t)state->reg[1])->type = &type_string; + ((string_t)state->reg[1])->n = length + 1; /* includes NUL */ + memcpy(((string_t)state->reg[1])->c, s, length + 1); + } while(!mps_commit(state->ap, state->baby, size)); + + op_push(state); +} + + +int main(void) +{ + state_s state_s; + state_t state; + mps_arena_t arena; + mps_fmt_t fmt; + mps_root_t root; + + MPS_ARGS_BEGIN(args) { + die(mps_arena_create_k(&arena, mps_arena_class_vm(), args), + "main / mps_arena_create_k"); + } MPS_ARGS_END(args); + + MPS_ARGS_BEGIN(args) { + MPS_ARGS_ADD(args, MPS_KEY_FMT_ALIGN, OBJ_ALIGN); + MPS_ARGS_ADD(args, MPS_KEY_FMT_SCAN, fmt_scan); + MPS_ARGS_ADD(args, MPS_KEY_FMT_SKIP, fmt_skip); + MPS_ARGS_ADD(args, MPS_KEY_FMT_FWD, fmt_fwd); + MPS_ARGS_ADD(args, MPS_KEY_FMT_ISFWD, fmt_isfwd); + MPS_ARGS_ADD(args, MPS_KEY_FMT_PAD, fmt_pad); + die(mps_fmt_create_k(&fmt, arena, args), + "main / mps_fmt_create_k"); + } MPS_ARGS_END(args); + + state_init(&state_s, arena, fmt); + state = &state_s; + + die(mps_root_create_fmt(&root, + arena, + mps_rank_exact(), + 0, + fmt_scan, + &state, + &state + 1), + "main / mps_root_create_fmt"); + + make_string(state, "Hello, world!\n"); + + state->reg[0] = (obj_t)&fun_print; + op_call(state, exit_entry); + run(state); + + assert(0); + return EXIT_FAILURE; +} diff --git a/code/mpm.h b/code/mpm.h index 9979d20180..e072a7a1ea 100644 --- a/code/mpm.h +++ b/code/mpm.h @@ -236,6 +236,7 @@ extern Res PoolTraceBegin(Pool pool, Trace trace); extern void PoolFreeWalk(Pool pool, FreeBlockVisitor f, void *p); extern Size PoolTotalSize(Pool pool); extern Size PoolFreeSize(Pool pool); +extern Res PoolAddrObject(Addr *pReturn, Pool pool, Addr addr); extern Res PoolAbsInit(Pool pool, Arena arena, PoolClass klass, ArgList arg); extern void PoolAbsFinish(Inst inst); @@ -267,6 +268,7 @@ extern void PoolTrivFreeWalk(Pool pool, FreeBlockVisitor f, void *p); extern PoolDebugMixin PoolNoDebugMixin(Pool pool); extern BufferClass PoolNoBufferClass(void); extern Size PoolNoSize(Pool pool); +extern Res PoolTrivAddrObject(Addr *pReturn, Pool pool, Addr addr); /* See .critical.macros. */ #define PoolFreeMacro(pool, old, size) Method(Pool, pool, free)(pool, old, size) @@ -536,6 +538,7 @@ extern Res ArenaStartCollect(Globals globals, TraceStartWhy why); extern Res ArenaCollect(Globals globals, TraceStartWhy why); extern Bool ArenaBusy(Arena arena); extern Bool ArenaHasAddr(Arena arena, Addr addr); +extern Res ArenaAddrObject(Addr *pReturn, Arena arena, Addr addr); extern void ArenaChunkInsert(Arena arena, Chunk chunk); extern void ArenaChunkRemoved(Arena arena, Chunk chunk); extern void ArenaAccumulateTime(Arena arena, Clock start, Clock now); diff --git a/code/mpmst.h b/code/mpmst.h index e03033ae99..f5ba00b8d6 100644 --- a/code/mpmst.h +++ b/code/mpmst.h @@ -60,6 +60,7 @@ typedef struct mps_pool_class_s { PoolRampEndMethod rampEnd; /* end a ramp pattern */ PoolFramePushMethod framePush; /* push an allocation frame */ PoolFramePopMethod framePop; /* pop an allocation frame */ + PoolAddrObjectMethod addrObject; /* return object's base pointer */ PoolFreeWalkMethod freewalk; /* walk over free blocks */ PoolBufferClassMethod bufferClass; /* default BufferClass of pool */ PoolDebugMixinMethod debugMixin; /* find the debug mixin, if any */ diff --git a/code/mpmtypes.h b/code/mpmtypes.h index d913c445f7..c219e908e0 100644 --- a/code/mpmtypes.h +++ b/code/mpmtypes.h @@ -214,6 +214,7 @@ typedef Res (*PoolFramePushMethod)(AllocFrame *frameReturn, Pool pool, Buffer buf); typedef Res (*PoolFramePopMethod)(Pool pool, Buffer buf, AllocFrame frame); +typedef Res (*PoolAddrObjectMethod)(Addr *pReturn, Pool pool, Addr addr); typedef void (*PoolFreeWalkMethod)(Pool pool, FreeBlockVisitor f, void *p); typedef BufferClass (*PoolBufferClassMethod)(void); typedef PoolDebugMixin (*PoolDebugMixinMethod)(Pool pool); diff --git a/code/mps.h b/code/mps.h index 44727b9739..700c41462d 100644 --- a/code/mps.h +++ b/code/mps.h @@ -259,6 +259,9 @@ extern const struct mps_key_s _mps_key_FMT_PAD; extern const struct mps_key_s _mps_key_FMT_CLASS; #define MPS_KEY_FMT_CLASS (&_mps_key_FMT_CLASS) #define MPS_KEY_FMT_CLASS_FIELD fmt_class +extern const struct mps_key_s _mps_key_ap_hash_arrays; +#define MPS_KEY_AP_HASH_ARRAYS (&_mps_key_ap_hash_arrays) +#define MPS_KEY_AP_HASH_ARRAYS_FIELD b /* Maximum length of a keyword argument list. */ #define MPS_ARGS_MAX 32 @@ -845,6 +848,8 @@ extern mps_res_t _mps_fix2(mps_ss_t, mps_addr_t *); (ss)->_ufs = _mps_ufs; \ MPS_END +/* Misc interface */ +extern mps_res_t mps_addr_object(mps_addr_t *p_o, mps_arena_t arena, mps_addr_t addr); /* Transforms interface. */ diff --git a/code/mps.xcodeproj/project.pbxproj b/code/mps.xcodeproj/project.pbxproj index be24cfea23..888ebe6a05 100644 --- a/code/mps.xcodeproj/project.pbxproj +++ b/code/mps.xcodeproj/project.pbxproj @@ -73,6 +73,7 @@ buildPhases = ( ); dependencies = ( + 319F7A192A30D2F000E5B418 /* PBXTargetDependency */, 3104AFF6156D37BC000A585A /* PBXTargetDependency */, 3114A644156E94FB001E0AA3 /* PBXTargetDependency */, 22FACEF1188809B5000FDBC1 /* PBXTargetDependency */, @@ -89,8 +90,6 @@ 3114A677156E961C001E0AA3 /* PBXTargetDependency */, 3114A612156E943B001E0AA3 /* PBXTargetDependency */, 22B2BC3D18B643B300C33E63 /* PBXTargetDependency */, - 2291A5E6175CB207001D4920 /* PBXTargetDependency */, - 2291A5E8175CB20E001D4920 /* PBXTargetDependency */, 3114A5CC156E932C001E0AA3 /* PBXTargetDependency */, 3114A5EA156E93C4001E0AA3 /* PBXTargetDependency */, 22EA3F4820D2B23F0065F5B6 /* PBXTargetDependency */, @@ -166,16 +165,6 @@ 2291A5B5175CAB2F001D4920 /* testlib.c in Sources */ = {isa = PBXBuildFile; fileRef = 31EEAC9E156AB73400714D05 /* testlib.c */; }; 2291A5B7175CAB2F001D4920 /* libmps.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 31EEABFB156AAF9D00714D05 /* libmps.a */; }; 2291A5BE175CAB4E001D4920 /* awlutth.c in Sources */ = {isa = PBXBuildFile; fileRef = 2291A5A9175CAA9B001D4920 /* awlutth.c */; }; - 2291A5C5175CAFCA001D4920 /* fmtdy.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CAC6156BE48D00753214 /* fmtdy.c */; }; - 2291A5C6175CAFCA001D4920 /* fmtdytst.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CAC7156BE48D00753214 /* fmtdytst.c */; }; - 2291A5C7175CAFCA001D4920 /* fmtno.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CACC156BE4C200753214 /* fmtno.c */; }; - 2291A5C8175CAFCA001D4920 /* testlib.c in Sources */ = {isa = PBXBuildFile; fileRef = 31EEAC9E156AB73400714D05 /* testlib.c */; }; - 2291A5CB175CAFCA001D4920 /* libmps.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 31EEABFB156AAF9D00714D05 /* libmps.a */; }; - 2291A5D8175CB05F001D4920 /* fmtdy.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CAC6156BE48D00753214 /* fmtdy.c */; }; - 2291A5D9175CB05F001D4920 /* fmtdytst.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CAC7156BE48D00753214 /* fmtdytst.c */; }; - 2291A5DA175CB05F001D4920 /* fmtno.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CACC156BE4C200753214 /* fmtno.c */; }; - 2291A5DB175CB05F001D4920 /* testlib.c in Sources */ = {isa = PBXBuildFile; fileRef = 31EEAC9E156AB73400714D05 /* testlib.c */; }; - 2291A5DD175CB05F001D4920 /* libmps.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 31EEABFB156AAF9D00714D05 /* libmps.a */; }; 2291A5ED175CB5E2001D4920 /* landtest.c in Sources */ = {isa = PBXBuildFile; fileRef = 2291A5E9175CB4EC001D4920 /* landtest.c */; }; 22B2BC2E18B6434F00C33E63 /* mps.c in Sources */ = {isa = PBXBuildFile; fileRef = 31A47BA3156C1E130039B1C2 /* mps.c */; }; 22B2BC3718B6437C00C33E63 /* scheme-advanced.c in Sources */ = {isa = PBXBuildFile; fileRef = 22B2BC2B18B6434000C33E63 /* scheme-advanced.c */; }; @@ -309,6 +298,12 @@ 3124CAFC156BE82900753214 /* libmps.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 31EEABFB156AAF9D00714D05 /* libmps.a */; }; 3150AE53156ABA2500A6E22A /* libmps.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 31EEABFB156AAF9D00714D05 /* libmps.a */; }; 318DA8D31892B27E0089718C /* testlib.c in Sources */ = {isa = PBXBuildFile; fileRef = 31EEAC9E156AB73400714D05 /* testlib.c */; }; + 319F7A082A30D08500E5B418 /* testlib.c in Sources */ = {isa = PBXBuildFile; fileRef = 31EEAC9E156AB73400714D05 /* testlib.c */; }; + 319F7A0A2A30D08500E5B418 /* fmtdy.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CAC6156BE48D00753214 /* fmtdy.c */; }; + 319F7A0B2A30D08500E5B418 /* fmtdytst.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CAC7156BE48D00753214 /* fmtdytst.c */; }; + 319F7A0C2A30D08500E5B418 /* fmtno.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CACC156BE4C200753214 /* fmtno.c */; }; + 319F7A0E2A30D08500E5B418 /* libmps.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 31EEABFB156AAF9D00714D05 /* libmps.a */; }; + 319F7A172A30D11400E5B418 /* addrobj.c in Sources */ = {isa = PBXBuildFile; fileRef = 319F7A152A30D11400E5B418 /* addrobj.c */; }; 31A47BA4156C1E130039B1C2 /* mps.c in Sources */ = {isa = PBXBuildFile; fileRef = 31A47BA3156C1E130039B1C2 /* mps.c */; }; 31D60007156D3C6200337B26 /* segsmss.c in Sources */ = {isa = PBXBuildFile; fileRef = 31D60006156D3C5F00337B26 /* segsmss.c */; }; 31D60008156D3C7400337B26 /* libmps.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 31EEABFB156AAF9D00714D05 /* libmps.a */; }; @@ -490,20 +485,6 @@ remoteGlobalIDString = 2291A5AC175CAB2F001D4920; remoteInfo = awlutth; }; - 2291A5C3175CAFCA001D4920 /* PBXContainerItemProxy */ = { - isa = PBXContainerItemProxy; - containerPortal = 31EEABDA156AAE9E00714D05 /* Project object */; - proxyType = 1; - remoteGlobalIDString = 31EEABFA156AAF9D00714D05; - remoteInfo = mps; - }; - 2291A5D5175CB05F001D4920 /* PBXContainerItemProxy */ = { - isa = PBXContainerItemProxy; - containerPortal = 31EEABDA156AAE9E00714D05 /* Project object */; - proxyType = 1; - remoteGlobalIDString = 31EEABFA156AAF9D00714D05; - remoteInfo = mps; - }; 229E228719EAB10D00E21417 /* PBXContainerItemProxy */ = { isa = PBXContainerItemProxy; containerPortal = 31EEABDA156AAE9E00714D05 /* Project object */; @@ -945,6 +926,20 @@ remoteGlobalIDString = 31108A3A1C6B90E900E728EA; remoteInfo = tagtest; }; + 319F7A062A30D08500E5B418 /* PBXContainerItemProxy */ = { + isa = PBXContainerItemProxy; + containerPortal = 31EEABDA156AAE9E00714D05 /* Project object */; + proxyType = 1; + remoteGlobalIDString = 31EEABFA156AAF9D00714D05; + remoteInfo = mps; + }; + 319F7A182A30D2F000E5B418 /* PBXContainerItemProxy */ = { + isa = PBXContainerItemProxy; + containerPortal = 31EEABDA156AAE9E00714D05 /* Project object */; + proxyType = 1; + remoteGlobalIDString = 319F7A042A30D08500E5B418; + remoteInfo = addrobj; + }; 31A47BA9156C210D0039B1C2 /* PBXContainerItemProxy */ = { isa = PBXContainerItemProxy; containerPortal = 31EEABDA156AAE9E00714D05 /* Project object */; @@ -1123,24 +1118,6 @@ ); runOnlyForDeploymentPostprocessing = 1; }; - 2291A5CC175CAFCA001D4920 /* CopyFiles */ = { - isa = PBXCopyFilesBuildPhase; - buildActionMask = 2147483647; - dstPath = /usr/share/man/man1/; - dstSubfolderSpec = 0; - files = ( - ); - runOnlyForDeploymentPostprocessing = 1; - }; - 2291A5DE175CB05F001D4920 /* CopyFiles */ = { - isa = PBXCopyFilesBuildPhase; - buildActionMask = 2147483647; - dstPath = /usr/share/man/man1/; - dstSubfolderSpec = 0; - files = ( - ); - runOnlyForDeploymentPostprocessing = 1; - }; 22B2BC3118B6434F00C33E63 /* CopyFiles */ = { isa = PBXCopyFilesBuildPhase; buildActionMask = 2147483647; @@ -1438,6 +1415,15 @@ ); runOnlyForDeploymentPostprocessing = 1; }; + 319F7A0F2A30D08500E5B418 /* CopyFiles */ = { + isa = PBXCopyFilesBuildPhase; + buildActionMask = 2147483647; + dstPath = /usr/share/man/man1/; + dstSubfolderSpec = 0; + files = ( + ); + runOnlyForDeploymentPostprocessing = 1; + }; 31D6000B156D3CB200337B26 /* CopyFiles */ = { isa = PBXCopyFilesBuildPhase; buildActionMask = 2147483647; @@ -1766,6 +1752,8 @@ 31942AA91C8EC446001AAF32 /* sp.txt */ = {isa = PBXFileReference; lastKnownFileType = text; name = sp.txt; path = ../design/sp.txt; sourceTree = ""; }; 31942AAB1C8EC446001AAF32 /* stack-scan.txt */ = {isa = PBXFileReference; lastKnownFileType = text; name = "stack-scan.txt"; path = "../design/stack-scan.txt"; sourceTree = ""; }; 31942AB01C8EC446001AAF32 /* testthr.txt */ = {isa = PBXFileReference; lastKnownFileType = text; name = testthr.txt; path = ../design/testthr.txt; sourceTree = ""; }; + 319F7A142A30D08500E5B418 /* addrobj */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = addrobj; sourceTree = BUILT_PRODUCTS_DIR; }; + 319F7A152A30D11400E5B418 /* addrobj.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = addrobj.c; sourceTree = ""; }; 31A47BA3156C1E130039B1C2 /* mps.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = mps.c; sourceTree = ""; }; 31C83ADD1786281C0031A0DB /* protxc.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = protxc.h; sourceTree = ""; }; 31CD33BB173A9F1500524741 /* mpscams.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = mpscams.h; sourceTree = ""; }; @@ -1901,22 +1889,6 @@ ); runOnlyForDeploymentPostprocessing = 0; }; - 2291A5CA175CAFCA001D4920 /* Frameworks */ = { - isa = PBXFrameworksBuildPhase; - buildActionMask = 2147483647; - files = ( - 2291A5CB175CAFCA001D4920 /* libmps.a in Frameworks */, - ); - runOnlyForDeploymentPostprocessing = 0; - }; - 2291A5DC175CB05F001D4920 /* Frameworks */ = { - isa = PBXFrameworksBuildPhase; - buildActionMask = 2147483647; - files = ( - 2291A5DD175CB05F001D4920 /* libmps.a in Frameworks */, - ); - runOnlyForDeploymentPostprocessing = 0; - }; 22B2BC3018B6434F00C33E63 /* Frameworks */ = { isa = PBXFrameworksBuildPhase; buildActionMask = 2147483647; @@ -2179,6 +2151,14 @@ ); runOnlyForDeploymentPostprocessing = 0; }; + 319F7A0D2A30D08500E5B418 /* Frameworks */ = { + isa = PBXFrameworksBuildPhase; + buildActionMask = 2147483647; + files = ( + 319F7A0E2A30D08500E5B418 /* libmps.a in Frameworks */, + ); + runOnlyForDeploymentPostprocessing = 0; + }; 31D6000A156D3CB200337B26 /* Frameworks */ = { isa = PBXFrameworksBuildPhase; buildActionMask = 2147483647; @@ -2385,6 +2365,7 @@ 3124CAB3156BE1B700753214 /* Tests */ = { isa = PBXGroup; children = ( + 319F7A152A30D11400E5B418 /* addrobj.c */, 3114A63D156E94EA001E0AA3 /* abqtest.c */, 22FACED1188807FF000FDBC1 /* airtest.c */, 3124CAF5156BE81100753214 /* amcss.c */, @@ -2531,7 +2512,9 @@ 223E796519EAB00B00DC26A6 /* sncss */, 22EA3F4520D2B0D90065F5B6 /* forktest */, 2265D71D20E53F9C003019E8 /* mpseventpy */, + 319F7A142A30D08500E5B418 /* addrobj */, 220FD3E9195339C000967A35 /* ztfm */, + ); name = Products; sourceTree = ""; @@ -3434,6 +3417,24 @@ productReference = 318DA8CD1892B0F30089718C /* djbench */; productType = "com.apple.product-type.tool"; }; + 319F7A042A30D08500E5B418 /* addrobj */ = { + isa = PBXNativeTarget; + buildConfigurationList = 319F7A102A30D08500E5B418 /* Build configuration list for PBXNativeTarget "addrobj" */; + buildPhases = ( + 319F7A072A30D08500E5B418 /* Sources */, + 319F7A0D2A30D08500E5B418 /* Frameworks */, + 319F7A0F2A30D08500E5B418 /* CopyFiles */, + ); + buildRules = ( + ); + dependencies = ( + 319F7A052A30D08500E5B418 /* PBXTargetDependency */, + ); + name = addrobj; + productName = finalcv; + productReference = 319F7A142A30D08500E5B418 /* addrobj */; + productType = "com.apple.product-type.tool"; + }; 31D6000C156D3CB200337B26 /* awluthe */ = { isa = PBXNativeTarget; buildConfigurationList = 31D60014156D3CB200337B26 /* Build configuration list for PBXNativeTarget "awluthe" */; @@ -3624,6 +3625,7 @@ developmentRegion = English; hasScannedForEncodings = 0; knownRegions = ( + English, en, ); mainGroup = 31EEABD8156AAE9E00714D05; @@ -3687,6 +3689,7 @@ 31FCAE0917692403008C034C /* scheme */, 22B2BC2C18B6434F00C33E63 /* scheme-advanced */, 31108A3A1C6B90E900E728EA /* tagtest */, + 319F7A042A30D08500E5B418 /* addrobj */, ); }; /* End PBXProject section */ @@ -4173,6 +4176,18 @@ ); runOnlyForDeploymentPostprocessing = 0; }; + 319F7A072A30D08500E5B418 /* Sources */ = { + isa = PBXSourcesBuildPhase; + buildActionMask = 2147483647; + files = ( + 319F7A172A30D11400E5B418 /* addrobj.c in Sources */, + 319F7A082A30D08500E5B418 /* testlib.c in Sources */, + 319F7A0A2A30D08500E5B418 /* fmtdy.c in Sources */, + 319F7A0B2A30D08500E5B418 /* fmtdytst.c in Sources */, + 319F7A0C2A30D08500E5B418 /* fmtno.c in Sources */, + ); + runOnlyForDeploymentPostprocessing = 0; + }; 31D60009156D3CB200337B26 /* Sources */ = { isa = PBXSourcesBuildPhase; buildActionMask = 2147483647; @@ -4380,16 +4395,6 @@ target = 2291A5AC175CAB2F001D4920 /* awlutth */; targetProxy = 2291A5BF175CAB5F001D4920 /* PBXContainerItemProxy */; }; - 2291A5C2175CAFCA001D4920 /* PBXTargetDependency */ = { - isa = PBXTargetDependency; - target = 31EEABFA156AAF9D00714D05 /* mps */; - targetProxy = 2291A5C3175CAFCA001D4920 /* PBXContainerItemProxy */; - }; - 2291A5D4175CB05F001D4920 /* PBXTargetDependency */ = { - isa = PBXTargetDependency; - target = 31EEABFA156AAF9D00714D05 /* mps */; - targetProxy = 2291A5D5175CB05F001D4920 /* PBXContainerItemProxy */; - }; 229E228819EAB10D00E21417 /* PBXTargetDependency */ = { isa = PBXTargetDependency; target = 223E795819EAB00B00DC26A6 /* sncss */; @@ -4705,6 +4710,16 @@ target = 31108A3A1C6B90E900E728EA /* tagtest */; targetProxy = 314CB6EA1C6D272A0073CA42 /* PBXContainerItemProxy */; }; + 319F7A052A30D08500E5B418 /* PBXTargetDependency */ = { + isa = PBXTargetDependency; + target = 31EEABFA156AAF9D00714D05 /* mps */; + targetProxy = 319F7A062A30D08500E5B418 /* PBXContainerItemProxy */; + }; + 319F7A192A30D2F000E5B418 /* PBXTargetDependency */ = { + isa = PBXTargetDependency; + target = 319F7A042A30D08500E5B418 /* addrobj */; + targetProxy = 319F7A182A30D2F000E5B418 /* PBXContainerItemProxy */; + }; 31A47BAA156C210D0039B1C2 /* PBXTargetDependency */ = { isa = PBXTargetDependency; target = 31EEABFA156AAF9D00714D05 /* mps */; @@ -5005,34 +5020,6 @@ }; name = Release; }; - 2291A5CE175CAFCA001D4920 /* Debug */ = { - isa = XCBuildConfiguration; - buildSettings = { - PRODUCT_NAME = "$(TARGET_NAME)"; - }; - name = Debug; - }; - 2291A5CF175CAFCA001D4920 /* Release */ = { - isa = XCBuildConfiguration; - buildSettings = { - PRODUCT_NAME = "$(TARGET_NAME)"; - }; - name = Release; - }; - 2291A5E0175CB05F001D4920 /* Debug */ = { - isa = XCBuildConfiguration; - buildSettings = { - PRODUCT_NAME = "$(TARGET_NAME)"; - }; - name = Debug; - }; - 2291A5E1175CB05F001D4920 /* Release */ = { - isa = XCBuildConfiguration; - buildSettings = { - PRODUCT_NAME = "$(TARGET_NAME)"; - }; - name = Release; - }; 22B2BC3318B6434F00C33E63 /* Debug */ = { isa = XCBuildConfiguration; buildSettings = { @@ -5747,20 +5734,6 @@ }; name = RASH; }; - 318DA8E51892C0D00089718C /* RASH */ = { - isa = XCBuildConfiguration; - buildSettings = { - PRODUCT_NAME = "$(TARGET_NAME)"; - }; - name = RASH; - }; - 318DA8E61892C0D00089718C /* RASH */ = { - isa = XCBuildConfiguration; - buildSettings = { - PRODUCT_NAME = "$(TARGET_NAME)"; - }; - name = RASH; - }; 318DA8E71892C0D00089718C /* RASH */ = { isa = XCBuildConfiguration; buildSettings = { @@ -5930,6 +5903,27 @@ }; name = RASH; }; + 319F7A112A30D08500E5B418 /* Debug */ = { + isa = XCBuildConfiguration; + buildSettings = { + PRODUCT_NAME = "$(TARGET_NAME)"; + }; + name = Debug; + }; + 319F7A122A30D08500E5B418 /* Release */ = { + isa = XCBuildConfiguration; + buildSettings = { + PRODUCT_NAME = "$(TARGET_NAME)"; + }; + name = Release; + }; + 319F7A132A30D08500E5B418 /* RASH */ = { + isa = XCBuildConfiguration; + buildSettings = { + PRODUCT_NAME = "$(TARGET_NAME)"; + }; + name = RASH; + }; 31D60015156D3CB200337B26 /* Debug */ = { isa = XCBuildConfiguration; buildSettings = { @@ -6677,6 +6671,16 @@ defaultConfigurationIsVisible = 0; defaultConfigurationName = Release; }; + 319F7A102A30D08500E5B418 /* Build configuration list for PBXNativeTarget "addrobj" */ = { + isa = XCConfigurationList; + buildConfigurations = ( + 319F7A112A30D08500E5B418 /* Debug */, + 319F7A122A30D08500E5B418 /* Release */, + 319F7A132A30D08500E5B418 /* RASH */, + ); + defaultConfigurationIsVisible = 0; + defaultConfigurationName = Release; + }; 31D60014156D3CB200337B26 /* Build configuration list for PBXNativeTarget "awluthe" */ = { isa = XCConfigurationList; buildConfigurations = ( diff --git a/code/mps.xcodeproj/xcshareddata/xcschemes/addrobj.xcscheme b/code/mps.xcodeproj/xcshareddata/xcschemes/addrobj.xcscheme new file mode 100644 index 0000000000..fc6990f251 --- /dev/null +++ b/code/mps.xcodeproj/xcshareddata/xcschemes/addrobj.xcscheme @@ -0,0 +1,78 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/code/mps.xcodeproj/xcshareddata/xcschemes/finaltest.xcscheme b/code/mps.xcodeproj/xcshareddata/xcschemes/finaltest.xcscheme new file mode 100644 index 0000000000..67ef98c430 --- /dev/null +++ b/code/mps.xcodeproj/xcshareddata/xcschemes/finaltest.xcscheme @@ -0,0 +1,78 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/code/mpsi.c b/code/mpsi.c index 10e26ab07a..eab0deb89e 100644 --- a/code/mpsi.c +++ b/code/mpsi.c @@ -449,6 +449,37 @@ mps_bool_t mps_addr_pool(mps_pool_t *mps_pool_o, } +/* mps_addr_object -- find base pointer of a managed object */ + +mps_res_t mps_addr_object(mps_addr_t *p_o, mps_arena_t arena, mps_addr_t addr) +{ + Res res; + Addr p; + + AVER(p_o != NULL); + + /* This function cannot be called while walking the heap, unlike + * mps_arena_has_addr(). This is because it is designed to be called + * with an active mutator, so takes the arena lock. This is in order + * that it sees a consistent view of MPS structures and the heap, + * and can peek behind the barrier. + */ + ArenaEnter(arena); + AVERT(Arena, arena); + res = ArenaAddrObject(&p, arena, (Addr)addr); + ArenaLeave(arena); + /* We require the object to be ambiguously referenced (hence pinned) + * so that p doesn't become invalid before it is written to *p_o. + * (We can't simply put this write before the ArenaLeave(), because + * p_o could point to MPS-managed memory that is behind a barrier.) + */ + if (res == ResOK) + *p_o = (mps_addr_t)p; + + return res; +} + + /* mps_addr_fmt -- what format might this address have? * * .per-pool: There's no reason why all objects in a pool should have diff --git a/code/pool.c b/code/pool.c index ea6971025e..fc04563175 100644 --- a/code/pool.c +++ b/code/pool.c @@ -57,6 +57,7 @@ Bool PoolClassCheck(PoolClass klass) CHECKL(FUNCHECK(klass->debugMixin)); CHECKL(FUNCHECK(klass->totalSize)); CHECKL(FUNCHECK(klass->freeSize)); + CHECKL(FUNCHECK(klass->addrObject)); /* Check that pool classes overide sets of related methods. */ CHECKL((klass->init == PoolAbsInit) == @@ -303,6 +304,21 @@ Size PoolFreeSize(Pool pool) } +/* PoolAddrObject -- return base pointer from interior pointer + * + * Note: addr is not necessarily inside the pool, even though + * mps_addr_object dispatches via the tract table. This allows this + * function to be used more generally internally. The pool should + * check (it has to anyway). + */ + +Res PoolAddrObject(Addr *pReturn, Pool pool, Addr addr) +{ + AVER(pReturn != NULL); + AVERT(Pool, pool); + return Method(Pool, pool, addrObject)(pReturn, pool, addr); +} + /* PoolDescribe -- describe a pool */ Res PoolDescribe(Pool pool, mps_lib_FILE *stream, Count depth) diff --git a/code/poolabs.c b/code/poolabs.c index f7fe65a8e4..d6eae2dd04 100644 --- a/code/poolabs.c +++ b/code/poolabs.c @@ -173,6 +173,7 @@ DEFINE_CLASS(Pool, AbstractPool, klass) klass->debugMixin = PoolNoDebugMixin; klass->totalSize = PoolNoSize; klass->freeSize = PoolNoSize; + klass->addrObject = PoolTrivAddrObject; klass->sig = PoolClassSig; AVERT(PoolClass, klass); } @@ -476,6 +477,16 @@ Size PoolNoSize(Pool pool) } +Res PoolTrivAddrObject(Addr *pReturn, Pool pool, Addr addr) +{ + AVERT(Pool, pool); + AVER(pReturn != NULL); + UNUSED(addr); + + return ResUNIMPL; +} + + /* C. COPYRIGHT AND LICENSE * * Copyright (C) 2001-2020 Ravenbrook Limited . diff --git a/code/poolamc.c b/code/poolamc.c index 8a29aee552..c526c8e56f 100644 --- a/code/poolamc.c +++ b/code/poolamc.c @@ -513,7 +513,6 @@ static Res AMCBufInit(Buffer buffer, Pool pool, Bool isMutator, ArgList args) if (ArgPick(&arg, args, amcKeyAPHashArrays)) forHashArrays = arg.val.b; - /* call next method */ res = NextMethod(Buffer, amcBuf, init)(buffer, pool, isMutator, args); if(res != ResOK) return res; @@ -1893,6 +1892,90 @@ static void amcWalkAll(Pool pool, FormattedObjectsVisitor f, void *p, size_t s) } } +/* AMCAddrObject -- return base pointer from interior pointer + * + * amcAddrObjectSearch implements the scan for an object containing + * the interior pointer by skipping using format methods. + * + * AMCAddrObject locates the segment containing the interior pointer + * and wraps amcAddrObjectSearch in the necessary shield operations to + * give it access. + */ + +static Res amcAddrObjectSearch(Addr *pReturn, + Pool pool, + Addr objBase, + Addr searchLimit, + Addr addr) +{ + Format format; + Size hdrSize; + + AVER(pReturn != NULL); + AVERT(Pool, pool); + AVER(objBase <= searchLimit); + + format = pool->format; + hdrSize = format->headerSize; + while (objBase < searchLimit) { + Addr objRef = AddrAdd(objBase, hdrSize); + Addr objLimit = AddrSub((*format->skip)(objRef), hdrSize); + AVER(objBase < objLimit); + + if (addr < objLimit) { + AVER(objBase <= addr); + AVER(addr < objLimit); + + /* Don't return base pointer if object is moved */ + if (NULL == (*format->isMoved)(objRef)) { + *pReturn = objRef; + return ResOK; + } + break; + } + objBase = objLimit; + } + return ResFAIL; +} + +static Res AMCAddrObject(Addr *pReturn, Pool pool, Addr addr) +{ + Res res; + Arena arena; + Addr base, limit; + Buffer buffer; + Seg seg; + + AVER(pReturn != NULL); + AVERT(Pool, pool); + + arena = PoolArena(pool); + if (!SegOfAddr(&seg, arena, addr) || SegPool(seg) != pool) + return ResFAIL; + + base = SegBase(seg); + if (SegBuffer(&buffer, seg)) + /* We use BufferGetInit here (and not BufferScanLimit) because we + * want to be able to find objects that have been allocated and + * committed since the last flip. These objects lie between the + * addresses returned by BufferScanLimit (which returns the value + * of init at the last flip) and BufferGetInit. + * + * Strictly speaking we only need a limit that is at least the + * maximum of the objects on the segments. This is because addr + * *must* point inside a live object and we stop skipping once we + * have found it. The init pointer serves this purpose. + */ + limit = BufferGetInit(buffer); + else + limit = SegLimit(seg); + + ShieldExpose(arena, seg); + res = amcAddrObjectSearch(pReturn, pool, base, limit, addr); + ShieldCover(arena, seg); + return res; +} + /* AMCTotalSize -- total memory allocated from the arena */ @@ -2008,6 +2091,7 @@ DEFINE_CLASS(Pool, AMCZPool, klass) klass->bufferClass = amcBufClassGet; klass->totalSize = AMCTotalSize; klass->freeSize = AMCFreeSize; + klass->addrObject = AMCAddrObject; AVERT(PoolClass, klass); } diff --git a/manual/source/pool/amc.rst b/manual/source/pool/amc.rst index 4760f928bd..317fcc0b56 100644 --- a/manual/source/pool/amc.rst +++ b/manual/source/pool/amc.rst @@ -139,3 +139,63 @@ AMC interface MPS_ARGS_ADD(args, MPS_KEY_FORMAT, fmt); res = mps_pool_create_k(&pool, arena, mps_class_amc(), args); } MPS_ARGS_END(args); + + When creating an :term:`allocation point` on an AMC pool, + :c:func:`mps_ap_create_k` accepts one optional keyword argument: + + * :c:macro:`MPS_KEY_AP_HASH_ARRAYS` (type :c:type:`mps_bool_t`, + defaulting to false) specifies (if true) that blocks allocated + from the allocation point do not contribute to the *new size* of + the :term:`nursery space` for the purposes of deciding whether + to start a collection of that generation. See + :ref:`pool-amc-hash-arrays`. + + +.. index:: + pair: AMC pool class; hash arrays + +.. _pool-amc-hash-arrays: + +Hash arrays +----------- + +The :term:`location dependency` feature of the MPS allows the +:term:`client program` to implement address-based hash tables in pools +like AMC that use a :term:`moving memory manager`, re-hashing the +tables when the addresses they contain might have moved. + +However, when a frequently-used hash table grows large enough, the +following sequence of events may take place: + +1. The hash table discovers that its location dependency is stale. + +2. A new array is allocated to contain the re-hashed keys. + +3. The new array is large enough to push the *new size* of the + :term:`nursery space` (that is, the amount of newly allocated + memory since the last collection in the first :term:`generation` in + the :term:`generation chain` for the pool containing the array) + close to its capacity. + +4. A small amount of additional allocation causes the new size of the + nursery generation to exceed its capacity, which causes the MPS to + start a new collection of that generation. This in turn causes the + hash table to become stale again. + +When the hash table reaches this critical size, the client program may +find that a large fraction of its time is being spent re-hashing the +table. + +In order to avoid this happening, the MPS provides a mechanism for +specifying that the newly allocated array does not contribute to the +new size of the nursery space: this cuts off the vicious cycle at step +3. + +To enable this mechanism, use the optional :c:macro:`MPS_KEY_AP_HASH_ARRAYS` +keyword argument when creating an allocation point with +:c:func:`mps_ap_create_k`. This interface is documented in the AMC Interface +section of the :ref:`pool-amc` documentation above. + +See :ref:`topic-collection-schedule` for an explanation of the *new +size* of a generation, and how the MPS uses this to determine when to +start a collection of that generation. diff --git a/manual/source/release.rst b/manual/source/release.rst index cabf9158f2..6cbbf46916 100644 --- a/manual/source/release.rst +++ b/manual/source/release.rst @@ -52,12 +52,25 @@ New features :ref:`topic-scanning-protocol`, support hot reloading and serialization. See :ref:`design-walk`. +#. The new function :c:func:`mps_addr_object` allows clients to + discover the base pointer of an object from a pointer to anywhere + inside the object. This is intended to support stack tracing and + debugging for client programs that allocate their code on the + heap. + #. A :term:`virtual memory arena` can now be configured to call functions when it acquires a new chunk of :term:`address space`, and when it returns a chunk of address space to the operation system. This is intended to support dynamic function tables in Windows. See :ref:`topic-arena-extension`. +#. An :term:`allocation point` for a pool belonging to the class + :ref:`pool-amc` can now be configured so that allocations do not + provoke garbage collections, reducing the amount of re-hashing for + address-based hash tables using :term:`location dependency`. See + :ref:`pool-amc-hash-arrays`. + + Interface changes ................. diff --git a/manual/source/topic/arena.rst b/manual/source/topic/arena.rst index 5ca0dbbd0c..61302d249a 100644 --- a/manual/source/topic/arena.rst +++ b/manual/source/topic/arena.rst @@ -1054,6 +1054,52 @@ Arena introspection and debugging :c:func:`mps_addr_fmt`. +.. c:function:: mps_res_t mps_addr_object(mps_addr_t *p_o, mps_arena_t arena, mps_addr_t addr) + + Find the :term:`base pointer` of an :term:`object` if provided with an + :term:`interior pointer` to that object, or the object's base pointer, + provided the object exists in a pool that supports this feature. + + ``p_o`` points to a location that will hold the object's base pointer. + + ``arena`` is an arena. + + ``addr`` is an address that might be an interior or base pointer. + + Returns MPS_RES_OK if a base pointer to an object into which ``addr`` + points was successfully returned. + + Returns MPS_RES_FAIL if ``addr`` points to memory not managed by the + ``arena`` or if ``addr`` points to the interior of an object which has + been moved by a :term:`moving memory manager`. + + Returns MPS_RES_UNIMPL if ``addr`` is found to be managed by a :term:`pool` + which does not currently implement this feature. + + :c:func:`mps_addr_object` allows client programs that allocate + code on the heap to implement debugging and stack tracing, in that it provides + a way to unwind a client program's stack by finding the block of code to which the + program counter or function return addresses currently point. It can be called + multiple times as needed to build a complete trace of the client program's stack. + + This function does not support debugging in situations where the arena + itself has encountered a runtime error. For cases where the MPS encounters + runtime errors, see :c:func:`mps_arena_postmortem`. + + .. note:: + + This function is intended to assist with debugging fatal + errors in the :term:`client program`. It is not expected to be + needed in normal use, i.e. as part of the regular operation of code in + production, since it is not optimized for performance. If you find yourself + wanting to use this function other than in the use case described, there may + be a better way to meet your requirements: please + :ref:`contact us `. + + If you would like this function to work in a pool in which it's currently + unimplemented, please :ref:`contact us `. + + .. index:: single: arena extension callbacks; introduction single: extension callbacks; introduction diff --git a/tool/testcases.txt b/tool/testcases.txt index 721ed9a3f4..dd23a616d3 100644 --- a/tool/testcases.txt +++ b/tool/testcases.txt @@ -2,6 +2,7 @@ Test case Flags Notes ============= ================ ========================================== abqtest +addrobj airtest amcss =P amcsshe =P