From 44d61b71f62e8b9b46882825b80b5c0f2f5291e4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 19 Mar 2009 03:00:21 -0500
Subject: [PATCH 01/10] Store next_free pointer to free blocks only
---
vm/code_gc.c | 42 +++++++++++++++++++++---------------------
vm/code_gc.h | 13 +++++++++----
2 files changed, 30 insertions(+), 25 deletions(-)
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 8c734c263c..aa82d34412 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -13,7 +13,7 @@ void new_heap(F_HEAP *heap, CELL size)
/* If there is no previous block, next_free becomes the head of the free list,
else its linked in */
-INLINE void update_free_list(F_HEAP *heap, F_BLOCK *prev, F_BLOCK *next_free)
+INLINE void update_free_list(F_HEAP *heap, F_FREE_BLOCK *prev, F_FREE_BLOCK *next_free)
{
if(prev)
prev->next_free = next_free;
@@ -28,18 +28,18 @@ compiling.limit. */
void build_free_list(F_HEAP *heap, CELL size)
{
F_BLOCK *prev = NULL;
- F_BLOCK *prev_free = NULL;
+ F_FREE_BLOCK *prev_free = NULL;
F_BLOCK *scan = first_block(heap);
- F_BLOCK *end = (F_BLOCK *)(heap->segment->start + size);
+ F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size);
/* Add all free blocks to the free list */
- while(scan && scan < end)
+ while(scan && scan < (F_BLOCK *)end)
{
switch(scan->status)
{
case B_FREE:
- update_free_list(heap,prev_free,scan);
- prev_free = scan;
+ update_free_list(heap,prev_free,(F_FREE_BLOCK *)scan);
+ prev_free = (F_FREE_BLOCK *)scan;
break;
case B_ALLOCATED:
break;
@@ -56,9 +56,9 @@ void build_free_list(F_HEAP *heap, CELL size)
branch is only taken after loading a new image, not after code GC */
if((CELL)(end + 1) <= heap->segment->end)
{
- end->status = B_FREE;
+ end->block.status = B_FREE;
+ end->block.size = heap->segment->end - (CELL)end;
end->next_free = NULL;
- end->size = heap->segment->end - (CELL)end;
/* add final free block */
update_free_list(heap,prev_free,end);
@@ -82,18 +82,18 @@ void build_free_list(F_HEAP *heap, CELL size)
/* Allocate a block of memory from the mark and sweep GC heap */
void *heap_allot(F_HEAP *heap, CELL size)
{
- F_BLOCK *prev = NULL;
- F_BLOCK *scan = heap->free_list;
+ F_FREE_BLOCK *prev = NULL;
+ F_FREE_BLOCK *scan = heap->free_list;
size = (size + 31) & ~31;
while(scan)
{
- CELL this_size = scan->size - sizeof(F_BLOCK);
-
- if(scan->status != B_FREE)
+ if(scan->block.status != B_FREE)
critical_error("Invalid block in free list",(CELL)scan);
+ CELL this_size = scan->block.size - sizeof(F_BLOCK);
+
if(this_size < size)
{
prev = scan;
@@ -102,9 +102,9 @@ void *heap_allot(F_HEAP *heap, CELL size)
}
/* we found a candidate block */
- F_BLOCK *next_free;
+ F_FREE_BLOCK *next_free;
- if(this_size - size <= sizeof(F_BLOCK))
+ if(this_size - size <= sizeof(F_BLOCK) * 2)
{
/* too small to be split */
next_free = scan->next_free;
@@ -113,11 +113,11 @@ void *heap_allot(F_HEAP *heap, CELL size)
{
/* split the block in two */
CELL new_size = size + sizeof(F_BLOCK);
- F_BLOCK *split = (F_BLOCK *)((CELL)scan + new_size);
- split->status = B_FREE;
- split->size = scan->size - new_size;
+ F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)scan + new_size);
+ split->block.status = B_FREE;
+ split->block.size = scan->block.size - new_size;
split->next_free = scan->next_free;
- scan->size = new_size;
+ scan->block.size = new_size;
next_free = split;
}
@@ -125,9 +125,9 @@ void *heap_allot(F_HEAP *heap, CELL size)
update_free_list(heap,prev,next_free);
/* this is our new block */
- scan->status = B_ALLOCATED;
+ scan->block.status = B_ALLOCATED;
- return scan + 1;
+ return &scan->block + 1;
}
return NULL;
diff --git a/vm/code_gc.h b/vm/code_gc.h
index 4d4637d0e1..4d4aec1926 100644
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -12,16 +12,21 @@ typedef struct _F_BLOCK
/* In bytes, includes this header */
CELL size;
- /* Filled in on image load */
- struct _F_BLOCK *next_free;
-
/* Used during compaction */
struct _F_BLOCK *forwarding;
} F_BLOCK;
+typedef struct _F_FREE_BLOCK
+{
+ F_BLOCK block;
+
+ /* Filled in on image load */
+ struct _F_FREE_BLOCK *next_free;
+} F_FREE_BLOCK;
+
typedef struct {
F_SEGMENT *segment;
- F_BLOCK *free_list;
+ F_FREE_BLOCK *free_list;
} F_HEAP;
void new_heap(F_HEAP *heap, CELL size);
From 78f168e304b3d7320df01f2d5395a839f4e096a2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 19 Mar 2009 03:45:37 -0500
Subject: [PATCH 02/10] Remove code_length field from F_CODE_BLOCK struct, and
make F_BLOCK the head of F_CODE_BLOCK to simplify other code
---
vm/code_block.c | 24 +++++++++++-------------
vm/code_block.h | 2 +-
vm/code_gc.c | 18 +++++++-----------
vm/code_gc.h | 28 +---------------------------
vm/code_heap.c | 6 +++---
vm/code_heap.h | 10 ----------
vm/data_gc.h | 2 +-
vm/debug.c | 4 ++--
vm/layouts.h | 28 +++++++++++++++++++++++++++-
vm/profiler.c | 2 +-
vm/quotations.c | 4 ++--
vm/types.c | 2 +-
12 files changed, 57 insertions(+), 73 deletions(-)
diff --git a/vm/code_block.c b/vm/code_block.c
index a1369a3f99..8e528120dc 100644
--- a/vm/code_block.c
+++ b/vm/code_block.c
@@ -1,9 +1,8 @@
#include "master.h"
-void flush_icache_for(F_CODE_BLOCK *compiled)
+void flush_icache_for(F_CODE_BLOCK *block)
{
- CELL start = (CELL)(compiled + 1);
- flush_icache(start,compiled->code_length);
+ flush_icache((CELL)block,block->block.size);
}
void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
@@ -170,7 +169,7 @@ is added to the heap. */
collections */
void mark_code_block(F_CODE_BLOCK *compiled)
{
- mark_block(compiled_to_block(compiled));
+ mark_block(&compiled->block);
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
@@ -361,18 +360,18 @@ CELL compiled_code_format(void)
}
/* Might GC */
-void *allot_code_block(CELL size)
+F_CODE_BLOCK *allot_code_block(CELL size)
{
- void *start = heap_allot(&code_heap,size);
+ F_BLOCK *block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
/* If allocation failed, do a code GC */
- if(start == NULL)
+ if(block == NULL)
{
gc();
- start = heap_allot(&code_heap,size);
+ block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
/* Insufficient room even after code GC, give up */
- if(start == NULL)
+ if(block == NULL)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
@@ -385,11 +384,11 @@ void *allot_code_block(CELL size)
}
}
- return start;
+ return (F_CODE_BLOCK *)block;
}
/* Might GC */
-F_CODE_BLOCK *add_compiled_block(
+F_CODE_BLOCK *add_code_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
@@ -404,7 +403,7 @@ F_CODE_BLOCK *add_compiled_block(
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
- F_CODE_BLOCK *compiled = allot_code_block(sizeof(F_CODE_BLOCK) + code_length);
+ F_CODE_BLOCK *compiled = allot_code_block(code_length);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
@@ -415,7 +414,6 @@ F_CODE_BLOCK *add_compiled_block(
compiled->type = type;
compiled->last_scan = NURSERY;
compiled->needs_fixup = true;
- compiled->code_length = code_length;
compiled->literals = literals;
compiled->relocation = relocation;
diff --git a/vm/code_block.h b/vm/code_block.h
index 5ebe04f9c3..011847eb3c 100644
--- a/vm/code_block.h
+++ b/vm/code_block.h
@@ -83,7 +83,7 @@ CELL compiled_code_format(void);
bool stack_traces_p(void);
-F_CODE_BLOCK *add_compiled_block(
+F_CODE_BLOCK *add_code_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
diff --git a/vm/code_gc.c b/vm/code_gc.c
index aa82d34412..c3c5bc9a10 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -80,7 +80,7 @@ void build_free_list(F_HEAP *heap, CELL size)
}
/* Allocate a block of memory from the mark and sweep GC heap */
-void *heap_allot(F_HEAP *heap, CELL size)
+F_BLOCK *heap_allot(F_HEAP *heap, CELL size)
{
F_FREE_BLOCK *prev = NULL;
F_FREE_BLOCK *scan = heap->free_list;
@@ -92,9 +92,7 @@ void *heap_allot(F_HEAP *heap, CELL size)
if(scan->block.status != B_FREE)
critical_error("Invalid block in free list",(CELL)scan);
- CELL this_size = scan->block.size - sizeof(F_BLOCK);
-
- if(this_size < size)
+ if(scan->block.size < size)
{
prev = scan;
scan = scan->next_free;
@@ -104,7 +102,7 @@ void *heap_allot(F_HEAP *heap, CELL size)
/* we found a candidate block */
F_FREE_BLOCK *next_free;
- if(this_size - size <= sizeof(F_BLOCK) * 2)
+ if(scan->block.size - size <= sizeof(F_BLOCK) * 2)
{
/* too small to be split */
next_free = scan->next_free;
@@ -112,12 +110,11 @@ void *heap_allot(F_HEAP *heap, CELL size)
else
{
/* split the block in two */
- CELL new_size = size + sizeof(F_BLOCK);
- F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)scan + new_size);
+ F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)scan + size);
split->block.status = B_FREE;
- split->block.size = scan->block.size - new_size;
+ split->block.size = scan->block.size - size;
split->next_free = scan->next_free;
- scan->block.size = new_size;
+ scan->block.size = size;
next_free = split;
}
@@ -126,8 +123,7 @@ void *heap_allot(F_HEAP *heap, CELL size)
/* this is our new block */
scan->block.status = B_ALLOCATED;
-
- return &scan->block + 1;
+ return &scan->block;
}
return NULL;
diff --git a/vm/code_gc.h b/vm/code_gc.h
index 4d4aec1926..cc2c42f120 100644
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -1,29 +1,3 @@
-typedef enum
-{
- B_FREE,
- B_ALLOCATED,
- B_MARKED
-} F_BLOCK_STATUS;
-
-typedef struct _F_BLOCK
-{
- F_BLOCK_STATUS status;
-
- /* In bytes, includes this header */
- CELL size;
-
- /* Used during compaction */
- struct _F_BLOCK *forwarding;
-} F_BLOCK;
-
-typedef struct _F_FREE_BLOCK
-{
- F_BLOCK block;
-
- /* Filled in on image load */
- struct _F_FREE_BLOCK *next_free;
-} F_FREE_BLOCK;
-
typedef struct {
F_SEGMENT *segment;
F_FREE_BLOCK *free_list;
@@ -31,7 +5,7 @@ typedef struct {
void new_heap(F_HEAP *heap, CELL size);
void build_free_list(F_HEAP *heap, CELL size);
-void *heap_allot(F_HEAP *heap, CELL size);
+F_BLOCK *heap_allot(F_HEAP *heap, CELL size);
void mark_block(F_BLOCK *block);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap);
diff --git a/vm/code_heap.c b/vm/code_heap.c
index 325aed5037..89e6ceacfc 100755
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -40,7 +40,7 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter)
while(scan)
{
if(scan->status != B_FREE)
- iter(block_to_compiled(scan));
+ iter((F_CODE_BLOCK *)scan);
scan = next_block(&code_heap,scan);
}
}
@@ -103,7 +103,7 @@ void primitive_modify_code_heap(void)
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
- F_CODE_BLOCK *compiled = add_compiled_block(
+ F_CODE_BLOCK *compiled = add_code_block(
WORD_TYPE,
code,
labels,
@@ -137,7 +137,7 @@ void primitive_code_room(void)
F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled)
{
- return block_to_compiled(compiled_to_block(compiled)->forwarding);
+ return (F_CODE_BLOCK *)compiled->block.forwarding;
}
void forward_frame_xt(F_STACK_FRAME *frame)
diff --git a/vm/code_heap.h b/vm/code_heap.h
index 17a32aedd3..4f52819547 100755
--- a/vm/code_heap.h
+++ b/vm/code_heap.h
@@ -1,16 +1,6 @@
/* compiled code */
F_HEAP code_heap;
-INLINE F_BLOCK *compiled_to_block(F_CODE_BLOCK *compiled)
-{
- return (F_BLOCK *)compiled - 1;
-}
-
-INLINE F_CODE_BLOCK *block_to_compiled(F_BLOCK *block)
-{
- return (F_CODE_BLOCK *)(block + 1);
-}
-
void init_code_heap(CELL size);
bool in_code_heap_p(CELL ptr);
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 06beb7ea33..354c9398a5 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -30,7 +30,7 @@ u64 decks_scanned;
CELL code_heap_scans;
/* What generation was being collected when copy_code_heap_roots() was last
-called? Until the next call to add_compiled_block(), future
+called? Until the next call to add_code_block(), future
collections of younger generations don't have to touch the code
heap. */
CELL last_code_heap_scan;
diff --git a/vm/debug.c b/vm/debug.c
index 6b72b97bec..adae1cdd36 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -324,11 +324,11 @@ void dump_code_heap(void)
status = "free";
break;
case B_ALLOCATED:
- size += object_size(block_to_compiled(scan)->relocation);
+ size += object_size(((F_CODE_BLOCK *)scan)->relocation);
status = "allocated";
break;
case B_MARKED:
- size += object_size(block_to_compiled(scan)->relocation);
+ size += object_size(((F_CODE_BLOCK *)scan)->relocation);
status = "marked";
break;
default:
diff --git a/vm/layouts.h b/vm/layouts.h
index 5b417f92dd..95aa3c19b1 100755
--- a/vm/layouts.h
+++ b/vm/layouts.h
@@ -102,12 +102,38 @@ typedef struct {
} F_STRING;
/* The compiled code heap is structured into blocks. */
+typedef enum
+{
+ B_FREE,
+ B_ALLOCATED,
+ B_MARKED
+} F_BLOCK_STATUS;
+
+typedef struct _F_BLOCK
+{
+ F_BLOCK_STATUS status;
+
+ /* In bytes, includes this header */
+ CELL size;
+
+ /* Used during compaction */
+ struct _F_BLOCK *forwarding;
+} F_BLOCK;
+
+typedef struct _F_FREE_BLOCK
+{
+ F_BLOCK block;
+
+ /* Filled in on image load */
+ struct _F_FREE_BLOCK *next_free;
+} F_FREE_BLOCK;
+
typedef struct
{
+ F_BLOCK block;
char type; /* this is WORD_TYPE or QUOTATION_TYPE */
char last_scan; /* the youngest generation in which this block's literals may live */
char needs_fixup; /* is this a new block that needs full fixup? */
- CELL code_length; /* # bytes */
CELL literals; /* # bytes */
CELL relocation; /* tagged pointer to byte-array or f */
} F_CODE_BLOCK;
diff --git a/vm/profiler.c b/vm/profiler.c
index 66cefcf891..a6b4950cb6 100755
--- a/vm/profiler.c
+++ b/vm/profiler.c
@@ -21,7 +21,7 @@ F_CODE_BLOCK *compile_profiling_stub(F_WORD *word)
UNREGISTER_ROOT(code);
UNREGISTER_ROOT(literals);
- return add_compiled_block(
+ return add_code_block(
WORD_TYPE,
untag_object(code),
NULL, /* no labels */
diff --git a/vm/quotations.c b/vm/quotations.c
index 8ea2d5839b..cc501e1fdc 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -158,7 +158,7 @@ bool jit_stack_frame_p(F_ARRAY *array)
void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code)
{
if(code->type != QUOTATION_TYPE)
- critical_error("bad param to set_quot_xt",(CELL)code);
+ critical_error("Bad param to set_quot_xt",(CELL)code);
quot->code = code;
quot->xt = (XT)(code + 1);
@@ -339,7 +339,7 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY_TRIM(literals);
GROWABLE_BYTE_ARRAY_TRIM(relocation);
- F_CODE_BLOCK *compiled = add_compiled_block(
+ F_CODE_BLOCK *compiled = add_code_block(
QUOTATION_TYPE,
untag_object(code),
NULL,
diff --git a/vm/types.c b/vm/types.c
index 2f8cafb768..0162de6131 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -81,7 +81,7 @@ void primitive_word_xt(void)
F_WORD *word = untag_word(dpop());
F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code);
dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK)));
- dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK) + code->code_length));
+ dpush(allot_cell((CELL)code + code->block.size));
}
void primitive_wrapper(void)
From 8f059e07a79e7fea0a826cc4488e826269d805fb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 19 Mar 2009 03:49:49 -0500
Subject: [PATCH 03/10] Move flags from F_CODE_BLOCK to F_BLOCK for further
space savings
---
vm/callstack.c | 2 +-
vm/code_block.c | 18 +++++++++---------
vm/code_heap.c | 2 +-
vm/layouts.h | 8 ++++----
vm/quotations.c | 2 +-
5 files changed, 16 insertions(+), 16 deletions(-)
diff --git a/vm/callstack.c b/vm/callstack.c
index ae3f524112..d44a889756 100755
--- a/vm/callstack.c
+++ b/vm/callstack.c
@@ -97,7 +97,7 @@ F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame)
CELL frame_type(F_STACK_FRAME *frame)
{
- return frame_code(frame)->type;
+ return frame_code(frame)->block.type;
}
CELL frame_executing(F_STACK_FRAME *frame)
diff --git a/vm/code_block.c b/vm/code_block.c
index 8e528120dc..fc19aff2ac 100644
--- a/vm/code_block.c
+++ b/vm/code_block.c
@@ -107,12 +107,12 @@ void update_literal_references(F_CODE_BLOCK *compiled)
aging and nursery collections */
void copy_literal_references(F_CODE_BLOCK *compiled)
{
- if(collecting_gen >= compiled->last_scan)
+ if(collecting_gen >= compiled->block.last_scan)
{
if(collecting_accumulation_gen_p())
- compiled->last_scan = collecting_gen;
+ compiled->block.last_scan = collecting_gen;
else
- compiled->last_scan = collecting_gen + 1;
+ compiled->block.last_scan = collecting_gen + 1;
/* initialize chase pointer */
CELL scan = newspace->here;
@@ -153,7 +153,7 @@ to update references to other words, without worrying about literals
or dlsyms. */
void update_word_references(F_CODE_BLOCK *compiled)
{
- if(compiled->needs_fixup)
+ if(compiled->block.needs_fixup)
relocate_code_block(compiled);
else
{
@@ -305,8 +305,8 @@ void relocate_code_block_step(F_REL *rel, F_CODE_BLOCK *compiled)
/* Perform all fixups on a code block */
void relocate_code_block(F_CODE_BLOCK *compiled)
{
- compiled->last_scan = NURSERY;
- compiled->needs_fixup = false;
+ compiled->block.last_scan = NURSERY;
+ compiled->block.needs_fixup = false;
iterate_relocations(compiled,relocate_code_block_step);
flush_icache_for(compiled);
}
@@ -411,9 +411,9 @@ F_CODE_BLOCK *add_code_block(
UNREGISTER_ROOT(literals);
/* compiled header */
- compiled->type = type;
- compiled->last_scan = NURSERY;
- compiled->needs_fixup = true;
+ compiled->block.type = type;
+ compiled->block.last_scan = NURSERY;
+ compiled->block.needs_fixup = true;
compiled->literals = literals;
compiled->relocation = relocation;
diff --git a/vm/code_heap.c b/vm/code_heap.c
index 89e6ceacfc..65a28c6de3 100755
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -14,7 +14,7 @@ bool in_code_heap_p(CELL ptr)
void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled)
{
- if(compiled->type != WORD_TYPE)
+ if(compiled->block.type != WORD_TYPE)
critical_error("bad param to set_word_xt",(CELL)compiled);
word->code = compiled;
diff --git a/vm/layouts.h b/vm/layouts.h
index 95aa3c19b1..e9cdef6272 100755
--- a/vm/layouts.h
+++ b/vm/layouts.h
@@ -111,7 +111,10 @@ typedef enum
typedef struct _F_BLOCK
{
- F_BLOCK_STATUS status;
+ char status; /* free or allocated? */
+ char type; /* this is WORD_TYPE or QUOTATION_TYPE */
+ char last_scan; /* the youngest generation in which this block's literals may live */
+ char needs_fixup; /* is this a new block that needs full fixup? */
/* In bytes, includes this header */
CELL size;
@@ -131,9 +134,6 @@ typedef struct _F_FREE_BLOCK
typedef struct
{
F_BLOCK block;
- char type; /* this is WORD_TYPE or QUOTATION_TYPE */
- char last_scan; /* the youngest generation in which this block's literals may live */
- char needs_fixup; /* is this a new block that needs full fixup? */
CELL literals; /* # bytes */
CELL relocation; /* tagged pointer to byte-array or f */
} F_CODE_BLOCK;
diff --git a/vm/quotations.c b/vm/quotations.c
index cc501e1fdc..4df45eba54 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -157,7 +157,7 @@ bool jit_stack_frame_p(F_ARRAY *array)
void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code)
{
- if(code->type != QUOTATION_TYPE)
+ if(code->block.type != QUOTATION_TYPE)
critical_error("Bad param to set_quot_xt",(CELL)code);
quot->code = code;
From 9366ffe83af6e107f73a480797ba8baa5badd8be Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 19 Mar 2009 15:52:58 -0500
Subject: [PATCH 04/10] Fix load error
---
extra/project-euler/050/050.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/project-euler/050/050.factor b/extra/project-euler/050/050.factor
index a97e16d0fa..0c5b288b65 100644
--- a/extra/project-euler/050/050.factor
+++ b/extra/project-euler/050/050.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel locals math math.primes sequences ;
+USING: arrays kernel locals math math.primes sequences project-euler.common ;
IN: project-euler.050
! http://projecteuler.net/index.php?section=problems&id=50
From 7f4c967acea28ef92a36050831c6875e718f145d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 19 Mar 2009 20:02:43 -0500
Subject: [PATCH 05/10] More compact relocation layout
---
basis/compiler/codegen/codegen.factor | 2 +-
basis/compiler/codegen/fixup/fixup.factor | 32 ++++++++++------------
basis/compiler/constants/constants.factor | 4 +--
basis/cpu/ppc/bootstrap.factor | 2 +-
basis/cpu/x86/bootstrap.factor | 2 +-
basis/tools/profiler/profiler-tests.factor | 6 ++--
6 files changed, 22 insertions(+), 26 deletions(-)
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 40b1f56f8b..4ddd0c0300 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -53,7 +53,7 @@ SYMBOL: labels
V{ } clone literal-table set
V{ } clone calls set
compiling-word set
- compiled-stack-traces? compiling-word get f ? add-literal drop ;
+ compiled-stack-traces? compiling-word get f ? add-literal ;
: generate ( mr -- asm )
[
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index e0f391deb5..3a047a8d39 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
@@ -28,51 +28,47 @@ M: label-fixup fixup*
[ label>> ] [ class>> ] bi compiled-offset 4 - rot
3array label-table get push ;
-TUPLE: rel-fixup arg class type ;
+TUPLE: rel-fixup class type ;
-: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
+: rel-fixup ( class type -- ) \ rel-fixup boa , ;
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
- [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
- [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
- [ relocation-table get push-4 ] bi@ ;
+ [ type>> ]
+ [ class>> ]
+ [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
+ { 0 24 28 } bitfield
+ relocation-table get push-4 ;
M: integer fixup* , ;
-: indq ( elt seq -- n ) [ eq? ] with find drop ;
-
-: adjoin* ( obj table -- n )
- 2dup indq [ 2nip ] [ dup length [ push ] dip ] if* ;
-
SYMBOL: literal-table
-: add-literal ( obj -- n ) literal-table get adjoin* ;
+: add-literal ( obj -- ) literal-table get push ;
: add-dlsym-literals ( symbol dll -- )
- [ string>symbol ] dip 2array literal-table get push-all ;
+ [ string>symbol add-literal ] [ add-literal ] bi* ;
: rel-dlsym ( name dll class -- )
- [ literal-table get length [ add-dlsym-literals ] dip ] dip
- rt-dlsym rel-fixup ;
+ [ add-dlsym-literals ] dip rt-dlsym rel-fixup ;
: rel-word ( word class -- )
[ add-literal ] dip rt-xt rel-fixup ;
: rel-primitive ( word class -- )
- [ def>> first ] dip rt-primitive rel-fixup ;
+ [ def>> first add-literal ] dip rt-primitive rel-fixup ;
: rel-immediate ( literal class -- )
[ add-literal ] dip rt-immediate rel-fixup ;
: rel-this ( class -- )
- 0 swap rt-label rel-fixup ;
+ rt-this rel-fixup ;
: rel-here ( offset class -- )
- rt-here rel-fixup ;
+ [ add-literal ] dip rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index f82b6d479f..b3757bf008 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -23,7 +23,7 @@ CONSTANT: deck-bits 18
: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
-: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
+: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
! Relocation classes
CONSTANT: rc-absolute-cell 0
@@ -42,7 +42,7 @@ CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3
CONSTANT: rt-here 4
-CONSTANT: rt-label 5
+CONSTANT: rt-this 5
CONSTANT: rt-immediate 6
CONSTANT: rt-stack-chain 7
diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index b27f3aee72..ebee48de5f 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -41,7 +41,7 @@ big-endian on
stack-frame 6 LI
6 1 next-save STW
0 1 lr-save stack-frame + STW
-] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define
+] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define
[
0 6 LOAD32
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 5e3405e93a..f5829d76ea 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -32,7 +32,7 @@ big-endian off
temp0 PUSH
! alignment
stack-reg stack-frame-size 3 bootstrap-cells - SUB
-] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
+] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define
[
! load literal
diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor
index 3924cc7b83..0bd3663729 100644
--- a/basis/tools/profiler/profiler-tests.factor
+++ b/basis/tools/profiler/profiler-tests.factor
@@ -25,7 +25,7 @@ words ;
: indirect-test ( callback -- ) "void" { } "cdecl" alien-indirect ;
-: foobar ;
+: foobar ( -- ) ;
[
[ ] [ callback-test indirect-test ] unit-test
@@ -34,9 +34,9 @@ words ;
[ 1 ] [ \ foobar counter>> ] unit-test
-: fooblah { } [ ] each ;
+: fooblah ( -- ) { } [ ] like call ;
-: foobaz fooblah fooblah ;
+: foobaz ( -- ) fooblah fooblah ;
[ foobaz ] profile
From ae09d85d84828c6ac89e436ca4e87b4f1e7c53f0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 19 Mar 2009 20:03:07 -0500
Subject: [PATCH 06/10] More compact relocation layout
---
vm/code_block.c | 67 ++++++++++++++++++++++++++++++++-----------------
vm/code_block.h | 21 ++++++----------
vm/profiler.c | 12 ++++-----
vm/quotations.c | 64 +++++++++++++++++++++-------------------------
vm/types.c | 12 +++++++++
vm/types.h | 1 +
6 files changed, 99 insertions(+), 78 deletions(-)
diff --git a/vm/code_block.c b/vm/code_block.c
index fc19aff2ac..7cfadbbefb 100644
--- a/vm/code_block.c
+++ b/vm/code_block.c
@@ -11,12 +11,34 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
{
F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
- F_REL *rel = (F_REL *)(relocation + 1);
- F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
+ CELL index = 1;
+
+ CELL *rel = (CELL *)(relocation + 1);
+ CELL *rel_end = (CELL *)((char *)rel + byte_array_capacity(relocation));
while(rel < rel_end)
{
- iter(rel,compiled);
+ iter(*rel,index,compiled);
+
+ switch(REL_TYPE(*rel))
+ {
+ case RT_PRIMITIVE:
+ case RT_XT:
+ case RT_IMMEDIATE:
+ case RT_HERE:
+ index++;
+ break;
+ case RT_DLSYM:
+ index += 2;
+ break;
+ case RT_THIS:
+ case RT_STACK_CHAIN:
+ break;
+ default:
+ critical_error("Bad rel type",*rel);
+ return; /* Can't happen */
+ }
+
rel++;
}
}
@@ -85,13 +107,13 @@ void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_valu
}
}
-void update_literal_references_step(F_REL *rel, F_CODE_BLOCK *compiled)
+void update_literal_references_step(CELL rel, CELL index, F_CODE_BLOCK *compiled)
{
if(REL_TYPE(rel) == RT_IMMEDIATE)
{
- CELL offset = rel->offset + (CELL)(compiled + 1);
+ CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
- F_FIXNUM absolute_value = array_nth(literals,REL_ARGUMENT(rel));
+ F_FIXNUM absolute_value = array_nth(literals,index);
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
}
}
@@ -136,13 +158,13 @@ CELL object_xt(CELL obj)
return (CELL)untag_quotation(obj)->xt;
}
-void update_word_references_step(F_REL *rel, F_CODE_BLOCK *compiled)
+void update_word_references_step(CELL rel, CELL index, F_CODE_BLOCK *compiled)
{
if(REL_TYPE(rel) == RT_XT)
{
- CELL offset = rel->offset + (CELL)(compiled + 1);
+ CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
- CELL xt = object_xt(array_nth(literals,REL_ARGUMENT(rel)));
+ CELL xt = object_xt(array_nth(literals,index));
store_address_in_code_block(REL_CLASS(rel),offset,xt);
}
}
@@ -228,11 +250,10 @@ void undefined_symbol(void)
}
/* Look up an external library symbol referenced by a compiled code block */
-void *get_rel_symbol(F_REL *rel, F_ARRAY *literals)
+void *get_rel_symbol(F_ARRAY *literals, CELL index)
{
- CELL arg = REL_ARGUMENT(rel);
- CELL symbol = array_nth(literals,arg);
- CELL library = array_nth(literals,arg + 1);
+ CELL symbol = array_nth(literals,index);
+ CELL library = array_nth(literals,index + 1);
F_DLL *dll = (library == F ? NULL : untag_dll(library));
@@ -265,37 +286,37 @@ void *get_rel_symbol(F_REL *rel, F_ARRAY *literals)
}
/* Compute an address to store at a relocation */
-void relocate_code_block_step(F_REL *rel, F_CODE_BLOCK *compiled)
+void relocate_code_block_step(CELL rel, CELL index, F_CODE_BLOCK *compiled)
{
- CELL offset = rel->offset + (CELL)(compiled + 1);
+ CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
F_FIXNUM absolute_value;
switch(REL_TYPE(rel))
{
case RT_PRIMITIVE:
- absolute_value = (CELL)primitives[REL_ARGUMENT(rel)];
+ absolute_value = (CELL)primitives[to_fixnum(array_nth(literals,index))];
break;
case RT_DLSYM:
- absolute_value = (CELL)get_rel_symbol(rel,literals);
+ absolute_value = (CELL)get_rel_symbol(literals,index);
break;
case RT_IMMEDIATE:
- absolute_value = array_nth(literals,REL_ARGUMENT(rel));
+ absolute_value = array_nth(literals,index);
break;
case RT_XT:
- absolute_value = object_xt(array_nth(literals,REL_ARGUMENT(rel)));
+ absolute_value = object_xt(array_nth(literals,index));
break;
case RT_HERE:
- absolute_value = rel->offset + (CELL)(compiled + 1) + (short)REL_ARGUMENT(rel);
+ absolute_value = offset + (short)to_fixnum(array_nth(literals,index));
break;
- case RT_LABEL:
- absolute_value = (CELL)(compiled + 1) + REL_ARGUMENT(rel);
+ case RT_THIS:
+ absolute_value = (CELL)(compiled + 1);
break;
case RT_STACK_CHAIN:
absolute_value = (CELL)&stack_chain;
break;
default:
- critical_error("Bad rel type",rel->type);
+ critical_error("Bad rel type",rel);
return; /* Can't happen */
}
diff --git a/vm/code_block.h b/vm/code_block.h
index 011847eb3c..e3668108da 100644
--- a/vm/code_block.h
+++ b/vm/code_block.h
@@ -9,8 +9,8 @@ typedef enum {
RT_XT,
/* current offset */
RT_HERE,
- /* a local label */
- RT_LABEL,
+ /* current code block */
+ RT_THIS,
/* immediate literal */
RT_IMMEDIATE,
/* address of stack_chain var */
@@ -43,21 +43,14 @@ typedef enum {
#define REL_INDIRECT_ARM_MASK 0xfff
#define REL_RELATIVE_ARM_3_MASK 0xffffff
-/* the rel type is built like a cell to avoid endian-specific code in
-the compiler */
-#define REL_TYPE(r) ((r)->type & 0x000000ff)
-#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
-#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
-
-/* code relocation consists of a table of entries for each fixup */
-typedef struct {
- unsigned int type;
- unsigned int offset;
-} F_REL;
+/* code relocation table consists of a table of entries for each fixup */
+#define REL_TYPE(r) (((r) & 0xf0000000) >> 28)
+#define REL_CLASS(r) (((r) & 0x0f000000) >> 24)
+#define REL_OFFSET(r) ((r) & 0x00ffffff)
void flush_icache_for(F_CODE_BLOCK *compiled);
-typedef void (*RELOCATION_ITERATOR)(F_REL *rel, F_CODE_BLOCK *compiled);
+typedef void (*RELOCATION_ITERATOR)(CELL rel, CELL index, F_CODE_BLOCK *compiled);
void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter);
diff --git a/vm/profiler.c b/vm/profiler.c
index a6b4950cb6..b87a241f7d 100755
--- a/vm/profiler.c
+++ b/vm/profiler.c
@@ -3,7 +3,7 @@
/* Allocates memory */
F_CODE_BLOCK *compile_profiling_stub(F_WORD *word)
{
- CELL literals = allot_array_1(tag_object(word));
+ CELL literals = allot_array_2(tag_object(word),tag_object(word));
REGISTER_ROOT(literals);
F_ARRAY *quadruple = untag_object(userenv[JIT_PROFILING]);
@@ -11,12 +11,12 @@ F_CODE_BLOCK *compile_profiling_stub(F_WORD *word)
CELL code = array_nth(quadruple,0);
REGISTER_ROOT(code);
- F_REL rel;
- rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8);
- rel.offset = to_fixnum(array_nth(quadruple,3)) * compiled_code_format();
+ CELL rel = (to_fixnum(array_nth(quadruple,1)) << 24)
+ | (to_fixnum(array_nth(quadruple,2)) << 28)
+ | (to_fixnum(array_nth(quadruple,3)) * compiled_code_format());
- F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL));
- memcpy((void *)BREF(relocation,0),&rel,sizeof(F_REL));
+ F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(CELL));
+ memcpy(relocation + 1,&rel,sizeof(CELL));
UNREGISTER_ROOT(code);
UNREGISTER_ROOT(literals);
diff --git a/vm/quotations.c b/vm/quotations.c
index 4df45eba54..b65f8de27c 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -94,38 +94,31 @@ F_ARRAY *code_to_emit(CELL code)
return untag_object(array_nth(untag_object(code),0));
}
-F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length,
- CELL rel_argument, bool *rel_p)
+CELL rel_to_emit(CELL code, CELL code_format, CELL code_length, bool *rel_p)
{
F_ARRAY *quadruple = untag_object(code);
CELL rel_class = array_nth(quadruple,1);
CELL rel_type = array_nth(quadruple,2);
CELL offset = array_nth(quadruple,3);
- F_REL rel;
-
if(rel_class == F)
{
*rel_p = false;
- rel.type = 0;
- rel.offset = 0;
+ return 0;
}
else
{
*rel_p = true;
- rel.type = to_fixnum(rel_type)
- | (to_fixnum(rel_class) << 8)
- | (rel_argument << 16);
- rel.offset = (code_length + to_fixnum(offset)) * code_format;
+ return (to_fixnum(rel_type) << 28)
+ | (to_fixnum(rel_class) << 24)
+ | ((code_length + to_fixnum(offset)) * code_format);
}
-
- return rel;
}
-#define EMIT(name,rel_argument) { \
+#define EMIT(name) { \
bool rel_p; \
- F_REL rel = rel_to_emit(name,code_format,code_count,rel_argument,&rel_p); \
- if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \
+ CELL rel = rel_to_emit(name,code_format,code_count,&rel_p); \
+ if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(CELL)); \
GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \
}
@@ -192,7 +185,7 @@ void jit_compile(CELL quot, bool relocate)
bool stack_frame = jit_stack_frame_p(untag_object(array));
if(stack_frame)
- EMIT(userenv[JIT_PROLOG],0);
+ EMIT(userenv[JIT_PROLOG]);
CELL i;
CELL length = array_capacity(untag_object(array));
@@ -217,35 +210,36 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY_ADD(literals,T);
}
- EMIT(word->subprimitive,literals_count - 1);
+ EMIT(word->subprimitive);
}
else
{
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+ GROWABLE_ARRAY_ADD(literals,obj);
if(i == length - 1)
{
if(stack_frame)
- EMIT(userenv[JIT_EPILOG],0);
+ EMIT(userenv[JIT_EPILOG]);
- EMIT(userenv[JIT_WORD_JUMP],literals_count - 1);
+ EMIT(userenv[JIT_WORD_JUMP]);
tail_call = true;
}
else
- EMIT(userenv[JIT_WORD_CALL],literals_count - 1);
+ EMIT(userenv[JIT_WORD_CALL]);
}
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
GROWABLE_ARRAY_ADD(literals,wrapper->object);
- EMIT(userenv[JIT_PUSH_IMMEDIATE],literals_count - 1);
+ EMIT(userenv[JIT_PUSH_IMMEDIATE]);
break;
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
- EMIT(userenv[JIT_SAVE_STACK],0);
- EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj));
+ EMIT(userenv[JIT_SAVE_STACK]);
+ GROWABLE_ARRAY_ADD(literals,obj);
+ EMIT(userenv[JIT_PRIMITIVE]);
i++;
@@ -256,15 +250,15 @@ void jit_compile(CELL quot, bool relocate)
if(jit_fast_if_p(untag_object(array),i))
{
if(stack_frame)
- EMIT(userenv[JIT_EPILOG],0);
+ EMIT(userenv[JIT_EPILOG]);
jit_compile(array_nth(untag_object(array),i),relocate);
jit_compile(array_nth(untag_object(array),i + 1),relocate);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_IF_1],literals_count - 1);
+ EMIT(userenv[JIT_IF_1]);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
- EMIT(userenv[JIT_IF_2],literals_count - 1);
+ EMIT(userenv[JIT_IF_2]);
i += 2;
@@ -276,7 +270,7 @@ void jit_compile(CELL quot, bool relocate)
jit_compile(obj,relocate);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_DIP],literals_count - 1);
+ EMIT(userenv[JIT_DIP]);
i++;
break;
@@ -286,7 +280,7 @@ void jit_compile(CELL quot, bool relocate)
jit_compile(obj,relocate);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_2DIP],literals_count - 1);
+ EMIT(userenv[JIT_2DIP]);
i++;
break;
@@ -296,7 +290,7 @@ void jit_compile(CELL quot, bool relocate)
jit_compile(obj,relocate);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_3DIP],literals_count - 1);
+ EMIT(userenv[JIT_3DIP]);
i++;
break;
@@ -305,10 +299,10 @@ void jit_compile(CELL quot, bool relocate)
if(jit_fast_dispatch_p(untag_object(array),i))
{
if(stack_frame)
- EMIT(userenv[JIT_EPILOG],0);
+ EMIT(userenv[JIT_EPILOG]);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_DISPATCH],literals_count - 1);
+ EMIT(userenv[JIT_DISPATCH]);
i++;
@@ -322,7 +316,7 @@ void jit_compile(CELL quot, bool relocate)
}
default:
GROWABLE_ARRAY_ADD(literals,obj);
- EMIT(userenv[JIT_PUSH_IMMEDIATE],literals_count - 1);
+ EMIT(userenv[JIT_PUSH_IMMEDIATE]);
break;
}
}
@@ -330,9 +324,9 @@ void jit_compile(CELL quot, bool relocate)
if(!tail_call)
{
if(stack_frame)
- EMIT(userenv[JIT_EPILOG],0);
+ EMIT(userenv[JIT_EPILOG]);
- EMIT(userenv[JIT_RETURN],0);
+ EMIT(userenv[JIT_RETURN]);
}
GROWABLE_ARRAY_TRIM(code);
diff --git a/vm/types.c b/vm/types.c
index 0162de6131..119dc675bc 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -139,6 +139,18 @@ CELL allot_array_1(CELL obj)
return tag_object(a);
}
+CELL allot_array_2(CELL v1, CELL v2)
+{
+ REGISTER_ROOT(v1);
+ REGISTER_ROOT(v2);
+ F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2);
+ UNREGISTER_ROOT(v2);
+ UNREGISTER_ROOT(v1);
+ set_array_nth(a,0,v1);
+ set_array_nth(a,1,v2);
+ return tag_object(a);
+}
+
CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
{
REGISTER_ROOT(v1);
diff --git a/vm/types.h b/vm/types.h
index 5850489a4c..2775f57bb2 100755
--- a/vm/types.h
+++ b/vm/types.h
@@ -109,6 +109,7 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill);
F_BYTE_ARRAY *allot_byte_array(CELL size);
CELL allot_array_1(CELL obj);
+CELL allot_array_2(CELL v1, CELL v2);
CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
void primitive_array(void);
From 2a7848053fe2591c3f511a03ac7abfcd84dcbbf0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 19 Mar 2009 23:21:32 -0500
Subject: [PATCH 07/10] Fix 64-bit build issue; relocation entries are 32-bit
on all platforms
---
vm/code_block.c | 10 +++++-----
vm/code_block.h | 3 ++-
vm/profiler.c | 6 +++---
vm/quotations.c | 6 +++---
4 files changed, 13 insertions(+), 12 deletions(-)
diff --git a/vm/code_block.c b/vm/code_block.c
index 7cfadbbefb..a9b5277c84 100644
--- a/vm/code_block.c
+++ b/vm/code_block.c
@@ -13,8 +13,8 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
CELL index = 1;
- CELL *rel = (CELL *)(relocation + 1);
- CELL *rel_end = (CELL *)((char *)rel + byte_array_capacity(relocation));
+ F_REL *rel = (F_REL *)(relocation + 1);
+ F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
while(rel < rel_end)
{
@@ -107,7 +107,7 @@ void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_valu
}
}
-void update_literal_references_step(CELL rel, CELL index, F_CODE_BLOCK *compiled)
+void update_literal_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
{
if(REL_TYPE(rel) == RT_IMMEDIATE)
{
@@ -158,7 +158,7 @@ CELL object_xt(CELL obj)
return (CELL)untag_quotation(obj)->xt;
}
-void update_word_references_step(CELL rel, CELL index, F_CODE_BLOCK *compiled)
+void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
{
if(REL_TYPE(rel) == RT_XT)
{
@@ -286,7 +286,7 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index)
}
/* Compute an address to store at a relocation */
-void relocate_code_block_step(CELL rel, CELL index, F_CODE_BLOCK *compiled)
+void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
{
CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
diff --git a/vm/code_block.h b/vm/code_block.h
index e3668108da..b00e4be8b6 100644
--- a/vm/code_block.h
+++ b/vm/code_block.h
@@ -44,13 +44,14 @@ typedef enum {
#define REL_RELATIVE_ARM_3_MASK 0xffffff
/* code relocation table consists of a table of entries for each fixup */
+typedef u32 F_REL;
#define REL_TYPE(r) (((r) & 0xf0000000) >> 28)
#define REL_CLASS(r) (((r) & 0x0f000000) >> 24)
#define REL_OFFSET(r) ((r) & 0x00ffffff)
void flush_icache_for(F_CODE_BLOCK *compiled);
-typedef void (*RELOCATION_ITERATOR)(CELL rel, CELL index, F_CODE_BLOCK *compiled);
+typedef void (*RELOCATION_ITERATOR)(F_REL rel, CELL index, F_CODE_BLOCK *compiled);
void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter);
diff --git a/vm/profiler.c b/vm/profiler.c
index b87a241f7d..acafecdff5 100755
--- a/vm/profiler.c
+++ b/vm/profiler.c
@@ -11,12 +11,12 @@ F_CODE_BLOCK *compile_profiling_stub(F_WORD *word)
CELL code = array_nth(quadruple,0);
REGISTER_ROOT(code);
- CELL rel = (to_fixnum(array_nth(quadruple,1)) << 24)
+ F_REL rel = (to_fixnum(array_nth(quadruple,1)) << 24)
| (to_fixnum(array_nth(quadruple,2)) << 28)
| (to_fixnum(array_nth(quadruple,3)) * compiled_code_format());
- F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(CELL));
- memcpy(relocation + 1,&rel,sizeof(CELL));
+ F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL));
+ memcpy(relocation + 1,&rel,sizeof(F_REL));
UNREGISTER_ROOT(code);
UNREGISTER_ROOT(literals);
diff --git a/vm/quotations.c b/vm/quotations.c
index b65f8de27c..86e47745b7 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -94,7 +94,7 @@ F_ARRAY *code_to_emit(CELL code)
return untag_object(array_nth(untag_object(code),0));
}
-CELL rel_to_emit(CELL code, CELL code_format, CELL code_length, bool *rel_p)
+F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length, bool *rel_p)
{
F_ARRAY *quadruple = untag_object(code);
CELL rel_class = array_nth(quadruple,1);
@@ -117,8 +117,8 @@ CELL rel_to_emit(CELL code, CELL code_format, CELL code_length, bool *rel_p)
#define EMIT(name) { \
bool rel_p; \
- CELL rel = rel_to_emit(name,code_format,code_count,&rel_p); \
- if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(CELL)); \
+ F_REL rel = rel_to_emit(name,code_format,code_count,&rel_p); \
+ if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \
GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \
}
From 4b26ff6a95d0754a2aa38caeb7b309cd83e4052b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 20 Mar 2009 01:47:09 -0500
Subject: [PATCH 08/10] Add variables to set request-limit and upload-limit
---
basis/http/server/server.factor | 16 +++++++++++-----
basis/io/streams/limited/limited-docs.factor | 18 +++++++++---------
basis/io/streams/limited/limited-tests.factor | 6 +++---
basis/io/streams/limited/limited.factor | 10 +++++-----
4 files changed, 28 insertions(+), 22 deletions(-)
diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor
index d7f6f1841a..1e16b4146c 100755
--- a/basis/http/server/server.factor
+++ b/basis/http/server/server.factor
@@ -45,10 +45,13 @@ ERROR: no-boundary ;
";" split1 nip
"=" split1 nip [ no-boundary ] unless* ;
+SYMBOL: upload-limit
+
: read-multipart-data ( request -- mime-parts )
[ "content-type" header ]
[ "content-length" header string>number ] bi
- unlimit-input
+ unlimited-input
+ upload-limit get stream-throws limit-input
stream-eofs limit-input
binary decode-input
parse-multipart-form-data parse-multipart ;
@@ -250,12 +253,15 @@ LOG: httpd-benchmark DEBUG
httpd-benchmark
] [ call ] if ; inline
-TUPLE: http-server < threaded-server ;
+TUPLE: http-server < threaded-server request-limit ;
+
+SYMBOL: request-limit
+
+64 1024 * request-limit set-global
M: http-server handle-client*
- drop
- [
- 64 1024 * stream-throws limit-input
+ drop [
+ request-limit get stream-throws limit-input
?refresh-all
[ read-request ] ?benchmark
[ do-request ] ?benchmark
diff --git a/basis/io/streams/limited/limited-docs.factor b/basis/io/streams/limited/limited-docs.factor
index fac1232cc0..130c7ba3a9 100755
--- a/basis/io/streams/limited/limited-docs.factor
+++ b/basis/io/streams/limited/limited-docs.factor
@@ -5,14 +5,14 @@ IN: io.streams.limited
HELP: <limited-stream>
{ $values
- { "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
+ { "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
{ "stream'" "an input stream" }
}
{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit } " or " { $link limit-input } "." } ;
HELP: limit
{ $values
- { "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
+ { "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
{ "stream'" "a stream" }
}
{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." }
@@ -36,7 +36,7 @@ HELP: limit
}
} ;
-HELP: unlimit
+HELP: unlimited
{ $values
{ "stream" "an input stream" }
{ "stream'" "a stream" }
@@ -51,22 +51,22 @@ HELP: limited-stream
HELP: limit-input
{ $values
- { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
+ { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
}
{ $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ;
-HELP: unlimit-input
+HELP: unlimited-input
{ $description "Returns the underlying stream of the limited-stream stored in " { $link input-stream } "." } ;
HELP: stream-eofs
{ $values
- { "value" "a " { $link limited-stream } " mode singleton" }
+ { "value" { $link stream-throws } " or " { $link stream-eofs } }
}
{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will return " { $link f } " upon exhaustion." } ;
HELP: stream-throws
{ $values
- { "value" "a " { $link limited-stream } " mode singleton" }
+ { "value" { $link stream-throws } " or " { $link stream-eofs } }
}
{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will throw " { $link limit-exceeded } " upon exhaustion." } ;
@@ -79,9 +79,9 @@ ARTICLE: "io.streams.limited" "Limited input streams"
"Wrap the current " { $link input-stream } " in a limited stream:"
{ $subsection limit-input }
"Unlimits a limited stream:"
-{ $subsection unlimit }
+{ $subsection unlimited }
"Unlimits the current " { $link input-stream } ":"
-{ $subsection unlimit-input }
+{ $subsection unlimited-input }
"Make a limited stream throw an exception on exhaustion:"
{ $subsection stream-throws }
"Make a limited stream return " { $link f } " on exhaustion:"
diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor
index feddc130e9..36c257fb5e 100644
--- a/basis/io/streams/limited/limited-tests.factor
+++ b/basis/io/streams/limited/limited-tests.factor
@@ -57,13 +57,13 @@ IN: io.streams.limited.tests
[ t ]
[
- "abc" <string-reader> 3 stream-eofs limit unlimit
+ "abc" <string-reader> 3 stream-eofs limit unlimited
"abc" <string-reader> =
] unit-test
[ t ]
[
- "abc" <string-reader> 3 stream-eofs limit unlimit
+ "abc" <string-reader> 3 stream-eofs limit unlimited
"abc" <string-reader> =
] unit-test
@@ -71,7 +71,7 @@ IN: io.streams.limited.tests
[
[
"resource:license.txt" utf8 <file-reader> &dispose
- 3 stream-eofs limit unlimit
+ 3 stream-eofs limit unlimited
"resource:license.txt" utf8 <file-reader> &dispose
[ decoder? ] both?
] with-destructors
diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor
index 1237b3aba2..fe3dd9ad93 100755
--- a/basis/io/streams/limited/limited.factor
+++ b/basis/io/streams/limited/limited.factor
@@ -24,20 +24,20 @@ M: decoder limit ( stream limit mode -- stream' )
M: object limit ( stream limit mode -- stream' )
<limited-stream> ;
-GENERIC: unlimit ( stream -- stream' )
+GENERIC: unlimited ( stream -- stream' )
-M: decoder unlimit ( stream -- stream' )
+M: decoder unlimited ( stream -- stream' )
[ stream>> ] change-stream ;
-M: object unlimit ( stream -- stream' )
+M: object unlimited ( stream -- stream' )
stream>> stream>> ;
: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
-: unlimit-input ( -- ) input-stream [ unlimit ] change ;
+: unlimited-input ( -- ) input-stream [ unlimited ] change ;
: with-unlimited-stream ( stream quot -- )
- [ clone unlimit ] dip call ; inline
+ [ clone unlimited ] dip call ; inline
: with-limited-stream ( stream limit mode quot -- )
[ limit ] dip call ; inline
From fd0fd8fb7146ab3e948460fca53f4f45442e80d3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 20 Mar 2009 01:53:49 -0500
Subject: [PATCH 09/10] Remove useless slot
---
basis/http/server/server.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor
index 1e16b4146c..8b22b9a885 100755
--- a/basis/http/server/server.factor
+++ b/basis/http/server/server.factor
@@ -253,7 +253,7 @@ LOG: httpd-benchmark DEBUG
httpd-benchmark
] [ call ] if ; inline
-TUPLE: http-server < threaded-server request-limit ;
+TUPLE: http-server < threaded-server ;
SYMBOL: request-limit
From 91aec52a1e77b92c97f62a4106b7a37c905db8a6 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Fri, 20 Mar 2009 02:20:31 -0500
Subject: [PATCH 10/10] Fixing io.encodings.iana help lint
---
basis/io/encodings/iana/iana.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor
index b504bf854a..cb4627460c 100644
--- a/basis/io/encodings/iana/iana.factor
+++ b/basis/io/encodings/iana/iana.factor
@@ -10,10 +10,10 @@ SYMBOL: e>n-table
SYMBOL: aliases
PRIVATE>
-: name>encoding ( name -- encoding/f )
+: name>encoding ( name -- encoding )
n>e-table get-global at ;
-: encoding>name ( encoding -- name/f )
+: encoding>name ( encoding -- name )
e>n-table get-global at ;
<PRIVATE