Merge branch 'master' of git://factorcode.org/git/factor
commit
97cb0a5130
|
@ -9,11 +9,10 @@ VERSION = 0.92
|
||||||
|
|
||||||
BUNDLE = Factor.app
|
BUNDLE = Factor.app
|
||||||
LIBPATH = -L/usr/X11R6/lib
|
LIBPATH = -L/usr/X11R6/lib
|
||||||
CFLAGS = -Wall
|
CFLAGS = -Wall -Werror
|
||||||
FFI_TEST_CFLAGS = -fPIC
|
|
||||||
|
|
||||||
ifdef DEBUG
|
ifdef DEBUG
|
||||||
CFLAGS += -g
|
CFLAGS += -g -DFACTOR_DEBUG
|
||||||
else
|
else
|
||||||
CFLAGS += -O3
|
CFLAGS += -O3
|
||||||
endif
|
endif
|
||||||
|
@ -28,7 +27,10 @@ endif
|
||||||
|
|
||||||
DLL_OBJS = $(PLAF_DLL_OBJS) \
|
DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||||
vm/alien.o \
|
vm/alien.o \
|
||||||
|
vm/arrays.o \
|
||||||
vm/bignum.o \
|
vm/bignum.o \
|
||||||
|
vm/booleans.o \
|
||||||
|
vm/byte_arrays.o \
|
||||||
vm/callstack.o \
|
vm/callstack.o \
|
||||||
vm/code_block.o \
|
vm/code_block.o \
|
||||||
vm/code_gc.o \
|
vm/code_gc.o \
|
||||||
|
@ -36,17 +38,22 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||||
vm/data_gc.o \
|
vm/data_gc.o \
|
||||||
vm/data_heap.o \
|
vm/data_heap.o \
|
||||||
vm/debug.o \
|
vm/debug.o \
|
||||||
|
vm/dispatch.o \
|
||||||
vm/errors.o \
|
vm/errors.o \
|
||||||
vm/factor.o \
|
vm/factor.o \
|
||||||
vm/image.o \
|
vm/image.o \
|
||||||
|
vm/inline_cache.o \
|
||||||
vm/io.o \
|
vm/io.o \
|
||||||
|
vm/jit.o \
|
||||||
vm/math.o \
|
vm/math.o \
|
||||||
vm/primitives.o \
|
vm/primitives.o \
|
||||||
vm/profiler.o \
|
vm/profiler.o \
|
||||||
vm/quotations.o \
|
vm/quotations.o \
|
||||||
vm/run.o \
|
vm/run.o \
|
||||||
vm/types.o \
|
vm/strings.o \
|
||||||
vm/utilities.o
|
vm/tuples.o \
|
||||||
|
vm/utilities.o \
|
||||||
|
vm/words.o
|
||||||
|
|
||||||
EXE_OBJS = $(PLAF_EXE_OBJS)
|
EXE_OBJS = $(PLAF_EXE_OBJS)
|
||||||
|
|
||||||
|
@ -183,5 +190,5 @@ vm/ffi_test.o: vm/ffi_test.c
|
||||||
|
|
||||||
.m.o:
|
.m.o:
|
||||||
$(CC) -c $(CFLAGS) -o $@ $<
|
$(CC) -c $(CFLAGS) -o $@ $<
|
||||||
|
|
||||||
.PHONY: factor
|
.PHONY: factor
|
||||||
|
|
|
@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ;
|
||||||
] when* ;
|
] when* ;
|
||||||
|
|
||||||
: init-alarms ( -- )
|
: init-alarms ( -- )
|
||||||
alarms global [ cancel-alarms <min-heap> ] change-at
|
alarms [ cancel-alarms <min-heap> ] change-global
|
||||||
[ alarm-thread-loop t ] "Alarms" spawn-server
|
[ alarm-thread-loop t ] "Alarms" spawn-server
|
||||||
alarm-thread set-global ;
|
alarm-thread set-global ;
|
||||||
|
|
||||||
|
|
|
@ -15,7 +15,7 @@ HELP: libraries
|
||||||
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
|
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
|
||||||
|
|
||||||
HELP: library
|
HELP: library
|
||||||
{ $values { "name" "a string" } { "library" "a hashtable" } }
|
{ $values { "name" "a string" } { "library" assoc } }
|
||||||
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
|
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
|
||||||
{ $list
|
{ $list
|
||||||
{ { $snippet "name" } " - the full path of the C library binary" }
|
{ { $snippet "name" } " - the full path of the C library binary" }
|
||||||
|
|
|
@ -15,7 +15,7 @@ IN: alien.remote-control
|
||||||
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
|
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
|
||||||
|
|
||||||
: ?callback ( word -- alien )
|
: ?callback ( word -- alien )
|
||||||
dup optimized>> [ execute ] [ drop f ] if ; inline
|
dup optimized? [ execute ] [ drop f ] if ; inline
|
||||||
|
|
||||||
: init-remote-control ( -- )
|
: init-remote-control ( -- )
|
||||||
\ eval-callback ?callback 16 setenv
|
\ eval-callback ?callback 16 setenv
|
||||||
|
|
|
@ -5,7 +5,7 @@ sequences namespaces parser kernel kernel.private classes
|
||||||
classes.private arrays hashtables vectors classes.tuple sbufs
|
classes.private arrays hashtables vectors classes.tuple sbufs
|
||||||
hashtables.private sequences.private math classes.tuple.private
|
hashtables.private sequences.private math classes.tuple.private
|
||||||
growable namespaces.private assocs words command-line vocabs io
|
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.units math.order compiler.tree.builder
|
||||||
compiler.tree.optimizer compiler.cfg.optimizer ;
|
compiler.tree.optimizer compiler.cfg.optimizer ;
|
||||||
IN: bootstrap.compiler
|
IN: bootstrap.compiler
|
||||||
|
@ -23,10 +23,13 @@ IN: bootstrap.compiler
|
||||||
|
|
||||||
"cpu." cpu name>> append require
|
"cpu." cpu name>> append require
|
||||||
|
|
||||||
enable-compiler
|
enable-optimizer
|
||||||
|
|
||||||
|
! Push all tuple layouts to tenured space to improve method caching
|
||||||
|
gc
|
||||||
|
|
||||||
: compile-unoptimized ( words -- )
|
: compile-unoptimized ( words -- )
|
||||||
[ optimized>> not ] filter compile ;
|
[ optimized? not ] filter compile ;
|
||||||
|
|
||||||
nl
|
nl
|
||||||
"Compiling..." write flush
|
"Compiling..." write flush
|
||||||
|
|
|
@ -3,14 +3,13 @@
|
||||||
USING: alien arrays byte-arrays generic assocs hashtables assocs
|
USING: alien arrays byte-arrays generic assocs hashtables assocs
|
||||||
hashtables.private io io.binary io.files io.encodings.binary
|
hashtables.private io io.binary io.files io.encodings.binary
|
||||||
io.pathnames kernel kernel.private math namespaces make parser
|
io.pathnames kernel kernel.private math namespaces make parser
|
||||||
prettyprint sequences sequences.private strings sbufs
|
prettyprint sequences sequences.private strings sbufs vectors words
|
||||||
vectors words quotations assocs system layouts splitting
|
quotations assocs system layouts splitting grouping growable classes
|
||||||
grouping growable classes classes.builtin classes.tuple
|
classes.builtin classes.tuple classes.tuple.private vocabs
|
||||||
classes.tuple.private words.private vocabs
|
vocabs.loader source-files definitions debugger quotations.private
|
||||||
vocabs.loader source-files definitions debugger
|
sequences.private combinators math.order math.private accessors
|
||||||
quotations.private sequences.private combinators
|
slots.private generic.single.private compiler.units compiler.constants
|
||||||
math.order math.private accessors
|
fry ;
|
||||||
slots.private compiler.units fry ;
|
|
||||||
IN: bootstrap.image
|
IN: bootstrap.image
|
||||||
|
|
||||||
: arch ( os cpu -- arch )
|
: arch ( os cpu -- arch )
|
||||||
|
@ -94,13 +93,30 @@ CONSTANT: -1-offset 9
|
||||||
|
|
||||||
SYMBOL: sub-primitives
|
SYMBOL: sub-primitives
|
||||||
|
|
||||||
: make-jit ( quot rc rt offset -- quad )
|
SYMBOL: jit-define-rc
|
||||||
[ [ call( -- ) ] { } make ] 3dip 4array ;
|
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 ;
|
[ 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 ;
|
[ make-jit ] dip sub-primitives get set-at ;
|
||||||
|
|
||||||
! The image being constructed; a vector of word-size integers
|
! The image being constructed; a vector of word-size integers
|
||||||
|
@ -119,7 +135,6 @@ SYMBOL: bootstrap-global
|
||||||
SYMBOL: bootstrap-boot-quot
|
SYMBOL: bootstrap-boot-quot
|
||||||
|
|
||||||
! JIT parameters
|
! JIT parameters
|
||||||
SYMBOL: jit-code-format
|
|
||||||
SYMBOL: jit-prolog
|
SYMBOL: jit-prolog
|
||||||
SYMBOL: jit-primitive-word
|
SYMBOL: jit-primitive-word
|
||||||
SYMBOL: jit-primitive
|
SYMBOL: jit-primitive
|
||||||
|
@ -129,20 +144,36 @@ SYMBOL: jit-push-immediate
|
||||||
SYMBOL: jit-if-word
|
SYMBOL: jit-if-word
|
||||||
SYMBOL: jit-if-1
|
SYMBOL: jit-if-1
|
||||||
SYMBOL: jit-if-2
|
SYMBOL: jit-if-2
|
||||||
SYMBOL: jit-dispatch-word
|
|
||||||
SYMBOL: jit-dispatch
|
|
||||||
SYMBOL: jit-dip-word
|
SYMBOL: jit-dip-word
|
||||||
SYMBOL: jit-dip
|
SYMBOL: jit-dip
|
||||||
SYMBOL: jit-2dip-word
|
SYMBOL: jit-2dip-word
|
||||||
SYMBOL: jit-2dip
|
SYMBOL: jit-2dip
|
||||||
SYMBOL: jit-3dip-word
|
SYMBOL: jit-3dip-word
|
||||||
SYMBOL: jit-3dip
|
SYMBOL: jit-3dip
|
||||||
|
SYMBOL: jit-execute-word
|
||||||
|
SYMBOL: jit-execute-jump
|
||||||
|
SYMBOL: jit-execute-call
|
||||||
SYMBOL: jit-epilog
|
SYMBOL: jit-epilog
|
||||||
SYMBOL: jit-return
|
SYMBOL: jit-return
|
||||||
SYMBOL: jit-profiling
|
SYMBOL: jit-profiling
|
||||||
SYMBOL: jit-declare-word
|
|
||||||
SYMBOL: jit-save-stack
|
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
|
! Default definition for undefined words
|
||||||
SYMBOL: undefined-quot
|
SYMBOL: undefined-quot
|
||||||
|
|
||||||
|
@ -150,7 +181,6 @@ SYMBOL: undefined-quot
|
||||||
H{
|
H{
|
||||||
{ bootstrap-boot-quot 20 }
|
{ bootstrap-boot-quot 20 }
|
||||||
{ bootstrap-global 21 }
|
{ bootstrap-global 21 }
|
||||||
{ jit-code-format 22 }
|
|
||||||
{ jit-prolog 23 }
|
{ jit-prolog 23 }
|
||||||
{ jit-primitive-word 24 }
|
{ jit-primitive-word 24 }
|
||||||
{ jit-primitive 25 }
|
{ jit-primitive 25 }
|
||||||
|
@ -159,20 +189,32 @@ SYMBOL: undefined-quot
|
||||||
{ jit-if-word 28 }
|
{ jit-if-word 28 }
|
||||||
{ jit-if-1 29 }
|
{ jit-if-1 29 }
|
||||||
{ jit-if-2 30 }
|
{ jit-if-2 30 }
|
||||||
{ jit-dispatch-word 31 }
|
|
||||||
{ jit-dispatch 32 }
|
|
||||||
{ jit-epilog 33 }
|
{ jit-epilog 33 }
|
||||||
{ jit-return 34 }
|
{ jit-return 34 }
|
||||||
{ jit-profiling 35 }
|
{ jit-profiling 35 }
|
||||||
{ jit-push-immediate 36 }
|
{ jit-push-immediate 36 }
|
||||||
{ jit-declare-word 42 }
|
{ jit-save-stack 38 }
|
||||||
{ jit-save-stack 43 }
|
{ jit-dip-word 39 }
|
||||||
{ jit-dip-word 44 }
|
{ jit-dip 40 }
|
||||||
{ jit-dip 45 }
|
{ jit-2dip-word 41 }
|
||||||
{ jit-2dip-word 46 }
|
{ jit-2dip 42 }
|
||||||
{ jit-2dip 47 }
|
{ jit-3dip-word 43 }
|
||||||
{ jit-3dip-word 48 }
|
{ jit-3dip 44 }
|
||||||
{ jit-3dip 49 }
|
{ 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 }
|
{ undefined-quot 60 }
|
||||||
} ; inline
|
} ; inline
|
||||||
|
|
||||||
|
@ -205,8 +247,8 @@ SYMBOL: undefined-quot
|
||||||
|
|
||||||
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
||||||
|
|
||||||
: emit-object ( header tag quot -- addr )
|
: emit-object ( class quot -- addr )
|
||||||
swap here-as [ swap tag-fixnum emit call align-here ] dip ;
|
over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
|
||||||
inline
|
inline
|
||||||
|
|
||||||
! Write an object to the image.
|
! Write an object to the image.
|
||||||
|
@ -251,7 +293,7 @@ GENERIC: ' ( obj -- ptr )
|
||||||
|
|
||||||
M: bignum '
|
M: bignum '
|
||||||
[
|
[
|
||||||
bignum tag-number dup [ emit-bignum ] emit-object
|
bignum [ emit-bignum ] emit-object
|
||||||
] cache-object ;
|
] cache-object ;
|
||||||
|
|
||||||
! Fixnums
|
! Fixnums
|
||||||
|
@ -274,7 +316,7 @@ M: fake-bignum ' n>> tag-fixnum ;
|
||||||
|
|
||||||
M: float '
|
M: float '
|
||||||
[
|
[
|
||||||
float tag-number dup [
|
float [
|
||||||
align-here double>bits emit-64
|
align-here double>bits emit-64
|
||||||
] emit-object
|
] emit-object
|
||||||
] cache-object ;
|
] cache-object ;
|
||||||
|
@ -309,7 +351,7 @@ M: f '
|
||||||
[ vocabulary>> , ]
|
[ vocabulary>> , ]
|
||||||
[ def>> , ]
|
[ def>> , ]
|
||||||
[ props>> , ]
|
[ props>> , ]
|
||||||
[ drop f , ]
|
[ direct-entry-def>> , ] ! direct-entry-def
|
||||||
[ drop 0 , ] ! count
|
[ drop 0 , ] ! count
|
||||||
[ word-sub-primitive , ]
|
[ word-sub-primitive , ]
|
||||||
[ drop 0 , ] ! xt
|
[ drop 0 , ] ! xt
|
||||||
|
@ -318,8 +360,7 @@ M: f '
|
||||||
} cleave
|
} cleave
|
||||||
] { } make [ ' ] map
|
] { } make [ ' ] map
|
||||||
] bi
|
] bi
|
||||||
\ word type-number object tag-number
|
\ word [ emit-seq ] emit-object
|
||||||
[ emit-seq ] emit-object
|
|
||||||
] keep put-object ;
|
] keep put-object ;
|
||||||
|
|
||||||
: word-error ( word msg -- * )
|
: word-error ( word msg -- * )
|
||||||
|
@ -340,8 +381,7 @@ M: word ' ;
|
||||||
! Wrappers
|
! Wrappers
|
||||||
|
|
||||||
M: wrapper '
|
M: wrapper '
|
||||||
wrapped>> ' wrapper type-number object tag-number
|
wrapped>> ' wrapper [ emit ] emit-object ;
|
||||||
[ emit ] emit-object ;
|
|
||||||
|
|
||||||
! Strings
|
! Strings
|
||||||
: native> ( object -- object )
|
: native> ( object -- object )
|
||||||
|
@ -370,7 +410,7 @@ M: wrapper '
|
||||||
|
|
||||||
: emit-string ( string -- ptr )
|
: emit-string ( string -- ptr )
|
||||||
[ length ] [ extended-part ' ] [ ] tri
|
[ length ] [ extended-part ' ] [ ] tri
|
||||||
string type-number object tag-number [
|
string [
|
||||||
[ emit-fixnum ]
|
[ emit-fixnum ]
|
||||||
[ emit ]
|
[ emit ]
|
||||||
[ f ' emit ascii-part pad-bytes emit-bytes ]
|
[ f ' emit ascii-part pad-bytes emit-bytes ]
|
||||||
|
@ -387,12 +427,11 @@ M: string '
|
||||||
|
|
||||||
: emit-dummy-array ( obj type -- ptr )
|
: emit-dummy-array ( obj type -- ptr )
|
||||||
[ assert-empty ] [
|
[ assert-empty ] [
|
||||||
type-number object tag-number
|
|
||||||
[ 0 emit-fixnum ] emit-object
|
[ 0 emit-fixnum ] emit-object
|
||||||
] bi* ;
|
] bi* ;
|
||||||
|
|
||||||
M: byte-array '
|
M: byte-array '
|
||||||
byte-array type-number object tag-number [
|
byte-array [
|
||||||
dup length emit-fixnum
|
dup length emit-fixnum
|
||||||
pad-bytes emit-bytes
|
pad-bytes emit-bytes
|
||||||
] emit-object ;
|
] emit-object ;
|
||||||
|
@ -406,7 +445,7 @@ ERROR: tuple-removed class ;
|
||||||
: (emit-tuple) ( tuple -- pointer )
|
: (emit-tuple) ( tuple -- pointer )
|
||||||
[ tuple-slots ]
|
[ tuple-slots ]
|
||||||
[ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
|
[ 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 )
|
: emit-tuple ( tuple -- pointer )
|
||||||
dup class name>> "tombstone" =
|
dup class name>> "tombstone" =
|
||||||
|
@ -421,8 +460,7 @@ M: tombstone '
|
||||||
|
|
||||||
! Arrays
|
! Arrays
|
||||||
: emit-array ( array -- offset )
|
: emit-array ( array -- offset )
|
||||||
[ ' ] map array type-number object tag-number
|
[ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
|
||||||
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
|
|
||||||
|
|
||||||
M: array ' emit-array ;
|
M: array ' emit-array ;
|
||||||
|
|
||||||
|
@ -448,7 +486,7 @@ M: tuple-layout-array '
|
||||||
M: quotation '
|
M: quotation '
|
||||||
[
|
[
|
||||||
array>> '
|
array>> '
|
||||||
quotation type-number object tag-number [
|
quotation [
|
||||||
emit ! array
|
emit ! array
|
||||||
f ' emit ! compiled
|
f ' emit ! compiled
|
||||||
f ' emit ! cached-effect
|
f ' emit ! cached-effect
|
||||||
|
@ -480,15 +518,16 @@ M: quotation '
|
||||||
|
|
||||||
: emit-jit-data ( -- )
|
: emit-jit-data ( -- )
|
||||||
\ if jit-if-word set
|
\ if jit-if-word set
|
||||||
\ dispatch jit-dispatch-word set
|
|
||||||
\ do-primitive jit-primitive-word set
|
\ do-primitive jit-primitive-word set
|
||||||
\ declare jit-declare-word set
|
|
||||||
\ dip jit-dip-word set
|
\ dip jit-dip-word set
|
||||||
\ 2dip jit-2dip-word set
|
\ 2dip jit-2dip-word set
|
||||||
\ 3dip jit-3dip-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
|
[ undefined ] undefined-quot set
|
||||||
{
|
{
|
||||||
jit-code-format
|
|
||||||
jit-prolog
|
jit-prolog
|
||||||
jit-primitive-word
|
jit-primitive-word
|
||||||
jit-primitive
|
jit-primitive
|
||||||
|
@ -498,19 +537,31 @@ M: quotation '
|
||||||
jit-if-word
|
jit-if-word
|
||||||
jit-if-1
|
jit-if-1
|
||||||
jit-if-2
|
jit-if-2
|
||||||
jit-dispatch-word
|
|
||||||
jit-dispatch
|
|
||||||
jit-dip-word
|
jit-dip-word
|
||||||
jit-dip
|
jit-dip
|
||||||
jit-2dip-word
|
jit-2dip-word
|
||||||
jit-2dip
|
jit-2dip
|
||||||
jit-3dip-word
|
jit-3dip-word
|
||||||
jit-3dip
|
jit-3dip
|
||||||
|
jit-execute-word
|
||||||
|
jit-execute-jump
|
||||||
|
jit-execute-call
|
||||||
jit-epilog
|
jit-epilog
|
||||||
jit-return
|
jit-return
|
||||||
jit-profiling
|
jit-profiling
|
||||||
jit-declare-word
|
|
||||||
jit-save-stack
|
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
|
undefined-quot
|
||||||
} [ emit-userenv ] each ;
|
} [ emit-userenv ] each ;
|
||||||
|
|
||||||
|
|
|
@ -35,10 +35,6 @@ SYMBOL: bootstrap-time
|
||||||
"Core bootstrap completed in " write core-bootstrap-time get print-time
|
"Core bootstrap completed in " write core-bootstrap-time get print-time
|
||||||
"Bootstrap completed in " write 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
|
"Bootstrapping is complete." print
|
||||||
"Now, you can run Factor:" print
|
"Now, you can run Factor:" print
|
||||||
vm write " -i=" write "output-image" get print flush ;
|
vm write " -i=" write "output-image" get print flush ;
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
USING: calendar namespaces alien.c-types system windows
|
USING: calendar namespaces alien.c-types system
|
||||||
windows.kernel32 kernel math combinators ;
|
windows.kernel32 kernel math combinators windows.errors ;
|
||||||
IN: calendar.windows
|
IN: calendar.windows
|
||||||
|
|
||||||
M: windows gmt-offset ( -- hours minutes seconds )
|
M: windows gmt-offset ( -- hours minutes seconds )
|
||||||
|
|
|
@ -7,7 +7,7 @@ compiler.units lexer init ;
|
||||||
IN: cocoa
|
IN: cocoa
|
||||||
|
|
||||||
: (remember-send) ( selector variable -- )
|
: (remember-send) ( selector variable -- )
|
||||||
global [ dupd ?set-at ] change-at ;
|
[ dupd ?set-at ] change-global ;
|
||||||
|
|
||||||
SYMBOL: sent-messages
|
SYMBOL: sent-messages
|
||||||
|
|
||||||
|
|
|
@ -12,6 +12,9 @@ IN: cocoa.dialogs
|
||||||
dup 1 -> setResolvesAliases:
|
dup 1 -> setResolvesAliases:
|
||||||
dup 1 -> setAllowsMultipleSelection: ;
|
dup 1 -> setAllowsMultipleSelection: ;
|
||||||
|
|
||||||
|
: <NSDirPanel> ( -- panel ) <NSOpenPanel>
|
||||||
|
dup 1 -> setCanChooseDirectories: ;
|
||||||
|
|
||||||
: <NSSavePanel> ( -- panel )
|
: <NSSavePanel> ( -- panel )
|
||||||
NSSavePanel -> savePanel
|
NSSavePanel -> savePanel
|
||||||
dup 1 -> setCanChooseFiles:
|
dup 1 -> setCanChooseFiles:
|
||||||
|
@ -21,10 +24,12 @@ IN: cocoa.dialogs
|
||||||
CONSTANT: NSOKButton 1
|
CONSTANT: NSOKButton 1
|
||||||
CONSTANT: NSCancelButton 0
|
CONSTANT: NSCancelButton 0
|
||||||
|
|
||||||
: open-panel ( -- paths )
|
: (open-panel) ( panel -- paths )
|
||||||
<NSOpenPanel>
|
|
||||||
dup -> runModal NSOKButton =
|
dup -> runModal NSOKButton =
|
||||||
[ -> filenames CF>string-array ] [ drop f ] if ;
|
[ -> filenames CF>string-array ] [ drop f ] if ;
|
||||||
|
|
||||||
|
: open-panel ( -- paths ) <NSOpenPanel> (open-panel) ;
|
||||||
|
: open-dir-panel ( -- paths ) <NSDirPanel> (open-panel) ;
|
||||||
|
|
||||||
: split-path ( path -- dir file )
|
: split-path ( path -- dir file )
|
||||||
"/" split1-last [ <NSString> ] bi@ ;
|
"/" split1-last [ <NSString> ] bi@ ;
|
||||||
|
|
|
@ -1,5 +1,4 @@
|
||||||
USING: help.markup help.syntax parser vocabs.loader strings
|
USING: help.markup help.syntax parser vocabs.loader strings ;
|
||||||
command-line.private ;
|
|
||||||
IN: command-line
|
IN: command-line
|
||||||
|
|
||||||
HELP: run-bootstrap-init
|
HELP: run-bootstrap-init
|
||||||
|
@ -53,6 +52,7 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
|
||||||
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
|
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
|
||||||
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
|
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
|
||||||
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, 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" }
|
{ { $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)." ;
|
"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)." ;
|
||||||
|
|
|
@ -27,11 +27,11 @@ IN: compiler.cfg.intrinsics.allot
|
||||||
[ tuple ##set-slots ] [ ds-push drop ] 2bi
|
[ tuple ##set-slots ] [ ds-push drop ] 2bi
|
||||||
] [ drop emit-primitive ] if ;
|
] [ drop emit-primitive ] if ;
|
||||||
|
|
||||||
: store-length ( len reg -- )
|
: store-length ( len reg class -- )
|
||||||
[ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
|
[ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
|
||||||
|
|
||||||
: store-initial-element ( elt reg len -- )
|
:: store-initial-element ( len reg elt class -- )
|
||||||
[ 2 + object tag-number ##set-slot-imm ] with with each ;
|
len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
|
||||||
|
|
||||||
: expand-<array>? ( obj -- ? )
|
: expand-<array>? ( obj -- ? )
|
||||||
dup integer? [ 0 8 between? ] [ drop f ] if ;
|
dup integer? [ 0 8 between? ] [ drop f ] if ;
|
||||||
|
@ -42,8 +42,8 @@ IN: compiler.cfg.intrinsics.allot
|
||||||
[let | elt [ ds-pop ]
|
[let | elt [ ds-pop ]
|
||||||
reg [ len ^^allot-array ] |
|
reg [ len ^^allot-array ] |
|
||||||
ds-drop
|
ds-drop
|
||||||
len reg store-length
|
len reg array store-length
|
||||||
elt reg len store-initial-element
|
len reg elt array store-initial-element
|
||||||
reg ds-push
|
reg ds-push
|
||||||
]
|
]
|
||||||
] [ node emit-primitive ] if
|
] [ node emit-primitive ] if
|
||||||
|
@ -57,16 +57,16 @@ IN: compiler.cfg.intrinsics.allot
|
||||||
: emit-allot-byte-array ( len -- dst )
|
: emit-allot-byte-array ( len -- dst )
|
||||||
ds-drop
|
ds-drop
|
||||||
dup ^^allot-byte-array
|
dup ^^allot-byte-array
|
||||||
[ store-length ] [ ds-push ] [ ] tri ;
|
[ byte-array store-length ] [ ds-push ] [ ] tri ;
|
||||||
|
|
||||||
: emit-(byte-array) ( node -- )
|
: emit-(byte-array) ( node -- )
|
||||||
dup node-input-infos first literal>> dup expand-<byte-array>?
|
dup node-input-infos first literal>> dup expand-<byte-array>?
|
||||||
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
|
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
|
||||||
|
|
||||||
: emit-<byte-array> ( node -- )
|
:: emit-<byte-array> ( node -- )
|
||||||
dup node-input-infos first literal>> dup expand-<byte-array>? [
|
node node-input-infos first literal>> dup expand-<byte-array>? [
|
||||||
nip
|
:> len
|
||||||
[ 0 ^^load-literal ] dip
|
0 ^^load-literal :> elt
|
||||||
[ emit-allot-byte-array ] keep
|
len emit-allot-byte-array :> reg
|
||||||
bytes>cells store-initial-element
|
len reg elt byte-array store-initial-element
|
||||||
] [ drop emit-primitive ] if ;
|
] [ drop node emit-primitive ] if ;
|
||||||
|
|
|
@ -52,8 +52,6 @@ IN: compiler.cfg.intrinsics
|
||||||
arrays:<array>
|
arrays:<array>
|
||||||
byte-arrays:<byte-array>
|
byte-arrays:<byte-array>
|
||||||
byte-arrays:(byte-array)
|
byte-arrays:(byte-array)
|
||||||
math.private:<complex>
|
|
||||||
math.private:<ratio>
|
|
||||||
kernel:<wrapper>
|
kernel:<wrapper>
|
||||||
alien.accessors:alien-unsigned-1
|
alien.accessors:alien-unsigned-1
|
||||||
alien.accessors:set-alien-unsigned-1
|
alien.accessors:set-alien-unsigned-1
|
||||||
|
@ -140,8 +138,6 @@ IN: compiler.cfg.intrinsics
|
||||||
{ \ arrays:<array> [ emit-<array> iterate-next ] }
|
{ \ arrays:<array> [ emit-<array> iterate-next ] }
|
||||||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
|
{ \ byte-arrays:<byte-array> [ emit-<byte-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 ] }
|
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
|
||||||
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter 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 ] }
|
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
|
||||||
|
|
|
@ -92,7 +92,7 @@ sequences ;
|
||||||
T{ ##load-reference f V int-regs 1 + }
|
T{ ##load-reference f V int-regs 1 + }
|
||||||
T{ ##peek f V int-regs 2 D 0 }
|
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 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 }
|
T{ ##replace f V int-regs 6 D 0 }
|
||||||
} value-numbering trim-temps
|
} value-numbering trim-temps
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -110,7 +110,7 @@ sequences ;
|
||||||
T{ ##load-reference f V int-regs 1 + }
|
T{ ##load-reference f V int-regs 1 + }
|
||||||
T{ ##peek f V int-regs 2 D 0 }
|
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 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 }
|
T{ ##replace f V int-regs 6 D 0 }
|
||||||
} value-numbering trim-temps
|
} value-numbering trim-temps
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -132,7 +132,7 @@ sequences ;
|
||||||
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
|
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{ ##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-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 }
|
T{ ##replace f V int-regs 14 D 0 }
|
||||||
} value-numbering trim-temps
|
} value-numbering trim-temps
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -149,6 +149,6 @@ sequences ;
|
||||||
T{ ##peek f V int-regs 29 D -1 }
|
T{ ##peek f V int-regs 29 D -1 }
|
||||||
T{ ##peek f V int-regs 30 D -2 }
|
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 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
|
} value-numbering trim-temps
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -44,7 +44,7 @@ SYMBOL: calls
|
||||||
|
|
||||||
SYMBOL: compiling-word
|
SYMBOL: compiling-word
|
||||||
|
|
||||||
: compiled-stack-traces? ( -- ? ) 59 getenv ;
|
: compiled-stack-traces? ( -- ? ) 67 getenv ;
|
||||||
|
|
||||||
! Mapping _label IDs to label instances
|
! Mapping _label IDs to label instances
|
||||||
SYMBOL: labels
|
SYMBOL: labels
|
||||||
|
|
|
@ -3,15 +3,13 @@
|
||||||
USING: arrays byte-arrays byte-vectors generic assocs hashtables
|
USING: arrays byte-arrays byte-vectors generic assocs hashtables
|
||||||
io.binary kernel kernel.private math namespaces make sequences
|
io.binary kernel kernel.private math namespaces make sequences
|
||||||
words quotations strings alien.accessors alien.strings layouts
|
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 ;
|
accessors growable cpu.architecture compiler.constants ;
|
||||||
IN: compiler.codegen.fixup
|
IN: compiler.codegen.fixup
|
||||||
|
|
||||||
GENERIC: fixup* ( obj -- )
|
GENERIC: fixup* ( obj -- )
|
||||||
|
|
||||||
: code-format ( -- n ) 22 getenv ;
|
: compiled-offset ( -- n ) building get length ;
|
||||||
|
|
||||||
: compiled-offset ( -- n ) building get length code-format * ;
|
|
||||||
|
|
||||||
SYMBOL: relocation-table
|
SYMBOL: relocation-table
|
||||||
SYMBOL: label-table
|
SYMBOL: label-table
|
||||||
|
@ -25,7 +23,7 @@ TUPLE: label-fixup label class ;
|
||||||
M: label-fixup fixup*
|
M: label-fixup fixup*
|
||||||
dup class>> rc-absolute?
|
dup class>> rc-absolute?
|
||||||
[ "Absolute labels not supported" throw ] when
|
[ "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 ;
|
3array label-table get push ;
|
||||||
|
|
||||||
TUPLE: rel-fixup class type ;
|
TUPLE: rel-fixup class type ;
|
||||||
|
@ -58,6 +56,9 @@ SYMBOL: literal-table
|
||||||
: rel-word ( word class -- )
|
: rel-word ( word class -- )
|
||||||
[ add-literal ] dip rt-xt rel-fixup ;
|
[ add-literal ] dip rt-xt rel-fixup ;
|
||||||
|
|
||||||
|
: rel-word-direct ( word class -- )
|
||||||
|
[ add-literal ] dip rt-xt-direct rel-fixup ;
|
||||||
|
|
||||||
: rel-primitive ( word class -- )
|
: rel-primitive ( word class -- )
|
||||||
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
|
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
|
||||||
|
|
||||||
|
@ -88,4 +89,4 @@ SYMBOL: literal-table
|
||||||
literal-table get >array
|
literal-table get >array
|
||||||
relocation-table get >byte-array
|
relocation-table get >byte-array
|
||||||
label-table get resolve-labels
|
label-table get resolve-labels
|
||||||
] { } make 4array ;
|
] B{ } make 4array ;
|
||||||
|
|
|
@ -1,19 +1,19 @@
|
||||||
USING: assocs compiler.cfg.builder compiler.cfg.optimizer
|
USING: assocs compiler.cfg.builder compiler.cfg.optimizer
|
||||||
compiler.errors compiler.tree.builder compiler.tree.optimizer
|
compiler.errors compiler.tree.builder compiler.tree.optimizer
|
||||||
compiler.units help.markup help.syntax io parser quotations
|
compiler.units help.markup help.syntax io parser quotations
|
||||||
sequences words words.private ;
|
sequences words ;
|
||||||
IN: compiler
|
IN: compiler
|
||||||
|
|
||||||
HELP: enable-compiler
|
HELP: enable-optimizer
|
||||||
{ $description "Enables the optimizing compiler." } ;
|
{ $description "Enables the optimizing compiler." } ;
|
||||||
|
|
||||||
HELP: disable-compiler
|
HELP: disable-optimizer
|
||||||
{ $description "Disable the optimizing compiler." } ;
|
{ $description "Disable the optimizing compiler." } ;
|
||||||
|
|
||||||
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
||||||
"Normally, new word definitions are recompiled automatically. This can be changed:"
|
"Normally, new word definitions are recompiled automatically. This can be changed:"
|
||||||
{ $subsection disable-compiler }
|
{ $subsection disable-optimizer }
|
||||||
{ $subsection enable-compiler }
|
{ $subsection enable-optimizer }
|
||||||
"Removing a word's optimized definition:"
|
"Removing a word's optimized definition:"
|
||||||
{ $subsection decompile }
|
{ $subsection decompile }
|
||||||
"Compiling a single quotation:"
|
"Compiling a single quotation:"
|
||||||
|
|
|
@ -2,19 +2,20 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel namespaces arrays sequences io words fry
|
USING: accessors kernel namespaces arrays sequences io words fry
|
||||||
continuations vocabs assocs dlists definitions math graphs generic
|
continuations vocabs assocs dlists definitions math graphs generic
|
||||||
combinators deques search-deques macros io source-files.errors
|
generic.single combinators deques search-deques macros io
|
||||||
stack-checker stack-checker.state stack-checker.inlining
|
source-files.errors stack-checker stack-checker.state
|
||||||
stack-checker.errors combinators.short-circuit compiler.errors
|
stack-checker.inlining stack-checker.errors combinators.short-circuit
|
||||||
compiler.units compiler.tree.builder compiler.tree.optimizer
|
compiler.errors compiler.units compiler.tree.builder
|
||||||
compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization
|
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
||||||
compiler.cfg.two-operand compiler.cfg.linear-scan
|
compiler.cfg.linearization compiler.cfg.two-operand
|
||||||
compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
|
compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
|
||||||
|
compiler.utilities ;
|
||||||
IN: compiler
|
IN: compiler
|
||||||
|
|
||||||
SYMBOL: compile-queue
|
SYMBOL: compile-queue
|
||||||
SYMBOL: compiled
|
SYMBOL: compiled
|
||||||
|
|
||||||
: queue-compile? ( word -- ? )
|
: compile? ( word -- ? )
|
||||||
#! Don't attempt to compile certain words.
|
#! Don't attempt to compile certain words.
|
||||||
{
|
{
|
||||||
[ "forgotten" word-prop ]
|
[ "forgotten" word-prop ]
|
||||||
|
@ -24,7 +25,7 @@ SYMBOL: compiled
|
||||||
} 1|| not ;
|
} 1|| not ;
|
||||||
|
|
||||||
: queue-compile ( word -- )
|
: 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 -- ? )
|
: recompile-callers? ( word -- ? )
|
||||||
changed-effects get key? ;
|
changed-effects get key? ;
|
||||||
|
@ -41,6 +42,14 @@ SYMBOL: compiled
|
||||||
H{ } clone generic-dependencies set
|
H{ } clone generic-dependencies set
|
||||||
clear-compiler-error ;
|
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-error? ( word error -- ? )
|
||||||
#! Ignore some errors on inline combinators, macros, and special
|
#! Ignore some errors on inline combinators, macros, and special
|
||||||
#! words such as 'call'.
|
#! words such as 'call'.
|
||||||
|
@ -48,8 +57,8 @@ SYMBOL: compiled
|
||||||
{
|
{
|
||||||
[ macro? ]
|
[ macro? ]
|
||||||
[ inline? ]
|
[ inline? ]
|
||||||
|
[ no-compile? ]
|
||||||
[ "special" word-prop ]
|
[ "special" word-prop ]
|
||||||
[ "no-compile" word-prop ]
|
|
||||||
} 1||
|
} 1||
|
||||||
] [
|
] [
|
||||||
{
|
{
|
||||||
|
@ -80,32 +89,46 @@ SYMBOL: compiled
|
||||||
: not-compiled-def ( word error -- def )
|
: not-compiled-def ( word error -- def )
|
||||||
'[ _ _ not-compiled ] [ ] like ;
|
'[ _ _ 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 -- * )
|
: deoptimize ( word error -- * )
|
||||||
#! If the error is ignorable, compile the word with the
|
#! If the error is ignorable, compile the word with the
|
||||||
#! non-optimizing compiler, using its definition. Otherwise,
|
#! non-optimizing compiler, using its definition. Otherwise,
|
||||||
#! if the compiler error is not ignorable, use a dummy
|
#! if the compiler error is not ignorable, use a dummy
|
||||||
#! definition from 'not-compiled-def' which throws an error.
|
#! definition from 'not-compiled-def' which throws an error.
|
||||||
2dup ignore-error? [
|
{
|
||||||
drop
|
{ [ dup inference-error? not ] [ rethrow ] }
|
||||||
[ dup def>> deoptimize-with ]
|
{ [ 2dup ignore-error? ] [ ignore-error ] }
|
||||||
[ clear-compiler-error ]
|
[ remember-error ]
|
||||||
bi
|
} cond ;
|
||||||
] [
|
|
||||||
[ swap <compiler-error> compiler-error ]
|
: optimize? ( word -- ? )
|
||||||
[ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
|
{
|
||||||
2bi
|
[ predicate-engine-word? ]
|
||||||
] if ;
|
[ contains-breakpoints? ]
|
||||||
|
[ single-generic? ]
|
||||||
|
} 1|| not ;
|
||||||
|
|
||||||
: frontend ( word -- nodes )
|
: frontend ( word -- nodes )
|
||||||
#! If the word contains breakpoints, don't optimize it, since
|
#! If the word contains breakpoints, don't optimize it, since
|
||||||
#! the walker does not support this.
|
#! the walker does not support this.
|
||||||
dup contains-breakpoints? [ dup def>> deoptimize-with ] [
|
dup optimize?
|
||||||
[ build-tree ] [ deoptimize ] recover optimize-tree
|
[ [ build-tree ] [ deoptimize ] recover optimize-tree ]
|
||||||
] if ;
|
[ dup def>> deoptimize-with ]
|
||||||
|
if ;
|
||||||
|
|
||||||
: compile-dependency ( word -- )
|
: compile-dependency ( word -- )
|
||||||
#! If a word calls an unoptimized word, try to compile the callee.
|
#! 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.
|
! Only switch this off for debugging.
|
||||||
SYMBOL: compile-dependencies?
|
SYMBOL: compile-dependencies?
|
||||||
|
@ -161,15 +184,21 @@ M: optimizing-compiler recompile ( words -- alist )
|
||||||
[
|
[
|
||||||
<hashed-dlist> compile-queue set
|
<hashed-dlist> compile-queue set
|
||||||
H{ } clone compiled set
|
H{ } clone compiled set
|
||||||
[ queue-compile ] each
|
[
|
||||||
|
[ queue-compile ]
|
||||||
|
[ subwords [ compile-dependency ] each ] bi
|
||||||
|
] each
|
||||||
compile-queue get compile-loop
|
compile-queue get compile-loop
|
||||||
compiled get >alist
|
compiled get >alist
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
: enable-compiler ( -- )
|
: with-optimizer ( quot -- )
|
||||||
|
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
|
||||||
|
|
||||||
|
: enable-optimizer ( -- )
|
||||||
optimizing-compiler compiler-impl set-global ;
|
optimizing-compiler compiler-impl set-global ;
|
||||||
|
|
||||||
: disable-compiler ( -- )
|
: disable-optimizer ( -- )
|
||||||
f compiler-impl set-global ;
|
f compiler-impl set-global ;
|
||||||
|
|
||||||
: recompile-all ( -- )
|
: recompile-all ( -- )
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: compiler.constants
|
||||||
|
|
||||||
! These constants must match vm/memory.h
|
! These constants must match vm/memory.h
|
||||||
|
@ -11,18 +12,17 @@ CONSTANT: deck-bits 18
|
||||||
! These constants must match vm/layouts.h
|
! These constants must match vm/layouts.h
|
||||||
: header-offset ( -- n ) object tag-number neg ; inline
|
: header-offset ( -- n ) object tag-number neg ; inline
|
||||||
: float-offset ( -- n ) 8 float tag-number - ; 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
|
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
|
||||||
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
|
: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
|
||||||
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
|
||||||
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
|
: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
|
||||||
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
|
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
|
||||||
: tuple-class-offset ( -- n ) bootstrap-cell tuple 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 \ word tag-number - ; inline
|
||||||
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
|
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
|
||||||
: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
|
: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
|
||||||
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
|
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
|
||||||
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
|
||||||
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
|
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
|
||||||
|
|
||||||
! Relocation classes
|
! Relocation classes
|
||||||
|
@ -41,10 +41,12 @@ CONSTANT: rt-primitive 0
|
||||||
CONSTANT: rt-dlsym 1
|
CONSTANT: rt-dlsym 1
|
||||||
CONSTANT: rt-dispatch 2
|
CONSTANT: rt-dispatch 2
|
||||||
CONSTANT: rt-xt 3
|
CONSTANT: rt-xt 3
|
||||||
CONSTANT: rt-here 4
|
CONSTANT: rt-xt-direct 4
|
||||||
CONSTANT: rt-this 5
|
CONSTANT: rt-here 5
|
||||||
CONSTANT: rt-immediate 6
|
CONSTANT: rt-this 6
|
||||||
CONSTANT: rt-stack-chain 7
|
CONSTANT: rt-immediate 7
|
||||||
|
CONSTANT: rt-stack-chain 8
|
||||||
|
CONSTANT: rt-untagged 9
|
||||||
|
|
||||||
: rc-absolute? ( n -- ? )
|
: rc-absolute? ( n -- ? )
|
||||||
[ rc-absolute-ppc-2/2 = ]
|
[ rc-absolute-ppc-2/2 = ]
|
||||||
|
|
|
@ -0,0 +1,14 @@
|
||||||
|
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
|
||||||
|
|
||||||
|
: call-test ( q -- ) call( -- ) ;
|
||||||
|
|
||||||
|
[ ] [ [ ] call-test ] unit-test
|
||||||
|
[ ] [ f [ drop ] curry call-test ] unit-test
|
||||||
|
[ ] [ [ ] [ ] compose call-test ] unit-test
|
||||||
|
[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
|
|
@ -26,7 +26,7 @@ IN: compiler.tests.codegen
|
||||||
|
|
||||||
[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
|
[ 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 ]
|
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
|
@ -37,7 +37,7 @@ unit-test
|
||||||
|
|
||||||
: foo ( -- ) ;
|
: foo ( -- ) ;
|
||||||
|
|
||||||
[ 5 5 ]
|
[ 3 3 ]
|
||||||
[ 1.2 [ tag [ foo ] keep ] compile-call ]
|
[ 1.2 [ tag [ foo ] keep ] compile-call ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
|
@ -211,7 +211,7 @@ TUPLE: my-tuple ;
|
||||||
{ tuple vector } 3 slot { word } declare
|
{ tuple vector } 3 slot { word } declare
|
||||||
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
|
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
|
[ vector ] [ dispatch-alignment-regression ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -9,7 +9,7 @@ math.private tools.test math.floats.private ;
|
||||||
|
|
||||||
[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] 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 float+ ] compile-call ] unit-test
|
||||||
[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test
|
[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test
|
||||||
|
|
|
@ -0,0 +1,11 @@
|
||||||
|
IN: compiler.tests.generic
|
||||||
|
USING: tools.test math kernel compiler.units definitions ;
|
||||||
|
|
||||||
|
GENERIC: bad ( -- )
|
||||||
|
M: integer bad ;
|
||||||
|
M: object bad ;
|
||||||
|
|
||||||
|
[ 0 bad ] must-fail
|
||||||
|
[ "" bad ] must-fail
|
||||||
|
|
||||||
|
[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
|
|
@ -342,12 +342,12 @@ cell 8 = [
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 1 2 ] [
|
[ 1 2 ] [
|
||||||
1 2 [ <complex> ] compile-call
|
1 2 [ complex boa ] compile-call
|
||||||
dup real-part swap imaginary-part
|
dup real-part swap imaginary-part
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 1 2 ] [
|
[ 1 2 ] [
|
||||||
1 2 [ <ratio> ] compile-call dup numerator swap denominator
|
1 2 [ ratio boa ] compile-call dup numerator swap denominator
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
|
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
|
||||||
|
|
|
@ -4,13 +4,13 @@ sbufs strings tools.test vectors words sequences.private
|
||||||
quotations classes classes.algebra classes.tuple.private
|
quotations classes classes.algebra classes.tuple.private
|
||||||
continuations growable namespaces hints alien.accessors
|
continuations growable namespaces hints alien.accessors
|
||||||
compiler.tree.builder compiler.tree.optimizer sequences.deep
|
compiler.tree.builder compiler.tree.optimizer sequences.deep
|
||||||
compiler ;
|
compiler definitions ;
|
||||||
IN: compiler.tests.optimizer
|
IN: compiler.tests.optimizer
|
||||||
|
|
||||||
GENERIC: xyz ( obj -- obj )
|
GENERIC: xyz ( obj -- obj )
|
||||||
M: array xyz xyz ;
|
M: array xyz xyz ;
|
||||||
|
|
||||||
[ t ] [ \ xyz optimized>> ] unit-test
|
[ t ] [ M\ array xyz optimized? ] unit-test
|
||||||
|
|
||||||
! Test predicate inlining
|
! Test predicate inlining
|
||||||
: pred-test-1 ( a -- b c )
|
: pred-test-1 ( a -- b c )
|
||||||
|
@ -95,7 +95,7 @@ TUPLE: pred-test ;
|
||||||
! regression
|
! regression
|
||||||
GENERIC: void-generic ( obj -- * )
|
GENERIC: void-generic ( obj -- * )
|
||||||
: breakage ( -- * ) "hi" void-generic ;
|
: breakage ( -- * ) "hi" void-generic ;
|
||||||
[ t ] [ \ breakage optimized>> ] unit-test
|
[ t ] [ \ breakage optimized? ] unit-test
|
||||||
[ breakage ] must-fail
|
[ breakage ] must-fail
|
||||||
|
|
||||||
! regression
|
! regression
|
||||||
|
@ -120,7 +120,7 @@ GENERIC: void-generic ( obj -- * )
|
||||||
! compiling <tuple> with a non-literal class failed
|
! compiling <tuple> with a non-literal class failed
|
||||||
: <tuple>-regression ( class -- tuple ) <tuple> ;
|
: <tuple>-regression ( class -- tuple ) <tuple> ;
|
||||||
|
|
||||||
[ t ] [ \ <tuple>-regression optimized>> ] unit-test
|
[ t ] [ \ <tuple>-regression optimized? ] unit-test
|
||||||
|
|
||||||
GENERIC: foozul ( a -- b )
|
GENERIC: foozul ( a -- b )
|
||||||
M: reversed foozul ;
|
M: reversed foozul ;
|
||||||
|
@ -229,7 +229,7 @@ USE: binary-search.private
|
||||||
: node-successor-f-bug ( x -- * )
|
: node-successor-f-bug ( x -- * )
|
||||||
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
|
[ 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
|
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
|
||||||
|
|
||||||
|
@ -243,7 +243,7 @@ USE: binary-search.private
|
||||||
] if
|
] if
|
||||||
] 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
|
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
|
||||||
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
|
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
|
||||||
|
|
||||||
|
@ -274,7 +274,7 @@ HINTS: recursive-inline-hang array ;
|
||||||
: recursive-inline-hang-1 ( -- a )
|
: recursive-inline-hang-1 ( -- a )
|
||||||
{ } recursive-inline-hang ;
|
{ } recursive-inline-hang ;
|
||||||
|
|
||||||
[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
|
[ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test
|
||||||
|
|
||||||
DEFER: recursive-inline-hang-3
|
DEFER: recursive-inline-hang-3
|
||||||
|
|
||||||
|
@ -325,7 +325,7 @@ PREDICATE: list < improper-list
|
||||||
dup "a" get { array-capacity } declare >=
|
dup "a" get { array-capacity } declare >=
|
||||||
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
|
[ 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
|
[ ] [ 1 "a" set 2 "b" set ] unit-test
|
||||||
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
|
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
|
||||||
|
@ -384,3 +384,9 @@ DEFER: loop-bbb
|
||||||
1 >bignum 2 >bignum
|
1 >bignum 2 >bignum
|
||||||
[ { bignum integer } declare [ shift ] keep 1+ ] compile-call
|
[ { bignum integer } declare [ shift ] keep 1+ ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
: broken-declaration ( -- ) \ + declare ;
|
||||||
|
|
||||||
|
[ f ] [ \ broken-declaration optimized? ] unit-test
|
||||||
|
|
||||||
|
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
|
|
@ -4,7 +4,7 @@
|
||||||
! optimization, which would batch generic word updates at the
|
! optimization, which would batch generic word updates at the
|
||||||
! end of a compilation unit.
|
! end of a compilation unit.
|
||||||
|
|
||||||
USING: kernel accessors peg.ebnf ;
|
USING: kernel accessors peg.ebnf words ;
|
||||||
IN: compiler.tests.peg-regression
|
IN: compiler.tests.peg-regression
|
||||||
|
|
||||||
TUPLE: pipeline-expr background ;
|
TUPLE: pipeline-expr background ;
|
||||||
|
@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
|
||||||
|
|
||||||
USE: tools.test
|
USE: tools.test
|
||||||
|
|
||||||
[ t ] [ \ expr optimized>> ] unit-test
|
[ t ] [ \ expr optimized? ] unit-test
|
||||||
[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test
|
[ t ] [ \ ast>pipeline-expr optimized? ] unit-test
|
||||||
|
|
|
@ -0,0 +1,14 @@
|
||||||
|
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
|
|
@ -1,8 +1,8 @@
|
||||||
USING: compiler.units definitions tools.test sequences ;
|
USING: compiler.units definitions tools.test sequences ;
|
||||||
IN: compiler.tests.redefine14
|
IN: compiler.tests.redefine14
|
||||||
|
|
||||||
! TUPLE: bad ;
|
TUPLE: bad ;
|
||||||
!
|
|
||||||
! M: bad length 1 2 3 ;
|
M: bad length 1 2 3 ;
|
||||||
!
|
|
||||||
! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test
|
[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test
|
||||||
|
|
|
@ -0,0 +1,49 @@
|
||||||
|
IN: compiler.tests.redefine17
|
||||||
|
USING: tools.test classes.mixin compiler.units arrays kernel.private
|
||||||
|
strings sequences vocabs definitions kernel ;
|
||||||
|
|
||||||
|
<< "compiler.tests.redefine17" words forget-all >>
|
||||||
|
|
||||||
|
GENERIC: bong ( a -- b )
|
||||||
|
|
||||||
|
M: array bong ;
|
||||||
|
|
||||||
|
M: string bong length ;
|
||||||
|
|
||||||
|
MIXIN: mixin
|
||||||
|
|
||||||
|
INSTANCE: array mixin
|
||||||
|
|
||||||
|
: blah ( a -- b ) { mixin } declare bong ;
|
||||||
|
|
||||||
|
[ { } ] [ { } blah ] unit-test
|
||||||
|
|
||||||
|
[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||||
|
|
||||||
|
[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test
|
||||||
|
|
||||||
|
[ 0 ] [ "" blah ] unit-test
|
||||||
|
|
||||||
|
MIXIN: mixin1
|
||||||
|
|
||||||
|
INSTANCE: string mixin1
|
||||||
|
|
||||||
|
MIXIN: mixin2
|
||||||
|
|
||||||
|
GENERIC: billy ( a -- b )
|
||||||
|
|
||||||
|
M: mixin2 billy ;
|
||||||
|
|
||||||
|
M: array billy drop "BILLY" ;
|
||||||
|
|
||||||
|
INSTANCE: string mixin2
|
||||||
|
|
||||||
|
: bully ( a -- b ) { mixin1 } declare billy ;
|
||||||
|
|
||||||
|
[ "" ] [ "" bully ] unit-test
|
||||||
|
|
||||||
|
[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||||
|
|
||||||
|
[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test
|
||||||
|
|
||||||
|
[ "BILLY" ] [ { } bully ] unit-test
|
|
@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
|
||||||
: sheeple-test ( -- string ) { } sheeple ;
|
: sheeple-test ( -- string ) { } sheeple ;
|
||||||
|
|
||||||
[ "sheeple" ] [ sheeple-test ] 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
|
[ 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
|
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||||
|
|
||||||
|
@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
|
||||||
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
|
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||||
|
|
||||||
[ "sheeple" ] [ sheeple-test ] 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
|
[ 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
|
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||||
|
|
|
@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
|
||||||
10 [
|
10 [
|
||||||
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
|
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
|
||||||
[ t ] [
|
[ 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
|
] unit-test
|
||||||
] times
|
] times
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
USING: math.private kernel combinators accessors arrays
|
USING: math.private kernel combinators accessors arrays
|
||||||
generalizations tools.test ;
|
generalizations tools.test words ;
|
||||||
IN: compiler.tests.spilling
|
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 )
|
: 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 )
|
||||||
|
@ -47,7 +47,7 @@ IN: compiler.tests.spilling
|
||||||
[ 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 ]
|
[ 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
|
[ 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 )
|
: 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 )
|
||||||
{
|
{
|
||||||
|
@ -132,7 +132,7 @@ IN: compiler.tests.spilling
|
||||||
[ 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 ]
|
[ 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
|
[ 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 )
|
: resolve-spill-bug ( a b -- c )
|
||||||
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
|
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
|
||||||
|
@ -159,7 +159,7 @@ IN: compiler.tests.spilling
|
||||||
16 narray
|
16 narray
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
|
[ t ] [ \ resolve-spill-bug optimized? ] unit-test
|
||||||
|
|
||||||
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
|
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -153,7 +153,7 @@ SYMBOL: node-count
|
||||||
[ 1+ ] dip
|
[ 1+ ] dip
|
||||||
dup #call? [
|
dup #call? [
|
||||||
word>> {
|
word>> {
|
||||||
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
|
{ [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
|
||||||
{ [ dup generic? ] [ generics-called ] }
|
{ [ dup generic? ] [ generics-called ] }
|
||||||
{ [ dup method-body? ] [ methods-called ] }
|
{ [ dup method-body? ] [ methods-called ] }
|
||||||
[ words-called ]
|
[ words-called ]
|
||||||
|
|
|
@ -12,7 +12,6 @@ M: #push run-escape-analysis*
|
||||||
|
|
||||||
M: #call run-escape-analysis*
|
M: #call run-escape-analysis*
|
||||||
{
|
{
|
||||||
{ [ dup word>> \ <complex> eq? ] [ t ] }
|
|
||||||
{ [ dup immutable-tuple-boa? ] [ t ] }
|
{ [ dup immutable-tuple-boa? ] [ t ] }
|
||||||
[ f ]
|
[ f ]
|
||||||
} cond nip ;
|
} cond nip ;
|
||||||
|
|
|
@ -17,7 +17,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
|
||||||
out-d>> first escaping-allocation? [ 1+ ] unless ;
|
out-d>> first escaping-allocation? [ 1+ ] unless ;
|
||||||
|
|
||||||
M: #call count-unboxed-allocations*
|
M: #call count-unboxed-allocations*
|
||||||
dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or
|
dup immutable-tuple-boa?
|
||||||
[ (count-unboxed-allocations) ] [ drop ] if ;
|
[ (count-unboxed-allocations) ] [ drop ] if ;
|
||||||
|
|
||||||
M: #push count-unboxed-allocations*
|
M: #push count-unboxed-allocations*
|
||||||
|
@ -291,7 +291,7 @@ C: <ro-box> ro-box
|
||||||
|
|
||||||
[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
|
[ 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
|
[ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -47,9 +47,6 @@ M: #push escape-analysis*
|
||||||
[ record-unknown-allocation ]
|
[ record-unknown-allocation ]
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
: record-complex-allocation ( #call -- )
|
|
||||||
[ in-d>> ] [ out-d>> first ] bi record-allocation ;
|
|
||||||
|
|
||||||
: slot-offset ( #call -- n/f )
|
: slot-offset ( #call -- n/f )
|
||||||
dup in-d>>
|
dup in-d>>
|
||||||
[ first node-value-info class>> ]
|
[ first node-value-info class>> ]
|
||||||
|
@ -71,7 +68,6 @@ M: #push escape-analysis*
|
||||||
M: #call escape-analysis*
|
M: #call escape-analysis*
|
||||||
dup word>> {
|
dup word>> {
|
||||||
{ \ <tuple-boa> [ record-tuple-allocation ] }
|
{ \ <tuple-boa> [ record-tuple-allocation ] }
|
||||||
{ \ <complex> [ record-complex-allocation ] }
|
|
||||||
{ \ slot [ record-slot-call ] }
|
{ \ slot [ record-slot-call ] }
|
||||||
[ drop record-unknown-allocation ]
|
[ drop record-unknown-allocation ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
|
@ -59,29 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval }
|
||||||
|
|
||||||
: <value-info> ( -- info ) \ value-info new ;
|
: <value-info> ( -- info ) \ value-info new ;
|
||||||
|
|
||||||
: read-only-slots ( values class -- slots )
|
|
||||||
all-slots
|
|
||||||
[ read-only>> [ drop f ] unless ] 2map
|
|
||||||
f prefix ;
|
|
||||||
|
|
||||||
DEFER: <literal-info>
|
DEFER: <literal-info>
|
||||||
|
|
||||||
|
: tuple-slot-infos ( tuple -- slots )
|
||||||
|
[ tuple-slots ] [ class all-slots ] bi
|
||||||
|
[ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
|
||||||
|
f prefix ;
|
||||||
|
|
||||||
: init-literal-info ( info -- info )
|
: init-literal-info ( info -- info )
|
||||||
dup literal>> class >>class
|
dup literal>> class >>class
|
||||||
dup literal>> dup real? [ [a,a] >>interval ] [
|
dup literal>> dup real? [ [a,a] >>interval ] [
|
||||||
[ [-inf,inf] >>interval ] dip
|
[ [-inf,inf] >>interval ] dip
|
||||||
{
|
dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
|
||||||
{ [ 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
|
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: init-value-info ( info -- info )
|
: init-value-info ( info -- info )
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel arrays sequences math math.order
|
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
|
classes.algebra classes.union sets quotations assocs combinators
|
||||||
words namespaces continuations classes fry combinators.smart hints
|
words namespaces continuations classes fry combinators.smart hints
|
||||||
locals
|
locals
|
||||||
|
@ -188,9 +188,7 @@ SYMBOL: history
|
||||||
{ curry compose } memq? ;
|
{ curry compose } memq? ;
|
||||||
|
|
||||||
: never-inline-word? ( word -- ? )
|
: never-inline-word? ( word -- ? )
|
||||||
[ deferred? ]
|
[ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
|
||||||
[ "default" word-prop ]
|
|
||||||
[ { call execute } memq? ] tri or or ;
|
|
||||||
|
|
||||||
: custom-inlining? ( word -- ? )
|
: custom-inlining? ( word -- ? )
|
||||||
"custom-inlining" word-prop ;
|
"custom-inlining" word-prop ;
|
||||||
|
|
|
@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
|
||||||
compiler.tree.debugger compiler.tree.checker
|
compiler.tree.debugger compiler.tree.checker
|
||||||
slots.private words hashtables classes assocs locals
|
slots.private words hashtables classes assocs locals
|
||||||
specialized-arrays.double system sorting math.libm
|
specialized-arrays.double system sorting math.libm
|
||||||
math.intervals ;
|
math.intervals quotations ;
|
||||||
IN: compiler.tree.propagation.tests
|
IN: compiler.tree.propagation.tests
|
||||||
|
|
||||||
[ V{ } ] [ [ ] final-classes ] unit-test
|
[ V{ } ] [ [ ] final-classes ] unit-test
|
||||||
|
@ -357,7 +357,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ V{ complex } ] [
|
[ V{ complex } ] [
|
||||||
[ <complex> ] final-classes
|
[ complex boa ] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ V{ complex } ] [
|
[ V{ complex } ] [
|
||||||
|
@ -375,7 +375,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
|
||||||
[ V{ complex } ] [
|
[ V{ complex } ] [
|
||||||
[
|
[
|
||||||
{ float float object } declare
|
{ float float object } declare
|
||||||
[ "Oops" throw ] [ <complex> ] if
|
[ "Oops" throw ] [ complex boa ] if
|
||||||
] final-classes
|
] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -590,7 +590,7 @@ MIXIN: empty-mixin
|
||||||
|
|
||||||
[ V{ float } ] [
|
[ V{ float } ] [
|
||||||
[
|
[
|
||||||
[ { float float } declare <complex> ]
|
[ { float float } declare complex boa ]
|
||||||
[ 2drop C{ 0.0 0.0 } ]
|
[ 2drop C{ 0.0 0.0 } ]
|
||||||
if real-part
|
if real-part
|
||||||
] final-classes
|
] final-classes
|
||||||
|
@ -686,3 +686,8 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
|
||||||
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
|
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
|
||||||
|
|
||||||
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
|
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
|
||||||
|
|
||||||
|
! Mutable tuples with circularity should not cause problems
|
||||||
|
TUPLE: circle me ;
|
||||||
|
|
||||||
|
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
|
|
@ -109,7 +109,7 @@ M: #declare propagate-before
|
||||||
|
|
||||||
: output-value-infos ( #call word -- infos )
|
: 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 sequence-constructor? ] [ propagate-sequence-constructor ] }
|
||||||
{ [ dup predicate? ] [ propagate-predicate ] }
|
{ [ dup predicate? ] [ propagate-predicate ] }
|
||||||
{ [ dup "outputs" word-prop ] [ call-outputs-quot ] }
|
{ [ dup "outputs" word-prop ] [ call-outputs-quot ] }
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: fry assocs arrays byte-arrays strings accessors sequences
|
USING: fry assocs arrays byte-arrays strings accessors sequences
|
||||||
kernel slots classes.algebra classes.tuple classes.tuple.private
|
kernel slots classes.algebra classes.tuple classes.tuple.private
|
||||||
|
@ -8,9 +8,6 @@ IN: compiler.tree.propagation.slots
|
||||||
|
|
||||||
! Propagation of immutable slots and array lengths
|
! 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 ;
|
UNION: fixed-length-sequence array byte-array string ;
|
||||||
|
|
||||||
: sequence-constructor? ( word -- ? )
|
: sequence-constructor? ( word -- ? )
|
||||||
|
@ -29,33 +26,26 @@ UNION: fixed-length-sequence array byte-array string ;
|
||||||
[ constructor-output-class <class-info> ]
|
[ constructor-output-class <class-info> ]
|
||||||
bi* value-info-intersect 1array ;
|
bi* value-info-intersect 1array ;
|
||||||
|
|
||||||
: tuple-constructor? ( word -- ? )
|
|
||||||
{ <tuple-boa> <complex> } memq? ;
|
|
||||||
|
|
||||||
: fold-<tuple-boa> ( values class -- info )
|
: fold-<tuple-boa> ( values class -- info )
|
||||||
[ [ literal>> ] map ] dip prefix >tuple
|
[ [ literal>> ] map ] dip prefix >tuple
|
||||||
<literal-info> ;
|
<literal-info> ;
|
||||||
|
|
||||||
|
: read-only-slots ( values class -- slots )
|
||||||
|
all-slots
|
||||||
|
[ read-only>> [ value-info ] [ drop f ] if ] 2map
|
||||||
|
f prefix ;
|
||||||
|
|
||||||
: (propagate-tuple-constructor) ( values class -- info )
|
: (propagate-tuple-constructor) ( values class -- info )
|
||||||
[ [ value-info ] map ] dip [ read-only-slots ] keep
|
[ read-only-slots ] keep
|
||||||
over rest-slice [ dup [ literal?>> ] when ] all? [
|
over rest-slice [ dup [ literal?>> ] when ] all? [
|
||||||
[ rest-slice ] dip fold-<tuple-boa>
|
[ rest-slice ] dip fold-<tuple-boa>
|
||||||
] [
|
] [
|
||||||
<tuple-info>
|
<tuple-info>
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: propagate-<tuple-boa> ( #call -- info )
|
: propagate-<tuple-boa> ( #call -- infos )
|
||||||
in-d>> unclip-last
|
in-d>> unclip-last
|
||||||
value-info literal>> first (propagate-tuple-constructor) ;
|
value-info literal>> first (propagate-tuple-constructor) 1array ;
|
||||||
|
|
||||||
: 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 ;
|
|
||||||
|
|
||||||
: read-only-slot? ( n class -- ? )
|
: read-only-slot? ( n class -- ? )
|
||||||
all-slots [ offset>> = ] with find nip
|
all-slots [ offset>> = ] with find nip
|
||||||
|
|
|
@ -32,7 +32,6 @@ TUPLE: empty-tuple ;
|
||||||
[ dup [ drop f ] [ "A" throw ] if ]
|
[ dup [ drop f ] [ "A" throw ] if ]
|
||||||
[ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
|
[ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
|
||||||
[ [ ] [ ] curry curry call ]
|
[ [ ] [ ] curry curry call ]
|
||||||
[ <complex> <complex> dup 1 slot drop 2 slot drop ]
|
|
||||||
[ 1 cons boa over [ "A" throw ] when car>> ]
|
[ 1 cons boa over [ "A" throw ] when car>> ]
|
||||||
[ [ <=> ] sort ]
|
[ [ <=> ] sort ]
|
||||||
[ [ <=> ] with search ]
|
[ [ <=> ] with search ]
|
||||||
|
|
|
@ -36,9 +36,6 @@ M: #push unbox-tuples* ( #push -- nodes )
|
||||||
: unbox-<tuple-boa> ( #call -- nodes )
|
: unbox-<tuple-boa> ( #call -- nodes )
|
||||||
dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
|
dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
|
||||||
|
|
||||||
: unbox-<complex> ( #call -- nodes )
|
|
||||||
dup unbox-output? [ drop { } ] when ;
|
|
||||||
|
|
||||||
: (flatten-values) ( values accum -- )
|
: (flatten-values) ( values accum -- )
|
||||||
dup '[
|
dup '[
|
||||||
dup unboxed-allocation
|
dup unboxed-allocation
|
||||||
|
@ -70,7 +67,6 @@ M: #push unbox-tuples* ( #push -- nodes )
|
||||||
M: #call unbox-tuples*
|
M: #call unbox-tuples*
|
||||||
dup word>> {
|
dup word>> {
|
||||||
{ \ <tuple-boa> [ unbox-<tuple-boa> ] }
|
{ \ <tuple-boa> [ unbox-<tuple-boa> ] }
|
||||||
{ \ <complex> [ unbox-<complex> ] }
|
|
||||||
{ \ slot [ unbox-slot-access ] }
|
{ \ slot [ unbox-slot-access ] }
|
||||||
[ drop ]
|
[ drop ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
|
@ -151,8 +151,8 @@ SYMBOL: event-stream-callbacks
|
||||||
\ event-stream-counter counter ;
|
\ event-stream-counter counter ;
|
||||||
|
|
||||||
[
|
[
|
||||||
event-stream-callbacks global
|
event-stream-callbacks
|
||||||
[ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at
|
[ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
|
||||||
] "core-foundation" add-init-hook
|
] "core-foundation" add-init-hook
|
||||||
|
|
||||||
: add-event-source-callback ( quot -- id )
|
: add-event-source-callback ( quot -- id )
|
||||||
|
|
|
@ -2,15 +2,13 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: bootstrap.image.private kernel kernel.private namespaces
|
USING: bootstrap.image.private kernel kernel.private namespaces
|
||||||
system cpu.ppc.assembler compiler.codegen.fixup compiler.units
|
system cpu.ppc.assembler compiler.codegen.fixup compiler.units
|
||||||
compiler.constants math math.private layouts words words.private
|
compiler.constants math math.private layouts words
|
||||||
vocabs slots.private locals.backend ;
|
vocabs slots.private locals.backend ;
|
||||||
IN: bootstrap.ppc
|
IN: bootstrap.ppc
|
||||||
|
|
||||||
4 \ cell set
|
4 \ cell set
|
||||||
big-endian on
|
big-endian on
|
||||||
|
|
||||||
4 jit-code-format set
|
|
||||||
|
|
||||||
CONSTANT: ds-reg 29
|
CONSTANT: ds-reg 29
|
||||||
CONSTANT: rs-reg 30
|
CONSTANT: rs-reg 30
|
||||||
|
|
||||||
|
@ -23,7 +21,7 @@ CONSTANT: rs-reg 30
|
||||||
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
|
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
|
||||||
|
|
||||||
[
|
[
|
||||||
0 6 LOAD32
|
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||||
11 6 profile-count-offset LWZ
|
11 6 profile-count-offset LWZ
|
||||||
11 11 1 tag-fixnum ADDI
|
11 11 1 tag-fixnum ADDI
|
||||||
11 6 profile-count-offset STW
|
11 6 profile-count-offset STW
|
||||||
|
@ -31,65 +29,50 @@ CONSTANT: rs-reg 30
|
||||||
11 11 compiled-header-size ADDI
|
11 11 compiled-header-size ADDI
|
||||||
11 MTCTR
|
11 MTCTR
|
||||||
BCTR
|
BCTR
|
||||||
] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define
|
] jit-profiling jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
0 6 LOAD32
|
0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
|
||||||
0 MFLR
|
0 MFLR
|
||||||
1 1 stack-frame SUBI
|
1 1 stack-frame SUBI
|
||||||
6 1 xt-save STW
|
6 1 xt-save STW
|
||||||
stack-frame 6 LI
|
stack-frame 6 LI
|
||||||
6 1 next-save STW
|
6 1 next-save STW
|
||||||
0 1 lr-save stack-frame + STW
|
0 1 lr-save stack-frame + STW
|
||||||
] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define
|
] jit-prolog jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
0 6 LOAD32
|
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||||
6 ds-reg 4 STWU
|
6 ds-reg 4 STWU
|
||||||
] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define
|
] jit-push-immediate jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
0 6 LOAD32
|
0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
|
||||||
7 6 0 LWZ
|
7 6 0 LWZ
|
||||||
1 7 0 STW
|
1 7 0 STW
|
||||||
] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define
|
] jit-save-stack jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
0 6 LOAD32
|
0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
|
||||||
6 MTCTR
|
6 MTCTR
|
||||||
BCTR
|
BCTR
|
||||||
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define
|
] jit-primitive jit-define
|
||||||
|
|
||||||
[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define
|
[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define
|
||||||
|
|
||||||
[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
|
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
ds-reg dup 4 SUBI
|
ds-reg dup 4 SUBI
|
||||||
0 3 \ f tag-number CMPI
|
0 3 \ f tag-number CMPI
|
||||||
2 BEQ
|
2 BEQ
|
||||||
0 B
|
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||||
] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define
|
] jit-if-1 jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
0 B
|
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||||
] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define
|
] jit-if-2 jit-define
|
||||||
|
|
||||||
: jit-jump-quot ( -- )
|
|
||||||
4 3 quot-xt-offset LWZ
|
|
||||||
4 MTCTR
|
|
||||||
BCTR ;
|
|
||||||
|
|
||||||
[
|
|
||||||
0 3 LOAD32
|
|
||||||
6 ds-reg 0 LWZ
|
|
||||||
6 6 1 SRAWI
|
|
||||||
3 3 6 ADD
|
|
||||||
3 3 array-start-offset LWZ
|
|
||||||
ds-reg dup 4 SUBI
|
|
||||||
jit-jump-quot
|
|
||||||
] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define
|
|
||||||
|
|
||||||
: jit->r ( -- )
|
: jit->r ( -- )
|
||||||
4 ds-reg 0 LWZ
|
4 ds-reg 0 LWZ
|
||||||
|
@ -139,29 +122,29 @@ CONSTANT: rs-reg 30
|
||||||
|
|
||||||
[
|
[
|
||||||
jit->r
|
jit->r
|
||||||
0 BL
|
0 BL rc-relative-ppc-3 rt-xt jit-rel
|
||||||
jit-r>
|
jit-r>
|
||||||
] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define
|
] jit-dip jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
jit-2>r
|
jit-2>r
|
||||||
0 BL
|
0 BL rc-relative-ppc-3 rt-xt jit-rel
|
||||||
jit-2r>
|
jit-2r>
|
||||||
] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define
|
] jit-2dip jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
jit-3>r
|
jit-3>r
|
||||||
0 BL
|
0 BL rc-relative-ppc-3 rt-xt jit-rel
|
||||||
jit-3r>
|
jit-3r>
|
||||||
] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define
|
] jit-3dip jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
0 1 lr-save stack-frame + LWZ
|
0 1 lr-save stack-frame + LWZ
|
||||||
1 1 stack-frame ADDI
|
1 1 stack-frame ADDI
|
||||||
0 MTLR
|
0 MTLR
|
||||||
] f f f jit-epilog jit-define
|
] jit-epilog jit-define
|
||||||
|
|
||||||
[ BLR ] f f f jit-return jit-define
|
[ BLR ] jit-return jit-define
|
||||||
|
|
||||||
! Sub-primitives
|
! Sub-primitives
|
||||||
|
|
||||||
|
@ -169,8 +152,10 @@ CONSTANT: rs-reg 30
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
ds-reg dup 4 SUBI
|
ds-reg dup 4 SUBI
|
||||||
jit-jump-quot
|
4 3 quot-xt-offset LWZ
|
||||||
] f f f \ (call) define-sub-primitive
|
4 MTCTR
|
||||||
|
BCTR
|
||||||
|
] \ (call) define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -178,7 +163,7 @@ CONSTANT: rs-reg 30
|
||||||
4 3 word-xt-offset LWZ
|
4 3 word-xt-offset LWZ
|
||||||
4 MTCTR
|
4 MTCTR
|
||||||
BCTR
|
BCTR
|
||||||
] f f f \ (execute) define-sub-primitive
|
] \ (execute) define-sub-primitive
|
||||||
|
|
||||||
! Objects
|
! Objects
|
||||||
[
|
[
|
||||||
|
@ -186,7 +171,7 @@ CONSTANT: rs-reg 30
|
||||||
3 3 tag-mask get ANDI
|
3 3 tag-mask get ANDI
|
||||||
3 3 tag-bits get SLWI
|
3 3 tag-bits get SLWI
|
||||||
3 ds-reg 0 STW
|
3 ds-reg 0 STW
|
||||||
] f f f \ tag define-sub-primitive
|
] \ tag define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -195,25 +180,25 @@ CONSTANT: rs-reg 30
|
||||||
4 4 0 0 31 tag-bits get - RLWINM
|
4 4 0 0 31 tag-bits get - RLWINM
|
||||||
4 3 3 LWZX
|
4 3 3 LWZX
|
||||||
3 ds-reg 0 STW
|
3 ds-reg 0 STW
|
||||||
] f f f \ slot define-sub-primitive
|
] \ slot define-sub-primitive
|
||||||
|
|
||||||
! Shufflers
|
! Shufflers
|
||||||
[
|
[
|
||||||
ds-reg dup 4 SUBI
|
ds-reg dup 4 SUBI
|
||||||
] f f f \ drop define-sub-primitive
|
] \ drop define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
ds-reg dup 8 SUBI
|
ds-reg dup 8 SUBI
|
||||||
] f f f \ 2drop define-sub-primitive
|
] \ 2drop define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
ds-reg dup 12 SUBI
|
ds-reg dup 12 SUBI
|
||||||
] f f f \ 3drop define-sub-primitive
|
] \ 3drop define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
3 ds-reg 4 STWU
|
3 ds-reg 4 STWU
|
||||||
] f f f \ dup define-sub-primitive
|
] \ dup define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -221,7 +206,7 @@ CONSTANT: rs-reg 30
|
||||||
ds-reg dup 8 ADDI
|
ds-reg dup 8 ADDI
|
||||||
3 ds-reg 0 STW
|
3 ds-reg 0 STW
|
||||||
4 ds-reg -4 STW
|
4 ds-reg -4 STW
|
||||||
] f f f \ 2dup define-sub-primitive
|
] \ 2dup define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -231,36 +216,36 @@ CONSTANT: rs-reg 30
|
||||||
3 ds-reg 0 STW
|
3 ds-reg 0 STW
|
||||||
4 ds-reg -4 STW
|
4 ds-reg -4 STW
|
||||||
5 ds-reg -8 STW
|
5 ds-reg -8 STW
|
||||||
] f f f \ 3dup define-sub-primitive
|
] \ 3dup define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
ds-reg dup 4 SUBI
|
ds-reg dup 4 SUBI
|
||||||
3 ds-reg 0 STW
|
3 ds-reg 0 STW
|
||||||
] f f f \ nip define-sub-primitive
|
] \ nip define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
ds-reg dup 8 SUBI
|
ds-reg dup 8 SUBI
|
||||||
3 ds-reg 0 STW
|
3 ds-reg 0 STW
|
||||||
] f f f \ 2nip define-sub-primitive
|
] \ 2nip define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg -4 LWZ
|
3 ds-reg -4 LWZ
|
||||||
3 ds-reg 4 STWU
|
3 ds-reg 4 STWU
|
||||||
] f f f \ over define-sub-primitive
|
] \ over define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg -8 LWZ
|
3 ds-reg -8 LWZ
|
||||||
3 ds-reg 4 STWU
|
3 ds-reg 4 STWU
|
||||||
] f f f \ pick define-sub-primitive
|
] \ pick define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
4 ds-reg -4 LWZ
|
4 ds-reg -4 LWZ
|
||||||
4 ds-reg 0 STW
|
4 ds-reg 0 STW
|
||||||
3 ds-reg 4 STWU
|
3 ds-reg 4 STWU
|
||||||
] f f f \ dupd define-sub-primitive
|
] \ dupd define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -268,21 +253,21 @@ CONSTANT: rs-reg 30
|
||||||
3 ds-reg 4 STWU
|
3 ds-reg 4 STWU
|
||||||
4 ds-reg -4 STW
|
4 ds-reg -4 STW
|
||||||
3 ds-reg -8 STW
|
3 ds-reg -8 STW
|
||||||
] f f f \ tuck define-sub-primitive
|
] \ tuck define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
4 ds-reg -4 LWZ
|
4 ds-reg -4 LWZ
|
||||||
3 ds-reg -4 STW
|
3 ds-reg -4 STW
|
||||||
4 ds-reg 0 STW
|
4 ds-reg 0 STW
|
||||||
] f f f \ swap define-sub-primitive
|
] \ swap define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg -4 LWZ
|
3 ds-reg -4 LWZ
|
||||||
4 ds-reg -8 LWZ
|
4 ds-reg -8 LWZ
|
||||||
3 ds-reg -8 STW
|
3 ds-reg -8 STW
|
||||||
4 ds-reg -4 STW
|
4 ds-reg -4 STW
|
||||||
] f f f \ swapd define-sub-primitive
|
] \ swapd define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -291,7 +276,7 @@ CONSTANT: rs-reg 30
|
||||||
4 ds-reg -8 STW
|
4 ds-reg -8 STW
|
||||||
3 ds-reg -4 STW
|
3 ds-reg -4 STW
|
||||||
5 ds-reg 0 STW
|
5 ds-reg 0 STW
|
||||||
] f f f \ rot define-sub-primitive
|
] \ rot define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -300,13 +285,13 @@ CONSTANT: rs-reg 30
|
||||||
3 ds-reg -8 STW
|
3 ds-reg -8 STW
|
||||||
5 ds-reg -4 STW
|
5 ds-reg -4 STW
|
||||||
4 ds-reg 0 STW
|
4 ds-reg 0 STW
|
||||||
] 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
|
! Comparisons
|
||||||
: jit-compare ( insn -- )
|
: jit-compare ( insn -- )
|
||||||
0 3 LOAD32
|
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||||
4 ds-reg 0 LWZ
|
4 ds-reg 0 LWZ
|
||||||
5 ds-reg -4 LWZU
|
5 ds-reg -4 LWZU
|
||||||
5 0 4 CMP
|
5 0 4 CMP
|
||||||
|
@ -315,8 +300,7 @@ CONSTANT: rs-reg 30
|
||||||
3 ds-reg 0 STW ;
|
3 ds-reg 0 STW ;
|
||||||
|
|
||||||
: define-jit-compare ( insn word -- )
|
: define-jit-compare ( insn word -- )
|
||||||
[ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip
|
[ [ jit-compare ] curry ] dip define-sub-primitive ;
|
||||||
define-sub-primitive ;
|
|
||||||
|
|
||||||
\ BEQ \ eq? define-jit-compare
|
\ BEQ \ eq? define-jit-compare
|
||||||
\ BGE \ fixnum>= define-jit-compare
|
\ BGE \ fixnum>= define-jit-compare
|
||||||
|
@ -336,7 +320,7 @@ CONSTANT: rs-reg 30
|
||||||
2 BNE
|
2 BNE
|
||||||
1 tag-fixnum 4 LI
|
1 tag-fixnum 4 LI
|
||||||
4 ds-reg 0 STW
|
4 ds-reg 0 STW
|
||||||
] f f f \ both-fixnums? define-sub-primitive
|
] \ both-fixnums? define-sub-primitive
|
||||||
|
|
||||||
: jit-math ( insn -- )
|
: jit-math ( insn -- )
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -344,9 +328,9 @@ CONSTANT: rs-reg 30
|
||||||
[ 5 3 4 ] dip execute( dst src1 src2 -- )
|
[ 5 3 4 ] dip execute( dst src1 src2 -- )
|
||||||
5 ds-reg 0 STW ;
|
5 ds-reg 0 STW ;
|
||||||
|
|
||||||
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
|
[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
|
||||||
|
|
||||||
[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive
|
[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -354,20 +338,20 @@ CONSTANT: rs-reg 30
|
||||||
4 4 tag-bits get SRAWI
|
4 4 tag-bits get SRAWI
|
||||||
5 3 4 MULLW
|
5 3 4 MULLW
|
||||||
5 ds-reg 0 STW
|
5 ds-reg 0 STW
|
||||||
] 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
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
3 3 NOT
|
3 3 NOT
|
||||||
3 3 tag-mask get XORI
|
3 3 tag-mask get XORI
|
||||||
3 ds-reg 0 STW
|
3 ds-reg 0 STW
|
||||||
] f f f \ fixnum-bitnot define-sub-primitive
|
] \ fixnum-bitnot define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -382,7 +366,7 @@ CONSTANT: rs-reg 30
|
||||||
2 BGT
|
2 BGT
|
||||||
5 7 MR
|
5 7 MR
|
||||||
5 ds-reg 0 STW
|
5 ds-reg 0 STW
|
||||||
] f f f \ fixnum-shift-fast define-sub-primitive
|
] \ fixnum-shift-fast define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -392,7 +376,7 @@ CONSTANT: rs-reg 30
|
||||||
6 5 3 MULLW
|
6 5 3 MULLW
|
||||||
7 6 4 SUBF
|
7 6 4 SUBF
|
||||||
7 ds-reg 0 STW
|
7 ds-reg 0 STW
|
||||||
] f f f \ fixnum-mod define-sub-primitive
|
] \ fixnum-mod define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -401,7 +385,7 @@ CONSTANT: rs-reg 30
|
||||||
5 4 3 DIVW
|
5 4 3 DIVW
|
||||||
5 5 tag-bits get SLWI
|
5 5 tag-bits get SLWI
|
||||||
5 ds-reg 0 STW
|
5 ds-reg 0 STW
|
||||||
] f f f \ fixnum/i-fast define-sub-primitive
|
] \ fixnum/i-fast define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
|
@ -412,20 +396,20 @@ CONSTANT: rs-reg 30
|
||||||
5 5 tag-bits get SLWI
|
5 5 tag-bits get SLWI
|
||||||
5 ds-reg -4 STW
|
5 ds-reg -4 STW
|
||||||
7 ds-reg 0 STW
|
7 ds-reg 0 STW
|
||||||
] f f f \ fixnum/mod-fast define-sub-primitive
|
] \ fixnum/mod-fast define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
3 3 1 SRAWI
|
3 3 1 SRAWI
|
||||||
rs-reg 3 3 LWZX
|
rs-reg 3 3 LWZX
|
||||||
3 ds-reg 0 STW
|
3 ds-reg 0 STW
|
||||||
] f f f \ get-local define-sub-primitive
|
] \ get-local define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
ds-reg ds-reg 4 SUBI
|
ds-reg ds-reg 4 SUBI
|
||||||
3 3 1 SRAWI
|
3 3 1 SRAWI
|
||||||
rs-reg 3 rs-reg SUBF
|
rs-reg 3 rs-reg SUBF
|
||||||
] f f f \ drop-locals define-sub-primitive
|
] \ drop-locals define-sub-primitive
|
||||||
|
|
||||||
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit
|
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit
|
||||||
|
|
|
@ -309,7 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
|
||||||
check_sse2 ;
|
check_sse2 ;
|
||||||
|
|
||||||
"-no-sse2" (command-line) member? [
|
"-no-sse2" (command-line) member? [
|
||||||
optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
|
[ { check_sse2 } compile ] with-optimizer
|
||||||
|
|
||||||
"Checking if your CPU supports SSE2..." print flush
|
"Checking if your CPU supports SSE2..." print flush
|
||||||
sse2? [
|
sse2? [
|
||||||
|
|
|
@ -22,13 +22,15 @@ IN: bootstrap.x86
|
||||||
: rex-length ( -- n ) 0 ;
|
: rex-length ( -- n ) 0 ;
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 0 [] MOV ! load stack_chain
|
! load stack_chain
|
||||||
temp0 [] stack-reg MOV ! save stack pointer
|
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
|
||||||
] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
|
! save stack pointer
|
||||||
|
temp0 [] stack-reg MOV
|
||||||
|
] jit-save-stack jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
(JMP) drop
|
(JMP) drop rc-relative rt-primitive jit-rel
|
||||||
] rc-relative rt-primitive 1 jit-primitive jit-define
|
] jit-primitive jit-define
|
||||||
|
|
||||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
|
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
|
||||||
call
|
call
|
||||||
|
|
|
@ -20,15 +20,19 @@ IN: bootstrap.x86
|
||||||
: rex-length ( -- n ) 1 ;
|
: 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 temp0 [] MOV
|
||||||
temp0 [] stack-reg MOV ! save stack pointer
|
! save stack pointer
|
||||||
] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
|
temp0 [] stack-reg MOV
|
||||||
|
] jit-save-stack jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
temp1 0 MOV ! load XT
|
! load XT
|
||||||
temp1 JMP ! go
|
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
|
||||||
] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
|
! go
|
||||||
|
temp1 JMP
|
||||||
|
] jit-primitive jit-define
|
||||||
|
|
||||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
|
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
|
||||||
call
|
call
|
||||||
|
|
|
@ -62,3 +62,5 @@ IN: cpu.x86.assembler.tests
|
||||||
[ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
|
[ { 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: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
|
||||||
[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX 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
|
||||||
|
|
|
@ -316,15 +316,16 @@ M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
|
||||||
GENERIC: CALL ( op -- )
|
GENERIC: CALL ( op -- )
|
||||||
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
|
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
|
||||||
M: f CALL (CALL) 2drop ;
|
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: label CALL (CALL) label-fixup ;
|
||||||
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
|
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
|
||||||
|
|
||||||
GENERIC# JUMPcc 1 ( addr opcode -- )
|
GENERIC# JUMPcc 1 ( addr opcode -- )
|
||||||
: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
|
: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
|
||||||
M: f JUMPcc nip (JUMPcc) drop ;
|
M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
|
||||||
M: callable JUMPcc (JUMPcc) rel-word ;
|
M: integer JUMPcc (JUMPcc) drop ;
|
||||||
M: label JUMPcc (JUMPcc) label-fixup ;
|
M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
|
||||||
|
M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
|
||||||
|
|
||||||
: JO ( dst -- ) HEX: 80 JUMPcc ;
|
: JO ( dst -- ) HEX: 80 JUMPcc ;
|
||||||
: JNO ( dst -- ) HEX: 81 JUMPcc ;
|
: JNO ( dst -- ) HEX: 81 JUMPcc ;
|
||||||
|
@ -382,6 +383,10 @@ GENERIC: CMP ( dst src -- )
|
||||||
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
|
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
|
||||||
M: operand CMP OCT: 070 2-operand ;
|
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 ;
|
: XCHG ( dst src -- ) OCT: 207 2-operand ;
|
||||||
|
|
||||||
: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
|
: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
|
||||||
|
|
|
@ -1,18 +1,16 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: bootstrap.image.private kernel kernel.private namespaces
|
USING: bootstrap.image.private kernel kernel.private namespaces
|
||||||
system cpu.x86.assembler layouts compiler.units math
|
system cpu.x86.assembler layouts compiler.units math
|
||||||
math.private compiler.constants vocabs slots.private words
|
math.private compiler.constants vocabs slots.private words
|
||||||
words.private locals.backend ;
|
locals.backend make sequences combinators arrays ;
|
||||||
IN: bootstrap.x86
|
IN: bootstrap.x86
|
||||||
|
|
||||||
big-endian off
|
big-endian off
|
||||||
|
|
||||||
1 jit-code-format set
|
|
||||||
|
|
||||||
[
|
[
|
||||||
! Load word
|
! Load word
|
||||||
temp0 0 MOV
|
temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
|
||||||
! Bump profiling counter
|
! Bump profiling counter
|
||||||
temp0 profile-count-offset [+] 1 tag-fixnum ADD
|
temp0 profile-count-offset [+] 1 tag-fixnum ADD
|
||||||
! Load word->code
|
! Load word->code
|
||||||
|
@ -21,35 +19,35 @@ big-endian off
|
||||||
temp0 compiled-header-size ADD
|
temp0 compiled-header-size ADD
|
||||||
! Jump to XT
|
! Jump to XT
|
||||||
temp0 JMP
|
temp0 JMP
|
||||||
] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
|
] jit-profiling jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
! load XT
|
! load XT
|
||||||
temp0 0 MOV
|
temp0 0 MOV rc-absolute-cell rt-this jit-rel
|
||||||
! save stack frame size
|
! save stack frame size
|
||||||
stack-frame-size PUSH
|
stack-frame-size PUSH
|
||||||
! push XT
|
! push XT
|
||||||
temp0 PUSH
|
temp0 PUSH
|
||||||
! alignment
|
! alignment
|
||||||
stack-reg stack-frame-size 3 bootstrap-cells - SUB
|
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
|
! load literal
|
||||||
temp0 0 MOV
|
temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
|
||||||
! increment datastack pointer
|
! increment datastack pointer
|
||||||
ds-reg bootstrap-cell ADD
|
ds-reg bootstrap-cell ADD
|
||||||
! store literal on datastack
|
! store literal on datastack
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
|
] jit-push-immediate jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
f JMP
|
f JMP rc-relative rt-xt jit-rel
|
||||||
] rc-relative rt-xt 1 jit-word-jump jit-define
|
] jit-word-jump jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
f CALL
|
f CALL rc-relative rt-xt-direct jit-rel
|
||||||
] rc-relative rt-xt 1 jit-word-call jit-define
|
] jit-word-call jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
! load boolean
|
! load boolean
|
||||||
|
@ -59,31 +57,13 @@ big-endian off
|
||||||
! compare boolean with f
|
! compare boolean with f
|
||||||
temp0 \ f tag-number CMP
|
temp0 \ f tag-number CMP
|
||||||
! jump to true branch if not equal
|
! jump to true branch if not equal
|
||||||
f JNE
|
f JNE rc-relative rt-xt jit-rel
|
||||||
] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
|
] jit-if-1 jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
! jump to false branch if equal
|
! jump to false branch if equal
|
||||||
f JMP
|
f JMP rc-relative rt-xt jit-rel
|
||||||
] rc-relative rt-xt 1 jit-if-2 jit-define
|
] 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
|
|
||||||
|
|
||||||
: jit->r ( -- )
|
: jit->r ( -- )
|
||||||
rs-reg bootstrap-cell ADD
|
rs-reg bootstrap-cell ADD
|
||||||
|
@ -135,30 +115,133 @@ big-endian off
|
||||||
|
|
||||||
[
|
[
|
||||||
jit->r
|
jit->r
|
||||||
f CALL
|
f CALL rc-relative rt-xt jit-rel
|
||||||
jit-r>
|
jit-r>
|
||||||
] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define
|
] jit-dip jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
jit-2>r
|
jit-2>r
|
||||||
f CALL
|
f CALL rc-relative rt-xt jit-rel
|
||||||
jit-2r>
|
jit-2r>
|
||||||
] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
|
] jit-2dip jit-define
|
||||||
|
|
||||||
[
|
[
|
||||||
jit-3>r
|
jit-3>r
|
||||||
f CALL
|
f CALL rc-relative rt-xt jit-rel
|
||||||
jit-3r>
|
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
|
! unwind stack frame
|
||||||
stack-reg stack-frame-size bootstrap-cell - ADD
|
stack-reg stack-frame-size bootstrap-cell - ADD
|
||||||
] f f f jit-epilog jit-define
|
] jit-epilog jit-define
|
||||||
|
|
||||||
[ 0 RET ] f f f jit-return jit-define
|
[ 0 RET ] jit-return jit-define
|
||||||
|
|
||||||
! Sub-primitives
|
! ! ! Polymorphic inline caches
|
||||||
|
|
||||||
|
! 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
|
! Quotations and words
|
||||||
[
|
[
|
||||||
|
@ -168,16 +251,7 @@ big-endian off
|
||||||
ds-reg bootstrap-cell SUB
|
ds-reg bootstrap-cell SUB
|
||||||
! call quotation
|
! call quotation
|
||||||
arg quot-xt-offset [+] JMP
|
arg quot-xt-offset [+] JMP
|
||||||
] f f f \ (call) define-sub-primitive
|
] \ (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
|
|
||||||
|
|
||||||
! Objects
|
! Objects
|
||||||
[
|
[
|
||||||
|
@ -189,7 +263,7 @@ big-endian off
|
||||||
temp0 tag-bits get SHL
|
temp0 tag-bits get SHL
|
||||||
! push to stack
|
! push to stack
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
] f f f \ tag define-sub-primitive
|
] \ tag define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
! load slot number
|
! load slot number
|
||||||
|
@ -207,26 +281,26 @@ big-endian off
|
||||||
temp0 temp1 temp0 [+] MOV
|
temp0 temp1 temp0 [+] MOV
|
||||||
! push to stack
|
! push to stack
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
] f f f \ slot define-sub-primitive
|
] \ slot define-sub-primitive
|
||||||
|
|
||||||
! Shufflers
|
! Shufflers
|
||||||
[
|
[
|
||||||
ds-reg bootstrap-cell SUB
|
ds-reg bootstrap-cell SUB
|
||||||
] f f f \ drop define-sub-primitive
|
] \ drop define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
ds-reg 2 bootstrap-cells SUB
|
ds-reg 2 bootstrap-cells SUB
|
||||||
] f f f \ 2drop define-sub-primitive
|
] \ 2drop define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
ds-reg 3 bootstrap-cells SUB
|
ds-reg 3 bootstrap-cells SUB
|
||||||
] f f f \ 3drop define-sub-primitive
|
] \ 3drop define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg [] MOV
|
temp0 ds-reg [] MOV
|
||||||
ds-reg bootstrap-cell ADD
|
ds-reg bootstrap-cell ADD
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
] f f f \ dup define-sub-primitive
|
] \ dup define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg [] MOV
|
temp0 ds-reg [] MOV
|
||||||
|
@ -234,7 +308,7 @@ big-endian off
|
||||||
ds-reg 2 bootstrap-cells ADD
|
ds-reg 2 bootstrap-cells ADD
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
ds-reg bootstrap-cell neg [+] temp1 MOV
|
ds-reg bootstrap-cell neg [+] temp1 MOV
|
||||||
] f f f \ 2dup define-sub-primitive
|
] \ 2dup define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg [] MOV
|
temp0 ds-reg [] MOV
|
||||||
|
@ -244,31 +318,31 @@ big-endian off
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
ds-reg -1 bootstrap-cells [+] temp1 MOV
|
ds-reg -1 bootstrap-cells [+] temp1 MOV
|
||||||
ds-reg -2 bootstrap-cells [+] temp3 MOV
|
ds-reg -2 bootstrap-cells [+] temp3 MOV
|
||||||
] f f f \ 3dup define-sub-primitive
|
] \ 3dup define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg [] MOV
|
temp0 ds-reg [] MOV
|
||||||
ds-reg bootstrap-cell SUB
|
ds-reg bootstrap-cell SUB
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
] f f f \ nip define-sub-primitive
|
] \ nip define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg [] MOV
|
temp0 ds-reg [] MOV
|
||||||
ds-reg 2 bootstrap-cells SUB
|
ds-reg 2 bootstrap-cells SUB
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
] f f f \ 2nip define-sub-primitive
|
] \ 2nip define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg -1 bootstrap-cells [+] MOV
|
temp0 ds-reg -1 bootstrap-cells [+] MOV
|
||||||
ds-reg bootstrap-cell ADD
|
ds-reg bootstrap-cell ADD
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
] f f f \ over define-sub-primitive
|
] \ over define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg -2 bootstrap-cells [+] MOV
|
temp0 ds-reg -2 bootstrap-cells [+] MOV
|
||||||
ds-reg bootstrap-cell ADD
|
ds-reg bootstrap-cell ADD
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
] f f f \ pick define-sub-primitive
|
] \ pick define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg [] MOV
|
temp0 ds-reg [] MOV
|
||||||
|
@ -276,7 +350,7 @@ big-endian off
|
||||||
ds-reg [] temp1 MOV
|
ds-reg [] temp1 MOV
|
||||||
ds-reg bootstrap-cell ADD
|
ds-reg bootstrap-cell ADD
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
] f f f \ dupd define-sub-primitive
|
] \ dupd define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg [] MOV
|
temp0 ds-reg [] MOV
|
||||||
|
@ -285,21 +359,21 @@ big-endian off
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
ds-reg -1 bootstrap-cells [+] temp1 MOV
|
ds-reg -1 bootstrap-cells [+] temp1 MOV
|
||||||
ds-reg -2 bootstrap-cells [+] temp0 MOV
|
ds-reg -2 bootstrap-cells [+] temp0 MOV
|
||||||
] f f f \ tuck define-sub-primitive
|
] \ tuck define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg [] MOV
|
temp0 ds-reg [] MOV
|
||||||
temp1 ds-reg bootstrap-cell neg [+] MOV
|
temp1 ds-reg bootstrap-cell neg [+] MOV
|
||||||
ds-reg bootstrap-cell neg [+] temp0 MOV
|
ds-reg bootstrap-cell neg [+] temp0 MOV
|
||||||
ds-reg [] temp1 MOV
|
ds-reg [] temp1 MOV
|
||||||
] f f f \ swap define-sub-primitive
|
] \ swap define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg -1 bootstrap-cells [+] MOV
|
temp0 ds-reg -1 bootstrap-cells [+] MOV
|
||||||
temp1 ds-reg -2 bootstrap-cells [+] MOV
|
temp1 ds-reg -2 bootstrap-cells [+] MOV
|
||||||
ds-reg -2 bootstrap-cells [+] temp0 MOV
|
ds-reg -2 bootstrap-cells [+] temp0 MOV
|
||||||
ds-reg -1 bootstrap-cells [+] temp1 MOV
|
ds-reg -1 bootstrap-cells [+] temp1 MOV
|
||||||
] f f f \ swapd define-sub-primitive
|
] \ swapd define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg [] MOV
|
temp0 ds-reg [] MOV
|
||||||
|
@ -308,7 +382,7 @@ big-endian off
|
||||||
ds-reg -2 bootstrap-cells [+] temp1 MOV
|
ds-reg -2 bootstrap-cells [+] temp1 MOV
|
||||||
ds-reg -1 bootstrap-cells [+] temp0 MOV
|
ds-reg -1 bootstrap-cells [+] temp0 MOV
|
||||||
ds-reg [] temp3 MOV
|
ds-reg [] temp3 MOV
|
||||||
] f f f \ rot define-sub-primitive
|
] \ rot define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
temp0 ds-reg [] MOV
|
temp0 ds-reg [] MOV
|
||||||
|
@ -317,14 +391,14 @@ big-endian off
|
||||||
ds-reg -2 bootstrap-cells [+] temp0 MOV
|
ds-reg -2 bootstrap-cells [+] temp0 MOV
|
||||||
ds-reg -1 bootstrap-cells [+] temp3 MOV
|
ds-reg -1 bootstrap-cells [+] temp3 MOV
|
||||||
ds-reg [] temp1 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
|
! Comparisons
|
||||||
: jit-compare ( insn -- )
|
: jit-compare ( insn -- )
|
||||||
! load t
|
! load t
|
||||||
temp3 0 MOV
|
temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
|
||||||
! load f
|
! load f
|
||||||
temp1 \ f tag-number MOV
|
temp1 \ f tag-number MOV
|
||||||
! load first value
|
! load first value
|
||||||
|
@ -339,8 +413,7 @@ big-endian off
|
||||||
ds-reg [] temp1 MOV ;
|
ds-reg [] temp1 MOV ;
|
||||||
|
|
||||||
: define-jit-compare ( insn word -- )
|
: define-jit-compare ( insn word -- )
|
||||||
[ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
|
[ [ jit-compare ] curry ] dip define-sub-primitive ;
|
||||||
define-sub-primitive ;
|
|
||||||
|
|
||||||
\ CMOVE \ eq? define-jit-compare
|
\ CMOVE \ eq? define-jit-compare
|
||||||
\ CMOVGE \ fixnum>= define-jit-compare
|
\ CMOVGE \ fixnum>= define-jit-compare
|
||||||
|
@ -357,9 +430,9 @@ big-endian off
|
||||||
! compute result
|
! compute result
|
||||||
[ ds-reg [] temp0 ] dip execute( dst src -- ) ;
|
[ 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
|
! load second input
|
||||||
|
@ -374,20 +447,20 @@ big-endian off
|
||||||
temp0 temp1 IMUL2
|
temp0 temp1 IMUL2
|
||||||
! push result
|
! push result
|
||||||
ds-reg [] temp1 MOV
|
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
|
! complement
|
||||||
ds-reg [] NOT
|
ds-reg [] NOT
|
||||||
! clear tag bits
|
! clear tag bits
|
||||||
ds-reg [] tag-mask get XOR
|
ds-reg [] tag-mask get XOR
|
||||||
] f f f \ fixnum-bitnot define-sub-primitive
|
] \ fixnum-bitnot define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
! load shift count
|
! load shift count
|
||||||
|
@ -411,7 +484,7 @@ big-endian off
|
||||||
temp1 temp3 CMOVGE
|
temp1 temp3 CMOVGE
|
||||||
! push to stack
|
! push to stack
|
||||||
ds-reg [] temp1 MOV
|
ds-reg [] temp1 MOV
|
||||||
] f f f \ fixnum-shift-fast define-sub-primitive
|
] \ fixnum-shift-fast define-sub-primitive
|
||||||
|
|
||||||
: jit-fixnum-/mod ( -- )
|
: jit-fixnum-/mod ( -- )
|
||||||
! load second parameter
|
! load second parameter
|
||||||
|
@ -431,7 +504,7 @@ big-endian off
|
||||||
ds-reg bootstrap-cell SUB
|
ds-reg bootstrap-cell SUB
|
||||||
! push to stack
|
! push to stack
|
||||||
ds-reg [] mod-arg MOV
|
ds-reg [] mod-arg MOV
|
||||||
] f f f \ fixnum-mod define-sub-primitive
|
] \ fixnum-mod define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
jit-fixnum-/mod
|
jit-fixnum-/mod
|
||||||
|
@ -441,7 +514,7 @@ big-endian off
|
||||||
div-arg tag-bits get SHL
|
div-arg tag-bits get SHL
|
||||||
! push to stack
|
! push to stack
|
||||||
ds-reg [] div-arg MOV
|
ds-reg [] div-arg MOV
|
||||||
] f f f \ fixnum/i-fast define-sub-primitive
|
] \ fixnum/i-fast define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
jit-fixnum-/mod
|
jit-fixnum-/mod
|
||||||
|
@ -450,7 +523,7 @@ big-endian off
|
||||||
! push to stack
|
! push to stack
|
||||||
ds-reg [] mod-arg MOV
|
ds-reg [] mod-arg MOV
|
||||||
ds-reg bootstrap-cell neg [+] div-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
|
temp0 ds-reg [] MOV
|
||||||
|
@ -461,7 +534,7 @@ big-endian off
|
||||||
temp1 1 tag-fixnum MOV
|
temp1 1 tag-fixnum MOV
|
||||||
temp0 temp1 CMOVE
|
temp0 temp1 CMOVE
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
] f f f \ both-fixnums? define-sub-primitive
|
] \ both-fixnums? define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
! load local number
|
! load local number
|
||||||
|
@ -472,7 +545,7 @@ big-endian off
|
||||||
temp0 rs-reg temp0 [+] MOV
|
temp0 rs-reg temp0 [+] MOV
|
||||||
! push to stack
|
! push to stack
|
||||||
ds-reg [] temp0 MOV
|
ds-reg [] temp0 MOV
|
||||||
] f f f \ get-local define-sub-primitive
|
] \ get-local define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
! load local count
|
! load local count
|
||||||
|
@ -483,6 +556,6 @@ big-endian off
|
||||||
fixnum>slot@
|
fixnum>slot@
|
||||||
! decrement retain stack pointer
|
! decrement retain stack pointer
|
||||||
rs-reg temp0 SUB
|
rs-reg temp0 SUB
|
||||||
] f f f \ drop-locals define-sub-primitive
|
] \ drop-locals define-sub-primitive
|
||||||
|
|
||||||
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
|
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: alien arrays generic generic.math help.markup help.syntax
|
USING: alien arrays generic generic.math help.markup help.syntax
|
||||||
kernel math memory strings sbufs vectors io io.files classes
|
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 ;
|
alien.libraries ;
|
||||||
IN: debugger
|
IN: debugger
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@ sequences assocs sequences.private strings io.styles
|
||||||
io.pathnames vectors words system splitting math.parser
|
io.pathnames vectors words system splitting math.parser
|
||||||
classes.mixin classes.tuple continuations continuations.private
|
classes.mixin classes.tuple continuations continuations.private
|
||||||
combinators generic.math classes.builtin classes compiler.units
|
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
|
accessors math.order destructors source-files parser
|
||||||
classes.tuple.parser effects.parser lexer
|
classes.tuple.parser effects.parser lexer
|
||||||
generic.parser strings.parser vocabs.loader vocabs.parser see
|
generic.parser strings.parser vocabs.loader vocabs.parser see
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: delegate kernel arrays tools.test words math definitions
|
USING: delegate kernel arrays tools.test words math definitions
|
||||||
compiler.units parser generic prettyprint io.streams.string
|
compiler.units parser generic prettyprint io.streams.string
|
||||||
accessors eval multiline generic.standard delegate.protocols
|
accessors eval multiline generic.single delegate.protocols
|
||||||
delegate.private assocs see ;
|
delegate.private assocs see ;
|
||||||
IN: delegate.tests
|
IN: delegate.tests
|
||||||
|
|
||||||
|
|
|
@ -79,6 +79,13 @@ M: one-word-elt next-elt
|
||||||
drop
|
drop
|
||||||
[ f next-word ] modify-col ;
|
[ f next-word ] modify-col ;
|
||||||
|
|
||||||
|
SINGLETON: word-start-elt
|
||||||
|
|
||||||
|
M: word-start-elt prev-elt
|
||||||
|
drop one-word-elt prev-elt ;
|
||||||
|
|
||||||
|
M: word-start-elt next-elt 2drop ;
|
||||||
|
|
||||||
SINGLETON: word-elt
|
SINGLETON: word-elt
|
||||||
|
|
||||||
M: word-elt prev-elt
|
M: word-elt prev-elt
|
||||||
|
|
|
@ -66,7 +66,7 @@ ERROR: ftp-error got expected ;
|
||||||
: list ( url -- ftp-response )
|
: list ( url -- ftp-response )
|
||||||
utf8 open-passive-client
|
utf8 open-passive-client
|
||||||
ftp-list
|
ftp-list
|
||||||
lines
|
stream-lines
|
||||||
<ftp-response> swap >>strings
|
<ftp-response> swap >>strings
|
||||||
read-response 226 ftp-assert
|
read-response 226 ftp-assert
|
||||||
parse-list ;
|
parse-list ;
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: parser words definitions kernel sequences assocs arrays
|
USING: parser words definitions kernel sequences assocs arrays
|
||||||
kernel.private fry combinators accessors vectors strings sbufs
|
kernel.private fry combinators accessors vectors strings sbufs
|
||||||
byte-arrays byte-vectors io.binary io.streams.string splitting math
|
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 ;
|
hashtables namespaces ;
|
||||||
IN: hints
|
IN: hints
|
||||||
|
|
||||||
|
@ -42,13 +42,13 @@ SYMBOL: specialize-method?
|
||||||
|
|
||||||
t specialize-method? set-global
|
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 ( quot method -- quot' )
|
||||||
[
|
[ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
|
||||||
specialize-method? get [
|
|
||||||
[ "method-class" word-prop ] [ "method-generic" word-prop ] bi
|
|
||||||
method-declaration prepend
|
|
||||||
] [ drop ] if
|
|
||||||
]
|
|
||||||
[ "method-generic" word-prop "specializer" word-prop ] bi
|
[ "method-generic" word-prop "specializer" word-prop ] bi
|
||||||
[ specialize-quot ] when* ;
|
[ specialize-quot ] when* ;
|
||||||
|
|
||||||
|
@ -71,7 +71,7 @@ t specialize-method? set-global
|
||||||
SYNTAX: HINTS:
|
SYNTAX: HINTS:
|
||||||
scan-object
|
scan-object
|
||||||
[ changed-definition ]
|
[ changed-definition ]
|
||||||
[ parse-definition "specializer" set-word-prop ] bi ;
|
[ parse-definition { } like "specializer" set-word-prop ] bi ;
|
||||||
|
|
||||||
! Default specializers
|
! Default specializers
|
||||||
{ first first2 first3 first4 }
|
{ first first2 first3 first4 }
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
USING: http help.markup help.syntax io.pathnames io.streams.string
|
USING: http help.markup help.syntax io.pathnames io.streams.string
|
||||||
io.encodings.8-bit io.encodings.binary kernel strings urls
|
io.encodings.8-bit io.encodings.binary kernel strings urls
|
||||||
urls.encoding byte-arrays strings assocs sequences destructors ;
|
urls.encoding byte-arrays strings assocs sequences destructors
|
||||||
|
http.client.post-data.private ;
|
||||||
IN: http.client
|
IN: http.client
|
||||||
|
|
||||||
HELP: download-failed
|
HELP: download-failed
|
||||||
|
@ -71,7 +72,7 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client"
|
||||||
{ $subsection with-http-get }
|
{ $subsection with-http-get }
|
||||||
{ $subsection with-http-request } ;
|
{ $subsection with-http-request } ;
|
||||||
|
|
||||||
ARTICLE: "http.client.post-data" "HTTP client submission data"
|
ARTICLE: "http.client.post-data" "HTTP client post data"
|
||||||
"HTTP POST and PUT request words take a post data parameter, which can be one of the following:"
|
"HTTP POST and PUT request words take a post data parameter, which can be one of the following:"
|
||||||
{ $list
|
{ $list
|
||||||
{ "a " { $link byte-array } ": the data is sent the server without further encoding" }
|
{ "a " { $link byte-array } ": the data is sent the server without further encoding" }
|
||||||
|
@ -85,7 +86,9 @@ ARTICLE: "http.client.post-data" "HTTP client submission data"
|
||||||
{ $code
|
{ $code
|
||||||
"\"my-large-post-request.txt\" ascii <file-reader>"
|
"\"my-large-post-request.txt\" ascii <file-reader>"
|
||||||
"[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal"
|
"[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal"
|
||||||
} ;
|
}
|
||||||
|
"An internal word used to convert objects to " { $link post-data } " instances:"
|
||||||
|
{ $subsection >post-data } ;
|
||||||
|
|
||||||
ARTICLE: "http.client.post" "POST requests with the HTTP client"
|
ARTICLE: "http.client.post" "POST requests with the HTTP client"
|
||||||
"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"
|
"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"
|
||||||
|
|
|
@ -0,0 +1,6 @@
|
||||||
|
IN: http.client.post-data
|
||||||
|
USING: http http.client.post-data.private help.markup help.syntax kernel ;
|
||||||
|
|
||||||
|
HELP: >post-data
|
||||||
|
{ $values { "object" object } { "post-data" { $maybe post-data } } }
|
||||||
|
{ $description "Converts an object into a " { $link post-data } " tuple instance." } ;
|
|
@ -46,7 +46,7 @@ M: winnt add-completion ( win32-handle -- )
|
||||||
{ [ dup integer? ] [ ] }
|
{ [ dup integer? ] [ ] }
|
||||||
{ [ dup array? ] [
|
{ [ dup array? ] [
|
||||||
first dup eof?
|
first dup eof?
|
||||||
[ drop 0 ] [ (win32-error-string) throw ] if
|
[ drop 0 ] [ n>win32-error-string throw ] if
|
||||||
] }
|
] }
|
||||||
} cond
|
} cond
|
||||||
] with-timeout ;
|
] with-timeout ;
|
||||||
|
@ -105,7 +105,7 @@ M: winnt seek-handle ( n seek-type handle -- )
|
||||||
GetLastError {
|
GetLastError {
|
||||||
{ [ dup expected-io-error? ] [ drop f ] }
|
{ [ dup expected-io-error? ] [ drop f ] }
|
||||||
{ [ dup eof? ] [ drop t ] }
|
{ [ dup eof? ] [ drop t ] }
|
||||||
[ (win32-error-string) throw ]
|
[ n>win32-error-string throw ]
|
||||||
} cond
|
} cond
|
||||||
] [ f ] if ;
|
] [ f ] if ;
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@ USING: alien alien.c-types alien.syntax arrays continuations
|
||||||
destructors generic io.mmap io.ports io.backend.windows io.files.windows
|
destructors generic io.mmap io.ports io.backend.windows io.files.windows
|
||||||
kernel libc math math.bitwise namespaces quotations sequences windows
|
kernel libc math math.bitwise namespaces quotations sequences windows
|
||||||
windows.advapi32 windows.kernel32 io.backend system accessors
|
windows.advapi32 windows.kernel32 io.backend system accessors
|
||||||
io.backend.windows.privileges ;
|
io.backend.windows.privileges windows.errors ;
|
||||||
IN: io.backend.windows.nt.privileges
|
IN: io.backend.windows.nt.privileges
|
||||||
|
|
||||||
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
|
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types arrays destructors io io.backend
|
USING: alien alien.c-types arrays destructors io io.backend
|
||||||
io.buffers io.files io.ports io.binary io.timeouts
|
io.buffers io.files io.ports io.binary io.timeouts system
|
||||||
windows.errors strings kernel math namespaces sequences windows
|
windows.errors strings kernel math namespaces sequences
|
||||||
windows.kernel32 windows.shell32 windows.types windows.winsock
|
windows.errors windows.kernel32 windows.shell32 windows.types
|
||||||
splitting continuations math.bitwise system accessors ;
|
windows.winsock splitting continuations math.bitwise accessors ;
|
||||||
IN: io.backend.windows
|
IN: io.backend.windows
|
||||||
|
|
||||||
: set-inherit ( handle ? -- )
|
: set-inherit ( handle ? -- )
|
||||||
|
@ -51,4 +51,4 @@ HOOK: add-completion io-backend ( port -- )
|
||||||
: default-security-attributes ( -- obj )
|
: default-security-attributes ( -- obj )
|
||||||
"SECURITY_ATTRIBUTES" <c-object>
|
"SECURITY_ATTRIBUTES" <c-object>
|
||||||
"SECURITY_ATTRIBUTES" heap-size
|
"SECURITY_ATTRIBUTES" heap-size
|
||||||
over set-SECURITY_ATTRIBUTES-nLength ;
|
over set-SECURITY_ATTRIBUTES-nLength ;
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: io io.streams.byte-array ;
|
||||||
IN: io.encodings.string
|
IN: io.encodings.string
|
||||||
|
|
||||||
: decode ( byte-array encoding -- string )
|
: decode ( byte-array encoding -- string )
|
||||||
<byte-reader> contents ;
|
<byte-reader> stream-contents ;
|
||||||
|
|
||||||
: encode ( string encoding -- byte-array )
|
: encode ( string encoding -- byte-array )
|
||||||
[ write ] with-byte-writer ;
|
[ write ] with-byte-writer ;
|
||||||
|
|
|
@ -5,6 +5,10 @@ HELP: make-link
|
||||||
{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
|
{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
|
||||||
{ $description "Creates a symbolic link." } ;
|
{ $description "Creates a symbolic link." } ;
|
||||||
|
|
||||||
|
HELP: make-hard-link
|
||||||
|
{ $values { "target" "a path to the hard link's target" } { "link" "a path to new symbolic link" } }
|
||||||
|
{ $description "Creates a hard link." } ;
|
||||||
|
|
||||||
HELP: read-link
|
HELP: read-link
|
||||||
{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
|
{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
|
||||||
{ $description "Reads the symbolic link and returns its target path." } ;
|
{ $description "Reads the symbolic link and returns its target path." } ;
|
||||||
|
|
|
@ -6,6 +6,8 @@ IN: io.files.links
|
||||||
|
|
||||||
HOOK: make-link os ( target symlink -- )
|
HOOK: make-link os ( target symlink -- )
|
||||||
|
|
||||||
|
HOOK: make-hard-link os ( target link -- )
|
||||||
|
|
||||||
HOOK: read-link os ( symlink -- path )
|
HOOK: read-link os ( symlink -- path )
|
||||||
|
|
||||||
: copy-link ( target symlink -- )
|
: copy-link ( target symlink -- )
|
||||||
|
|
|
@ -7,6 +7,9 @@ IN: io.files.links.unix
|
||||||
M: unix make-link ( path1 path2 -- )
|
M: unix make-link ( path1 path2 -- )
|
||||||
normalize-path symlink io-error ;
|
normalize-path symlink io-error ;
|
||||||
|
|
||||||
|
M: unix make-hard-link ( path1 path2 -- )
|
||||||
|
normalize-path link io-error ;
|
||||||
|
|
||||||
M: unix read-link ( path -- path' )
|
M: unix read-link ( path -- path' )
|
||||||
normalize-path read-symbolic-link ;
|
normalize-path read-symbolic-link ;
|
||||||
|
|
||||||
|
|
|
@ -4,7 +4,8 @@ io.backend.windows io.files.windows io.encodings.utf16n windows
|
||||||
windows.kernel32 kernel libc math threads system environment
|
windows.kernel32 kernel libc math threads system environment
|
||||||
alien.c-types alien.arrays alien.strings sequences combinators
|
alien.c-types alien.arrays alien.strings sequences combinators
|
||||||
combinators.short-circuit ascii splitting alien strings assocs
|
combinators.short-circuit ascii splitting alien strings assocs
|
||||||
namespaces make accessors tr windows.time windows.shell32 ;
|
namespaces make accessors tr windows.time windows.shell32
|
||||||
|
windows.errors ;
|
||||||
IN: io.files.windows.nt
|
IN: io.files.windows.nt
|
||||||
|
|
||||||
M: winnt cwd
|
M: winnt cwd
|
||||||
|
|
|
@ -3,9 +3,9 @@
|
||||||
USING: system kernel namespaces strings hashtables sequences
|
USING: system kernel namespaces strings hashtables sequences
|
||||||
assocs combinators vocabs.loader init threads continuations
|
assocs combinators vocabs.loader init threads continuations
|
||||||
math accessors concurrency.flags destructors environment
|
math accessors concurrency.flags destructors environment
|
||||||
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
|
io io.encodings.ascii io.backend io.timeouts io.pipes
|
||||||
io.streams.duplex io.ports debugger prettyprint summary
|
io.pipes.private io.encodings io.streams.duplex io.ports
|
||||||
calendar ;
|
debugger prettyprint summary calendar ;
|
||||||
IN: io.launcher
|
IN: io.launcher
|
||||||
|
|
||||||
TUPLE: process < identity-tuple
|
TUPLE: process < identity-tuple
|
||||||
|
@ -265,3 +265,5 @@ M: object run-pipeline-element
|
||||||
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] }
|
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] }
|
||||||
[ ]
|
[ ]
|
||||||
} cond
|
} cond
|
||||||
|
|
||||||
|
: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;
|
||||||
|
|
|
@ -33,7 +33,7 @@ concurrency.promises threads unix.process ;
|
||||||
"cat"
|
"cat"
|
||||||
"launcher-test-1" temp-file
|
"launcher-test-1" temp-file
|
||||||
2array
|
2array
|
||||||
ascii <process-reader> contents
|
ascii <process-reader> stream-contents
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -52,7 +52,7 @@ concurrency.promises threads unix.process ;
|
||||||
"cat"
|
"cat"
|
||||||
"launcher-test-1" temp-file
|
"launcher-test-1" temp-file
|
||||||
2array
|
2array
|
||||||
ascii <process-reader> contents
|
ascii <process-reader> stream-contents
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -70,14 +70,14 @@ concurrency.promises threads unix.process ;
|
||||||
"cat"
|
"cat"
|
||||||
"launcher-test-1" temp-file
|
"launcher-test-1" temp-file
|
||||||
2array
|
2array
|
||||||
ascii <process-reader> contents
|
ascii <process-reader> stream-contents
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
<process>
|
<process>
|
||||||
"env" >>command
|
"env" >>command
|
||||||
{ { "A" "B" } } >>environment
|
{ { "A" "B" } } >>environment
|
||||||
ascii <process-reader> lines
|
ascii <process-reader> stream-lines
|
||||||
"A=B" swap member?
|
"A=B" swap member?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -86,7 +86,7 @@ concurrency.promises threads unix.process ;
|
||||||
"env" >>command
|
"env" >>command
|
||||||
{ { "A" "B" } } >>environment
|
{ { "A" "B" } } >>environment
|
||||||
+replace-environment+ >>environment-mode
|
+replace-environment+ >>environment-mode
|
||||||
ascii <process-reader> lines
|
ascii <process-reader> stream-lines
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "hi\n" ] [
|
[ "hi\n" ] [
|
||||||
|
@ -113,13 +113,13 @@ concurrency.promises threads unix.process ;
|
||||||
"append-test" temp-file utf8 file-contents
|
"append-test" temp-file utf8 file-contents
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
|
[ t ] [ "ls" utf8 <process-stream> stream-contents >boolean ] unit-test
|
||||||
|
|
||||||
[ "Hello world.\n" ] [
|
[ "Hello world.\n" ] [
|
||||||
"cat" utf8 <process-stream> [
|
"cat" utf8 <process-stream> [
|
||||||
"Hello world.\n" write
|
"Hello world.\n" write
|
||||||
output-stream get dispose
|
output-stream get dispose
|
||||||
input-stream get contents
|
input-stream get stream-contents
|
||||||
] with-stream
|
] with-stream
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@ USING: alien alien.c-types arrays destructors generic io.mmap
|
||||||
io.ports io.backend.windows io.files.windows io.backend.windows.privileges
|
io.ports io.backend.windows io.files.windows io.backend.windows.privileges
|
||||||
kernel libc math math.bitwise namespaces quotations sequences
|
kernel libc math math.bitwise namespaces quotations sequences
|
||||||
windows windows.advapi32 windows.kernel32 io.backend system
|
windows windows.advapi32 windows.kernel32 io.backend system
|
||||||
accessors locals ;
|
accessors locals windows.errors ;
|
||||||
IN: io.mmap.windows
|
IN: io.mmap.windows
|
||||||
|
|
||||||
: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
|
: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
|
||||||
|
@ -12,8 +12,8 @@ IN: io.mmap.windows
|
||||||
MapViewOfFile [ win32-error=0/f ] keep ;
|
MapViewOfFile [ win32-error=0/f ] keep ;
|
||||||
|
|
||||||
:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
|
:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
|
||||||
[let | lo [ length HEX: ffffffff bitand ]
|
[let | lo [ length 32 bits ]
|
||||||
hi [ length -32 shift HEX: ffffffff bitand ] |
|
hi [ length -32 shift 32 bits ] |
|
||||||
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
|
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
|
||||||
path access-mode create-mode 0 open-file |dispose
|
path access-mode create-mode 0 open-file |dispose
|
||||||
dup handle>> f protect hi lo f create-file-mapping |dispose
|
dup handle>> f protect hi lo f create-file-mapping |dispose
|
||||||
|
|
|
@ -6,7 +6,7 @@ hashtables sorting arrays combinators math.bitwise strings
|
||||||
system accessors threads splitting io.backend io.backend.windows
|
system accessors threads splitting io.backend io.backend.windows
|
||||||
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
|
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
|
||||||
io.buffers io.files io.timeouts io.encodings.string
|
io.buffers io.files io.timeouts io.encodings.string
|
||||||
io.encodings.utf16n io windows windows.kernel32 windows.types
|
io.encodings.utf16n io windows.errors windows.kernel32 windows.types
|
||||||
io.pathnames ;
|
io.pathnames ;
|
||||||
IN: io.monitors.windows.nt
|
IN: io.monitors.windows.nt
|
||||||
|
|
||||||
|
|
|
@ -35,4 +35,4 @@ concurrency.promises io.encodings.ascii io threads calendar ;
|
||||||
dup start-server* sockets>> first addr>> port>> "port" set
|
dup start-server* sockets>> first addr>> port>> "port" set
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop contents ] unit-test
|
[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop stream-contents ] unit-test
|
||||||
|
|
|
@ -23,7 +23,7 @@ io.sockets.secure.unix.debug ;
|
||||||
|
|
||||||
: client-test ( -- string )
|
: client-test ( -- string )
|
||||||
<secure-config> [
|
<secure-config> [
|
||||||
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
|
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop stream-contents
|
||||||
] with-secure-context ;
|
] with-secure-context ;
|
||||||
|
|
||||||
[ ] [ [ class name>> write ] server-test ] unit-test
|
[ ] [ [ class name>> write ] server-test ] unit-test
|
||||||
|
|
|
@ -6,7 +6,7 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
|
||||||
|
|
||||||
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
|
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
|
||||||
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
|
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
|
||||||
[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
|
[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> stream-contents dup >array swap string? ] unit-test
|
||||||
|
|
||||||
[ B{ 121 120 } 0 ] [
|
[ B{ 121 120 } 0 ] [
|
||||||
B{ 0 121 120 0 0 0 0 0 0 } binary
|
B{ 0 121 120 0 0 0 0 0 0 } binary
|
||||||
|
@ -26,4 +26,4 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
|
||||||
0 seek-end input-stream get stream-seek
|
0 seek-end input-stream get stream-seek
|
||||||
read1
|
read1
|
||||||
] with-byte-reader
|
] with-byte-reader
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -1,17 +1,17 @@
|
||||||
USING: help.markup help.syntax io.streams.plain io strings
|
USING: help.markup help.syntax io.streams.plain io strings
|
||||||
hashtables kernel quotations colors ;
|
hashtables kernel quotations colors assocs ;
|
||||||
IN: io.styles
|
IN: io.styles
|
||||||
|
|
||||||
HELP: stream-format
|
HELP: stream-format
|
||||||
{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } }
|
{ $values { "str" string } { "style" assoc } { "stream" "an output stream" } }
|
||||||
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
|
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
|
||||||
$nl
|
$nl
|
||||||
"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
|
"The " { $snippet "style" } " assoc holds character style information. See " { $link "character-styles" } "." }
|
||||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
|
{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: make-block-stream
|
HELP: make-block-stream
|
||||||
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
|
{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
|
||||||
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
|
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
|
||||||
$nl
|
$nl
|
||||||
"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
|
"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
|
||||||
|
@ -21,7 +21,7 @@ $nl
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: stream-write-table
|
HELP: stream-write-table
|
||||||
{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } }
|
{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" assoc } { "stream" "an output stream" } }
|
||||||
{ $contract "Prints a table of cells produced by " { $link with-cell } "."
|
{ $contract "Prints a table of cells produced by " { $link with-cell } "."
|
||||||
$nl
|
$nl
|
||||||
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
|
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
|
||||||
|
@ -29,13 +29,13 @@ $nl
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: make-cell-stream
|
HELP: make-cell-stream
|
||||||
{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
|
{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" object } }
|
||||||
{ $contract "Creates an output stream which writes to a table cell object." }
|
{ $contract "Creates an output stream which writes to a table cell object." }
|
||||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
|
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: make-span-stream
|
HELP: make-span-stream
|
||||||
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
|
{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
|
||||||
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
|
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
|
||||||
$nl
|
$nl
|
||||||
"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
|
"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
|
||||||
|
@ -43,19 +43,19 @@ $nl
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: format
|
HELP: format
|
||||||
{ $values { "str" string } { "style" "a hashtable" } }
|
{ $values { "str" string } { "style" assoc } }
|
||||||
{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
|
{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
|
||||||
{ $notes "Details are in the documentation for " { $link stream-format } "." }
|
{ $notes "Details are in the documentation for " { $link stream-format } "." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: with-nesting
|
HELP: with-nesting
|
||||||
{ $values { "style" "a hashtable" } { "quot" quotation } }
|
{ $values { "style" assoc } { "quot" quotation } }
|
||||||
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
|
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
|
||||||
{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
|
{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: tabular-output
|
HELP: tabular-output
|
||||||
{ $values { "style" "a hashtable" } { "quot" quotation } }
|
{ $values { "style" assoc } { "quot" quotation } }
|
||||||
{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
|
{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
|
||||||
$nl
|
$nl
|
||||||
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
|
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
|
||||||
|
@ -85,7 +85,7 @@ HELP: write-cell
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: with-style
|
HELP: with-style
|
||||||
{ $values { "style" "a hashtable" } { "quot" quotation } }
|
{ $values { "style" assoc } { "quot" quotation } }
|
||||||
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
|
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
|
||||||
{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
|
{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
|
@ -99,7 +99,11 @@ M: plain-writer make-block-stream
|
||||||
nip <ignore-close-stream> ;
|
nip <ignore-close-stream> ;
|
||||||
|
|
||||||
M: plain-writer stream-write-table
|
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> ;
|
M: plain-writer make-cell-stream 2drop <string-writer> ;
|
||||||
|
|
||||||
|
|
|
@ -585,4 +585,4 @@ M: integer ed's-bug neg ;
|
||||||
:: ed's-test-case ( a -- b )
|
:: ed's-test-case ( a -- b )
|
||||||
{ [ a ed's-bug ] } && ;
|
{ [ a ed's-bug ] } && ;
|
||||||
|
|
||||||
[ t ] [ \ ed's-test-case optimized>> ] unit-test
|
[ t ] [ \ ed's-test-case optimized? ] unit-test
|
||||||
|
|
|
@ -49,6 +49,7 @@ $nl
|
||||||
{ $subsection POSTPONE: MACRO: }
|
{ $subsection POSTPONE: MACRO: }
|
||||||
"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion."
|
"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion."
|
||||||
{ $subsection define-transform }
|
{ $subsection define-transform }
|
||||||
"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ;
|
"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated."
|
||||||
|
{ $see-also "generalizations" "fry" } ;
|
||||||
|
|
||||||
ABOUT: "macros"
|
ABOUT: "macros"
|
||||||
|
|
|
@ -25,7 +25,3 @@ HELP: complex
|
||||||
{ $class-description "The class of complex numbers with non-zero imaginary part." } ;
|
{ $class-description "The class of complex numbers with non-zero imaginary part." } ;
|
||||||
|
|
||||||
ABOUT: "complex-numbers"
|
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." } ;
|
|
||||||
|
|
|
@ -15,14 +15,14 @@ M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ;
|
||||||
: complex= ( x y quot -- ? ) componentwise and ; inline
|
: complex= ( x y quot -- ? ) componentwise and ; inline
|
||||||
M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ;
|
M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ;
|
||||||
M: complex number= [ number= ] complex= ;
|
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 ;
|
||||||
M: complex - [ - ] complex-op ;
|
M: complex - [ - ] complex-op ;
|
||||||
: *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline
|
: *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
|
: *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 -- 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 / [ / ] complex/ ;
|
||||||
M: complex /f [ /f ] complex/ ;
|
M: complex /f [ /f ] complex/ ;
|
||||||
M: complex /i [ /i ] complex/ ;
|
M: complex /i [ /i ] complex/ ;
|
||||||
|
|
|
@ -100,11 +100,6 @@ ARTICLE: "math-functions" "Mathematical functions"
|
||||||
|
|
||||||
ABOUT: "math-functions"
|
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>
|
HELP: rect>
|
||||||
{ $values { "x" real } { "y" real } { "z" number } }
|
{ $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" } "." } ;
|
{ $description "Creates a complex number from real and imaginary components. If " { $snippet "z" } " is an integer zero, this will simply output " { $snippet "x" } "." } ;
|
||||||
|
|
|
@ -7,19 +7,8 @@ IN: math.functions
|
||||||
: >fraction ( a/b -- a b )
|
: >fraction ( a/b -- a b )
|
||||||
[ numerator ] [ denominator ] bi ; inline
|
[ numerator ] [ denominator ] bi ; inline
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
: (rect>) ( x y -- z )
|
|
||||||
dup 0 = [ drop ] [ <complex> ] if ; inline
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: rect> ( x y -- z )
|
: rect> ( x y -- z )
|
||||||
2dup [ real? ] both? [
|
dup 0 = [ drop ] [ complex boa ] if ; inline
|
||||||
(rect>)
|
|
||||||
] [
|
|
||||||
"Complex number must have real components" throw
|
|
||||||
] if ; inline
|
|
||||||
|
|
||||||
GENERIC: sqrt ( x -- y ) foldable
|
GENERIC: sqrt ( x -- y ) foldable
|
||||||
|
|
||||||
|
|
|
@ -47,6 +47,3 @@ HELP: 2>fraction
|
||||||
{ $values { "a/b" rational } { "c/d" rational } { "a" integer } { "c" integer } { "b" "a positive integer" } { "d" "a positive integer" } }
|
{ $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." } ;
|
{ $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." } ;
|
|
||||||
|
|
|
@ -9,7 +9,7 @@ IN: math.ratios
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: fraction> ( a b -- a/b )
|
: 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 )
|
: scale ( a/b c/d -- a*d b*c )
|
||||||
2>fraction [ * swap ] dip * swap ; inline
|
2>fraction [ * swap ] dip * swap ; inline
|
||||||
|
|
|
@ -199,10 +199,10 @@ IN: peg.tests
|
||||||
|
|
||||||
USE: compiler
|
USE: compiler
|
||||||
|
|
||||||
[ ] [ disable-compiler ] unit-test
|
[ ] [ disable-optimizer ] unit-test
|
||||||
|
|
||||||
[ ] [ "" epsilon parse drop ] unit-test
|
[ ] [ "" epsilon parse drop ] unit-test
|
||||||
|
|
||||||
[ ] [ enable-compiler ] unit-test
|
[ ] [ enable-optimizer ] unit-test
|
||||||
|
|
||||||
[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
|
[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: accessors alien.c-types byte-arrays continuations
|
USING: accessors alien.c-types byte-arrays continuations
|
||||||
kernel windows windows.advapi32 init namespaces random
|
kernel windows.advapi32 init namespaces random destructors
|
||||||
destructors locals ;
|
locals windows.errors ;
|
||||||
IN: random.windows
|
IN: random.windows
|
||||||
|
|
||||||
TUPLE: windows-rng provider type ;
|
TUPLE: windows-rng provider type ;
|
||||||
|
|
|
@ -1,14 +1,18 @@
|
||||||
! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
|
! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: boxes help.markup help.syntax kernel math namespaces ;
|
USING: boxes help.markup help.syntax kernel math namespaces assocs ;
|
||||||
IN: refs
|
IN: refs
|
||||||
|
|
||||||
ARTICLE: "refs" "References"
|
ARTICLE: "refs" "References"
|
||||||
"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "."
|
"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing a protocol."
|
||||||
{ $subsection get-ref }
|
{ $subsection "refs-protocol" }
|
||||||
{ $subsection set-ref }
|
{ $subsection "refs-impls" }
|
||||||
{ $subsection set-ref* }
|
{ $subsection "refs-utils" }
|
||||||
{ $subsection delete-ref }
|
"References are used by the " { $link "ui-inspector" } "." ;
|
||||||
|
|
||||||
|
ABOUT: "refs"
|
||||||
|
|
||||||
|
ARTICLE: "refs-impls" "Reference implementations"
|
||||||
"References to objects:"
|
"References to objects:"
|
||||||
{ $subsection obj-ref }
|
{ $subsection obj-ref }
|
||||||
{ $subsection <obj-ref> }
|
{ $subsection <obj-ref> }
|
||||||
|
@ -27,20 +31,24 @@ ARTICLE: "refs" "References"
|
||||||
{ $subsection slot-ref }
|
{ $subsection slot-ref }
|
||||||
{ $subsection <slot-ref> }
|
{ $subsection <slot-ref> }
|
||||||
"Using boxes as references:"
|
"Using boxes as references:"
|
||||||
{ $subsection "box-refs" }
|
{ $subsection "box-refs" } ;
|
||||||
"References are used by the UI inspector." ;
|
|
||||||
|
|
||||||
ABOUT: "refs"
|
ARTICLE: "refs-utils" "Reference utilities"
|
||||||
|
{ $subsection ref-on }
|
||||||
|
{ $subsection ref-off }
|
||||||
|
{ $subsection ref-inc }
|
||||||
|
{ $subsection ref-dec }
|
||||||
|
{ $subsection set-ref* } ;
|
||||||
|
|
||||||
ARTICLE: "refs-protocol" "Reference Protocol"
|
ARTICLE: "refs-protocol" "Reference protocol"
|
||||||
"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:"
|
"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:"
|
||||||
{ $subsection get-ref }
|
{ $subsection get-ref }
|
||||||
{ $subsection set-ref }
|
{ $subsection set-ref }
|
||||||
"References may also implement:"
|
"References may also implement:"
|
||||||
{ $subsection delete-ref } ;
|
{ $subsection delete-ref } ;
|
||||||
|
|
||||||
ARTICLE: "box-refs" "Using Boxes as References"
|
ARTICLE: "box-refs" "Boxes as references"
|
||||||
"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
|
{ $link "boxes" } " are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
|
||||||
|
|
||||||
HELP: ref
|
HELP: ref
|
||||||
{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ;
|
{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ;
|
||||||
|
@ -89,14 +97,14 @@ HELP: key-ref
|
||||||
{ $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link <key-ref> } "." } ;
|
{ $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link <key-ref> } "." } ;
|
||||||
|
|
||||||
HELP: <key-ref>
|
HELP: <key-ref>
|
||||||
{ $values { "assoc" "an assoc" } { "key" object } { "key-ref" key-ref } }
|
{ $values { "assoc" assoc } { "key" object } { "key-ref" key-ref } }
|
||||||
{ $description "Creates a reference to a key stored in an assoc." } ;
|
{ $description "Creates a reference to a key stored in an assoc." } ;
|
||||||
|
|
||||||
HELP: value-ref
|
HELP: value-ref
|
||||||
{ $class-description "Instances of this class identify a value associated to a key in an associative structure. New value references are created by calling " { $link <value-ref> } "." } ;
|
{ $class-description "Instances of this class identify a value associated to a key in an associative structure. New value references are created by calling " { $link <value-ref> } "." } ;
|
||||||
|
|
||||||
HELP: <value-ref>
|
HELP: <value-ref>
|
||||||
{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } }
|
{ $values { "assoc" assoc } { "key" object } { "value-ref" value-ref } }
|
||||||
{ $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ;
|
{ $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ;
|
||||||
|
|
||||||
{ get-ref set-ref delete-ref set-ref* } related-words
|
{ get-ref set-ref delete-ref set-ref* } related-words
|
||||||
|
|
|
@ -1,13 +1,13 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays assocs classes classes.builtin
|
USING: accessors arrays assocs classes classes.builtin
|
||||||
classes.intersection classes.mixin classes.predicate
|
classes.intersection classes.mixin classes.predicate classes.singleton
|
||||||
classes.singleton classes.tuple classes.union combinators
|
classes.tuple classes.union combinators definitions effects generic
|
||||||
definitions effects generic generic.standard io io.pathnames
|
generic.single generic.standard generic.hook io io.pathnames
|
||||||
io.streams.string io.styles kernel make namespaces prettyprint
|
io.streams.string io.styles kernel make namespaces prettyprint
|
||||||
prettyprint.backend prettyprint.config prettyprint.custom
|
prettyprint.backend prettyprint.config prettyprint.custom
|
||||||
prettyprint.sections sequences sets sorting strings summary
|
prettyprint.sections sequences sets sorting strings summary words
|
||||||
words words.symbol words.constant words.alias ;
|
words.symbol words.constant words.alias ;
|
||||||
IN: see
|
IN: see
|
||||||
|
|
||||||
GENERIC: synopsis* ( defspec -- )
|
GENERIC: synopsis* ( defspec -- )
|
||||||
|
|
|
@ -1,10 +1,9 @@
|
||||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: fry arrays generic io io.streams.string kernel math
|
USING: fry arrays generic io io.streams.string kernel math namespaces
|
||||||
namespaces parser sequences strings vectors words quotations
|
parser sequences strings vectors words quotations effects classes
|
||||||
effects classes continuations assocs combinators
|
continuations assocs combinators compiler.errors accessors math.order
|
||||||
compiler.errors accessors math.order definitions sets
|
definitions sets hints macros stack-checker.state
|
||||||
generic.standard.engines.tuple hints macros stack-checker.state
|
|
||||||
stack-checker.visitor stack-checker.errors stack-checker.values
|
stack-checker.visitor stack-checker.errors stack-checker.values
|
||||||
stack-checker.recursive-state ;
|
stack-checker.recursive-state ;
|
||||||
IN: stack-checker.backend
|
IN: stack-checker.backend
|
||||||
|
|
|
@ -1,7 +1,16 @@
|
||||||
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
|
IN: stack-checker.call-effect.tests
|
||||||
|
|
||||||
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
|
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
|
||||||
[ t ] [ \ + (( a b c -- d e )) 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 ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
|
||||||
[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
|
[ 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
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors combinators combinators.private effects fry
|
USING: accessors combinators combinators.private effects fry
|
||||||
kernel kernel.private make sequences continuations quotations
|
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
|
IN: stack-checker.call-effect
|
||||||
|
|
||||||
! call( and execute( have complex expansions.
|
! call( and execute( have complex expansions.
|
||||||
|
@ -18,14 +18,36 @@ IN: stack-checker.call-effect
|
||||||
|
|
||||||
TUPLE: inline-cache value ;
|
TUPLE: inline-cache value ;
|
||||||
|
|
||||||
: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline
|
: cache-hit? ( word/quot ic -- ? )
|
||||||
|
[ value>> eq? ] [ value>> ] bi and ; inline
|
||||||
|
|
||||||
SYMBOL: +unknown+
|
SINGLETON: +unknown+
|
||||||
|
|
||||||
GENERIC: cached-effect ( quot -- effect )
|
GENERIC: cached-effect ( quot -- effect )
|
||||||
|
|
||||||
M: object cached-effect drop +unknown+ ;
|
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
|
M: quotation cached-effect
|
||||||
dup cached-effect>>
|
dup cached-effect>>
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -79,7 +101,7 @@ M: quotation cached-effect
|
||||||
[ '[ _ execute ] ] dip call-effect-slow ; inline
|
[ '[ _ execute ] ] dip call-effect-slow ; inline
|
||||||
|
|
||||||
: execute-effect-unsafe? ( word effect -- ? )
|
: 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 -- )
|
: execute-effect-fast ( word effect inline-cache -- )
|
||||||
2over execute-effect-unsafe?
|
2over execute-effect-unsafe?
|
||||||
|
|
|
@ -84,8 +84,11 @@ HELP: inconsistent-recursive-call-error
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "inference-errors" "Stack checker errors"
|
ARTICLE: "inference-errors" "Stack checker errors"
|
||||||
"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "."
|
"These " { $link "inference" } " failure conditions are reported in one of two ways:"
|
||||||
$nl
|
{ $list
|
||||||
|
{ { $link "tools.inference" } " throws them as errors" }
|
||||||
|
{ "The " { $link "compiler" } " reports them via " { $link "tools.errors" } }
|
||||||
|
}
|
||||||
"Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):"
|
"Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):"
|
||||||
{ $subsection literal-expected }
|
{ $subsection literal-expected }
|
||||||
"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:"
|
"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:"
|
||||||
|
|
|
@ -33,4 +33,6 @@ ERROR: unknown-primitive-error < inference-error ;
|
||||||
|
|
||||||
ERROR: transform-expansion-error < inference-error word error ;
|
ERROR: transform-expansion-error < inference-error word error ;
|
||||||
|
|
||||||
|
ERROR: bad-declaration-error < inference-error declaration ;
|
||||||
|
|
||||||
M: object (literal) "literal value" literal-expected ;
|
M: object (literal) "literal value" literal-expected ;
|
|
@ -9,9 +9,10 @@ quotations quotations.private sbufs sbufs.private
|
||||||
sequences sequences.private slots.private strings
|
sequences sequences.private slots.private strings
|
||||||
strings.private system threads.private classes.tuple
|
strings.private system threads.private classes.tuple
|
||||||
classes.tuple.private vectors vectors.private words definitions
|
classes.tuple.private vectors vectors.private words definitions
|
||||||
words.private assocs summary compiler.units system.private
|
assocs summary compiler.units system.private
|
||||||
combinators locals locals.backend locals.types words.private
|
combinators combinators.short-circuit locals locals.backend locals.types
|
||||||
quotations.private combinators.private stack-checker.values
|
quotations.private combinators.private stack-checker.values
|
||||||
|
generic.single generic.single.private
|
||||||
alien.libraries
|
alien.libraries
|
||||||
stack-checker.alien
|
stack-checker.alien
|
||||||
stack-checker.state
|
stack-checker.state
|
||||||
|
@ -57,8 +58,12 @@ IN: stack-checker.known-words
|
||||||
: infer-shuffle-word ( word -- )
|
: infer-shuffle-word ( word -- )
|
||||||
"shuffle" word-prop infer-shuffle ;
|
"shuffle" word-prop infer-shuffle ;
|
||||||
|
|
||||||
|
: check-declaration ( declaration -- declaration )
|
||||||
|
dup { [ array? ] [ [ class? ] all? ] } 1&&
|
||||||
|
[ bad-declaration-error ] unless ;
|
||||||
|
|
||||||
: infer-declare ( -- )
|
: infer-declare ( -- )
|
||||||
pop-literal nip
|
pop-literal nip check-declaration
|
||||||
[ length ensure-d ] keep zip
|
[ length ensure-d ] keep zip
|
||||||
#declare, ;
|
#declare, ;
|
||||||
|
|
||||||
|
@ -142,7 +147,7 @@ M: object infer-call*
|
||||||
apply-word/effect ;
|
apply-word/effect ;
|
||||||
|
|
||||||
: infer-execute-effect-unsafe ( -- )
|
: infer-execute-effect-unsafe ( -- )
|
||||||
\ execute infer-effect-unsafe ;
|
\ (execute) infer-effect-unsafe ;
|
||||||
|
|
||||||
: infer-call-effect-unsafe ( -- )
|
: infer-call-effect-unsafe ( -- )
|
||||||
\ call infer-effect-unsafe ;
|
\ call infer-effect-unsafe ;
|
||||||
|
@ -227,14 +232,7 @@ M: object infer-call*
|
||||||
|
|
||||||
! More words not to compile
|
! More words not to compile
|
||||||
\ call t "no-compile" set-word-prop
|
\ call t "no-compile" set-word-prop
|
||||||
\ call subwords [ t "no-compile" set-word-prop ] each
|
|
||||||
|
|
||||||
\ execute t "no-compile" set-word-prop
|
\ 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
|
\ clear t "no-compile" set-word-prop
|
||||||
|
|
||||||
: non-inline-word ( word -- )
|
: non-inline-word ( word -- )
|
||||||
|
@ -292,9 +290,6 @@ M: object infer-call*
|
||||||
\ bignum>float { bignum } { float } define-primitive
|
\ bignum>float { bignum } { float } define-primitive
|
||||||
\ bignum>float make-foldable
|
\ bignum>float make-foldable
|
||||||
|
|
||||||
\ <ratio> { integer integer } { ratio } define-primitive
|
|
||||||
\ <ratio> make-foldable
|
|
||||||
|
|
||||||
\ string>float { string } { float } define-primitive
|
\ string>float { string } { float } define-primitive
|
||||||
\ string>float make-foldable
|
\ string>float make-foldable
|
||||||
|
|
||||||
|
@ -313,9 +308,6 @@ M: object infer-call*
|
||||||
\ bits>double { integer } { float } define-primitive
|
\ bits>double { integer } { float } define-primitive
|
||||||
\ bits>double make-foldable
|
\ bits>double make-foldable
|
||||||
|
|
||||||
\ <complex> { real real } { complex } define-primitive
|
|
||||||
\ <complex> make-foldable
|
|
||||||
|
|
||||||
\ both-fixnums? { object object } { object } define-primitive
|
\ both-fixnums? { object object } { object } define-primitive
|
||||||
|
|
||||||
\ fixnum+ { fixnum fixnum } { integer } define-primitive
|
\ fixnum+ { fixnum fixnum } { integer } define-primitive
|
||||||
|
@ -676,3 +668,12 @@ M: object infer-call*
|
||||||
\ gc-stats { } { array } define-primitive
|
\ gc-stats { } { array } define-primitive
|
||||||
|
|
||||||
\ jit-compile { quotation } { } 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
|
|
@ -102,6 +102,7 @@ ARTICLE: "tools.inference" "Stack effect tools"
|
||||||
"Comparing effects:"
|
"Comparing effects:"
|
||||||
{ $subsection effect-height }
|
{ $subsection effect-height }
|
||||||
{ $subsection effect<= }
|
{ $subsection effect<= }
|
||||||
|
{ $subsection effect= }
|
||||||
"The class of stack effects:"
|
"The class of stack effects:"
|
||||||
{ $subsection effect }
|
{ $subsection effect }
|
||||||
{ $subsection effect? } ;
|
{ $subsection effect? } ;
|
||||||
|
|
|
@ -19,7 +19,6 @@ IN: stack-checker.transforms
|
||||||
rstate recursive-state
|
rstate recursive-state
|
||||||
[ word stack quot call-transformer ] with-variable
|
[ word stack quot call-transformer ] with-variable
|
||||||
[
|
[
|
||||||
word inlined-dependency depends-on
|
|
||||||
values [ length meta-d shorten-by ] [ #drop, ] bi
|
values [ length meta-d shorten-by ] [ #drop, ] bi
|
||||||
rstate infer-quot
|
rstate infer-quot
|
||||||
] [ word infer-word ] if* ;
|
] [ word infer-word ] if* ;
|
||||||
|
@ -108,7 +107,6 @@ IN: stack-checker.transforms
|
||||||
] 1 define-transform
|
] 1 define-transform
|
||||||
|
|
||||||
\ boa t "no-compile" set-word-prop
|
\ boa t "no-compile" set-word-prop
|
||||||
M\ tuple-class boa t "no-compile" set-word-prop
|
|
||||||
|
|
||||||
\ new [
|
\ new [
|
||||||
dup tuple-class? [
|
dup tuple-class? [
|
||||||
|
|
|
@ -2,3 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: tools.test strings.tables ;
|
USING: tools.test strings.tables ;
|
||||||
IN: strings.tables.tests
|
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
|
|
@ -1,21 +1,30 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: strings.tables
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: format-column ( seq ? -- seq )
|
|
||||||
[
|
|
||||||
dup [ length ] [ max ] map-reduce
|
|
||||||
'[ _ CHAR: \s pad-tail ] map
|
|
||||||
] unless ;
|
|
||||||
|
|
||||||
: map-last ( seq quot -- seq )
|
: map-last ( seq quot -- seq )
|
||||||
[ dup length <reversed> ] dip '[ 0 = @ ] 2map ; inline
|
[ 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 max-length
|
||||||
|
'[ _ CHAR: \s pad-tail ] map
|
||||||
|
] unless ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: format-table ( table -- seq )
|
: format-table ( table -- seq )
|
||||||
flip [ format-column ] map-last
|
[ [ [ string-lines ] map ] dip format-row flip ] map-last concat
|
||||||
flip [ " " join ] map ;
|
flip [ format-column ] map-last flip [ " " join ] map ;
|
|
@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
|
||||||
sequences math namespaces.private continuations.private
|
sequences math namespaces.private continuations.private
|
||||||
concurrency.messaging quotations kernel.private words
|
concurrency.messaging quotations kernel.private words
|
||||||
sequences.private assocs models models.arrow arrays accessors
|
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
|
IN: tools.continuations
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
@ -53,8 +53,7 @@ M: object add-breakpoint ;
|
||||||
: (step-into-execute) ( word -- )
|
: (step-into-execute) ( word -- )
|
||||||
{
|
{
|
||||||
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
||||||
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
|
{ [ dup single-generic? ] [ effective-method (step-into-execute) ] }
|
||||||
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
|
|
||||||
{ [ dup uses \ suspend swap member? ] [ execute break ] }
|
{ [ dup uses \ suspend swap member? ] [ execute break ] }
|
||||||
{ [ dup primitive? ] [ execute break ] }
|
{ [ dup primitive? ] [ execute break ] }
|
||||||
[ def>> (step-into-quot) ]
|
[ def>> (step-into-quot) ]
|
||||||
|
|
|
@ -3,8 +3,7 @@
|
||||||
USING: words assocs definitions io io.pathnames io.styles kernel
|
USING: words assocs definitions io io.pathnames io.styles kernel
|
||||||
prettyprint sorting see sets sequences arrays hashtables help.crossref
|
prettyprint sorting see sets sequences arrays hashtables help.crossref
|
||||||
help.topics help.markup quotations accessors source-files namespaces
|
help.topics help.markup quotations accessors source-files namespaces
|
||||||
graphs vocabs generic generic.standard.engines.tuple threads
|
graphs vocabs generic generic.single threads compiler.units init ;
|
||||||
compiler.units init ;
|
|
||||||
IN: tools.crossref
|
IN: tools.crossref
|
||||||
|
|
||||||
SYMBOL: crossref
|
SYMBOL: crossref
|
||||||
|
@ -82,7 +81,7 @@ M: object irrelevant? drop f ;
|
||||||
|
|
||||||
M: default-method irrelevant? drop t ;
|
M: default-method irrelevant? drop t ;
|
||||||
|
|
||||||
M: engine-word irrelevant? drop t ;
|
M: predicate-engine irrelevant? drop t ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue