From 5114f5973c05b535f1ec127e3f4a679a3df07493 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Apr 2011 06:35:10 -0600 Subject: [PATCH 01/23] remove unneeded places prefab-key conversions (second try) --- src/racket/src/places.c | 13 ++++-- src/racket/src/struct.c | 98 +++++------------------------------------ 2 files changed, 20 insertions(+), 91 deletions(-) diff --git a/src/racket/src/places.c b/src/racket/src/places.c index 08eea0c62e..de5cff031e 100644 --- a/src/racket/src/places.c +++ b/src/racket/src/places.c @@ -1054,7 +1054,7 @@ Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab } } - nprefab_key = scheme_places_deep_copy_worker(stype->prefab_key, ht, copy); + nprefab_key = scheme_places_deep_copy_worker(SCHEME_CDR(stype->prefab_key), ht, copy); if (copy) { new_so = scheme_make_serialized_struct_instance(nprefab_key, size); @@ -1080,13 +1080,16 @@ Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so; Scheme_Struct_Type *stype; Scheme_Structure *nst; + Scheme_Object *key; intptr_t size; int i = 0; size = st->num_slots; - stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size); + key = scheme_places_deep_copy_worker(st->prefab_key, ht, copy); + if (copy) { + stype = scheme_lookup_prefab_type(key, size); new_so = scheme_make_blank_prefab_struct_instance(stype); nst = (Scheme_Structure*)new_so; } else @@ -1384,11 +1387,13 @@ Scheme_Object *scheme_places_deserialize_worker(Scheme_Object *so) Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so; Scheme_Struct_Type *stype; Scheme_Structure *nst; + Scheme_Object *key; intptr_t size; int i = 0; - + size = st->num_slots; - stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size); + key = scheme_places_deserialize_worker(st->prefab_key); + stype = scheme_lookup_prefab_type(key, size); nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype); for (i = 0; i stype->prefab_key) { - Scheme_Object *prefab_key; - prefab_key = SCHEME_CDR(s->stype->prefab_key); -#ifdef MZ_USE_PLACES - return convert_prefab_key_to_external_form(prefab_key); -#else - return prefab_key; -#endif + return SCHEME_CDR(s->stype->prefab_key); } return scheme_false; @@ -3966,8 +3957,6 @@ Scheme_Struct_Type *scheme_make_prefab_struct_type_raw(Scheme_Object *base, struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0); struct_type->name_pos = depth; struct_type->inspector = scheme_false; - //Scheme_Object *accessor *mutator; - //Scheme_Object *prefab_key; struct_type->uninit_val = uninit_val; struct_type->props = NULL; struct_type->num_props = 0; @@ -3988,19 +3977,12 @@ static Scheme_Struct_Type *scheme_make_prefab_struct_type(Scheme_Object *base, Scheme_Object *uninit_val, char *immutable_array) { -#ifdef MZ_USE_PLACES -/* - return scheme_make_prefab_struct_type_in_master -*/ -#else -#endif - return scheme_make_prefab_struct_type_raw - (base, - parent, - num_fields, - num_uninit_fields, - uninit_val, - immutable_array); + return scheme_make_prefab_struct_type_raw(base, + parent, + num_fields, + num_uninit_fields, + uninit_val, + immutable_array); } static Scheme_Object *_make_struct_type(Scheme_Object *base, @@ -4638,19 +4620,7 @@ static Scheme_Object *make_prefab_key(Scheme_Struct_Type *type) if (!SCHEME_NULLP(stack)) key = scheme_make_pair(scheme_make_integer(icnt), key); -/*symbols aren't equal? across places now*/ -#if defined(MZ_USE_PLACES) - if (SCHEME_SYMBOLP(type->name)) { - Scheme_Object *newname; - newname = scheme_make_sized_offset_byte_string((char *)type->name, SCHEME_SYMSTR_OFFSET(type->name), SCHEME_SYM_LEN(type->name), 1); - key = scheme_make_pair(newname, key); - } - else { - scheme_arg_mismatch("make_prefab_key", "unknown type of struct name", type->name); - } -#else key = scheme_make_pair(type->name, key); -#endif if (SCHEME_PAIRP(stack)) { type = (Scheme_Struct_Type *)SCHEME_CAR(stack); @@ -4703,29 +4673,6 @@ static char *mutability_data_to_immutability_data(int icnt, Scheme_Object *mutab return immutable_array; } -#ifdef MZ_USE_PLACES -static Scheme_Object *convert_prefab_key_to_external_form(Scheme_Object *key) -{ - Scheme_Object *l; - Scheme_Object *nl; - - if (SCHEME_SYMBOLP(key)) return key; - if (SCHEME_BYTE_STRINGP(key)) - return scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(key), SCHEME_BYTE_STRLEN_VAL(key)); - - nl = scheme_null; - for (l = key; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - Scheme_Object *a; - a = SCHEME_CAR(l); - if (SCHEME_BYTE_STRINGP(a)) - a = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(a), SCHEME_BYTE_STRLEN_VAL(a)); - nl = scheme_make_pair(a, nl); - } - - return scheme_reverse(nl); -} -#endif - Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_count) { Scheme_Struct_Type *parent = NULL; @@ -4733,19 +4680,8 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun int ucnt, icnt; char *immutable_array = NULL; -/*symbols aren't equal? across places now*/ -#if defined(MZ_USE_PLACES) - if (SCHEME_SYMBOLP(key)) { - Scheme_Object *newname; - newname = scheme_make_sized_offset_byte_string((char*)key, SCHEME_SYMSTR_OFFSET(key), SCHEME_SYM_LEN(key), 1); - key = scheme_make_pair(newname, scheme_null); - } - if (SCHEME_BYTE_STRINGP(key)) - key = scheme_make_pair(key, scheme_null); -#else if (SCHEME_SYMBOLP(key)) key = scheme_make_pair(key, scheme_null); -#endif if (scheme_proper_list_length(key) < 0) return NULL; @@ -4819,21 +4755,9 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun a = SCHEME_CAR(key); key = SCHEME_CDR(key); -/*symbols aren't equal? across places now*/ -#if defined(MZ_USE_PLACES) - if (SCHEME_SYMBOLP(a)) { - name = a; - } - else if (SCHEME_BYTE_STRINGP(a)) - name = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(a), SCHEME_BYTE_STRLEN_VAL(a)); - else - return NULL; -#else if (!SCHEME_SYMBOLP(a)) return NULL; name = a; -#endif - immutable_array = mutability_data_to_immutability_data(icnt + ucnt, mutables); @@ -4841,10 +4765,10 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun return NULL; parent = scheme_make_prefab_struct_type(name, - (Scheme_Object *)parent, - icnt, ucnt, - uninit_val, - immutable_array); + (Scheme_Object *)parent, + icnt, ucnt, + uninit_val, + immutable_array); } From 76480006085cb92226c3305dbe86623d64d62862 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Apr 2011 06:51:36 -0600 Subject: [PATCH 02/23] fix alloc_cache page counting --- src/racket/gc2/alloc_cache.c | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/racket/gc2/alloc_cache.c b/src/racket/gc2/alloc_cache.c index 44895afa90..4a3ee07d80 100644 --- a/src/racket/gc2/alloc_cache.c +++ b/src/racket/gc2/alloc_cache.c @@ -207,7 +207,7 @@ static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, siz r = alloc_cache_find_pages(blockfree, len, alignment, dirty_ok); if(!r) { /* attempt to allocate from OS */ - size_t extra = alignment + CACHE_SEED_PAGES * APAGE_SIZE; + size_t extra = (alignment ? (alignment + CACHE_SEED_PAGES * APAGE_SIZE) : 0); r = os_alloc_pages(len + extra); if(r == (void *)-1) { return NULL; } @@ -227,13 +227,14 @@ static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, siz a good chance we can use it next time: */ (*size_diff) += extra; (*size_diff) += alloc_cache_free_page(blockfree, real_r + len, extra, 1); - } - else { os_free_pages(real_r + len, extra - pre_extra); } + } else { + os_free_pages(real_r + len, extra - pre_extra); + } } r = real_r; } - (*size_diff) += extra; + (*size_diff) += len; } return r; From aaf74636c2e696fb191dc37f1986ea67230a8e4f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Apr 2011 06:58:14 -0600 Subject: [PATCH 03/23] another __FreeBSD_kernel__ fix --- src/racket/gc2/sighand.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/racket/gc2/sighand.c b/src/racket/gc2/sighand.c index 5e79bbbba1..7b137fa5f4 100644 --- a/src/racket/gc2/sighand.c +++ b/src/racket/gc2/sighand.c @@ -125,7 +125,7 @@ void fault_handler(int sn, struct siginfo *si, void *ctx) /* ========== FreeBSD/NetBSD/OpenBSD signal handler ========== */ /* As of 2007/06/29, this is a guess for NetBSD! */ -#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) +#if defined(__FreeBSD__) || defined(__FreeBSD_kernel__) || defined(__NetBSD__) || defined(__OpenBSD__) # include # include void fault_handler(int sn, siginfo_t *si, void *ctx) From 3dc38f25eec6709e3ad84f8de3655cd92707db7c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Apr 2011 07:08:07 -0600 Subject: [PATCH 04/23] adjust GC logging, include JIT pages size --- src/racket/src/thread.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index 3c3371d4dd..02864b97b9 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -7624,6 +7624,8 @@ static char *gc_num(char *nums, int v) } i++; + v /= 1024; /* bytes => kbytes */ + sprintf(nums+i, "%d", v); for (len = 0; nums[i+len]; len++) { } clen = len + ((len + ((nums[i] == '-') ? -2 : -1)) / 3); @@ -7667,13 +7669,14 @@ static void inform_GC(int master_gc, int major_gc, delta = pre_used - post_used; admin_delta = (pre_admin - post_admin) - delta; sprintf(buf, - "GC [" PLACE_ID_FORMAT "%s] at %s(+%s) bytes;" - " %s(%s%s) collected in %" PRIdPTR " msec", + "GC [" PLACE_ID_FORMAT "%s] at %sK(+%sK)[+%sK];" + " freed %sK(%s%sK) in %" PRIdPTR " msec", #ifdef MZ_USE_PLACES scheme_current_place_id, #endif (master_gc ? "MASTER" : (major_gc ? "MAJOR" : "minor")), gc_num(nums, pre_used), gc_num(nums, pre_admin - pre_used), + gc_num(nums, scheme_code_page_total), gc_num(nums, delta), ((admin_delta < 0) ? "" : "+"), gc_num(nums, admin_delta), (master_gc ? 0 : (end_this_gc_time - start_this_gc_time))); buflen = strlen(buf); From 9f50228db845b2622215ec9618bf446b0f5041de Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Apr 2011 09:16:57 -0600 Subject: [PATCH 05/23] fix #include for fpsetmask() --- src/racket/src/number.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/racket/src/number.c b/src/racket/src/number.c index a4cb69b725..fea2871bc9 100644 --- a/src/racket/src/number.c +++ b/src/racket/src/number.c @@ -187,13 +187,13 @@ READ_ONLY Scheme_Object *scheme_single_inf_object, *scheme_single_minus_inf_obje #ifdef FREEBSD_CONTROL_387 -#include +# include #endif #ifdef LINUX_CONTROL_387 -#include +# include #endif #ifdef ALPHA_CONTROL_FP -#include +# include #endif #ifdef ASM_DBLPREC_CONTROL_87 @@ -243,7 +243,7 @@ scheme_init_number (Scheme_Env *env) MZ_SIGSET(SIGFPE, SIG_IGN); #endif #ifdef FREEBSD_CONTROL_387 - fpsetmask(0); + (void)fpsetmask(0); #endif #ifdef LINUX_CONTROL_387 __setfpucw(_FPU_EXTENDED + _FPU_RC_NEAREST + 0x3F); From 651655f7bc07317e9143154d4f0e998f4aba6445 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Apr 2011 09:53:29 -0600 Subject: [PATCH 06/23] fix memory counting on orphaned message pages --- src/racket/gc2/alloc_cache.c | 14 ++++++------- src/racket/gc2/block_cache.c | 9 +++++---- src/racket/gc2/newgc.c | 38 +++++++++++++++++------------------- src/racket/gc2/vm.c | 10 +++++++--- 4 files changed, 37 insertions(+), 34 deletions(-) diff --git a/src/racket/gc2/alloc_cache.c b/src/racket/gc2/alloc_cache.c index 4a3ee07d80..a15c107bde 100644 --- a/src/racket/gc2/alloc_cache.c +++ b/src/racket/gc2/alloc_cache.c @@ -1,6 +1,6 @@ /* Provides: - static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty) + static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty, int originated_here) static ssize_t void alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree) static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, size_t alignment, int dirty_ok, ssize_t *size_diff) Requires (defined earlier): @@ -112,7 +112,7 @@ inline static void *alloc_cache_find_pages(AllocCacheBlock *blockfree, size_t le return NULL; } -static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty) +static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty, int originated_here) { int i; @@ -124,14 +124,14 @@ static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t blockfree[i].len += len; if (dirty) blockfree[i].zeroed = 0; - return 0; + return (originated_here ? 0 : len); } if (p + len == blockfree[i].start) { blockfree[i].start = p; blockfree[i].len += len; if (dirty) blockfree[i].zeroed = 0; - return 0; + return (originated_here ? 0 : len); } } @@ -141,7 +141,7 @@ static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t blockfree[i].len = len; blockfree[i].age = 0; blockfree[i].zeroed = !dirty; - return 0; + return (originated_here ? 0 : len); } } @@ -149,7 +149,7 @@ static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t alloc_cache_collapse_pages(blockfree); os_free_pages(p, len); - return -len; + return (originated_here ? -len : 0); } static ssize_t alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree) @@ -226,7 +226,7 @@ static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, siz /* Instead of actually unmapping, put it in the cache, and there's a good chance we can use it next time: */ (*size_diff) += extra; - (*size_diff) += alloc_cache_free_page(blockfree, real_r + len, extra, 1); + (*size_diff) += alloc_cache_free_page(blockfree, real_r + len, extra, 1, 1); } else { os_free_pages(real_r + len, extra - pre_extra); } diff --git a/src/racket/gc2/block_cache.c b/src/racket/gc2/block_cache.c index 9f83ac6b0b..d3b30be95b 100644 --- a/src/racket/gc2/block_cache.c +++ b/src/racket/gc2/block_cache.c @@ -12,7 +12,7 @@ static void os_protect_pages(void *p, size_t len, int writable); struct block_desc; static AllocCacheBlock *alloc_cache_create(); static ssize_t alloc_cache_free(AllocCacheBlock *); -static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty); +static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty, int originated_here); static ssize_t alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree); static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, size_t alignment, int dirty_ok, ssize_t *size_diff); @@ -222,7 +222,8 @@ static int find_addr_in_bd(GCList *head, void *p, char* msg) { } #endif -static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int type, int expect_mprotect, void **src_block) { +static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int type, int expect_mprotect, void **src_block, + int originated_here) { switch(type) { case MMU_SMALL_GEN1: { @@ -252,7 +253,7 @@ static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int ty printf("FREE PAGE %i %p %p-%p %03i %03i %04i %04i : %03i %03i %03i %03i %09i\n", expect_mprotect, bg, p, p + APAGE_SIZE, afu, afr, nafu, nafr, afub, afrb, nafub, nafrb, mmu_memory_allocated(bc->mmu)); } #endif - return 0; + return (originated_here ? 0 : len); } break; default: @@ -263,7 +264,7 @@ static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int ty find_addr_in_bd(&bc->non_atomic.free, p, "non_atomic freeblock"))); assert(*src_block == (char*)~0x0); #endif - return alloc_cache_free_page(bc->bigBlockCache, p, len, MMU_DIRTY); + return alloc_cache_free_page(bc->bigBlockCache, p, len, MMU_DIRTY, originated_here); break; } } diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index 26b145160c..e285f2f0ef 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -378,17 +378,18 @@ static void *malloc_pages(NewGC *gc, size_t len, size_t alignment, int dirty, in static void free_pages(NewGC *gc, void *p, size_t len, int type, int expect_mprotect, void **src_block) { gc->used_pages -= size_to_apage_count(len); - mmu_free_page(gc->mmu, p, len, type, expect_mprotect, src_block); + mmu_free_page(gc->mmu, p, len, type, expect_mprotect, src_block, 1); } static void free_orphaned_page(NewGC *gc, mpage *tmp) { - /* free_pages decrements gc->used_pages which is incorrect, since this is an orphaned page + /* free_pages decrements gc->used_pages which is incorrect, since this is an orphaned page, * so we use mmu_free_page directly */ mmu_free_page(gc->mmu, tmp->addr, round_to_apage_size(tmp->size), - page_mmu_type(tmp), - page_mmu_protectable(tmp), - &tmp->mmu_src_block); + page_mmu_type(tmp), + page_mmu_protectable(tmp), + &tmp->mmu_src_block, + 0); /* don't adjust count, since we're failing to adopt it */ free_mpage(tmp); } @@ -899,16 +900,14 @@ static void *allocate_big(const size_t request_size_bytes, int type) gc->gen0.big_pages = bpage; - /* orphan this page from the current GC */ - /* this page is going to be sent to a different place, don't account for it here */ - /* message memory pages shouldn't go into the page_map, they are getting sent to another place */ if (gc->saved_allocator) { + /* MESSAGE ALLOCATION: orphan this page from the current GC; this + page is going to be sent to a different place, so don't account + for it here, and don't put it in the page_map */ orphan_page_accounting(gc, allocate_size); - } - else { + } else pagemap_add(gc->page_maps, bpage); - } - + { void * objptr = BIG_PAGE_TO_OBJECT(bpage); ASSERT_VALID_OBJPTR(objptr); @@ -942,7 +941,11 @@ inline static mpage *create_new_medium_page(NewGC *gc, const int sz, const int p gc->med_pages[pos] = page; gc->med_freelist_pages[pos] = page; - pagemap_add(gc->page_maps, page); + if (gc->saved_allocator) /* see MESSAGE ALLOCATION above */ + orphan_page_accounting(gc, APAGE_SIZE); + else + pagemap_add(gc->page_maps, page); + return page; } @@ -1049,15 +1052,10 @@ inline static mpage *gen0_create_new_nursery_mpage(NewGC *gc, const size_t page_ page->size = PREFIX_SIZE; GEN0_ALLOC_SIZE(page) = page_size; - /* orphan this page from the current GC */ - /* this page is going to be sent to a different place, don't account for it here */ - /* message memory pages shouldn't go into the page_map, they are getting sent to another place */ - if (gc->saved_allocator) { + if (gc->saved_allocator) /* see MESSAGE ALLOCATION above */ orphan_page_accounting(gc, page_size); - } - else { + else pagemap_add_with_size(gc->page_maps, page, page_size); - } GCVERBOSEPAGE(gc, "NEW gen0", page); diff --git a/src/racket/gc2/vm.c b/src/racket/gc2/vm.c index 648948bb54..43fe58575c 100644 --- a/src/racket/gc2/vm.c +++ b/src/racket/gc2/vm.c @@ -135,22 +135,26 @@ static void *mmu_alloc_page(MMU* mmu, size_t len, size_t alignment, int dirty, i return alloc_cache_alloc_page(alloc_cache, len, alignment, dirty, &mmu->memory_allocated); } #else + mmu->memory_allocated += len; return os_alloc_pages(mmu, len, alignment, dirty); #endif } -static void mmu_free_page(MMU* mmu, void *p, size_t len, int type, int expect_mprotect, void **src_block) { +static void mmu_free_page(MMU* mmu, void *p, size_t len, int type, int expect_mprotect, void **src_block, + int originated_here) { mmu_assert_os_page_aligned(mmu, (size_t)p); mmu_assert_os_page_aligned(mmu, len); #ifdef USE_BLOCK_CACHE - mmu->memory_allocated += block_cache_free_page(mmu->block_cache, p, len, type, expect_mprotect, src_block); + mmu->memory_allocated += block_cache_free_page(mmu->block_cache, p, len, type, expect_mprotect, src_block, + originated_here); #elif !( defined(_WIN32) || defined(OSKIT) ) //len = mmu_round_up_to_os_page_size(mmu, len); { AllocCacheBlock *alloc_cache = mmu->alloc_caches[!!expect_mprotect]; - mmu->memory_allocated += alloc_cache_free_page(alloc_cache, p, len, MMU_DIRTY); + mmu->memory_allocated += alloc_cache_free_page(alloc_cache, p, len, MMU_DIRTY, originated_here); } #else + if (originated_here) mmu->memory_allocated -= len; os_free_pages(mmu, p, len); #endif } From ddc9213fbb05ab790b567222afb44af66498e16d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Apr 2011 10:16:35 -0600 Subject: [PATCH 07/23] allocate shared JIT code on pages shared by places --- src/racket/include/mzwin.def | 1 + src/racket/include/mzwin3m.def | 1 + src/racket/include/racket.exp | 1 + src/racket/include/racket3m.exp | 1 + src/racket/src/jitstate.c | 2 +- src/racket/src/salloc.c | 47 +++++++++++++++++++++++++++++++++ src/racket/src/schemef.h | 1 + src/racket/src/schemex.h | 1 + src/racket/src/schemex.inc | 1 + src/racket/src/schemexm.h | 1 + 10 files changed, 56 insertions(+), 1 deletion(-) diff --git a/src/racket/include/mzwin.def b/src/racket/include/mzwin.def index 4064ca015c..007b1aadb5 100644 --- a/src/racket/include/mzwin.def +++ b/src/racket/include/mzwin.def @@ -185,6 +185,7 @@ EXPORTS scheme_eval_compiled_sized_string_with_magic scheme_detach_multple_array scheme_malloc_code + scheme_malloc_permanent_code scheme_free_code scheme_malloc_gcable_code scheme_malloc_eternal diff --git a/src/racket/include/mzwin3m.def b/src/racket/include/mzwin3m.def index 4cdbe20d4b..eba516240e 100644 --- a/src/racket/include/mzwin3m.def +++ b/src/racket/include/mzwin3m.def @@ -194,6 +194,7 @@ EXPORTS GC_malloc_atomic_allow_interior GC_malloc_tagged_allow_interior scheme_malloc_code + scheme_malloc_permanent_code scheme_free_code scheme_malloc_gcable_code scheme_malloc_eternal diff --git a/src/racket/include/racket.exp b/src/racket/include/racket.exp index 0a8dd3a8e1..07ca3c6666 100644 --- a/src/racket/include/racket.exp +++ b/src/racket/include/racket.exp @@ -197,6 +197,7 @@ GC_malloc_atomic GC_malloc_stubborn GC_malloc_uncollectable scheme_malloc_code +scheme_malloc_permanent_code scheme_free_code scheme_malloc_gcable_code scheme_malloc_eternal diff --git a/src/racket/include/racket3m.exp b/src/racket/include/racket3m.exp index 79adea4d10..fe920d3ce1 100644 --- a/src/racket/include/racket3m.exp +++ b/src/racket/include/racket3m.exp @@ -202,6 +202,7 @@ GC_malloc_allow_interior GC_malloc_atomic_allow_interior GC_malloc_tagged_allow_interior scheme_malloc_code +scheme_malloc_permanent_code scheme_free_code scheme_malloc_gcable_code scheme_malloc_eternal diff --git a/src/racket/src/jitstate.c b/src/racket/src/jitstate.c index 5d07da058c..6c61c1a6bb 100644 --- a/src/racket/src/jitstate.c +++ b/src/racket/src/jitstate.c @@ -136,7 +136,7 @@ void *scheme_generate_one(mz_jit_state *old_jitter, buffer = scheme_malloc_gcable_code(size); #endif } else { - buffer = scheme_malloc_code(size); + buffer = scheme_malloc_permanent_code(size); } RECORD_CODE_SIZE(size); } else if (old_jitter) { diff --git a/src/racket/src/salloc.c b/src/racket/src/salloc.c index 77b5361e97..25a8c9de64 100644 --- a/src/racket/src/salloc.c +++ b/src/racket/src/salloc.c @@ -839,6 +839,12 @@ struct free_list_entry { THREAD_LOCAL_DECL(static struct free_list_entry *free_list;) THREAD_LOCAL_DECL(static int free_list_bucket_count;) +#ifdef MZ_USE_PLACES +static mzrt_mutex *permanent_code_mutex = NULL; +static void *permanent_code_page = NULL; +static intptr_t available_code_page_amount = 0; +#endif + static intptr_t get_page_size() { # ifdef PAGESIZE @@ -1095,6 +1101,47 @@ void *scheme_malloc_code(intptr_t size) #endif } +void *scheme_malloc_permanent_code(intptr_t size) +/* allocate code that will never be freed and that can be used + in multiple places */ +{ +#if defined(MZ_USE_PLACES) && (defined(MZ_JIT_USE_MPROTECT) || defined(MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC)) + void *p; + intptr_t page_size; + + if (!permanent_code_mutex) { + /* This function will be called at least once before any other place + is created, so it's ok to create the mutex here. */ + mzrt_mutex_create(&permanent_code_mutex); + } + + /* 16-byte alignment: */ + if (size & 0xF) size += 16 - (size & 0xF); + + mzrt_mutex_lock(permanent_code_mutex); + + if (available_code_page_amount < size) { + page_size = get_page_size(); + page_size *= 4; + while (page_size < size) page_size *= 2; + + permanent_code_page = malloc_page(page_size); + + available_code_page_amount = page_size; + } + + p = permanent_code_page; + permanent_code_page = ((char *)permanent_code_page) + size; + available_code_page_amount -= size; + + mzrt_mutex_unlock(permanent_code_mutex); + + return p; +#else + return scheme_malloc_code(size); +#endif +} + void scheme_free_code(void *p) { #if defined(MZ_JIT_USE_MPROTECT) || defined(MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC) diff --git a/src/racket/src/schemef.h b/src/racket/src/schemef.h index 66aa634730..fe05e3bff0 100644 --- a/src/racket/src/schemef.h +++ b/src/racket/src/schemef.h @@ -399,6 +399,7 @@ MZ_EXTERN void *GC_malloc_uncollectable(size_t size_in_bytes); #endif MZ_EXTERN void *scheme_malloc_code(intptr_t size); +MZ_EXTERN void *scheme_malloc_permanent_code(intptr_t size); MZ_EXTERN void scheme_free_code(void *p); #ifndef MZ_PRECISE_GC MZ_EXTERN void *scheme_malloc_gcable_code(intptr_t size); diff --git a/src/racket/src/schemex.h b/src/racket/src/schemex.h index c7760e7aad..45031faf8c 100644 --- a/src/racket/src/schemex.h +++ b/src/racket/src/schemex.h @@ -308,6 +308,7 @@ void *(*GC_malloc_uncollectable)(size_t size_in_bytes); # endif #endif void *(*scheme_malloc_code)(intptr_t size); +void *(*scheme_malloc_permanent_code)(intptr_t size); void (*scheme_free_code)(void *p); #ifndef MZ_PRECISE_GC void *(*scheme_malloc_gcable_code)(intptr_t size); diff --git a/src/racket/src/schemex.inc b/src/racket/src/schemex.inc index bcb847cff3..3d669fbe97 100644 --- a/src/racket/src/schemex.inc +++ b/src/racket/src/schemex.inc @@ -219,6 +219,7 @@ # endif #endif scheme_extension_table->scheme_malloc_code = scheme_malloc_code; + scheme_extension_table->scheme_malloc_permanent_code = scheme_malloc_permanent_code; scheme_extension_table->scheme_free_code = scheme_free_code; #ifndef MZ_PRECISE_GC scheme_extension_table->scheme_malloc_gcable_code = scheme_malloc_gcable_code; diff --git a/src/racket/src/schemexm.h b/src/racket/src/schemexm.h index 505e2e2085..40feea2bfb 100644 --- a/src/racket/src/schemexm.h +++ b/src/racket/src/schemexm.h @@ -219,6 +219,7 @@ # endif #endif #define scheme_malloc_code (scheme_extension_table->scheme_malloc_code) +#define scheme_malloc_permanent_code (scheme_extension_table->scheme_malloc_permanent_code) #define scheme_free_code (scheme_extension_table->scheme_free_code) #ifndef MZ_PRECISE_GC #define scheme_malloc_gcable_code (scheme_extension_table->scheme_malloc_gcable_code) From 499852087dcc023b70056007b6eb613ec8ba9596 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 28 Apr 2011 14:51:29 -0500 Subject: [PATCH 08/23] stlc bug fix --- collects/redex/examples/stlc.rkt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/redex/examples/stlc.rkt b/collects/redex/examples/stlc.rkt index 4e740cfed2..5e248cc4b2 100644 --- a/collects/redex/examples/stlc.rkt +++ b/collects/redex/examples/stlc.rkt @@ -154,10 +154,16 @@ (test-equal (term (tc x)) (term #f)) (test-equal (term (tc x (x num) (x (-> num num)))) (term num)) (test-equal (term (tc ((λ ((x num)) x) 1))) (term num)) +(test-equal (term (tc ((λ ((x num)) x) 1 2))) (term #f)) (test-equal (term (tc ((λ ((f (-> num num)) (x num)) (f x)) (λ ((x num)) x) 1))) (term num)) (test-equal (term (tc (+ (+ 1 2) 3))) (term num)) (test-equal (term (tc (if0 1 (λ ((x num)) x) 3))) (term #f)) (test-equal (term (tc (if0 1 2 3))) (term num)) (test-equal (term (tc (λ ((x num)) (x)))) (term #f)) +(test-equal (term (tc (1 2))) + (term #f)) +(test-equal (term (tc (λ ((x num)) (1 2)))) + (term #f)) + (test-results) From cfab042e549061e62da8f05e7582ee13dc6326ba Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Thu, 28 Apr 2011 14:20:55 -0400 Subject: [PATCH 09/23] Added TR keywords to default tabify list --- collects/framework/private/main.rkt | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index a1e5c93942..b08e619d76 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -221,6 +221,8 @@ '(struct local + struct: + define: define-type match-define)) (for-each (λ (x) @@ -250,10 +252,18 @@ let/cc let/ec letcc catch let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values + let: letrec: let*: + let-values: letrec-values: let*-values: + let/cc: let/ec: + lambda: λ: + for for/list for/hash for/hasheq for/and for/or for/lists for/first for/last for/fold for* for*/list for*/hash for*/hasheq for*/and for*/or for*/lists for*/first for*/last for*/fold + + for: for/list: for/or: for/lists: for/fold: + for*: for*/lists: do: kernel-syntax-case syntax-case syntax-case* syntax-rules syntax-id-rules From 5592e9b34ba24964d7688c9566f7bda343205ec9 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 28 Apr 2011 16:10:21 -0400 Subject: [PATCH 10/23] Add more TR keywords to tabify list. --- collects/framework/private/main.rkt | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index b08e619d76..18572e0428 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -221,13 +221,13 @@ '(struct local - struct: + struct: define-struct: define-struct/exec: define: - define-type + define-type define-predicate match-define)) (for-each (λ (x) (hash-set! hash-table x 'begin)) - '(case-lambda + '(case-lambda case-lambda: pcase-lambda: match-lambda match-lambda* cond delay @@ -256,6 +256,7 @@ let-values: letrec-values: let*-values: let/cc: let/ec: lambda: λ: + plambda: opt-lambda: popt-lambda: for for/list for/hash for/hasheq for/and for/or for/lists for/first for/last for/fold @@ -263,7 +264,7 @@ for*/lists for*/first for*/last for*/fold for: for/list: for/or: for/lists: for/fold: - for*: for*/lists: do: + for*: for*/lists: for*/fold: do: kernel-syntax-case syntax-case syntax-case* syntax-rules syntax-id-rules From e11582a5228720a995a6c4fec48b1859dd0deab6 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 27 Apr 2011 15:41:45 -0400 Subject: [PATCH 11/23] Chicken can do scheme2 now. --- collects/tests/racket/benchmarks/common/auto.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/racket/benchmarks/common/auto.rkt b/collects/tests/racket/benchmarks/common/auto.rkt index d03a2d59af..52fe78fd99 100755 --- a/collects/tests/racket/benchmarks/common/auto.rkt +++ b/collects/tests/racket/benchmarks/common/auto.rkt @@ -441,7 +441,7 @@ exec racket -qu "$0" ${1+"$@"} run-exe extract-chicken-times clean-up-bin - (append '(scheme2 takr2) + (append '(takr2) racket-specific-progs)) (make-impl 'bigloo void From 7cf64050f8d8dc18d58698d0add35c6119b0ed21 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 27 Apr 2011 17:03:59 -0400 Subject: [PATCH 12/23] Make tabulation script more resilient to incorrect input. --- collects/tests/racket/benchmarks/common/tabulate.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/tests/racket/benchmarks/common/tabulate.rkt b/collects/tests/racket/benchmarks/common/tabulate.rkt index d284938008..5db0bae47e 100755 --- a/collects/tests/racket/benchmarks/common/tabulate.rkt +++ b/collects/tests/racket/benchmarks/common/tabulate.rkt @@ -99,7 +99,8 @@ exec racket -qu "$0" ${1+"$@"} #f)]) (if a ;; compute cpu, real and gc average time for the nothing benchmark - (let ([nothing-runs (map car a)]) + (let ([nothing-runs (map (lambda (x) (map (lambda (y) (or y 0)) x)) + (map car a))]) (map (lambda (x) (exact->inexact (/ x (length nothing-runs)))) (foldl (lambda (x y) (map + x y)) '(0 0 0) From fc531c4dbf936352cab997da1fefc219fa90b250 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 28 Apr 2011 08:48:57 -0400 Subject: [PATCH 13/23] Fix chicken output processing. --- collects/tests/racket/benchmarks/common/auto.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/racket/benchmarks/common/auto.rkt b/collects/tests/racket/benchmarks/common/auto.rkt index 52fe78fd99..3ca0e7a4a1 100755 --- a/collects/tests/racket/benchmarks/common/auto.rkt +++ b/collects/tests/racket/benchmarks/common/auto.rkt @@ -300,7 +300,7 @@ exec racket -qu "$0" ${1+"$@"} #f (if (caddr m) ; if the GC doesn't kick in, chicken doesn't print anything for GC time (* 1000 (string->number (format "#e~a" (cadddr m)))) - #f)))) + 0)))) (define (extract-time-times bm str) (let ([m (regexp-match #rx#"real[ \t]+([0-9m.]+)s.*user[ \t]+([0-9m.]+)s.sys[ \t]+([0-9m.]+)s." str)] From 437baf905a45f4b51ac62cf51a8b07b8e671dc83 Mon Sep 17 00:00:00 2001 From: John Clements Date: Tue, 26 Apr 2011 11:36:56 -0700 Subject: [PATCH 14/23] added simple scribblings from old doc.txt --- collects/stepper/info.rkt | 2 + collects/stepper/scribblings/stepper.scrbl | 177 +++++++++++++++++++++ 2 files changed, 179 insertions(+) create mode 100644 collects/stepper/scribblings/stepper.scrbl diff --git a/collects/stepper/info.rkt b/collects/stepper/info.rkt index 202ca1181d..356f6c2205 100644 --- a/collects/stepper/info.rkt +++ b/collects/stepper/info.rkt @@ -13,3 +13,5 @@ )) (define compile-omit-paths '("debugger-tool.ss")) + +(define scribblings '(("scribblings/stepper.scrbl"))) diff --git a/collects/stepper/scribblings/stepper.scrbl b/collects/stepper/scribblings/stepper.scrbl new file mode 100644 index 0000000000..5b6db19954 --- /dev/null +++ b/collects/stepper/scribblings/stepper.scrbl @@ -0,0 +1,177 @@ +#lang scribble/doc + +@(require scribble/manual) + +@title{The Stepper} + +@section{What is the Stepper?} + +DrRacket includes an "algebraic stepper," a tool which proceeds +through the evaluation of a set of definitions and expressions, +one step at a time. This evaluation shows the user how DrRacket +evaluates expressions and definitions, and can help in debugging +programs. Currently, the Stepper is available in the "Beginning +Student" and "Intermediate Student" language levels. + +@section{How do I use the Stepper?} + +The Stepper operates on the contents of the frontmost DrRacket +window. A click on the "Step" button brings up the stepper +window. The stepper window has two panes, arranged as follows: + +@verbatim{ +------------------ +| | | +| before -> after| +| | | +------------------ +} + +The first, "before," box, shows the current expression. The +region highlighted in green is known as the "redex". You may +pronounce this word in any way you want. It is short for +"reducible expression," and it is the expression which is the +next to be simplified. + +The second, "after," box shows the result of the reduction. The +region highlighted in purple is the new expression which is +substituted for the green one as a result of the reduction. For +most reductions, the only difference between the left- and right-hand +sides should be the contents of the green and purple boxes. + +Please note that the stepper only steps through the expressions +in the definitions window, and does not allow the user to enter +additional expressions. So, for instance, a definitions buffer +which contains only procedure definitions will not result in +any reductions. + +@section{How Does the Stepper work?} + +In order to discover all of the steps that occur during the evaluation +of your code, the Stepper rewrites (or "instruments") your code. +The inserted code uses a mechanism called "continuation marks" to +store information about the program's execution as it is running, +and makes calls to the Stepper before, after and during the evaluation +of each expression, indicating the current shape of the program. + +What does this instrumented code look like? For the curious, here's the +expanded version of @racket[(define (f x) (+ 3 x))] in the beginner +language [*]: + +@racketblock[ +(module #%htdp (lib "lang/htdp-beginner.ss") + (#%plain-module-begin + (define-syntaxes (f) + (#%app make-first-order-function + (quote procedure) + (quote 1) + (quote-syntax f) + (quote-syntax #%app))) + (define-values (test~object) (#%app namespace-variable-value (quote test~object))) + (begin + (define-values (f) + (with-continuation-mark "#" + (#%plain-lambda () (#%plain-app "#")) + (#%plain-app + call-with-values + (#%plain-lambda () + (with-continuation-mark "#" + (#%plain-lambda () (#%plain-app + "#" + (#%plain-lambda () beginner:+))) + (#%plain-app + "#" + (#%plain-lambda (x) + (begin + (let-values (((arg0-1643 arg1-1644 arg2-1645) + (#%plain-app + values + "#<*unevaluated-struct*>" + "#<*unevaluated-struct*>" + "#<*unevaluated-struct*>"))) + (with-continuation-mark "#" + (#%plain-lambda () + (#%plain-app + "#" + (#%plain-lambda () beginner:+) + (#%plain-lambda () x) + (#%plain-lambda () arg0-1643) + (#%plain-lambda () arg1-1644) + (#%plain-lambda () arg2-1645))) + (begin + (#%plain-app "#") + (begin + (set! arg0-1643 + (with-continuation-mark "#" + (#%plain-lambda () + (#%plain-app + "#")) + beginner:+)) + (set! arg1-1644 + (with-continuation-mark "#" + (#%plain-lambda () + (#%plain-app + "#")) + (quote 3))) + (set! arg2-1645 + (with-continuation-mark "#" + (#%plain-lambda () + (#%plain-app + "#")) x)) + (begin + (#%plain-app "#") + (with-continuation-mark "#" + (#%plain-lambda () + (#%plain-app + "#" + (#%plain-lambda () arg0-1643) + (#%plain-lambda () arg1-1644) + (#%plain-lambda () arg2-1645))) + (if (#%plain-app + "#" + arg0-1643) + (#%plain-app + arg0-1643 + arg1-1644 + arg2-1645) + (#%plain-app + call-with-values + (#%plain-lambda () + (#%plain-app arg0-1643 arg1-1644 arg2-1645)) + (#%plain-lambda args + (#%plain-app + "#" + args) + (#%plain-app + "#" + values + args)))))))))))) + (#%plain-lambda () + (#%plain-app + "#" + (#%plain-lambda () beginner:+))) #f))) + (#%plain-lambda args + (#%plain-app "#" values args))))) + (#%plain-app "#" + (#%plain-app + list + (#%plain-app + list + "#" + #f + (#%plain-lambda () (#%plain-app list f)))))))) + +(let-values (((done-already?) (quote #f))) + (#%app dynamic-wind void + (lambda () (#%app dynamic-require (quote (quote #%htdp)) (quote #f))) + (lambda () (if done-already? + (#%app void) + (let-values () + (set! done-already? (quote #t)) + (#%app test*) + (#%app current-namespace + (#%app module->namespace + (quote (quote #%htdp)))))))))] + + +[*] : In order to allow things like @verbatim{#} in scribble, I've taken the cheap solution of wrapping them in quotes. These are not actually strings, they're opaque 3D syntax elements. \ No newline at end of file From e4a834e9b03ff1c2ea9aff1eb5c8da0c0c4f3188 Mon Sep 17 00:00:00 2001 From: John Clements Date: Thu, 28 Apr 2011 11:36:08 -0700 Subject: [PATCH 15/23] housekeeping, changed to drracket-tool, moved files to private --- collects/stepper/break.rkt | 25 ------ collects/stepper/info.rkt | 12 +-- .../stepper/{ => private}/view-controller.rkt | 24 +++--- collects/stepper/{ => private}/xml-sig.rkt | 0 collects/stepper/stepper+xml-tool.rkt | 38 ++++----- collects/stepper/stepper-tool.rkt | 78 +++++++++---------- collects/stepper/tests/test-docs-complete.rkt | 4 - collects/stepper/xml-tool.rkt | 53 +++++++------ 8 files changed, 96 insertions(+), 138 deletions(-) delete mode 100644 collects/stepper/break.rkt rename collects/stepper/{ => private}/view-controller.rkt (96%) rename collects/stepper/{ => private}/xml-sig.rkt (100%) diff --git a/collects/stepper/break.rkt b/collects/stepper/break.rkt deleted file mode 100644 index 8800aff026..0000000000 --- a/collects/stepper/break.rkt +++ /dev/null @@ -1,25 +0,0 @@ -(module break mzscheme - - (require mzlib/contract) - - (provide current-breakpoint-handler) - - (define (default-current-breakpoint-handler) - (error 'default-current-breakpoint-handler - "The current-breakpoint-handler parameter has not yet been set in this thread.")) - - (define current-breakpoint-handler - (make-parameter - default-current-breakpoint-handler - (lambda (new-handler) - (if (and (procedure? new-handler) - (procedure-arity-includes? new-handler 0)) - new-handler - (error 'current-breakpoint-handler - "Bad value for current-breakpoint-handler: ~e" - new-handler))))) - - (provide/contract [break (-> any)]) - - (define (break) - ((current-breakpoint-handler)))) diff --git a/collects/stepper/info.rkt b/collects/stepper/info.rkt index 356f6c2205..ae2a7d8351 100644 --- a/collects/stepper/info.rkt +++ b/collects/stepper/info.rkt @@ -1,16 +1,10 @@ #lang setup/infotab -(define tools '(("stepper+xml-tool.ss") - ;; ("debugger-tool.ss") - )) +(define drracket-tools '(("stepper+xml-tool.ss"))) -(define tool-names (list "The Stepper" - ;; "The Debugger" - )) +(define drracket-tool-names (list "The Stepper")) -(define tool-icons (list '("foot-up.png" "icons") - ;; #f - )) +(define drracket-tool-icons (list '("foot-up.png" "icons"))) (define compile-omit-paths '("debugger-tool.ss")) diff --git a/collects/stepper/view-controller.rkt b/collects/stepper/private/view-controller.rkt similarity index 96% rename from collects/stepper/view-controller.rkt rename to collects/stepper/private/view-controller.rkt index 155d527802..f8ff5d094b 100644 --- a/collects/stepper/view-controller.rkt +++ b/collects/stepper/private/view-controller.rkt @@ -6,21 +6,21 @@ (require racket/class racket/match racket/list - drscheme/tool + drracket/tool mred string-constants racket/async-channel - (prefix-in model: "private/model.ss") - (prefix-in x: "private/mred-extensions.ss") - "private/shared.ss" - "private/model-settings.ss" + (prefix-in model: "model.ss") + (prefix-in x: "mred-extensions.ss") + "shared.ss" + "model-settings.ss" "xml-sig.ss") -(import drscheme:tool^ xml^ stepper-frame^) +(import drracket:tool^ xml^ stepper-frame^) (export view-controller^) -(define drscheme-eventspace (current-eventspace)) +(define drracket-eventspace (current-eventspace)) (define (definitions-text->settings definitions-text) (send definitions-text get-next-settings)) @@ -28,12 +28,12 @@ ;; the stored representation of a step (define-struct step (text kind posns) #:transparent) -(define (go drscheme-frame program-expander selection-start selection-end) +(define (go drracket-frame program-expander selection-start selection-end) ;; get the language-level: - (define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text))) - (define language-level (drscheme:language-configuration:language-settings-language language-settings)) - (define simple-settings (drscheme:language-configuration:language-settings-settings language-settings)) + (define language-settings (definitions-text->settings (send drracket-frame get-definitions-text))) + (define language-level (drracket:language-configuration:language-settings-language language-settings)) + (define simple-settings (drracket:language-configuration:language-settings-settings language-settings)) ;; VALUE CONVERSION CODE: @@ -211,7 +211,7 @@ ;; GUI ELEMENTS: (define s-frame - (make-object stepper-frame% drscheme-frame)) + (make-object stepper-frame% drracket-frame)) (define button-panel (make-object horizontal-panel% (send s-frame get-area-container))) (define (add-button name fun) diff --git a/collects/stepper/xml-sig.rkt b/collects/stepper/private/xml-sig.rkt similarity index 100% rename from collects/stepper/xml-sig.rkt rename to collects/stepper/private/xml-sig.rkt diff --git a/collects/stepper/stepper+xml-tool.rkt b/collects/stepper/stepper+xml-tool.rkt index 6a13023fc2..e071d73ea8 100644 --- a/collects/stepper/stepper+xml-tool.rkt +++ b/collects/stepper/stepper+xml-tool.rkt @@ -1,25 +1,19 @@ -(module stepper+xml-tool mzscheme - (require mzlib/unit - drscheme/tool - "stepper-tool.ss" - "xml-tool.ss" - "view-controller.ss" - "private/shared.ss") +#lang racket - (provide tool@) +(require drracket/tool + "stepper-tool.rkt" + "xml-tool.rkt" + "private/view-controller.rkt") - ;; the xml and stepper tools are combined, so that the stepper can create XML - ;; snips. note that both of these tools provide 'void' for phase1 and phase2 - ;; (which together make up the tool-exports^), so we can provide either one - ;; of these for the compound unit. Doesn't matter. - - ;; NNNURRRG! This is not true any more. But that should be okay, because the - ;; stepper-tool phase1 is the non-void one. -- JBC, 2006-09-28 +(provide tool@) - (define tool@ - (compound-unit/infer - (import drscheme:tool^) - (export STEPPER-TOOL) - (link xml-tool@ - view-controller@ - [((STEPPER-TOOL : drscheme:tool-exports^)) stepper-tool@])))) +;; the xml and stepper tools are combined, so that the stepper can create XML +;; snips. + +(define tool@ + (compound-unit/infer + (import drracket:tool^) + (export STEPPER-TOOL) + (link xml-tool@ + view-controller@ + [((STEPPER-TOOL : drracket:tool-exports^)) stepper-tool@]))) \ No newline at end of file diff --git a/collects/stepper/stepper-tool.rkt b/collects/stepper/stepper-tool.rkt index 3b142e312c..32034807fd 100644 --- a/collects/stepper/stepper-tool.rkt +++ b/collects/stepper/stepper-tool.rkt @@ -1,27 +1,26 @@ #lang racket/unit -(require scheme/class - drscheme/tool +(require racket/class + drracket/tool mred - mzlib/pconvert - string-constants (prefix-in frame: framework) mrlib/switchable-button - (file "private/my-macros.ss") - (prefix-in x: "private/mred-extensions.ss") - "private/shared.ss" + mzlib/pconvert + racket/pretty + string-constants lang/stepper-language-interface - scheme/pretty - "xml-sig.ss" + (prefix-in x: "private/mred-extensions.rkt") + "private/shared.rkt" + "private/xml-sig.rkt" "drracket-button.ss") ;; get the stepper-button-callback private-member-name -(import drscheme:tool^ xml^ view-controller^) -(export drscheme:tool-exports^ stepper-frame^) +(import drracket:tool^ xml^ view-controller^) +(export drracket:tool-exports^ stepper-frame^) ;; tool magic here: (define (phase1) ;; experiment with extending the language... parameter-like fields for stepper parameters - (drscheme:language:extend-language-interface + (drracket:language:extend-language-interface stepper-language<%> (lambda (superclass) (class* superclass (stepper-language<%>) @@ -67,7 +66,7 @@ (send definitions-text get-next-settings)) (define (settings->language-level settings) - (drscheme:language-configuration:language-settings-language settings)) + (drracket:language-configuration:language-settings-language settings)) (define (stepper-works-for? language-level) (or (send language-level stepper:supported?) @@ -76,10 +75,10 @@ ;; the stepper's frame: (define stepper-frame% - (class (drscheme:frame:basics-mixin + (class (drracket:frame:basics-mixin (frame:frame:standard-menus-mixin frame:frame:basic%)) - (init-field drscheme-frame) + (init-field drracket-frame) ;; PRINTING-PROC ;; I frankly don't think that printing (i.e., to a printer) works @@ -114,7 +113,7 @@ (define/augment (on-close) (when custodian (custodian-shutdown-all custodian)) - (send drscheme-frame on-stepper-close) + (send drracket-frame on-stepper-close) (inner (void) on-close)) ;; WARNING BOXES: @@ -153,14 +152,14 @@ [height stepper-initial-height]))) - ;; stepper-unit-frame<%> : the interface that the extended drscheme frame + ;; stepper-unit-frame<%> : the interface that the extended drracket frame ;; fulfils (define stepper-unit-frame<%> (interface () get-stepper-frame on-stepper-close)) - ;; stepper-unit-frame-mixin : the mixin that is applied to the drscheme + ;; stepper-unit-frame-mixin : the mixin that is applied to the drracket ;; frame to interact with a possible stepper window (define (stepper-unit-frame-mixin super%) (class* super% (stepper-unit-frame<%>) @@ -179,10 +178,10 @@ (define (program-expander init iter) (let* ([lang-settings (send (get-definitions-text) get-next-settings)] - [lang (drscheme:language-configuration:language-settings-language lang-settings)] - [settings (drscheme:language-configuration:language-settings-settings lang-settings)]) - (drscheme:eval:expand-program - (drscheme:language:make-text/pos + [lang (drracket:language-configuration:language-settings-language lang-settings)] + [settings (drracket:language-configuration:language-settings-settings lang-settings)]) + (drracket:eval:expand-program + (drracket:language:make-text/pos (get-definitions-text) 0 (send (get-definitions-text) last-position)) @@ -213,7 +212,7 @@ [stretchable-width #f] [stretchable-height #f])) - ;; called from drracket-button.rkt, installed via the #lang htdp/bsl (& co) reader into drscheme + ;; called from drracket-button.rkt, installed via the #lang htdp/bsl (& co) reader into drracket (define/public (stepper-button-callback) (if stepper-frame (send stepper-frame show #t) @@ -221,7 +220,7 @@ (extract-language-level (get-definitions-text))] [language-level-name (language-level->name language-level)]) (if (or (stepper-works-for? language-level) - (is-a? language-level drscheme:module-language:module-language<%>)) + (is-a? language-level drracket:module-language:module-language<%>)) (set! stepper-frame (go this program-expander @@ -271,8 +270,9 @@ ;; add the stepper button to the button panel: (send (get-button-panel) change-children - (lx (cons stepper-button-parent-panel - (remq stepper-button-parent-panel _)))) + (lambda (x) + (cons stepper-button-parent-panel + (remq stepper-button-parent-panel x)))) ;; hide stepper button if it's not supported for the initial language: (check-current-language-for-stepper))) @@ -321,28 +321,28 @@ (super-new))) - ;; apply the mixins dynamically to the drscheme unit frame and + ;; apply the mixins dynamically to the drracket unit frame and ;; definitions text: - (drscheme:get/extend:extend-unit-frame stepper-unit-frame-mixin) - (drscheme:get/extend:extend-definitions-text stepper-definitions-text-mixin) + (drracket:get/extend:extend-unit-frame stepper-unit-frame-mixin) + (drracket:get/extend:extend-definitions-text stepper-definitions-text-mixin) - ;; COPIED FROM drscheme/private/language.ss + ;; COPIED FROM drracket/private/language.ss ;; simple-module-based-language-convert-value : TST STYLE boolean -> TST (define (simple-module-based-language-convert-value value settings) - (case (drscheme:language:simple-settings-printing-style settings) + (case (drracket:language:simple-settings-printing-style settings) [(print) value] [(write trad-write) value] [(constructor) (parameterize ([constructor-style-printing #t] - [show-sharing (drscheme:language:simple-settings-show-sharing settings)] + [show-sharing (drracket:language:simple-settings-show-sharing settings)] [current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))]) (stepper-print-convert value))] [(quasiquote) (parameterize ([constructor-style-printing #f] - [show-sharing (drscheme:language:simple-settings-show-sharing settings)] + [show-sharing (drracket:language:simple-settings-show-sharing settings)] [current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))]) (stepper-print-convert value))] @@ -381,19 +381,19 @@ [(is-a? exp snip%) (send exp copy)] #; - [((drscheme:rep:use-number-snip) exp) + [((drracket:rep:use-number-snip) exp) (let ([number-snip-type - (drscheme:language:simple-settings-fraction-style + (drracket:language:simple-settings-fraction-style simple-settings)]) (cond [(eq? number-snip-type 'repeating-decimal) - (drscheme:number-snip:make-repeating-decimal-snip exp #f)] + (drracket:number-snip:make-repeating-decimal-snip exp #f)] [(eq? number-snip-type 'repeating-decimal-e) - (drscheme:number-snip:make-repeating-decimal-snip exp #t)] + (drracket:number-snip:make-repeating-decimal-snip exp #t)] [(eq? number-snip-type 'mixed-fraction) - (drscheme:number-snip:make-fraction-snip exp #f)] + (drracket:number-snip:make-fraction-snip exp #f)] [(eq? number-snip-type 'mixed-fraction-e) - (drscheme:number-snip:make-fraction-snip exp #t)] + (drracket:number-snip:make-fraction-snip exp #t)] [else (error 'which-number-snip "expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e" diff --git a/collects/stepper/tests/test-docs-complete.rkt b/collects/stepper/tests/test-docs-complete.rkt index ed14222480..5c7f0c3dd5 100644 --- a/collects/stepper/tests/test-docs-complete.rkt +++ b/collects/stepper/tests/test-docs-complete.rkt @@ -1,6 +1,2 @@ #lang racket/base (require tests/utils/docs-complete) -(check-docs (quote stepper/xml-sig)) -(check-docs (quote stepper/view-controller)) -(check-docs (quote stepper/drracket-button)) -(check-docs (quote stepper/break)) diff --git a/collects/stepper/xml-tool.rkt b/collects/stepper/xml-tool.rkt index c29fe32f90..ca30f8f4e2 100644 --- a/collects/stepper/xml-tool.rkt +++ b/collects/stepper/xml-tool.rkt @@ -1,27 +1,26 @@ +#lang racket -(module xml-tool mzscheme - (require "private/xml-snip-helpers.rkt" - "private/find-tag.rkt" - "xml-sig.ss" - mzlib/unit - mzlib/contract - mzlib/class - mred - framework - drscheme/tool - xml/xml - string-constants) +(require "private/xml-snip-helpers.rkt" + "private/find-tag.rkt" + "private/xml-sig.ss" + mred + framework + drracket/tool + xml/xml + string-constants) (provide xml-tool@) (define orig (current-output-port)) (define-unit xml-tool@ - (import drscheme:tool^) + (import drracket:tool^) (export xml^) - (define (phase1) (void)) - (define (phase2) (void)) - - (preferences:set-default 'drscheme:xml-eliminate-whitespace #t boolean?) + + ;; these were necessary when this was a stand-alone tool: + #;(define (phase1) (void)) + #;(define (phase2) (void)) + + (preferences:set-default 'drracket:xml-eliminate-whitespace #t boolean?) (define xml-box-color "forest green") (define scheme-splice-box-color "blue") @@ -74,7 +73,7 @@ (define/private (set-eliminate-whitespace-in-empty-tags? new) (unless (eq? eliminate-whitespace-in-empty-tags? new) (set! eliminate-whitespace-in-empty-tags? new) - (preferences:set 'drscheme:xml-eliminate-whitespace new) + (preferences:set 'drracket:xml-eliminate-whitespace new) (reset-min-sizes) (let ([admin (get-admin)]) (when admin @@ -109,7 +108,7 @@ (define/override (make-snip stream-in) (instantiate xml-snip% () [eliminate-whitespace-in-empty-tags? - (preferences:get 'drscheme:xml-eliminate-whitespace)])) + (preferences:get 'drracket:xml-eliminate-whitespace)])) (super-instantiate ()))) ;; this snipclass is for old, saved files (no snip has it set) @@ -196,7 +195,7 @@ (define (get-scheme-box-text%) (unless scheme-box-text% (set! scheme-box-text% - (class ((drscheme:unit:get-program-editor-mixin) + (class ((drracket:unit:get-program-editor-mixin) (add-file-keymap-mixin scheme:text%)) (inherit copy-self-to) @@ -306,7 +305,7 @@ (let ([xml-text% #f]) (lambda () (unless xml-text% - (set! xml-text% (class ((drscheme:unit:get-program-editor-mixin) + (set! xml-text% (class ((drracket:unit:get-program-editor-mixin) (xml-text-mixin plain-text%)) (inherit copy-self-to) @@ -375,8 +374,8 @@ (lambda () (instantiate xml-snip% () [eliminate-whitespace-in-empty-tags? - (preferences:get 'drscheme:xml-eliminate-whitespace)])))))) - (register-capability-menu-item 'drscheme:special:xml-menus (get-insert-menu)) + (preferences:get 'drracket:xml-eliminate-whitespace)])))))) + (register-capability-menu-item 'drracket:special:xml-menus (get-insert-menu)) (instantiate menu:can-restore-menu-item% () (label (string-constant xml-tool-insert-scheme-box)) (parent menu) @@ -385,7 +384,7 @@ (lambda (menu evt) (insert-snip (lambda () (instantiate scheme-snip% () (splice? #f))))))) - (register-capability-menu-item 'drscheme:special:xml-menus (get-insert-menu)) + (register-capability-menu-item 'drracket:special:xml-menus (get-insert-menu)) (instantiate menu:can-restore-menu-item% () (label (string-constant xml-tool-insert-scheme-splice-box)) (parent menu) @@ -394,10 +393,10 @@ (lambda (menu evt) (insert-snip (lambda () (instantiate scheme-snip% () (splice? #t))))))) - (register-capability-menu-item 'drscheme:special:xml-menus (get-insert-menu))) + (register-capability-menu-item 'drracket:special:xml-menus (get-insert-menu))) (frame:reorder-menus this))) - (drscheme:language:register-capability 'drscheme:special:xml-menus (flat-contract boolean?) #t) + (drracket:language:register-capability 'drracket:special:xml-menus (flat-contract boolean?) #t) - (drscheme:get/extend:extend-unit-frame xml-box-frame-extension))) + (drracket:get/extend:extend-unit-frame xml-box-frame-extension)) From d2a21d717c46bf9c7ede4c3de19760e5f0291e9b Mon Sep 17 00:00:00 2001 From: John Clements Date: Thu, 28 Apr 2011 13:21:45 -0700 Subject: [PATCH 16/23] refactored stepper tool to work with tabs instead of frames --- collects/stepper/private/view-controller.rkt | 6 +- collects/stepper/stepper-tool.rkt | 206 +++++++++++-------- 2 files changed, 125 insertions(+), 87 deletions(-) diff --git a/collects/stepper/private/view-controller.rkt b/collects/stepper/private/view-controller.rkt index f8ff5d094b..e604a5a50e 100644 --- a/collects/stepper/private/view-controller.rkt +++ b/collects/stepper/private/view-controller.rkt @@ -28,10 +28,10 @@ ;; the stored representation of a step (define-struct step (text kind posns) #:transparent) -(define (go drracket-frame program-expander selection-start selection-end) +(define (go drracket-tab program-expander selection-start selection-end) ;; get the language-level: - (define language-settings (definitions-text->settings (send drracket-frame get-definitions-text))) + (define language-settings (definitions-text->settings (send drracket-tab get-defs))) (define language-level (drracket:language-configuration:language-settings-language language-settings)) (define simple-settings (drracket:language-configuration:language-settings-settings language-settings)) @@ -211,7 +211,7 @@ ;; GUI ELEMENTS: (define s-frame - (make-object stepper-frame% drracket-frame)) + (make-object stepper-frame% drracket-tab)) (define button-panel (make-object horizontal-panel% (send s-frame get-area-container))) (define (add-button name fun) diff --git a/collects/stepper/stepper-tool.rkt b/collects/stepper/stepper-tool.rkt index 32034807fd..a9c7acd19f 100644 --- a/collects/stepper/stepper-tool.rkt +++ b/collects/stepper/stepper-tool.rkt @@ -78,7 +78,7 @@ (class (drracket:frame:basics-mixin (frame:frame:standard-menus-mixin frame:frame:basic%)) - (init-field drracket-frame) + (init-field drracket-tab) ;; PRINTING-PROC ;; I frankly don't think that printing (i.e., to a printer) works @@ -113,7 +113,7 @@ (define/augment (on-close) (when custodian (custodian-shutdown-all custodian)) - (send drracket-frame on-stepper-close) + (send drracket-tab on-stepper-close) (inner (void) on-close)) ;; WARNING BOXES: @@ -154,18 +154,89 @@ ;; stepper-unit-frame<%> : the interface that the extended drracket frame ;; fulfils - (define stepper-unit-frame<%> + (define stepper-tab<%> (interface () get-stepper-frame on-stepper-close)) ;; stepper-unit-frame-mixin : the mixin that is applied to the drracket - ;; frame to interact with a possible stepper window + ;; frame to interact with a possible stepper window. Specifically, this + ;; mixin needs to manage the creation and visibility of the stepper button. (define (stepper-unit-frame-mixin super%) - (class* super% (stepper-unit-frame<%>) + (class* super% () + (inherit get-button-panel register-toolbar-button get-current-tab get-tabs) - (inherit get-button-panel register-toolbar-button get-interactions-text get-definitions-text) + (super-new) + ;; STEPPER BUTTON + + (define/public (get-stepper-button) stepper-button) + + (define stepper-button-parent-panel + (new horizontal-panel% + [parent (get-button-panel)] + [stretchable-width #f] + [stretchable-height #f])) + + (define stepper-button + (new switchable-button% + [parent stepper-button-parent-panel] + [label (string-constant stepper-button-label)] + [bitmap x:foot-img/horizontal] + [alternate-bitmap x:foot-img/vertical] + [callback (lambda (dont-care) (send (get-current-tab) + stepper-button-callback))])) + + (register-toolbar-button stepper-button) + + (define (stepper-button-show) + (unless (send stepper-button is-shown?) + (send (send stepper-button get-parent) + add-child stepper-button))) + + (define (stepper-button-hide) + (when (send stepper-button is-shown?) + (send (send stepper-button get-parent) + delete-child stepper-button))) + + ;; when the window closes, notify all of the stepper frames. + (define/augment (on-close) + (for ([tab (in-list (get-tabs))]) + (define possible-stepper-frame (send tab get-stepper-frame)) + (when possible-stepper-frame + (send possible-stepper-frame original-program-gone))) + (inner (void) on-close)) + + ;; when we change tabs, show or hide the stepper button. + (define/augment (on-tab-change old new) + (show/hide-stepper-button) + (inner (void) on-tab-change old new)) + + ;; add the stepper button to the button panel: + (send (get-button-panel) change-children + (lambda (x) + (cons stepper-button-parent-panel + (remq stepper-button-parent-panel x)))) + + ;; show or hide the stepper button depending + ;; on the language level + (define/public (show/hide-stepper-button) + (cond [(send (get-current-tab) current-lang-supports-stepper?) + (stepper-button-show)] + [else + (stepper-button-hide)])) + + ;; hide stepper button if it's not supported for the initial language: + (show/hide-stepper-button))) + + ;; stepper-tab-mixin : the mixin that is applied to drracket tabs, to + ;; interact with a possible stepper window. + (define (stepper-tab-mixin super%) + (class* super% (stepper-tab<%>) + + (inherit get-ints get-defs get-frame) + + ;; a reference to a possible stepper frame. (define stepper-frame #f) (define/public (on-stepper-close) (set! stepper-frame #f)) @@ -177,14 +248,14 @@ ;; definitions window one at a time and calls 'iter' on each one (define (program-expander init iter) (let* ([lang-settings - (send (get-definitions-text) get-next-settings)] + (send (get-defs) get-next-settings)] [lang (drracket:language-configuration:language-settings-language lang-settings)] [settings (drracket:language-configuration:language-settings-settings lang-settings)]) (drracket:eval:expand-program (drracket:language:make-text/pos - (get-definitions-text) + (get-defs) 0 - (send (get-definitions-text) last-position)) + (send (get-defs) last-position)) lang-settings #f (lambda () @@ -202,109 +273,75 @@ void ; kill iter))) - ;; STEPPER BUTTON - - (define/public (get-stepper-button) stepper-button) - - (define stepper-button-parent-panel - (new horizontal-panel% - [parent (get-button-panel)] - [stretchable-width #f] - [stretchable-height #f])) - + ;; called from drracket-button.rkt, installed via the #lang htdp/bsl (& co) reader into drracket (define/public (stepper-button-callback) - (if stepper-frame - (send stepper-frame show #t) - (let* ([language-level - (extract-language-level (get-definitions-text))] - [language-level-name (language-level->name language-level)]) - (if (or (stepper-works-for? language-level) - (is-a? language-level drracket:module-language:module-language<%>)) - (set! stepper-frame - (go this - program-expander - (+ 1 (send (get-definitions-text) get-start-position)) - (+ 1 (send (get-definitions-text) get-end-position)))) - (message-box - (string-constant stepper-name) - (format (string-constant stepper-language-level-message) - language-level-name)))))) + (cond + [stepper-frame (send stepper-frame show #t)] + [else (create-new-stepper)])) - (define stepper-button - (new switchable-button% - [parent stepper-button-parent-panel] - [label (string-constant stepper-button-label)] - [bitmap x:foot-img/horizontal] - [alternate-bitmap x:foot-img/vertical] - [callback (lambda (dont-care) (stepper-button-callback))])) + ;; open a new stepper window, start it running + (define (create-new-stepper) + (let* ([language-level + (extract-language-level (get-defs))] + [language-level-name (language-level->name language-level)]) + (if (or (stepper-works-for? language-level) + (is-a? language-level drracket:module-language:module-language<%>)) + (set! stepper-frame + (go this + program-expander + (+ 1 (send (get-defs) get-start-position)) + (+ 1 (send (get-defs) get-end-position)))) + (message-box + (string-constant stepper-name) + (format (string-constant stepper-language-level-message) + language-level-name))))) - (register-toolbar-button stepper-button) + (define/override (enable-evaluation) + (super enable-evaluation) + (send (send (get-frame) get-stepper-button) enable #t)) - (define/augment (enable-evaluation) - (send stepper-button enable #t) - (inner (void) enable-evaluation)) + (define/override (disable-evaluation) + (super enable-evaluation) + (send (send (get-frame) get-stepper-button) enable #f)) - (define/augment (disable-evaluation) - (send stepper-button enable #f) - (inner (void) disable-evaluation)) + (define/public (current-lang-supports-stepper?) + (stepper-works-for? (extract-language-level (get-defs)))) + + (define/public (notify-stepper-frame-of-change) + (when stepper-frame + (send stepper-frame original-program-changed))) (define/augment (on-close) (when stepper-frame - (send stepper-frame original-program-gone)) + (send stepper-frame original-program-gone)) (inner (void) on-close)) - - (define/augment (on-tab-change old new) - (check-current-language-for-stepper) - (inner (void) on-tab-change old new)) - - (define/public (check-current-language-for-stepper) - (if (stepper-works-for? - (extract-language-level (get-definitions-text))) - (unless (send stepper-button is-shown?) - (send (send stepper-button get-parent) - add-child stepper-button)) - (when (send stepper-button is-shown?) - (send (send stepper-button get-parent) - delete-child stepper-button)))) - - ;; add the stepper button to the button panel: - (send (get-button-panel) change-children - (lambda (x) - (cons stepper-button-parent-panel - (remq stepper-button-parent-panel x)))) - - ;; hide stepper button if it's not supported for the initial language: - (check-current-language-for-stepper))) + + )) + + ;; stepper-definitions-text-mixin : a mixin for the definitions text that ;; alerts thet stepper when the definitions text is altered or destroyed (define (stepper-definitions-text-mixin %) (class % - (inherit get-top-level-window) - (define/private (notify-stepper-frame-of-change) - (let ([win (get-top-level-window)]) - ;; should only be #f when win is #f - (when (is-a? win stepper-unit-frame<%>) - (let ([stepper-window (send win get-stepper-frame)]) - (when stepper-window - (send stepper-window original-program-changed)))))) + (inherit get-tab get-top-level-window) (define/augment (on-insert x y) (unless metadata-changing-now? - (notify-stepper-frame-of-change)) + (send (get-tab) notify-stepper-frame-of-change)) (inner (void) on-insert x y)) (define/augment (on-delete x y) (unless metadata-changing-now? - (notify-stepper-frame-of-change)) + (send (get-tab) notify-stepper-frame-of-change)) (inner (void) on-delete x y)) (define/augment (after-set-next-settings s) (let ([tlw (get-top-level-window)]) (when tlw - (send tlw check-current-language-for-stepper))) + (send tlw show/hide-stepper-button))) (inner (void) after-set-next-settings s)) (define metadata-changing-now? #f) @@ -325,6 +362,7 @@ ;; definitions text: (drracket:get/extend:extend-unit-frame stepper-unit-frame-mixin) (drracket:get/extend:extend-definitions-text stepper-definitions-text-mixin) + (drracket:get/extend:extend-tab stepper-tab-mixin) ;; COPIED FROM drracket/private/language.ss ;; simple-module-based-language-convert-value : TST STYLE boolean -> TST From 632e36f751ea454874548cdb62d6cb73694c773d Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 28 Apr 2011 18:21:21 -0400 Subject: [PATCH 17/23] Add set types to TR. Original patch by Eric Dobson. --- collects/tests/typed-scheme/succeed/set.rkt | 40 +++++++++++++++++++ collects/typed-scheme/infer/infer-unit.rkt | 2 + collects/typed-scheme/private/base-env.rkt | 20 ++++++++++ collects/typed-scheme/private/base-types.rkt | 1 + collects/typed-scheme/rep/type-rep.rkt | 4 ++ .../scribblings/ts-reference.scrbl | 4 ++ collects/typed-scheme/types/abbrev.rkt | 1 + collects/typed-scheme/types/printer.rkt | 1 + collects/typed-scheme/types/subtype.rkt | 1 + 9 files changed, 74 insertions(+) create mode 100644 collects/tests/typed-scheme/succeed/set.rkt diff --git a/collects/tests/typed-scheme/succeed/set.rkt b/collects/tests/typed-scheme/succeed/set.rkt new file mode 100644 index 0000000000..de9d5cb179 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/set.rkt @@ -0,0 +1,40 @@ +#lang typed/racket + +(define s (set 0 1 2 3)) +(define q (seteq 0 1 2 3)) +(define v (seteqv 0 1 2 3)) +(define s0 (ann (set) (Setof Byte))) + +(set-empty? s) +(set-empty? q) +(set-empty? v) +(set-empty? s0) + +(set-count s) +(set-count q) +(set-count v) +(set-count s0) + +(set-member? s 0) +(set-member? q 0) +(set-member? v 0) +(set-member? s0 0) + +(set-add s 4) +(set-add q 4) +(set-add v 4) +(set-add s0 4) + +(set-remove s 4) +(set-remove q 4) +(set-remove v 4) +(set-remove s0 4) + +(subset? s s0) +(set-map v add1) +(set-for-each s0 display) + +(set-equal? s) +(set-eqv? v) +(set-eq? q) +(set? s0) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 51c3ce685f..c58d490bed 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -497,6 +497,8 @@ (cset-meet (cg e e*) (cg e* e))] [((Ephemeron: e) (Ephemeron: e*)) (cg e e*)] + [((Set: a) (Set: a*)) + (cg a a*)] ;; we assume all HTs are mutable at the moment [((Hashtable: s1 s2) (Hashtable: t1 t2)) ;; for mutable hash tables, both are invariant diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 05313abf6d..24b2bf2c13 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -18,6 +18,7 @@ racket/function racket/mpair racket/base + racket/set (only-in string-constants/private/only-once maybe-print-message) (only-in mzscheme make-namespace) (only-in racket/match/runtime match:error matchable? match-equality-test)) @@ -599,6 +600,25 @@ [hash-iterate-value (-poly (a b) ((-HT a b) -Integer . -> . b))] +;Set operations +[set (-poly (e) (->* (list) e (-set e)))] +[seteqv (-poly (e) (->* (list) e (-set e)))] +[seteq (-poly (e) (->* (list) e (-set e)))] +[set-empty? (-poly (e) (-> (-set e) B))] +[set-count (-poly (e) (-> (-set e) -Index))] +[set-member? (-poly (e) (-> (-set e) e B))] +[set-add (-poly (e) (-> (-set e) e (-set e)))] + +[set-remove (-poly (e) (-> (-set e) e (-set e)))] + +[subset? (-poly (e) (-> (-set e) (-set e) B))] +[set-map (-poly (e b) (-> (-set e) (-> e b) (-lst b)))] +[set-for-each (-poly (e b) (-> (-set e) (-> e b) -Void))] +[set? (make-pred-ty (-poly (e) (-set e)))] +[set-equal? (-poly (e) (-> (-set e) B))] +[set-eqv? (-poly (e) (-> (-set e) B))] +[set-eq? (-poly (e) (-> (-set e) B))] + [bytes (->* (list) -Integer -Bytes)] [bytes? (make-pred-ty -Bytes)] [make-bytes (cl-> [(-Integer -Integer) -Bytes] diff --git a/collects/typed-scheme/private/base-types.rkt b/collects/typed-scheme/private/base-types.rkt index 6f81bf6698..1f63fe699b 100644 --- a/collects/typed-scheme/private/base-types.rkt +++ b/collects/typed-scheme/private/base-types.rkt @@ -112,6 +112,7 @@ [Boxof (-poly (a) (make-Box a))] [Channelof (-poly (a) (make-Channel a))] [Ephemeronof (-poly (a) (make-Ephemeron a))] +[Setof (-poly (e) (make-Set e))] [Continuation-Mark-Set -Cont-Mark-Set] [False (-val #f)] [True (-val #t)] diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 2c013717f5..1c70bb5fd2 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -135,6 +135,10 @@ [#:key 'ephemeron]) +;; elem is a Type +(dt Set ([elem Type/c]) [#:key 'set]) + + ;; name is a Symbol (not a Name) ;; contract is used when generating contracts from types ;; predicate is used to check (at compile-time) whether a value belongs diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 759d4a281f..06248aca7d 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -163,6 +163,10 @@ corresponding to @racket[trest], where @racket[bound] @ex[#hash((a . 1) (b . 2))] } +@defform[(Setof t)]{is the type of a @rtech{set} of @racket[t]. +@ex[(set 0 1 2 3)] +} + @defform[(Channelof t)]{A @rtech{channel} on which only @racket[t]s can be sent. @ex[ (ann (make-channel) (Channelof Symbol)) diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 397f56c471..460818bef4 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -29,6 +29,7 @@ (define -Param make-Param) (define -box make-Box) (define -channel make-Channel) +(define -set make-Set) (define -vec make-Vector) (define -future make-Future) (define (-seq . args) (make-Sequence args)) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 29995c352c..8509d0cac8 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -172,6 +172,7 @@ [(Future: e) (fp "(Futureof ~a)" e)] [(Channel: e) (fp "(Channelof ~a)" e)] [(Ephemeron: e) (fp "(Ephemeronof ~a)" e)] + [(Set: e) (fp "(Setof ~a)" e)] [(Union: elems) (fp "~a" (cons 'U elems))] [(Pair: l r) (fp "(Pairof ~a ~a)" l r)] [(ListDots: dty dbound) diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index 199b268a4b..548a6bf8c8 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -361,6 +361,7 @@ [((Ephemeron: s) (Ephemeron: t)) (subtype* A0 s t)] [((Box: _) (BoxTop:)) A0] + [((Set: t) (Set: t*)) (subtype* A0 t t*)] [((Channel: _) (ChannelTop:)) A0] [((Vector: _) (VectorTop:)) A0] [((HeterogenousVector: _) (VectorTop:)) A0] From 0d246de2930907fb5bfd549549ad9c8774e0350f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 26 Apr 2011 12:30:09 -0400 Subject: [PATCH 18/23] Remove obselete shell script --- collects/tests/typed-scheme/run | 2 -- 1 file changed, 2 deletions(-) delete mode 100755 collects/tests/typed-scheme/run diff --git a/collects/tests/typed-scheme/run b/collects/tests/typed-scheme/run deleted file mode 100755 index 63ee58cc4f..0000000000 --- a/collects/tests/typed-scheme/run +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -gracket -e '(begin (require "main.ss") (go tests))' From 9469835be431bbbf59b8567932572d19ee8b2efd Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 27 Apr 2011 10:46:07 -0400 Subject: [PATCH 19/23] Add deftech for "future". --- collects/scribblings/reference/futures.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/futures.scrbl b/collects/scribblings/reference/futures.scrbl index f40ae6a6da..ee631c2050 100644 --- a/collects/scribblings/reference/futures.scrbl +++ b/collects/scribblings/reference/futures.scrbl @@ -23,7 +23,7 @@ The @racket[future] and @racket[touch] functions from by the hardware and operating system. In contrast to @racket[thread], which provides concurrency for arbitrary computations without parallelism, @racket[future] provides parallelism for limited -computations. A future executes its work in parallel (assuming that +computations. A @deftech{future} executes its work in parallel (assuming that support for parallelism is available) until it detects an attempt to perform an operation that is too complex for the system to run safely in parallel. Similarly, work in a future is suspended if it depends in some From c28f024ae05ef276c9bf2e5ad5ddea45462ac3ff Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 26 Apr 2011 18:02:22 -0400 Subject: [PATCH 20/23] Progress on missing docs. --- .../scribblings/ts-reference.scrbl | 93 ++++++++++++++----- collects/typed/tests/test-docs-complete.rkt | 3 +- 2 files changed, 74 insertions(+), 22 deletions(-) diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 06248aca7d..54a1715570 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -78,16 +78,23 @@ default in Racket. @defidform[Void] @defidform[Input-Port] @defidform[Output-Port] +@defidform[Port] @defidform[Path] @defidform[Path-String] @defidform[Regexp] @defidform[PRegexp] +@defidform[Byte-Regexp] +@defidform[Byte-PRegexp] @defidform[Bytes] @defidform[Namespace] @defidform[Null] @defidform[EOF] @defidform[Continuation-Mark-Set] @defidform[Char] +@defidform[Module-Path] +@defidform[Module-Path-Index] +@defidform[Compiled-Module-Expression] +@defidform[Resolved-Module-Path] @defidform[Thread])]{ These types represent primitive Racket data. @@ -124,7 +131,7 @@ subtypes of @racket[Symbol] and @racket[Keyword], respectively. The following base types are parameteric in their type arguments. -@defform[(Pair s t)]{is the @rtech{pair} containing @racket[s] as the @racket[car] +@defform[(Pairof s t)]{is the @rtech{pair} containing @racket[s] as the @racket[car] and @racket[t] as the @racket[cdr]} @ex[ @@ -146,6 +153,9 @@ corresponding to @racket[trest], where @racket[bound] (map symbol->string (list 'a 'b 'c)) ] +@defform[(MListof t)]{Homogenous @rtech{mutable lists} of @racket[t].} +@defform[(MPairof t u)]{@rtech{Mutable pairs} of @racket[t] and @racket[u].} + @defform[(Boxof t)]{A @rtech{box} of @racket[t]} @ex[(box "hello world")] @@ -153,6 +163,7 @@ corresponding to @racket[trest], where @racket[bound] @defform[(Vectorof t)]{Homogenous @rtech{vectors} of @racket[t]} @defform[(Vector t ...)]{is the type of the list with one element, in order, for each type provided to the @racket[Vector] type constructor.} +@defidform[FlVector]{An @rtech{flvector}.} @ex[(vector 1 2 3) #(a b c)] @@ -183,6 +194,11 @@ corresponding to @racket[trest], where @racket[bound] @defform[(Promise t)]{A @rtech{promise} of @racket[t]. @ex[(delay 3)]} +@defform[(Futureof t)]{A @rtech{future} which produce a value of type @racket[t] when touched.} + +@defform[(Sequenceof t ...)]{A @rtech{sequence} that produces values of the +types @racket[_t ...] on each iteration.} + @subsection{Syntax Objects} The following types represent @rtech{syntax object}s and their content. @@ -217,7 +233,7 @@ of type @racket[Syntax-E].} @racket[Datum] produces a value of type @racket[Syntax]. Equivalent to @racket[(Sexpof Syntax)].} -@subsection{Other Type Constructors} +@subsection{Other Type Constructors} @defform*[#:id -> #:literals (* ...) [(dom ... -> rng) @@ -237,12 +253,16 @@ of type @racket[Syntax-E].} (λ: ([x : Number] . [y : String *]) (length y)) ormap string?]} + +@defidform[Procedure]{is the supertype of all function types.} + + @defform[(U t ...)]{is the union of the types @racket[t ...]. @ex[(λ: ([x : Real])(if (> 0 x) "yes" 'no))]} -@defform[(case-lambda fun-ty ...)]{is a function that behaves like all of +@defform[(case-> fun-ty ...)]{is a function that behaves like all of the @racket[fun-ty]s, considered in order from first to last. The @racket[fun-ty]s must all be function types constructed with @racket[->]. - @ex[(: add-map : (case-lambda + @ex[(: add-map : (case-> [(Listof Integer) -> (Listof Integer)] [(Listof Integer) (Listof Integer) -> (Listof Integer)]))] For the definition of @racket[add-map] look into @racket[case-lambda:].} @@ -259,7 +279,7 @@ of type @racket[Syntax-E].} 0 (add1 (list-lenght (cdr lst)))))]} -@defform[(values t ...)]{is the type of a sequence of multiple values, with +@defform[(Values t ...)]{is the type of a sequence of multiple values, with types @racket[t ...]. This can only appear as the return type of a function. @ex[(values 1 2 3)]} @@ -273,11 +293,16 @@ recursive type in the body @racket[t] (define-type (List A) (Rec List (Pair A (U List Null))))]} +@(define-syntax-rule (defalias id1 id2) + @defidform[id1]{An alias for @racket[id2].}) + +@defalias[→ ->] +@defalias[∀ All] @subsection{Other Types} @defform[(Option t)]{Either @racket[t] or @racket[#f]} - +@defform[(Opaque t)]{A type constructed using @racket[require-opaque-type].} @section[#:tag "special-forms"]{Special Form Reference} Typed Racket provides a variety of special forms above and beyond @@ -525,14 +550,13 @@ can be used anywhere a definition form may be used. @defform[(provide: [v t] ...)]{This declares that the @racket[v]s have the types @racket[t], and also provides all of the @racket[v]s.} -@litchar{#{v : t}} This declares that the variable @racket[v] has type -@racket[t]. This is legal only for binding occurrences of @racket[_v]. +@defform/none[@litchar|{ #{v : t} }|]{ This declares that the variable @racket[v] has type +@racket[t]. This is legal only for binding occurrences of @racket[_v].} @defform[(ann e t)]{Ensure that @racket[e] has type @racket[t], or some subtype. The entire expression has type @racket[t]. -This is legal only in expression contexts.} - -@litchar{#{e :: t}} This is identical to @racket[(ann e t)]. +This is legal only in expression contexts. The syntax @litchar{#{e :: t}} may +also be used.} @defform[(inst e t ...)]{Instantiate the type of @racket[e] with types @racket[t ...]. @racket[e] must have a polymorphic type with the @@ -544,9 +568,10 @@ contexts. (define (fold-list lst) (foldl (inst cons A A) null lst)) - (fold-list (list "1" "2" "3" "4"))]} + (fold-list (list "1" "2" "3" "4"))] -@litchar|{#{e @ t ...}}| This is identical to @racket[(inst e t ...)]. +The syntax @litchar|{#{e @ t ...}}| may also be used. +} @subsection{Require} @@ -603,12 +628,12 @@ enforce the specified types. If this contract fails, the module Some types, notably polymorphic types constructed with @racket[All], cannot be converted to contracts and raise a static error when used in a @racket[require/typed] form. Here is an example of using -@racket[case-lambda] in @racket[require/typed]. +@racket[case->] in @racket[require/typed]. @(racketblock (require/typed racket/base [file-or-directory-modify-seconds - (case-lambda + (case-> [String -> Exact-Nonnegative-Integer] [String (Option Exact-Nonnegative-Integer) -> @@ -617,8 +642,8 @@ a @racket[require/typed] form. Here is an example of using -> Any])])) -@racket[file-or-directory-modify-seconds] has some arguments which are optional. -So we need to use @racket[case-lambda].} +@racket[file-or-directory-modify-seconds] has some arguments which are optional, +so we need to use @racket[case->].} @section{Libraries Provided With Typed Racket} @@ -749,7 +774,7 @@ have the types ascribed to them; these types are converted to contracts and chec (define (fun x) x) (define val 17)) -(fun val)] +(fun val)]} @section{Optimization in Typed Racket} @@ -776,14 +801,40 @@ The following forms are provided by Typed Racket for backwards compatibility. @defidform[define-type-alias]{Equivalent to @racket[define-type].} +@defidform[define-typed-struct]{Equivalent to @racket[define-struct:]} @defidform[require/opaque-type]{Similar to using the @racket[opaque] keyword with @racket[require/typed].} @defidform[require-typed-struct]{Similar to using the @racket[struct] keyword with @racket[require/typed].} -@(defmodulelang* (typed-scheme) +@defalias[Un U] +@defalias[mu Rec] +@defalias[Tuple List] +@defalias[Parameter Parameterof] +@defalias[Pair Pairof] + +@section{Compatibility Languages} + +@(defmodulelang* (typed/scheme typed/scheme/base typed-scheme) #:use-sources (typed-scheme/typed-scheme typed-scheme/private/prims)) -Equivalent to the @racketmod[typed/racket/base] language. +Typed versions of the @racketmod[scheme] and @racketmod[scheme/base] +languages. The @racketmod[typed-scheme] language is equivalent to the +@racketmod[typed/scheme/base] language. -} + +@section{Experimental Features} + +These features are currently experimental and subject to change. + +@defform[(Class args ...)]{A type constructor for typing classes created using @racketmodname[racket/class].} +@defform[(Instance c)]{A type constructor for typing objects created using @racketmodname[racket/class].} + +@defform[(:type t)]{Prints the type @racket[_t].} + +@defform[(declare-refinement id)]{Declares @racket[id] to be usable in +refinement types.} + +@defform[(Refinement id)]{Includes values that have been tested with the +predicate @racket[id], which must have been specified with +@racket[declare-refinement].} diff --git a/collects/typed/tests/test-docs-complete.rkt b/collects/typed/tests/test-docs-complete.rkt index 642d5aa81c..9a53a76e15 100644 --- a/collects/typed/tests/test-docs-complete.rkt +++ b/collects/typed/tests/test-docs-complete.rkt @@ -1,5 +1,6 @@ #lang racket/base (require tests/utils/docs-complete) (check-docs (quote typed/scheme)) -(check-docs (quote typed/rackunit)) +(check-docs (quote typed/scheme/base)) (check-docs (quote typed/racket)) +(check-docs (quote typed/racket/base)) From 561d89f0aff26c4171776ae4ed38127e51a349d5 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 28 Apr 2011 18:23:00 -0400 Subject: [PATCH 21/23] Remove uneccesary provides. --- collects/typed-scheme/private/prims.rkt | 2 +- collects/typed/racket/base.rkt | 18 +++++++++--------- collects/typed/scheme/base.rkt | 18 +++++++++--------- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index 50efd86404..255c576111 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -19,7 +19,7 @@ This file defines two sorts of primitives. All of them are provided into any mod |# -(provide (all-defined-out) +(provide (except-out (all-defined-out) dtsi* let-internal: define-for-variants define-for*-variants) : (rename-out [define-typed-struct define-struct:] [lambda: λ:] diff --git a/collects/typed/racket/base.rkt b/collects/typed/racket/base.rkt index 65d5432443..64952f4ac7 100644 --- a/collects/typed/racket/base.rkt +++ b/collects/typed/racket/base.rkt @@ -1,18 +1,18 @@ #lang s-exp typed-scheme/minimal +(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)) + (basics #%module-begin #%top-interaction lambda #%app)) - -(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*) - (except typed-scheme/private/prims) - (except typed-scheme/private/base-types) - (except typed-scheme/private/base-types-extra)) - (basics #%module-begin - #%top-interaction - lambda - #%app)) (require typed-scheme/private/extra-procs + typed-scheme/private/prims + typed-scheme/private/base-types + typed-scheme/private/base-types-extra (for-syntax typed-scheme/private/base-types-extra)) (provide (rename-out [with-handlers: with-handlers] [define-type-alias define-type]) + (except-out (all-from-out typed-scheme/private/prims) + with-handlers: for/annotation for*/annotation) + (all-from-out typed-scheme/private/base-types) + (all-from-out typed-scheme/private/base-types-extra) assert defined? with-type for for* (for-syntax (all-from-out typed-scheme/private/base-types-extra))) diff --git a/collects/typed/scheme/base.rkt b/collects/typed/scheme/base.rkt index 4c184c2146..302f1c162c 100644 --- a/collects/typed/scheme/base.rkt +++ b/collects/typed/scheme/base.rkt @@ -1,18 +1,18 @@ #lang s-exp typed-scheme/minimal +(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)) + (basics #%module-begin #%top-interaction lambda #%app)) - -(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*) - (except typed-scheme/private/prims) - (except typed-scheme/private/base-types) - (except typed-scheme/private/base-types-extra)) - (basics #%module-begin - #%top-interaction - lambda - #%app)) (require typed-scheme/private/extra-procs + typed-scheme/private/prims + typed-scheme/private/base-types + typed-scheme/private/base-types-extra (for-syntax typed-scheme/private/base-types-extra)) (provide (rename-out [with-handlers: with-handlers] [define-type-alias define-type]) + (except-out (all-from-out typed-scheme/private/prims) + with-handlers: for/annotation for*/annotation) + (all-from-out typed-scheme/private/base-types) + (all-from-out typed-scheme/private/base-types-extra) assert defined? with-type for for* (for-syntax (all-from-out typed-scheme/private/base-types-extra))) From 6a87483f38214ab4efe00188a31b671d8551c4b7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 28 Apr 2011 18:23:22 -0400 Subject: [PATCH 22/23] Document a bunch of TR types and special forms. --- .../scribblings/ts-reference.scrbl | 45 +++++++++++++------ 1 file changed, 32 insertions(+), 13 deletions(-) diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 54a1715570..8c1fa423c0 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -91,6 +91,7 @@ default in Racket. @defidform[EOF] @defidform[Continuation-Mark-Set] @defidform[Char] +@defidform[Undefined] @defidform[Module-Path] @defidform[Module-Path-Index] @defidform[Compiled-Module-Expression] @@ -117,11 +118,12 @@ These types represent primitive Racket data. @subsection{Singleton Types} Some kinds of data are given singleton types by default. In -particular, @rtech{symbols} and @rtech{keywords} have types which -consist only of the particular symbol or keyword. These types are -subtypes of @racket[Symbol] and @racket[Keyword], respectively. +particular, @rtech{booleans}, @rtech{symbols}, and @rtech{keywords} have types which +consist only of the particular boolean, symbol, or keyword. These types are +subtypes of @racket[Boolean], @racket[Symbol] and @racket[Keyword], respectively. @ex[ +#t '#:foo 'bar ] @@ -147,6 +149,7 @@ The following base types are parameteric in their type arguments. one element for each of the @racket[t]s, plus a sequence of elements corresponding to @racket[trest], where @racket[bound] must be an identifier denoting a type variable bound with @racket[...].} +@defform[(List* t t1 ... s)]{is equivalent to @racket[(Pairof t (List* t1 ... s))].} @ex[ (list 'a 'b 'c) @@ -233,6 +236,8 @@ of type @racket[Syntax-E].} @racket[Datum] produces a value of type @racket[Syntax]. Equivalent to @racket[(Sexpof Syntax)].} +@defform[(Ephemeronof t)]{An @rtech{ephemeron} whose value is of type @racket[t].} + @subsection{Other Type Constructors} @defform*[#:id -> #:literals (* ...) @@ -418,15 +423,25 @@ variants. @deftogether[[ @defform[(for/list: : u (for:-clause ...) expr ...+)] -@;@defform[(for/hash: : u (for:-clause ...) expr ...+)] @; the ones that are commented out don't currently work -@;@defform[(for/hasheq: : u (for:-clause ...) expr ...+)] -@;@defform[(for/hasheqv: : u (for:-clause ...) expr ...+)] -@;@defform[(for/vector: : u (for:-clause ...) expr ...+)] -@;@defform[(for/flvector: : u (for:-clause ...) expr ...+)] -@;@defform[(for/and: : u (for:-clause ...) expr ...+)] +@defform[(for/hash: : u (for:-clause ...) expr ...+)] +@defform[(for/hasheq: : u (for:-clause ...) expr ...+)] +@defform[(for/hasheqv: : u (for:-clause ...) expr ...+)] +@defform[(for/vector: : u (for:-clause ...) expr ...+)] +@defform[(for/flvector: : u (for:-clause ...) expr ...+)] +@defform[(for/and: : u (for:-clause ...) expr ...+)] @defform[(for/or: : u (for:-clause ...) expr ...+)] -@;@defform[(for/first: : u (for:-clause ...) expr ...+)] -@;@defform[(for/last: : u (for:-clause ...) expr ...+)] +@defform[(for/first: : u (for:-clause ...) expr ...+)] +@defform[(for/last: : u (for:-clause ...) expr ...+)] +@defform[(for*/list: : u (for:-clause ...) expr ...+)] +@defform[(for*/hash: : u (for:-clause ...) expr ...+)] +@defform[(for*/hasheq: : u (for:-clause ...) expr ...+)] +@defform[(for*/hasheqv: : u (for:-clause ...) expr ...+)] +@defform[(for*/vector: : u (for:-clause ...) expr ...+)] +@defform[(for*/flvector: : u (for:-clause ...) expr ...+)] +@defform[(for*/and: : u (for:-clause ...) expr ...+)] +@defform[(for*/or: : u (for:-clause ...) expr ...+)] +@defform[(for*/first: : u (for:-clause ...) expr ...+)] +@defform[(for*/last: : u (for:-clause ...) expr ...+)] ]]{ These behave like their non-annotated counterparts, with the exception that @racket[#:when] clauses can only appear as the last @@ -806,6 +821,8 @@ compatibility. keyword with @racket[require/typed].} @defidform[require-typed-struct]{Similar to using the @racket[struct] keyword with @racket[require/typed].} +@defidform[pdefine:]{Defines a polymorphic function.} +@defform[(pred t)]{Equivalent to @racket[(Any -> Boolean : t)].} @defalias[Un U] @defalias[mu Rec] @@ -817,7 +834,7 @@ keyword with @racket[require/typed].} @(defmodulelang* (typed/scheme typed/scheme/base typed-scheme) #:use-sources (typed-scheme/typed-scheme - typed-scheme/private/prims)) + typed-scheme/private/prims typed-scheme/private/base-types)) Typed versions of the @racketmod[scheme] and @racketmod[scheme/base] languages. The @racketmod[typed-scheme] language is equivalent to the @racketmod[typed/scheme/base] language. @@ -837,4 +854,6 @@ refinement types.} @defform[(Refinement id)]{Includes values that have been tested with the predicate @racket[id], which must have been specified with -@racket[declare-refinement].} +@racket[declare-refinement].} + +@defform[(define-typed-struct/exec forms ...)]{Defines an executable structure.} From 030eb185bc544e9b76b39c4a9e134c55005496a7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Apr 2011 19:21:58 -0600 Subject: [PATCH 23/23] fix non-futures, non-places build --- src/racket/src/thread.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index 02864b97b9..ff56eecb73 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -122,6 +122,7 @@ static void check_ready_break(); THREAD_LOCAL_DECL(extern int scheme_num_read_syntax_objects); THREAD_LOCAL_DECL(extern intptr_t scheme_hash_request_count); THREAD_LOCAL_DECL(extern intptr_t scheme_hash_iteration_count); +THREAD_LOCAL_DECL(extern intptr_t scheme_code_page_total); #ifdef MZ_USE_JIT extern int scheme_jit_malloced; #else