BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
-CFLAGS = -Wall
+CFLAGS = -Wall -Werror
FFI_TEST_CFLAGS = -fPIC
ifdef DEBUG
- CFLAGS += -g
+ CFLAGS += -g -DFACTOR_DEBUG
else
CFLAGS += -O3
endif
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/alien.o \
+ vm/arrays.o \
vm/bignum.o \
+ vm/booleans.o \
+ vm/byte_arrays.o \
vm/callstack.o \
vm/code_block.o \
vm/code_gc.o \
vm/data_gc.o \
vm/data_heap.o \
vm/debug.o \
+ vm/dispatch.o \
vm/errors.o \
vm/factor.o \
vm/image.o \
+ vm/inline_cache.o \
vm/io.o \
+ vm/jit.o \
vm/math.o \
vm/primitives.o \
vm/profiler.o \
vm/quotations.o \
vm/run.o \
- vm/types.o \
- vm/utilities.o
+ vm/strings.o \
+ vm/tuples.o \
+ vm/utilities.o \
+ vm/words.o
EXE_OBJS = $(PLAF_EXE_OBJS)
.m.o:
$(CC) -c $(CFLAGS) -o $@ $<
-
+
.PHONY: factor
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
- dup optimized>> [ execute ] [ drop f ] if ; inline
+ dup optimized? [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
\ eval-callback ?callback 16 setenv
classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io
-io.encodings.string libc splitting math.parser
+io.encodings.string libc splitting math.parser memory
compiler.units math.order compiler.tree.builder
compiler.tree.optimizer compiler.cfg.optimizer ;
IN: bootstrap.compiler
enable-compiler
+! Push all tuple layouts to tenured space to improve method caching
+gc
+
: compile-unoptimized ( words -- )
- [ optimized>> not ] filter compile ;
+ [ optimized? not ] filter compile ;
nl
"Compiling..." write flush
USING: alien arrays byte-arrays generic assocs hashtables assocs
hashtables.private io io.binary io.files io.encodings.binary
io.pathnames kernel kernel.private math namespaces make parser
-prettyprint sequences sequences.private strings sbufs
-vectors words quotations assocs system layouts splitting
-grouping growable classes classes.builtin classes.tuple
-classes.tuple.private words.private vocabs
-vocabs.loader source-files definitions debugger
-quotations.private sequences.private combinators
-math.order math.private accessors
-slots.private compiler.units fry ;
+prettyprint sequences sequences.private strings sbufs vectors words
+quotations assocs system layouts splitting grouping growable classes
+classes.builtin classes.tuple classes.tuple.private vocabs
+vocabs.loader source-files definitions debugger quotations.private
+sequences.private combinators math.order math.private accessors
+slots.private generic.single.private compiler.units compiler.constants
+fry ;
IN: bootstrap.image
: arch ( os cpu -- arch )
SYMBOL: sub-primitives
-: make-jit ( quot rc rt offset -- quad )
- [ [ call( -- ) ] { } make ] 3dip 4array ;
+SYMBOL: jit-define-rc
+SYMBOL: jit-define-rt
+SYMBOL: jit-define-offset
-: jit-define ( quot rc rt offset name -- )
+: compute-offset ( -- offset )
+ building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
+
+: jit-rel ( rc rt -- )
+ jit-define-rt set
+ jit-define-rc set
+ compute-offset jit-define-offset set ;
+
+: make-jit ( quot -- quad )
+ [
+ call( -- )
+ jit-define-rc get
+ jit-define-rt get
+ jit-define-offset get 3array
+ ] B{ } make prefix ;
+
+: jit-define ( quot name -- )
[ make-jit ] dip set ;
-: define-sub-primitive ( quot rc rt offset word -- )
+: define-sub-primitive ( quot word -- )
[ make-jit ] dip sub-primitives get set-at ;
! The image being constructed; a vector of word-size integers
SYMBOL: bootstrap-boot-quot
! JIT parameters
-SYMBOL: jit-code-format
SYMBOL: jit-prolog
SYMBOL: jit-primitive-word
SYMBOL: jit-primitive
SYMBOL: jit-if-word
SYMBOL: jit-if-1
SYMBOL: jit-if-2
-SYMBOL: jit-dispatch-word
-SYMBOL: jit-dispatch
SYMBOL: jit-dip-word
SYMBOL: jit-dip
SYMBOL: jit-2dip-word
SYMBOL: jit-2dip
SYMBOL: jit-3dip-word
SYMBOL: jit-3dip
+SYMBOL: jit-execute-word
+SYMBOL: jit-execute-jump
+SYMBOL: jit-execute-call
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
-SYMBOL: jit-declare-word
SYMBOL: jit-save-stack
+! PIC stubs
+SYMBOL: pic-load
+SYMBOL: pic-tag
+SYMBOL: pic-hi-tag
+SYMBOL: pic-tuple
+SYMBOL: pic-hi-tag-tuple
+SYMBOL: pic-check-tag
+SYMBOL: pic-check
+SYMBOL: pic-hit
+SYMBOL: pic-miss-word
+
+! Megamorphic dispatch
+SYMBOL: mega-lookup
+SYMBOL: mega-lookup-word
+SYMBOL: mega-miss-word
+
! Default definition for undefined words
SYMBOL: undefined-quot
H{
{ bootstrap-boot-quot 20 }
{ bootstrap-global 21 }
- { jit-code-format 22 }
{ jit-prolog 23 }
{ jit-primitive-word 24 }
{ jit-primitive 25 }
{ jit-if-word 28 }
{ jit-if-1 29 }
{ jit-if-2 30 }
- { jit-dispatch-word 31 }
- { jit-dispatch 32 }
{ jit-epilog 33 }
{ jit-return 34 }
{ jit-profiling 35 }
{ jit-push-immediate 36 }
- { jit-declare-word 42 }
- { jit-save-stack 43 }
- { jit-dip-word 44 }
- { jit-dip 45 }
- { jit-2dip-word 46 }
- { jit-2dip 47 }
- { jit-3dip-word 48 }
- { jit-3dip 49 }
+ { jit-save-stack 38 }
+ { jit-dip-word 39 }
+ { jit-dip 40 }
+ { jit-2dip-word 41 }
+ { jit-2dip 42 }
+ { jit-3dip-word 43 }
+ { jit-3dip 44 }
+ { jit-execute-word 45 }
+ { jit-execute-jump 46 }
+ { jit-execute-call 47 }
+ { pic-load 48 }
+ { pic-tag 49 }
+ { pic-hi-tag 50 }
+ { pic-tuple 51 }
+ { pic-hi-tag-tuple 52 }
+ { pic-check-tag 53 }
+ { pic-check 54 }
+ { pic-hit 55 }
+ { pic-miss-word 56 }
+ { mega-lookup 57 }
+ { mega-lookup-word 58 }
+ { mega-miss-word 59 }
{ undefined-quot 60 }
} ; inline
: emit-fixnum ( n -- ) tag-fixnum emit ;
-: emit-object ( header tag quot -- addr )
- swap here-as [ swap tag-fixnum emit call align-here ] dip ;
+: emit-object ( class quot -- addr )
+ over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
inline
! Write an object to the image.
M: bignum '
[
- bignum tag-number dup [ emit-bignum ] emit-object
+ bignum [ emit-bignum ] emit-object
] cache-object ;
! Fixnums
M: float '
[
- float tag-number dup [
+ float [
align-here double>bits emit-64
] emit-object
] cache-object ;
[ vocabulary>> , ]
[ def>> , ]
[ props>> , ]
- [ drop f , ]
+ [ direct-entry-def>> , ] ! direct-entry-def
[ drop 0 , ] ! count
[ word-sub-primitive , ]
[ drop 0 , ] ! xt
} cleave
] { } make [ ' ] map
] bi
- \ word type-number object tag-number
- [ emit-seq ] emit-object
+ \ word [ emit-seq ] emit-object
] keep put-object ;
: word-error ( word msg -- * )
! Wrappers
M: wrapper '
- wrapped>> ' wrapper type-number object tag-number
- [ emit ] emit-object ;
+ wrapped>> ' wrapper [ emit ] emit-object ;
! Strings
: native> ( object -- object )
: emit-string ( string -- ptr )
[ length ] [ extended-part ' ] [ ] tri
- string type-number object tag-number [
+ string [
[ emit-fixnum ]
[ emit ]
[ f ' emit ascii-part pad-bytes emit-bytes ]
: emit-dummy-array ( obj type -- ptr )
[ assert-empty ] [
- type-number object tag-number
[ 0 emit-fixnum ] emit-object
] bi* ;
M: byte-array '
- byte-array type-number object tag-number [
+ byte-array [
dup length emit-fixnum
pad-bytes emit-bytes
] emit-object ;
: (emit-tuple) ( tuple -- pointer )
[ tuple-slots ]
[ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
- tuple type-number dup [ emit-seq ] emit-object ;
+ tuple [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer )
dup class name>> "tombstone" =
! Arrays
: emit-array ( array -- offset )
- [ ' ] map array type-number object tag-number
- [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
+ [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
M: array ' emit-array ;
M: quotation '
[
array>> '
- quotation type-number object tag-number [
+ quotation [
emit ! array
f ' emit ! compiled
f ' emit ! cached-effect
: emit-jit-data ( -- )
\ if jit-if-word set
- \ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
- \ declare jit-declare-word set
\ dip jit-dip-word set
\ 2dip jit-2dip-word set
\ 3dip jit-3dip-word set
+ \ (execute) jit-execute-word set
+ \ inline-cache-miss \ pic-miss-word set
+ \ mega-cache-lookup \ mega-lookup-word set
+ \ mega-cache-miss \ mega-miss-word set
[ undefined ] undefined-quot set
{
- jit-code-format
jit-prolog
jit-primitive-word
jit-primitive
jit-if-word
jit-if-1
jit-if-2
- jit-dispatch-word
- jit-dispatch
jit-dip-word
jit-dip
jit-2dip-word
jit-2dip
jit-3dip-word
jit-3dip
+ jit-execute-word
+ jit-execute-jump
+ jit-execute-call
jit-epilog
jit-return
jit-profiling
- jit-declare-word
jit-save-stack
+ pic-load
+ pic-tag
+ pic-hi-tag
+ pic-tuple
+ pic-hi-tag-tuple
+ pic-check-tag
+ pic-check
+ pic-hit
+ pic-miss-word
+ mega-lookup
+ mega-lookup-word
+ mega-miss-word
undefined-quot
} [ emit-userenv ] each ;
"Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time
- [ optimized>> ] count-words " compiled words" print
- [ symbol? ] count-words " symbol words" print
- [ ] count-words " words total" print
-
"Bootstrapping is complete." print
"Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush ;
-USING: help.markup help.syntax parser vocabs.loader strings
-command-line.private ;
+USING: help.markup help.syntax parser vocabs.loader strings ;
IN: command-line
HELP: run-bootstrap-init
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
+ { { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
}
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;
[ tuple ##set-slots ] [ ds-push drop ] 2bi
] [ drop emit-primitive ] if ;
-: store-length ( len reg -- )
- [ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
+: store-length ( len reg class -- )
+ [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
-: store-initial-element ( elt reg len -- )
- [ 2 + object tag-number ##set-slot-imm ] with with each ;
+:: store-initial-element ( len reg elt class -- )
+ len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;
[let | elt [ ds-pop ]
reg [ len ^^allot-array ] |
ds-drop
- len reg store-length
- elt reg len store-initial-element
+ len reg array store-length
+ len reg elt array store-initial-element
reg ds-push
]
] [ node emit-primitive ] if
: emit-allot-byte-array ( len -- dst )
ds-drop
dup ^^allot-byte-array
- [ store-length ] [ ds-push ] [ ] tri ;
+ [ byte-array store-length ] [ ds-push ] [ ] tri ;
: emit-(byte-array) ( node -- )
dup node-input-infos first literal>> dup expand-<byte-array>?
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
-: emit-<byte-array> ( node -- )
- dup node-input-infos first literal>> dup expand-<byte-array>? [
- nip
- [ 0 ^^load-literal ] dip
- [ emit-allot-byte-array ] keep
- bytes>cells store-initial-element
- ] [ drop emit-primitive ] if ;
+:: emit-<byte-array> ( node -- )
+ node node-input-infos first literal>> dup expand-<byte-array>? [
+ :> len
+ 0 ^^load-literal :> elt
+ len emit-allot-byte-array :> reg
+ len reg elt byte-array store-initial-element
+ ] [ drop node emit-primitive ] if ;
arrays:<array>
byte-arrays:<byte-array>
byte-arrays:(byte-array)
- math.private:<complex>
- math.private:<ratio>
kernel:<wrapper>
alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1
{ \ arrays:<array> [ emit-<array> iterate-next ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
{ \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
- { \ math.private:<complex> [ emit-simple-allot iterate-next ] }
- { \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
- T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
+ T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering trim-temps
] unit-test
T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
- T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
+ T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering trim-temps
] unit-test
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
- T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
+ T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
T{ ##replace f V int-regs 14 D 0 }
} value-numbering trim-temps
] unit-test
T{ ##peek f V int-regs 29 D -1 }
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
- T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
+ T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
} value-numbering trim-temps
] unit-test
SYMBOL: compiling-word
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
+: compiled-stack-traces? ( -- ? ) 67 getenv ;
! Mapping _label IDs to label instances
SYMBOL: labels
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
-system combinators math.bitwise words.private math.order
+system combinators math.bitwise math.order
accessors growable cpu.architecture compiler.constants ;
IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )
-: code-format ( -- n ) 22 getenv ;
-
-: compiled-offset ( -- n ) building get length code-format * ;
+: compiled-offset ( -- n ) building get length ;
SYMBOL: relocation-table
SYMBOL: label-table
M: label-fixup fixup*
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
- [ label>> ] [ class>> ] bi compiled-offset 4 - rot
+ [ class>> ] [ label>> ] bi compiled-offset 4 - swap
3array label-table get push ;
TUPLE: rel-fixup class type ;
: rel-word ( word class -- )
[ add-literal ] dip rt-xt rel-fixup ;
+: rel-word-direct ( word class -- )
+ [ add-literal ] dip rt-xt-direct rel-fixup ;
+
: rel-primitive ( word class -- )
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
- ] { } make 4array ;
+ ] B{ } make 4array ;
USING: assocs compiler.cfg.builder compiler.cfg.optimizer
compiler.errors compiler.tree.builder compiler.tree.optimizer
compiler.units help.markup help.syntax io parser quotations
-sequences words words.private ;
+sequences words ;
IN: compiler
HELP: enable-compiler
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
-combinators deques search-deques macros io source-files.errors
-stack-checker stack-checker.state stack-checker.inlining
-stack-checker.errors combinators.short-circuit compiler.errors
-compiler.units compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization
-compiler.cfg.two-operand compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
+generic.single combinators deques search-deques macros io
+source-files.errors stack-checker stack-checker.state
+stack-checker.inlining stack-checker.errors combinators.short-circuit
+compiler.errors compiler.units compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
+compiler.cfg.linearization compiler.cfg.two-operand
+compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
+compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
SYMBOL: compiled
-: queue-compile? ( word -- ? )
+: compile? ( word -- ? )
#! Don't attempt to compile certain words.
{
[ "forgotten" word-prop ]
} 1|| not ;
: queue-compile ( word -- )
- dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
+ dup compile? [ compile-queue get push-front ] [ drop ] if ;
: recompile-callers? ( word -- ? )
changed-effects get key? ;
H{ } clone generic-dependencies set
clear-compiler-error ;
+GENERIC: no-compile? ( word -- ? )
+
+M: word no-compile? "no-compile" word-prop ;
+
+M: method-body no-compile? "method-generic" word-prop no-compile? ;
+
+M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
+
: ignore-error? ( word error -- ? )
#! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'.
{
[ macro? ]
[ inline? ]
+ [ no-compile? ]
[ "special" word-prop ]
- [ "no-compile" word-prop ]
} 1||
] [
{
: not-compiled-def ( word error -- def )
'[ _ _ not-compiled ] [ ] like ;
+: ignore-error ( word error -- * )
+ drop
+ [ clear-compiler-error ]
+ [ dup def>> deoptimize-with ]
+ bi ;
+
+: remember-error ( word error -- * )
+ [ swap <compiler-error> compiler-error ]
+ [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
+ 2bi ;
+
: deoptimize ( word error -- * )
#! If the error is ignorable, compile the word with the
#! non-optimizing compiler, using its definition. Otherwise,
#! if the compiler error is not ignorable, use a dummy
#! definition from 'not-compiled-def' which throws an error.
- 2dup ignore-error? [
- drop
- [ dup def>> deoptimize-with ]
- [ clear-compiler-error ]
- bi
- ] [
- [ swap <compiler-error> compiler-error ]
- [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
- 2bi
- ] if ;
+ {
+ { [ dup inference-error? not ] [ rethrow ] }
+ { [ 2dup ignore-error? ] [ ignore-error ] }
+ [ remember-error ]
+ } cond ;
+
+: optimize? ( word -- ? )
+ {
+ [ predicate-engine-word? ]
+ [ contains-breakpoints? ]
+ [ single-generic? ]
+ } 1|| not ;
: frontend ( word -- nodes )
#! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this.
- dup contains-breakpoints? [ dup def>> deoptimize-with ] [
- [ build-tree ] [ deoptimize ] recover optimize-tree
- ] if ;
+ dup optimize?
+ [ [ build-tree ] [ deoptimize ] recover optimize-tree ]
+ [ dup def>> deoptimize-with ]
+ if ;
: compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee.
- dup optimized>> [ drop ] [ queue-compile ] if ;
+ dup optimized? [ drop ] [ queue-compile ] if ;
! Only switch this off for debugging.
SYMBOL: compile-dependencies?
[
<hashed-dlist> compile-queue set
H{ } clone compiled set
- [ queue-compile ] each
+ [
+ [ queue-compile ]
+ [ subwords [ compile-dependency ] each ] bi
+ ] each
compile-queue get compile-loop
compiled get >alist
] with-scope ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel layouts system strings ;
+USING: math kernel layouts system strings words quotations byte-arrays
+alien arrays ;
IN: compiler.constants
! These constants must match vm/memory.h
! These constants must match vm/layouts.h
: header-offset ( -- n ) object tag-number neg ; inline
: float-offset ( -- n ) 8 float tag-number - ; inline
-: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
+: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
-: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
-: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
-: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
-: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
+: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
+: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
+: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
-: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
-: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
-: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
-: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
-: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
+: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
+: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
+: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
! Relocation classes
CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3
-CONSTANT: rt-here 4
-CONSTANT: rt-this 5
-CONSTANT: rt-immediate 6
-CONSTANT: rt-stack-chain 7
+CONSTANT: rt-xt-direct 4
+CONSTANT: rt-here 5
+CONSTANT: rt-this 6
+CONSTANT: rt-immediate 7
+CONSTANT: rt-stack-chain 8
+CONSTANT: rt-untagged 9
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
--- /dev/null
+IN: compiler.tests.call-effect
+USING: tools.test combinators generic.single sequences kernel ;
+
+: execute-ic-test ( a b -- c ) execute( a -- c ) ;
+
+! VM type check error
+[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
\ No newline at end of file
[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
-[ { 1 2 3 } { 1 4 3 } 3 3 ]
+[ { 1 2 3 } { 1 4 3 } 2 2 ]
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test
: foo ( -- ) ;
-[ 5 5 ]
+[ 3 3 ]
[ 1.2 [ tag [ foo ] keep ] compile-call ]
unit-test
{ tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
-[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
+[ t ] [ \ dispatch-alignment-regression optimized? ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test
[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test
-[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
+[ 3 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test
[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test
] unit-test
[ 1 2 ] [
- 1 2 [ <complex> ] compile-call
+ 1 2 [ complex boa ] compile-call
dup real-part swap imaginary-part
] unit-test
[ 1 2 ] [
- 1 2 [ <ratio> ] compile-call dup numerator swap denominator
+ 1 2 [ ratio boa ] compile-call dup numerator swap denominator
] unit-test
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler ;
+compiler definitions ;
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
-[ t ] [ \ xyz optimized>> ] unit-test
+[ t ] [ M\ array xyz optimized? ] unit-test
! Test predicate inlining
: pred-test-1 ( a -- b c )
! regression
GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ;
-[ t ] [ \ breakage optimized>> ] unit-test
+[ t ] [ \ breakage optimized? ] unit-test
[ breakage ] must-fail
! regression
! compiling <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ;
-[ t ] [ \ <tuple>-regression optimized>> ] unit-test
+[ t ] [ \ <tuple>-regression optimized? ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
-[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
+[ t ] [ \ node-successor-f-bug optimized? ] unit-test
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
] if
] if ;
-[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
+[ t ] [ \ lift-throw-tail-regression optimized? ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
-[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
+[ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test
DEFER: recursive-inline-hang-3
dup "a" get { array-capacity } declare >=
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
-[ t ] [ \ interval-inference-bug optimized>> ] unit-test
+[ t ] [ \ interval-inference-bug optimized? ] unit-test
[ ] [ 1 "a" set 2 "b" set ] unit-test
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
1 >bignum 2 >bignum
[ { bignum integer } declare [ shift ] keep 1+ ] compile-call
] unit-test
+
+: broken-declaration ( -- ) \ + declare ;
+
+[ f ] [ \ broken-declaration optimized? ] unit-test
+
+[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
\ No newline at end of file
! optimization, which would batch generic word updates at the
! end of a compilation unit.
-USING: kernel accessors peg.ebnf ;
+USING: kernel accessors peg.ebnf words ;
IN: compiler.tests.peg-regression
TUPLE: pipeline-expr background ;
USE: tools.test
-[ t ] [ \ expr optimized>> ] unit-test
-[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test
+[ t ] [ \ expr optimized? ] unit-test
+[ t ] [ \ ast>pipeline-expr optimized? ] unit-test
--- /dev/null
+IN: compiler.tests.pic-problem-1
+USING: kernel sequences prettyprint memory tools.test ;
+
+TUPLE: x ;
+
+M: x length drop 0 ;
+
+INSTANCE: x sequence
+
+<< gc >>
+
+CONSTANT: blah T{ x }
+
+[ T{ x } ] [ blah ] unit-test
\ No newline at end of file
: sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test optimized>> ] unit-test
+[ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test optimized>> ] unit-test
+[ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
- "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj )
+ "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
] unit-test
] times
USING: math.private kernel combinators accessors arrays
-generalizations tools.test ;
+generalizations tools.test words ;
IN: compiler.tests.spilling
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test
-[ t ] [ \ float-spill-bug optimized>> ] unit-test
+[ t ] [ \ float-spill-bug optimized? ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test
-[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
+[ t ] [ \ float-fixnum-spill-bug optimized? ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
16 narray
] if ;
-[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
+[ t ] [ \ resolve-spill-bug optimized? ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
[ 1+ ] dip
dup #call? [
word>> {
- { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
+ { [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
[ words-called ]
M: #call run-escape-analysis*
{
- { [ dup word>> \ <complex> eq? ] [ t ] }
{ [ dup immutable-tuple-boa? ] [ t ] }
[ f ]
} cond nip ;
out-d>> first escaping-allocation? [ 1+ ] unless ;
M: #call count-unboxed-allocations*
- dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or
+ dup immutable-tuple-boa?
[ (count-unboxed-allocations) ] [ drop ] if ;
M: #push count-unboxed-allocations*
[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
-[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
+[ 1 ] [ [ complex boa >rect ] count-unboxed-allocations ] unit-test
[ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
[ record-unknown-allocation ]
if ;
-: record-complex-allocation ( #call -- )
- [ in-d>> ] [ out-d>> first ] bi record-allocation ;
-
: slot-offset ( #call -- n/f )
dup in-d>>
[ first node-value-info class>> ]
M: #call escape-analysis*
dup word>> {
{ \ <tuple-boa> [ record-tuple-allocation ] }
- { \ <complex> [ record-complex-allocation ] }
{ \ slot [ record-slot-call ] }
[ drop record-unknown-allocation ]
} case ;
dup literal>> class >>class
dup literal>> dup real? [ [a,a] >>interval ] [
[ [-inf,inf] >>interval ] dip
- {
- { [ dup complex? ] [
- [ real-part <literal-info> ]
- [ imaginary-part <literal-info> ] bi
- 2array >>slots
- ] }
- { [ dup tuple? ] [
- [ tuple-slots [ <literal-info> ] map ] [ class ] bi
- read-only-slots >>slots
- ] }
- [ drop ]
- } cond
+ dup tuple? [
+ [ tuple-slots [ <literal-info> ] map ] [ class ] bi
+ read-only-slots >>slots
+ ] [ drop ] if
] if ; inline
: init-value-info ( info -- info )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays sequences math math.order
-math.partial-dispatch generic generic.standard generic.math
+math.partial-dispatch generic generic.standard generic.single generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry combinators.smart hints
locals
{ curry compose } memq? ;
: never-inline-word? ( word -- ? )
- [ deferred? ]
- [ "default" word-prop ]
- [ { call execute } memq? ] tri or or ;
+ [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
: custom-inlining? ( word -- ? )
"custom-inlining" word-prop ;
] unit-test
[ V{ complex } ] [
- [ <complex> ] final-classes
+ [ complex boa ] final-classes
] unit-test
[ V{ complex } ] [
[ V{ complex } ] [
[
{ float float object } declare
- [ "Oops" throw ] [ <complex> ] if
+ [ "Oops" throw ] [ complex boa ] if
] final-classes
] unit-test
[ V{ float } ] [
[
- [ { float float } declare <complex> ]
+ [ { float float } declare complex boa ]
[ 2drop C{ 0.0 0.0 } ]
if real-part
] final-classes
: output-value-infos ( #call word -- infos )
{
- { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
+ { [ dup \ <tuple-boa> eq? ] [ drop propagate-<tuple-boa> ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup predicate? ] [ propagate-predicate ] }
{ [ dup "outputs" word-prop ] [ call-outputs-quot ] }
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry assocs arrays byte-arrays strings accessors sequences
kernel slots classes.algebra classes.tuple classes.tuple.private
! Propagation of immutable slots and array lengths
-! Revisit this code when delegation is removed and when complex
-! numbers become tuples.
-
UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( word -- ? )
[ constructor-output-class <class-info> ]
bi* value-info-intersect 1array ;
-: tuple-constructor? ( word -- ? )
- { <tuple-boa> <complex> } memq? ;
-
: fold-<tuple-boa> ( values class -- info )
[ [ literal>> ] map ] dip prefix >tuple
<literal-info> ;
<tuple-info>
] if ;
-: propagate-<tuple-boa> ( #call -- info )
+: propagate-<tuple-boa> ( #call -- infos )
in-d>> unclip-last
- value-info literal>> first (propagate-tuple-constructor) ;
-
-: propagate-<complex> ( #call -- info )
- in-d>> [ value-info ] map complex <tuple-info> ;
-
-: propagate-tuple-constructor ( #call word -- infos )
- {
- { \ <tuple-boa> [ propagate-<tuple-boa> ] }
- { \ <complex> [ propagate-<complex> ] }
- } case 1array ;
+ value-info literal>> first (propagate-tuple-constructor) 1array ;
: read-only-slot? ( n class -- ? )
all-slots [ offset>> = ] with find nip
[ dup [ drop f ] [ "A" throw ] if ]
[ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
[ [ ] [ ] curry curry call ]
- [ <complex> <complex> dup 1 slot drop 2 slot drop ]
[ 1 cons boa over [ "A" throw ] when car>> ]
[ [ <=> ] sort ]
[ [ <=> ] with search ]
: unbox-<tuple-boa> ( #call -- nodes )
dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
-: unbox-<complex> ( #call -- nodes )
- dup unbox-output? [ drop { } ] when ;
-
: (flatten-values) ( values accum -- )
dup '[
dup unboxed-allocation
M: #call unbox-tuples*
dup word>> {
{ \ <tuple-boa> [ unbox-<tuple-boa> ] }
- { \ <complex> [ unbox-<complex> ] }
{ \ slot [ unbox-slot-access ] }
[ drop ]
} case ;
! See http://factorcode.org/license.txt for BSD license.\r
USING: bootstrap.image.private kernel kernel.private namespaces\r
system cpu.ppc.assembler compiler.codegen.fixup compiler.units\r
-compiler.constants math math.private layouts words words.private\r
+compiler.constants math math.private layouts words\r
vocabs slots.private locals.backend ;\r
IN: bootstrap.ppc\r
\r
4 \ cell set\r
big-endian on\r
\r
-4 jit-code-format set\r
-\r
CONSTANT: ds-reg 29\r
CONSTANT: rs-reg 30\r
\r
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
11 6 profile-count-offset LWZ\r
11 11 1 tag-fixnum ADDI\r
11 6 profile-count-offset STW\r
11 11 compiled-header-size ADDI\r
11 MTCTR\r
BCTR\r
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define\r
+] jit-profiling jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
0 MFLR\r
1 1 stack-frame SUBI\r
6 1 xt-save STW\r
stack-frame 6 LI\r
6 1 next-save STW\r
0 1 lr-save stack-frame + STW\r
-] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define\r
+] jit-prolog jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
6 ds-reg 4 STWU\r
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define\r
+] jit-push-immediate jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel\r
7 6 0 LWZ\r
1 7 0 STW\r
-] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define\r
+] jit-save-stack jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel\r
6 MTCTR\r
BCTR\r
-] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define\r
+] jit-primitive jit-define\r
\r
-[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define\r
+[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define\r
\r
-[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define\r
+[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
0 3 \ f tag-number CMPI\r
2 BEQ\r
- 0 B\r
-] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define\r
-\r
-[\r
- 0 B\r
-] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define\r
-\r
-: jit-jump-quot ( -- )\r
- 4 3 quot-xt-offset LWZ\r
- 4 MTCTR\r
- BCTR ;\r
+ 0 B rc-relative-ppc-3 rt-xt jit-rel\r
+] jit-if-1 jit-define\r
\r
[\r
- 0 3 LOAD32\r
- 6 ds-reg 0 LWZ\r
- 6 6 1 SRAWI\r
- 3 3 6 ADD\r
- 3 3 array-start-offset LWZ\r
- ds-reg dup 4 SUBI\r
- jit-jump-quot\r
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define\r
+ 0 B rc-relative-ppc-3 rt-xt jit-rel\r
+] jit-if-2 jit-define\r
\r
: jit->r ( -- )\r
4 ds-reg 0 LWZ\r
\r
[\r
jit->r\r
- 0 BL\r
+ 0 BL rc-relative-ppc-3 rt-xt jit-rel\r
jit-r>\r
-] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define\r
+] jit-dip jit-define\r
\r
[\r
jit-2>r\r
- 0 BL\r
+ 0 BL rc-relative-ppc-3 rt-xt jit-rel\r
jit-2r>\r
-] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define\r
+] jit-2dip jit-define\r
\r
[\r
jit-3>r\r
- 0 BL\r
+ 0 BL rc-relative-ppc-3 rt-xt jit-rel\r
jit-3r>\r
-] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define\r
+] jit-3dip jit-define\r
\r
[\r
0 1 lr-save stack-frame + LWZ\r
1 1 stack-frame ADDI\r
0 MTLR\r
-] f f f jit-epilog jit-define\r
+] jit-epilog jit-define\r
\r
-[ BLR ] f f f jit-return jit-define\r
+[ BLR ] jit-return jit-define\r
\r
! Sub-primitives\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
- jit-jump-quot\r
-] f f f \ (call) define-sub-primitive\r
+ 4 3 quot-xt-offset LWZ\r
+ 4 MTCTR\r
+ BCTR\r
+] \ (call) define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 3 word-xt-offset LWZ\r
4 MTCTR\r
BCTR\r
-] f f f \ (execute) define-sub-primitive\r
+] \ (execute) define-sub-primitive\r
\r
! Objects\r
[\r
3 3 tag-mask get ANDI\r
3 3 tag-bits get SLWI\r
3 ds-reg 0 STW\r
-] f f f \ tag define-sub-primitive\r
+] \ tag define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 4 0 0 31 tag-bits get - RLWINM\r
4 3 3 LWZX\r
3 ds-reg 0 STW\r
-] f f f \ slot define-sub-primitive\r
+] \ slot define-sub-primitive\r
\r
! Shufflers\r
[\r
ds-reg dup 4 SUBI\r
-] f f f \ drop define-sub-primitive\r
+] \ drop define-sub-primitive\r
\r
[\r
ds-reg dup 8 SUBI\r
-] f f f \ 2drop define-sub-primitive\r
+] \ 2drop define-sub-primitive\r
\r
[\r
ds-reg dup 12 SUBI\r
-] f f f \ 3drop define-sub-primitive\r
+] \ 3drop define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg 4 STWU\r
-] f f f \ dup define-sub-primitive\r
+] \ dup define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 8 ADDI\r
3 ds-reg 0 STW\r
4 ds-reg -4 STW\r
-] f f f \ 2dup define-sub-primitive\r
+] \ 2dup define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg 0 STW\r
4 ds-reg -4 STW\r
5 ds-reg -8 STW\r
-] f f f \ 3dup define-sub-primitive\r
+] \ 3dup define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
3 ds-reg 0 STW\r
-] f f f \ nip define-sub-primitive\r
+] \ nip define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 8 SUBI\r
3 ds-reg 0 STW\r
-] f f f \ 2nip define-sub-primitive\r
+] \ 2nip define-sub-primitive\r
\r
[\r
3 ds-reg -4 LWZ\r
3 ds-reg 4 STWU\r
-] f f f \ over define-sub-primitive\r
+] \ over define-sub-primitive\r
\r
[\r
3 ds-reg -8 LWZ\r
3 ds-reg 4 STWU\r
-] f f f \ pick define-sub-primitive\r
+] \ pick define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZ\r
4 ds-reg 0 STW\r
3 ds-reg 4 STWU\r
-] f f f \ dupd define-sub-primitive\r
+] \ dupd define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg 4 STWU\r
4 ds-reg -4 STW\r
3 ds-reg -8 STW\r
-] f f f \ tuck define-sub-primitive\r
+] \ tuck define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZ\r
3 ds-reg -4 STW\r
4 ds-reg 0 STW\r
-] f f f \ swap define-sub-primitive\r
+] \ swap define-sub-primitive\r
\r
[\r
3 ds-reg -4 LWZ\r
4 ds-reg -8 LWZ\r
3 ds-reg -8 STW\r
4 ds-reg -4 STW\r
-] f f f \ swapd define-sub-primitive\r
+] \ swapd define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -8 STW\r
3 ds-reg -4 STW\r
5 ds-reg 0 STW\r
-] f f f \ rot define-sub-primitive\r
+] \ rot define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg -8 STW\r
5 ds-reg -4 STW\r
4 ds-reg 0 STW\r
-] f f f \ -rot define-sub-primitive\r
+] \ -rot define-sub-primitive\r
\r
-[ jit->r ] f f f \ load-local define-sub-primitive\r
+[ jit->r ] \ load-local define-sub-primitive\r
\r
! Comparisons\r
: jit-compare ( insn -- )\r
- 0 3 LOAD32\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
4 ds-reg 0 LWZ\r
5 ds-reg -4 LWZU\r
5 0 4 CMP\r
3 ds-reg 0 STW ;\r
\r
: define-jit-compare ( insn word -- )\r
- [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip\r
- define-sub-primitive ;\r
+ [ [ jit-compare ] curry ] dip define-sub-primitive ;\r
\r
\ BEQ \ eq? define-jit-compare\r
\ BGE \ fixnum>= define-jit-compare\r
2 BNE\r
1 tag-fixnum 4 LI\r
4 ds-reg 0 STW\r
-] f f f \ both-fixnums? define-sub-primitive\r
+] \ both-fixnums? define-sub-primitive\r
\r
: jit-math ( insn -- )\r
3 ds-reg 0 LWZ\r
[ 5 3 4 ] dip execute( dst src1 src2 -- )\r
5 ds-reg 0 STW ;\r
\r
-[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive\r
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive\r
\r
-[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive\r
+[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 4 tag-bits get SRAWI\r
5 3 4 MULLW\r
5 ds-reg 0 STW\r
-] f f f \ fixnum*fast define-sub-primitive\r
+] \ fixnum*fast define-sub-primitive\r
\r
-[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive\r
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive\r
\r
-[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive\r
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive\r
\r
-[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive\r
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 3 NOT\r
3 3 tag-mask get XORI\r
3 ds-reg 0 STW\r
-] f f f \ fixnum-bitnot define-sub-primitive\r
+] \ fixnum-bitnot define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
2 BGT\r
5 7 MR\r
5 ds-reg 0 STW\r
-] f f f \ fixnum-shift-fast define-sub-primitive\r
+] \ fixnum-shift-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
6 5 3 MULLW\r
7 6 4 SUBF\r
7 ds-reg 0 STW\r
-] f f f \ fixnum-mod define-sub-primitive\r
+] \ fixnum-mod define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
5 4 3 DIVW\r
5 5 tag-bits get SLWI\r
5 ds-reg 0 STW\r
-] f f f \ fixnum/i-fast define-sub-primitive\r
+] \ fixnum/i-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
5 5 tag-bits get SLWI\r
5 ds-reg -4 STW\r
7 ds-reg 0 STW\r
-] f f f \ fixnum/mod-fast define-sub-primitive\r
+] \ fixnum/mod-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 3 1 SRAWI\r
rs-reg 3 3 LWZX\r
3 ds-reg 0 STW\r
-] f f f \ get-local define-sub-primitive\r
+] \ get-local define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg ds-reg 4 SUBI\r
3 3 1 SRAWI\r
rs-reg 3 rs-reg SUBF\r
-] f f f \ drop-locals define-sub-primitive\r
+] \ drop-locals define-sub-primitive\r
\r
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r
: rex-length ( -- n ) 0 ;
[
- temp0 0 [] MOV ! load stack_chain
- temp0 [] stack-reg MOV ! save stack pointer
-] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
+ ! load stack_chain
+ temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
+ ! save stack pointer
+ temp0 [] stack-reg MOV
+] jit-save-stack jit-define
[
- (JMP) drop
-] rc-relative rt-primitive 1 jit-primitive jit-define
+ (JMP) drop rc-relative rt-primitive jit-rel
+] jit-primitive jit-define
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
call
: rex-length ( -- n ) 1 ;
[
- temp0 0 MOV ! load stack_chain
+ ! load stack_chain
+ temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
temp0 temp0 [] MOV
- temp0 [] stack-reg MOV ! save stack pointer
-] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
+ ! save stack pointer
+ temp0 [] stack-reg MOV
+] jit-save-stack jit-define
[
- temp1 0 MOV ! load XT
- temp1 JMP ! go
-] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
+ ! load XT
+ temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
+ ! go
+ temp1 JMP
+] jit-primitive jit-define
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
call
[ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
+
+[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
GENERIC: CALL ( op -- )
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
M: f CALL (CALL) 2drop ;
-M: callable CALL (CALL) rel-word ;
+M: callable CALL (CALL) rel-word-direct ;
M: label CALL (CALL) label-fixup ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
-M: f JUMPcc nip (JUMPcc) drop ;
-M: callable JUMPcc (JUMPcc) rel-word ;
-M: label JUMPcc (JUMPcc) label-fixup ;
+: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
+M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
+M: integer JUMPcc (JUMPcc) drop ;
+M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
+M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
: JO ( dst -- ) HEX: 80 JUMPcc ;
: JNO ( dst -- ) HEX: 81 JUMPcc ;
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
M: operand CMP OCT: 070 2-operand ;
+GENERIC: TEST ( dst src -- )
+M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ;
+M: operand TEST OCT: 204 2-operand ;
+
: XCHG ( dst src -- ) OCT: 207 2-operand ;
: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.x86.assembler layouts compiler.units math
math.private compiler.constants vocabs slots.private words
-words.private locals.backend ;
+locals.backend make sequences combinators arrays ;
IN: bootstrap.x86
big-endian off
-1 jit-code-format set
-
[
! Load word
- temp0 0 MOV
+ temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
! Bump profiling counter
temp0 profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
temp0 compiled-header-size ADD
! Jump to XT
temp0 JMP
-] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
+] jit-profiling jit-define
[
! load XT
- temp0 0 MOV
+ temp0 0 MOV rc-absolute-cell rt-this jit-rel
! save stack frame size
stack-frame-size PUSH
! push XT
temp0 PUSH
! alignment
stack-reg stack-frame-size 3 bootstrap-cells - SUB
-] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define
+] jit-prolog jit-define
[
! load literal
- temp0 0 MOV
+ temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
! increment datastack pointer
ds-reg bootstrap-cell ADD
! store literal on datastack
ds-reg [] temp0 MOV
-] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
+] jit-push-immediate jit-define
[
- f JMP
-] rc-relative rt-xt 1 jit-word-jump jit-define
+ f JMP rc-relative rt-xt jit-rel
+] jit-word-jump jit-define
[
- f CALL
-] rc-relative rt-xt 1 jit-word-call jit-define
+ f CALL rc-relative rt-xt-direct jit-rel
+] jit-word-call jit-define
[
! load boolean
! compare boolean with f
temp0 \ f tag-number CMP
! jump to true branch if not equal
- f JNE
-] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
+ f JNE rc-relative rt-xt jit-rel
+] jit-if-1 jit-define
[
! jump to false branch if equal
- f JMP
-] rc-relative rt-xt 1 jit-if-2 jit-define
-
-[
- ! load dispatch table
- temp1 0 MOV
- ! load index
- temp0 ds-reg [] MOV
- ! turn it into an array offset
- fixnum>slot@
- ! pop index
- ds-reg bootstrap-cell SUB
- ! compute quotation location
- temp0 temp1 ADD
- ! load quotation
- arg temp0 array-start-offset [+] MOV
- ! execute branch. the quot must be in arg, since it might
- ! not be compiled yet
- arg quot-xt-offset [+] JMP
-] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
+ f JMP rc-relative rt-xt jit-rel
+] jit-if-2 jit-define
: jit->r ( -- )
rs-reg bootstrap-cell ADD
[
jit->r
- f CALL
+ f CALL rc-relative rt-xt jit-rel
jit-r>
-] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define
+] jit-dip jit-define
[
jit-2>r
- f CALL
+ f CALL rc-relative rt-xt jit-rel
jit-2r>
-] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
+] jit-2dip jit-define
[
jit-3>r
- f CALL
+ f CALL rc-relative rt-xt jit-rel
jit-3r>
-] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
+] jit-3dip jit-define
+
+: prepare-(execute) ( -- operand )
+ ! load from stack
+ temp0 ds-reg [] MOV
+ ! pop stack
+ ds-reg bootstrap-cell SUB
+ ! execute word
+ temp0 word-xt-offset [+] ;
+
+[ prepare-(execute) JMP ] jit-execute-jump jit-define
+
+[ prepare-(execute) CALL ] jit-execute-call jit-define
[
! unwind stack frame
stack-reg stack-frame-size bootstrap-cell - ADD
-] f f f jit-epilog jit-define
+] jit-epilog jit-define
+
+[ 0 RET ] jit-return jit-define
-[ 0 RET ] f f f jit-return jit-define
+! ! ! Polymorphic inline caches
-! Sub-primitives
+! temp0 contains the object being dispatched on
+! temp1 contains its class
+
+! Load a value from a stack position
+[
+ temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel
+] pic-load jit-define
+
+! Tag
+: load-tag ( -- )
+ temp1 tag-mask get AND
+ temp1 tag-bits get SHL ;
+
+[ load-tag ] pic-tag jit-define
+
+! The 'make' trick lets us compute the jump distance for the
+! conditional branches there
+
+! Hi-tag
+[
+ temp0 temp1 MOV
+ load-tag
+ temp1 object tag-number tag-fixnum CMP
+ [ temp1 temp0 object tag-number neg [+] MOV ] { } make
+ [ length JNE ] [ % ] bi
+] pic-hi-tag jit-define
+
+! Tuple
+[
+ temp0 temp1 MOV
+ load-tag
+ temp1 tuple tag-number tag-fixnum CMP
+ [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
+ [ length JNE ] [ % ] bi
+] pic-tuple jit-define
+
+! Hi-tag and tuple
+[
+ temp0 temp1 MOV
+ load-tag
+ ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
+ temp1 BIN: 110 tag-fixnum CMP
+ [
+ ! Untag temp0
+ temp0 tag-mask get bitnot AND
+ ! Set temp1 to 0 for objects, and 8 for tuples
+ temp1 1 tag-fixnum AND
+ bootstrap-cell 4 = [ temp1 1 SHR ] when
+ ! Load header cell or tuple layout cell
+ temp1 temp0 temp1 [+] MOV
+ ] [ ] make [ length JL ] [ % ] bi
+] pic-hi-tag-tuple jit-define
+
+[
+ temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
+] pic-check-tag jit-define
+
+[
+ temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
+ temp1 temp2 CMP
+] pic-check jit-define
+
+[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
+
+! ! ! Megamorphic caches
+
+[
+ ! cache = ...
+ temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
+ ! key = class
+ temp2 temp1 MOV
+ bootstrap-cell 8 = [ temp2 1 SHL ] when
+ ! key &= cache.length - 1
+ temp2 mega-cache-size get 1- bootstrap-cell * AND
+ ! cache += array-start-offset
+ temp0 array-start-offset ADD
+ ! cache += key
+ temp0 temp2 ADD
+ ! if(get(cache) == class)
+ temp0 [] temp1 CMP
+ ! ... goto get(cache + bootstrap-cell)
+ [
+ temp0 temp0 bootstrap-cell [+] MOV
+ temp0 word-xt-offset [+] JMP
+ ] [ ] make
+ [ length JNE ] [ % ] bi
+ ! fall-through on miss
+] mega-lookup jit-define
+
+! ! ! Sub-primitives
! Quotations and words
[
ds-reg bootstrap-cell SUB
! call quotation
arg quot-xt-offset [+] JMP
-] f f f \ (call) define-sub-primitive
-
-[
- ! load from stack
- temp0 ds-reg [] MOV
- ! pop stack
- ds-reg bootstrap-cell SUB
- ! execute word
- temp0 word-xt-offset [+] JMP
-] f f f \ (execute) define-sub-primitive
+] \ (call) define-sub-primitive
! Objects
[
temp0 tag-bits get SHL
! push to stack
ds-reg [] temp0 MOV
-] f f f \ tag define-sub-primitive
+] \ tag define-sub-primitive
[
! load slot number
temp0 temp1 temp0 [+] MOV
! push to stack
ds-reg [] temp0 MOV
-] f f f \ slot define-sub-primitive
+] \ slot define-sub-primitive
! Shufflers
[
ds-reg bootstrap-cell SUB
-] f f f \ drop define-sub-primitive
+] \ drop define-sub-primitive
[
ds-reg 2 bootstrap-cells SUB
-] f f f \ 2drop define-sub-primitive
+] \ 2drop define-sub-primitive
[
ds-reg 3 bootstrap-cells SUB
-] f f f \ 3drop define-sub-primitive
+] \ 3drop define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ dup define-sub-primitive
+] \ dup define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg 2 bootstrap-cells ADD
ds-reg [] temp0 MOV
ds-reg bootstrap-cell neg [+] temp1 MOV
-] f f f \ 2dup define-sub-primitive
+] \ 2dup define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
ds-reg -2 bootstrap-cells [+] temp3 MOV
-] f f f \ 3dup define-sub-primitive
+] \ 3dup define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
ds-reg [] temp0 MOV
-] f f f \ nip define-sub-primitive
+] \ nip define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg 2 bootstrap-cells SUB
ds-reg [] temp0 MOV
-] f f f \ 2nip define-sub-primitive
+] \ 2nip define-sub-primitive
[
temp0 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ over define-sub-primitive
+] \ over define-sub-primitive
[
temp0 ds-reg -2 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ pick define-sub-primitive
+] \ pick define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg [] temp1 MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ dupd define-sub-primitive
+] \ dupd define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV
-] f f f \ tuck define-sub-primitive
+] \ tuck define-sub-primitive
[
temp0 ds-reg [] MOV
temp1 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell neg [+] temp0 MOV
ds-reg [] temp1 MOV
-] f f f \ swap define-sub-primitive
+] \ swap define-sub-primitive
[
temp0 ds-reg -1 bootstrap-cells [+] MOV
temp1 ds-reg -2 bootstrap-cells [+] MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
-] f f f \ swapd define-sub-primitive
+] \ swapd define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg -2 bootstrap-cells [+] temp1 MOV
ds-reg -1 bootstrap-cells [+] temp0 MOV
ds-reg [] temp3 MOV
-] f f f \ rot define-sub-primitive
+] \ rot define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp3 MOV
ds-reg [] temp1 MOV
-] f f f \ -rot define-sub-primitive
+] \ -rot define-sub-primitive
-[ jit->r ] f f f \ load-local define-sub-primitive
+[ jit->r ] \ load-local define-sub-primitive
! Comparisons
: jit-compare ( insn -- )
! load t
- temp3 0 MOV
+ temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
! load f
temp1 \ f tag-number MOV
! load first value
ds-reg [] temp1 MOV ;
: define-jit-compare ( insn word -- )
- [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
- define-sub-primitive ;
+ [ [ jit-compare ] curry ] dip define-sub-primitive ;
\ CMOVE \ eq? define-jit-compare
\ CMOVGE \ fixnum>= define-jit-compare
! compute result
[ ds-reg [] temp0 ] dip execute( dst src -- ) ;
-[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
-[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
+[ \ SUB jit-math ] \ fixnum-fast define-sub-primitive
[
! load second input
temp0 temp1 IMUL2
! push result
ds-reg [] temp1 MOV
-] f f f \ fixnum*fast define-sub-primitive
+] \ fixnum*fast define-sub-primitive
-[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
-[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
-[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
[
! complement
ds-reg [] NOT
! clear tag bits
ds-reg [] tag-mask get XOR
-] f f f \ fixnum-bitnot define-sub-primitive
+] \ fixnum-bitnot define-sub-primitive
[
! load shift count
temp1 temp3 CMOVGE
! push to stack
ds-reg [] temp1 MOV
-] f f f \ fixnum-shift-fast define-sub-primitive
+] \ fixnum-shift-fast define-sub-primitive
: jit-fixnum-/mod ( -- )
! load second parameter
ds-reg bootstrap-cell SUB
! push to stack
ds-reg [] mod-arg MOV
-] f f f \ fixnum-mod define-sub-primitive
+] \ fixnum-mod define-sub-primitive
[
jit-fixnum-/mod
div-arg tag-bits get SHL
! push to stack
ds-reg [] div-arg MOV
-] f f f \ fixnum/i-fast define-sub-primitive
+] \ fixnum/i-fast define-sub-primitive
[
jit-fixnum-/mod
! push to stack
ds-reg [] mod-arg MOV
ds-reg bootstrap-cell neg [+] div-arg MOV
-] f f f \ fixnum/mod-fast define-sub-primitive
+] \ fixnum/mod-fast define-sub-primitive
[
temp0 ds-reg [] MOV
temp1 1 tag-fixnum MOV
temp0 temp1 CMOVE
ds-reg [] temp0 MOV
-] f f f \ both-fixnums? define-sub-primitive
+] \ both-fixnums? define-sub-primitive
[
! load local number
temp0 rs-reg temp0 [+] MOV
! push to stack
ds-reg [] temp0 MOV
-] f f f \ get-local define-sub-primitive
+] \ get-local define-sub-primitive
[
! load local count
fixnum>slot@
! decrement retain stack pointer
rs-reg temp0 SUB
-] f f f \ drop-locals define-sub-primitive
+] \ drop-locals define-sub-primitive
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations io.files.private listener
+help generic.single continuations io.files.private listener
alien.libraries ;
IN: debugger
io.pathnames vectors words system splitting math.parser
classes.mixin classes.tuple continuations continuations.private
combinators generic.math classes.builtin classes compiler.units
-generic.standard vocabs init kernel.private io.encodings
+generic.standard generic.single vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser
classes.tuple.parser effects.parser lexer
generic.parser strings.parser vocabs.loader vocabs.parser see
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting math
-math.parser generic generic.standard generic.standard.engines classes
+math.parser generic generic.single generic.standard classes
hashtables namespaces ;
IN: hints
t specialize-method? set-global
+: method-declaration ( method -- quot )
+ [ "method-generic" word-prop dispatch# object <array> ]
+ [ "method-class" word-prop ]
+ bi prefix [ declare ] curry [ ] like ;
+
: specialize-method ( quot method -- quot' )
- [
- specialize-method? get [
- [ "method-class" word-prop ] [ "method-generic" word-prop ] bi
- method-declaration prepend
- ] [ drop ] if
- ]
+ [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
[ "method-generic" word-prop "specializer" word-prop ] bi
[ specialize-quot ] when* ;
SYNTAX: HINTS:
scan-object
[ changed-definition ]
- [ parse-definition "specializer" set-word-prop ] bi ;
+ [ parse-definition { } like "specializer" set-word-prop ] bi ;
! Default specializers
{ first first2 first3 first4 }
nip <ignore-close-stream> ;
M: plain-writer stream-write-table
- [ drop format-table [ nl ] [ write ] interleave ] with-output-stream* ;
+ [
+ drop
+ [ [ >string ] map ] map format-table
+ [ nl ] [ write ] interleave
+ ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;
:: ed's-test-case ( a -- b )
{ [ a ed's-bug ] } && ;
-[ t ] [ \ ed's-test-case optimized>> ] unit-test
+[ t ] [ \ ed's-test-case optimized? ] unit-test
{ $class-description "The class of complex numbers with non-zero imaginary part." } ;
ABOUT: "complex-numbers"
-
-HELP: <complex> ( x y -- z )
-{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } }
-{ $description "Low-level complex number constructor. User code should call " { $link rect> } " instead." } ;
: complex= ( x y quot -- ? ) componentwise and ; inline
M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ;
M: complex number= [ number= ] complex= ;
-: complex-op ( x y quot -- z ) componentwise (rect>) ; inline
+: complex-op ( x y quot -- z ) componentwise rect> ; inline
M: complex + [ + ] complex-op ;
M: complex - [ - ] complex-op ;
: *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline
: *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline
-M: complex * [ *re - ] [ *im + ] 2bi (rect>) ;
+M: complex * [ *re - ] [ *im + ] 2bi rect> ;
: (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
-: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ (rect>) ; inline
+: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline
M: complex / [ / ] complex/ ;
M: complex /f [ /f ] complex/ ;
M: complex /i [ /i ] complex/ ;
ABOUT: "math-functions"
-HELP: (rect>)
-{ $values { "x" real } { "y" real } { "z" number } }
-{ $description "Creates a complex number from real and imaginary components." }
-{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ;
-
HELP: rect>
{ $values { "x" real } { "y" real } { "z" number } }
{ $description "Creates a complex number from real and imaginary components. If " { $snippet "z" } " is an integer zero, this will simply output " { $snippet "x" } "." } ;
: >fraction ( a/b -- a b )
[ numerator ] [ denominator ] bi ; inline
-<PRIVATE
-
-: (rect>) ( x y -- z )
- dup 0 = [ drop ] [ <complex> ] if ; inline
-
-PRIVATE>
-
: rect> ( x y -- z )
- 2dup [ real? ] both? [
- (rect>)
- ] [
- "Complex number must have real components" throw
- ] if ; inline
+ dup 0 = [ drop ] [ complex boa ] if ; inline
GENERIC: sqrt ( x -- y ) foldable
{ $values { "a/b" rational } { "c/d" rational } { "a" integer } { "c" integer } { "b" "a positive integer" } { "d" "a positive integer" } }
{ $description "Extracts the numerator and denominator of two rational numbers at once." } ;
-HELP: <ratio> ( a b -- a/b )
-{ $values { "a" integer } { "b" integer } { "a/b" "a ratio" } }
-{ $description "Primitive ratio constructor. User code should call " { $link / } " to create ratios instead." } ;
<PRIVATE
: fraction> ( a b -- a/b )
- dup 1 number= [ drop ] [ <ratio> ] if ; inline
+ dup 1 number= [ drop ] [ ratio boa ] if ; inline
: scale ( a/b c/d -- a*d b*c )
2>fraction [ * swap ] dip * swap ; inline
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.builtin
-classes.intersection classes.mixin classes.predicate
-classes.singleton classes.tuple classes.union combinators
-definitions effects generic generic.standard io io.pathnames
+classes.intersection classes.mixin classes.predicate classes.singleton
+classes.tuple classes.union combinators definitions effects generic
+generic.single generic.standard generic.hook io io.pathnames
io.streams.string io.styles kernel make namespaces prettyprint
prettyprint.backend prettyprint.config prettyprint.custom
-prettyprint.sections sequences sets sorting strings summary
-words words.symbol words.constant words.alias ;
+prettyprint.sections sequences sets sorting strings summary words
+words.symbol words.constant words.alias ;
IN: see
GENERIC: synopsis* ( defspec -- )
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry arrays generic io io.streams.string kernel math
-namespaces parser sequences strings vectors words quotations
-effects classes continuations assocs combinators
-compiler.errors accessors math.order definitions sets
-generic.standard.engines.tuple hints macros stack-checker.state
+USING: fry arrays generic io io.streams.string kernel math namespaces
+parser sequences strings vectors words quotations effects classes
+continuations assocs combinators compiler.errors accessors math.order
+definitions sets hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
stack-checker.recursive-state ;
IN: stack-checker.backend
-USING: stack-checker.call-effect tools.test math kernel ;
+USING: stack-checker.call-effect tools.test math kernel math effects ;
IN: stack-checker.call-effect.tests
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
-[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
\ No newline at end of file
+[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
+
+[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test
+[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test
+[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test
+[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test
+[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test
+[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test
+[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test
+[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations
-stack-checker stack-checker.transforms words ;
+stack-checker stack-checker.transforms words math ;
IN: stack-checker.call-effect
! call( and execute( have complex expansions.
TUPLE: inline-cache value ;
-: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline
+: cache-hit? ( word/quot ic -- ? )
+ [ value>> ] [ value>> eq? ] bi and ; inline
-SYMBOL: +unknown+
+SINGLETON: +unknown+
GENERIC: cached-effect ( quot -- effect )
M: object cached-effect drop +unknown+ ;
+GENERIC: curry-effect ( effect -- effect' )
+
+M: +unknown+ curry-effect ;
+
+M: effect curry-effect
+ [ in>> length ] [ out>> length ] [ terminated?>> ] tri
+ pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if
+ effect boa ;
+
+M: curry cached-effect
+ quot>> cached-effect curry-effect ;
+
+: compose-effects* ( effect1 effect2 -- effect' )
+ {
+ { [ 2dup [ effect? ] both? ] [ compose-effects ] }
+ { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
+ } cond ;
+
+M: compose cached-effect
+ [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
+
M: quotation cached-effect
dup cached-effect>>
[ ] [
[ '[ _ execute ] ] dip call-effect-slow ; inline
: execute-effect-unsafe? ( word effect -- ? )
- over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
+ over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
: execute-effect-fast ( word effect inline-cache -- )
2over execute-effect-unsafe?
ERROR: transform-expansion-error < inference-error word error ;
+ERROR: bad-declaration-error < inference-error declaration ;
+
M: object (literal) "literal value" literal-expected ;
\ No newline at end of file
sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
-words.private assocs summary compiler.units system.private
-combinators locals locals.backend locals.types words.private
+assocs summary compiler.units system.private
+combinators combinators.short-circuit locals locals.backend locals.types
quotations.private combinators.private stack-checker.values
+generic.single generic.single.private
alien.libraries
stack-checker.alien
stack-checker.state
: infer-shuffle-word ( word -- )
"shuffle" word-prop infer-shuffle ;
+: check-declaration ( declaration -- declaration )
+ dup { [ array? ] [ [ class? ] all? ] } 1&&
+ [ bad-declaration-error ] unless ;
+
: infer-declare ( -- )
- pop-literal nip
+ pop-literal nip check-declaration
[ length ensure-d ] keep zip
#declare, ;
apply-word/effect ;
: infer-execute-effect-unsafe ( -- )
- \ execute infer-effect-unsafe ;
+ \ (execute) infer-effect-unsafe ;
: infer-call-effect-unsafe ( -- )
\ call infer-effect-unsafe ;
! More words not to compile
\ call t "no-compile" set-word-prop
-\ call subwords [ t "no-compile" set-word-prop ] each
-
\ execute t "no-compile" set-word-prop
-\ execute subwords [ t "no-compile" set-word-prop ] each
-
-\ effective-method t "no-compile" set-word-prop
-\ effective-method subwords [ t "no-compile" set-word-prop ] each
-
\ clear t "no-compile" set-word-prop
: non-inline-word ( word -- )
\ bignum>float { bignum } { float } define-primitive
\ bignum>float make-foldable
-\ <ratio> { integer integer } { ratio } define-primitive
-\ <ratio> make-foldable
-
\ string>float { string } { float } define-primitive
\ string>float make-foldable
\ bits>double { integer } { float } define-primitive
\ bits>double make-foldable
-\ <complex> { real real } { complex } define-primitive
-\ <complex> make-foldable
-
\ both-fixnums? { object object } { object } define-primitive
\ fixnum+ { fixnum fixnum } { integer } define-primitive
\ gc-stats { } { array } define-primitive
\ jit-compile { quotation } { } define-primitive
+
+\ lookup-method { object array } { word } define-primitive
+
+\ reset-dispatch-stats { } { } define-primitive
+\ dispatch-stats { } { array } define-primitive
+\ reset-inline-cache-stats { } { } define-primitive
+\ inline-cache-stats { } { array } define-primitive
+
+\ optimized? { word } { object } define-primitive
\ No newline at end of file
"Comparing effects:"
{ $subsection effect-height }
{ $subsection effect<= }
+{ $subsection effect= }
"The class of stack effects:"
{ $subsection effect }
{ $subsection effect? } ;
] 1 define-transform
\ boa t "no-compile" set-word-prop
-M\ tuple-class boa t "no-compile" set-word-prop
\ new [
dup tuple-class? [
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test strings.tables ;
IN: strings.tables.tests
+
+[ { "A BB" "CC D" } ] [ { { "A" "BB" } { "CC" "D" } } format-table ] unit-test
+
+[ { "A C" "B " "D E" } ] [ { { "A\nB" "C" } { "D" "E" } } format-table ] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences fry math.order ;
+USING: kernel sequences fry math.order splitting ;
IN: strings.tables
<PRIVATE
+: map-last ( seq quot -- seq )
+ [ dup length <reversed> ] dip '[ 0 = @ ] 2map ; inline
+
+: max-length ( seq -- n )
+ [ length ] [ max ] map-reduce ;
+
+: format-row ( seq ? -- seq )
+ [
+ dup max-length
+ '[ _ "" pad-tail ] map
+ ] unless ;
+
: format-column ( seq ? -- seq )
[
- dup [ length ] [ max ] map-reduce
+ dup max-length
'[ _ CHAR: \s pad-tail ] map
] unless ;
-: map-last ( seq quot -- seq )
- [ dup length <reversed> ] dip '[ 0 = @ ] 2map ; inline
-
PRIVATE>
: format-table ( table -- seq )
- flip [ format-column ] map-last
- flip [ " " join ] map ;
\ No newline at end of file
+ [ [ [ string-lines ] map ] dip format-row flip ] map-last concat
+ flip [ format-column ] map-last flip [ " " join ] map ;
\ No newline at end of file
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models models.arrow arrays accessors
-generic generic.standard definitions make sbufs tools.crossref ;
+generic generic.single definitions make sbufs tools.crossref ;
IN: tools.continuations
<PRIVATE
: (step-into-execute) ( word -- )
{
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
- { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
- { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup single-generic? ] [ effective-method (step-into-execute) ] }
{ [ dup uses \ suspend swap member? ] [ execute break ] }
{ [ dup primitive? ] [ execute break ] }
[ def>> (step-into-quot) ]
USING: words assocs definitions io io.pathnames io.styles kernel
prettyprint sorting see sets sequences arrays hashtables help.crossref
help.topics help.markup quotations accessors source-files namespaces
-graphs vocabs generic generic.standard.engines.tuple threads
-compiler.units init ;
+graphs vocabs generic generic.single threads compiler.units init ;
IN: tools.crossref
SYMBOL: crossref
M: default-method irrelevant? drop t ;
-M: engine-word irrelevant? drop t ;
+M: predicate-engine irrelevant? drop t ;
PRIVATE>
USING: namespaces make continuations.private kernel.private init
assocs kernel vocabs words sequences memory io system arrays
continuations math definitions mirrors splitting parser classes
-summary layouts vocabs.loader prettyprint.config prettyprint
-debugger io.streams.c io.files io.files.temp io.pathnames
-io.directories io.directories.hierarchy io.backend quotations
-io.launcher words.private tools.deploy.config
-tools.deploy.config.editor bootstrap.image io.encodings.utf8
-destructors accessors hashtables ;
+summary layouts vocabs.loader prettyprint.config prettyprint debugger
+io.streams.c io.files io.files.temp io.pathnames io.directories
+io.directories.hierarchy io.backend quotations io.launcher
+tools.deploy.config tools.deploy.config.editor bootstrap.image
+io.encodings.utf8 destructors accessors hashtables ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name -- vm )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io.backend io.streams.c init fry
namespaces make assocs kernel parser lexer strings.parser vocabs
-sequences words words.private memory kernel.private
+sequences words memory kernel.private
continuations io vocabs.loader system strings sets
vectors quotations byte-arrays sorting compiler.units
definitions generic generic.standard tools.deploy.config ;
"compiled-uses"
"constraints"
"custom-inlining"
+ "decision-tree"
"declared-effect"
"default"
"default-method"
"engines"
"forgotten"
"identities"
- "if-intrinsics"
- "infer"
"inline"
"inlined-block"
"input-classes"
"instances"
"interval"
- "intrinsics"
+ "intrinsic"
"lambda"
"loc"
"local-reader"
"method-generic"
"modular-arithmetic"
"no-compile"
- "optimizer-hooks"
+ "owner-generic"
"outputs"
"participants"
"predicate"
"register"
"register-size"
"shuffle"
- "slot-names"
"slots"
"special"
"specializer"
- "step-into"
- "step-into?"
! UI needs this
! "superclass"
"transform-n"
"transform-quot"
- "tuple-dispatch-generic"
"type"
"writer"
"writing"
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.vectors memory io io.styles prettyprint
-namespaces system sequences splitting grouping assocs strings ;
+namespaces system sequences splitting grouping assocs strings
+generic.single combinators ;
IN: tools.time
: benchmark ( quot -- runtime )
micros [ call micros ] dip - ; inline
-: time. ( data -- )
- unclip
- "==== RUNNING TIME" print nl 1000000 /f pprint " seconds" print nl
+: time. ( time -- )
+ "== Running time ==" print nl 1000000 /f pprint " seconds" print ;
+
+: gc-stats. ( stats -- )
5 cut*
- "==== GARBAGE COLLECTION" print nl
+ "== Garbage collection ==" print nl
+ "Times are in microseconds." print nl
[
6 group
{
"GC count:"
- "Cumulative GC time (us):"
- "Longest GC pause (us):"
- "Average GC pause (us):"
+ "Total GC time:"
+ "Longest GC pause:"
+ "Average GC pause:"
"Objects copied:"
"Bytes copied:"
} prefix
[
nl
{
- "Total GC time (us):"
+ "Total GC time:"
"Cards scanned:"
"Decks scanned:"
- "Card scan time (us):"
+ "Card scan time:"
"Code heap literal scans:"
} swap zip simple-table.
] bi* ;
+: dispatch-stats. ( stats -- )
+ "== Megamorphic caches ==" print nl
+ { "Hits" "Misses" } swap zip simple-table. ;
+
+: inline-cache-stats. ( stats -- )
+ nl "== Polymorphic inline caches ==" print nl
+ 3 cut
+ [
+ "Transitions:" print
+ { "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } swap zip
+ simple-table. nl
+ ] [
+ "Type check stubs:" print
+ { "Tag only" "Hi-tag" "Tuple" "Hi-tag and tuple" } swap zip
+ simple-table.
+ ] bi* ;
+
: time ( quot -- )
- gc-reset micros [ call gc-stats micros ] dip - prefix time. ; inline
+ gc-reset
+ reset-dispatch-stats
+ reset-inline-cache-stats
+ benchmark gc-stats dispatch-stats inline-cache-stats
+ H{ { table-gap { 20 20 } } } [
+ [
+ [ [ time. ] 3dip ] with-cell
+ [ ] with-cell
+ ] with-row
+ [
+ [ [ gc-stats. ] 2dip ] with-cell
+ [ [ dispatch-stats. ] [ inline-cache-stats. ] bi* ] with-cell
+ ] with-row
+ ] tabular-output nl ; inline
USING: tools.walker io io.streams.string kernel math
math.private namespaces prettyprint sequences tools.test
continuations math.parser threads arrays tools.walker.debug
-generic.standard sequences.private kernel.private
+generic.single sequences.private kernel.private
tools.continuations accessors words ;
IN: tools.walker.tests
\ breakpoint-test don't-step-into
-[ f ] [ \ breakpoint-test optimized>> ] unit-test
+[ f ] [ \ breakpoint-test optimized? ] unit-test
[ { 3 } ] [ [ breakpoint-test ] test-walker ] unit-test
ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers
ui.tools.inspector ui.gadgets.status-bar ui.operations
ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs
-ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener
+ui.gadgets.labels ui.baseline-alignment ui.images
compiler.errors tools.errors tools.errors.model ;
IN: ui.tools.error-list
USING: accessors arrays assocs calendar colors colors.constants
documents documents.elements fry kernel words sets splitting math
math.vectors models.delay models.arrow combinators.short-circuit
-parser present sequences tools.completion help.vocabs generic
-generic.standard.engines.tuple fonts definitions.icons ui.images
-ui.commands ui.operations ui.gadgets ui.gadgets.editors
-ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables
-ui.gadgets.tracks ui.gadgets.labeled
+parser present sequences tools.completion help.vocabs generic fonts
+definitions.icons ui.images ui.commands ui.operations ui.gadgets
+ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers
+ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled
ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid
ui.tools.listener.history combinators vocabs ui.tools.listener.popups ;
IN: ui.tools.listener.completion
M: method-body completion-string method-completion-string ;
-M: engine-word completion-string method-completion-string ;
-
GENERIC# accept-completion-hook 1 ( item popup -- )
: insert-completion ( item popup -- )
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays
8 num-tags set
3 tag-bits set
-17 num-types set
+15 num-types set
+
+32 mega-cache-size set
H{
{ fixnum BIN: 000 }
{ bignum BIN: 001 }
- { tuple BIN: 010 }
- { object BIN: 011 }
- { hi-tag BIN: 011 }
- { ratio BIN: 100 }
- { float BIN: 101 }
- { complex BIN: 110 }
- { POSTPONE: f BIN: 111 }
+ { array BIN: 010 }
+ { float BIN: 011 }
+ { quotation BIN: 100 }
+ { POSTPONE: f BIN: 101 }
+ { object BIN: 110 }
+ { hi-tag BIN: 110 }
+ { tuple BIN: 111 }
} tag-numbers set
tag-numbers get H{
- { array 8 }
- { wrapper 9 }
- { byte-array 10 }
- { callstack 11 }
- { string 12 }
- { word 13 }
- { quotation 14 }
- { dll 15 }
- { alien 16 }
+ { wrapper 8 }
+ { byte-array 9 }
+ { callstack 10 }
+ { string 11 }
+ { word 12 }
+ { dll 13 }
+ { alien 14 }
} assoc-union type-numbers set
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math math.private math.order
"classes.predicate"
"compiler.units"
"continuations.private"
+ "generic.single"
+ "generic.single.private"
"growable"
"hashtables"
"hashtables.private"
"threads.private"
"tools.profiler.private"
"words"
- "words.private"
"vectors"
"vectors.private"
} [ create-vocab drop ] each
"fixnum" "math" create register-builtin
"bignum" "math" create register-builtin
"tuple" "kernel" create register-builtin
-"ratio" "math" create register-builtin
"float" "math" create register-builtin
-"complex" "math" create register-builtin
"f" "syntax" lookup register-builtin
"array" "arrays" create register-builtin
"wrapper" "kernel" create register-builtin
"f?" "syntax" vocab-words delete-at
! Some unions
-"integer" "math" create
-"fixnum" "math" lookup
-"bignum" "math" lookup
-2array
-define-union-class
-
-"rational" "math" create
-"integer" "math" lookup
-"ratio" "math" lookup
-2array
-define-union-class
-
-"real" "math" create
-"rational" "math" lookup
-"float" "math" lookup
-2array
-define-union-class
-
"c-ptr" "alien" create [
"alien" "alien" lookup ,
"f" "syntax" lookup ,
"bignum" "math" create { } define-builtin
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
-"ratio" "math" create {
- { "numerator" { "integer" "math" } read-only }
- { "denominator" { "integer" "math" } read-only }
-} define-builtin
-
"float" "math" create { } define-builtin
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
-"complex" "math" create {
- { "real" { "real" "math" } read-only }
- { "imaginary" { "real" "math" } read-only }
-} define-builtin
-
"array" "arrays" create {
{ "length" { "array-capacity" "sequences.private" } read-only }
} define-builtin
"vocabulary"
{ "def" { "quotation" "quotations" } initial: [ ] }
"props"
- { "optimized" read-only }
+ { "direct-entry-def" }
{ "counter" { "fixnum" "math" } }
{ "sub-primitive" read-only }
} define-builtin
[ create dup 1quotation ] dip define-declared ;
{
- { "(execute)" "words.private" (( word -- )) }
+ { "(execute)" "kernel.private" (( word -- )) }
{ "(call)" "kernel.private" (( quot -- )) }
{ "both-fixnums?" "math.private" (( x y -- ? )) }
{ "fixnum+fast" "math.private" (( x y -- z )) }
{ "get-local" "locals.backend" (( n -- obj )) }
{ "load-local" "locals.backend" (( obj -- )) }
{ "drop-locals" "locals.backend" (( n -- )) }
+ { "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) }
} [ first3 make-sub-primitive ] each
! Primitive words
{ "float>bignum" "math.private" (( x -- y )) }
{ "fixnum>float" "math.private" (( x -- y )) }
{ "bignum>float" "math.private" (( x -- y )) }
- { "<ratio>" "math.private" (( a b -- a/b )) }
{ "string>float" "math.private" (( str -- n/f )) }
{ "float>string" "math.private" (( n -- str )) }
{ "float>bits" "math" (( x -- n )) }
{ "double>bits" "math" (( x -- n )) }
{ "bits>float" "math" (( n -- x )) }
{ "bits>double" "math" (( n -- x )) }
- { "<complex>" "math.private" (( x y -- z )) }
{ "fixnum+" "math.private" (( x y -- z )) }
{ "fixnum-" "math.private" (( x y -- z )) }
{ "fixnum*" "math.private" (( x y -- z )) }
{ "jit-compile" "quotations" (( quot -- )) }
{ "load-locals" "locals.backend" (( ... n -- )) }
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
+ { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
+ { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
+ { "lookup-method" "generic.single.private" (( object methods -- method )) }
+ { "reset-dispatch-stats" "generic.single" (( -- )) }
+ { "dispatch-stats" "generic.single" (( -- stats )) }
+ { "reset-inline-cache-stats" "generic.single" (( -- )) }
+ { "inline-cache-stats" "generic.single" (( -- stats )) }
+ { "optimized?" "words" (( word -- ? )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number
M: hi-tag-class define-builtin-predicate
dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
- [ dup tag 3 eq? ] [ [ drop f ] if ] surround
+ [ dup tag 6 eq? ] [ [ drop f ] if ] surround
define-predicate ;
M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
M: hi-tag-class instance?
- over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
+ over tag 6 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
M: builtin-class (flatten-class) dup set ;
[ ] [ "IN: classes.mixin.tests.a" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
[ { string } ] [ move-instance-declaration-mixin members ] unit-test
+
+MIXIN: silly-mixin
+SYMBOL: not-a-class
+
+[ [ \ not-a-class \ silly-mixin add-mixin-instance ] with-compilation-unit ] must-fail
+
+SYMBOL: not-a-mixin
+TUPLE: a-class ;
+
+[ [ \ a-class \ not-a-mixin add-mixin-instance ] with-compilation-unit ] must-fail
[ [ f ] 2dip "instances" word-prop set-at ]
2bi ;
-: add-mixin-instance ( class mixin -- )
+GENERIC# add-mixin-instance 1 ( class mixin -- )
+
+M: class add-mixin-instance
#! Note: we call update-classes on the new member, not the
#! mixin. This ensures that we only have to update the
#! methods whose specializer intersects the new member, not
-USING: definitions generic kernel kernel.private math
-math.constants parser sequences tools.test words assocs
-namespaces quotations sequences.private classes continuations
-generic.standard effects classes.tuple classes.tuple.private
-arrays vectors strings compiler.units accessors classes.algebra
-calendar prettyprint io.streams.string splitting summary
-columns math.order classes.private slots slots.private eval see
-words.symbol compiler.errors ;
+USING: definitions generic kernel kernel.private math math.constants
+parser sequences tools.test words assocs namespaces quotations
+sequences.private classes continuations generic.single
+generic.standard effects classes.tuple classes.tuple.private arrays
+vectors strings compiler.units accessors classes.algebra calendar
+prettyprint io.streams.string splitting summary columns math.order
+classes.private slots slots.private eval see words.symbol
+compiler.errors ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
-[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test
+[ t ] [ \ compile-execute(-test-1 optimized? ] unit-test
[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
-[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test
+[ t ] [ \ compile-execute(-test-2 optimized? ] unit-test
[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
: compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ;
-[ t ] [ \ compile-call(-test-1 optimized>> ] unit-test
+[ t ] [ \ compile-call(-test-1 optimized? ] unit-test
[ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test
[ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test
[ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test
<< \ corner-case-1 2 [ + ] curry 1array [ case ] curry (( a -- b )) define-declared >>
-[ t ] [ \ corner-case-1 optimized>> ] unit-test
+[ t ] [ \ corner-case-1 optimized? ] unit-test
[ 4 ] [ 2 corner-case-1 ] unit-test
[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
{ $description "Outputs the number of objects added to the data stack by the stack effect. This will be negative if the stack effect only removes objects from the stack." } ;
HELP: effect<=
-{ $values { "eff1" effect } { "eff2" effect } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "eff1" } " is substitutable for " { $snippet "eff2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ;
+{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "effect1" } " is substitutable for " { $snippet "effect2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ;
+
+HELP: effect=
+{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "effect1" } " and " { $snippet "effect2" } " represent the same stack transformation, without looking parameter names." }
+{ $examples
+ { $example "USING: effects prettyprint ;" "(( a -- b )) (( x -- y )) effect= ." "t" }
+} ;
HELP: effect>string
{ $values { "obj" object } { "str" string } }
[ { "x" "y" } ] [ { "y" "x" } (( a b -- b a )) shuffle ] unit-test
[ { "y" "x" "y" } ] [ { "y" "x" } (( a b -- a b a )) shuffle ] unit-test
-[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test
\ No newline at end of file
+[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test
+
+[ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test
+[ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test
+[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
\ No newline at end of file
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser namespaces make sequences strings
+USING: kernel math math.parser math.order namespaces make sequences strings
words assocs combinators accessors arrays ;
IN: effects
: effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline
-: effect<= ( eff1 eff2 -- ? )
+: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
[ t ]
} cond 2nip ; inline
+: effect= ( effect1 effect2 -- ? )
+ [ [ in>> length ] bi@ = ]
+ [ [ out>> length ] bi@ = ]
+ [ [ terminated?>> ] bi@ = ]
+ 2tri and and ;
+
GENERIC: effect>string ( obj -- str )
M: string effect>string ;
M: object effect>string drop "object" ;
: add-effect-input ( effect -- effect' )
[ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ;
+
+: compose-effects ( effect1 effect2 -- effect' )
+ over terminated?>> [
+ drop
+ ] [
+ [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
+ [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
+ [ nip terminated?>> ] 2tri
+ effect boa
+ ] if ; inline
USING: help.markup help.syntax words classes classes.algebra
definitions kernel alien sequences math quotations
-generic.standard generic.math combinators prettyprint effects ;
+generic.single generic.standard generic.hook generic.math
+combinators prettyprint effects ;
IN: generic
ARTICLE: "method-order" "Method precedence"
[ t ] [ \ + math-generic? ] unit-test
-! Test math-combination
-[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
-[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
-[ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
-[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
-[ number ] [ \ number \ float math-class-max ] unit-test
-[ float ] [ \ real \ float math-class-max ] unit-test
-[ fixnum ] [ \ fixnum \ null math-class-max ] unit-test
-
! Regression
TUPLE: first-one ;
TUPLE: second-one ;
drop
2dup [ "combination" word-prop ] dip = [ 2drop ] [
{
+ [ drop reset-generic ]
[ "combination" set-word-prop ]
- [ drop "methods" word-prop values forget-all ]
[ drop H{ } clone "methods" set-word-prop ]
[ define-default-method ]
}
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: generic generic.single generic.standard help.markup help.syntax sequences math
+math.parser effects ;
+IN: generic.hook
+
+HELP: hook-combination
+{ $class-description
+ "Performs hook method combination . See " { $link POSTPONE: HOOK: } "."
+} ;
+
+{ standard-combination hook-combination } related-words
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors definitions generic generic.single
+generic.single.private kernel namespaces words kernel.private
+quotations sequences ;
+IN: generic.hook
+
+TUPLE: hook-combination < single-combination var ;
+
+C: <hook-combination> hook-combination
+
+PREDICATE: hook-generic < generic
+ "combination" word-prop hook-combination? ;
+
+M: hook-combination picker
+ combination get var>> [ get ] curry ;
+
+M: hook-combination dispatch# drop 0 ;
+
+M: hook-combination inline-cache-quot 2drop f ;
+
+M: hook-combination mega-cache-quot
+ 1quotation picker [ lookup-method (execute) ] surround ;
+
+M: hook-generic definer drop \ HOOK: f ;
+
+M: hook-generic effective-method
+ [ "combination" word-prop var>> get ] keep (effective-method) ;
\ No newline at end of file
USING: kernel generic help.markup help.syntax math classes
-sequences quotations ;
+sequences quotations generic.math.private ;
IN: generic.math
HELP: math-upgrade
--- /dev/null
+IN: generic.math.tests
+USING: generic.math math tools.test kernel ;
+
+! Test math-combination
+[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
+[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
+[ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
+[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
+
+[ number ] [ number float math-class-max ] unit-test
+[ number ] [ float number math-class-max ] unit-test
+[ float ] [ real float math-class-max ] unit-test
+[ float ] [ float real math-class-max ] unit-test
+[ fixnum ] [ fixnum null math-class-max ] unit-test
+[ fixnum ] [ null fixnum math-class-max ] unit-test
+[ bignum ] [ fixnum bignum math-class-max ] unit-test
+[ bignum ] [ bignum fixnum math-class-max ] unit-test
+[ number ] [ fixnum number math-class-max ] unit-test
+[ number ] [ number fixnum math-class-max ] unit-test
+
+
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
-namespaces make sequences words quotations layouts combinators
+namespaces sequences words quotations layouts combinators
sequences.private classes classes.builtin classes.algebra
-definitions math.order math.private ;
+definitions math.order math.private assocs ;
IN: generic.math
PREDICATE: math-class < class
number bootstrap-word class<=
] if ;
+<PRIVATE
+
: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
-: math-precedence ( class -- pair )
- {
- { [ dup null class<= ] [ drop { -1 -1 } ] }
- { [ dup math-class? ] [ class-types last/first ] }
- [ drop { 100 100 } ]
- } cond ;
-
-: math-class<=> ( class1 class2 -- class )
- [ math-precedence ] compare +gt+ eq? ;
+: bootstrap-words ( classes -- classes' )
+ [ bootstrap-word ] map ;
-: math-class-max ( class1 class2 -- class )
- [ math-class<=> ] most ;
+: math-precedence ( class -- pair )
+ [
+ { fixnum integer rational real number object } bootstrap-words
+ swap [ swap class<= ] curry find drop -1 or
+ ] [
+ { fixnum bignum ratio float complex object } bootstrap-words
+ swap [ class<= ] curry find drop -1 or
+ ] bi 2array ;
: (math-upgrade) ( max class -- quot )
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
+PRIVATE>
+
+: math-class-max ( class1 class2 -- class )
+ [ [ math-precedence ] bi@ after? ] most ;
+
: math-upgrade ( class1 class2 -- quot )
[ math-class-max ] 2keep
[
: default-math-method ( generic -- quot )
[ no-math-method ] curry [ ] like ;
+<PRIVATE
+
: applicable-method ( generic class -- quot )
over method
[ 1quotation ]
[ default-math-method ] ?if ;
+PRIVATE>
+
: object-method ( generic -- quot )
object bootstrap-word applicable-method ;
: math-method ( word class1 class2 -- quot )
2dup and [
- [
- 2dup 2array , \ declare ,
- 2dup math-upgrade %
- math-class-max over order min-class applicable-method %
- ] [ ] make
+ [ 2array [ declare ] curry nip ]
+ [ math-upgrade nip ]
+ [ math-class-max over order min-class applicable-method ]
+ 3tri 3append
] [
2drop object-method
] if ;
-SYMBOL: picker
+<PRIVATE
-: math-vtable ( picker quot -- quot )
- [
- [ , \ tag , ]
- [ num-tags get swap [ bootstrap-type>class ] prepose map , ] bi*
- \ dispatch ,
- ] [ ] make ; inline
+SYMBOL: generic-word
+
+: make-math-method-table ( classes quot: ( class -- quot ) -- alist )
+ [ bootstrap-words ] dip
+ [ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline
+
+: math-alist>quot ( alist -- quot )
+ [ generic-word get object-method ] dip alist>quot ;
+
+: tag-dispatch-entry ( tag picker -- quot )
+ [ "type" word-prop 1quotation [ tag ] [ eq? ] surround ] dip prepend ;
+
+: tag-dispatch ( picker alist -- alist' )
+ swap [ [ tag-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
+
+: tuple-dispatch-entry ( class picker -- quot )
+ [ 1quotation [ { tuple } declare class ] [ eq? ] surround ] dip prepend ;
+
+: tuple-dispatch ( picker alist -- alist' )
+ swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
+
+: math-dispatch-step ( picker quot: ( class -- quot ) -- quot )
+ [ [ { bignum float fixnum } ] dip make-math-method-table ]
+ [ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi
+ tuple swap 2array prefix tag-dispatch ; inline
+
+PRIVATE>
SINGLETON: math-combination
drop default-math-method ;
M: math-combination perform-combination
- drop
- dup
- [
- [ 2dup both-fixnums? ] %
- dup fixnum bootstrap-word dup math-method ,
- \ over [
- dup math-class? [
- \ dup [ [ 2dup ] dip math-method ] math-vtable
- ] [
- over object-method
- ] if nip
- ] math-vtable nip ,
- \ if ,
- ] [ ] make define ;
+ drop dup generic-word [
+ dup
+ [ fixnum bootstrap-word dup math-method ]
+ [
+ [ over ] [
+ dup math-class? [
+ [ dup ] [ math-method ] with with math-dispatch-step
+ ] [
+ drop object-method
+ ] if
+ ] with math-dispatch-step
+ ] bi
+ [ if ] 2curry [ 2dup both-fixnums? ] prepend
+ define
+ ] with-variable ;
PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: generic help.markup help.syntax sequences math
+math.parser effects ;
+IN: generic.single
+
+HELP: no-method
+{ $values { "object" "an object" } { "generic" "a generic word" } }
+{ $description "Throws a " { $link no-method } " error." }
+{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ;
+
+HELP: inconsistent-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
+{ $examples
+ "The following code throws this error:"
+ { $code
+ "GENERIC: error-test ( object -- )"
+ ""
+ "M: string error-test print ;"
+ ""
+ "M: integer error-test number>string call-next-method ;"
+ ""
+ "123 error-test"
+ }
+ "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
+ $nl
+ "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
+ { $code "M: integer error-test number>string error-test ;" }
+} ;
\ No newline at end of file
--- /dev/null
+IN: generic.single.tests
+USING: tools.test math math.functions math.constants generic.standard
+generic.single strings sequences arrays kernel accessors words
+specialized-arrays.double byte-arrays bit-arrays parser namespaces
+make quotations stack-checker vectors growable hashtables sbufs
+prettyprint byte-vectors bit-vectors specialized-vectors.double
+definitions generic sets graphs assocs grouping see eval ;
+
+GENERIC: lo-tag-test ( obj -- obj' )
+
+M: integer lo-tag-test 3 + ;
+
+M: float lo-tag-test 4 - ;
+
+M: rational lo-tag-test 2 - ;
+
+M: complex lo-tag-test sq ;
+
+[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
+[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
+[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
+[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
+
+GENERIC: hi-tag-test ( obj -- obj' )
+
+M: string hi-tag-test ", in bed" append ;
+
+M: integer hi-tag-test 3 + ;
+
+M: array hi-tag-test [ hi-tag-test ] map ;
+
+M: sequence hi-tag-test reverse ;
+
+[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
+
+[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
+
+[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
+
+TUPLE: shape ;
+
+TUPLE: abstract-rectangle < shape width height ;
+
+TUPLE: rectangle < abstract-rectangle ;
+
+C: <rectangle> rectangle
+
+TUPLE: parallelogram < abstract-rectangle skew ;
+
+C: <parallelogram> parallelogram
+
+TUPLE: circle < shape radius ;
+
+C: <circle> circle
+
+GENERIC: area ( shape -- n )
+
+M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
+
+M: circle area radius>> sq pi * ;
+
+[ 12 ] [ 4 3 <rectangle> area ] unit-test
+[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
+[ t ] [ 2 <circle> area 4 pi * = ] unit-test
+
+GENERIC: perimiter ( shape -- n )
+
+: rectangle-perimiter ( l w -- n ) + 2 * ;
+
+M: rectangle perimiter
+ [ width>> ] [ height>> ] bi
+ rectangle-perimiter ;
+
+: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
+
+M: parallelogram perimiter
+ [ width>> ]
+ [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
+ rectangle-perimiter ;
+
+M: circle perimiter 2 * pi * ;
+
+[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
+[ 30.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
+
+GENERIC: big-mix-test ( obj -- obj' )
+
+M: object big-mix-test drop "object" ;
+
+M: tuple big-mix-test drop "tuple" ;
+
+M: integer big-mix-test drop "integer" ;
+
+M: float big-mix-test drop "float" ;
+
+M: complex big-mix-test drop "complex" ;
+
+M: string big-mix-test drop "string" ;
+
+M: array big-mix-test drop "array" ;
+
+M: sequence big-mix-test drop "sequence" ;
+
+M: rectangle big-mix-test drop "rectangle" ;
+
+M: parallelogram big-mix-test drop "parallelogram" ;
+
+M: circle big-mix-test drop "circle" ;
+
+[ "integer" ] [ 3 big-mix-test ] unit-test
+[ "float" ] [ 5.0 big-mix-test ] unit-test
+[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
+[ "sequence" ] [ double-array{ 1.0 2.0 3.0 } big-mix-test ] unit-test
+[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
+[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
+[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
+[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
+[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
+[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
+[ "sequence" ] [ double-vector{ -0.3 4.6 } big-mix-test ] unit-test
+[ "string" ] [ "hello" big-mix-test ] unit-test
+[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
+[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
+[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
+[ "tuple" ] [ H{ } big-mix-test ] unit-test
+[ "object" ] [ \ + big-mix-test ] unit-test
+
+GENERIC: small-lo-tag ( obj -- obj )
+
+M: fixnum small-lo-tag drop "fixnum" ;
+
+M: string small-lo-tag drop "string" ;
+
+M: array small-lo-tag drop "array" ;
+
+M: double-array small-lo-tag drop "double-array" ;
+
+M: byte-array small-lo-tag drop "byte-array" ;
+
+[ "fixnum" ] [ 3 small-lo-tag ] unit-test
+
+[ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test
+
+! Testing next-method
+TUPLE: person ;
+
+TUPLE: intern < person ;
+
+TUPLE: employee < person ;
+
+TUPLE: tape-monkey < employee ;
+
+TUPLE: manager < employee ;
+
+TUPLE: junior-manager < manager ;
+
+TUPLE: middle-manager < manager ;
+
+TUPLE: senior-manager < manager ;
+
+TUPLE: executive < senior-manager ;
+
+TUPLE: ceo < executive ;
+
+GENERIC: salary ( person -- n )
+
+M: intern salary
+ #! Intentional mistake.
+ call-next-method ;
+
+M: employee salary drop 24000 ;
+
+M: manager salary call-next-method 12000 + ;
+
+M: middle-manager salary call-next-method 5000 + ;
+
+M: senior-manager salary call-next-method 15000 + ;
+
+M: executive salary call-next-method 2 * ;
+
+M: ceo salary
+ #! Intentional error.
+ drop 5 call-next-method 3 * ;
+
+[ salary ] must-infer
+
+[ 24000 ] [ employee boa salary ] unit-test
+
+[ 24000 ] [ tape-monkey boa salary ] unit-test
+
+[ 36000 ] [ junior-manager boa salary ] unit-test
+
+[ 41000 ] [ middle-manager boa salary ] unit-test
+
+[ 51000 ] [ senior-manager boa salary ] unit-test
+
+[ 102000 ] [ executive boa salary ] unit-test
+
+[ ceo boa salary ]
+[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
+
+[ intern boa salary ]
+[ no-next-method? ] must-fail-with
+
+! Weird shit
+TUPLE: a ;
+TUPLE: b ;
+TUPLE: c ;
+
+UNION: x a b ;
+UNION: y a c ;
+
+UNION: z x y ;
+
+GENERIC: funky* ( obj -- )
+
+M: z funky* "z" , drop ;
+
+M: x funky* "x" , call-next-method ;
+
+M: y funky* "y" , call-next-method ;
+
+M: a funky* "a" , call-next-method ;
+
+M: b funky* "b" , call-next-method ;
+
+M: c funky* "c" , call-next-method ;
+
+: funky ( obj -- seq ) [ funky* ] { } make ;
+
+[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
+
+[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
+
+[ t ] [
+ T{ a } funky
+ { { "a" "x" "z" } { "a" "y" "z" } } member?
+] unit-test
+
+! Hooks
+SYMBOL: my-var
+HOOK: my-hook my-var ( -- x )
+
+M: integer my-hook "an integer" ;
+M: string my-hook "a string" ;
+
+[ "an integer" ] [ 3 my-var set my-hook ] unit-test
+[ "a string" ] [ my-hook my-var set my-hook ] unit-test
+[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
+
+HOOK: call-next-hooker my-var ( -- x )
+
+M: sequence call-next-hooker "sequence" ;
+
+M: array call-next-hooker call-next-method "array " prepend ;
+
+M: vector call-next-hooker call-next-method "vector " prepend ;
+
+M: growable call-next-hooker call-next-method "growable " prepend ;
+
+[ "vector growable sequence" ] [
+ V{ } my-var [ call-next-hooker ] with-variable
+] unit-test
+
+[ t ] [
+ { } \ nth effective-method nip M\ sequence nth eq?
+] unit-test
+
+[ t ] [
+ \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
+] unit-test
+
+[ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
+[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
+
+[ f ] [ "xyz" "generic.single.tests" lookup direct-entry-def>> ] unit-test
+[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes classes.algebra
+combinators definitions generic hashtables kernel
+kernel.private layouts math namespaces quotations
+sequences words generic.single.private effects make ;
+IN: generic.single
+
+ERROR: no-method object generic ;
+
+ERROR: inconsistent-next-method class generic ;
+
+TUPLE: single-combination ;
+
+PREDICATE: single-generic < generic
+ "combination" word-prop single-combination? ;
+
+GENERIC: dispatch# ( word -- n )
+
+M: generic dispatch# "combination" word-prop dispatch# ;
+
+SYMBOL: assumed
+SYMBOL: default
+SYMBOL: generic-word
+SYMBOL: combination
+
+: with-combination ( combination quot -- )
+ [ combination ] dip with-variable ; inline
+
+HOOK: picker combination ( -- quot )
+
+M: single-combination next-method-quot* ( class generic combination -- quot )
+ [
+ 2dup next-method dup [
+ [
+ pick "predicate" word-prop %
+ 1quotation ,
+ [ inconsistent-next-method ] 2curry ,
+ \ if ,
+ ] [ ] make picker prepend
+ ] [ 3drop f ] if
+ ] with-combination ;
+
+: (effective-method) ( obj word -- method )
+ [ [ order [ instance? ] with find-last nip ] keep method ]
+ [ "default-method" word-prop ]
+ bi or ;
+
+M: single-combination make-default-method
+ [ [ picker ] dip [ no-method ] curry append ] with-combination ;
+
+! ! ! Build an engine ! ! !
+
+: find-default ( methods -- default )
+ #! Side-effects methods.
+ [ object bootstrap-word ] dip delete-at* [
+ drop generic-word get "default-method" word-prop
+ ] unless ;
+
+! 1. Flatten methods
+TUPLE: predicate-engine methods ;
+
+: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
+
+: push-method ( method specializer atomic assoc -- )
+ [
+ [ H{ } clone <predicate-engine> ] unless*
+ [ methods>> set-at ] keep
+ ] change-at ;
+
+: flatten-method ( class method assoc -- )
+ [ [ flatten-class keys ] keep ] 2dip [
+ [ spin ] dip push-method
+ ] 3curry each ;
+
+: flatten-methods ( assoc -- assoc' )
+ H{ } clone [ [ flatten-method ] curry assoc-each ] keep ;
+
+! 2. Convert methods
+: split-methods ( assoc class -- first second )
+ [ [ nip class<= not ] curry assoc-filter ]
+ [ [ nip class<= ] curry assoc-filter ] 2bi ;
+
+: convert-methods ( assoc class word -- assoc' )
+ over [ split-methods ] 2dip pick assoc-empty?
+ [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline
+
+! 2.1 Convert tuple methods
+TUPLE: echelon-dispatch-engine n methods ;
+
+C: <echelon-dispatch-engine> echelon-dispatch-engine
+
+TUPLE: tuple-dispatch-engine echelons ;
+
+: push-echelon ( class method assoc -- )
+ [ swap dup "layout" word-prop third ] dip
+ [ ?set-at ] change-at ;
+
+: echelon-sort ( assoc -- assoc' )
+ #! Convert an assoc mapping classes to methods into an
+ #! assoc mapping echelons to assocs. The first echelon
+ #! is always there
+ H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ;
+
+: <tuple-dispatch-engine> ( methods -- engine )
+ echelon-sort
+ [ dupd <echelon-dispatch-engine> ] assoc-map
+ \ tuple-dispatch-engine boa ;
+
+: convert-tuple-methods ( assoc -- assoc' )
+ tuple bootstrap-word
+ \ <tuple-dispatch-engine> convert-methods ;
+
+! 2.2 Convert hi-tag methods
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+ \ hi-tag bootstrap-word
+ \ <hi-tag-dispatch-engine> convert-methods ;
+
+! 3 Tag methods
+TUPLE: tag-dispatch-engine methods ;
+
+C: <tag-dispatch-engine> tag-dispatch-engine
+
+: <engine> ( assoc -- engine )
+ flatten-methods
+ convert-tuple-methods
+ convert-hi-tag-methods
+ <tag-dispatch-engine> ;
+
+! ! ! Compile engine ! ! !
+GENERIC: compile-engine ( engine -- obj )
+
+: compile-engines ( assoc -- assoc' )
+ [ compile-engine ] assoc-map ;
+
+: compile-engines* ( assoc -- assoc' )
+ [ over assumed [ compile-engine ] with-variable ] assoc-map ;
+
+: direct-dispatch-table ( assoc n -- table )
+ default get <array> [ <enum> swap update ] keep ;
+
+: lo-tag-number ( class -- n )
+ "type" word-prop dup num-tags get member?
+ [ drop object tag-number ] unless ;
+
+M: tag-dispatch-engine compile-engine
+ methods>> compile-engines*
+ [ [ lo-tag-number ] dip ] assoc-map
+ num-tags get direct-dispatch-table ;
+
+: num-hi-tags ( -- n ) num-types get num-tags get - ;
+
+: hi-tag-number ( class -- n ) "type" word-prop ;
+
+M: hi-tag-dispatch-engine compile-engine
+ methods>> compile-engines*
+ [ [ hi-tag-number num-tags get - ] dip ] assoc-map
+ num-hi-tags direct-dispatch-table ;
+
+: build-fast-hash ( methods -- buckets )
+ >alist V{ } clone [ hashcode 1array ] distribute-buckets
+ [ compile-engines* >alist >array ] map ;
+
+M: echelon-dispatch-engine compile-engine
+ dup n>> 0 = [
+ methods>> dup assoc-size {
+ { 0 [ drop default get ] }
+ { 1 [ >alist first second compile-engine ] }
+ } case
+ ] [
+ methods>> compile-engines* build-fast-hash
+ ] if ;
+
+M: tuple-dispatch-engine compile-engine
+ tuple assumed [
+ echelons>> compile-engines
+ dup keys supremum 1+ f <array>
+ [ <enum> swap update ] keep
+ ] with-variable ;
+
+: sort-methods ( assoc -- assoc' )
+ >alist [ keys sort-classes ] keep extract-keys ;
+
+: quote-methods ( assoc -- assoc' )
+ [ 1quotation \ drop prefix ] assoc-map ;
+
+: methods-with-default ( engine -- assoc )
+ methods>> clone default get object bootstrap-word pick set-at ;
+
+: keep-going? ( assoc -- ? )
+ assumed get swap second first class<= ;
+
+: prune-redundant-predicates ( assoc -- default assoc' )
+ {
+ { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+ { [ dup length 1 = ] [ first second { } ] }
+ { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
+ [ [ first second ] [ rest-slice ] bi ]
+ } cond ;
+
+: class-predicates ( assoc -- assoc )
+ [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
+
+PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
+
+: <predicate-engine-word> ( -- word )
+ generic-word get name>> "/predicate-engine" append f <word>
+ dup generic-word get "owner-generic" set-word-prop ;
+
+M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
+
+: define-predicate-engine ( alist -- word )
+ [ <predicate-engine-word> ] dip
+ [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
+
+M: predicate-engine compile-engine
+ methods-with-default
+ sort-methods
+ quote-methods
+ prune-redundant-predicates
+ class-predicates
+ [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
+
+M: word compile-engine ;
+
+M: f compile-engine ;
+
+: build-decision-tree ( generic -- methods )
+ [ "engines" word-prop forget-all ]
+ [ V{ } clone "engines" set-word-prop ]
+ [
+ "methods" word-prop clone
+ [ find-default default set ]
+ [ <engine> compile-engine ] bi
+ ] tri ;
+
+HOOK: inline-cache-quot combination ( word methods -- quot/f )
+
+: define-inline-cache-quot ( word methods -- )
+ [ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ;
+
+HOOK: mega-cache-quot combination ( methods -- quot/f )
+
+M: single-combination perform-combination
+ [
+ dup generic-word set
+ dup build-decision-tree
+ [ "decision-tree" set-word-prop ]
+ [ mega-cache-quot define ]
+ [ define-inline-cache-quot ]
+ 2tri
+ ] with-combination ;
\ No newline at end of file
-Slava Pestov
+Slava Pestov
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel kernel.private namespaces quotations
-generic math sequences combinators words classes.algebra arrays
-;
-IN: generic.standard.engines
-
-SYMBOL: default
-SYMBOL: assumed
-SYMBOL: (dispatch#)
-
-GENERIC: engine>quot ( engine -- quot )
-
-: engines>quots ( assoc -- assoc' )
- [ engine>quot ] assoc-map ;
-
-: engines>quots* ( assoc -- assoc' )
- [ over assumed [ engine>quot ] with-variable ] assoc-map ;
-
-: if-small? ( assoc true false -- )
- [ dup assoc-size 4 <= ] 2dip if ; inline
-
-: linear-dispatch-quot ( alist -- quot )
- default get [ drop ] prepend swap
- [
- [ [ dup ] swap [ eq? ] curry compose ]
- [ [ drop ] prepose ]
- bi* [ ] like
- ] assoc-map
- alist>quot ;
-
-: split-methods ( assoc class -- first second )
- [ [ nip class<= not ] curry assoc-filter ]
- [ [ nip class<= ] curry assoc-filter ] 2bi ;
-
-: convert-methods ( assoc class word -- assoc' )
- over [ split-methods ] 2dip pick assoc-empty? [
- 3drop
- ] [
- [ execute ] dip pick set-at
- ] if ; inline
-
-: (picker) ( n -- quot )
- {
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1- (picker) [ dip swap ] curry ]
- } case ;
-
-: picker ( -- quot ) \ (dispatch#) get (picker) ;
-
-GENERIC: extra-values ( generic -- n )
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generic.standard.engines generic namespaces kernel
-kernel.private sequences classes.algebra accessors words
-combinators assocs arrays ;
-IN: generic.standard.engines.predicate
-
-TUPLE: predicate-dispatch-engine methods ;
-
-C: <predicate-dispatch-engine> predicate-dispatch-engine
-
-: class-predicates ( assoc -- assoc )
- [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ;
-
-: keep-going? ( assoc -- ? )
- assumed get swap second first class<= ;
-
-: prune-redundant-predicates ( assoc -- default assoc' )
- {
- { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
- { [ dup length 1 = ] [ first second { } ] }
- { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
- [ [ first second ] [ rest-slice ] bi ]
- } cond ;
-
-: sort-methods ( assoc -- assoc' )
- >alist [ keys sort-classes ] keep extract-keys ;
-
-: methods-with-default ( engine -- assoc )
- methods>> clone default get object bootstrap-word pick set-at ;
-
-M: predicate-dispatch-engine engine>quot
- methods-with-default
- engines>quots
- sort-methods
- prune-redundant-predicates
- class-predicates
- alist>quot ;
+++ /dev/null
-Chained-conditional dispatch strategy
+++ /dev/null
-Generic word dispatch strategy implementation
+++ /dev/null
-Jump table keyed by pointer tag dispatch strategy
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes.private generic.standard.engines namespaces make
-arrays assocs sequences.private quotations kernel.private
-math slots.private math.private kernel accessors words
-layouts sorting sequences combinators ;
-IN: generic.standard.engines.tag
-
-TUPLE: lo-tag-dispatch-engine methods ;
-
-C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
-
-: direct-dispatch-quot ( alist n -- quot )
- default get <array>
- [ <enum> swap update ] keep
- [ dispatch ] curry >quotation ;
-
-: lo-tag-number ( class -- n )
- dup \ hi-tag bootstrap-word eq? [
- drop \ hi-tag tag-number
- ] [
- "type" word-prop
- ] if ;
-
-: sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
-
-: tag-dispatch-test ( tag# -- quot )
- picker [ tag ] append swap [ eq? ] curry append ;
-
-: tag-dispatch-quot ( alist -- quot )
- [ default get ] dip
- [ [ tag-dispatch-test ] dip ] assoc-map
- alist>quot ;
-
-M: lo-tag-dispatch-engine engine>quot
- methods>> engines>quots*
- [ [ lo-tag-number ] dip ] assoc-map
- [
- [ sort-tags tag-dispatch-quot ]
- [ picker % [ tag ] % num-tags get direct-dispatch-quot ]
- if-small? %
- ] [ ] make ;
-
-TUPLE: hi-tag-dispatch-engine methods ;
-
-C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
-
-: convert-hi-tag-methods ( assoc -- assoc' )
- \ hi-tag bootstrap-word
- \ <hi-tag-dispatch-engine> convert-methods ;
-
-: num-hi-tags ( -- n ) num-types get num-tags get - ;
-
-: hi-tag-number ( class -- n )
- "type" word-prop ;
-
-: hi-tag-quot ( -- quot )
- \ hi-tag def>> ;
-
-M: hi-tag-dispatch-engine engine>quot
- methods>> engines>quots*
- [ [ hi-tag-number ] dip ] assoc-map
- [
- picker % hi-tag-quot % [
- sort-tags linear-dispatch-quot
- ] [
- num-tags get , \ fixnum-fast ,
- [ [ num-tags get - ] dip ] assoc-map
- num-hi-tags direct-dispatch-quot
- ] if-small? %
- ] [ ] make ;
+++ /dev/null
-Tuple class dispatch strategy
+++ /dev/null
-! Copyright (c) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes.tuple.private hashtables assocs sorting
-accessors combinators sequences slots.private math.parser words
-effects namespaces make generic generic.standard.engines
-classes.algebra math math.private kernel.private
-quotations arrays definitions ;
-IN: generic.standard.engines.tuple
-
-: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline
-
-: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline
-
-: tuple-layout% ( -- )
- [ { tuple } declare 1 slot { array } declare ] % ; inline
-
-: tuple-layout-echelon% ( -- )
- [ 4 slot ] % ; inline
-
-TUPLE: echelon-dispatch-engine n methods ;
-
-C: <echelon-dispatch-engine> echelon-dispatch-engine
-
-TUPLE: trivial-tuple-dispatch-engine n methods ;
-
-C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
-
-TUPLE: tuple-dispatch-engine echelons ;
-
-: push-echelon ( class method assoc -- )
- [ swap dup "layout" word-prop third ] dip
- [ ?set-at ] change-at ;
-
-: echelon-sort ( assoc -- assoc' )
- V{ } clone [
- [
- push-echelon
- ] curry assoc-each
- ] keep sort-keys ;
-
-: <tuple-dispatch-engine> ( methods -- engine )
- echelon-sort
- [ dupd <echelon-dispatch-engine> ] assoc-map
- \ tuple-dispatch-engine boa ;
-
-: convert-tuple-methods ( assoc -- assoc' )
- tuple bootstrap-word
- \ <tuple-dispatch-engine> convert-methods ;
-
-M: trivial-tuple-dispatch-engine engine>quot
- [ n>> ] [ methods>> ] bi dup assoc-empty? [
- 2drop default get [ drop ] prepend
- ] [
- [
- [ nth-superclass% ]
- [ engines>quots* linear-dispatch-quot % ] bi*
- ] [ ] make
- ] if ;
-
-: hash-methods ( n methods -- buckets )
- >alist V{ } clone [ hashcode 1array ] distribute-buckets
- [ <trivial-tuple-dispatch-engine> ] with map ;
-
-: class-hash-dispatch-quot ( n methods -- quot )
- [
- \ dup ,
- [ drop nth-hashcode% ]
- [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi
- ] [ ] make ;
-
-: engine-word-name ( -- string )
- generic get name>> "/tuple-dispatch-engine" append ;
-
-PREDICATE: engine-word < word
- "tuple-dispatch-generic" word-prop generic? ;
-
-M: engine-word stack-effect
- "tuple-dispatch-generic" word-prop
- [ extra-values ] [ stack-effect ] bi
- dup [
- [ in>> length + ] [ out>> ] [ terminated?>> ] tri
- effect boa
- ] [ 2drop f ] if ;
-
-M: engine-word where "tuple-dispatch-generic" word-prop where ;
-
-M: engine-word crossref? "forgotten" word-prop not ;
-
-: remember-engine ( word -- )
- generic get "engines" word-prop push ;
-
-: <engine-word> ( -- word )
- engine-word-name f <word>
- dup generic get "tuple-dispatch-generic" set-word-prop ;
-
-: define-engine-word ( quot -- word )
- [ <engine-word> dup ] dip define ;
-
-: tuple-dispatch-engine-body ( engine -- quot )
- [
- picker %
- tuple-layout%
- [ n>> ] [ methods>> ] bi
- [ <trivial-tuple-dispatch-engine> engine>quot ]
- [ class-hash-dispatch-quot ]
- if-small? %
- ] [ ] make ;
-
-M: echelon-dispatch-engine engine>quot
- dup n>> zero? [
- methods>> dup assoc-empty?
- [ drop default get ] [ values first engine>quot ] if
- ] [
- tuple-dispatch-engine-body
- ] if ;
-
-: >=-case-quot ( default alist -- quot )
- [ [ drop ] prepend ] dip
- [
- [ [ dup ] swap [ fixnum>= ] curry compose ]
- [ [ drop ] prepose ]
- bi* [ ] like
- ] assoc-map
- alist>quot ;
-
-: simplify-echelon-alist ( default alist -- default' alist' )
- dup empty? [
- dup first first 1 <= [
- nip unclip second swap
- simplify-echelon-alist
- ] when
- ] unless ;
-
-: echelon-case-quot ( alist -- quot )
- #! We don't have to test for echelon 1 since all tuple
- #! classes are at least at depth 1 in the inheritance
- #! hierarchy.
- default get swap simplify-echelon-alist
- [
- [
- picker %
- tuple-layout%
- tuple-layout-echelon%
- >=-case-quot %
- ] [ ] make
- ] unless-empty ;
-
-M: tuple-dispatch-engine engine>quot
- [
- [
- tuple assumed set
- echelons>> unclip-last
- [
- [
- engine>quot
- over 0 = [
- define-engine-word
- [ remember-engine ] [ 1quotation ] bi
- ] unless
- dup default set
- ] assoc-map
- ]
- [ first2 engine>quot 2array ] bi*
- suffix
- ] with-scope
- echelon-case-quot %
- ] [ ] make ;
-USING: generic help.markup help.syntax sequences math
+USING: generic generic.single help.markup help.syntax sequences math
math.parser effects ;
IN: generic.standard
-HELP: no-method
-{ $values { "object" "an object" } { "generic" "a generic word" } }
-{ $description "Throws a " { $link no-method } " error." }
-{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ;
-
HELP: standard-combination
{ $class-description
"Performs standard method combination."
}
} ;
-HELP: hook-combination
-{ $class-description
- "Performs hook method combination . See " { $link POSTPONE: HOOK: } "."
-} ;
-
HELP: define-simple-generic
{ $values { "word" "a word" } { "effect" effect } }
-{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
-
-{ standard-combination hook-combination } related-words
-
-HELP: inconsistent-next-method
-{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
-{ $examples
- "The following code throws this error:"
- { $code
- "GENERIC: error-test ( object -- )"
- ""
- "M: string error-test print ;"
- ""
- "M: integer error-test number>string call-next-method ;"
- ""
- "123 error-test"
- }
- "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
- $nl
- "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
- { $code "M: integer error-test number>string error-test ;" }
-} ;
+{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
\ No newline at end of file
+++ /dev/null
-IN: generic.standard.tests
-USING: tools.test math math.functions math.constants
-generic.standard strings sequences arrays kernel accessors words
-specialized-arrays.double byte-arrays bit-arrays parser
-namespaces make quotations stack-checker vectors growable
-hashtables sbufs prettyprint byte-vectors bit-vectors
-specialized-vectors.double definitions generic sets graphs assocs
-grouping see ;
-
-GENERIC: lo-tag-test ( obj -- obj' )
-
-M: integer lo-tag-test 3 + ;
-
-M: float lo-tag-test 4 - ;
-
-M: rational lo-tag-test 2 - ;
-
-M: complex lo-tag-test sq ;
-
-[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
-[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
-[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
-[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
-
-GENERIC: hi-tag-test ( obj -- obj' )
-
-M: string hi-tag-test ", in bed" append ;
-
-M: integer hi-tag-test 3 + ;
-
-M: array hi-tag-test [ hi-tag-test ] map ;
-
-M: sequence hi-tag-test reverse ;
-
-[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
-
-[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
-
-[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
-
-TUPLE: shape ;
-
-TUPLE: abstract-rectangle < shape width height ;
-
-TUPLE: rectangle < abstract-rectangle ;
-
-C: <rectangle> rectangle
-
-TUPLE: parallelogram < abstract-rectangle skew ;
-
-C: <parallelogram> parallelogram
-
-TUPLE: circle < shape radius ;
-
-C: <circle> circle
-
-GENERIC: area ( shape -- n )
-
-M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
-
-M: circle area radius>> sq pi * ;
-
-[ 12 ] [ 4 3 <rectangle> area ] unit-test
-[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
-[ t ] [ 2 <circle> area 4 pi * = ] unit-test
-
-GENERIC: perimiter ( shape -- n )
-
-: rectangle-perimiter ( l w -- n ) + 2 * ;
-
-M: rectangle perimiter
- [ width>> ] [ height>> ] bi
- rectangle-perimiter ;
-
-: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
-
-M: parallelogram perimiter
- [ width>> ]
- [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
- rectangle-perimiter ;
-
-M: circle perimiter 2 * pi * ;
-
-[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
-[ 30.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
-
-GENERIC: big-mix-test ( obj -- obj' )
-
-M: object big-mix-test drop "object" ;
-
-M: tuple big-mix-test drop "tuple" ;
-
-M: integer big-mix-test drop "integer" ;
-
-M: float big-mix-test drop "float" ;
-
-M: complex big-mix-test drop "complex" ;
-
-M: string big-mix-test drop "string" ;
-
-M: array big-mix-test drop "array" ;
-
-M: sequence big-mix-test drop "sequence" ;
-
-M: rectangle big-mix-test drop "rectangle" ;
-
-M: parallelogram big-mix-test drop "parallelogram" ;
-
-M: circle big-mix-test drop "circle" ;
-
-[ "integer" ] [ 3 big-mix-test ] unit-test
-[ "float" ] [ 5.0 big-mix-test ] unit-test
-[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
-[ "sequence" ] [ double-array{ 1.0 2.0 3.0 } big-mix-test ] unit-test
-[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
-[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
-[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
-[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
-[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
-[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
-[ "sequence" ] [ double-vector{ -0.3 4.6 } big-mix-test ] unit-test
-[ "string" ] [ "hello" big-mix-test ] unit-test
-[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
-[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
-[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
-[ "tuple" ] [ H{ } big-mix-test ] unit-test
-[ "object" ] [ \ + big-mix-test ] unit-test
-
-GENERIC: small-lo-tag ( obj -- obj )
-
-M: fixnum small-lo-tag drop "fixnum" ;
-
-M: string small-lo-tag drop "string" ;
-
-M: array small-lo-tag drop "array" ;
-
-M: double-array small-lo-tag drop "double-array" ;
-
-M: byte-array small-lo-tag drop "byte-array" ;
-
-[ "fixnum" ] [ 3 small-lo-tag ] unit-test
-
-[ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test
-
-! Testing next-method
-TUPLE: person ;
-
-TUPLE: intern < person ;
-
-TUPLE: employee < person ;
-
-TUPLE: tape-monkey < employee ;
-
-TUPLE: manager < employee ;
-
-TUPLE: junior-manager < manager ;
-
-TUPLE: middle-manager < manager ;
-
-TUPLE: senior-manager < manager ;
-
-TUPLE: executive < senior-manager ;
-
-TUPLE: ceo < executive ;
-
-GENERIC: salary ( person -- n )
-
-M: intern salary
- #! Intentional mistake.
- call-next-method ;
-
-M: employee salary drop 24000 ;
-
-M: manager salary call-next-method 12000 + ;
-
-M: middle-manager salary call-next-method 5000 + ;
-
-M: senior-manager salary call-next-method 15000 + ;
-
-M: executive salary call-next-method 2 * ;
-
-M: ceo salary
- #! Intentional error.
- drop 5 call-next-method 3 * ;
-
-[ salary ] must-infer
-
-[ 24000 ] [ employee boa salary ] unit-test
-
-[ 24000 ] [ tape-monkey boa salary ] unit-test
-
-[ 36000 ] [ junior-manager boa salary ] unit-test
-
-[ 41000 ] [ middle-manager boa salary ] unit-test
-
-[ 51000 ] [ senior-manager boa salary ] unit-test
-
-[ 102000 ] [ executive boa salary ] unit-test
-
-[ ceo boa salary ]
-[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
-
-[ intern boa salary ]
-[ no-next-method? ] must-fail-with
-
-! Weird shit
-TUPLE: a ;
-TUPLE: b ;
-TUPLE: c ;
-
-UNION: x a b ;
-UNION: y a c ;
-
-UNION: z x y ;
-
-GENERIC: funky* ( obj -- )
-
-M: z funky* "z" , drop ;
-
-M: x funky* "x" , call-next-method ;
-
-M: y funky* "y" , call-next-method ;
-
-M: a funky* "a" , call-next-method ;
-
-M: b funky* "b" , call-next-method ;
-
-M: c funky* "c" , call-next-method ;
-
-: funky ( obj -- seq ) [ funky* ] { } make ;
-
-[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
-
-[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
-
-[ t ] [
- T{ a } funky
- { { "a" "x" "z" } { "a" "y" "z" } } member?
-] unit-test
-
-! Hooks
-SYMBOL: my-var
-HOOK: my-hook my-var ( -- x )
-
-M: integer my-hook "an integer" ;
-M: string my-hook "a string" ;
-
-[ "an integer" ] [ 3 my-var set my-hook ] unit-test
-[ "a string" ] [ my-hook my-var set my-hook ] unit-test
-[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
-
-HOOK: my-tuple-hook my-var ( -- x )
-
-M: sequence my-tuple-hook my-hook ;
-
-TUPLE: m-t-h-a ;
-
-M: m-t-h-a my-tuple-hook "foo" ;
-
-TUPLE: m-t-h-b < m-t-h-a ;
-
-M: m-t-h-b my-tuple-hook "bar" ;
-
-[ f ] [
- \ my-tuple-hook [ "engines" word-prop ] keep prefix
- [ 1quotation infer ] map all-equal?
-] unit-test
-
-HOOK: call-next-hooker my-var ( -- x )
-
-M: sequence call-next-hooker "sequence" ;
-
-M: array call-next-hooker call-next-method "array " prepend ;
-
-M: vector call-next-hooker call-next-method "vector " prepend ;
-
-M: growable call-next-hooker call-next-method "growable " prepend ;
-
-[ "vector growable sequence" ] [
- V{ } my-var [ call-next-hooker ] with-variable
-] unit-test
-
-[ t ] [
- { } \ nth effective-method nip \ sequence \ nth method eq?
-] unit-test
-
-[ t ] [
- \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
-] unit-test
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel kernel.private slots.private math
-namespaces make sequences vectors words quotations definitions
-hashtables layouts combinators sequences.private generic
-classes classes.algebra classes.private generic.standard.engines
-generic.standard.engines.tag generic.standard.engines.predicate
-generic.standard.engines.tuple accessors ;
+USING: accessors definitions generic generic.single kernel
+namespaces words math math.order combinators sequences
+generic.single.private quotations kernel.private
+assocs arrays layouts ;
IN: generic.standard
-GENERIC: dispatch# ( word -- n )
+TUPLE: standard-combination < single-combination # ;
-M: generic dispatch#
- "combination" word-prop dispatch# ;
-
-GENERIC: method-declaration ( class generic -- quot )
-
-M: generic method-declaration
- "combination" word-prop method-declaration ;
-
-M: quotation engine>quot
- assumed get generic get method-declaration prepend ;
-
-ERROR: no-method object generic ;
-
-: error-method ( word -- quot )
- [ picker ] dip [ no-method ] curry append ;
-
-: push-method ( method specializer atomic assoc -- )
- [
- [ H{ } clone <predicate-dispatch-engine> ] unless*
- [ methods>> set-at ] keep
- ] change-at ;
-
-: flatten-method ( class method assoc -- )
- [ [ flatten-class keys ] keep ] 2dip [
- [ spin ] dip push-method
- ] 3curry each ;
-
-: flatten-methods ( assoc -- assoc' )
- H{ } clone [
- [
- flatten-method
- ] curry assoc-each
- ] keep ;
-
-: <big-dispatch-engine> ( assoc -- engine )
- flatten-methods
- convert-tuple-methods
- convert-hi-tag-methods
- <lo-tag-dispatch-engine> ;
-
-: mangle-method ( method -- quot )
- 1quotation generic get extra-values \ drop <repetition>
- prepend [ ] like ;
-
-: find-default ( methods -- quot )
- #! Side-effects methods.
- [ object bootstrap-word ] dip delete-at* [
- drop generic get "default-method" word-prop mangle-method
- ] unless ;
-
-: <standard-engine> ( word -- engine )
- object bootstrap-word assumed set {
- [ generic set ]
- [ "engines" word-prop forget-all ]
- [ V{ } clone "engines" set-word-prop ]
- [
- "methods" word-prop
- [ mangle-method ] assoc-map
- [ find-default default set ]
- [ <big-dispatch-engine> ]
- bi
- ]
- } cleave ;
-
-: single-combination ( word -- quot )
- [ <standard-engine> engine>quot ] with-scope ;
-
-ERROR: inconsistent-next-method class generic ;
-
-: single-next-method-quot ( class generic -- quot/f )
- 2dup next-method dup [
- [
- pick "predicate" word-prop %
- 1quotation ,
- [ inconsistent-next-method ] 2curry ,
- \ if ,
- ] [ ] make
- ] [ 3drop f ] if ;
-
-: single-effective-method ( obj word -- method )
- [ [ order [ instance? ] with find-last nip ] keep method ]
- [ "default-method" word-prop ]
- bi or ;
-
-TUPLE: standard-combination # ;
-
-C: <standard-combination> standard-combination
+: <standard-combination> ( n -- standard-combination )
+ dup 0 2 between? [ "Bad dispatch position" throw ] unless
+ standard-combination boa ;
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
PREDICATE: simple-generic < standard-generic
- "combination" word-prop #>> zero? ;
+ "combination" word-prop #>> 0 = ;
CONSTANT: simple-combination T{ standard-combination f 0 }
: define-simple-generic ( word effect -- )
[ simple-combination ] dip define-generic ;
-: with-standard ( combination quot -- quot' )
- [ #>> (dispatch#) ] dip with-variable ; inline
-
-M: standard-generic extra-values drop 0 ;
-
-M: standard-combination make-default-method
- [ error-method ] with-standard ;
+: (picker) ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1- (picker) [ dip swap ] curry ]
+ } case ;
-M: standard-combination perform-combination
- [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
+M: standard-combination picker
+ combination get #>> (picker) ;
M: standard-combination dispatch# #>> ;
-M: standard-combination method-declaration
- dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
-
-M: standard-combination next-method-quot*
- [
- single-next-method-quot
- dup [ picker prepend ] when
- ] with-standard ;
-
M: standard-generic effective-method
- [ dispatch# (picker) call ] keep single-effective-method ;
-
-TUPLE: hook-combination var ;
-
-C: <hook-combination> hook-combination
-
-PREDICATE: hook-generic < generic
- "combination" word-prop hook-combination? ;
-
-: with-hook ( combination quot -- quot' )
- 0 (dispatch#) [
- [ hook-combination ] dip with-variable
- ] with-variable ; inline
+ [ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
+ (effective-method) ;
-: prepend-hook-var ( quot -- quot' )
- hook-combination get var>> [ get ] curry prepend ;
+M: standard-combination inline-cache-quot ( word methods -- )
+ #! Direct calls to the generic word (not tail calls or indirect calls)
+ #! will jump to the inline cache entry point instead of the megamorphic
+ #! dispatch entry point.
+ combination get #>> [ f inline-cache-miss ] 3curry [ ] like ;
-M: hook-combination dispatch# drop 0 ;
+: make-empty-cache ( -- array )
+ mega-cache-size get f <array> ;
-M: hook-combination method-declaration 2drop [ ] ;
-
-M: hook-generic extra-values drop 1 ;
-
-M: hook-generic effective-method
- [ "combination" word-prop var>> get ] keep
- single-effective-method ;
-
-M: hook-combination make-default-method
- [ error-method prepend-hook-var ] with-hook ;
-
-M: hook-combination perform-combination
- [ drop ] [
- [ single-combination prepend-hook-var ] with-hook
- ] 2bi define ;
-
-M: hook-combination next-method-quot*
- [
- single-next-method-quot
- dup [ prepend-hook-var ] when
- ] with-hook ;
-
-M: simple-generic definer drop \ GENERIC: f ;
+M: standard-combination mega-cache-quot
+ combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ;
M: standard-generic definer drop \ GENERIC# f ;
-M: hook-generic definer drop \ HOOK: f ;
+M: simple-generic definer drop \ GENERIC: f ;
+++ /dev/null
-Standard method combination used for most generic words
{ $example "USING: kernel math prettyprint ;" "5 7 [ even? ] either? ." "f" }
} ;
+HELP: execute
+{ $values { "word" word } }
+{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." }
+{ $examples
+ { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
+} ;
+
+{ execute POSTPONE: execute( } related-words
+
+HELP: (execute)
+{ $values { "word" word } }
+{ $description "Executes a word without checking if it is a word first." }
+{ $warning "This word is in the " { $vocab-link "kernel.private" } " vocabulary because it is unsafe. Calling with a parameter that is not a word will crash Factor. Use " { $link execute } " instead." } ;
+
HELP: call
{ $values { "callable" callable } }
{ $description "Calls a quotation. Words which " { $link call } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal quotation can have a static stack effect." }
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel assocs classes
math.order kernel.private ;
SYMBOL: type-numbers
-: tag-number ( class -- n )
- tag-numbers get at [ object tag-number ] unless* ;
+SYMBOL: mega-cache-size
: type-number ( class -- n )
type-numbers get at ;
+: tag-number ( class -- n )
+ type-number dup num-tags get >= [ drop object tag-number ] when ;
+
: tag-fixnum ( n -- tagged )
tag-bits get shift ;
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private ;
IN: math
: neg ( x -- -x ) 0 swap - ; inline
: recip ( x -- y ) 1 swap / ; inline
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
-
: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline
-
: rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable
-
: 2^ ( n -- 2^n ) 1 swap shift ; inline
-
: even? ( n -- ? ) 1 bitand zero? ;
-
: odd? ( n -- ? ) 1 bitand 1 number= ;
UNION: integer fixnum bignum ;
+TUPLE: ratio { numerator integer read-only } { denominator integer read-only } ;
+
UNION: rational integer ratio ;
UNION: real rational float ;
+TUPLE: complex { real real read-only } { imaginary real read-only } ;
+
UNION: number real complex ;
GENERIC: fp-nan? ( x -- ? )
USING: arrays help.markup help.syntax math
sequences.private vectors strings kernel math.order layouts
-quotations generic.standard ;
+quotations generic.single ;
IN: sequences
HELP: sequence
{ $subsection produce }
{ $subsection produce-as }
"Filtering:"
-{ $subsection push-if }
{ $subsection filter }
+{ $subsection partition }
"Testing if a sequence contains elements satisfying a predicate:"
{ $subsection any? }
{ $subsection all? }
USING: generic help.syntax help.markup kernel math parser words
effects classes generic.standard classes.tuple generic.math
-generic.standard arrays io.pathnames vocabs.loader io sequences
-assocs words.symbol words.alias words.constant combinators ;
+generic.standard generic.single arrays io.pathnames vocabs.loader io
+sequences assocs words.symbol words.alias words.constant combinators ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"
hashtables kernel math namespaces parser lexer sequences strings
strings.parser sbufs vectors words words.symbol words.constant
words.alias quotations io assocs splitting classes.tuple
-generic.standard generic.math generic.parser classes
+generic.standard generic.hook generic.math generic.parser classes
io.pathnames vocabs vocabs.parser classes.parser classes.union
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple.parser compiler.units
USING: definitions help.markup help.syntax kernel parser
-kernel.private words.private vocabs classes quotations
+kernel.private vocabs classes quotations
strings effects compiler.units ;
IN: words
ABOUT: "words"
-HELP: execute ( word -- )
-{ $values { "word" word } }
-{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." }
-{ $examples
- { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
-} ;
-
-{ execute POSTPONE: execute( } related-words
-
HELP: deferred
{ $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ;
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions graphs assocs kernel
-kernel.private slots.private math namespaces sequences strings
-vectors sbufs quotations assocs hashtables sorting words.private
-vocabs math.order sets ;
+kernel.private kernel.private slots.private math namespaces sequences
+strings vectors sbufs quotations assocs hashtables sorting vocabs
+math.order sets ;
IN: words
: word ( -- word ) \ word get-global ;
: reset-generic ( word -- )
[ subwords forget-all ]
[ reset-word ]
- [ { "methods" "combination" "default-method" } reset-props ]
- tri ;
+ [
+ f >>direct-entry-def
+ {
+ "methods"
+ "combination"
+ "default-method"
+ "engines"
+ "decision-tree"
+ } reset-props
+ ] tri ;
: gensym ( -- word )
"( gensym )" f <word> ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.vocabs
arrays assocs io.styles io help.markup prettyprint sequences
-continuations debugger math namespaces ;
+continuations debugger math namespaces memory ;
IN: benchmark
<PRIVATE
: run-benchmark ( vocab -- )
[ "=== " write vocab-name print flush ] [
- [ [ require ] [ [ run ] benchmark ] [ ] tri timings ]
+ [ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
[ swap errors ]
recover get set-at
] bi ;
TUPLE: hello n ;
-: hello-n* ( obj -- val ) dup tag 2 eq? [ 2 slot ] [ 3 throw ] if ;
+: hello-n* ( obj -- val ) 2 slot ;
: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: math kernel kernel.private slots.private ;
-IN: benchmark.typecheck4
-
-TUPLE: hello n ;
-
-: hello-n* ( obj -- val ) 2 slot ;
-
-: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
-
-: typecheck-main ( -- ) 0 hello boa foo 2drop ;
-
-MAIN: typecheck-main
PLAF_DLL_OBJS += vm/cpu-x86.32.o
# gcc bug workaround
-CFLAGS += -fno-builtin-strlen -fno-builtin-strcat -mtune=pentium4
+CFLAGS += -fno-builtin-strlen -fno-builtin-strcat
--- /dev/null
+#include "master.h"
+
+/* the array is full of undefined data, and must be correctly filled before the
+next GC. size is in cells */
+F_ARRAY *allot_array_internal(CELL type, CELL capacity)
+{
+ F_ARRAY *array = allot_object(type,array_size(capacity));
+ array->capacity = tag_fixnum(capacity);
+ return array;
+}
+
+/* make a new array with an initial element */
+F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
+{
+ int i;
+ REGISTER_ROOT(fill);
+ F_ARRAY* array = allot_array_internal(type, capacity);
+ UNREGISTER_ROOT(fill);
+ if(fill == 0)
+ memset((void*)AREF(array,0),'\0',capacity * CELLS);
+ else
+ {
+ /* No need for write barrier here. Either the object is in
+ the nursery, or it was allocated directly in tenured space
+ and the write barrier is already hit for us in that case. */
+ for(i = 0; i < capacity; i++)
+ put(AREF(array,i),fill);
+ }
+ return array;
+}
+
+/* push a new array on the stack */
+void primitive_array(void)
+{
+ CELL initial = dpop();
+ CELL size = unbox_array_size();
+ dpush(tag_array(allot_array(ARRAY_TYPE,size,initial)));
+}
+
+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_array(a);
+}
+
+CELL allot_array_2(CELL v1, CELL v2)
+{
+ REGISTER_ROOT(v1);
+ REGISTER_ROOT(v2);
+ F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2);
+ UNREGISTER_ROOT(v2);
+ UNREGISTER_ROOT(v1);
+ set_array_nth(a,0,v1);
+ set_array_nth(a,1,v2);
+ return tag_array(a);
+}
+
+CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
+{
+ REGISTER_ROOT(v1);
+ REGISTER_ROOT(v2);
+ REGISTER_ROOT(v3);
+ REGISTER_ROOT(v4);
+ F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4);
+ UNREGISTER_ROOT(v4);
+ UNREGISTER_ROOT(v3);
+ UNREGISTER_ROOT(v2);
+ UNREGISTER_ROOT(v1);
+ set_array_nth(a,0,v1);
+ set_array_nth(a,1,v2);
+ set_array_nth(a,2,v3);
+ set_array_nth(a,3,v4);
+ return tag_array(a);
+}
+
+static bool reallot_array_in_place_p(F_ARRAY *array, CELL capacity)
+{
+ return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array);
+}
+
+F_ARRAY *reallot_array(F_ARRAY *array, CELL capacity)
+{
+#ifdef FACTOR_DEBUG
+ CELL header = untag_header(array->header);
+ assert(header == ARRAY_TYPE || header == BIGNUM_TYPE);
+#endif
+
+ if(reallot_array_in_place_p(array,capacity))
+ {
+ array->capacity = tag_fixnum(capacity);
+ return array;
+ }
+ else
+ {
+ CELL to_copy = array_capacity(array);
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ REGISTER_UNTAGGED(array);
+ F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity);
+ UNREGISTER_UNTAGGED(array);
+
+ memcpy(new_array + 1,array + 1,to_copy * CELLS);
+ memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS);
+
+ return new_array;
+ }
+}
+
+void primitive_resize_array(void)
+{
+ F_ARRAY* array = untag_array(dpop());
+ CELL capacity = unbox_array_size();
+ dpush(tag_array(reallot_array(array,capacity)));
+}
+
+void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt)
+{
+ F_ARRAY *underlying = untag_object(array->array);
+ REGISTER_ROOT(elt);
+
+ if(array->count == array_capacity(underlying))
+ {
+ underlying = reallot_array(underlying,array->count * 2);
+ array->array = tag_array(underlying);
+ }
+
+ UNREGISTER_ROOT(elt);
+ set_array_nth(underlying,array->count++,elt);
+}
+
+void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts)
+{
+ REGISTER_UNTAGGED(elts);
+
+ F_ARRAY *underlying = untag_object(array->array);
+
+ CELL elts_size = array_capacity(elts);
+ CELL new_size = array->count + elts_size;
+
+ if(new_size >= array_capacity(underlying))
+ {
+ underlying = reallot_array(underlying,new_size * 2);
+ array->array = tag_array(underlying);
+ }
+
+ UNREGISTER_UNTAGGED(elts);
+
+ write_barrier(array->array);
+
+ memcpy((void *)AREF(underlying,array->count),
+ (void *)AREF(elts,0),
+ elts_size * CELLS);
+
+ array->count += elts_size;
+}
--- /dev/null
+DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
+
+INLINE CELL tag_array(F_ARRAY *array)
+{
+ return RETAG(array,ARRAY_TYPE);
+}
+
+/* Inline functions */
+INLINE CELL array_size(CELL size)
+{
+ return sizeof(F_ARRAY) + size * CELLS;
+}
+
+INLINE CELL array_capacity(F_ARRAY* array)
+{
+#ifdef FACTOR_DEBUG
+ CELL header = untag_header(array->header);
+ assert(header == ARRAY_TYPE || header == BIGNUM_TYPE || header == BYTE_ARRAY_TYPE);
+#endif
+ return array->capacity >> TAG_BITS;
+}
+
+#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
+#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
+
+INLINE CELL array_nth(F_ARRAY *array, CELL slot)
+{
+#ifdef FACTOR_DEBUG
+ assert(slot < array_capacity(array));
+ assert(untag_header(array->header) == ARRAY_TYPE);
+#endif
+ return get(AREF(array,slot));
+}
+
+INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value)
+{
+#ifdef FACTOR_DEBUG
+ assert(slot < array_capacity(array));
+ assert(untag_header(array->header) == ARRAY_TYPE);
+#endif
+ put(AREF(array,slot),value);
+ write_barrier((CELL)array);
+}
+
+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);
+
+void primitive_array(void);
+
+F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity);
+void primitive_resize_array(void);
+
+/* Macros to simulate a vector in C */
+typedef struct {
+ CELL count;
+ CELL array;
+} F_GROWABLE_ARRAY;
+
+/* Allocates memory */
+INLINE F_GROWABLE_ARRAY make_growable_array(void)
+{
+ F_GROWABLE_ARRAY result;
+ result.count = 0;
+ result.array = tag_array(allot_array(ARRAY_TYPE,100,F));
+ return result;
+}
+
+#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \
+ REGISTER_ROOT(result##_g.array)
+
+void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt);
+
+#define GROWABLE_ARRAY_ADD(result,elt) \
+ growable_array_add(&result##_g,elt)
+
+void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts);
+
+#define GROWABLE_ARRAY_APPEND(result,elts) \
+ growable_array_append(&result##_g,elts)
+
+INLINE void growable_array_trim(F_GROWABLE_ARRAY *array)
+{
+ array->array = tag_array(reallot_array(untag_object(array->array),array->count));
+}
+
+#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g)
+
+#define GROWABLE_ARRAY_DONE(result) \
+ UNREGISTER_ROOT(result##_g.array); \
+ CELL result = result##_g.array;
#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1)
-#define BIGNUM_NEGATIVE_P(bignum) (array_nth(bignum,0) != 0)
+#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0)
#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg)
#define BIGNUM_ZERO_P(bignum) \
--- /dev/null
+#include "master.h"
+
+/* FFI calls this */
+void box_boolean(bool value)
+{
+ dpush(value ? T : F);
+}
+
+/* FFI calls this */
+bool to_boolean(CELL value)
+{
+ return value != F;
+}
--- /dev/null
+INLINE CELL tag_boolean(CELL untagged)
+{
+ return (untagged == false ? F : T);
+}
+
+DLLEXPORT void box_boolean(bool value);
+DLLEXPORT bool to_boolean(CELL value);
--- /dev/null
+#include "master.h"
+
+/* must fill out array before next GC */
+F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
+{
+ F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
+ byte_array_size(size));
+ array->capacity = tag_fixnum(size);
+ return array;
+}
+
+/* size is in bytes this time */
+F_BYTE_ARRAY *allot_byte_array(CELL size)
+{
+ F_BYTE_ARRAY *array = allot_byte_array_internal(size);
+ memset(array + 1,0,size);
+ return array;
+}
+
+/* push a new byte array on the stack */
+void primitive_byte_array(void)
+{
+ CELL size = unbox_array_size();
+ dpush(tag_object(allot_byte_array(size)));
+}
+
+void primitive_uninitialized_byte_array(void)
+{
+ CELL size = unbox_array_size();
+ dpush(tag_object(allot_byte_array_internal(size)));
+}
+
+static bool reallot_byte_array_in_place_p(F_BYTE_ARRAY *array, CELL capacity)
+{
+ return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array);
+}
+
+F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
+{
+#ifdef FACTOR_DEBUG
+ assert(untag_header(array->header) == BYTE_ARRAY_TYPE);
+#endif
+ if(reallot_byte_array_in_place_p(array,capacity))
+ {
+ array->capacity = tag_fixnum(capacity);
+ return array;
+ }
+ else
+ {
+ CELL to_copy = array_capacity(array);
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ REGISTER_UNTAGGED(array);
+ F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity);
+ UNREGISTER_UNTAGGED(array);
+
+ memcpy(new_array + 1,array + 1,to_copy);
+
+ return new_array;
+ }
+}
+
+void primitive_resize_byte_array(void)
+{
+ F_BYTE_ARRAY* array = untag_byte_array(dpop());
+ CELL capacity = unbox_array_size();
+ dpush(tag_object(reallot_byte_array(array,capacity)));
+}
+
+void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len)
+{
+ CELL new_size = array->count + len;
+ F_BYTE_ARRAY *underlying = untag_object(array->array);
+
+ if(new_size >= byte_array_capacity(underlying))
+ {
+ underlying = reallot_byte_array(underlying,new_size * 2);
+ array->array = tag_object(underlying);
+ }
+
+ memcpy((void *)BREF(underlying,array->count),elts,len);
+
+ array->count += len;
+}
--- /dev/null
+DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
+
+INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array)
+{
+ return untag_fixnum_fast(array->capacity);
+}
+
+INLINE CELL byte_array_size(CELL size)
+{
+ return sizeof(F_BYTE_ARRAY) + size;
+}
+
+F_BYTE_ARRAY *allot_byte_array(CELL size);
+F_BYTE_ARRAY *allot_byte_array_internal(CELL size);
+F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
+
+void primitive_byte_array(void);
+void primitive_uninitialized_byte_array(void);
+void primitive_resize_byte_array(void);
+
+/* Macros to simulate a byte vector in C */
+typedef struct {
+ CELL count;
+ CELL array;
+} F_GROWABLE_BYTE_ARRAY;
+
+INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void)
+{
+ F_GROWABLE_BYTE_ARRAY result;
+ result.count = 0;
+ result.array = tag_object(allot_byte_array(100));
+ return result;
+}
+
+void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len);
+
+INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array)
+{
+ byte_array->array = tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count));
+}
frame_index = 0;
iterate_callstack_object(stack,stack_frame_to_array);
- dpush(tag_object(array));
+ dpush(tag_array(array));
}
F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack)
REGISTER_UNTAGGED(callstack);
REGISTER_UNTAGGED(quot);
- jit_compile(tag_object(quot),true);
+ jit_compile(tag_quotation(quot),true);
UNREGISTER_UNTAGGED(quot);
UNREGISTER_UNTAGGED(callstack);
+INLINE CELL callstack_size(CELL size)
+{
+ return sizeof(F_CALLSTACK) + size;
+}
+
+DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
+
F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1)
{
case RT_PRIMITIVE:
case RT_XT:
+ case RT_XT_DIRECT:
case RT_IMMEDIATE:
case RT_HERE:
+ case RT_UNTAGGED:
index++;
break;
case RT_DLSYM:
CELL object_xt(CELL obj)
{
- if(type_of(obj) == WORD_TYPE)
- return (CELL)untag_word(obj)->xt;
+ if(TAG(obj) == QUOTATION_TYPE)
+ {
+ F_QUOTATION *quot = untag_object(obj);
+ return (CELL)quot->xt;
+ }
else
- return (CELL)untag_quotation(obj)->xt;
+ {
+ F_WORD *word = untag_object(obj);
+ return (CELL)word->xt;
+ }
+}
+
+CELL word_direct_xt(CELL obj)
+{
+#ifdef FACTOR_DEBUG
+ type_check(WORD_TYPE,obj);
+#endif
+ F_WORD *word = untag_object(obj);
+ CELL quot = word->direct_entry_def;
+ if(quot == F || max_pic_size == 0)
+ return (CELL)word->xt;
+ else
+ {
+ F_QUOTATION *untagged = untag_object(quot);
+#ifdef FACTOR_DEBUG
+ type_check(QUOTATION_TYPE,quot);
+#endif
+ if(untagged->compiledp == F)
+ return (CELL)word->xt;
+ else
+ return (CELL)untagged->xt;
+ }
}
void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
{
- if(REL_TYPE(rel) == RT_XT)
+ F_RELTYPE type = REL_TYPE(rel);
+ if(type == RT_XT || type == RT_XT_DIRECT)
{
CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
- CELL xt = object_xt(array_nth(literals,index));
+ CELL obj = array_nth(literals,index);
+
+ CELL xt;
+ if(type == RT_XT)
+ xt = object_xt(obj);
+ else
+ xt = word_direct_xt(obj);
+
store_address_in_code_block(REL_CLASS(rel),offset,xt);
}
}
{
if(compiled->block.needs_fixup)
relocate_code_block(compiled);
+ /* update_word_references() is always applied to every block in
+ the code heap. Since it resets all call sites to point to
+ their canonical XT (cold entry point for non-tail calls,
+ standard entry point for tail calls), it means that no PICs
+ are referenced after this is done. So instead of polluting
+ the code heap with dead PICs that will be freed on the next
+ GC, we add them to the free list immediately. */
+ else if(compiled->block.type == PIC_TYPE)
+ {
+ fflush(stdout);
+ heap_free(&code_heap,&compiled->block);
+ }
else
{
iterate_relocations(compiled,update_word_references_step);
}
}
+void update_literal_and_word_references(F_CODE_BLOCK *compiled)
+{
+ update_literal_references(compiled);
+ update_word_references(compiled);
+}
+
+INLINE void check_code_address(CELL address)
+{
+#ifdef FACTOR_DEBUG
+ assert(address >= code_heap.segment->start && address < code_heap.segment->end);
+#endif
+}
+
/* Update references to words. This is done after a new code block
is added to the heap. */
collections */
void mark_code_block(F_CODE_BLOCK *compiled)
{
+ check_code_address((CELL)compiled);
+
mark_block(&compiled->block);
copy_handle(&compiled->literals);
F_QUOTATION *quot;
F_CALLSTACK *stack;
- switch(object_type(scan))
+ switch(hi_tag(scan))
{
case WORD_TYPE:
word = (F_WORD *)scan;
if(word->code)
- mark_code_block(word->code);
+ mark_code_block(word->code);
if(word->profiling)
mark_code_block(word->profiling);
break;
/* Compute an address to store at a relocation */
void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
{
+#ifdef FACTOR_DEBUG
+ type_check(ARRAY_TYPE,compiled->literals);
+ type_check(BYTE_ARRAY_TYPE,compiled->relocation);
+#endif
+
CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
F_FIXNUM absolute_value;
case RT_XT:
absolute_value = object_xt(array_nth(literals,index));
break;
+ case RT_XT_DIRECT:
+ absolute_value = word_direct_xt(array_nth(literals,index));
+ break;
case RT_HERE:
absolute_value = offset + (short)to_fixnum(array_nth(literals,index));
break;
case RT_STACK_CHAIN:
absolute_value = (CELL)&stack_chain;
break;
+ case RT_UNTAGGED:
+ absolute_value = to_fixnum(array_nth(literals,index));
+ break;
default:
critical_error("Bad rel type",rel);
return; /* Can't happen */
}
/* Fixup labels. This is done at compile time, not image load time */
-void fixup_labels(F_ARRAY *labels, CELL code_format, F_CODE_BLOCK *compiled)
+void fixup_labels(F_ARRAY *labels, F_CODE_BLOCK *compiled)
{
CELL i;
CELL size = array_capacity(labels);
}
}
-/* Write a sequence of integers to memory, with 'format' bytes per integer */
-void deposit_integers(CELL here, F_ARRAY *array, CELL format)
-{
- CELL count = array_capacity(array);
- CELL i;
-
- for(i = 0; i < count; i++)
- {
- F_FIXNUM value = to_fixnum(array_nth(array,i));
- if(format == 1)
- bput(here + i,value);
- else if(format == sizeof(unsigned int))
- *(unsigned int *)(here + format * i) = value;
- else if(format == sizeof(CELL))
- *(CELL *)(here + format * i) = value;
- else
- critical_error("Bad format in deposit_integers()",format);
- }
-}
-
-CELL compiled_code_format(void)
-{
- return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
-}
-
/* Might GC */
F_CODE_BLOCK *allot_code_block(CELL size)
{
/* Might GC */
F_CODE_BLOCK *add_code_block(
CELL type,
- F_ARRAY *code,
+ F_BYTE_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
CELL literals)
{
- CELL code_format = compiled_code_format();
- CELL code_length = align8(array_capacity(code) * code_format);
+#ifdef FACTOR_DEBUG
+ type_check(ARRAY_TYPE,literals);
+ type_check(BYTE_ARRAY_TYPE,relocation);
+ assert(untag_header(code->header) == BYTE_ARRAY_TYPE);
+#endif
+
+ CELL code_length = align8(array_capacity(code));
REGISTER_ROOT(literals);
REGISTER_ROOT(relocation);
compiled->relocation = relocation;
/* code */
- deposit_integers((CELL)(compiled + 1),code,code_format);
+ memcpy(compiled + 1,code + 1,code_length);
/* fixup labels */
- if(labels) fixup_labels(labels,code_format,compiled);
+ if(labels) fixup_labels(labels,compiled);
/* next time we do a minor GC, we have to scan the code heap for
literals */
RT_DLSYM,
/* a pointer to a compiled word reference */
RT_DISPATCH,
- /* a compiled word reference */
+ /* a word's general entry point XT */
RT_XT,
+ /* a word's direct entry point XT */
+ RT_XT_DIRECT,
/* current offset */
RT_HERE,
/* current code block */
/* immediate literal */
RT_IMMEDIATE,
/* address of stack_chain var */
- RT_STACK_CHAIN
+ RT_STACK_CHAIN,
+ /* untagged fixnum literal */
+ RT_UNTAGGED,
} F_RELTYPE;
typedef enum {
void update_word_references(F_CODE_BLOCK *compiled);
+void update_literal_and_word_references(F_CODE_BLOCK *compiled);
+
void mark_code_block(F_CODE_BLOCK *compiled);
void mark_active_blocks(F_CONTEXT *stacks);
void relocate_code_block(F_CODE_BLOCK *relocating);
-CELL compiled_code_format(void);
-
INLINE bool stack_traces_p(void)
{
return userenv[STACK_TRACES_ENV] != F;
F_CODE_BLOCK *add_code_block(
CELL type,
- F_ARRAY *code,
+ F_BYTE_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
CELL literals);
clear_free_list(heap);
}
-void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block)
+static void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block)
{
if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
{
critical_error("Invalid block in free list",(CELL)block);
}
-F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
+static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
{
CELL attempt = size;
return NULL;
}
-F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size)
+static F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size)
{
if(block->block.size != size )
{
return NULL;
}
+/* Deallocates a block manually */
+void heap_free(F_HEAP *heap, F_BLOCK *block)
+{
+ block->status = B_FREE;
+ add_to_free_list(heap,(F_FREE_BLOCK *)block);
+}
+
void mark_block(F_BLOCK *block)
{
/* If already marked, do nothing */
switch(scan->status)
{
case B_ALLOCATED:
+ if(secure_gc)
+ memset(scan + 1,0,scan->size - sizeof(F_BLOCK));
+
if(prev && prev->status == B_FREE)
prev->size += scan->size;
else
void new_heap(F_HEAP *heap, CELL size);
void build_free_list(F_HEAP *heap, CELL size);
F_BLOCK *heap_allot(F_HEAP *heap, CELL size);
+void heap_free(F_HEAP *heap, F_BLOCK *block);
void mark_block(F_BLOCK *block);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter);
&& ptr <= code_heap.segment->end);
}
-void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled)
-{
- if(compiled->block.type != WORD_TYPE)
- critical_error("bad param to set_word_xt",(CELL)compiled);
-
- word->code = compiled;
- word->optimizedp = T;
-}
-
/* Compile a word definition with the non-optimizing compiler. Allocates memory */
void jit_compile_word(F_WORD *word, CELL def, bool relocate)
{
UNREGISTER_ROOT(def);
word->code = untag_quotation(def)->code;
- word->optimizedp = F;
+
+ if(word->direct_entry_def != F)
+ jit_compile(word->direct_entry_def,relocate);
}
/* Apply a function to every code block */
iterate_code_heap(copy_literal_references);
}
-/* Update literals referenced from all code blocks. Only for tenured
-collections, done at the end. */
-void update_code_heap_roots(void)
-{
- iterate_code_heap(update_literal_references);
-}
-
/* Update pointers to words referenced from all code blocks. Only after
defining a new word. */
void update_code_heap_words(void)
{
F_ARRAY *compiled_code = untag_array(data);
- F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
+ CELL literals = array_nth(compiled_code,0);
CELL relocation = array_nth(compiled_code,1);
F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
- F_ARRAY *code = untag_array(array_nth(compiled_code,3));
+ F_BYTE_ARRAY *code = untag_byte_array(array_nth(compiled_code,3));
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
code,
labels,
relocation,
- tag_object(literals));
+ literals);
UNREGISTER_UNTAGGED(word);
UNREGISTER_UNTAGGED(alist);
- set_word_code(word,compiled);
+ word->code = compiled;
}
else
critical_error("Expected a quotation or an array",data);
void jit_compile_word(F_WORD *word, CELL def, bool relocate);
-void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled);
-
typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled);
void iterate_code_heap(CODE_HEAP_ITERATOR iter);
void copy_code_heap_roots(void);
-void update_code_heap_roots(void);
-
void primitive_modify_code_heap(void);
void primitive_code_room(void);
void compact_code_heap(void);
+
+INLINE void check_code_pointer(CELL pointer)
+{
+#ifdef FACTOR_DEBUG
+ assert(pointer >= code_heap.segment->start && pointer < code_heap.segment->end);
+#endif
+}
/* Note that the XT is passed to the quotation in r11 */
#define CALL_OR_JUMP_QUOT \
- lwz r11,17(r3) /* load quotation-xt slot */ XX \
+ lwz r11,14(r3) /* load quotation-xt slot */ XX \
#define CALL_QUOT \
CALL_OR_JUMP_QUOT XX \
pop %ebp ; \
pop %ebx
-#define QUOT_XT_OFFSET 17
+#define QUOT_XT_OFFSET 16
+#define WORD_XT_OFFSET 30
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
mov %edx,%eax
ret
+DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
+ mov (%esp),%eax
+ sub $8,%esp
+ push %eax
+ call MANGLE(inline_cache_miss)
+ add $12,%esp
+ jmp *%eax
+
#include "cpu-x86.S"
#ifdef WINDOWS
#endif
-#define QUOT_XT_OFFSET 37
+#define QUOT_XT_OFFSET 36
+#define WORD_XT_OFFSET 66
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
call *ARG3 /* call memcpy */
ret /* return _with new stack_ */
+DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
+ mov (%rsp),ARG0
+ sub $STACK_PADDING,%rsp
+ call MANGLE(inline_cache_miss)
+ add $STACK_PADDING,%rsp
+ jmp *%rax
+
#include "cpu-x86.S"
mov ARG1,STACK_REG
jmp *QUOT_XT_OFFSET(ARG0)
-DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
+DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)):
mov STACK_REG,ARG1 /* Save stack pointer */
sub $STACK_PADDING,STACK_REG
call MANGLE(lazy_jit_compile_impl)
+#include <assert.h>
+
#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
INLINE void flush_icache(CELL start, CELL len) {}
F_FASTCALL void lazy_jit_compile(CELL quot);
void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
+
+INLINE void check_call_site(CELL return_address)
+{
+ /* An x86 CALL instruction looks like so:
+ |e8|..|..|..|..|
+ where the ... are a PC-relative jump address.
+ The return_address points to right after the
+ instruction. */
+#ifdef FACTOR_DEBUG
+ assert(*(unsigned char *)(return_address - 5) == 0xe8);
+#endif
+}
+
+INLINE CELL get_call_target(CELL return_address)
+{
+ check_call_site(return_address);
+ return *(int *)(return_address - 4) + return_address;
+}
+
+INLINE void set_call_target(CELL return_address, CELL target)
+{
+ check_call_site(return_address);
+ *(int *)(return_address - 4) = (target - return_address);
+}
/* Follow a chain of forwarding pointers */
CELL resolve_forwarding(CELL untagged, CELL tag)
{
+ check_data_pointer(untagged);
+
CELL header = get(untagged);
/* another forwarding pointer */
if(TAG(header) == GC_COLLECTED)
/* we've found the destination */
else
{
+ check_header(header);
CELL pointer = RETAG(untagged,tag);
if(should_copy(untagged))
pointer = RETAG(copy_object_impl(pointer),tag);
a new forwarding pointer. */
INLINE CELL copy_object(CELL pointer)
{
+ check_data_pointer(pointer);
+
CELL tag = TAG(pointer);
CELL header = get(UNTAG(pointer));
if(TAG(header) == GC_COLLECTED)
return resolve_forwarding(UNTAG(header),tag);
else
+ {
+ check_header(header);
return RETAG(copy_object_impl(pointer),tag);
+ }
}
void copy_handle(CELL *handle)
{
CELL pointer = *handle;
- if(!immediate_p(pointer) && should_copy(pointer))
- *handle = copy_object(pointer);
+ if(!immediate_p(pointer))
+ {
+ check_data_pointer(pointer);
+ if(should_copy(pointer))
+ *handle = copy_object(pointer);
+ }
}
CELL copy_next_from_nursery(CELL scan)
{
CELL pointer = *obj;
- if(!immediate_p(pointer)
- && (pointer >= nursery_start && pointer < nursery_end))
- *obj = copy_object(pointer);
+ if(!immediate_p(pointer))
+ {
+ check_data_pointer(pointer);
+ if(pointer >= nursery_start && pointer < nursery_end)
+ *obj = copy_object(pointer);
+ }
}
}
{
CELL pointer = *obj;
- if(!immediate_p(pointer)
- && !(pointer >= newspace_start && pointer < newspace_end)
- && !(pointer >= tenured_start && pointer < tenured_end))
- *obj = copy_object(pointer);
+ if(!immediate_p(pointer))
+ {
+ check_data_pointer(pointer);
+ if(!(pointer >= newspace_start && pointer < newspace_end)
+ && !(pointer >= tenured_start && pointer < tenured_end))
+ *obj = copy_object(pointer);
+ }
}
}
{
CELL pointer = *obj;
- if(!immediate_p(pointer) && !(pointer >= newspace_start && pointer < newspace_end))
- *obj = copy_object(pointer);
+ if(!immediate_p(pointer))
+ {
+ check_data_pointer(pointer);
+ if(!(pointer >= newspace_start && pointer < newspace_end))
+ *obj = copy_object(pointer);
+ }
}
}
copy_roots();
/* collect objects referenced from older generations */
copy_cards();
+
/* do some tracing */
copy_reachable_objects(scan,&newspace->here);
code_heap_scans++;
if(collecting_gen == TENURED)
- free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_references);
+ free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_and_word_references);
else
copy_code_heap_roots();
GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
GROWABLE_ARRAY_TRIM(stats);
+ GROWABLE_ARRAY_DONE(stats);
dpush(stats);
}
/* If this is defined, we GC every 100 allocations. This catches missing local roots */
#ifdef GC_DEBUG
-static int count;
+int gc_count;
#endif
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
+int count;
INLINE void *allot_object(CELL type, CELL a)
{
-
#ifdef GC_DEBUG
-
if(!gc_off)
{
- if(count++ % 1000 == 0)
+ if(gc_count++ % 100 == 0)
gc();
}
void clear_gc_stats(void);
void primitive_clear_gc_stats(void);
void primitive_become(void);
+
+INLINE void check_data_pointer(CELL pointer)
+{
+#ifdef FACTOR_DEBUG
+ if(!growing_data_heap)
+ {
+ assert(pointer >= data_heap->segment->start
+ && pointer < data_heap->segment->end);
+ }
+#endif
+}
return sizeof(F_QUOTATION);
case WORD_TYPE:
return sizeof(F_WORD);
- case RATIO_TYPE:
- return sizeof(F_RATIO);
case FLOAT_TYPE:
return sizeof(F_FLOAT);
- case COMPLEX_TYPE:
- return sizeof(F_COMPLEX);
case DLL_TYPE:
return sizeof(F_DLL);
case ALIEN_TYPE:
tuple = untag_object(pointer);
layout = untag_object(tuple->layout);
return tuple_size(layout);
- case RATIO_TYPE:
- return sizeof(F_RATIO);
- case COMPLEX_TYPE:
- return sizeof(F_COMPLEX);
case WRAPPER_TYPE:
return sizeof(F_WRAPPER);
default:
/* Push memory usage statistics in data heap */
void primitive_data_room(void)
{
- F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
- int gen;
-
dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
+ GROWABLE_ARRAY(a);
+
+ int gen;
for(gen = 0; gen < data_heap->gen_count; gen++)
{
F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
- set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
- set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
+ GROWABLE_ARRAY_ADD(a,tag_fixnum((z->end - z->here) >> 10));
+ GROWABLE_ARRAY_ADD(a,tag_fixnum((z->size) >> 10));
}
- dpush(tag_object(a));
+ GROWABLE_ARRAY_TRIM(a);
+ GROWABLE_ARRAY_DONE(a);
+ dpush(a);
}
/* Disables GC and activates next-object ( -- obj ) primitive */
type = untag_header(value);
heap_scan_ptr += untagged_object_size(heap_scan_ptr);
- return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
+ return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE);
}
/* Push object at heap scan cursor and advance; pushes f when done */
gc_off = false;
GROWABLE_ARRAY_TRIM(words);
+ GROWABLE_ARRAY_DONE(words);
return words;
}
--- /dev/null
+#include "master.h"
+
+static CELL search_lookup_alist(CELL table, CELL class)
+{
+ F_ARRAY *pairs = untag_object(table);
+ F_FIXNUM index = array_capacity(pairs) - 1;
+ while(index >= 0)
+ {
+ F_ARRAY *pair = untag_object(array_nth(pairs,index));
+ if(array_nth(pair,0) == class)
+ return array_nth(pair,1);
+ else
+ index--;
+ }
+
+ return F;
+}
+
+static CELL search_lookup_hash(CELL table, CELL class, CELL hashcode)
+{
+ F_ARRAY *buckets = untag_object(table);
+ CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
+ if(type_of(bucket) == WORD_TYPE || bucket == F)
+ return bucket;
+ else
+ return search_lookup_alist(bucket,class);
+}
+
+static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon)
+{
+ CELL *ptr = (CELL *)(layout + 1);
+ return ptr[echelon * 2];
+}
+
+static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon)
+{
+ CELL *ptr = (CELL *)(layout + 1);
+ return ptr[echelon * 2 + 1];
+}
+
+static CELL lookup_tuple_method(CELL object, CELL methods)
+{
+ F_TUPLE *tuple = untag_object(object);
+ F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
+
+ F_ARRAY *echelons = untag_object(methods);
+
+ F_FIXNUM echelon = untag_fixnum_fast(layout->echelon);
+ F_FIXNUM max_echelon = array_capacity(echelons) - 1;
+ if(echelon > max_echelon) echelon = max_echelon;
+
+ while(echelon >= 0)
+ {
+ CELL echelon_methods = array_nth(echelons,echelon);
+
+ if(type_of(echelon_methods) == WORD_TYPE)
+ return echelon_methods;
+ else if(echelon_methods != F)
+ {
+ CELL class = nth_superclass(layout,echelon);
+ CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon));
+ CELL result = search_lookup_hash(echelon_methods,class,hashcode);
+ if(result != F)
+ return result;
+ }
+
+ echelon--;
+ }
+
+ critical_error("Cannot find tuple method",methods);
+ return F;
+}
+
+static CELL lookup_hi_tag_method(CELL object, CELL methods)
+{
+ F_ARRAY *hi_tag_methods = untag_object(methods);
+ CELL tag = hi_tag(object) - HEADER_TYPE;
+#ifdef FACTOR_DEBUG
+ assert(tag < TYPE_COUNT - HEADER_TYPE);
+#endif
+ return array_nth(hi_tag_methods,tag);
+}
+
+static CELL lookup_hairy_method(CELL object, CELL methods)
+{
+ CELL method = array_nth(untag_object(methods),TAG(object));
+ if(type_of(method) == WORD_TYPE)
+ return method;
+ else
+ {
+ switch(TAG(object))
+ {
+ case TUPLE_TYPE:
+ return lookup_tuple_method(object,method);
+ break;
+ case OBJECT_TYPE:
+ return lookup_hi_tag_method(object,method);
+ break;
+ default:
+ critical_error("Bad methods array",methods);
+ return -1;
+ }
+ }
+}
+
+CELL lookup_method(CELL object, CELL methods)
+{
+ if(!HI_TAG_OR_TUPLE_P(object))
+ return array_nth(untag_object(methods),TAG(object));
+ else
+ return lookup_hairy_method(object,methods);
+}
+
+void primitive_lookup_method(void)
+{
+ CELL methods = dpop();
+ CELL object = dpop();
+ dpush(lookup_method(object,methods));
+}
+
+CELL object_class(CELL object)
+{
+ if(!HI_TAG_OR_TUPLE_P(object))
+ return tag_fixnum(TAG(object));
+ else
+ return get(HI_TAG_HEADER(object));
+}
+
+static CELL method_cache_hashcode(CELL class, F_ARRAY *array)
+{
+ CELL capacity = (array_capacity(array) >> 1) - 1;
+ return ((class >> TAG_BITS) & capacity) << 1;
+}
+
+static void update_method_cache(CELL cache, CELL class, CELL method)
+{
+ F_ARRAY *array = untag_object(cache);
+ CELL hashcode = method_cache_hashcode(class,array);
+ set_array_nth(array,hashcode,class);
+ set_array_nth(array,hashcode + 1,method);
+}
+
+void primitive_mega_cache_miss(void)
+{
+ megamorphic_cache_misses++;
+
+ CELL cache = dpop();
+ F_FIXNUM index = untag_fixnum_fast(dpop());
+ CELL methods = dpop();
+
+ CELL object = get(ds - index * CELLS);
+ CELL class = object_class(object);
+ CELL method = lookup_method(object,methods);
+
+ update_method_cache(cache,class,method);
+
+ dpush(method);
+}
+
+void primitive_reset_dispatch_stats(void)
+{
+ megamorphic_cache_hits = megamorphic_cache_misses = 0;
+}
+
+void primitive_dispatch_stats(void)
+{
+ GROWABLE_ARRAY(stats);
+ GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_hits));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_misses));
+ GROWABLE_ARRAY_TRIM(stats);
+ GROWABLE_ARRAY_DONE(stats);
+ dpush(stats);
+}
+
+void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type)
+{
+ jit_emit_with(jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS));
+ jit_emit(jit,userenv[type]);
+}
+
+void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache)
+{
+ /* Generate machine code to determine the object's class. */
+ jit_emit_class_lookup(jit,index,PIC_HI_TAG_TUPLE);
+
+ /* Do a cache lookup. */
+ jit_emit_with(jit,userenv[MEGA_LOOKUP],cache);
+
+ /* If we end up here, the cache missed. */
+ jit_emit(jit,userenv[JIT_PROLOG]);
+
+ /* Push index, method table and cache on the stack. */
+ jit_push(jit,methods);
+ jit_push(jit,tag_fixnum(index));
+ jit_push(jit,cache);
+ jit_word_call(jit,userenv[MEGA_MISS_WORD]);
+
+ /* Now the new method has been stored into the cache, and its on
+ the stack. */
+ jit_emit(jit,userenv[JIT_EPILOG]);
+ jit_emit(jit,userenv[JIT_EXECUTE_JUMP]);
+}
--- /dev/null
+CELL megamorphic_cache_hits;
+CELL megamorphic_cache_misses;
+
+CELL lookup_method(CELL object, CELL methods);
+void primitive_lookup_method(void);
+
+CELL object_class(CELL object);
+
+void primitive_mega_cache_miss(void);
+
+void primitive_reset_dispatch_stats(void);
+void primitive_dispatch_stats(void);
+
+void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type);
+
+void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache);
p->tenured_size = 4 * CELLS;
#endif
+ p->max_pic_size = 3;
+
p->secure_gc = false;
p->fep = false;
else if(factor_arg(argv[i],STRING_LITERAL("-aging=%d"),&p->aging_size));
else if(factor_arg(argv[i],STRING_LITERAL("-tenured=%d"),&p->tenured_size));
else if(factor_arg(argv[i],STRING_LITERAL("-codeheap=%d"),&p->code_size));
+ else if(factor_arg(argv[i],STRING_LITERAL("-pic=%d"),&p->max_pic_size));
else if(STRCMP(argv[i],STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
else if(STRCMP(argv[i],STRING_LITERAL("-fep")) == 0) p->fep = true;
else if(STRNCMP(argv[i],STRING_LITERAL("-i="),3) == 0) p->image_path = argv[i] + 3;
init_stacks(p->ds_size,p->rs_size);
load_image(p);
init_c_io();
+ init_inline_caching(p->max_pic_size);
+
+#ifndef FACTOR_DEBUG
init_signals();
+#endif
if(p->console)
open_console();
set_array_nth(args,i,arg);
}
- userenv[ARGS_ENV] = tag_object(args);
+ userenv[ARGS_ENV] = tag_array(args);
}
void start_factor(F_PARAMETERS *p)
for(i = 0; i < FIRST_SAVE_ENV; i++)
userenv[i] = F;
- for(i = LAST_SAVE_ENV + 1; i < USER_ENV; i++)
+ for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++)
userenv[i] = F;
/* do a full GC + code heap compaction */
bool fep;
bool console;
bool stack_traces;
+ CELL max_pic_size;
} F_PARAMETERS;
void load_image(F_PARAMETERS *p);
--- /dev/null
+#include "master.h"
+
+void init_inline_caching(int max_size)
+{
+ max_pic_size = max_size;
+}
+
+void deallocate_inline_cache(CELL return_address)
+{
+ /* Find the call target. */
+ XT old_xt = (XT)get_call_target(return_address);
+ F_CODE_BLOCK *old_block = (F_CODE_BLOCK *)old_xt - 1;
+ CELL old_type = old_block->block.type;
+
+#ifdef FACTOR_DEBUG
+ /* The call target was either another PIC,
+ or a compiled quotation (megamorphic stub) */
+ assert(old_type == PIC_TYPE || old_type == QUOTATION_TYPE);
+#endif
+
+ if(old_type == PIC_TYPE)
+ heap_free(&code_heap,&old_block->block);
+}
+
+/* Figure out what kind of type check the PIC needs based on the methods
+it contains */
+static CELL determine_inline_cache_type(CELL cache_entries)
+{
+ F_ARRAY *array = untag_object(cache_entries);
+
+ bool seen_hi_tag = false, seen_tuple = false;
+
+ CELL i;
+ for(i = 0; i < array_capacity(array); i += 2)
+ {
+ CELL class = array_nth(array,i);
+ F_FIXNUM type;
+
+ /* Is it a tuple layout? */
+ switch(type_of(class))
+ {
+ case FIXNUM_TYPE:
+ type = untag_fixnum_fast(class);
+ if(type >= HEADER_TYPE)
+ seen_hi_tag = true;
+ break;
+ case ARRAY_TYPE:
+ seen_tuple = true;
+ break;
+ default:
+ critical_error("Expected a fixnum or array",class);
+ break;
+ }
+ }
+
+ if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE;
+ if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG;
+ if(!seen_hi_tag && seen_tuple) return PIC_TUPLE;
+ if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
+
+ critical_error("Oops",0);
+ return -1;
+}
+
+static void update_pic_count(CELL type)
+{
+ pic_counts[type - PIC_TAG]++;
+}
+
+static void jit_emit_check(F_JIT *jit, CELL class)
+{
+ CELL template;
+ if(TAG(class) == FIXNUM_TYPE && untag_fixnum_fast(class) < HEADER_TYPE)
+ template = userenv[PIC_CHECK_TAG];
+ else
+ template = userenv[PIC_CHECK];
+
+ jit_emit_with(jit,template,class);
+}
+
+/* index: 0 = top of stack, 1 = item underneath, etc
+ cache_entries: array of class/method pairs */
+static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CELL methods, CELL cache_entries)
+{
+#ifdef FACTOR_DEBUG
+ type_check(WORD_TYPE,generic_word);
+ type_check(ARRAY_TYPE,cache_entries);
+#endif
+
+ REGISTER_ROOT(generic_word);
+ REGISTER_ROOT(methods);
+ REGISTER_ROOT(cache_entries);
+
+ CELL inline_cache_type = determine_inline_cache_type(cache_entries);
+
+ update_pic_count(inline_cache_type);
+
+ F_JIT jit;
+ jit_init(&jit,PIC_TYPE,generic_word);
+
+ /* Generate machine code to determine the object's class. */
+ jit_emit_class_lookup(&jit,index,inline_cache_type);
+
+ /* Generate machine code to check, in turn, if the class is one of the cached entries. */
+ CELL i;
+ for(i = 0; i < array_capacity(untag_object(cache_entries)); i += 2)
+ {
+ /* Class equal? */
+ CELL class = array_nth(untag_object(cache_entries),i);
+ jit_emit_check(&jit,class);
+
+ /* Yes? Jump to method */
+ CELL method = array_nth(untag_object(cache_entries),i + 1);
+ jit_emit_with(&jit,userenv[PIC_HIT],method);
+ }
+
+ /* Generate machine code to handle a cache miss, which ultimately results in
+ this function being called again.
+
+ The inline-cache-miss primitive call receives enough information to
+ reconstruct the PIC. */
+ jit_push(&jit,generic_word);
+ jit_push(&jit,methods);
+ jit_push(&jit,tag_fixnum(index));
+ jit_push(&jit,cache_entries);
+ jit_word_jump(&jit,userenv[PIC_MISS_WORD]);
+
+ F_CODE_BLOCK *code = jit_make_code_block(&jit);
+ relocate_code_block(code);
+
+ jit_dispose(&jit);
+
+ UNREGISTER_ROOT(cache_entries);
+ UNREGISTER_ROOT(methods);
+ UNREGISTER_ROOT(generic_word);
+
+ return code;
+}
+
+/* A generic word's definition performs general method lookup. Allocates memory */
+static XT megamorphic_call_stub(CELL generic_word)
+{
+ return untag_word(generic_word)->xt;
+}
+
+static CELL inline_cache_size(CELL cache_entries)
+{
+ return (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries)) / 2);
+}
+
+/* Allocates memory */
+static CELL add_inline_cache_entry(CELL cache_entries, CELL class, CELL method)
+{
+ if(cache_entries == F)
+ return allot_array_2(class,method);
+ else
+ {
+ F_ARRAY *cache_entries_array = untag_object(cache_entries);
+ CELL pic_size = array_capacity(cache_entries_array);
+ cache_entries_array = reallot_array(cache_entries_array,pic_size + 2);
+ set_array_nth(cache_entries_array,pic_size,class);
+ set_array_nth(cache_entries_array,pic_size + 1,method);
+ return tag_array(cache_entries_array);
+ }
+}
+
+static void update_pic_transitions(CELL pic_size)
+{
+ if(pic_size == max_pic_size)
+ pic_to_mega_transitions++;
+ else if(pic_size == 0)
+ cold_call_to_ic_transitions++;
+ else if(pic_size == 1)
+ ic_to_pic_transitions++;
+}
+
+/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss).
+Called from assembly with the actual return address */
+XT inline_cache_miss(CELL return_address)
+{
+ check_code_pointer(return_address);
+
+ /* Since each PIC is only referenced from a single call site,
+ if the old call target was a PIC, we can deallocate it immediately,
+ instead of leaving dead PICs around until the next GC. */
+ deallocate_inline_cache(return_address);
+
+ CELL cache_entries = dpop();
+ F_FIXNUM index = untag_fixnum_fast(dpop());
+ CELL methods = dpop();
+ CELL generic_word = dpop();
+ CELL object = get(ds - index * CELLS);
+
+ XT xt;
+
+ CELL pic_size = inline_cache_size(cache_entries);
+
+ update_pic_transitions(pic_size);
+
+ if(pic_size >= max_pic_size)
+ xt = megamorphic_call_stub(generic_word);
+ else
+ {
+ REGISTER_ROOT(generic_word);
+ REGISTER_ROOT(cache_entries);
+ REGISTER_ROOT(methods);
+
+ CELL class = object_class(object);
+ CELL method = lookup_method(object,methods);
+
+ cache_entries = add_inline_cache_entry(cache_entries,class,method);
+ xt = compile_inline_cache(index,generic_word,methods,cache_entries) + 1;
+
+ UNREGISTER_ROOT(methods);
+ UNREGISTER_ROOT(cache_entries);
+ UNREGISTER_ROOT(generic_word);
+ }
+
+ /* Install the new stub. */
+ set_call_target(return_address,(CELL)xt);
+
+#ifdef PIC_DEBUG
+ printf("Updated call site 0x%lx with 0x%lx\n",return_address,(CELL)xt);
+#endif
+
+ return xt;
+}
+
+void primitive_reset_inline_cache_stats(void)
+{
+ cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0;
+ CELL i;
+ for(i = 0; i < 4; i++) pic_counts[i] = 0;
+}
+
+void primitive_inline_cache_stats(void)
+{
+ GROWABLE_ARRAY(stats);
+ GROWABLE_ARRAY_ADD(stats,allot_cell(cold_call_to_ic_transitions));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(ic_to_pic_transitions));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(pic_to_mega_transitions));
+ CELL i;
+ for(i = 0; i < 4; i++)
+ GROWABLE_ARRAY_ADD(stats,allot_cell(pic_counts[i]));
+ GROWABLE_ARRAY_TRIM(stats);
+ GROWABLE_ARRAY_DONE(stats);
+ dpush(stats);
+}
--- /dev/null
+CELL max_pic_size;
+
+CELL cold_call_to_ic_transitions;
+CELL ic_to_pic_transitions;
+CELL pic_to_mega_transitions;
+
+/* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
+CELL pic_counts[4];
+
+void init_inline_caching(int max_size);
+
+void primitive_inline_cache_miss(void);
+
+XT inline_cache_miss(CELL return_address);
+
+void primitive_reset_inline_cache_stats(void);
+void primitive_inline_cache_stats(void);
--- /dev/null
+#include "master.h"
+
+/* Simple code generator used by:
+- profiler (profiler.c),
+- quotation compiler (quotations.c),
+- megamorphic caches (dispatch.c),
+- polymorphic inline caches (inline_cache.c) */
+
+/* Allocates memory */
+void jit_init(F_JIT *jit, CELL jit_type, CELL owner)
+{
+ jit->owner = owner;
+ REGISTER_ROOT(jit->owner);
+
+ jit->type = jit_type;
+
+ jit->code = make_growable_byte_array();
+ REGISTER_ROOT(jit->code.array);
+ jit->relocation = make_growable_byte_array();
+ REGISTER_ROOT(jit->relocation.array);
+ jit->literals = make_growable_array();
+ REGISTER_ROOT(jit->literals.array);
+
+ if(stack_traces_p())
+ growable_array_add(&jit->literals,jit->owner);
+
+ jit->computing_offset_p = false;
+}
+
+/* Facility to convert compiled code offsets to quotation offsets.
+Call jit_compute_offset() with the compiled code offset, then emit
+code, and at the end jit->position is the quotation position. */
+void jit_compute_position(F_JIT *jit, CELL offset)
+{
+ jit->computing_offset_p = true;
+ jit->position = 0;
+ jit->offset = offset;
+}
+
+/* Allocates memory */
+F_CODE_BLOCK *jit_make_code_block(F_JIT *jit)
+{
+ growable_byte_array_trim(&jit->code);
+ growable_byte_array_trim(&jit->relocation);
+ growable_array_trim(&jit->literals);
+
+ F_CODE_BLOCK *code = add_code_block(
+ jit->type,
+ untag_object(jit->code.array),
+ NULL, /* no labels */
+ jit->relocation.array,
+ jit->literals.array);
+
+ return code;
+}
+
+void jit_dispose(F_JIT *jit)
+{
+ UNREGISTER_ROOT(jit->literals.array);
+ UNREGISTER_ROOT(jit->relocation.array);
+ UNREGISTER_ROOT(jit->code.array);
+ UNREGISTER_ROOT(jit->owner);
+}
+
+static F_REL rel_to_emit(F_JIT *jit, CELL template, bool *rel_p)
+{
+ F_ARRAY *quadruple = untag_object(template);
+ CELL rel_class = array_nth(quadruple,1);
+ CELL rel_type = array_nth(quadruple,2);
+ CELL offset = array_nth(quadruple,3);
+
+ if(rel_class == F)
+ {
+ *rel_p = false;
+ return 0;
+ }
+ else
+ {
+ *rel_p = true;
+ return (untag_fixnum_fast(rel_type) << 28)
+ | (untag_fixnum_fast(rel_class) << 24)
+ | ((jit->code.count + untag_fixnum_fast(offset)));
+ }
+}
+
+/* Allocates memory */
+void jit_emit(F_JIT *jit, CELL template)
+{
+ REGISTER_ROOT(template);
+
+ bool rel_p;
+ F_REL rel = rel_to_emit(jit,template,&rel_p);
+ if(rel_p) growable_byte_array_append(&jit->relocation,&rel,sizeof(F_REL));
+
+ F_BYTE_ARRAY *code = code_to_emit(template);
+
+ if(jit->computing_offset_p)
+ {
+ CELL size = array_capacity(code);
+
+ if(jit->offset == 0)
+ {
+ jit->position--;
+ jit->computing_offset_p = false;
+ }
+ else if(jit->offset < size)
+ {
+ jit->position++;
+ jit->computing_offset_p = false;
+ }
+ else
+ jit->offset -= size;
+ }
+
+ growable_byte_array_append(&jit->code,code + 1,array_capacity(code));
+
+ UNREGISTER_ROOT(template);
+}
+
--- /dev/null
+typedef struct {
+ CELL type;
+ CELL owner;
+ F_GROWABLE_BYTE_ARRAY code;
+ F_GROWABLE_BYTE_ARRAY relocation;
+ F_GROWABLE_ARRAY literals;
+ bool computing_offset_p;
+ F_FIXNUM position;
+ CELL offset;
+} F_JIT;
+
+void jit_init(F_JIT *jit, CELL jit_type, CELL owner);
+
+void jit_compute_position(F_JIT *jit, CELL offset);
+
+F_CODE_BLOCK *jit_make_code_block(F_JIT *jit);
+
+void jit_dispose(F_JIT *jit);
+
+INLINE F_BYTE_ARRAY *code_to_emit(CELL template)
+{
+ return untag_object(array_nth(untag_object(template),0));
+}
+
+void jit_emit(F_JIT *jit, CELL template);
+
+/* Allocates memory */
+INLINE void jit_add_literal(F_JIT *jit, CELL literal)
+{
+ growable_array_add(&jit->literals,literal);
+}
+
+/* Allocates memory */
+INLINE void jit_emit_with(F_JIT *jit, CELL template, CELL argument)
+{
+ REGISTER_ROOT(template);
+ jit_add_literal(jit,argument);
+ UNREGISTER_ROOT(template);
+ jit_emit(jit,template);
+}
+
+/* Allocates memory */
+INLINE void jit_push(F_JIT *jit, CELL literal)
+{
+ jit_emit_with(jit,userenv[JIT_PUSH_IMMEDIATE],literal);
+}
+
+/* Allocates memory */
+INLINE void jit_word_jump(F_JIT *jit, CELL word)
+{
+ jit_emit_with(jit,userenv[JIT_WORD_JUMP],word);
+}
+
+/* Allocates memory */
+INLINE void jit_word_call(F_JIT *jit, CELL word)
+{
+ jit_emit_with(jit,userenv[JIT_WORD_CALL],word);
+}
+
+/* Allocates memory */
+INLINE void jit_emit_subprimitive(F_JIT *jit, F_WORD *word)
+{
+ REGISTER_UNTAGGED(word);
+ if(array_nth(untag_object(word->subprimitive),1) != F)
+ jit_add_literal(jit,T);
+ UNREGISTER_UNTAGGED(word);
+
+ jit_emit(jit,word->subprimitive);
+}
+
+INLINE F_FIXNUM jit_get_position(F_JIT *jit)
+{
+ if(jit->computing_offset_p)
+ {
+ /* If this is still on, jit_emit() didn't clear it,
+ so the offset was out of bounds */
+ return -1;
+ }
+ else
+ return jit->position;
+}
+
+INLINE void jit_set_position(F_JIT *jit, F_FIXNUM position)
+{
+ if(jit->computing_offset_p)
+ jit->position = position;
+}
/*** Tags ***/
#define FIXNUM_TYPE 0
#define BIGNUM_TYPE 1
-#define TUPLE_TYPE 2
-#define OBJECT_TYPE 3
-#define RATIO_TYPE 4
-#define FLOAT_TYPE 5
-#define COMPLEX_TYPE 6
+#define ARRAY_TYPE 2
+#define FLOAT_TYPE 3
+#define QUOTATION_TYPE 4
+#define F_TYPE 5
+#define OBJECT_TYPE 6
+#define TUPLE_TYPE 7
+
+#define HI_TAG_OR_TUPLE_P(cell) (((CELL)(cell) & 6) == 6)
+#define HI_TAG_HEADER(cell) (((CELL)(cell) & 1) * CELLS + UNTAG(cell))
/* Canonical F object */
-#define F_TYPE 7
#define F F_TYPE
-#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */
+#define HEADER_TYPE 8 /* anything less than this is a tag */
-#define GC_COLLECTED 5 /* See gc.c */
+#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
/*** Header types ***/
-#define ARRAY_TYPE 8
-#define WRAPPER_TYPE 9
-#define BYTE_ARRAY_TYPE 10
-#define CALLSTACK_TYPE 11
-#define STRING_TYPE 12
-#define WORD_TYPE 13
-#define QUOTATION_TYPE 14
-#define DLL_TYPE 15
-#define ALIEN_TYPE 16
-
-#define TYPE_COUNT 17
+#define WRAPPER_TYPE 8
+#define BYTE_ARRAY_TYPE 9
+#define CALLSTACK_TYPE 10
+#define STRING_TYPE 11
+#define WORD_TYPE 12
+#define DLL_TYPE 13
+#define ALIEN_TYPE 14
+
+#define TYPE_COUNT 15
+
+/* Not a real type, but F_CODE_BLOCK's type field can be set to this */
+#define PIC_TYPE 69
INLINE bool immediate_p(CELL obj)
{
CELL def;
/* TAGGED property assoc for library code */
CELL props;
- /* TAGGED t or f, t means its compiled with the optimizing compiler,
- f means its compiled with the non-optimizing compiler */
- CELL optimizedp;
+ /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */
+ CELL direct_entry_def;
/* TAGGED call count for profiling */
CELL counter;
/* TAGGED machine code for sub-primitive */
CELL object;
} F_WRAPPER;
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- CELL numerator;
- CELL denominator;
-} F_RATIO;
-
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
/* We use a union here to force the float value to be aligned on an
F_CODE_BLOCK *code;
} F_QUOTATION;
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- CELL real;
- CELL imaginary;
-} F_COMPLEX;
-
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
CELL header;
DEFPUSHPOP(gc_local_,gc_locals)
-#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj)
+#define REGISTER_ROOT(obj) \
+ { \
+ if(!immediate_p(obj)) \
+ check_data_pointer(obj); \
+ gc_local_push((CELL)&(obj)); \
+ }
#define UNREGISTER_ROOT(obj) \
{ \
- if(gc_local_pop() != (CELL)&obj) \
+ if(gc_local_pop() != (CELL)&(obj)) \
critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
}
DEFPUSHPOP(root_,extra_roots)
-#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
+#define REGISTER_UNTAGGED(obj) root_push(obj ? RETAG(obj,OBJECT_TYPE) : 0)
#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
/* We ignore strings which point outside the data heap, but we might be given
#define __FACTOR_MASTER_H__
#ifndef WINCE
- #include <errno.h>
+#include <errno.h>
+#endif
+
+#ifdef FACTOR_DEBUG
+#include <assert.h>
#endif
#include <fcntl.h>
#include "bignum.h"
#include "write_barrier.h"
#include "data_heap.h"
-#include "local_roots.h"
#include "data_gc.h"
+#include "local_roots.h"
#include "debug.h"
-#include "types.h"
+#include "arrays.h"
+#include "strings.h"
+#include "booleans.h"
+#include "byte_arrays.h"
+#include "tuples.h"
+#include "words.h"
#include "math.h"
#include "float_bits.h"
#include "io.h"
#include "callstack.h"
#include "alien.h"
#include "quotations.h"
+#include "jit.h"
+#include "dispatch.h"
+#include "inline_cache.h"
#include "factor.h"
#include "utilities.h"
return 0; /* can't happen */
}
-/* Ratios */
-
-/* Does not reduce to lowest terms, so should only be used by math
-library implementation, to avoid breaking invariants. */
-void primitive_from_fraction(void)
-{
- F_RATIO* ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO));
- ratio->denominator = dpop();
- ratio->numerator = dpop();
- dpush(RETAG(ratio,RATIO_TYPE));
-}
-
/* Floats */
void primitive_fixnum_to_float(void)
{
{
dpush(allot_float(flo));
}
-
-/* Complex numbers */
-
-void primitive_from_rect(void)
-{
- F_COMPLEX* z = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
- z->imaginary = dpop();
- z->real = dpop();
- dpush(RETAG(z,COMPLEX_TYPE));
-}
CELL unbox_array_size(void);
-void primitive_from_fraction(void);
-
INLINE double untag_float_fast(CELL tagged)
{
return ((F_FLOAT*)UNTAG(tagged))->n;
void primitive_bits_float(void);
void primitive_double_bits(void);
void primitive_bits_double(void);
-
-void primitive_from_rect(void);
primitive_float_to_bignum,
primitive_fixnum_to_float,
primitive_bignum_to_float,
- primitive_from_fraction,
primitive_str_to_float,
primitive_float_to_str,
primitive_float_bits,
primitive_double_bits,
primitive_bits_float,
primitive_bits_double,
- primitive_from_rect,
primitive_fixnum_add,
primitive_fixnum_subtract,
primitive_fixnum_multiply,
primitive_clear_gc_stats,
primitive_jit_compile,
primitive_load_locals,
- primitive_check_datastack
+ primitive_check_datastack,
+ primitive_inline_cache_miss,
+ primitive_mega_cache_miss,
+ primitive_lookup_method,
+ primitive_reset_dispatch_stats,
+ primitive_dispatch_stats,
+ primitive_reset_inline_cache_stats,
+ primitive_inline_cache_stats,
+ primitive_optimized_p,
};
#include "master.h"
/* Allocates memory */
-F_CODE_BLOCK *compile_profiling_stub(F_WORD *word)
+F_CODE_BLOCK *compile_profiling_stub(CELL word)
{
- CELL literals = allot_array_2(tag_object(word),tag_object(word));
- REGISTER_ROOT(literals);
-
- F_ARRAY *quadruple = untag_object(userenv[JIT_PROFILING]);
-
- CELL code = array_nth(quadruple,0);
- REGISTER_ROOT(code);
-
- F_REL rel = (to_fixnum(array_nth(quadruple,1)) << 24)
- | (to_fixnum(array_nth(quadruple,2)) << 28)
- | (to_fixnum(array_nth(quadruple,3)) * compiled_code_format());
-
- F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL));
- memcpy(relocation + 1,&rel,sizeof(F_REL));
-
- UNREGISTER_ROOT(code);
- UNREGISTER_ROOT(literals);
-
- return add_code_block(
- WORD_TYPE,
- untag_object(code),
- NULL, /* no labels */
- tag_object(relocation),
- literals);
+ REGISTER_ROOT(word);
+ F_JIT jit;
+ jit_init(&jit,WORD_TYPE,word);
+ jit_emit_with(&jit,userenv[JIT_PROFILING],word);
+ F_CODE_BLOCK *block = jit_make_code_block(&jit);
+ jit_dispose(&jit);
+ UNREGISTER_ROOT(word);
+ return block;
}
/* Allocates memory */
-void update_word_xt(F_WORD *word)
-{
- if(profiling_p)
- {
- if(!word->profiling)
- {
- REGISTER_UNTAGGED(word);
- F_CODE_BLOCK *profiling = compile_profiling_stub(word);
- UNREGISTER_UNTAGGED(word);
- word->profiling = profiling;
- }
-
- word->xt = (XT)(word->profiling + 1);
- }
- else
- word->xt = (XT)(word->code + 1);
-}
-
-void set_profiling(bool profiling)
+static void set_profiling(bool profiling)
{
if(profiling == profiling_p)
return;
bool profiling_p;
+F_CODE_BLOCK *compile_profiling_stub(CELL word);
void primitive_profiling(void);
-F_CODE_BLOCK *compile_profiling_stub(F_WORD *word);
-void update_word_xt(F_WORD *word);
generated.
3) When in tail position and immediately preceded by literal arguments, the
-'if' and 'dispatch' conditionals are generated inline, instead of as a call to
-the 'if' word.
+'if' is generated inline, instead of as a call to the 'if' word.
4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are
open-coded as retain stack manipulation surrounding a subroutine call.
-5) When preceded by an array, calls to the 'declare' word are optimized out
-entirely. This word is only used by the optimizing compiler, and with the
-non-optimizing compiler it would otherwise just decrease performance to have to
-push the array and immediately drop it after.
-
-6) Sub-primitives are primitive words which are implemented in assembly and not
+5) Sub-primitives are primitive words which are implemented in assembly and not
in the VM. They are open-coded and no subroutine call is generated. This
includes stack shufflers, some fixnum arithmetic words, and words such as tag,
slot and eq?. A primitive call is relatively expensive (two subroutine calls)
so this results in a big speedup for relatively little effort. */
-bool jit_primitive_call_p(F_ARRAY *array, CELL i)
+static 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)
+static bool jit_fast_if_p(F_ARRAY *array, CELL i)
{
return (i + 3) == array_capacity(array)
&& type_of(array_nth(array,i)) == QUOTATION_TYPE
&& array_nth(array,i + 2) == userenv[JIT_IF_WORD];
}
-bool jit_fast_dispatch_p(F_ARRAY *array, CELL i)
-{
- return (i + 2) == array_capacity(array)
- && type_of(array_nth(array,i)) == ARRAY_TYPE
- && array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD];
-}
-
-bool jit_fast_dip_p(F_ARRAY *array, CELL i)
+static bool jit_fast_dip_p(F_ARRAY *array, CELL i)
{
return (i + 2) <= array_capacity(array)
&& type_of(array_nth(array,i)) == QUOTATION_TYPE
&& array_nth(array,i + 1) == userenv[JIT_DIP_WORD];
}
-bool jit_fast_2dip_p(F_ARRAY *array, CELL i)
+static bool jit_fast_2dip_p(F_ARRAY *array, CELL i)
{
return (i + 2) <= array_capacity(array)
&& type_of(array_nth(array,i)) == QUOTATION_TYPE
&& array_nth(array,i + 1) == userenv[JIT_2DIP_WORD];
}
-bool jit_fast_3dip_p(F_ARRAY *array, CELL i)
+static bool jit_fast_3dip_p(F_ARRAY *array, CELL i)
{
return (i + 2) <= array_capacity(array)
&& type_of(array_nth(array,i)) == QUOTATION_TYPE
&& array_nth(array,i + 1) == userenv[JIT_3DIP_WORD];
}
-bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
+static bool jit_mega_lookup_p(F_ARRAY *array, CELL i)
{
- return (i + 1) < array_capacity(array)
+ return (i + 3) < array_capacity(array)
&& type_of(array_nth(array,i)) == ARRAY_TYPE
- && array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
+ && type_of(array_nth(array,i + 1)) == FIXNUM_TYPE
+ && type_of(array_nth(array,i + 2)) == ARRAY_TYPE
+ && array_nth(array,i + 3) == userenv[MEGA_LOOKUP_WORD];
}
-F_ARRAY *code_to_emit(CELL code)
-{
- return untag_object(array_nth(untag_object(code),0));
-}
-
-F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length, bool *rel_p)
-{
- F_ARRAY *quadruple = untag_object(code);
- CELL rel_class = array_nth(quadruple,1);
- CELL rel_type = array_nth(quadruple,2);
- CELL offset = array_nth(quadruple,3);
-
- if(rel_class == F)
- {
- *rel_p = false;
- return 0;
- }
- else
- {
- *rel_p = true;
- return (to_fixnum(rel_type) << 28)
- | (to_fixnum(rel_class) << 24)
- | ((code_length + to_fixnum(offset)) * code_format);
- }
-}
-
-#define EMIT(name) { \
- bool rel_p; \
- F_REL rel = rel_to_emit(name,code_format,code_count,&rel_p); \
- if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \
- GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \
- }
-
-bool jit_stack_frame_p(F_ARRAY *array)
+static bool jit_stack_frame_p(F_ARRAY *array)
{
F_FIXNUM length = array_capacity(array);
F_FIXNUM i;
if(type_of(obj) == WORD_TYPE)
{
F_WORD *word = untag_object(obj);
- if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD])
+ if(word->subprimitive == F)
return true;
}
else if(type_of(obj) == QUOTATION_TYPE)
return false;
}
-void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code)
-{
- if(code->block.type != QUOTATION_TYPE)
- critical_error("Bad param to set_quot_xt",(CELL)code);
-
- quot->code = code;
- quot->xt = (XT)(code + 1);
- quot->compiledp = T;
-}
+#define TAIL_CALL { \
+ if(stack_frame) jit_emit(jit,userenv[JIT_EPILOG]); \
+ tail_call = true; \
+ }
-/* Might GC */
-void jit_compile(CELL quot, bool relocate)
+/* Allocates memory */
+static void jit_iterate_quotation(F_JIT *jit, CELL array, CELL compiling, CELL relocate)
{
- if(untag_quotation(quot)->compiledp != F)
- return;
-
- CELL code_format = compiled_code_format();
-
- REGISTER_ROOT(quot);
-
- CELL array = untag_quotation(quot)->array;
REGISTER_ROOT(array);
- GROWABLE_ARRAY(code);
- REGISTER_ROOT(code);
-
- GROWABLE_BYTE_ARRAY(relocation);
- REGISTER_ROOT(relocation);
-
- GROWABLE_ARRAY(literals);
- REGISTER_ROOT(literals);
-
- if(stack_traces_p())
- GROWABLE_ARRAY_ADD(literals,quot);
-
bool stack_frame = jit_stack_frame_p(untag_object(array));
+ jit_set_position(jit,0);
+
if(stack_frame)
- EMIT(userenv[JIT_PROLOG]);
+ jit_emit(jit,userenv[JIT_PROLOG]);
CELL i;
CELL length = array_capacity(untag_object(array));
for(i = 0; i < length; i++)
{
+ jit_set_position(jit,i);
+
CELL obj = array_nth(untag_object(array),i);
+ REGISTER_ROOT(obj);
+
F_WORD *word;
F_WRAPPER *wrapper;
/* Intrinsics */
if(word->subprimitive != F)
+ jit_emit_subprimitive(jit,word);
+ /* The (execute) primitive is special-cased */
+ else if(obj == userenv[JIT_EXECUTE_WORD])
{
- if(array_nth(untag_object(word->subprimitive),1) != F)
+ if(i == length - 1)
{
- GROWABLE_ARRAY_ADD(literals,T);
+ TAIL_CALL;
+ jit_emit(jit,userenv[JIT_EXECUTE_JUMP]);
}
-
- EMIT(word->subprimitive);
+ else
+ jit_emit(jit,userenv[JIT_EXECUTE_CALL]);
}
+ /* Everything else */
else
{
- GROWABLE_ARRAY_ADD(literals,obj);
-
if(i == length - 1)
{
- if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
-
- EMIT(userenv[JIT_WORD_JUMP]);
-
- tail_call = true;
+ TAIL_CALL;
+ jit_word_jump(jit,obj);
}
else
- EMIT(userenv[JIT_WORD_CALL]);
+ jit_word_call(jit,obj);
}
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
- GROWABLE_ARRAY_ADD(literals,wrapper->object);
- EMIT(userenv[JIT_PUSH_IMMEDIATE]);
+ jit_push(jit,wrapper->object);
break;
case FIXNUM_TYPE:
+ /* Primitive calls */
if(jit_primitive_call_p(untag_object(array),i))
{
- EMIT(userenv[JIT_SAVE_STACK]);
- GROWABLE_ARRAY_ADD(literals,obj);
- EMIT(userenv[JIT_PRIMITIVE]);
+ jit_emit(jit,userenv[JIT_SAVE_STACK]);
+ jit_emit_with(jit,userenv[JIT_PRIMITIVE],obj);
i++;
break;
}
case QUOTATION_TYPE:
+ /* 'if' preceeded by two literal quotations (this is why if and ? are
+ mutually recursive in the library, but both still work) */
if(jit_fast_if_p(untag_object(array),i))
{
- if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
+ TAIL_CALL;
- jit_compile(array_nth(untag_object(array),i),relocate);
- jit_compile(array_nth(untag_object(array),i + 1),relocate);
+ if(compiling)
+ {
+ jit_compile(array_nth(untag_object(array),i),relocate);
+ jit_compile(array_nth(untag_object(array),i + 1),relocate);
+ }
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_IF_1]);
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
- EMIT(userenv[JIT_IF_2]);
+ jit_emit_with(jit,userenv[JIT_IF_1],array_nth(untag_object(array),i));
+ jit_emit_with(jit,userenv[JIT_IF_2],array_nth(untag_object(array),i + 1));
i += 2;
- tail_call = true;
break;
}
+ /* dip */
else if(jit_fast_dip_p(untag_object(array),i))
{
- jit_compile(obj,relocate);
-
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_DIP]);
-
+ if(compiling)
+ jit_compile(obj,relocate);
+ jit_emit_with(jit,userenv[JIT_DIP],obj);
i++;
break;
}
+ /* 2dip */
else if(jit_fast_2dip_p(untag_object(array),i))
{
- jit_compile(obj,relocate);
-
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_2DIP]);
-
+ if(compiling)
+ jit_compile(obj,relocate);
+ jit_emit_with(jit,userenv[JIT_2DIP],obj);
i++;
break;
}
+ /* 3dip */
else if(jit_fast_3dip_p(untag_object(array),i))
{
- jit_compile(obj,relocate);
-
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_3DIP]);
-
+ if(compiling)
+ jit_compile(obj,relocate);
+ jit_emit_with(jit,userenv[JIT_3DIP],obj);
i++;
break;
}
case ARRAY_TYPE:
- if(jit_fast_dispatch_p(untag_object(array),i))
+ /* Method dispatch */
+ if(jit_mega_lookup_p(untag_object(array),i))
{
- if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
-
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_DISPATCH]);
-
- i++;
-
+ jit_emit_mega_cache_lookup(jit,
+ array_nth(untag_object(array),i),
+ untag_fixnum_fast(array_nth(untag_object(array),i + 1)),
+ array_nth(untag_object(array),i + 2));
+ i += 3;
tail_call = true;
break;
}
- else if(jit_ignore_declare_p(untag_object(array),i))
- {
- i++;
- break;
- }
default:
- GROWABLE_ARRAY_ADD(literals,obj);
- EMIT(userenv[JIT_PUSH_IMMEDIATE]);
+ jit_push(jit,obj);
break;
}
+
+ UNREGISTER_ROOT(obj);
}
if(!tail_call)
{
- if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
+ jit_set_position(jit,length);
- EMIT(userenv[JIT_RETURN]);
+ if(stack_frame)
+ jit_emit(jit,userenv[JIT_EPILOG]);
+ jit_emit(jit,userenv[JIT_RETURN]);
}
- GROWABLE_ARRAY_TRIM(code);
- GROWABLE_ARRAY_TRIM(literals);
- GROWABLE_BYTE_ARRAY_TRIM(relocation);
-
- F_CODE_BLOCK *compiled = add_code_block(
- QUOTATION_TYPE,
- untag_object(code),
- NULL,
- relocation,
- literals);
-
- set_quot_xt(untag_object(quot),compiled);
-
- if(relocate)
- relocate_code_block(compiled);
-
- UNREGISTER_ROOT(literals);
- UNREGISTER_ROOT(relocation);
- UNREGISTER_ROOT(code);
UNREGISTER_ROOT(array);
- UNREGISTER_ROOT(quot);
}
-/* Crappy code duplication. If C had closures (not just function pointers)
-it would be easy to get rid of, but I can't think of a good way to deal
-with it right now that doesn't involve lots of boilerplate that would be
-worse than the duplication itself (eg, putting all state in some global
-struct.) */
-#define COUNT(name,scan) \
- { \
- CELL size = array_capacity(code_to_emit(name)) * code_format; \
- if(offset == 0) return scan - 1; \
- if(offset < size) return scan + 1; \
- offset -= size; \
- }
-
-F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
+void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code)
{
- CELL code_format = compiled_code_format();
-
- CELL array = untag_quotation(quot)->array;
-
- bool stack_frame = jit_stack_frame_p(untag_object(array));
-
- if(stack_frame)
- COUNT(userenv[JIT_PROLOG],0)
-
- CELL i;
- CELL length = array_capacity(untag_object(array));
- bool tail_call = false;
+ if(code->block.type != QUOTATION_TYPE)
+ critical_error("Bad param to set_quot_xt",(CELL)code);
- for(i = 0; i < length; i++)
- {
- CELL obj = array_nth(untag_object(array),i);
- F_WORD *word;
+ quot->code = code;
+ quot->xt = (XT)(code + 1);
+ quot->compiledp = T;
+}
- switch(type_of(obj))
- {
- case WORD_TYPE:
- /* Intrinsics */
- word = untag_object(obj);
- if(word->subprimitive != F)
- COUNT(word->subprimitive,i)
- else if(i == length - 1)
- {
- if(stack_frame)
- COUNT(userenv[JIT_EPILOG],i);
+/* Allocates memory */
+void jit_compile(CELL quot, bool relocate)
+{
+ if(untag_quotation(quot)->compiledp != F)
+ return;
- COUNT(userenv[JIT_WORD_JUMP],i)
+ CELL array = untag_quotation(quot)->array;
- tail_call = true;
- }
- else
- COUNT(userenv[JIT_WORD_CALL],i)
- break;
- case WRAPPER_TYPE:
- COUNT(userenv[JIT_PUSH_IMMEDIATE],i)
- break;
- case FIXNUM_TYPE:
- if(jit_primitive_call_p(untag_object(array),i))
- {
- COUNT(userenv[JIT_SAVE_STACK],i);
- COUNT(userenv[JIT_PRIMITIVE],i);
+ REGISTER_ROOT(quot);
+ REGISTER_ROOT(array);
- i++;
+ F_JIT jit;
+ jit_init(&jit,QUOTATION_TYPE,quot);
- tail_call = true;
- break;
- }
- case QUOTATION_TYPE:
- if(jit_fast_if_p(untag_object(array),i))
- {
- if(stack_frame)
- COUNT(userenv[JIT_EPILOG],i)
+ jit_iterate_quotation(&jit,array,true,relocate);
- COUNT(userenv[JIT_IF_1],i)
- COUNT(userenv[JIT_IF_2],i)
- i += 2;
+ F_CODE_BLOCK *compiled = jit_make_code_block(&jit);
- tail_call = true;
- break;
- }
- else if(jit_fast_dip_p(untag_object(array),i))
- {
- COUNT(userenv[JIT_DIP],i)
- i++;
- break;
- }
- else if(jit_fast_2dip_p(untag_object(array),i))
- {
- COUNT(userenv[JIT_2DIP],i)
- i++;
- break;
- }
- else if(jit_fast_3dip_p(untag_object(array),i))
- {
- COUNT(userenv[JIT_3DIP],i)
- i++;
- break;
- }
- case ARRAY_TYPE:
- if(jit_fast_dispatch_p(untag_object(array),i))
- {
- if(stack_frame)
- COUNT(userenv[JIT_EPILOG],i)
-
- i++;
+ set_quot_xt(untag_object(quot),compiled);
- COUNT(userenv[JIT_DISPATCH],i)
+ if(relocate) relocate_code_block(compiled);
- tail_call = true;
- break;
- }
- if(jit_ignore_declare_p(untag_object(array),i))
- {
- if(offset == 0) return i;
+ jit_dispose(&jit);
- i++;
+ UNREGISTER_ROOT(array);
+ UNREGISTER_ROOT(quot);
+}
- break;
- }
- default:
- COUNT(userenv[JIT_PUSH_IMMEDIATE],i)
- break;
- }
- }
+F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset)
+{
+ CELL array = untag_quotation(quot)->array;
+ REGISTER_ROOT(array);
- if(!tail_call)
- {
- if(stack_frame)
- COUNT(userenv[JIT_EPILOG],length)
+ F_JIT jit;
+ jit_init(&jit,QUOTATION_TYPE,quot);
+ jit_compute_position(&jit,offset);
+ jit_iterate_quotation(&jit,array,false,false);
+ jit_dispose(&jit);
- COUNT(userenv[JIT_RETURN],length)
- }
+ UNREGISTER_ROOT(array);
- return -1;
+ return jit_get_position(&jit);
}
F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack)
quot->compiledp = F;
quot->cached_effect = F;
quot->cache_counter = F;
- drepl(tag_object(quot));
+ drepl(tag_quotation(quot));
}
void primitive_quotation_xt(void)
{
F_WORD *word = untag_word(array_nth(untag_array(words),i));
REGISTER_UNTAGGED(word);
- if(word->optimizedp == F)
+
+ if(!word->code || !word_optimized_p(word))
jit_compile_word(word,word->def,false);
+
UNREGISTER_UNTAGGED(word);
update_word_xt(word);
+
}
UNREGISTER_ROOT(words);
+DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
+
+INLINE CELL tag_quotation(F_QUOTATION *quotation)
+{
+ return RETAG(quotation,QUOTATION_TYPE);
+}
+
void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code);
void jit_compile(CELL quot, bool relocate);
F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack);
-F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
+F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset);
void primitive_array_to_quotation(void);
void primitive_quotation_xt(void);
void primitive_jit_compile(void);
{
F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS);
memcpy(a + 1,(void*)bottom,depth);
- dpush(tag_object(a));
+ dpush(tag_array(a));
return true;
}
}
ds -= CELLS * count;
rs += CELLS * count;
}
+
+static CELL clone_object(CELL object)
+{
+ CELL size = object_size(object);
+ if(size == 0)
+ return object;
+ else
+ {
+ REGISTER_ROOT(object);
+ void *new_obj = allot_object(type_of(object),size);
+ UNREGISTER_ROOT(object);
+
+ CELL tag = TAG(object);
+ memcpy(new_obj,(void*)UNTAG(object),size);
+ return RETAG(new_obj,tag);
+ }
+}
+
+void primitive_clone(void)
+{
+ drepl(clone_object(dpeek()));
+}
BOOT_ENV = 20, /* boot quotation */
GLOBAL_ENV, /* global namespace */
- /* Used by the JIT compiler */
- JIT_CODE_FORMAT = 22,
- JIT_PROLOG,
+ /* Quotation compilation in quotations.c */
+ JIT_PROLOG = 23,
JIT_PRIMITIVE_WORD,
JIT_PRIMITIVE,
JIT_WORD_JUMP,
JIT_IF_WORD,
JIT_IF_1,
JIT_IF_2,
- JIT_DISPATCH_WORD,
- JIT_DISPATCH,
- JIT_EPILOG,
+ JIT_EPILOG = 33,
JIT_RETURN,
JIT_PROFILING,
JIT_PUSH_IMMEDIATE,
- JIT_DECLARE_WORD = 42,
- JIT_SAVE_STACK,
+ JIT_SAVE_STACK = 38,
JIT_DIP_WORD,
JIT_DIP,
JIT_2DIP_WORD,
JIT_2DIP,
JIT_3DIP_WORD,
JIT_3DIP,
-
- STACK_TRACES_ENV = 59,
+ JIT_EXECUTE_WORD,
+ JIT_EXECUTE_JUMP,
+ JIT_EXECUTE_CALL,
+
+ /* Polymorphic inline cache generation in inline_cache.c */
+ PIC_LOAD = 48,
+ PIC_TAG,
+ PIC_HI_TAG,
+ PIC_TUPLE,
+ PIC_HI_TAG_TUPLE,
+ PIC_CHECK_TAG,
+ PIC_CHECK,
+ PIC_HIT,
+ PIC_MISS_WORD,
+
+ /* Megamorphic cache generation in dispatch.c */
+ MEGA_LOOKUP = 57,
+ MEGA_LOOKUP_WORD,
+ MEGA_MISS_WORD,
UNDEFINED_ENV = 60, /* default quotation for undefined words */
THREADS_ENV = 64,
RUN_QUEUE_ENV = 65,
SLEEP_QUEUE_ENV = 66,
+
+ STACK_TRACES_ENV = 67,
} F_ENVTYPE;
#define FIRST_SAVE_ENV BOOT_ENV
return cell << TAG_BITS;
}
+INLINE void check_header(CELL cell)
+{
+#ifdef FACTOR_DEBUG
+ assert(TAG(cell) == FIXNUM_TYPE && untag_fixnum_fast(cell) < TYPE_COUNT);
+#endif
+}
+
INLINE CELL untag_header(CELL cell)
{
+ check_header(cell);
return cell >> TAG_BITS;
}
-INLINE CELL tag_object(void* cell)
+INLINE CELL hi_tag(CELL tagged)
{
- return RETAG(cell,OBJECT_TYPE);
+ return untag_header(get(UNTAG(tagged)));
}
-INLINE CELL object_type(CELL tagged)
+INLINE CELL tag_object(void *cell)
{
- return untag_header(get(UNTAG(tagged)));
+#ifdef FACTOR_DEBUG
+ assert(hi_tag((CELL)cell) >= HEADER_TYPE);
+#endif
+ return RETAG(cell,OBJECT_TYPE);
}
INLINE CELL type_of(CELL tagged)
{
CELL tag = TAG(tagged);
if(tag == OBJECT_TYPE)
- return object_type(tagged);
+ return hi_tag(tagged);
else
return tag;
}
void primitive_getenv(void);
void primitive_setenv(void);
void primitive_exit(void);
-void primitive_os_env(void);
-void primitive_os_envs(void);
-void primitive_set_os_env(void);
-void primitive_unset_os_env(void);
-void primitive_set_os_envs(void);
void primitive_micros(void);
void primitive_sleep(void);
void primitive_set_slot(void);
void primitive_load_locals(void);
+void primitive_clone(void);
bool stage2;
--- /dev/null
+#include "master.h"
+
+CELL string_nth(F_STRING* string, CELL index)
+{
+ /* If high bit is set, the most significant 16 bits of the char
+ come from the aux vector. The least significant bit of the
+ corresponding aux vector entry is negated, so that we can
+ XOR the two components together and get the original code point
+ back. */
+ CELL ch = bget(SREF(string,index));
+ if((ch & 0x80) == 0)
+ return ch;
+ else
+ {
+ F_BYTE_ARRAY *aux = untag_object(string->aux);
+ return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch;
+ }
+}
+
+void set_string_nth_fast(F_STRING* string, CELL index, CELL ch)
+{
+ bput(SREF(string,index),ch);
+}
+
+void set_string_nth_slow(F_STRING* string, CELL index, CELL ch)
+{
+ F_BYTE_ARRAY *aux;
+
+ bput(SREF(string,index),(ch & 0x7f) | 0x80);
+
+ if(string->aux == F)
+ {
+ REGISTER_UNTAGGED(string);
+ /* We don't need to pre-initialize the
+ byte array with any data, since we
+ only ever read from the aux vector
+ if the most significant bit of a
+ character is set. Initially all of
+ the bits are clear. */
+ aux = allot_byte_array_internal(
+ untag_fixnum_fast(string->length)
+ * sizeof(u16));
+ UNREGISTER_UNTAGGED(string);
+
+ write_barrier((CELL)string);
+ string->aux = tag_object(aux);
+ }
+ else
+ aux = untag_object(string->aux);
+
+ cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1);
+}
+
+/* allocates memory */
+void set_string_nth(F_STRING* string, CELL index, CELL ch)
+{
+ if(ch <= 0x7f)
+ set_string_nth_fast(string,index,ch);
+ else
+ set_string_nth_slow(string,index,ch);
+}
+
+/* untagged */
+F_STRING* allot_string_internal(CELL capacity)
+{
+ F_STRING *string = allot_object(STRING_TYPE,string_size(capacity));
+
+ string->length = tag_fixnum(capacity);
+ string->hashcode = F;
+ string->aux = F;
+
+ return string;
+}
+
+/* allocates memory */
+void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
+{
+ if(fill <= 0x7f)
+ memset((void *)SREF(string,start),fill,capacity - start);
+ else
+ {
+ CELL i;
+
+ for(i = start; i < capacity; i++)
+ {
+ REGISTER_UNTAGGED(string);
+ set_string_nth(string,i,fill);
+ UNREGISTER_UNTAGGED(string);
+ }
+ }
+}
+
+/* untagged */
+F_STRING *allot_string(CELL capacity, CELL fill)
+{
+ F_STRING* string = allot_string_internal(capacity);
+ REGISTER_UNTAGGED(string);
+ fill_string(string,0,capacity,fill);
+ UNREGISTER_UNTAGGED(string);
+ return string;
+}
+
+void primitive_string(void)
+{
+ CELL initial = to_cell(dpop());
+ CELL length = unbox_array_size();
+ dpush(tag_object(allot_string(length,initial)));
+}
+
+static bool reallot_string_in_place_p(F_STRING *string, CELL capacity)
+{
+ return in_zone(&nursery,(CELL)string) && capacity <= string_capacity(string);
+}
+
+F_STRING* reallot_string(F_STRING* string, CELL capacity)
+{
+ if(reallot_string_in_place_p(string,capacity))
+ {
+ string->length = tag_fixnum(capacity);
+
+ if(string->aux != F)
+ {
+ F_BYTE_ARRAY *aux = untag_object(string->aux);
+ aux->capacity = tag_fixnum(capacity * 2);
+ }
+
+ return string;
+ }
+ else
+ {
+ CELL to_copy = string_capacity(string);
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ REGISTER_UNTAGGED(string);
+ F_STRING *new_string = allot_string_internal(capacity);
+ UNREGISTER_UNTAGGED(string);
+
+ memcpy(new_string + 1,string + 1,to_copy);
+
+ if(string->aux != F)
+ {
+ REGISTER_UNTAGGED(string);
+ REGISTER_UNTAGGED(new_string);
+ F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
+ UNREGISTER_UNTAGGED(new_string);
+ UNREGISTER_UNTAGGED(string);
+
+ write_barrier((CELL)new_string);
+ new_string->aux = tag_object(new_aux);
+
+ F_BYTE_ARRAY *aux = untag_object(string->aux);
+ memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
+ }
+
+ REGISTER_UNTAGGED(string);
+ REGISTER_UNTAGGED(new_string);
+ fill_string(new_string,to_copy,capacity,'\0');
+ UNREGISTER_UNTAGGED(new_string);
+ UNREGISTER_UNTAGGED(string);
+
+ return new_string;
+ }
+}
+
+void primitive_resize_string(void)
+{
+ F_STRING* string = untag_string(dpop());
+ CELL capacity = unbox_array_size();
+ dpush(tag_object(reallot_string(string,capacity)));
+}
+
+/* Some ugly macros to prevent a 2x code duplication */
+
+#define MEMORY_TO_STRING(type,utype) \
+ F_STRING *memory_to_##type##_string(const type *string, CELL length) \
+ { \
+ REGISTER_C_STRING(string); \
+ F_STRING* s = allot_string_internal(length); \
+ UNREGISTER_C_STRING(string); \
+ CELL i; \
+ for(i = 0; i < length; i++) \
+ { \
+ REGISTER_UNTAGGED(s); \
+ set_string_nth(s,i,(utype)*string); \
+ UNREGISTER_UNTAGGED(s); \
+ string++; \
+ } \
+ return s; \
+ } \
+ F_STRING *from_##type##_string(const type *str) \
+ { \
+ CELL length = 0; \
+ const type *scan = str; \
+ while(*scan++) length++; \
+ return memory_to_##type##_string(str,length); \
+ } \
+ void box_##type##_string(const type *str) \
+ { \
+ dpush(str ? tag_object(from_##type##_string(str)) : F); \
+ }
+
+MEMORY_TO_STRING(char,u8)
+MEMORY_TO_STRING(u16,u16)
+MEMORY_TO_STRING(u32,u32)
+
+bool check_string(F_STRING *s, CELL max)
+{
+ CELL capacity = string_capacity(s);
+ CELL i;
+ for(i = 0; i < capacity; i++)
+ {
+ CELL ch = string_nth(s,i);
+ if(ch == '\0' || ch >= (1 << (max * 8)))
+ return false;
+ }
+ return true;
+}
+
+F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
+{
+ return allot_byte_array((capacity + 1) * size);
+}
+
+#define STRING_TO_MEMORY(type) \
+ void type##_string_to_memory(F_STRING *s, type *string) \
+ { \
+ CELL i; \
+ CELL capacity = string_capacity(s); \
+ for(i = 0; i < capacity; i++) \
+ string[i] = string_nth(s,i); \
+ } \
+ void primitive_##type##_string_to_memory(void) \
+ { \
+ type *address = unbox_alien(); \
+ F_STRING *str = untag_string(dpop()); \
+ type##_string_to_memory(str,address); \
+ } \
+ F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
+ { \
+ CELL capacity = string_capacity(s); \
+ F_BYTE_ARRAY *_c_str; \
+ if(check && !check_string(s,sizeof(type))) \
+ general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
+ REGISTER_UNTAGGED(s); \
+ _c_str = allot_c_string(capacity,sizeof(type)); \
+ UNREGISTER_UNTAGGED(s); \
+ type *c_str = (type*)(_c_str + 1); \
+ type##_string_to_memory(s,c_str); \
+ c_str[capacity] = 0; \
+ return _c_str; \
+ } \
+ type *to_##type##_string(F_STRING *s, bool check) \
+ { \
+ return (type*)(string_to_##type##_alien(s,check) + 1); \
+ } \
+ type *unbox_##type##_string(void) \
+ { \
+ return to_##type##_string(untag_string(dpop()),true); \
+ }
+
+STRING_TO_MEMORY(char);
+STRING_TO_MEMORY(u16);
+
+void primitive_string_nth(void)
+{
+ F_STRING *string = untag_object(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ dpush(tag_fixnum(string_nth(string,index)));
+}
+
+void primitive_set_string_nth(void)
+{
+ F_STRING *string = untag_object(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ CELL value = untag_fixnum_fast(dpop());
+ set_string_nth(string,index,value);
+}
+
+void primitive_set_string_nth_fast(void)
+{
+ F_STRING *string = untag_object(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ CELL value = untag_fixnum_fast(dpop());
+ set_string_nth_fast(string,index,value);
+}
+
+void primitive_set_string_nth_slow(void)
+{
+ F_STRING *string = untag_object(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ CELL value = untag_fixnum_fast(dpop());
+ set_string_nth_slow(string,index,value);
+}
--- /dev/null
+INLINE CELL string_capacity(F_STRING* str)
+{
+ return untag_fixnum_fast(str->length);
+}
+
+INLINE CELL string_size(CELL size)
+{
+ return sizeof(F_STRING) + size;
+}
+
+#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index))
+#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index))
+
+INLINE F_STRING* untag_string(CELL tagged)
+{
+ type_check(STRING_TYPE,tagged);
+ return untag_object(tagged);
+}
+
+F_STRING* allot_string_internal(CELL capacity);
+F_STRING* allot_string(CELL capacity, CELL fill);
+void primitive_string(void);
+F_STRING *reallot_string(F_STRING *string, CELL capacity);
+void primitive_resize_string(void);
+
+F_STRING *memory_to_char_string(const char *string, CELL length);
+F_STRING *from_char_string(const char *c_string);
+DLLEXPORT void box_char_string(const char *c_string);
+
+F_STRING *memory_to_u16_string(const u16 *string, CELL length);
+F_STRING *from_u16_string(const u16 *c_string);
+DLLEXPORT void box_u16_string(const u16 *c_string);
+
+void char_string_to_memory(F_STRING *s, char *string);
+F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check);
+char* to_char_string(F_STRING *s, bool check);
+DLLEXPORT char *unbox_char_string(void);
+
+void u16_string_to_memory(F_STRING *s, u16 *string);
+F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
+u16* to_u16_string(F_STRING *s, bool check);
+DLLEXPORT u16 *unbox_u16_string(void);
+
+/* String getters and setters */
+CELL string_nth(F_STRING* string, CELL index);
+void set_string_nth(F_STRING* string, CELL index, CELL value);
+
+void primitive_string_nth(void);
+void primitive_set_string_nth_slow(void);
+void primitive_set_string_nth_fast(void);
--- /dev/null
+#include "master.h"
+
+/* push a new tuple on the stack */
+F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
+{
+ REGISTER_UNTAGGED(layout);
+ F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout));
+ UNREGISTER_UNTAGGED(layout);
+ tuple->layout = tag_array((F_ARRAY *)layout);
+ return tuple;
+}
+
+void primitive_tuple(void)
+{
+ F_TUPLE_LAYOUT *layout = untag_object(dpop());
+ F_FIXNUM size = untag_fixnum_fast(layout->size);
+
+ F_TUPLE *tuple = allot_tuple(layout);
+ F_FIXNUM i;
+ for(i = size - 1; i >= 0; i--)
+ put(AREF(tuple,i),F);
+
+ dpush(tag_tuple(tuple));
+}
+
+/* push a new tuple on the stack, filling its slots from the stack */
+void primitive_tuple_boa(void)
+{
+ F_TUPLE_LAYOUT *layout = untag_object(dpop());
+ F_FIXNUM size = untag_fixnum_fast(layout->size);
+ F_TUPLE *tuple = allot_tuple(layout);
+ memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
+ ds -= CELLS * size;
+ dpush(tag_tuple(tuple));
+}
--- /dev/null
+INLINE CELL tag_tuple(F_TUPLE *tuple)
+{
+ return RETAG(tuple,TUPLE_TYPE);
+}
+
+INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout)
+{
+ CELL size = untag_fixnum_fast(layout->size);
+ return sizeof(F_TUPLE) + size * CELLS;
+}
+
+INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot)
+{
+ return get(AREF(tuple,slot));
+}
+
+INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value)
+{
+ put(AREF(tuple,slot),value);
+ write_barrier((CELL)tuple);
+}
+
+void primitive_tuple(void);
+void primitive_tuple_boa(void);
+void primitive_tuple_layout(void);
+++ /dev/null
-#include "master.h"
-
-/* FFI calls this */
-void box_boolean(bool value)
-{
- dpush(value ? T : F);
-}
-
-/* FFI calls this */
-bool to_boolean(CELL value)
-{
- return value != F;
-}
-
-CELL clone_object(CELL object)
-{
- CELL size = object_size(object);
- if(size == 0)
- return object;
- else
- {
- REGISTER_ROOT(object);
- void *new_obj = allot_object(type_of(object),size);
- UNREGISTER_ROOT(object);
-
- CELL tag = TAG(object);
- memcpy(new_obj,(void*)UNTAG(object),size);
- return RETAG(new_obj,tag);
- }
-}
-
-void primitive_clone(void)
-{
- drepl(clone_object(dpeek()));
-}
-
-F_WORD *allot_word(CELL vocab, CELL name)
-{
- REGISTER_ROOT(vocab);
- REGISTER_ROOT(name);
- F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
- UNREGISTER_ROOT(name);
- UNREGISTER_ROOT(vocab);
-
- word->hashcode = tag_fixnum((rand() << 16) ^ rand());
- word->vocabulary = vocab;
- word->name = name;
- word->def = userenv[UNDEFINED_ENV];
- word->props = F;
- word->counter = tag_fixnum(0);
- word->optimizedp = F;
- word->subprimitive = F;
- word->profiling = NULL;
- word->code = NULL;
-
- REGISTER_UNTAGGED(word);
- jit_compile_word(word,word->def,true);
- UNREGISTER_UNTAGGED(word);
-
- REGISTER_UNTAGGED(word);
- update_word_xt(word);
- UNREGISTER_UNTAGGED(word);
-
- if(profiling_p)
- relocate_code_block(word->profiling);
-
- return word;
-}
-
-/* <word> ( name vocabulary -- word ) */
-void primitive_word(void)
-{
- CELL vocab = dpop();
- CELL name = dpop();
- dpush(tag_object(allot_word(vocab,name)));
-}
-
-/* word-xt ( word -- start end ) */
-void primitive_word_xt(void)
-{
- F_WORD *word = untag_word(dpop());
- F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code);
- dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK)));
- dpush(allot_cell((CELL)code + code->block.size));
-}
-
-void primitive_wrapper(void)
-{
- F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
- wrapper->object = dpeek();
- drepl(tag_object(wrapper));
-}
-
-/* Arrays */
-
-/* the array is full of undefined data, and must be correctly filled before the
-next GC. size is in cells */
-F_ARRAY *allot_array_internal(CELL type, CELL capacity)
-{
- F_ARRAY *array = allot_object(type,array_size(capacity));
- array->capacity = tag_fixnum(capacity);
- return array;
-}
-
-/* make a new array with an initial element */
-F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
-{
- int i;
- REGISTER_ROOT(fill);
- F_ARRAY* array = allot_array_internal(type, capacity);
- UNREGISTER_ROOT(fill);
- if(fill == 0)
- memset((void*)AREF(array,0),'\0',capacity * CELLS);
- else
- {
- /* No need for write barrier here. Either the object is in
- the nursery, or it was allocated directly in tenured space
- and the write barrier is already hit for us in that case. */
- for(i = 0; i < capacity; i++)
- put(AREF(array,i),fill);
- }
- return array;
-}
-
-/* push a new array on the stack */
-void primitive_array(void)
-{
- CELL initial = dpop();
- CELL size = unbox_array_size();
- dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
-}
-
-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);
- REGISTER_ROOT(v2);
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2);
- UNREGISTER_ROOT(v2);
- UNREGISTER_ROOT(v1);
- set_array_nth(a,0,v1);
- set_array_nth(a,1,v2);
- return tag_object(a);
-}
-
-CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
-{
- REGISTER_ROOT(v1);
- REGISTER_ROOT(v2);
- REGISTER_ROOT(v3);
- REGISTER_ROOT(v4);
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4);
- UNREGISTER_ROOT(v4);
- UNREGISTER_ROOT(v3);
- UNREGISTER_ROOT(v2);
- UNREGISTER_ROOT(v1);
- set_array_nth(a,0,v1);
- set_array_nth(a,1,v2);
- set_array_nth(a,2,v3);
- set_array_nth(a,3,v4);
- return tag_object(a);
-}
-
-F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity)
-{
- CELL to_copy = array_capacity(array);
- if(capacity < to_copy)
- to_copy = capacity;
-
- REGISTER_UNTAGGED(array);
- F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity);
- UNREGISTER_UNTAGGED(array);
-
- memcpy(new_array + 1,array + 1,to_copy * CELLS);
- memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS);
-
- return new_array;
-}
-
-void primitive_resize_array(void)
-{
- F_ARRAY* array = untag_array(dpop());
- CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_array(array,capacity)));
-}
-
-F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
-{
- REGISTER_ROOT(elt);
-
- if(*result_count == array_capacity(result))
- {
- result = reallot_array(result,*result_count * 2);
- }
-
- UNREGISTER_ROOT(elt);
- set_array_nth(result,*result_count,elt);
- (*result_count)++;
-
- return result;
-}
-
-F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
-{
- REGISTER_UNTAGGED(elts);
-
- CELL elts_size = array_capacity(elts);
- CELL new_size = *result_count + elts_size;
-
- if(new_size >= array_capacity(result))
- result = reallot_array(result,new_size * 2);
-
- UNREGISTER_UNTAGGED(elts);
-
- write_barrier((CELL)result);
-
- memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS);
-
- *result_count += elts_size;
-
- return result;
-}
-
-/* Byte arrays */
-
-/* must fill out array before next GC */
-F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
-{
- F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
- byte_array_size(size));
- array->capacity = tag_fixnum(size);
- return array;
-}
-
-/* size is in bytes this time */
-F_BYTE_ARRAY *allot_byte_array(CELL size)
-{
- F_BYTE_ARRAY *array = allot_byte_array_internal(size);
- memset(array + 1,0,size);
- return array;
-}
-
-/* push a new byte array on the stack */
-void primitive_byte_array(void)
-{
- CELL size = unbox_array_size();
- dpush(tag_object(allot_byte_array(size)));
-}
-
-void primitive_uninitialized_byte_array(void)
-{
- CELL size = unbox_array_size();
- dpush(tag_object(allot_byte_array_internal(size)));
-}
-
-F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
-{
- CELL to_copy = array_capacity(array);
- if(capacity < to_copy)
- to_copy = capacity;
-
- REGISTER_UNTAGGED(array);
- F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity);
- UNREGISTER_UNTAGGED(array);
-
- memcpy(new_array + 1,array + 1,to_copy);
-
- return new_array;
-}
-
-void primitive_resize_byte_array(void)
-{
- F_BYTE_ARRAY* array = untag_byte_array(dpop());
- CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_byte_array(array,capacity)));
-}
-
-F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
-{
- CELL new_size = *result_count + len;
-
- if(new_size >= byte_array_capacity(result))
- result = reallot_byte_array(result,new_size * 2);
-
- memcpy((void *)BREF(result,*result_count),elts,len);
-
- *result_count = new_size;
-
- return result;
-}
-
-/* Tuples */
-
-/* push a new tuple on the stack */
-F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
-{
- REGISTER_UNTAGGED(layout);
- F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout));
- UNREGISTER_UNTAGGED(layout);
- tuple->layout = tag_object(layout);
- return tuple;
-}
-
-void primitive_tuple(void)
-{
- F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = untag_fixnum_fast(layout->size);
-
- F_TUPLE *tuple = allot_tuple(layout);
- F_FIXNUM i;
- for(i = size - 1; i >= 0; i--)
- put(AREF(tuple,i),F);
-
- dpush(tag_tuple(tuple));
-}
-
-/* push a new tuple on the stack, filling its slots from the stack */
-void primitive_tuple_boa(void)
-{
- F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = untag_fixnum_fast(layout->size);
- F_TUPLE *tuple = allot_tuple(layout);
- memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
- ds -= CELLS * size;
- dpush(tag_tuple(tuple));
-}
-
-/* Strings */
-CELL string_nth(F_STRING* string, CELL index)
-{
- /* If high bit is set, the most significant 16 bits of the char
- come from the aux vector. The least significant bit of the
- corresponding aux vector entry is negated, so that we can
- XOR the two components together and get the original code point
- back. */
- CELL ch = bget(SREF(string,index));
- if((ch & 0x80) == 0)
- return ch;
- else
- {
- F_BYTE_ARRAY *aux = untag_object(string->aux);
- return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch;
- }
-}
-
-void set_string_nth_fast(F_STRING* string, CELL index, CELL ch)
-{
- bput(SREF(string,index),ch);
-}
-
-void set_string_nth_slow(F_STRING* string, CELL index, CELL ch)
-{
- F_BYTE_ARRAY *aux;
-
- bput(SREF(string,index),(ch & 0x7f) | 0x80);
-
- if(string->aux == F)
- {
- REGISTER_UNTAGGED(string);
- /* We don't need to pre-initialize the
- byte array with any data, since we
- only ever read from the aux vector
- if the most significant bit of a
- character is set. Initially all of
- the bits are clear. */
- aux = allot_byte_array_internal(
- untag_fixnum_fast(string->length)
- * sizeof(u16));
- UNREGISTER_UNTAGGED(string);
-
- write_barrier((CELL)string);
- string->aux = tag_object(aux);
- }
- else
- aux = untag_object(string->aux);
-
- cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1);
-}
-
-/* allocates memory */
-void set_string_nth(F_STRING* string, CELL index, CELL ch)
-{
- if(ch <= 0x7f)
- set_string_nth_fast(string,index,ch);
- else
- set_string_nth_slow(string,index,ch);
-}
-
-/* untagged */
-F_STRING* allot_string_internal(CELL capacity)
-{
- F_STRING *string = allot_object(STRING_TYPE,string_size(capacity));
-
- string->length = tag_fixnum(capacity);
- string->hashcode = F;
- string->aux = F;
-
- return string;
-}
-
-/* allocates memory */
-void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
-{
- if(fill <= 0x7f)
- memset((void *)SREF(string,start),fill,capacity - start);
- else
- {
- CELL i;
-
- for(i = start; i < capacity; i++)
- {
- REGISTER_UNTAGGED(string);
- set_string_nth(string,i,fill);
- UNREGISTER_UNTAGGED(string);
- }
- }
-}
-
-/* untagged */
-F_STRING *allot_string(CELL capacity, CELL fill)
-{
- F_STRING* string = allot_string_internal(capacity);
- REGISTER_UNTAGGED(string);
- fill_string(string,0,capacity,fill);
- UNREGISTER_UNTAGGED(string);
- return string;
-}
-
-void primitive_string(void)
-{
- CELL initial = to_cell(dpop());
- CELL length = unbox_array_size();
- dpush(tag_object(allot_string(length,initial)));
-}
-
-F_STRING* reallot_string(F_STRING* string, CELL capacity)
-{
- CELL to_copy = string_capacity(string);
- if(capacity < to_copy)
- to_copy = capacity;
-
- REGISTER_UNTAGGED(string);
- F_STRING *new_string = allot_string_internal(capacity);
- UNREGISTER_UNTAGGED(string);
-
- memcpy(new_string + 1,string + 1,to_copy);
-
- if(string->aux != F)
- {
- REGISTER_UNTAGGED(string);
- REGISTER_UNTAGGED(new_string);
- F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
- UNREGISTER_UNTAGGED(new_string);
- UNREGISTER_UNTAGGED(string);
-
- write_barrier((CELL)new_string);
- new_string->aux = tag_object(new_aux);
-
- F_BYTE_ARRAY *aux = untag_object(string->aux);
- memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
- }
-
- REGISTER_UNTAGGED(string);
- REGISTER_UNTAGGED(new_string);
- fill_string(new_string,to_copy,capacity,'\0');
- UNREGISTER_UNTAGGED(new_string);
- UNREGISTER_UNTAGGED(string);
-
- return new_string;
-}
-
-void primitive_resize_string(void)
-{
- F_STRING* string = untag_string(dpop());
- CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_string(string,capacity)));
-}
-
-/* Some ugly macros to prevent a 2x code duplication */
-
-#define MEMORY_TO_STRING(type,utype) \
- F_STRING *memory_to_##type##_string(const type *string, CELL length) \
- { \
- REGISTER_C_STRING(string); \
- F_STRING* s = allot_string_internal(length); \
- UNREGISTER_C_STRING(string); \
- CELL i; \
- for(i = 0; i < length; i++) \
- { \
- REGISTER_UNTAGGED(s); \
- set_string_nth(s,i,(utype)*string); \
- UNREGISTER_UNTAGGED(s); \
- string++; \
- } \
- return s; \
- } \
- F_STRING *from_##type##_string(const type *str) \
- { \
- CELL length = 0; \
- const type *scan = str; \
- while(*scan++) length++; \
- return memory_to_##type##_string(str,length); \
- } \
- void box_##type##_string(const type *str) \
- { \
- dpush(str ? tag_object(from_##type##_string(str)) : F); \
- }
-
-MEMORY_TO_STRING(char,u8)
-MEMORY_TO_STRING(u16,u16)
-MEMORY_TO_STRING(u32,u32)
-
-bool check_string(F_STRING *s, CELL max)
-{
- CELL capacity = string_capacity(s);
- CELL i;
- for(i = 0; i < capacity; i++)
- {
- CELL ch = string_nth(s,i);
- if(ch == '\0' || ch >= (1 << (max * 8)))
- return false;
- }
- return true;
-}
-
-F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
-{
- return allot_byte_array((capacity + 1) * size);
-}
-
-#define STRING_TO_MEMORY(type) \
- void type##_string_to_memory(F_STRING *s, type *string) \
- { \
- CELL i; \
- CELL capacity = string_capacity(s); \
- for(i = 0; i < capacity; i++) \
- string[i] = string_nth(s,i); \
- } \
- void primitive_##type##_string_to_memory(void) \
- { \
- type *address = unbox_alien(); \
- F_STRING *str = untag_string(dpop()); \
- type##_string_to_memory(str,address); \
- } \
- F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
- { \
- CELL capacity = string_capacity(s); \
- F_BYTE_ARRAY *_c_str; \
- if(check && !check_string(s,sizeof(type))) \
- general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
- REGISTER_UNTAGGED(s); \
- _c_str = allot_c_string(capacity,sizeof(type)); \
- UNREGISTER_UNTAGGED(s); \
- type *c_str = (type*)(_c_str + 1); \
- type##_string_to_memory(s,c_str); \
- c_str[capacity] = 0; \
- return _c_str; \
- } \
- type *to_##type##_string(F_STRING *s, bool check) \
- { \
- return (type*)(string_to_##type##_alien(s,check) + 1); \
- } \
- type *unbox_##type##_string(void) \
- { \
- return to_##type##_string(untag_string(dpop()),true); \
- }
-
-STRING_TO_MEMORY(char);
-STRING_TO_MEMORY(u16);
-
-void primitive_string_nth(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- dpush(tag_fixnum(string_nth(string,index)));
-}
-
-void primitive_set_string_nth(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- CELL value = untag_fixnum_fast(dpop());
- set_string_nth(string,index,value);
-}
-
-void primitive_set_string_nth_fast(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- CELL value = untag_fixnum_fast(dpop());
- set_string_nth_fast(string,index,value);
-}
-
-void primitive_set_string_nth_slow(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- CELL value = untag_fixnum_fast(dpop());
- set_string_nth_slow(string,index,value);
-}
+++ /dev/null
-/* Inline functions */
-INLINE CELL array_size(CELL size)
-{
- return sizeof(F_ARRAY) + size * CELLS;
-}
-
-INLINE CELL string_capacity(F_STRING* str)
-{
- return untag_fixnum_fast(str->length);
-}
-
-INLINE CELL string_size(CELL size)
-{
- return sizeof(F_STRING) + size;
-}
-
-DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
-
-INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array)
-{
- return untag_fixnum_fast(array->capacity);
-}
-
-INLINE CELL byte_array_size(CELL size)
-{
- return sizeof(F_BYTE_ARRAY) + size;
-}
-
-INLINE CELL callstack_size(CELL size)
-{
- return sizeof(F_CALLSTACK) + size;
-}
-
-DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
-
-INLINE CELL tag_boolean(CELL untagged)
-{
- return (untagged == false ? F : T);
-}
-
-DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
-
-#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
-#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
-
-INLINE CELL array_nth(F_ARRAY *array, CELL slot)
-{
- return get(AREF(array,slot));
-}
-
-INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value)
-{
- put(AREF(array,slot),value);
- write_barrier((CELL)array);
-}
-
-INLINE CELL array_capacity(F_ARRAY* array)
-{
- return array->capacity >> TAG_BITS;
-}
-
-#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index))
-#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index))
-
-INLINE F_STRING* untag_string(CELL tagged)
-{
- type_check(STRING_TYPE,tagged);
- return untag_object(tagged);
-}
-
-DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
-
-DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
-
-INLINE CELL tag_tuple(F_TUPLE *tuple)
-{
- return RETAG(tuple,TUPLE_TYPE);
-}
-
-INLINE F_TUPLE *untag_tuple(CELL object)
-{
- type_check(TUPLE_TYPE,object);
- return untag_object(object);
-}
-
-INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout)
-{
- CELL size = untag_fixnum_fast(layout->size);
- return sizeof(F_TUPLE) + size * CELLS;
-}
-
-INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot)
-{
- return get(AREF(tuple,slot));
-}
-
-INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value)
-{
- put(AREF(tuple,slot),value);
- write_barrier((CELL)tuple);
-}
-
-/* Prototypes */
-DLLEXPORT void box_boolean(bool value);
-DLLEXPORT bool to_boolean(CELL value);
-
-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);
-
-void primitive_array(void);
-void primitive_tuple(void);
-void primitive_tuple_boa(void);
-void primitive_tuple_layout(void);
-void primitive_byte_array(void);
-void primitive_uninitialized_byte_array(void);
-void primitive_clone(void);
-
-F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity);
-F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
-void primitive_resize_array(void);
-void primitive_resize_byte_array(void);
-
-F_STRING* allot_string_internal(CELL capacity);
-F_STRING* allot_string(CELL capacity, CELL fill);
-void primitive_uninitialized_string(void);
-void primitive_string(void);
-F_STRING *reallot_string(F_STRING *string, CELL capacity);
-void primitive_resize_string(void);
-
-F_STRING *memory_to_char_string(const char *string, CELL length);
-F_STRING *from_char_string(const char *c_string);
-DLLEXPORT void box_char_string(const char *c_string);
-
-F_STRING *memory_to_u16_string(const u16 *string, CELL length);
-F_STRING *from_u16_string(const u16 *c_string);
-DLLEXPORT void box_u16_string(const u16 *c_string);
-
-void char_string_to_memory(F_STRING *s, char *string);
-F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check);
-char* to_char_string(F_STRING *s, bool check);
-DLLEXPORT char *unbox_char_string(void);
-
-void u16_string_to_memory(F_STRING *s, u16 *string);
-F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
-u16* to_u16_string(F_STRING *s, bool check);
-DLLEXPORT u16 *unbox_u16_string(void);
-
-/* String getters and setters */
-CELL string_nth(F_STRING* string, CELL index);
-void set_string_nth(F_STRING* string, CELL index, CELL value);
-
-void primitive_string_nth(void);
-void primitive_set_string_nth_slow(void);
-void primitive_set_string_nth_fast(void);
-
-F_WORD *allot_word(CELL vocab, CELL name);
-void primitive_word(void);
-void primitive_word_xt(void);
-
-void primitive_wrapper(void);
-
-/* Macros to simulate a vector in C */
-#define GROWABLE_ARRAY(result) \
- CELL result##_count = 0; \
- CELL result = tag_object(allot_array(ARRAY_TYPE,100,F))
-
-F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count);
-
-#define GROWABLE_ARRAY_ADD(result,elt) \
- result = tag_object(growable_array_add(untag_object(result),elt,&result##_count))
-
-F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
-
-#define GROWABLE_ARRAY_APPEND(result,elts) \
- result = tag_object(growable_array_append(untag_object(result),elts,&result##_count))
-
-#define GROWABLE_ARRAY_TRIM(result) \
- result = tag_object(reallot_array(untag_object(result),result##_count))
-
-/* Macros to simulate a byte vector in C */
-#define GROWABLE_BYTE_ARRAY(result) \
- CELL result##_count = 0; \
- CELL result = tag_object(allot_byte_array(100))
-
-F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count);
-
-#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \
- result = tag_object(growable_byte_array_append(untag_object(result),elts,len,&result##_count))
-
-#define GROWABLE_BYTE_ARRAY_TRIM(result) \
- result = tag_object(reallot_byte_array(untag_object(result),result##_count))
--- /dev/null
+#include "master.h"
+
+F_WORD *allot_word(CELL vocab, CELL name)
+{
+ REGISTER_ROOT(vocab);
+ REGISTER_ROOT(name);
+ F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
+ UNREGISTER_ROOT(name);
+ UNREGISTER_ROOT(vocab);
+
+ word->hashcode = tag_fixnum((rand() << 16) ^ rand());
+ word->vocabulary = vocab;
+ word->name = name;
+ word->def = userenv[UNDEFINED_ENV];
+ word->props = F;
+ word->counter = tag_fixnum(0);
+ word->direct_entry_def = F;
+ word->subprimitive = F;
+ word->profiling = NULL;
+ word->code = NULL;
+
+ REGISTER_UNTAGGED(word);
+ jit_compile_word(word,word->def,true);
+ UNREGISTER_UNTAGGED(word);
+
+ REGISTER_UNTAGGED(word);
+ update_word_xt(word);
+ UNREGISTER_UNTAGGED(word);
+
+ if(profiling_p)
+ relocate_code_block(word->profiling);
+
+ return word;
+}
+
+/* <word> ( name vocabulary -- word ) */
+void primitive_word(void)
+{
+ CELL vocab = dpop();
+ CELL name = dpop();
+ dpush(tag_object(allot_word(vocab,name)));
+}
+
+/* word-xt ( word -- start end ) */
+void primitive_word_xt(void)
+{
+ F_WORD *word = untag_word(dpop());
+ F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code);
+ dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK)));
+ dpush(allot_cell((CELL)code + code->block.size));
+}
+
+/* Allocates memory */
+void update_word_xt(F_WORD *word)
+{
+ if(profiling_p)
+ {
+ if(!word->profiling)
+ {
+ REGISTER_UNTAGGED(word);
+ F_CODE_BLOCK *profiling = compile_profiling_stub(tag_object(word));
+ UNREGISTER_UNTAGGED(word);
+ word->profiling = profiling;
+ }
+
+ word->xt = (XT)(word->profiling + 1);
+ }
+ else
+ word->xt = (XT)(word->code + 1);
+}
+
+void primitive_optimized_p(void)
+{
+ drepl(tag_boolean(word_optimized_p(untag_word(dpeek()))));
+}
+
+void primitive_wrapper(void)
+{
+ F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
+ wrapper->object = dpeek();
+ drepl(tag_object(wrapper));
+}
--- /dev/null
+DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
+
+F_WORD *allot_word(CELL vocab, CELL name);
+
+void primitive_word(void);
+void primitive_word_xt(void);
+void update_word_xt(F_WORD *word);
+
+INLINE bool word_optimized_p(F_WORD *word)
+{
+ return word->code->block.type == WORD_TYPE;
+}
+
+void primitive_optimized_p(void);
+
+void primitive_wrapper(void);
projects / factor.git / commitdiff