Merge branch 'master' into startup

Conflicts:
	core/bootstrap/primitives.factor
	vm/run.hpp
db4
Doug Coleman 2009-11-15 02:52:50 -06:00
commit cc194416f9
1229 changed files with 14931 additions and 8413 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

View File

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

View File

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

41
basis/compiler/tests/intrinsics.factor Normal file → Executable file
View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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