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

Merge branch 'master' of git://github.com/slavapestov/factor

db4
Anton Gorenko 2010-05-23 09:58:35 +06:00
parent 83819c9902 6fb91a042e
commit f44bc6f056
227 changed files with 6086 additions and 3143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
basis/alarms/alarms-docs.factor
View File

@ -2,46 +2,45 @@ USING: help.markup help.syntax calendar quotations system ;
IN: alarms
HELP: alarm
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
{ $class-description "An alarm. Can be passed to " { $link stop-alarm } "." } ;
HELP: current-alarm
{ $description "A symbol that contains the currently executing alarm, availble only to the alarm quotation. One use for this symbol is if a repeated alarm wishes to cancel itself from executing in the future."
}
{ $examples
{ $unchecked-example
"""USING: alarms calendar io threads ;"""
"""["""
""" "Hi, this should only get printed once..." print flush"""
""" current-alarm get cancel-alarm"""
"""] 1 seconds every"""
""
}
} ;
HELP: add-alarm
{ $values { "quot" quotation } { "start" duration } { "interval" { $maybe "duration/f" } } { "alarm" alarm } }
{ $description "Creates and registers an alarm to start at " { $snippet "start" } " offset from the current time. If " { $snippet "interval" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency, with scheduling happening before the quotation is called in order to ensure that the next event will happen on time. The quotation will be called from a new thread spawned by the alarm thread. If a repeated alarm's quotation throws an exception, the alarm will not be rescheduled." } ;
HELP: later
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "duration" } " offset from now." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
"""[ "Break's over!" print flush ] 15 minutes drop"""
""
}
} ;
HELP: cancel-alarm
HELP: start-alarm
{ $values { "alarm" alarm } }
{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
{ $description "Starts an alarm." } ;
HELP: stop-alarm
{ $values { "alarm" alarm } }
{ $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ;
HELP: every
{ $values
{ "quot" quotation } { "interval-duration" duration }
{ "alarm" alarm } }
{ $description "Creates an alarm that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the alarm will stop." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
"""[ "Hi Buddy." print flush ] 10 seconds every drop"""
""
}
} ;
HELP: later
{ $values { "quot" quotation } { "delay-duration" duration } { "alarm" alarm } }
{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the alarm before " { $snippet "quot" } " runs. This alarm is not repeated." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
"""[ "Break's over!" print flush ] 15 minutes later drop"""
""
}
} ;
HELP: delayed-every
{ $values
{ "quot" quotation } { "duration" duration }
{ "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency. If the quotation throws an exception that is not caught inside it, the alarm scheduler will cancel the alarm and will not reschedule it again." }
{ $description "Creates an alarm that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the alarm will stop." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
@ -51,19 +50,21 @@ HELP: every
} ;
ARTICLE: "alarms" "Alarms"
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread. Alarms use " { $link nano-count } ", so they continue to work across system clock changes." $nl
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per alarm and consist of a quotation, a delay duration, and an interval duration. After starting an alarm, the alarm thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the alarm. If a recurring alarm's quotation would be scheduled to run again before the previous quotation has finished processing, the alarm will be run again immediately afterwards. This may result in the alarm falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring alarms that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the alarm from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl
"The alarm class:"
{ $subsections alarm }
"Register a recurring alarm:"
"Create an alarm before starting it:"
{ $subsections <alarm> }
"Starting an alarm:"
{ $subsections start-alarm }
"Stopping an alarm:"
{ $subsections stop-alarm }
"A recurring alarm without an initial delay:"
{ $subsections every }
"Register a one-time alarm:"
"A one-time alarm with an initial delay:"
{ $subsections later }
"The currently executing alarm:"
{ $subsections current-alarm }
"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." ;
"A recurring alarm with an initial delay:"
{ $subsections delayed-every } ;
ABOUT: "alarms"

22
basis/alarms/alarms-tests.factor
View File

@ -1,11 +1,12 @@
USING: alarms alarms.private kernel calendar sequences
tools.test threads concurrency.count-downs ;
USING: alarms alarms.private calendar concurrency.count-downs
concurrency.promises fry kernel math math.order sequences
threads tools.test tools.time ;
IN: alarms.tests
[ ] [
1 <count-down>
{ f } clone 2dup
[ first cancel-alarm count-down ] 2curry 1 seconds later
[ first stop-alarm count-down ] 2curry 1 seconds later
swap set-first
await
] unit-test
@ -14,3 +15,18 @@ IN: alarms.tests
self [ resume ] curry instant later drop
"test" suspend drop
] unit-test
[ t ] [
[
<promise>
[ '[ t _ fulfill ] 2 seconds later drop ]
[ 5 seconds ?promise-timeout drop ] bi
] benchmark 1,500,000,000 2,500,000,000 between?
] unit-test
[ { 3 } ] [
{ 3 } dup
'[ 4 _ set-first ] 2 seconds later
1/2 seconds sleep
stop-alarm
] unit-test

141
basis/alarms/alarms.factor
View File

@ -1,104 +1,89 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs boxes calendar combinators.short-circuit
continuations fry heaps init kernel math.order
namespaces quotations threads math system ;
USING: accessors assocs calendar combinators.short-circuit fry
heaps init kernel math math.functions math.parser namespaces
quotations sequences system threads ;
IN: alarms
TUPLE: alarm
{ quot callable initial: [ ] }
{ start integer }
interval
{ entry box } ;
SYMBOL: alarms
SYMBOL: alarm-thread
SYMBOL: current-alarm
: cancel-alarm ( alarm -- )
entry>> [ alarms get-global heap-delete ] if-box? ;
start-nanos
delay-nanos
interval-nanos integer
{ next-iteration-nanos integer }
{ stop? boolean } ;
<PRIVATE
: notify-alarm-thread ( -- )
alarm-thread get-global interrupt ;
GENERIC: >nanoseconds ( obj -- duration/f )
M: f >nanoseconds ;
M: real >nanoseconds >integer ;
M: duration >nanoseconds duration>nanoseconds >integer ;
: <alarm> ( quot start interval -- alarm )
alarm new
swap >nanoseconds >>interval
swap >nanoseconds nano-count + >>start
swap >>quot
<box> >>entry ;
: set-next-alarm-time ( alarm -- alarm )
! start + delay + ceiling((now - start) / interval) * interval
nano-count
over start-nanos>> -
over delay-nanos>> [ + ] when*
over interval-nanos>> / ceiling
over interval-nanos>> *
over start-nanos>> + >>next-iteration-nanos ; inline
: register-alarm ( alarm -- )
[ dup start>> alarms get-global heap-push* ]
[ entry>> >box ] bi
notify-alarm-thread ;
DEFER: call-alarm-loop
: alarm-expired? ( alarm n -- ? )
[ start>> ] dip <= ;
: loop-alarm ( alarm -- )
nano-count over
[ next-iteration-nanos>> - ] [ interval-nanos>> ] bi <
[ set-next-alarm-time ] dip
[ dup next-iteration-nanos>> ] [ 0 ] if
sleep-until call-alarm-loop ;
: reschedule-alarm ( alarm -- )
dup interval>> nano-count + >>start register-alarm ;
: maybe-loop-alarm ( alarm -- )
dup { [ stop?>> ] [ interval-nanos>> not ] } 1||
[ drop ] [ loop-alarm ] if ;
: call-alarm ( alarm -- )
[ entry>> box> drop ]
[ dup interval>> [ reschedule-alarm ] [ drop ] if ]
[
[ ] [ quot>> ] [ ] tri
'[
_ current-alarm
[
_ [ _ dup interval>> [ cancel-alarm ] [ drop ] if rethrow ]
recover
] with-variable
] "Alarm execution" spawn drop
] tri ;
: (trigger-alarms) ( alarms n -- )
over heap-empty? [
2drop
: call-alarm-loop ( alarm -- )
dup stop?>> [
drop
] [
over heap-peek drop over alarm-expired? [
over heap-pop drop call-alarm (trigger-alarms)
] [
2drop
] if
[ quot>> call( -- ) ] keep
maybe-loop-alarm
] if ;
: trigger-alarms ( alarms -- )
nano-count (trigger-alarms) ;
: next-alarm ( alarms -- nanos/f )
dup heap-empty? [ drop f ] [ heap-peek drop start>> ] if ;
: alarm-thread-loop ( -- )
alarms get-global
dup next-alarm sleep-until
trigger-alarms ;
: cancel-alarms ( alarms -- )
[
heap-pop-all [ nip entry>> box> drop ] assoc-each
] when* ;
: init-alarms ( -- )
alarms [ cancel-alarms <min-heap> ] change-global
[ alarm-thread-loop t ] "Alarms" spawn-server
alarm-thread set-global ;
[ init-alarms ] "alarms" add-startup-hook
: call-alarm ( alarm -- )
[ delay-nanos>> ] [ ] bi
'[ _ [ sleep ] when* _ call-alarm-loop ] "Alarm execution" spawn drop ;
PRIVATE>
: add-alarm ( quot start interval -- alarm )
<alarm> [ register-alarm ] keep ;
: <alarm> ( quot delay-duration/f interval-duration/f -- alarm )
alarm new
swap >nanoseconds >>interval-nanos
swap >nanoseconds >>delay-nanos
swap >>quot ; inline
: later ( quot duration -- alarm ) f add-alarm ;
: start-alarm ( alarm -- )
f >>stop?
nano-count >>start-nanos
call-alarm ;
: every ( quot duration -- alarm ) dup add-alarm ;
: stop-alarm ( alarm -- )
t >>stop?
f >>start-nanos
drop ;
<PRIVATE
: (start-alarm) ( quot start-duration interval-duration -- alarm )
<alarm> [ start-alarm ] keep ;
PRIVATE>
: every ( quot interval-duration -- alarm )
[ f ] dip (start-alarm) ;
: later ( quot delay-duration -- alarm )
f (start-alarm) ;
: delayed-every ( quot duration -- alarm )
dup (start-alarm) ;

4
basis/alien/arrays/arrays.factor
View File

@ -24,8 +24,6 @@ M: array c-type-align-first first c-type-align-first ;
M: array base-type drop void* base-type ;
M: array stack-size drop void* stack-size ;
PREDICATE: string-type < pair
first2 [ c-string = ] [ word? ] bi* and ;
@ -43,8 +41,6 @@ M: string-type c-type-align-first drop void* c-type-align-first ;
M: string-type base-type drop void* base-type ;
M: string-type stack-size drop void* stack-size ;
M: string-type c-type-rep drop int-rep ;
M: string-type c-type-boxer-quot

27
basis/alien/c-types/c-types-docs.factor
View File

@ -1,47 +1,42 @@
USING: alien alien.complex help.syntax help.markup libc kernel.private
byte-arrays strings hashtables alien.syntax alien.strings sequences
io.encodings.string debugger destructors vocabs.loader
classes.struct ;
classes.struct math kernel ;
QUALIFIED: math
QUALIFIED: sequences
IN: alien.c-types
HELP: heap-size
{ $values { "name" "a C type name" } { "size" math:integer } }
{ $values { "name" c-type-name } { "size" math:integer } }
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
{ $examples
{ $example "USING: alien alien.c-types prettyprint ;\nint heap-size ." "4" }
}
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: stack-size
{ $values { "name" "a C type name" } { "size" math:integer } }
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: <c-type>
{ $values { "c-type" c-type } }
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
HELP: no-c-type
{ $values { "name" "a C type name" } }
{ $values { "name" c-type-name } }
{ $description "Throws a " { $link no-c-type } " error." }
{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
HELP: c-type
{ $values { "name" "a C type" } { "c-type" c-type } }
{ $values { "name" c-type-name } { "c-type" c-type } }
{ $description "Looks up a C type by name." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist, or the word is not a C type." } ;
HELP: c-getter
{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
HELP: alien-value
{ $values { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } { "value" object } }
{ $description "Loads a value at a byte offset from a base C pointer." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-setter
{ $values { "name" "a C type" } { "quot" { $quotation "( obj c-ptr n -- )" } } }
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
{ $errors "Throws an error if the type does not exist." } ;
HELP: set-alien-value
{ $values { "value" object } { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } }
{ $description "Stores a value at a byte offset from a base C pointer." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: define-deref
{ $values { "c-type" "a C type" } }

60
basis/alien/c-types/c-types.factor
View File

@ -6,7 +6,7 @@ words splitting cpu.architecture alien alien.accessors
alien.strings quotations layouts system compiler.units io
io.files io.encodings.binary io.streams.memory accessors
combinators effects continuations fry classes vocabs
vocabs.loader words.symbol ;
vocabs.loader words.symbol macros ;
QUALIFIED: math
IN: alien.c-types
@ -17,8 +17,7 @@ SYMBOLS:
long ulong
longlong ulonglong
float double
void* bool
(stack-value) ;
void* bool ;
SINGLETON: void
@ -94,7 +93,7 @@ GENERIC: c-type-setter ( name -- quot )
M: c-type c-type-setter setter>> ;
GENERIC: c-type-align ( name -- n )
GENERIC: c-type-align ( name -- n ) foldable
M: abstract-c-type c-type-align align>> ;
@ -114,24 +113,24 @@ GENERIC: heap-size ( name -- size )
M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( name -- size )
M: c-type stack-size size>> cell align ;
MIXIN: value-type
: c-getter ( name -- quot )
MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
[ c-type-getter ] [ c-type-boxer-quot ] bi append ;
: c-setter ( name -- quot )
MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
[ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
[ c-type-setter ]
bi append ;
: array-accessor ( c-type quot -- def )
[
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make ;
: array-accessor ( n c-ptr c-type -- c-ptr offset c-type )
[ swapd heap-size * >fixnum ] keep ; inline
: alien-element ( n c-ptr c-type -- value )
array-accessor alien-value ; inline
: set-alien-element ( value n c-ptr c-type -- )
array-accessor set-alien-value ; inline
PROTOCOL: c-type-protocol
c-type-class
@ -144,8 +143,7 @@ PROTOCOL: c-type-protocol
c-type-align
c-type-align-first
base-type
heap-size
stack-size ;
heap-size ;
CONSULT: c-type-protocol c-type-name
c-type ;
@ -165,12 +163,13 @@ TUPLE: long-long-type < c-type ;
long-long-type new ;
: define-deref ( c-type -- )
[ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
(( c-ptr -- value )) define-inline ;
[ name>> CHAR: * prefix "alien.c-types" create ]
[ '[ 0 _ alien-value ] ]
bi (( c-ptr -- value )) define-inline ;
: define-out ( c-type -- )
[ name>> "alien.c-types" constructor-word ]
[ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
[ dup '[ _ heap-size (byte-array) [ 0 _ set-alien-value ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
: define-primitive-type ( c-type name -- )
@ -195,15 +194,19 @@ CONSTANT: primitive-types
c-string
}
: (pointer-c-type) ( void* type -- void*' )
[ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
: >c-bool ( ? -- int ) 1 0 ? ; inline
: c-bool> ( int -- ? ) 0 = not ; inline
<PRIVATE
: 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 ;
: resolve-pointer-typedef ( type -- base-type )
dup "c-type" word-prop dup word?
[ nip resolve-pointer-typedef ] [
@ -215,19 +218,15 @@ CONSTANT: primitive-types
resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
] [ drop t ] if ;
: (pointer-c-type) ( void* type -- void*' )
[ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
PRIVATE>
M: pointer c-type
[ \ void* c-type ] dip
to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
: 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-ptr >>class
@ -448,9 +447,6 @@ M: pointer c-type
object >>boxed-class
\ bool define-primitive-type
\ void* c-type clone stack-params >>rep
\ (stack-value) define-primitive-type
] with-compilation-unit
M: char-16-rep rep-component-type drop char ;

34
basis/alien/data/data.factor
View File

@ -1,7 +1,8 @@
! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.arrays alien.strings
arrays byte-arrays cpu.architecture fry io io.encodings.binary
io.files io.streams.memory kernel libc math sequences words ;
io.files io.streams.memory kernel libc math sequences words
macros combinators generalizations ;
IN: alien.data
GENERIC: require-c-array ( c-type -- )
@ -74,3 +75,34 @@ M: array c-type-boxer-quot
unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
ERROR: local-allocation-error ;
<PRIVATE
: (local-allot) ( size align -- alien ) local-allocation-error ;
: (cleanup-allot) ( -- )
! Inhibit TCO in order for the last word in the quotation
! to still be abl to access scope-allocated data.
;
MACRO: (local-allots) ( c-types -- quot )
[ '[ _ [ heap-size ] [ c-type-align ] bi (local-allot) ] ] map [ ] join ;
MACRO: box-values ( c-types -- quot )
[ c-type-boxer-quot ] map '[ _ spread ] ;
MACRO: out-parameters ( c-types -- quot )
[ length ] [ [ '[ 0 _ alien-value ] ] map ] bi
'[ _ nkeep _ spread ] ;
PRIVATE>
: with-scoped-allocation ( c-types quot -- )
[ [ (local-allots) ] [ box-values ] bi ] dip call
(cleanup-allot) ; inline
: with-out-parameters ( c-types quot finish -- values )
[ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call
(cleanup-allot) ; inline

15
basis/alien/fortran/fortran.factor
View File

@ -1,11 +1,12 @@
! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex alien.data alien.parser
grouping alien.strings alien.syntax arrays ascii assocs
byte-arrays combinators combinators.short-circuit fry generalizations
kernel lexer macros math math.parser namespaces parser sequences
splitting stack-checker vectors vocabs.parser words locals
io.encodings.ascii io.encodings.string shuffle effects math.ranges
math.order sorting strings system alien.libraries ;
USING: accessors alien alien.c-types alien.complex alien.data
alien.parser grouping alien.strings alien.syntax arrays ascii
assocs byte-arrays combinators combinators.short-circuit fry
generalizations kernel lexer macros math math.parser namespaces
parser sequences sequences.generalizations splitting
stack-checker vectors vocabs.parser words locals
io.encodings.ascii io.encodings.string shuffle effects
math.ranges math.order sorting strings system alien.libraries ;
QUALIFIED-WITH: alien.c-types c
IN: alien.fortran

5
basis/alien/libraries/libraries.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.strings assocs io.backend
kernel namespaces destructors sequences system io.pathnames ;
kernel namespaces destructors sequences strings
system io.pathnames ;
IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
@ -12,7 +13,7 @@ SYMBOL: libraries
libraries [ H{ } clone ] initialize
TUPLE: library path abi dll ;
TUPLE: library { path string } { abi abi initial: cdecl } dll ;
ERROR: no-library name ;

4
basis/alien/parser/parser.factor
View File

@ -168,8 +168,8 @@ PREDICATE: alien-callback-type-word < typedef-word
"callback-effect" word-prop ;
: global-quot ( type word -- quot )
name>> current-library get '[ _ _ address-of 0 ]
swap c-getter append ;
swap [ name>> current-library get ] dip
'[ _ _ address-of 0 _ alien-value ] ;
: define-global ( type word -- )
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;

4
basis/bootstrap/compiler/timing/timing.factor
View File

@ -8,6 +8,8 @@ QUALIFIED: compiler.cfg.finalization
QUALIFIED: compiler.codegen
QUALIFIED: compiler.tree.builder
QUALIFIED: compiler.tree.optimizer
QUALIFIED: compiler.cfg.liveness
QUALIFIED: compiler.cfg.liveness.ssa
IN: bootstrap.compiler.timing
: passes ( word -- seq )
@ -33,6 +35,8 @@ IN: bootstrap.compiler.timing
machine-passes %
linear-scan-passes %
\ compiler.codegen:generate ,
\ compiler.cfg.liveness:compute-live-sets ,
\ compiler.cfg.liveness.ssa:compute-ssa-live-sets ,
] { } make ;
all-passes [ [ reset ] [ add-timing ] bi ] each

10
basis/bootstrap/image/image.factor
View File

@ -3,11 +3,11 @@
USING: alien alien.strings arrays byte-arrays generic hashtables
hashtables.private io io.binary io.files io.encodings.binary
io.pathnames kernel kernel.private math namespaces make parser
prettyprint sequences strings sbufs vectors words quotations
assocs system layouts splitting grouping growable classes
classes.private classes.builtin classes.tuple
classes.tuple.private vocabs vocabs.loader source-files
definitions debugger quotations.private combinators
prettyprint sequences sequences.generalizations strings sbufs
vectors words quotations assocs system layouts splitting
grouping growable classes classes.private classes.builtin
classes.tuple classes.tuple.private vocabs vocabs.loader
source-files definitions debugger quotations.private combinators
combinators.short-circuit math.order math.private accessors
slots.private generic.single.private compiler.units
compiler.constants fry locals bootstrap.image.syntax

8
basis/checksums/md5/md5.factor
View File

@ -182,10 +182,10 @@ HINTS: (process-md5-block-I) { uint-array md5-state } ;
] each
] unless ;
: byte-array>uint-array-le ( byte-array -- uint-array )
byte-array>le byte-array>uint-array ;
: uint-array-cast-le ( byte-array -- uint-array )
byte-array>le uint-array-cast ;
HINTS: byte-array>uint-array-le byte-array ;
HINTS: uint-array-cast-le byte-array ;
: uint-array>byte-array-le ( uint-array -- byte-array )
underlying>> byte-array>le ;
@ -194,7 +194,7 @@ HINTS: uint-array>byte-array-le uint-array ;
M: md5-state checksum-block ( block state -- )
[
[ byte-array>uint-array-le ] [ state>> ] bi* {
[ uint-array-cast-le ] [ state>> ] bi* {
[ (process-md5-block-F) ]
[ (process-md5-block-G) ]
[ (process-md5-block-H) ]

2
basis/checksums/sha/sha.factor
View File

@ -4,7 +4,7 @@ USING: accessors checksums checksums.common checksums.stream
combinators combinators.smart fry generalizations grouping
io.binary kernel literals locals make math math.bitwise
math.ranges multiline namespaces sbufs sequences
sequences.private splitting strings ;
sequences.generalizations sequences.private splitting strings ;
IN: checksums.sha
SINGLETON: sha1

17
basis/classes/struct/struct.factor
View File

@ -101,8 +101,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
GENERIC: (reader-quot) ( slot -- quot )
M: struct-slot-spec (reader-quot)
[ type>> c-getter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
[ offset>> ] [ type>> ] bi '[ >c-ptr _ _ alien-value ] ;
M: struct-bit-slot-spec (reader-quot)
[ [ offset>> ] [ bits>> ] bi bit-reader ]
@ -113,12 +112,10 @@ M: struct-bit-slot-spec (reader-quot)
GENERIC: (writer-quot) ( slot -- quot )
M: struct-slot-spec (writer-quot)
[ type>> c-setter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
[ offset>> ] [ type>> ] bi '[ >c-ptr _ _ set-alien-value ] ;
M: struct-bit-slot-spec (writer-quot)
[ offset>> ] [ bits>> ] bi bit-writer
[ >c-ptr ] prepose ;
[ offset>> ] [ bits>> ] bi bit-writer [ >c-ptr ] prepose ;
: (boxer-quot) ( class -- quot )
'[ _ memory>struct ] ;
@ -168,14 +165,6 @@ M: struct-c-type c-type ;
M: struct-c-type base-type ;
M: struct-c-type stack-size
dup value-struct? [ heap-size cell align ] [ drop cell ] if ;
HOOK: flatten-struct-type cpu ( type -- pairs )
M: object flatten-struct-type
stack-size cell /i { int-rep f } <repetition> ;
: large-struct? ( type -- ? )
{
{ [ dup void? ] [ drop f ] }

4
basis/combinators/smart/smart.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry generalizations kernel macros math.order
stack-checker math sequences ;
USING: accessors fry generalizations sequences.generalizations
kernel macros math.order stack-checker math sequences ;
IN: combinators.smart
MACRO: drop-outputs ( quot -- quot' )

54
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
View File

@ -1,8 +1,14 @@
USING: arrays compiler.cfg.alias-analysis compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
cpu.architecture tools.test byte-arrays layouts literals alien ;
cpu.architecture tools.test byte-arrays layouts literals alien
accessors sequences ;
IN: compiler.cfg.alias-analysis.tests
: test-alias-analysis ( insn -- insn )
init-alias-analysis
alias-analysis-step
[ f >>insn# ] map ;
! Redundant load elimination
[
V{
@ -15,7 +21,7 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##slot-imm f 2 0 1 0 }
} alias-analysis-step
} test-alias-analysis
] unit-test
! Store-load forwarding
@ -32,7 +38,7 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##peek f 1 D 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##slot-imm f 2 0 1 0 }
} alias-analysis-step
} test-alias-analysis
] unit-test
! Dead store elimination
@ -50,7 +56,27 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##peek f 2 D 2 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 2 0 1 0 }
} alias-analysis-step
} test-alias-analysis
] unit-test
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##set-slot-imm f 3 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 2 0 1 0 }
T{ ##set-slot-imm f 3 0 1 0 }
} test-alias-analysis
] unit-test
! Redundant store elimination
@ -64,7 +90,7 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 1 0 1 0 }
} alias-analysis-step
} test-alias-analysis
] unit-test
[
@ -79,7 +105,7 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##slot-imm f 1 0 1 0 }
T{ ##copy f 2 1 any-rep }
T{ ##set-slot-imm f 2 0 1 0 }
} alias-analysis-step
} test-alias-analysis
] unit-test
! Not a redundant load
@ -98,7 +124,7 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 0 1 1 0 }
T{ ##slot-imm f 2 0 1 0 }
} alias-analysis-step
} test-alias-analysis
] unit-test
! Not a redundant store
@ -121,7 +147,7 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##set-slot-imm f 2 1 1 0 }
T{ ##slot-imm f 4 0 1 0 }
T{ ##set-slot-imm f 3 1 1 0 }
} alias-analysis-step
} test-alias-analysis
] unit-test
! There's a redundant load, but not a redundant store
@ -148,7 +174,7 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##slot f 5 0 3 0 0 }
T{ ##set-slot-imm f 3 0 1 0 }
T{ ##slot-imm f 6 0 1 0 }
} alias-analysis-step
} test-alias-analysis
] unit-test
! Fresh allocations don't alias existing values
@ -173,7 +199,7 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##set-slot-imm f 3 4 1 0 }
T{ ##set-slot-imm f 2 1 1 0 }
T{ ##slot-imm f 5 4 1 0 }
} alias-analysis-step
} test-alias-analysis
] unit-test
! Redundant store elimination
@ -195,7 +221,7 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##set-slot-imm f 1 4 1 0 }
T{ ##slot-imm f 5 1 1 0 }
T{ ##set-slot-imm f 3 4 1 0 }
} alias-analysis-step
} test-alias-analysis
] unit-test
! Storing a new alias class into another object means that heap-ac
@ -225,7 +251,7 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##slot-imm f 5 3 1 0 }
T{ ##set-slot-imm f 1 5 1 0 }
T{ ##slot-imm f 6 4 1 0 }
} alias-analysis-step
} test-alias-analysis
] unit-test
! Compares between objects which cannot alias are eliminated
@ -240,7 +266,7 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##peek f 0 D 0 }
T{ ##allot f 1 16 array }
T{ ##compare f 2 0 1 cc= }
} alias-analysis-step
} test-alias-analysis
] unit-test
! Make sure that input to ##box-displaced-alien becomes heap-ac
@ -259,5 +285,5 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##box-displaced-alien f 3 2 1 4 byte-array }
T{ ##slot-imm f 5 3 1 $[ alien type-number ] }
T{ ##compare f 6 5 1 cc= }
} alias-analysis-step
} test-alias-analysis
] unit-test

182
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
accessors words vectors combinators combinators.short-circuit
sets classes layouts fry cpu.architecture
sets classes layouts fry locals cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.def-use
@ -112,29 +112,20 @@ SYMBOL: acs>vregs
! Map vregs -> slot# -> vreg
SYMBOL: live-slots
! Current instruction number
SYMBOL: insn#
! Maps vreg -> slot# -> insn# of last store or f
SYMBOL: recent-stores
! Load/store history, for dead store elimination
TUPLE: load insn# ;
TUPLE: store insn# ;
! A set of insn#s of dead stores
SYMBOL: dead-stores
: new-action ( class -- action )
insn# get swap boa ; inline
: dead-store ( insn# -- ) dead-stores get adjoin ;
! Maps vreg -> slot# -> sequence of loads/stores
SYMBOL: histories
: history ( vreg -- history ) histories get at ;
: set-ac ( vreg ac -- )
:: set-ac ( vreg ac -- )
#! Set alias class of newly-seen vreg.
{
[ drop H{ } clone swap histories get set-at ]
[ drop H{ } clone swap live-slots get set-at ]
[ swap vregs>acs get set-at ]
[ acs>vregs get push-at ]
} 2cleave ;
H{ } clone vreg recent-stores get set-at
H{ } clone vreg live-slots get set-at
ac vreg vregs>acs get set-at
vreg ac acs>vregs get push-at ;
: live-slot ( slot#/f vreg -- vreg' )
#! If the slot number is unknown, we never reuse a previous
@ -152,20 +143,17 @@ ERROR: vreg-has-no-slots vreg ;
: record-constant-slot ( slot# vreg -- )
#! A load can potentially read every store of this slot#
#! in that alias class.
[
history [ load new-action swap ?push ] change-at
] with each-alias ;
[ recent-stores get at delete-at ] with each-alias ;
: record-computed-slot ( vreg -- )
#! Computed load is like a load of every slot touched so far
[
history values [ load new-action swap push ] each
] each-alias ;
[ recent-stores get at clear-assoc ] each-alias ;
: remember-slot ( value slot#/f vreg -- )
over
[ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
[ 2nip record-computed-slot ] if ;
:: remember-slot ( value slot# vreg -- )
slot# [
slot# vreg record-constant-slot
value slot# vreg load-constant-slot
] [ vreg record-computed-slot ] if ;
SYMBOL: ac-counter
@ -184,21 +172,19 @@ SYMBOL: heap-ac
: kill-constant-set-slot ( slot# vreg -- )
[ live-slots get at delete-at ] with each-alias ;
: record-constant-set-slot ( slot# vreg -- )
history [
dup empty? [ dup last store? [ dup pop* ] when ] unless
store new-action swap ?push
] change-at ;
:: record-constant-set-slot ( insn# slot# vreg -- )
vreg recent-stores get at :> recent-stores
slot# recent-stores at [ dead-store ] when*
insn# slot# recent-stores set-at ;
: kill-computed-set-slot ( ac -- )
: kill-computed-set-slot ( vreg -- )
[ live-slots get at clear-assoc ] each-alias ;
: remember-set-slot ( slot#/f vreg -- )
over [
[ record-constant-set-slot ]
[ kill-constant-set-slot ]
2bi
] [ nip kill-computed-set-slot ] if ;
:: remember-set-slot ( insn# slot# vreg -- )
slot# [
insn# slot# vreg record-constant-set-slot
slot# vreg kill-constant-set-slot
] [ vreg kill-computed-set-slot ] if ;
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
@ -219,24 +205,11 @@ M: ##alien-global insn-object drop \ ##alien-global ;
M: ##vm-field insn-object drop \ ##vm-field ;
M: ##set-vm-field insn-object drop \ ##vm-field ;
: init-alias-analysis ( insns -- insns' )
H{ } clone histories set
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone copies set
GENERIC: analyze-aliases ( insn -- insn' )
0 ac-counter set
next-ac heap-ac set
M: insn analyze-aliases ;
\ ##vm-field set-new-ac
\ ##alien-global set-new-ac
dup local-live-in [ set-heap-ac ] each ;
GENERIC: analyze-aliases* ( insn -- insn' )
M: insn analyze-aliases*
M: vreg-insn analyze-aliases
! If an instruction defines a value with a non-integer
! representation it means that the value will be boxed
! anywhere its used as a tagged pointer. Boxing allocates
@ -247,23 +220,23 @@ M: insn analyze-aliases*
[ set-heap-ac ] [ set-new-ac ] if
] when* ;
M: ##phi analyze-aliases*
M: ##phi analyze-aliases
dup defs-vreg set-heap-ac ;
M: ##allocation analyze-aliases*
M: ##allocation analyze-aliases
#! A freshly allocated object is distinct from any other
#! object.
dup dst>> set-new-ac ;
M: ##box-displaced-alien analyze-aliases*
M: ##box-displaced-alien analyze-aliases
[ call-next-method ]
[ base>> heap-ac get merge-acs ] bi ;
M: ##read analyze-aliases*
M: ##read analyze-aliases
call-next-method
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup
[ 2nip <copy> analyze-aliases* nip ]
[ 2nip <copy> analyze-aliases nip ]
[ drop remember-slot ]
if ;
@ -272,17 +245,21 @@ M: ##read analyze-aliases*
#! from?
live-slot = ;
M: ##write analyze-aliases*
dup
[ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
3dup idempotent? [ 3drop ] [
[ 2drop heap-ac get merge-acs ]
[ remember-set-slot drop ]
[ load-slot ]
3tri
] if ;
M:: ##write analyze-aliases ( insn -- insn )
insn src>> resolve :> src
insn insn-slot# :> slot#
insn insn-object :> vreg
insn insn#>> :> insn#
M: ##copy analyze-aliases*
src slot# vreg idempotent? [ insn# dead-store ] [
src heap-ac get merge-acs
insn insn#>> slot# vreg remember-set-slot
src slot# vreg load-slot
] if
insn ;
M: ##copy analyze-aliases
#! The output vreg gets the same alias class as the input
#! vreg, since they both contain the same value.
dup record-copy ;
@ -293,48 +270,47 @@ M: ##copy analyze-aliases*
[ [ src1>> ] [ src2>> ] bi [ resolve vreg>ac ] bi@ = not ]
} 1&& ; inline
M: ##compare analyze-aliases*
M: ##compare analyze-aliases
call-next-method
dup useless-compare? [
dst>> f \ ##load-reference new-insn
analyze-aliases*
analyze-aliases
] when ;
: analyze-aliases ( insns -- insns' )
[ insn# set analyze-aliases* ] map-index sift ;
GENERIC: eliminate-dead-stores ( insn -- ? )
SYMBOL: live-stores
M: ##set-slot-imm eliminate-dead-stores
insn#>> dead-stores get in? not ;
: compute-live-stores ( -- )
histories get
values [
values [ [ store? ] filter [ insn#>> ] map ] map concat
] map concat fast-set
live-stores set ;
M: insn eliminate-dead-stores drop t ;
GENERIC: eliminate-dead-stores* ( insn -- insn' )
: init-alias-analysis ( -- )
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone copies set
H{ } clone recent-stores set
HS{ } clone dead-stores set
0 ac-counter set ;
: (eliminate-dead-stores) ( insn -- insn' )
dup insn-slot# [
insn# get live-stores get in? [
drop f
] unless
] when ;
: reset-alias-analysis ( -- )
recent-stores get clear-assoc
vregs>acs get clear-assoc
acs>vregs get clear-assoc
live-slots get clear-assoc
copies get clear-assoc
dead-stores get table>> clear-assoc
M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
M: insn eliminate-dead-stores* ;
: eliminate-dead-stores ( insns -- insns' )
[ insn# set eliminate-dead-stores* ] map-index sift ;
next-ac heap-ac set
\ ##vm-field set-new-ac
\ ##alien-global set-new-ac ;
: alias-analysis-step ( insns -- insns' )
init-alias-analysis
analyze-aliases
compute-live-stores
eliminate-dead-stores ;
reset-alias-analysis
[ local-live-in [ set-heap-ac ] each ]
[ 0 [ [ insn#<< ] [ drop 1 + ] 2bi ] reduce drop ]
[ [ analyze-aliases ] map! [ eliminate-dead-stores ] filter! ] tri ;
: alias-analysis ( cfg -- cfg )
init-alias-analysis
dup [ alias-analysis-step ] simple-optimization ;

92
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -1,47 +1,77 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
combinators classes words cpu.architecture layouts compiler.cfg
compiler.cfg.rpo compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.stack-frame ;
USING: namespaces accessors math math.order assocs kernel
sequences combinators classes words system fry locals
cpu.architecture layouts compiler.cfg compiler.cfg.rpo
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.stack-frame ;
IN: compiler.cfg.build-stack-frame
SYMBOL: frame-required?
SYMBOLS: param-area-size allot-area-size allot-area-align
frame-required? ;
: frame-required ( -- ) frame-required? on ;
GENERIC: compute-stack-frame* ( insn -- )
: request-stack-frame ( stack-frame -- )
frame-required? on
stack-frame [ max-stack-frame ] change ;
M:: ##local-allot compute-stack-frame* ( insn -- )
frame-required
insn size>> :> s
insn align>> :> a
allot-area-align [ a max ] change
allot-area-size [ a align [ insn offset<< ] [ s + ] bi ] change ;
M: ##stack-frame compute-stack-frame*
stack-frame>> request-stack-frame ;
frame-required
stack-frame>> param-area-size [ max ] change ;
M: ##call compute-stack-frame* drop frame-required? on ;
: vm-frame-required ( -- )
frame-required
vm-stack-space param-area-size [ max ] change ;
M: ##call-gc compute-stack-frame*
drop
frame-required? on
stack-frame new t >>calls-vm? request-stack-frame ;
M: ##call-gc compute-stack-frame* drop vm-frame-required ;
M: ##box compute-stack-frame* drop vm-frame-required ;
M: ##unbox compute-stack-frame* drop vm-frame-required ;
M: ##box-long-long compute-stack-frame* drop vm-frame-required ;
M: ##begin-callback compute-stack-frame* drop vm-frame-required ;
M: ##end-callback compute-stack-frame* drop vm-frame-required ;
M: ##unary-float-function compute-stack-frame* drop vm-frame-required ;
M: ##binary-float-function compute-stack-frame* drop vm-frame-required ;
M: insn compute-stack-frame*
class "frame-required?" word-prop
[ frame-required? on ] when ;
M: ##call compute-stack-frame* drop frame-required ;
M: ##alien-callback compute-stack-frame* drop frame-required ;
M: ##spill compute-stack-frame* drop frame-required ;
M: ##reload compute-stack-frame* drop frame-required ;
: initial-stack-frame ( -- stack-frame )
stack-frame new cfg get spill-area-size>> >>spill-area-size ;
M: ##float>integer compute-stack-frame*
drop integer-float-needs-stack-frame? [ frame-required ] when ;
: compute-stack-frame ( insns -- )
frame-required? off
initial-stack-frame stack-frame set
[ instructions>> [ compute-stack-frame* ] each ] each-basic-block
stack-frame get dup stack-frame-size >>total-size drop ;
M: ##integer>float compute-stack-frame*
drop integer-float-needs-stack-frame? [ frame-required ] when ;
M: insn compute-stack-frame* drop ;
: finalize-stack-frame ( stack-frame -- )
dup [ params>> ] [ allot-area-align>> ] bi align >>allot-area-base
dup [ [ allot-area-base>> ] [ allot-area-size>> ] bi + ] [ spill-area-align>> ] bi align >>spill-area-base
dup stack-frame-size >>total-size drop ;
: <stack-frame> ( cfg -- stack-frame )
[ stack-frame new ] dip
[ spill-area-size>> >>spill-area-size ]
[ spill-area-align>> >>spill-area-align ] bi
allot-area-size get >>allot-area-size
allot-area-align get >>allot-area-align
param-area-size get >>params
dup finalize-stack-frame ;
: compute-stack-frame ( cfg -- stack-frame/f )
[ [ instructions>> [ compute-stack-frame* ] each ] each-basic-block ]
[ frame-required? get [ <stack-frame> ] [ drop f ] if ]
bi ;
: build-stack-frame ( cfg -- cfg )
[
[ compute-stack-frame ]
[
frame-required? get stack-frame get f ?
>>stack-frame
] bi
] with-scope ;
0 param-area-size set
0 allot-area-size set
cell allot-area-align set
dup compute-stack-frame >>stack-frame ;

533
basis/compiler/cfg/builder/alien/alien.factor
View File

@ -1,335 +1,198 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays layouts math math.order math.parser
combinators combinators.short-circuit fry make sequences locals
alien alien.private alien.strings alien.c-types alien.libraries
classes.struct namespaces kernel strings libc quotations words
cpu.architecture compiler.utilities compiler.tree compiler.cfg
compiler.cfg.builder compiler.cfg.builder.alien.params
compiler.cfg.builder.blocks compiler.cfg.instructions
compiler.cfg.stack-frame compiler.cfg.stacks
compiler.cfg.registers compiler.cfg.hats ;
FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien
! output is triples with shape { vreg rep on-stack? }
GENERIC: unbox ( src c-type -- vregs )
M: c-type unbox
[ [ unboxer>> ] [ rep>> ] bi ^^unbox ] [ rep>> ] bi
f 3array 1array ;
M: long-long-type unbox
unboxer>> int-rep ^^unbox
0 cell
[
int-rep f ^^load-memory-imm
int-rep long-long-on-stack? 3array
] bi-curry@ bi 2array ;
GENERIC: unbox-parameter ( src c-type -- vregs )
M: c-type unbox-parameter unbox ;
M: long-long-type unbox-parameter unbox ;
M:: struct-c-type unbox-parameter ( src c-type -- )
src ^^unbox-any-c-ptr :> src
c-type value-struct? [
c-type flatten-struct-type
[| pair i |
src i cells pair first f ^^load-memory-imm
pair first2 3array
] map-index
] [ { { src int-rep f } } ] if ;
: unbox-parameters ( parameters -- vregs )
[
[ length iota <reversed> ] keep
[
[ <ds-loc> ^^peek ] [ base-type ] bi*
unbox-parameter
] 2map concat
]
[ length neg ##inc-d ] bi ;
: prepare-struct-area ( vregs return -- vregs )
#! Return offset on C stack where to store unboxed
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
large-struct? [
^^prepare-struct-area int-rep struct-return-on-stack?
3array prefix
] when ;
: (objects>registers) ( vregs -- )
! Place ##store-stack-param instructions first. This ensures
! that no registers are used after the ##store-reg-param
! instructions.
[
first3 [ dup reg-class-of reg-class-full? ] dip or
[ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
[ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
if
] map [ ##store-stack-param? ] partition [ % ] bi@ ;
: objects>registers ( params -- stack-size )
[ abi>> ] [ parameters>> ] [ return>> ] tri
'[
_ unbox-parameters
_ prepare-struct-area
(objects>registers)
stack-params get
] with-param-regs ;
GENERIC: box-return ( c-type -- dst )
M: c-type box-return
[ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ;
M: long-long-type box-return
[ f ] dip boxer>> ^^box-long-long ;
M: struct-c-type box-return
dup return-struct-in-registers?
[ ^^box-small-struct ] [ [ f ] dip ^^box-large-struct ] if ;
: box-return* ( node -- )
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
M: string dlsym-valid? dlsym ;
M: array dlsym-valid? '[ _ dlsym ] any? ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd dlsym-valid?
[ drop ] [ cfg get word>> no-such-symbol ] if
] [ dll-path cfg get word>> no-such-library drop ] if ;
: decorated-symbol ( params -- symbols )
[ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
{
[ drop ]
[ "@" glue ]
[ "@" glue "_" prepend ]
[ "@" glue "@" prepend ]
} 2cleave
4array ;
: alien-invoke-dlsym ( params -- symbols dll )
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
[ library>> load-library ]
bi 2dup check-dlsym ;
: return-size ( c-type -- n )
#! Amount of space we reserve for a return value.
{
{ [ dup void? ] [ drop 0 ] }
{ [ dup base-type struct-c-type? not ] [ drop 0 ] }
{ [ dup large-struct? not ] [ drop 2 cells ] }
[ heap-size ]
} cond ;
: alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
: emit-alien-block ( node quot: ( params -- ) -- )
'[
make-kill-block
params>>
_ [ alien-node-height ] bi
] emit-trivial-block ; inline
: <alien-stack-frame> ( stack-size return -- stack-frame )
stack-frame new
swap return-size >>return
swap >>params
t >>calls-vm? ;
: emit-stack-frame ( stack-size params -- )
[ return>> ] [ abi>> ] bi
[ stack-cleanup ##cleanup ]
[ drop <alien-stack-frame> ##stack-frame ] 3bi ;
M: #alien-invoke emit-node
[
{
[ objects>registers ]
[ alien-invoke-dlsym ##alien-invoke ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
] emit-alien-block ;
M:: #alien-indirect emit-node ( node -- )
node [
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
{
[ objects>registers ]
[ drop src ##alien-indirect ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
] emit-alien-block ;
M: #alien-assembly emit-node
[
{
[ objects>registers ]
[ quot>> ##alien-assembly ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
] emit-alien-block ;
GENERIC: box-parameter ( n c-type -- dst )
M: c-type box-parameter
[ rep>> ] [ boxer>> ] bi ^^box ;
M: long-long-type box-parameter
boxer>> ^^box-long-long ;
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
M: struct-c-type box-parameter
[ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ;
: parameter-offsets ( types -- offsets )
0 [ stack-size + ] accumulate nip ;
: prepare-parameters ( parameters -- offsets types indices )
[ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;
: alien-parameters ( params -- seq )
[ parameters>> ] [ return>> large-struct? ] bi
[ struct-return-on-stack? (stack-value) void* ? prefix ] when ;
: box-parameters ( params -- )
alien-parameters
[ length ##inc-d ]
[
prepare-parameters
[
next-vreg next-vreg ##save-context
base-type box-parameter swap <ds-loc> ##replace
] 3each
] bi ;
:: alloc-parameter ( rep -- reg rep )
rep dup reg-class-of reg-class-full?
[ alloc-stack-param stack-params ] [ [ next-reg-param ] keep ] if ;
GENERIC: flatten-c-type ( type -- reps )
M: struct-c-type flatten-c-type
flatten-struct-type [ first2 [ drop stack-params ] when ] map ;
M: long-long-type flatten-c-type drop { int-rep int-rep } ;
M: c-type flatten-c-type
rep>> {
{ int-rep [ { int-rep } ] }
{ float-rep [ float-on-stack? { stack-params } { float-rep } ? ] }
{ double-rep [
float-on-stack?
cell 4 = { stack-params stack-params } { stack-params } ?
{ double-rep } ?
] }
{ stack-params [ { stack-params } ] }
} case ;
M: object flatten-c-type base-type flatten-c-type ;
: flatten-c-types ( types -- reps )
[ flatten-c-type ] map concat ;
: (registers>objects) ( params -- )
[ 0 ] dip alien-parameters flatten-c-types [
[ alloc-parameter ##save-param-reg ]
[ rep-size cell align + ]
2bi
] each drop ; inline
: registers>objects ( params -- )
! Generate code for boxing input parameters in a callback.
dup abi>> [
dup (registers>objects)
##begin-callback
next-vreg next-vreg ##restore-context
box-parameters
] with-param-regs ;
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup void? ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
[ c-type c-type-unboxer-quot ]
} cond ;
: callback-prep-quot ( params -- quot )
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
: wrap-callback-quot ( params -- quot )
[ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
yield-hook get
'[ _ _ do-callback ]
>quotation ;
GENERIC: unbox-return ( src c-type -- )
M: c-type unbox-return
unbox first first2 ##store-return ;
M: long-long-type unbox-return
unbox first2 [ first ] bi@ ##store-long-long-return ;
M: struct-c-type unbox-return
[ ^^unbox-any-c-ptr ] dip ##store-struct-return ;
: emit-callback-stack-frame ( params -- )
[ alien-parameters [ stack-size ] map-sum ] [ return>> ] bi
<alien-stack-frame> ##stack-frame ;
: stack-args-size ( params -- n )
dup abi>> [
alien-parameters flatten-c-types
[ alloc-parameter 2drop ] each
stack-params get
] with-param-regs ;
: callback-stack-cleanup ( params -- )
[ xt>> ] [ [ stack-args-size ] [ return>> ] [ abi>> ] tri stack-cleanup ] bi
"stack-cleanup" set-word-prop ;
M: #alien-callback emit-node
dup params>> xt>> dup
[
##prologue
[
{
[ registers>objects ]
[ emit-callback-stack-frame ]
[ callback-stack-cleanup ]
[ wrap-callback-quot ##alien-callback ]
[
return>> {
{ [ dup void? ] [ drop ##end-callback ] }
{ [ dup large-struct? ] [ drop ##end-callback ] }
[
[ D 0 ^^peek ] dip
##end-callback
base-type unbox-return
]
} cond
]
} cleave
] emit-alien-block
##epilogue
##return
] with-cfg-builder ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays layouts math math.order math.parser
combinators combinators.short-circuit fry make sequences
sequences.generalizations alien alien.private alien.strings
alien.c-types alien.libraries classes.struct namespaces kernel
strings libc locals quotations words cpu.architecture
compiler.utilities compiler.tree compiler.cfg
compiler.cfg.builder compiler.cfg.builder.alien.params
compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
compiler.cfg.instructions compiler.cfg.stack-frame
compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien
: unbox-parameters ( parameters -- vregs reps )
[
[ length iota <reversed> ] keep
[ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
2 2 mnmap [ concat ] bi@
]
[ length neg ##inc-d ] bi ;
: prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
dup large-struct? [
heap-size cell f ^^local-allot [
'[ _ prefix ]
[ int-rep struct-return-on-stack? 2array prefix ] bi*
] keep
] [ drop f ] if ;
: caller-parameter ( vreg rep on-stack? -- insn )
[ dup reg-class-of reg-class-full? ] dip or
[ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
[ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
if ;
: (caller-parameters) ( vregs reps -- )
! Place ##store-stack-param instructions first. This ensures
! that no registers are used after the ##store-reg-param
! instructions.
[ first2 caller-parameter ] 2map
[ ##store-stack-param? ] partition [ % ] bi@ ;
: caller-parameters ( params -- stack-size )
[ abi>> ] [ parameters>> ] [ return>> ] tri
'[
_ unbox-parameters
_ prepare-struct-caller struct-return-area set
(caller-parameters)
stack-params get
struct-return-area get
] with-param-regs
struct-return-area set ;
: box-return* ( node -- )
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
M: string dlsym-valid? dlsym ;
M: array dlsym-valid? '[ _ dlsym ] any? ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd dlsym-valid?
[ drop ] [ cfg get word>> no-such-symbol ] if
] [ dll-path cfg get word>> no-such-library drop ] if ;
: decorated-symbol ( params -- symbols )
[ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
{
[ drop ]
[ "@" glue ]
[ "@" glue "_" prepend ]
[ "@" glue "@" prepend ]
} 2cleave
4array ;
: alien-invoke-dlsym ( params -- symbols dll )
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
[ library>> load-library ]
bi 2dup check-dlsym ;
: alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
: emit-alien-block ( node quot: ( params -- ) -- )
'[
make-kill-block
params>>
_ [ alien-node-height ] bi
] emit-trivial-block ; inline
: emit-stack-frame ( stack-size params -- )
[ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
[ drop ##stack-frame ]
2bi ;
M: #alien-invoke emit-node
[
{
[ caller-parameters ]
[ ##prepare-var-args alien-invoke-dlsym ##alien-invoke ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
] emit-alien-block ;
M:: #alien-indirect emit-node ( node -- )
node [
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
[ caller-parameters src ##alien-indirect ]
[ emit-stack-frame ]
[ box-return* ]
tri
] emit-alien-block ;
M: #alien-assembly emit-node
[
{
[ caller-parameters ]
[ quot>> ##alien-assembly ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
] emit-alien-block ;
: callee-parameter ( rep on-stack? -- dst insn )
[ next-vreg dup ] 2dip
[ dup reg-class-of reg-class-full? ] dip or
[ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]
[ [ next-reg-param ] keep \ ##load-reg-param new-insn ]
if ;
: prepare-struct-callee ( c-type -- vreg )
large-struct?
[ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;
: (callee-parameters) ( params -- vregs reps )
[ flatten-parameter-type ] map
[
[ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap
concat [ ##load-reg-param? ] partition [ % ] bi@
]
[ [ keys ] map ]
bi ;
: box-parameters ( vregs reps params -- )
##begin-callback
next-vreg next-vreg ##restore-context
[
next-vreg next-vreg ##save-context
box-parameter
1 ##inc-d D 0 ##replace
] 3each ;
: callee-parameters ( params -- stack-size )
[ abi>> ] [ return>> ] [ parameters>> ] tri
'[
_ prepare-struct-callee struct-return-area set
_ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi
stack-params get
struct-return-area get
] with-param-regs
struct-return-area set ;
: callback-stack-cleanup ( stack-size params -- )
[ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
"stack-cleanup" set-word-prop ;
: needs-frame-pointer ( -- )
cfg get t >>frame-pointer? drop ;
M: #alien-callback emit-node
dup params>> xt>> dup
[
needs-frame-pointer
##prologue
[
{
[ callee-parameters ]
[ quot>> ##alien-callback ]
[
return>> [ ##end-callback ] [
[ D 0 ^^peek ] dip
##end-callback
base-type unbox-return
] if-void
]
[ callback-stack-cleanup ]
} cleave
] emit-alien-block
##epilogue
##return
] with-cfg-builder ;

1
basis/compiler/cfg/builder/alien/boxing/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

145
basis/compiler/cfg/builder/alien/boxing/boxing.factor Normal file
View File

@ -0,0 +1,145 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays assocs classes.struct fry
kernel layouts locals math namespaces sequences
sequences.generalizations system
compiler.cfg.builder.alien.params compiler.cfg.hats
compiler.cfg.instructions cpu.architecture ;
IN: compiler.cfg.builder.alien.boxing
SYMBOL: struct-return-area
! pairs have shape { rep on-stack? }
GENERIC: flatten-c-type ( c-type -- pairs )
M: c-type flatten-c-type
rep>> f 2array 1array ;
M: long-long-type flatten-c-type
drop 2 [ int-rep long-long-on-stack? 2array ] replicate ;
HOOK: flatten-struct-type cpu ( type -- pairs )
M: object flatten-struct-type
heap-size cell align cell /i { int-rep f } <repetition> ;
M: struct-c-type flatten-c-type
flatten-struct-type ;
: stack-size ( c-type -- n )
base-type flatten-c-type keys 0 [ rep-size + ] reduce ;
: component-offsets ( reps -- offsets )
0 [ rep-size + ] accumulate nip ;
:: explode-struct ( src c-type -- vregs reps )
c-type flatten-struct-type :> reps
reps keys dup component-offsets
[| rep offset | src offset rep f ^^load-memory-imm ] 2map
reps ;
:: implode-struct ( src vregs reps -- )
vregs reps dup component-offsets
[| vreg rep offset | vreg src offset rep f ##store-memory-imm ] 3each ;
GENERIC: unbox ( src c-type -- vregs reps )
M: c-type unbox
[ unboxer>> ] [ rep>> ] bi
[ ^^unbox 1array ] [ nip f 2array 1array ] 2bi ;
M: long-long-type unbox
[ 8 cell f ^^local-allot ] dip '[ _ unboxer>> ##unbox-long-long ] keep
0 cell [ int-rep f ^^load-memory-imm ] bi-curry@ bi 2array
int-rep long-long-on-stack? 2array dup 2array ;
M: struct-c-type unbox ( src c-type -- vregs )
[ ^^unbox-any-c-ptr ] dip explode-struct ;
: frob-struct ( c-type -- c-type )
dup value-struct? [ drop void* base-type ] unless ;
GENERIC: unbox-parameter ( src c-type -- vregs reps )
M: c-type unbox-parameter unbox ;
M: long-long-type unbox-parameter unbox ;
M: struct-c-type unbox-parameter
dup value-struct? [ unbox ] [
[ nip heap-size cell f ^^local-allot dup ]
[ [ ^^unbox-any-c-ptr ] dip explode-struct keys ] 2bi
implode-struct
1array { { int-rep f } }
] if ;
GENERIC: unbox-return ( src c-type -- )
: store-return ( vregs reps -- )
[
[ [ next-return-reg ] keep ##store-reg-param ] 2each
] with-return-regs ;
: (unbox-return) ( src c-type -- vregs reps )
! Don't care about on-stack? flag when looking at return
! values.
unbox keys ;
M: c-type unbox-return (unbox-return) store-return ;
M: long-long-type unbox-return (unbox-return) store-return ;
M: struct-c-type unbox-return
dup return-struct-in-registers?
[ (unbox-return) store-return ]
[ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ;
GENERIC: flatten-parameter-type ( c-type -- reps )
M: c-type flatten-parameter-type flatten-c-type ;
M: long-long-type flatten-parameter-type flatten-c-type ;
M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
GENERIC: box ( vregs reps c-type -- dst )
M: c-type box
[ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ;
M: long-long-type box
[ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ;
M: struct-c-type box
'[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
implode-struct ;
GENERIC: box-parameter ( vregs reps c-type -- dst )
M: c-type box-parameter box ;
M: long-long-type box-parameter box ;
M: struct-c-type box-parameter
dup value-struct?
[ [ [ drop first ] dip explode-struct keys ] keep ] unless
box ;
GENERIC: box-return ( c-type -- dst )
: load-return ( c-type -- vregs reps )
[
flatten-c-type keys
[ [ [ next-return-reg ] keep ^^load-reg-param ] map ] keep
] with-return-regs ;
M: c-type box-return [ load-return ] keep box ;
M: long-long-type box-return [ load-return ] keep box ;
M: struct-c-type box-return
[
dup return-struct-in-registers?
[ load-return ]
[ [ struct-return-area get ] dip explode-struct keys ] if
] keep box ;

36
basis/compiler/cfg/builder/alien/params/params.factor
View File

@ -1,9 +1,11 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cpu.architecture fry kernel layouts math math.order
namespaces sequences vectors ;
namespaces sequences vectors assocs ;
IN: compiler.cfg.builder.alien.params
SYMBOL: stack-params
: alloc-stack-param ( rep -- n )
stack-params get
[ rep-size cell align stack-params +@ ] dip ;
@ -23,27 +25,29 @@ IN: compiler.cfg.builder.alien.params
GENERIC: next-reg-param ( rep -- reg )
M: int-rep next-reg-param
[ ?dummy-stack-params ] [ ?dummy-fp-params ] bi int-regs get pop ;
[ ?dummy-stack-params ] [ ?dummy-fp-params ] bi
int-regs get pop ;
M: float-rep next-reg-param
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ;
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi
float-regs get pop ;
M: double-rep next-reg-param
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ;
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi
float-regs get pop ;
GENERIC: reg-class-full? ( reg-class -- ? )
M: stack-params reg-class-full? drop t ;
M: reg-class reg-class-full? get empty? ;
: reg-class-full? ( reg-class -- ? ) get empty? ;
: init-reg-class ( abi reg-class -- )
[ swap param-regs <reversed> >vector ] keep set ;
[ swap param-regs at <reversed> >vector ] keep set ;
: init-regs ( regs -- )
[ <reversed> >vector swap set ] assoc-each ;
: with-param-regs ( abi quot -- )
'[
[ int-regs init-reg-class ]
[ float-regs init-reg-class ] bi
0 stack-params set
@
] with-scope ; inline
'[ param-regs init-regs 0 stack-params set @ ] with-scope ; inline
: next-return-reg ( rep -- reg ) reg-class-of get pop ;
: with-return-regs ( quot -- )
'[ return-regs init-regs @ ] with-scope ; inline

3
basis/compiler/cfg/cfg.factor
View File

@ -22,8 +22,9 @@ number
M: basic-block hashcode* nip id>> ;
TUPLE: cfg { entry basic-block } word label
spill-area-size
spill-area-size spill-area-align
stack-frame
frame-pointer?
post-order linear-order
predecessors-valid? dominance-valid? loops-valid? ;

18
basis/compiler/cfg/dce/dce.factor
View File

@ -49,9 +49,11 @@ M: ##write-barrier-imm build-liveness-graph
M: ##allot build-liveness-graph
[ dst>> allocations get adjoin ] [ call-next-method ] bi ;
M: insn build-liveness-graph
M: vreg-insn build-liveness-graph
dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
M: insn build-liveness-graph drop ;
GENERIC: compute-live-vregs ( insn -- )
: (record-live) ( vregs -- )
@ -87,9 +89,11 @@ M: ##fixnum-sub compute-live-vregs record-live ;
M: ##fixnum-mul compute-live-vregs record-live ;
M: insn compute-live-vregs
M: vreg-insn compute-live-vregs
dup defs-vreg [ drop ] [ record-live ] if ;
M: insn compute-live-vregs drop ;
GENERIC: live-insn? ( insn -- ? )
M: ##set-slot live-insn? obj>> live-vreg? ;
@ -106,7 +110,9 @@ M: ##fixnum-sub live-insn? drop t ;
M: ##fixnum-mul live-insn? drop t ;
M: insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
M: vreg-insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
M: insn live-insn? defs-vreg drop t ;
: eliminate-dead-code ( cfg -- cfg' )
! Even though we don't use predecessors directly, we depend
@ -116,7 +122,7 @@ M: insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
init-dead-code
dup
[ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
[ [ instructions>> [ compute-live-vregs ] each ] each-basic-block ]
[ [ instructions>> [ live-insn? ] filter! drop ] each-basic-block ]
[ [ [ build-liveness-graph ] each ] simple-analysis ]
[ [ [ compute-live-vregs ] each ] simple-analysis ]
[ [ [ live-insn? ] filter! ] simple-optimization ]
tri ;

6
basis/compiler/cfg/def-use/def-use.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays classes combinators
compiler.units fry generalizations generic kernel locals
namespaces quotations sequences sets slots words
compiler.cfg.instructions compiler.cfg.instructions.syntax
compiler.units fry generalizations sequences.generalizations
generic kernel locals namespaces quotations sequences sets slots
words compiler.cfg.instructions compiler.cfg.instructions.syntax
compiler.cfg.rpo ;
FROM: namespaces => set ;
FROM: sets => members ;

3
basis/compiler/cfg/gc-checks/gc-checks.factor
View File

@ -22,7 +22,8 @@ IN: compiler.cfg.gc-checks
! can contain tagged pointers.
: insert-gc-check? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
dup kill-block?>>
[ drop f ] [ instructions>> [ ##allocation? ] any? ] if ;
: blocks-with-gc ( cfg -- bbs )
post-order [ insert-gc-check? ] filter ;

135
basis/compiler/cfg/instructions/instructions.factor
View File

@ -16,9 +16,12 @@ V{ } clone insn-classes set-global
! Virtual CPU instructions, used by CFG IR
TUPLE: insn ;
! Instructions which use vregs
TUPLE: vreg-insn < insn ;
! Instructions which are referentially transparent; used for
! value numbering
TUPLE: pure-insn < insn ;
TUPLE: pure-insn < vreg-insn ;
! Constants
INSN: ##load-integer
@ -216,6 +219,10 @@ PURE-INSN: ##log2
def: dst/int-rep
use: src/int-rep ;
PURE-INSN: ##bit-count
def: dst/int-rep
use: src/int-rep ;
! Float arithmetic
PURE-INSN: ##add-float
def: dst/double-rep
@ -288,16 +295,36 @@ def: dst
use: src1/scalar-rep src2/scalar-rep
literal: rep ;
PURE-INSN: ##gather-int-vector-2
def: dst
use: src1/int-rep src2/int-rep
literal: rep ;
PURE-INSN: ##gather-vector-4
def: dst
use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep
literal: rep ;
PURE-INSN: ##gather-int-vector-4
def: dst
use: src1/int-rep src2/int-rep src3/int-rep src4/int-rep
literal: rep ;
PURE-INSN: ##select-vector
def: dst/int-rep
use: src
literal: n rep ;
PURE-INSN: ##shuffle-vector
def: dst
use: src shuffle
literal: rep ;
PURE-INSN: ##shuffle-vector-halves-imm
def: dst
use: src1 src2
literal: shuffle rep ;
PURE-INSN: ##shuffle-vector-imm
def: dst
use: src
@ -611,6 +638,10 @@ def: dst
use: src/tagged-rep
literal: unboxer rep ;
INSN: ##unbox-long-long
use: src/tagged-rep out/int-rep
literal: unboxer ;
INSN: ##store-reg-param
use: src
literal: reg rep ;
@ -619,35 +650,33 @@ INSN: ##store-stack-param
use: src
literal: n rep ;
INSN: ##store-return
use: src
literal: rep ;
INSN: ##load-reg-param
def: dst
literal: reg rep ;
INSN: ##store-struct-return
use: src/int-rep
literal: c-type ;
INSN: ##load-stack-param
def: dst
literal: n rep ;
INSN: ##store-long-long-return
use: src1/int-rep src2/int-rep ;
INSN: ##prepare-struct-area
def: dst/int-rep ;
INSN: ##local-allot
def: dst/int-rep
literal: size align offset ;
INSN: ##box
def: dst/tagged-rep
literal: n rep boxer ;
use: src
literal: boxer rep ;
INSN: ##box-long-long
def: dst/tagged-rep
literal: n boxer ;
use: src1/int-rep src2/int-rep
literal: boxer ;
INSN: ##box-small-struct
INSN: ##allot-byte-array
def: dst/tagged-rep
literal: c-type ;
literal: size ;
INSN: ##box-large-struct
def: dst/tagged-rep
literal: n c-type ;
INSN: ##prepare-var-args ;
INSN: ##alien-invoke
literal: symbols dll ;
@ -661,9 +690,6 @@ use: src/int-rep ;
INSN: ##alien-assembly
literal: quot ;
INSN: ##save-param-reg
literal: offset reg rep ;
INSN: ##begin-callback ;
INSN: ##alien-callback
@ -708,6 +734,14 @@ INSN: ##compare-integer-imm-branch
use: src1/int-rep
literal: src2 cc ;
INSN: ##test-branch
use: src1/int-rep src2/int-rep
literal: cc ;
INSN: ##test-imm-branch
use: src1/int-rep
literal: src2 cc ;
PURE-INSN: ##compare-integer
def: dst/tagged-rep
use: src1/int-rep src2/int-rep
@ -720,6 +754,18 @@ use: src1/int-rep
literal: src2 cc
temp: temp/int-rep ;
PURE-INSN: ##test
def: dst/tagged-rep
use: src1/int-rep src2/int-rep
literal: cc
temp: temp/int-rep ;
PURE-INSN: ##test-imm
def: dst/tagged-rep
use: src1/int-rep
literal: src2 cc
temp: temp/int-rep ;
! Float conditionals
INSN: ##compare-float-ordered-branch
use: src1/double-rep src2/double-rep
@ -793,6 +839,8 @@ UNION: conditional-branch-insn
##compare-imm-branch
##compare-integer-branch
##compare-integer-imm-branch
##test-branch
##test-imm-branch
##compare-float-ordered-branch
##compare-float-unordered-branch
##test-vector-branch
@ -805,40 +853,35 @@ UNION: conditional-branch-insn
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
! Instructions that clobber registers
UNION: clobber-insn
##call-gc
##unary-float-function
##binary-float-function
##box
##box-long-long
##box-small-struct
##box-large-struct
##unbox
! Instructions that clobber registers. They receive inputs and
! produce outputs in spill slots.
UNION: hairy-clobber-insn
##load-reg-param
##store-reg-param
##store-return
##store-struct-return
##store-long-long-return
##call-gc
##alien-invoke
##alien-indirect
##alien-assembly
##save-param-reg
##begin-callback
##end-callback ;
! Instructions that clobber registers but are allowed to produce
! outputs in registers. Inputs are in spill slots, except for
! inputs coalesced with the output, in which case that input
! will be in a register.
UNION: clobber-insn
hairy-clobber-insn
##unary-float-function
##binary-float-function
##unbox
##unbox-long-long
##box
##box-long-long
##allot-byte-array ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn
##box-alien
##box-displaced-alien
##unbox-any-c-ptr ;
SYMBOL: vreg-insn
[
vreg-insn
insn-classes get [
"insn-slots" word-prop [ type>> { def use temp } member-eq? ] any?
] filter
define-union-class
] with-compilation-unit

21
basis/compiler/cfg/instructions/syntax/syntax.factor
View File

@ -56,21 +56,32 @@ TUPLE: insn-slot-spec type name rep ;
: insn-word ( -- word )
"insn" "compiler.cfg.instructions" lookup ;
: vreg-insn-word ( -- word )
"vreg-insn" "compiler.cfg.instructions" lookup ;
: pure-insn-word ( -- word )
"pure-insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
boa-effect in>> but-last { } <effect> ;
: define-insn-tuple ( class superclass specs -- )
: uses-vregs? ( specs -- ? )
[ type>> { def use temp } member-eq? ] any? ;
: insn-superclass ( pure? specs -- superclass )
pure-insn-word swap uses-vregs? vreg-insn-word insn-word ? ? ;
: define-insn-tuple ( class pure? specs -- )
[ insn-superclass ] keep
[ name>> ] map "insn#" suffix define-tuple-class ;
: define-insn-ctor ( class specs -- )
[ dup '[ _ ] [ f ] [ boa , ] surround ] dip
[ name>> ] map { } <effect> define-declared ;
: define-insn ( class superclass specs -- )
parse-insn-slot-specs {
: define-insn ( class pure? specs -- )
parse-insn-slot-specs
{
[ nip "insn-slots" set-word-prop ]
[ 2drop insn-classes-word get push ]
[ define-insn-tuple ]
@ -78,6 +89,6 @@ TUPLE: insn-slot-spec type name rep ;
[ nip define-insn-ctor ]
} 3cleave ;
SYNTAX: INSN: CREATE-CLASS insn-word ";" parse-tokens define-insn ;
SYNTAX: INSN: CREATE-CLASS f ";" parse-tokens define-insn ;
SYNTAX: PURE-INSN: CREATE-CLASS pure-insn-word ";" parse-tokens define-insn ;
SYNTAX: PURE-INSN: CREATE-CLASS t ";" parse-tokens define-insn ;

9
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -14,6 +14,7 @@ compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
QUALIFIED: alien
QUALIFIED: alien.accessors
QUALIFIED: alien.data.private
QUALIFIED: alien.c-types
QUALIFIED: kernel
QUALIFIED: arrays
@ -23,6 +24,7 @@ QUALIFIED: slots.private
QUALIFIED: strings.private
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: math.bitwise.private
QUALIFIED: math.integers.private
QUALIFIED: math.floats.private
QUALIFIED: math.libm
@ -63,6 +65,8 @@ IN: compiler.cfg.intrinsics
{ byte-arrays:<byte-array> [ emit-<byte-array> ] }
{ byte-arrays:(byte-array) [ emit-(byte-array) ] }
{ kernel:<wrapper> [ emit-simple-allot ] }
{ alien.data.private:(local-allot) [ emit-local-allot ] }
{ alien.data.private:(cleanup-allot) [ drop emit-cleanup-allot ] }
{ alien:<displaced-alien> [ emit-<displaced-alien> ] }
{ alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] }
{ alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] }
@ -155,5 +159,10 @@ IN: compiler.cfg.intrinsics
{ math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-op ] }
} enable-intrinsics ;
: enable-bit-count ( -- )
{
{ math.bitwise.private:fixnum-bit-count [ drop [ ^^bit-count ] unary-op ] }
} enable-intrinsics ;
: emit-intrinsic ( node word -- )
"intrinsic" word-prop call( node -- ) ;

9
basis/compiler/cfg/intrinsics/misc/misc.factor
View File

@ -52,3 +52,12 @@ IN: compiler.cfg.intrinsics.misc
0 int-rep f ^^load-memory-imm
hashcode-shift ^^shr-imm
] unary-op ;
: emit-local-allot ( node -- )
dup node-input-infos first2 [ literal>> ] bi@ 2dup [ integer? ] both?
[ ds-drop ds-drop f ^^local-allot ^^box-alien ds-push drop ]
[ 2drop emit-primitive ]
if ;
: emit-cleanup-allot ( -- )
[ ##no-tco ] emit-trivial-block ;

17
basis/compiler/cfg/intrinsics/simd/backend/backend.factor
View File

@ -6,7 +6,7 @@ compiler.cfg.stacks.local compiler.tree.propagation.info
compiler.cfg.instructions
cpu.architecture effects fry generalizations
kernel locals macros make math namespaces quotations sequences
splitting stack-checker words ;
sequences.generalizations splitting stack-checker words ;
IN: compiler.cfg.intrinsics.simd.backend
! Selection of implementation based on available CPU instructions
@ -19,9 +19,13 @@ M: ##zero-vector insn-available? rep>> %zero-vector-reps member? ;
M: ##fill-vector insn-available? rep>> %fill-vector-reps member? ;
M: ##gather-vector-2 insn-available? rep>> %gather-vector-2-reps member? ;
M: ##gather-vector-4 insn-available? rep>> %gather-vector-4-reps member? ;
M: ##gather-int-vector-2 insn-available? rep>> %gather-int-vector-2-reps member? ;
M: ##gather-int-vector-4 insn-available? rep>> %gather-int-vector-4-reps member? ;
M: ##select-vector insn-available? rep>> %select-vector-reps member? ;
M: ##store-memory-imm insn-available? rep>> %alien-vector-reps member? ;
M: ##shuffle-vector insn-available? rep>> %shuffle-vector-reps member? ;
M: ##shuffle-vector-imm insn-available? rep>> %shuffle-vector-imm-reps member? ;
M: ##shuffle-vector-halves-imm insn-available? rep>> %shuffle-vector-halves-imm-reps member? ;
M: ##merge-vector-head insn-available? rep>> %merge-vector-reps member? ;
M: ##merge-vector-tail insn-available? rep>> %merge-vector-reps member? ;
M: ##signed-pack-vector insn-available? rep>> %signed-pack-vector-reps member? ;
@ -84,6 +88,8 @@ MACRO: v-vector-op ( trials -- )
[ 1 2 >vector-op-cond ] map '[ f f _ cond ] ;
MACRO: vl-vector-op ( trials -- )
[ 1 3 >vector-op-cond ] map '[ f f _ cond ] ;
MACRO: vvl-vector-op ( trials -- )
[ 1 4 >vector-op-cond ] map '[ f f _ cond ] ;
MACRO: vv-vector-op ( trials -- )
[ 1 3 >vector-op-cond ] map '[ f f _ cond ] ;
MACRO: vv-cc-vector-op ( trials -- )
@ -118,9 +124,10 @@ MACRO: if-literals-match ( quots -- )
] [ 2drop bad-simd-intrinsic ] if
] ;
CONSTANT: [unary] [ ds-drop ds-pop ]
CONSTANT: [unary/param] [ [ -2 inc-d ds-pop ] dip ]
CONSTANT: [binary] [ ds-drop 2inputs ]
CONSTANT: [unary] [ ds-drop ds-pop ]
CONSTANT: [unary/param] [ [ -2 inc-d ds-pop ] dip ]
CONSTANT: [binary] [ ds-drop 2inputs ]
CONSTANT: [binary/param] [ [ -2 inc-d 2inputs ] dip ]
CONSTANT: [quaternary]
[
ds-drop
@ -141,6 +148,8 @@ MACRO: emit-vl-vector-op ( trials literal-pred -- )
[ [unary/param] [ vl-vector-op ] { [ representation? ] } ] dip prefix [emit-vector-op] ;
MACRO: emit-vv-vector-op ( trials -- )
[binary] [ vv-vector-op ] { [ representation? ] } [emit-vector-op] ;
MACRO: emit-vvl-vector-op ( trials literal-pred -- )
[ [binary/param] [ vvl-vector-op ] { [ representation? ] } ] dip prefix [emit-vector-op] ;
MACRO: emit-vvvv-vector-op ( trials -- )
[quaternary] [ vvvv-vector-op ] { [ representation? ] } [emit-vector-op] ;

151
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -275,6 +275,26 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
[ [ ^load-immediate-shuffle ] [ ^^shuffle-vector ] bi ]
} vl-vector-op ;
: ^shuffle-2-vectors-imm ( src1 src2 shuffle rep -- dst )
[ rep-length 0 pad-tail ] keep {
{ double-2-rep [| src1 src2 shuffle rep |
shuffle first2 [ 4 mod ] bi@ :> ( i j )
{
{ [ i j [ 2 < ] both? ] [
src1 shuffle rep ^shuffle-vector-imm
] }
{ [ i j [ 2 >= ] both? ] [
src2 shuffle [ 2 - ] map rep ^shuffle-vector-imm
] }
{ [ i 2 < ] [
src1 src2 i j 2 - 2array rep ^^shuffle-vector-halves-imm
] }
! [ j 2 < ]
[ src2 src1 i 2 - j 2array rep ^^shuffle-vector-halves-imm ]
} cond
] }
} vvl-vector-op ;
: ^broadcast-vector ( src n rep -- dst )
[ rep-length swap <array> ] keep
^shuffle-vector-imm ;
@ -283,7 +303,10 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
[ ^^scalar>vector ] keep [ 0 ] dip ^broadcast-vector ;
: ^select-vector ( src n rep -- dst )
[ ^broadcast-vector ] keep ^^vector>scalar ;
{
[ ^^select-vector ]
[ [ ^broadcast-vector ] keep ^^vector>scalar ]
} vl-vector-op ;
! intrinsic emitters
@ -475,6 +498,11 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
[ ^shuffle-vector-imm ]
} [ shuffle? ] emit-vl-vector-op ;
: emit-simd-vshuffle2-elements ( node -- )
{
[ ^shuffle-2-vectors-imm ]
} [ shuffle? ] emit-vvl-vector-op ;
: emit-simd-vshuffle-bytes ( node -- )
{
[ ^^shuffle-vector ]
@ -568,12 +596,14 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
: emit-simd-gather-2 ( node -- )
{
{ fixnum-vector-rep [ ^^gather-int-vector-2 ] }
{ fixnum-vector-rep [ ^^gather-vector-2 ] }
{ float-vector-rep [ ^^gather-vector-2 ] }
} emit-vv-vector-op ;
: emit-simd-gather-4 ( node -- )
{
{ fixnum-vector-rep [ ^^gather-int-vector-4 ] }
{ fixnum-vector-rep [ ^^gather-vector-4 ] }
{ float-vector-rep [ ^^gather-vector-4 ] }
} emit-vvvv-vector-op ;
@ -605,65 +635,66 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
: enable-simd ( -- )
{
{ (simd-v+) [ emit-simd-v+ ] }
{ (simd-v-) [ emit-simd-v- ] }
{ (simd-vneg) [ emit-simd-vneg ] }
{ (simd-v+-) [ emit-simd-v+- ] }
{ (simd-vs+) [ emit-simd-vs+ ] }
{ (simd-vs-) [ emit-simd-vs- ] }
{ (simd-vs*) [ emit-simd-vs* ] }
{ (simd-v*) [ emit-simd-v* ] }
{ (simd-v*high) [ emit-simd-v*high ] }
{ (simd-v*hs+) [ emit-simd-v*hs+ ] }
{ (simd-v/) [ emit-simd-v/ ] }
{ (simd-vmin) [ emit-simd-vmin ] }
{ (simd-vmax) [ emit-simd-vmax ] }
{ (simd-vavg) [ emit-simd-vavg ] }
{ (simd-v.) [ emit-simd-v. ] }
{ (simd-vsad) [ emit-simd-vsad ] }
{ (simd-vsqrt) [ emit-simd-vsqrt ] }
{ (simd-sum) [ emit-simd-sum ] }
{ (simd-vabs) [ emit-simd-vabs ] }
{ (simd-vbitand) [ emit-simd-vand ] }
{ (simd-vbitandn) [ emit-simd-vandn ] }
{ (simd-vbitor) [ emit-simd-vor ] }
{ (simd-vbitxor) [ emit-simd-vxor ] }
{ (simd-vbitnot) [ emit-simd-vnot ] }
{ (simd-vand) [ emit-simd-vand ] }
{ (simd-vandn) [ emit-simd-vandn ] }
{ (simd-vor) [ emit-simd-vor ] }
{ (simd-vxor) [ emit-simd-vxor ] }
{ (simd-vnot) [ emit-simd-vnot ] }
{ (simd-vlshift) [ emit-simd-vlshift ] }
{ (simd-vrshift) [ emit-simd-vrshift ] }
{ (simd-hlshift) [ emit-simd-hlshift ] }
{ (simd-hrshift) [ emit-simd-hrshift ] }
{ (simd-vshuffle-elements) [ emit-simd-vshuffle-elements ] }
{ (simd-vshuffle-bytes) [ emit-simd-vshuffle-bytes ] }
{ (simd-vmerge-head) [ emit-simd-vmerge-head ] }
{ (simd-vmerge-tail) [ emit-simd-vmerge-tail ] }
{ (simd-v<=) [ emit-simd-v<= ] }
{ (simd-v<) [ emit-simd-v< ] }
{ (simd-v=) [ emit-simd-v= ] }
{ (simd-v>) [ emit-simd-v> ] }
{ (simd-v>=) [ emit-simd-v>= ] }
{ (simd-vunordered?) [ emit-simd-vunordered? ] }
{ (simd-vany?) [ emit-simd-vany? ] }
{ (simd-vall?) [ emit-simd-vall? ] }
{ (simd-vnone?) [ emit-simd-vnone? ] }
{ (simd-v>float) [ emit-simd-v>float ] }
{ (simd-v>integer) [ emit-simd-v>integer ] }
{ (simd-vpack-signed) [ emit-simd-vpack-signed ] }
{ (simd-vpack-unsigned) [ emit-simd-vpack-unsigned ] }
{ (simd-vunpack-head) [ emit-simd-vunpack-head ] }
{ (simd-vunpack-tail) [ emit-simd-vunpack-tail ] }
{ (simd-with) [ emit-simd-with ] }
{ (simd-gather-2) [ emit-simd-gather-2 ] }
{ (simd-gather-4) [ emit-simd-gather-4 ] }
{ (simd-select) [ emit-simd-select ] }
{ alien-vector [ emit-alien-vector ] }
{ set-alien-vector [ emit-set-alien-vector ] }
{ assert-positive [ drop ] }
{ (simd-v+) [ emit-simd-v+ ] }
{ (simd-v-) [ emit-simd-v- ] }
{ (simd-vneg) [ emit-simd-vneg ] }
{ (simd-v+-) [ emit-simd-v+- ] }
{ (simd-vs+) [ emit-simd-vs+ ] }
{ (simd-vs-) [ emit-simd-vs- ] }
{ (simd-vs*) [ emit-simd-vs* ] }
{ (simd-v*) [ emit-simd-v* ] }
{ (simd-v*high) [ emit-simd-v*high ] }
{ (simd-v*hs+) [ emit-simd-v*hs+ ] }
{ (simd-v/) [ emit-simd-v/ ] }
{ (simd-vmin) [ emit-simd-vmin ] }
{ (simd-vmax) [ emit-simd-vmax ] }
{ (simd-vavg) [ emit-simd-vavg ] }
{ (simd-v.) [ emit-simd-v. ] }
{ (simd-vsad) [ emit-simd-vsad ] }
{ (simd-vsqrt) [ emit-simd-vsqrt ] }
{ (simd-sum) [ emit-simd-sum ] }
{ (simd-vabs) [ emit-simd-vabs ] }
{ (simd-vbitand) [ emit-simd-vand ] }
{ (simd-vbitandn) [ emit-simd-vandn ] }
{ (simd-vbitor) [ emit-simd-vor ] }
{ (simd-vbitxor) [ emit-simd-vxor ] }
{ (simd-vbitnot) [ emit-simd-vnot ] }
{ (simd-vand) [ emit-simd-vand ] }
{ (simd-vandn) [ emit-simd-vandn ] }
{ (simd-vor) [ emit-simd-vor ] }
{ (simd-vxor) [ emit-simd-vxor ] }
{ (simd-vnot) [ emit-simd-vnot ] }
{ (simd-vlshift) [ emit-simd-vlshift ] }
{ (simd-vrshift) [ emit-simd-vrshift ] }
{ (simd-hlshift) [ emit-simd-hlshift ] }
{ (simd-hrshift) [ emit-simd-hrshift ] }
{ (simd-vshuffle-elements) [ emit-simd-vshuffle-elements ] }
{ (simd-vshuffle2-elements) [ emit-simd-vshuffle2-elements ] }
{ (simd-vshuffle-bytes) [ emit-simd-vshuffle-bytes ] }
{ (simd-vmerge-head) [ emit-simd-vmerge-head ] }
{ (simd-vmerge-tail) [ emit-simd-vmerge-tail ] }
{ (simd-v<=) [ emit-simd-v<= ] }
{ (simd-v<) [ emit-simd-v< ] }
{ (simd-v=) [ emit-simd-v= ] }
{ (simd-v>) [ emit-simd-v> ] }
{ (simd-v>=) [ emit-simd-v>= ] }
{ (simd-vunordered?) [ emit-simd-vunordered? ] }
{ (simd-vany?) [ emit-simd-vany? ] }
{ (simd-vall?) [ emit-simd-vall? ] }
{ (simd-vnone?) [ emit-simd-vnone? ] }
{ (simd-v>float) [ emit-simd-v>float ] }
{ (simd-v>integer) [ emit-simd-v>integer ] }
{ (simd-vpack-signed) [ emit-simd-vpack-signed ] }
{ (simd-vpack-unsigned) [ emit-simd-vpack-unsigned ] }
{ (simd-vunpack-head) [ emit-simd-vunpack-head ] }
{ (simd-vunpack-tail) [ emit-simd-vunpack-tail ] }
{ (simd-with) [ emit-simd-with ] }
{ (simd-gather-2) [ emit-simd-gather-2 ] }
{ (simd-gather-4) [ emit-simd-gather-4 ] }
{ (simd-select) [ emit-simd-select ] }
{ alien-vector [ emit-alien-vector ] }
{ set-alien-vector [ emit-set-alien-vector ] }
{ assert-positive [ drop ] }
} enable-intrinsics ;
enable-simd

38
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -36,31 +36,39 @@ IN: compiler.cfg.linear-scan.allocation
[ drop assign-blocked-register ]
} cond ;
: spill-at-sync-point ( n live-interval -- ? )
! If the live interval has a definition at 'n', don't spill
2dup find-use
{ [ ] [ def-rep>> ] } 1&&
[ 2drop t ] [ swap spill f ] if ;
: spill-at-sync-point? ( sync-point live-interval -- ? )
! If the live interval has a definition at a keep-dst?
! sync-point, don't spill.
{
[ drop keep-dst?>> not ]
[ [ n>> ] dip find-use dup [ def-rep>> ] when not ]
} 2|| ;
: handle-sync-point ( n -- )
: spill-at-sync-point ( sync-point live-interval -- ? )
2dup spill-at-sync-point?
[ swap n>> spill f ] [ 2drop t ] if ;
GENERIC: handle-progress* ( obj -- )
M: live-interval handle-progress* drop ;
M: sync-point handle-progress*
active-intervals get values
[ [ spill-at-sync-point ] with filter! drop ] with each ;
:: handle-progress ( n sync? -- )
n {
[ progress set ]
[ deactivate-intervals ]
[ sync? [ handle-sync-point ] [ drop ] if ]
[ activate-intervals ]
} cleave ;
:: handle-progress ( n obj -- )
n progress set
n deactivate-intervals
obj handle-progress*
n activate-intervals ;
GENERIC: handle ( obj -- )
M: live-interval handle ( live-interval -- )
[ start>> f handle-progress ] [ assign-register ] bi ;
[ [ start>> ] keep handle-progress ] [ assign-register ] bi ;
M: sync-point handle ( sync-point -- )
n>> t handle-progress ;
[ n>> ] keep handle-progress ;
: smallest-heap ( heap1 heap2 -- heap )
! If heap1 and heap2 have the same key, favors heap1.

12
basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
View File

@ -17,15 +17,15 @@ ERROR: bad-live-ranges interval ;
] [ drop ] if ;
: trim-before-ranges ( live-interval -- )
[ ranges>> ] [ last-use n>> 1 + ] bi
[ '[ from>> _ <= ] filter! drop ]
[ swap last to<< ]
dup last-use n>> 1 +
[ '[ [ from>> _ >= ] trim-tail-slice ] change-ranges drop ]
[ swap ranges>> last to<< ]
2bi ;
: trim-after-ranges ( live-interval -- )
[ ranges>> ] [ first-use n>> ] bi
[ '[ to>> _ >= ] filter! drop ]
[ swap first from<< ]
dup first-use n>>
[ '[ [ to>> _ < ] trim-head-slice ] change-ranges drop ]
[ swap ranges>> first from<< ]
2bi ;
: last-use-rep ( live-interval -- rep/f )

15
basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
USING: accessors arrays assocs binary-search combinators
combinators.short-circuit fry hints kernel locals
math sequences sets sorting splitting namespaces
math math.order sequences sets sorting splitting namespaces
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.splitting
@ -25,10 +25,13 @@ IN: compiler.cfg.linear-scan.allocation.splitting
[ split-last-range ] [ 2drop ] if
] bi ;
: split-uses ( uses n -- before after )
[ '[ n>> _ < ] filter ]
[ '[ n>> _ > ] filter ]
2bi ;
:: split-uses ( uses n -- before after )
uses n uses [ n>> <=> ] with search
n>> n <=> {
{ +eq+ [ [ head-slice ] [ 1 + tail-slice ] 2bi ] }
{ +lt+ [ 1 + cut-slice ] }
{ +gt+ [ cut-slice ] }
} case ;
ERROR: splitting-too-early ;

14
basis/compiler/cfg/linear-scan/allocation/state/state.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors assocs combinators cpu.architecture fry
heaps kernel math math.order namespaces sequences vectors
heaps kernel math math.order namespaces layouts sequences vectors
linked-assocs compiler.cfg compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.live-intervals ;
@ -122,6 +122,9 @@ SYMBOL: unhandled-intervals
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
<spill-slot> ;
: align-spill-area ( align -- )
cfg get [ max ] change-spill-area-align drop ;
! Minheap of sync points which still need to be processed
SYMBOL: unhandled-sync-points
@ -129,7 +132,10 @@ SYMBOL: unhandled-sync-points
SYMBOL: spill-slots
: assign-spill-slot ( coalesced-vreg rep -- spill-slot )
rep-size spill-slots get [ nip next-spill-slot ] 2cache ;
rep-size
[ align-spill-area ]
[ spill-slots get [ nip next-spill-slot ] 2cache ]
bi ;
: lookup-spill-slot ( coalesced-vreg rep -- spill-slot )
rep-size 2array spill-slots get ?at [ ] [ bad-vreg ] if ;
@ -141,7 +147,7 @@ SYMBOL: spill-slots
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
cfg get 0 >>spill-area-size drop
cfg get 0 >>spill-area-size cell >>spill-area-align drop
H{ } clone spill-slots set
-1 progress set ;

67
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -76,7 +76,7 @@ check-numbering? on
{ T{ live-range f 0 5 } } 0 split-ranges
] unit-test
cfg new 0 >>spill-area-size cfg set
cfg new 0 >>spill-area-size 4 >>spill-area-align cfg set
H{ } spill-slots set
H{
@ -85,6 +85,9 @@ H{
{ 3 float-rep }
} representations set
: clean-up-split ( a b -- a b )
[ dup [ [ >vector ] change-uses [ >vector ] change-ranges ] when ] bi@ ;
[
T{ live-interval
{ vreg 1 }
@ -115,6 +118,7 @@ H{
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } }
{ ranges V{ T{ live-range f 0 5 } } }
} 2 split-for-spill
clean-up-split
] unit-test
[
@ -138,6 +142,7 @@ H{
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } }
{ ranges V{ T{ live-range f 0 5 } } }
} 0 split-for-spill
clean-up-split
] unit-test
[
@ -161,6 +166,7 @@ H{
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } }
{ ranges V{ T{ live-range f 0 5 } } }
} 5 split-for-spill
clean-up-split
] unit-test
[
@ -193,6 +199,7 @@ H{
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
{ ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
} 10 split-for-spill
clean-up-split
] unit-test
! Don't insert reload if first usage is a def
@ -224,6 +231,7 @@ H{
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 float-rep f } T{ vreg-use f 30 f float-rep } } }
{ ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
} 10 split-for-spill
clean-up-split
] unit-test
! Multiple representations
@ -257,6 +265,63 @@ H{
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 10 double-rep float-rep } T{ vreg-use f 20 f double-rep } } }
{ ranges V{ T{ live-range f 0 20 } } }
} 15 split-for-spill
clean-up-split
] unit-test
[
f
T{ live-interval
{ vreg 7 }
{ start 8 }
{ end 8 }
{ ranges V{ T{ live-range f 8 8 } } }
{ uses V{ T{ vreg-use f 8 int-rep } } }
{ reg-class int-regs }
}
] [
T{ live-interval
{ vreg 7 }
{ start 4 }
{ end 8 }
{ ranges V{ T{ live-range f 4 8 } } }
{ uses V{ T{ vreg-use f 8 int-rep } } }
{ reg-class int-regs }
} 4 split-for-spill
clean-up-split
] unit-test
! trim-before-ranges, trim-after-ranges
[
T{ live-interval
{ vreg 8 }
{ start 0 }
{ end 3 }
{ ranges V{ T{ live-range f 0 3 } } }
{ uses V{ T{ vreg-use f 0 f int-rep } T{ vreg-use f 2 f int-rep } } }
{ reg-class int-regs }
{ spill-to T{ spill-slot f 32 } }
{ spill-rep int-rep }
}
T{ live-interval
{ vreg 8 }
{ start 14 }
{ end 16 }
{ ranges V{ T{ live-range f 14 16 } } }
{ uses V{ T{ vreg-use f 14 f int-rep } } }
{ reg-class int-regs }
{ reload-from T{ spill-slot f 32 } }
{ reload-rep int-rep }
}
] [
T{ live-interval
{ vreg 8 }
{ start 0 }
{ end 16 }
{ ranges V{ T{ live-range f 0 4 } T{ live-range f 6 10 } T{ live-range f 12 16 } } }
{ uses V{ T{ vreg-use f 0 f int-rep } T{ vreg-use f 2 f int-rep } T{ vreg-use f 14 f int-rep } } }
{ reg-class int-regs }
} 8 split-for-spill
clean-up-split
] unit-test
H{

11
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make locals
USING: kernel accessors assocs sequences namespaces make locals
cpu.architecture
compiler.cfg
compiler.cfg.rpo
@ -37,5 +37,12 @@ IN: compiler.cfg.linear-scan
cfg resolve-data-flow
cfg check-numbering ;
: admissible-registers ( cfg -- regs )
[ machine-registers ] dip
frame-pointer?>> [
[ int-regs ] dip [ clone ] map
[ [ [ frame-reg ] dip remove ] change-at ] keep
] when ;
: linear-scan ( cfg -- cfg' )
dup machine-registers (linear-scan) ;
dup dup admissible-registers (linear-scan) ;

13
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -134,7 +134,7 @@ M: vreg-insn compute-live-intervals* ( insn -- )
] if ;
! A location where all registers have to be spilled
TUPLE: sync-point n ;
TUPLE: sync-point n keep-dst? ;
C: <sync-point> sync-point
@ -143,8 +143,11 @@ SYMBOL: sync-points
GENERIC: compute-sync-points* ( insn -- )
M: hairy-clobber-insn compute-sync-points*
insn#>> f <sync-point> sync-points get push ;
M: clobber-insn compute-sync-points*
insn#>> <sync-point> sync-points get push ;
insn#>> t <sync-point> sync-points get push ;
M: insn compute-sync-points* drop ;
@ -165,7 +168,7 @@ M: insn compute-sync-points* drop ;
: init-live-intervals ( -- )
H{ } clone live-intervals set
V{ } clone sync-points set ;
: compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi
[ >>start ] [ >>end ] bi* drop ;
@ -180,8 +183,8 @@ ERROR: bad-live-interval live-interval ;
! to reverse some sequences, and compute the start and end.
values dup [
{
[ ranges>> reverse! drop ]
[ uses>> reverse! drop ]
[ [ { } like reverse! ] change-ranges drop ]
[ [ { } like reverse! ] change-uses drop ]
[ compute-start/end ]
[ check-start ]
} cleave

7
basis/compiler/cfg/linear-scan/numbering/numbering.factor
View File

@ -4,13 +4,8 @@ USING: kernel accessors math sequences grouping namespaces
compiler.cfg.linearization ;
IN: compiler.cfg.linear-scan.numbering
ERROR: already-numbered insn ;
: number-instruction ( n insn -- n' )
[ nip dup insn#>> [ already-numbered ] [ drop ] if ]
[ insn#<< ]
[ drop 2 + ]
2tri ;
[ insn#<< ] [ drop 2 + ] 2bi ;
: number-instructions ( cfg -- )
linearization-order

24
basis/compiler/cfg/representations/peephole/peephole.factor
View File

@ -211,24 +211,48 @@ M: ##compare-integer-imm optimize-insn
[ call-next-method ]
} cond ;
M: ##test-imm optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged-bitwise? ] } 1&& ] [ >tagged-imm ] }
[ call-next-method ]
} cond ;
M: ##compare-integer-imm-branch optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
[ call-next-method ]
} cond ;
M: ##test-imm-branch optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged-bitwise? ] } 1&& ] [ >tagged-imm ] }
[ call-next-method ]
} cond ;
M: ##compare-integer optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
[ call-next-method ]
} cond ;
M: ##test optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
[ call-next-method ]
} cond ;
M: ##compare-integer-branch optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
[ call-next-method ]
} cond ;
M: ##test-branch optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
[ call-next-method ]
} cond ;
! Identities:
! tag(neg(untag(x))) = x
! tag(neg(x)) = x * -2^tag-bits

7
basis/compiler/cfg/representations/preferred/preferred.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays fry namespaces generic
words sets combinators generalizations cpu.architecture compiler.units
compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
compiler.cfg.instructions compiler.cfg.def-use ;
words sets combinators generalizations sequences.generalizations
cpu.architecture compiler.units compiler.cfg.utilities
compiler.cfg compiler.cfg.rpo compiler.cfg.instructions
compiler.cfg.def-use ;
FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ;
FROM: namespaces => set ;
IN: compiler.cfg.representations.preferred

46
basis/compiler/cfg/representations/representations-tests.factor
View File

@ -632,7 +632,23 @@ cpu x86.64? [
} test-peephole
] unit-test
! Tag/untag elimination for ##compare-integer
! Tag/untag elimination for ##compare-integer and ##test
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##test f 2 0 1 cc= }
T{ ##replace f 2 D 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##test f 2 0 1 cc= }
T{ ##replace f 2 D 0 }
} test-peephole
] unit-test
[
V{
T{ ##peek f 0 D 0 }
@ -663,6 +679,20 @@ cpu x86.64? [
} test-peephole
] unit-test
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##test-branch f 0 1 cc= }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##test-branch f 0 1 cc= }
} test-peephole
] unit-test
[
V{
T{ ##peek f 0 D 0 }
@ -677,6 +707,20 @@ cpu x86.64? [
} test-peephole
] unit-test
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##test-imm-branch f 0 $[ 10 tag-fixnum ] cc= }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##test-imm-branch f 0 10 cc= }
} test-peephole
] unit-test
! Tag/untag elimination for ##neg
[
V{

12
basis/compiler/cfg/representations/rewrite/rewrite.factor
View File

@ -89,15 +89,13 @@ M: ##copy conversions-for-insn , ;
M: insn conversions-for-insn , ;
: conversions-for-block ( bb -- )
: conversions-for-block ( insns -- insns )
[
[
alternatives get clear-assoc
[ conversions-for-insn ] each
] V{ } make
] change-instructions drop ;
alternatives get clear-assoc
[ conversions-for-insn ] each
] V{ } make ;
: insert-conversions ( cfg -- )
H{ } clone alternatives set
V{ } clone renaming-set set
[ conversions-for-block ] each-basic-block ;
[ conversions-for-block ] simple-optimization ;

4
basis/compiler/cfg/representations/selection/selection.factor
View File

@ -123,6 +123,10 @@ M: ##compare-integer-imm has-peephole-opts? drop t ;
M: ##compare-integer has-peephole-opts? drop t ;
M: ##compare-integer-imm-branch has-peephole-opts? drop t ;
M: ##compare-integer-branch has-peephole-opts? drop t ;
M: ##test-imm has-peephole-opts? drop t ;
M: ##test has-peephole-opts? drop t ;
M: ##test-imm-branch has-peephole-opts? drop t ;
M: ##test-branch has-peephole-opts? drop t ;
GENERIC: compute-insn-costs ( insn -- )

8
basis/compiler/cfg/rpo/rpo.factor
View File

@ -44,5 +44,13 @@ SYMBOL: visited
: simple-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... )
'[ _ optimize-basic-block ] each-basic-block ; inline
: analyze-basic-block ( bb quot -- )
over kill-block?>> [ 2drop ] [
[ dup basic-block set instructions>> ] dip call
] if ; inline
: simple-analysis ( ... cfg quot: ( ... insns -- ... ) -- ... )
'[ _ analyze-basic-block ] each-basic-block ; inline
: needs-post-order ( cfg -- cfg' )
dup post-order drop ;

13
basis/compiler/cfg/ssa/construction/construction.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel accessors sequences fry assocs
sets math combinators
@ -42,10 +42,9 @@ SYMBOL: defs-multi
H{ } clone defs set
H{ } clone defs-multi set
[
dup instructions>> [
compute-insn-defs
] with each
] each-basic-block ;
[ basic-block get ] dip
[ compute-insn-defs ] with each
] simple-analysis ;
! Maps basic blocks to sequences of vregs
SYMBOL: inserting-phi-nodes
@ -88,7 +87,9 @@ RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ]
GENERIC: rename-insn ( insn -- )
M: insn rename-insn
M: insn rename-insn drop ;
M: vreg-insn rename-insn
[ ssa-rename-insn-uses ]
[ ssa-rename-insn-defs ]
bi ;

64
basis/compiler/cfg/ssa/destruction/destruction.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry kernel namespaces
USING: accessors arrays assocs fry locals kernel namespaces
sequences sequences.deep
sets vectors
cpu.architecture
@ -46,56 +46,62 @@ SYMBOL: class-element-map
! Sequence of vreg pairs
SYMBOL: copies
: value-of ( vreg -- value )
insn-of dup ##tagged>integer? [ src>> ] [ dst>> ] if ;
: init-coalescing ( -- )
defs get keys
[ [ dup ] H{ } map>assoc leader-map set ]
[ [ dup 1vector ] H{ } map>assoc class-element-map set ] bi
defs get
[ [ drop dup ] assoc-map leader-map set ]
[ [ [ dup dup value-of ] dip <vreg-info> 1array ] assoc-map class-element-map set ] bi
V{ } clone copies set ;
: classes-interfere? ( vreg1 vreg2 -- ? )
[ leader ] bi@ 2dup eq? [ 2drop f ] [
[ class-elements flatten ] bi@ sets-interfere?
] if ;
: update-leaders ( vreg1 vreg2 -- )
: coalesce-leaders ( vreg1 vreg2 -- )
! leader2 becomes the leader.
swap leader-map get set-at ;
: merge-classes ( vreg1 vreg2 -- )
[ [ class-elements ] bi@ push ]
[ drop class-element-map get delete-at ] 2bi ;
: coalesce-elements ( merged vreg1 vreg2 -- )
! delete leader1's class, and set leader2's class to merged.
class-element-map get [ delete-at ] [ set-at ] bi-curry bi* ;
: eliminate-copy ( vreg1 vreg2 -- )
[ leader ] bi@
2dup eq? [ 2drop ] [
[ update-leaders ]
[ merge-classes ]
2bi
] if ;
: coalesce-vregs ( merged leader1 leader2 -- )
[ coalesce-leaders ] [ coalesce-elements ] 2bi ;
:: maybe-eliminate-copy ( vreg1 vreg2 -- )
! Eliminate a copy of possible.
vreg1 leader :> vreg1
vreg2 leader :> vreg2
vreg1 vreg2 eq? [
vreg1 class-elements vreg2 class-elements sets-interfere?
[ drop ] [ vreg1 vreg2 coalesce-vregs ] if
] unless ;
GENERIC: prepare-insn ( insn -- )
: try-to-coalesce ( dst src -- ) 2array copies get push ;
: maybe-eliminate-copy-later ( dst src -- )
2array copies get push ;
M: insn prepare-insn
M: insn prepare-insn drop ;
M: vreg-insn prepare-insn
[ temp-vregs [ leader-map get conjoin ] each ]
[
[ defs-vreg ] [ uses-vregs ] bi
2dup empty? not and [
first
2dup [ rep-of reg-class-of ] bi@ eq?
[ try-to-coalesce ] [ 2drop ] if
[ maybe-eliminate-copy-later ] [ 2drop ] if
] [ 2drop ] if
] bi ;
M: ##copy prepare-insn
[ dst>> ] [ src>> ] bi try-to-coalesce ;
[ dst>> ] [ src>> ] bi maybe-eliminate-copy-later ;
M: ##tagged>integer prepare-insn
[ dst>> ] [ src>> ] bi eliminate-copy ;
[ dst>> ] [ src>> ] bi maybe-eliminate-copy ;
M: ##phi prepare-insn
[ dst>> ] [ inputs>> values ] bi
[ eliminate-copy ] with each ;
[ maybe-eliminate-copy ] with each ;
: prepare-block ( bb -- )
instructions>> [ prepare-insn ] each ;
@ -105,10 +111,7 @@ M: ##phi prepare-insn
[ prepare-block ] each-basic-block ;
: process-copies ( -- )
copies get [
2dup classes-interfere?
[ 2drop ] [ eliminate-copy ] if
] assoc-each ;
copies get [ maybe-eliminate-copy ] assoc-each ;
GENERIC: useful-insn? ( insn -- ? )
@ -133,6 +136,7 @@ PRIVATE>
dup construct-cssa
dup compute-defs
dup compute-insns
dup compute-ssa-live-sets
dup compute-live-ranges
dup prepare-coalescing

345
basis/compiler/cfg/ssa/interference/interference-tests.factor
View File

@ -2,17 +2,35 @@ USING: accessors compiler.cfg compiler.cfg.debugger
compiler.cfg.def-use compiler.cfg.dominance
compiler.cfg.instructions compiler.cfg.liveness.ssa
compiler.cfg.registers compiler.cfg.predecessors
compiler.cfg.ssa.interference
compiler.cfg.ssa.interference.live-ranges cpu.architecture
kernel namespaces tools.test ;
compiler.cfg.comparisons compiler.cfg.ssa.interference
compiler.cfg.ssa.interference.private
compiler.cfg.ssa.interference.live-ranges
cpu.architecture kernel namespaces tools.test alien.c-types
arrays sequences slots ;
IN: compiler.cfg.ssa.interference.tests
: test-interference ( -- )
cfg new 0 get >>entry
dup compute-ssa-live-sets
dup compute-defs
dup compute-insns
compute-live-ranges ;
: <test-vreg-info> ( vreg -- info )
[ ] [ insn-of dup ##tagged>integer? [ src>> ] [ dst>> ] if ] [ def-of ] tri
<vreg-info> ;
: test-vregs-intersect? ( vreg1 vreg2 -- ? )
[ <test-vreg-info> ] bi@ vregs-intersect? ;
: test-vregs-interfere? ( vreg1 vreg2 -- ? )
[ <test-vreg-info> ] bi@
[ blue >>color ] [ red >>color ] bi*
vregs-interfere? ;
: test-sets-interfere? ( seq1 seq2 -- merged ? )
[ [ <test-vreg-info> ] map ] bi@ sets-interfere? ;
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 2 D 0 }
@ -34,17 +52,310 @@ V{
[ ] [ test-interference ] unit-test
[ f ] [ 0 1 vregs-interfere? ] unit-test
[ f ] [ 1 0 vregs-interfere? ] unit-test
[ f ] [ 2 3 vregs-interfere? ] unit-test
[ f ] [ 3 2 vregs-interfere? ] unit-test
[ t ] [ 0 2 vregs-interfere? ] unit-test
[ t ] [ 2 0 vregs-interfere? ] unit-test
[ f ] [ 1 3 vregs-interfere? ] unit-test
[ f ] [ 3 1 vregs-interfere? ] unit-test
[ t ] [ 3 4 vregs-interfere? ] unit-test
[ t ] [ 4 3 vregs-interfere? ] unit-test
[ t ] [ 3 5 vregs-interfere? ] unit-test
[ t ] [ 5 3 vregs-interfere? ] unit-test
[ f ] [ 3 6 vregs-interfere? ] unit-test
[ f ] [ 6 3 vregs-interfere? ] unit-test
[ f ] [ 0 1 test-vregs-intersect? ] unit-test
[ f ] [ 1 0 test-vregs-intersect? ] unit-test
[ f ] [ 2 3 test-vregs-intersect? ] unit-test
[ f ] [ 3 2 test-vregs-intersect? ] unit-test
[ t ] [ 0 2 test-vregs-intersect? ] unit-test
[ t ] [ 2 0 test-vregs-intersect? ] unit-test
[ f ] [ 1 3 test-vregs-intersect? ] unit-test
[ f ] [ 3 1 test-vregs-intersect? ] unit-test
[ t ] [ 3 4 test-vregs-intersect? ] unit-test
[ t ] [ 4 3 test-vregs-intersect? ] unit-test
[ t ] [ 3 5 test-vregs-intersect? ] unit-test
[ t ] [ 5 3 test-vregs-intersect? ] unit-test
[ f ] [ 3 6 test-vregs-intersect? ] unit-test
[ f ] [ 6 3 test-vregs-intersect? ] unit-test
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##inc-d f -3 }
T{ ##peek f 12 D -2 }
T{ ##peek f 23 D -1 }
T{ ##sar-imm f 13 23 4 }
T{ ##peek f 24 D -3 }
T{ ##sar-imm f 14 24 4 }
T{ ##mul f 15 13 13 }
T{ ##mul f 16 15 15 }
T{ ##tagged>integer f 17 12 }
T{ ##store-memory f 16 17 14 0 7 int-rep uchar }
T{ ##branch }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 2 test-bb
0 1 edge
1 2 edge
[ ] [ test-interference ] unit-test
[ t ] [ { 15 } { 23 13 } test-sets-interfere? nip ] unit-test
V{
T{ ##prologue f }
T{ ##branch f }
} 0 test-bb
V{
T{ ##inc-d f 2 }
T{ ##peek f 32 D 2 }
T{ ##load-reference f 33 ##check-nursery-branch }
T{ ##load-integer f 34 11 }
T{ ##tagged>integer f 35 32 }
T{ ##and-imm f 36 35 15 }
T{ ##compare-integer-imm-branch f 36 7 cc= }
} 1 test-bb
V{
T{ ##slot-imm f 48 32 1 7 }
T{ ##slot-imm f 50 48 1 2 }
T{ ##sar-imm f 65 50 4 }
T{ ##compare-integer-branch f 34 65 cc<= }
} 2 test-bb
V{
T{ ##inc-d f -2 }
T{ ##slot-imm f 57 48 11 2 }
T{ ##compare f 58 33 57 cc= 20 }
T{ ##replace f 58 D 0 }
T{ ##branch f }
} 3 test-bb
V{
T{ ##epilogue f }
T{ ##return f }
} 4 test-bb
V{
T{ ##inc-d f -2 }
T{ ##replace-imm f f D 0 }
T{ ##branch f }
} 5 test-bb
V{
T{ ##epilogue f }
T{ ##return f }
} 6 test-bb
V{
T{ ##inc-d f -2 }
T{ ##replace-imm f f D 0 }
T{ ##branch f }
} 7 test-bb
V{
T{ ##epilogue f }
T{ ##return f }
} 8 test-bb
0 1 edge
1 { 2 7 } edges
2 { 3 5 } edges
3 4 edge
5 6 edge
7 8 edge
[ ] [ test-interference ] unit-test
[ f ] [ { 48 } { 32 35 } test-sets-interfere? nip ] unit-test
TUPLE: bab ;
TUPLE: gfg { x bab } ;
: bah ( -- x ) f ;
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##check-nursery-branch f 16 cc<= 75 76 }
} 1 test-bb
V{
T{ ##save-context f 77 78 }
T{ ##call-gc f { } }
T{ ##branch }
} 2 test-bb
V{
T{ ##inc-d f 1 }
T{ ##load-reference f 37 T{ bab } }
T{ ##load-reference f 38 { gfg 1 1 tuple 57438726 gfg 7785907 } }
T{ ##allot f 40 12 tuple 4 }
T{ ##set-slot-imm f 38 40 1 7 }
T{ ##set-slot-imm f 37 40 2 7 }
T{ ##replace f 40 D 0 }
T{ ##branch }
} 3 test-bb
V{
T{ ##call f bah }
T{ ##branch }
} 4 test-bb
V{
T{ ##inc-r f 1 }
T{ ##inc-d f 1 }
T{ ##peek f 43 D 1 }
T{ ##peek f 44 D 2 }
T{ ##tagged>integer f 45 43 }
T{ ##and-imm f 46 45 15 }
T{ ##compare-integer-imm-branch f 46 7 cc= }
} 5 test-bb
V{
T{ ##inc-d f -1 }
T{ ##slot-imm f 58 43 1 7 }
T{ ##slot-imm f 60 58 7 2 }
T{ ##compare-imm-branch f 60 bab cc= }
} 6 test-bb
V{
T{ ##branch }
} 7 test-bb
V{
T{ ##inc-r f -1 }
T{ ##inc-d f -1 }
T{ ##set-slot-imm f 43 44 2 7 }
T{ ##write-barrier-imm f 44 2 7 34 35 }
T{ ##branch }
} 8 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 9 test-bb
V{
T{ ##inc-d f 1 }
T{ ##replace f 44 R 0 }
T{ ##replace-imm f bab D 0 }
T{ ##branch }
} 10 test-bb
V{
T{ ##call f bad-slot-value }
T{ ##branch }
} 11 test-bb
V{
T{ ##no-tco }
} 12 test-bb
V{
T{ ##inc-d f -1 }
T{ ##branch }
} 13 test-bb
V{
T{ ##inc-d f 1 }
T{ ##replace f 44 R 0 }
T{ ##replace-imm f bab D 0 }
T{ ##branch }
} 14 test-bb
V{
T{ ##call f bad-slot-value }
T{ ##branch }
} 15 test-bb
V{
T{ ##no-tco }
} 16 test-bb
0 1 edge
1 { 3 2 } edges
2 3 edge
3 4 edge
4 5 edge
5 { 6 13 } edges
6 { 7 10 } edges
7 8 edge
8 9 edge
10 11 edge
11 12 edge
13 14 edge
14 15 edge
15 16 edge
[ ] [ test-interference ] unit-test
[ t ] [ 43 45 test-vregs-intersect? ] unit-test
[ f ] [ 43 45 test-vregs-interfere? ] unit-test
[ t ] [ 43 46 test-vregs-intersect? ] unit-test
[ t ] [ 43 46 test-vregs-interfere? ] unit-test
[ f ] [ 45 46 test-vregs-intersect? ] unit-test
[ f ] [ 45 46 test-vregs-interfere? ] unit-test
[ f ] [ { 43 } { 45 } test-sets-interfere? nip ] unit-test
[ t f ] [
{ 46 } { 43 } { 45 }
[ [ <test-vreg-info> ] map ] tri@
sets-interfere? [ sets-interfere? nip ] dip
] unit-test
V{
T{ ##prologue f }
T{ ##branch f }
} 0 test-bb
V{
T{ ##inc-d f 1 }
T{ ##peek f 31 D 1 }
T{ ##sar-imm f 16 31 4 }
T{ ##load-integer f 17 0 }
T{ ##copy f 33 17 int-rep }
T{ ##branch f }
} 1 test-bb
V{
T{ ##phi f 21 H{ { 1 33 } { 3 32 } } }
T{ ##compare-integer-branch f 21 16 cc< }
} 2 test-bb
V{
T{ ##add-imm f 27 21 1 }
T{ ##copy f 32 27 int-rep }
T{ ##branch f }
} 3 test-bb
V{
T{ ##inc-d f -2 }
T{ ##branch f }
} 4 test-bb
V{
T{ ##epilogue f }
T{ ##return f }
} 5 test-bb
0 1 edge
1 2 edge
2 { 3 4 } edges
3 2 edge
4 5 edge
[ ] [ test-interference ] unit-test
[ f f ] [
{ 33 } { 21 } { 32 }
[ [ <test-vreg-info> ] map ] tri@
sets-interfere? [ sets-interfere? nip ] dip
] unit-test
[ f ] [ 33 21 test-vregs-intersect? ] unit-test
[ f ] [ 32 21 test-vregs-intersect? ] unit-test
[ f ] [ 32 33 test-vregs-intersect? ] unit-test

199
basis/compiler/cfg/ssa/interference/interference.factor
View File

@ -1,92 +1,175 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.short-circuit fry
kernel math math.order sorting namespaces sequences locals
compiler.cfg.def-use compiler.cfg.dominance
compiler.cfg.ssa.interference.live-ranges ;
USING: accessors arrays assocs combinators
combinators.short-circuit fry kernel math math.order sorting
sorting.slots namespaces sequences locals compiler.cfg.def-use
compiler.cfg.dominance compiler.cfg.ssa.interference.live-ranges ;
IN: compiler.cfg.ssa.interference
! Interference testing using SSA properties. Actually the only SSA property
! used here is that definitions dominate uses; because of this, the input
! is allowed to have multiple definitions of each vreg as long as they're
! all in the same basic block. This is needed because two-operand conversion
! runs before coalescing, which uses SSA interference testing.
! Interference testing using SSA properties.
!
! Based on:
!
! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency
! http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf
TUPLE: vreg-info vreg value def-index bb pre-of color equal-anc-in equal-anc-out ;
:: <vreg-info> ( vreg value bb -- info )
vreg-info new
vreg >>vreg
bb >>bb
value >>value
bb pre-of >>pre-of
vreg bb def-index >>def-index ;
<PRIVATE
:: kill-after-def? ( vreg1 vreg2 bb -- ? )
! Our dominance pass computes dominance information on a
! per-basic block level. Rig up a more fine-grained dominance
! test here.
: locally-dominates? ( vreg1 vreg2 -- ? )
[ def-index>> ] bi@ < ;
:: vreg-dominates? ( vreg1 vreg2 -- ? )
vreg1 bb>> :> bb1
vreg2 bb>> :> bb2
bb1 bb2 eq?
[ vreg1 vreg2 locally-dominates? ] [ bb1 bb2 dominates? ] if ;
! Testing individual vregs for live range intersection.
: kill-after-def? ( vreg1 vreg2 bb -- ? )
! If first register is used after second one is defined, they interfere.
! If they are used in the same instruction, no interference. If the
! instruction is a def-is-use-insn, then there will be a use at +1
! (instructions are 2 apart) and so outputs will interfere with
! inputs.
vreg1 bb kill-index
vreg2 bb def-index > ;
[ kill-index ] [ def-index ] bi-curry bi* > ;
:: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? )
! If both are defined in the same basic block, they interfere if their
! local live ranges intersect.
vreg1 bb1 def-index
vreg2 bb1 def-index <
[ vreg1 vreg2 ] [ vreg2 vreg1 ] if
bb1 kill-after-def? ;
: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
: interferes-first-dominates? ( vreg1 vreg2 -- ? )
! If vreg1 dominates vreg2, then they interfere if vreg2's definition
! occurs before vreg1 is killed.
nip
kill-after-def? ;
[ [ vreg>> ] bi@ ] [ nip bb>> ] 2bi kill-after-def? ;
: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
: interferes-second-dominates? ( vreg1 vreg2 -- ? )
! If vreg2 dominates vreg1, then they interfere if vreg1's definition
! occurs before vreg2 is killed.
drop
swapd kill-after-def? ;
swap interferes-first-dominates? ;
PRIVATE>
: interferes-same-block? ( vreg1 vreg2 -- ? )
! If both are defined in the same basic block, they interfere if their
! local live ranges intersect.
2dup locally-dominates? [ swap ] unless
interferes-first-dominates? ;
: vregs-interfere? ( vreg1 vreg2 -- ? )
2dup [ def-of ] bi@ {
{ [ 2dup eq? ] [ interferes-same-block? ] }
{ [ 2dup dominates? ] [ interferes-first-dominates? ] }
{ [ 2dup swap dominates? ] [ interferes-second-dominates? ] }
[ 2drop 2drop f ]
:: vregs-intersect? ( vreg1 vreg2 -- ? )
vreg1 bb>> :> bb1
vreg2 bb>> :> bb2
{
{ [ bb1 bb2 eq? ] [ vreg1 vreg2 interferes-same-block? ] }
{ [ bb1 bb2 dominates? ] [ vreg1 vreg2 interferes-first-dominates? ] }
{ [ bb2 bb1 dominates? ] [ vreg1 vreg2 interferes-second-dominates? ] }
[ f ]
} cond ;
<PRIVATE
! Value-based interference test.
: chain-intersect ( vreg1 vreg2 -- vreg )
[ 2dup { [ nip ] [ vregs-intersect? not ] } 2&& ]
[ equal-anc-in>> ]
while nip ;
! Debug this stuff later
: update-equal-anc-out ( vreg1 vreg2 -- )
dupd chain-intersect >>equal-anc-out drop ;
: quadratic-test? ( seq1 seq2 -- ? ) [ length ] bi@ + 10 < ;
: same-sets? ( vreg1 vreg2 -- ? )
[ color>> ] bi@ eq? ;
: quadratic-test ( seq1 seq2 -- ? )
'[ _ [ vregs-interfere? ] with any? ] any? ;
: same-values? ( vreg1 vreg2 -- ? )
[ value>> ] bi@ eq? ;
: sort-vregs-by-bb ( vregs -- alist )
defs get
'[ dup _ at ] { } map>assoc
[ second pre-of ] sort-with ;
: vregs-interfere? ( vreg1 vreg2 -- ? )
[ f >>equal-anc-out ] dip
: ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline
2dup same-sets? [ equal-anc-out>> ] when
: find-parent ( dom current -- parent )
2dup same-values?
[ update-equal-anc-out f ] [ chain-intersect >boolean ] if ;
! Merging lists of vregs sorted by dominance.
M: vreg-info <=> ( vreg1 vreg2 -- <=> )
{ { pre-of>> <=> } { def-index>> <=> } } compare-slots ;
SYMBOLS: blue red ;
TUPLE: iterator seq n ;
: <iterator> ( seq -- iterator ) 0 iterator boa ; inline
: done? ( iterator -- ? ) [ seq>> length ] [ n>> ] bi = ; inline
: this ( iterator -- obj ) [ n>> ] [ seq>> ] bi nth ; inline
: ++ ( iterator -- ) [ 1 + ] change-n drop ; inline
: take ( iterator -- obj ) [ this ] [ ++ ] bi ; inline
: blue-smaller? ( blue red -- ? )
[ this ] bi@ before? ; inline
: take-blue? ( blue red -- ? )
{
[ nip done? ]
[
{
[ drop done? not ]
[ blue-smaller? ]
} 2&&
]
} 2|| ; inline
: merge-sets ( blue red -- seq )
[ <iterator> ] bi@
[ 2dup [ done? ] both? not ]
[
2dup take-blue?
[ over take blue >>color ]
[ dup take red >>color ]
if
] produce 2nip ;
: update-for-merge ( seq -- )
[
dup [ equal-anc-in>> ] [ equal-anc-out>> ] bi
2dup and [ [ vreg-dominates? ] most ] [ or ] if
>>equal-anc-in
drop
] each ;
! Linear-time live range intersection test in a merged set.
: find-parent ( dom current -- vreg )
over empty? [ 2drop f ] [
over last over dominates? [ drop last ] [
over pop* find-parent
] if
over last over vreg-dominates?
[ drop last ] [ over pop* find-parent ] if
] if ;
:: linear-test ( seq1 seq2 -- ? )
! Instead of sorting, SSA destruction should keep equivalence
! classes sorted by merging them on append
:: linear-interference-test ( seq -- ? )
V{ } clone :> dom
seq1 seq2 append sort-vregs-by-bb [| pair |
pair first :> current
dom current find-parent
dup [ current vregs-interfere? ] when
[ t ] [ current dom push f ] if
seq [| vreg |
dom vreg find-parent
{ [ ] [ vreg same-sets? not ] [ vreg swap vregs-interfere? ] } 1&&
[ t ] [ vreg dom push f ] if
] any? ;
: sets-interfere-1? ( seq1 seq2 -- merged/f ? )
[ first ] bi@
2dup before? [ swap ] unless
2dup same-values? [
2dup equal-anc-in<<
2array f
] [
2dup vregs-intersect?
[ 2drop f t ] [ 2array f ] if
] if ;
PRIVATE>
: sets-interfere? ( seq1 seq2 -- ? )
quadratic-test ;
: sets-interfere? ( seq1 seq2 -- merged/f ? )
2dup [ length 1 = ] both? [ sets-interfere-1? ] [
merge-sets dup linear-interference-test
[ drop f t ] [ dup update-for-merge f ] if
] if ;

29
basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel namespaces sequences math
arrays compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.liveness.ssa compiler.cfg.rpo compiler.cfg.dominance ;
compiler.cfg.liveness.ssa compiler.cfg.rpo
compiler.cfg.dominance compiler.cfg ;
IN: compiler.cfg.ssa.interference.live-ranges
! Live ranges for interference testing
@ -12,31 +13,35 @@ IN: compiler.cfg.ssa.interference.live-ranges
SYMBOLS: local-def-indices local-kill-indices ;
: record-def ( n insn -- )
! We allow multiple defs of a vreg as long as they're
! all in the same basic block
defs-vreg dup [
local-def-indices get 2dup key?
[ 3drop ] [ set-at ] if
] [ 2drop ] if ;
defs-vreg dup [ local-def-indices get set-at ] [ 2drop ] if ;
: record-uses ( n insn -- )
! Record live intervals so that all but the first input interfere
! with the output. This lets us coalesce the output with the
! first input.
[ uses-vregs ] [ def-is-use-insn? ] bi over empty? [ 3drop ] [
dup uses-vregs dup empty? [ 3drop ] [
swap def-is-use-insn?
[ [ first local-kill-indices get set-at ] [ rest-slice ] 2bi ] unless
[ 1 + ] dip [ local-kill-indices get set-at ] with each
] if ;
: visit-insn ( insn n -- )
2 * swap [ record-def ] [ record-uses ] 2bi ;
GENERIC: record-insn ( n insn -- )
M: ##phi record-insn
record-def ;
M: vreg-insn record-insn
[ 2 * ] dip [ record-def ] [ record-uses ] 2bi ;
M: insn record-insn
2drop ;
SYMBOLS: def-indices kill-indices ;
: compute-local-live-ranges ( bb -- )
H{ } clone local-def-indices set
H{ } clone local-kill-indices set
[ instructions>> [ visit-insn ] each-index ]
[ instructions>> [ swap record-insn ] each-index ]
[ [ local-def-indices get ] dip def-indices get set-at ]
[ [ local-kill-indices get ] dip kill-indices get set-at ]
tri ;

37
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -1,39 +1,26 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order namespaces accessors kernel layouts
combinators combinators.smart assocs sequences cpu.architecture
combinators assocs sequences cpu.architecture
words compiler.cfg.instructions ;
IN: compiler.cfg.stack-frame
TUPLE: stack-frame
{ params integer }
{ return integer }
{ allot-area-size integer }
{ allot-area-align integer }
{ spill-area-size integer }
{ total-size integer }
{ calls-vm? boolean } ;
{ spill-area-align integer }
! Stack frame utilities
: param-base ( -- n )
stack-frame get [ params>> ] [ return>> ] bi + ;
{ total-size integer }
{ allot-area-base integer }
{ spill-area-base integer } ;
: local-allot-offset ( n -- offset )
stack-frame get allot-area-base>> + ;
: spill-offset ( n -- offset )
param-base + ;
stack-frame get spill-area-base>> + ;
: (stack-frame-size) ( stack-frame -- n )
[
[ params>> ] [ return>> ] [ spill-area-size>> ] tri
] sum-outputs ;
: max-stack-frame ( frame1 frame2 -- frame3 )
[ stack-frame new ] 2dip
{
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
[ [ spill-area-size>> ] bi@ max >>spill-area-size ]
[ [ calls-vm?>> ] bi@ or >>calls-vm? ]
} 2cleave ;
! PowerPC backend sets frame-required? for ##integer>float too
\ ##spill t "frame-required?" set-word-prop
\ ##unary-float-function t "frame-required?" set-word-prop
\ ##binary-float-function t "frame-required?" set-word-prop
[ spill-area-base>> ] [ spill-area-size>> ] bi + ;

111
basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
View File

@ -1,8 +1,11 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel math math.order namespaces
sequences vectors combinators.short-circuit compiler.cfg
compiler.cfg.comparisons compiler.cfg.instructions
sequences vectors combinators.short-circuit
cpu.architecture
compiler.cfg
compiler.cfg.comparisons
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.value-numbering.math
compiler.cfg.value-numbering.graph
@ -34,6 +37,23 @@ IN: compiler.cfg.value-numbering.comparisons
[ src1>> vreg>integer ] [ src2>> ] [ cc>> ] tri
[ <=> ] dip evaluate-cc ;
: fold-test-imm? ( insn -- ? )
src1>> vreg>insn ##load-integer? ;
: evaluate-test-imm ( insn -- ? )
[ src1>> vreg>integer ] [ src2>> ] [ cc>> ] tri
[ bitand ] dip {
{ cc= [ 0 = ] }
{ cc/= [ 0 = not ] }
} case ;
: rewrite-into-test? ( insn -- ? )
{
[ drop test-instruction? ]
[ cc>> { cc= cc/= } member-eq? ]
[ src2>> 0 = ]
} 1&& ;
: >compare< ( insn -- in1 in2 cc )
[ src1>> ] [ src2>> ] [ cc>> ] tri ; inline
@ -50,6 +70,8 @@ UNION: scalar-compare-insn
##compare-imm
##compare-integer
##compare-integer-imm
##test
##test-imm
##compare-float-unordered
##compare-float-ordered ;
@ -68,6 +90,8 @@ UNION: general-compare-insn scalar-compare-insn ##test-vector ;
{ [ dup ##compare-imm? ] [ >compare< \ ##compare-imm-branch new-insn ] }
{ [ dup ##compare-integer? ] [ >compare< \ ##compare-integer-branch new-insn ] }
{ [ dup ##compare-integer-imm? ] [ >compare< \ ##compare-integer-imm-branch new-insn ] }
{ [ dup ##test? ] [ >compare< \ ##test-branch new-insn ] }
{ [ dup ##test-imm? ] [ >compare< \ ##test-imm-branch new-insn ] }
{ [ dup ##compare-float-unordered? ] [ >compare< \ ##compare-float-unordered-branch new-insn ] }
{ [ dup ##compare-float-ordered? ] [ >compare< \ ##compare-float-ordered-branch new-insn ] }
{ [ dup ##test-vector? ] [ >test-vector< \ ##test-vector-branch new-insn ] }
@ -81,6 +105,9 @@ UNION: general-compare-insn scalar-compare-insn ##test-vector ;
: fold-compare-imm-branch ( insn -- insn/f )
evaluate-compare-imm fold-branch ;
: >test-branch ( insn -- insn )
[ src1>> ] [ src1>> ] [ cc>> ] tri \ ##test-branch new-insn ;
M: ##compare-imm-branch rewrite
{
{ [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
@ -94,6 +121,16 @@ M: ##compare-imm-branch rewrite
M: ##compare-integer-imm-branch rewrite
{
{ [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm-branch ] }
{ [ dup rewrite-into-test? ] [ >test-branch ] }
[ drop f ]
} cond ;
: fold-test-imm-branch ( insn -- insn/f )
evaluate-test-imm fold-branch ;
M: ##test-imm-branch rewrite
{
{ [ dup fold-test-imm? ] [ fold-test-imm-branch ] }
[ drop f ]
} cond ;
@ -184,6 +221,8 @@ M: ##compare-integer rewrite
{ [ dup ##compare-imm? ] [ >compare< next-vreg \ ##compare-imm new-insn ] }
{ [ dup ##compare-integer? ] [ >compare< next-vreg \ ##compare-integer new-insn ] }
{ [ dup ##compare-integer-imm? ] [ >compare< next-vreg \ ##compare-integer-imm new-insn ] }
{ [ dup ##test? ] [ >compare< next-vreg \ ##test new-insn ] }
{ [ dup ##test-imm? ] [ >compare< next-vreg \ ##test-imm new-insn ] }
{ [ dup ##compare-float-unordered? ] [ >compare< next-vreg \ ##compare-float-unordered new-insn ] }
{ [ dup ##compare-float-ordered? ] [ >compare< next-vreg \ ##compare-float-ordered new-insn ] }
} cond
@ -202,8 +241,76 @@ M: ##compare-imm rewrite
: fold-compare-integer-imm ( insn -- insn' )
dup evaluate-compare-integer-imm >boolean-insn ;
: >test ( insn -- insn' )
{ [ dst>> ] [ src1>> ] [ src1>> ] [ cc>> ] [ temp>> ] } cleave
\ ##test new-insn ;
M: ##compare-integer-imm rewrite
{
{ [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm ] }
{ [ dup rewrite-into-test? ] [ >test ] }
[ drop f ]
} cond ;
: (simplify-test) ( insn -- src1 src2 cc )
[ src1>> vreg>insn [ src1>> ] [ src2>> ] bi ] [ cc>> ] bi ; inline
: simplify-test ( insn -- insn )
dup (simplify-test) drop [ >>src1 ] [ >>src2 ] bi* ; inline
: simplify-test-branch ( insn -- insn )
dup (simplify-test) drop [ >>src1 ] [ >>src2 ] bi* ; inline
: (simplify-test-imm) ( insn -- src1 src2 cc )
[ src1>> vreg>insn [ src1>> ] [ src2>> ] bi ] [ cc>> ] bi ; inline
: simplify-test-imm ( insn -- insn )
[ dst>> ] [ (simplify-test-imm) ] [ temp>> ] tri \ ##test-imm new-insn ; inline
: simplify-test-imm-branch ( insn -- insn )
(simplify-test-imm) \ ##test-imm-branch new-insn ; inline
: >test-imm ( insn ? -- insn' )
(>compare-imm) [ vreg>integer ] dip next-vreg
\ ##test-imm new-insn ; inline
: >test-imm-branch ( insn ? -- insn' )
(>compare-imm-branch) [ vreg>integer ] dip
\ ##test-imm-branch new-insn ; inline
M: ##test rewrite
{
{ [ dup src1>> vreg-immediate-comparand? ] [ t >test-imm ] }
{ [ dup src2>> vreg-immediate-comparand? ] [ f >test-imm ] }
{ [ dup diagonal? ] [
{
{ [ dup src1>> vreg>insn ##and? ] [ simplify-test ] }
{ [ dup src1>> vreg>insn ##and-imm? ] [ simplify-test-imm ] }
[ drop f ]
} cond
] }
[ drop f ]
} cond ;
M: ##test-branch rewrite
{
{ [ dup src1>> vreg-immediate-comparand? ] [ t >test-imm-branch ] }
{ [ dup src2>> vreg-immediate-comparand? ] [ f >test-imm-branch ] }
{ [ dup diagonal? ] [
{
{ [ dup src1>> vreg>insn ##and? ] [ simplify-test-branch ] }
{ [ dup src1>> vreg>insn ##and-imm? ] [ simplify-test-imm-branch ] }
[ drop f ]
} cond
] }
[ drop f ]
} cond ;
: fold-test-imm ( insn -- insn' )
dup evaluate-test-imm >boolean-insn ;
M: ##test-imm rewrite
{
{ [ dup fold-test-imm? ] [ fold-test-imm ] }
[ drop f ]
} cond ;

64
basis/compiler/cfg/value-numbering/simd/simd.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
math.bitwise math.order classes
vectors locals make alien.c-types io.binary grouping
math.bitwise math.order classes generalizations
combinators.smart locals make alien.c-types io.binary grouping
math.vectors.simd.intrinsics
compiler.cfg
compiler.cfg.registers
@ -44,24 +44,72 @@ M: ##shuffle-vector-imm rewrite
[ 2drop f ]
} cond ;
: scalar-value ( literal-insn rep -- byte-array )
{
{ float-4-rep [ obj>> float>bits 4 >le ] }
{ double-2-rep [ obj>> double>bits 8 >le ] }
[ [ val>> ] [ rep-component-type heap-size ] bi* >le ]
} case ;
: (fold-scalar>vector) ( insn bytes -- insn' )
[ [ dst>> ] [ rep>> rep-length ] bi ] dip <repetition> concat
\ ##load-reference new-insn ;
: fold-scalar>vector ( outer inner -- insn' )
obj>> over rep>> {
{ float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
{ double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
[ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ]
} case ;
over rep>> scalar-value (fold-scalar>vector) ;
M: ##scalar>vector rewrite
dup src>> vreg>insn {
{ [ dup ##load-reference? ] [ fold-scalar>vector ] }
{ [ dup literal-insn? ] [ fold-scalar>vector ] }
{ [ dup ##vector>scalar? ] [ [ dst>> ] [ src>> ] bi* <copy> ] }
[ 2drop f ]
} cond ;
:: fold-gather-vector-2 ( insn src1 src2 -- insn )
insn dst>>
src1 src2 [ insn rep>> scalar-value ] bi@ append
\ ##load-reference new-insn ;
: rewrite-gather-vector-2 ( insn -- insn/f )
dup [ src1>> vreg>insn ] [ src2>> vreg>insn ] bi {
{ [ 2dup [ literal-insn? ] both? ] [ fold-gather-vector-2 ] }
[ 3drop f ]
} cond ;
M: ##gather-vector-2 rewrite rewrite-gather-vector-2 ;
M: ##gather-int-vector-2 rewrite rewrite-gather-vector-2 ;
:: fold-gather-vector-4 ( insn src1 src2 src3 src4 -- insn )
insn dst>>
[
src1 src2 src3 src4
[ insn rep>> scalar-value ] 4 napply
] B{ } append-outputs-as
\ ##load-reference new-insn ;
: rewrite-gather-vector-4 ( insn -- insn/f )
dup { [ src1>> ] [ src2>> ] [ src3>> ] [ src4>> ] } cleave [ vreg>insn ] 4 napply
{
{ [ 4 ndup [ literal-insn? ] 4 napply and and and ] [ fold-gather-vector-4 ] }
[ 5 ndrop f ]
} cond ;
M: ##gather-vector-4 rewrite rewrite-gather-vector-4 ;
M: ##gather-int-vector-4 rewrite rewrite-gather-vector-4 ;
: fold-shuffle-vector ( insn src1 src2 -- insn )
[ dst>> ] [ obj>> ] [ obj>> ] tri*
swap nths \ ##load-reference new-insn ;
M: ##shuffle-vector rewrite
dup [ src>> vreg>insn ] [ shuffle>> vreg>insn ] bi
{
{ [ 2dup [ ##load-reference? ] both? ] [ fold-shuffle-vector ] }
[ 3drop f ]
} cond ;
M: ##xor-vector rewrite
dup diagonal?
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;

386
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -18,6 +18,8 @@ IN: compiler.cfg.value-numbering.tests
[ ##compare-integer-imm? ]
[ ##compare-float-unordered? ]
[ ##compare-float-ordered? ]
[ ##test? ]
[ ##test-imm? ]
[ ##test-vector? ]
[ ##test-vector-branch? ]
} 1|| [ f >>temp ] when
@ -265,6 +267,36 @@ cpu x86.64? [
} value-numbering-step trim-temps
] unit-test
[
{
T{ ##peek f 29 D -1 }
T{ ##peek f 30 D -2 }
T{ ##test f 33 29 30 cc= }
T{ ##test-branch f 29 30 cc= }
}
] [
{
T{ ##peek f 29 D -1 }
T{ ##peek f 30 D -2 }
T{ ##test f 33 29 30 cc= }
T{ ##compare-imm-branch f 33 f cc/= }
} value-numbering-step trim-temps
] unit-test
[
{
T{ ##peek f 29 D -1 }
T{ ##test-imm f 33 29 30 cc= }
T{ ##test-imm-branch f 29 30 cc= }
}
] [
{
T{ ##peek f 29 D -1 }
T{ ##test-imm f 33 29 30 cc= }
T{ ##compare-imm-branch f 33 f cc/= }
} value-numbering-step trim-temps
] unit-test
[
{
T{ ##peek f 1 D -1 }
@ -995,6 +1027,262 @@ cpu x86.32? [
} value-numbering-step
] unit-test
[
{
T{ ##load-integer f 1 12 }
T{ ##load-reference f 3 t }
}
] [
{
T{ ##load-integer f 1 12 }
T{ ##test-imm f 3 1 13 cc/= }
} value-numbering-step
] unit-test
[
{
T{ ##load-integer f 1 15 }
T{ ##load-reference f 3 f }
}
] [
{
T{ ##load-integer f 1 15 }
T{ ##test-imm f 3 1 16 cc/= }
} value-numbering-step
] unit-test
[
{
T{ ##load-integer f 1 12 }
T{ ##load-reference f 3 f }
}
] [
{
T{ ##load-integer f 1 12 }
T{ ##test-imm f 3 1 13 cc= }
} value-numbering-step
] unit-test
[
{
T{ ##load-integer f 1 15 }
T{ ##load-reference f 3 t }
}
] [
{
T{ ##load-integer f 1 15 }
T{ ##test-imm f 3 1 16 cc= }
} value-numbering-step
] unit-test
! Rewriting a ##test of an ##and into a ##test
[
{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##and f 2 0 1 }
T{ ##test f 3 0 1 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##and f 2 0 1 }
T{ ##test f 3 2 2 cc= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##and-imm f 2 0 12 }
T{ ##test-imm f 3 0 12 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##and-imm f 2 0 12 }
T{ ##test f 3 2 2 cc= }
} value-numbering-step
] unit-test
! Rewriting ##test into ##test-imm
[
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 10 }
T{ ##test-imm f 2 0 10 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 10 }
T{ ##test f 2 0 1 cc= }
} value-numbering-step trim-temps
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 10 }
T{ ##test-imm f 2 0 10 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 10 }
T{ ##test f 2 1 0 cc= }
} value-numbering-step trim-temps
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 10 }
T{ ##test-imm-branch f 0 10 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 10 }
T{ ##test-branch f 0 1 cc= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 10 }
T{ ##test-imm-branch f 0 10 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 10 }
T{ ##test-branch f 1 0 cc= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 10 }
T{ ##test-imm-branch f 0 10 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 10 }
T{ ##test-branch f 1 0 cc= }
} value-numbering-step
] unit-test
! Make sure the immediate fits
cpu x86.64? [
[
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 100000000000 }
T{ ##test f 2 1 0 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 100000000000 }
T{ ##test f 2 1 0 cc= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 100000000000 }
T{ ##test-branch f 1 0 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-integer f 1 100000000000 }
T{ ##test-branch f 1 0 cc= }
} value-numbering-step
] unit-test
] when
! Rewriting ##compare into ##test
cpu x86? [
[
{
T{ ##peek f 0 D 0 }
T{ ##test f 1 0 0 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##compare-integer-imm f 1 0 0 cc= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##test f 1 0 0 cc/= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##compare-integer-imm f 1 0 0 cc/= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##compare-integer-imm f 1 0 0 cc<= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##compare-integer-imm f 1 0 0 cc<= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##test-branch f 0 0 cc= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##compare-integer-imm-branch f 0 0 cc= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##test-branch f 0 0 cc/= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##compare-integer-imm-branch f 0 0 cc/= }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##compare-integer-imm-branch f 0 0 cc<= }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##compare-integer-imm-branch f 0 0 cc<= }
} value-numbering-step
] unit-test
] when
! Reassociation
[
{
@ -2020,13 +2308,13 @@ cell 8 = [
[
{
T{ ##load-reference f 0 $[ 55 tag-fixnum ] }
T{ ##load-integer f 0 55 }
T{ ##load-reference f 1 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } }
T{ ##load-reference f 2 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } }
}
] [
{
T{ ##load-reference f 0 $[ 55 tag-fixnum ] }
T{ ##load-integer f 0 55 }
T{ ##scalar>vector f 1 0 int-4-rep }
T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep }
} value-numbering-step
@ -2046,6 +2334,100 @@ cell 8 = [
} value-numbering-step
] unit-test
[
{
T{ ##load-reference f 0 1.25 }
T{ ##load-reference f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
T{ ##load-reference f 2 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
}
] [
{
T{ ##load-reference f 0 1.25 }
T{ ##scalar>vector f 1 0 float-4-rep }
T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep }
} value-numbering-step
] unit-test
[
{
T{ ##load-integer f 0 55 }
T{ ##load-reference f 1 B{ 55 0 55 0 55 0 55 0 55 0 55 0 55 0 55 0 } }
T{ ##load-reference f 2 B{ 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 } }
T{ ##load-reference f 3 B{ 0 55 0 55 0 55 0 55 0 55 0 55 0 55 0 55 } }
}
] [
{
T{ ##load-integer f 0 55 }
T{ ##scalar>vector f 1 0 short-8-rep }
T{ ##load-reference f 2 B{ 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 } }
T{ ##shuffle-vector f 3 1 2 float-4-rep }
} value-numbering-step
] unit-test
[
{
T{ ##load-reference f 0 1.25 }
T{ ##load-reference f 2 3.75 }
T{ ##load-reference f 4 B{ 0 0 0 0 0 0 244 63 0 0 0 0 0 0 14 64 } }
}
] [
{
T{ ##load-reference f 0 1.25 }
T{ ##load-reference f 2 3.75 }
T{ ##gather-vector-2 f 4 0 2 double-2-rep }
} value-numbering-step
] unit-test
[
{
T{ ##load-integer f 0 125 }
T{ ##load-integer f 2 375 }
T{ ##load-reference f 4 B{ 125 0 0 0 0 0 0 0 119 1 0 0 0 0 0 0 } }
}
] [
{
T{ ##load-integer f 0 125 }
T{ ##load-integer f 2 375 }
T{ ##gather-vector-2 f 4 0 2 longlong-2-rep }
} value-numbering-step
] unit-test
[
{
T{ ##load-reference f 0 1.25 }
T{ ##load-reference f 1 2.50 }
T{ ##load-reference f 2 3.75 }
T{ ##load-reference f 3 5.00 }
T{ ##load-reference f 4 B{ 0 0 160 63 0 0 32 64 0 0 112 64 0 0 160 64 } }
}
] [
{
T{ ##load-reference f 0 1.25 }
T{ ##load-reference f 1 2.50 }
T{ ##load-reference f 2 3.75 }
T{ ##load-reference f 3 5.00 }
T{ ##gather-vector-4 f 4 0 1 2 3 float-4-rep }
} value-numbering-step
] unit-test
[
{
T{ ##load-integer f 0 125 }
T{ ##load-integer f 1 250 }
T{ ##load-integer f 2 375 }
T{ ##load-integer f 3 500 }
T{ ##load-reference f 4 B{ 125 0 0 0 250 0 0 0 119 1 0 0 244 1 0 0 } }
}
] [
{
T{ ##load-integer f 0 125 }
T{ ##load-integer f 1 250 }
T{ ##load-integer f 2 375 }
T{ ##load-integer f 3 500 }
T{ ##gather-vector-4 f 4 0 1 2 3 int-4-rep }
} value-numbering-step
] unit-test
[
{
T{ ##zero-vector f 2 float-4-rep }

22
basis/compiler/codegen/codegen.factor
View File

@ -162,6 +162,7 @@ CODEGEN: ##max %max
CODEGEN: ##not %not
CODEGEN: ##neg %neg
CODEGEN: ##log2 %log2
CODEGEN: ##bit-count %bit-count
CODEGEN: ##copy %copy
CODEGEN: ##tagged>integer %tagged>integer
CODEGEN: ##add-float %add-float
@ -181,7 +182,11 @@ CODEGEN: ##zero-vector %zero-vector
CODEGEN: ##fill-vector %fill-vector
CODEGEN: ##gather-vector-2 %gather-vector-2
CODEGEN: ##gather-vector-4 %gather-vector-4
CODEGEN: ##gather-int-vector-2 %gather-int-vector-2
CODEGEN: ##gather-int-vector-4 %gather-int-vector-4
CODEGEN: ##select-vector %select-vector
CODEGEN: ##shuffle-vector-imm %shuffle-vector-imm
CODEGEN: ##shuffle-vector-halves-imm %shuffle-vector-halves-imm
CODEGEN: ##shuffle-vector %shuffle-vector
CODEGEN: ##tail>head-vector %tail>head-vector
CODEGEN: ##merge-vector-head %merge-vector-head
@ -241,6 +246,8 @@ CODEGEN: ##write-barrier %write-barrier
CODEGEN: ##write-barrier-imm %write-barrier-imm
CODEGEN: ##compare %compare
CODEGEN: ##compare-imm %compare-imm
CODEGEN: ##test %test
CODEGEN: ##test-imm %test-imm
CODEGEN: ##compare-integer %compare
CODEGEN: ##compare-integer-imm %compare-integer-imm
CODEGEN: ##compare-float-ordered %compare-float-ordered
@ -267,6 +274,8 @@ CONDITIONAL: ##compare-branch %compare-branch
CONDITIONAL: ##compare-imm-branch %compare-imm-branch
CONDITIONAL: ##compare-integer-branch %compare-branch
CONDITIONAL: ##compare-integer-imm-branch %compare-integer-imm-branch
CONDITIONAL: ##test-branch %test-branch
CONDITIONAL: ##test-imm-branch %test-imm-branch
CONDITIONAL: ##compare-float-ordered-branch %compare-float-ordered-branch
CONDITIONAL: ##compare-float-unordered-branch %compare-float-unordered-branch
CONDITIONAL: ##test-vector-branch %test-vector-branch
@ -277,17 +286,16 @@ CONDITIONAL: ##fixnum-mul %fixnum-mul
! FFI
CODEGEN: ##unbox %unbox
CODEGEN: ##unbox-long-long %unbox-long-long
CODEGEN: ##store-reg-param %store-reg-param
CODEGEN: ##store-stack-param %store-stack-param
CODEGEN: ##store-return %store-return
CODEGEN: ##store-struct-return %store-struct-return
CODEGEN: ##store-long-long-return %store-long-long-return
CODEGEN: ##prepare-struct-area %prepare-struct-area
CODEGEN: ##load-reg-param %load-reg-param
CODEGEN: ##load-stack-param %load-stack-param
CODEGEN: ##local-allot %local-allot
CODEGEN: ##box %box
CODEGEN: ##box-long-long %box-long-long
CODEGEN: ##box-large-struct %box-large-struct
CODEGEN: ##box-small-struct %box-small-struct
CODEGEN: ##save-param-reg %save-param-reg
CODEGEN: ##allot-byte-array %allot-byte-array
CODEGEN: ##prepare-var-args %prepare-var-args
CODEGEN: ##alien-invoke %alien-invoke
CODEGEN: ##cleanup %cleanup
CODEGEN: ##alien-indirect %alien-indirect

22
basis/compiler/codegen/fixup/fixup.factor
View File

@ -3,7 +3,7 @@
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise math.order generalizations
system combinators math.bitwise math.order combinators.smart
accessors growable fry compiler.constants memoize ;
IN: compiler.codegen.fixup
@ -138,12 +138,14 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
: with-fixup ( quot -- code )
'[
init-fixup
@
emit-binary-literals
label-table [ compute-labels ] change
parameter-table get >array
literal-table get >array
relocation-table get >byte-array
label-table get
] B{ } make 5 narray ; inline
[
init-fixup
@
emit-binary-literals
label-table [ compute-labels ] change
parameter-table get >array
literal-table get >array
relocation-table get >byte-array
label-table get
] B{ } make
] output>array ; inline

36
basis/compiler/tests/alien.factor
View File

@ -5,12 +5,20 @@ io.backend io.pathnames io.streams.string kernel
math memory namespaces namespaces.private parser
quotations sequences specialized-arrays stack-checker
stack-checker.errors system threads tools.test words
alien.complex concurrency.promises ;
alien.complex concurrency.promises alien.data
byte-arrays classes ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
IN: compiler.tests.alien
! Make sure that invalid inputs don't pass the stack checker
[ [ void { } "cdecl" alien-indirect ] infer ] must-fail
[ [ "void" { } cdecl alien-indirect ] infer ] must-fail
[ [ void* 3 cdecl alien-indirect ] infer ] must-fail
[ [ void* { "int" } cdecl alien-indirect ] infer ] must-fail
[ [ void* { int } cdecl { } alien-callback ] infer ] must-fail
<<
: libfactor-ffi-tests-path ( -- string )
"resource:" absolute-path
@ -448,11 +456,11 @@ STRUCT: double-rect
void { void* void* double-rect } cdecl alien-indirect
"example" get-global ;
[ 1.0 2.0 3.0 4.0 ]
[ byte-array 1.0 2.0 3.0 4.0 ]
[
1.0 2.0 3.0 4.0 <double-rect>
double-rect-callback double-rect-test
>double-rect<
[ >c-ptr class ] [ >double-rect< ] bi
] unit-test
STRUCT: test_struct_14
@ -754,3 +762,25 @@ mingw? [
[ S{ test-struct-11 f 7 -3 } ]
[ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test
! Stack allocation
: blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ;
[ 3 ] [ blah ] unit-test
: out-param-test ( -- b )
{ int } [ [ 12 ] dip 0 int set-alien-value ] [ ] with-out-parameters ;
[ 12 ] [ out-param-test ] unit-test
: out-param-callback ( -- a )
void { int pointer: int } cdecl
[ [ 2 * ] dip 0 int set-alien-value ] alien-callback ;
: out-param-indirect ( a a -- b )
{ int } [
swap void { int pointer: int } cdecl
alien-indirect
] [ ] with-out-parameters ;
[ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test

25
basis/compiler/tests/float.factor
View File

@ -1,18 +1,14 @@
USING: compiler.units compiler.test kernel kernel.private memory
math math.private tools.test math.floats.private math.order fry
specialized-arrays sequences ;
specialized-arrays sequences math.functions layouts literals ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: c:float
SPECIALIZED-ARRAY: c:double
IN: compiler.tests.float
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-call ] unit-test
[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test
[ 3 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
[ $[ float type-number ] ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test
[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test
@ -85,6 +81,9 @@ IN: compiler.tests.float
[ t ] [ -0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test
[ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test
[ 313.0 ] [ 313 [ fixnum>float ] compile-call ] unit-test
[ -313 ] [ -313.5 [ float>fixnum ] compile-call ] unit-test
[ 313 ] [ 313.5 [ float>fixnum ] compile-call ] unit-test
[ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test
[ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test
@ -131,3 +130,15 @@ IN: compiler.tests.float
float-array{ 1.0 3.5 }
[ { float-array } declare [ 1 + ] map ] compile-call
] unit-test
[ t ] [
[ double-array{ 1.0 2.0 3.0 } 0.0 [ + ] reduce sqrt ] compile-call
2.44948 0.0001 ~
] unit-test
[ 7.5 3 ] [
[
double-array{ 1.0 2.0 3.0 }
1.5 [ + ] reduce dup 0.0 < [ 2 ] [ 3 ] if
] compile-call
] unit-test

6
basis/compiler/tests/low-level-ir.factor
View File

@ -93,9 +93,9 @@ IN: compiler.tests.low-level-ir
[ 31 ] [
V{
T{ ##load-reference f 1 B{ 31 67 52 } }
T{ ##unbox-any-c-ptr f 0 1 }
T{ ##load-memory-imm f 0 0 0 int-rep uchar }
T{ ##shl-imm f 0 0 4 }
T{ ##unbox-any-c-ptr f 2 1 }
T{ ##load-memory-imm f 3 2 0 int-rep uchar }
T{ ##shl-imm f 0 3 4 }
} compile-test-bb
] unit-test

5
basis/compiler/tests/spilling.factor
View File

@ -1,7 +1,9 @@
USING: math.private kernel combinators accessors arrays
generalizations tools.test words ;
generalizations sequences.generalizations tools.test words ;
IN: compiler.tests.spilling
! These tests are stupid and don't trigger spilling anymore
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{
[ dup float+ ]
@ -163,7 +165,6 @@ IN: compiler.tests.spilling
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
! The above don't really test spilling...
: spill-test-1 ( a -- b )
dup 1 fixnum+fast
dup 1 fixnum+fast

4
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -7,7 +7,7 @@ layouts words sequences sequences.private arrays assocs classes
classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private
slots.private definitions strings.private vectors hashtables
generic quotations alien
generic quotations alien alien.data alien.data.private
stack-checker.dependencies
compiler.tree.comparisons
compiler.tree.propagation.info
@ -338,3 +338,5 @@ flog fpow fsqrt facosh fasinh fatanh } [
\ fixnum-max { fixnum fixnum } "input-classes" set-word-prop
\ fixnum-max [ interval-max ] [ fixnum-valued ] binary-op
\ (local-allot) { alien } "default-output-classes" set-word-prop

1
basis/compiler/tree/propagation/simd/simd.factor
View File

@ -39,6 +39,7 @@ CONSTANT: vector>vector-intrinsics
(simd-hlshift)
(simd-hrshift)
(simd-vshuffle-elements)
(simd-vshuffle2-elements)
(simd-vshuffle-bytes)
(simd-vmerge-head)
(simd-vmerge-tail)

11
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -6,9 +6,10 @@ definitions stack-checker.dependencies quotations
classes.tuple.private math math.partial-dispatch math.private
math.intervals sets.private math.floats.private
math.integers.private layouts math.order vectors hashtables
combinators effects generalizations assocs sets
combinators.short-circuit sequences.private locals growable
stack-checker namespaces compiler.tree.propagation.info ;
combinators effects generalizations sequences.generalizations
assocs sets combinators.short-circuit sequences.private locals
growable stack-checker namespaces compiler.tree.propagation.info
;
FROM: math => float ;
FROM: sets => set ;
IN: compiler.tree.propagation.transforms
@ -309,9 +310,7 @@ M\ set intersect [ intersect-quot ] 1 define-partial-eval
! We want to constant-fold calls to heap-size, and recompile those
! calls when a C type is redefined
\ heap-size [
dup word? [
[ depends-on-definition ] [ heap-size '[ _ ] ] bi
] [ drop f ] if
[ depends-on-c-type ] [ heap-size '[ _ ] ] bi
] 1 define-partial-eval
! Eliminates a few redundant checks here and there

2
basis/concurrency/conditions/conditions.factor
View File

@ -28,7 +28,7 @@ ERROR: wait-timeout ;
: wait ( queue timeout status -- )
over [
[ queue-timeout ] dip suspend
[ wait-timeout ] [ cancel-alarm ] if
[ wait-timeout ] [ stop-alarm ] if
] [
[ drop queue ] dip suspend drop
] if ; inline

98
basis/cpu/architecture/architecture.factor
View File

@ -150,9 +150,6 @@ SINGLETONS: int-regs float-regs ;
UNION: reg-class int-regs float-regs ;
CONSTANT: reg-classes { int-regs float-regs }
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
! On x86, vectors and floats are stored in the same register bank
! On PowerPC they are distinct
HOOK: vector-regs cpu ( -- reg-class )
@ -165,7 +162,6 @@ M: float-rep reg-class-of drop float-regs ;
M: double-rep reg-class-of drop float-regs ;
M: vector-rep reg-class-of drop vector-regs ;
M: scalar-rep reg-class-of drop vector-regs ;
M: stack-params reg-class-of drop stack-params ;
GENERIC: rep-size ( rep -- n ) foldable
@ -173,7 +169,6 @@ M: tagged-rep rep-size drop cell ;
M: int-rep rep-size drop cell ;
M: float-rep rep-size drop 4 ;
M: double-rep rep-size drop 8 ;
M: stack-params rep-size drop cell ;
M: vector-rep rep-size drop 16 ;
M: char-scalar-rep rep-size drop 1 ;
M: uchar-scalar-rep rep-size drop 1 ;
@ -217,6 +212,14 @@ M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
! Callbacks are not allowed to clobber this
HOOK: frame-reg cpu ( -- reg )
! Parameter space to reserve in anything making VM calls
HOOK: vm-stack-space cpu ( -- n )
M: object vm-stack-space 0 ;
! Specifies if %slot, %set-slot and %write-barrier accept the
! 'scale' and 'tag' parameters, and if %load-memory and
! %store-memory work
@ -270,6 +273,7 @@ HOOK: %max cpu ( dst src1 src2 -- )
HOOK: %not cpu ( dst src -- )
HOOK: %neg cpu ( dst src -- )
HOOK: %log2 cpu ( dst src -- )
HOOK: %bit-count cpu ( dst src -- )
HOOK: %copy cpu ( dst src rep -- )
@ -292,15 +296,21 @@ HOOK: %binary-float-function cpu ( dst src1 src2 func -- )
HOOK: %single>double-float cpu ( dst src -- )
HOOK: %double>single-float cpu ( dst src -- )
HOOK: integer-float-needs-stack-frame? cpu ( -- ? )
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
HOOK: %zero-vector cpu ( dst rep -- )
HOOK: %fill-vector cpu ( dst rep -- )
HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
HOOK: %gather-int-vector-2 cpu ( dst src1 src2 rep -- )
HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
HOOK: %gather-int-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
HOOK: %select-vector cpu ( dst src n rep -- )
HOOK: %shuffle-vector cpu ( dst src shuffle rep -- )
HOOK: %shuffle-vector-imm cpu ( dst src shuffle rep -- )
HOOK: %shuffle-vector-halves-imm cpu ( dst src1 src2 shuffle rep -- )
HOOK: %tail>head-vector cpu ( dst src rep -- )
HOOK: %merge-vector-head cpu ( dst src1 src2 rep -- )
HOOK: %merge-vector-tail cpu ( dst src1 src2 rep -- )
@ -352,10 +362,14 @@ HOOK: %scalar>vector cpu ( dst src rep -- )
HOOK: %zero-vector-reps cpu ( -- reps )
HOOK: %fill-vector-reps cpu ( -- reps )
HOOK: %gather-vector-2-reps cpu ( -- reps )
HOOK: %gather-int-vector-2-reps cpu ( -- reps )
HOOK: %gather-vector-4-reps cpu ( -- reps )
HOOK: %gather-int-vector-4-reps cpu ( -- reps )
HOOK: %select-vector-reps cpu ( -- reps )
HOOK: %alien-vector-reps cpu ( -- reps )
HOOK: %shuffle-vector-reps cpu ( -- reps )
HOOK: %shuffle-vector-imm-reps cpu ( -- reps )
HOOK: %shuffle-vector-halves-imm-reps cpu ( -- reps )
HOOK: %merge-vector-reps cpu ( -- reps )
HOOK: %signed-pack-vector-reps cpu ( -- reps )
HOOK: %unsigned-pack-vector-reps cpu ( -- reps )
@ -400,10 +414,14 @@ HOOK: %horizontal-shr-vector-imm-reps cpu ( -- reps )
M: object %zero-vector-reps { } ;
M: object %fill-vector-reps { } ;
M: object %gather-vector-2-reps { } ;
M: object %gather-int-vector-2-reps { } ;
M: object %gather-vector-4-reps { } ;
M: object %gather-int-vector-4-reps { } ;
M: object %select-vector-reps { } ;
M: object %alien-vector-reps { } ;
M: object %shuffle-vector-reps { } ;
M: object %shuffle-vector-imm-reps { } ;
M: object %shuffle-vector-halves-imm-reps { } ;
M: object %merge-vector-reps { } ;
M: object %signed-pack-vector-reps { } ;
M: object %unsigned-pack-vector-reps { } ;
@ -472,15 +490,23 @@ HOOK: %call-gc cpu ( gc-roots -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
HOOK: %compare cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-integer-imm cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-float-ordered cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-float-unordered cpu ( dst temp cc src1 src2 -- )
HOOK: test-instruction? cpu ( -- ? )
M: object test-instruction? f ;
HOOK: %compare cpu ( dst src1 src2 cc temp -- )
HOOK: %compare-imm cpu ( dst src1 src2 cc temp -- )
HOOK: %compare-integer-imm cpu ( dst src1 src2 cc temp -- )
HOOK: %test cpu ( dst src1 src2 cc temp -- )
HOOK: %test-imm cpu ( dst src1 src2 cc temp -- )
HOOK: %compare-float-ordered cpu ( dst src1 src2 cc temp -- )
HOOK: %compare-float-unordered cpu ( dst src1 src2 cc temp -- )
HOOK: %compare-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-integer-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %test-branch cpu ( label cc src1 src2 -- )
HOOK: %test-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- )
@ -489,22 +515,6 @@ HOOK: %reload cpu ( dst rep src -- )
HOOK: %loop-entry cpu ( -- )
! FFI stuff
! Return values of this class go here
GENERIC: return-reg ( reg-class -- reg )
! Sequence of registers used for parameter passing in class
GENERIC# param-regs 1 ( reg-class abi -- regs )
M: stack-params param-regs 2drop f ;
GENERIC# param-reg 1 ( n reg-class abi -- reg )
M: reg-class param-reg param-regs nth ;
M: stack-params param-reg 2drop ;
! Does this architecture support %load-float, %load-double,
! and %load-vector?
HOOK: fused-unboxing? cpu ( -- ? )
@ -534,6 +544,14 @@ M: object immediate-comparand? ( n -- ? )
: immediate-shift-count? ( n -- ? )
0 cell-bits 1 - between? ;
! FFI stuff
! Return values of this class go here
HOOK: return-regs cpu ( -- regs )
! Registers used for parameter passing
HOOK: param-regs cpu ( abi -- regs )
! Is this structure small enough to be returned in registers?
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
@ -562,35 +580,31 @@ HOOK: struct-return-on-stack? cpu ( -- ? )
! can be passed to a C function, or returned from a callback
HOOK: %unbox cpu ( dst src func rep -- )
HOOK: %unbox-long-long cpu ( src out func -- )
HOOK: %store-reg-param cpu ( src reg rep -- )
HOOK: %store-stack-param cpu ( src n rep -- )
HOOK: %store-return cpu ( src rep -- )
HOOK: %store-struct-return cpu ( src reps -- )
HOOK: %store-long-long-return cpu ( src1 src2 -- )
HOOK: %prepare-struct-area cpu ( dst -- )
HOOK: %local-allot cpu ( dst size align offset -- )
! Call a function to convert a value into a tagged pointer,
! possibly allocating a bignum, float, or alien instance,
! which is then pushed on the data stack
HOOK: %box cpu ( dst n rep func -- )
HOOK: %box cpu ( dst src func rep -- )
HOOK: %box-long-long cpu ( dst n func -- )
HOOK: %box-long-long cpu ( dst src1 src2 func -- )
HOOK: %box-small-struct cpu ( dst c-type -- )
HOOK: %box-large-struct cpu ( dst n c-type -- )
HOOK: %save-param-reg cpu ( stack reg rep -- )
HOOK: %allot-byte-array cpu ( dst size -- )
HOOK: %restore-context cpu ( temp1 temp2 -- )
HOOK: %save-context cpu ( temp1 temp2 -- )
HOOK: %prepare-var-args cpu ( -- )
M: object %prepare-var-args ;
HOOK: %alien-invoke cpu ( function library -- )
HOOK: %cleanup cpu ( n -- )
@ -599,6 +613,10 @@ M: object %cleanup ( n -- ) drop ;
HOOK: %alien-indirect cpu ( src -- )
HOOK: %load-reg-param cpu ( dst reg rep -- )
HOOK: %load-stack-param cpu ( dst n rep -- )
HOOK: %begin-callback cpu ( -- )
HOOK: %alien-callback cpu ( quot -- )

6
basis/cpu/ppc/linux/linux.factor
View File

@ -13,7 +13,11 @@ M: linux reserved-area-size 2 cells ;
M: linux lr-save 1 cells ;
M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 } ;
M: ppc param-regs
drop {
{ int-regs { 3 4 5 6 7 8 9 10 } }
{ float-regs { 1 2 3 4 5 6 7 8 } }
} ;
M: ppc value-struct? drop f ;

6
basis/cpu/ppc/macosx/macosx.factor
View File

@ -8,7 +8,11 @@ M: macosx reserved-area-size 6 cells ;
M: macosx lr-save 2 cells ;
M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
M: ppc param-regs
drop {
{ int-regs { 3 4 5 6 7 8 9 10 } }
{ float-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
} ;
M: ppc value-struct? drop t ;

23
basis/cpu/ppc/ppc.factor
View File

@ -32,11 +32,6 @@ M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
enable-float-intrinsics
<<
\ ##integer>float t "frame-required?" set-word-prop
\ ##float>integer t "frame-required?" set-word-prop
>>
M: ppc machine-registers
{
{ int-regs $[ 2 12 [a,b] 16 29 [a,b] append ] }
@ -195,6 +190,8 @@ M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ;
M: ppc integer-float-needs-stack-frame? t ;
M:: ppc %integer>float ( dst src -- )
HEX: 4330 scratch-reg LIS
scratch-reg 1 0 scratch@ STW
@ -226,10 +223,10 @@ M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
M: integer float-function-param* FMR ;
: float-function-param ( i src -- )
[ float-regs cdecl param-regs nth ] dip float-function-param* ;
[ float-regs cdecl param-regs at nth ] dip float-function-param* ;
: float-function-return ( reg -- )
float-regs return-reg double-rep %copy ;
float-regs return-regs at first double-rep %copy ;
M:: ppc %unary-float-function ( dst src func -- )
0 src float-function-param
@ -665,11 +662,11 @@ M: ppc %reload ( dst rep src -- )
M: ppc %loop-entry ;
M: int-regs return-reg drop 3 ;
M: int-regs param-regs 2drop { 3 4 5 6 7 8 9 10 } ;
M: float-regs return-reg drop 1 ;
M: ppc return-regs
{
{ int-regs { 3 4 5 6 } }
{ float-regs { 1 } }
} ;
M:: ppc %save-param-reg ( stack reg rep -- )
reg stack local@ rep store-to-frame ;
@ -697,7 +694,7 @@ M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
M:: ppc %unbox ( src n rep func -- )
src func call-unbox-func
! Store the return value on the C stack
n [ rep reg-class-of return-reg rep %save-param-reg ] when* ;
n [ rep reg-class-of return-regs at first rep %save-param-reg ] when* ;
M:: ppc %unbox-long-long ( src n func -- )
src func call-unbox-func

238
basis/cpu/x86/32/32.factor
View File

@ -2,37 +2,36 @@
! See http://factorcode.org/license.txt for BSD license.
USING: locals alien alien.c-types alien.libraries alien.syntax
arrays kernel fry math namespaces sequences system layouts io
vocabs.loader accessors init classes.struct combinators
make words compiler.constants compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics
compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands
cpu.x86 cpu.architecture vm ;
vocabs.loader accessors init classes.struct combinators make
words compiler.constants compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.builder.alien.boxing compiler.cfg.intrinsics
compiler.cfg.stack-frame cpu.x86.assembler
cpu.x86.assembler.operands cpu.x86 cpu.architecture vm vocabs ;
FROM: layouts => cell ;
IN: cpu.x86.32
: x86-float-regs ( -- seq )
"cpu.x86.sse" vocab
{ XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 }
{ ST0 ST1 ST2 ST3 ST4 ST5 ST6 }
? ;
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
{ float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;
{ int-regs { EAX ECX EDX EBP EBX } }
float-regs x86-float-regs 2array
2array ;
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 frame-reg EBP ;
M: x86.32 temp-reg ECX ;
M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
M:: x86.32 %load-vector ( dst val rep -- )
dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ;
M: x86.32 %load-float ( dst val -- )
<float> float-rep %load-vector ;
M: x86.32 %load-double ( dst val -- )
<double> double-rep %load-vector ;
M: x86.32 %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ;
@ -45,11 +44,6 @@ M: x86.32 %set-vm-field ( dst field -- )
M: x86.32 %vm-field-ptr ( dst field -- )
[ 0 MOV ] dip rc-absolute-cell rel-vm ;
: local@ ( n -- op )
stack-frame get extra-stack-space dup 16 assert= + stack@ ;
M: x86.32 extra-stack-space calls-vm?>> 16 0 ? ;
M: x86.32 %mark-card
drop HEX: ffffffff [+] card-mark <byte> MOV
building get pop
@ -80,7 +74,7 @@ M: x86.32 pic-tail-reg EDX ;
M: x86.32 reserved-stack-space 0 ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
M: x86.32 vm-stack-space 16 ;
: save-vm-ptr ( n -- )
stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
@ -94,56 +88,19 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
! On x86, parameters are usually never passed in registers,
! except with Microsoft's "thiscall" and "fastcall" abis
M: int-regs return-reg drop EAX ;
M: float-regs param-regs 2drop { } ;
M: int-regs param-regs
nip {
{ thiscall [ { ECX } ] }
{ fastcall [ { ECX EDX } ] }
[ drop { } ]
M: x86.32 param-regs
{
{ thiscall [ { { int-regs { ECX } } { float-regs { } } } ] }
{ fastcall [ { { int-regs { ECX EDX } } { float-regs { } } } ] }
[ drop { { int-regs { } } { float-regs { } } } ]
} case ;
GENERIC: load-return-reg ( src rep -- )
GENERIC: store-return-reg ( dst rep -- )
M: stack-params load-return-reg drop EAX swap MOV ;
M: stack-params store-return-reg drop EAX MOV ;
M: int-rep load-return-reg drop EAX swap MOV ;
M: int-rep store-return-reg drop EAX MOV ;
:: load-float-return ( src x87-insn sse-insn -- )
src register? [
ESP 4 SUB
ESP [] src sse-insn execute
ESP [] x87-insn execute
ESP 4 ADD
] [
src x87-insn execute
] if ; inline
:: store-float-return ( dst x87-insn sse-insn -- )
dst register? [
ESP 4 SUB
ESP [] x87-insn execute
dst ESP [] sse-insn execute
ESP 4 ADD
] [
dst x87-insn execute
] if ; inline
M: float-rep load-return-reg
drop \ FLDS \ MOVSS load-float-return ;
M: float-rep store-return-reg
drop \ FSTPS \ MOVSS store-float-return ;
M: double-rep load-return-reg
drop \ FLDL \ MOVSD load-float-return ;
M: double-rep store-return-reg
drop \ FSTPL \ MOVSD store-float-return ;
! Need a fake return-reg for floats
M: x86.32 return-regs
{
{ int-regs { EAX EDX } }
{ float-regs { ST0 } }
} ;
M: x86.32 %prologue ( n -- )
dup PUSH
@ -153,6 +110,40 @@ M: x86.32 %prologue ( n -- )
M: x86.32 %prepare-jump
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
:: load-float-return ( dst x87-insn rep -- )
dst register? [
ESP 4 SUB
ESP [] x87-insn execute
dst ESP [] rep %copy
ESP 4 ADD
] [
dst ?spill-slot x87-insn execute
] if ; inline
M: x86.32 %load-reg-param ( dst reg rep -- )
{
{ int-rep [ int-rep %copy ] }
{ float-rep [ drop \ FSTPS float-rep load-float-return ] }
{ double-rep [ drop \ FSTPL double-rep load-float-return ] }
} case ;
:: store-float-return ( src x87-insn rep -- )
src register? [
ESP 4 SUB
ESP [] src rep %copy
ESP [] x87-insn execute
ESP 4 ADD
] [
src ?spill-slot x87-insn execute
] if ; inline
M: x86.32 %store-reg-param ( src reg rep -- )
{
{ int-rep [ swap int-rep %copy ] }
{ float-rep [ drop \ FLDS float-rep store-float-return ] }
{ double-rep [ drop \ FLDL double-rep store-float-return ] }
} case ;
:: call-unbox-func ( src func -- )
EAX src tagged-rep %copy
4 save-vm-ptr
@ -161,77 +152,39 @@ M: x86.32 %prepare-jump
M:: x86.32 %unbox ( dst src func rep -- )
src func call-unbox-func
dst ?spill-slot rep store-return-reg ;
dst rep %load-return ;
M:: x86.32 %store-return ( src rep -- )
src ?spill-slot rep load-return-reg ;
M:: x86.32 %store-long-long-return ( src1 src2 -- )
src2 EAX = [ src1 src2 XCHG src2 src1 ] [ src1 src2 ] if :> ( src1 src2 )
EAX src1 int-rep %copy
EDX src2 int-rep %copy ;
M:: x86.32 %store-struct-return ( src c-type -- )
M:: x86.32 %unbox-long-long ( src out func -- )
EAX src int-rep %copy
EDX EAX 4 [+] MOV
EAX EAX [] MOV ;
0 stack@ EAX MOV
EAX out int-rep %copy
4 stack@ EAX MOV
8 save-vm-ptr
func f %alien-invoke ;
M: stack-params copy-register*
drop
{
{ [ dup integer? ] [ EAX swap next-stack@ MOV EAX MOV ] }
{ [ over integer? ] [ EAX swap MOV param@ EAX MOV ] }
} cond ;
M: x86.32 %save-param-reg [ local@ ] 2dip %copy ;
: (%box) ( n rep -- )
#! If n is f, push the return register onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
over [ [ local@ ] dip load-return-reg ] [ 2drop ] if ;
M:: x86.32 %box ( dst n rep func -- )
n rep (%box)
M:: x86.32 %box ( dst src func rep -- )
rep rep-size save-vm-ptr
0 stack@ rep store-return-reg
src rep %store-return
0 stack@ rep %load-return
func f %alien-invoke
dst EAX tagged-rep %copy ;
: (%box-long-long) ( n -- )
[
[ EDX swap next-stack@ MOV ]
[ EAX swap cell - next-stack@ MOV ] bi
] when* ;
M:: x86.32 %box-long-long ( dst n func -- )
n (%box-long-long)
M:: x86.32 %box-long-long ( dst src1 src2 func -- )
8 save-vm-ptr
4 stack@ EDX MOV
0 stack@ EAX MOV
EAX src1 int-rep %copy
0 stack@ EAX int-rep %copy
EAX src2 int-rep %copy
4 stack@ EAX int-rep %copy
func f %alien-invoke
dst EAX tagged-rep %copy ;
M: x86.32 struct-return@ ( n -- operand )
[ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
M:: x86.32 %box-large-struct ( dst n c-type -- )
EDX n struct-return@ LEA
8 save-vm-ptr
4 stack@ c-type heap-size MOV
0 stack@ EDX MOV
"from_value_struct" f %alien-invoke
M:: x86.32 %allot-byte-array ( dst size -- )
4 save-vm-ptr
0 stack@ size MOV
"allot_byte_array" f %alien-invoke
dst EAX tagged-rep %copy ;
M:: x86.32 %box-small-struct ( dst c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
12 save-vm-ptr
8 stack@ c-type heap-size MOV
4 stack@ EDX MOV
0 stack@ EAX MOV
"from_small_struct" f %alien-invoke
dst EAX tagged-rep %copy ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
@ -246,34 +199,27 @@ M: x86.32 %end-callback ( -- )
0 save-vm-ptr
"end_callback" f %alien-invoke ;
GENERIC: float-function-param ( stack-slot dst src -- )
GENERIC: float-function-param ( n dst src -- )
M:: spill-slot float-function-param ( stack-slot dst src -- )
M:: spill-slot float-function-param ( n dst src -- )
! We can clobber dst here since its going to contain the
! final result
dst src double-rep %copy
stack-slot dst double-rep %copy ;
dst n double-rep %store-stack-param ;
M: register float-function-param
nip double-rep %copy ;
: float-function-return ( reg -- )
ESP [] FSTPL
ESP [] MOVSD
ESP 16 ADD ;
M:: register float-function-param ( n dst src -- )
src n double-rep %store-stack-param ;
M:: x86.32 %unary-float-function ( dst src func -- )
ESP -16 [+] dst src float-function-param
ESP 16 SUB
0 dst src float-function-param
func "libm" load-library %alien-invoke
dst float-function-return ;
dst double-rep %load-return ;
M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
ESP -16 [+] dst src1 float-function-param
ESP -8 [+] dst src2 float-function-param
ESP 16 SUB
0 dst src1 float-function-param
8 dst src2 float-function-param
func "libm" load-library %alien-invoke
dst float-function-return ;
dst double-rep %load-return ;
: funny-large-struct-return? ( return abi -- ? )
#! MINGW ABI incompatibility disaster
@ -309,7 +255,7 @@ M: x86.32 long-long-on-stack? t ;
M: x86.32 float-on-stack? t ;
M: x86.32 flatten-struct-type
stack-size cell /i { int-rep t } <repetition> ;
call-next-method [ first t 2array ] map ;
M: x86.32 struct-return-on-stack? os linux? not ;

5
basis/cpu/x86/64/64-tests.factor
View File

@ -1,5 +1,6 @@
USING: alien alien.c-types cpu.architecture cpu.x86.64
cpu.x86.assembler cpu.x86.assembler.operands tools.test ;
cpu.x86.assembler cpu.x86.assembler.operands tools.test
assocs sequences ;
IN: cpu.x86.64.tests
: assembly-test-1 ( -- x ) int { } cdecl [ RAX 3 MOV ] alien-assembly ;
@ -9,7 +10,7 @@ IN: cpu.x86.64.tests
: assembly-test-2 ( a b -- x )
int { int int } cdecl [
param-reg-0 param-reg-1 ADD
int-regs return-reg param-reg-0 MOV
int-regs return-regs at first param-reg-0 MOV
] alien-assembly ;
[ 23 ] [ 17 6 assembly-test-2 ] unit-test

124
basis/cpu/x86/64/64.factor
View File

@ -11,23 +11,26 @@ cpu.architecture vm ;
FROM: layouts => cell cells ;
IN: cpu.x86.64
: param-reg-0 ( -- reg ) 0 int-regs cdecl param-reg ; inline
: param-reg-1 ( -- reg ) 1 int-regs cdecl param-reg ; inline
: param-reg-2 ( -- reg ) 2 int-regs cdecl param-reg ; inline
: param-reg-3 ( -- reg ) 3 int-regs cdecl param-reg ; inline
: param-reg ( n -- reg ) int-regs cdecl param-regs at nth ;
: param-reg-0 ( -- reg ) 0 param-reg ; inline
: param-reg-1 ( -- reg ) 1 param-reg ; inline
: param-reg-2 ( -- reg ) 2 param-reg ; inline
: param-reg-3 ( -- reg ) 3 param-reg ; inline
M: x86.64 pic-tail-reg RBX ;
M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ;
M: x86.64 return-regs
{
{ int-regs { RAX EDX } }
{ float-regs { XMM0 XMM1 } }
} ;
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 frame-reg RBP ;
M: x86.64 extra-stack-space drop 0 ;
M: x86.64 machine-registers
{
{ int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 } }
@ -49,18 +52,16 @@ M: x86.64 %vm-field ( dst offset -- )
M:: x86.64 %load-vector ( dst val rep -- )
dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ;
M: x86.64 %load-float ( dst val -- )
<float> float-rep %load-vector ;
M: x86.64 %load-double ( dst val -- )
<double> double-rep %load-vector ;
M: x86.64 %set-vm-field ( src offset -- )
[ vm-reg ] dip [+] swap MOV ;
M: x86.64 %vm-field-ptr ( dst offset -- )
[ vm-reg ] dip [+] LEA ;
! Must be a volatile register not used for parameter passing or
! integer return
HOOK: temp-reg cpu ( -- reg )
M: x86.64 %prologue ( n -- )
temp-reg -7 [RIP+] LEA
dup PUSH
@ -99,85 +100,29 @@ M:: x86.64 %dispatch ( src temp -- )
[ (align-code) ]
bi ;
M:: x86.64 %load-reg-param ( dst reg rep -- )
dst reg rep %copy ;
M:: x86.64 %store-reg-param ( src reg rep -- )
reg src rep %copy ;
M:: x86.64 %unbox ( dst src func rep -- )
param-reg-0 src tagged-rep %copy
param-reg-1 %mov-vm-ptr
func f %alien-invoke
dst rep reg-class-of return-reg rep %copy ;
dst rep %load-return ;
: with-return-regs ( quot -- )
[
V{ RDX RAX } clone int-regs set
V{ XMM1 XMM0 } clone float-regs set
call
] with-scope ; inline
: each-struct-component ( c-type quot -- )
'[
flatten-struct-type
[ [ first ] dip @ ] each-index
] with-return-regs ; inline
: %unbox-struct-component ( rep i -- )
R11 swap cells [+] swap reg-class-of {
{ int-regs [ int-regs get pop swap MOV ] }
{ float-regs [ float-regs get pop swap MOVSD ] }
} case ;
M:: x86.64 %store-return ( src rep -- )
rep reg-class-of return-reg src rep %copy ;
M:: x86.64 %store-struct-return ( src c-type -- )
! Move src to R11 so that we don't clobber it.
R11 src int-rep %copy
c-type [ %unbox-struct-component ] each-struct-component ;
M: stack-params copy-register*
drop
{
{ [ dup integer? ] [ R11 swap next-stack@ MOV R11 MOV ] }
{ [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
} cond ;
M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
M:: x86.64 %box ( dst n rep func -- )
0 rep reg-class-of cdecl param-reg
n [ n param@ ] [ rep reg-class-of return-reg ] if rep %copy
M:: x86.64 %box ( dst src func rep -- )
0 rep reg-class-of cdecl param-regs at nth src rep %copy
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
func f %alien-invoke
dst RAX tagged-rep %copy ;
dst int-rep %load-return ;
: box-struct-component@ ( i -- operand ) 1 + cells param@ ;
: %box-struct-component ( rep i -- )
box-struct-component@ swap reg-class-of {
{ int-regs [ int-regs get pop MOV ] }
{ float-regs [ float-regs get pop MOVSD ] }
} case ;
M:: x86.64 %box-small-struct ( dst c-type -- )
#! Box a <= 16-byte struct.
c-type [ %box-struct-component ] each-struct-component
param-reg-2 c-type heap-size MOV
param-reg-0 0 box-struct-component@ MOV
param-reg-1 1 box-struct-component@ MOV
param-reg-3 %mov-vm-ptr
"from_small_struct" f %alien-invoke
dst RAX tagged-rep %copy ;
M: x86.64 struct-return@ ( n -- operand )
[ stack-frame get params>> ] unless* param@ ;
M:: x86.64 %box-large-struct ( dst n c-type -- )
! Struct size is parameter 2
param-reg-1 c-type heap-size MOV
! Compute destination address
param-reg-0 n struct-return@ LEA
param-reg-2 %mov-vm-ptr
! Copy the struct from the C stack
"from_value_struct" f %alien-invoke
dst RAX tagged-rep %copy ;
M:: x86.64 %allot-byte-array ( dst size -- )
param-reg-0 size MOV
param-reg-1 %mov-vm-ptr
"allot_byte_array" f %alien-invoke
dst int-rep %load-return ;
M: x86.64 %alien-invoke
R11 0 MOV
@ -198,15 +143,12 @@ M: x86.64 %end-callback ( -- )
"end_callback" f %alien-invoke ;
: float-function-param ( i src -- )
[ float-regs cdecl param-regs nth ] dip double-rep %copy ;
: float-function-return ( reg -- )
float-regs return-reg double-rep %copy ;
[ float-regs cdecl param-regs at nth ] dip double-rep %copy ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
func "libm" load-library %alien-invoke
dst float-function-return ;
dst double-rep %load-return ;
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
! src1 might equal dst; otherwise it will be a spill slot
@ -214,7 +156,7 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
0 src1 float-function-param
1 src2 float-function-param
func "libm" load-library %alien-invoke
dst float-function-return ;
dst double-rep %load-return ;
M:: x86.64 %call-gc ( gc-roots -- )
param-reg-0 gc-roots gc-root-offsets %load-reference

23
basis/cpu/x86/64/unix/unix.factor
View File

@ -3,14 +3,15 @@
USING: accessors arrays sequences math splitting make assocs
kernel layouts system alien.c-types classes.struct
cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
cpu.x86 compiler.cfg.builder.alien compiler.cfg.registers ;
cpu.x86 cpu.x86.64 compiler.cfg.builder.alien
compiler.cfg.builder.alien.boxing compiler.cfg.registers ;
IN: cpu.x86.64.unix
M: int-regs param-regs
2drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs param-regs
2drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
M: x86.64 param-regs
drop {
{ int-regs { RDI RSI RDX RCX R8 R9 } }
{ float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;
M: x86.64 reserved-stack-space 0 ;
@ -31,13 +32,9 @@ M: x86.64 reserved-stack-space 0 ;
f 2array
] map ;
: flatten-large-struct ( c-type -- seq )
stack-size cell /i { int-rep t } <repetition> ;
M: x86.64 flatten-struct-type ( c-type -- seq )
dup heap-size 16 >
[ flatten-large-struct ]
[ flatten-small-struct ] if ;
dup heap-size 16 <=
[ flatten-small-struct ] [ call-next-method [ first t 2array ] map ] if ;
M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size 2 cells <= ;
@ -49,3 +46,5 @@ M: x86.64 dummy-int-params? f ;
M: x86.64 dummy-fp-params? f ;
M: x86.64 temp-reg R8 ;
M: x86.64 %prepare-var-args RAX RAX XOR ;

15
basis/cpu/x86/64/winnt/winnt.factor
View File

@ -1,13 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts system math alien.c-types sequences
compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86
cpu.x86.assembler.operands ;
compiler.cfg.registers cpu.architecture cpu.x86.assembler
cpu.x86 cpu.x86.64 cpu.x86.assembler.operands ;
IN: cpu.x86.64.winnt
M: int-regs param-regs 2drop { RCX RDX R8 R9 } ;
M: float-regs param-regs 2drop { XMM0 XMM1 XMM2 XMM3 } ;
M: x86.64 param-regs
drop {
{ int-regs { RCX RDX R8 R9 } }
{ float-regs { XMM0 XMM1 XMM2 XMM3 } }
} ;
M: x86.64 reserved-stack-space 4 cells ;
@ -23,4 +25,3 @@ M: x86.64 dummy-int-params? t ;
M: x86.64 dummy-fp-params? t ;
M: x86.64 temp-reg R11 ;

32
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -2,6 +2,15 @@ USING: cpu.x86.assembler cpu.x86.assembler.operands
kernel tools.test namespaces make layouts ;
IN: cpu.x86.assembler.tests
! small registers
[ { 128 192 12 } ] [ [ AL 12 <byte> ADD ] { } make ] unit-test
[ { 128 196 12 } ] [ [ AH 12 <byte> ADD ] { } make ] unit-test
[ { 176 12 } ] [ [ AL 12 <byte> MOV ] { } make ] unit-test
[ { 180 12 } ] [ [ AH 12 <byte> MOV ] { } make ] unit-test
[ { 198 0 12 } ] [ [ EAX [] 12 <byte> MOV ] { } make ] unit-test
[ { 0 235 } ] [ [ BL CH ADD ] { } make ] unit-test
[ { 136 235 } ] [ [ BL CH MOV ] { } make ] unit-test
! immediate operands
cell 4 = [
[ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
@ -190,6 +199,29 @@ cell 4 = [
[ { HEX: 48 HEX: 6b HEX: c1 HEX: 03 } ] [ [ RAX RCX 3 IMUL3 ] { } make ] unit-test
[ { HEX: 48 HEX: 69 HEX: c1 HEX: 44 HEX: 03 HEX: 00 HEX: 00 } ] [ [ RAX RCX HEX: 344 IMUL3 ] { } make ] unit-test
! BT family instructions
[ { HEX: 0f HEX: ba HEX: e0 HEX: 01 } ] [ [ EAX 1 BT ] { } make ] unit-test
[ { HEX: 0f HEX: ba HEX: f8 HEX: 01 } ] [ [ EAX 1 BTC ] { } make ] unit-test
[ { HEX: 0f HEX: ba HEX: e8 HEX: 01 } ] [ [ EAX 1 BTS ] { } make ] unit-test
[ { HEX: 0f HEX: ba HEX: f0 HEX: 01 } ] [ [ EAX 1 BTR ] { } make ] unit-test
[ { HEX: 48 HEX: 0f HEX: ba HEX: e0 HEX: 01 } ] [ [ RAX 1 BT ] { } make ] unit-test
[ { HEX: 0f HEX: ba HEX: 20 HEX: 01 } ] [ [ EAX [] 1 BT ] { } make ] unit-test
[ { HEX: 0f HEX: a3 HEX: d8 } ] [ [ EAX EBX BT ] { } make ] unit-test
[ { HEX: 0f HEX: bb HEX: d8 } ] [ [ EAX EBX BTC ] { } make ] unit-test
[ { HEX: 0f HEX: ab HEX: d8 } ] [ [ EAX EBX BTS ] { } make ] unit-test
[ { HEX: 0f HEX: b3 HEX: d8 } ] [ [ EAX EBX BTR ] { } make ] unit-test
[ { HEX: 0f HEX: a3 HEX: 18 } ] [ [ EAX [] EBX BT ] { } make ] unit-test
! x87 instructions
[ { HEX: D8 HEX: C5 } ] [ [ ST0 ST5 FADD ] { } make ] unit-test
[ { HEX: DC HEX: C5 } ] [ [ ST5 ST0 FADD ] { } make ] unit-test
[ { HEX: D8 HEX: 00 } ] [ [ ST0 EAX [] FADD ] { } make ] unit-test
[ { HEX: D9 HEX: C2 } ] [ [ ST2 FLD ] { } make ] unit-test
[ { HEX: DD HEX: D2 } ] [ [ ST2 FST ] { } make ] unit-test
[ { HEX: DD HEX: DA } ] [ [ ST2 FSTP ] { } make ] unit-test
[ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test
bootstrap-cell 4 = [

142
basis/cpu/x86/assembler/assembler.factor
View File

@ -152,8 +152,11 @@ M: register displacement, drop ;
: immediate-operand-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
over integer? [ first3 BIN: 1 opcode-or 3array ] when ;
: immediate-1* ( dst imm reg,rex.w,opcode -- )
swap [ 1-operand ] dip 1, ;
: immediate-1 ( dst imm reg,rex.w,opcode -- )
immediate-operand-size-bit swap [ 1-operand ] dip 1, ;
immediate-operand-size-bit immediate-1* ;
: immediate-4 ( dst imm reg,rex.w,opcode -- )
immediate-operand-size-bit swap [ 1-operand ] dip 4, ;
@ -211,7 +214,13 @@ M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
<PRIVATE
GENERIC# (MOV-I) 1 ( dst src -- )
M: register (MOV-I) [ t HEX: b8 short-operand ] [ cell, ] bi* ;
M: register (MOV-I)
dup byte?
[ [ t HEX: b0 short-operand ] [ 1, ] bi* ]
[ [ t HEX: b8 short-operand ] [ cell, ] bi* ]
if ;
M: operand (MOV-I)
{ BIN: 000 t HEX: c6 }
over byte? [ immediate-1 ] [ immediate-4 ] if ;
@ -238,6 +247,9 @@ M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- )
M: integer JUMPcc extended-opcode, 4, ;
: SETcc ( dst opcode -- )
{ BIN: 000 t } swap suffix 1-operand ;
PRIVATE>
: JO ( dst -- ) HEX: 80 JUMPcc ;
@ -257,6 +269,23 @@ PRIVATE>
: JLE ( dst -- ) HEX: 8e JUMPcc ;
: JG ( dst -- ) HEX: 8f JUMPcc ;
: SETO ( dst -- ) { HEX: 0f HEX: 90 } SETcc ;
: SETNO ( dst -- ) { HEX: 0f HEX: 91 } SETcc ;
: SETB ( dst -- ) { HEX: 0f HEX: 92 } SETcc ;
: SETAE ( dst -- ) { HEX: 0f HEX: 93 } SETcc ;
: SETE ( dst -- ) { HEX: 0f HEX: 94 } SETcc ;
: SETNE ( dst -- ) { HEX: 0f HEX: 95 } SETcc ;
: SETBE ( dst -- ) { HEX: 0f HEX: 96 } SETcc ;
: SETA ( dst -- ) { HEX: 0f HEX: 97 } SETcc ;
: SETS ( dst -- ) { HEX: 0f HEX: 98 } SETcc ;
: SETNS ( dst -- ) { HEX: 0f HEX: 99 } SETcc ;
: SETP ( dst -- ) { HEX: 0f HEX: 9a } SETcc ;
: SETNP ( dst -- ) { HEX: 0f HEX: 9b } SETcc ;
: SETL ( dst -- ) { HEX: 0f HEX: 9c } SETcc ;
: SETGE ( dst -- ) { HEX: 0f HEX: 9d } SETcc ;
: SETLE ( dst -- ) { HEX: 0f HEX: 9e } SETcc ;
: SETG ( dst -- ) { HEX: 0f HEX: 9f } SETcc ;
: LEAVE ( -- ) HEX: c9 , ;
: RET ( n -- )
@ -304,6 +333,22 @@ M: operand TEST OCT: 204 2-operand ;
: BSR ( dst src -- ) { HEX: 0f HEX: bd } (2-operand) ;
GENERIC: BT ( value n -- )
M: immediate BT ( value n -- ) { BIN: 100 t { HEX: 0f HEX: ba } } immediate-1* ;
M: operand BT ( value n -- ) swap { HEX: 0f HEX: a3 } (2-operand) ;
GENERIC: BTC ( value n -- )
M: immediate BTC ( value n -- ) { BIN: 111 t { HEX: 0f HEX: ba } } immediate-1* ;
M: operand BTC ( value n -- ) swap { HEX: 0f HEX: bb } (2-operand) ;
GENERIC: BTR ( value n -- )
M: immediate BTR ( value n -- ) { BIN: 110 t { HEX: 0f HEX: ba } } immediate-1* ;
M: operand BTR ( value n -- ) swap { HEX: 0f HEX: b3 } (2-operand) ;
GENERIC: BTS ( value n -- )
M: immediate BTS ( value n -- ) { BIN: 101 t { HEX: 0f HEX: ba } } immediate-1* ;
M: operand BTS ( value n -- ) swap { HEX: 0f HEX: ab } (2-operand) ;
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
@ -400,6 +445,99 @@ PRIVATE>
: FNCLEX ( -- ) HEX: db , HEX: e2 , ;
: FNINIT ( -- ) HEX: db , HEX: e3 , ;
ERROR: bad-x87-operands ;
<PRIVATE
:: (x87-op) ( operand opcode reg -- )
opcode ,
BIN: 1100,0000 reg
3 shift bitor
operand reg-code bitor , ;
:: x87-st0-op ( src opcode reg -- )
src register?
[ src opcode reg (x87-op) ]
[ bad-x87-operands ] if ;
:: x87-m-st0/n-op ( dst src opcode reg -- )
{
{ [ dst ST0 = src indirect? and ] [
src { reg f opcode } 1-operand
] }
{ [ dst ST0 = src register? and ] [
src opcode reg (x87-op)
] }
{ [ src ST0 = dst register? and ] [
dst opcode 4 + reg (x87-op)
] }
[ bad-x87-operands ]
} cond ;
PRIVATE>
: F2XM1 ( -- ) { HEX: D9 HEX: F0 } % ;
: FABS ( -- ) { HEX: D9 HEX: E1 } % ;
: FADD ( dst src -- ) HEX: D8 0 x87-m-st0/n-op ;
: FCHS ( -- ) { HEX: D9 HEX: E0 } % ;
: FCMOVB ( src -- ) HEX: DA 0 x87-st0-op ;
: FCMOVE ( src -- ) HEX: DA 1 x87-st0-op ;
: FCMOVBE ( src -- ) HEX: DA 2 x87-st0-op ;
: FCMOVU ( src -- ) HEX: DA 3 x87-st0-op ;
: FCMOVNB ( src -- ) HEX: DB 0 x87-st0-op ;
: FCMOVNE ( src -- ) HEX: DB 1 x87-st0-op ;
: FCMOVNBE ( src -- ) HEX: DB 2 x87-st0-op ;
: FCMOVNU ( src -- ) HEX: DB 3 x87-st0-op ;
: FCOMI ( src -- ) HEX: DB 6 x87-st0-op ;
: FUCOMI ( src -- ) HEX: DB 5 x87-st0-op ;
: FCOS ( -- ) { HEX: D9 HEX: FF } % ;
: FDECSTP ( -- ) { HEX: D9 HEX: F6 } % ;
: FINCSTP ( -- ) { HEX: D9 HEX: F7 } % ;
: FDIV ( dst src -- ) HEX: D8 6 x87-m-st0/n-op ;
: FDIVR ( dst src -- ) HEX: D8 7 x87-m-st0/n-op ;
: FILDD ( src -- ) { BIN: 000 f HEX: DB } 1-operand ;
: FILDQ ( src -- ) { BIN: 101 f HEX: DF } 1-operand ;
: FISTPD ( dst -- ) { BIN: 011 f HEX: DB } 1-operand ;
: FISTPQ ( dst -- ) { BIN: 111 f HEX: DF } 1-operand ;
: FISTTPD ( dst -- ) { BIN: 001 f HEX: DB } 1-operand ;
: FISTTPQ ( dst -- ) { BIN: 001 f HEX: DF } 1-operand ;
: FLD ( src -- ) HEX: D9 0 x87-st0-op ;
: FLD1 ( -- ) { HEX: D9 HEX: E8 } % ;
: FLDL2T ( -- ) { HEX: D9 HEX: E9 } % ;
: FLDL2E ( -- ) { HEX: D9 HEX: EA } % ;
: FLDPI ( -- ) { HEX: D9 HEX: EB } % ;
: FLDLG2 ( -- ) { HEX: D9 HEX: EC } % ;
: FLDLN2 ( -- ) { HEX: D9 HEX: ED } % ;
: FLDZ ( -- ) { HEX: D9 HEX: EE } % ;
: FMUL ( dst src -- ) HEX: D8 1 x87-m-st0/n-op ;
: FNOP ( -- ) { HEX: D9 HEX: D0 } % ;
: FPATAN ( -- ) { HEX: D9 HEX: F3 } % ;
: FPREM ( -- ) { HEX: D9 HEX: F8 } % ;
: FPREM1 ( -- ) { HEX: D9 HEX: F5 } % ;
: FRNDINT ( -- ) { HEX: D9 HEX: FC } % ;
: FSCALE ( -- ) { HEX: D9 HEX: FD } % ;
: FSIN ( -- ) { HEX: D9 HEX: FE } % ;
: FSINCOS ( -- ) { HEX: D9 HEX: FB } % ;
: FSQRT ( -- ) { HEX: D9 HEX: FA } % ;
: FSUB ( dst src -- ) HEX: D8 HEX: 4 x87-m-st0/n-op ;
: FSUBR ( dst src -- ) HEX: D8 HEX: 5 x87-m-st0/n-op ;
: FST ( src -- ) HEX: DD 2 x87-st0-op ;
: FSTP ( src -- ) HEX: DD 3 x87-st0-op ;
: FXAM ( -- ) { HEX: D9 HEX: E5 } % ;
: FXCH ( src -- ) HEX: D9 1 x87-st0-op ;
: FXTRACT ( -- ) { HEX: D9 HEX: F4 } % ;
: FYL2X ( -- ) { HEX: D9 HEX: F1 } % ;
: FYL2XP1 ( -- ) { HEX: D9 HEX: F1 } % ;
! SSE multimedia instructions
<PRIVATE

13
basis/cpu/x86/assembler/operands/operands.factor
View File

@ -6,22 +6,23 @@ IN: cpu.x86.assembler.operands
REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ;
ALIAS: AH SPL
ALIAS: CH BPL
ALIAS: DH SIL
ALIAS: BH DIL
HI-REGISTERS: 8 AH CH DH BH ;
REGISTERS: 16 AX CX DX BX SP BP SI DI R8W R9W R10W R11W R12W R13W R14W R15W ;
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI R8D R9D R10D R11D R12D R13D R14D R15D ;
REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
REGISTERS: 64 RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
REGISTERS: 128
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
REGISTERS: 80 ST0 ST1 ST2 ST3 ST4 ST5 ST6 ST7 ;
: shuffle-down ( STn -- STn+1 )
"register" word-prop 1 + 80 registers get at nth ;
PREDICATE: register < word
"register" word-prop ;

20
basis/cpu/x86/assembler/syntax/syntax.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words words.symbol sequences lexer parser fry
namespaces combinators assocs ;
namespaces combinators assocs math ;
IN: cpu.x86.assembler.syntax
SYMBOL: registers
@ -9,15 +9,21 @@ SYMBOL: registers
registers [ H{ } clone ] initialize
: define-register ( name num size -- word )
[ "cpu.x86.assembler.operands" create ] 2dip {
[ create-in ] 2dip {
[ 2drop ]
[ 2drop define-symbol ]
[ drop "register" set-word-prop ]
[ nip "register-size" set-word-prop ]
} 3cleave ;
: define-registers ( size names -- )
[ swap '[ _ define-register ] map-index ] [ drop ] 2bi
registers get set-at ;
: (define-registers) ( names start size -- seq )
'[ _ + _ define-register ] map-index ;
SYNTAX: REGISTERS: scan-word ";" parse-tokens define-registers ;
: define-registers ( names size -- )
[ [ 0 ] dip (define-registers) ] keep registers get set-at ;
SYNTAX: REGISTERS:
scan-word [ ";" parse-tokens ] dip define-registers ;
SYNTAX: HI-REGISTERS:
scan-word [ ";" parse-tokens 4 ] dip (define-registers) drop ;

2
basis/cpu/x86/bootstrap.factor
View File

@ -548,7 +548,7 @@ big-endian off
temp0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
temp0 ds-reg [] OR
temp0 tag-mask get AND
temp0 tag-mask get TEST
temp0 \ f type-number MOV
temp1 1 tag-fixnum MOV
temp0 temp1 CMOVE

60
basis/cpu/x86/features/features.factor
View File

@ -1,13 +1,16 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types combinators compiler
compiler.codegen.fixup compiler.units cpu.architecture
cpu.x86.assembler cpu.x86.assembler.operands init io kernel
locals math math.order math.parser memoize namespaces system ;
USING: accessors assocs sequences alien alien.c-types
combinators compiler compiler.codegen.fixup compiler.units
cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
init io kernel locals math math.order math.parser memoize
namespaces system ;
IN: cpu.x86.features
<PRIVATE
: return-reg ( -- reg ) int-regs return-regs at first ;
: (sse-version) ( -- n )
int { } cdecl [
"sse-42" define-label
@ -18,53 +21,53 @@ IN: cpu.x86.features
"sse-1" define-label
"end" define-label
int-regs return-reg 1 MOV
return-reg 1 MOV
CPUID
ECX HEX: 100000 TEST
"sse-42" get JNE
ECX 20 BT
"sse-42" get JB
ECX HEX: 80000 TEST
"sse-41" get JNE
ECX 19 BT
"sse-41" get JB
ECX HEX: 200 TEST
"ssse-3" get JNE
ECX 9 BT
"ssse-3" get JB
ECX HEX: 1 TEST
"sse-3" get JNE
ECX 0 BT
"sse-3" get JB
EDX HEX: 4000000 TEST
"sse-2" get JNE
EDX 26 BT
"sse-2" get JB
EDX HEX: 2000000 TEST
"sse-1" get JNE
EDX 25 BT
"sse-1" get JB
int-regs return-reg 0 MOV
return-reg 0 MOV
"end" get JMP
"sse-42" resolve-label
int-regs return-reg 42 MOV
return-reg 42 MOV
"end" get JMP
"sse-41" resolve-label
int-regs return-reg 41 MOV
return-reg 41 MOV
"end" get JMP
"ssse-3" resolve-label
int-regs return-reg 33 MOV
return-reg 33 MOV
"end" get JMP
"sse-3" resolve-label
int-regs return-reg 30 MOV
return-reg 30 MOV
"end" get JMP
"sse-2" resolve-label
int-regs return-reg 20 MOV
return-reg 20 MOV
"end" get JMP
"sse-1" resolve-label
int-regs return-reg 10 MOV
return-reg 10 MOV
"end" resolve-label
] alien-assembly ;
@ -83,6 +86,15 @@ MEMO: sse-version ( -- n )
: sse4.1? ( -- ? ) sse-version 41 >= ;
: sse4.2? ( -- ? ) sse-version 42 >= ;
: popcnt? ( -- ? )
bool { } cdecl [
return-reg 1 MOV
CPUID
ECX 23 BT
return-reg dup XOR
return-reg SETB
] alien-assembly ;
: sse-string ( version -- string )
{
{ 00 [ "no SSE" ] }

2
basis/cpu/x86/sse/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Slava Pestov
Joe Groff

916
basis/cpu/x86/sse/sse.factor Normal file
View File

@ -0,0 +1,916 @@
! Copyright (C) 2009, 2010 Joe Groff, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays assocs combinators fry kernel locals
macros math math.vectors namespaces quotations sequences system
compiler.cfg.comparisons compiler.cfg.intrinsics
compiler.codegen.fixup cpu.architecture cpu.x86
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features ;
IN: cpu.x86.sse
! Scalar floating point with SSE2
M: x86 %load-float <float> float-rep %load-vector ;
M: x86 %load-double <double> double-rep %load-vector ;
M: float-rep copy-register* drop MOVAPS ;
M: double-rep copy-register* drop MOVAPS ;
M: float-rep copy-memory* drop MOVSS ;
M: double-rep copy-memory* drop MOVSD ;
M: x86 %add-float double-rep two-operand ADDSD ;
M: x86 %sub-float double-rep two-operand SUBSD ;
M: x86 %mul-float double-rep two-operand MULSD ;
M: x86 %div-float double-rep two-operand DIVSD ;
M: x86 %min-float double-rep two-operand MINSD ;
M: x86 %max-float double-rep two-operand MAXSD ;
M: x86 %sqrt SQRTSD ;
: %clear-unless-in-place ( dst src -- )
over = [ drop ] [ dup XORPS ] if ;
M: x86 %single>double-float [ %clear-unless-in-place ] [ CVTSS2SD ] 2bi ;
M: x86 %double>single-float [ %clear-unless-in-place ] [ CVTSD2SS ] 2bi ;
M: x86 integer-float-needs-stack-frame? f ;
M: x86 %integer>float [ drop dup XORPS ] [ CVTSI2SD ] 2bi ;
M: x86 %float>integer CVTTSD2SI ;
M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
[ COMISD ] (%compare-float) ;
M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
[ UCOMISD ] (%compare-float) ;
M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
[ COMISD ] (%compare-float-branch) ;
M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
[ UCOMISD ] (%compare-float-branch) ;
! SIMD
M: float-4-rep copy-register* drop MOVAPS ;
M: double-2-rep copy-register* drop MOVAPS ;
M: vector-rep copy-register* drop MOVDQA ;
MACRO: available-reps ( alist -- )
! Each SSE version adds new representations and supports
! all old ones
unzip { } [ append ] accumulate rest swap suffix
[ [ 1quotation ] map ] bi@ zip
reverse [ { } ] suffix
'[ _ cond ] ;
M: x86 %alien-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %zero-vector
{
{ double-2-rep [ dup XORPS ] }
{ float-4-rep [ dup XORPS ] }
[ drop dup PXOR ]
} case ;
M: x86 %zero-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %fill-vector
{
{ double-2-rep [ dup [ XORPS ] [ CMPEQPS ] 2bi ] }
{ float-4-rep [ dup [ XORPS ] [ CMPEQPS ] 2bi ] }
[ drop dup PCMPEQB ]
} case ;
M: x86 %fill-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
rep signed-rep {
{ float-4-rep [
dst src1 float-4-rep %copy
dst src2 UNPCKLPS
src3 src4 UNPCKLPS
dst src3 MOVLHPS
] }
{ int-4-rep [
dst src1 int-4-rep %copy
dst src2 PUNPCKLDQ
src3 src4 PUNPCKLDQ
dst src3 PUNPCKLQDQ
] }
} case ;
M: x86 %gather-vector-4-reps
{
! Can't do this with sse1 since it will want to unbox
! double-precision floats and convert to single precision
{ sse2? { float-4-rep int-4-rep uint-4-rep } }
} available-reps ;
M:: x86 %gather-int-vector-4 ( dst src1 src2 src3 src4 rep -- )
dst rep %zero-vector
dst src1 32-bit-version-of 0 PINSRD
dst src2 32-bit-version-of 1 PINSRD
dst src3 32-bit-version-of 2 PINSRD
dst src4 32-bit-version-of 3 PINSRD ;
M: x86 %gather-int-vector-4-reps
{
{ sse4.1? { int-4-rep uint-4-rep } }
} available-reps ;
M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
rep signed-rep {
{ double-2-rep [
dst src1 double-2-rep %copy
dst src2 MOVLHPS
] }
{ longlong-2-rep [
dst src1 longlong-2-rep %copy
dst src2 PUNPCKLQDQ
] }
} case ;
M: x86 %gather-vector-2-reps
{
{ sse2? { double-2-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M:: x86.64 %gather-int-vector-2 ( dst src1 src2 rep -- )
dst rep %zero-vector
dst src1 0 PINSRQ
dst src2 1 PINSRQ ;
M: x86.64 %gather-int-vector-2-reps
{
{ sse4.1? { longlong-2-rep ulonglong-2-rep } }
} available-reps ;
:: %select-vector-32 ( dst src n rep -- )
rep {
{ char-16-rep [
dst 32-bit-version-of src n PEXTRB
dst dst 8-bit-version-of MOVSX
] }
{ uchar-16-rep [
dst 32-bit-version-of src n PEXTRB
] }
{ short-8-rep [
dst 32-bit-version-of src n PEXTRW
dst dst 16-bit-version-of MOVSX
] }
{ ushort-8-rep [
dst 32-bit-version-of src n PEXTRW
] }
{ int-4-rep [
dst 32-bit-version-of src n PEXTRD
dst dst 32-bit-version-of 2dup = [ 2drop ] [ MOVSX ] if
] }
{ uint-4-rep [
dst 32-bit-version-of src n PEXTRD
] }
} case ;
M: x86.32 %select-vector
%select-vector-32 ;
M: x86.32 %select-vector-reps
{
{ sse4.1? { uchar-16-rep char-16-rep ushort-8-rep short-8-rep uint-4-rep int-4-rep } }
} available-reps ;
M: x86.64 %select-vector
{
{ longlong-2-rep [ PEXTRQ ] }
{ ulonglong-2-rep [ PEXTRQ ] }
[ %select-vector-32 ]
} case ;
M: x86.64 %select-vector-reps
{
{ sse4.1? { uchar-16-rep char-16-rep ushort-8-rep short-8-rep uint-4-rep int-4-rep ulonglong-2-rep longlong-2-rep } }
} available-reps ;
: sse1-float-4-shuffle ( dst shuffle -- )
{
{ { 0 1 2 3 } [ drop ] }
{ { 0 1 0 1 } [ dup MOVLHPS ] }
{ { 2 3 2 3 } [ dup MOVHLPS ] }
{ { 0 0 1 1 } [ dup UNPCKLPS ] }
{ { 2 2 3 3 } [ dup UNPCKHPS ] }
[ dupd SHUFPS ]
} case ;
: float-4-shuffle ( dst shuffle -- )
sse3? [
{
{ { 0 0 2 2 } [ dup MOVSLDUP ] }
{ { 1 1 3 3 } [ dup MOVSHDUP ] }
[ sse1-float-4-shuffle ]
} case
] [ sse1-float-4-shuffle ] if ;
: int-4-shuffle ( dst shuffle -- )
{
{ { 0 1 2 3 } [ drop ] }
{ { 0 0 1 1 } [ dup PUNPCKLDQ ] }
{ { 2 2 3 3 } [ dup PUNPCKHDQ ] }
{ { 0 1 0 1 } [ dup PUNPCKLQDQ ] }
{ { 2 3 2 3 } [ dup PUNPCKHQDQ ] }
[ dupd PSHUFD ]
} case ;
: longlong-2-shuffle ( dst shuffle -- )
first2 [ 2 * dup 1 + ] bi@ 4array int-4-shuffle ;
: >float-4-shuffle ( double-2-shuffle -- float-4-shuffle )
[ 2 * { 0 1 } n+v ] map concat ;
M:: x86 %shuffle-vector-imm ( dst src shuffle rep -- )
dst src rep %copy
dst shuffle rep signed-rep {
{ double-2-rep [ >float-4-shuffle float-4-shuffle ] }
{ float-4-rep [ float-4-shuffle ] }
{ int-4-rep [ int-4-shuffle ] }
{ longlong-2-rep [ longlong-2-shuffle ] }
} case ;
M: x86 %shuffle-vector-imm-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M:: x86 %shuffle-vector-halves-imm ( dst src1 src2 shuffle rep -- )
dst src1 src2 rep two-operand
shuffle rep {
{ double-2-rep [ >float-4-shuffle SHUFPS ] }
{ float-4-rep [ SHUFPS ] }
} case ;
M: x86 %shuffle-vector-halves-imm-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep } }
} available-reps ;
M: x86 %shuffle-vector ( dst src shuffle rep -- )
two-operand PSHUFB ;
M: x86 %shuffle-vector-reps
{
{ ssse3? { float-4-rep double-2-rep longlong-2-rep ulonglong-2-rep int-4-rep uint-4-rep short-8-rep ushort-8-rep char-16-rep uchar-16-rep } }
} available-reps ;
M: x86 %merge-vector-head
[ two-operand ] keep
signed-rep {
{ double-2-rep [ MOVLHPS ] }
{ float-4-rep [ UNPCKLPS ] }
{ longlong-2-rep [ PUNPCKLQDQ ] }
{ int-4-rep [ PUNPCKLDQ ] }
{ short-8-rep [ PUNPCKLWD ] }
{ char-16-rep [ PUNPCKLBW ] }
} case ;
M: x86 %merge-vector-tail
[ two-operand ] keep
signed-rep {
{ double-2-rep [ UNPCKHPD ] }
{ float-4-rep [ UNPCKHPS ] }
{ longlong-2-rep [ PUNPCKHQDQ ] }
{ int-4-rep [ PUNPCKHDQ ] }
{ short-8-rep [ PUNPCKHWD ] }
{ char-16-rep [ PUNPCKHBW ] }
} case ;
M: x86 %merge-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %signed-pack-vector
[ two-operand ] keep
{
{ int-4-rep [ PACKSSDW ] }
{ short-8-rep [ PACKSSWB ] }
} case ;
M: x86 %signed-pack-vector-reps
{
{ sse2? { short-8-rep int-4-rep } }
} available-reps ;
M: x86 %unsigned-pack-vector
[ two-operand ] keep
signed-rep {
{ int-4-rep [ PACKUSDW ] }
{ short-8-rep [ PACKUSWB ] }
} case ;
M: x86 %unsigned-pack-vector-reps
{
{ sse2? { short-8-rep } }
{ sse4.1? { int-4-rep } }
} available-reps ;
M: x86 %tail>head-vector ( dst src rep -- )
dup {
{ float-4-rep [ drop UNPCKHPD ] }
{ double-2-rep [ drop UNPCKHPD ] }
[ drop [ %copy ] [ drop PUNPCKHQDQ ] 3bi ]
} case ;
M: x86 %unpack-vector-head ( dst src rep -- )
{
{ char-16-rep [ PMOVSXBW ] }
{ uchar-16-rep [ PMOVZXBW ] }
{ short-8-rep [ PMOVSXWD ] }
{ ushort-8-rep [ PMOVZXWD ] }
{ int-4-rep [ PMOVSXDQ ] }
{ uint-4-rep [ PMOVZXDQ ] }
{ float-4-rep [ CVTPS2PD ] }
} case ;
M: x86 %unpack-vector-head-reps ( -- reps )
{
{ sse2? { float-4-rep } }
{ sse4.1? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ;
M: x86 %integer>float-vector ( dst src rep -- )
{
{ int-4-rep [ CVTDQ2PS ] }
} case ;
M: x86 %integer>float-vector-reps
{
{ sse2? { int-4-rep } }
} available-reps ;
M: x86 %float>integer-vector ( dst src rep -- )
{
{ float-4-rep [ CVTTPS2DQ ] }
} case ;
M: x86 %float>integer-vector-reps
{
{ sse2? { float-4-rep } }
} available-reps ;
: (%compare-float-vector) ( dst src rep double single -- )
[ double-2-rep eq? ] 2dip if ; inline
: %compare-float-vector ( dst src rep cc -- )
{
{ cc< [ [ CMPLTPD ] [ CMPLTPS ] (%compare-float-vector) ] }
{ cc<= [ [ CMPLEPD ] [ CMPLEPS ] (%compare-float-vector) ] }
{ cc= [ [ CMPEQPD ] [ CMPEQPS ] (%compare-float-vector) ] }
{ cc<>= [ [ CMPORDPD ] [ CMPORDPS ] (%compare-float-vector) ] }
{ cc/< [ [ CMPNLTPD ] [ CMPNLTPS ] (%compare-float-vector) ] }
{ cc/<= [ [ CMPNLEPD ] [ CMPNLEPS ] (%compare-float-vector) ] }
{ cc/= [ [ CMPNEQPD ] [ CMPNEQPS ] (%compare-float-vector) ] }
{ cc/<>= [ [ CMPUNORDPD ] [ CMPUNORDPS ] (%compare-float-vector) ] }
} case ;
:: (%compare-int-vector) ( dst src rep int64 int32 int16 int8 -- )
rep signed-rep :> rep'
dst src rep' {
{ longlong-2-rep [ int64 call ] }
{ int-4-rep [ int32 call ] }
{ short-8-rep [ int16 call ] }
{ char-16-rep [ int8 call ] }
} case ; inline
: %compare-int-vector ( dst src rep cc -- )
{
{ cc= [ [ PCMPEQQ ] [ PCMPEQD ] [ PCMPEQW ] [ PCMPEQB ] (%compare-int-vector) ] }
{ cc> [ [ PCMPGTQ ] [ PCMPGTD ] [ PCMPGTW ] [ PCMPGTB ] (%compare-int-vector) ] }
} case ;
M: x86 %compare-vector ( dst src1 src2 rep cc -- )
[ [ two-operand ] keep ] dip
over float-vector-rep?
[ %compare-float-vector ]
[ %compare-int-vector ] if ;
: %compare-vector-eq-reps ( -- reps )
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
{ sse4.1? { longlong-2-rep ulonglong-2-rep } }
} available-reps ;
: %compare-vector-ord-reps ( -- reps )
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep short-8-rep int-4-rep } }
{ sse4.2? { longlong-2-rep } }
} available-reps ;
M: x86 %compare-vector-reps
{
{ [ dup { cc= cc/= cc/<>= cc<>= } member-eq? ] [ drop %compare-vector-eq-reps ] }
[ drop %compare-vector-ord-reps ]
} cond ;
: %compare-float-vector-ccs ( cc -- ccs not? )
{
{ cc< [ { { cc< f } } f ] }
{ cc<= [ { { cc<= f } } f ] }
{ cc> [ { { cc< t } } f ] }
{ cc>= [ { { cc<= t } } f ] }
{ cc= [ { { cc= f } } f ] }
{ cc<> [ { { cc< f } { cc< t } } f ] }
{ cc<>= [ { { cc<>= f } } f ] }
{ cc/< [ { { cc/< f } } f ] }
{ cc/<= [ { { cc/<= f } } f ] }
{ cc/> [ { { cc/< t } } f ] }
{ cc/>= [ { { cc/<= t } } f ] }
{ cc/= [ { { cc/= f } } f ] }
{ cc/<> [ { { cc/= f } { cc/<>= f } } f ] }
{ cc/<>= [ { { cc/<>= f } } f ] }
} case ;
: %compare-int-vector-ccs ( cc -- ccs not? )
order-cc {
{ cc< [ { { cc> t } } f ] }
{ cc<= [ { { cc> f } } t ] }
{ cc> [ { { cc> f } } f ] }
{ cc>= [ { { cc> t } } t ] }
{ cc= [ { { cc= f } } f ] }
{ cc/= [ { { cc= f } } t ] }
{ t [ { } t ] }
{ f [ { } f ] }
} case ;
M: x86 %compare-vector-ccs
swap float-vector-rep?
[ %compare-float-vector-ccs ]
[ %compare-int-vector-ccs ] if ;
:: %test-vector-mask ( dst temp mask vcc -- )
vcc {
{ vcc-any [ dst dst TEST dst temp \ CMOVNE (%boolean) ] }
{ vcc-none [ dst dst TEST dst temp \ CMOVE (%boolean) ] }
{ vcc-all [ dst mask CMP dst temp \ CMOVE (%boolean) ] }
{ vcc-notall [ dst mask CMP dst temp \ CMOVNE (%boolean) ] }
} case ;
: %move-vector-mask ( dst src rep -- mask )
{
{ double-2-rep [ MOVMSKPS HEX: f ] }
{ float-4-rep [ MOVMSKPS HEX: f ] }
[ drop PMOVMSKB HEX: ffff ]
} case ;
M:: x86 %test-vector ( dst src temp rep vcc -- )
dst src rep %move-vector-mask :> mask
dst temp mask vcc %test-vector-mask ;
:: %test-vector-mask-branch ( label temp mask vcc -- )
vcc {
{ vcc-any [ temp temp TEST label JNE ] }
{ vcc-none [ temp temp TEST label JE ] }
{ vcc-all [ temp mask CMP label JE ] }
{ vcc-notall [ temp mask CMP label JNE ] }
} case ;
M:: x86 %test-vector-branch ( label src temp rep vcc -- )
temp src rep %move-vector-mask :> mask
label temp mask vcc %test-vector-mask-branch ;
M: x86 %test-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %add-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ float-4-rep [ ADDPS ] }
{ double-2-rep [ ADDPD ] }
{ char-16-rep [ PADDB ] }
{ uchar-16-rep [ PADDB ] }
{ short-8-rep [ PADDW ] }
{ ushort-8-rep [ PADDW ] }
{ int-4-rep [ PADDD ] }
{ uint-4-rep [ PADDD ] }
{ longlong-2-rep [ PADDQ ] }
{ ulonglong-2-rep [ PADDQ ] }
} case ;
M: x86 %add-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %saturated-add-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ char-16-rep [ PADDSB ] }
{ uchar-16-rep [ PADDUSB ] }
{ short-8-rep [ PADDSW ] }
{ ushort-8-rep [ PADDUSW ] }
} case ;
M: x86 %saturated-add-vector-reps
{
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
} available-reps ;
M: x86 %add-sub-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ float-4-rep [ ADDSUBPS ] }
{ double-2-rep [ ADDSUBPD ] }
} case ;
M: x86 %add-sub-vector-reps
{
{ sse3? { float-4-rep double-2-rep } }
} available-reps ;
M: x86 %sub-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ float-4-rep [ SUBPS ] }
{ double-2-rep [ SUBPD ] }
{ char-16-rep [ PSUBB ] }
{ uchar-16-rep [ PSUBB ] }
{ short-8-rep [ PSUBW ] }
{ ushort-8-rep [ PSUBW ] }
{ int-4-rep [ PSUBD ] }
{ uint-4-rep [ PSUBD ] }
{ longlong-2-rep [ PSUBQ ] }
{ ulonglong-2-rep [ PSUBQ ] }
} case ;
M: x86 %sub-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %saturated-sub-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ char-16-rep [ PSUBSB ] }
{ uchar-16-rep [ PSUBUSB ] }
{ short-8-rep [ PSUBSW ] }
{ ushort-8-rep [ PSUBUSW ] }
} case ;
M: x86 %saturated-sub-vector-reps
{
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
} available-reps ;
M: x86 %mul-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ float-4-rep [ MULPS ] }
{ double-2-rep [ MULPD ] }
{ short-8-rep [ PMULLW ] }
{ ushort-8-rep [ PMULLW ] }
{ int-4-rep [ PMULLD ] }
{ uint-4-rep [ PMULLD ] }
} case ;
M: x86 %mul-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep short-8-rep ushort-8-rep } }
{ sse4.1? { int-4-rep uint-4-rep } }
} available-reps ;
M: x86 %mul-high-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ short-8-rep [ PMULHW ] }
{ ushort-8-rep [ PMULHUW ] }
} case ;
M: x86 %mul-high-vector-reps
{
{ sse2? { short-8-rep ushort-8-rep } }
} available-reps ;
M: x86 %mul-horizontal-add-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ char-16-rep [ PMADDUBSW ] }
{ uchar-16-rep [ PMADDUBSW ] }
{ short-8-rep [ PMADDWD ] }
} case ;
M: x86 %mul-horizontal-add-vector-reps
{
{ sse2? { short-8-rep } }
{ ssse3? { char-16-rep uchar-16-rep } }
} available-reps ;
M: x86 %div-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ float-4-rep [ DIVPS ] }
{ double-2-rep [ DIVPD ] }
} case ;
M: x86 %div-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep } }
} available-reps ;
M: x86 %min-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ char-16-rep [ PMINSB ] }
{ uchar-16-rep [ PMINUB ] }
{ short-8-rep [ PMINSW ] }
{ ushort-8-rep [ PMINUW ] }
{ int-4-rep [ PMINSD ] }
{ uint-4-rep [ PMINUD ] }
{ float-4-rep [ MINPS ] }
{ double-2-rep [ MINPD ] }
} case ;
M: x86 %min-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { uchar-16-rep short-8-rep double-2-rep } }
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ;
M: x86 %max-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ char-16-rep [ PMAXSB ] }
{ uchar-16-rep [ PMAXUB ] }
{ short-8-rep [ PMAXSW ] }
{ ushort-8-rep [ PMAXUW ] }
{ int-4-rep [ PMAXSD ] }
{ uint-4-rep [ PMAXUD ] }
{ float-4-rep [ MAXPS ] }
{ double-2-rep [ MAXPD ] }
} case ;
M: x86 %max-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { uchar-16-rep short-8-rep double-2-rep } }
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ;
M: x86 %avg-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ uchar-16-rep [ PAVGB ] }
{ ushort-8-rep [ PAVGW ] }
} case ;
M: x86 %avg-vector-reps
{
{ sse2? { uchar-16-rep ushort-8-rep } }
} available-reps ;
M: x86 %dot-vector
[ two-operand ] keep
{
{ float-4-rep [ HEX: ff DPPS ] }
{ double-2-rep [ HEX: ff DPPD ] }
} case ;
M: x86 %dot-vector-reps
{
{ sse4.1? { float-4-rep double-2-rep } }
} available-reps ;
M: x86 %sad-vector
[ two-operand ] keep
{
{ uchar-16-rep [ PSADBW ] }
} case ;
M: x86 %sad-vector-reps
{
{ sse2? { uchar-16-rep } }
} available-reps ;
M: x86 %horizontal-add-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
signed-rep {
{ float-4-rep [ HADDPS ] }
{ double-2-rep [ HADDPD ] }
{ int-4-rep [ PHADDD ] }
{ short-8-rep [ PHADDW ] }
} case ;
M: x86 %horizontal-add-vector-reps
{
{ sse3? { float-4-rep double-2-rep } }
{ ssse3? { int-4-rep uint-4-rep short-8-rep ushort-8-rep } }
} available-reps ;
M: x86 %horizontal-shl-vector-imm ( dst src1 src2 rep -- )
two-operand PSLLDQ ;
M: x86 %horizontal-shl-vector-imm-reps
{
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } }
} available-reps ;
M: x86 %horizontal-shr-vector-imm ( dst src1 src2 rep -- )
two-operand PSRLDQ ;
M: x86 %horizontal-shr-vector-imm-reps
{
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } }
} available-reps ;
M: x86 %abs-vector ( dst src rep -- )
{
{ char-16-rep [ PABSB ] }
{ short-8-rep [ PABSW ] }
{ int-4-rep [ PABSD ] }
} case ;
M: x86 %abs-vector-reps
{
{ ssse3? { char-16-rep short-8-rep int-4-rep } }
} available-reps ;
M: x86 %sqrt-vector ( dst src rep -- )
{
{ float-4-rep [ SQRTPS ] }
{ double-2-rep [ SQRTPD ] }
} case ;
M: x86 %sqrt-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep } }
} available-reps ;
M: x86 %and-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ float-4-rep [ ANDPS ] }
{ double-2-rep [ ANDPS ] }
[ drop PAND ]
} case ;
M: x86 %and-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %andn-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ float-4-rep [ ANDNPS ] }
{ double-2-rep [ ANDNPS ] }
[ drop PANDN ]
} case ;
M: x86 %andn-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %or-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ float-4-rep [ ORPS ] }
{ double-2-rep [ ORPS ] }
[ drop POR ]
} case ;
M: x86 %or-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %xor-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ float-4-rep [ XORPS ] }
{ double-2-rep [ XORPS ] }
[ drop PXOR ]
} case ;
M: x86 %xor-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %shl-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ short-8-rep [ PSLLW ] }
{ ushort-8-rep [ PSLLW ] }
{ int-4-rep [ PSLLD ] }
{ uint-4-rep [ PSLLD ] }
{ longlong-2-rep [ PSLLQ ] }
{ ulonglong-2-rep [ PSLLQ ] }
} case ;
M: x86 %shl-vector-reps
{
{ sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %shr-vector ( dst src1 src2 rep -- )
[ two-operand ] keep
{
{ short-8-rep [ PSRAW ] }
{ ushort-8-rep [ PSRLW ] }
{ int-4-rep [ PSRAD ] }
{ uint-4-rep [ PSRLD ] }
{ ulonglong-2-rep [ PSRLQ ] }
} case ;
M: x86 %shr-vector-reps
{
{ sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %shl-vector-imm %shl-vector ;
M: x86 %shl-vector-imm-reps %shl-vector-reps ;
M: x86 %shr-vector-imm %shr-vector ;
M: x86 %shr-vector-imm-reps %shr-vector-reps ;
: scalar-sized-reg ( reg rep -- reg' )
rep-size 8 * n-bit-version-of ;
M: x86 %integer>scalar drop MOVD ;
:: %scalar>integer-32 ( dst src rep -- )
rep {
{ int-scalar-rep [
dst 32-bit-version-of src MOVD
dst dst 32-bit-version-of
2dup eq? [ 2drop ] [ MOVSX ] if
] }
{ uint-scalar-rep [
dst 32-bit-version-of src MOVD
] }
{ short-scalar-rep [
dst 32-bit-version-of src MOVD
dst dst 16-bit-version-of MOVSX
] }
{ ushort-scalar-rep [
dst 32-bit-version-of src MOVD
dst dst 16-bit-version-of MOVZX
] }
{ char-scalar-rep [
dst 32-bit-version-of src MOVD
dst { } 8 [| tmp-dst |
tmp-dst dst int-rep %copy
tmp-dst tmp-dst 8-bit-version-of MOVSX
dst tmp-dst int-rep %copy
] with-small-register
] }
{ uchar-scalar-rep [
dst 32-bit-version-of src MOVD
dst { } 8 [| tmp-dst |
tmp-dst dst int-rep %copy
tmp-dst tmp-dst 8-bit-version-of MOVZX
dst tmp-dst int-rep %copy
] with-small-register
] }
} case ;
M: x86.32 %scalar>integer ( dst src rep -- ) %scalar>integer-32 ;
M: x86.64 %scalar>integer ( dst src rep -- )
{
{ longlong-scalar-rep [ MOVD ] }
{ ulonglong-scalar-rep [ MOVD ] }
[ %scalar>integer-32 ]
} case ;
M: x86 %vector>scalar %copy ;
M: x86 %scalar>vector %copy ;
enable-float-intrinsics
enable-float-functions
enable-float-min/max
enable-fsqrt

1
basis/cpu/x86/sse/tags.txt Normal file
View File

@ -0,0 +1 @@
not loaded

1058
basis/cpu/x86/x86.factor
View File

File diff suppressed because it is too large Load Diff

1
basis/cpu/x86/x87/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/cpu/x86/x87/tags.txt Normal file
View File

@ -0,0 +1 @@
not loaded

103
basis/cpu/x86/x87/x87.factor Normal file
View File

@ -0,0 +1,103 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel locals system namespaces
compiler.codegen.fixup compiler.constants
compiler.cfg.comparisons compiler.cfg.intrinsics
cpu.architecture cpu.x86 cpu.x86.assembler
cpu.x86.assembler.operands ;
IN: cpu.x86.x87
! x87 unit is only used if SSE2 is not available.
: copy-register-x87 ( dst src -- )
2dup eq? [ 2drop ] [ FLD shuffle-down FSTP ] if ;
M: float-rep copy-register* drop copy-register-x87 ;
M: double-rep copy-register* drop copy-register-x87 ;
: load-x87 ( dst src rep -- )
{
{ float-rep [ FLDS shuffle-down FSTP ] }
{ double-rep [ FLDL shuffle-down FSTP ] }
} case ;
: store-x87 ( dst src rep -- )
{
{ float-rep [ FLD FSTPS ] }
{ double-rep [ FLD FSTPL ] }
} case ;
: copy-memory-x87 ( dst src rep -- )
{
{ [ pick register? ] [ load-x87 ] }
{ [ over register? ] [ store-x87 ] }
} cond ;
M: float-rep copy-memory* copy-memory-x87 ;
M: double-rep copy-memory* copy-memory-x87 ;
M: x86 %load-float
0 [] FLDS
<float> rc-absolute rel-binary-literal
shuffle-down FSTP ;
M: x86 %load-double
0 [] FLDL
<double> rc-absolute rel-binary-literal
shuffle-down FSTP ;
:: binary-op ( dst src1 src2 quot -- )
src1 FLD
ST0 src2 shuffle-down quot call
dst shuffle-down FSTP ; inline
M: x86 %add-float [ FADD ] binary-op ;
M: x86 %sub-float [ FSUB ] binary-op ;
M: x86 %mul-float [ FMUL ] binary-op ;
M: x86 %div-float [ FDIV ] binary-op ;
M: x86 %sqrt FLD FSQRT shuffle-down FSTP ;
M: x86 %single>double-float copy-register-x87 ;
M: x86 %double>single-float copy-register-x87 ;
M: x86 integer-float-needs-stack-frame? t ;
M:: x86 %integer>float ( dst src -- )
4 stack@ src MOV
4 stack@ FILDD
dst shuffle-down FSTP ;
M:: x86 %float>integer ( dst src -- )
src FLD
8 stack@ EAX MOV
0 stack@ FNSTCW
AX 0 stack@ MOV
AH 12 <byte> MOV
2 stack@ AX MOV
2 stack@ FLDCW
4 stack@ FISTPD
0 stack@ FLDCW
EAX 8 stack@ MOV
dst 4 stack@ MOV ;
:: compare-op ( src1 src2 quot -- )
src1 FLD
src2 shuffle-down quot call
ST0 FSTP ; inline
M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
[ [ FCOMI ] compare-op ] (%compare-float) ;
M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
[ [ FUCOMI ] compare-op ] (%compare-float) ;
M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
[ [ FCOMI ] compare-op ] (%compare-float-branch) ;
M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
[ [ FUCOMI ] compare-op ] (%compare-float-branch) ;
enable-float-intrinsics
enable-float-functions
enable-fsqrt

2
basis/db/tuples/tuples.factor
View File

@ -75,7 +75,7 @@ PRIVATE>
ERROR: no-slots-named class seq ;
: check-columns ( class columns -- )
[ nip ] [
[ [ first ] map ]
[ keys ]
[ all-slots [ name>> ] map ] bi* diff
] 2bi
[ drop ] [ no-slots-named ] if-empty ;

2
basis/furnace/cache/cache.factor vendored
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math.intervals
system calendar alarms fry
system calendar fry
random db db.tuples db.types
http.server.filters ;
IN: furnace.cache

7
basis/game/input/x11/x11.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2010 Erik Charlebois, William Schlieper.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays kernel game.input namespaces math
classes bit-arrays system sequences vectors x11 x11.xlib ;
USING: accessors alien.c-types arrays kernel game.input
namespaces math classes bit-arrays system sequences vectors
x11 x11.xlib assocs ;
IN: game.input.x11
SINGLETON: x11-game-input-backend
@ -77,7 +78,7 @@ M: linux x>hid-bit-order
} ; inline
: x-bits>hid-bits ( bit-array -- bit-array )
256 iota [ 2array ] { } 2map-as [ first ] filter [ second ] map
256 iota [ 2array ] { } 2map-as [ first ] filter values
x>hid-bit-order [ nth ] curry map
256 <bit-array> swap [ t swap pick set-nth ] each ;

116
basis/generalizations/generalizations-docs.factor
View File

@ -2,59 +2,10 @@ USING: help.syntax help.markup kernel sequences quotations
math arrays combinators ;
IN: generalizations
HELP: nsequence
{ $values { "n" integer } { "seq" "an exemplar" } }
{ $description "A generalization of " { $link 2sequence } ", "
{ $link 3sequence } ", and " { $link 4sequence } " "
"that constructs a sequence from the top " { $snippet "n" } " elements of the stack."
}
{ $examples
{ $example "USING: generalizations prettyprint ;" "CHAR: f CHAR: i CHAR: s CHAR: h 4 \"\" nsequence ." "\"fish\"" }
} ;
HELP: narray
{ $values { "n" integer } }
{ $description "A generalization of " { $link 1array } ", "
{ $link 2array } ", " { $link 3array } " and " { $link 4array } " "
"that constructs an array from the top " { $snippet "n" } " elements of the stack."
}
{ $examples
"Some core words expressed in terms of " { $link narray } ":"
{ $table
{ { $link 1array } { $snippet "1 narray" } }
{ { $link 2array } { $snippet "2 narray" } }
{ { $link 3array } { $snippet "3 narray" } }
{ { $link 4array } { $snippet "4 narray" } }
}
} ;
{ nsequence narray } related-words
HELP: nsum
{ $values { "n" integer } }
{ $description "Adds the top " { $snippet "n" } " stack values." } ;
HELP: firstn
{ $values { "n" integer } }
{ $description "A generalization of " { $link first } ", "
{ $link first2 } ", " { $link first3 } " and " { $link first4 } " "
"that pushes the first " { $snippet "n" } " elements of a sequence on the stack."
}
{ $examples
"Some core words expressed in terms of " { $link firstn } ":"
{ $table
{ { $link first } { $snippet "1 firstn" } }
{ { $link first2 } { $snippet "2 firstn" } }
{ { $link first3 } { $snippet "3 firstn" } }
{ { $link first4 } { $snippet "4 firstn" } }
}
} ;
HELP: set-firstn
{ $values { "n" integer } }
{ $description "A generalization of " { $link set-first } " "
"that sets the first " { $snippet "n" } " elements of a sequence from the top " { $snippet "n" } " elements of the stack." } ;
HELP: npick
{ $values { "n" integer } }
{ $description "A generalization of " { $link dup } ", "
@ -63,7 +14,13 @@ HELP: npick
"placed on the top of the stack."
}
{ $examples
{ $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick 5 narray ." "{ 1 2 3 4 1 }" }
{ $example
"USING: kernel generalizations prettyprint"
"sequences.generalizations ;"
""
"1 2 3 4 4 npick 5 narray ."
"{ 1 2 3 4 1 }"
}
"Some core words expressed in terms of " { $link npick } ":"
{ $table
{ { $link dup } { $snippet "1 npick" } }
@ -80,7 +37,13 @@ HELP: ndup
"placed on the top of the stack."
}
{ $examples
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup 8 narray ." "{ 1 2 3 4 1 2 3 4 }" }
{ $example
"USING: prettyprint generalizations kernel"
"sequences.generalizations ;"
""
"1 2 3 4 4 ndup 8 narray ."
"{ 1 2 3 4 1 2 3 4 }"
}
"Some core words expressed in terms of " { $link ndup } ":"
{ $table
{ { $link dup } { $snippet "1 ndup" } }
@ -178,7 +141,13 @@ HELP: nkeep
"saved, the quotation called, and the items restored."
}
{ $examples
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ." "{ 99 1 2 3 4 5 }" }
{ $example
"USING: generalizations kernel prettyprint"
"sequences.generalizations ;"
""
"1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ."
"{ 99 1 2 3 4 5 }"
}
"Some core words expressed in terms of " { $link nkeep } ":"
{ $table
{ { $link keep } { $snippet "1 nkeep" } }
@ -302,46 +271,6 @@ HELP: n*quot
}
{ $description "Construct a quotation containing the contents of " { $snippet "seq" } " repeated " { $snippet "n"} " times." } ;
HELP: nappend
{ $values
{ "n" integer }
{ "seq" sequence }
}
{ $description "Outputs a new sequence consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }
{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }
{ $examples
{ $example "USING: generalizations prettyprint math ;"
"{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 nappend ."
"{ 1 2 3 4 5 6 7 8 }"
}
} ;
HELP: nappend-as
{ $values
{ "n" integer } { "exemplar" sequence }
{ "seq" sequence }
}
{ $description "Outputs a new sequence of type " { $snippet "exemplar" } " consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }
{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }
{ $examples
{ $example "USING: generalizations prettyprint math ;"
"{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 V{ } nappend-as ."
"V{ 1 2 3 4 5 6 7 8 }"
}
} ;
{ nappend nappend-as } related-words
ARTICLE: "sequence-generalizations" "Generalized sequence operations"
{ $subsections
narray
nsequence
firstn
set-firstn
nappend
nappend-as
} ;
ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
{ $subsections
ndup
@ -381,11 +310,10 @@ ARTICLE: "generalizations" "Generalized shuffle words and combinators"
"macros where the arity of the input quotations depends on an "
"input parameter."
{ $subsections
"sequence-generalizations"
"shuffle-generalizations"
"combinator-generalizations"
"other-generalizations"
}
"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence iteration combinators." ;
"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence operations." ;
ABOUT: "generalizations"

14
basis/generalizations/generalizations-tests.factor
View File

@ -39,24 +39,10 @@ IN: generalizations.tests
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
[ { 1 2 3 4 } ] [ 1 2 3 4 { f f f f } [ 4 set-firstn ] keep ] unit-test
[ 1 2 3 4 { f f f } [ 4 set-firstn ] keep ] must-fail
[ ] [ { } 0 firstn ] unit-test
[ "a" ] [ { "a" } 1 firstn ] unit-test
[ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test
[ 4 5 1 2 3 ] [ 1 2 3 4 5 2 3 mnswap ] unit-test
[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 2 4 mnswap 4 2 mnswap ] unit-test
[ { 1 2 3 4 } ] [ { 1 } { 2 } { 3 } { 4 } 4 nappend ] unit-test
[ V{ 1 2 3 4 } ] [ { 1 } { 2 } { 3 } { 4 } 4 V{ } nappend-as ] unit-test
[ 4 nappend ] must-infer
[ 4 { } nappend-as ] must-infer
[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test
{ 4 1 } [ 4 nsum ] must-infer-as

35
basis/generalizations/generalizations.factor
View File

@ -14,26 +14,9 @@ ALIAS: n*quot (n*quot)
>>
MACRO: nsequence ( n seq -- )
[ [nsequence] ] keep
'[ @ _ like ] ;
MACRO: narray ( n -- )
'[ _ { } nsequence ] ;
MACRO: nsum ( n -- )
1 - [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- )
[firstn] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ 1 - swap bounds-check 2drop ]
[ firstn-unsafe ]
bi-curry '[ _ _ bi ]
] if ;
MACRO: npick ( n -- )
1 - [ dup ] [ '[ _ dip swap ] ] repeat ;
@ -53,18 +36,6 @@ MACRO: nrot ( n -- )
MACRO: -nrot ( n -- )
1 - [ ] [ '[ swap _ dip ] ] repeat ;
MACRO: set-firstn-unsafe ( n -- )
[ 1 + ]
[ iota [ '[ _ rot [ set-nth-unsafe ] keep ] ] map ] bi
'[ _ -nrot _ spread drop ] ;
MACRO: set-firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ 1 - swap bounds-check 2drop ]
[ set-firstn-unsafe ]
bi-curry '[ _ _ bi ]
] if ;
MACRO: ndrop ( n -- )
[ drop ] n*quot ;
@ -143,9 +114,3 @@ MACRO: nweave ( n -- )
MACRO: nbi-curry ( n -- )
[ bi-curry ] n*quot ;
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline
: nappend ( n -- seq ) narray concat ; inline

8
basis/grouping/grouping-docs.factor
View File

@ -32,8 +32,8 @@ ARTICLE: "grouping" "Groups and clumps"
"{ 1 2 3 4 } 2 clump ." "{ { 1 2 } { 2 3 } { 3 4 } }"
}
{ $unchecked-example
"USING: grouping ;"
"{ 1 2 3 4 } dup" "2 <clumps> unclip-last [ [ first ] map ] dip append sequence= ." "t"
"USING: grouping assocs sequences ;"
"{ 1 2 3 4 } dup" "2 <clumps> unclip-last [ keys ] dip append sequence= ." "t"
}
}
{ "With circular clumps, collecting the first element of each subsequence yields the original sequence. Collecting the " { $snippet "n" } "th element of each subsequence would rotate the original sequence " { $snippet "n" } " elements rightward:"
@ -42,8 +42,8 @@ ARTICLE: "grouping" "Groups and clumps"
"{ 1 2 3 4 } 2 circular-clump ." "{ { 1 2 } { 2 3 } { 3 4 } { 4 1 } }"
}
{ $unchecked-example
"USING: grouping ;"
"{ 1 2 3 4 } dup" "2 <circular-clumps> [ first ] map sequence= ." "t"
"USING: grouping assocs sequences ;"
"{ 1 2 3 4 } dup" "2 <circular-clumps> keys sequence= ." "t"
}
{ $unchecked-example
"USING: grouping ;"

2
basis/help/lint/checks/checks.factor
View File

@ -34,7 +34,7 @@ SYMBOL: vocab-articles
: extract-values ( element -- seq )
\ $values swap elements dup empty? [
first rest [ first ] map
first rest keys
] unless ;
: extract-value-effects ( element -- seq )

4
basis/images/bitmap/bitmap.factor
View File

@ -281,7 +281,7 @@ ERROR: bmp-not-supported n ;
{ 24 [ color-index>> ] }
{ 16 [
[
! byte-array>ushort-array
! ushort-array-cast
2 group [ le> ] map
! 5 6 5
! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
@ -312,7 +312,7 @@ M: unsupported-bitfield-widths summary
dup header>> bit-count>> {
{ 16 [
dup bitfields>> '[
byte-array>ushort-array _ uncompress-bitfield
ushort-array-cast _ uncompress-bitfield
] change-color-index
] }
{ 32 [ ] }

6
basis/images/normalization/normalization.factor
View File

@ -47,13 +47,13 @@ GENERIC: normalize-component-type* ( image component-type -- image )
[ 255.0 * >integer ] B{ } map-as ;
M: float-components normalize-component-type*
drop byte-array>float-array normalize-floats ;
drop float-array-cast normalize-floats ;
M: half-components normalize-component-type*
drop byte-array>half-array normalize-floats ;
drop half-array-cast normalize-floats ;
: ushorts>ubytes ( bitmap -- bitmap' )
byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
ushort-array-cast [ -8 shift ] B{ } map-as ; inline
M: ushort-components normalize-component-type*
drop ushorts>ubytes ;

2
basis/inverse/inverse.factor
View File

@ -6,7 +6,7 @@ classes.tuple namespaces make vectors bit-arrays byte-arrays
strings sbufs math.functions macros sequences.private
combinators mirrors splitting combinators.smart
combinators.short-circuit fry words.symbol generalizations
classes ;
sequences.generalizations classes ;
IN: inverse
ERROR: fail ;

9
basis/io/backend/unix/unix.factor
View File

@ -144,7 +144,7 @@ M: stdin dispose*
tri
] with-destructors ;
: wait-for-stdin ( stdin -- n )
: wait-for-stdin ( stdin -- size )
[ control>> CHAR: X over io:stream-write1 io:stream-flush ]
[ size>> ssize_t heap-size swap io:stream-read *int ]
bi ;
@ -160,7 +160,12 @@ M: stdin dispose*
] if ;
M: stdin refill
[ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ;
'[
buffer>> _ dup wait-for-stdin refill-stdin f
] with-timeout ;
M: stdin cancel-operation
[ size>> ] [ control>> ] bi [ cancel-operation ] bi@ ;
: control-write-fd ( -- fd ) &: control_write *uint ;

Some files were not shown because too many files have changed in this diff Show More