steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Redo the profiler

db4
Slava Pestov 2008-01-02 20:36:36 -04:00
parent e35ca18921
commit b7327b6228
59 changed files with 388 additions and 460 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/alien/c-types/c-types.factor
View File

@ -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>

1
core/alien/compiler/compiler.factor
View File

@ -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

2
core/alien/syntax/syntax-docs.factor
View File

@ -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:"

2
core/alien/syntax/syntax.factor
View File

@ -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*

1
core/bootstrap/compiler/compiler.factor
View File

@ -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

25
core/bootstrap/image/image.factor
View File

@ -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 ;

6
core/bootstrap/primitives.factor
View File

@ -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

2
core/classes/classes-docs.factor Normal file → Executable file
View File

@ -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" }

4
core/classes/classes-tests.factor
View File

@ -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

3
core/classes/classes.factor
View File

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

22
core/compiler/constants/constants.factor Executable file
View File

@ -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 ;

13
core/cpu/architecture/architecture.factor
View File

@ -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 ;

2
core/cpu/arm/allot/allot.factor
View File

@ -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
;

2
core/cpu/arm/architecture/architecture.factor
View File

@ -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

2
core/cpu/ppc/allot/allot.factor
View File

@ -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
;

2
core/cpu/ppc/architecture/architecture.factor
View File

@ -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

2
core/cpu/x86/32/32.factor
View File

@ -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 [

2
core/cpu/x86/allot/allot.factor
View File

@ -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

21
core/cpu/x86/architecture/architecture.factor
View File

@ -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

29
core/cpu/x86/bootstrap.factor
View File

@ -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

8
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -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

7
core/generator/fixup/fixup.factor Normal file → Executable file
View File

@ -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 -- )

50
core/generator/generator.factor
View File

@ -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 ;

7
core/generic/generic.factor
View File

@ -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

28
core/inference/backend/backend.factor
View File

@ -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

3
core/inference/class/class-tests.factor
View File

@ -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?

7
core/inference/inference-tests.factor
View File

@ -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

4
core/inference/known-words/known-words.factor
View File

@ -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

2
core/kernel/kernel.factor
View File

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

6
core/layouts/layouts-docs.factor Normal file → Executable file
View File

@ -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" } } ;

2
core/layouts/layouts.factor Normal file → Executable file
View File

@ -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 )

8
core/prettyprint/prettyprint-tests.factor
View File

@ -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 ] [

2
core/prettyprint/sections/sections-docs.factor Normal file → Executable file
View File

@ -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." } ;

6
core/slots/slots.factor Normal file → Executable file
View File

@ -25,8 +25,7 @@ C: <slot-spec> 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 <effect> ;
PREDICATE: compound slot-writer
"writing" word-prop >boolean ;
PREDICATE: word slot-writer "writing" word-prop >boolean ;
: set-writer-props ( class spec -- )
2dup writer-effect

4
core/syntax/syntax-docs.factor
View File

@ -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 ";" }

5
core/syntax/syntax.factor
View File

@ -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:" [

4
core/vocabs/loader/loader-tests.factor
View File

@ -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

63
core/words/words-docs.factor
View File

@ -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 } "." } ;

18
core/words/words-tests.factor
View File

@ -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

32
core/words/words.factor
View File

@ -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 <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 ;

5
extra/help/handbook/handbook.factor
View File

@ -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." }
}

5
extra/macros/macros.factor
View File

@ -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: \ ; ;

14
extra/tools/annotations/annotations.factor
View File

@ -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 .

6
extra/tools/interpreter/interpreter.factor
View File

@ -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 ;

2
extra/ui/tools/operations/operations.factor
View File

@ -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

9
vm/code_gc.c
View File

@ -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)
{

109
vm/code_heap.c
View File

@ -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

5
vm/code_heap.h
View File

@ -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,

30
vm/data_gc.c
View File

@ -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);
}

19
vm/factor.c
View File

@ -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;

24
vm/image.c
View File

@ -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)

5
vm/layouts.h
View File

@ -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 */

62
vm/profiler.c
View File

@ -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 */

4
vm/profiler.h Normal file → Executable file
View File

@ -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);

77
vm/quotations.c
View File

@ -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))
{

16
vm/run.c
View File

@ -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());

9
vm/run.h
View File

@ -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);

28
vm/types.c
View File

@ -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());

6
vm/types.h
View File

@ -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);