Merge branch 'master' into startup
Conflicts: core/bootstrap/primitives.factor vm/run.hppdb4
commit
cc194416f9
7
Makefile
7
Makefile
|
@ -41,22 +41,25 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||||
vm/callstack.o \
|
vm/callstack.o \
|
||||||
vm/code_block.o \
|
vm/code_block.o \
|
||||||
vm/code_heap.o \
|
vm/code_heap.o \
|
||||||
|
vm/compaction.o \
|
||||||
vm/contexts.o \
|
vm/contexts.o \
|
||||||
vm/data_heap.o \
|
vm/data_heap.o \
|
||||||
|
vm/data_heap_checker.o \
|
||||||
vm/debug.o \
|
vm/debug.o \
|
||||||
vm/dispatch.o \
|
vm/dispatch.o \
|
||||||
vm/errors.o \
|
vm/errors.o \
|
||||||
vm/factor.o \
|
vm/factor.o \
|
||||||
|
vm/free_list.o \
|
||||||
vm/full_collector.o \
|
vm/full_collector.o \
|
||||||
vm/gc.o \
|
vm/gc.o \
|
||||||
vm/heap.o \
|
|
||||||
vm/image.o \
|
vm/image.o \
|
||||||
vm/inline_cache.o \
|
vm/inline_cache.o \
|
||||||
vm/io.o \
|
vm/io.o \
|
||||||
vm/jit.o \
|
vm/jit.o \
|
||||||
vm/math.o \
|
vm/math.o \
|
||||||
vm/nursery_collector.o \
|
vm/nursery_collector.o \
|
||||||
vm/old_space.o \
|
vm/object_start_map.o \
|
||||||
|
vm/objects.o \
|
||||||
vm/primitives.o \
|
vm/primitives.o \
|
||||||
vm/profiler.o \
|
vm/profiler.o \
|
||||||
vm/quotations.o \
|
vm/quotations.o \
|
||||||
|
|
|
@ -1,16 +1,23 @@
|
||||||
IN: alarms
|
|
||||||
USING: help.markup help.syntax calendar quotations ;
|
USING: help.markup help.syntax calendar quotations ;
|
||||||
|
IN: alarms
|
||||||
|
|
||||||
HELP: alarm
|
HELP: alarm
|
||||||
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
|
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
|
||||||
|
|
||||||
HELP: add-alarm
|
HELP: add-alarm
|
||||||
{ $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } }
|
{ $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } }
|
||||||
{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
|
{ $description "Creates and registers an alarm to start at " { $snippet "time" } ". If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
|
||||||
|
|
||||||
HELP: later
|
HELP: later
|
||||||
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
|
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
|
||||||
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;
|
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." }
|
||||||
|
{ $examples
|
||||||
|
{ $unchecked-example
|
||||||
|
"USING: alarms io calendar ;"
|
||||||
|
"""[ "GET BACK TO WORK, Guy." print flush ] 10 minutes later drop"""
|
||||||
|
""
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
HELP: cancel-alarm
|
HELP: cancel-alarm
|
||||||
{ $values { "alarm" alarm } }
|
{ $values { "alarm" alarm } }
|
||||||
|
@ -20,16 +27,29 @@ HELP: every
|
||||||
{ $values
|
{ $values
|
||||||
{ "quot" quotation } { "duration" duration }
|
{ "quot" quotation } { "duration" duration }
|
||||||
{ "alarm" alarm } }
|
{ "alarm" alarm } }
|
||||||
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;
|
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." }
|
||||||
|
{ $examples
|
||||||
|
{ $unchecked-example
|
||||||
|
"USING: alarms io calendar ;"
|
||||||
|
"""[ "Hi Buddy." print flush ] 10 seconds every drop"""
|
||||||
|
""
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
ARTICLE: "alarms" "Alarms"
|
ARTICLE: "alarms" "Alarms"
|
||||||
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
|
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread." $nl
|
||||||
|
"The alarm class:"
|
||||||
{ $subsections
|
{ $subsections
|
||||||
alarm
|
alarm
|
||||||
add-alarm
|
|
||||||
later
|
|
||||||
cancel-alarm
|
|
||||||
}
|
}
|
||||||
|
"Register a recurring alarm:"
|
||||||
|
{ $subsections every }
|
||||||
|
"Register a one-time alarm:"
|
||||||
|
{ $subsections later }
|
||||||
|
"Low-level interface to add alarms:"
|
||||||
|
{ $subsections add-alarm }
|
||||||
|
"Cancelling an alarm:"
|
||||||
|
{ $subsections cancel-alarm }
|
||||||
"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
|
"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
|
||||||
|
|
||||||
ABOUT: "alarms"
|
ABOUT: "alarms"
|
||||||
|
|
|
@ -20,6 +20,8 @@ M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
|
||||||
|
|
||||||
M: array c-type-align first c-type-align ;
|
M: array c-type-align first c-type-align ;
|
||||||
|
|
||||||
|
M: array c-type-align-first first c-type-align-first ;
|
||||||
|
|
||||||
M: array c-type-stack-align? drop f ;
|
M: array c-type-stack-align? drop f ;
|
||||||
|
|
||||||
M: array unbox-parameter drop void* unbox-parameter ;
|
M: array unbox-parameter drop void* unbox-parameter ;
|
||||||
|
@ -55,6 +57,9 @@ M: string-type heap-size
|
||||||
M: string-type c-type-align
|
M: string-type c-type-align
|
||||||
drop void* c-type-align ;
|
drop void* c-type-align ;
|
||||||
|
|
||||||
|
M: string-type c-type-align-first
|
||||||
|
drop void* c-type-align-first ;
|
||||||
|
|
||||||
M: string-type c-type-stack-align?
|
M: string-type c-type-stack-align?
|
||||||
drop void* c-type-stack-align? ;
|
drop void* c-type-stack-align? ;
|
||||||
|
|
||||||
|
@ -97,5 +102,5 @@ M: string-type c-type-setter
|
||||||
{ char* utf8 } char* typedef
|
{ char* utf8 } char* typedef
|
||||||
char* uchar* typedef
|
char* uchar* typedef
|
||||||
|
|
||||||
char char* "pointer-c-type" set-word-prop
|
char char* "pointer-c-type" set-word-prop
|
||||||
uchar uchar* "pointer-c-type" set-word-prop
|
uchar uchar* "pointer-c-type" set-word-prop
|
||||||
|
|
|
@ -30,8 +30,9 @@ TUPLE: abstract-c-type
|
||||||
{ unboxer-quot callable }
|
{ unboxer-quot callable }
|
||||||
{ getter callable }
|
{ getter callable }
|
||||||
{ setter callable }
|
{ setter callable }
|
||||||
size
|
{ size integer }
|
||||||
align ;
|
{ align integer }
|
||||||
|
{ align-first integer } ;
|
||||||
|
|
||||||
TUPLE: c-type < abstract-c-type
|
TUPLE: c-type < abstract-c-type
|
||||||
boxer
|
boxer
|
||||||
|
@ -104,10 +105,9 @@ M: word c-type
|
||||||
|
|
||||||
GENERIC: c-struct? ( c-type -- ? )
|
GENERIC: c-struct? ( c-type -- ? )
|
||||||
|
|
||||||
M: object c-struct?
|
M: object c-struct? drop f ;
|
||||||
drop f ;
|
|
||||||
M: c-type-name c-struct?
|
M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
|
||||||
dup void? [ drop f ] [ c-type c-struct? ] if ;
|
|
||||||
|
|
||||||
! These words being foldable means that words need to be
|
! These words being foldable means that words need to be
|
||||||
! recompiled if a C type is redefined. Even so, folding the
|
! recompiled if a C type is redefined. Even so, folding the
|
||||||
|
@ -172,6 +172,12 @@ M: abstract-c-type c-type-align align>> ;
|
||||||
|
|
||||||
M: c-type-name c-type-align c-type c-type-align ;
|
M: c-type-name c-type-align c-type c-type-align ;
|
||||||
|
|
||||||
|
GENERIC: c-type-align-first ( name -- n )
|
||||||
|
|
||||||
|
M: c-type-name c-type-align-first c-type c-type-align-first ;
|
||||||
|
|
||||||
|
M: abstract-c-type c-type-align-first align-first>> ;
|
||||||
|
|
||||||
GENERIC: c-type-stack-align? ( name -- ? )
|
GENERIC: c-type-stack-align? ( name -- ? )
|
||||||
|
|
||||||
M: c-type c-type-stack-align? stack-align?>> ;
|
M: c-type c-type-stack-align? stack-align?>> ;
|
||||||
|
@ -230,6 +236,10 @@ M: byte-array byte-length length ; inline
|
||||||
|
|
||||||
M: f byte-length drop 0 ; inline
|
M: f byte-length drop 0 ; inline
|
||||||
|
|
||||||
|
: >c-bool ( ? -- int ) 1 0 ? ; inline
|
||||||
|
|
||||||
|
: c-bool> ( int -- ? ) 0 = not ; inline
|
||||||
|
|
||||||
MIXIN: value-type
|
MIXIN: value-type
|
||||||
|
|
||||||
: c-getter ( name -- quot )
|
: c-getter ( name -- quot )
|
||||||
|
@ -256,6 +266,7 @@ PREDICATE: typedef-word < c-type-word
|
||||||
"c-type" word-prop c-type-name? ;
|
"c-type" word-prop c-type-name? ;
|
||||||
|
|
||||||
M: string typedef ( old new -- ) c-types get set-at ;
|
M: string typedef ( old new -- ) c-types get set-at ;
|
||||||
|
|
||||||
M: word typedef ( old new -- )
|
M: word typedef ( old new -- )
|
||||||
{
|
{
|
||||||
[ nip define-symbol ]
|
[ nip define-symbol ]
|
||||||
|
@ -292,7 +303,7 @@ M: long-long-type box-return ( c-type -- )
|
||||||
|
|
||||||
: define-out ( name -- )
|
: define-out ( name -- )
|
||||||
[ "alien.c-types" constructor-word ]
|
[ "alien.c-types" constructor-word ]
|
||||||
[ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
|
[ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
|
||||||
(( value -- c-ptr )) define-inline ;
|
(( value -- c-ptr )) define-inline ;
|
||||||
|
|
||||||
: define-primitive-type ( c-type name -- )
|
: define-primitive-type ( c-type name -- )
|
||||||
|
@ -319,6 +330,13 @@ SYMBOLS:
|
||||||
ptrdiff_t intptr_t uintptr_t size_t
|
ptrdiff_t intptr_t uintptr_t size_t
|
||||||
char* uchar* ;
|
char* uchar* ;
|
||||||
|
|
||||||
|
: 8-byte-alignment ( c-type -- c-type )
|
||||||
|
{
|
||||||
|
{ [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
|
||||||
|
{ [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
|
||||||
|
[ 8 >>align 8 >>align-first ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
[
|
[
|
||||||
<c-type>
|
<c-type>
|
||||||
c-ptr >>class
|
c-ptr >>class
|
||||||
|
@ -327,6 +345,7 @@ SYMBOLS:
|
||||||
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
|
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
|
||||||
bootstrap-cell >>size
|
bootstrap-cell >>size
|
||||||
bootstrap-cell >>align
|
bootstrap-cell >>align
|
||||||
|
bootstrap-cell >>align-first
|
||||||
[ >c-ptr ] >>unboxer-quot
|
[ >c-ptr ] >>unboxer-quot
|
||||||
"box_alien" >>boxer
|
"box_alien" >>boxer
|
||||||
"alien_offset" >>unboxer
|
"alien_offset" >>unboxer
|
||||||
|
@ -338,7 +357,7 @@ SYMBOLS:
|
||||||
[ alien-signed-8 ] >>getter
|
[ alien-signed-8 ] >>getter
|
||||||
[ set-alien-signed-8 ] >>setter
|
[ set-alien-signed-8 ] >>setter
|
||||||
8 >>size
|
8 >>size
|
||||||
8 >>align
|
8-byte-alignment
|
||||||
"box_signed_8" >>boxer
|
"box_signed_8" >>boxer
|
||||||
"to_signed_8" >>unboxer
|
"to_signed_8" >>unboxer
|
||||||
\ longlong define-primitive-type
|
\ longlong define-primitive-type
|
||||||
|
@ -349,7 +368,7 @@ SYMBOLS:
|
||||||
[ alien-unsigned-8 ] >>getter
|
[ alien-unsigned-8 ] >>getter
|
||||||
[ set-alien-unsigned-8 ] >>setter
|
[ set-alien-unsigned-8 ] >>setter
|
||||||
8 >>size
|
8 >>size
|
||||||
8 >>align
|
8-byte-alignment
|
||||||
"box_unsigned_8" >>boxer
|
"box_unsigned_8" >>boxer
|
||||||
"to_unsigned_8" >>unboxer
|
"to_unsigned_8" >>unboxer
|
||||||
\ ulonglong define-primitive-type
|
\ ulonglong define-primitive-type
|
||||||
|
@ -361,6 +380,7 @@ SYMBOLS:
|
||||||
[ set-alien-signed-cell ] >>setter
|
[ set-alien-signed-cell ] >>setter
|
||||||
bootstrap-cell >>size
|
bootstrap-cell >>size
|
||||||
bootstrap-cell >>align
|
bootstrap-cell >>align
|
||||||
|
bootstrap-cell >>align-first
|
||||||
"box_signed_cell" >>boxer
|
"box_signed_cell" >>boxer
|
||||||
"to_fixnum" >>unboxer
|
"to_fixnum" >>unboxer
|
||||||
\ long define-primitive-type
|
\ long define-primitive-type
|
||||||
|
@ -372,6 +392,7 @@ SYMBOLS:
|
||||||
[ set-alien-unsigned-cell ] >>setter
|
[ set-alien-unsigned-cell ] >>setter
|
||||||
bootstrap-cell >>size
|
bootstrap-cell >>size
|
||||||
bootstrap-cell >>align
|
bootstrap-cell >>align
|
||||||
|
bootstrap-cell >>align-first
|
||||||
"box_unsigned_cell" >>boxer
|
"box_unsigned_cell" >>boxer
|
||||||
"to_cell" >>unboxer
|
"to_cell" >>unboxer
|
||||||
\ ulong define-primitive-type
|
\ ulong define-primitive-type
|
||||||
|
@ -383,6 +404,7 @@ SYMBOLS:
|
||||||
[ set-alien-signed-4 ] >>setter
|
[ set-alien-signed-4 ] >>setter
|
||||||
4 >>size
|
4 >>size
|
||||||
4 >>align
|
4 >>align
|
||||||
|
4 >>align-first
|
||||||
"box_signed_4" >>boxer
|
"box_signed_4" >>boxer
|
||||||
"to_fixnum" >>unboxer
|
"to_fixnum" >>unboxer
|
||||||
\ int define-primitive-type
|
\ int define-primitive-type
|
||||||
|
@ -394,6 +416,7 @@ SYMBOLS:
|
||||||
[ set-alien-unsigned-4 ] >>setter
|
[ set-alien-unsigned-4 ] >>setter
|
||||||
4 >>size
|
4 >>size
|
||||||
4 >>align
|
4 >>align
|
||||||
|
4 >>align-first
|
||||||
"box_unsigned_4" >>boxer
|
"box_unsigned_4" >>boxer
|
||||||
"to_cell" >>unboxer
|
"to_cell" >>unboxer
|
||||||
\ uint define-primitive-type
|
\ uint define-primitive-type
|
||||||
|
@ -405,6 +428,7 @@ SYMBOLS:
|
||||||
[ set-alien-signed-2 ] >>setter
|
[ set-alien-signed-2 ] >>setter
|
||||||
2 >>size
|
2 >>size
|
||||||
2 >>align
|
2 >>align
|
||||||
|
2 >>align-first
|
||||||
"box_signed_2" >>boxer
|
"box_signed_2" >>boxer
|
||||||
"to_fixnum" >>unboxer
|
"to_fixnum" >>unboxer
|
||||||
\ short define-primitive-type
|
\ short define-primitive-type
|
||||||
|
@ -416,6 +440,7 @@ SYMBOLS:
|
||||||
[ set-alien-unsigned-2 ] >>setter
|
[ set-alien-unsigned-2 ] >>setter
|
||||||
2 >>size
|
2 >>size
|
||||||
2 >>align
|
2 >>align
|
||||||
|
2 >>align-first
|
||||||
"box_unsigned_2" >>boxer
|
"box_unsigned_2" >>boxer
|
||||||
"to_cell" >>unboxer
|
"to_cell" >>unboxer
|
||||||
\ ushort define-primitive-type
|
\ ushort define-primitive-type
|
||||||
|
@ -427,6 +452,7 @@ SYMBOLS:
|
||||||
[ set-alien-signed-1 ] >>setter
|
[ set-alien-signed-1 ] >>setter
|
||||||
1 >>size
|
1 >>size
|
||||||
1 >>align
|
1 >>align
|
||||||
|
1 >>align-first
|
||||||
"box_signed_1" >>boxer
|
"box_signed_1" >>boxer
|
||||||
"to_fixnum" >>unboxer
|
"to_fixnum" >>unboxer
|
||||||
\ char define-primitive-type
|
\ char define-primitive-type
|
||||||
|
@ -438,17 +464,30 @@ SYMBOLS:
|
||||||
[ set-alien-unsigned-1 ] >>setter
|
[ set-alien-unsigned-1 ] >>setter
|
||||||
1 >>size
|
1 >>size
|
||||||
1 >>align
|
1 >>align
|
||||||
|
1 >>align-first
|
||||||
"box_unsigned_1" >>boxer
|
"box_unsigned_1" >>boxer
|
||||||
"to_cell" >>unboxer
|
"to_cell" >>unboxer
|
||||||
\ uchar define-primitive-type
|
\ uchar define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
cpu ppc? [
|
||||||
[ alien-unsigned-1 0 = not ] >>getter
|
<c-type>
|
||||||
[ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
|
[ alien-unsigned-4 c-bool> ] >>getter
|
||||||
1 >>size
|
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
|
||||||
1 >>align
|
4 >>size
|
||||||
"box_boolean" >>boxer
|
4 >>align
|
||||||
"to_boolean" >>unboxer
|
4 >>align-first
|
||||||
|
"box_boolean" >>boxer
|
||||||
|
"to_boolean" >>unboxer
|
||||||
|
] [
|
||||||
|
<c-type>
|
||||||
|
[ alien-unsigned-1 c-bool> ] >>getter
|
||||||
|
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
|
||||||
|
1 >>size
|
||||||
|
1 >>align
|
||||||
|
1 >>align-first
|
||||||
|
"box_boolean" >>boxer
|
||||||
|
"to_boolean" >>unboxer
|
||||||
|
] if
|
||||||
\ bool define-primitive-type
|
\ bool define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
|
@ -458,6 +497,7 @@ SYMBOLS:
|
||||||
[ [ >float ] 2dip set-alien-float ] >>setter
|
[ [ >float ] 2dip set-alien-float ] >>setter
|
||||||
4 >>size
|
4 >>size
|
||||||
4 >>align
|
4 >>align
|
||||||
|
4 >>align-first
|
||||||
"box_float" >>boxer
|
"box_float" >>boxer
|
||||||
"to_float" >>unboxer
|
"to_float" >>unboxer
|
||||||
float-rep >>rep
|
float-rep >>rep
|
||||||
|
@ -470,17 +510,24 @@ SYMBOLS:
|
||||||
[ alien-double ] >>getter
|
[ alien-double ] >>getter
|
||||||
[ [ >float ] 2dip set-alien-double ] >>setter
|
[ [ >float ] 2dip set-alien-double ] >>setter
|
||||||
8 >>size
|
8 >>size
|
||||||
8 >>align
|
8-byte-alignment
|
||||||
"box_double" >>boxer
|
"box_double" >>boxer
|
||||||
"to_double" >>unboxer
|
"to_double" >>unboxer
|
||||||
double-rep >>rep
|
double-rep >>rep
|
||||||
[ >float ] >>unboxer-quot
|
[ >float ] >>unboxer-quot
|
||||||
\ double define-primitive-type
|
\ double define-primitive-type
|
||||||
|
|
||||||
\ long c-type \ ptrdiff_t typedef
|
cpu x86.64? os windows? and [
|
||||||
\ long c-type \ intptr_t typedef
|
\ longlong c-type \ ptrdiff_t typedef
|
||||||
\ ulong c-type \ uintptr_t typedef
|
\ longlong c-type \ intptr_t typedef
|
||||||
\ ulong c-type \ size_t typedef
|
\ ulonglong c-type \ uintptr_t typedef
|
||||||
|
\ ulonglong c-type \ size_t typedef
|
||||||
|
] [
|
||||||
|
\ long c-type \ ptrdiff_t typedef
|
||||||
|
\ long c-type \ intptr_t typedef
|
||||||
|
\ ulong c-type \ uintptr_t typedef
|
||||||
|
\ ulong c-type \ size_t typedef
|
||||||
|
] if
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
|
|
||||||
M: char-16-rep rep-component-type drop char ;
|
M: char-16-rep rep-component-type drop char ;
|
||||||
|
@ -501,9 +548,9 @@ M: double-2-rep rep-component-type drop double ;
|
||||||
|
|
||||||
: c-type-interval ( c-type -- from to )
|
: c-type-interval ( c-type -- from to )
|
||||||
{
|
{
|
||||||
{ [ dup { float double } memq? ] [ drop -1/0. 1/0. ] }
|
{ [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
|
||||||
{ [ dup { char short int long longlong } memq? ] [ signed-interval ] }
|
{ [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
|
||||||
{ [ dup { uchar ushort uint ulong ulonglong } memq? ] [ unsigned-interval ] }
|
{ [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
|
||||||
} cond ; foldable
|
} cond ; foldable
|
||||||
|
|
||||||
: c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline
|
: c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline
|
||||||
|
|
|
@ -65,10 +65,6 @@ M: memory-stream stream-read
|
||||||
: byte-array>memory ( byte-array base -- )
|
: byte-array>memory ( byte-array base -- )
|
||||||
swap dup byte-length memcpy ; inline
|
swap dup byte-length memcpy ; inline
|
||||||
|
|
||||||
: >c-bool ( ? -- int ) 1 0 ? ; inline
|
|
||||||
|
|
||||||
: c-bool> ( int -- ? ) 0 = not ; inline
|
|
||||||
|
|
||||||
M: value-type c-type-rep drop int-rep ;
|
M: value-type c-type-rep drop int-rep ;
|
||||||
|
|
||||||
M: value-type c-type-getter
|
M: value-type c-type-getter
|
||||||
|
@ -77,5 +73,3 @@ M: value-type c-type-getter
|
||||||
M: value-type c-type-setter ( type -- quot )
|
M: value-type c-type-setter ( type -- quot )
|
||||||
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
|
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
|
||||||
'[ @ swap @ _ memcpy ] ;
|
'[ @ swap @ _ memcpy ] ;
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -205,9 +205,6 @@ M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
|
||||||
M: real-type (fortran-ret-type>c-type)
|
M: real-type (fortran-ret-type>c-type)
|
||||||
drop real-functions-return-double? [ "double" ] [ "float" ] if ;
|
drop real-functions-return-double? [ "double" ] [ "float" ] if ;
|
||||||
|
|
||||||
: suffix! ( seq elt -- seq ) over push ; inline
|
|
||||||
: append! ( seq-a seq-b -- seq-a ) over push-all ; inline
|
|
||||||
|
|
||||||
GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
|
GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
|
||||||
|
|
||||||
: args?dims ( type quot -- main-quot added-quot )
|
: args?dims ( type quot -- main-quot added-quot )
|
||||||
|
@ -333,7 +330,7 @@ M: character-type (<fortran-result>)
|
||||||
] if-empty ;
|
] if-empty ;
|
||||||
|
|
||||||
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
|
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
|
||||||
return parameters fortran-sig>c-sig :> c-parameters :> c-return
|
return parameters fortran-sig>c-sig :> ( c-return c-parameters )
|
||||||
function fortran-name>symbol-name :> c-function
|
function fortran-name>symbol-name :> c-function
|
||||||
[args>args]
|
[args>args]
|
||||||
c-return library c-function c-parameters \ alien-invoke
|
c-return library c-function c-parameters \ alien-invoke
|
||||||
|
|
|
@ -98,7 +98,7 @@ IN: alien.parser
|
||||||
type-name current-vocab create :> type-word
|
type-name current-vocab create :> type-word
|
||||||
type-word [ reset-generic ] [ reset-c-type ] bi
|
type-word [ reset-generic ] [ reset-c-type ] bi
|
||||||
void* type-word typedef
|
void* type-word typedef
|
||||||
parameters return parse-arglist :> callback-effect :> types
|
parameters return parse-arglist :> ( types callback-effect )
|
||||||
type-word callback-effect "callback-effect" set-word-prop
|
type-word callback-effect "callback-effect" set-word-prop
|
||||||
type-word lib "callback-library" set-word-prop
|
type-word lib "callback-library" set-word-prop
|
||||||
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
|
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
|
||||||
|
|
|
@ -7,11 +7,11 @@ effects assocs combinators lexer strings.parser alien.parser
|
||||||
fry vocabs.parser words.constant alien.libraries ;
|
fry vocabs.parser words.constant alien.libraries ;
|
||||||
IN: alien.syntax
|
IN: alien.syntax
|
||||||
|
|
||||||
SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ;
|
SYNTAX: DLL" lexer get skip-blank parse-string dlopen suffix! ;
|
||||||
|
|
||||||
SYNTAX: ALIEN: 16 scan-base <alien> parsed ;
|
SYNTAX: ALIEN: 16 scan-base <alien> suffix! ;
|
||||||
|
|
||||||
SYNTAX: BAD-ALIEN <bad-alien> parsed ;
|
SYNTAX: BAD-ALIEN <bad-alien> suffix! ;
|
||||||
|
|
||||||
SYNTAX: LIBRARY: scan "c-library" set ;
|
SYNTAX: LIBRARY: scan "c-library" set ;
|
||||||
|
|
||||||
|
@ -37,7 +37,7 @@ ERROR: no-such-symbol name library ;
|
||||||
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
|
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
|
||||||
|
|
||||||
SYNTAX: &:
|
SYNTAX: &:
|
||||||
scan "c-library" get '[ _ _ address-of ] over push-all ;
|
scan "c-library" get '[ _ _ address-of ] append! ;
|
||||||
|
|
||||||
: global-quot ( type word -- quot )
|
: global-quot ( type word -- quot )
|
||||||
name>> "c-library" get '[ _ _ address-of 0 ]
|
name>> "c-library" get '[ _ _ address-of 0 ]
|
||||||
|
|
|
@ -25,11 +25,11 @@ HELP: sorted-member?
|
||||||
|
|
||||||
{ member? sorted-member? } related-words
|
{ member? sorted-member? } related-words
|
||||||
|
|
||||||
HELP: sorted-memq?
|
HELP: sorted-member-eq?
|
||||||
{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
|
{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
|
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
|
||||||
|
|
||||||
{ memq? sorted-memq? } related-words
|
{ member-eq? sorted-member-eq? } related-words
|
||||||
|
|
||||||
ARTICLE: "binary-search" "Binary search"
|
ARTICLE: "binary-search" "Binary search"
|
||||||
"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
|
"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
|
||||||
|
@ -38,7 +38,7 @@ ARTICLE: "binary-search" "Binary search"
|
||||||
{ $subsections
|
{ $subsections
|
||||||
sorted-index
|
sorted-index
|
||||||
sorted-member?
|
sorted-member?
|
||||||
sorted-memq?
|
sorted-member-eq?
|
||||||
}
|
}
|
||||||
{ $see-also "order-specifiers" "sequences-sorting" } ;
|
{ $see-also "order-specifiers" "sequences-sorting" } ;
|
||||||
|
|
||||||
|
|
|
@ -49,5 +49,5 @@ HINTS: natural-search array ;
|
||||||
: sorted-member? ( obj seq -- ? )
|
: sorted-member? ( obj seq -- ? )
|
||||||
dupd natural-search nip = ;
|
dupd natural-search nip = ;
|
||||||
|
|
||||||
: sorted-memq? ( obj seq -- ? )
|
: sorted-member-eq? ( obj seq -- ? )
|
||||||
dupd natural-search nip eq? ;
|
dupd natural-search nip eq? ;
|
||||||
|
|
|
@ -55,7 +55,7 @@ HELP: clear-bits
|
||||||
{ $values { "bit-array" bit-array } }
|
{ $values { "bit-array" bit-array } }
|
||||||
{ $description "Sets all elements of the bit array to " { $link f } "." }
|
{ $description "Sets all elements of the bit array to " { $link f } "." }
|
||||||
{ $notes "Calling this word is more efficient than the following:"
|
{ $notes "Calling this word is more efficient than the following:"
|
||||||
{ $code "[ drop f ] change-each" }
|
{ $code "[ drop f ] map! drop" }
|
||||||
}
|
}
|
||||||
{ $side-effects "bit-array" } ;
|
{ $side-effects "bit-array" } ;
|
||||||
|
|
||||||
|
@ -63,7 +63,7 @@ HELP: set-bits
|
||||||
{ $values { "bit-array" bit-array } }
|
{ $values { "bit-array" bit-array } }
|
||||||
{ $description "Sets all elements of the bit array to " { $link t } "." }
|
{ $description "Sets all elements of the bit array to " { $link t } "." }
|
||||||
{ $notes "Calling this word is more efficient than the following:"
|
{ $notes "Calling this word is more efficient than the following:"
|
||||||
{ $code "[ drop t ] change-each" }
|
{ $code "[ drop t ] map! drop" }
|
||||||
}
|
}
|
||||||
{ $side-effects "bit-array" } ;
|
{ $side-effects "bit-array" } ;
|
||||||
|
|
||||||
|
|
|
@ -20,7 +20,7 @@ IN: bit-arrays.tests
|
||||||
[
|
[
|
||||||
{ t f t } { f t f }
|
{ t f t } { f t f }
|
||||||
] [
|
] [
|
||||||
{ t f t } >bit-array dup clone dup [ not ] change-each
|
{ t f t } >bit-array dup clone [ not ] map!
|
||||||
[ >array ] bi@
|
[ >array ] bi@
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -113,7 +113,7 @@ PRIVATE>
|
||||||
M:: lsb0-bit-writer poke ( value n bs -- )
|
M:: lsb0-bit-writer poke ( value n bs -- )
|
||||||
value n <widthed> :> widthed
|
value n <widthed> :> widthed
|
||||||
widthed
|
widthed
|
||||||
bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
|
bs widthed>> #bits>> 8 swap - split-widthed :> ( byte remainder )
|
||||||
byte bs widthed>> |widthed :> new-byte
|
byte bs widthed>> |widthed :> new-byte
|
||||||
new-byte #bits>> 8 = [
|
new-byte #bits>> 8 = [
|
||||||
new-byte bits>> bs bytes>> push
|
new-byte bits>> bs bytes>> push
|
||||||
|
@ -143,7 +143,7 @@ ERROR: not-enough-bits n bit-reader ;
|
||||||
neg shift n bits ;
|
neg shift n bits ;
|
||||||
|
|
||||||
:: adjust-bits ( n bs -- )
|
:: adjust-bits ( n bs -- )
|
||||||
n 8 /mod :> #bits :> #bytes
|
n 8 /mod :> ( #bytes #bits )
|
||||||
bs [ #bytes + ] change-byte-pos
|
bs [ #bytes + ] change-byte-pos
|
||||||
bit-pos>> #bits + dup 8 >= [
|
bit-pos>> #bits + dup 8 >= [
|
||||||
8 - bs (>>bit-pos)
|
8 - bs (>>bit-pos)
|
||||||
|
|
|
@ -49,7 +49,7 @@ gc
|
||||||
{
|
{
|
||||||
not ?
|
not ?
|
||||||
|
|
||||||
2over roll -roll
|
2over
|
||||||
|
|
||||||
array? hashtable? vector?
|
array? hashtable? vector?
|
||||||
tuple? sbuf? tombstone?
|
tuple? sbuf? tombstone?
|
||||||
|
@ -94,7 +94,7 @@ gc
|
||||||
"." write flush
|
"." write flush
|
||||||
|
|
||||||
{
|
{
|
||||||
memq? split harvest sift cut cut-slice start index clone
|
member-eq? split harvest sift cut cut-slice start index clone
|
||||||
set-at reverse push-all class number>string string>number
|
set-at reverse push-all class number>string string>number
|
||||||
like clone-like
|
like clone-like
|
||||||
} compile-unoptimized
|
} compile-unoptimized
|
||||||
|
@ -118,4 +118,4 @@ gc
|
||||||
|
|
||||||
" done" print flush
|
" done" print flush
|
||||||
|
|
||||||
] unless
|
] unless
|
||||||
|
|
|
@ -1,14 +1,16 @@
|
||||||
! 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: alien arrays byte-arrays generic hashtables hashtables.private
|
USING: alien arrays byte-arrays generic hashtables
|
||||||
io io.binary io.files io.encodings.binary io.pathnames kernel
|
hashtables.private io io.binary io.files io.encodings.binary
|
||||||
kernel.private math namespaces make parser prettyprint sequences
|
io.pathnames kernel kernel.private math namespaces make parser
|
||||||
strings sbufs vectors words quotations assocs system layouts splitting
|
prettyprint sequences strings sbufs vectors words quotations
|
||||||
grouping growable classes classes.builtin classes.tuple
|
assocs system layouts splitting grouping growable classes
|
||||||
classes.tuple.private vocabs vocabs.loader source-files definitions
|
classes.builtin classes.tuple classes.tuple.private vocabs
|
||||||
debugger quotations.private combinators math.order math.private
|
vocabs.loader source-files definitions debugger
|
||||||
accessors slots.private generic.single.private compiler.units
|
quotations.private combinators combinators.short-circuit
|
||||||
compiler.constants fry bootstrap.image.syntax ;
|
math.order math.private accessors slots.private
|
||||||
|
generic.single.private compiler.units compiler.constants fry
|
||||||
|
bootstrap.image.syntax ;
|
||||||
IN: bootstrap.image
|
IN: bootstrap.image
|
||||||
|
|
||||||
: arch ( os cpu -- arch )
|
: arch ( os cpu -- arch )
|
||||||
|
@ -38,7 +40,7 @@ IN: bootstrap.image
|
||||||
|
|
||||||
! Object cache; we only consider numbers equal if they have the
|
! Object cache; we only consider numbers equal if they have the
|
||||||
! same type
|
! same type
|
||||||
TUPLE: eql-wrapper obj ;
|
TUPLE: eql-wrapper { obj read-only } ;
|
||||||
|
|
||||||
C: <eql-wrapper> eql-wrapper
|
C: <eql-wrapper> eql-wrapper
|
||||||
|
|
||||||
|
@ -47,31 +49,31 @@ M: eql-wrapper hashcode* obj>> hashcode* ;
|
||||||
GENERIC: (eql?) ( obj1 obj2 -- ? )
|
GENERIC: (eql?) ( obj1 obj2 -- ? )
|
||||||
|
|
||||||
: eql? ( obj1 obj2 -- ? )
|
: eql? ( obj1 obj2 -- ? )
|
||||||
[ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
|
{ [ [ class ] bi@ = ] [ (eql?) ] } 2&& ;
|
||||||
|
|
||||||
M: integer (eql?) = ;
|
M: fixnum (eql?) eq? ;
|
||||||
|
|
||||||
M: float (eql?)
|
M: bignum (eql?) = ;
|
||||||
over float? [ fp-bitwise= ] [ 2drop f ] if ;
|
|
||||||
|
|
||||||
M: sequence (eql?)
|
M: float (eql?) fp-bitwise= ;
|
||||||
over sequence? [
|
|
||||||
2dup [ length ] bi@ =
|
M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ;
|
||||||
[ [ eql? ] 2all? ] [ 2drop f ] if
|
|
||||||
] [ 2drop f ] if ;
|
|
||||||
|
|
||||||
M: object (eql?) = ;
|
M: object (eql?) = ;
|
||||||
|
|
||||||
M: eql-wrapper equal?
|
M: eql-wrapper equal?
|
||||||
over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
|
over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
|
||||||
|
|
||||||
TUPLE: eq-wrapper obj ;
|
TUPLE: eq-wrapper { obj read-only } ;
|
||||||
|
|
||||||
C: <eq-wrapper> eq-wrapper
|
C: <eq-wrapper> eq-wrapper
|
||||||
|
|
||||||
M: eq-wrapper equal?
|
M: eq-wrapper equal?
|
||||||
over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
|
over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: eq-wrapper hashcode*
|
||||||
|
nip obj>> identity-hashcode ;
|
||||||
|
|
||||||
SYMBOL: objects
|
SYMBOL: objects
|
||||||
|
|
||||||
: cache-eql-object ( obj quot -- value )
|
: cache-eql-object ( obj quot -- value )
|
||||||
|
@ -177,14 +179,12 @@ USERENV: callback-stub 45
|
||||||
! PIC stubs
|
! PIC stubs
|
||||||
USERENV: pic-load 47
|
USERENV: pic-load 47
|
||||||
USERENV: pic-tag 48
|
USERENV: pic-tag 48
|
||||||
USERENV: pic-hi-tag 49
|
USERENV: pic-tuple 49
|
||||||
USERENV: pic-tuple 50
|
USERENV: pic-check-tag 50
|
||||||
USERENV: pic-hi-tag-tuple 51
|
USERENV: pic-check-tuple 51
|
||||||
USERENV: pic-check-tag 52
|
USERENV: pic-hit 52
|
||||||
USERENV: pic-check 53
|
USERENV: pic-miss-word 53
|
||||||
USERENV: pic-hit 54
|
USERENV: pic-miss-tail-word 54
|
||||||
USERENV: pic-miss-word 55
|
|
||||||
USERENV: pic-miss-tail-word 56
|
|
||||||
|
|
||||||
! Megamorphic dispatch
|
! Megamorphic dispatch
|
||||||
USERENV: mega-lookup 57
|
USERENV: mega-lookup 57
|
||||||
|
@ -218,13 +218,20 @@ USERENV: undefined-quot 60
|
||||||
|
|
||||||
: here-as ( tag -- pointer ) here bitor ;
|
: here-as ( tag -- pointer ) here bitor ;
|
||||||
|
|
||||||
|
: (align-here) ( alignment -- )
|
||||||
|
[ here neg ] dip rem
|
||||||
|
[ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
|
||||||
|
|
||||||
: align-here ( -- )
|
: align-here ( -- )
|
||||||
here 8 mod 4 = [ 0 emit ] when ;
|
data-alignment get (align-here) ;
|
||||||
|
|
||||||
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
||||||
|
|
||||||
|
: emit-header ( n -- ) tag-header emit ;
|
||||||
|
|
||||||
: emit-object ( class quot -- addr )
|
: emit-object ( class quot -- addr )
|
||||||
over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
|
[ type-number ] dip over here-as
|
||||||
|
[ swap emit-header call align-here ] dip ;
|
||||||
inline
|
inline
|
||||||
|
|
||||||
! Write an object to the image.
|
! Write an object to the image.
|
||||||
|
@ -232,7 +239,7 @@ GENERIC: ' ( obj -- ptr )
|
||||||
|
|
||||||
! Image header
|
! Image header
|
||||||
|
|
||||||
: emit-header ( -- )
|
: emit-image-header ( -- )
|
||||||
image-magic emit
|
image-magic emit
|
||||||
image-version emit
|
image-version emit
|
||||||
data-base emit ! relocation base at end of header
|
data-base emit ! relocation base at end of header
|
||||||
|
@ -293,7 +300,7 @@ M: fake-bignum ' n>> tag-fixnum ;
|
||||||
M: float '
|
M: float '
|
||||||
[
|
[
|
||||||
float [
|
float [
|
||||||
align-here double>bits emit-64
|
8 (align-here) double>bits emit-64
|
||||||
] emit-object
|
] emit-object
|
||||||
] cache-eql-object ;
|
] cache-eql-object ;
|
||||||
|
|
||||||
|
@ -305,7 +312,7 @@ M: float '
|
||||||
|
|
||||||
M: f '
|
M: f '
|
||||||
#! f is #define F RETAG(0,F_TYPE)
|
#! f is #define F RETAG(0,F_TYPE)
|
||||||
drop \ f tag-number ;
|
drop \ f type-number ;
|
||||||
|
|
||||||
: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
|
: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
|
||||||
: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
|
: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
|
||||||
|
@ -351,7 +358,7 @@ M: f '
|
||||||
[ ] [ "Not in image: " word-error ] ?if ;
|
[ ] [ "Not in image: " word-error ] ?if ;
|
||||||
|
|
||||||
: fixup-words ( -- )
|
: fixup-words ( -- )
|
||||||
image get [ dup word? [ fixup-word ] when ] change-each ;
|
image get [ dup word? [ fixup-word ] when ] map! drop ;
|
||||||
|
|
||||||
M: word ' ;
|
M: word ' ;
|
||||||
|
|
||||||
|
@ -411,6 +418,7 @@ M: byte-array '
|
||||||
[
|
[
|
||||||
byte-array [
|
byte-array [
|
||||||
dup length emit-fixnum
|
dup length emit-fixnum
|
||||||
|
bootstrap-cell 4 = [ 0 emit 0 emit ] when
|
||||||
pad-bytes emit-bytes
|
pad-bytes emit-bytes
|
||||||
] emit-object
|
] emit-object
|
||||||
] cache-eq-object ;
|
] cache-eq-object ;
|
||||||
|
@ -515,7 +523,7 @@ M: quotation '
|
||||||
: build-image ( -- image )
|
: build-image ( -- image )
|
||||||
800000 <vector> image set
|
800000 <vector> image set
|
||||||
20000 <hashtable> objects set
|
20000 <hashtable> objects set
|
||||||
emit-header t, 0, 1, -1,
|
emit-image-header t, 0, 1, -1,
|
||||||
"Building generic words..." print flush
|
"Building generic words..." print flush
|
||||||
remake-generics
|
remake-generics
|
||||||
"Serializing words..." print flush
|
"Serializing words..." print flush
|
||||||
|
|
|
@ -78,8 +78,6 @@ SYMBOL: bootstrap-time
|
||||||
"stage2: deployment mode" print
|
"stage2: deployment mode" print
|
||||||
] [
|
] [
|
||||||
"debugger" require
|
"debugger" require
|
||||||
"inspector" require
|
|
||||||
"tools.errors" require
|
|
||||||
"listener" require
|
"listener" require
|
||||||
"none" require
|
"none" require
|
||||||
] if
|
] if
|
||||||
|
|
|
@ -2,14 +2,17 @@ USING: vocabs.loader sequences ;
|
||||||
IN: bootstrap.tools
|
IN: bootstrap.tools
|
||||||
|
|
||||||
{
|
{
|
||||||
|
"editors"
|
||||||
"inspector"
|
"inspector"
|
||||||
"bootstrap.image"
|
"bootstrap.image"
|
||||||
|
"see"
|
||||||
"tools.annotations"
|
"tools.annotations"
|
||||||
"tools.crossref"
|
"tools.crossref"
|
||||||
"tools.errors"
|
"tools.errors"
|
||||||
"tools.deploy"
|
"tools.deploy"
|
||||||
"tools.destructors"
|
"tools.destructors"
|
||||||
"tools.disassembler"
|
"tools.disassembler"
|
||||||
|
"tools.dispatch"
|
||||||
"tools.memory"
|
"tools.memory"
|
||||||
"tools.profiler"
|
"tools.profiler"
|
||||||
"tools.test"
|
"tools.test"
|
||||||
|
@ -19,5 +22,4 @@ IN: bootstrap.tools
|
||||||
"vocabs.hierarchy"
|
"vocabs.hierarchy"
|
||||||
"vocabs.refresh"
|
"vocabs.refresh"
|
||||||
"vocabs.refresh.monitor"
|
"vocabs.refresh.monitor"
|
||||||
"editors"
|
|
||||||
} [ require ] each
|
} [ require ] each
|
||||||
|
|
|
@ -7,4 +7,4 @@ SYNTAX: HEX{
|
||||||
"}" parse-tokens "" join
|
"}" parse-tokens "" join
|
||||||
[ blank? not ] filter
|
[ blank? not ] filter
|
||||||
2 group [ hex> ] B{ } map-as
|
2 group [ hex> ] B{ } map-as
|
||||||
parsed ;
|
suffix! ;
|
||||||
|
|
|
@ -32,7 +32,7 @@ HELP: month-names
|
||||||
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
|
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
|
||||||
|
|
||||||
HELP: month-name
|
HELP: month-name
|
||||||
{ $values { "n" integer } { "string" string } }
|
{ $values { "obj" { $or integer timestamp } } { "string" string } }
|
||||||
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
|
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
|
||||||
|
|
||||||
HELP: month-abbreviations
|
HELP: month-abbreviations
|
||||||
|
@ -46,11 +46,11 @@ HELP: month-abbreviation
|
||||||
|
|
||||||
|
|
||||||
HELP: day-names
|
HELP: day-names
|
||||||
{ $values { "array" array } }
|
{ $values { "value" array } }
|
||||||
{ $description "Returns an array with the English names of the days of the week." } ;
|
{ $description "Returns an array with the English names of the days of the week." } ;
|
||||||
|
|
||||||
HELP: day-name
|
HELP: day-name
|
||||||
{ $values { "n" integer } { "string" string } }
|
{ $values { "obj" { $or integer timestamp } } { "string" string } }
|
||||||
{ $description "Looks up the day name and returns it as a string." } ;
|
{ $description "Looks up the day name and returns it as a string." } ;
|
||||||
|
|
||||||
HELP: day-abbreviations2
|
HELP: day-abbreviations2
|
||||||
|
|
|
@ -170,3 +170,8 @@ IN: calendar.tests
|
||||||
[ f ] [ now dup midnight eq? ] unit-test
|
[ f ] [ now dup midnight eq? ] unit-test
|
||||||
[ f ] [ now dup easter eq? ] unit-test
|
[ f ] [ now dup easter eq? ] unit-test
|
||||||
[ f ] [ now dup beginning-of-year eq? ] unit-test
|
[ f ] [ now dup beginning-of-year eq? ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ 1325376000 unix-time>timestamp 2012 <year-gmt> = ] unit-test
|
||||||
|
[ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
|
||||||
|
|
|
@ -17,6 +17,8 @@ TUPLE: duration
|
||||||
|
|
||||||
C: <duration> duration
|
C: <duration> duration
|
||||||
|
|
||||||
|
: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
|
||||||
|
|
||||||
TUPLE: timestamp
|
TUPLE: timestamp
|
||||||
{ year integer }
|
{ year integer }
|
||||||
{ month integer }
|
{ month integer }
|
||||||
|
@ -34,6 +36,15 @@ C: <timestamp> timestamp
|
||||||
: <date> ( year month day -- timestamp )
|
: <date> ( year month day -- timestamp )
|
||||||
0 0 0 gmt-offset-duration <timestamp> ;
|
0 0 0 gmt-offset-duration <timestamp> ;
|
||||||
|
|
||||||
|
: <date-gmt> ( year month day -- timestamp )
|
||||||
|
0 0 0 instant <timestamp> ;
|
||||||
|
|
||||||
|
: <year> ( year -- timestamp )
|
||||||
|
1 1 <date> ;
|
||||||
|
|
||||||
|
: <year-gmt> ( year -- timestamp )
|
||||||
|
1 1 <date-gmt> ;
|
||||||
|
|
||||||
ERROR: not-a-month ;
|
ERROR: not-a-month ;
|
||||||
M: not-a-month summary
|
M: not-a-month summary
|
||||||
drop "Months are indexed starting at 1" ;
|
drop "Months are indexed starting at 1" ;
|
||||||
|
@ -51,8 +62,16 @@ CONSTANT: month-names
|
||||||
"July" "August" "September" "October" "November" "December"
|
"July" "August" "September" "October" "November" "December"
|
||||||
}
|
}
|
||||||
|
|
||||||
: month-name ( n -- string )
|
<PRIVATE
|
||||||
check-month 1 - month-names nth ;
|
|
||||||
|
: (month-name) ( n -- string ) 1 - month-names nth ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
GENERIC: month-name ( obj -- string )
|
||||||
|
|
||||||
|
M: integer month-name check-month 1 - month-names nth ;
|
||||||
|
M: timestamp month-name month>> 1 - month-names nth ;
|
||||||
|
|
||||||
CONSTANT: month-abbreviations
|
CONSTANT: month-abbreviations
|
||||||
{
|
{
|
||||||
|
@ -65,12 +84,8 @@ CONSTANT: month-abbreviations
|
||||||
|
|
||||||
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
|
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
|
||||||
|
|
||||||
: day-names ( -- array )
|
CONSTANT: day-names
|
||||||
{
|
{ "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" }
|
||||||
"Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
|
|
||||||
} ;
|
|
||||||
|
|
||||||
: day-name ( n -- string ) day-names nth ;
|
|
||||||
|
|
||||||
CONSTANT: day-abbreviations2
|
CONSTANT: day-abbreviations2
|
||||||
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
|
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
|
||||||
|
@ -119,16 +134,16 @@ GENERIC: easter ( obj -- obj' )
|
||||||
|
|
||||||
:: easter-month-day ( year -- month day )
|
:: easter-month-day ( year -- month day )
|
||||||
year 19 mod :> a
|
year 19 mod :> a
|
||||||
year 100 /mod :> c :> b
|
year 100 /mod :> ( b c )
|
||||||
b 4 /mod :> e :> d
|
b 4 /mod :> ( d e )
|
||||||
b 8 + 25 /i :> f
|
b 8 + 25 /i :> f
|
||||||
b f - 1 + 3 /i :> g
|
b f - 1 + 3 /i :> g
|
||||||
19 a * b + d - g - 15 + 30 mod :> h
|
19 a * b + d - g - 15 + 30 mod :> h
|
||||||
c 4 /mod :> k :> i
|
c 4 /mod :> ( i k )
|
||||||
32 2 e * + 2 i * + h - k - 7 mod :> l
|
32 2 e * + 2 i * + h - k - 7 mod :> l
|
||||||
a 11 h * + 22 l * + 451 /i :> m
|
a 11 h * + 22 l * + 451 /i :> m
|
||||||
|
|
||||||
h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
|
h l + 7 m * - 114 + 31 /mod 1 + :> ( month day )
|
||||||
month day ;
|
month day ;
|
||||||
|
|
||||||
M: integer easter ( year -- timestamp )
|
M: integer easter ( year -- timestamp )
|
||||||
|
@ -145,7 +160,6 @@ M: timestamp easter ( timestamp -- timestamp )
|
||||||
: >time< ( timestamp -- hour minute second )
|
: >time< ( timestamp -- hour minute second )
|
||||||
[ hour>> ] [ minute>> ] [ second>> ] tri ;
|
[ hour>> ] [ minute>> ] [ second>> ] tri ;
|
||||||
|
|
||||||
: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
|
|
||||||
: years ( x -- duration ) instant clone swap >>year ;
|
: years ( x -- duration ) instant clone swap >>year ;
|
||||||
: months ( x -- duration ) instant clone swap >>month ;
|
: months ( x -- duration ) instant clone swap >>month ;
|
||||||
: days ( x -- duration ) instant clone swap >>day ;
|
: days ( x -- duration ) instant clone swap >>day ;
|
||||||
|
@ -157,6 +171,18 @@ M: timestamp easter ( timestamp -- timestamp )
|
||||||
: microseconds ( x -- duration ) 1000000 / seconds ;
|
: microseconds ( x -- duration ) 1000000 / seconds ;
|
||||||
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
|
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
|
||||||
|
|
||||||
|
GENERIC: year ( obj -- n )
|
||||||
|
M: integer year ;
|
||||||
|
M: timestamp year year>> ;
|
||||||
|
|
||||||
|
GENERIC: month ( obj -- n )
|
||||||
|
M: integer month ;
|
||||||
|
M: timestamp month month>> ;
|
||||||
|
|
||||||
|
GENERIC: day ( obj -- n )
|
||||||
|
M: integer day ;
|
||||||
|
M: timestamp day day>> ;
|
||||||
|
|
||||||
GENERIC: leap-year? ( obj -- ? )
|
GENERIC: leap-year? ( obj -- ? )
|
||||||
|
|
||||||
M: integer leap-year? ( year -- ? )
|
M: integer leap-year? ( year -- ? )
|
||||||
|
@ -305,6 +331,9 @@ GENERIC: time- ( time1 time2 -- time3 )
|
||||||
M: timestamp <=> ( ts1 ts2 -- n )
|
M: timestamp <=> ( ts1 ts2 -- n )
|
||||||
[ >gmt tuple-slots ] compare ;
|
[ >gmt tuple-slots ] compare ;
|
||||||
|
|
||||||
|
: same-day? ( ts1 ts2 -- ? )
|
||||||
|
[ >gmt >date< <date> ] bi@ = ;
|
||||||
|
|
||||||
: (time-) ( timestamp timestamp -- n )
|
: (time-) ( timestamp timestamp -- n )
|
||||||
[ >gmt ] bi@
|
[ >gmt ] bi@
|
||||||
[ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
|
[ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
|
||||||
|
@ -387,6 +416,10 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
|
||||||
: day-of-week ( timestamp -- n )
|
: day-of-week ( timestamp -- n )
|
||||||
>date< zeller-congruence ;
|
>date< zeller-congruence ;
|
||||||
|
|
||||||
|
GENERIC: day-name ( obj -- string )
|
||||||
|
M: integer day-name day-names nth ;
|
||||||
|
M: timestamp day-name day-of-week day-names nth ;
|
||||||
|
|
||||||
:: (day-of-year) ( year month day -- n )
|
:: (day-of-year) ( year month day -- n )
|
||||||
day-counts month head-slice sum day +
|
day-counts month head-slice sum day +
|
||||||
year leap-year? [
|
year leap-year? [
|
||||||
|
@ -398,22 +431,6 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
|
||||||
: day-of-year ( timestamp -- n )
|
: day-of-year ( timestamp -- n )
|
||||||
>date< (day-of-year) ;
|
>date< (day-of-year) ;
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
: day-offset ( timestamp m -- timestamp n )
|
|
||||||
over day-of-week - ; inline
|
|
||||||
|
|
||||||
: day-this-week ( timestamp n -- timestamp )
|
|
||||||
day-offset days time+ ;
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
|
|
||||||
: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
|
|
||||||
: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
|
|
||||||
: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ;
|
|
||||||
: thursday ( timestamp -- new-timestamp ) 4 day-this-week ;
|
|
||||||
: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
|
|
||||||
: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
|
|
||||||
|
|
||||||
: midnight ( timestamp -- new-timestamp )
|
: midnight ( timestamp -- new-timestamp )
|
||||||
clone 0 >>hour 0 >>minute 0 >>second ; inline
|
clone 0 >>hour 0 >>minute 0 >>second ; inline
|
||||||
|
|
||||||
|
@ -423,11 +440,108 @@ PRIVATE>
|
||||||
: beginning-of-month ( timestamp -- new-timestamp )
|
: beginning-of-month ( timestamp -- new-timestamp )
|
||||||
midnight 1 >>day ;
|
midnight 1 >>day ;
|
||||||
|
|
||||||
|
: end-of-month ( timestamp -- new-timestamp )
|
||||||
|
[ midnight ] [ days-in-month ] bi >>day ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: day-offset ( timestamp m -- new-timestamp n )
|
||||||
|
over day-of-week - ; inline
|
||||||
|
|
||||||
|
: day-this-week ( timestamp n -- new-timestamp )
|
||||||
|
day-offset days time+ ;
|
||||||
|
|
||||||
|
:: nth-day-this-month ( timestamp n day -- new-timestamp )
|
||||||
|
timestamp beginning-of-month day day-this-week
|
||||||
|
dup timestamp [ month>> ] bi@ = [ 1 weeks time+ ] unless
|
||||||
|
n 1 - [ weeks time+ ] unless-zero ;
|
||||||
|
|
||||||
|
: last-day-this-month ( timestamp day -- new-timestamp )
|
||||||
|
[ 1 months time+ 1 ] dip nth-day-this-month 1 weeks time- ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
GENERIC: january ( obj -- timestamp )
|
||||||
|
GENERIC: february ( obj -- timestamp )
|
||||||
|
GENERIC: march ( obj -- timestamp )
|
||||||
|
GENERIC: april ( obj -- timestamp )
|
||||||
|
GENERIC: may ( obj -- timestamp )
|
||||||
|
GENERIC: june ( obj -- timestamp )
|
||||||
|
GENERIC: july ( obj -- timestamp )
|
||||||
|
GENERIC: august ( obj -- timestamp )
|
||||||
|
GENERIC: september ( obj -- timestamp )
|
||||||
|
GENERIC: october ( obj -- timestamp )
|
||||||
|
GENERIC: november ( obj -- timestamp )
|
||||||
|
GENERIC: december ( obj -- timestamp )
|
||||||
|
|
||||||
|
M: integer january 1 1 <date> ;
|
||||||
|
M: integer february 2 1 <date> ;
|
||||||
|
M: integer march 3 1 <date> ;
|
||||||
|
M: integer april 4 1 <date> ;
|
||||||
|
M: integer may 5 1 <date> ;
|
||||||
|
M: integer june 6 1 <date> ;
|
||||||
|
M: integer july 7 1 <date> ;
|
||||||
|
M: integer august 8 1 <date> ;
|
||||||
|
M: integer september 9 1 <date> ;
|
||||||
|
M: integer october 10 1 <date> ;
|
||||||
|
M: integer november 11 1 <date> ;
|
||||||
|
M: integer december 12 1 <date> ;
|
||||||
|
|
||||||
|
M: timestamp january clone 1 >>month ;
|
||||||
|
M: timestamp february clone 2 >>month ;
|
||||||
|
M: timestamp march clone 3 >>month ;
|
||||||
|
M: timestamp april clone 4 >>month ;
|
||||||
|
M: timestamp may clone 5 >>month ;
|
||||||
|
M: timestamp june clone 6 >>month ;
|
||||||
|
M: timestamp july clone 7 >>month ;
|
||||||
|
M: timestamp august clone 8 >>month ;
|
||||||
|
M: timestamp september clone 9 >>month ;
|
||||||
|
M: timestamp october clone 10 >>month ;
|
||||||
|
M: timestamp november clone 11 >>month ;
|
||||||
|
M: timestamp december clone 12 >>month ;
|
||||||
|
|
||||||
|
: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
|
||||||
|
: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
|
||||||
|
: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
|
||||||
|
: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ;
|
||||||
|
: thursday ( timestamp -- new-timestamp ) 4 day-this-week ;
|
||||||
|
: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
|
||||||
|
: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
|
||||||
|
|
||||||
|
: sunday? ( timestamp -- ? ) day-of-week 0 = ;
|
||||||
|
: monday? ( timestamp -- ? ) day-of-week 1 = ;
|
||||||
|
: tuesday? ( timestamp -- ? ) day-of-week 2 = ;
|
||||||
|
: wednesday? ( timestamp -- ? ) day-of-week 3 = ;
|
||||||
|
: thursday? ( timestamp -- ? ) day-of-week 4 = ;
|
||||||
|
: friday? ( timestamp -- ? ) day-of-week 5 = ;
|
||||||
|
: saturday? ( timestamp -- ? ) day-of-week 6 = ;
|
||||||
|
|
||||||
|
: sunday-of-month ( timestamp n -- new-timestamp ) 0 nth-day-this-month ;
|
||||||
|
: monday-of-month ( timestamp n -- new-timestamp ) 1 nth-day-this-month ;
|
||||||
|
: tuesday-of-month ( timestamp n -- new-timestamp ) 2 nth-day-this-month ;
|
||||||
|
: wednesday-of-month ( timestamp n -- new-timestamp ) 3 nth-day-this-month ;
|
||||||
|
: thursday-of-month ( timestamp n -- new-timestamp ) 4 nth-day-this-month ;
|
||||||
|
: friday-of-month ( timestamp n -- new-timestamp ) 5 nth-day-this-month ;
|
||||||
|
: saturday-of-month ( timestamp n -- new-timestamp ) 6 nth-day-this-month ;
|
||||||
|
|
||||||
|
: last-sunday-of-month ( timestamp -- new-timestamp ) 0 last-day-this-month ;
|
||||||
|
: last-monday-of-month ( timestamp -- new-timestamp ) 1 last-day-this-month ;
|
||||||
|
: last-tuesday-of-month ( timestamp -- new-timestamp ) 2 last-day-this-month ;
|
||||||
|
: last-wednesday-of-month ( timestamp -- new-timestamp ) 3 last-day-this-month ;
|
||||||
|
: last-thursday-of-month ( timestamp -- new-timestamp ) 4 last-day-this-month ;
|
||||||
|
: last-friday-of-month ( timestamp -- new-timestamp ) 5 last-day-this-month ;
|
||||||
|
: last-saturday-of-month ( timestamp -- new-timestamp ) 6 last-day-this-month ;
|
||||||
|
|
||||||
: beginning-of-week ( timestamp -- new-timestamp )
|
: beginning-of-week ( timestamp -- new-timestamp )
|
||||||
midnight sunday ;
|
midnight sunday ;
|
||||||
|
|
||||||
: beginning-of-year ( timestamp -- new-timestamp )
|
GENERIC: beginning-of-year ( object -- new-timestamp )
|
||||||
beginning-of-month 1 >>month ;
|
M: timestamp beginning-of-year beginning-of-month 1 >>month ;
|
||||||
|
M: integer beginning-of-year <year> ;
|
||||||
|
|
||||||
|
GENERIC: end-of-year ( object -- new-timestamp )
|
||||||
|
M: timestamp end-of-year 12 >>month 31 >>day ;
|
||||||
|
M: integer end-of-year 12 31 <date> ;
|
||||||
|
|
||||||
: time-since-midnight ( timestamp -- duration )
|
: time-since-midnight ( timestamp -- duration )
|
||||||
dup midnight time- ;
|
dup midnight time- ;
|
||||||
|
@ -435,6 +549,12 @@ PRIVATE>
|
||||||
: since-1970 ( duration -- timestamp )
|
: since-1970 ( duration -- timestamp )
|
||||||
unix-1970 time+ >local-time ;
|
unix-1970 time+ >local-time ;
|
||||||
|
|
||||||
|
: timestamp>unix-time ( timestamp -- seconds )
|
||||||
|
unix-1970 time- second>> ;
|
||||||
|
|
||||||
|
: unix-time>timestamp ( seconds -- timestamp )
|
||||||
|
seconds unix-1970 time+ ;
|
||||||
|
|
||||||
M: timestamp sleep-until timestamp>micros sleep-until ;
|
M: timestamp sleep-until timestamp>micros sleep-until ;
|
||||||
|
|
||||||
M: duration sleep hence sleep-until ;
|
M: duration sleep hence sleep-until ;
|
||||||
|
|
|
@ -14,6 +14,9 @@ IN: calendar.unix
|
||||||
: timespec>seconds ( timespec -- seconds )
|
: timespec>seconds ( timespec -- seconds )
|
||||||
[ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
|
[ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
|
||||||
|
|
||||||
|
: timespec>nanoseconds ( timespec -- seconds )
|
||||||
|
[ sec>> 1000000000 * ] [ nsec>> ] bi + ;
|
||||||
|
|
||||||
: timespec>unix-time ( timespec -- timestamp )
|
: timespec>unix-time ( timespec -- timestamp )
|
||||||
timespec>seconds since-1970 ;
|
timespec>seconds since-1970 ;
|
||||||
|
|
||||||
|
|
|
@ -25,12 +25,11 @@ IN: channels.examples
|
||||||
] 3keep filter ;
|
] 3keep filter ;
|
||||||
|
|
||||||
:: (sieve) ( prime c -- )
|
:: (sieve) ( prime c -- )
|
||||||
[let | p [ c from ]
|
c from :> p
|
||||||
newc [ <channel> ] |
|
<channel> :> newc
|
||||||
p prime to
|
p prime to
|
||||||
[ newc p c filter ] "Filter" spawn drop
|
[ newc p c filter ] "Filter" spawn drop
|
||||||
prime newc (sieve)
|
prime newc (sieve) ;
|
||||||
] ;
|
|
||||||
|
|
||||||
: sieve ( prime -- )
|
: sieve ( prime -- )
|
||||||
#! Send prime numbers to 'prime' channel
|
#! Send prime numbers to 'prime' channel
|
||||||
|
|
|
@ -53,11 +53,11 @@ $nl
|
||||||
" to be accessed remotely. " { $link publish } " returns an id which a remote node "
|
" to be accessed remotely. " { $link publish } " returns an id which a remote node "
|
||||||
"needs to know to access the channel."
|
"needs to know to access the channel."
|
||||||
$nl
|
$nl
|
||||||
{ $snippet "channel [ from . ] spawn drop dup publish" }
|
{ $snippet "<channel> dup [ from . flush ] curry \"test\" spawn drop publish" }
|
||||||
$nl
|
$nl
|
||||||
"Given the id from the snippet above, a remote node can put items in the channel."
|
"Given the id from the snippet above, a remote node can put items in the channel (where 123456 is the id):"
|
||||||
$nl
|
$nl
|
||||||
{ $snippet "\"myhost.com\" 9001 <node> \"ID123456\" <remote-channel>\n\"hello\" over to" }
|
{ $snippet "\"myhost.com\" 9001 <node> 123456 <remote-channel>\n\"hello\" over to" }
|
||||||
;
|
;
|
||||||
|
|
||||||
ABOUT: { "remote-channels" "remote-channels" }
|
ABOUT: { "remote-channels" "remote-channels" }
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
!
|
!
|
||||||
! Remote Channels
|
! Remote Channels
|
||||||
USING: kernel init namespaces make assocs arrays random
|
USING: kernel init namespaces assocs arrays random
|
||||||
sequences channels match concurrency.messaging
|
sequences channels match concurrency.messaging
|
||||||
concurrency.distributed threads accessors ;
|
concurrency.distributed threads accessors ;
|
||||||
IN: channels.remote
|
IN: channels.remote
|
||||||
|
@ -27,39 +27,44 @@ PRIVATE>
|
||||||
MATCH-VARS: ?from ?tag ?id ?value ;
|
MATCH-VARS: ?from ?tag ?id ?value ;
|
||||||
|
|
||||||
SYMBOL: no-channel
|
SYMBOL: no-channel
|
||||||
|
TUPLE: to-message id value ;
|
||||||
|
TUPLE: from-message id ;
|
||||||
|
|
||||||
: channel-process ( -- )
|
: channel-thread ( -- )
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
{ { to ?id ?value }
|
{ T{ to-message f ?id ?value }
|
||||||
[ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
|
[ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
|
||||||
{ { from ?id }
|
{ T{ from-message f ?id }
|
||||||
[ ?id get-channel [ from ] [ no-channel ] if* ] }
|
[ ?id get-channel [ from ] [ no-channel ] if* ] }
|
||||||
} match-cond
|
} match-cond
|
||||||
] handle-synchronous ;
|
] handle-synchronous ;
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: start-channel-node ( -- )
|
: start-channel-node ( -- )
|
||||||
"remote-channels" get-process [
|
"remote-channels" get-remote-thread [
|
||||||
"remote-channels"
|
[ channel-thread t ] "Remote channels" spawn-server
|
||||||
[ channel-process t ] "Remote channels" spawn-server
|
"remote-channels" register-remote-thread
|
||||||
register-process
|
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
TUPLE: remote-channel node id ;
|
TUPLE: remote-channel node id ;
|
||||||
|
|
||||||
C: <remote-channel> remote-channel
|
C: <remote-channel> remote-channel
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: send-message ( message remote-channel -- value )
|
||||||
|
node>> "remote-channels" <remote-thread>
|
||||||
|
send-synchronous dup no-channel = [ no-channel throw ] when* ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
M: remote-channel to ( value remote-channel -- )
|
M: remote-channel to ( value remote-channel -- )
|
||||||
[ [ \ to , id>> , , ] { } make ] keep
|
[ id>> swap to-message boa ] keep send-message drop ;
|
||||||
node>> "remote-channels" <remote-process>
|
|
||||||
send-synchronous no-channel = [ no-channel throw ] when ;
|
|
||||||
|
|
||||||
M: remote-channel from ( remote-channel -- value )
|
M: remote-channel from ( remote-channel -- value )
|
||||||
[ [ \ from , id>> , ] { } make ] keep
|
[ id>> from-message boa ] keep send-message ;
|
||||||
node>> "remote-channels" <remote-process>
|
|
||||||
send-synchronous dup no-channel = [ no-channel throw ] when* ;
|
|
||||||
|
|
||||||
[
|
[
|
||||||
H{ } clone \ remote-channels set-global
|
H{ } clone \ remote-channels set-global
|
||||||
|
|
|
@ -24,7 +24,7 @@ PRIVATE>
|
||||||
|
|
||||||
:: hmac-stream ( stream key checksum -- value )
|
:: hmac-stream ( stream key checksum -- value )
|
||||||
checksum initialize-checksum-state :> checksum-state
|
checksum initialize-checksum-state :> checksum-state
|
||||||
checksum key checksum-state init-key :> Ki :> Ko
|
checksum key checksum-state init-key :> ( Ko Ki )
|
||||||
checksum-state Ki add-checksum-bytes
|
checksum-state Ki add-checksum-bytes
|
||||||
stream add-checksum-stream get-checksum
|
stream add-checksum-stream get-checksum
|
||||||
checksum initialize-checksum-state
|
checksum initialize-checksum-state
|
||||||
|
|
|
@ -21,7 +21,7 @@ M: circular length seq>> length ;
|
||||||
|
|
||||||
M: circular virtual@ circular-wrap seq>> ;
|
M: circular virtual@ circular-wrap seq>> ;
|
||||||
|
|
||||||
M: circular virtual-seq seq>> ;
|
M: circular virtual-exemplar seq>> ;
|
||||||
|
|
||||||
: change-circular-start ( n circular -- )
|
: change-circular-start ( n circular -- )
|
||||||
#! change start to (start + n) mod length
|
#! change start to (start + n) mod length
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: classes.struct.bit-accessors
|
||||||
[ 2^ 1 - ] bi@ swap bitnot bitand ;
|
[ 2^ 1 - ] bi@ swap bitnot bitand ;
|
||||||
|
|
||||||
:: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' )
|
:: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' )
|
||||||
offset 8 /mod :> start-bit :> i
|
offset 8 /mod :> ( i start-bit )
|
||||||
start-bit bits + 8 min :> end-bit
|
start-bit bits + 8 min :> end-bit
|
||||||
start-bit end-bit ones-between :> mask
|
start-bit end-bit ones-between :> mask
|
||||||
end-bit start-bit - :> used-bits
|
end-bit start-bit - :> used-bits
|
||||||
|
|
|
@ -365,3 +365,18 @@ STRUCT: bit-field-test
|
||||||
[ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
|
[ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
|
||||||
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
|
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
|
||||||
[ 3 ] [ bit-field-test heap-size ] unit-test
|
[ 3 ] [ bit-field-test heap-size ] unit-test
|
||||||
|
|
||||||
|
cpu ppc? [
|
||||||
|
STRUCT: ppc-align-test-1
|
||||||
|
{ x longlong }
|
||||||
|
{ y int } ;
|
||||||
|
|
||||||
|
[ 16 ] [ ppc-align-test-1 heap-size ] unit-test
|
||||||
|
|
||||||
|
STRUCT: ppc-align-test-2
|
||||||
|
{ y int }
|
||||||
|
{ x longlong } ;
|
||||||
|
|
||||||
|
[ 12 ] [ ppc-align-test-2 heap-size ] unit-test
|
||||||
|
[ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
|
||||||
|
] when
|
||||||
|
|
|
@ -211,27 +211,32 @@ M: struct-c-type c-struct? drop t ;
|
||||||
slots >>fields
|
slots >>fields
|
||||||
size >>size
|
size >>size
|
||||||
align >>align
|
align >>align
|
||||||
|
align >>align-first
|
||||||
class (unboxer-quot) >>unboxer-quot
|
class (unboxer-quot) >>unboxer-quot
|
||||||
class (boxer-quot) >>boxer-quot ;
|
class (boxer-quot) >>boxer-quot ;
|
||||||
|
|
||||||
GENERIC: align-offset ( offset class -- offset' )
|
|
||||||
|
|
||||||
M: struct-slot-spec align-offset
|
GENERIC: compute-slot-offset ( offset class -- offset' )
|
||||||
[ type>> c-type-align 8 * align ] keep
|
|
||||||
|
: c-type-align-at ( class offset -- n )
|
||||||
|
0 = [ c-type-align-first ] [ c-type-align ] if ;
|
||||||
|
|
||||||
|
M: struct-slot-spec compute-slot-offset
|
||||||
|
[ type>> over c-type-align-at 8 * align ] keep
|
||||||
[ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;
|
[ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;
|
||||||
|
|
||||||
M: struct-bit-slot-spec align-offset
|
M: struct-bit-slot-spec compute-slot-offset
|
||||||
[ (>>offset) ] [ bits>> + ] 2bi ;
|
[ (>>offset) ] [ bits>> + ] 2bi ;
|
||||||
|
|
||||||
: struct-offsets ( slots -- size )
|
: compute-struct-offsets ( slots -- size )
|
||||||
0 [ align-offset ] reduce 8 align 8 /i ;
|
0 [ compute-slot-offset ] reduce 8 align 8 /i ;
|
||||||
|
|
||||||
: union-struct-offsets ( slots -- size )
|
: compute-union-offsets ( slots -- size )
|
||||||
1 [ 0 >>offset type>> heap-size max ] reduce ;
|
1 [ 0 >>offset type>> heap-size max ] reduce ;
|
||||||
|
|
||||||
: struct-align ( slots -- align )
|
: struct-alignment ( slots -- align )
|
||||||
[ struct-bit-slot-spec? not ] filter
|
[ struct-bit-slot-spec? not ] filter
|
||||||
1 [ type>> c-type-align max ] reduce ;
|
1 [ [ type>> ] [ offset>> ] bi c-type-align-at max ] reduce ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
M: struct byte-length class "struct-size" word-prop ; foldable
|
M: struct byte-length class "struct-size" word-prop ; foldable
|
||||||
|
@ -243,10 +248,8 @@ GENERIC: binary-zero? ( value -- ? )
|
||||||
|
|
||||||
M: object binary-zero? drop f ;
|
M: object binary-zero? drop f ;
|
||||||
M: f binary-zero? drop t ;
|
M: f binary-zero? drop t ;
|
||||||
M: number binary-zero? zero? ;
|
M: number binary-zero? 0 = ;
|
||||||
M: struct binary-zero?
|
M: struct binary-zero? >c-ptr [ 0 = ] all? ;
|
||||||
[ byte-length iota ] [ >c-ptr ] bi
|
|
||||||
[ <displaced-alien> *uchar zero? ] curry all? ;
|
|
||||||
|
|
||||||
: struct-needs-prototype? ( class -- ? )
|
: struct-needs-prototype? ( class -- ? )
|
||||||
struct-slots [ initial>> binary-zero? ] all? not ;
|
struct-slots [ initial>> binary-zero? ] all? not ;
|
||||||
|
@ -278,7 +281,7 @@ M: struct binary-zero?
|
||||||
slots empty? [ struct-must-have-slots ] when
|
slots empty? [ struct-must-have-slots ] when
|
||||||
class redefine-struct-tuple-class
|
class redefine-struct-tuple-class
|
||||||
slots make-slots dup check-struct-slots :> slot-specs
|
slots make-slots dup check-struct-slots :> slot-specs
|
||||||
slot-specs struct-align :> alignment
|
slot-specs struct-alignment :> alignment
|
||||||
slot-specs offsets-quot call alignment align :> size
|
slot-specs offsets-quot call alignment align :> size
|
||||||
|
|
||||||
class slot-specs size alignment c-type-for-class :> c-type
|
class slot-specs size alignment c-type-for-class :> c-type
|
||||||
|
@ -291,10 +294,10 @@ M: struct binary-zero?
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: define-struct-class ( class slots -- )
|
: define-struct-class ( class slots -- )
|
||||||
[ struct-offsets ] (define-struct-class) ;
|
[ compute-struct-offsets ] (define-struct-class) ;
|
||||||
|
|
||||||
: define-union-struct-class ( class slots -- )
|
: define-union-struct-class ( class slots -- )
|
||||||
[ union-struct-offsets ] (define-struct-class) ;
|
[ compute-union-offsets ] (define-struct-class) ;
|
||||||
|
|
||||||
M: struct-class reset-class
|
M: struct-class reset-class
|
||||||
[ call-next-method ] [ name>> c-types get delete-at ] bi ;
|
[ call-next-method ] [ name>> c-types get delete-at ] bi ;
|
||||||
|
@ -350,7 +353,7 @@ PRIVATE>
|
||||||
: parse-struct-slots ( slots -- slots' more? )
|
: parse-struct-slots ( slots -- slots' more? )
|
||||||
scan {
|
scan {
|
||||||
{ ";" [ f ] }
|
{ ";" [ f ] }
|
||||||
{ "{" [ parse-struct-slot over push t ] }
|
{ "{" [ parse-struct-slot suffix! t ] }
|
||||||
{ f [ unexpected-eof ] }
|
{ f [ unexpected-eof ] }
|
||||||
[ invalid-struct-slot ]
|
[ invalid-struct-slot ]
|
||||||
} case ;
|
} case ;
|
||||||
|
@ -365,10 +368,10 @@ SYNTAX: UNION-STRUCT:
|
||||||
parse-struct-definition define-union-struct-class ;
|
parse-struct-definition define-union-struct-class ;
|
||||||
|
|
||||||
SYNTAX: S{
|
SYNTAX: S{
|
||||||
scan-word dup struct-slots parse-tuple-literal-slots parsed ;
|
scan-word dup struct-slots parse-tuple-literal-slots suffix! ;
|
||||||
|
|
||||||
SYNTAX: S@
|
SYNTAX: S@
|
||||||
scan-word scan-object swap memory>struct parsed ;
|
scan-word scan-object swap memory>struct suffix! ;
|
||||||
|
|
||||||
! functor support
|
! functor support
|
||||||
|
|
||||||
|
@ -378,7 +381,7 @@ SYNTAX: S@
|
||||||
|
|
||||||
: parse-struct-slot` ( accum -- accum )
|
: parse-struct-slot` ( accum -- accum )
|
||||||
scan-string-param scan-c-type` \ } parse-until
|
scan-string-param scan-c-type` \ } parse-until
|
||||||
[ <struct-slot-spec> over push ] 3curry over push-all ;
|
[ <struct-slot-spec> suffix! ] 3curry append! ;
|
||||||
|
|
||||||
: parse-struct-slots` ( accum -- accum more? )
|
: parse-struct-slots` ( accum -- accum more? )
|
||||||
scan {
|
scan {
|
||||||
|
@ -389,10 +392,10 @@ SYNTAX: S@
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
FUNCTOR-SYNTAX: STRUCT:
|
FUNCTOR-SYNTAX: STRUCT:
|
||||||
scan-param parsed
|
scan-param suffix!
|
||||||
[ 8 <vector> ] over push-all
|
[ 8 <vector> ] append!
|
||||||
[ parse-struct-slots` ] [ ] while
|
[ parse-struct-slots` ] [ ] while
|
||||||
[ >array define-struct-class ] over push-all ;
|
[ >array define-struct-class ] append! ;
|
||||||
|
|
||||||
USING: vocabs vocabs.loader ;
|
USING: vocabs vocabs.loader ;
|
||||||
|
|
||||||
|
|
|
@ -16,11 +16,11 @@ CLASS: {
|
||||||
{ +superclass+ "NSObject" }
|
{ +superclass+ "NSObject" }
|
||||||
}
|
}
|
||||||
|
|
||||||
{ "perform:" "void" { "id" "SEL" "id" }
|
{ "perform:" void { id SEL id }
|
||||||
[ 2drop callbacks get at try ]
|
[ 2drop callbacks get at try ]
|
||||||
}
|
}
|
||||||
|
|
||||||
{ "dealloc" "void" { "id" "SEL" }
|
{ "dealloc" void { id SEL }
|
||||||
[
|
[
|
||||||
drop
|
drop
|
||||||
dup callbacks get delete-at
|
dup callbacks get delete-at
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
|
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
|
||||||
compiler kernel namespaces cocoa.classes tools.test memory
|
compiler kernel namespaces cocoa.classes cocoa.runtime
|
||||||
compiler.units math core-graphics.types ;
|
tools.test memory compiler.units math core-graphics.types ;
|
||||||
|
FROM: alien.c-types => int void ;
|
||||||
IN: cocoa.tests
|
IN: cocoa.tests
|
||||||
|
|
||||||
CLASS: {
|
CLASS: {
|
||||||
|
@ -8,8 +9,8 @@ CLASS: {
|
||||||
{ +name+ "Foo" }
|
{ +name+ "Foo" }
|
||||||
} {
|
} {
|
||||||
"foo:"
|
"foo:"
|
||||||
"void"
|
void
|
||||||
{ "id" "SEL" "NSRect" }
|
{ id SEL NSRect }
|
||||||
[ gc "x" set 2drop ]
|
[ gc "x" set 2drop ]
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
@ -30,8 +31,8 @@ CLASS: {
|
||||||
{ +name+ "Bar" }
|
{ +name+ "Bar" }
|
||||||
} {
|
} {
|
||||||
"bar"
|
"bar"
|
||||||
"NSRect"
|
NSRect
|
||||||
{ "id" "SEL" }
|
{ id SEL }
|
||||||
[ 2drop test-foo "x" get ]
|
[ 2drop test-foo "x" get ]
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
@ -52,13 +53,13 @@ CLASS: {
|
||||||
{ +name+ "Bar" }
|
{ +name+ "Bar" }
|
||||||
} {
|
} {
|
||||||
"bar"
|
"bar"
|
||||||
"NSRect"
|
NSRect
|
||||||
{ "id" "SEL" }
|
{ id SEL }
|
||||||
[ 2drop test-foo "x" get ]
|
[ 2drop test-foo "x" get ]
|
||||||
} {
|
} {
|
||||||
"babb"
|
"babb"
|
||||||
"int"
|
int
|
||||||
{ "id" "SEL" "int" }
|
{ id SEL int }
|
||||||
[ 2nip sq ]
|
[ 2nip sq ]
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
|
|
@ -14,14 +14,14 @@ SYMBOL: sent-messages
|
||||||
: remember-send ( selector -- )
|
: remember-send ( selector -- )
|
||||||
sent-messages (remember-send) ;
|
sent-messages (remember-send) ;
|
||||||
|
|
||||||
SYNTAX: -> scan dup remember-send parsed \ send parsed ;
|
SYNTAX: -> scan dup remember-send suffix! \ send suffix! ;
|
||||||
|
|
||||||
SYMBOL: super-sent-messages
|
SYMBOL: super-sent-messages
|
||||||
|
|
||||||
: remember-super-send ( selector -- )
|
: remember-super-send ( selector -- )
|
||||||
super-sent-messages (remember-send) ;
|
super-sent-messages (remember-send) ;
|
||||||
|
|
||||||
SYNTAX: SUPER-> scan dup remember-super-send parsed \ super-send parsed ;
|
SYNTAX: SUPER-> scan dup remember-super-send suffix! \ super-send suffix! ;
|
||||||
|
|
||||||
SYMBOL: frameworks
|
SYMBOL: frameworks
|
||||||
|
|
||||||
|
|
|
@ -2,13 +2,13 @@ USING: help.markup help.syntax strings alien ;
|
||||||
IN: cocoa.messages
|
IN: cocoa.messages
|
||||||
|
|
||||||
HELP: send
|
HELP: send
|
||||||
{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
|
{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
|
||||||
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to " { $snippet "receiver" } ". The arguments must be on the stack in left-to-right order." }
|
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to " { $snippet "receiver" } ". The arguments must be on the stack in left-to-right order." }
|
||||||
{ $errors "Throws an error if the receiver does not recognize the message, or if the arguments have inappropriate types." }
|
{ $errors "Throws an error if the receiver does not recognize the message, or if the arguments have inappropriate types." }
|
||||||
{ $notes "This word uses a special fast code path if " { $snippet "selector" } " is a literal and the word containing the call to " { $link send } " is compiled." } ;
|
{ $notes "This word uses a special fast code path if " { $snippet "selector" } " is a literal and the word containing the call to " { $link send } " is compiled." } ;
|
||||||
|
|
||||||
HELP: super-send
|
HELP: super-send
|
||||||
{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
|
{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
|
||||||
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to the super class of " { $snippet "receiver" } ". Otherwise behaves identically to " { $link send } "." } ;
|
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to the super class of " { $snippet "receiver" } ". Otherwise behaves identically to " { $link send } "." } ;
|
||||||
|
|
||||||
HELP: objc-class
|
HELP: objc-class
|
||||||
|
|
|
@ -2,10 +2,12 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors alien alien.c-types alien.strings arrays assocs
|
USING: accessors alien alien.c-types alien.strings arrays assocs
|
||||||
classes.struct continuations combinators compiler compiler.alien
|
classes.struct continuations combinators compiler compiler.alien
|
||||||
stack-checker kernel math namespaces make quotations sequences
|
core-graphics.types stack-checker kernel math namespaces make
|
||||||
strings words cocoa.runtime io macros memoize io.encodings.utf8
|
quotations sequences strings words cocoa.runtime cocoa.types io
|
||||||
effects libc libc.private lexer init core-foundation fry
|
macros memoize io.encodings.utf8 effects layouts libc
|
||||||
generalizations specialized-arrays ;
|
libc.private lexer init core-foundation fry generalizations
|
||||||
|
specialized-arrays ;
|
||||||
|
QUALIFIED-WITH: alien.c-types c
|
||||||
IN: cocoa.messages
|
IN: cocoa.messages
|
||||||
|
|
||||||
SPECIALIZED-ARRAY: void*
|
SPECIALIZED-ARRAY: void*
|
||||||
|
@ -98,75 +100,84 @@ class-startup-hooks [ H{ } clone ] initialize
|
||||||
SYMBOL: objc>alien-types
|
SYMBOL: objc>alien-types
|
||||||
|
|
||||||
H{
|
H{
|
||||||
{ "c" "char" }
|
{ "c" c:char }
|
||||||
{ "i" "int" }
|
{ "i" c:int }
|
||||||
{ "s" "short" }
|
{ "s" c:short }
|
||||||
{ "C" "uchar" }
|
{ "C" c:uchar }
|
||||||
{ "I" "uint" }
|
{ "I" c:uint }
|
||||||
{ "S" "ushort" }
|
{ "S" c:ushort }
|
||||||
{ "f" "float" }
|
{ "f" c:float }
|
||||||
{ "d" "double" }
|
{ "d" c:double }
|
||||||
{ "B" "bool" }
|
{ "B" c:bool }
|
||||||
{ "v" "void" }
|
{ "v" c:void }
|
||||||
{ "*" "char*" }
|
{ "*" c:char* }
|
||||||
{ "?" "unknown_type" }
|
{ "?" unknown_type }
|
||||||
{ "@" "id" }
|
{ "@" id }
|
||||||
{ "#" "Class" }
|
{ "#" Class }
|
||||||
{ ":" "SEL" }
|
{ ":" SEL }
|
||||||
}
|
}
|
||||||
"ptrdiff_t" heap-size {
|
cell {
|
||||||
{ 4 [ H{
|
{ 4 [ H{
|
||||||
{ "l" "long" }
|
{ "l" c:long }
|
||||||
{ "q" "longlong" }
|
{ "q" c:longlong }
|
||||||
{ "L" "ulong" }
|
{ "L" c:ulong }
|
||||||
{ "Q" "ulonglong" }
|
{ "Q" c:ulonglong }
|
||||||
} ] }
|
} ] }
|
||||||
{ 8 [ H{
|
{ 8 [ H{
|
||||||
{ "l" "long32" }
|
{ "l" long32 }
|
||||||
{ "q" "long" }
|
{ "q" long }
|
||||||
{ "L" "ulong32" }
|
{ "L" ulong32 }
|
||||||
{ "Q" "ulong" }
|
{ "Q" ulong }
|
||||||
} ] }
|
} ] }
|
||||||
} case
|
} case
|
||||||
assoc-union objc>alien-types set-global
|
assoc-union objc>alien-types set-global
|
||||||
|
|
||||||
|
SYMBOL: objc>struct-types
|
||||||
|
|
||||||
|
H{
|
||||||
|
{ "_NSPoint" NSPoint }
|
||||||
|
{ "NSPoint" NSPoint }
|
||||||
|
{ "CGPoint" NSPoint }
|
||||||
|
{ "_NSRect" NSRect }
|
||||||
|
{ "NSRect" NSRect }
|
||||||
|
{ "CGRect" NSRect }
|
||||||
|
{ "_NSSize" NSSize }
|
||||||
|
{ "NSSize" NSSize }
|
||||||
|
{ "CGSize" NSSize }
|
||||||
|
{ "_NSRange" NSRange }
|
||||||
|
{ "NSRange" NSRange }
|
||||||
|
} objc>struct-types set-global
|
||||||
|
|
||||||
! The transpose of the above map
|
! The transpose of the above map
|
||||||
SYMBOL: alien>objc-types
|
SYMBOL: alien>objc-types
|
||||||
|
|
||||||
objc>alien-types get [ swap ] assoc-map
|
objc>alien-types get [ swap ] assoc-map
|
||||||
! A hack...
|
! A hack...
|
||||||
"ptrdiff_t" heap-size {
|
cell {
|
||||||
{ 4 [ H{
|
{ 4 [ H{
|
||||||
{ "NSPoint" "{_NSPoint=ff}" }
|
{ NSPoint "{_NSPoint=ff}" }
|
||||||
{ "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
|
{ NSRect "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
|
||||||
{ "NSSize" "{_NSSize=ff}" }
|
{ NSSize "{_NSSize=ff}" }
|
||||||
{ "NSRange" "{_NSRange=II}" }
|
{ NSRange "{_NSRange=II}" }
|
||||||
{ "NSInteger" "i" }
|
{ NSInteger "i" }
|
||||||
{ "NSUInteger" "I" }
|
{ NSUInteger "I" }
|
||||||
{ "CGFloat" "f" }
|
{ CGFloat "f" }
|
||||||
} ] }
|
} ] }
|
||||||
{ 8 [ H{
|
{ 8 [ H{
|
||||||
{ "NSPoint" "{CGPoint=dd}" }
|
{ NSPoint "{CGPoint=dd}" }
|
||||||
{ "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" }
|
{ NSRect "{CGRect={CGPoint=dd}{CGSize=dd}}" }
|
||||||
{ "NSSize" "{CGSize=dd}" }
|
{ NSSize "{CGSize=dd}" }
|
||||||
{ "NSRange" "{_NSRange=QQ}" }
|
{ NSRange "{_NSRange=QQ}" }
|
||||||
{ "NSInteger" "q" }
|
{ NSInteger "q" }
|
||||||
{ "NSUInteger" "Q" }
|
{ NSUInteger "Q" }
|
||||||
{ "CGFloat" "d" }
|
{ CGFloat "d" }
|
||||||
} ] }
|
} ] }
|
||||||
} case
|
} case
|
||||||
assoc-union alien>objc-types set-global
|
assoc-union alien>objc-types set-global
|
||||||
|
|
||||||
: internal-cocoa-type? ( c-type -- ? )
|
|
||||||
[ "?" = ] [ first CHAR: _ = ] bi or ;
|
|
||||||
|
|
||||||
: warn-c-type ( c-type -- )
|
|
||||||
dup internal-cocoa-type?
|
|
||||||
[ drop ] [ "Warning: no such C type: " write print ] if ;
|
|
||||||
|
|
||||||
: objc-struct-type ( i string -- ctype )
|
: objc-struct-type ( i string -- ctype )
|
||||||
[ CHAR: = ] 2keep index-from swap subseq
|
[ CHAR: = ] 2keep index-from swap subseq
|
||||||
dup c-types get key? [ warn-c-type "void*" ] unless ;
|
objc>struct-types get at* [ drop void* ] unless ;
|
||||||
|
|
||||||
ERROR: no-objc-type name ;
|
ERROR: no-objc-type name ;
|
||||||
|
|
||||||
|
@ -177,9 +188,9 @@ ERROR: no-objc-type name ;
|
||||||
: (parse-objc-type) ( i string -- ctype )
|
: (parse-objc-type) ( i string -- ctype )
|
||||||
[ [ 1 + ] dip ] [ nth ] 2bi {
|
[ [ 1 + ] dip ] [ nth ] 2bi {
|
||||||
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
|
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
|
||||||
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
|
{ [ dup CHAR: ^ = ] [ 3drop void* ] }
|
||||||
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
|
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
|
||||||
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
|
{ [ dup CHAR: [ = ] [ 3drop void* ] }
|
||||||
[ 2nip decode-type ]
|
[ 2nip decode-type ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@ USING: help.markup help.syntax strings alien hashtables ;
|
||||||
IN: cocoa.subclassing
|
IN: cocoa.subclassing
|
||||||
|
|
||||||
HELP: define-objc-class
|
HELP: define-objc-class
|
||||||
{ $values { "hash" hashtable } { "imeth" "a sequence of instance method definitions" } }
|
{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } }
|
||||||
{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
|
{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
|
||||||
{ $list
|
{ $list
|
||||||
{ { $link +name+ } " - a string naming the new class. Required." }
|
{ { $link +name+ } " - a string naming the new class. Required." }
|
||||||
|
|
|
@ -30,4 +30,4 @@ ERROR: no-such-color name ;
|
||||||
: named-color ( name -- color )
|
: named-color ( name -- color )
|
||||||
dup colors at [ ] [ no-such-color ] ?if ;
|
dup colors at [ ] [ no-such-color ] ?if ;
|
||||||
|
|
||||||
SYNTAX: COLOR: scan named-color parsed ;
|
SYNTAX: COLOR: scan named-color suffix! ;
|
||||||
|
|
|
@ -5,5 +5,5 @@ IN: columns.tests
|
||||||
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
|
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
|
||||||
|
|
||||||
[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
|
[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
|
||||||
[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
|
[ ] [ "seq" get 1 <column> [ sq ] map! drop ] unit-test
|
||||||
[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
|
[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
|
||||||
|
|
|
@ -8,7 +8,7 @@ TUPLE: column seq col ;
|
||||||
|
|
||||||
C: <column> column
|
C: <column> column
|
||||||
|
|
||||||
M: column virtual-seq seq>> ;
|
M: column virtual-exemplar seq>> ;
|
||||||
M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ;
|
M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ;
|
||||||
M: column length seq>> length ;
|
M: column length seq>> length ;
|
||||||
|
|
||||||
|
|
|
@ -47,3 +47,9 @@ IN: combinators.smart.tests
|
||||||
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
||||||
|
|
||||||
[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
|
[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
|
||||||
|
|
||||||
|
{ 2 3 } [ [ + ] preserving ] must-infer-as
|
||||||
|
|
||||||
|
{ 2 0 } [ [ + ] nullary ] must-infer-as
|
||||||
|
|
||||||
|
{ 2 2 } [ [ [ + ] nullary ] preserving ] must-infer-as
|
||||||
|
|
|
@ -46,5 +46,8 @@ MACRO: append-outputs ( quot -- seq )
|
||||||
MACRO: preserving ( quot -- )
|
MACRO: preserving ( quot -- )
|
||||||
[ infer in>> length ] keep '[ _ ndup @ ] ;
|
[ infer in>> length ] keep '[ _ ndup @ ] ;
|
||||||
|
|
||||||
|
MACRO: nullary ( quot -- quot' )
|
||||||
|
dup infer out>> length '[ @ _ ndrop ] ;
|
||||||
|
|
||||||
MACRO: smart-if ( pred true false -- )
|
MACRO: smart-if ( pred true false -- )
|
||||||
'[ _ preserving _ _ if ] ; inline
|
'[ _ preserving _ _ if ] ; inline
|
||||||
|
|
|
@ -284,7 +284,7 @@ M: ##copy analyze-aliases*
|
||||||
M: ##compare analyze-aliases*
|
M: ##compare analyze-aliases*
|
||||||
call-next-method
|
call-next-method
|
||||||
dup useless-compare? [
|
dup useless-compare? [
|
||||||
dst>> \ f tag-number \ ##load-immediate new-insn
|
dst>> \ f type-number \ ##load-immediate new-insn
|
||||||
analyze-aliases*
|
analyze-aliases*
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
|
|
|
@ -6,6 +6,7 @@ compiler.cfg arrays locals byte-arrays kernel.private math
|
||||||
slots.private vectors sbufs strings math.partial-dispatch
|
slots.private vectors sbufs strings math.partial-dispatch
|
||||||
hashtables assocs combinators.short-circuit
|
hashtables assocs combinators.short-circuit
|
||||||
strings.private accessors compiler.cfg.instructions ;
|
strings.private accessors compiler.cfg.instructions ;
|
||||||
|
FROM: alien.c-types => int ;
|
||||||
IN: compiler.cfg.builder.tests
|
IN: compiler.cfg.builder.tests
|
||||||
|
|
||||||
! Just ensure that various CFGs build correctly.
|
! Just ensure that various CFGs build correctly.
|
||||||
|
@ -66,9 +67,9 @@ IN: compiler.cfg.builder.tests
|
||||||
[ [ t ] loop ]
|
[ [ t ] loop ]
|
||||||
[ [ dup ] loop ]
|
[ [ dup ] loop ]
|
||||||
[ [ 2 ] [ 3 throw ] if 4 ]
|
[ [ 2 ] [ 3 throw ] if 4 ]
|
||||||
[ "int" f "malloc" { "int" } alien-invoke ]
|
[ int f "malloc" { int } alien-invoke ]
|
||||||
[ "int" { "int" } "cdecl" alien-indirect ]
|
[ int { int } "cdecl" alien-indirect ]
|
||||||
[ "int" { "int" } "cdecl" [ ] alien-callback ]
|
[ int { int } "cdecl" [ ] alien-callback ]
|
||||||
[ swap - + * ]
|
[ swap - + * ]
|
||||||
[ swap slot ]
|
[ swap slot ]
|
||||||
[ blahblah ]
|
[ blahblah ]
|
||||||
|
@ -118,7 +119,6 @@ IN: compiler.cfg.builder.tests
|
||||||
|
|
||||||
{
|
{
|
||||||
byte-array
|
byte-array
|
||||||
simple-alien
|
|
||||||
alien
|
alien
|
||||||
POSTPONE: f
|
POSTPONE: f
|
||||||
} [| class |
|
} [| class |
|
||||||
|
@ -161,7 +161,7 @@ IN: compiler.cfg.builder.tests
|
||||||
|
|
||||||
: count-insns ( quot insn-check -- ? )
|
: count-insns ( quot insn-check -- ? )
|
||||||
[ test-mr [ instructions>> ] map ] dip
|
[ test-mr [ instructions>> ] map ] dip
|
||||||
'[ _ count ] sigma ; inline
|
'[ _ count ] map-sum ; inline
|
||||||
|
|
||||||
: contains-insn? ( quot insn-check -- ? )
|
: contains-insn? ( quot insn-check -- ? )
|
||||||
count-insns 0 > ; inline
|
count-insns 0 > ; inline
|
||||||
|
@ -191,7 +191,7 @@ IN: compiler.cfg.builder.tests
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ f t ] [
|
[ f t ] [
|
||||||
[ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
|
[ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
|
||||||
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
|
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
|
||||||
[ [ ##unbox-alien? ] contains-insn? ] bi
|
[ [ ##unbox-alien? ] contains-insn? ] bi
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -204,7 +204,7 @@ IN: compiler.cfg.builder.tests
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ f t ] [
|
[ f t ] [
|
||||||
[ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
|
[ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
|
||||||
[ [ ##box-alien? ] contains-insn? ]
|
[ [ ##box-alien? ] contains-insn? ]
|
||||||
[ [ ##allot? ] contains-insn? ] bi
|
[ [ ##allot? ] contains-insn? ] bi
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -213,4 +213,4 @@ IN: compiler.cfg.builder.tests
|
||||||
] when
|
] when
|
||||||
|
|
||||||
! Regression. Make sure everything is inlined correctly
|
! Regression. Make sure everything is inlined correctly
|
||||||
[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
|
[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
|
||||||
|
|
|
@ -117,7 +117,7 @@ M: #recursive emit-node
|
||||||
and ;
|
and ;
|
||||||
|
|
||||||
: emit-trivial-if ( -- )
|
: emit-trivial-if ( -- )
|
||||||
ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
|
ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
|
||||||
|
|
||||||
: trivial-not-if? ( #if -- ? )
|
: trivial-not-if? ( #if -- ? )
|
||||||
children>> first2
|
children>> first2
|
||||||
|
@ -126,12 +126,12 @@ M: #recursive emit-node
|
||||||
and ;
|
and ;
|
||||||
|
|
||||||
: emit-trivial-not-if ( -- )
|
: emit-trivial-not-if ( -- )
|
||||||
ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
|
ds-pop \ f type-number cc= ^^compare-imm ds-push ;
|
||||||
|
|
||||||
: emit-actual-if ( #if -- )
|
: emit-actual-if ( #if -- )
|
||||||
! Inputs to the final instruction need to be copied because of
|
! Inputs to the final instruction need to be copied because of
|
||||||
! loc>vreg sync
|
! loc>vreg sync
|
||||||
ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
|
ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
|
||||||
|
|
||||||
M: #if emit-node
|
M: #if emit-node
|
||||||
{
|
{
|
||||||
|
|
|
@ -4,20 +4,20 @@ USING: kernel math vectors arrays accessors namespaces ;
|
||||||
IN: compiler.cfg
|
IN: compiler.cfg
|
||||||
|
|
||||||
TUPLE: basic-block < identity-tuple
|
TUPLE: basic-block < identity-tuple
|
||||||
{ id integer }
|
id
|
||||||
number
|
number
|
||||||
{ instructions vector }
|
{ instructions vector }
|
||||||
{ successors vector }
|
{ successors vector }
|
||||||
{ predecessors vector } ;
|
{ predecessors vector } ;
|
||||||
|
|
||||||
M: basic-block hashcode* nip id>> ;
|
|
||||||
|
|
||||||
: <basic-block> ( -- bb )
|
: <basic-block> ( -- bb )
|
||||||
basic-block new
|
basic-block new
|
||||||
|
\ basic-block counter >>id
|
||||||
V{ } clone >>instructions
|
V{ } clone >>instructions
|
||||||
V{ } clone >>successors
|
V{ } clone >>successors
|
||||||
V{ } clone >>predecessors
|
V{ } clone >>predecessors ;
|
||||||
\ basic-block counter >>id ;
|
|
||||||
|
M: basic-block hashcode* nip id>> ;
|
||||||
|
|
||||||
TUPLE: cfg { entry basic-block } word label
|
TUPLE: cfg { entry basic-block } word label
|
||||||
spill-area-size reps
|
spill-area-size reps
|
||||||
|
|
|
@ -49,7 +49,7 @@ ERROR: bad-kill-insn bb ;
|
||||||
ERROR: bad-successors ;
|
ERROR: bad-successors ;
|
||||||
|
|
||||||
: check-successors ( bb -- )
|
: check-successors ( bb -- )
|
||||||
dup successors>> [ predecessors>> memq? ] with all?
|
dup successors>> [ predecessors>> member-eq? ] with all?
|
||||||
[ bad-successors ] unless ;
|
[ bad-successors ] unless ;
|
||||||
|
|
||||||
: check-basic-block ( bb -- )
|
: check-basic-block ( bb -- )
|
||||||
|
|
|
@ -90,5 +90,5 @@ SYMBOLS:
|
||||||
{ cc/> { +lt+ +eq+ +unordered+ } }
|
{ cc/> { +lt+ +eq+ +unordered+ } }
|
||||||
{ cc/<> { +eq+ +unordered+ } }
|
{ cc/<> { +eq+ +unordered+ } }
|
||||||
{ cc/<>= { +unordered+ } }
|
{ cc/<>= { +unordered+ } }
|
||||||
} at memq? ;
|
} at member-eq? ;
|
||||||
|
|
||||||
|
|
|
@ -63,7 +63,7 @@ M: insn update-insn rename-insn-uses t ;
|
||||||
copies get dup assoc-empty? [ 2drop ] [
|
copies get dup assoc-empty? [ 2drop ] [
|
||||||
renamings set
|
renamings set
|
||||||
[
|
[
|
||||||
instructions>> [ update-insn ] filter-here
|
instructions>> [ update-insn ] filter! drop
|
||||||
] each-basic-block
|
] each-basic-block
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
|
@ -117,5 +117,5 @@ M: insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
|
||||||
dup
|
dup
|
||||||
[ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
|
[ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
|
||||||
[ [ instructions>> [ compute-live-vregs ] each ] each-basic-block ]
|
[ [ instructions>> [ compute-live-vregs ] each ] each-basic-block ]
|
||||||
[ [ instructions>> [ live-insn? ] filter-here ] each-basic-block ]
|
[ [ instructions>> [ live-insn? ] filter! drop ] each-basic-block ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
|
@ -11,6 +11,10 @@ GENERIC: defs-vreg ( insn -- vreg/f )
|
||||||
GENERIC: temp-vregs ( insn -- seq )
|
GENERIC: temp-vregs ( insn -- seq )
|
||||||
GENERIC: uses-vregs ( insn -- seq )
|
GENERIC: uses-vregs ( insn -- seq )
|
||||||
|
|
||||||
|
M: insn defs-vreg drop f ;
|
||||||
|
M: insn temp-vregs drop { } ;
|
||||||
|
M: insn uses-vregs drop { } ;
|
||||||
|
|
||||||
M: ##phi uses-vregs inputs>> values ;
|
M: ##phi uses-vregs inputs>> values ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
@ -24,19 +28,25 @@ M: ##phi uses-vregs inputs>> values ;
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: define-defs-vreg-method ( insn -- )
|
: define-defs-vreg-method ( insn -- )
|
||||||
[ \ defs-vreg create-method ]
|
dup insn-def-slot dup [
|
||||||
[ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi
|
[ \ defs-vreg create-method ]
|
||||||
define ;
|
[ name>> reader-word 1quotation ] bi*
|
||||||
|
define
|
||||||
|
] [ 2drop ] if ;
|
||||||
|
|
||||||
: define-uses-vregs-method ( insn -- )
|
: define-uses-vregs-method ( insn -- )
|
||||||
[ \ uses-vregs create-method ]
|
dup insn-use-slots [ drop ] [
|
||||||
[ insn-use-slots [ name>> ] map slot-array-quot ] bi
|
[ \ uses-vregs create-method ]
|
||||||
define ;
|
[ [ name>> ] map slot-array-quot ] bi*
|
||||||
|
define
|
||||||
|
] if-empty ;
|
||||||
|
|
||||||
: define-temp-vregs-method ( insn -- )
|
: define-temp-vregs-method ( insn -- )
|
||||||
[ \ temp-vregs create-method ]
|
dup insn-temp-slots [ drop ] [
|
||||||
[ insn-temp-slots [ name>> ] map slot-array-quot ] bi
|
[ \ temp-vregs create-method ]
|
||||||
define ;
|
[ [ name>> ] map slot-array-quot ] bi*
|
||||||
|
define
|
||||||
|
] if-empty ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! 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 kernel sequences assocs fry
|
USING: accessors kernel sequences assocs fry math
|
||||||
cpu.architecture layouts
|
cpu.architecture layouts namespaces
|
||||||
compiler.cfg.rpo
|
compiler.cfg.rpo
|
||||||
compiler.cfg.registers
|
compiler.cfg.registers
|
||||||
compiler.cfg.instructions
|
compiler.cfg.instructions
|
||||||
|
@ -21,12 +21,14 @@ GENERIC: allocation-size* ( insn -- n )
|
||||||
|
|
||||||
M: ##allot allocation-size* size>> ;
|
M: ##allot allocation-size* size>> ;
|
||||||
|
|
||||||
M: ##box-alien allocation-size* drop 4 cells ;
|
M: ##box-alien allocation-size* drop 5 cells ;
|
||||||
|
|
||||||
M: ##box-displaced-alien allocation-size* drop 4 cells ;
|
M: ##box-displaced-alien allocation-size* drop 5 cells ;
|
||||||
|
|
||||||
: allocation-size ( bb -- n )
|
: allocation-size ( bb -- n )
|
||||||
instructions>> [ ##allocation? ] filter [ allocation-size* ] sigma ;
|
instructions>>
|
||||||
|
[ ##allocation? ] filter
|
||||||
|
[ allocation-size* data-alignment get align ] map-sum ;
|
||||||
|
|
||||||
: insert-gc-check ( bb -- )
|
: insert-gc-check ( bb -- )
|
||||||
dup dup '[
|
dup dup '[
|
||||||
|
@ -44,4 +46,4 @@ M: ##box-displaced-alien allocation-size* drop 4 cells ;
|
||||||
dup blocks-with-gc [
|
dup blocks-with-gc [
|
||||||
over compute-uninitialized-sets
|
over compute-uninitialized-sets
|
||||||
[ insert-gc-check ] each
|
[ insert-gc-check ] each
|
||||||
] unless-empty ;
|
] unless-empty ;
|
||||||
|
|
|
@ -26,7 +26,7 @@ IN: compiler.cfg.hats
|
||||||
|
|
||||||
: hat-effect ( insn -- effect )
|
: hat-effect ( insn -- effect )
|
||||||
"insn-slots" word-prop
|
"insn-slots" word-prop
|
||||||
[ type>> { def temp } memq? not ] filter [ name>> ] map
|
[ type>> { def temp } member-eq? not ] filter [ name>> ] map
|
||||||
{ "vreg" } <effect> ;
|
{ "vreg" } <effect> ;
|
||||||
|
|
||||||
: define-hat ( insn -- )
|
: define-hat ( insn -- )
|
||||||
|
@ -43,14 +43,14 @@ insn-classes get [
|
||||||
|
|
||||||
: ^^load-literal ( obj -- dst )
|
: ^^load-literal ( obj -- dst )
|
||||||
[ next-vreg dup ] dip {
|
[ next-vreg dup ] dip {
|
||||||
{ [ dup not ] [ drop \ f tag-number ##load-immediate ] }
|
{ [ dup not ] [ drop \ f type-number ##load-immediate ] }
|
||||||
{ [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
|
{ [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
|
||||||
{ [ dup float? ] [ ##load-constant ] }
|
{ [ dup float? ] [ ##load-constant ] }
|
||||||
[ ##load-reference ]
|
[ ##load-reference ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: ^^offset>slot ( slot -- vreg' )
|
: ^^offset>slot ( slot -- vreg' )
|
||||||
cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ;
|
cell 4 = 2 1 ? ^^shr-imm ;
|
||||||
|
|
||||||
: ^^tag-fixnum ( src -- dst )
|
: ^^tag-fixnum ( src -- dst )
|
||||||
tag-bits get ^^shl-imm ;
|
tag-bits get ^^shl-imm ;
|
||||||
|
|
|
@ -417,12 +417,12 @@ def: dst/scalar-rep
|
||||||
use: src
|
use: src
|
||||||
literal: rep ;
|
literal: rep ;
|
||||||
|
|
||||||
PURE-INSN: ##horizontal-shl-vector
|
PURE-INSN: ##horizontal-shl-vector-imm
|
||||||
def: dst
|
def: dst
|
||||||
use: src1
|
use: src1
|
||||||
literal: src2 rep ;
|
literal: src2 rep ;
|
||||||
|
|
||||||
PURE-INSN: ##horizontal-shr-vector
|
PURE-INSN: ##horizontal-shr-vector-imm
|
||||||
def: dst
|
def: dst
|
||||||
use: src1
|
use: src1
|
||||||
literal: src2 rep ;
|
literal: src2 rep ;
|
||||||
|
@ -462,6 +462,16 @@ def: dst
|
||||||
use: src
|
use: src
|
||||||
literal: rep ;
|
literal: rep ;
|
||||||
|
|
||||||
|
PURE-INSN: ##shl-vector-imm
|
||||||
|
def: dst
|
||||||
|
use: src1
|
||||||
|
literal: src2 rep ;
|
||||||
|
|
||||||
|
PURE-INSN: ##shr-vector-imm
|
||||||
|
def: dst
|
||||||
|
use: src1
|
||||||
|
literal: src2 rep ;
|
||||||
|
|
||||||
PURE-INSN: ##shl-vector
|
PURE-INSN: ##shl-vector
|
||||||
def: dst
|
def: dst
|
||||||
use: src1 src2/int-scalar-rep
|
use: src1 src2/int-scalar-rep
|
||||||
|
@ -502,13 +512,12 @@ temp: temp/int-rep ;
|
||||||
PURE-INSN: ##box-displaced-alien
|
PURE-INSN: ##box-displaced-alien
|
||||||
def: dst/int-rep
|
def: dst/int-rep
|
||||||
use: displacement/int-rep base/int-rep
|
use: displacement/int-rep base/int-rep
|
||||||
temp: temp1/int-rep temp2/int-rep
|
temp: temp/int-rep
|
||||||
literal: base-class ;
|
literal: base-class ;
|
||||||
|
|
||||||
PURE-INSN: ##unbox-any-c-ptr
|
PURE-INSN: ##unbox-any-c-ptr
|
||||||
def: dst/int-rep
|
def: dst/int-rep
|
||||||
use: src/int-rep
|
use: src/int-rep ;
|
||||||
temp: temp/int-rep ;
|
|
||||||
|
|
||||||
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
|
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
|
||||||
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
|
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
|
||||||
|
@ -517,12 +526,12 @@ PURE-INSN: ##unbox-alien
|
||||||
def: dst/int-rep
|
def: dst/int-rep
|
||||||
use: src/int-rep ;
|
use: src/int-rep ;
|
||||||
|
|
||||||
: ##unbox-c-ptr ( dst src class temp -- )
|
: ##unbox-c-ptr ( dst src class -- )
|
||||||
{
|
{
|
||||||
{ [ over \ f class<= ] [ 2drop ##unbox-f ] }
|
{ [ dup \ f class<= ] [ drop ##unbox-f ] }
|
||||||
{ [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
|
{ [ dup alien class<= ] [ drop ##unbox-alien ] }
|
||||||
{ [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
|
{ [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
|
||||||
[ nip ##unbox-any-c-ptr ]
|
[ drop ##unbox-any-c-ptr ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
! Alien accessors
|
! Alien accessors
|
||||||
|
@ -833,7 +842,7 @@ SYMBOL: vreg-insn
|
||||||
[
|
[
|
||||||
vreg-insn
|
vreg-insn
|
||||||
insn-classes get [
|
insn-classes get [
|
||||||
"insn-slots" word-prop [ type>> { def use temp } memq? ] any?
|
"insn-slots" word-prop [ type>> { def use temp } member-eq? ] any?
|
||||||
] filter
|
] filter
|
||||||
define-union-class
|
define-union-class
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
|
|
|
@ -22,12 +22,10 @@ IN: compiler.cfg.intrinsics.alien
|
||||||
] [ emit-primitive ] if ;
|
] [ emit-primitive ] if ;
|
||||||
|
|
||||||
:: inline-alien ( node quot test -- )
|
:: inline-alien ( node quot test -- )
|
||||||
[let | infos [ node node-input-infos ] |
|
node node-input-infos :> infos
|
||||||
infos test call
|
infos test call
|
||||||
[ infos quot call ]
|
[ infos quot call ]
|
||||||
[ node emit-primitive ]
|
[ node emit-primitive ] if ; inline
|
||||||
if
|
|
||||||
] ; inline
|
|
||||||
|
|
||||||
: inline-alien-getter? ( infos -- ? )
|
: inline-alien-getter? ( infos -- ? )
|
||||||
[ first class>> c-ptr class<= ]
|
[ first class>> c-ptr class<= ]
|
||||||
|
@ -35,7 +33,7 @@ IN: compiler.cfg.intrinsics.alien
|
||||||
bi and ;
|
bi and ;
|
||||||
|
|
||||||
: ^^unbox-c-ptr ( src class -- dst )
|
: ^^unbox-c-ptr ( src class -- dst )
|
||||||
[ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
|
[ next-vreg dup ] 2dip ##unbox-c-ptr ;
|
||||||
|
|
||||||
: prepare-alien-accessor ( info -- ptr-vreg offset )
|
: prepare-alien-accessor ( info -- ptr-vreg offset )
|
||||||
class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
|
class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
|
||||||
|
|
|
@ -8,7 +8,7 @@ compiler.cfg.utilities compiler.cfg.builder.blocks ;
|
||||||
IN: compiler.cfg.intrinsics.allot
|
IN: compiler.cfg.intrinsics.allot
|
||||||
|
|
||||||
: ##set-slots ( regs obj class -- )
|
: ##set-slots ( regs obj class -- )
|
||||||
'[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
|
'[ _ swap 1 + _ type-number ##set-slot-imm ] each-index ;
|
||||||
|
|
||||||
: emit-simple-allot ( node -- )
|
: emit-simple-allot ( node -- )
|
||||||
[ in-d>> length ] [ node-output-infos first class>> ] bi
|
[ in-d>> length ] [ node-output-infos first class>> ] bi
|
||||||
|
@ -31,10 +31,10 @@ IN: compiler.cfg.intrinsics.allot
|
||||||
] [ drop emit-primitive ] if ;
|
] [ drop emit-primitive ] if ;
|
||||||
|
|
||||||
: store-length ( len reg class -- )
|
: store-length ( len reg class -- )
|
||||||
[ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
|
[ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
|
||||||
|
|
||||||
:: store-initial-element ( len reg elt class -- )
|
:: store-initial-element ( len reg elt class -- )
|
||||||
len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
|
len [ [ elt reg ] dip 2 + class type-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 ;
|
||||||
|
@ -43,17 +43,15 @@ IN: compiler.cfg.intrinsics.allot
|
||||||
2 + cells array ^^allot ;
|
2 + cells array ^^allot ;
|
||||||
|
|
||||||
:: emit-<array> ( node -- )
|
:: emit-<array> ( node -- )
|
||||||
[let | len [ node node-input-infos first literal>> ] |
|
node node-input-infos first literal>> :> len
|
||||||
len expand-<array>? [
|
len expand-<array>? [
|
||||||
[let | elt [ ds-pop ]
|
ds-pop :> elt
|
||||||
reg [ len ^^allot-array ] |
|
len ^^allot-array :> reg
|
||||||
ds-drop
|
ds-drop
|
||||||
len reg array store-length
|
len reg array store-length
|
||||||
len reg elt array store-initial-element
|
len reg elt array store-initial-element
|
||||||
reg ds-push
|
reg ds-push
|
||||||
]
|
] [ node emit-primitive ] if ;
|
||||||
] [ node emit-primitive ] if
|
|
||||||
] ;
|
|
||||||
|
|
||||||
: expand-(byte-array)? ( obj -- ? )
|
: expand-(byte-array)? ( obj -- ? )
|
||||||
dup integer? [ 0 1024 between? ] [ drop f ] if ;
|
dup integer? [ 0 1024 between? ] [ drop f ] if ;
|
||||||
|
@ -64,7 +62,7 @@ IN: compiler.cfg.intrinsics.allot
|
||||||
: bytes>cells ( m -- n ) cell align cell /i ;
|
: bytes>cells ( m -- n ) cell align cell /i ;
|
||||||
|
|
||||||
: ^^allot-byte-array ( n -- dst )
|
: ^^allot-byte-array ( n -- dst )
|
||||||
2 cells + byte-array ^^allot ;
|
16 + byte-array ^^allot ;
|
||||||
|
|
||||||
: emit-allot-byte-array ( len -- dst )
|
: emit-allot-byte-array ( len -- dst )
|
||||||
ds-drop
|
ds-drop
|
||||||
|
|
|
@ -21,7 +21,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
||||||
ds-push ;
|
ds-push ;
|
||||||
|
|
||||||
: tag-literal ( n -- tagged )
|
: tag-literal ( n -- tagged )
|
||||||
literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
|
literal>> [ tag-fixnum ] [ \ f type-number ] if* ;
|
||||||
|
|
||||||
: emit-fixnum-op ( insn -- )
|
: emit-fixnum-op ( insn -- )
|
||||||
[ 2inputs ] dip call ds-push ; inline
|
[ 2inputs ] dip call ds-push ; inline
|
||||||
|
|
|
@ -33,6 +33,7 @@ IN: compiler.cfg.intrinsics
|
||||||
{
|
{
|
||||||
{ kernel.private:tag [ drop emit-tag ] }
|
{ kernel.private:tag [ drop emit-tag ] }
|
||||||
{ kernel.private:getenv [ emit-getenv ] }
|
{ kernel.private:getenv [ emit-getenv ] }
|
||||||
|
{ kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
|
||||||
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
|
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
|
||||||
{ math.private:fixnum+ [ drop emit-fixnum+ ] }
|
{ math.private:fixnum+ [ drop emit-fixnum+ ] }
|
||||||
{ math.private:fixnum- [ drop emit-fixnum- ] }
|
{ math.private:fixnum- [ drop emit-fixnum- ] }
|
||||||
|
@ -163,8 +164,8 @@ IN: compiler.cfg.intrinsics
|
||||||
{ math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
|
||||||
|
@ -187,10 +188,10 @@ IN: compiler.cfg.intrinsics
|
||||||
{ math.vectors.simd.intrinsics:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector-imm ] [ ^^shr-vector ] emit-shift-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector ] emit-horizontal-shift ] }
|
{ math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector ] emit-horizontal-shift ] }
|
{ math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector-imm ] emit-shift-vector-imm-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
|
{ math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
|
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
|
||||||
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
|
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: namespaces layouts sequences kernel
|
USING: namespaces layouts sequences kernel math accessors
|
||||||
accessors compiler.tree.propagation.info
|
compiler.tree.propagation.info compiler.cfg.stacks
|
||||||
compiler.cfg.stacks compiler.cfg.hats
|
compiler.cfg.hats compiler.cfg.instructions
|
||||||
compiler.cfg.instructions compiler.cfg.utilities ;
|
compiler.cfg.utilities ;
|
||||||
IN: compiler.cfg.intrinsics.misc
|
IN: compiler.cfg.intrinsics.misc
|
||||||
|
|
||||||
: emit-tag ( -- )
|
: emit-tag ( -- )
|
||||||
|
@ -14,3 +14,9 @@ IN: compiler.cfg.intrinsics.misc
|
||||||
swap node-input-infos first literal>>
|
swap node-input-infos first literal>>
|
||||||
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
|
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
|
||||||
ds-push ;
|
ds-push ;
|
||||||
|
|
||||||
|
: emit-identity-hashcode ( -- )
|
||||||
|
ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm
|
||||||
|
hashcode-shift ^^shr-imm
|
||||||
|
^^tag-fixnum
|
||||||
|
ds-push ;
|
||||||
|
|
|
@ -10,8 +10,8 @@ compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
|
||||||
compiler.cfg.instructions compiler.cfg.registers
|
compiler.cfg.instructions compiler.cfg.registers
|
||||||
compiler.cfg.intrinsics.alien
|
compiler.cfg.intrinsics.alien
|
||||||
specialized-arrays ;
|
specialized-arrays ;
|
||||||
FROM: alien.c-types => heap-size char uchar float double ;
|
FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ;
|
||||||
SPECIALIZED-ARRAYS: float double ;
|
SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ;
|
||||||
IN: compiler.cfg.intrinsics.simd
|
IN: compiler.cfg.intrinsics.simd
|
||||||
|
|
||||||
MACRO: check-elements ( quots -- )
|
MACRO: check-elements ( quots -- )
|
||||||
|
@ -55,10 +55,15 @@ MACRO: if-literals-match ( quots -- )
|
||||||
: [unary/param] ( quot -- quot' )
|
: [unary/param] ( quot -- quot' )
|
||||||
'[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
|
'[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
|
||||||
|
|
||||||
: emit-horizontal-shift ( node quot -- )
|
: emit-shift-vector-imm-op ( node quot -- )
|
||||||
[unary/param]
|
[unary/param]
|
||||||
{ [ integer? ] [ representation? ] } if-literals-match ; inline
|
{ [ integer? ] [ representation? ] } if-literals-match ; inline
|
||||||
|
|
||||||
|
:: emit-shift-vector-op ( node imm-quot var-quot -- )
|
||||||
|
node node-input-infos 2 tail-slice* first literal>> integer?
|
||||||
|
[ node imm-quot emit-shift-vector-imm-op ]
|
||||||
|
[ node var-quot emit-binary-vector-op ] if ; inline
|
||||||
|
|
||||||
: emit-gather-vector-2 ( node -- )
|
: emit-gather-vector-2 ( node -- )
|
||||||
[ ^^gather-vector-2 ] emit-binary-vector-op ;
|
[ ^^gather-vector-2 ] emit-binary-vector-op ;
|
||||||
|
|
||||||
|
@ -155,28 +160,79 @@ MACRO: if-literals-match ( quots -- )
|
||||||
[ ^^not-vector ]
|
[ ^^not-vector ]
|
||||||
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
|
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
|
||||||
|
|
||||||
:: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst )
|
:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
|
||||||
{cc,swap} first2 :> swap? :> cc
|
{cc,swap} first2 :> ( cc swap? )
|
||||||
swap?
|
swap?
|
||||||
[ src2 src1 rep cc ^^compare-vector ]
|
[ src2 src1 rep cc ^^compare-vector ]
|
||||||
[ src1 src2 rep cc ^^compare-vector ] if ;
|
[ src1 src2 rep cc ^^compare-vector ] if ;
|
||||||
|
|
||||||
:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
|
:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
|
||||||
rep orig-cc %compare-vector-ccs :> not? :> ccs
|
rep orig-cc %compare-vector-ccs :> ( ccs not? )
|
||||||
|
|
||||||
ccs empty?
|
ccs empty?
|
||||||
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
|
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
|
||||||
[
|
[
|
||||||
ccs unclip :> first-cc :> rest-ccs
|
ccs unclip :> ( rest-ccs first-cc )
|
||||||
src1 src2 rep first-cc (generate-compare-vector) :> first-dst
|
src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
|
||||||
|
|
||||||
rest-ccs first-dst
|
rest-ccs first-dst
|
||||||
[ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ]
|
[ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ]
|
||||||
reduce
|
reduce
|
||||||
|
|
||||||
not? [ rep generate-not-vector ] when
|
not? [ rep generate-not-vector ] when
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
: sign-bit-mask ( rep -- byte-array )
|
||||||
|
unsign-rep {
|
||||||
|
{ char-16-rep [ uchar-array{
|
||||||
|
HEX: 80 HEX: 80 HEX: 80 HEX: 80
|
||||||
|
HEX: 80 HEX: 80 HEX: 80 HEX: 80
|
||||||
|
HEX: 80 HEX: 80 HEX: 80 HEX: 80
|
||||||
|
HEX: 80 HEX: 80 HEX: 80 HEX: 80
|
||||||
|
} underlying>> ] }
|
||||||
|
{ short-8-rep [ ushort-array{
|
||||||
|
HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
|
||||||
|
HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
|
||||||
|
} underlying>> ] }
|
||||||
|
{ int-4-rep [ uint-array{
|
||||||
|
HEX: 8000,0000 HEX: 8000,0000
|
||||||
|
HEX: 8000,0000 HEX: 8000,0000
|
||||||
|
} underlying>> ] }
|
||||||
|
{ longlong-2-rep [ ulonglong-array{
|
||||||
|
HEX: 8000,0000,0000,0000
|
||||||
|
HEX: 8000,0000,0000,0000
|
||||||
|
} underlying>> ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
:: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst )
|
||||||
|
orig-cc order-cc {
|
||||||
|
{ cc< [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] }
|
||||||
|
{ cc<= [ src1 src2 rep ^^min-vector src1 rep cc= (generate-compare-vector) ] }
|
||||||
|
{ cc> [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] }
|
||||||
|
{ cc>= [ src1 src2 rep ^^max-vector src1 rep cc= (generate-compare-vector) ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
|
||||||
|
{
|
||||||
|
{
|
||||||
|
[ rep orig-cc %compare-vector-reps member? ]
|
||||||
|
[ src1 src2 rep orig-cc (generate-compare-vector) ]
|
||||||
|
}
|
||||||
|
{
|
||||||
|
[ rep %min-vector-reps member? ]
|
||||||
|
[ src1 src2 rep orig-cc (generate-minmax-compare-vector) ]
|
||||||
|
}
|
||||||
|
{
|
||||||
|
[ rep unsign-rep orig-cc %compare-vector-reps member? ]
|
||||||
|
[
|
||||||
|
rep sign-bit-mask ^^load-constant :> sign-bits
|
||||||
|
src1 sign-bits rep ^^xor-vector
|
||||||
|
src2 sign-bits rep ^^xor-vector
|
||||||
|
rep unsign-rep orig-cc (generate-compare-vector)
|
||||||
|
]
|
||||||
|
}
|
||||||
|
} cond ;
|
||||||
|
|
||||||
:: generate-unpack-vector-head ( src rep -- dst )
|
:: generate-unpack-vector-head ( src rep -- dst )
|
||||||
{
|
{
|
||||||
{
|
{
|
||||||
|
@ -190,6 +246,14 @@ MACRO: if-literals-match ( quots -- )
|
||||||
src zero rep ^^merge-vector-head
|
src zero rep ^^merge-vector-head
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
{
|
||||||
|
[ rep widen-vector-rep %shr-vector-imm-reps member? ]
|
||||||
|
[
|
||||||
|
src src rep ^^merge-vector-head
|
||||||
|
rep rep-component-type
|
||||||
|
heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
|
||||||
|
]
|
||||||
|
}
|
||||||
[
|
[
|
||||||
rep ^^zero-vector :> zero
|
rep ^^zero-vector :> zero
|
||||||
zero src rep cc> ^^compare-vector :> sign
|
zero src rep cc> ^^compare-vector :> sign
|
||||||
|
@ -217,6 +281,14 @@ MACRO: if-literals-match ( quots -- )
|
||||||
src zero rep ^^merge-vector-tail
|
src zero rep ^^merge-vector-tail
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
{
|
||||||
|
[ rep widen-vector-rep %shr-vector-imm-reps member? ]
|
||||||
|
[
|
||||||
|
src src rep ^^merge-vector-tail
|
||||||
|
rep rep-component-type
|
||||||
|
heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
|
||||||
|
]
|
||||||
|
}
|
||||||
[
|
[
|
||||||
rep ^^zero-vector :> zero
|
rep ^^zero-vector :> zero
|
||||||
zero src rep cc> ^^compare-vector :> sign
|
zero src rep cc> ^^compare-vector :> sign
|
||||||
|
@ -265,3 +337,17 @@ MACRO: if-literals-match ( quots -- )
|
||||||
]
|
]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
: generate-min-vector ( src1 src2 rep -- dst )
|
||||||
|
dup %min-vector-reps member?
|
||||||
|
[ ^^min-vector ] [
|
||||||
|
[ cc< generate-compare-vector ]
|
||||||
|
[ generate-blend-vector ] 3bi
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: generate-max-vector ( src1 src2 rep -- dst )
|
||||||
|
dup %max-vector-reps member?
|
||||||
|
[ ^^max-vector ] [
|
||||||
|
[ cc> generate-compare-vector ]
|
||||||
|
[ generate-blend-vector ] 3bi
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
|
|
@ -1,14 +1,17 @@
|
||||||
! 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: layouts namespaces kernel accessors sequences math
|
USING: layouts namespaces kernel accessors sequences math
|
||||||
classes.algebra locals combinators cpu.architecture
|
classes.algebra classes.builtin locals combinators
|
||||||
compiler.tree.propagation.info compiler.cfg.stacks
|
cpu.architecture compiler.tree.propagation.info
|
||||||
compiler.cfg.hats compiler.cfg.registers
|
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
|
||||||
compiler.cfg.instructions compiler.cfg.utilities
|
compiler.cfg.instructions compiler.cfg.utilities
|
||||||
compiler.cfg.builder.blocks compiler.constants ;
|
compiler.cfg.builder.blocks compiler.constants ;
|
||||||
IN: compiler.cfg.intrinsics.slots
|
IN: compiler.cfg.intrinsics.slots
|
||||||
|
|
||||||
: value-tag ( info -- n ) class>> class-tag ; inline
|
: class-tag ( class -- tag/f )
|
||||||
|
builtins get [ class<= ] with find drop ;
|
||||||
|
|
||||||
|
: value-tag ( info -- n ) class>> class-tag ;
|
||||||
|
|
||||||
: ^^tag-offset>slot ( slot tag -- vreg' )
|
: ^^tag-offset>slot ( slot tag -- vreg' )
|
||||||
[ ^^offset>slot ] dip ^^sub-imm ;
|
[ ^^offset>slot ] dip ^^sub-imm ;
|
||||||
|
@ -42,7 +45,7 @@ IN: compiler.cfg.intrinsics.slots
|
||||||
first class>> immediate class<= not ;
|
first class>> immediate class<= not ;
|
||||||
|
|
||||||
:: (emit-set-slot) ( infos -- )
|
:: (emit-set-slot) ( infos -- )
|
||||||
3inputs :> slot :> obj :> src
|
3inputs :> ( src obj slot )
|
||||||
|
|
||||||
slot infos second value-tag ^^tag-offset>slot :> slot
|
slot infos second value-tag ^^tag-offset>slot :> slot
|
||||||
|
|
||||||
|
@ -54,7 +57,7 @@ IN: compiler.cfg.intrinsics.slots
|
||||||
:: (emit-set-slot-imm) ( infos -- )
|
:: (emit-set-slot-imm) ( infos -- )
|
||||||
ds-drop
|
ds-drop
|
||||||
|
|
||||||
2inputs :> obj :> src
|
2inputs :> ( src obj )
|
||||||
|
|
||||||
infos third literal>> :> slot
|
infos third literal>> :> slot
|
||||||
infos second value-tag :> tag
|
infos second value-tag :> tag
|
||||||
|
|
|
@ -42,7 +42,7 @@ IN: compiler.cfg.linear-scan.allocation
|
||||||
|
|
||||||
: handle-sync-point ( n -- )
|
: handle-sync-point ( n -- )
|
||||||
[ active-intervals get values ] dip
|
[ active-intervals get values ] dip
|
||||||
'[ [ _ spill-at-sync-point ] filter-here ] each ;
|
'[ [ _ spill-at-sync-point ] filter! drop ] each ;
|
||||||
|
|
||||||
:: handle-progress ( n sync? -- )
|
:: handle-progress ( n sync? -- )
|
||||||
n {
|
n {
|
||||||
|
|
|
@ -18,13 +18,13 @@ ERROR: bad-live-ranges interval ;
|
||||||
|
|
||||||
: trim-before-ranges ( live-interval -- )
|
: trim-before-ranges ( live-interval -- )
|
||||||
[ ranges>> ] [ uses>> last 1 + ] bi
|
[ ranges>> ] [ uses>> last 1 + ] bi
|
||||||
[ '[ from>> _ <= ] filter-here ]
|
[ '[ from>> _ <= ] filter! drop ]
|
||||||
[ swap last (>>to) ]
|
[ swap last (>>to) ]
|
||||||
2bi ;
|
2bi ;
|
||||||
|
|
||||||
: trim-after-ranges ( live-interval -- )
|
: trim-after-ranges ( live-interval -- )
|
||||||
[ ranges>> ] [ uses>> first ] bi
|
[ ranges>> ] [ uses>> first ] bi
|
||||||
[ '[ to>> _ >= ] filter-here ]
|
[ '[ to>> _ >= ] filter! drop ]
|
||||||
[ swap first (>>from) ]
|
[ swap first (>>from) ]
|
||||||
2bi ;
|
2bi ;
|
||||||
|
|
||||||
|
@ -103,7 +103,7 @@ ERROR: bad-live-ranges interval ;
|
||||||
! most one) are split and spilled and removed from the inactive
|
! most one) are split and spilled and removed from the inactive
|
||||||
! set.
|
! set.
|
||||||
new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
|
new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
|
||||||
'[ _ delete-nth new start>> spill ] [ 2drop ] if ;
|
'[ _ remove-nth! drop new start>> spill ] [ 2drop ] if ;
|
||||||
|
|
||||||
:: spill-intersecting-inactive ( new reg -- )
|
:: spill-intersecting-inactive ( new reg -- )
|
||||||
! Any inactive intervals using 'reg' are split and spilled
|
! Any inactive intervals using 'reg' are split and spilled
|
||||||
|
@ -114,7 +114,7 @@ ERROR: bad-live-ranges interval ;
|
||||||
new start>> spill f
|
new start>> spill f
|
||||||
] [ drop t ] if
|
] [ drop t ] if
|
||||||
] [ drop t ] if
|
] [ drop t ] if
|
||||||
] filter-here ;
|
] filter! drop ;
|
||||||
|
|
||||||
: spill-intersecting ( new reg -- )
|
: spill-intersecting ( new reg -- )
|
||||||
! Split and spill all active and inactive intervals
|
! Split and spill all active and inactive intervals
|
||||||
|
@ -141,4 +141,4 @@ ERROR: bad-live-ranges interval ;
|
||||||
{ [ 2dup spill-new? ] [ spill-new ] }
|
{ [ 2dup spill-new? ] [ spill-new ] }
|
||||||
{ [ 2dup register-available? ] [ spill-available ] }
|
{ [ 2dup register-available? ] [ spill-available ] }
|
||||||
[ spill-partially-available ]
|
[ spill-partially-available ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
|
@ -33,7 +33,7 @@ SYMBOL: active-intervals
|
||||||
dup vreg>> active-intervals-for push ;
|
dup vreg>> active-intervals-for push ;
|
||||||
|
|
||||||
: delete-active ( live-interval -- )
|
: delete-active ( live-interval -- )
|
||||||
dup vreg>> active-intervals-for delq ;
|
dup vreg>> active-intervals-for remove-eq! drop ;
|
||||||
|
|
||||||
: assign-free-register ( new registers -- )
|
: assign-free-register ( new registers -- )
|
||||||
pop >>reg add-active ;
|
pop >>reg add-active ;
|
||||||
|
@ -48,7 +48,7 @@ SYMBOL: inactive-intervals
|
||||||
dup vreg>> inactive-intervals-for push ;
|
dup vreg>> inactive-intervals-for push ;
|
||||||
|
|
||||||
: delete-inactive ( live-interval -- )
|
: delete-inactive ( live-interval -- )
|
||||||
dup vreg>> inactive-intervals-for delq ;
|
dup vreg>> inactive-intervals-for remove-eq! drop ;
|
||||||
|
|
||||||
! Vector of handled live intervals
|
! Vector of handled live intervals
|
||||||
SYMBOL: handled-intervals
|
SYMBOL: handled-intervals
|
||||||
|
@ -83,7 +83,7 @@ ERROR: register-already-used live-interval ;
|
||||||
! Moving intervals between active and inactive sets
|
! Moving intervals between active and inactive sets
|
||||||
: process-intervals ( n symbol quots -- )
|
: process-intervals ( n symbol quots -- )
|
||||||
! symbol stores an alist mapping register classes to vectors
|
! symbol stores an alist mapping register classes to vectors
|
||||||
[ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
|
[ get values ] dip '[ [ _ cond ] with filter! drop ] with each ; inline
|
||||||
|
|
||||||
: deactivate-intervals ( n -- )
|
: deactivate-intervals ( n -- )
|
||||||
! Any active intervals which have ended are moved to handled
|
! Any active intervals which have ended are moved to handled
|
||||||
|
|
|
@ -152,8 +152,8 @@ ERROR: bad-live-interval live-interval ;
|
||||||
! to reverse some sequences, and compute the start and end.
|
! to reverse some sequences, and compute the start and end.
|
||||||
values dup [
|
values dup [
|
||||||
{
|
{
|
||||||
[ ranges>> reverse-here ]
|
[ ranges>> reverse! drop ]
|
||||||
[ uses>> reverse-here ]
|
[ uses>> reverse! drop ]
|
||||||
[ compute-start/end ]
|
[ compute-start/end ]
|
||||||
[ check-start ]
|
[ check-start ]
|
||||||
} cleave
|
} cleave
|
||||||
|
@ -187,4 +187,4 @@ ERROR: bad-live-interval live-interval ;
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: intervals-intersect? ( interval1 interval2 -- ? )
|
: intervals-intersect? ( interval1 interval2 -- ? )
|
||||||
relevant-ranges intersect-live-ranges >boolean ; inline
|
relevant-ranges intersect-live-ranges >boolean ; inline
|
||||||
|
|
|
@ -12,7 +12,7 @@ IN: compiler.cfg.predecessors
|
||||||
: update-phi ( bb ##phi -- )
|
: update-phi ( bb ##phi -- )
|
||||||
[
|
[
|
||||||
swap predecessors>>
|
swap predecessors>>
|
||||||
'[ drop _ memq? ] assoc-filter
|
'[ drop _ member-eq? ] assoc-filter
|
||||||
] change-inputs drop ;
|
] change-inputs drop ;
|
||||||
|
|
||||||
: update-phis ( bb -- )
|
: update-phis ( bb -- )
|
||||||
|
@ -30,4 +30,4 @@ PRIVATE>
|
||||||
|
|
||||||
: needs-predecessors ( cfg -- cfg' )
|
: needs-predecessors ( cfg -- cfg' )
|
||||||
dup predecessors-valid?>>
|
dup predecessors-valid?>>
|
||||||
[ compute-predecessors t >>predecessors-valid? ] unless ;
|
[ compute-predecessors t >>predecessors-valid? ] unless ;
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! 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 namespaces kernel parser assocs ;
|
USING: accessors namespaces kernel parser assocs sequences ;
|
||||||
IN: compiler.cfg.registers
|
IN: compiler.cfg.registers
|
||||||
|
|
||||||
! Virtual registers, used by CFG and machine IRs, are just integers
|
! Virtual registers, used by CFG and machine IRs, are just integers
|
||||||
|
@ -42,5 +42,5 @@ C: <ds-loc> ds-loc
|
||||||
TUPLE: rs-loc < loc ;
|
TUPLE: rs-loc < loc ;
|
||||||
C: <rs-loc> rs-loc
|
C: <rs-loc> rs-loc
|
||||||
|
|
||||||
SYNTAX: D scan-word <ds-loc> parsed ;
|
SYNTAX: D scan-word <ds-loc> suffix! ;
|
||||||
SYNTAX: R scan-word <rs-loc> parsed ;
|
SYNTAX: R scan-word <rs-loc> suffix! ;
|
||||||
|
|
|
@ -20,15 +20,19 @@ WHERE
|
||||||
|
|
||||||
GENERIC: rename-insn-defs ( insn -- )
|
GENERIC: rename-insn-defs ( insn -- )
|
||||||
|
|
||||||
insn-classes get [
|
M: insn rename-insn-defs drop ;
|
||||||
|
|
||||||
|
insn-classes get [ insn-def-slot ] filter [
|
||||||
[ \ rename-insn-defs create-method-in ]
|
[ \ rename-insn-defs create-method-in ]
|
||||||
[ insn-def-slot dup [ name>> 1array ] when DEF-QUOT slot-change-quot ] bi
|
[ insn-def-slot name>> 1array DEF-QUOT slot-change-quot ] bi
|
||||||
define
|
define
|
||||||
] each
|
] each
|
||||||
|
|
||||||
GENERIC: rename-insn-uses ( insn -- )
|
GENERIC: rename-insn-uses ( insn -- )
|
||||||
|
|
||||||
insn-classes get { ##phi } diff [
|
M: insn rename-insn-uses drop ;
|
||||||
|
|
||||||
|
insn-classes get { ##phi } diff [ insn-use-slots empty? not ] filter [
|
||||||
[ \ rename-insn-uses create-method-in ]
|
[ \ rename-insn-uses create-method-in ]
|
||||||
[ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
|
[ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
|
||||||
define
|
define
|
||||||
|
@ -39,7 +43,9 @@ M: ##phi rename-insn-uses
|
||||||
|
|
||||||
GENERIC: rename-insn-temps ( insn -- )
|
GENERIC: rename-insn-temps ( insn -- )
|
||||||
|
|
||||||
insn-classes get [
|
M: insn rename-insn-temps drop ;
|
||||||
|
|
||||||
|
insn-classes get [ insn-temp-slots empty? not ] filter [
|
||||||
[ \ rename-insn-temps create-method-in ]
|
[ \ rename-insn-temps create-method-in ]
|
||||||
[ insn-temp-slots [ name>> ] map TEMP-QUOT slot-change-quot ] bi
|
[ insn-temp-slots [ name>> ] map TEMP-QUOT slot-change-quot ] bi
|
||||||
define
|
define
|
||||||
|
|
|
@ -11,6 +11,10 @@ GENERIC: defs-vreg-rep ( insn -- rep/f )
|
||||||
GENERIC: temp-vreg-reps ( insn -- reps )
|
GENERIC: temp-vreg-reps ( insn -- reps )
|
||||||
GENERIC: uses-vreg-reps ( insn -- reps )
|
GENERIC: uses-vreg-reps ( insn -- reps )
|
||||||
|
|
||||||
|
M: insn defs-vreg-rep drop f ;
|
||||||
|
M: insn temp-vreg-reps drop { } ;
|
||||||
|
M: insn uses-vreg-reps drop { } ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: rep-getter-quot ( rep -- quot )
|
: rep-getter-quot ( rep -- quot )
|
||||||
|
@ -21,12 +25,14 @@ GENERIC: uses-vreg-reps ( insn -- reps )
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: define-defs-vreg-rep-method ( insn -- )
|
: define-defs-vreg-rep-method ( insn -- )
|
||||||
[ \ defs-vreg-rep create-method ]
|
dup insn-def-slot dup [
|
||||||
[ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ]
|
[ \ defs-vreg-rep create-method ]
|
||||||
bi define ;
|
[ rep>> rep-getter-quot ]
|
||||||
|
bi* define
|
||||||
|
] [ 2drop ] if ;
|
||||||
|
|
||||||
: reps-getter-quot ( reps -- quot )
|
: reps-getter-quot ( reps -- quot )
|
||||||
dup [ rep>> { f scalar-rep } memq? not ] all? [
|
dup [ rep>> { f scalar-rep } member-eq? not ] all? [
|
||||||
[ rep>> ] map [ drop ] swap suffix
|
[ rep>> ] map [ drop ] swap suffix
|
||||||
] [
|
] [
|
||||||
[ rep>> rep-getter-quot ] map dup length {
|
[ rep>> rep-getter-quot ] map dup length {
|
||||||
|
@ -38,14 +44,18 @@ GENERIC: uses-vreg-reps ( insn -- reps )
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: define-uses-vreg-reps-method ( insn -- )
|
: define-uses-vreg-reps-method ( insn -- )
|
||||||
[ \ uses-vreg-reps create-method ]
|
dup insn-use-slots [ drop ] [
|
||||||
[ insn-use-slots reps-getter-quot ]
|
[ \ uses-vreg-reps create-method ]
|
||||||
bi define ;
|
[ reps-getter-quot ]
|
||||||
|
bi* define
|
||||||
|
] if-empty ;
|
||||||
|
|
||||||
: define-temp-vreg-reps-method ( insn -- )
|
: define-temp-vreg-reps-method ( insn -- )
|
||||||
[ \ temp-vreg-reps create-method ]
|
dup insn-temp-slots [ drop ] [
|
||||||
[ insn-temp-slots reps-getter-quot ]
|
[ \ temp-vreg-reps create-method ]
|
||||||
bi define ;
|
[ reps-getter-quot ]
|
||||||
|
bi* define
|
||||||
|
] if-empty ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -47,7 +47,7 @@ M:: vector-rep emit-box ( dst src rep -- )
|
||||||
int-rep next-vreg-rep :> temp
|
int-rep next-vreg-rep :> temp
|
||||||
dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
|
dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
|
||||||
temp 16 tag-fixnum ##load-immediate
|
temp 16 tag-fixnum ##load-immediate
|
||||||
temp dst 1 byte-array tag-number ##set-slot-imm
|
temp dst 1 byte-array type-number ##set-slot-imm
|
||||||
dst byte-array-offset src rep ##set-alien-vector ;
|
dst byte-array-offset src rep ##set-alien-vector ;
|
||||||
|
|
||||||
M: vector-rep emit-unbox
|
M: vector-rep emit-unbox
|
||||||
|
@ -209,7 +209,7 @@ RENAMING: convert [ converted-value ] [ converted-value ] [ ]
|
||||||
|
|
||||||
: perform-renaming ( insn -- )
|
: perform-renaming ( insn -- )
|
||||||
needs-renaming? get [
|
needs-renaming? get [
|
||||||
renaming-set get reverse-here
|
renaming-set get reverse! drop
|
||||||
[ convert-insn-uses ] [ convert-insn-defs ] bi
|
[ convert-insn-uses ] [ convert-insn-defs ] bi
|
||||||
renaming-set get length 0 assert=
|
renaming-set get length 0 assert=
|
||||||
] [ drop ] if ;
|
] [ drop ] if ;
|
||||||
|
|
|
@ -102,7 +102,7 @@ M: ##phi prepare-insn
|
||||||
[ rename-insn-defs ]
|
[ rename-insn-defs ]
|
||||||
[ rename-insn-uses ]
|
[ rename-insn-uses ]
|
||||||
[ [ useless-copy? ] [ ##phi? ] bi or not ] tri
|
[ [ useless-copy? ] [ ##phi? ] bi or not ] tri
|
||||||
] filter-here
|
] filter! drop
|
||||||
] each-basic-block ;
|
] each-basic-block ;
|
||||||
|
|
||||||
: destruct-ssa ( cfg -- cfg' )
|
: destruct-ssa ( cfg -- cfg' )
|
||||||
|
@ -114,4 +114,4 @@ M: ##phi prepare-insn
|
||||||
dup compute-live-ranges
|
dup compute-live-ranges
|
||||||
dup prepare-coalescing
|
dup prepare-coalescing
|
||||||
process-copies
|
process-copies
|
||||||
dup perform-renaming ;
|
dup perform-renaming ;
|
||||||
|
|
|
@ -121,10 +121,9 @@ PRIVATE>
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
:: live-out? ( vreg node -- ? )
|
:: live-out? ( vreg node -- ? )
|
||||||
[let | def [ vreg def-of ] |
|
vreg def-of :> def
|
||||||
{
|
{
|
||||||
{ [ node def eq? ] [ vreg uses-of def only? not ] }
|
{ [ node def eq? ] [ vreg uses-of def only? not ] }
|
||||||
{ [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
|
{ [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
|
||||||
[ f ]
|
[ f ]
|
||||||
} cond
|
} cond ;
|
||||||
] ;
|
|
||||||
|
|
|
@ -13,7 +13,7 @@ IN: compiler.cfg.useless-conditionals
|
||||||
##compare-imm-branch
|
##compare-imm-branch
|
||||||
##compare-float-ordered-branch
|
##compare-float-ordered-branch
|
||||||
##compare-float-unordered-branch
|
##compare-float-unordered-branch
|
||||||
} memq?
|
} member-eq?
|
||||||
]
|
]
|
||||||
[ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
|
[ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
|
||||||
} 1&& ;
|
} 1&& ;
|
||||||
|
|
|
@ -40,8 +40,8 @@ SYMBOL: visited
|
||||||
:: insert-basic-block ( froms to bb -- )
|
:: insert-basic-block ( froms to bb -- )
|
||||||
bb froms V{ } like >>predecessors drop
|
bb froms V{ } like >>predecessors drop
|
||||||
bb to 1vector >>successors drop
|
bb to 1vector >>successors drop
|
||||||
to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each
|
to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop
|
||||||
froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
|
froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ;
|
||||||
|
|
||||||
: add-instructions ( bb quot -- )
|
: add-instructions ( bb quot -- )
|
||||||
[ instructions>> building ] dip '[
|
[ instructions>> building ] dip '[
|
||||||
|
|
|
@ -27,6 +27,9 @@ C: <reference> reference-expr
|
||||||
M: reference-expr equal?
|
M: reference-expr equal?
|
||||||
over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
|
over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: reference-expr hashcode*
|
||||||
|
nip value>> identity-hashcode ;
|
||||||
|
|
||||||
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
|
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
|
||||||
|
|
||||||
GENERIC: >expr ( insn -- expr )
|
GENERIC: >expr ( insn -- expr )
|
||||||
|
@ -42,7 +45,7 @@ M: ##load-constant >expr obj>> <constant> ;
|
||||||
<<
|
<<
|
||||||
|
|
||||||
: input-values ( slot-specs -- slot-specs' )
|
: input-values ( slot-specs -- slot-specs' )
|
||||||
[ type>> { use literal constant } memq? ] filter ;
|
[ type>> { use literal constant } member-eq? ] filter ;
|
||||||
|
|
||||||
: expr-class ( insn -- expr )
|
: expr-class ( insn -- expr )
|
||||||
name>> "##" ?head drop "-expr" append create-class-in ;
|
name>> "##" ?head drop "-expr" append create-class-in ;
|
||||||
|
|
|
@ -37,7 +37,7 @@ M: insn rewrite drop f ;
|
||||||
dup ##compare-imm-branch? [
|
dup ##compare-imm-branch? [
|
||||||
{
|
{
|
||||||
[ cc>> cc/= eq? ]
|
[ cc>> cc/= eq? ]
|
||||||
[ src2>> \ f tag-number eq? ]
|
[ src2>> \ f type-number eq? ]
|
||||||
} 1&&
|
} 1&&
|
||||||
] [ drop f ] if ; inline
|
] [ drop f ] if ; inline
|
||||||
|
|
||||||
|
@ -110,8 +110,8 @@ M: ##compare-imm rewrite-tagged-comparison
|
||||||
: rewrite-redundant-comparison? ( insn -- ? )
|
: rewrite-redundant-comparison? ( insn -- ? )
|
||||||
{
|
{
|
||||||
[ src1>> vreg>expr general-compare-expr? ]
|
[ src1>> vreg>expr general-compare-expr? ]
|
||||||
[ src2>> \ f tag-number = ]
|
[ src2>> \ f type-number = ]
|
||||||
[ cc>> { cc= cc/= } memq? ]
|
[ cc>> { cc= cc/= } member-eq? ]
|
||||||
} 1&& ; inline
|
} 1&& ; inline
|
||||||
|
|
||||||
: rewrite-redundant-comparison ( insn -- insn' )
|
: rewrite-redundant-comparison ( insn -- insn' )
|
||||||
|
@ -174,7 +174,7 @@ M: ##compare-imm-branch rewrite
|
||||||
[ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
|
[ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
|
||||||
|
|
||||||
: (rewrite-self-compare) ( insn -- ? )
|
: (rewrite-self-compare) ( insn -- ? )
|
||||||
cc>> { cc= cc<= cc>= } memq? ;
|
cc>> { cc= cc<= cc>= } member-eq? ;
|
||||||
|
|
||||||
: rewrite-self-compare-branch ( insn -- insn' )
|
: rewrite-self-compare-branch ( insn -- insn' )
|
||||||
(rewrite-self-compare) fold-branch ;
|
(rewrite-self-compare) fold-branch ;
|
||||||
|
@ -204,7 +204,7 @@ M: ##compare-branch rewrite
|
||||||
[ dst>> ] dip
|
[ dst>> ] dip
|
||||||
{
|
{
|
||||||
{ t [ t \ ##load-constant new-insn ] }
|
{ t [ t \ ##load-constant new-insn ] }
|
||||||
{ f [ \ f tag-number \ ##load-immediate new-insn ] }
|
{ f [ \ f type-number \ ##load-immediate new-insn ] }
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: rewrite-self-compare ( insn -- insn' )
|
: rewrite-self-compare ( insn -- insn' )
|
||||||
|
@ -279,7 +279,7 @@ M: ##not rewrite
|
||||||
##sub-imm
|
##sub-imm
|
||||||
##mul
|
##mul
|
||||||
##mul-imm
|
##mul-imm
|
||||||
} memq? ;
|
} member-eq? ;
|
||||||
|
|
||||||
: immediate? ( value op -- ? )
|
: immediate? ( value op -- ? )
|
||||||
arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ;
|
arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ;
|
||||||
|
@ -440,7 +440,7 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
|
||||||
:: rewrite-unbox-displaced-alien ( insn expr -- insns )
|
:: rewrite-unbox-displaced-alien ( insn expr -- insns )
|
||||||
[
|
[
|
||||||
next-vreg :> temp
|
next-vreg :> temp
|
||||||
temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr
|
temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr
|
||||||
insn dst>> temp expr displacement>> vn>vreg ##add
|
insn dst>> temp expr displacement>> vn>vreg ##add
|
||||||
] { } make ;
|
] { } make ;
|
||||||
|
|
||||||
|
@ -515,3 +515,48 @@ M: ##scalar>vector rewrite
|
||||||
M: ##xor-vector rewrite
|
M: ##xor-vector rewrite
|
||||||
dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
|
dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
|
||||||
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
|
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
|
||||||
|
|
||||||
|
: vector-not? ( expr -- ? )
|
||||||
|
{
|
||||||
|
[ not-vector-expr? ]
|
||||||
|
[ {
|
||||||
|
[ xor-vector-expr? ]
|
||||||
|
[ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
|
||||||
|
} 1&& ]
|
||||||
|
} 1|| ;
|
||||||
|
|
||||||
|
GENERIC: vector-not-src ( expr -- vreg )
|
||||||
|
M: not-vector-expr vector-not-src src>> vn>vreg ;
|
||||||
|
M: xor-vector-expr vector-not-src
|
||||||
|
dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
|
||||||
|
|
||||||
|
M: ##and-vector rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src1>> vreg>expr vector-not? ] [
|
||||||
|
{
|
||||||
|
[ dst>> ]
|
||||||
|
[ src1>> vreg>expr vector-not-src ]
|
||||||
|
[ src2>> ]
|
||||||
|
[ rep>> ]
|
||||||
|
} cleave \ ##andn-vector new-insn
|
||||||
|
] }
|
||||||
|
{ [ dup src2>> vreg>expr vector-not? ] [
|
||||||
|
{
|
||||||
|
[ dst>> ]
|
||||||
|
[ src2>> vreg>expr vector-not-src ]
|
||||||
|
[ src1>> ]
|
||||||
|
[ rep>> ]
|
||||||
|
} cleave \ ##andn-vector new-insn
|
||||||
|
] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##andn-vector rewrite
|
||||||
|
dup src1>> vreg>expr vector-not? [
|
||||||
|
{
|
||||||
|
[ dst>> ]
|
||||||
|
[ src1>> vreg>expr vector-not-src ]
|
||||||
|
[ src2>> ]
|
||||||
|
[ rep>> ]
|
||||||
|
} cleave \ ##and-vector new-insn
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
|
@ -82,7 +82,7 @@ IN: compiler.cfg.value-numbering.tests
|
||||||
T{ ##load-reference f 1 + }
|
T{ ##load-reference f 1 + }
|
||||||
T{ ##peek f 2 D 0 }
|
T{ ##peek f 2 D 0 }
|
||||||
T{ ##compare f 4 2 1 cc> }
|
T{ ##compare f 4 2 1 cc> }
|
||||||
T{ ##compare-imm f 6 4 5 cc/= }
|
T{ ##compare-imm f 6 4 $[ \ f type-number ] cc/= }
|
||||||
T{ ##replace f 6 D 0 }
|
T{ ##replace f 6 D 0 }
|
||||||
} value-numbering-step trim-temps
|
} value-numbering-step trim-temps
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -100,7 +100,7 @@ IN: compiler.cfg.value-numbering.tests
|
||||||
T{ ##load-reference f 1 + }
|
T{ ##load-reference f 1 + }
|
||||||
T{ ##peek f 2 D 0 }
|
T{ ##peek f 2 D 0 }
|
||||||
T{ ##compare f 4 2 1 cc<= }
|
T{ ##compare f 4 2 1 cc<= }
|
||||||
T{ ##compare-imm f 6 4 5 cc= }
|
T{ ##compare-imm f 6 4 $[ \ f type-number ] cc= }
|
||||||
T{ ##replace f 6 D 0 }
|
T{ ##replace f 6 D 0 }
|
||||||
} value-numbering-step trim-temps
|
} value-numbering-step trim-temps
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -118,7 +118,7 @@ IN: compiler.cfg.value-numbering.tests
|
||||||
T{ ##peek f 8 D 0 }
|
T{ ##peek f 8 D 0 }
|
||||||
T{ ##peek f 9 D -1 }
|
T{ ##peek f 9 D -1 }
|
||||||
T{ ##compare-float-unordered f 12 8 9 cc< }
|
T{ ##compare-float-unordered f 12 8 9 cc< }
|
||||||
T{ ##compare-imm f 14 12 5 cc= }
|
T{ ##compare-imm f 14 12 $[ \ f type-number ] cc= }
|
||||||
T{ ##replace f 14 D 0 }
|
T{ ##replace f 14 D 0 }
|
||||||
} value-numbering-step trim-temps
|
} value-numbering-step trim-temps
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -135,7 +135,7 @@ IN: compiler.cfg.value-numbering.tests
|
||||||
T{ ##peek f 29 D -1 }
|
T{ ##peek f 29 D -1 }
|
||||||
T{ ##peek f 30 D -2 }
|
T{ ##peek f 30 D -2 }
|
||||||
T{ ##compare f 33 29 30 cc<= }
|
T{ ##compare f 33 29 30 cc<= }
|
||||||
T{ ##compare-imm-branch f 33 5 cc/= }
|
T{ ##compare-imm-branch f 33 $[ \ f type-number ] cc/= }
|
||||||
} value-numbering-step trim-temps
|
} value-numbering-step trim-temps
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -149,7 +149,7 @@ IN: compiler.cfg.value-numbering.tests
|
||||||
{
|
{
|
||||||
T{ ##peek f 1 D -1 }
|
T{ ##peek f 1 D -1 }
|
||||||
T{ ##test-vector f 2 1 f float-4-rep vcc-any }
|
T{ ##test-vector f 2 1 f float-4-rep vcc-any }
|
||||||
T{ ##compare-imm-branch f 2 5 cc/= }
|
T{ ##compare-imm-branch f 2 $[ \ f type-number ] cc/= }
|
||||||
} value-numbering-step trim-temps
|
} value-numbering-step trim-temps
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -1071,14 +1071,14 @@ cell 8 = [
|
||||||
! Branch folding
|
! Branch folding
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
T{ ##load-immediate f 1 1 }
|
T{ ##load-immediate f 1 10 }
|
||||||
T{ ##load-immediate f 2 2 }
|
T{ ##load-immediate f 2 20 }
|
||||||
T{ ##load-immediate f 3 5 }
|
T{ ##load-immediate f 3 $[ \ f type-number ] }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
{
|
{
|
||||||
T{ ##load-immediate f 1 1 }
|
T{ ##load-immediate f 1 10 }
|
||||||
T{ ##load-immediate f 2 2 }
|
T{ ##load-immediate f 2 20 }
|
||||||
T{ ##compare f 3 1 2 cc= }
|
T{ ##compare f 3 1 2 cc= }
|
||||||
} value-numbering-step
|
} value-numbering-step
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -1113,14 +1113,14 @@ cell 8 = [
|
||||||
|
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
T{ ##load-immediate f 1 1 }
|
T{ ##load-immediate f 1 10 }
|
||||||
T{ ##load-immediate f 2 2 }
|
T{ ##load-immediate f 2 20 }
|
||||||
T{ ##load-immediate f 3 5 }
|
T{ ##load-immediate f 3 $[ \ f type-number ] }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
{
|
{
|
||||||
T{ ##load-immediate f 1 1 }
|
T{ ##load-immediate f 1 10 }
|
||||||
T{ ##load-immediate f 2 2 }
|
T{ ##load-immediate f 2 20 }
|
||||||
T{ ##compare f 3 2 1 cc< }
|
T{ ##compare f 3 2 1 cc< }
|
||||||
} value-numbering-step
|
} value-numbering-step
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -1128,7 +1128,7 @@ cell 8 = [
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
T{ ##peek f 0 D 0 }
|
T{ ##peek f 0 D 0 }
|
||||||
T{ ##load-immediate f 1 5 }
|
T{ ##load-immediate f 1 $[ \ f type-number ] }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
{
|
{
|
||||||
|
@ -1152,7 +1152,7 @@ cell 8 = [
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
T{ ##peek f 0 D 0 }
|
T{ ##peek f 0 D 0 }
|
||||||
T{ ##load-immediate f 1 5 }
|
T{ ##load-immediate f 1 $[ \ f type-number ] }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
{
|
{
|
||||||
|
@ -1176,7 +1176,7 @@ cell 8 = [
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
T{ ##peek f 0 D 0 }
|
T{ ##peek f 0 D 0 }
|
||||||
T{ ##load-immediate f 1 5 }
|
T{ ##load-immediate f 1 $[ \ f type-number ] }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
{
|
{
|
||||||
|
@ -1281,6 +1281,128 @@ cell 8 = [
|
||||||
} value-numbering-step
|
} value-numbering-step
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
! NOT x AND y => x ANDN y
|
||||||
|
|
||||||
|
[
|
||||||
|
{
|
||||||
|
T{ ##fill-vector f 3 float-4-rep }
|
||||||
|
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||||
|
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
{
|
||||||
|
T{ ##fill-vector f 3 float-4-rep }
|
||||||
|
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||||
|
T{ ##and-vector f 5 4 1 float-4-rep }
|
||||||
|
} value-numbering-step
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
{
|
||||||
|
T{ ##not-vector f 4 0 float-4-rep }
|
||||||
|
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
{
|
||||||
|
T{ ##not-vector f 4 0 float-4-rep }
|
||||||
|
T{ ##and-vector f 5 4 1 float-4-rep }
|
||||||
|
} value-numbering-step
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
! x AND NOT y => y ANDN x
|
||||||
|
|
||||||
|
[
|
||||||
|
{
|
||||||
|
T{ ##fill-vector f 3 float-4-rep }
|
||||||
|
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||||
|
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
{
|
||||||
|
T{ ##fill-vector f 3 float-4-rep }
|
||||||
|
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||||
|
T{ ##and-vector f 5 1 4 float-4-rep }
|
||||||
|
} value-numbering-step
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
{
|
||||||
|
T{ ##not-vector f 4 0 float-4-rep }
|
||||||
|
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
{
|
||||||
|
T{ ##not-vector f 4 0 float-4-rep }
|
||||||
|
T{ ##and-vector f 5 1 4 float-4-rep }
|
||||||
|
} value-numbering-step
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
! NOT x ANDN y => x AND y
|
||||||
|
|
||||||
|
[
|
||||||
|
{
|
||||||
|
T{ ##fill-vector f 3 float-4-rep }
|
||||||
|
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||||
|
T{ ##and-vector f 5 0 1 float-4-rep }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
{
|
||||||
|
T{ ##fill-vector f 3 float-4-rep }
|
||||||
|
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||||
|
T{ ##andn-vector f 5 4 1 float-4-rep }
|
||||||
|
} value-numbering-step
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
{
|
||||||
|
T{ ##not-vector f 4 0 float-4-rep }
|
||||||
|
T{ ##and-vector f 5 0 1 float-4-rep }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
{
|
||||||
|
T{ ##not-vector f 4 0 float-4-rep }
|
||||||
|
T{ ##andn-vector f 5 4 1 float-4-rep }
|
||||||
|
} value-numbering-step
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
! AND <=> ANDN
|
||||||
|
|
||||||
|
[
|
||||||
|
{
|
||||||
|
T{ ##fill-vector f 3 float-4-rep }
|
||||||
|
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||||
|
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||||
|
T{ ##and-vector f 6 0 2 float-4-rep }
|
||||||
|
T{ ##or-vector f 7 5 6 float-4-rep }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
{
|
||||||
|
T{ ##fill-vector f 3 float-4-rep }
|
||||||
|
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||||
|
T{ ##and-vector f 5 4 1 float-4-rep }
|
||||||
|
T{ ##andn-vector f 6 4 2 float-4-rep }
|
||||||
|
T{ ##or-vector f 7 5 6 float-4-rep }
|
||||||
|
} value-numbering-step
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
{
|
||||||
|
T{ ##not-vector f 4 0 float-4-rep }
|
||||||
|
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||||
|
T{ ##and-vector f 6 0 2 float-4-rep }
|
||||||
|
T{ ##or-vector f 7 5 6 float-4-rep }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
{
|
||||||
|
T{ ##not-vector f 4 0 float-4-rep }
|
||||||
|
T{ ##and-vector f 5 4 1 float-4-rep }
|
||||||
|
T{ ##andn-vector f 6 4 2 float-4-rep }
|
||||||
|
T{ ##or-vector f 7 5 6 float-4-rep }
|
||||||
|
} value-numbering-step
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
! branch folding
|
||||||
|
|
||||||
: test-branch-folding ( insns -- insns' n )
|
: test-branch-folding ( insns -- insns' n )
|
||||||
<basic-block>
|
<basic-block>
|
||||||
[ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
|
[ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
|
||||||
|
@ -1435,7 +1557,7 @@ cell 8 = [
|
||||||
{
|
{
|
||||||
T{ ##peek f 0 D 0 }
|
T{ ##peek f 0 D 0 }
|
||||||
T{ ##compare f 1 0 0 cc<= }
|
T{ ##compare f 1 0 0 cc<= }
|
||||||
T{ ##compare-imm-branch f 1 5 cc/= }
|
T{ ##compare-imm-branch f 1 $[ \ f type-number ] cc/= }
|
||||||
} test-branch-folding
|
} test-branch-folding
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -1537,7 +1659,7 @@ V{
|
||||||
T{ ##copy { dst 21 } { src 20 } { rep any-rep } }
|
T{ ##copy { dst 21 } { src 20 } { rep any-rep } }
|
||||||
T{ ##compare-imm-branch
|
T{ ##compare-imm-branch
|
||||||
{ src1 21 }
|
{ src1 21 }
|
||||||
{ src2 5 }
|
{ src2 $[ \ f type-number ] }
|
||||||
{ cc cc/= }
|
{ cc cc/= }
|
||||||
}
|
}
|
||||||
} 1 test-bb
|
} 1 test-bb
|
||||||
|
|
|
@ -37,7 +37,7 @@ M: insn eliminate-write-barrier drop t ;
|
||||||
: write-barriers-step ( bb -- )
|
: write-barriers-step ( bb -- )
|
||||||
H{ } clone fresh-allocations set
|
H{ } clone fresh-allocations set
|
||||||
H{ } clone mutated-objects set
|
H{ } clone mutated-objects set
|
||||||
instructions>> [ eliminate-write-barrier ] filter-here ;
|
instructions>> [ eliminate-write-barrier ] filter! drop ;
|
||||||
|
|
||||||
: eliminate-write-barriers ( cfg -- cfg' )
|
: eliminate-write-barriers ( cfg -- cfg' )
|
||||||
dup [ write-barriers-step ] each-basic-block ;
|
dup [ write-barriers-step ] each-basic-block ;
|
||||||
|
|
|
@ -181,14 +181,16 @@ CODEGEN: ##dot-vector %dot-vector
|
||||||
CODEGEN: ##sqrt-vector %sqrt-vector
|
CODEGEN: ##sqrt-vector %sqrt-vector
|
||||||
CODEGEN: ##horizontal-add-vector %horizontal-add-vector
|
CODEGEN: ##horizontal-add-vector %horizontal-add-vector
|
||||||
CODEGEN: ##horizontal-sub-vector %horizontal-sub-vector
|
CODEGEN: ##horizontal-sub-vector %horizontal-sub-vector
|
||||||
CODEGEN: ##horizontal-shl-vector %horizontal-shl-vector
|
CODEGEN: ##horizontal-shl-vector-imm %horizontal-shl-vector-imm
|
||||||
CODEGEN: ##horizontal-shr-vector %horizontal-shr-vector
|
CODEGEN: ##horizontal-shr-vector-imm %horizontal-shr-vector-imm
|
||||||
CODEGEN: ##abs-vector %abs-vector
|
CODEGEN: ##abs-vector %abs-vector
|
||||||
CODEGEN: ##and-vector %and-vector
|
CODEGEN: ##and-vector %and-vector
|
||||||
CODEGEN: ##andn-vector %andn-vector
|
CODEGEN: ##andn-vector %andn-vector
|
||||||
CODEGEN: ##or-vector %or-vector
|
CODEGEN: ##or-vector %or-vector
|
||||||
CODEGEN: ##xor-vector %xor-vector
|
CODEGEN: ##xor-vector %xor-vector
|
||||||
CODEGEN: ##not-vector %not-vector
|
CODEGEN: ##not-vector %not-vector
|
||||||
|
CODEGEN: ##shl-vector-imm %shl-vector-imm
|
||||||
|
CODEGEN: ##shr-vector-imm %shr-vector-imm
|
||||||
CODEGEN: ##shl-vector %shl-vector
|
CODEGEN: ##shl-vector %shl-vector
|
||||||
CODEGEN: ##shr-vector %shr-vector
|
CODEGEN: ##shr-vector %shr-vector
|
||||||
CODEGEN: ##integer>scalar %integer>scalar
|
CODEGEN: ##integer>scalar %integer>scalar
|
||||||
|
|
|
@ -5,13 +5,16 @@ continuations vocabs assocs dlists definitions math graphs generic
|
||||||
generic.single combinators deques search-deques macros
|
generic.single combinators deques search-deques macros
|
||||||
source-files.errors combinators.short-circuit
|
source-files.errors combinators.short-circuit
|
||||||
|
|
||||||
stack-checker stack-checker.state stack-checker.inlining stack-checker.errors
|
stack-checker stack-checker.dependencies stack-checker.inlining
|
||||||
|
stack-checker.errors
|
||||||
|
|
||||||
compiler.errors compiler.units compiler.utilities
|
compiler.errors compiler.units compiler.utilities
|
||||||
|
|
||||||
compiler.tree.builder
|
compiler.tree.builder
|
||||||
compiler.tree.optimizer
|
compiler.tree.optimizer
|
||||||
|
|
||||||
|
compiler.crossref
|
||||||
|
|
||||||
compiler.cfg
|
compiler.cfg
|
||||||
compiler.cfg.builder
|
compiler.cfg.builder
|
||||||
compiler.cfg.optimizer
|
compiler.cfg.optimizer
|
||||||
|
@ -55,28 +58,28 @@ SYMBOL: compiled
|
||||||
|
|
||||||
GENERIC: no-compile? ( word -- ? )
|
GENERIC: no-compile? ( word -- ? )
|
||||||
|
|
||||||
M: word no-compile? "no-compile" word-prop ;
|
|
||||||
|
|
||||||
M: method-body no-compile? "method-generic" word-prop no-compile? ;
|
M: method-body no-compile? "method-generic" word-prop no-compile? ;
|
||||||
|
|
||||||
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
|
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
|
||||||
|
|
||||||
|
M: word no-compile?
|
||||||
|
{ [ macro? ] [ "special" word-prop ] [ "no-compile" word-prop ] } 1|| ;
|
||||||
|
|
||||||
|
GENERIC: combinator? ( word -- ? )
|
||||||
|
|
||||||
|
M: method-body combinator? "method-generic" word-prop combinator? ;
|
||||||
|
|
||||||
|
M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ;
|
||||||
|
|
||||||
|
M: word combinator? inline? ;
|
||||||
|
|
||||||
: 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'.
|
||||||
[
|
{
|
||||||
{
|
[ drop no-compile? ]
|
||||||
[ macro? ]
|
[ [ combinator? ] [ unknown-macro-input? ] bi* and ]
|
||||||
[ inline? ]
|
} 2|| ;
|
||||||
[ no-compile? ]
|
|
||||||
[ "special" word-prop ]
|
|
||||||
} 1||
|
|
||||||
] [
|
|
||||||
{
|
|
||||||
[ do-not-compile? ]
|
|
||||||
[ literal-expected? ]
|
|
||||||
} 1||
|
|
||||||
] bi* and ;
|
|
||||||
|
|
||||||
: finish ( word -- )
|
: finish ( word -- )
|
||||||
#! Recompile callers if the word's stack effect changed, then
|
#! Recompile callers if the word's stack effect changed, then
|
||||||
|
@ -199,6 +202,14 @@ M: optimizing-compiler recompile ( words -- alist )
|
||||||
] with-scope
|
] with-scope
|
||||||
"--- compile done" compiler-message ;
|
"--- compile done" compiler-message ;
|
||||||
|
|
||||||
|
M: optimizing-compiler to-recompile ( -- words )
|
||||||
|
changed-definitions get compiled-usages
|
||||||
|
changed-generics get compiled-generic-usages
|
||||||
|
append assoc-combine keys ;
|
||||||
|
|
||||||
|
M: optimizing-compiler process-forgotten-words
|
||||||
|
[ delete-compiled-xref ] each ;
|
||||||
|
|
||||||
: with-optimizer ( quot -- )
|
: with-optimizer ( quot -- )
|
||||||
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
|
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
|
||||||
|
|
||||||
|
|
|
@ -12,19 +12,18 @@ CONSTANT: deck-bits 18
|
||||||
! These constants must match vm/layouts.h
|
! These constants must match vm/layouts.h
|
||||||
: slot-offset ( slot tag -- n ) [ bootstrap-cells ] dip - ; inline
|
: slot-offset ( slot tag -- n ) [ bootstrap-cells ] dip - ; inline
|
||||||
|
|
||||||
: header-offset ( -- n ) 0 object tag-number slot-offset ; inline
|
: float-offset ( -- n ) 8 float type-number - ; inline
|
||||||
: float-offset ( -- n ) 8 float tag-number - ; inline
|
: string-offset ( -- n ) 4 string type-number slot-offset ; inline
|
||||||
: string-offset ( -- n ) 4 string tag-number slot-offset ; inline
|
: string-aux-offset ( -- n ) 2 string type-number slot-offset ; inline
|
||||||
: string-aux-offset ( -- n ) 2 string tag-number slot-offset ; inline
|
: profile-count-offset ( -- n ) 8 \ word type-number slot-offset ; inline
|
||||||
: profile-count-offset ( -- n ) 8 \ word tag-number slot-offset ; inline
|
: byte-array-offset ( -- n ) 16 byte-array type-number - ; inline
|
||||||
: byte-array-offset ( -- n ) 2 byte-array tag-number slot-offset ; inline
|
: alien-offset ( -- n ) 4 alien type-number slot-offset ; inline
|
||||||
: alien-offset ( -- n ) 3 alien tag-number slot-offset ; inline
|
: underlying-alien-offset ( -- n ) 1 alien type-number slot-offset ; inline
|
||||||
: underlying-alien-offset ( -- n ) 1 alien tag-number slot-offset ; inline
|
: tuple-class-offset ( -- n ) 1 tuple type-number slot-offset ; inline
|
||||||
: tuple-class-offset ( -- n ) 1 tuple tag-number slot-offset ; inline
|
: word-xt-offset ( -- n ) 10 \ word type-number slot-offset ; inline
|
||||||
: word-xt-offset ( -- n ) 10 \ word tag-number slot-offset ; inline
|
: quot-xt-offset ( -- n ) 4 quotation type-number slot-offset ; inline
|
||||||
: quot-xt-offset ( -- n ) 4 quotation tag-number slot-offset ; inline
|
: word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline
|
||||||
: word-code-offset ( -- n ) 11 \ word tag-number slot-offset ; inline
|
: array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
|
||||||
: array-start-offset ( -- n ) 2 array tag-number slot-offset ; inline
|
|
||||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
|
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
|
||||||
|
|
||||||
! Relocation classes
|
! Relocation classes
|
||||||
|
|
0
basis/io/servers/packet/authors.txt → basis/compiler/crossref/authors.txt
Executable file → Normal file
0
basis/io/servers/packet/authors.txt → basis/compiler/crossref/authors.txt
Executable file → Normal file
|
@ -0,0 +1,68 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: assocs classes.algebra compiler.units definitions graphs
|
||||||
|
grouping kernel namespaces sequences words
|
||||||
|
stack-checker.dependencies ;
|
||||||
|
IN: compiler.crossref
|
||||||
|
|
||||||
|
SYMBOL: compiled-crossref
|
||||||
|
|
||||||
|
compiled-crossref [ H{ } clone ] initialize
|
||||||
|
|
||||||
|
SYMBOL: compiled-generic-crossref
|
||||||
|
|
||||||
|
compiled-generic-crossref [ H{ } clone ] initialize
|
||||||
|
|
||||||
|
: compiled-usage ( word -- assoc )
|
||||||
|
compiled-crossref get at ;
|
||||||
|
|
||||||
|
: (compiled-usages) ( word -- assoc )
|
||||||
|
#! If the word is not flushable anymore, we have to recompile
|
||||||
|
#! all words which flushable away a call (presumably when the
|
||||||
|
#! word was still flushable). If the word is flushable, we
|
||||||
|
#! don't have to recompile words that folded this away.
|
||||||
|
[ compiled-usage ]
|
||||||
|
[ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
|
||||||
|
[ dependency>= nip ] curry assoc-filter ;
|
||||||
|
|
||||||
|
: compiled-usages ( seq -- assocs )
|
||||||
|
[ drop word? ] assoc-filter
|
||||||
|
[ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
|
||||||
|
|
||||||
|
: compiled-generic-usage ( word -- assoc )
|
||||||
|
compiled-generic-crossref get at ;
|
||||||
|
|
||||||
|
: (compiled-generic-usages) ( generic class -- assoc )
|
||||||
|
[ compiled-generic-usage ] dip
|
||||||
|
[
|
||||||
|
2dup [ valid-class? ] both?
|
||||||
|
[ classes-intersect? ] [ 2drop f ] if nip
|
||||||
|
] curry assoc-filter ;
|
||||||
|
|
||||||
|
: compiled-generic-usages ( assoc -- assocs )
|
||||||
|
[ (compiled-generic-usages) ] { } assoc>map ;
|
||||||
|
|
||||||
|
: (compiled-xref) ( word dependencies word-prop variable -- )
|
||||||
|
[ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
|
||||||
|
|
||||||
|
: compiled-xref ( word dependencies generic-dependencies -- )
|
||||||
|
[ [ drop crossref? ] { } assoc-filter-as ] bi@
|
||||||
|
[ "compiled-uses" compiled-crossref (compiled-xref) ]
|
||||||
|
[ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
|
||||||
|
bi-curry* bi ;
|
||||||
|
|
||||||
|
: (compiled-unxref) ( word word-prop variable -- )
|
||||||
|
[ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
|
||||||
|
[ drop [ remove-word-prop ] curry ]
|
||||||
|
2bi bi ;
|
||||||
|
|
||||||
|
: compiled-unxref ( word -- )
|
||||||
|
[ "compiled-uses" compiled-crossref (compiled-unxref) ]
|
||||||
|
[ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
|
||||||
|
bi ;
|
||||||
|
|
||||||
|
: delete-compiled-xref ( word -- )
|
||||||
|
[ compiled-unxref ]
|
||||||
|
[ compiled-crossref get delete-at ]
|
||||||
|
[ compiled-generic-crossref get delete-at ]
|
||||||
|
tri ;
|
|
@ -12,7 +12,7 @@ IN: compiler.tests.alien
|
||||||
|
|
||||||
<<
|
<<
|
||||||
: libfactor-ffi-tests-path ( -- string )
|
: libfactor-ffi-tests-path ( -- string )
|
||||||
"resource:" (normalize-path)
|
"resource:" absolute-path
|
||||||
{
|
{
|
||||||
{ [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
|
{ [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
|
||||||
{ [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
|
{ [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
|
||||||
|
@ -90,14 +90,14 @@ FUNCTION: TINY ffi_test_17 int x ;
|
||||||
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
|
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
|
||||||
|
|
||||||
: indirect-test-1 ( ptr -- result )
|
: indirect-test-1 ( ptr -- result )
|
||||||
"int" { } "cdecl" alien-indirect ;
|
int { } "cdecl" alien-indirect ;
|
||||||
|
|
||||||
{ 1 1 } [ indirect-test-1 ] must-infer-as
|
{ 1 1 } [ indirect-test-1 ] must-infer-as
|
||||||
|
|
||||||
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
|
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
|
||||||
|
|
||||||
: indirect-test-1' ( ptr -- )
|
: indirect-test-1' ( ptr -- )
|
||||||
"int" { } "cdecl" alien-indirect drop ;
|
int { } "cdecl" alien-indirect drop ;
|
||||||
|
|
||||||
{ 1 0 } [ indirect-test-1' ] must-infer-as
|
{ 1 0 } [ indirect-test-1' ] must-infer-as
|
||||||
|
|
||||||
|
@ -106,7 +106,7 @@ FUNCTION: TINY ffi_test_17 int x ;
|
||||||
[ -1 indirect-test-1 ] must-fail
|
[ -1 indirect-test-1 ] must-fail
|
||||||
|
|
||||||
: indirect-test-2 ( x y ptr -- result )
|
: indirect-test-2 ( x y ptr -- result )
|
||||||
"int" { "int" "int" } "cdecl" alien-indirect gc ;
|
int { int int } "cdecl" alien-indirect gc ;
|
||||||
|
|
||||||
{ 3 1 } [ indirect-test-2 ] must-infer-as
|
{ 3 1 } [ indirect-test-2 ] must-infer-as
|
||||||
|
|
||||||
|
@ -115,20 +115,20 @@ FUNCTION: TINY ffi_test_17 int x ;
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
: indirect-test-3 ( a b c d ptr -- result )
|
: indirect-test-3 ( a b c d ptr -- result )
|
||||||
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
|
int { int int int int } "stdcall" alien-indirect
|
||||||
gc ;
|
gc ;
|
||||||
|
|
||||||
[ f ] [ "f-stdcall" load-library f = ] unit-test
|
[ f ] [ "f-stdcall" load-library f = ] unit-test
|
||||||
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
|
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
|
||||||
|
|
||||||
: ffi_test_18 ( w x y z -- int )
|
: ffi_test_18 ( w x y z -- int )
|
||||||
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
|
int "f-stdcall" "ffi_test_18" { int int int int }
|
||||||
alien-invoke gc ;
|
alien-invoke gc ;
|
||||||
|
|
||||||
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
|
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
|
||||||
|
|
||||||
: ffi_test_19 ( x y z -- BAR )
|
: ffi_test_19 ( x y z -- BAR )
|
||||||
"BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
|
BAR "f-stdcall" "ffi_test_19" { long long long }
|
||||||
alien-invoke gc ;
|
alien-invoke gc ;
|
||||||
|
|
||||||
[ 11 6 -7 ] [
|
[ 11 6 -7 ] [
|
||||||
|
@ -157,17 +157,17 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
|
||||||
! Make sure XT doesn't get clobbered in stack frame
|
! Make sure XT doesn't get clobbered in stack frame
|
||||||
|
|
||||||
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
|
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
|
||||||
"int"
|
int
|
||||||
"f-cdecl" "ffi_test_31"
|
"f-cdecl" "ffi_test_31"
|
||||||
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
|
{ int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
|
||||||
alien-invoke gc 3 ;
|
alien-invoke gc 3 ;
|
||||||
|
|
||||||
[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
|
[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
|
||||||
|
|
||||||
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
|
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
|
||||||
"float"
|
float
|
||||||
"f-cdecl" "ffi_test_31_point_5"
|
"f-cdecl" "ffi_test_31_point_5"
|
||||||
{ "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
|
{ float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
|
||||||
alien-invoke ;
|
alien-invoke ;
|
||||||
|
|
||||||
[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
|
[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
|
||||||
|
@ -312,21 +312,21 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
|
||||||
|
|
||||||
! Test callbacks
|
! Test callbacks
|
||||||
|
|
||||||
: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
|
: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
|
||||||
|
|
||||||
[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
|
[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
|
||||||
|
|
||||||
[ t ] [ callback-1 alien? ] unit-test
|
[ t ] [ callback-1 alien? ] unit-test
|
||||||
|
|
||||||
: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
|
: callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
|
||||||
|
|
||||||
[ ] [ callback-1 callback_test_1 ] unit-test
|
[ ] [ callback-1 callback_test_1 ] unit-test
|
||||||
|
|
||||||
: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
|
: callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
|
||||||
|
|
||||||
[ ] [ callback-2 callback_test_1 ] unit-test
|
[ ] [ callback-2 callback_test_1 ] unit-test
|
||||||
|
|
||||||
: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
|
: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
namestack*
|
namestack*
|
||||||
|
@ -341,7 +341,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: callback-4 ( -- callback )
|
: callback-4 ( -- callback )
|
||||||
"void" { } "cdecl" [ "Hello world" write ] alien-callback
|
void { } "cdecl" [ "Hello world" write ] alien-callback
|
||||||
gc ;
|
gc ;
|
||||||
|
|
||||||
[ "Hello world" ] [
|
[ "Hello world" ] [
|
||||||
|
@ -349,40 +349,40 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: callback-5 ( -- callback )
|
: callback-5 ( -- callback )
|
||||||
"void" { } "cdecl" [ gc ] alien-callback ;
|
void { } "cdecl" [ gc ] alien-callback ;
|
||||||
|
|
||||||
[ "testing" ] [
|
[ "testing" ] [
|
||||||
"testing" callback-5 callback_test_1
|
"testing" callback-5 callback_test_1
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: callback-5b ( -- callback )
|
: callback-5b ( -- callback )
|
||||||
"void" { } "cdecl" [ compact-gc ] alien-callback ;
|
void { } "cdecl" [ compact-gc ] alien-callback ;
|
||||||
|
|
||||||
[ "testing" ] [
|
[ "testing" ] [
|
||||||
"testing" callback-5b callback_test_1
|
"testing" callback-5b callback_test_1
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: callback-6 ( -- callback )
|
: callback-6 ( -- callback )
|
||||||
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
|
void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
|
||||||
|
|
||||||
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
|
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
|
||||||
|
|
||||||
: callback-7 ( -- callback )
|
: callback-7 ( -- callback )
|
||||||
"void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
|
void { } "cdecl" [ 1000000 sleep ] alien-callback ;
|
||||||
|
|
||||||
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
|
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
|
||||||
|
|
||||||
[ f ] [ namespace global eq? ] unit-test
|
[ f ] [ namespace global eq? ] unit-test
|
||||||
|
|
||||||
: callback-8 ( -- callback )
|
: callback-8 ( -- callback )
|
||||||
"void" { } "cdecl" [
|
void { } "cdecl" [
|
||||||
[ continue ] callcc0
|
[ continue ] callcc0
|
||||||
] alien-callback ;
|
] alien-callback ;
|
||||||
|
|
||||||
[ ] [ callback-8 callback_test_1 ] unit-test
|
[ ] [ callback-8 callback_test_1 ] unit-test
|
||||||
|
|
||||||
: callback-9 ( -- callback )
|
: callback-9 ( -- callback )
|
||||||
"int" { "int" "int" "int" } "cdecl" [
|
int { int int int } "cdecl" [
|
||||||
+ + 1 +
|
+ + 1 +
|
||||||
] alien-callback ;
|
] alien-callback ;
|
||||||
|
|
||||||
|
@ -440,13 +440,13 @@ STRUCT: double-rect
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
: double-rect-callback ( -- alien )
|
: double-rect-callback ( -- alien )
|
||||||
"void" { "void*" "void*" "double-rect" } "cdecl"
|
void { void* void* double-rect } "cdecl"
|
||||||
[ "example" set-global 2drop ] alien-callback ;
|
[ "example" set-global 2drop ] alien-callback ;
|
||||||
|
|
||||||
: double-rect-test ( arg -- arg' )
|
: double-rect-test ( arg -- arg' )
|
||||||
f f rot
|
f f rot
|
||||||
double-rect-callback
|
double-rect-callback
|
||||||
"void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect
|
void { void* void* double-rect } "cdecl" alien-indirect
|
||||||
"example" get-global ;
|
"example" get-global ;
|
||||||
|
|
||||||
[ 1.0 2.0 3.0 4.0 ]
|
[ 1.0 2.0 3.0 4.0 ]
|
||||||
|
@ -463,7 +463,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: callback-10 ( -- callback )
|
: callback-10 ( -- callback )
|
||||||
"test_struct_14" { "double" "double" } "cdecl"
|
test_struct_14 { double double } "cdecl"
|
||||||
[
|
[
|
||||||
test_struct_14 <struct>
|
test_struct_14 <struct>
|
||||||
swap >>x2
|
swap >>x2
|
||||||
|
@ -471,7 +471,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
|
||||||
] alien-callback ;
|
] alien-callback ;
|
||||||
|
|
||||||
: callback-10-test ( x1 x2 callback -- result )
|
: callback-10-test ( x1 x2 callback -- result )
|
||||||
"test_struct_14" { "double" "double" } "cdecl" alien-indirect ;
|
test_struct_14 { double double } "cdecl" alien-indirect ;
|
||||||
|
|
||||||
[ 1.0 2.0 ] [
|
[ 1.0 2.0 ] [
|
||||||
1.0 2.0 callback-10 callback-10-test
|
1.0 2.0 callback-10 callback-10-test
|
||||||
|
@ -486,7 +486,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: callback-11 ( -- callback )
|
: callback-11 ( -- callback )
|
||||||
"test-struct-12" { "int" "double" } "cdecl"
|
test-struct-12 { int double } "cdecl"
|
||||||
[
|
[
|
||||||
test-struct-12 <struct>
|
test-struct-12 <struct>
|
||||||
swap >>x
|
swap >>x
|
||||||
|
@ -494,7 +494,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
|
||||||
] alien-callback ;
|
] alien-callback ;
|
||||||
|
|
||||||
: callback-11-test ( x1 x2 callback -- result )
|
: callback-11-test ( x1 x2 callback -- result )
|
||||||
"test-struct-12" { "int" "double" } "cdecl" alien-indirect ;
|
test-struct-12 { int double } "cdecl" alien-indirect ;
|
||||||
|
|
||||||
[ 1 2.0 ] [
|
[ 1 2.0 ] [
|
||||||
1 2.0 callback-11 callback-11-test
|
1 2.0 callback-11 callback-11-test
|
||||||
|
@ -510,7 +510,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
|
||||||
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
|
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
|
||||||
|
|
||||||
: callback-12 ( -- callback )
|
: callback-12 ( -- callback )
|
||||||
"test_struct_15" { "float" "float" } "cdecl"
|
test_struct_15 { float float } "cdecl"
|
||||||
[
|
[
|
||||||
test_struct_15 <struct>
|
test_struct_15 <struct>
|
||||||
swap >>y
|
swap >>y
|
||||||
|
@ -518,7 +518,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
|
||||||
] alien-callback ;
|
] alien-callback ;
|
||||||
|
|
||||||
: callback-12-test ( x1 x2 callback -- result )
|
: callback-12-test ( x1 x2 callback -- result )
|
||||||
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
|
test_struct_15 { float float } "cdecl" alien-indirect ;
|
||||||
|
|
||||||
[ 1.0 2.0 ] [
|
[ 1.0 2.0 ] [
|
||||||
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
|
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
|
||||||
|
@ -533,7 +533,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
|
||||||
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
|
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
|
||||||
|
|
||||||
: callback-13 ( -- callback )
|
: callback-13 ( -- callback )
|
||||||
"test_struct_16" { "float" "int" } "cdecl"
|
test_struct_16 { float int } "cdecl"
|
||||||
[
|
[
|
||||||
test_struct_16 <struct>
|
test_struct_16 <struct>
|
||||||
swap >>a
|
swap >>a
|
||||||
|
@ -541,7 +541,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
|
||||||
] alien-callback ;
|
] alien-callback ;
|
||||||
|
|
||||||
: callback-13-test ( x1 x2 callback -- result )
|
: callback-13-test ( x1 x2 callback -- result )
|
||||||
"test_struct_16" { "float" "int" } "cdecl" alien-indirect ;
|
test_struct_16 { float int } "cdecl" alien-indirect ;
|
||||||
|
|
||||||
[ 1.0 2 ] [
|
[ 1.0 2 ] [
|
||||||
1.0 2 callback-13 callback-13-test
|
1.0 2 callback-13 callback-13-test
|
||||||
|
@ -588,5 +588,4 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
|
||||||
! Regression: calling an undefined function would raise a protection fault
|
! Regression: calling an undefined function would raise a protection fault
|
||||||
FUNCTION: void this_does_not_exist ( ) ;
|
FUNCTION: void this_does_not_exist ( ) ;
|
||||||
|
|
||||||
[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with
|
[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
|
||||||
|
|
||||||
|
|
|
@ -175,20 +175,6 @@ TUPLE: my-tuple ;
|
||||||
] compile-call
|
] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 1 t ] [
|
|
||||||
B{ 1 2 3 4 } [
|
|
||||||
{ c-ptr } declare
|
|
||||||
[ 0 alien-unsigned-1 ] keep hi-tag
|
|
||||||
] compile-call byte-array type-number =
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ t ] [
|
|
||||||
B{ 1 2 3 4 } [
|
|
||||||
{ c-ptr } declare
|
|
||||||
0 alien-cell hi-tag
|
|
||||||
] compile-call alien type-number =
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ 2 1 ] [
|
[ 2 1 ] [
|
||||||
2 1
|
2 1
|
||||||
[ 2dup fixnum< [ [ die ] dip ] when ] compile-call
|
[ 2dup fixnum< [ [ die ] dip ] when ] compile-call
|
||||||
|
@ -270,8 +256,8 @@ TUPLE: id obj ;
|
||||||
{ float } declare dup 0 =
|
{ float } declare dup 0 =
|
||||||
[ drop 1 ] [
|
[ drop 1 ] [
|
||||||
dup 0 >=
|
dup 0 >=
|
||||||
[ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
|
[ 2 double "libm" "pow" { double double } alien-invoke ]
|
||||||
[ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
|
[ -0.5 double "libm" "pow" { double double } alien-invoke ]
|
||||||
if
|
if
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
@ -475,4 +461,4 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
|
||||||
[ 2 0 ] [
|
[ 2 0 ] [
|
||||||
1 1
|
1 1
|
||||||
[ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
|
[ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -21,7 +21,6 @@ IN: compiler.tests.intrinsics
|
||||||
[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
|
[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
|
||||||
[ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
|
[ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
|
||||||
[ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
|
[ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
|
||||||
[ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test
|
|
||||||
[ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
|
[ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
|
||||||
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
|
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
|
||||||
[ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
|
[ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
|
||||||
|
@ -244,20 +243,20 @@ IN: compiler.tests.intrinsics
|
||||||
[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
|
[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
|
||||||
|
|
||||||
[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
|
[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
|
||||||
[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
|
[ HEX: 8000000 ] [ HEX: -8000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
|
||||||
[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
|
[ HEX: 8000000 ] [ HEX: -7ffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
|
||||||
|
|
||||||
[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
|
[ t ] [ 1 26 fixnum-shift dup [ fixnum+ ] compile-call 1 27 fixnum-shift = ] unit-test
|
||||||
[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
|
[ -134217729 ] [ 1 27 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
|
||||||
|
|
||||||
[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
|
[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
|
||||||
[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
|
[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
|
||||||
[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
|
[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
|
||||||
[ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
|
[ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
|
||||||
|
|
||||||
[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
|
[ 134217728 ] [ -134217728 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
|
||||||
|
|
||||||
[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
|
[ 134217728 0 ] [ -134217728 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
|
||||||
|
|
||||||
[ t ] [ f [ f eq? ] compile-call ] unit-test
|
[ t ] [ f [ f eq? ] compile-call ] unit-test
|
||||||
|
|
||||||
|
@ -285,8 +284,8 @@ cell 8 = [
|
||||||
|
|
||||||
! 64-bit overflow
|
! 64-bit overflow
|
||||||
cell 8 = [
|
cell 8 = [
|
||||||
[ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
|
[ t ] [ 1 58 fixnum-shift dup [ fixnum+ ] compile-call 1 59 fixnum-shift = ] unit-test
|
||||||
[ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
|
[ -576460752303423489 ] [ 1 59 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
|
||||||
|
|
||||||
[ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
|
[ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
|
||||||
[ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
|
[ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
|
||||||
|
@ -301,9 +300,9 @@ cell 8 = [
|
||||||
[ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
|
[ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
|
||||||
[ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
|
[ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
|
||||||
|
|
||||||
[ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
|
[ 576460752303423488 ] [ -576460752303423488 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
|
||||||
|
|
||||||
[ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
|
[ 576460752303423488 0 ] [ -576460752303423488 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
|
||||||
|
|
||||||
[ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
|
[ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
|
||||||
] when
|
] when
|
||||||
|
@ -311,12 +310,14 @@ cell 8 = [
|
||||||
! Some randomized tests
|
! Some randomized tests
|
||||||
: compiled-fixnum* ( a b -- c ) fixnum* ;
|
: compiled-fixnum* ( a b -- c ) fixnum* ;
|
||||||
|
|
||||||
|
ERROR: bug-in-fixnum* x y a b ;
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
10000 [
|
10000 [
|
||||||
32 random-bits >fixnum 32 random-bits >fixnum
|
32 random-bits >fixnum
|
||||||
2dup
|
32 random-bits >fixnum
|
||||||
[ fixnum* ] 2keep compiled-fixnum* =
|
2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
|
||||||
[ 2drop ] [ "Oops" throw ] if
|
[ 2drop 2drop ] [ bug-in-fixnum* ] if
|
||||||
] times
|
] times
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -419,7 +420,7 @@ cell 8 = [
|
||||||
"b" get [
|
"b" get [
|
||||||
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
|
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
|
||||||
[ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
|
[ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
|
||||||
[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
[ 3 ] [ "b" get 2 [ { alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
||||||
[ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
[ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
||||||
|
|
||||||
[ ] [ "b" get free ] unit-test
|
[ ] [ "b" get free ] unit-test
|
||||||
|
@ -584,16 +585,16 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
|
||||||
swap [
|
swap [
|
||||||
{ tuple } declare 1 slot
|
{ tuple } declare 1 slot
|
||||||
] [
|
] [
|
||||||
0 slot
|
1 slot
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
|
[ 0 ] [ f { } mutable-value-bug-1 ] unit-test
|
||||||
|
|
||||||
: mutable-value-bug-2 ( a b -- c )
|
: mutable-value-bug-2 ( a b -- c )
|
||||||
swap [
|
swap [
|
||||||
0 slot
|
1 slot
|
||||||
] [
|
] [
|
||||||
{ tuple } declare 1 slot
|
{ tuple } declare 1 slot
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test
|
[ 0 ] [ t { } mutable-value-bug-2 ] unit-test
|
||||||
|
|
|
@ -36,7 +36,7 @@ IN: compiler.tests.low-level-ir
|
||||||
! loading immediates
|
! loading immediates
|
||||||
[ f ] [
|
[ f ] [
|
||||||
V{
|
V{
|
||||||
T{ ##load-immediate f 0 5 }
|
T{ ##load-immediate f 0 $[ \ f type-number ] }
|
||||||
} compile-test-bb
|
} compile-test-bb
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -50,7 +50,7 @@ IN: compiler.tests.low-level-ir
|
||||||
! one of the sources
|
! one of the sources
|
||||||
[ t ] [
|
[ t ] [
|
||||||
V{
|
V{
|
||||||
T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
|
T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
|
||||||
T{ ##load-reference f 0 { t f t } }
|
T{ ##load-reference f 0 { t f t } }
|
||||||
T{ ##slot f 0 0 1 }
|
T{ ##slot f 0 0 1 }
|
||||||
} compile-test-bb
|
} compile-test-bb
|
||||||
|
@ -59,13 +59,13 @@ IN: compiler.tests.low-level-ir
|
||||||
[ t ] [
|
[ t ] [
|
||||||
V{
|
V{
|
||||||
T{ ##load-reference f 0 { t f t } }
|
T{ ##load-reference f 0 { t f t } }
|
||||||
T{ ##slot-imm f 0 0 2 $[ array tag-number ] }
|
T{ ##slot-imm f 0 0 2 $[ array type-number ] }
|
||||||
} compile-test-bb
|
} compile-test-bb
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
V{
|
V{
|
||||||
T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
|
T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
|
||||||
T{ ##load-reference f 0 { t f t } }
|
T{ ##load-reference f 0 { t f t } }
|
||||||
T{ ##set-slot f 0 0 1 }
|
T{ ##set-slot f 0 0 1 }
|
||||||
} compile-test-bb
|
} compile-test-bb
|
||||||
|
@ -75,12 +75,12 @@ IN: compiler.tests.low-level-ir
|
||||||
[ t ] [
|
[ t ] [
|
||||||
V{
|
V{
|
||||||
T{ ##load-reference f 0 { t f t } }
|
T{ ##load-reference f 0 { t f t } }
|
||||||
T{ ##set-slot-imm f 0 0 2 $[ array tag-number ] }
|
T{ ##set-slot-imm f 0 0 2 $[ array type-number ] }
|
||||||
} compile-test-bb
|
} compile-test-bb
|
||||||
dup first eq?
|
dup first eq?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 8 ] [
|
[ 4 ] [
|
||||||
V{
|
V{
|
||||||
T{ ##load-immediate f 0 4 }
|
T{ ##load-immediate f 0 4 }
|
||||||
T{ ##shl f 0 0 0 }
|
T{ ##shl f 0 0 0 }
|
||||||
|
@ -90,16 +90,16 @@ IN: compiler.tests.low-level-ir
|
||||||
[ 4 ] [
|
[ 4 ] [
|
||||||
V{
|
V{
|
||||||
T{ ##load-immediate f 0 4 }
|
T{ ##load-immediate f 0 4 }
|
||||||
T{ ##shl-imm f 0 0 3 }
|
T{ ##shl-imm f 0 0 4 }
|
||||||
} compile-test-bb
|
} compile-test-bb
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 31 ] [
|
[ 31 ] [
|
||||||
V{
|
V{
|
||||||
T{ ##load-reference f 1 B{ 31 67 52 } }
|
T{ ##load-reference f 1 B{ 31 67 52 } }
|
||||||
T{ ##unbox-any-c-ptr f 0 1 2 }
|
T{ ##unbox-any-c-ptr f 0 1 }
|
||||||
T{ ##alien-unsigned-1 f 0 0 0 }
|
T{ ##alien-unsigned-1 f 0 0 0 }
|
||||||
T{ ##shl-imm f 0 0 3 }
|
T{ ##shl-imm f 0 0 4 }
|
||||||
} compile-test-bb
|
} compile-test-bb
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -108,13 +108,13 @@ IN: compiler.tests.low-level-ir
|
||||||
T{ ##load-reference f 0 "hello world" }
|
T{ ##load-reference f 0 "hello world" }
|
||||||
T{ ##load-immediate f 1 3 }
|
T{ ##load-immediate f 1 3 }
|
||||||
T{ ##string-nth f 0 0 1 2 }
|
T{ ##string-nth f 0 0 1 2 }
|
||||||
T{ ##shl-imm f 0 0 3 }
|
T{ ##shl-imm f 0 0 4 }
|
||||||
} compile-test-bb
|
} compile-test-bb
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 1 ] [
|
[ 1 ] [
|
||||||
V{
|
V{
|
||||||
T{ ##load-immediate f 0 16 }
|
T{ ##load-immediate f 0 32 }
|
||||||
T{ ##add-imm f 0 0 -8 }
|
T{ ##add-imm f 0 0 -16 }
|
||||||
} compile-test-bb
|
} compile-test-bb
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -4,7 +4,7 @@ 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 definitions generic.single ;
|
compiler definitions generic.single shuffle ;
|
||||||
IN: compiler.tests.optimizer
|
IN: compiler.tests.optimizer
|
||||||
|
|
||||||
GENERIC: xyz ( obj -- obj )
|
GENERIC: xyz ( obj -- obj )
|
||||||
|
@ -202,7 +202,7 @@ USE: binary-search.private
|
||||||
dup length 1 <= [
|
dup length 1 <= [
|
||||||
from>>
|
from>>
|
||||||
] [
|
] [
|
||||||
[ midpoint swap call ] 3keep roll dup zero?
|
[ midpoint swap call ] 3keep [ rot ] dip swap dup zero?
|
||||||
[ drop dup from>> swap midpoint@ + ]
|
[ drop dup from>> swap midpoint@ + ]
|
||||||
[ drop dup midpoint@ head-slice old-binsearch ] if
|
[ drop dup midpoint@ head-slice old-binsearch ] if
|
||||||
] if ; inline recursive
|
] if ; inline recursive
|
||||||
|
@ -443,5 +443,7 @@ M: object bad-dispatch-position-test* ;
|
||||||
[ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test
|
[ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test
|
||||||
[ 12 ] [ 3 4 1 dispatch-branch-problem ] unit-test
|
[ 12 ] [ 3 4 1 dispatch-branch-problem ] unit-test
|
||||||
|
|
||||||
|
[ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test
|
||||||
|
|
||||||
! Not sure if I want to fix this...
|
! Not sure if I want to fix this...
|
||||||
! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
|
! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: accessors compiler compiler.units tools.test math parser
|
USING: accessors compiler compiler.units tools.test math parser
|
||||||
kernel sequences sequences.private classes.mixin generic
|
kernel sequences sequences.private classes.mixin generic
|
||||||
definitions arrays words assocs eval ;
|
definitions arrays words assocs eval grouping ;
|
||||||
IN: compiler.tests.redefine3
|
IN: compiler.tests.redefine3
|
||||||
|
|
||||||
GENERIC: sheeple ( obj -- x )
|
GENERIC: sheeple ( obj -- x )
|
||||||
|
@ -13,20 +13,23 @@ M: empty-mixin sheeple drop "wake up" ; inline
|
||||||
|
|
||||||
: sheeple-test ( -- string ) { } sheeple ;
|
: sheeple-test ( -- string ) { } sheeple ;
|
||||||
|
|
||||||
|
: compiled-use? ( key word -- ? )
|
||||||
|
"compiled-uses" word-prop 2 <groups> key? ;
|
||||||
|
|
||||||
[ "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-use? ] unit-test
|
||||||
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
|
[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ "wake up" ] [ sheeple-test ] unit-test
|
[ "wake up" ] [ sheeple-test ] unit-test
|
||||||
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
[ f ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
|
||||||
[ t ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
[ t ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
|
||||||
|
|
||||||
[ ] [ [ 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-use? ] unit-test
|
||||||
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
USING: compiler compiler.units tools.test kernel kernel.private
|
USING: compiler compiler.units tools.test kernel kernel.private
|
||||||
sequences.private math.private math combinators strings alien
|
sequences.private math.private math combinators strings alien
|
||||||
arrays memory vocabs parser eval ;
|
arrays memory vocabs parser eval quotations compiler.errors
|
||||||
|
definitions ;
|
||||||
IN: compiler.tests.simple
|
IN: compiler.tests.simple
|
||||||
|
|
||||||
! Test empty word
|
! Test empty word
|
||||||
|
@ -238,3 +239,13 @@ M: f single-combination-test-2 single-combination-test-4 ;
|
||||||
"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
|
||||||
|
|
||||||
|
! This should not compile
|
||||||
|
GENERIC: bad-effect-test ( a -- )
|
||||||
|
M: quotation bad-effect-test call ; inline
|
||||||
|
: bad-effect-test* ( -- ) [ 1 2 3 ] bad-effect-test ;
|
||||||
|
|
||||||
|
[ bad-effect-test* ] [ not-compiled? ] must-fail-with
|
||||||
|
|
||||||
|
! Don't want compiler error to stick around
|
||||||
|
[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test
|
||||||
|
|
|
@ -19,7 +19,7 @@ IN: compiler.tests.stack-trace
|
||||||
|
|
||||||
: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
|
: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
|
||||||
|
|
||||||
: stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ;
|
: stack-trace-any? ( word -- ? ) symbolic-stack-trace member-eq? ;
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
|
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
|
||||||
|
|
|
@ -39,7 +39,7 @@ M: word (build-tree)
|
||||||
[
|
[
|
||||||
<recursive-state> recursive-state set
|
<recursive-state> recursive-state set
|
||||||
V{ } clone stack-visitor set
|
V{ } clone stack-visitor set
|
||||||
[ [ >vector \ meta-d set ] [ length d-in set ] bi ]
|
[ [ >vector \ meta-d set ] [ length input-count set ] bi ]
|
||||||
[ (build-tree) ]
|
[ (build-tree) ]
|
||||||
bi*
|
bi*
|
||||||
] with-infer nip ;
|
] with-infer nip ;
|
||||||
|
|
|
@ -491,7 +491,7 @@ cell-bits 32 = [
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ { array } declare 2 <groups> [ . . ] assoc-each ]
|
[ { array } declare 2 <sliced-groups> [ . . ] assoc-each ]
|
||||||
\ nth-unsafe inlined?
|
\ nth-unsafe inlined?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: kernel accessors sequences combinators fry
|
USING: kernel accessors sequences combinators fry
|
||||||
classes.algebra namespaces assocs words math math.private
|
classes.algebra namespaces assocs words math math.private
|
||||||
math.partial-dispatch math.intervals classes classes.tuple
|
math.partial-dispatch math.intervals classes classes.tuple
|
||||||
classes.tuple.private layouts definitions stack-checker.state
|
classes.tuple.private layouts definitions stack-checker.dependencies
|
||||||
stack-checker.branches
|
stack-checker.branches
|
||||||
compiler.utilities
|
compiler.utilities
|
||||||
compiler.tree
|
compiler.tree
|
||||||
|
@ -20,7 +20,7 @@ IN: compiler.tree.cleanup
|
||||||
GENERIC: delete-node ( node -- )
|
GENERIC: delete-node ( node -- )
|
||||||
|
|
||||||
M: #call-recursive delete-node
|
M: #call-recursive delete-node
|
||||||
dup label>> calls>> [ node>> eq? not ] with filter-here ;
|
dup label>> calls>> [ node>> eq? not ] with filter! drop ;
|
||||||
|
|
||||||
M: #return-recursive delete-node
|
M: #return-recursive delete-node
|
||||||
label>> f >>return drop ;
|
label>> f >>return drop ;
|
||||||
|
|
|
@ -6,7 +6,7 @@ compiler.tree.tuple-unboxing compiler.tree.debugger
|
||||||
compiler.tree.recursive compiler.tree.normalization
|
compiler.tree.recursive compiler.tree.normalization
|
||||||
compiler.tree.checker tools.test kernel math stack-checker.state
|
compiler.tree.checker tools.test kernel math stack-checker.state
|
||||||
accessors combinators io prettyprint words sequences.deep
|
accessors combinators io prettyprint words sequences.deep
|
||||||
sequences.private arrays classes kernel.private ;
|
sequences.private arrays classes kernel.private shuffle ;
|
||||||
IN: compiler.tree.dead-code.tests
|
IN: compiler.tree.dead-code.tests
|
||||||
|
|
||||||
: count-live-values ( quot -- n )
|
: count-live-values ( quot -- n )
|
||||||
|
|
|
@ -39,14 +39,13 @@ M: #enter-recursive remove-dead-code*
|
||||||
2bi ;
|
2bi ;
|
||||||
|
|
||||||
:: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
|
:: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
|
||||||
[let* | new-live-outputs [ inputs outputs filter-corresponding make-values ]
|
inputs outputs filter-corresponding make-values :> new-live-outputs
|
||||||
live-outputs [ outputs filter-live ] |
|
outputs filter-live :> live-outputs
|
||||||
new-live-outputs
|
new-live-outputs
|
||||||
live-outputs
|
live-outputs
|
||||||
live-outputs
|
live-outputs
|
||||||
new-live-outputs
|
new-live-outputs
|
||||||
drop-values
|
drop-values ;
|
||||||
] ;
|
|
||||||
|
|
||||||
: drop-call-recursive-outputs ( node -- #shuffle )
|
: drop-call-recursive-outputs ( node -- #shuffle )
|
||||||
dup [ label>> return>> in-d>> ] [ out-d>> ] bi
|
dup [ label>> return>> in-d>> ] [ out-d>> ] bi
|
||||||
|
@ -60,22 +59,20 @@ M: #call-recursive remove-dead-code*
|
||||||
tri 3array ;
|
tri 3array ;
|
||||||
|
|
||||||
:: drop-recursive-inputs ( node -- shuffle )
|
:: drop-recursive-inputs ( node -- shuffle )
|
||||||
[let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
|
node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs :> shuffle
|
||||||
new-outputs [ shuffle out-d>> ] |
|
shuffle out-d>> :> new-outputs
|
||||||
node new-outputs
|
node new-outputs
|
||||||
[ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
|
[ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
|
||||||
shuffle
|
shuffle ;
|
||||||
] ;
|
|
||||||
|
|
||||||
:: drop-recursive-outputs ( node -- shuffle )
|
:: drop-recursive-outputs ( node -- shuffle )
|
||||||
[let* | return [ node label>> return>> ]
|
node label>> return>> :> return
|
||||||
new-inputs [ return in-d>> filter-live ]
|
return in-d>> filter-live :> new-inputs
|
||||||
new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
|
return [ in-d>> ] [ out-d>> ] bi filter-corresponding :> new-outputs
|
||||||
return
|
return
|
||||||
[ new-inputs >>in-d new-outputs >>out-d drop ]
|
[ new-inputs >>in-d new-outputs >>out-d drop ]
|
||||||
[ drop-dead-outputs ]
|
[ drop-dead-outputs ]
|
||||||
bi
|
bi ;
|
||||||
] ;
|
|
||||||
|
|
||||||
M: #recursive remove-dead-code* ( node -- nodes )
|
M: #recursive remove-dead-code* ( node -- nodes )
|
||||||
[ drop-recursive-inputs ]
|
[ drop-recursive-inputs ]
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel accessors words assocs sequences arrays namespaces
|
USING: kernel accessors words assocs sequences arrays namespaces
|
||||||
fry locals definitions classes classes.algebra generic
|
fry locals definitions classes classes.algebra generic
|
||||||
stack-checker.state
|
stack-checker.dependencies
|
||||||
stack-checker.backend
|
stack-checker.backend
|
||||||
compiler.tree
|
compiler.tree
|
||||||
compiler.tree.propagation.info
|
compiler.tree.propagation.info
|
||||||
|
@ -71,14 +71,13 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
|
||||||
filter-corresponding zip #data-shuffle ; inline
|
filter-corresponding zip #data-shuffle ; inline
|
||||||
|
|
||||||
:: drop-dead-values ( outputs -- #shuffle )
|
:: drop-dead-values ( outputs -- #shuffle )
|
||||||
[let* | new-outputs [ outputs make-values ]
|
outputs make-values :> new-outputs
|
||||||
live-outputs [ outputs filter-live ] |
|
outputs filter-live :> live-outputs
|
||||||
new-outputs
|
new-outputs
|
||||||
live-outputs
|
live-outputs
|
||||||
outputs
|
outputs
|
||||||
new-outputs
|
new-outputs
|
||||||
drop-values
|
drop-values ;
|
||||||
] ;
|
|
||||||
|
|
||||||
: drop-dead-outputs ( node -- #shuffle )
|
: drop-dead-outputs ( node -- #shuffle )
|
||||||
dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
|
dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
|
||||||
|
|
|
@ -51,7 +51,6 @@ MATCH-VARS: ?a ?b ?c ;
|
||||||
{ { { ?b ?a } { ?a ?b } } [ swap ] }
|
{ { { ?b ?a } { ?a ?b } } [ swap ] }
|
||||||
{ { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
|
{ { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
|
||||||
{ { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
|
{ { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
|
||||||
{ { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
|
|
||||||
{ { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
|
{ { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
|
||||||
{ { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
|
{ { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
|
||||||
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
|
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
|
||||||
|
|
|
@ -75,7 +75,7 @@ M: #push compute-modular-candidates*
|
||||||
0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ;
|
0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ;
|
||||||
|
|
||||||
: modular-word? ( #call -- ? )
|
: modular-word? ( #call -- ? )
|
||||||
dup word>> { shift fixnum-shift bignum-shift } memq?
|
dup word>> { shift fixnum-shift bignum-shift } member-eq?
|
||||||
[ node-input-infos second interval>> small-shift? ]
|
[ node-input-infos second interval>> small-shift? ]
|
||||||
[ word>> "modular-arithmetic" word-prop ]
|
[ word>> "modular-arithmetic" word-prop ]
|
||||||
if ;
|
if ;
|
||||||
|
@ -178,10 +178,10 @@ MEMO: fixnum-coercion ( flags -- nodes )
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: like->fixnum? ( #call -- ? )
|
: like->fixnum? ( #call -- ? )
|
||||||
word>> { >fixnum bignum>fixnum float>fixnum } memq? ;
|
word>> { >fixnum bignum>fixnum float>fixnum } member-eq? ;
|
||||||
|
|
||||||
: like->integer? ( #call -- ? )
|
: like->integer? ( #call -- ? )
|
||||||
word>> { >integer >bignum fixnum>bignum } memq? ;
|
word>> { >integer >bignum fixnum>bignum } member-eq? ;
|
||||||
|
|
||||||
M: #call optimize-modular-arithmetic*
|
M: #call optimize-modular-arithmetic*
|
||||||
{
|
{
|
||||||
|
|
|
@ -97,7 +97,7 @@ M: #phi propagate-before ( #phi -- )
|
||||||
constraints get last update-constraints ;
|
constraints get last update-constraints ;
|
||||||
|
|
||||||
: branch-phi-constraints ( output values booleans -- )
|
: branch-phi-constraints ( output values booleans -- )
|
||||||
{
|
{
|
||||||
{
|
{
|
||||||
{ { t } { f } }
|
{ { t } { f } }
|
||||||
[
|
[
|
||||||
|
@ -130,6 +130,22 @@ M: #phi propagate-before ( #phi -- )
|
||||||
swap t-->
|
swap t-->
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
{
|
||||||
|
{ { t f } { t } }
|
||||||
|
[
|
||||||
|
first =f
|
||||||
|
condition-value get =t /\
|
||||||
|
swap f-->
|
||||||
|
]
|
||||||
|
}
|
||||||
|
{
|
||||||
|
{ { t } { t f } }
|
||||||
|
[
|
||||||
|
second =f
|
||||||
|
condition-value get =f /\
|
||||||
|
swap f-->
|
||||||
|
]
|
||||||
|
}
|
||||||
{
|
{
|
||||||
{ { t f } { } }
|
{ { t f } { } }
|
||||||
[
|
[
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
|
! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel
|
USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel
|
||||||
compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ;
|
compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences
|
||||||
|
eval combinators ;
|
||||||
IN: compiler.tree.propagation.call-effect.tests
|
IN: compiler.tree.propagation.call-effect.tests
|
||||||
|
|
||||||
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
|
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
|
||||||
|
@ -58,4 +59,23 @@ IN: compiler.tree.propagation.call-effect.tests
|
||||||
! [ boa ] by itself doesn't infer
|
! [ boa ] by itself doesn't infer
|
||||||
TUPLE: a-tuple x ;
|
TUPLE: a-tuple x ;
|
||||||
|
|
||||||
[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
|
[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
|
||||||
|
|
||||||
|
! See if redefinitions are handled correctly
|
||||||
|
: call(-redefine-test ( a -- b ) 1 + ;
|
||||||
|
|
||||||
|
: test-quotatation ( -- quot ) [ call(-redefine-test ] ;
|
||||||
|
|
||||||
|
[ t ] [ test-quotatation cached-effect (( a -- b )) effect<= ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a b -- c ) + ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ test-quotatation cached-effect (( a b -- c )) effect<= ] unit-test
|
||||||
|
|
||||||
|
: inline-cache-invalidation-test ( a b c -- c ) call( a b -- c ) ;
|
||||||
|
|
||||||
|
[ 4 ] [ 1 3 test-quotatation inline-cache-invalidation-test ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
|
[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue