From ef22d57ef65b8f6a8ec38ca853c75f8bdead1fb5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 28 Oct 2007 04:33:36 -0400
Subject: [PATCH 01/11] Improved profiler doesn't require all words to be
 recompiled to enable/disable

---
 core/alien/compiler/compiler.factor           |  2 +
 core/bootstrap/image/image.factor             |  8 ++-
 core/cpu/architecture/architecture.factor     |  3 +
 core/cpu/arm/architecture/architecture.factor | 15 ++---
 core/cpu/arm/arm.factor                       |  2 +
 core/cpu/ppc/architecture/architecture.factor |  8 +--
 core/cpu/ppc/ppc.factor                       |  2 +
 core/cpu/x86/32/32.factor                     |  2 +
 core/cpu/x86/64/64.factor                     |  2 +
 core/cpu/x86/architecture/architecture.factor |  7 +--
 core/generator/generator-docs.factor          |  6 +-
 core/generator/generator.factor               | 19 +++---
 extra/tools/profiler/profiler-docs.factor     | 33 +++-------
 extra/tools/profiler/profiler-tests.factor    |  4 --
 extra/tools/profiler/profiler.factor          | 31 ++--------
 extra/ui/tools/profiler/profiler.factor       | 12 ----
 extra/ui/tools/tools-docs.factor              |  2 +-
 vm/callstack.c                                | 11 +++-
 vm/callstack.h                                |  1 +
 vm/code_gc.c                                  | 22 +++----
 vm/code_gc.h                                  | 28 +--------
 vm/code_heap.c                                | 62 +++++++++++--------
 vm/code_heap.h                                |  4 +-
 vm/data_gc.c                                  | 18 +++---
 vm/debug.c                                    |  1 +
 vm/errors.c                                   | 24 +++----
 vm/factor.c                                   |  2 -
 vm/image.c                                    | 19 ++++--
 vm/layouts.h                                  | 20 +++++-
 vm/master.h                                   |  1 +
 vm/profiler.c                                 | 60 ++++++++++++++++++
 vm/profiler.h                                 |  3 +
 vm/quotations.c                               | 19 ++++--
 vm/run.c                                      | 35 +----------
 vm/run.h                                      |  8 +--
 35 files changed, 244 insertions(+), 252 deletions(-)
 create mode 100644 vm/profiler.c
 create mode 100644 vm/profiler.h

diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index f4f57f258d..a3fc5b5534 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -383,6 +383,8 @@ TUPLE: callback-context ;
 
 : generate-callback ( node -- )
     dup alien-callback-xt dup rot [
+        %save-xt
+        %prologue-later
         dup alien-stack-frame [
             init-templates
             dup registers>objects
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index f210f33ac5..ba0e4800fb 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -210,8 +210,9 @@ M: f '
         dup word-def ' ,
         dup word-props ' ,
         f ' ,
-        0 ,
-        0 ,
+        0 , ! count
+        0 , ! xt
+        0 , ! code
     ] { } make
     \ word type-number object tag-number
     [ emit-seq ] emit-object
@@ -307,7 +308,8 @@ M: quotation '
         quotation type-number object tag-number [
             emit ! array
             f ' emit ! compiled?
-            0 emit ! XT
+            0 emit ! xt
+            0 emit ! code
         ] emit-object
     ] cache ;
 
diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 22efad5c4d..6d2d455896 100644
--- a/core/cpu/architecture/architecture.factor
+++ b/core/cpu/architecture/architecture.factor
@@ -5,6 +5,9 @@ namespaces sequences layouts system hashtables classes alien
 byte-arrays bit-arrays float-arrays combinators words ;
 IN: cpu.architecture
 
+: set-profiler-prologues ( n -- )
+    39 setenv ;
+
 SYMBOL: compiler-backend
 
 ! A pseudo-register class for parameters spilled on the stack
diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor
index d082773b71..5fdca75f98 100755
--- a/core/cpu/arm/architecture/architecture.factor
+++ b/core/cpu/arm/architecture/architecture.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays cpu.arm.assembler compiler
-kernel kernel.private math namespaces words
-words.private generator.registers generator.fixup generator
-cpu.architecture system layouts ;
+kernel kernel.private math namespaces words words.private
+generator.registers generator.fixup generator cpu.architecture
+system layouts ;
 IN: cpu.arm.architecture
 
 TUPLE: arm-backend ;
@@ -86,18 +86,13 @@ M: arm-backend %epilogue ( n -- )
 : %alien-global ( symbol dll reg -- )
     [ compile-dlsym ] keep dup 0 <+> LDR ;
 
-M: arm-backend %profiler-prologue ( word -- )
+M: arm-backend %profiler-prologue ( -- )
     #! We can clobber R0 here since it is undefined at the start
     #! of a word.
-    "end" define-label
-    "profiling" f R12 %alien-global
-    R12 0 CMP
-    "end" get EQ B
     R12 load-indirect
     R0 R12 profile-count-offset <+> LDR
     R0 R0 1 v>operand ADD
-    R0 R12 profile-count-offset <+> STR
-    "end" resolve-label ;
+    R0 R12 profile-count-offset <+> STR ;
 
 M: arm-backend %call-label ( label -- ) BL ;
 
diff --git a/core/cpu/arm/arm.factor b/core/cpu/arm/arm.factor
index e2814b772f..ca37912790 100755
--- a/core/cpu/arm/arm.factor
+++ b/core/cpu/arm/arm.factor
@@ -52,3 +52,5 @@ T{ arm-backend } compiler-backend set-global
 "arm-variant" get "arm5" = [
     t have-BLX? set-global
 ] when
+
+7 cells set-profiler-prologue
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index ba2f90c7ed..714b41453b 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -103,16 +103,10 @@ M: ppc-backend %epilogue ( n -- )
     0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
 
 M: ppc-backend %profiler-prologue ( word -- )
-    "end" define-label
-    "profiling" f 3 %load-dlsym
-    3 3 0 LWZ
-    0 3 0 CMPI
-    "end" get BEQ
     3 load-indirect
     4 3 profile-count-offset LWZ
     4 4 1 v>operand ADDI
-    4 3 profile-count-offset STW
-    "end" resolve-label ;
+    4 3 profile-count-offset STW ;
 
 M: ppc-backend %call-label ( label -- ) BL ;
 
diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor
index 460ce26333..a9aea95b4d 100644
--- a/core/cpu/ppc/ppc.factor
+++ b/core/cpu/ppc/ppc.factor
@@ -13,3 +13,5 @@ namespaces alien.c-types kernel system combinators ;
 } cond
 
 T{ ppc-backend } compiler-backend set-global
+
+6 cells set-profiler-prologues
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index 9cf9994a33..df41571e55 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -281,3 +281,5 @@ T{ x86-backend f 4 } compiler-backend set-global
         " - no" print
     ] if
 ] unless
+
+9 set-profiler-prologues
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index cb1fdc85b8..5e5898ae88 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -204,3 +204,5 @@ M: struct-type flatten-value-type ( type -- seq )
             "void*" "double" ? c-type ,
         ] each
     ] if ;
+
+14 set-profiler-prologues
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 07651c16e7..e35c4a3d52 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -71,13 +71,8 @@ M: x86-backend %prepare-alien-invoke
     temp-reg v>operand 3 cells [+] rs-reg MOV ;
 
 M: x86-backend %profiler-prologue ( word -- )
-    "end" define-label
-    "profiling" f temp-reg v>operand %alien-global
-    temp-reg v>operand 0 CMP
-    "end" get JE
     temp-reg load-literal
-    temp-reg v>operand profile-count-offset [+] 1 v>operand ADD
-    "end" resolve-label ;
+    temp-reg v>operand profile-count-offset [+] 1 v>operand ADD ;
 
 M: x86-backend %call-label ( label -- ) CALL ;
 
diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor
index 9b19b57587..43089ca91a 100644
--- a/core/generator/generator-docs.factor
+++ b/core/generator/generator-docs.factor
@@ -5,8 +5,7 @@ IN: generator
 ARTICLE: "generator" "Compiled code generator"
 "Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
 $nl
-"Debugging information can be enabled or disabled; these hooks are used by " { $link "profiling" } " and " { $link "tools.deploy" } ":"
-{ $subsection profiler-prologues }
+"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
 { $subsection compiled-stack-traces }
 "Assembler intrinsics can be defined for low-level optimization:"
 { $subsection define-intrinsic }
@@ -66,9 +65,6 @@ HELP: generate-nodes
 { $description "Recursively generate machine code for a dataflow graph." }
 { $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
 
-HELP: profiler-prologue
-{ $description "Compiles a prologue which increment's the currently compiling word's call count, if such prologues were enabled by setting " { $link profiler-prologues } " to a true value." } ;
-
 HELP: generate
 { $values { "word" word } { "label" word } { "node" "a dataflow node" } }
 { $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index 380d6fd4a4..9e2cc23765 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -33,17 +33,17 @@ t compiled-stack-traces set-global
 : init-generator ( -- )
     V{ } clone literal-table set
     V{ } clone word-table set
-    compiled-stack-traces get
-    [ compiling-word get ] [ f ] if
+    compiled-stack-traces get compiling-word get f ?
     literal-table get push ;
 
+: profiler-prologue ( -- )
+    literal-table get first %profiler-prologue ;
+
 : generate-1 ( word label node quot -- )
     pick f save-xt [
         roll compiling-word set
         pick compiling-label set
         init-generator
-        %save-xt
-        %prologue-later
         call
         literal-table get >array
         word-table get >array
@@ -54,17 +54,12 @@ GENERIC: generate-node ( node -- next )
 : generate-nodes ( node -- )
     [ node@ generate-node ] iterate-nodes end-basic-block ;
 
-SYMBOL: profiler-prologues
-
-: profiler-prologue ( -- )
-    profiler-prologues get-global [
-        compiling-word get %profiler-prologue
-    ] when ;
-
 : generate ( word label node -- )
     [
         init-templates
         profiler-prologue
+        %save-xt
+        %prologue-later
         current-label-start define-label
         current-label-start resolve-label
         [ generate-nodes ] with-node-iterator
@@ -188,6 +183,8 @@ M: #if generate-node
     gensym [
         rot [
             copy-templates
+            %save-xt
+            %prologue-later
             [ generate-nodes ] with-node-iterator
         ] generate-1
     ] keep ;
diff --git a/extra/tools/profiler/profiler-docs.factor b/extra/tools/profiler/profiler-docs.factor
index 0af8943497..0c06417c1c 100644
--- a/extra/tools/profiler/profiler-docs.factor
+++ b/extra/tools/profiler/profiler-docs.factor
@@ -1,18 +1,15 @@
 USING: tools.profiler.private tools.time help.markup help.syntax
-quotations io strings words definitions generator ;
+quotations io strings words definitions ;
 IN: tools.profiler
 
 ARTICLE: "profiling" "Profiling code" 
-"A simple call counting profiler is included. Both compiled and interpreted code can be profiled. There are a number of limitations when profiling compiled code:"
+"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler. The profiler has three main limitations:"
 { $list
-    { "Calls to " { $link POSTPONE: inline } " words are not counted" }
-    "Calls to primitives are not counted"
+    "Calls to primitives are not counted."
+    { "Calls to " { $link POSTPONE: inline } " words from words compiled with the optimizing compiler are not counted." }
+    "Certain types of tail-recursive words compiled with the optimizing compiler will only count the initial invocation of the word, not every tail call."
 }
-"The profiler must be enabled before use:"
-{ $subsection enable-profiler }
-"Since enabling the profiler reduces performance, it should be disabled after use:"
-{ $subsection disable-profiler }
-"While enabled, a combinator which counts all calls made by a quotation can be used:"
+"Quotations can be passed to a combinator which calls them with word call counting enabled:"
 { $subsection profile }
 "After a quotation has been profiled, call counts can be presented in various ways:"
 { $subsection profile. }
@@ -34,20 +31,9 @@ HELP: counters.
 { $values { "assoc" "an association list mapping words to integers" } }
 { $description "Prints an association list of call counts to the " { $link stdio } " stream." } ;
 
-HELP: enable-profiler
-{ $description "Recompiles all words in the dictionary to include a stub which increments the call count during profiling. Once this is done, the " { $link profile } " combinator may be used." }
-{ $notes "Performance is affected when profiling is enabled, so profiling should only be enabled when necessary." } ;
-
-HELP: disable-profiler
-{ $description "Recompiles all words in the dictionary to exclude a stub which increments the call count during profiling. This should be done when you no longer wish to use the " { $link profile } " combinator." } ;
-
-HELP: check-profiler
-{ $description "Throws an error if the profiler has not yet been enabled by a call to " { $link enable-profiler } "." } ;
-
 HELP: profile
 { $values { "quot" quotation } }
-{ $description "Calls the quotation while collecting word call counts, which can then be displayed using " { $link profile. } " or related words." }
-{ $errors "Throws an error if the profiler has not been enabled by a prior call to " { $link enable-profiler } "." } ;
+{ $description "Calls the quotation while collecting word call counts, which can then be displayed using " { $link profile. } " or related words." } ;
 
 HELP: profile.
 { $description "Prints a table of call counts from the most recent invocation of " { $link profile } "." } ;
@@ -68,9 +54,6 @@ HELP: vocabs-profile.
 
 HELP: profiling ( ? -- )
 { $values { "?" "a boolean" } }
-{ $description "Internal primitive to switch on call counting. This word should not be used; instead see " { $link enable-profiler } ", " { $link profile } " and " { $link disable-profiler } "." } ;
+{ $description "Internal primitive to switch on call counting. This word should not be used; instead use " { $link profile } "." } ;
 
 { time profile } related-words
-
-HELP: profiler-prologues
-{ $var-description "If set, each word will be compiled with an extra prologue which checks if profiling is enabled, and if so, increments the word's call count. This variable is off by default. It should never be set directly; " { $link enable-profiler } " and " { $link disable-profiler } " should be used instead." } ;
diff --git a/extra/tools/profiler/profiler-tests.factor b/extra/tools/profiler/profiler-tests.factor
index 991f2af562..e76e5759b9 100644
--- a/extra/tools/profiler/profiler-tests.factor
+++ b/extra/tools/profiler/profiler-tests.factor
@@ -2,8 +2,6 @@ IN: temporary
 USING: tools.profiler tools.test kernel memory math threads
 alien tools.profiler.private ;
 
-enable-profiler
-
 [ ] [ [ 10 [ data-gc ] times ] profile ] unit-test
 
 [ ] [ [ 1000 sleep ] profile ] unit-test 
@@ -28,5 +26,3 @@ enable-profiler
 ] profile
 
 [ 1 ] [ \ foobar profile-counter ] unit-test
-
-disable-profiler
diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor
index ee34e6f9b0..456c4876ec 100755
--- a/extra/tools/profiler/profiler.factor
+++ b/extra/tools/profiler/profiler.factor
@@ -1,13 +1,12 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: words sequences math prettyprint kernel arrays
-io io.styles namespaces assocs kernel.private generator
-compiler strings combinators sorting math.parser
-vocabs definitions tools.profiler.private ;
+USING: words sequences math prettyprint kernel arrays io
+io.styles namespaces assocs kernel.private strings combinators
+sorting math.parser vocabs definitions tools.profiler.private ;
 IN: tools.profiler
 
-: reset-counters ( -- )
-    all-words [ 0 swap set-profile-counter ] each ;
+: profile ( quot -- )
+    [ t profiling call ] [ f profiling ] [ ] cleanup ;
 
 : counters ( words -- assoc )
     [ dup profile-counter ] { } map>assoc ;
@@ -40,26 +39,6 @@ M: string (profile.)
         [ counter. ] assoc-each
     ] tabular-output ;
 
-: enable-profiler ( -- )
-    t profiler-prologues set-global recompile-all
-    "Profiler enabled; use disable-profiler to disable" print ;
-
-: disable-profiler ( -- )
-    f profiler-prologues set-global recompile-all ;
-
-: check-profiler ( -- )
-    profiler-prologues get-global [
-        "Enable the profiler by calling enable-profiler first"
-        throw
-    ] unless ;
-
-: profile ( quot -- )
-    check-profiler
-    reset-counters
-    t profiling
-    call
-    f profiling ;
-
 : profile. ( -- )
     "Call counts for all words:" print
     all-words counters counters. ;
diff --git a/extra/ui/tools/profiler/profiler.factor b/extra/ui/tools/profiler/profiler.factor
index 0fbe6a74f9..2c25474fa0 100644
--- a/extra/ui/tools/profiler/profiler.factor
+++ b/extra/ui/tools/profiler/profiler.factor
@@ -24,23 +24,11 @@ TUPLE: profiler-gadget pane ;
 : com-vocabs-profile ( gadget -- )
     [ vocabs-profile. ] with-profiler-pane ;
 
-\ enable-profiler H{
-    { +nullary+ t }
-    { +listener+ t }
-} define-command
-
-\ disable-profiler H{
-    { +nullary+ t }
-    { +listener+ t }
-} define-command
-
 : profiler-help "ui-profiler" help-window ;
 
 \ profiler-help H{ { +nullary+ t } } define-command
 
 profiler-gadget "toolbar" f {
-    { f enable-profiler }
-    { f disable-profiler }
     { f com-full-profile }
     { f com-vocabs-profile }
     { T{ key-down f f "F1" } profiler-help }
diff --git a/extra/ui/tools/tools-docs.factor b/extra/ui/tools/tools-docs.factor
index 82544a55cf..e80dfe3c33 100644
--- a/extra/ui/tools/tools-docs.factor
+++ b/extra/ui/tools/tools-docs.factor
@@ -65,7 +65,7 @@ $nl
 ARTICLE: "ui-profiler" "UI profiler" 
 "The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
 $nl
-"The profiler must be enabled before use. Once the profiler has been enabled, enter a piece of code in the listener input area and press " { $operation com-profile } "."
+"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
 $nl
 "Vocabulary and word presentations in the profiler pane can be clicked on to show profiler results pertaining to the object in question. Clicking a vocabulary in the profiler yields the same output as the " { $link vocab-profile. } " word, and clicking a word yields the same output as the " { $link usage-profile. } " word. Consult " { $link "profiling" } " for details."
 { $command-map profiler-gadget "toolbar" } ;
diff --git a/vm/callstack.c b/vm/callstack.c
index 4461d39b1c..536be88bda 100755
--- a/vm/callstack.c
+++ b/vm/callstack.c
@@ -95,14 +95,19 @@ DEFINE_PRIMITIVE(set_callstack)
 	critical_error("Bug in set_callstack()",0);
 }
 
+F_COMPILED *frame_code(F_STACK_FRAME *frame)
+{
+	return (F_COMPILED *)frame->xt - 1;
+}
+
 CELL frame_type(F_STACK_FRAME *frame)
 {
-	return xt_to_compiled(frame->xt)->type;
+	return frame_code(frame)->type;
 }
 
 CELL frame_executing(F_STACK_FRAME *frame)
 {
-	F_COMPILED *compiled = xt_to_compiled(frame->xt);
+	F_COMPILED *compiled = frame_code(frame);
 	CELL code_start = (CELL)(compiled + 1);
 	CELL literal_start = code_start
 		+ compiled->code_length
@@ -199,7 +204,7 @@ DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
 	REGISTER_UNTAGGED(callstack);
 	REGISTER_UNTAGGED(quot);
 
-	if(quot->compiled == F)
+	if(quot->compiledp == F)
 		jit_compile(quot);
 
 	UNREGISTER_UNTAGGED(quot);
diff --git a/vm/callstack.h b/vm/callstack.h
index 4033820184..6c38cd0117 100644
--- a/vm/callstack.h
+++ b/vm/callstack.h
@@ -9,6 +9,7 @@ F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom);
 void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator);
 void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator);
 F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame);
+F_COMPILED *frame_code(F_STACK_FRAME *frame);
 CELL frame_executing(F_STACK_FRAME *frame);
 CELL frame_scan(F_STACK_FRAME *frame);
 CELL frame_type(F_STACK_FRAME *frame);
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 1595ba66df..aa97203444 100644
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -279,17 +279,17 @@ void collect_literals(void)
 void mark_sweep_step(F_COMPILED *compiled, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
 {
-	CELL scan;
+	F_COMPILED **start = (F_COMPILED **)words_start;
+	F_COMPILED **end = (F_COMPILED **)words_end;
+	F_COMPILED **iter = start;
 
-	for(scan = words_start; scan < words_end; scan += CELLS)
-		recursive_mark((XT)get(scan));
+	while(iter < end)
+		recursive_mark(compiled_to_block(*iter++));
 }
 
 /* Mark all XTs and literals referenced from a word XT */
-void recursive_mark(XT xt)
+void recursive_mark(F_BLOCK *block)
 {
-	F_BLOCK *block = xt_to_block(xt);
-
 	/* If already marked, do nothing */
 	switch(block->status)
 	{
@@ -303,7 +303,7 @@ void recursive_mark(XT xt)
 		break;
 	}
 
-	F_COMPILED *compiled = xt_to_compiled(xt);
+	F_COMPILED *compiled = block_to_compiled(block);
 	iterate_code_heap_step(compiled,collect_literals_step);
 
 	switch(compiled->finalized)
@@ -388,8 +388,8 @@ CELL compute_heap_forwarding(F_HEAP *heap)
 
 void forward_xt(XT *xt)
 {
-	F_BLOCK *block = xt_to_block(*xt);
-	*xt = block_to_xt(block->forwarding);
+	/* F_BLOCK *block = xt_to_block(*xt);
+	*xt = block_to_xt(block->forwarding); */
 }
 
 void forward_object_xts(void)
@@ -404,14 +404,14 @@ void forward_object_xts(void)
 		{
 			F_WORD *word = untag_object(obj);
 
-			if(in_code_heap_p((CELL)word->xt))
+			if(word->compiledp != F)
 				forward_xt(&word->xt);
 		}
 		else if(type_of(obj) == QUOTATION_TYPE)
 		{
 			F_QUOTATION *quot = untag_object(obj);
 
-			if(in_code_heap_p((CELL)quot->xt))
+			if(quot->compiledp != F)
 				forward_xt(&quot->xt);
 		}
 	}
diff --git a/vm/code_gc.h b/vm/code_gc.h
index a2b1310585..b91f16e5b0 100644
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -47,18 +47,6 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
 /* compiled code */
 F_HEAP code_heap;
 
-/* The compiled code heap is structured into blocks. */
-typedef struct
-{
-	CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */
-	CELL code_length; /* # bytes */
-	CELL reloc_length; /* # bytes */
-	CELL literals_length; /* # bytes */
-	CELL words_length; /* # bytes */
-	CELL finalized; /* has finalize_code_block() been called on this yet? */
-	CELL padding[2];
-} F_COMPILED;
-
 typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end);
 
@@ -73,14 +61,9 @@ INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter
 	iter(compiled,code_start,reloc_start,literals_start,words_start,words_end);
 }
 
-INLINE F_BLOCK *xt_to_block(XT xt)
+INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)
 {
-	return (F_BLOCK *)((CELL)xt - sizeof(F_BLOCK) - sizeof(F_COMPILED));
-}
-
-INLINE F_COMPILED *xt_to_compiled(XT xt)
-{
-	return (F_COMPILED *)((CELL)xt - sizeof(F_COMPILED));
+	return (F_BLOCK *)compiled - 1;
 }
 
 INLINE F_COMPILED *block_to_compiled(F_BLOCK *block)
@@ -88,11 +71,6 @@ INLINE F_COMPILED *block_to_compiled(F_BLOCK *block)
 	return (F_COMPILED *)(block + 1);
 }
 
-INLINE XT block_to_xt(F_BLOCK *block)
-{
-	return (XT)((CELL)block + sizeof(F_BLOCK) + sizeof(F_COMPILED));
-}
-
 INLINE F_BLOCK *first_block(F_HEAP *heap)
 {
 	return (F_BLOCK *)heap->segment->start;
@@ -107,7 +85,7 @@ void init_code_heap(CELL size);
 bool in_code_heap_p(CELL ptr);
 void iterate_code_heap(CODE_HEAP_ITERATOR iter);
 void collect_literals(void);
-void recursive_mark(XT xt);
+void recursive_mark(F_BLOCK *block);
 void dump_heap(F_HEAP *heap);
 void code_gc(void);
 void compact_code_heap(void);
diff --git a/vm/code_heap.c b/vm/code_heap.c
index 9487c7a47a..6e6d024147 100644
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -36,6 +36,8 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start)
 		return undefined_symbol;
 }
 
+static CELL xt_offset;
+
 /* Compute an address to store at a relocation */
 INLINE CELL compute_code_rel(F_REL *rel,
 	CELL code_start, CELL literals_start, CELL words_start)
@@ -51,7 +53,8 @@ INLINE CELL compute_code_rel(F_REL *rel,
 	case RT_DISPATCH:
 		return CREF(words_start,REL_ARGUMENT(rel));
 	case RT_XT:
-		return get(CREF(words_start,REL_ARGUMENT(rel)));
+		return get(CREF(words_start,REL_ARGUMENT(rel)))
+			+ sizeof(F_COMPILED) + xt_offset;
 	case RT_LABEL:
 		return code_start + REL_ARGUMENT(rel);
 	default:
@@ -127,6 +130,8 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
 void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
 {
+	xt_offset = (profiling_p() ? 0 : profiler_prologue());
+
 	F_REL *rel = (F_REL *)reloc_start;
 	F_REL *rel_end = (F_REL *)literals_start;
 
@@ -172,12 +177,15 @@ void finalize_code_block(F_COMPILED *relocating, CELL code_start,
 		critical_error("Finalizing a finalized block",(CELL)relocating);
 
 	for(scan = words_start; scan < words_end; scan += CELLS)
-		put(scan,(CELL)(untag_word(get(scan))->xt));
+		put(scan,(CELL)(untag_word(get(scan))->code));
 
 	relocating->finalized = true;
 
-	relocate_code_block(relocating,code_start,reloc_start,
-		literals_start,words_start,words_end);
+	if(reloc_start != literals_start)
+	{
+		relocate_code_block(relocating,code_start,reloc_start,
+			literals_start,words_start,words_end);
+	}
 
 	flush_icache(code_start,reloc_start - code_start);
 }
@@ -231,7 +239,7 @@ CELL allot_code_block(CELL size)
 	return start;
 }
 
-XT add_compiled_block(
+F_COMPILED *add_compiled_block(
 	CELL type,
 	F_ARRAY *code,
 	F_ARRAY *labels,
@@ -252,7 +260,7 @@ XT add_compiled_block(
 	REGISTER_UNTAGGED(words);
 	REGISTER_UNTAGGED(literals);
 
-	CELL start = allot_code_block(sizeof(F_COMPILED) + code_length
+	CELL here = allot_code_block(sizeof(F_COMPILED) + code_length
 		+ rel_length + literals_length + words_length);
 
 	UNREGISTER_UNTAGGED(literals);
@@ -261,9 +269,6 @@ XT add_compiled_block(
 	UNREGISTER_UNTAGGED(labels);
 	UNREGISTER_UNTAGGED(code);
 
-	/* begin depositing the code block's contents */
-	CELL here = start;
-
 	/* compiled header */
 	F_COMPILED *header = (void *)here;
 	header->type = type;
@@ -275,6 +280,8 @@ XT add_compiled_block(
 
 	here += sizeof(F_COMPILED);
 
+	CELL code_start = here;
+
 	/* code */
 	deposit_integers(here,code,code_format);
 	here += code_length;
@@ -300,18 +307,26 @@ XT add_compiled_block(
 		here += words_length;
 	}
 
-	/* compute the XT */
-	XT xt = (XT)(start + sizeof(F_COMPILED));
-
 	/* fixup labels */
 	if(labels)
-		fixup_labels(labels,code_format,(CELL)xt);
+		fixup_labels(labels,code_format,code_start);
 
 	/* next time we do a minor GC, we have to scan the code heap for
 	literals */
 	last_code_heap_scan = NURSERY;
 
-	return xt;
+	return header;
+}
+
+void set_word_xt(F_WORD *word, F_COMPILED *compiled)
+{
+	word->code = compiled;
+	word->xt = (XT)(compiled + 1);
+
+	if(!profiling_p())
+		word->xt += profiler_prologue();
+
+	word->compiledp = T;
 }
 
 DEFINE_PRIMITIVE(add_compiled_block)
@@ -322,12 +337,11 @@ DEFINE_PRIMITIVE(add_compiled_block)
 	F_ARRAY *words = untag_array(dpop());
 	F_ARRAY *literals = untag_array(dpop());
 
-	XT xt = add_compiled_block(WORD_TYPE,code,labels,rel,words,literals);
+	F_COMPILED *compiled = add_compiled_block(WORD_TYPE,code,labels,rel,words,literals);
 
-	/* push the XT of the new word on the stack */
+	/* push a new word whose XT points to this code block on the stack */
 	F_WORD *word = allot_word(F,F);
-	word->xt = xt;
-	word->compiledp = T;
+	set_word_xt(word,compiled);
 	dpush(tag_object(word));
 }
 
@@ -344,13 +358,8 @@ DEFINE_PRIMITIVE(finalize_compile)
 	{
 		F_ARRAY *pair = untag_array(array_nth(array,i));
 		F_WORD *word = untag_word(array_nth(pair,0));
-		XT xt = untag_word(array_nth(pair,1))->xt;
-		F_BLOCK *block = xt_to_block(xt);
-		if(block->status != B_ALLOCATED)
-			critical_error("bad XT",(CELL)xt);
-
-		word->xt = xt;
-		word->compiledp = T;
+		F_COMPILED *compiled = untag_word(array_nth(pair,1))->code;
+		set_word_xt(word,compiled);
 	}
 
 	/* perform relocation */
@@ -358,7 +367,6 @@ DEFINE_PRIMITIVE(finalize_compile)
 	{
 		F_ARRAY *pair = untag_array(array_nth(array,i));
 		F_WORD *word = untag_word(array_nth(pair,0));
-		XT xt = word->xt;
-		iterate_code_heap_step(xt_to_compiled(xt),finalize_code_block);
+		iterate_code_heap_step(word->code,finalize_code_block);
 	}
 }
diff --git a/vm/code_heap.h b/vm/code_heap.h
index c4aeb9e6c3..4bc6803533 100644
--- a/vm/code_heap.h
+++ b/vm/code_heap.h
@@ -57,7 +57,9 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 void finalize_code_block(F_COMPILED *relocating, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end);
 
-XT add_compiled_block(
+void set_word_xt(F_WORD *word, F_COMPILED *compiled);
+
+F_COMPILED *add_compiled_block(
 	CELL type,
 	F_ARRAY *code,
 	F_ARRAY *labels,
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 89e5ac3b56..8016ad4234 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -386,7 +386,7 @@ void collect_stack_frame(F_STACK_FRAME *frame)
 	}
 
 	if(collecting_code)
-		recursive_mark(frame->xt);
+		recursive_mark(compiled_to_block(frame_code(frame)));
 }
 
 /* The base parameter allows us to adjust for a heap-allocated
@@ -402,9 +402,6 @@ void collect_callstack(F_CONTEXT *stacks)
 the user environment and extra roots registered with REGISTER_ROOT */
 void collect_roots(void)
 {
-	int i;
-	F_CONTEXT *stacks;
-
 	copy_handle(&T);
 	copy_handle(&bignum_zero);
 	copy_handle(&bignum_pos_one);
@@ -413,7 +410,7 @@ void collect_roots(void)
 	collect_stack(extra_roots_region,extra_roots);
 
 	save_stacks();
-	stacks = stack_chain;
+	F_CONTEXT *stacks = stack_chain;
 
 	while(stacks)
 	{
@@ -428,6 +425,7 @@ void collect_roots(void)
 		stacks = stacks->next;
 	}
 
+	int i;
 	for(i = 0; i < USER_ENV; i++)
 		copy_handle(&userenv[i]);
 }
@@ -517,13 +515,13 @@ CELL binary_payload_start(CELL pointer)
 		return 0;
 	/* these objects have some binary data at the end */
 	case WORD_TYPE:
-		return sizeof(F_WORD) - CELLS;
+		return sizeof(F_WORD) - CELLS * 2;
 	case ALIEN_TYPE:
 		return CELLS * 3;
 	case DLL_TYPE:
 		return CELLS * 2;
 	case QUOTATION_TYPE:
-		return sizeof(F_QUOTATION) - CELLS;
+		return sizeof(F_QUOTATION) - CELLS * 2;
 	/* everything else consists entirely of pointers */
 	default:
 		return unaligned_object_size(pointer);
@@ -549,12 +547,12 @@ CELL collect_next(CELL scan)
 	case WORD_TYPE:
 		word = (F_WORD *)scan;
 		if(collecting_code && word->compiledp != F)
-			recursive_mark(word->xt);
+			recursive_mark(compiled_to_block(word->code));
 		break;
 	case QUOTATION_TYPE:
 		quot = (F_QUOTATION *)scan;
-		if(collecting_code && quot->xt != lazy_jit_compile)
-			recursive_mark(quot->xt);
+		if(collecting_code && quot->compiledp != F)
+			recursive_mark(compiled_to_block(quot->code));
 		break;
 	case CALLSTACK_TYPE:
 		stack = (F_CALLSTACK *)scan;
diff --git a/vm/debug.c b/vm/debug.c
index b0761a4c5c..733f4eb49c 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -192,6 +192,7 @@ void dump_generations(void)
 
 void dump_objects(F_FIXNUM type)
 {
+	data_gc();
 	begin_scan();
 
 	CELL obj;
diff --git a/vm/errors.c b/vm/errors.c
index 1472283c51..d306ea1aff 100755
--- a/vm/errors.c
+++ b/vm/errors.c
@@ -15,22 +15,22 @@ void critical_error(char* msg, CELL tagged)
 
 void throw_error(CELL error, F_STACK_FRAME *callstack_top)
 {
-	/* If error was thrown during heap scan, we re-enable the GC */
-	gc_off = false;
-
-	/* Reset local roots */
-	extra_roots = stack_chain->extra_roots;
-
-	/* If we had an underflow or overflow, stack pointers might be
-	out of bounds */
-	fix_stacks();
-
-	dpush(error);
-
 	/* If the error handler is set, we rewind any C stack frames and
 	pass the error to user-space. */
 	if(userenv[BREAK_ENV] != F)
 	{
+		/* If error was thrown during heap scan, we re-enable the GC */
+		gc_off = false;
+
+		/* Reset local roots */
+		extra_roots = stack_chain->extra_roots;
+
+		/* If we had an underflow or overflow, stack pointers might be
+		out of bounds */
+		fix_stacks();
+
+		dpush(error);
+
 		/* Errors thrown from C code pass NULL for this parameter.
 		Errors thrown from Factor code, or signal handlers, pass the
 		actual stack pointer at the time, since the saved pointer is
diff --git a/vm/factor.c b/vm/factor.c
index d5e3ab23cf..7b37648081 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -43,8 +43,6 @@ void init_factor(F_PARAMETERS *p)
 	/* Disable GC during init as a sanity check */
 	gc_off = true;
 
-	profiling = false;
-
 	early_init();
 
 	if(p->image == NULL)
diff --git a/vm/image.c b/vm/image.c
index 7b9e67f5cf..bca8a36052 100755
--- a/vm/image.c
+++ b/vm/image.c
@@ -144,8 +144,8 @@ DEFINE_PRIMITIVE(save_image_and_exit)
 		userenv[i] = F;
 
 	/* do a full GC + code heap compaction */
-	compact_code_heap();
-
+	//compact_code_heap();
+	code_gc();
 	save_image(unbox_native_string());
 
 	/* now exit; we cannot continue executing like this */
@@ -159,15 +159,21 @@ void fixup_word(F_WORD *word)
 	if(word->compiledp == F)
 		word->xt = default_word_xt(word);
 	else
+	{
 		code_fixup(&word->xt);
+		code_fixup(&word->code);
+	}
 }
 
 void fixup_quotation(F_QUOTATION *quot)
 {
-	if(quot->compiled == F)
+	if(quot->compiledp == F)
 		quot->xt = lazy_jit_compile;
 	else
+	{
 		code_fixup(&quot->xt);
+		code_fixup(&quot->code);
+	}
 }
 
 void fixup_alien(F_ALIEN *d)
@@ -263,8 +269,11 @@ void fixup_code_block(F_COMPILED *relocating, CELL code_start,
 			data_fixup((CELL*)scan);
 	}
 
-	relocate_code_block(relocating,code_start,reloc_start,
-		literals_start,words_start,words_end);
+	if(reloc_start != literals_start)
+	{
+		relocate_code_block(relocating,code_start,reloc_start,
+			literals_start,words_start,words_end);
+	}
 }
 
 void relocate_code()
diff --git a/vm/layouts.h b/vm/layouts.h
index 92a42d33f4..94a2fe3a1b 100755
--- a/vm/layouts.h
+++ b/vm/layouts.h
@@ -144,6 +144,18 @@ typedef struct {
 	CELL array;
 } F_HASHTABLE;
 
+/* The compiled code heap is structured into blocks. */
+typedef struct
+{
+	CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */
+	CELL code_length; /* # bytes */
+	CELL reloc_length; /* # bytes */
+	CELL literals_length; /* # bytes */
+	CELL words_length; /* # bytes */
+	CELL finalized; /* has finalize_code_block() been called on this yet? */
+	CELL padding[2];
+} F_COMPILED;
+
 /* Assembly code makes assumptions about the layout of this struct */
 typedef struct {
 	/* TAGGED header */
@@ -164,6 +176,8 @@ typedef struct {
 	CELL counter;
 	/* UNTAGGED execution token: jump here to execute word */
 	XT xt;
+	/* UNTAGGED compiled code block */
+	F_COMPILED *code;
 } F_WORD;
 
 /* Assembly code makes assumptions about the layout of this struct */
@@ -195,9 +209,11 @@ typedef struct {
 	/* tagged */
 	CELL array;
 	/* tagged */
-	CELL compiled;
-	/* untagged */
+	CELL compiledp;
+	/* UNTAGGED */
 	XT xt;
+	/* UNTAGGED compiled code block */
+	F_COMPILED *code;
 } F_QUOTATION;
 
 /* Assembly code makes assumptions about the layout of this struct */
diff --git a/vm/master.h b/vm/master.h
index b50ac97f9d..178c8fc7ff 100644
--- a/vm/master.h
+++ b/vm/master.h
@@ -22,6 +22,7 @@
 #include "primitives.h"
 #include "debug.h"
 #include "run.h"
+#include "profiler.h"
 #include "errors.h"
 #include "bignumint.h"
 #include "bignum.h"
diff --git a/vm/profiler.c b/vm/profiler.c
new file mode 100644
index 0000000000..df62b4a3e5
--- /dev/null
+++ b/vm/profiler.c
@@ -0,0 +1,60 @@
+#include "master.h"
+
+bool profiling_p(void)
+{
+	return to_boolean(userenv[PROFILING_ENV]);
+}
+
+F_FIXNUM profiler_prologue(void)
+{
+	return to_fixnum(userenv[PROFILER_PROLOGUE_ENV]);
+}
+
+void profiling_word(F_WORD *word)
+{
+	/* If we just enabled the profiler, reset call count */
+	if(profiling_p())
+		word->counter = tag_fixnum(0);
+
+	if(word->compiledp == F)
+	{
+		if(type_of(word->def) == QUOTATION_TYPE)
+			word->xt = default_word_xt(word);
+	}
+	else
+		set_word_xt(word,word->code);
+}
+
+void set_profiling(bool profiling)
+{
+	if(profiling == profiling_p())
+		return;
+
+	userenv[PROFILING_ENV] = tag_boolean(profiling);
+
+	/* Push everything to tenured space so that we can heap scan */
+	data_gc();
+
+	/* Step 1 - Update word XTs and saved callstack objects */
+	begin_scan();
+
+	CELL obj;
+	while((obj = next_object()) != F)
+	{
+		if(type_of(obj) == WORD_TYPE)
+			profiling_word(untag_object(obj));
+	}
+
+	gc_off = false; /* end heap scan */
+
+	/* Step 2 - Update XTs in code heap */
+	iterate_code_heap(relocate_code_block);
+
+	/* Step 3 - flush instruction cache */
+	flush_icache(code_heap.segment->start,code_heap.segment->size);
+}
+
+DEFINE_PRIMITIVE(profiling)
+{
+	set_profiling(to_boolean(dpop()));
+}
diff --git a/vm/profiler.h b/vm/profiler.h
new file mode 100644
index 0000000000..2c5cdb5206
--- /dev/null
+++ b/vm/profiler.h
@@ -0,0 +1,3 @@
+bool profiling_p(void);
+F_FIXNUM profiler_prologue(void);
+DECLARE_PRIMITIVE(profiling);
diff --git a/vm/quotations.c b/vm/quotations.c
index ace8740d64..472ec76f1e 100644
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -37,6 +37,13 @@ bool jit_stack_frame_p(F_ARRAY *array)
 	return false;
 }
 
+void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code)
+{
+	quot->code = code;
+	quot->xt = (XT)(code + 1);
+	quot->compiledp = T;
+}
+
 void jit_compile(F_QUOTATION *quot)
 {
 	F_ARRAY *array = untag_object(quot->array);
@@ -148,12 +155,11 @@ void jit_compile(F_QUOTATION *quot)
 	F_ARRAY *literals = allot_array(ARRAY_TYPE,1,tag_object(quot));
 	UNREGISTER_UNTAGGED(result);
 
-	XT xt = add_compiled_block(QUOTATION_TYPE,result,NULL,NULL,NULL,literals);
-	iterate_code_heap_step(xt_to_compiled(xt),finalize_code_block);
+	F_COMPILED *compiled = add_compiled_block(QUOTATION_TYPE,result,NULL,NULL,NULL,literals);
+	iterate_code_heap_step(compiled,finalize_code_block);
 
 	UNREGISTER_UNTAGGED(quot);
-	quot->xt = xt;
-	quot->compiled = T;
+	set_quot_xt(quot,compiled);
 }
 
 F_FASTCALL CELL primitive_jit_compile(CELL tagged, F_STACK_FRAME *stack)
@@ -222,7 +228,7 @@ DEFINE_PRIMITIVE(array_to_quotation)
 	F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION));
 	quot->array = dpeek();
 	quot->xt = lazy_jit_compile;
-	quot->compiled = F;
+	quot->compiledp = F;
 	drepl(tag_object(quot));
 }
 
@@ -234,6 +240,7 @@ DEFINE_PRIMITIVE(quotation_xt)
 
 DEFINE_PRIMITIVE(strip_compiled_quotations)
 {
+	data_gc();
 	begin_scan();
 
 	CELL obj;
@@ -242,7 +249,7 @@ DEFINE_PRIMITIVE(strip_compiled_quotations)
 		if(type_of(obj) == QUOTATION_TYPE)
 		{
 			F_QUOTATION *quot = untag_object(obj);
-			quot->compiled = F;
+			quot->compiledp = F;
 			quot->xt = lazy_jit_compile;
 		}
 	}
diff --git a/vm/run.c b/vm/run.c
index e4201ddee5..802ff4e8cc 100644
--- a/vm/run.c
+++ b/vm/run.c
@@ -269,7 +269,7 @@ XT default_word_xt(F_WORD *word)
 		return dosym;
 	else if(type_of(word->def) == QUOTATION_TYPE)
 	{
-		if(profiling)
+		if(profiling_p())
 			return docol_profiling;
 		else
 			return docol;
@@ -364,36 +364,3 @@ DEFINE_PRIMITIVE(set_slot)
 	CELL value = dpop();
 	set_slot(obj,slot,value);
 }
-
-void enable_word_profiling(F_WORD *word)
-{
-	if(word->xt == docol)
-		word->xt = docol_profiling;
-}
-
-void disable_word_profiling(F_WORD *word)
-{
-	if(word->xt == docol_profiling)
-		word->xt = docol;
-}
-
-DEFINE_PRIMITIVE(profiling)
-{
-	profiling = to_boolean(dpop());
-
-	begin_scan();
-
-	CELL obj;
-	while((obj = next_object()) != F)
-	{
-		if(type_of(obj) == WORD_TYPE)
-		{
-			if(profiling)
-				enable_word_profiling(untag_object(obj));
-			else
-				disable_word_profiling(untag_object(obj));
-		}
-	}
-
-	gc_off = false; /* end heap scan */
-}
diff --git a/vm/run.h b/vm/run.h
index c959a7e007..d171e98bc0 100644
--- a/vm/run.h
+++ b/vm/run.h
@@ -1,6 +1,3 @@
-/* Is profiling on? */
-DLLEXPORT bool profiling;
-
 #define USER_ENV 40
 
 typedef enum {
@@ -52,6 +49,10 @@ typedef enum {
 	JIT_DISPATCH,
 	JIT_EPILOG,
 	JIT_RETURN,
+
+	/* Profiler support */    
+	PROFILING_ENV       = 38, /* is the profiler on? */
+	PROFILER_PROLOGUE_ENV     /* length of optimizing compiler's profiler prologue */
 } F_ENVTYPE;
 
 #define FIRST_SAVE_ENV BOOT_ENV
@@ -242,4 +243,3 @@ DECLARE_PRIMITIVE(tag);
 DECLARE_PRIMITIVE(class_hash);
 DECLARE_PRIMITIVE(slot);
 DECLARE_PRIMITIVE(set_slot);
-DECLARE_PRIMITIVE(profiling);

From 589ea40b58cbb65b8b0eac7ca4569949ec331804 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 28 Oct 2007 14:41:28 -0400
Subject: [PATCH 02/11] Add attributions to mach_signal files

---
 vm/mach_signal.c      |  2 +-
 vm/mach_signal.h      | 10 ++++++++++
 vm/os-macosx-ppc.h    | 26 ++++++++++++++++++--------
 vm/os-macosx-x86.32.h | 22 ++++++++++++++++------
 4 files changed, 45 insertions(+), 15 deletions(-)

diff --git a/vm/mach_signal.c b/vm/mach_signal.c
index d373037b82..118fc7044c 100644
--- a/vm/mach_signal.c
+++ b/vm/mach_signal.c
@@ -7,7 +7,7 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
 
 http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
 
-Extensively modified for Factor - portions copyright (C) 2004-2007 Slava Pestov */
+Modified for Factor by Slava Pestov */
 
 #include "master.h"
 
diff --git a/vm/mach_signal.h b/vm/mach_signal.h
index ca46a4c32c..863fd86dae 100644
--- a/vm/mach_signal.h
+++ b/vm/mach_signal.h
@@ -1,3 +1,13 @@
+/* Fault handler information.  MacOSX version.
+Copyright (C) 1993-1999, 2002-2003  Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003  Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
 #include <stdio.h>
 #include <stdlib.h>
 #include <errno.h>
diff --git a/vm/os-macosx-ppc.h b/vm/os-macosx-ppc.h
index f3a5de88c2..b6c2cc6859 100644
--- a/vm/os-macosx-ppc.h
+++ b/vm/os-macosx-ppc.h
@@ -1,3 +1,13 @@
+/* Fault handler information.  MacOSX version.
+Copyright (C) 1993-1999, 2002-2003  Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003  Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
 #define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2)
 
 #define MACH_EXC_STATE_TYPE ppc_exception_state_t
@@ -8,15 +18,15 @@
 #define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
 
 #if __DARWIN_UNIX03
-    #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar
-    #define MACH_STACK_POINTER(thr_state) (thr_state)->__r1
-    #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0
-    #define UAP_PROGRAM_COUNTER(ucontext) \
+	#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar
+	#define MACH_STACK_POINTER(thr_state) (thr_state)->__r1
+	#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0
+	#define UAP_PROGRAM_COUNTER(ucontext) \
 		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
 #else
-    #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar
-    #define MACH_STACK_POINTER(thr_state) (thr_state)->r1
-    #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0
-    #define UAP_PROGRAM_COUNTER(ucontext) \
+	#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar
+	#define MACH_STACK_POINTER(thr_state) (thr_state)->r1
+	#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0
+	#define UAP_PROGRAM_COUNTER(ucontext) \
 		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
 #endif
diff --git a/vm/os-macosx-x86.32.h b/vm/os-macosx-x86.32.h
index d335c4abd4..b77a0c7742 100644
--- a/vm/os-macosx-x86.32.h
+++ b/vm/os-macosx-x86.32.h
@@ -1,3 +1,13 @@
+/* Fault handler information.  MacOSX version.
+Copyright (C) 1993-1999, 2002-2003  Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003  Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
 #define MACH_EXC_STATE_TYPE i386_exception_state_t
 #define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
 #define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
@@ -6,15 +16,15 @@
 #define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
 
 #if __DARWIN_UNIX03
-    #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
-    #define MACH_STACK_POINTER(thr_state) (thr_state)->__esp
-    #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip
+	#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
+	#define MACH_STACK_POINTER(thr_state) (thr_state)->__esp
+	#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip
 	#define UAP_PROGRAM_COUNTER(ucontext) \
 		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
 #else
-    #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
-    #define MACH_STACK_POINTER(thr_state) (thr_state)->esp
-    #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip
+	#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
+	#define MACH_STACK_POINTER(thr_state) (thr_state)->esp
+	#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip
 	#define UAP_PROGRAM_COUNTER(ucontext) \
 		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))	
 #endif

From ed295cd8fe36f14f58e800bce029050e374d86d7 Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Sun, 28 Oct 2007 13:13:00 -0400
Subject: [PATCH 03/11] Free posix_argv after use

---
 vm/factor.c | 1 +
 1 file changed, 1 insertion(+)

diff --git a/vm/factor.c b/vm/factor.c
index 7b37648081..4dee712c0b 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -143,6 +143,7 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
 
 	for(i = 0; i < argc; i++)
 		free(posix_argv[i]);
+	free(posix_argv);
 }
 
 char *factor_eval_string(char *string)

From 2e78ce3d4a1e7e5f7aa57dffebe170af1ea9644b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 29 Oct 2007 01:12:27 -0400
Subject: [PATCH 04/11] Profiler fixes

---
 core/alien/compiler/compiler.factor           |  3 ++-
 core/bootstrap/compiler/compiler.factor       | 11 ++++----
 core/cpu/arm/architecture/architecture.factor |  2 +-
 core/cpu/ppc/architecture/architecture.factor | 10 ++++----
 core/cpu/x86/architecture/architecture.factor |  2 +-
 core/generator/fixup/fixup.factor             | 13 +++++-----
 core/generator/generator-docs.factor          |  6 ++---
 core/generator/generator.factor               | 25 +++++++++++--------
 core/math/math.factor                         |  2 --
 extra/tools/profiler/profiler-docs.factor     |  4 ---
 extra/tools/profiler/profiler.factor          |  3 ++-
 vm/code_gc.c                                  | 18 +++++++------
 vm/code_heap.c                                |  3 +++
 vm/code_heap.h                                |  2 ++
 vm/image.c                                    | 19 +++++++-------
 vm/image.h                                    |  7 +++---
 vm/quotations.h                               |  1 +
 17 files changed, 71 insertions(+), 60 deletions(-)

diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index a3fc5b5534..9728d4298a 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -383,10 +383,11 @@ TUPLE: callback-context ;
 
 : generate-callback ( node -- )
     dup alien-callback-xt dup rot [
+        init-templates
+        generate-profiler-prologue
         %save-xt
         %prologue-later
         dup alien-stack-frame [
-            init-templates
             dup registers>objects
             dup wrap-callback-quot %alien-callback
             %callback-return
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index eb65e7182b..17e03c768f 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -1,16 +1,17 @@
-USING: compiler vocabs.loader system sequences namespaces
-parser kernel kernel.private classes classes.private
+USING: compiler cpu.architecture vocabs.loader system sequences
+namespaces parser kernel kernel.private classes classes.private
 arrays hashtables vectors tuples sbufs inference.dataflow
 hashtables.private sequences.private math tuples.private
-growable namespaces.private alien.remote-control assocs
-words generator command-line vocabs io prettyprint libc ;
+growable namespaces.private alien.remote-control assocs words
+generator command-line vocabs io prettyprint libc ;
 
 "cpu." cpu append require
 
 global [ { "compiler" } add-use ] bind
 
 "-no-stack-traces" cli-args member? [
-    f compiled-stack-traces set-global
+    f compiled-stack-traces? set-global
+    0 set-profiler-prologues
 ] when
 
 ! Compile a set of words ahead of our general
diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor
index 5fdca75f98..07a4a073de 100755
--- a/core/cpu/arm/architecture/architecture.factor
+++ b/core/cpu/arm/architecture/architecture.factor
@@ -67,7 +67,7 @@ M: arm-backend stack-frame ( n -- i )
     factor-area-size + 8 align ;
 
 M: arm-backend %save-xt ( -- )
-    R12 PC 8 SUB ;
+    R12 PC 9 cells SUB ;
 
 M: arm-backend %prologue ( n -- )
     SP SP pick SUB
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index 714b41453b..9dd6c9c6c8 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -76,11 +76,8 @@ M: ppc-backend load-indirect ( obj reg -- )
     [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
     dup 0 LWZ ;
 
-: %load-xt ( word reg -- )
-    0 swap LOAD32  rc-absolute-ppc-2/2 rel-word ;
-
 M: ppc-backend %save-xt ( -- )
-    compiling-label get 11 %load-xt ;
+    0 11 LOAD32 rc-absolute-ppc-2/2 rel-current-word ;
 
 M: ppc-backend %prologue ( n -- )
     0 MFLR
@@ -114,7 +111,9 @@ M: ppc-backend %jump-label ( label -- ) B ;
 
 : %prepare-primitive ( word -- )
     #! Save stack pointer to stack_chain->callstack_top, load XT
-    4 1 MR 11 %load-xt ;
+    4 1 MR
+    0 11 LOAD32
+    rc-absolute-ppc-2/2 rel-word ;
 
 : (%call) 11 MTLR BLRL ;
 
@@ -135,6 +134,7 @@ M: ppc-backend %jump-t ( label -- )
         "offset" operand "n" operand 1 SRAWI
         0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch
         11 dup "offset" operand LWZX
+        11 dup compiled-header-size ADDI
         r> call
     ] H{
         { +input+ { { f "n" } } }
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index e35c4a3d52..0ff85d637b 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -45,7 +45,7 @@ M: x86-backend stack-frame ( n -- i )
     3 cells + 16 align cell - ;
 
 M: x86-backend %save-xt ( -- )
-    xt-reg compiling-label get MOV ;
+    xt-reg 0 MOV rc-absolute-cell rel-current-word ;
 
 : factor-area-size 4 cells ;
 
diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor
index b45f463bbe..8730258d6d 100644
--- a/core/generator/fixup/fixup.factor
+++ b/core/generator/fixup/fixup.factor
@@ -64,12 +64,13 @@ SYMBOL: label-table
     rot rc-absolute-ppc-2/2 = or or ;
 
 ! Relocation types
-: rt-primitive 0 ;
-: rt-dlsym     1 ;
-: rt-literal   2 ;
-: rt-dispatch  3 ;
-: rt-xt        4 ;
-: rt-label     5 ;
+: rt-primitive    0 ;
+: rt-dlsym        1 ;
+: rt-literal      2 ;
+: rt-dispatch     3 ;
+: rt-xt           4 ;
+: rt-xt-profiling 5 ;
+: rt-label        6 ;
 
 TUPLE: label-fixup label class ;
 
diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor
index 43089ca91a..a68454f001 100644
--- a/core/generator/generator-docs.factor
+++ b/core/generator/generator-docs.factor
@@ -6,7 +6,7 @@ ARTICLE: "generator" "Compiled code generator"
 "Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
 $nl
 "Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
-{ $subsection compiled-stack-traces }
+{ $subsection compiled-stack-traces? }
 "Assembler intrinsics can be defined for low-level optimization:"
 { $subsection define-intrinsic }
 { $subsection define-intrinsics }
@@ -41,11 +41,11 @@ HELP: compiling-word
 HELP: compiling-label
 { $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ;
 
-HELP: compiled-stack-traces
+HELP: compiled-stack-traces?
 { $var-description "If set to true, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This variable is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
 
 HELP: literal-table
-{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
+{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
 
 HELP: init-generator
 { $values { "word" word } }
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index 9e2cc23765..77f45dc70d 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -26,19 +26,16 @@ SYMBOL: compiling-label
 ! Label of current word, after prologue, makes recursion faster
 SYMBOL: current-label-start
 
-SYMBOL: compiled-stack-traces
+SYMBOL: compiled-stack-traces?
 
-t compiled-stack-traces set-global
+t compiled-stack-traces? set-global
 
 : init-generator ( -- )
     V{ } clone literal-table set
     V{ } clone word-table set
-    compiled-stack-traces get compiling-word get f ?
+    compiled-stack-traces? get compiling-word get f ?
     literal-table get push ;
 
-: profiler-prologue ( -- )
-    literal-table get first %profiler-prologue ;
-
 : generate-1 ( word label node quot -- )
     pick f save-xt [
         roll compiling-word set
@@ -49,6 +46,11 @@ t compiled-stack-traces set-global
         word-table get >array
     ] { } make fixup add-compiled-block save-xt ;
 
+: generate-profiler-prologue ( -- )
+    compiled-stack-traces? get [
+        compiling-word get %profiler-prologue
+    ] when ;
+
 GENERIC: generate-node ( node -- next )
 
 : generate-nodes ( node -- )
@@ -57,7 +59,7 @@ GENERIC: generate-node ( node -- next )
 : generate ( word label node -- )
     [
         init-templates
-        profiler-prologue
+        generate-profiler-prologue
         %save-xt
         %prologue-later
         current-label-start define-label
@@ -178,6 +180,10 @@ M: #if generate-node
     with-template
     generate-if ;
 
+: rel-current-word ( class -- )
+    compiling-label get add-word
+    swap rt-xt-profiling rel-fixup ;
+
 ! #dispatch
 : dispatch-branch ( node word -- label )
     gensym [
@@ -229,11 +235,9 @@ M: #dispatch generate-node
 
 : define-if>boolean-intrinsics ( word intrinsics -- )
     [
-        first2
         >r [ if>boolean-intrinsic ] curry r>
         { { f "if-scratch" } } +scratch+ associate union
-        2array
-    ] map "intrinsics" set-word-prop ;
+    ] assoc-map "intrinsics" set-word-prop ;
 
 : define-if-intrinsics ( word intrinsics -- )
     [ +input+ associate ] assoc-map
@@ -310,3 +314,4 @@ M: #return generate-node drop end-basic-block %return f ;
 : tuple-class-offset 2 cells tuple tag-number - ;
 : class-hash-offset cell object tag-number - ;
 : word-xt-offset 8 cells object tag-number - ;
+: compiled-header-size 8 cells ;
diff --git a/core/math/math.factor b/core/math/math.factor
index fea77855eb..54651f51d8 100755
--- a/core/math/math.factor
+++ b/core/math/math.factor
@@ -91,8 +91,6 @@ M: real hashcode* nip >fixnum ;
 M: real <=> - ;
 
 ! real and sequence overlap. we disambiguate:
-M: integer equal? number= ;
-
 M: integer hashcode* nip >fixnum ;
 
 M: integer <=> - ;
diff --git a/extra/tools/profiler/profiler-docs.factor b/extra/tools/profiler/profiler-docs.factor
index 0c06417c1c..feb6abbbb1 100644
--- a/extra/tools/profiler/profiler-docs.factor
+++ b/extra/tools/profiler/profiler-docs.factor
@@ -19,10 +19,6 @@ ARTICLE: "profiling" "Profiling code"
 
 ABOUT: "profiling"
 
-HELP: reset-counters
-{ $description "Reset the call count of all words in the dictionary." }
-{ $notes "This word is automatically called by the profiler when profiling begins." } ;
-
 HELP: counters
 { $values { "words" "a sequence of words" } { "assoc" "an association list mapping words to integers" } }
 { $description "Outputs an association list of word call counts." } ;
diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor
index 456c4876ec..4702431a8f 100755
--- a/extra/tools/profiler/profiler.factor
+++ b/extra/tools/profiler/profiler.factor
@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences math prettyprint kernel arrays io
 io.styles namespaces assocs kernel.private strings combinators
-sorting math.parser vocabs definitions tools.profiler.private ;
+sorting math.parser vocabs definitions tools.profiler.private
+continuations ;
 IN: tools.profiler
 
 : profile ( quot -- )
diff --git a/vm/code_gc.c b/vm/code_gc.c
index aa97203444..3d74ae0e4c 100644
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -386,10 +386,9 @@ CELL compute_heap_forwarding(F_HEAP *heap)
 	return address - heap->segment->start;
 }
 
-void forward_xt(XT *xt)
+F_COMPILED *forward_xt(F_COMPILED *compiled)
 {
-	/* F_BLOCK *block = xt_to_block(*xt);
-	*xt = block_to_xt(block->forwarding); */
+	return block_to_compiled(compiled_to_block(compiled)->forwarding);
 }
 
 void forward_object_xts(void)
@@ -405,14 +404,14 @@ void forward_object_xts(void)
 			F_WORD *word = untag_object(obj);
 
 			if(word->compiledp != F)
-				forward_xt(&word->xt);
+				set_word_xt(word,forward_xt(word->code));
 		}
 		else if(type_of(obj) == QUOTATION_TYPE)
 		{
 			F_QUOTATION *quot = untag_object(obj);
 
 			if(quot->compiledp != F)
-				forward_xt(&quot->xt);
+				set_quot_xt(quot,forward_xt(quot->code));
 		}
 	}
 
@@ -423,11 +422,14 @@ void forward_object_xts(void)
 void compaction_code_block_fixup(F_COMPILED *compiled, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
 {
-	XT *iter = (XT *)words_start;
-	XT *end = (XT *)words_end;
+	F_COMPILED **iter = (F_COMPILED **)words_start;
+	F_COMPILED **end = (F_COMPILED **)words_end;
 
 	while(iter < end)
-		forward_xt(iter++);
+	{
+		*iter = forward_xt(*iter);
+		iter++;
+	}
 }
 
 void forward_block_xts(void)
diff --git a/vm/code_heap.c b/vm/code_heap.c
index 6e6d024147..ccf2c99a38 100644
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -55,6 +55,9 @@ INLINE CELL compute_code_rel(F_REL *rel,
 	case RT_XT:
 		return get(CREF(words_start,REL_ARGUMENT(rel)))
 			+ sizeof(F_COMPILED) + xt_offset;
+	case RT_XT_PROFILING:
+		return get(CREF(words_start,REL_ARGUMENT(rel)))
+			+ sizeof(F_COMPILED);
 	case RT_LABEL:
 		return code_start + REL_ARGUMENT(rel);
 	default:
diff --git a/vm/code_heap.h b/vm/code_heap.h
index 4bc6803533..45312fca02 100644
--- a/vm/code_heap.h
+++ b/vm/code_heap.h
@@ -9,6 +9,8 @@ typedef enum {
 	RT_DISPATCH,
 	/* a compiled word reference */
 	RT_XT,
+	/* a compiled word reference, pointing at the profiling prologue */
+	RT_XT_PROFILING,
 	/* a local label */
 	RT_LABEL
 } F_RELTYPE;
diff --git a/vm/image.c b/vm/image.c
index bca8a36052..e1398eed81 100755
--- a/vm/image.c
+++ b/vm/image.c
@@ -144,8 +144,9 @@ DEFINE_PRIMITIVE(save_image_and_exit)
 		userenv[i] = F;
 
 	/* do a full GC + code heap compaction */
-	//compact_code_heap();
-	code_gc();
+	compact_code_heap();
+
+	/* Save the image */
 	save_image(unbox_native_string());
 
 	/* now exit; we cannot continue executing like this */
@@ -160,8 +161,8 @@ void fixup_word(F_WORD *word)
 		word->xt = default_word_xt(word);
 	else
 	{
-		code_fixup(&word->xt);
-		code_fixup(&word->code);
+		code_fixup((CELL)&word->xt);
+		code_fixup((CELL)&word->code);
 	}
 }
 
@@ -171,8 +172,8 @@ void fixup_quotation(F_QUOTATION *quot)
 		quot->xt = lazy_jit_compile;
 	else
 	{
-		code_fixup(&quot->xt);
-		code_fixup(&quot->code);
+		code_fixup((CELL)&quot->xt);
+		code_fixup((CELL)&quot->code);
 	}
 }
 
@@ -183,7 +184,7 @@ void fixup_alien(F_ALIEN *d)
 
 void fixup_stack_frame(F_STACK_FRAME *frame)
 {
-	code_fixup(&frame->xt);
+	code_fixup((CELL)&frame->xt);
 
 	if(frame_type(frame) == QUOTATION_TYPE)
 	{
@@ -192,7 +193,7 @@ void fixup_stack_frame(F_STACK_FRAME *frame)
 		frame->scan = scan + frame->array;
 	}
 
-	code_fixup(&FRAME_RETURN_ADDRESS(frame));
+	code_fixup((CELL)&FRAME_RETURN_ADDRESS(frame));
 }
 
 void fixup_callstack_object(F_CALLSTACK *stack)
@@ -264,7 +265,7 @@ void fixup_code_block(F_COMPILED *relocating, CELL code_start,
 	for(scan = words_start; scan < words_end; scan += CELLS)
 	{
 		if(relocating->finalized)
-			code_fixup((XT*)scan);
+			code_fixup(scan);
 		else
 			data_fixup((CELL*)scan);
 	}
diff --git a/vm/image.h b/vm/image.h
index 0fc2f03a3d..52b666254e 100755
--- a/vm/image.h
+++ b/vm/image.h
@@ -55,11 +55,10 @@ INLINE void data_fixup(CELL *cell)
 
 CELL code_relocation_base;
 
-INLINE void code_fixup(XT *cell)
+INLINE void code_fixup(CELL cell)
 {
-	CELL value = (CELL)*cell;
-	value += (code_heap.segment->start - code_relocation_base);
-	*cell = (XT)value;
+	CELL value = get(cell);
+	put(cell,value + (code_heap.segment->start - code_relocation_base));
 }
 
 void relocate_data();
diff --git a/vm/quotations.h b/vm/quotations.h
index d70d37ac44..e8da6093cd 100644
--- a/vm/quotations.h
+++ b/vm/quotations.h
@@ -1,3 +1,4 @@
+void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
 void jit_compile(F_QUOTATION *quot);
 F_FASTCALL CELL primitive_jit_compile(CELL tagged, F_STACK_FRAME *stack);
 XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset);

From 0586d7556cd354b46565d0beb53bc1835194b8de Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 29 Oct 2007 00:15:14 -0500
Subject: [PATCH 05/11] ARM intrinsics fixes

---
 core/cpu/arm/intrinsics/intrinsics.factor | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/core/cpu/arm/intrinsics/intrinsics.factor b/core/cpu/arm/intrinsics/intrinsics.factor
index 4b0a0bf591..9eedd8e494 100755
--- a/core/cpu/arm/intrinsics/intrinsics.factor
+++ b/core/cpu/arm/intrinsics/intrinsics.factor
@@ -55,10 +55,10 @@ IN: cpu.arm.intrinsics
 : %write-barrier ( -- )
     "val" get operand-immediate? "obj" get fresh-object? or [
         "cards_offset" f R12 %alien-global
-        "scratch" operand R12 "scratch" operand card-bits <LSR> ADD
-        "val" operand "scratch" operand 0 LDRB
+        "scratch" operand R12 "obj" operand card-bits <LSR> ADD
+        "val" operand "scratch" operand 0 <+> LDRB
         "val" operand dup card-mark ORR
-        "val" operand "scratch" operand 0 STRB
+        "val" operand "scratch" operand 0 <+> STRB
     ] unless ;
 
 \ set-slot {
@@ -315,12 +315,12 @@ IN: cpu.arm.intrinsics
     ! Store class
     "class" operand 2 %set-slot
     ! Zero out the rest of the tuple
-    R12 f v>operand MOV
-    "n" get 1- [ 1+ R12 %fill-array ] each
-    "out" get object %store-tagged
+    "initial" operand f v>operand MOV
+    "n" get 1- [ 1+ "initial" operand %fill-array ] each
+    "out" get tuple %store-tagged
 ] H{
     { +input+ { { f "class" } { [ inline-array? ] "n" } } }
-    { +scratch+ { { f "out" } } }
+    { +scratch+ { { f "out" } { f "initial" } } }
     { +output+ { "out" } }
 } define-intrinsic
 

From 976bfab6d714f977b16dec0bfc9adff9957c76b0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 29 Oct 2007 01:17:02 -0400
Subject: [PATCH 06/11] Planet update

---
 extra/webapps/planet/planet.factor | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index 17823d0c44..3f7fed6446 100644
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -64,7 +64,7 @@ TUPLE: posting author title date link body ;
 : print-posting ( posting -- )
     <h2 "posting-title" =class h2>
         <a dup posting-link =href a>
-            dup posting-title write
+            dup posting-title write-html
             " - " write
             dup posting-author write
         </a>
@@ -104,6 +104,9 @@ SYMBOL: cached-postings
     { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
     { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
     { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
+    { "Kio M. Smallwood"
+    "http://sekenre.wordpress.com/feed/atom/"
+    "http://sekenre.wordpress.com/" }
     { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
     { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
 } default-blogroll set-global

From c69f19bb6429ec5dc4e46383b966050a3afccad3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 29 Oct 2007 00:19:58 -0500
Subject: [PATCH 07/11] Remove obsolete file

---
 vm/os-windows-ce-arm.S | 19 -------------------
 1 file changed, 19 deletions(-)
 delete mode 100755 vm/os-windows-ce-arm.S

diff --git a/vm/os-windows-ce-arm.S b/vm/os-windows-ce-arm.S
deleted file mode 100755
index bde0c3d8ed..0000000000
--- a/vm/os-windows-ce-arm.S
+++ /dev/null
@@ -1,19 +0,0 @@
-	.text
-
-	.globl c_to_factor_toplevel
-
-	.word exception_handler
-	.word 0
-
-c_to_factor_toplevel:
-	ldr pc, _Pc_to_factor
-
-
-_Pc_to_factor:
-	.word c_to_factor
-
-	.section .pdata
-	.word c_to_factor_toplevel
-
-	.word 0xc0000002 | (0xFFFFF << 8)
-

From fa126b0b7248e9ee7176bae403f858cfbed26c81 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 29 Oct 2007 01:46:34 -0400
Subject: [PATCH 08/11] Makefile update

---
 Makefile                  | 3 ++-
 core/assocs/assocs.factor | 6 +++---
 2 files changed, 5 insertions(+), 4 deletions(-)

diff --git a/Makefile b/Makefile
index 378f96deae..a67f24f19d 100644
--- a/Makefile
+++ b/Makefile
@@ -38,7 +38,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/types.o \
 	vm/quotations.o \
 	vm/utilities.o \
-	vm/errors.o
+	vm/errors.o \
+	vm/profiler.o
 
 EXE_OBJS = $(PLAF_EXE_OBJS)
 
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 95b5dd9600..272a763b7b 100644
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -98,9 +98,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     2dup subassoc? >r swap subassoc? r> and ;
 
 : assoc-hashcode ( n assoc -- code )
-    swap [
-        tuck swap hashcode* >r swap hashcode* 2/ r> bitxor
-    ] curry { } assoc>map hashcode ;
+    [
+        >r over r> hashcode* 2/ >r dupd hashcode* r> bitxor
+    ] { } assoc>map hashcode* ;
 
 : intersect ( assoc1 assoc2 -- intersection )
     swap [ nip key? ] curry assoc-subset ;

From 77cbc5687392fe48e023eda429d3fe1958dd2a7b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 29 Oct 2007 01:17:44 -0500
Subject: [PATCH 09/11] Update x86.32 backend for profiler changes

---
 core/compiler/test/intrinsics.factor          | 12 +++-
 core/cpu/x86/32/32.factor                     | 61 ++++++++++---------
 core/cpu/x86/architecture/architecture.factor |  6 +-
 3 files changed, 47 insertions(+), 32 deletions(-)

diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor
index 2d738b96dd..a907c4c152 100755
--- a/core/compiler/test/intrinsics.factor
+++ b/core/compiler/test/intrinsics.factor
@@ -4,7 +4,7 @@ math.constants math.private sequences strings tools.test words
 continuations sequences.private hashtables.private byte-arrays
 strings.private system random layouts vectors.private
 sbufs.private strings.private slots.private alien alien.c-types
-alien.syntax namespaces libc ;
+alien.syntax namespaces libc combinators.private ;
 
 ! Make sure that intrinsic ops compile to correct code.
 [ ] [ 1 [ drop ] compile-1 ] unit-test
@@ -433,3 +433,13 @@ cell 8 = [
 [
     B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-1
 ] unit-test-fails
+
+[
+    4 5
+] [
+    3 [
+        [
+            { [ 4444 ] [ 444 ] [ 44 ] [ 4 ] } dispatch
+        ] keep 2 fixnum+fast
+    ] compile-1
+] unit-test
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index df41571e55..62ea28609b 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -8,20 +8,23 @@ alien.compiler combinators command-line
 compiler io vocabs.loader ;
 IN: cpu.x86.32
 
+PREDICATE: x86-backend x86-32-backend
+    x86-backend-cell 4 = ;
+
 ! We implement the FFI for Linux, OS X and Windows all at once.
 ! OS X requires that the stack be 16-byte aligned, and we do
 ! this on all platforms, sacrificing some stack space for
 ! code simplicity.
 
-M: x86-backend ds-reg ESI ;
-M: x86-backend rs-reg EDI ;
-M: x86-backend stack-reg ESP ;
-M: x86-backend xt-reg ECX ;
-M: x86-backend stack-save-reg EDX ;
+M: x86-32-backend ds-reg ESI ;
+M: x86-32-backend rs-reg EDI ;
+M: x86-32-backend stack-reg ESP ;
+M: x86-32-backend xt-reg ECX ;
+M: x86-32-backend stack-save-reg EDX ;
 
 M: temp-reg v>operand drop EBX ;
 
-M: x86-backend %alien-invoke ( symbol dll -- )
+M: x86-32-backend %alien-invoke ( symbol dll -- )
     (CALL) rel-dlsym ;
 
 ! On x86, parameters are never passed in registers.
@@ -58,20 +61,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
 
 ! On x86, we can always use an address as an operand
 ! directly.
-M: x86-backend address-operand ;
+M: x86-32-backend address-operand ;
 
-M: x86-backend fixnum>slot@ 1 SHR ;
+M: x86-32-backend fixnum>slot@ 1 SHR ;
 
-M: x86-backend prepare-division CDQ ;
+M: x86-32-backend prepare-division CDQ ;
 
-M: x86-backend load-indirect
+M: x86-32-backend load-indirect
     0 [] MOV rc-absolute-cell rel-literal ;
 
 M: object %load-param-reg 3drop ;
 
 M: object %save-param-reg 3drop ;
 
-M: x86-backend %prepare-unbox ( -- )
+M: x86-32-backend %prepare-unbox ( -- )
     #! Move top of data stack to EAX.
     EAX ESI [] MOV
     ESI 4 SUB ;
@@ -84,7 +87,7 @@ M: x86-backend %prepare-unbox ( -- )
         f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-backend %unbox ( n reg-class func -- )
+M: x86-32-backend %unbox ( n reg-class func -- )
     #! The value being unboxed must already be in EAX.
     #! If n is f, we're unboxing a return value about to be
     #! returned by the callback. Otherwise, we're unboxing
@@ -93,7 +96,7 @@ M: x86-backend %unbox ( n reg-class func -- )
     ! Store the return value on the C stack
     over [ store-return-reg ] [ 2drop ] if ;
 
-M: x86-backend %unbox-long-long ( n func -- )
+M: x86-32-backend %unbox-long-long ( n func -- )
     (%unbox)
     ! Store the return value on the C stack
     [
@@ -101,7 +104,7 @@ M: x86-backend %unbox-long-long ( n func -- )
         cell + stack@ EDX MOV
     ] when* ;
 
-M: x86-backend %unbox-struct-2
+M: x86-32-backend %unbox-struct-2
     #! Alien must be in EAX.
     4 [
         EAX PUSH
@@ -112,7 +115,7 @@ M: x86-backend %unbox-struct-2
         EAX EAX [] MOV
     ] with-aligned-stack ;
 
-M: x86-backend %unbox-large-struct ( n size -- )
+M: x86-32-backend %unbox-large-struct ( n size -- )
     #! Alien must be in EAX.
     ! Compute destination address
     ECX ESP roll [+] LEA
@@ -144,7 +147,7 @@ M: x86-backend %unbox-large-struct ( n size -- )
     over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
     push-return-reg ;
 
-M: x86-backend %box ( n reg-class func -- )
+M: x86-32-backend %box ( n reg-class func -- )
     over reg-size [
         >r (%box) r> f %alien-invoke
     ] with-aligned-stack ;
@@ -162,12 +165,12 @@ M: x86-backend %box ( n reg-class func -- )
     EDX PUSH
     EAX PUSH ;
 
-M: x86-backend %box-long-long ( n func -- )
+M: x86-32-backend %box-long-long ( n func -- )
     8 [
         >r (%box-long-long) r> f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-backend %box-large-struct ( n size -- )
+M: x86-32-backend %box-large-struct ( n size -- )
     ! Compute destination address
     [ swap struct-return@ ] keep
     ECX ESP roll [+] LEA
@@ -180,13 +183,13 @@ M: x86-backend %box-large-struct ( n size -- )
         "box_value_struct" f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-backend %prepare-box-struct ( size -- )
+M: x86-32-backend %prepare-box-struct ( size -- )
     ! Compute target address for value struct return
     EAX ESP rot f struct-return@ [+] LEA
     ! Store it as the first parameter
     ESP [] EAX MOV ;
 
-M: x86-backend %unbox-struct-1
+M: x86-32-backend %unbox-struct-1
     #! Alien must be in EAX.
     4 [
         EAX PUSH
@@ -195,7 +198,7 @@ M: x86-backend %unbox-struct-1
         EAX EAX [] MOV
     ] with-aligned-stack ;
 
-M: x86-backend %box-small-struct ( size -- )
+M: x86-32-backend %box-small-struct ( size -- )
     #! Box a <= 8-byte struct returned in EAX:DX. OS X only.
     12 [
         PUSH
@@ -204,21 +207,21 @@ M: x86-backend %box-small-struct ( size -- )
         "box_small_struct" f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-backend %prepare-alien-indirect ( -- )
+M: x86-32-backend %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
     cell temp@ EAX MOV ;
 
-M: x86-backend %alien-indirect ( -- )
+M: x86-32-backend %alien-indirect ( -- )
     cell temp@ CALL ;
 
-M: x86-backend %alien-callback ( quot -- )
+M: x86-32-backend %alien-callback ( quot -- )
     4 [
         EAX load-indirect
         EAX PUSH
         "c_to_factor" f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-backend %callback-value ( ctype -- )
+M: x86-32-backend %callback-value ( ctype -- )
     ! Align C stack
     ESP 12 SUB
     ! Save top of data stack
@@ -233,7 +236,7 @@ M: x86-backend %callback-value ( ctype -- )
     ! Unbox EAX
     unbox-return ;
 
-M: x86-backend %cleanup ( alien-node -- )
+M: x86-32-backend %cleanup ( alien-node -- )
     #! a) If we just called an stdcall function in Windows, it
     #! cleaned up the stack frame for us. But we don't want that
     #! so we 'undo' the cleanup since we do that in %epilogue.
@@ -251,7 +254,7 @@ M: x86-backend %cleanup ( alien-node -- )
         }
     } cond ;
 
-M: x86-backend %unwind ( n -- ) %epilogue-later RET ;
+M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ;
 
 windows? [
     cell "longlong" c-type set-c-type-align
@@ -272,6 +275,8 @@ T{ x86-backend f 4 } compiler-backend set-global
     JNE
 ] { } define-if-intrinsic
 
+10 set-profiler-prologues
+
 "-no-sse2" cli-args member? [
     "Checking if your CPU supports SSE2..." print flush
     [ sse2? ] compile-1 [
@@ -281,5 +286,3 @@ T{ x86-backend f 4 } compiler-backend set-global
         " - no" print
     ] if
 ] unless
-
-9 set-profiler-prologues
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 0ff85d637b..b85081fb6c 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -101,14 +101,16 @@ M: x86-backend %jump-t ( label -- )
     ! since on AMD64 we have to load a 64-bit immediate. On
     ! x86, this is redundant.
     "scratch" operand HEX: ffffffff MOV rc-absolute-cell rel-dispatch
-    "n" operand "scratch" operand ADD ;
+    "n" operand "n" operand "scratch" operand [+] MOV
+    "n" operand compiled-header-size ADD ;
 
 : dispatch-template ( word-table# quot -- )
     [
-        >r (%dispatch) "n" operand [] r> call
+        >r (%dispatch) "n" operand r> call
     ] H{
         { +input+ { { f "n" } } }
         { +scratch+ { { f "scratch" } } }
+        { +clobber+ { "n" } }
     } with-template ; inline
 
 M: x86-backend %call-dispatch ( word-table# -- )

From 2454135fd311f7a48ae8d003c78c4d01b0b0b739 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 29 Oct 2007 02:18:23 -0400
Subject: [PATCH 10/11] Fix stack overflow when taking hashcode of hashtables
 with circular structure

---
 core/hashtables/hashtables.factor | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor
index 0eec1d6293..004cc9fa90 100644
--- a/core/hashtables/hashtables.factor
+++ b/core/hashtables/hashtables.factor
@@ -168,8 +168,10 @@ M: hashtable equal?
     } cond ;
 
 M: hashtable hashcode*
-    dup assoc-size 1 number=
-    [ assoc-hashcode ] [ nip assoc-size ] if ;
+    [
+        dup assoc-size 1 number=
+        [ assoc-hashcode ] [ nip assoc-size ] if
+    ] recursive-hashcode ;
 
 ! Default method
 M: assoc new-assoc drop <hashtable> ;

From c014cf1aeb7775510d63764ff3a89312cfe87221 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 29 Oct 2007 02:23:16 -0400
Subject: [PATCH 11/11] Fix x86 stack alignment in Mach exception handler code

---
 vm/mach_signal.c      | 2 ++
 vm/os-macosx-ppc.h    | 5 +++++
 vm/os-macosx-x86.32.h | 5 +++++
 3 files changed, 12 insertions(+)

diff --git a/vm/mach_signal.c b/vm/mach_signal.c
index 118fc7044c..bfffa4cee0 100644
--- a/vm/mach_signal.c
+++ b/vm/mach_signal.c
@@ -37,6 +37,8 @@ static void call_fault_handler(exception_type_t exception,
 	else
 		signal_callstack_top = NULL;
 
+	MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state));
+
 	/* Now we point the program counter at the right handler function. */
 	if(exception == EXC_BAD_ACCESS)
 	{
diff --git a/vm/os-macosx-ppc.h b/vm/os-macosx-ppc.h
index b6c2cc6859..640aeb796d 100644
--- a/vm/os-macosx-ppc.h
+++ b/vm/os-macosx-ppc.h
@@ -30,3 +30,8 @@ Modified for Factor by Slava Pestov */
 	#define UAP_PROGRAM_COUNTER(ucontext) \
 		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
 #endif
+
+INLINE CELL fix_stack_pointer(CELL sp)
+{
+	return sp;
+}
diff --git a/vm/os-macosx-x86.32.h b/vm/os-macosx-x86.32.h
index b77a0c7742..d5e5827a5c 100644
--- a/vm/os-macosx-x86.32.h
+++ b/vm/os-macosx-x86.32.h
@@ -28,3 +28,8 @@ Modified for Factor by Slava Pestov */
 	#define UAP_PROGRAM_COUNTER(ucontext) \
 		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))	
 #endif
+
+INLINE CELL fix_stack_pointer(CELL sp)
+{
+	return ((sp + 4) & ~15) - 4;
+}