Merge branch 'master' of git://factorcode.org/git/factor

core/compiler/compiler.factor

@@ -57,7 +57,7 @@ compiled-crossref global [ H{ } assoc-like ] change-at
     ] computing-dependencies ;
 
 : compile-failed ( word error -- )
-    dup inference-error? [ rethrow ] unless
+    ! dup inference-error? [ rethrow ] unless
     f pick compiled get set-at
     swap compiler-error ;
 

core/compiler/errors/errors.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces assocs prettyprint io sequences
 sorting continuations debugger math ;
@@ -24,6 +24,8 @@ SYMBOL: with-compiler-errors?
 
 GENERIC: compiler-warning? ( error -- ? )
 
+M: object compiler-warning? drop f ;
+
 : (:errors) ( -- assoc )
     compiler-errors get-global
     [ nip compiler-warning? not ] assoc-subset ;

core/cpu/ppc/architecture/architecture.factor

@@ -3,7 +3,8 @@
 USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
 kernel kernel.private math memory namespaces sequences words
 assocs generator generator.registers generator.fixup system
-layouts classes words.private alien combinators ;
+layouts classes words.private alien combinators
+compiler.constants ;
 IN: cpu.ppc.architecture
 
 TUPLE: ppc-backend ;
@@ -37,7 +38,7 @@ TUPLE: ppc-backend ;
 : local@ ( n -- x )
     reserved-area-size param-save-size + + ; inline
 
-: factor-area-size 4 cells ;
+: factor-area-size 2 cells ;
 
 : next-save ( n -- i ) cell - ;
 
@@ -77,7 +78,7 @@ M: ppc-backend load-indirect ( obj reg -- )
     dup 0 LWZ ;
 
 M: ppc-backend %save-word-xt ( -- )
-    0 11 LOAD32 rc-absolute-ppc-2/2 rel-current-word ;
+    0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
 
 M: ppc-backend %prologue ( n -- )
     0 MFLR
@@ -99,35 +100,15 @@ M: ppc-backend %epilogue ( n -- )
 : %load-dlsym ( symbol dll register -- )
     0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
 
-M: ppc-backend %profiler-prologue ( word -- )
-    3 load-indirect
-    4 3 profile-count-offset LWZ
-    4 4 1 v>operand ADDI
-    4 3 profile-count-offset STW ;
-
 M: ppc-backend %call-label ( label -- ) BL ;
 
 M: ppc-backend %jump-label ( label -- ) B ;
 
-: %prepare-primitive ( word -- )
-    #! Save stack pointer to stack_chain->callstack_top, load XT
-    4 1 MR
-    0 11 LOAD32
-    rc-absolute-ppc-2/2 rel-word ;
-
-: (%call) 11 MTLR BLRL ;
-
-M: ppc-backend %call-primitive ( word -- )
-    %prepare-primitive (%call) ;
-
-: (%jump) 11 MTCTR BCTR ;
-
-M: ppc-backend %jump-primitive ( word -- )
-    %prepare-primitive (%jump) ;
-
 M: ppc-backend %jump-t ( label -- )
     0 "flag" operand f v>operand CMPI BNE ;
 
+: (%call) 11 MTLR BLRL ;
+
 : dispatch-template ( word-table# quot -- )
     [
         >r
@@ -145,7 +126,7 @@ M: ppc-backend %call-dispatch ( word-table# -- )
     [ (%call) ] dispatch-template ;
 
 M: ppc-backend %jump-dispatch ( word-table# -- )
-    [ %epilogue-later (%jump) ] dispatch-template ;
+    [ %epilogue-later 11 MTCTR BCTR ] dispatch-template ;
 
 M: ppc-backend %return ( -- ) %epilogue-later BLR ;
 

core/cpu/ppc/bootstrap.factor

@@ -29,7 +29,7 @@ big-endian on
     temp-reg dup 0 LWZ
     ! Bump profiling counter
     aux-reg temp-reg profile-count-offset LWZ
-    aux-reg dup 1 tag-fixnum ADD
+    aux-reg dup 1 tag-fixnum ADDI
     aux-reg temp-reg profile-count-offset STW
     ! Load word->code
     aux-reg temp-reg word-code-offset LWZ

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -8,7 +8,7 @@ generator generator.registers generator.fixup sequences.private
 sbufs vectors system layouts math.floats.private
 classes tuples tuples.private sbufs.private vectors.private
 strings.private slots.private combinators bit-arrays
-float-arrays ;
+float-arrays compiler.constants ;
 IN: cpu.ppc.intrinsics
 
 : %slot-literal-known-tag

core/cpu/ppc/ppc.factor

@@ -13,5 +13,3 @@ namespaces alien.c-types kernel system combinators ;
 } cond
 
 T{ ppc-backend } compiler-backend set-global
-
-6 cells profiler-prologue set-global

core/io/streams/c/c.factor

@@ -61,7 +61,7 @@ M: object init-io ;
 : stdout 12 getenv ;
 
 M: object init-stdio
-    stdin stdout <duplex-c-stream> stdio set ;
+    stdin stdout <duplex-c-stream> stdio set-global ;
 
 M: object io-multiplex (sleep) ;
 

core/vocabs/vocabs-docs.factor

@@ -42,7 +42,7 @@ HELP: vocabs
 { $description "Outputs a sequence of all defined vocabulary names." } ;
 
 HELP: vocab
-{ $values { "name" string } { "vocab" vocab } }
+{ $values { "vocab-spec" "a vocabulary specifier" } { "vocab" vocab } }
 { $description "Outputs a named vocabulary, or " { $link f } " if no vocabulary with this name exists." }
 { $class-description "Instances represent vocabularies." } ;
 

extra/bootstrap/ui/tools/tools.factor

@@ -8,5 +8,3 @@ USING: kernel vocabs vocabs.loader sequences system ;
         "ui.cocoa.tools" require
     ] when
 ] when
-
-macosx? [ "ui.tools.deploy" require ] when

extra/cocoa/application/application-docs.factor

@@ -1,5 +1,18 @@
-USING: cocoa.application debugger quotations help.markup
+USING: debugger quotations help.markup help.syntax strings alien
-help.syntax strings alien core-foundation ;
+core-foundation ;
+IN: cocoa.application
+
+HELP: <NSString>
+{ $values { "str" string } { "alien" alien } }
+{ $description "Allocates an autoreleased " { $snippet "CFString" } "." } ;
+
+{ <NSString> <CFString> CF>string } related-words
+
+HELP: <NSArray>
+{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" alien } }
+{ $description "Allocates an autoreleased " { $snippet "CFArray" } "." } ;
+
+{ <NSArray> <CFArray> } related-words
 
 HELP: with-autorelease-pool
 { $values { "quot" quotation } }

extra/cocoa/application/application.factor

@@ -5,6 +5,10 @@ cocoa cocoa.classes cocoa.runtime sequences threads debugger
 init inspector kernel.private ;
 IN: cocoa.application
 
+: <NSString> ( str -- alien ) <CFString> -> autorelease ;
+
+: <NSArray> ( seq -- alien ) <CFArray> -> autorelease ;
+
 : NSApplicationDelegateReplySuccess 0 ;
 : NSApplicationDelegateReplyCancel  1 ;
 : NSApplicationDelegateReplyFailure 2 ;

extra/cocoa/cocoa-docs.factor

@@ -1,5 +1,6 @@
-USING: cocoa cocoa.messages help.markup help.syntax strings
+USING: cocoa.messages help.markup help.syntax strings
 alien core-foundation ;
+IN: cocoa
 
 HELP: ->
 { $syntax "-> selector" }
@@ -15,18 +16,6 @@ HELP: SUPER->
 
 { send super-send POSTPONE: -> POSTPONE: SUPER-> } related-words
 
-HELP: <NSString>
-{ $values { "str" string } { "alien" alien } }
-{ $description "Allocates an autoreleased " { $snippet "CFString" } "." } ;
-
-{ <NSString> <CFString> CF>string } related-words
-
-HELP: <NSArray>
-{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" alien } }
-{ $description "Allocates an autoreleased " { $snippet "CFArray" } "." } ;
-
-{ <NSArray> <CFArray> } related-words
-
 ARTICLE: "objc-calling" "Calling Objective C code"
 "Before an Objective C class can be used, it must be imported; by default, a small set of common classes are imported automatically, but additional classes can be imported as needed."
 { $subsection import-objc-class }

extra/cocoa/cocoa-tests.factor

@@ -12,8 +12,6 @@ CLASS: {
     [ data-gc "x" set 2drop ]
 } ;
 
-recompile
-
 : test-foo
     Foo -> alloc -> init
     dup 1.0 2.0 101.0 102.0 <NSRect> -> foo:
@@ -36,13 +34,11 @@ CLASS: {
     [ 2drop test-foo "x" get ]
 } ;
 
-recompile
-
 Bar [
     -> alloc -> init
     dup -> bar "x" set
     -> release
-] compile-1
+] compile-call
 
 [ 1 ] [ "x" get NSRect-x ] unit-test
 [ 2 ] [ "x" get NSRect-y ] unit-test

extra/cocoa/cocoa.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler io kernel cocoa.runtime cocoa.subclassing
 cocoa.messages cocoa.types sequences words vocabs parser
-core-foundation namespaces assocs hashtables ;
+core-foundation namespaces assocs hashtables definitions ;
 IN: cocoa
 
 : (remember-send) ( selector variable -- )
@@ -32,37 +32,36 @@ SYMBOL: super-sent-messages
 
 {
     "cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
-} [ words ] map concat compile-batch
+} [ words ] map concat compile
 
 "Importing Cocoa classes..." print
-{
-    "NSApplication"
-    "NSArray"
-    "NSAutoreleasePool"
-    "NSBundle"
-    "NSError"
-    "NSEvent"
-    "NSException"
-    "NSMenu"
-    "NSMenuItem"
-    "NSNib"
-    "NSNotification"
-    "NSNotificationCenter"
-    "NSObject"
-    "NSOpenGLContext"
-    "NSOpenGLPixelFormat"
-    "NSOpenGLView"
-    "NSOpenPanel"
-    "NSPasteboard"
-    "NSResponder"
-    "NSSavePanel"
-    "NSView"
-    "NSWindow"
-    "NSWorkspace"
-} [
-    [ ] import-objc-class
-] each
 
-: <NSString> ( str -- alien ) <CFString> -> autorelease ;
+[
-
+    {
-: <NSArray> ( seq -- alien ) <CFArray> -> autorelease ;
+        "NSApplication"
+        "NSArray"
+        "NSAutoreleasePool"
+        "NSBundle"
+        "NSError"
+        "NSEvent"
+        "NSException"
+        "NSMenu"
+        "NSMenuItem"
+        "NSNib"
+        "NSNotification"
+        "NSNotificationCenter"
+        "NSObject"
+        "NSOpenGLContext"
+        "NSOpenGLPixelFormat"
+        "NSOpenGLView"
+        "NSOpenPanel"
+        "NSPasteboard"
+        "NSResponder"
+        "NSSavePanel"
+        "NSView"
+        "NSWindow"
+        "NSWorkspace"
+    } [
+        [ ] import-objc-class
+    ] each
+] with-compilation-unit

extra/cocoa/dialogs/dialogs-docs.factor

@@ -1,4 +1,5 @@
-USING: cocoa.dialogs help.markup help.syntax ;
+USING: help.markup help.syntax ;
+IN: cocoa.dialogs
 
 HELP: <NSOpenPanel>
 { $values { "panel" "an " { $snippet "NSOpenPanel" } } }

extra/cocoa/messages/messages-docs.factor

@@ -1,4 +1,5 @@
-USING: cocoa.messages help.markup help.syntax strings alien ;
+USING: help.markup help.syntax strings alien ;
+IN: cocoa.messages
 
 HELP: send
 { $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }

extra/cocoa/messages/messages.factor

@@ -16,7 +16,7 @@ IN: cocoa.messages
 : sender-stub ( method function -- word )
     [ sender-stub-name f <word> dup ] 2keep
     over first large-struct? [ "_stret" append ] when
-    make-sender define-compound dup compile ;
+    make-sender define ;
 
 SYMBOL: message-senders
 SYMBOL: super-message-senders
@@ -196,7 +196,7 @@ H{
 : define-objc-class-word ( name quot -- )
     [
         over , , \ unless-defined , dup , \ objc-class ,
-    ] [ ] make >r "cocoa.classes" create r> define-compound ;
+    ] [ ] make >r "cocoa.classes" create r> define ;
 
 : import-objc-class ( name quot -- )
     2dup unless-defined

extra/cocoa/nibs/nibs-docs.factor

@@ -1,4 +1,5 @@
-USING: help.markup help.syntax cocoa.nibs strings ;
+USING: help.markup help.syntax strings ;
+IN: cocoa.nibs
 
 HELP: load-nib
 { $values { "name" string } }

extra/cocoa/pasteboard/pasteboard-docs.factor

@@ -1,4 +1,5 @@
-USING: cocoa.pasteboard help.markup help.syntax strings ;
+USING: help.markup help.syntax strings ;
+IN: cocoa.pasteboard
 
 HELP: pasteboard-string?
 { $values { "pasteboard" "an " { $snippet "NSPasteBoard" } } { "?" "a boolean" } }

extra/cocoa/subclassing/subclassing-docs.factor

@@ -1,5 +1,5 @@
-USING: cocoa.subclassing help.markup help.syntax strings alien
+USING: help.markup help.syntax strings alien hashtables ;
-hashtables ;
+IN: cocoa.subclassing
 
 HELP: define-objc-class
 { $values { "hash" hashtable } { "imeth" "a sequence of instance method definitions" } }

extra/cocoa/subclassing/subclassing.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays assocs combinators compiler
 hashtables kernel libc math namespaces parser sequences words
-cocoa.messages cocoa.runtime ;
+cocoa.messages cocoa.runtime definitions ;
 IN: cocoa.subclassing
 
 : init-method ( method alien -- )
@@ -86,7 +86,9 @@ IN: cocoa.subclassing
     ] [ ] make define-temp ;
 
 : prepare-methods ( methods -- methods )
-    [ first4 prepare-method 3array ] map ;
+    [
+        [ first4 prepare-method 3array ] map
+    ] with-compilation-unit ;
 
 : redefine-objc-methods ( imeth name -- )
     dup class-exists? [
@@ -102,16 +104,13 @@ SYMBOL: +superclass+
 : define-objc-class ( imeth hash -- )
     clone [
         prepare-methods
+        +name+ get "cocoa.classes" create drop
         +name+ get 2dup redefine-objc-methods swap [
             +protocols+ get , +superclass+ get , +name+ get , ,
             \ (define-objc-class) ,
         ] [ ] make import-objc-class
     ] bind ;
 
-: define-objc-class-early ( hash -- )
-    +name+ swap at "cocoa.classes" create drop ;
-
 : CLASS:
-    parse-definition unclip >r parsed r>
+    parse-definition unclip
-    >hashtable dup define-objc-class-early parsed
+    >hashtable define-objc-class ; parsing
-    \ define-objc-class parsed ; parsing

extra/cocoa/types/types-docs.factor

@@ -1,4 +1,5 @@
-USING: cocoa.types math help.markup help.syntax ;
+USING: math help.markup help.syntax ;
+IN: cocoa.types
 
 HELP: <NSRect>
 { $values { "x" real } { "y" real } { "w" real } { "h" real } { "rect" "an " { $snippet "NSRect" } } }

extra/cocoa/views/views-docs.factor

@@ -1,4 +1,5 @@
-USING: cocoa.views help.syntax help.markup ;
+USING: help.syntax help.markup ;
+IN: cocoa.views
 
 HELP: <PixelFormat>
 { $values { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }

extra/cocoa/windows/windows-docs.factor

@@ -1,4 +1,5 @@
-USING: cocoa.windows help.markup help.syntax ;
+USING: help.markup help.syntax ;
+IN: cocoa.windows
 
 HELP: <NSWindow>
 { $values { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } }

extra/core-foundation/core-foundation-docs.factor

@@ -1,5 +1,5 @@
-USING: core-foundation alien strings arrays help.markup
+USING: alien strings arrays help.markup help.syntax ;
-help.syntax ;
+IN: core-foundation
 
 HELP: CF>array
 { $values { "alien" "a " { $snippet "CFArray" } } { "array" "an array of " { $link alien } " instances" } }

extra/io/unix/backend/backend.factor

@@ -187,4 +187,4 @@ M: unix-io init-io ( -- )
     ] bind ;
 
 M: unix-io init-stdio ( -- )
-    0 1 handle>duplex-stream stdio set ;
+    0 1 handle>duplex-stream stdio set-global ;

extra/io/windows/ce/backend/backend.factor

@@ -42,4 +42,4 @@ M: windows-ce-io init-stdio ( -- )
             0 _getstdfilex _fileno
             1 _getstdfilex _fileno
         ] if <win32-duplex-stream>
-    ] with-variable stdio set ;
+    ] with-variable stdio set-global ;

extra/memoize/memoize-tests.factor

@@ -7,4 +7,4 @@ MEMO: fib ( m -- n )
 
 [ 89 ] [ 10 fib ] unit-test
 
-[ "USE: memoize MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" parse ] unit-test-fails
+[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] unit-test-fails

extra/new-slots/new-slots.factor

@@ -1,33 +1,51 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: effects words kernel sequences slots slots.private
-assocs parser mirrors ;
+assocs parser mirrors namespaces math vocabs ;
 IN: new-slots
 
-: reader-effect T{ effect f 1 1 } ; inline
-
-: writer-effect T{ effect f 2 0 } ; inline
-
 : create-accessor ( name effect -- word )
     >r "accessors" create dup r>
     "declared-effect" set-word-prop ;
 
+: reader-effect T{ effect f { "object" } { "value" } } ; inline
+
 : reader-word ( name -- word )
     ">>" append reader-effect create-accessor ;
 
-: writer-word ( name -- word )
-    ">>" swap append writer-effect create-accessor ;
-
 : define-reader ( class slot name -- )
     reader-word [ slot ] define-slot-word ;
 
+: writer-effect T{ effect f { "value" "object" } { } } ; inline
+
+: writer-word ( name -- word )
+    ">>" swap append writer-effect create-accessor ;
+
 : define-writer ( class slot name -- )
     writer-word [ set-slot ] define-slot-word ;
 
+: changer-effect T{ effect f { "object" "quot" } } ; inline
+
+: changer-word ( name -- word )
+    "change-" swap append changer-effect create-accessor ;
+
+: define-changer ( name -- )
+    dup changer-word dup deferred? [
+        [
+            [ over >r >r ] %
+            over reader-word ,
+            [ r> call r> ] %
+            swap writer-word ,
+        ] [ ] make define
+    ] [ 2drop ] if ;
+
+: define-new-slot ( class slot name -- )
+    dup define-changer 3dup define-reader define-writer ;
+
 : define-new-slots ( tuple-class -- )
     [ "slot-names" word-prop <enum> >alist ] keep
-    [
+    [ swap first2 >r 4 + r> define-new-slot ] curry each ;
-        swap first2 >r 2 + r> 3dup define-reader define-writer
-    ] curry each ;
 
 : NEW-SLOTS: scan-word define-new-slots ; parsing
+
+"accessors" create-vocab drop

extra/parser-combinators/parser-combinators-docs.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax parser-combinators ;
+USING: help.markup help.syntax ;
+IN: parser-combinators
 
 HELP: list-of
 { $values

extra/tools/profiler/profiler-docs.factor

@@ -3,13 +3,13 @@ quotations io strings words definitions ;
 IN: tools.profiler
 
 ARTICLE: "profiling" "Profiling code" 
-"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler. The profiler has three main limitations:"
+"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler. The profiler is completely accurate with words which are compiled with the non-optimizing compiler. Some optimizations performed by the optimizing compiler can inhibit accurate call counting, however:"
 { $list
-    "Calls to primitives are not counted."
+    "The optimizing compiler open-codes certain primitives with inline machine code, and in some cases optimizes them out altogether; this includes stack shuffling operations, conditionals, and many object allocation operations."
-    { "Calls to " { $link POSTPONE: inline } " words from words compiled with the optimizing compiler are not counted." }
+    { "Calls to " { $link POSTPONE: inline } " words 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."
+    "Tail-recursive loops will only count the initial invocation of the word, not every tail call."
 }
-"Quotations can be passed to a combinator which calls them with word call counting enabled:"
+"Quotations can be passed to a combinator which calls them with the profiler enabled:"
 { $subsection profile }
 "After a quotation has been profiled, call counts can be presented in various ways:"
 { $subsection profile. }

extra/webapps/pastebin/pastebin.factor

@@ -57,8 +57,11 @@ C: <annotation> annotation
 : paste-link ( paste -- link )
     paste-n number>string [ show-paste ] curry quot-link ;
 
+: safe-head ( seq n -- seq' )
+    over length min head ;
+
 : paste-feed ( -- entries )
-    get-pastebin pastebin-pastes <reversed> [
+    get-pastebin pastebin-pastes <reversed> 20 safe-head [
         {
             paste-summary
             paste-link

vm/callstack.c

@@ -216,8 +216,7 @@ DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
 	REGISTER_UNTAGGED(callstack);
 	REGISTER_UNTAGGED(quot);
 
-	if(quot->compiledp == F)
+	jit_compile(tag_object(quot),true);
-		jit_compile(tag_object(quot));
 
 	UNREGISTER_UNTAGGED(quot);
 	UNREGISTER_UNTAGGED(callstack);

vm/code_heap.c

@@ -303,10 +303,10 @@ void set_word_code(F_WORD *word, F_COMPILED *compiled)
 }
 
 /* Allocates memory */
-void default_word_code(F_WORD *word)
+void default_word_code(F_WORD *word, bool relocate)
 {
 	REGISTER_UNTAGGED(word);
-	jit_compile(word->def);
+	jit_compile(word->def,relocate);
 	UNREGISTER_UNTAGGED(word);
 
 	word->code = untag_quotation(word->def)->code;
@@ -336,7 +336,7 @@ DEFINE_PRIMITIVE(modify_code_heap)
 		{
 			REGISTER_UNTAGGED(alist);
 			REGISTER_UNTAGGED(word);
-			default_word_code(word);
+			default_word_code(word,false);
 			UNREGISTER_UNTAGGED(word);
 			UNREGISTER_UNTAGGED(alist);
 		}

vm/code_heap.h

@@ -56,7 +56,7 @@ typedef struct {
 void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end);
 
-void default_word_code(F_WORD *word);
+void default_word_code(F_WORD *word, bool relocate);
 
 void set_word_code(F_WORD *word, F_COMPILED *compiled);
 

vm/factor.c

@@ -44,7 +44,7 @@ void do_stage1_init(void)
 		if(type_of(obj) == WORD_TYPE)
 		{
 			F_WORD *word = untag_object(obj);
-			default_word_code(word);
+			default_word_code(word,false);
 			update_word_xt(word);
 		}
 	}

vm/profiler.c

@@ -13,7 +13,7 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
 
 	CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2))
 		| (to_fixnum(array_nth(quadruple,1)) << 8));
-	CELL rel_offset = array_nth(quadruple,3);
+	CELL rel_offset = array_nth(quadruple,3) * compiled_code_format();
 
 	CELL relocation = allot_array_2(rel_type,rel_offset);
 

vm/quotations.c

@@ -52,7 +52,7 @@ F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length,
 		rel.type = to_fixnum(rel_type)
 			| (to_fixnum(rel_class) << 8)
 			| (rel_argument << 16);
-		rel.offset = code_length * code_format + to_fixnum(offset);
+		rel.offset = (code_length + to_fixnum(offset)) * code_format;
 	}
 
 	return rel;
@@ -95,7 +95,7 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code)
 }
 
 /* Might GC */
-void jit_compile(CELL quot)
+void jit_compile(CELL quot, bool relocate)
 {
 	if(untag_quotation(quot)->compiledp != F)
 		return;
@@ -230,11 +230,10 @@ void jit_compile(CELL quot)
 		untag_object(words),
 		untag_object(literals));
 
-	/* We must do this before relocate_code_block(), so that
-	relocation knows the quotation's XT. */
 	set_quot_xt(untag_object(quot),compiled);
 
-	iterate_code_heap_step(compiled,relocate_code_block);
+	if(relocate)
+		iterate_code_heap_step(compiled,relocate_code_block);
 
 	UNREGISTER_ROOT(words);
 	UNREGISTER_ROOT(literals);
@@ -352,7 +351,7 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
 {
 	stack_chain->callstack_top = stack;
 	REGISTER_ROOT(quot);
-	jit_compile(quot);
+	jit_compile(quot,true);
 	UNREGISTER_ROOT(quot);
 	return quot;
 }

vm/quotations.h

@@ -1,5 +1,5 @@
 void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
-void jit_compile(CELL quot);
+void jit_compile(CELL quot, bool relocate);
 F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
 F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
 void uncurry(CELL obj);

vm/types.c

@@ -511,7 +511,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
 	word->profiling = NULL;
 
 	REGISTER_UNTAGGED(word);
-	default_word_code(word);
+	default_word_code(word,true);
 	UNREGISTER_UNTAGGED(word);
 
 	REGISTER_UNTAGGED(word);