Redo the profiler

core/alien/c-types/c-types.factor

@@ -194,7 +194,7 @@ M: long-long-type box-return ( type -- )
     >r ">c-" swap "-array" 3append r> create ;
 
 : define-to-array ( type vocab -- )
-    [ to-array-word ] 2keep >c-array-quot define-compound ;
+    [ to-array-word ] 2keep >c-array-quot define ;
 
 : c-array>quot ( type vocab -- quot )
     [
@@ -207,7 +207,7 @@ M: long-long-type box-return ( type -- )
     >r "c-" swap "-array>" 3append r> create ;
 
 : define-from-array ( type vocab -- )
-    [ from-array-word ] 2keep c-array>quot define-compound ;
+    [ from-array-word ] 2keep c-array>quot define ;
 
 : <primitive-type> ( getter setter width boxer unboxer -- type )
     <c-type>

core/alien/compiler/compiler.factor

@@ -394,7 +394,6 @@ TUPLE: callback-context ;
             dup wrap-callback-quot %alien-callback
             %callback-return
         ] with-stack-frame
-        0
     ] generate-1 ;
 
 M: alien-callback generate-node

core/alien/syntax/syntax-docs.factor

@@ -69,7 +69,7 @@ HELP: C-UNION:
 HELP: C-ENUM:
 { $syntax "C-ENUM: words... ;" }
 { $values { "words" "a sequence of word names" } }
-{ $description "Creates a sequence of compound definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." }
+{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." }
 { $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use symbolic constants instead." }
 { $examples
     "The following two lines are equivalent:"

core/alien/syntax/syntax.factor

@@ -49,7 +49,7 @@ PRIVATE>
 : C-ENUM:
     ";" parse-tokens
     dup length
-    [ >r create-in r> 1quotation define-compound ] 2each ;
+    [ >r create-in r> 1quotation define ] 2each ;
     parsing
 
 M: alien pprint*

core/bootstrap/compiler/compiler.factor

@@ -12,7 +12,6 @@ IN: bootstrap.compiler
 
 "-no-stack-traces" cli-args member? [
     f compiled-stack-traces? set-global
-    0 profiler-prologue set-global
 ] when
 
 nl

core/bootstrap/image/image.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien arrays bit-arrays byte-arrays generic assocs
 hashtables assocs hashtables.private io kernel kernel.private
@@ -62,8 +62,8 @@ SYMBOL: bootstrap-boot-quot
 ! JIT parameters
 SYMBOL: jit-code-format
 SYMBOL: jit-prolog
-SYMBOL: jit-word-primitive-jump
+SYMBOL: jit-primitive-word
-SYMBOL: jit-word-primitive-call
+SYMBOL: jit-primitive
 SYMBOL: jit-word-jump
 SYMBOL: jit-word-call
 SYMBOL: jit-push-literal
@@ -73,6 +73,7 @@ SYMBOL: jit-dispatch-word
 SYMBOL: jit-dispatch
 SYMBOL: jit-epilog
 SYMBOL: jit-return
+SYMBOL: jit-profiling
 
 ! Default definition for undefined words
 SYMBOL: undefined-quot
@@ -83,8 +84,8 @@ SYMBOL: undefined-quot
         { bootstrap-global 21 }
         { jit-code-format 22 }
         { jit-prolog 23 }
-        { jit-word-primitive-jump 24 }
+        { jit-primitive-word 24 }
-        { jit-word-primitive-call 25 }
+        { jit-primitive 25 }
         { jit-word-jump 26 }
         { jit-word-call 27 }
         { jit-push-literal 28 }
@@ -94,6 +95,7 @@ SYMBOL: undefined-quot
         { jit-dispatch 32 }
         { jit-epilog 33 }
         { jit-return 34 }
+        { jit-profiling 35 }
         { undefined-quot 37 }
     } at header-size + ;
 
@@ -121,10 +123,10 @@ SYMBOL: undefined-quot
 : align-here ( -- )
     here 8 mod 4 = [ 0 emit ] when ;
 
-: emit-fixnum ( n -- ) tag-bits get shift emit ;
+: emit-fixnum ( n -- ) tag-fixnum emit ;
 
 : emit-object ( header tag quot -- addr )
-    swap here-as >r swap tag-header emit call align-here r> ;
+    swap here-as >r swap tag-fixnum emit call align-here r> ;
     inline
 
 ! Write an object to the image.
@@ -174,7 +176,7 @@ M: fixnum '
     #! When generating a 32-bit image on a 64-bit system,
     #! some fixnums should be bignums.
     dup most-negative-fixnum most-positive-fixnum between?
-    [ tag-bits get shift ] [ >bignum ' ] if ;
+    [ tag-fixnum ] [ >bignum ' ] if ;
 
 ! Floats
 
@@ -214,6 +216,7 @@ M: f '
         0 , ! count
         0 , ! xt
         0 , ! code
+        0 , ! profiling
     ] { } make
     \ word type-number object tag-number
     [ emit-seq ] emit-object
@@ -368,12 +371,13 @@ M: curry '
 : emit-jit-data ( -- )
     \ if jit-if-word set
     \ dispatch jit-dispatch-word set
+    \ do-primitive jit-primitive-word set
     [ undefined ] undefined-quot set
     {
         jit-code-format
         jit-prolog
-        jit-word-primitive-jump
+        jit-primitive-word
-        jit-word-primitive-call
+        jit-primitive
         jit-word-jump
         jit-word-call
         jit-push-literal
@@ -383,6 +387,7 @@ M: curry '
         jit-dispatch
         jit-epilog
         jit-return
+        jit-profiling
         undefined-quot
     } [ emit-userenv ] each ;
 

core/bootstrap/primitives.factor

@@ -314,7 +314,7 @@ define-builtin
         { "set-word-vocabulary" "words" }
     }
     {
-        { "object" "kernel" }
+        { "quotation" "quotations" }
         "def"
         4
         { "word-def" "words" }
@@ -408,7 +408,7 @@ builtins get num-tags get tail f union-class define-class
 
 ! Primitive words
 : make-primitive ( word vocab n -- )
-    >r create dup reset-word r> define ;
+    >r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
 
 {
     { "(execute)" "words.private" }
@@ -607,4 +607,4 @@ builtins get num-tags get tail f union-class define-class
 dup length [ >r first2 r> make-primitive ] 2each
 
 ! Bump build number
-"build" "kernel" create build 1+ 1quotation define-compound
+"build" "kernel" create build 1+ 1quotation define

core/classes/classes-docs.factor

@@ -122,7 +122,7 @@ HELP: predicate-word
 HELP: define-predicate
 { $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } }
 { $description
-    "Defines a predicate word. This is identical to a compound definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
+    "Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
     { $list
         { "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" }
         { "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" }

core/classes/classes-tests.factor

@@ -36,8 +36,8 @@ UNION: both first-one union-class ;
 [ f ] [ \ integer \ null class< ] unit-test
 [ t ] [ \ null \ object class< ] unit-test
 
-[ t ] [ \ generic \ compound class< ] unit-test
+[ t ] [ \ generic \ word class< ] unit-test
-[ f ] [ \ compound \ generic class< ] unit-test
+[ f ] [ \ word \ generic class< ] unit-test
 
 [ f ] [ \ reversed \ slice class< ] unit-test
 [ f ] [ \ slice \ reversed class< ] unit-test

core/classes/classes.factor

@@ -27,8 +27,7 @@ PREDICATE: class tuple-class
 
 : predicate-effect 1 { "?" } <effect> ;
 
-PREDICATE: compound predicate
+PREDICATE: word predicate "predicating" word-prop >boolean ;
-    "predicating" word-prop >boolean ;
 
 : define-predicate ( class predicate quot -- )
     over [

core/compiler/constants/constants.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math kernel layouts system ;
+IN: compiler.constants
+
+! These constants must match vm/memory.h
+: card-bits 6 ;
+: card-mark HEX: 40 HEX: 80 bitor ;
+
+! These constants must match vm/layouts.h
+: header-offset object tag-number neg ;
+: float-offset 8 float tag-number - ;
+: string-offset 3 bootstrap-cells object tag-number - ;
+: profile-count-offset 7 bootstrap-cells object tag-number - ;
+: byte-array-offset 2 bootstrap-cells object tag-number - ;
+: alien-offset 3 bootstrap-cells object tag-number - ;
+: underlying-alien-offset bootstrap-cell object tag-number - ;
+: tuple-class-offset 2 bootstrap-cells tuple tag-number - ;
+: class-hash-offset bootstrap-cell object tag-number - ;
+: word-xt-offset 8 bootstrap-cells object tag-number - ;
+: word-code-offset 9 bootstrap-cells object tag-number - ;
+: compiled-header-size 8 bootstrap-cells ;

core/cpu/architecture/architecture.factor

@@ -5,8 +5,6 @@ namespaces sequences layouts system hashtables classes alien
 byte-arrays bit-arrays float-arrays combinators words ;
 IN: cpu.architecture
 
-SYMBOL: profiler-prologue
-
 SYMBOL: compiler-backend
 
 ! A pseudo-register class for parameters spilled on the stack
@@ -45,9 +43,6 @@ HOOK: %epilogue compiler-backend ( n -- )
 
 : %epilogue-later \ %epilogue-later , ;
 
-! Bump profiling counter
-HOOK: %profiler-prologue compiler-backend ( word -- )
-
 ! Store word XT in stack frame
 HOOK: %save-word-xt compiler-backend ( -- )
 
@@ -59,15 +54,9 @@ M: object %save-dispatch-xt %save-word-xt ;
 ! Call another label
 HOOK: %call-label compiler-backend ( label -- )
 
-! Call C primitive
-HOOK: %call-primitive compiler-backend ( label -- )
-
 ! Local jump for branches
 HOOK: %jump-label compiler-backend ( label -- )
 
-! Far jump to C primitive
-HOOK: %jump-primitive compiler-backend ( label -- )
-
 ! Test if vreg is 'f' or not
 HOOK: %jump-t compiler-backend ( label -- )
 
@@ -159,7 +148,7 @@ M: stack-params param-reg drop ;
 
 GENERIC: v>operand ( obj -- operand )
 
-M: integer v>operand tag-bits get shift ;
+M: integer v>operand tag-fixnum ;
 
 M: f v>operand drop \ f tag-number ;
 

core/cpu/arm/allot/allot.factor

@@ -17,7 +17,7 @@ IN: cpu.arm.allot
     R11 R11 pick ADD ! increment r11
     R11 R12 cell <+> STR ! r11 -> nursery.here
     R11 R11 rot SUB ! old value
-    R12 swap type-number tag-header MOV ! compute header
+    R12 swap type-number tag-fixnum MOV ! compute header
     R12 R11 0 <+> STR ! store header
     ;
     

core/cpu/arm/architecture/architecture.factor

@@ -350,7 +350,7 @@ M: arm-backend %unbox-any-c-ptr ( dst src -- )
     "end" get EQ B
     ! Is the object an alien?
     R14 R12 header-offset <+/-> LDR
-    R14 alien type-number tag-header CMP
+    R14 alien type-number tag-fixnum CMP
     ! Add byte array address to address being computed
     R11 R11 R12 NE ADD
     ! Add an offset to start of byte array's data area

core/cpu/ppc/allot/allot.factor

@@ -18,7 +18,7 @@ IN: cpu.ppc.allot
     11 11 pick ADDI ! increment r11
     11 12 cell STW ! r11 -> nursery.here
     11 11 rot SUBI ! old value
-    type-number tag-header 12 LI ! compute header
+    type-number tag-fixnum 12 LI ! compute header
     12 11 0 STW ! store header
     ;
 

core/cpu/ppc/architecture/architecture.factor

@@ -333,7 +333,7 @@ M: ppc-backend %unbox-any-c-ptr ( dst src -- )
     "end" get BEQ
     ! Is the object an alien?
     0 11 header-offset LWZ
-    0 0 alien type-number tag-header CMPI
+    0 0 alien type-number tag-fixnum CMPI
     "is-byte-array" get BNE
     ! If so, load the offset
     0 11 alien-offset LWZ

core/cpu/x86/32/32.factor

@@ -275,8 +275,6 @@ T{ x86-backend f 4 } compiler-backend set-global
     JNE
 ] { } define-if-intrinsic
 
-10 profiler-prologue set-global
-
 "-no-sse2" cli-args member? [
     "Checking if your CPU supports SSE2..." print flush
     [ sse2? ] compile-call [

core/cpu/x86/allot/allot.factor

@@ -30,7 +30,7 @@ IN: cpu.x86.allot
     allot-reg cell [+] swap 8 align ADD ;
 
 : store-header ( header -- )
-    0 object@ swap type-number tag-header MOV ;
+    0 object@ swap type-number tag-fixnum MOV ;
 
 : %allot ( header size quot -- )
     allot-reg PUSH

core/cpu/x86/architecture/architecture.factor

@@ -3,7 +3,7 @@
 USING: alien alien.c-types alien.compiler arrays
 cpu.x86.assembler cpu.architecture kernel kernel.private math
 memory namespaces sequences words generator generator.registers
-generator.fixup system layouts combinators ;
+generator.fixup system layouts combinators compiler.constants ;
 IN: cpu.x86.architecture
 
 TUPLE: x86-backend cell ;
@@ -70,27 +70,10 @@ M: x86-backend %prepare-alien-invoke
     temp-reg v>operand 2 cells [+] ds-reg MOV
     temp-reg v>operand 3 cells [+] rs-reg MOV ;
 
-M: x86-backend %profiler-prologue ( word -- )
-    temp-reg load-literal
-    temp-reg v>operand profile-count-offset [+] 1 v>operand ADD ;
-
 M: x86-backend %call-label ( label -- ) CALL ;
 
 M: x86-backend %jump-label ( label -- ) JMP ;
 
-: %prepare-primitive ( word -- operand )
-    ! Save stack pointer to stack_chain->callstack_top, load XT
-    ! in register
-    stack-save-reg stack-reg MOV address-operand ;
-
-M: x86-backend %call-primitive ( word -- )
-    stack-save-reg stack-reg cell neg [+] LEA
-    address-operand CALL ;
-
-M: x86-backend %jump-primitive ( word -- )
-    stack-save-reg stack-reg MOV
-    address-operand JMP ;
-
 M: x86-backend %jump-t ( label -- )
     "flag" operand f v>operand CMP JNE ;
 
@@ -195,7 +178,7 @@ M: x86-backend %unbox-any-c-ptr ( dst src -- )
     rs-reg f v>operand CMP
     "end" get JE
     ! Is the object an alien?
-    rs-reg header-offset [+] alien type-number tag-header CMP
+    rs-reg header-offset [+] alien type-number tag-fixnum CMP
     "is-byte-array" get JNE
     ! If so, load the offset and add it to the address
     ds-reg rs-reg alien-offset [+] ADD

core/cpu/x86/bootstrap.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel namespaces system
-cpu.x86.assembler layouts vocabs math generator.fixup ;
+cpu.x86.assembler layouts vocabs math generator.fixup
+compiler.constants ;
 IN: bootstrap.x86
 
 big-endian off
@@ -11,12 +12,23 @@ big-endian off
 : stack-frame-size 4 bootstrap-cells ;
 
 [
-    arg0 0 [] MOV                              ! load quotation
+    ! Load word
-    arg1 arg0 quot-xt@ [+] MOV                 ! load XT
+    arg0 0 [] MOV
+    ! Bump profiling counter
+    arg0 profile-count-offset [+] 1 tag-fixnum ADD
+    ! Load word->code
+    arg0 arg0 word-code-offset [+] MOV
+    ! Compute word XT
+    arg0 compiled-header-size ADD
+    ! Jump to XT
+    arg0 JMP
+] rc-absolute-cell rt-literal 2 jit-profiling jit-define
+
+[
     stack-frame-size PUSH                      ! save stack frame size
-    arg1 PUSH                                  ! save XT
+    0 PUSH                                     ! push XT
     arg1 PUSH                                  ! alignment
-] rc-absolute-cell rt-literal 2 jit-prolog jit-define
+] rc-absolute-cell rt-xt 6 jit-prolog jit-define
 
 [
     arg0 0 [] MOV                              ! load literal
@@ -27,12 +39,7 @@ big-endian off
 [
     arg1 stack-reg MOV                         ! pass callstack pointer as arg 2
     (JMP) drop                                 ! go
-] rc-relative rt-primitive 3 jit-word-primitive-jump jit-define
+] rc-relative rt-primitive 3 jit-primitive jit-define
-
-[
-    arg1 stack-reg bootstrap-cell neg [+] LEA  ! pass callstack pointer as arg 2
-    (CALL) drop                                ! go
-] rc-relative rt-primitive 5 jit-word-primitive-call jit-define
 
 [
     (JMP) drop

core/cpu/x86/intrinsics/intrinsics.factor

@@ -6,7 +6,7 @@ math.private namespaces quotations sequences
 words generic byte-arrays hashtables hashtables.private
 generator generator.registers generator.fixup sequences.private
 sbufs sbufs.private vectors vectors.private layouts system
-tuples.private strings.private slots.private ;
+tuples.private strings.private slots.private compiler.constants ;
 IN: cpu.x86.intrinsics
 
 ! Type checks
@@ -27,7 +27,7 @@ IN: cpu.x86.intrinsics
     ! Tag the tag
     "x" operand %tag-fixnum
     ! Compare with object tag number (3).
-    "x" operand object tag-number tag-bits get shift CMP
+    "x" operand object tag-number tag-fixnum CMP
     "end" get JNE
     ! If we have equality, load type from header
     "x" operand "obj" operand -3 [+] MOV
@@ -49,10 +49,10 @@ IN: cpu.x86.intrinsics
     ! Tag the tag
     "x" operand %tag-fixnum
     ! Compare with tuple tag number (2).
-    "x" operand tuple tag-number tag-bits get shift CMP
+    "x" operand tuple tag-number tag-fixnum CMP
     "tuple" get JE
     ! Compare with object tag number (3).
-    "x" operand object tag-number tag-bits get shift CMP
+    "x" operand object tag-number tag-fixnum CMP
     "object" get JE
     "end" get JMP
     "object" get resolve-label

core/generator/fixup/fixup.factor

@@ -127,12 +127,7 @@ SYMBOL: word-table
 
 : rel-dispatch ( word-table# class -- ) rt-dispatch rel-fixup ;
 
-GENERIC# rel-word 1 ( word class -- )
+: rel-word ( word class -- )
-
-M: primitive rel-word ( word class -- )
-    >r word-def r> rt-primitive rel-fixup ;
-
-M: word rel-word ( word class -- )
     >r add-word r> rt-xt rel-fixup ;
 
 : rel-literal ( literal class -- )

core/generator/generator.factor

@@ -10,13 +10,13 @@ IN: generator
 SYMBOL: compile-queue
 SYMBOL: compiled
 
-: 6array 3array >r 3array r> append ;
+: 5array 3array >r 2array r> append ;
 
 : begin-compiling ( word -- )
     f swap compiled get set-at ;
 
-: finish-compiling ( word literals words relocation labels code profiler-prologue -- )
+: finish-compiling ( word literals words relocation labels code -- )
-    6array swap compiled get set-at ;
+    5array swap compiled get set-at ;
 
 : queue-compile ( word -- )
     {
@@ -56,11 +56,6 @@ t compiled-stack-traces? set-global
         word-table get >array
     ] { } make fixup finish-compiling ;
 
-: generate-profiler-prologue ( -- )
-    compiled-stack-traces? get [
-        compiling-word get %profiler-prologue
-    ] when ;
-
 GENERIC: generate-node ( node -- next )
 
 : generate-nodes ( node -- )
@@ -69,13 +64,11 @@ GENERIC: generate-node ( node -- next )
 : generate ( word label node -- )
     [
         init-templates
-        generate-profiler-prologue
         %save-word-xt
         %prologue-later
         current-label-start define-label
         current-label-start resolve-label
         [ generate-nodes ] with-node-iterator
-        profiler-prologue get
     ] generate-1 ;
 
 : word-dataflow ( word -- effect dataflow )
@@ -113,21 +106,14 @@ UNION: #terminal
 ! node
 M: node generate-node drop iterate-next ;
 
-: %call ( word -- )
+: %call ( word -- ) %call-label ;
-    dup primitive? [ %call-primitive ] [ %call-label ] if ;
 
 : %jump ( word -- )
-    {
+    dup compiling-label get eq? [
-        { [ dup compiling-label get eq? ] [
+        drop current-label-start get %jump-label
-            drop current-label-start get %jump-label
+    ] [
-        ] }
+        %epilogue-later %jump-label
-        { [ dup primitive? ] [
+    ] if ;
-            %epilogue-later %jump-primitive
-        ] }
-        { [ t ] [
-            %epilogue-later %jump-label
-        ] }
-    } cond ;
 
 : generate-call ( label -- next )
     dup maybe-compile
@@ -179,7 +165,6 @@ M: #if generate-node
             %save-dispatch-xt
             %prologue-later
             [ generate-nodes ] with-node-iterator
-            0
         ] generate-1
     ] keep ;
 
@@ -286,20 +271,3 @@ M: #r> generate-node
 
 ! #return
 M: #return generate-node drop end-basic-block %return f ;
-
-! These constants must match vm/memory.h
-: card-bits 6 ;
-: card-mark HEX: 40 HEX: 80 bitor ;
-
-! These constants must match vm/layouts.h
-: header-offset object tag-number neg ;
-: float-offset 8 float tag-number - ;
-: string-offset 3 cells object tag-number - ;
-: profile-count-offset 7 cells object tag-number - ;
-: byte-array-offset 2 cells object tag-number - ;
-: alien-offset 3 cells object tag-number - ;
-: underlying-alien-offset cell object tag-number - ;
-: 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 ;

core/generic/generic.factor

@@ -5,8 +5,7 @@ definitions kernel.private classes classes.private
 quotations arrays vocabs ;
 IN: generic
 
-PREDICATE: compound generic ( word -- ? )
+PREDICATE: word generic "combination" word-prop >boolean ;
-    "combination" word-prop >boolean ;
 
 M: generic definer drop f f ;
 
@@ -24,9 +23,7 @@ M: object perform-combination
     nip [ "Invalid method combination" throw ] curry [ ] like ;
 
 : make-generic ( word -- )
-    dup
+    dup dup "combination" word-prop perform-combination define ;
-    dup "combination" word-prop perform-combination
-    define-compound ;
 
 : init-methods ( word -- )
      dup "methods" word-prop

core/inference/backend/backend.factor

@@ -345,10 +345,6 @@ TUPLE: no-effect word ;
 
 : no-effect ( word -- * ) \ no-effect inference-warning ;
 
-GENERIC: infer-word ( word -- effect )
-
-M: word infer-word no-effect ;
-
 TUPLE: effect-error word effect ;
 
 : effect-error ( word effect -- * )
@@ -364,18 +360,16 @@ TUPLE: effect-error word effect ;
     over recorded get push
     "inferred-effect" set-word-prop ;
 
-: infer-compound ( word -- effect )
+: infer-word ( word -- effect )
     [
-        init-inference
+        [
-        dependencies off
+            init-inference
-        dup word-def over dup infer-quot-recursive
+            dependencies off
-        finish-word
+            dup word-def over dup infer-quot-recursive
-        current-effect
+            finish-word
-    ] with-scope ;
+            current-effect
-
+        ] with-scope
-M: compound infer-word
+    ] [ ] [ t "no-effect" set-word-prop ] cleanup ;
-    [ infer-compound ] [ ] [ t "no-effect" set-word-prop ]
-    cleanup ;
 
 : custom-infer ( word -- )
     #! Customized inference behavior
@@ -392,8 +386,6 @@ M: compound infer-word
         { [ t ] [ dup infer-word make-call-node ] }
     } cond ;
 
-M: word apply-object apply-word ;
-
 TUPLE: recursive-declare-error word ;
 
 : declared-infer ( word -- )
@@ -458,7 +450,7 @@ M: #call-label collect-recursion*
         apply-infer node-child node-successor splice-node drop
     ] if ;
 
-M: compound apply-object
+M: word apply-object
     [
         dup inline-recursive-label
         [ declared-infer ] [ inline-word ] if

core/inference/class/class-tests.factor

@@ -141,8 +141,7 @@ DEFER: blah
 [ t ] [
     [
         \ blah
-        [ dup V{ } eq? [ foo ] when ] dup second dup push
+        [ dup V{ } eq? [ foo ] when ] dup second dup push define
-        define-compound
     ] with-compilation-unit
 
     \ blah compiled?

core/inference/inference-tests.factor

@@ -3,10 +3,9 @@ inference.dataflow kernel classes kernel.private math
 math.parser math.private namespaces namespaces.private parser
 sequences strings vectors words quotations effects tools.test
 continuations generic.standard sorting assocs definitions
-prettyprint io inspector tuples
+prettyprint io inspector tuples classes.union classes.predicate
-classes.union classes.predicate debugger bootstrap.image
+debugger threads.private io.streams.string combinators.private
-bootstrap.image.private threads.private
+tools.test.inference ;
-io.streams.string combinators.private tools.test.inference ;
 IN: temporary
 
 { 0 2 } [ 2 "Hello" ] unit-test-effect

core/inference/known-words/known-words.factor

@@ -9,7 +9,7 @@ math.private memory namespaces namespaces.private parser
 prettyprint quotations quotations.private sbufs sbufs.private
 sequences sequences.private slots.private strings
 strings.private system threads.private tuples tuples.private
-vectors vectors.private words words.private assocs ;
+vectors vectors.private words words.private assocs inspector ;
 IN: inference.known-words
 
 ! Shuffle words
@@ -577,3 +577,5 @@ t over set-effect-terminated?
 \ set-innermost-frame-quot { quotation callstack } { } <effect> "inferred-effect" set-word-prop
 
 \ (os-envs) { } { array } <effect> "inferred-effect" set-word-prop
+
+\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop

core/kernel/kernel.factor

@@ -159,4 +159,6 @@ GENERIC: construct-boa ( ... class -- tuple )
 
 : declare ( spec -- ) drop ;
 
+: do-primitive ( number -- ) "Improper primitive call" throw ;
+
 PRIVATE>

core/layouts/layouts-docs.factor

@@ -23,9 +23,9 @@ HELP: type-number
 { $description "Outputs the built-in type number instances of " { $link class } ". Will output " { $link f } " if this is not a built-in class." }
 { $see-also builtin-class } ;
 
-HELP: tag-header
+HELP: tag-fixnum
-{ $values { "n" "a built-in type number" } { "tagged" integer } }
+{ $values { "n" integer } { "tagged" integer } }
-{ $description "Outputs the header for objects of type " { $snippet "n" } "." } ;
+{ $description "Outputs a tagged fixnum." } ;
 
 HELP: first-bignum
 { $values { "n" "smallest positive integer not representable by a fixnum" } } ;

core/layouts/layouts.factor

@@ -21,7 +21,7 @@ SYMBOL: type-numbers
 : type-number ( class -- n )
     type-numbers get at ;
 
-: tag-header ( n -- tagged )
+: tag-fixnum ( n -- tagged )
     tag-bits get shift ;
 
 : first-bignum ( -- n )

core/prettyprint/prettyprint-tests.factor

@@ -2,7 +2,7 @@ USING: arrays definitions io.streams.string io.streams.duplex
 kernel math namespaces parser prettyprint prettyprint.config
 prettyprint.sections sequences tools.test vectors words
 effects splitting generic.standard prettyprint.private
-continuations ;
+continuations generic ;
 IN: temporary
 
 [ "4" ] [ 4 unparse ] unit-test
@@ -59,7 +59,7 @@ unit-test
 
 [ ] [ \ general-t see ] unit-test
 
-[ ] [ \ compound see ] unit-test
+[ ] [ \ generic see ] unit-test
 
 [ ] [ \ duplex-stream see ] unit-test
 
@@ -150,8 +150,8 @@ unit-test
         "IN: temporary"
         ": retain-stack-layout"
         "    dup stream-readln stream-readln"
-        "    >r [ define-compound ] map r>"
+        "    >r [ define ] map r>"
-        "    define-compound ;"
+        "    define ;"
     } ;
 
 [ t ] [

core/prettyprint/sections/sections-docs.factor

@@ -211,7 +211,7 @@ HELP: <flow
 
 HELP: colon
 { $class-description "A " { $link block } " section. When printed as a " { $link long-section } ", indents every line except the first." }
-{ $notes "Colon sections are used to enclose compound definitions printed by " { $link see } "." } ;
+{ $notes "Colon sections are used to enclose word definitions printed by " { $link see } "." } ;
 
 HELP: <colon
 { $description "Begins a " { $link colon } " section." } ;

core/slots/slots.factor

@@ -25,8 +25,7 @@ C: <slot-spec> slot-spec
         [ drop ] [ 1array , \ declare , ] if
     ] [ ] make ;
 
-PREDICATE: compound slot-reader
+PREDICATE: word slot-reader "reading" word-prop >boolean ;
-    "reading" word-prop >boolean ;
 
 : set-reader-props ( class spec -- )
     2dup reader-effect
@@ -48,8 +47,7 @@ PREDICATE: compound slot-reader
 : writer-effect ( class spec -- effect )
     slot-spec-name swap ?word-name 2array 0 <effect> ;
 
-PREDICATE: compound slot-writer
+PREDICATE: word slot-writer "writing" word-prop >boolean ;
-    "writing" word-prop >boolean ;
 
 : set-writer-props ( class spec -- )
     2dup writer-effect

core/syntax/syntax-docs.factor

@@ -318,10 +318,10 @@ HELP: POSTPONE:
 HELP: :
 { $syntax ": word definition... ;" }
 { $values { "word" "a new word to define" } { "definition" "a word definition" } }
-{ $description "Defines a compound word in the current vocabulary." }
+{ $description "Defines a word in the current vocabulary." }
 { $examples { $code ": ask-name ( -- name )\n    \"What is your name? \" write readln ;\n: greet ( name -- )\n    \"Greetings, \" write print ;\n: friend ( -- )\n    ask-name greet ;" } } ;
 
-{ POSTPONE: : POSTPONE: ; define-compound } related-words
+{ POSTPONE: : POSTPONE: ; define } related-words
 
 HELP: ;
 { $syntax ";" }

core/syntax/syntax.factor

@@ -19,8 +19,7 @@ IN: bootstrap.syntax
     "syntax" lookup t "delimiter" set-word-prop ;
 
 : define-syntax ( name quot -- )
-    >r "syntax" lookup dup r> define-compound
+    >r "syntax" lookup dup r> define t "parsing" set-word-prop ;
-    t "parsing" set-word-prop ;
 
 [
     { "]" "}" ";" ">>" } [ define-delimiter ] each
@@ -96,7 +95,7 @@ IN: bootstrap.syntax
     ] define-syntax
 
     ":" [
-        CREATE dup reset-generic parse-definition define-compound
+        CREATE dup reset-generic parse-definition define
     ] define-syntax
 
     "GENERIC:" [

core/vocabs/loader/loader-tests.factor

@@ -94,7 +94,7 @@ IN: temporary
 
 [ ] [
     [
-        "bob" "vocabs.loader.test.b" create [ ] define-compound
+        "bob" "vocabs.loader.test.b" create [ ] define
     ] with-compilation-unit
 ] unit-test
 
@@ -102,7 +102,7 @@ IN: temporary
 
 [ 2 ] [ "count-me" get-global ] unit-test
 
-[ t ] [ "fred" "vocabs.loader.test.b" lookup compound? ] unit-test
+[ f ] [ "fred" "vocabs.loader.test.b" lookup undefined? ] unit-test
 
 [ ] [
     "vocabs.loader.test.b" vocab-files [ forget-source ] each

core/words/words-docs.factor

@@ -26,18 +26,19 @@ $nl
 { $subsection gensym }
 { $subsection define-temp } ;
 
-ARTICLE: "colon-definition" "Compound definitions"
+ARTICLE: "colon-definition" "Word definitions"
-"A compound definition associates a word name with a quotation that is called when the word is executed."
+"Every word has an associated quotation definition that is called when the word is executed."
-{ $subsection compound }
+$nl
-{ $subsection compound? }
+"Defining words at parse time:"
-"Defining compound words at parse time:"
 { $subsection POSTPONE: : }
 { $subsection POSTPONE: ; }
-"Defining compound words at run time:"
+"Defining words at run time:"
-{ $subsection define-compound }
+{ $subsection define }
 { $subsection define-declared }
 { $subsection define-inline }
-"Compound definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "." ;
+"Word definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "."
+$nl
+"All other types of word definitions, such as " { $link "symbols" } " and " { $link "generic" } ", are just special cases of the above." ;
 
 ARTICLE: "symbols" "Symbols"
 "A symbol pushes itself on the stack when executed. By convention, symbols are used as variable names (" { $link "namespaces" } ")."
@@ -46,7 +47,12 @@ ARTICLE: "symbols" "Symbols"
 "Defining symbols at parse time:"
 { $subsection POSTPONE: SYMBOL: }
 "Defining symbols at run time:"
-{ $subsection define-symbol } ;
+{ $subsection define-symbol }
+"Symbols are just compound definitions in disguise. The following two lines are equivalent:"
+{ $code
+    "SYMBOL: foo"
+    ": foo \\ foo ;"
+} ;
 
 ARTICLE: "primitives" "Primitives"
 "Primitives are words defined in the Factor VM. They provide the essential low-level services to the rest of the system."
@@ -54,11 +60,20 @@ ARTICLE: "primitives" "Primitives"
 { $subsection primitive? } ;
 
 ARTICLE: "deferred" "Deferred words and mutual recursion"
-"Words cannot be referenced before they are defined; that is, source files must order definitions in a strictly bottom-up fashion. This is done to simplify the implementation, facilitate better parse time checking and remove some odd corner cases; it also encourages better coding style. Sometimes this restriction gets in the way, for example when defining mutually-recursive words; one way to get around this limitation is to make a forward definition."
+"Words cannot be referenced before they are defined; that is, source files must order definitions in a strictly bottom-up fashion. This is done to simplify the implementation, facilitate better parse time checking and remove some odd corner cases; it also encourages better coding style."
+$nl
+"Sometimes this restriction gets in the way, for example when defining mutually-recursive words; one way to get around this limitation is to make a forward definition."
 { $subsection POSTPONE: DEFER: }
-"The class of forward word definitions:"
+"The class of deferred word definitions:"
 { $subsection deferred }
-{ $subsection deferred? } ;
+{ $subsection deferred? }
+"Deferred words throw an error when called:"
+{ $subsection undefined }
+"Deferred words are just compound definitions in disguise. The following two lines are equivalent:"
+{ $code
+    "DEFER: foo"
+    ": foo undefined ;"
+} ;
 
 ARTICLE: "declarations" "Declarations"
 "Declarations give special behavior to a word. Declarations are parsing words that set a word property in the most recently defined word."
@@ -155,13 +170,15 @@ ARTICLE: "word.private" "Word implementation details"
 { $subsection modify-code-heap } ;
 
 ARTICLE: "words" "Words"
-"Words are the Factor equivalent of functions or procedures; a word is a body of code with a unique name and some additional meta-data. Words are defined in the " { $vocab-link "words" } " vocabulary."
+"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation."
+$nl
+"Word introspection facilities and implementation details are found in the " { $vocab-link "words" } " vocabulary."
 $nl
 "A word consists of several parts:"
 { $list
     "a word name,"
     "a vocabulary name,"
-    "a definition, specifying the behavior of the word when executed,"
+    "a definition quotation, called when the word when executed,"
     "a set of word properties, including documentation and other meta-data."
 }
 "Words are instances of a class."
@@ -212,9 +229,6 @@ HELP: deferred
 
 { deferred POSTPONE: DEFER: } related-words
 
-HELP: compound
-{ $description "The class of compound words created by " { $link POSTPONE: : } "." } ;
-
 HELP: primitive
 { $description "The class of primitive words." } ;
 
@@ -239,20 +253,13 @@ HELP: word-xt
 { $values { "word" word } { "xt" "an execution token integer" } }
 { $description "Outputs the machine code address of the word's definition." } ;
 
-HELP: define
-{ $values { "word" word } { "def" object } }
-{ $description "Defines a word and updates cross-referencing." }
-$low-level-note
-{ $side-effects "word" }
-{ $see-also define-symbol define-compound } ;
-
 HELP: define-symbol
 { $values { "word" word } }
 { $description "Defines the word to push itself on the stack when executed. This is the run time equivalent of " { $link POSTPONE: SYMBOL: } "." }
 { $notes "This word must be called from inside " { $link with-compilation-unit } "." }
 { $side-effects "word" } ;
 
-HELP: define-compound
+HELP: define
 { $values { "word" word } { "def" quotation } }
 { $description "Defines the word to call a quotation when executed. This is the run time equivalent of " { $link POSTPONE: : } "." }
 { $notes "This word must be called from inside " { $link with-compilation-unit } "." }
@@ -342,7 +349,7 @@ HELP: parsing?
 
 HELP: define-declared
 { $values { "word" word } { "def" quotation } { "effect" effect } }
-{ $description "Defines a compound word and declares its stack effect." }
+{ $description "Defines a word and declares its stack effect." }
 { $side-effects "word" } ;
 
 HELP: define-temp
@@ -393,7 +400,7 @@ HELP: make-inline
 
 HELP: define-inline
 { $values { "word" word } { "quot" quotation } }
-{ $description "Defines a compound word and makes it " { $link POSTPONE: inline } "." }
+{ $description "Defines a word and makes it " { $link POSTPONE: inline } "." }
 { $side-effects "word" } ;
 
 HELP: modify-code-heap ( alist -- )
@@ -401,6 +408,6 @@ HELP: modify-code-heap ( alist -- )
 { $description "Stores compiled code definitions in the code heap. The alist maps words to the following:"
 { $list
     { { $link f } " - in this case, the word is compiled with the non-optimizing compiler part of the VM." }
-    { { $snippet "{ code labels rel words literals profiler-prologue }" } " - in this case, a code heap block is allocated with the given data." }
+    { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." }
 } }
 { $notes "This word is called at the end of " { $link with-compilation-unit } "." } ;

core/words/words-tests.factor

@@ -5,7 +5,7 @@ IN: temporary
 
 [ 4 ] [
     [
-        "poo" "temporary" create [ 2 2 + ] define-compound
+        "poo" "temporary" create [ 2 2 + ] define
     ] with-compilation-unit
     "poo" "temporary" lookup execute
 ] unit-test
@@ -24,8 +24,6 @@ DEFER: plist-test
     \ plist-test "sample-property" word-prop
 ] unit-test
 
-[ f ] [ 5 compound? ] unit-test
-
 "create-test" "scratchpad" create { 1 2 } "testing" set-word-prop
 [ { 1 2 } ] [
     "create-test" "scratchpad" lookup "testing" word-prop
@@ -46,13 +44,7 @@ DEFER: plist-test
 
 [ f ] [ gensym gensym = ] unit-test
 
-[ f ] [ 123 compound? ] unit-test
-
-: colon-def ;
-[ t ] [ \ colon-def compound? ] unit-test
-
 SYMBOL: a-symbol
-[ t ] [ \ a-symbol compound? ] unit-test
 [ t ] [ \ a-symbol symbol? ] unit-test
 
 ! See if redefining a generic as a colon def clears some
@@ -91,7 +83,7 @@ FORGET: foe
 
 ! xref should not retain references to gensyms
 [ ] [
-    [ gensym [ * ] define-compound ] with-compilation-unit
+    [ gensym [ * ] define ] with-compilation-unit
 ] unit-test
 
 [ t ] [
@@ -103,7 +95,7 @@ DEFER: calls-a-gensym
     [
         \ calls-a-gensym
         gensym dup "x" set 1quotation
-        define-compound
+        define
     ] with-compilation-unit
 ] unit-test
 
@@ -143,7 +135,7 @@ SYMBOL: quot-uses-b
 
 [ ] [
     [
-        quot-uses-a [ 2 3 + ] define-compound
+        quot-uses-a [ 2 3 + ] define
     ] with-compilation-unit
 ] unit-test
 
@@ -151,7 +143,7 @@ SYMBOL: quot-uses-b
 
 [ ] [
     [
-        quot-uses-b 2 [ 3 + ] curry define-compound
+        quot-uses-b 2 [ 3 + ] curry define
     ] with-compilation-unit
 ] unit-test
 

core/words/words.factor

@@ -17,30 +17,28 @@ M: word execute (execute) ;
 M: word <=>
     [ dup word-name swap word-vocabulary 2array ] compare ;
 
-M: word definition drop f ;
+M: word definer drop \ : \ ; ;
 
-PREDICATE: word compound  ( obj -- ? ) word-def quotation? ;
+M: word definition word-def ;
-
-M: compound definer drop \ : \ ; ;
-
-M: compound definition word-def ;
 
 TUPLE: undefined ;
 
 : undefined ( -- * ) \ undefined construct-empty throw ;
 
-PREDICATE: compound deferred ( obj -- ? )
+PREDICATE: word deferred ( obj -- ? )
     word-def [ undefined ] = ;
 M: deferred definer drop \ DEFER: f ;
 M: deferred definition drop f ;
 
-PREDICATE: compound symbol ( obj -- ? )
+PREDICATE: word symbol ( obj -- ? )
     dup <wrapper> 1array swap word-def sequence= ;
 M: symbol definer drop \ SYMBOL: f ;
 M: symbol definition drop f ;
 
-PREDICATE: word primitive ( obj -- ? ) word-def fixnum? ;
+PREDICATE: word primitive ( obj -- ? )
+    word-def [ do-primitive ] tail? ;
 M: primitive definer drop \ PRIMITIVE: f ;
+M: primitive definition drop f ;
 
 : word-prop ( word name -- value ) swap word-props at ;
 
@@ -89,26 +87,20 @@ M: wrapper (quot-uses) >r wrapped r> (quot-uses) ;
 M: word uses ( word -- seq )
     word-def quot-uses keys ;
 
-M: compound redefined* ( word -- )
+M: word redefined* ( word -- )
     { "inferred-effect" "base-case" "no-effect" } reset-props ;
 
-<PRIVATE
-
 : define ( word def -- )
+    [ ] like
     over unxref
     over redefined
     over set-word-def
     dup changed-word
     dup word-vocabulary [ dup xref ] when drop ;
 
-PRIVATE>
-
-: define-compound ( word def -- )
-    [ ] like define ;
-
 : define-declared ( word def effect -- )
     pick swap "declared-effect" set-word-prop
-    define-compound ;
+    define ;
 
 : make-inline ( word -- )
     t "inline" set-word-prop ;
@@ -120,7 +112,7 @@ PRIVATE>
     dup make-flushable t "foldable" set-word-prop ;
 
 : define-inline ( word quot -- )
-    dupd define-compound make-inline ;
+    dupd define make-inline ;
 
 : define-symbol ( word -- )
     dup [ ] curry define-inline ;
@@ -142,7 +134,7 @@ PRIVATE>
     "G:" \ gensym counter number>string append f <word> ;
 
 : define-temp ( quot -- word )
-    gensym dup rot define-compound ;
+    gensym dup rot define ;
 
 : reveal ( word -- )
     dup word-name over word-vocabulary vocab-words set-at ;

extra/help/handbook/handbook.factor

@@ -58,10 +58,7 @@ $nl
 ARTICLE: "evaluator" "Evaluation semantics"
 { $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:"
 { $list
-    { "a " { $link symbol } " - pushed on the data stack. See " { $link "symbols" } }
+    { "a " { $link word } " - the word's definition quotation is called. See " { $link "words" } }
-    { "a " { $link compound } " - the associated definition is called. See " { $link "colon-definition" } }
-    { "a" { $link primitive } " - a primitive in the Factor VM is called. See " { $link "primitives" } }
-    { "an " { $link undefined } " -  an error is raised. See " { $link "deferred" } }
     { "a " { $link wrapper } " - the wrapped object is pushed on the data stack. Wrappers are used to push word objects directly on the stack when they would otherwise execute. See the " { $link POSTPONE: \ } " parsing word." }
     { "All other types of objects are pushed on the data stack." }
 }

extra/macros/macros.factor

@@ -13,14 +13,13 @@ IN: macros
 : (MACRO:)
     >r
     2dup "macro" set-word-prop
-    2dup [ call ] append define-compound
+    2dup [ call ] append define
     r> define-transform ;
 
 : MACRO:
     (:) (MACRO:) ; parsing
 
-PREDICATE: compound macro
+PREDICATE: word macro "macro" word-prop >boolean ;
-    "macro" word-prop >boolean ;
 
 M: macro definer drop \ MACRO: \ ; ;
 

extra/tools/annotations/annotations.factor

@@ -4,21 +4,13 @@ USING: kernel words parser io inspector quotations sequences
 prettyprint continuations effects definitions ;
 IN: tools.annotations
 
-: check-compound ( word -- )
-    compound? [
-        "Annotations can only be used with compound words" throw
-    ] unless ;
-
 : reset ( word -- )
-    dup check-compound
+    dup "unannotated-def" word-prop define ;
-    dup "unannotated-def" word-prop define-compound ;
 
 : annotate ( word quot -- )
-    over check-compound
     over dup word-def "unannotated-def" set-word-prop
-    [
+    [ >r dup word-def r> call define ] with-compilation-unit ;
-        >r dup word-def r> call define-compound
+    inline
-    ] with-compilation-unit ; inline
 
 : entering ( str -- )
     "/-- Entering: " write dup .

extra/tools/interpreter/interpreter.factor

@@ -41,10 +41,10 @@ M: pair restore
     dup "step-into" word-prop [
         call
     ] [
-        dup compound? [
+        dup primitive? [
-            word-def walk
-        ] [
             execute break
+        ] [
+            word-def walk
         ] if
     ] ?if ;
 

extra/ui/tools/operations/operations.factor

@@ -115,7 +115,7 @@ M: quotation com-stack-effect infer. ;
 
 M: word com-stack-effect word-def com-stack-effect ;
 
-[ compound? ] \ com-stack-effect H{
+[ word? ] \ com-stack-effect H{
     { +listener+ t }
 } define-operation
 

vm/code_gc.c

@@ -378,8 +378,7 @@ void forward_object_xts(void)
 		{
 			F_WORD *word = untag_object(obj);
 
-			if(word_references_code_heap_p(word))
+			word->code = forward_xt(word->code);
-				word->code = forward_xt(word->code);
 		}
 		else if(type_of(obj) == QUOTATION_TYPE)
 		{
@@ -411,11 +410,7 @@ void fixup_object_xts(void)
 		if(type_of(obj) == WORD_TYPE)
 		{
 			F_WORD *word = untag_object(obj);
-
+			update_word_xt(word);
-			if(word->compiledp != F)
-				set_word_xt(word,word->code);
-			else
-				word->xt = (void *)(word->code + 1);
 		}
 		else if(type_of(obj) == QUOTATION_TYPE)
 		{

vm/code_heap.c

@@ -36,13 +36,13 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start)
 		return undefined_symbol;
 }
 
-bool profiling_p_;
-
 /* 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)
 {
+	CELL obj;
 	F_WORD *word;
+	F_QUOTATION *quot;
 
 	switch(REL_TYPE(rel))
 	{
@@ -55,26 +55,27 @@ INLINE CELL compute_code_rel(F_REL *rel,
 	case RT_DISPATCH:
 		return CREF(words_start,REL_ARGUMENT(rel));
 	case RT_XT:
-		word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel))));
+		obj = get(CREF(words_start,REL_ARGUMENT(rel)));
-		if(word->code)
+		switch(type_of(obj))
 		{
-			return (CELL)word->code
+		case WORD_TYPE:
-				+ sizeof(F_COMPILED)
+			word = untag_object(obj);
-				+ (profiling_p_ ? 0 : word->code->profiler_prologue);
+			return (CELL)word->xt;
-		}
+		case QUOTATION_TYPE:
-		else
+			quot = untag_object(obj);
-		{
+			return (CELL)quot->xt;
-			/* Its only NULL in stage 2 early init */
+		default:
-			return 0;
+			critical_error("Bad parameter to rt-xt relocation",obj);
+			return -1; /* Can't happen */
 		}
 	case RT_XT_PROFILING:
 		word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel))));
-		return (CELL)word->code + sizeof(F_COMPILED);
+		return (CELL)(word->code + 1);
 	case RT_LABEL:
 		return code_start + REL_ARGUMENT(rel);
 	default:
 		critical_error("Bad rel type",rel->type);
-		return -1;
+		return -1; /* Can't happen */
 	}
 }
 
@@ -147,8 +148,6 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 {
 	if(reloc_start != literals_start)
 	{
-		profiling_p_ = profiling_p();
-
 		F_REL *rel = (F_REL *)reloc_start;
 		F_REL *rel_end = (F_REL *)literals_start;
 
@@ -186,20 +185,6 @@ void fixup_labels(F_ARRAY *labels, CELL code_format, CELL code_start)
 	}
 }
 
-/* After compiling a batch of words, we replace all mutual word references with
-direct XT references, and perform fixups */
-void finalize_code_block(F_COMPILED *relocating, CELL code_start,
-	CELL reloc_start, CELL literals_start, CELL words_start, CELL 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);
-}
-
 /* Write a sequence of integers to memory, with 'format' bytes per integer */
 void deposit_integers(CELL here, F_ARRAY *array, CELL format)
 {
@@ -252,7 +237,6 @@ CELL allot_code_block(CELL size)
 /* Might GC */
 F_COMPILED *add_compiled_block(
 	CELL type,
-	CELL profiler_prologue,
 	F_ARRAY *code,
 	F_ARRAY *labels,
 	F_ARRAY *relocation,
@@ -263,7 +247,7 @@ F_COMPILED *add_compiled_block(
 
 	CELL code_length = align8(array_capacity(code) * code_format);
 	CELL rel_length = array_capacity(relocation) * sizeof(unsigned int);
-	CELL words_length = array_capacity(words) * CELLS;
+	CELL words_length = (words ? array_capacity(words) * CELLS : 0);
 	CELL literals_length = array_capacity(literals) * CELLS;
 
 	REGISTER_UNTAGGED(code);
@@ -288,7 +272,6 @@ F_COMPILED *add_compiled_block(
 	header->reloc_length = rel_length;
 	header->literals_length = literals_length;
 	header->words_length = words_length;
-	header->profiler_prologue = profiler_prologue;
 
 	here += sizeof(F_COMPILED);
 
@@ -307,8 +290,11 @@ F_COMPILED *add_compiled_block(
 	here += literals_length;
 
 	/* words */
-	deposit_objects(here,words);
+	if(words)
-	here += words_length;
+	{
+		deposit_objects(here,words);
+		here += words_length;
+	}
 
 	/* fixup labels */
 	if(labels)
@@ -321,20 +307,26 @@ F_COMPILED *add_compiled_block(
 	return header;
 }
 
-void set_word_xt(F_WORD *word, F_COMPILED *compiled)
+void set_word_code(F_WORD *word, F_COMPILED *compiled)
 {
 	if(compiled->type != WORD_TYPE)
 		critical_error("bad param to set_word_xt",(CELL)compiled);
 
 	word->code = compiled;
-	word->xt = (XT)(compiled + 1);
-
-	if(!profiling_p())
-		word->xt += compiled->profiler_prologue;
-
 	word->compiledp = T;
 }
 
+/* Allocates memory */
+void default_word_code(F_WORD *word)
+{
+	REGISTER_UNTAGGED(word);
+	jit_compile(word->def);
+	UNREGISTER_UNTAGGED(word);
+
+	word->code = untag_quotation(word->def)->code;
+	word->compiledp = F;
+}
+
 DEFINE_PRIMITIVE(modify_code_heap)
 {
 	F_ARRAY *alist = untag_array(dpop());
@@ -356,38 +348,25 @@ DEFINE_PRIMITIVE(modify_code_heap)
 
 		if(data == F)
 		{
-			word->compiledp = F;
+			REGISTER_UNTAGGED(alist);
-
+			default_word_code(word);
-			if(type_of(word->def) == QUOTATION_TYPE)
+			UNREGISTER_UNTAGGED(alist);
-			{
-				REGISTER_UNTAGGED(alist);
-				REGISTER_UNTAGGED(word);
-
-				jit_compile(word->def);
-
-				UNREGISTER_UNTAGGED(word);
-				UNREGISTER_UNTAGGED(alist);
-			}
-
-			default_word_xt(word);
 		}
 		else
 		{
 			F_ARRAY *compiled_code = untag_array(data);
 
-			CELL profiler_prologue = to_cell(array_nth(compiled_code,0));
+			F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
-			F_ARRAY *literals = untag_array(array_nth(compiled_code,1));
+			F_ARRAY *words = untag_array(array_nth(compiled_code,1));
-			F_ARRAY *words = untag_array(array_nth(compiled_code,2));
+			F_ARRAY *relocation = untag_array(array_nth(compiled_code,2));
-			F_ARRAY *relocation = untag_array(array_nth(compiled_code,3));
+			F_ARRAY *labels = untag_array(array_nth(compiled_code,3));
-			F_ARRAY *labels = untag_array(array_nth(compiled_code,4));
+			F_ARRAY *code = untag_array(array_nth(compiled_code,4));
-			F_ARRAY *code = untag_array(array_nth(compiled_code,5));
 
 			REGISTER_UNTAGGED(alist);
 			REGISTER_UNTAGGED(word);
 
 			F_COMPILED *compiled = add_compiled_block(
 				WORD_TYPE,
-				profiler_prologue,
 				code,
 				labels,
 				relocation,
@@ -397,8 +376,12 @@ DEFINE_PRIMITIVE(modify_code_heap)
 			UNREGISTER_UNTAGGED(word);
 			UNREGISTER_UNTAGGED(alist);
 
-			set_word_xt(word,compiled);
+			set_word_code(word,compiled);
 		}
+
+		REGISTER_UNTAGGED(alist);
+		update_word_xt(word);
+		UNREGISTER_UNTAGGED(alist);
 	}
 
 	/* If there were any interned words in the set, we relocate all XT

vm/code_heap.h

@@ -56,11 +56,12 @@ 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 set_word_xt(F_WORD *word, F_COMPILED *compiled);
+void default_word_code(F_WORD *word);
+
+void set_word_code(F_WORD *word, F_COMPILED *compiled);
 
 F_COMPILED *add_compiled_block(
 	CELL type,
-	CELL profiler_prologue,
 	F_ARRAY *code,
 	F_ARRAY *labels,
 	F_ARRAY *rel,

vm/data_gc.c

@@ -521,7 +521,7 @@ 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 * 2;
+		return sizeof(F_WORD) - CELLS * 3;
 	case ALIEN_TYPE:
 		return CELLS * 3;
 	case DLL_TYPE:
@@ -534,17 +534,8 @@ CELL binary_payload_start(CELL pointer)
 	}
 }
 
-void collect_callstack_object(F_CALLSTACK *callstack)
+void do_code_slots(CELL scan)
 {
-	if(collecting_code)
-		iterate_callstack_object(callstack,collect_stack_frame);
-}
-
-CELL collect_next(CELL scan)
-{
-	do_slots(scan,copy_handle);
-
-	/* Special behaviors */
 	F_WORD *word;
 	F_QUOTATION *quot;
 	F_CALLSTACK *stack;
@@ -553,19 +544,28 @@ CELL collect_next(CELL scan)
 	{
 	case WORD_TYPE:
 		word = (F_WORD *)scan;
-		if(collecting_code && word_references_code_heap_p(word))
+		recursive_mark(compiled_to_block(word->code));
-			recursive_mark(compiled_to_block(word->code));
+		if(word->profiling)
+			recursive_mark(compiled_to_block(word->profiling));
 		break;
 	case QUOTATION_TYPE:
 		quot = (F_QUOTATION *)scan;
-		if(collecting_code && quot->compiledp != F)
+		if(quot->compiledp != F)
 			recursive_mark(compiled_to_block(quot->code));
 		break;
 	case CALLSTACK_TYPE:
 		stack = (F_CALLSTACK *)scan;
-		collect_callstack_object(stack);
+		iterate_callstack_object(stack,collect_stack_frame);
 		break;
 	}
+}
+
+CELL collect_next(CELL scan)
+{
+	do_slots(scan,copy_handle);
+
+	if(collecting_code)
+		do_code_slots(scan);
 
 	return scan + untagged_object_size(scan);
 }

vm/factor.c

@@ -35,8 +35,6 @@ void do_stage1_init(void)
 	fprintf(stderr,"*** Stage 2 early init... ");
 	fflush(stderr);
 
-	jit_compile(userenv[UNDEFINED_ENV]);
-
 	begin_scan();
 
 	CELL obj;
@@ -45,11 +43,8 @@ void do_stage1_init(void)
 		if(type_of(obj) == WORD_TYPE)
 		{
 			F_WORD *word = untag_object(obj);
-			if(type_of(word->def) == QUOTATION_TYPE)
+			default_word_code(word);
-			{
+			update_word_xt(word);
-				jit_compile(word->def);
-				default_word_xt(word);
-			}
 		}
 	}
 
@@ -79,6 +74,7 @@ void init_factor(F_PARAMETERS *p)
 	/* Disable GC during init as a sanity check */
 	gc_off = true;
 
+	/* OS-specific initialization */
 	early_init();
 
 	if(p->image == NULL)
@@ -92,16 +88,15 @@ void init_factor(F_PARAMETERS *p)
 	init_signals();
 
 	stack_chain = NULL;
+	profiling_p = false;
+	performing_gc = false;
+	last_code_heap_scan = NURSERY;
+	collecting_aging_again = false;
 
 	userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING));
 	userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING));
 	userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
 
-	performing_gc = false;
-	last_code_heap_scan = NURSERY;
-	collecting_aging_again = false;
-	stack_chain = NULL;
-
 	/* We can GC now */
 	gc_off = false;
 

vm/image.c

@@ -175,28 +175,12 @@ DEFINE_PRIMITIVE(save_image_and_exit)
 
 void fixup_word(F_WORD *word)
 {
-	/* If this is a compiled word, relocate the code pointer. Otherwise,
+	if(stage2)
-	reset it based on the primitive number of the word. */
-	if(word->compiledp == F)
 	{
-		if(type_of(word->def) == QUOTATION_TYPE)
+		code_fixup((CELL)&word->code);
-		{
+		if(word->profiling) code_fixup((CELL)&word->profiling);
-			if(!stage2)
+		update_word_xt(word);
-			{
-				/* Word XTs are fixed up in do_stage1_init() */
-				return;
-			}
-		}
-		else
-		{
-			/* Primitive */
-			default_word_xt(word);
-			return;
-		}
 	}
-
-	code_fixup((CELL)&word->xt);
-	code_fixup((CELL)&word->code);
 }
 
 void fixup_quotation(F_QUOTATION *quot)

vm/layouts.h

@@ -152,8 +152,7 @@ typedef struct
 	CELL reloc_length; /* # bytes */
 	CELL literals_length; /* # bytes */
 	CELL words_length; /* # bytes */
-	CELL profiler_prologue; /* # bytes */
+	CELL padding[3];
-	CELL padding[2];
 } F_COMPILED;
 
 /* Assembly code makes assumptions about the layout of this struct */
@@ -178,6 +177,8 @@ typedef struct {
 	XT xt;
 	/* UNTAGGED compiled code block */
 	F_COMPILED *code;
+	/* UNTAGGED profiler stub */
+	F_COMPILED *profiling;
 } F_WORD;
 
 /* Assembly code makes assumptions about the layout of this struct */

vm/profiler.c

@@ -1,31 +1,69 @@
 #include "master.h"
 
-bool profiling_p(void)
+/* Allocates memory */
+F_COMPILED *compile_profiling_stub(F_WORD *word)
 {
-	return to_boolean(userenv[PROFILING_ENV]);
+	CELL literals = allot_array_1(tag_object(word));
+	REGISTER_ROOT(literals);
+
+	F_ARRAY *quadruple = untag_object(userenv[JIT_PROFILING]);
+
+	CELL code = array_nth(quadruple,0);
+	REGISTER_ROOT(code);
+
+	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 relocation = allot_array_2(rel_type,rel_offset);
+
+	UNREGISTER_ROOT(code);
+	UNREGISTER_ROOT(literals);
+
+	return add_compiled_block(
+		WORD_TYPE,
+		untag_object(code),
+		NULL, /* no labels */
+		untag_object(relocation),
+		NULL, /* no words */
+		untag_object(literals));
 }
 
-void profiling_word(F_WORD *word)
+/* Allocates memory */
+void update_word_xt(F_WORD *word)
 {
 	/* If we just enabled the profiler, reset call count */
-	if(profiling_p())
+	if(profiling_p)
+	{
 		word->counter = tag_fixnum(0);
 
-	if(word->compiledp == F)
+		if(!word->profiling)
-		default_word_xt(word);
+		{
+			REGISTER_UNTAGGED(word);
+			F_COMPILED *profiling = compile_profiling_stub(word);
+			UNREGISTER_UNTAGGED(word);
+			word->profiling = profiling;
+		}
+
+		word->xt = (XT)(word->profiling + 1);
+
+		printf("%x\n",word->xt);
+	}
 	else
-		set_word_xt(word,word->code);
+		word->xt = (XT)(word->code + 1);
 }
 
 void set_profiling(bool profiling)
 {
-	if(profiling == profiling_p())
+	if(profiling == profiling_p)
 		return;
 
-	userenv[PROFILING_ENV] = tag_boolean(profiling);
+	profiling_p = profiling;
 
-	/* Push everything to tenured space so that we can heap scan */
+	/* Push everything to tenured space so that we can heap scan,
-	data_gc();
+	also code GC so that we can allocate profiling blocks if
+	necessary */
+	code_gc();
 
 	/* Update word XTs and saved callstack objects */
 	begin_scan();
@@ -34,7 +72,7 @@ void set_profiling(bool profiling)
 	while((obj = next_object()) != F)
 	{
 		if(type_of(obj) == WORD_TYPE)
-			profiling_word(untag_object(obj));
+			update_word_xt(untag_object(obj));
 	}
 
 	gc_off = false; /* end heap scan */

vm/profiler.h

@@ -1,2 +1,4 @@
-bool profiling_p(void);
+bool profiling_p;
 DECLARE_PRIMITIVE(profiling);
+F_COMPILED *compile_profiling_stub(F_WORD *word);
+void update_word_xt(F_WORD *word);

vm/quotations.c

@@ -3,6 +3,13 @@
 /* Simple JIT compiler. This is one of the two compilers implementing Factor;
 the second one is written in Factor and performs a lot of optimizations.
 See core/compiler/compiler.factor */
+bool jit_primitive_call_p(F_ARRAY *array, CELL i)
+{
+	return (i + 2) == array_capacity(array)
+		&& type_of(array_nth(array,i)) == FIXNUM_TYPE
+		&& array_nth(array,i + 1) == userenv[JIT_PRIMITIVE_WORD];
+}
+
 bool jit_fast_if_p(F_ARRAY *array, CELL i)
 {
 	return (i + 3) == array_capacity(array)
@@ -80,7 +87,7 @@ bool jit_stack_frame_p(F_ARRAY *array)
 void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code)
 {
 	if(code->type != QUOTATION_TYPE)
-		critical_error("bad param to set_word_xt",(CELL)code);
+		critical_error("bad param to set_quot_xt",(CELL)code);
 
 	quot->code = code;
 	quot->xt = (XT)(code + 1);
@@ -113,6 +120,7 @@ void jit_compile(CELL quot)
 	REGISTER_ROOT(words);
 
 	GROWABLE_ADD(literals,quot);
+	GROWABLE_ADD(words,quot);
 
 	bool stack_frame = jit_stack_frame_p(untag_object(array));
 
@@ -127,7 +135,6 @@ void jit_compile(CELL quot)
 	{
 		CELL obj = array_nth(untag_object(array),i);
 		F_WORD *word;
-		bool primitive_p;
 		F_WRAPPER *wrapper;
 
 		switch(type_of(obj))
@@ -137,45 +144,36 @@ void jit_compile(CELL quot)
 			so that we save the C stack pointer minus the
 			current stack frame. */
 			word = untag_object(obj);
-			primitive_p = type_of(word->def) == FIXNUM_TYPE;
+
+			GROWABLE_ADD(words,array_nth(untag_object(array),i));
 
 			if(i == length - 1)
 			{
 				if(stack_frame)
 					EMIT(JIT_EPILOG,0);
 
-				if(primitive_p)
+				EMIT(JIT_WORD_JUMP,words_count - 1);
-				{
-					EMIT(JIT_WORD_PRIMITIVE_JUMP,
-						to_fixnum(word->def));
-				}
-				else
-				{
-					GROWABLE_ADD(words,array_nth(untag_object(array),i));
-					EMIT(JIT_WORD_JUMP,words_count - 1);
-				}
 
 				tail_call = true;
 			}
 			else
-			{
+				EMIT(JIT_WORD_CALL,words_count - 1);
-				if(primitive_p)
-				{
-					EMIT(JIT_WORD_PRIMITIVE_CALL,
-						to_fixnum(word->def));
-				}
-				else
-				{
-					GROWABLE_ADD(words,array_nth(untag_object(array),i));
-					EMIT(JIT_WORD_CALL,words_count - 1);
-				}
-			}
 			break;
 		case WRAPPER_TYPE:
 			wrapper = untag_object(obj);
 			GROWABLE_ADD(literals,wrapper->object);
 			EMIT(JIT_PUSH_LITERAL,literals_count - 1);
 			break;
+		case FIXNUM_TYPE:
+			if(jit_primitive_call_p(untag_object(array),i))
+			{
+				EMIT(JIT_PRIMITIVE,to_fixnum(obj));
+
+				i++;
+
+				tail_call = true;
+				break;
+			}
 		case QUOTATION_TYPE:
 			if(jit_fast_if_p(untag_object(array),i))
 			{
@@ -227,17 +225,18 @@ void jit_compile(CELL quot)
 
 	F_COMPILED *compiled = add_compiled_block(
 		QUOTATION_TYPE,
-		0,
 		untag_object(code),
 		NULL,
 		untag_object(relocation),
 		untag_object(words),
 		untag_object(literals));
 
-	iterate_code_heap_step(compiled,relocate_code_block);
+	/* 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);
+
 	UNREGISTER_ROOT(words);
 	UNREGISTER_ROOT(literals);
 	UNREGISTER_ROOT(relocation);
@@ -287,24 +286,26 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
 				if(stack_frame)
 					COUNT(JIT_EPILOG,i);
 
-				if(type_of(word->def) == FIXNUM_TYPE)
+				COUNT(JIT_WORD_JUMP,i)
-					COUNT(JIT_WORD_PRIMITIVE_JUMP,i)
-				else
-					COUNT(JIT_WORD_JUMP,i)
 
 				tail_call = true;
 			}
 			else
-			{
+				COUNT(JIT_WORD_CALL,i)
-				if(type_of(word->def) == FIXNUM_TYPE)
-					COUNT(JIT_WORD_PRIMITIVE_CALL,i)
-				else
-					COUNT(JIT_WORD_CALL,i)
-			}
 			break;
 		case WRAPPER_TYPE:
 			COUNT(JIT_PUSH_LITERAL,i)
 			break;
+		case FIXNUM_TYPE:
+			if(jit_primitive_call_p(untag_object(array),i))
+			{
+				COUNT(JIT_PRIMITIVE,i);
+
+				i++;
+
+				tail_call = true;
+				break;
+			}
 		case QUOTATION_TYPE:
 			if(jit_fast_if_p(untag_object(array),i))
 			{

vm/run.c

@@ -259,22 +259,6 @@ DEFINE_PRIMITIVE(set_retainstack)
 	rs = array_to_stack(untag_array(dpop()),rs_bot);
 }
 
-void default_word_xt(F_WORD *word)
-{
-	if(type_of(word->def) == QUOTATION_TYPE)
-	{
-		F_QUOTATION *quot = untag_quotation(word->def);
-		if(quot->compiledp == F)
-			critical_error("default_word_xt invariant lost",0);
-		word->xt = quot->xt;
-		word->code = quot->code;
-	}
-	else if(type_of(word->def) == FIXNUM_TYPE)
-		word->xt = primitives[to_fixnum(word->def)];
-	else
-		critical_error("bad word-def",tag_object(word));
-}
-
 DEFINE_PRIMITIVE(getenv)
 {
 	F_FIXNUM e = untag_fixnum_fast(dpeek());

vm/run.h

@@ -35,8 +35,8 @@ typedef enum {
 	/* Used by the JIT compiler */
 	JIT_CODE_FORMAT     = 22,
 	JIT_PROLOG,
-	JIT_WORD_PRIMITIVE_JUMP,
+	JIT_PRIMITIVE_WORD,
-	JIT_WORD_PRIMITIVE_CALL,
+	JIT_PRIMITIVE,
 	JIT_WORD_JUMP,
 	JIT_WORD_CALL,
 	JIT_PUSH_LITERAL,
@@ -46,9 +46,9 @@ typedef enum {
 	JIT_DISPATCH,
 	JIT_EPILOG,
 	JIT_RETURN,
+	JIT_PROFILING,
 
 	UNDEFINED_ENV       = 37, /* default quotation for undefined words */
-	PROFILING_ENV       = 38, /* is the profiler on? */
 	STAGE2_ENV          = 39  /* have we bootstrapped? */
 } F_ENVTYPE;
 
@@ -220,9 +220,6 @@ DECLARE_PRIMITIVE(to_r);
 DECLARE_PRIMITIVE(from_r);
 DECLARE_PRIMITIVE(datastack);
 DECLARE_PRIMITIVE(retainstack);
-
-void default_word_xt(F_WORD *word);
-
 DECLARE_PRIMITIVE(execute);
 DECLARE_PRIMITIVE(call);
 DECLARE_PRIMITIVE(getenv);

vm/types.c

@@ -164,6 +164,15 @@ DEFINE_PRIMITIVE(to_tuple)
 	drepl(object);
 }
 
+CELL allot_array_1(CELL obj)
+{
+	REGISTER_ROOT(obj);
+	F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1);
+	UNREGISTER_ROOT(obj);
+	set_array_nth(a,0,obj);
+	return tag_object(a);
+}
+
 CELL allot_array_2(CELL v1, CELL v2)
 {
 	REGISTER_ROOT(v1);
@@ -198,7 +207,7 @@ F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill)
 {
 	int i;
 	F_ARRAY* new_array;
-	
+
 	CELL to_copy = array_capacity(array);
 	if(capacity < to_copy)
 		to_copy = capacity;
@@ -212,7 +221,7 @@ F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill)
 	UNREGISTER_UNTAGGED(array);
 
 	memcpy(new_array + 1,array + 1,to_copy * CELLS);
-	
+
 	for(i = to_copy; i < capacity; i++)
 		set_array_nth(new_array,i,fill);
 
@@ -484,7 +493,6 @@ DEFINE_PRIMITIVE(hashtable)
 	dpush(tag_object(hash));
 }
 
-/* <word> ( name vocabulary -- word ) */
 F_WORD *allot_word(CELL vocab, CELL name)
 {
 	REGISTER_ROOT(vocab);
@@ -492,6 +500,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
 	F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
 	UNREGISTER_ROOT(name);
 	UNREGISTER_ROOT(vocab);
+
 	word->hashcode = tag_fixnum(rand());
 	word->vocabulary = vocab;
 	word->name = name;
@@ -499,10 +508,20 @@ F_WORD *allot_word(CELL vocab, CELL name)
 	word->props = F;
 	word->counter = tag_fixnum(0);
 	word->compiledp = F;
-	default_word_xt(word);
+	word->profiling = NULL;
+
+	REGISTER_UNTAGGED(word);
+	default_word_code(word);
+	UNREGISTER_UNTAGGED(word);
+
+	REGISTER_UNTAGGED(word);
+	update_word_xt(word);
+	UNREGISTER_UNTAGGED(word);
+
 	return word;
 }
 
+/* <word> ( name vocabulary -- word ) */
 DEFINE_PRIMITIVE(word)
 {
 	CELL vocab = dpop();
@@ -510,6 +529,7 @@ DEFINE_PRIMITIVE(word)
 	dpush(tag_object(allot_word(vocab,name)));
 }
 
+/* word-xt ( word -- xt ) */
 DEFINE_PRIMITIVE(word_xt)
 {
 	F_WORD *word = untag_word(dpeek());

vm/types.h

@@ -109,11 +109,6 @@ INLINE F_QUOTATION *untag_quotation(CELL tagged)
 	return untag_object(tagged);
 }
 
-INLINE bool word_references_code_heap_p(F_WORD *word)
-{
-	return (word->compiledp != F || type_of(word->def) == QUOTATION_TYPE);
-}
-
 INLINE F_WORD *untag_word(CELL tagged)
 {
 	type_check(WORD_TYPE,tagged);
@@ -133,6 +128,7 @@ F_ARRAY *allot_array_internal(CELL type, CELL capacity);
 F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill);
 F_BYTE_ARRAY *allot_byte_array(CELL size);
 
+CELL allot_array_1(CELL obj);
 CELL allot_array_2(CELL v1, CELL v2);
 CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4);