mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-03-26 16:51:46 -07:00
Code Issues Projects Releases Wiki Activity

Catch-up merge from master to pick up "dj" benchmark.

Browse source 
Copied from Perforce
 Change: 184110
 ServerID: perforce.ravenbrook.com
This commit is contained in:
Richard Brooksby 2014-01-24 15:59:05 +00:00
commit adc7935bb8
5 changed files with 500 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

375
mps/code/djbench.c Normal file
View file

@ -0,0 +1,375 @@
/* djbench.c -- "DJ" Benchmark on ANSI C library
*
* $Id$
* Copyright 2013 Ravenbrook Limited. See end of file for license.
*
* This is an allocation stress benchmark test for manual variable pools
* and also for stdlib malloc/free (for comparison).
*
* It repeatedly runs over an array of blocks and allocates or frees them
* with some probability, then frees all the remaining blocks at the end.
* This test can be iterated.
*/
#include <time.h>
#include <stdio.h>
#include <stdlib.h>
#include <alloca.h>
#include <pthread.h>
#include "getopt.h"
#include "testlib.h"
#include "mps.c"
#define MUST(expr) \
do { \
mps_res_t res = (expr); \
if (res != MPS_RES_OK) { \
fprintf(stderr, #expr " returned %d\n", res); \
exit(EXIT_FAILURE); \
} \
} while(0)
static mps_arena_t arena;
static mps_pool_t pool;
/* The benchmark behaviour is defined as a macro in order to give realistic
opportunities for compiler optimisation and the intended inlining of the
MPS functions. */
static rnd_state_t seed = 0; /* random number seed */
static unsigned nthreads = 1; /* threads */
static unsigned niter = 50; /* iterations */
static unsigned npass = 100; /* passes over blocks */
static unsigned nblocks = 64; /* number of blocks */
static unsigned sshift = 18; /* log2 max block size in words */
static double pact = 0.2; /* probability per pass of acting */
static unsigned rinter = 75; /* pass interval for recursion */
static unsigned rmax = 10; /* maximum recursion depth */
#define DJRUN(fname, alloc, free) \
static unsigned fname##_inner(mps_ap_t ap, unsigned depth, unsigned r) { \
struct {void *p; size_t s;} *blocks = alloca(sizeof(blocks[0]) * nblocks); \
unsigned j, k; \
\
for (k = 0; k < nblocks; ++k) { \
blocks[k].p = NULL; \
} \
\
for (j = 0; j < npass; ++j) { \
for (k = 0; k < nblocks; ++k) { \
if (rnd() % 16384 < pact * 16384) { \
if (blocks[k].p == NULL) { \
size_t s = rnd() % ((sizeof(void *) << (rnd() % sshift)) - 1); \
void *p = NULL; \
if (s > 0) alloc(p, s); \
blocks[k].p = p; \
blocks[k].s = s; \
} else { \
free(blocks[k].p, blocks[k].s); \
blocks[k].p = NULL; \
} \
} \
} \
if (rinter > 0 && depth > 0 && ++r % rinter == 0) { \
/* putchar('>'); fflush(stdout); */ \
r = fname##_inner(ap, depth - 1, r); \
/* putchar('<'); fflush(stdout); */ \
} \
} \
\
for (k = 0; k < nblocks; ++k) { \
if (blocks[k].p) { \
free(blocks[k].p, blocks[k].s); \
blocks[k].p = NULL; \
} \
} \
return r; \
} \
\
static void *fname(void *p) { \
unsigned i; \
mps_ap_t ap = NULL; \
if (pool != NULL) \
MUST(mps_ap_create_k(&ap, pool, mps_args_none)); \
for (i = 0; i < niter; ++i) \
(void)fname##_inner(ap, rmax, 0); \
if (ap != NULL) \
mps_ap_destroy(ap); \
return p; \
}
/* malloc/free benchmark */
#define MALLOC_ALLOC(p, s) do { p = malloc(s); } while(0)
#define MALLOC_FREE(p, s) do { free(p); } while(0)
DJRUN(dj_malloc, MALLOC_ALLOC, MALLOC_FREE)
/* mps_alloc/mps_free benchmark */
#define MPS_ALLOC(p, s) do { mps_alloc(&p, pool, s); } while(0)
#define MPS_FREE(p, s) do { mps_free(pool, p, s); } while(0)
DJRUN(dj_alloc, MPS_ALLOC, MPS_FREE)
/* reserve/free benchmark */
#define ALIGN_UP(s, a) (((s) + ((a) - 1)) & ~((a) - 1))
#define RESERVE_ALLOC(p, s) \
do { \
size_t _s = ALIGN_UP(s, (size_t)MPS_PF_ALIGN); \
mps_reserve(&p, ap, _s); \
mps_commit(ap, p, _s); \
} while(0)
#define RESERVE_FREE(p, s) do { mps_free(pool, p, s); } while(0)
DJRUN(dj_reserve, RESERVE_ALLOC, RESERVE_FREE)
typedef void *(*dj_t)(void *);
static void weave(dj_t dj)
{
pthread_t *threads = alloca(sizeof(threads[0]) * nthreads);
unsigned t;
for (t = 0; t < nthreads; ++t) {
int err = pthread_create(&threads[t], NULL, dj, NULL);
if (err != 0) {
fprintf(stderr, "Unable to create thread: %d\n", err);
exit(EXIT_FAILURE);
}
}
for (t = 0; t < nthreads; ++t) {
int err = pthread_join(threads[t], NULL);
if (err != 0) {
fprintf(stderr, "Unable to join thread: %d\n", err);
exit(EXIT_FAILURE);
}
}
}
static void watch(dj_t dj, const char *name)
{
clock_t start, finish;
start = clock();
if (nthreads == 1)
dj(NULL);
else
weave(dj);
finish = clock();
printf("%s: %g\n", name, (double)(finish - start) / CLOCKS_PER_SEC);
}
/* Wrap a call to dj benchmark that doesn't require MPS setup */
static void wrap(dj_t dj, mps_class_t dummy, const char *name)
{
(void)dummy;
pool = NULL;
watch(dj, name);
}
/* Wrap a call to a dj benchmark that requires MPS setup */
static void arena_wrap(dj_t dj, mps_class_t pool_class, const char *name)
{
MPS_ARGS_BEGIN(args) {
MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, 256ul * 1024 * 1024); /* FIXME: Why is there no default? */
MPS_ARGS_DONE(args);
MUST(mps_arena_create_k(&arena, mps_arena_class_vm(), args));
} MPS_ARGS_END(args);
MUST(mps_pool_create_k(&pool, arena, pool_class, mps_args_none));
watch(dj, name);
mps_pool_destroy(pool);
mps_arena_destroy(arena);
}
/* Command-line options definitions. See getopt_long(3). */
static struct option longopts[] = {
{"help", no_argument, NULL, 'h'},
{"nthreads",required_argument, NULL, 't'},
{"niter", required_argument, NULL, 'i'},
{"npass", required_argument, NULL, 'p'},
{"nblocks", required_argument, NULL, 'b'},
{"sshift", required_argument, NULL, 's'},
{"pact", required_argument, NULL, 'a'},
{"rinter", required_argument, NULL, 'r'},
{"rmax", required_argument, NULL, 'd'},
{"seed", required_argument, NULL, 'x'},
{NULL, 0, NULL, 0}
};
/* Test definitions. */
static mps_class_t dummy_class(void)
{
return NULL;
}
static struct {
const char *name;
void (*wrap)(dj_t, mps_class_t, const char *name);
dj_t dj;
mps_class_t (*pool_class)(void);
} pools[] = {
{"mvt", arena_wrap, dj_reserve, mps_class_mvt},
{"mvff", arena_wrap, dj_reserve, mps_class_mvff},
{"mv", arena_wrap, dj_alloc, mps_class_mv},
{"mvb", arena_wrap, dj_reserve, mps_class_mv}, /* mv with buffers */
{"an", wrap, dj_malloc, dummy_class},
};
/* Command-line driver */
int main(int argc, char *argv[]) {
int ch;
unsigned i;
seed = rnd_seed();
while ((ch = getopt_long(argc, argv, "ht:i:p:b:s:a:r:d:x:", longopts, NULL)) != -1)
switch (ch) {
case 't':
nthreads = (unsigned)strtoul(optarg, NULL, 10);
break;
case 'i':
niter = (unsigned)strtoul(optarg, NULL, 10);
break;
case 'p':
npass = (unsigned)strtoul(optarg, NULL, 10);
break;
case 'b':
nblocks = (unsigned)strtoul(optarg, NULL, 10);
break;
case 's':
sshift = (unsigned)strtoul(optarg, NULL, 10);
break;
case 'a':
pact = strtod(optarg, NULL);
break;
case 'r':
rinter = (unsigned)strtoul(optarg, NULL, 10);
break;
case 'd':
rmax = (unsigned)strtoul(optarg, NULL, 10);
break;
case 'x':
seed = strtoul(optarg, NULL, 10);
break;
default:
fprintf(stderr,
"Usage: %s [option...] [test...]\n"
"Options:\n"
" -t n, --nthreads=n\n"
" Launch n threads each running the test\n"
" -i n, --niter=n\n"
" Iterate each test n times (default %u).\n"
" -p n, --npass=n\n"
" Pass over the block array n times (default %u).\n"
" -b n, --nblocks=n\n"
" Length of the block array (default %u).\n"
" -s n, --sshift=n\n"
" Log2 max block size in words (default %u).\n"
" -a p, --pact=p\n"
" Probability of acting on a block (default %g).\n",
argv[0],
niter,
npass,
nblocks,
sshift,
pact);
fprintf(stderr,
" -r n, --rinter=n\n"
" Recurse every n passes if n > 0 (default %u).\n"
" -d n, --rmax=n\n"
" Maximum recursion depth (default %u).\n"
" -x n, --seed=n\n"
" Random number seed (default from entropy).\n"
"Tests:\n"
" mvt pool class MVT\n"
" mvff pool class MVFF\n"
" mv pool class MV\n"
" mvb pool class MV with buffers\n"
" an malloc\n",
rinter,
rmax);
return EXIT_FAILURE;
}
argc -= optind;
argv += optind;
printf("seed: %lu\n", seed);
while (argc > 0) {
for (i = 0; i < sizeof(pools) / sizeof(pools[0]); ++i)
if (strcmp(argv[0], pools[i].name) == 0)
goto found;
fprintf(stderr, "unknown pool test \"%s\"\n", argv[0]);
return EXIT_FAILURE;
found:
rnd_state_set(seed);
pools[i].wrap(pools[i].dj, pools[i].pool_class(), pools[i].name);
--argc;
++argv;
}
return EXIT_SUCCESS;
}
/* C. COPYRIGHT AND LICENSE
*
* Copyright (c) 2001-2013 Ravenbrook Limited <http://www.ravenbrook.com/>.
* All rights reserved. This is an open source license. Contact
* Ravenbrook for commercial licensing options.
*
* 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.
*
* 3. Redistributions in any form must be accompanied by information on how
* to obtain complete source code for this software and any accompanying
* software that uses this software. The source code must either be
* included in the distribution or be available for no more than the cost
* of distribution plus a nominal fee, and must be freely redistributable
* under reasonable conditions. For an executable file, complete source
* code means the source code for all modules it contains. It does not
* include source code for modules or files that typically accompany the
* major components of the operating system on which the executable file
* runs.
*
* 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, FITNESS FOR A PARTICULAR
* PURPOSE, OR NON-INFRINGEMENT, ARE DISCLAIMED. IN NO EVENT SHALL THE
* COPYRIGHT HOLDERS AND 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.
*/

99
mps/code/mps.xcodeproj/project.pbxproj
View file

@ -204,6 +204,9 @@
3124CAFB156BE82000753214 /* testlib.c in Sources */ = {isa = PBXBuildFile; fileRef = 31EEAC9E156AB73400714D05 /* testlib.c */; };
3124CAFC156BE82900753214 /* libmps.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 31EEABFB156AAF9D00714D05 /* libmps.a */; };
3150AE53156ABA2500A6E22A /* libmps.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 31EEABFB156AAF9D00714D05 /* libmps.a */; };
318DA8CF1892B1210089718C /* djbench.c in Sources */ = {isa = PBXBuildFile; fileRef = 318DA8CE1892B1210089718C /* djbench.c */; };
318DA8D21892B13B0089718C /* getoptl.c in Sources */ = {isa = PBXBuildFile; fileRef = 318DA8D11892B13B0089718C /* getoptl.c */; };
318DA8D31892B27E0089718C /* testlib.c in Sources */ = {isa = PBXBuildFile; fileRef = 31EEAC9E156AB73400714D05 /* testlib.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 */; };
@ -1037,6 +1040,15 @@
);
runOnlyForDeploymentPostprocessing = 1;
};
318DA8C81892B0F30089718C /* CopyFiles */ = {
isa = PBXCopyFilesBuildPhase;
buildActionMask = 2147483647;
dstPath = /usr/share/man/man1/;
dstSubfolderSpec = 0;
files = (
);
runOnlyForDeploymentPostprocessing = 1;
};
31D6000B156D3CB200337B26 /* CopyFiles */ = {
isa = PBXCopyFilesBuildPhase;
buildActionMask = 2147483647;
@ -1208,7 +1220,6 @@
311F2F6917398B3B00C15B6A /* mpstd.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = mpstd.h; sourceTree = "<group>"; };
311F2F6A17398B4C00C15B6A /* mpsw3.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = mpsw3.h; sourceTree = "<group>"; };
311F2F6B17398B4C00C15B6A /* mpswin.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = mpswin.h; sourceTree = "<group>"; };
311F2F6C17398B5800C15B6A /* osxc.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = osxc.h; sourceTree = "<group>"; };
311F2F6D17398B6300C15B6A /* prmci3.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = prmci3.h; sourceTree = "<group>"; };
311F2F6E17398B6300C15B6A /* prmci6.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = prmci6.h; sourceTree = "<group>"; };
311F2F6F17398B6300C15B6A /* prmcix.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = prmcix.h; sourceTree = "<group>"; };
@ -1240,6 +1251,10 @@
315B7AFC17834FDB00B097C4 /* proti3.c */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.c; path = proti3.c; sourceTree = "<group>"; };
315B7AFD17834FDB00B097C4 /* proti6.c */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.c; path = proti6.c; sourceTree = "<group>"; };
317B3C2A1731830100F9A469 /* arg.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = arg.c; sourceTree = "<group>"; };
318DA8CD1892B0F30089718C /* djbench */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = djbench; sourceTree = BUILT_PRODUCTS_DIR; };
318DA8CE1892B1210089718C /* djbench.c */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.c; path = djbench.c; sourceTree = "<group>"; };
318DA8D01892B13B0089718C /* getopt.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = getopt.h; sourceTree = "<group>"; };
318DA8D11892B13B0089718C /* getoptl.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = getoptl.c; sourceTree = "<group>"; };
31A47BA3156C1E130039B1C2 /* mps.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = mps.c; sourceTree = "<group>"; };
31A47BA5156C1E5E0039B1C2 /* ssixi3.c */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.c; path = ssixi3.c; sourceTree = "<group>"; };
31C83ADD1786281C0031A0DB /* protxc.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = protxc.h; sourceTree = "<group>"; };
@ -1560,6 +1575,13 @@
);
runOnlyForDeploymentPostprocessing = 0;
};
318DA8C71892B0F30089718C /* Frameworks */ = {
isa = PBXFrameworksBuildPhase;
buildActionMask = 2147483647;
files = (
);
runOnlyForDeploymentPostprocessing = 0;
};
31D6000A156D3CB200337B26 /* Frameworks */ = {
isa = PBXFrameworksBuildPhase;
buildActionMask = 2147483647;
@ -1714,6 +1736,16 @@
name = Tests;
sourceTree = "<group>";
};
318DA8C21892B0B20089718C /* Benchmarks */ = {
isa = PBXGroup;
children = (
318DA8D01892B13B0089718C /* getopt.h */,
318DA8D11892B13B0089718C /* getoptl.c */,
318DA8CE1892B1210089718C /* djbench.c */,
);
name = Benchmarks;
sourceTree = "<group>";
};
31A47BA8156C1E930039B1C2 /* MPS */ = {
isa = PBXGroup;
children = (
@ -1733,6 +1765,7 @@
3114A6D6156E9846001E0AA3 /* Tools */,
31A47BA8156C1E930039B1C2 /* MPS */,
3124CAB3156BE1B700753214 /* Tests */,
318DA8C21892B0B20089718C /* Benchmarks */,
31FCAE171769247F008C034C /* Scheme */,
31EEABEF156AAF5C00714D05 /* Products */,
);
@ -1780,6 +1813,7 @@
2291A5E3175CB05F001D4920 /* exposet0 */,
224CC799175E1821002FF81B /* fotest */,
31FCAE0A17692403008C034C /* scheme */,
318DA8CD1892B0F30089718C /* djbench */,
);
name = Products;
sourceTree = "<group>";
@ -1838,7 +1872,6 @@
311F2F6917398B3B00C15B6A /* mpstd.h */,
311F2F6A17398B4C00C15B6A /* mpsw3.h */,
311F2F6B17398B4C00C15B6A /* mpswin.h */,
311F2F6C17398B5800C15B6A /* osxc.h */,
31EEAC09156AB27B00714D05 /* pool.c */,
31EEAC0A156AB27B00714D05 /* poolabs.c */,
31EEAC2D156AB2F200714D05 /* poolmfs.c */,
@ -2491,6 +2524,23 @@
productReference = 3124CAEB156BE7F300753214 /* amcss */;
productType = "com.apple.product-type.tool";
};
318DA8C31892B0F30089718C /* djbench */ = {
isa = PBXNativeTarget;
buildConfigurationList = 318DA8C91892B0F30089718C /* Build configuration list for PBXNativeTarget "djbench" */;
buildPhases = (
318DA8C41892B0F30089718C /* Sources */,
318DA8C71892B0F30089718C /* Frameworks */,
318DA8C81892B0F30089718C /* CopyFiles */,
);
buildRules = (
);
dependencies = (
);
name = djbench;
productName = scheme;
productReference = 318DA8CD1892B0F30089718C /* djbench */;
productType = "com.apple.product-type.tool";
};
31D6000C156D3CB200337B26 /* awluthe */ = {
isa = PBXNativeTarget;
buildConfigurationList = 31D60014156D3CB200337B26 /* Build configuration list for PBXNativeTarget "awluthe" */;
@ -2712,6 +2762,7 @@
2D604B9B16514B1A003AAF46 /* mpseventtxt */,
22CDE8EF16E9E97D00366D0A /* testrun */,
31FCAE0917692403008C034C /* scheme */,
318DA8C31892B0F30089718C /* djbench */,
);
};
/* End PBXProject section */
@ -3049,6 +3100,16 @@
);
runOnlyForDeploymentPostprocessing = 0;
};
318DA8C41892B0F30089718C /* Sources */ = {
isa = PBXSourcesBuildPhase;
buildActionMask = 2147483647;
files = (
318DA8D31892B27E0089718C /* testlib.c in Sources */,
318DA8D21892B13B0089718C /* getoptl.c in Sources */,
318DA8CF1892B1210089718C /* djbench.c in Sources */,
);
runOnlyForDeploymentPostprocessing = 0;
};
31D60009156D3CB200337B26 /* Sources */ = {
isa = PBXSourcesBuildPhase;
buildActionMask = 2147483647;
@ -4496,6 +4557,30 @@
};
name = WE;
};
318DA8CA1892B0F30089718C /* Debug */ = {
isa = XCBuildConfiguration;
buildSettings = {
GCC_TREAT_WARNINGS_AS_ERRORS = NO;
PRODUCT_NAME = djbench;
};
name = Debug;
};
318DA8CB1892B0F30089718C /* Release */ = {
isa = XCBuildConfiguration;
buildSettings = {
GCC_TREAT_WARNINGS_AS_ERRORS = NO;
PRODUCT_NAME = djbench;
};
name = Release;
};
318DA8CC1892B0F30089718C /* WE */ = {
isa = XCBuildConfiguration;
buildSettings = {
GCC_TREAT_WARNINGS_AS_ERRORS = NO;
PRODUCT_NAME = djbench;
};
name = WE;
};
31D60015156D3CB200337B26 /* Debug */ = {
isa = XCBuildConfiguration;
buildSettings = {
@ -5108,6 +5193,16 @@
defaultConfigurationIsVisible = 0;
defaultConfigurationName = Release;
};
318DA8C91892B0F30089718C /* Build configuration list for PBXNativeTarget "djbench" */ = {
isa = XCConfigurationList;
buildConfigurations = (
318DA8CA1892B0F30089718C /* Debug */,
318DA8CB1892B0F30089718C /* Release */,
318DA8CC1892B0F30089718C /* WE */,
);
defaultConfigurationIsVisible = 0;
defaultConfigurationName = Release;
};
31D60014156D3CB200337B26 /* Build configuration list for PBXNativeTarget "awluthe" */ = {
isa = XCConfigurationList;
buildConfigurations = (

16
mps/code/testlib.c
View file

@ -236,6 +236,16 @@ double rnd_double(void)
}
rnd_state_t rnd_seed(void)
{
/* Initialize seed based on seconds since epoch and on processor
* cycle count. */
EventClock t2;
EVENT_CLOCK(t2);
return 1 + ((unsigned long)time(NULL) + (unsigned long)t2) % (R_m - 1);
}
/* randomize -- randomize the generator, or initialize to replay
*
* There have been 3 versions of the rnd-states reported by this
@ -270,11 +280,7 @@ void randomize(int argc, char *argv[])
argv[0], seed0);
rnd_state_set(seed0);
} else {
/* Initialize seed based on seconds since epoch and on processor
* cycle count. */
EventClock t2;
EVENT_CLOCK(t2);
seed0 = 1 + ((unsigned long)time(NULL) + (unsigned long)t2) % (R_m - 1);
seed0 = rnd_seed();
printf("%s: randomize(): choosing initial state (v3): %lu.\n",
argv[0], seed0);
rnd_state_set(seed0);

1
mps/code/testlib.h
View file

@ -197,6 +197,7 @@ typedef unsigned long rnd_state_t;
extern rnd_state_t rnd_state(void);
extern void rnd_state_set(rnd_state_t state_v3);
extern void rnd_state_set_v2(rnd_state_t seed0_v2); /* legacy */
extern rnd_state_t rnd_seed(void);
/* rnd_verify() -- checks behaviour of rnd() */

32
mps/example/scheme/scheme.c
View file

@ -133,12 +133,12 @@ typedef struct integer_s {
typedef struct special_s {
type_t type; /* TYPE_SPECIAL */
char *name; /* printed representation, NUL terminated */
const char *name; /* printed representation, NUL terminated */
} special_s;
typedef struct operator_s {
type_t type; /* TYPE_OPERATOR */
char *name; /* printed name, NUL terminated */
const char *name; /* printed name, NUL terminated */
entry_t entry; /* entry point -- see eval() */
obj_t arguments, body; /* function arguments and code */
obj_t env, op_env; /* closure environments */
@ -389,7 +389,7 @@ static mps_ap_t obj_ap; /* allocation point used to allocate objects */
* message.
*/
static void error(char *format, ...)
static void error(const char *format, ...)
{
va_list args;
@ -484,7 +484,7 @@ static obj_t make_integer(long integer)
return obj;
}
static obj_t make_symbol(size_t length, char string[])
static obj_t make_symbol(size_t length, const char string[])
{
obj_t obj;
mps_addr_t addr;
@ -519,7 +519,7 @@ static obj_t make_string(size_t length, char string[])
return obj;
}
static obj_t make_special(char *string)
static obj_t make_special(const char *string)
{
obj_t obj;
mps_addr_t addr;
@ -535,7 +535,7 @@ static obj_t make_special(char *string)
return obj;
}
static obj_t make_operator(char *name,
static obj_t make_operator(const char *name,
entry_t entry, obj_t arguments,
obj_t body, obj_t env, obj_t op_env)
{
@ -732,7 +732,7 @@ static unsigned long hash(const char *s, size_t length) {
* is full.
*/
static obj_t *find(char *string) {
static obj_t *find(const char *string) {
unsigned long i, h, probe;
h = hash(string, strlen(string));
@ -791,7 +791,7 @@ static void rehash(void) {
}
/* union-find string in symbol table, rehashing if necessary */
static obj_t intern(char *string) {
static obj_t intern(const char *string) {
obj_t *where;
where = find(string);
@ -1549,7 +1549,7 @@ static obj_t load(obj_t env, obj_t op_env, obj_t filename) {
* using the message given.
*/
static obj_t eval_list(obj_t env, obj_t op_env, obj_t list, char *message)
static obj_t eval_list(obj_t env, obj_t op_env, obj_t list, const char *message)
{
obj_t result, end, pair;
result = obj_empty;
@ -1574,7 +1574,7 @@ static obj_t eval_list(obj_t env, obj_t op_env, obj_t list, char *message)
* See eval_args and eval_args_rest for usage.
*/
static obj_t eval_args1(char *name, obj_t env, obj_t op_env,
static obj_t eval_args1(const char *name, obj_t env, obj_t op_env,
obj_t operands, unsigned n, va_list args)
{
unsigned i;
@ -1599,7 +1599,7 @@ static obj_t eval_args1(char *name, obj_t env, obj_t op_env,
* eval_args("foo", env, op_env, operands, 2, &arg1, &arg2);
*/
static void eval_args(char *name, obj_t env, obj_t op_env,
static void eval_args(const char *name, obj_t env, obj_t op_env,
obj_t operands, unsigned n, ...)
{
va_list args;
@ -1623,7 +1623,7 @@ static void eval_args(char *name, obj_t env, obj_t op_env,
* eval_args_rest("foo", env, op_env, operands, &rest, 2, &arg1, &arg2);
*/
static void eval_args_rest(char *name, obj_t env, obj_t op_env,
static void eval_args_rest(const char *name, obj_t env, obj_t op_env,
obj_t operands, obj_t *restp, unsigned n, ...)
{
va_list args;
@ -3731,7 +3731,7 @@ static obj_t entry_gc(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
/* special table */
static struct {char *name; obj_t *varp;} sptab[] = {
static struct {const char *name; obj_t *varp;} sptab[] = {
{"()", &obj_empty},
{"#[eof]", &obj_eof},
{"#[error]", &obj_error},
@ -3745,7 +3745,7 @@ static struct {char *name; obj_t *varp;} sptab[] = {
/* initial symbol table */
static struct {char *name; obj_t *varp;} isymtab[] = {
static struct {const char *name; obj_t *varp;} isymtab[] = {
{"quote", &obj_quote},
{"lambda", &obj_lambda},
{"begin", &obj_begin},
@ -3758,7 +3758,7 @@ static struct {char *name; obj_t *varp;} isymtab[] = {
/* operator table */
static struct {char *name; entry_t entry;} optab[] = {
static struct {const char *name; entry_t entry;} optab[] = {
{"quote", entry_quote},
{"define", entry_define},
{"set!", entry_set},
@ -3779,7 +3779,7 @@ static struct {char *name; entry_t entry;} optab[] = {
/* function table */
static struct {char *name; entry_t entry;} funtab[] = {
static struct {const char *name; entry_t entry;} funtab[] = {
{"not", entry_not},
{"boolean?", entry_booleanp},
{"eqv?", entry_eqvp},