diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index f35981ce77..91a2e6efaa 100755 --- a/core/alien/c-types/c-types.factor +++ b/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 ; : ( getter setter width boxer unboxer -- type ) diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 85b66bc9e5..51240a66d9 100755 --- a/core/alien/compiler/compiler.factor +++ b/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 diff --git a/core/alien/syntax/syntax-docs.factor b/core/alien/syntax/syntax-docs.factor index 82f1ea3b78..d87b67eb59 100755 --- a/core/alien/syntax/syntax-docs.factor +++ b/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:" diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 12bf0c5cb9..99275d02bf 100755 --- a/core/alien/syntax/syntax.factor +++ b/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* diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 09da7f6af4..902c406158 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/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 diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 0052dd34f2..84e0f6ed1e 100755 --- a/core/bootstrap/image/image.factor +++ b/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-word-primitive-call +SYMBOL: jit-primitive-word +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-word-primitive-call 25 } + { jit-primitive-word 24 } + { 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-word-primitive-call + jit-primitive-word + 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 ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 702cc3e47d..586d4c0dfa 100755 --- a/core/bootstrap/primitives.factor +++ b/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 diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor old mode 100644 new mode 100755 index 130844e797..6cc08e9f8f --- a/core/classes/classes-docs.factor +++ b/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" } diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 00bf3262aa..592691f6c7 100755 --- a/core/classes/classes-tests.factor +++ b/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 -[ f ] [ \ compound \ generic class< ] unit-test +[ t ] [ \ generic \ word class< ] unit-test +[ f ] [ \ word \ generic class< ] unit-test [ f ] [ \ reversed \ slice class< ] unit-test [ f ] [ \ slice \ reversed class< ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index ee5dd2c7e9..ac40bc3a1a 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -27,8 +27,7 @@ PREDICATE: class tuple-class : predicate-effect 1 { "?" } ; -PREDICATE: compound predicate - "predicating" word-prop >boolean ; +PREDICATE: word predicate "predicating" word-prop >boolean ; : define-predicate ( class predicate quot -- ) over [ diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor new file mode 100755 index 0000000000..3de32ab7fa --- /dev/null +++ b/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 ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 538f17d2e0..3550dcadc0 100755 --- a/core/cpu/architecture/architecture.factor +++ b/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 ; diff --git a/core/cpu/arm/allot/allot.factor b/core/cpu/arm/allot/allot.factor index 41a5cab91e..27a4676926 100755 --- a/core/cpu/arm/allot/allot.factor +++ b/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 ; diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 4e693bbe34..8742a693cb 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/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 diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index a8c26d36bf..df0a08a86d 100755 --- a/core/cpu/ppc/allot/allot.factor +++ b/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 ; diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 43a2428d42..8bd9ca505d 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/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 diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index ddc72a0453..1104915a9e 100755 --- a/core/cpu/x86/32/32.factor +++ b/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 [ diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index f32bda7d2c..f837a92504 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/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 diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index d059afe9f2..5195981657 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/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 diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index be5275811c..af54b4dd7c 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/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 - arg1 arg0 quot-xt@ [+] MOV ! load XT + ! Load word + 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 - -[ - 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 +] rc-relative rt-primitive 3 jit-primitive jit-define [ (JMP) drop diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index d1a851b553..9f6fb5d3b0 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/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 diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor old mode 100644 new mode 100755 index 8730258d6d..393d0749ad --- a/core/generator/fixup/fixup.factor +++ b/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 -- ) - -M: primitive rel-word ( word class -- ) - >r word-def r> rt-primitive rel-fixup ; - -M: word rel-word ( word class -- ) +: rel-word ( word class -- ) >r add-word r> rt-xt rel-fixup ; : rel-literal ( literal class -- ) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index e085087da0..a33b0650ef 100755 --- a/core/generator/generator.factor +++ b/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 -- ) - 6array swap compiled get set-at ; +: finish-compiling ( word literals words relocation labels code -- ) + 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 -- ) - dup primitive? [ %call-primitive ] [ %call-label ] if ; +: %call ( word -- ) %call-label ; : %jump ( word -- ) - { - { [ dup compiling-label get eq? ] [ - drop current-label-start get %jump-label - ] } - { [ dup primitive? ] [ - %epilogue-later %jump-primitive - ] } - { [ t ] [ - %epilogue-later %jump-label - ] } - } cond ; + dup compiling-label get eq? [ + drop current-label-start get %jump-label + ] [ + %epilogue-later %jump-label + ] if ; : 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 ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index ed84c0fbd9..d57c4500e2 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -5,8 +5,7 @@ definitions kernel.private classes classes.private quotations arrays vocabs ; IN: generic -PREDICATE: compound generic ( word -- ? ) - "combination" word-prop >boolean ; +PREDICATE: word generic "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 "combination" word-prop perform-combination - define-compound ; + dup dup "combination" word-prop perform-combination define ; : init-methods ( word -- ) dup "methods" word-prop diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 862c86cce9..5003336164 100755 --- a/core/inference/backend/backend.factor +++ b/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 - dup word-def over dup infer-quot-recursive - finish-word - current-effect - ] with-scope ; - -M: compound infer-word - [ infer-compound ] [ ] [ t "no-effect" set-word-prop ] - cleanup ; + [ + init-inference + dependencies off + dup word-def over dup infer-quot-recursive + finish-word + current-effect + ] with-scope + ] [ ] [ 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 diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index c7289b110a..41f48e5521 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -141,8 +141,7 @@ DEFER: blah [ t ] [ [ \ blah - [ dup V{ } eq? [ foo ] when ] dup second dup push - define-compound + [ dup V{ } eq? [ foo ] when ] dup second dup push define ] with-compilation-unit \ blah compiled? diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 9ee2953445..f5ad256ec5 100755 --- a/core/inference/inference-tests.factor +++ b/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 -classes.union classes.predicate debugger bootstrap.image -bootstrap.image.private threads.private -io.streams.string combinators.private tools.test.inference ; +prettyprint io inspector tuples classes.union classes.predicate +debugger threads.private io.streams.string combinators.private +tools.test.inference ; IN: temporary { 0 2 } [ 2 "Hello" ] unit-test-effect diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index d0d23fe3db..747eeed673 100755 --- a/core/inference/known-words/known-words.factor +++ b/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 } { } "inferred-effect" set-word-prop \ (os-envs) { } { array } "inferred-effect" set-word-prop + +\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 625c31eba1..2a0f46b72c 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -159,4 +159,6 @@ GENERIC: construct-boa ( ... class -- tuple ) : declare ( spec -- ) drop ; +: do-primitive ( number -- ) "Improper primitive call" throw ; + PRIVATE> diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor old mode 100644 new mode 100755 index dccd13780f..0ce4c9bb73 --- a/core/layouts/layouts-docs.factor +++ b/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 -{ $values { "n" "a built-in type number" } { "tagged" integer } } -{ $description "Outputs the header for objects of type " { $snippet "n" } "." } ; +HELP: tag-fixnum +{ $values { "n" integer } { "tagged" integer } } +{ $description "Outputs a tagged fixnum." } ; HELP: first-bignum { $values { "n" "smallest positive integer not representable by a fixnum" } } ; diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor old mode 100644 new mode 100755 index 31e182eac9..2f8b158bbf --- a/core/layouts/layouts.factor +++ b/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 ) diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 700c7ea33c..0d7b19c837 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/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>" - " define-compound ;" + " >r [ define ] map r>" + " define ;" } ; [ t ] [ diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor old mode 100644 new mode 100755 index ad47dc0664..9833a7e50a --- a/core/prettyprint/sections/sections-docs.factor +++ b/core/prettyprint/sections/sections-docs.factor @@ -211,7 +211,7 @@ HELP: slot-spec [ drop ] [ 1array , \ declare , ] if ] [ ] make ; -PREDICATE: compound slot-reader - "reading" word-prop >boolean ; +PREDICATE: word slot-reader "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 ; -PREDICATE: compound slot-writer - "writing" word-prop >boolean ; +PREDICATE: word slot-writer "writing" word-prop >boolean ; : set-writer-props ( class spec -- ) 2dup writer-effect diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 9f6509989b..9cf9647e41 100755 --- a/core/syntax/syntax-docs.factor +++ b/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 ";" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 552c7480a3..85abd228cb 100755 --- a/core/syntax/syntax.factor +++ b/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 - t "parsing" set-word-prop ; + >r "syntax" lookup dup r> define 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:" [ diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 8a4d17c185..82e3187c75 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/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 diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 82dce8a241..8d7d5b179b 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -26,18 +26,19 @@ $nl { $subsection gensym } { $subsection define-temp } ; -ARTICLE: "colon-definition" "Compound definitions" -"A compound definition associates a word name with a quotation that is called when the word is executed." -{ $subsection compound } -{ $subsection compound? } -"Defining compound words at parse time:" +ARTICLE: "colon-definition" "Word definitions" +"Every word has an associated quotation definition that is called when the word is executed." +$nl +"Defining words at parse time:" { $subsection POSTPONE: : } { $subsection POSTPONE: ; } -"Defining compound words at run time:" -{ $subsection define-compound } +"Defining words at run time:" +{ $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 } "." } ; diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 84297e630d..90108ef01a 100755 --- a/core/words/words-tests.factor +++ b/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 diff --git a/core/words/words.factor b/core/words/words.factor index d365ffd1db..158ed7ec68 100755 --- a/core/words/words.factor +++ b/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: compound definer drop \ : \ ; ; - -M: compound definition word-def ; +M: word 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 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 ; - - -: 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 ; : 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 ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 30f8d0f29f..a66c1cd31b 100755 --- a/extra/help/handbook/handbook.factor +++ b/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 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 word } " - the word's definition quotation is called. See " { $link "words" } } { "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." } } diff --git a/extra/macros/macros.factor b/extra/macros/macros.factor index 1c23a1c85e..586156c040 100755 --- a/extra/macros/macros.factor +++ b/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 - "macro" word-prop >boolean ; +PREDICATE: word macro "macro" word-prop >boolean ; M: macro definer drop \ MACRO: \ ; ; diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index 5406208510..45826724ca 100755 --- a/extra/tools/annotations/annotations.factor +++ b/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-compound ; + dup "unannotated-def" word-prop define ; : annotate ( word quot -- ) - over check-compound over dup word-def "unannotated-def" set-word-prop - [ - >r dup word-def r> call define-compound - ] with-compilation-unit ; inline + [ >r dup word-def r> call define ] with-compilation-unit ; + inline : entering ( str -- ) "/-- Entering: " write dup . diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor index 53de43b7e5..f438bcd8df 100755 --- a/extra/tools/interpreter/interpreter.factor +++ b/extra/tools/interpreter/interpreter.factor @@ -41,10 +41,10 @@ M: pair restore dup "step-into" word-prop [ call ] [ - dup compound? [ - word-def walk - ] [ + dup primitive? [ execute break + ] [ + word-def walk ] if ] ?if ; diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index 10cc268124..089a3503fd 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/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 diff --git a/vm/code_gc.c b/vm/code_gc.c index 7d340f21b0..4c5e3c436f 100755 --- a/vm/code_gc.c +++ b/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); - - if(word->compiledp != F) - set_word_xt(word,word->code); - else - word->xt = (void *)(word->code + 1); + update_word_xt(word); } else if(type_of(obj) == QUOTATION_TYPE) { diff --git a/vm/code_heap.c b/vm/code_heap.c index 3f75153baa..9619e0f640 100755 --- a/vm/code_heap.c +++ b/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)))); - if(word->code) + obj = get(CREF(words_start,REL_ARGUMENT(rel))); + switch(type_of(obj)) { - return (CELL)word->code - + sizeof(F_COMPILED) - + (profiling_p_ ? 0 : word->code->profiler_prologue); - } - else - { - /* Its only NULL in stage 2 early init */ - return 0; + case WORD_TYPE: + word = untag_object(obj); + return (CELL)word->xt; + case QUOTATION_TYPE: + quot = untag_object(obj); + return (CELL)quot->xt; + default: + 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); - here += words_length; + if(words) + { + 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; - - if(type_of(word->def) == QUOTATION_TYPE) - { - REGISTER_UNTAGGED(alist); - REGISTER_UNTAGGED(word); - - jit_compile(word->def); - - UNREGISTER_UNTAGGED(word); - UNREGISTER_UNTAGGED(alist); - } - - default_word_xt(word); + REGISTER_UNTAGGED(alist); + default_word_code(word); + UNREGISTER_UNTAGGED(alist); } 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,1)); - F_ARRAY *words = 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,4)); - F_ARRAY *code = untag_array(array_nth(compiled_code,5)); + F_ARRAY *literals = untag_array(array_nth(compiled_code,0)); + F_ARRAY *words = untag_array(array_nth(compiled_code,1)); + F_ARRAY *relocation = untag_array(array_nth(compiled_code,2)); + F_ARRAY *labels = untag_array(array_nth(compiled_code,3)); + F_ARRAY *code = untag_array(array_nth(compiled_code,4)); 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 diff --git a/vm/code_heap.h b/vm/code_heap.h index e187f72a4c..4169a0df2f 100755 --- a/vm/code_heap.h +++ b/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, diff --git a/vm/data_gc.c b/vm/data_gc.c index 876b30084a..4826c1d1ea 100755 --- a/vm/data_gc.c +++ b/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); } diff --git a/vm/factor.c b/vm/factor.c index 76c4acc4b9..105fec17e9 100755 --- a/vm/factor.c +++ b/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) - { - jit_compile(word->def); - default_word_xt(word); - } + default_word_code(word); + update_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; diff --git a/vm/image.c b/vm/image.c index 8fc99d7cd9..0f80303749 100755 --- a/vm/image.c +++ b/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, - reset it based on the primitive number of the word. */ - if(word->compiledp == F) + if(stage2) { - if(type_of(word->def) == QUOTATION_TYPE) - { - if(!stage2) - { - /* Word XTs are fixed up in do_stage1_init() */ - return; - } - } - else - { - /* Primitive */ - default_word_xt(word); - return; - } + code_fixup((CELL)&word->code); + if(word->profiling) code_fixup((CELL)&word->profiling); + update_word_xt(word); } - - code_fixup((CELL)&word->xt); - code_fixup((CELL)&word->code); } void fixup_quotation(F_QUOTATION *quot) diff --git a/vm/layouts.h b/vm/layouts.h index 41574ff2f4..7c6d775209 100755 --- a/vm/layouts.h +++ b/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[2]; + CELL padding[3]; } 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 */ diff --git a/vm/profiler.c b/vm/profiler.c index c42c6925a9..ec4374db52 100755 --- a/vm/profiler.c +++ b/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) - default_word_xt(word); + if(!word->profiling) + { + 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 */ - data_gc(); + /* Push everything to tenured space so that we can heap scan, + 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 */ diff --git a/vm/profiler.h b/vm/profiler.h old mode 100644 new mode 100755 index 5cb7ea1856..d14ceb283b --- a/vm/profiler.h +++ b/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); diff --git a/vm/quotations.c b/vm/quotations.c index 2468e58822..1010eaf0b0 100755 --- a/vm/quotations.c +++ b/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_PRIMITIVE_JUMP, - to_fixnum(word->def)); - } - else - { - GROWABLE_ADD(words,array_nth(untag_object(array),i)); - EMIT(JIT_WORD_JUMP,words_count - 1); - } + EMIT(JIT_WORD_JUMP,words_count - 1); tail_call = true; } else - { - 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); - } - } + 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_PRIMITIVE_JUMP,i) - else - COUNT(JIT_WORD_JUMP,i) + COUNT(JIT_WORD_JUMP,i) tail_call = true; } else - { - if(type_of(word->def) == FIXNUM_TYPE) - COUNT(JIT_WORD_PRIMITIVE_CALL,i) - else - COUNT(JIT_WORD_CALL,i) - } + 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)) { diff --git a/vm/run.c b/vm/run.c index c5f16ac190..2e541a5b6c 100755 --- a/vm/run.c +++ b/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()); diff --git a/vm/run.h b/vm/run.h index f7668483ba..dcb3e76bb5 100755 --- a/vm/run.h +++ b/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_WORD_PRIMITIVE_CALL, + JIT_PRIMITIVE_WORD, + 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); diff --git a/vm/types.c b/vm/types.c index b5bf1a7449..70d754caea 100755 --- a/vm/types.c +++ b/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)); } -/* ( 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; } +/* ( 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()); diff --git a/vm/types.h b/vm/types.h index 38be4b8902..c896b69eba 100755 --- a/vm/types.h +++ b/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);