IN: alarms\r
\r
HELP: alarm\r
-{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;\r
+{ $class-description "An alarm. Can be passed to " { $link stop-alarm } "." } ;\r
\r
-HELP: current-alarm\r
-{ $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."\r
-}\r
+HELP: start-alarm\r
+{ $values { "alarm" alarm } }\r
+{ $description "Starts an alarm." } ;\r
+\r
+HELP: stop-alarm\r
+{ $values { "alarm" alarm } }\r
+{ $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ;\r
+\r
+HELP: every\r
+{ $values\r
+ { "quot" quotation } { "interval-duration" duration }\r
+ { "alarm" alarm } }\r
+{ $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." }\r
{ $examples\r
{ $unchecked-example\r
- """USING: alarms calendar io threads ;"""\r
- """["""\r
- """ "Hi, this should only get printed once..." print flush"""\r
- """ current-alarm get cancel-alarm"""\r
- """] 1 seconds every"""\r
+ "USING: alarms io calendar ;"\r
+ """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
""\r
}\r
} ;\r
\r
-HELP: add-alarm\r
-{ $values { "quot" quotation } { "start" duration } { "interval" { $maybe "duration/f" } } { "alarm" alarm } }\r
-{ $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." } ;\r
-\r
HELP: later\r
-{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }\r
-{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "duration" } " offset from now." }\r
+{ $values { "quot" quotation } { "delay-duration" duration } { "alarm" alarm } }\r
+{ $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." }\r
{ $examples\r
{ $unchecked-example\r
"USING: alarms io calendar ;"\r
- """[ "Break's over!" print flush ] 15 minutes drop"""\r
+ """[ "Break's over!" print flush ] 15 minutes later drop"""\r
""\r
}\r
} ;\r
\r
-HELP: cancel-alarm\r
-{ $values { "alarm" alarm } }\r
-{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;\r
-\r
-HELP: every\r
+HELP: delayed-every\r
{ $values\r
{ "quot" quotation } { "duration" duration }\r
{ "alarm" alarm } }\r
-{ $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." }\r
+{ $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." }\r
{ $examples\r
{ $unchecked-example\r
"USING: alarms io calendar ;"\r
} ;\r
\r
ARTICLE: "alarms" "Alarms"\r
-"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\r
+"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\r
"The alarm class:"\r
{ $subsections alarm }\r
-"Register a recurring alarm:"\r
+"Create an alarm before starting it:"\r
+{ $subsections <alarm> }\r
+"Starting an alarm:"\r
+{ $subsections start-alarm }\r
+"Stopping an alarm:"\r
+{ $subsections stop-alarm }\r
+\r
+"A recurring alarm without an initial delay:"\r
{ $subsections every }\r
-"Register a one-time alarm:"\r
+"A one-time alarm with an initial delay:"\r
{ $subsections later }\r
-"The currently executing alarm:"\r
-{ $subsections current-alarm }\r
-"Low-level interface to add alarms:"\r
-{ $subsections add-alarm }\r
-"Cancelling an alarm:"\r
-{ $subsections cancel-alarm }\r
-"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." ;\r
+"A recurring alarm with an initial delay:"\r
+{ $subsections delayed-every } ;\r
\r
ABOUT: "alarms"\r
-USING: alarms alarms.private kernel calendar sequences\r
-tools.test threads concurrency.count-downs ;\r
+USING: alarms alarms.private calendar concurrency.count-downs\r
+concurrency.promises fry kernel math math.order sequences\r
+threads tools.test tools.time ;\r
IN: alarms.tests\r
\r
[ ] [\r
1 <count-down>\r
{ f } clone 2dup\r
- [ first cancel-alarm count-down ] 2curry 1 seconds later\r
+ [ first stop-alarm count-down ] 2curry 1 seconds later\r
swap set-first\r
await\r
] unit-test\r
self [ resume ] curry instant later drop\r
"test" suspend drop\r
] unit-test\r
+\r
+[ t ] [\r
+ [\r
+ <promise>\r
+ [ '[ t _ fulfill ] 2 seconds later drop ]\r
+ [ 5 seconds ?promise-timeout drop ] bi\r
+ ] benchmark 1,500,000,000 2,500,000,000 between?\r
+] unit-test\r
+\r
+[ { 3 } ] [\r
+ { 3 } dup\r
+ '[ 4 _ set-first ] 2 seconds later\r
+ 1/2 seconds sleep\r
+ stop-alarm\r
+] unit-test\r
! 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 ;
-
-: register-alarm ( alarm -- )
- [ dup start>> alarms get-global heap-push* ]
- [ entry>> >box ] bi
- notify-alarm-thread ;
-
-: alarm-expired? ( alarm n -- ? )
- [ start>> ] dip <= ;
-
-: reschedule-alarm ( alarm -- )
- dup interval>> nano-count + >>start register-alarm ;
-
-: 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
+: 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
+
+DEFER: call-alarm-loop
+
+: 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 ;
+
+: maybe-loop-alarm ( alarm -- )
+ dup { [ stop?>> ] [ interval-nanos>> not ] } 1||
+ [ drop ] [ loop-alarm ] if ;
+
+: 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) ;
+: call-alarm ( alarm -- )
+ [ delay-nanos>> ] [ ] bi
+ '[ _ [ sleep ] when* _ call-alarm-loop ] "Alarm execution" spawn drop ;
-: next-alarm ( alarms -- nanos/f )
- dup heap-empty? [ drop f ] [ heap-peek drop start>> ] if ;
+PRIVATE>
-: alarm-thread-loop ( -- )
- alarms get-global
- dup next-alarm sleep-until
- trigger-alarms ;
+: <alarm> ( quot delay-duration/f interval-duration/f -- alarm )
+ alarm new
+ swap >nanoseconds >>interval-nanos
+ swap >nanoseconds >>delay-nanos
+ swap >>quot ; inline
+
+: start-alarm ( alarm -- )
+ f >>stop?
+ nano-count >>start-nanos
+ call-alarm ;
-: cancel-alarms ( alarms -- )
- [
- heap-pop-all [ nip entry>> box> drop ] assoc-each
- ] when* ;
+: stop-alarm ( alarm -- )
+ t >>stop?
+ f >>start-nanos
+ drop ;
-: init-alarms ( -- )
- alarms [ cancel-alarms <min-heap> ] change-global
- [ alarm-thread-loop t ] "Alarms" spawn-server
- alarm-thread set-global ;
+<PRIVATE
-[ init-alarms ] "alarms" add-startup-hook
+: (start-alarm) ( quot start-duration interval-duration -- alarm )
+ <alarm> [ start-alarm ] keep ;
PRIVATE>
-: add-alarm ( quot start interval -- alarm )
- <alarm> [ register-alarm ] keep ;
+: every ( quot interval-duration -- alarm )
+ [ f ] dip (start-alarm) ;
-: later ( quot duration -- alarm ) f add-alarm ;
+: later ( quot delay-duration -- alarm )
+ f (start-alarm) ;
-: every ( quot duration -- alarm ) dup add-alarm ;
+: delayed-every ( quot duration -- alarm )
+ dup (start-alarm) ;
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 ;
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
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" } }
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
long ulong
longlong ulonglong
float double
- void* bool
- (stack-value) ;
+ void* bool ;
SINGLETON: void
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>> ;
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
c-type-align
c-type-align-first
base-type
- heap-size
- stack-size ;
+ heap-size ;
CONSULT: c-type-protocol c-type-name
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 -- )
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 ] [
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
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 ;
! (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 -- )
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
! (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
! 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) ;
libraries [ H{ } clone ] initialize
-TUPLE: library path abi dll ;
+TUPLE: library { path string } { abi abi initial: cdecl } dll ;
ERROR: no-library name ;
"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 ;
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 )
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
\ No newline at end of file
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
] 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 ;
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) ]
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
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 ]
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 ] ;
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 ] }
! 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' )
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{
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
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
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
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
[
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
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
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
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
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
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
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
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
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
! 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
! 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
: 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
: 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 )
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
-
- \ ##vm-field set-new-ac
- \ ##alien-global set-new-ac
-
- dup local-live-in [ set-heap-ac ] each ;
+M: insn analyze-aliases ;
-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
[ 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 ;
#! 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#
+
+ 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
-M: ##copy analyze-aliases*
+ 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 ;
[ [ 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 ;
-
-SYMBOL: live-stores
+GENERIC: eliminate-dead-stores ( insn -- ? )
-: compute-live-stores ( -- )
- histories get
- values [
- values [ [ store? ] filter [ insn#>> ] map ] map concat
- ] map concat fast-set
- live-stores set ;
+M: ##set-slot-imm eliminate-dead-stores
+ insn#>> dead-stores get in? not ;
-GENERIC: eliminate-dead-stores* ( insn -- insn' )
-
-: (eliminate-dead-stores) ( insn -- insn' )
- dup insn-slot# [
- insn# get live-stores get in? [
- drop f
- ] unless
- ] when ;
+M: insn eliminate-dead-stores drop t ;
-M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
-
-M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
-
-M: insn eliminate-dead-stores* ;
+: 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 ;
+
+: 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
-: 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 ;
! 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 ;
+
+: vm-frame-required ( -- )
+ frame-required
+ vm-stack-space param-area-size [ max ] change ;
+
+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: ##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 ;
+
+M: ##float>integer compute-stack-frame*
+ drop integer-float-needs-stack-frame? [ frame-required ] when ;
-M: ##call compute-stack-frame* drop frame-required? on ;
+M: ##integer>float compute-stack-frame*
+ drop integer-float-needs-stack-frame? [ frame-required ] when ;
-M: ##call-gc compute-stack-frame*
- drop
- frame-required? on
- stack-frame new t >>calls-vm? request-stack-frame ;
+M: insn compute-stack-frame* drop ;
-M: insn compute-stack-frame*
- class "frame-required?" word-prop
- [ frame-required? on ] when ;
+: 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 ;
-: initial-stack-frame ( -- stack-frame )
- stack-frame new cfg get spill-area-size>> >>spill-area-size ;
+: <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 ( 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 ;
+: 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 ;
-! Copyright (C) 2008, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors arrays layouts math math.order math.parser\r
-combinators combinators.short-circuit fry make sequences locals\r
-alien alien.private alien.strings alien.c-types alien.libraries\r
-classes.struct namespaces kernel strings libc quotations words\r
-cpu.architecture compiler.utilities compiler.tree compiler.cfg\r
-compiler.cfg.builder compiler.cfg.builder.alien.params\r
-compiler.cfg.builder.blocks compiler.cfg.instructions\r
-compiler.cfg.stack-frame compiler.cfg.stacks\r
-compiler.cfg.registers compiler.cfg.hats ;\r
-FROM: compiler.errors => no-such-symbol no-such-library ;\r
-IN: compiler.cfg.builder.alien\r
-\r
-! output is triples with shape { vreg rep on-stack? }\r
-GENERIC: unbox ( src c-type -- vregs )\r
-\r
-M: c-type unbox\r
- [ [ unboxer>> ] [ rep>> ] bi ^^unbox ] [ rep>> ] bi\r
- f 3array 1array ;\r
-\r
-M: long-long-type unbox\r
- unboxer>> int-rep ^^unbox\r
- 0 cell\r
- [\r
- int-rep f ^^load-memory-imm\r
- int-rep long-long-on-stack? 3array\r
- ] bi-curry@ bi 2array ;\r
-\r
-GENERIC: unbox-parameter ( src c-type -- vregs )\r
-\r
-M: c-type unbox-parameter unbox ;\r
-\r
-M: long-long-type unbox-parameter unbox ;\r
-\r
-M:: struct-c-type unbox-parameter ( src c-type -- )\r
- src ^^unbox-any-c-ptr :> src\r
- c-type value-struct? [\r
- c-type flatten-struct-type\r
- [| pair i |\r
- src i cells pair first f ^^load-memory-imm\r
- pair first2 3array\r
- ] map-index\r
- ] [ { { src int-rep f } } ] if ;\r
-\r
-: unbox-parameters ( parameters -- vregs )\r
- [\r
- [ length iota <reversed> ] keep\r
- [\r
- [ <ds-loc> ^^peek ] [ base-type ] bi*\r
- unbox-parameter\r
- ] 2map concat\r
- ]\r
- [ length neg ##inc-d ] bi ;\r
-\r
-: prepare-struct-area ( vregs return -- vregs )\r
- #! Return offset on C stack where to store unboxed\r
- #! parameters. If the C function is returning a structure,\r
- #! the first parameter is an implicit target area pointer,\r
- #! so we need to use a different offset.\r
- large-struct? [\r
- ^^prepare-struct-area int-rep struct-return-on-stack?\r
- 3array prefix\r
- ] when ;\r
-\r
-: (objects>registers) ( vregs -- )\r
- ! Place ##store-stack-param instructions first. This ensures\r
- ! that no registers are used after the ##store-reg-param\r
- ! instructions.\r
- [\r
- first3 [ dup reg-class-of reg-class-full? ] dip or\r
- [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]\r
- [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]\r
- if\r
- ] map [ ##store-stack-param? ] partition [ % ] bi@ ;\r
-\r
-: objects>registers ( params -- stack-size )\r
- [ abi>> ] [ parameters>> ] [ return>> ] tri\r
- '[ \r
- _ unbox-parameters\r
- _ prepare-struct-area\r
- (objects>registers)\r
- stack-params get\r
- ] with-param-regs ;\r
-\r
-GENERIC: box-return ( c-type -- dst )\r
-\r
-M: c-type box-return\r
- [ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ;\r
-\r
-M: long-long-type box-return\r
- [ f ] dip boxer>> ^^box-long-long ;\r
-\r
-M: struct-c-type box-return\r
- dup return-struct-in-registers?\r
- [ ^^box-small-struct ] [ [ f ] dip ^^box-large-struct ] if ;\r
-\r
-: box-return* ( node -- )\r
- return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;\r
-\r
-GENERIC# dlsym-valid? 1 ( symbols dll -- ? )\r
-\r
-M: string dlsym-valid? dlsym ;\r
-\r
-M: array dlsym-valid? '[ _ dlsym ] any? ;\r
-\r
-: check-dlsym ( symbols dll -- )\r
- dup dll-valid? [\r
- dupd dlsym-valid?\r
- [ drop ] [ cfg get word>> no-such-symbol ] if\r
- ] [ dll-path cfg get word>> no-such-library drop ] if ;\r
-\r
-: decorated-symbol ( params -- symbols )\r
- [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi\r
- {\r
- [ drop ]\r
- [ "@" glue ]\r
- [ "@" glue "_" prepend ]\r
- [ "@" glue "@" prepend ]\r
- } 2cleave\r
- 4array ;\r
-\r
-: alien-invoke-dlsym ( params -- symbols dll )\r
- [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]\r
- [ library>> load-library ]\r
- bi 2dup check-dlsym ;\r
-\r
-: return-size ( c-type -- n )\r
- #! Amount of space we reserve for a return value.\r
- {\r
- { [ dup void? ] [ drop 0 ] }\r
- { [ dup base-type struct-c-type? not ] [ drop 0 ] }\r
- { [ dup large-struct? not ] [ drop 2 cells ] }\r
- [ heap-size ]\r
- } cond ;\r
-\r
-: alien-node-height ( params -- )\r
- [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;\r
-\r
-: emit-alien-block ( node quot: ( params -- ) -- )\r
- '[\r
- make-kill-block\r
- params>>\r
- _ [ alien-node-height ] bi\r
- ] emit-trivial-block ; inline\r
-\r
-: <alien-stack-frame> ( stack-size return -- stack-frame )\r
- stack-frame new\r
- swap return-size >>return\r
- swap >>params\r
- t >>calls-vm? ;\r
-\r
-: emit-stack-frame ( stack-size params -- )\r
- [ return>> ] [ abi>> ] bi\r
- [ stack-cleanup ##cleanup ]\r
- [ drop <alien-stack-frame> ##stack-frame ] 3bi ;\r
-\r
-M: #alien-invoke emit-node\r
- [\r
- {\r
- [ objects>registers ]\r
- [ alien-invoke-dlsym ##alien-invoke ]\r
- [ emit-stack-frame ]\r
- [ box-return* ]\r
- } cleave\r
- ] emit-alien-block ;\r
-\r
-M:: #alien-indirect emit-node ( node -- )\r
- node [\r
- D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src\r
- {\r
- [ objects>registers ]\r
- [ drop src ##alien-indirect ]\r
- [ emit-stack-frame ]\r
- [ box-return* ]\r
- } cleave\r
- ] emit-alien-block ;\r
-\r
-M: #alien-assembly emit-node\r
- [\r
- {\r
- [ objects>registers ]\r
- [ quot>> ##alien-assembly ]\r
- [ emit-stack-frame ]\r
- [ box-return* ]\r
- } cleave\r
- ] emit-alien-block ;\r
-\r
-GENERIC: box-parameter ( n c-type -- dst )\r
-\r
-M: c-type box-parameter\r
- [ rep>> ] [ boxer>> ] bi ^^box ;\r
-\r
-M: long-long-type box-parameter\r
- boxer>> ^^box-long-long ;\r
-\r
-: if-value-struct ( ctype true false -- )\r
- [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline\r
-\r
-M: struct-c-type box-parameter\r
- [ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ;\r
-\r
-: parameter-offsets ( types -- offsets )\r
- 0 [ stack-size + ] accumulate nip ;\r
-\r
-: prepare-parameters ( parameters -- offsets types indices )\r
- [ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;\r
-\r
-: alien-parameters ( params -- seq )\r
- [ parameters>> ] [ return>> large-struct? ] bi\r
- [ struct-return-on-stack? (stack-value) void* ? prefix ] when ;\r
-\r
-: box-parameters ( params -- )\r
- alien-parameters\r
- [ length ##inc-d ]\r
- [\r
- prepare-parameters\r
- [\r
- next-vreg next-vreg ##save-context\r
- base-type box-parameter swap <ds-loc> ##replace\r
- ] 3each\r
- ] bi ;\r
-\r
-:: alloc-parameter ( rep -- reg rep )\r
- rep dup reg-class-of reg-class-full?\r
- [ alloc-stack-param stack-params ] [ [ next-reg-param ] keep ] if ;\r
-\r
-GENERIC: flatten-c-type ( type -- reps )\r
-\r
-M: struct-c-type flatten-c-type\r
- flatten-struct-type [ first2 [ drop stack-params ] when ] map ;\r
- \r
-M: long-long-type flatten-c-type drop { int-rep int-rep } ;\r
-\r
-M: c-type flatten-c-type\r
- rep>> {\r
- { int-rep [ { int-rep } ] }\r
- { float-rep [ float-on-stack? { stack-params } { float-rep } ? ] }\r
- { double-rep [\r
- float-on-stack?\r
- cell 4 = { stack-params stack-params } { stack-params } ?\r
- { double-rep } ?\r
- ] }\r
- { stack-params [ { stack-params } ] }\r
- } case ;\r
- \r
-M: object flatten-c-type base-type flatten-c-type ;\r
-\r
-: flatten-c-types ( types -- reps )\r
- [ flatten-c-type ] map concat ;\r
-\r
-: (registers>objects) ( params -- )\r
- [ 0 ] dip alien-parameters flatten-c-types [\r
- [ alloc-parameter ##save-param-reg ]\r
- [ rep-size cell align + ]\r
- 2bi\r
- ] each drop ; inline\r
-\r
-: registers>objects ( params -- )\r
- ! Generate code for boxing input parameters in a callback.\r
- dup abi>> [\r
- dup (registers>objects)\r
- ##begin-callback\r
- next-vreg next-vreg ##restore-context\r
- box-parameters\r
- ] with-param-regs ;\r
-\r
-: callback-return-quot ( ctype -- quot )\r
- return>> {\r
- { [ dup void? ] [ drop [ ] ] }\r
- { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }\r
- [ c-type c-type-unboxer-quot ]\r
- } cond ;\r
-\r
-: callback-prep-quot ( params -- quot )\r
- parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;\r
-\r
-: wrap-callback-quot ( params -- quot )\r
- [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append\r
- yield-hook get\r
- '[ _ _ do-callback ]\r
- >quotation ;\r
-\r
-GENERIC: unbox-return ( src c-type -- )\r
-\r
-M: c-type unbox-return\r
- unbox first first2 ##store-return ;\r
-\r
-M: long-long-type unbox-return\r
- unbox first2 [ first ] bi@ ##store-long-long-return ;\r
-\r
-M: struct-c-type unbox-return\r
- [ ^^unbox-any-c-ptr ] dip ##store-struct-return ;\r
-\r
-: emit-callback-stack-frame ( params -- )\r
- [ alien-parameters [ stack-size ] map-sum ] [ return>> ] bi\r
- <alien-stack-frame> ##stack-frame ;\r
-\r
-: stack-args-size ( params -- n )\r
- dup abi>> [\r
- alien-parameters flatten-c-types\r
- [ alloc-parameter 2drop ] each\r
- stack-params get\r
- ] with-param-regs ;\r
-\r
-: callback-stack-cleanup ( params -- )\r
- [ xt>> ] [ [ stack-args-size ] [ return>> ] [ abi>> ] tri stack-cleanup ] bi\r
- "stack-cleanup" set-word-prop ;\r
-\r
-M: #alien-callback emit-node\r
- dup params>> xt>> dup\r
- [\r
- ##prologue\r
- [\r
- {\r
- [ registers>objects ]\r
- [ emit-callback-stack-frame ]\r
- [ callback-stack-cleanup ]\r
- [ wrap-callback-quot ##alien-callback ]\r
- [\r
- return>> {\r
- { [ dup void? ] [ drop ##end-callback ] }\r
- { [ dup large-struct? ] [ drop ##end-callback ] }\r
- [\r
- [ D 0 ^^peek ] dip\r
- ##end-callback\r
- base-type unbox-return\r
- ]\r
- } cond\r
- ]\r
- } cleave\r
- ] emit-alien-block\r
- ##epilogue\r
- ##return\r
- ] with-cfg-builder ;\r
+! 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 ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
! 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 ;
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 ;
-
-GENERIC: reg-class-full? ( reg-class -- ? )
-
-M: stack-params reg-class-full? drop t ;
+ [ ?dummy-stack-params ] [ ?dummy-int-params ] bi
+ float-regs get pop ;
-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
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? ;
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 -- )
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? ;
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
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 ;
! 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 ;
! 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 ;
! 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
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
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
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 ;
use: src
literal: n rep ;
-INSN: ##store-return
-use: src
-literal: rep ;
-
-INSN: ##store-struct-return
-use: src/int-rep
-literal: c-type ;
+INSN: ##load-reg-param
+def: dst
+literal: reg rep ;
-INSN: ##store-long-long-return
-use: src1/int-rep src2/int-rep ;
+INSN: ##load-stack-param
+def: dst
+literal: n 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 ;
INSN: ##alien-assembly
literal: quot ;
-INSN: ##save-param-reg
-literal: offset reg rep ;
-
INSN: ##begin-callback ;
INSN: ##alien-callback
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
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
##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
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
: 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 ]
[ 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 ;
compiler.cfg.comparisons ;
QUALIFIED: alien
QUALIFIED: alien.accessors
+QUALIFIED: alien.data.private
QUALIFIED: alien.c-types
QUALIFIED: kernel
QUALIFIED: arrays
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
{ 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 ] }
{ 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 -- ) ;
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 ;
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
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? ;
[ 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 -- )
] [ 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
[ [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] ;
[ [ ^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 ;
[ ^^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
[ ^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 ]
: 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 ;
: 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
[ 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|| ;
+
+: 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 ;
-: handle-sync-point ( n -- )
+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.
] [ 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 )
! 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
[ 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 ;
-! 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 ;
[ 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
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 ;
[ 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 ;
{ 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{
{ 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 }
{ 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
[
{ 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
[
{ 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
[
{ 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
{ 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
{ 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{
! 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
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) ;
] 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
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 ;
: 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 ;
! 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
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
[ 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
! 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
} 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 }
} 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 }
} 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{
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 ;
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 -- )
: 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 ;
-! 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
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
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 ;
! 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
! 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 drop ;
-M: insn prepare-insn
+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 ;
[ 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 -- ? )
dup construct-cssa
dup compute-defs
+ dup compute-insns
dup compute-ssa-live-sets
dup compute-live-ranges
dup prepare-coalescing
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 }
[ ] [ 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
\ No newline at end of file
+[ 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
\ No newline at end of file
-! 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? ;
-
-PRIVATE>
+ swap 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 ]
+: 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-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
-
-! Debug this stuff later
+! Value-based interference test.
+: chain-intersect ( vreg1 vreg2 -- vreg )
+ [ 2dup { [ nip ] [ vregs-intersect? not ] } 2&& ]
+ [ equal-anc-in>> ]
+ while nip ;
-: quadratic-test? ( seq1 seq2 -- ? ) [ length ] bi@ + 10 < ;
+: update-equal-anc-out ( vreg1 vreg2 -- )
+ dupd chain-intersect >>equal-anc-out drop ;
-: quadratic-test ( seq1 seq2 -- ? )
- '[ _ [ vregs-interfere? ] with any? ] any? ;
+: same-sets? ( vreg1 vreg2 -- ? )
+ [ color>> ] bi@ eq? ;
-: sort-vregs-by-bb ( vregs -- alist )
- defs get
- '[ dup _ at ] { } map>assoc
- [ second pre-of ] sort-with ;
+: same-values? ( vreg1 vreg2 -- ? )
+ [ value>> ] bi@ eq? ;
-: ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline
-
-: find-parent ( dom current -- parent )
+: vregs-interfere? ( vreg1 vreg2 -- ? )
+ [ f >>equal-anc-out ] dip
+
+ 2dup same-sets? [ equal-anc-out>> ] when
+
+ 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 ;
\ No newline at end of file
+: 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 ;
\ No newline at end of file
-! 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
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 ;
! 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 }
+{ spill-area-align integer }
+
{ total-size integer }
-{ calls-vm? boolean } ;
+{ allot-area-base integer }
+{ spill-area-base integer } ;
-! Stack frame utilities
-: param-base ( -- n )
- stack-frame get [ params>> ] [ return>> ] bi + ;
+: 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
\ No newline at end of file
+ [ spill-area-base>> ] [ spill-area-size>> ] bi + ;
! 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
[ 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
##compare-imm
##compare-integer
##compare-integer-imm
+ ##test
+ ##test-imm
##compare-float-unordered
##compare-float-ordered ;
{ [ 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 ] }
: 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 ] }
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 ;
{ [ 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
: 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 ;
! 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
[ 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 ;
[ ##compare-integer-imm? ]
[ ##compare-float-unordered? ]
[ ##compare-float-ordered? ]
+ [ ##test? ]
+ [ ##test-imm? ]
[ ##test-vector? ]
[ ##test-vector-branch? ]
} 1|| [ f >>temp ] when
} 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 }
} 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
[
{
[
{
- 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
} 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 }
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
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
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
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
! 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
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
: 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
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
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
[ 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
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
[ 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
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
[ 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
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+ ]
[ 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
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
\ 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
(simd-hlshift)
(simd-hrshift)
(simd-vshuffle-elements)
+ (simd-vshuffle2-elements)
(simd-vshuffle-bytes)
(simd-vmerge-head)
(simd-vmerge-tail)
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
! 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
: wait ( queue timeout status -- )\r
over [\r
[ queue-timeout ] dip suspend\r
- [ wait-timeout ] [ cancel-alarm ] if\r
+ [ wait-timeout ] [ stop-alarm ] if\r
] [\r
[ drop queue ] dip suspend drop\r
] if ; inline\r
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 )
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
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 ;
! 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
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 -- )
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 -- )
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 )
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 { } ;
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 -- )
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 ( -- ? )
: 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 -- ? )
! 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-long-long cpu ( dst n func -- )
+HOOK: %box cpu ( dst src func rep -- )
-HOOK: %box-small-struct cpu ( dst c-type -- )
+HOOK: %box-long-long cpu ( dst src1 src2 func -- )
-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 -- )
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 -- )
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 ;
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 ;
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 ] }
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
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
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 ;
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
! 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 ;
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
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 ;
! 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 -- )
+! Need a fake return-reg for floats
+M: x86.32 return-regs
+ {
+ { int-regs { EAX EDX } }
+ { float-regs { ST0 } }
+ } ;
-M: stack-params load-return-reg drop EAX swap MOV ;
-M: stack-params store-return-reg drop EAX MOV ;
+M: x86.32 %prologue ( n -- )
+ dup PUSH
+ 0 PUSH rc-absolute-cell rel-this
+ 3 cells - decr-stack-reg ;
-M: int-rep load-return-reg drop EAX swap MOV ;
-M: int-rep store-return-reg drop EAX MOV ;
+M: x86.32 %prepare-jump
+ pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
-:: load-float-return ( src x87-insn sse-insn -- )
- src register? [
+:: load-float-return ( dst x87-insn rep -- )
+ dst register? [
ESP 4 SUB
- ESP [] src sse-insn execute
ESP [] x87-insn execute
+ dst ESP [] rep %copy
ESP 4 ADD
] [
- src x87-insn execute
+ dst ?spill-slot x87-insn execute
] if ; inline
-:: store-float-return ( dst x87-insn sse-insn -- )
- dst register? [
+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
- dst ESP [] sse-insn execute
ESP 4 ADD
] [
- dst x87-insn execute
+ src ?spill-slot 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 ;
-
-M: x86.32 %prologue ( n -- )
- dup PUSH
- 0 PUSH rc-absolute-cell rel-this
- 3 cells - decr-stack-reg ;
-
-M: x86.32 %prepare-jump
- pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
+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
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 ;
-
-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 ;
+ 0 stack@ EAX MOV
+ EAX out int-rep %copy
+ 4 stack@ EAX MOV
+ 8 save-vm-ptr
+ func f %alien-invoke ;
-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
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 ;
-
-M: register float-function-param
- nip double-rep %copy ;
+ dst n double-rep %store-stack-param ;
-: 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
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 ;
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 ;
: 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
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 } }
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
[ (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 ;
-
-: 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 ;
+ dst rep %load-return ;
-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 ;
-
-: 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 ;
+ dst int-rep %load-return ;
+
+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
"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
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
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 ;
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 <= ;
M: x86.64 dummy-fp-params? f ;
M: x86.64 temp-reg R8 ;
+
+M: x86.64 %prepare-var-args RAX RAX XOR ;
-! 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 ;
M: x86.64 dummy-fp-params? t ;
M: x86.64 temp-reg R11 ;
-
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
[ { 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 = [
: 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, ;
<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 ;
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 ;
: 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 -- )
: 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 ;
: 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
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 ;
-! 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
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 ;
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
! 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
"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 ;
: 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" ] }
--- /dev/null
+Slava Pestov
+Joe Groff
--- /dev/null
+! 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
--- /dev/null
+not loaded
kernel.private math memory namespaces make sequences words system
layouts combinators math.order math.vectors fry locals compiler.constants
byte-arrays io macros quotations classes.algebra compiler
-compiler.units init vm
+compiler.units init vm vocabs.loader
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
HOOK: stack-reg cpu ( -- reg )
-HOOK: frame-reg cpu ( -- reg )
-
HOOK: reserved-stack-space cpu ( -- n )
-HOOK: extra-stack-space cpu ( stack-frame -- n )
-
: stack@ ( n -- op ) stack-reg swap [+] ;
: special-offset ( m -- n )
- stack-frame get extra-stack-space +
reserved-stack-space + ;
-: special@ ( n -- op ) special-offset stack@ ;
-
-: spill@ ( n -- op ) spill-offset special@ ;
-
-: param@ ( n -- op ) reserved-stack-space + stack@ ;
+: spill@ ( n -- op ) spill-offset special-offset stack@ ;
: gc-root-offsets ( seq -- seq' )
[ n>> spill-offset special-offset cell + ] map f like ;
: align-stack ( n -- n' ) 16 align ;
M: x86 stack-frame-size ( stack-frame -- i )
- [ (stack-frame-size) ]
- [ extra-stack-space ] bi +
+ (stack-frame-size)
reserved-stack-space +
3 cells +
align-stack ;
-! Must be a volatile register not used for parameter passing or
-! integer return
-HOOK: temp-reg cpu ( -- reg )
-
HOOK: pic-tail-reg cpu ( -- reg )
M: x86 complex-addressing? t ;
M: x86 fused-unboxing? t ;
+M: x86 test-instruction? t ;
+
M: x86 immediate-store? immediate-comparand? ;
M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
M: x86 %not int-rep one-operand NOT ;
M: x86 %neg int-rep one-operand NEG ;
M: x86 %log2 BSR ;
+M: x86 %bit-count POPCNT ;
! A bit of logic to avoid using MOVSS/MOVSD for reg-reg moves
! since this induces partial register stalls
M: int-rep copy-register* drop MOV ;
M: tagged-rep copy-register* drop MOV ;
-M: float-rep copy-register* drop MOVAPS ;
-M: double-rep copy-register* drop MOVAPS ;
-M: float-4-rep copy-register* drop MOVAPS ;
-M: double-2-rep copy-register* drop MOVAPS ;
-M: vector-rep copy-register* drop MOVDQA ;
M: object copy-memory* copy-register* ;
-M: float-rep copy-memory* drop MOVSS ;
-M: double-rep copy-memory* drop MOVSD ;
: ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ;
src1 src2 CMP
dst cc temp %boolean ;
-: use-test? ( src1 src2 cc -- ? )
- [ register? ] [ 0 = ] [ { cc= cc/= } member? ] tri* and and ;
+M:: x86 %test ( dst src1 src2 cc temp -- )
+ src1 src2 TEST
+ dst cc temp %boolean ;
: (%compare-tagged) ( src1 src2 -- )
[ HEX: ffffffff CMP ] dip rc-absolute rel-literal ;
-: (%compare-integer-imm) ( src1 src2 cc -- )
- 3dup use-test? [ 2drop dup TEST ] [ drop CMP ] if ;
-
M:: x86 %compare-integer-imm ( dst src1 src2 cc temp -- )
- src1 src2 cc (%compare-integer-imm)
+ src1 src2 CMP
+ dst cc temp %boolean ;
+
+M:: x86 %test-imm ( dst src1 src2 cc temp -- )
+ src1 src2 TEST
dst cc temp %boolean ;
-: (%compare-imm) ( src1 src2 cc -- )
+: (%compare-imm) ( src1 src2 -- )
{
- { [ over fixnum? ] [ [ tag-fixnum ] dip (%compare-integer-imm) ] }
- { [ over not ] [ 2drop \ f type-number CMP ] }
- [ drop (%compare-tagged) ]
+ { [ dup fixnum? ] [ tag-fixnum CMP ] }
+ { [ dup not ] [ drop \ f type-number CMP ] }
+ [ (%compare-tagged) ]
} cond ;
M:: x86 %compare-imm ( dst src1 src2 cc temp -- )
- src1 src2 cc (%compare-imm)
+ src1 src2 (%compare-imm)
dst cc temp %boolean ;
: %branch ( label cc -- )
label cc %branch ;
M:: x86 %compare-integer-imm-branch ( label src1 src2 cc -- )
- src1 src2 cc (%compare-integer-imm)
+ src1 src2 CMP
+ label cc %branch ;
+
+M:: x86 %test-branch ( label src1 src2 cc -- )
+ src1 src2 TEST
+ label cc %branch ;
+
+M:: x86 %test-imm-branch ( label src1 src2 cc -- )
+ src1 src2 TEST
label cc %branch ;
M:: x86 %compare-imm-branch ( label src1 src2 cc -- )
- src1 src2 cc (%compare-imm)
+ src1 src2 (%compare-imm)
label cc %branch ;
-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 ;
+M:: x86 %spill ( src rep dst -- )
+ dst src rep %copy ;
+
+M:: x86 %reload ( dst rep src -- )
+ dst src rep %copy ;
+
+M:: x86 %store-stack-param ( src n rep -- )
+ n reserved-stack-space + stack@ src rep %copy ;
+
+: %load-return ( dst rep -- )
+ [ reg-class-of return-regs at first ] keep %load-reg-param ;
+
+: %store-return ( dst rep -- )
+ [ reg-class-of return-regs at first ] keep %store-reg-param ;
+
+: next-stack@ ( n -- operand )
+ #! nth parameter from the next stack frame. Used to box
+ #! input values to callbacks; the callback has its own
+ #! stack frame set up, and we want to read the frame
+ #! set up by the caller.
+ frame-reg swap 2 cells + [+] ;
+
+M:: x86 %load-stack-param ( dst n rep -- )
+ dst n next-stack@ rep %copy ;
+
+M:: x86 %local-allot ( dst size align offset -- )
+ dst offset local-allot-offset special-offset stack@ LEA ;
+
+M: x86 %alien-indirect ( src -- )
+ ?spill-slot CALL ;
+
+M: x86 %loop-entry 16 alignment [ NOP ] times ;
+
+M:: x86 %restore-context ( temp1 temp2 -- )
+ #! Load Factor stack pointers on entry from C to Factor.
+ temp1 %context
+ temp2 stack-reg cell neg [+] LEA
+ temp1 "callstack-top" context-field-offset [+] temp2 MOV
+ ds-reg temp1 "datastack" context-field-offset [+] MOV
+ rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
+
+M:: x86 %save-context ( temp1 temp2 -- )
+ #! Save Factor stack pointers in case the C code calls a
+ #! callback which does a GC, which must reliably trace
+ #! all roots.
+ temp1 %context
+ temp2 stack-reg cell neg [+] LEA
+ temp1 "callstack-top" context-field-offset [+] temp2 MOV
+ temp1 "datastack" context-field-offset [+] ds-reg MOV
+ temp1 "retainstack" context-field-offset [+] rs-reg MOV ;
-: %clear-unless-in-place ( dst src -- )
- over = [ drop ] [ dup XORPS ] if ;
+M: x86 value-struct? drop t ;
-M: x86 %single>double-float [ %clear-unless-in-place ] [ CVTSS2SD ] 2bi ;
-M: x86 %double>single-float [ %clear-unless-in-place ] [ CVTSD2SS ] 2bi ;
+M: x86 immediate-arithmetic? ( n -- ? )
+ HEX: -80000000 HEX: 7fffffff between? ;
-M: x86 %integer>float [ drop dup XORPS ] [ CVTSI2SD ] 2bi ;
-M: x86 %float>integer CVTTSD2SI ;
+M: x86 immediate-bitwise? ( n -- ? )
+ HEX: -80000000 HEX: 7fffffff between? ;
: %cmov-float= ( dst src -- )
[
:: (%compare-float) ( dst src1 src2 cc temp compare -- )
cc {
- { cc< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA (%boolean) ] }
- { cc<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE (%boolean) ] }
- { cc> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA (%boolean) ] }
- { cc>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE (%boolean) ] }
- { cc= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= (%boolean) ] }
- { cc<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE (%boolean) ] }
- { cc<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP (%boolean) ] }
- { cc/< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE (%boolean) ] }
- { cc/<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB (%boolean) ] }
- { cc/> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE (%boolean) ] }
- { cc/>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB (%boolean) ] }
- { cc/= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= (%boolean) ] }
- { cc/<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE (%boolean) ] }
- { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP (%boolean) ] }
+ { cc< [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
+ { cc<= [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+ { cc> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
+ { cc>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+ { cc= [ src1 src2 \ compare call( a b -- ) dst temp \ %cmov-float= (%boolean) ] }
+ { cc<> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVNE (%boolean) ] }
+ { cc<>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVNP (%boolean) ] }
+ { cc/< [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+ { cc/<= [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
+ { cc/> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+ { cc/>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
+ { cc/= [ src1 src2 \ compare call( a b -- ) dst temp \ %cmov-float/= (%boolean) ] }
+ { cc/<> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVE (%boolean) ] }
+ { cc/<>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVP (%boolean) ] }
} case ; inline
-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) ;
-
: %jump-float= ( label -- )
[
"no-jump" define-label
:: (%compare-float-branch) ( label src1 src2 cc compare -- )
cc {
- { cc< [ src2 src1 \ compare execute( a b -- ) label JA ] }
- { cc<= [ src2 src1 \ compare execute( a b -- ) label JAE ] }
- { cc> [ src1 src2 \ compare execute( a b -- ) label JA ] }
- { cc>= [ src1 src2 \ compare execute( a b -- ) label JAE ] }
- { cc= [ src1 src2 \ compare execute( a b -- ) label %jump-float= ] }
- { cc<> [ src1 src2 \ compare execute( a b -- ) label JNE ] }
- { cc<>= [ src1 src2 \ compare execute( a b -- ) label JNP ] }
- { cc/< [ src2 src1 \ compare execute( a b -- ) label JBE ] }
- { cc/<= [ src2 src1 \ compare execute( a b -- ) label JB ] }
- { cc/> [ src1 src2 \ compare execute( a b -- ) label JBE ] }
- { cc/>= [ src1 src2 \ compare execute( a b -- ) label JB ] }
- { cc/= [ src1 src2 \ compare execute( a b -- ) label %jump-float/= ] }
- { cc/<> [ src1 src2 \ compare execute( a b -- ) label JE ] }
- { cc/<>= [ src1 src2 \ compare execute( a b -- ) label JP ] }
- } case ;
-
-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) ;
-
-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-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 ;
-
-: 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 ( 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 ] }
+ { cc< [ src2 src1 \ compare call( a b -- ) label JA ] }
+ { cc<= [ src2 src1 \ compare call( a b -- ) label JAE ] }
+ { cc> [ src1 src2 \ compare call( a b -- ) label JA ] }
+ { cc>= [ src1 src2 \ compare call( a b -- ) label JAE ] }
+ { cc= [ src1 src2 \ compare call( a b -- ) label %jump-float= ] }
+ { cc<> [ src1 src2 \ compare call( a b -- ) label JNE ] }
+ { cc<>= [ src1 src2 \ compare call( a b -- ) label JNP ] }
+ { cc/< [ src2 src1 \ compare call( a b -- ) label JBE ] }
+ { cc/<= [ src2 src1 \ compare call( a b -- ) label JB ] }
+ { cc/> [ src1 src2 \ compare call( a b -- ) label JBE ] }
+ { cc/>= [ src1 src2 \ compare call( a b -- ) label JB ] }
+ { cc/= [ src1 src2 \ compare call( a b -- ) label %jump-float/= ] }
+ { cc/<> [ src1 src2 \ compare call( a b -- ) label JE ] }
+ { cc/<>= [ src1 src2 \ compare call( a b -- ) label JP ] }
} 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 ;
-
-M:: x86 %spill ( src rep dst -- )
- dst src rep %copy ;
-
-M:: x86 %reload ( dst rep src -- )
- dst src rep %copy ;
-
-M:: x86 %store-reg-param ( src reg rep -- )
- reg src rep %copy ;
-
-M:: x86 %store-stack-param ( src n rep -- )
- n param@ src rep %copy ;
-
-HOOK: struct-return@ cpu ( n -- operand )
-
-M: x86 %prepare-struct-area ( dst -- )
- f struct-return@ LEA ;
-
-M: x86 %alien-indirect ( src -- )
- ?spill-slot CALL ;
-
-M: x86 %loop-entry 16 alignment [ NOP ] times ;
-
-M:: x86 %restore-context ( temp1 temp2 -- )
- #! Load Factor stack pointers on entry from C to Factor.
- temp1 %context
- ds-reg temp1 "datastack" context-field-offset [+] MOV
- rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
-
-M:: x86 %save-context ( temp1 temp2 -- )
- #! Save Factor stack pointers in case the C code calls a
- #! callback which does a GC, which must reliably trace
- #! all roots.
- temp1 %context
- temp2 stack-reg cell neg [+] LEA
- temp1 "callstack-top" context-field-offset [+] temp2 MOV
- temp1 "datastack" context-field-offset [+] ds-reg MOV
- temp1 "retainstack" context-field-offset [+] rs-reg MOV ;
-
-M: x86 value-struct? drop t ;
-
-M: x86 immediate-arithmetic? ( n -- ? )
- HEX: -80000000 HEX: 7fffffff between? ;
-
-M: x86 immediate-bitwise? ( n -- ? )
- HEX: -80000000 HEX: 7fffffff between? ;
-
-: next-stack@ ( n -- operand )
- #! nth parameter from the next stack frame. Used to box
- #! input values to callbacks; the callback has its own
- #! stack frame set up, and we want to read the frame
- #! set up by the caller.
- frame-reg swap 2 cells + [+] ;
-
enable-min/max
enable-log2
-:: install-sse2-check ( -- )
- [
- sse-version 20 < [
- "This image was built to use SSE2 but your CPU does not support it." print
- "You will need to bootstrap Factor again." print
- flush
- 1 exit
- ] when
- ] "cpu.x86" add-startup-hook ;
-
-: enable-sse2 ( version -- )
- 20 >= [
- enable-float-intrinsics
- enable-float-functions
- enable-float-min/max
- enable-fsqrt
- install-sse2-check
- ] when ;
-
: check-sse ( -- )
+ "Checking for multimedia extensions... " write flush
[ { (sse-version) } compile ] with-optimizer
- "Checking for multimedia extensions: " write sse-version
- [ sse-string write " detected" print ] [ enable-sse2 ] bi ;
+ sse-version
+ [ sse-string " detected" append print ]
+ [ 20 < "cpu.x86.x87" "cpu.x86.sse" ? require ] bi ;
--- /dev/null
+Slava Pestov
--- /dev/null
+not loaded
--- /dev/null
+! 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
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 ;
! 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
! 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
} ; 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 ;
math arrays combinators ;\r
IN: generalizations\r
\r
-HELP: nsequence\r
-{ $values { "n" integer } { "seq" "an exemplar" } }\r
-{ $description "A generalization of " { $link 2sequence } ", "\r
-{ $link 3sequence } ", and " { $link 4sequence } " "\r
-"that constructs a sequence from the top " { $snippet "n" } " elements of the stack."\r
-}\r
-{ $examples\r
- { $example "USING: generalizations prettyprint ;" "CHAR: f CHAR: i CHAR: s CHAR: h 4 \"\" nsequence ." "\"fish\"" }\r
-} ;\r
-\r
-HELP: narray\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link 1array } ", "\r
-{ $link 2array } ", " { $link 3array } " and " { $link 4array } " "\r
-"that constructs an array from the top " { $snippet "n" } " elements of the stack."\r
-}\r
-{ $examples\r
- "Some core words expressed in terms of " { $link narray } ":"\r
- { $table\r
- { { $link 1array } { $snippet "1 narray" } }\r
- { { $link 2array } { $snippet "2 narray" } }\r
- { { $link 3array } { $snippet "3 narray" } }\r
- { { $link 4array } { $snippet "4 narray" } }\r
- }\r
-} ;\r
-\r
-{ nsequence narray } related-words\r
-\r
HELP: nsum\r
{ $values { "n" integer } }\r
{ $description "Adds the top " { $snippet "n" } " stack values." } ;\r
\r
-HELP: firstn\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link first } ", "\r
-{ $link first2 } ", " { $link first3 } " and " { $link first4 } " "\r
-"that pushes the first " { $snippet "n" } " elements of a sequence on the stack."\r
-}\r
-{ $examples\r
- "Some core words expressed in terms of " { $link firstn } ":"\r
- { $table\r
- { { $link first } { $snippet "1 firstn" } }\r
- { { $link first2 } { $snippet "2 firstn" } }\r
- { { $link first3 } { $snippet "3 firstn" } }\r
- { { $link first4 } { $snippet "4 firstn" } }\r
- }\r
-} ;\r
-\r
-HELP: set-firstn\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link set-first } " "\r
-"that sets the first " { $snippet "n" } " elements of a sequence from the top " { $snippet "n" } " elements of the stack." } ;\r
-\r
HELP: npick\r
{ $values { "n" integer } }\r
{ $description "A generalization of " { $link dup } ", "\r
"placed on the top of the stack."\r
}\r
{ $examples\r
- { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick 5 narray ." "{ 1 2 3 4 1 }" }\r
+ { $example\r
+ "USING: kernel generalizations prettyprint"\r
+ "sequences.generalizations ;"\r
+ ""\r
+ "1 2 3 4 4 npick 5 narray ."\r
+ "{ 1 2 3 4 1 }"\r
+ }\r
"Some core words expressed in terms of " { $link npick } ":"\r
{ $table\r
{ { $link dup } { $snippet "1 npick" } }\r
"placed on the top of the stack."\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup 8 narray ." "{ 1 2 3 4 1 2 3 4 }" }\r
+ { $example\r
+ "USING: prettyprint generalizations kernel"\r
+ "sequences.generalizations ;"\r
+ ""\r
+ "1 2 3 4 4 ndup 8 narray ."\r
+ "{ 1 2 3 4 1 2 3 4 }"\r
+ }\r
"Some core words expressed in terms of " { $link ndup } ":"\r
{ $table\r
{ { $link dup } { $snippet "1 ndup" } }\r
"saved, the quotation called, and the items restored."\r
} \r
{ $examples\r
- { $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 }" }\r
+ { $example\r
+ "USING: generalizations kernel prettyprint"\r
+ "sequences.generalizations ;"\r
+ ""\r
+ "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ."\r
+ "{ 99 1 2 3 4 5 }"\r
+ }\r
"Some core words expressed in terms of " { $link nkeep } ":"\r
{ $table\r
{ { $link keep } { $snippet "1 nkeep" } }\r
}\r
{ $description "Construct a quotation containing the contents of " { $snippet "seq" } " repeated " { $snippet "n"} " times." } ;\r
\r
-HELP: nappend\r
-{ $values\r
- { "n" integer }\r
- { "seq" sequence }\r
-}\r
-{ $description "Outputs a new sequence consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }\r
-{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }\r
-{ $examples\r
- { $example "USING: generalizations prettyprint math ;"\r
- "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 nappend ."\r
- "{ 1 2 3 4 5 6 7 8 }"\r
- }\r
-} ;\r
-\r
-HELP: nappend-as\r
-{ $values\r
- { "n" integer } { "exemplar" sequence }\r
- { "seq" sequence }\r
-}\r
-{ $description "Outputs a new sequence of type " { $snippet "exemplar" } " consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }\r
-{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }\r
-{ $examples\r
- { $example "USING: generalizations prettyprint math ;"\r
- "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 V{ } nappend-as ."\r
- "V{ 1 2 3 4 5 6 7 8 }"\r
- }\r
-} ;\r
-\r
-{ nappend nappend-as } related-words\r
-\r
-ARTICLE: "sequence-generalizations" "Generalized sequence operations"\r
-{ $subsections\r
- narray\r
- nsequence\r
- firstn\r
- set-firstn\r
- nappend\r
- nappend-as\r
-} ;\r
-\r
ARTICLE: "shuffle-generalizations" "Generalized shuffle words"\r
{ $subsections\r
ndup\r
"macros where the arity of the input quotations depends on an "\r
"input parameter."\r
{ $subsections\r
- "sequence-generalizations"\r
"shuffle-generalizations"\r
"combinator-generalizations"\r
"other-generalizations"\r
}\r
-"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence iteration combinators." ;\r
+"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence operations." ;\r
\r
ABOUT: "generalizations"\r
\r
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test\r
\r
-[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test\r
-[ { 1 2 3 4 } ] [ 1 2 3 4 { f f f f } [ 4 set-firstn ] keep ] unit-test\r
-[ 1 2 3 4 { f f f } [ 4 set-firstn ] keep ] must-fail\r
-[ ] [ { } 0 firstn ] unit-test\r
-[ "a" ] [ { "a" } 1 firstn ] unit-test\r
-\r
-[ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test\r
-\r
[ 4 5 1 2 3 ] [ 1 2 3 4 5 2 3 mnswap ] unit-test\r
\r
[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 2 4 mnswap 4 2 mnswap ] unit-test\r
\r
-[ { 1 2 3 4 } ] [ { 1 } { 2 } { 3 } { 4 } 4 nappend ] unit-test\r
-[ V{ 1 2 3 4 } ] [ { 1 } { 2 } { 3 } { 4 } 4 V{ } nappend-as ] unit-test\r
-\r
-[ 4 nappend ] must-infer\r
-[ 4 { } nappend-as ] must-infer\r
-\r
[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test\r
{ 4 1 } [ 4 nsum ] must-infer-as\r
\r
>>
-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 ;
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 ;
MACRO: nbi-curry ( n -- )
[ bi-curry ] n*quot ;
-
-: nappend-as ( n exemplar -- seq )
- [ narray concat ] dip like ; inline
-
-: nappend ( n -- seq ) narray concat ; inline
-
"{ 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:"
"{ 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 ;"
: extract-values ( element -- seq )
\ $values swap elements dup empty? [
- first rest [ first ] map
+ first rest keys
] unless ;
: extract-value-effects ( element -- seq )
{ 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
dup header>> bit-count>> {
{ 16 [
dup bitfields>> '[
- byte-array>ushort-array _ uncompress-bitfield
+ ushort-array-cast _ uncompress-bitfield
] change-color-index
] }
{ 32 [ ] }
[ 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 ;
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 ;
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 ;
] 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 ;
utf8 file-lines { "" } split [
[ " " split ] map
[ first { "Name:" "Alias:" } member? ] filter
- [ second ] map { "None" } diff
+ values { "None" } diff
] map harvest ;
: make-aliases ( file -- n>e )
[ t ] [
"test.txt" temp-file binary [
- 100,000 4 * read byte-array>int-array 100,000 iota sequence=
+ 100,000 4 * read int-array-cast 100,000 iota sequence=
] with-file-reader
] unit-test
[ '[ _ cancel-operation ] ] dip later ;\r
\r
: with-timeout* ( obj timeout quot -- )\r
- 3dup drop queue-timeout [ nip call ] dip cancel-alarm ;\r
+ 3dup drop queue-timeout [ nip call ] dip stop-alarm ;\r
inline\r
\r
: with-timeout ( obj quot -- )\r
LIBRARY: libc
FUNCTION-ALIAS: (malloc)
- void* malloc ( ulong size ) ;
+ void* malloc ( size_t size ) ;
FUNCTION-ALIAS: (calloc)
- void* calloc ( ulong count, ulong size ) ;
+ void* calloc ( size_t count, size_t size ) ;
FUNCTION-ALIAS: (free)
void free ( void* alien ) ;
FUNCTION-ALIAS: (realloc)
- void* realloc ( void* alien, ulong size ) ;
+ void* realloc ( void* alien, size_t size ) ;
<PRIVATE
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.tuple fry
-generalizations hashtables kernel locals locals.backend
+sequences.generalizations hashtables kernel locals locals.backend
locals.errors locals.types make quotations sequences vectors
words ;
IN: locals.rewrite.sugar
\r
: schedule-insomniac ( service word-names -- )\r
[ [ email-log-report ] assoc-each rotate-logs ] 2curry\r
- 1 days every drop ;\r
+ 1 days delayed-every drop ;\r
words kernel arrays shuffle tools.annotations\r
prettyprint.config prettyprint debugger io.streams.string\r
splitting continuations effects generalizations parser strings\r
-quotations fry accessors math assocs math.order ;\r
+quotations fry accessors math assocs math.order\r
+sequences.generalizations ;\r
IN: logging\r
\r
SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;\r
GENERIC: (bit-count) ( x -- n )
-M: fixnum (bit-count)
+: fixnum-bit-count ( x -- n )
0 swap [
dup 0 >
] [
[ + ] dip
] while drop ;
+M: fixnum (bit-count)
+ fixnum-bit-count ; inline
+
M: bignum (bit-count)
dup 0 = [ drop 0 ] [
[ byte-bit-count ] [ -8 shift (bit-count) ] bi +
-USING: alien alien.c-types cpu.architecture cpu.x86.assembler
+USING: alien alien.c-types cpu.x86.64 cpu.x86.assembler
cpu.x86.assembler.operands math.floats.env.x86 sequences system ;
IN: math.floats.env.x86.64
M: x86.64 get-sse-env
void { void* } cdecl [
- int-regs cdecl param-regs first [] STMXCSR
+ param-reg-0 [] STMXCSR
] alien-assembly ;
M: x86.64 set-sse-env
void { void* } cdecl [
- int-regs cdecl param-regs first [] LDMXCSR
+ param-reg-0 [] LDMXCSR
] alien-assembly ;
M: x86.64 get-x87-env
void { void* } cdecl [
- int-regs cdecl param-regs first [] FNSTSW
- int-regs cdecl param-regs first 2 [+] FNSTCW
+ param-reg-0 [] FNSTSW
+ param-reg-0 2 [+] FNSTCW
] alien-assembly ;
M: x86.64 set-x87-env
void { void* } cdecl [
FNCLEX
- int-regs cdecl param-regs first 2 [+] FLDCW
+ param-reg-0 2 [+] FLDCW
] alien-assembly ;
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.functions
+USING: arrays assocs combinators kernel make math math.functions
math.primes math.ranges sequences sequences.product sorting
io math.parser ;
IN: math.primes.factors
: group-factors ( n -- seq )
dup prime? [ 1 2array 1array ] [ (group-factors) ] if ; flushable
-: unique-factors ( n -- seq ) group-factors [ first ] map ; flushable
+: unique-factors ( n -- seq ) group-factors keys ; flushable
: factors ( n -- seq )
group-factors [ first2 swap <array> ] map concat ; flushable
! (c)Joe Groff bsd license
USING: accessors arrays compiler.test continuations generalizations
kernel kernel.private locals math.vectors.conversion math.vectors.simd
-sequences stack-checker tools.test ;
+sequences stack-checker tools.test sequences.generalizations ;
FROM: alien.c-types => char uchar short ushort int uint longlong ulonglong float double ;
IN: math.vectors.conversion.tests
USING: accessors alien.c-types arrays byte-arrays
cpu.architecture effects functors generalizations kernel lexer
math math.vectors.simd math.vectors.simd.intrinsics parser
-prettyprint.custom quotations sequences sequences.cords words ;
+prettyprint.custom quotations sequences sequences.cords words
+classes ;
IN: math.vectors.simd.cords
<<
: A-cast ( v -- v' )
[ A/2-cast ] cord-map ; inline
+M: A new-sequence
+ 2drop
+ N A/2 new new-sequence
+ N A/2 new new-sequence
+ \ A boa ;
+
+M: A like
+ over \ A instance? [ drop ] [ call-next-method ] if ;
+
M: A >pprint-sequence ;
M: A pprint* pprint-object ;
USING: accessors alien alien.c-types alien.data combinators
sequences.cords cpu.architecture fry generalizations grouping
kernel libc locals math math.libm math.order math.ranges
-math.vectors sequences sequences.private specialized-arrays
-vocabs.loader ;
+math.vectors sequences sequences.generalizations
+sequences.private specialized-arrays vocabs.loader ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAYS:
c:char c:short c:int c:longlong
: [byte>rep-array] ( rep -- class )
{
- { char-16-rep [ [ byte-array>char-array ] ] }
- { uchar-16-rep [ [ byte-array>uchar-array ] ] }
- { short-8-rep [ [ byte-array>short-array ] ] }
- { ushort-8-rep [ [ byte-array>ushort-array ] ] }
- { int-4-rep [ [ byte-array>int-array ] ] }
- { uint-4-rep [ [ byte-array>uint-array ] ] }
- { longlong-2-rep [ [ byte-array>longlong-array ] ] }
- { ulonglong-2-rep [ [ byte-array>ulonglong-array ] ] }
- { float-4-rep [ [ byte-array>float-array ] ] }
- { double-2-rep [ [ byte-array>double-array ] ] }
+ { char-16-rep [ [ char-array-cast ] ] }
+ { uchar-16-rep [ [ uchar-array-cast ] ] }
+ { short-8-rep [ [ short-array-cast ] ] }
+ { ushort-8-rep [ [ ushort-array-cast ] ] }
+ { int-4-rep [ [ int-array-cast ] ] }
+ { uint-4-rep [ [ uint-array-cast ] ] }
+ { longlong-2-rep [ [ longlong-array-cast ] ] }
+ { ulonglong-2-rep [ [ ulonglong-array-cast ] ] }
+ { float-4-rep [ [ float-array-cast ] ] }
+ { double-2-rep [ [ double-array-cast ] ] }
} case ; foldable
: [>rep-array] ( rep -- class )
] each-index
c' underlying>> ; inline
+:: (vshuffle2) ( a b elts rep -- c )
+ a rep >rep-array :> a'
+ b rep >rep-array :> b'
+ a' b' cord-append :> ab'
+ rep <rep-array> :> c'
+ elts [| from to |
+ from rep rep-length dup + 1 - bitand
+ ab' nth-unsafe
+ to c' set-nth-unsafe
+ ] each-index
+ c' underlying>> ; inline
+
PRIVATE>
: (simd-v+) ( a b rep -- c ) [ + ] components-2map ;
: (simd-hrshift) ( a n rep -- c )
drop tail-slice 16 0 pad-tail ;
: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
+: (simd-vshuffle2-elements) ( a b n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle2) ;
: (simd-vshuffle-bytes) ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
:: (simd-vmerge-head) ( a b rep -- c )
a b rep 2>rep-array :> ( a' b' )
"compiler.cfg.intrinsics.simd" require
"compiler.tree.propagation.simd" require
"compiler.cfg.value-numbering.simd" require
-
USING: accessors arrays classes compiler.test compiler.tree.debugger
effects fry io kernel kernel.private math math.functions
-math.private math.vectors math.vectors.simd
+math.private math.vectors math.vectors.simd math.ranges
math.vectors.simd.private prettyprint random sequences system
tools.test vocabs assocs compiler.cfg.debugger words
locals combinators cpu.architecture namespaces byte-arrays alien
specialized-arrays classes.struct eval classes.algebra sets
-quotations math.constants compiler.units splitting ;
+quotations math.constants compiler.units splitting math.matrices
+math.vectors.simd.cords alien.data ;
FROM: math.vectors.simd.intrinsics => alien-vector set-alien-vector ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: c:float
[ dup '[ _ random ] replicate 1array ]
} case ;
+: 2shuffles-for ( n -- shuffles )
+ {
+ { 2 [
+ {
+ { 0 1 }
+ { 0 3 }
+ { 2 3 }
+ { 2 0 }
+ }
+ ] }
+ { 4 [
+ {
+ { 0 1 2 3 }
+ { 4 1 2 3 }
+ { 0 5 2 3 }
+ { 0 1 6 3 }
+ { 0 1 2 7 }
+ { 4 5 2 3 }
+ { 0 1 6 7 }
+ { 4 5 6 7 }
+ { 0 5 2 7 }
+ }
+ ] }
+ { 8 [
+ 4 2shuffles-for
+ 4 2shuffles-for
+ [ [ 8 + ] map ] map
+ [ append ] 2map
+ ] }
+ [ dup 2 * '[ _ random ] replicate 1array ]
+ } case ;
+
simd-classes [
[ [ { } ] ] dip
[ new length shuffles-for ] keep
] unit-test
] each
+simd-classes [
+ [ [ { } ] ] dip
+ [ new length 2shuffles-for ] keep
+ '[
+ _ [ [
+ _ new
+ [ [ length iota ] keep like ]
+ [ [ length dup dup + [a,b) ] keep like ] bi [ ] 2sequence
+ ] dip '[ _ vshuffle2-elements ] ]
+ [ = ] check-optimizer
+ ] unit-test
+] each
+
"== Checking variable shuffles" print
: random-shift-vector ( class -- vec )
[ ] [ char-16 new 1array stack. ] unit-test
+! Test some sequence protocol stuff
+[ t ] [ 4 double-4{ 1 2 3 4 } new-sequence double-4? ] unit-test
+[ double-4{ 2 3 4 5 } ] [ double-4{ 1 2 3 4 } [ 1 + ] map ] unit-test
+
+! Test cross product
+[ float-4{ 0.0 0.0 1.0 0.0 } ] [ float-4{ 1.0 0.0 0.0 0.0 } float-4{ 0.0 1.0 0.0 0.0 } cross ] unit-test
+[ float-4{ 0.0 -1.0 0.0 0.0 } ] [ float-4{ 1.0 0.0 0.0 0.0 } float-4{ 0.0 0.0 1.0 0.0 } cross ] unit-test
+
+[ double-4{ 0.0 0.0 1.0 0.0 } ] [ double-4{ 1.0 0.0 0.0 0.0 } double-4{ 0.0 1.0 0.0 0.0 } cross ] unit-test
+[ double-4{ 0.0 -1.0 0.0 0.0 } ] [ double-4{ 1.0 0.0 0.0 0.0 } double-4{ 0.0 0.0 1.0 0.0 } cross ] unit-test
+
! CSSA bug
[ 4000000 ] [
int-4{ 1000 1000 1000 1000 }
[ float-4{ 0 0 0 0 } ]
[ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test
+
+USE: alien
+
+: callback-1 ( -- c )
+ c:int { c:int c:int c:int c:int c:int } cdecl [ + + + + ] alien-callback ;
+
+: indirect-1 ( x x x x x c -- y )
+ c:int { c:int c:int c:int c:int c:int } cdecl alien-indirect ; inline
+
+: simd-spill-test-3 ( a b d c -- v )
+ { float float-4 float-4 float } declare
+ [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v
+ 10 5 100 50 500 callback-1 indirect-1 665 assert= ;
+
+[ float-4{ 0 0 0 0 } ]
+[ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-3 ] unit-test
+
+! Stack allocation of SIMD values -- make sure that everything is
+! aligned right
+
+: simd-stack-test ( -- b c )
+ { c:int float-4 } [
+ [ 123 swap 0 c:int c:set-alien-value ]
+ [ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi*
+ ] [ ] with-out-parameters ;
+
+[ 123 float-4{ 1 2 3 4 } ] [ simd-stack-test ] unit-test
+
+! Stack allocation + spilling
+
+: (simd-stack-spill-test) ( -- n ) 17 ;
+
+: simd-stack-spill-test ( x -- b c )
+ { c:int } [
+ 123 swap 0 c:int c:set-alien-value
+ >float (simd-stack-spill-test) float-4-with swap cos v*n
+ ] [ ] with-out-parameters ;
+
+[ ] [
+ 1.047197551196598 simd-stack-spill-test
+ [ float-4{ 8.5 8.5 8.5 8.5 } approx= t assert= ]
+ [ 123 assert= ]
+ bi*
+] unit-test
USING: accessors alien arrays byte-arrays classes combinators
cpu.architecture effects fry functors generalizations generic
-generic.parser kernel lexer literals macros math math.functions
+generic.parser kernel lexer literals locals macros math math.functions
math.vectors math.vectors.private math.vectors.simd.intrinsics
namespaces parser prettyprint.custom quotations sequences
-sequences.private vocabs vocabs.loader words ;
+sequences.generalizations sequences.private vocabs vocabs.loader
+words ;
QUALIFIED-WITH: alien.c-types c
IN: math.vectors.simd
: (vv->v-op) ( a b rep quot: ( (a) (b) rep -- (c) ) -- c )
[ [ simd-unbox ] [ underlying>> ] bi* ] 2dip 3curry make-underlying ; inline
-
: (vv->n-op) ( a b rep quot: ( (a) (b) rep -- n ) -- n )
[ [ underlying>> ] bi@ ] 2dip 3curry call ; inline
+: (vvn->v-op) ( a b n rep quot: ( (a) (b) n rep -- (c) ) -- c )
+ [ [ simd-unbox ] [ underlying>> ] bi* ] 3dip 2curry 2curry make-underlying ; inline
: vv->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
[ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
+:: vvn->v-op ( a b n rep quot: ( (a) (b) n rep -- (c) ) fallback-quot -- c )
+ a b rep
+ [ n swap quot (vvn->v-op) ]
+ [ drop n fallback-quot call ] if-both-vectors-match ; inline
+
: vv'->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
[ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors ; inline
over simd-rep [ (simd-hrshift) ] [ call-next-method ] vn->v-op ; inline
M: simd-128 vshuffle-elements
over simd-rep [ (simd-vshuffle-elements) ] [ call-next-method ] vn->v-op ; inline
+M: simd-128 vshuffle2-elements
+ over simd-rep [ (simd-vshuffle2-elements) ] [ call-next-method ] vvn->v-op ; inline
M: simd-128 vshuffle-bytes
dup simd-rep [ (simd-vshuffle-bytes) ] [ call-next-method ] vv'->v-op ; inline
M: simd-128 (vmerge-head)
N [ A-rep rep-length ]
COERCER [ ELT c:c-type-class "coercer" word-prop [ ] or ]
-SET-NTH [ ELT dup c:c-setter c:array-accessor ]
-
BOA-EFFECT [ N "n" <array> { "v" } <effect> ]
WHERE
swap \ A-rep [ (simd-select) ] [ call-next-method ] vn->n-op ; inline
M: A set-nth-unsafe
[ ELT boolean>element ] 2dip
- underlying>> SET-NTH call ; inline
+ underlying>> ELT c:set-alien-element ; inline
: >A ( seq -- simd ) \ A new clone-like ; inline
over length 0 pad-tail
swap [ '[ _ nth ] ] keep map-as ; inline
+GENERIC# vshuffle2-elements 1 ( u v perm -- w )
+M: object vshuffle2-elements
+ [ append ] dip vshuffle-elements ; inline
+
GENERIC# vshuffle-bytes 1 ( u perm -- v )
GENERIC: vshuffle ( u perm -- v )
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: models.arrow models.product stack-checker accessors fry
-generalizations combinators.smart macros kernel ;
+generalizations sequences.generalizations combinators.smart
+macros kernel ;
IN: models.arrow.smart
MACRO: <smart-arrow> ( quot -- quot' )
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors kernel models alarms ;\r
+USING: accessors alarms fry kernel models ;\r
IN: models.delay\r
\r
TUPLE: delay < model model timeout alarm ;\r
over >>model\r
[ add-dependency ] keep ;\r
\r
-: cancel-delay ( delay -- )\r
- alarm>> [ cancel-alarm ] when* ;\r
+: stop-delay ( delay -- )\r
+ alarm>> [ stop-alarm ] when* ;\r
\r
: start-delay ( delay -- )\r
dup\r
- [ [ f >>alarm update-delay-model ] curry ] [ timeout>> ] bi later\r
+ [ '[ _ f >>alarm update-delay-model ] ] [ timeout>> ] bi\r
+ later\r
>>alarm drop ;\r
\r
-M: delay model-changed nip dup cancel-delay start-delay ;\r
+M: delay model-changed nip dup stop-delay start-delay ;\r
\r
M: delay model-activated update-delay-model ;\r
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors generic kernel math sequences arrays assocs
-alarms calendar math.order continuations fry ;
+calendar math.order continuations fry ;
IN: models
TUPLE: model < identity-tuple
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors kernel models arrays sequences math math.order\r
-models.product generalizations math.functions ;\r
+models.product generalizations sequences.generalizations\r
+math.functions ;\r
FROM: models.product => product ;\r
IN: models.range\r
\r
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math.parser kernel macros
-generalizations locals ;
+generalizations sequences.generalizations locals ;
IN: nmake
SYMBOL: building-seq
continuations kernel libc math macros namespaces math.vectors
math.parser opengl.gl combinators combinators.smart arrays
sequences splitting words byte-arrays assocs vocabs
-colors colors.constants accessors generalizations locals fry
-specialized-arrays ;
+colors colors.constants accessors generalizations
+sequences.generalizations locals fry specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: uint
images.tesselation grouping sequences math math.vectors
generalizations fry arrays namespaces system
locals literals specialized-arrays ;
-FROM: alien.c-types => float ;
+FROM: alien.c-types => float <float> <int> *float *int ;
SPECIALIZED-ARRAY: float
IN: opengl.textures
over dim>> max-texture-size [ <= ] 2all?
[ <single-texture> ]
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
+
+: get-texture-float ( target level enum -- value )
+ 0 <float> [ glGetTexLevelParameterfv ] keep *float ; inline
+: get-texture-int ( target level enum -- value )
+ 0 <int> [ glGetTexLevelParameteriv ] keep *int ; inline
+
state-multiplier * 32 bits
] dip + 32 bits
] uint-array{ } accumulate-as nip
- dup underlying>> byte-array>uint-4-array ;
+ dup uint-4-array-cast ;
: <sfmt-state> ( seed n m mask parity -- sfmt )
sfmt-state <struct>
[ [ [ head>> ] bi@ ] dip call ]
[ [ [ tail>> ] bi@ ] dip call ] 3bi ; inline
+<PRIVATE
+: split-shuffle ( shuf -- sh uf )
+ dup length 2 /i cut* ; foldable
+PRIVATE>
+
M: cord v+ [ v+ ] cord-2map ; inline
M: cord v- [ v- ] cord-2map ; inline
M: cord vneg [ vneg ] cord-map ; inline
M: cord vany? [ vany? ] cord-both or ; inline
M: cord vall? [ vall? ] cord-both and ; inline
M: cord vnone? [ vnone? ] cord-both and ; inline
+M: cord vshuffle-elements
+ [ [ head>> ] [ tail>> ] bi ] [ split-shuffle ] bi*
+ [ vshuffle2-elements ] bi-curry@ 2bi cord-append ; inline
M: cord n+v [ n+v ] with cord-map ; inline
M: cord n-v [ n-v ] with cord-map ; inline
math arrays combinators ;
IN: sequences.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: prettyprint sequences.generalizations ;" "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: 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: 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: math prettyprint sequences.generalizations ;"
+ "{ 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: math prettyprint sequences.generalizations ;"
+ "{ 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
+
HELP: neach
{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( element... -- )" } } { "n" integer } }
{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "exemplar..." { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
-ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators"
-"The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of the iteration " { $link "sequences-combinators" } "."
+ARTICLE: "sequences.generalizations" "Generalized sequence words"
+"The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of various sequence operations."
+{ $subsections
+ narray
+ nsequence
+ firstn
+ set-firstn
+ nappend
+ nappend-as
+}
+"Generalized " { $link "sequences-combinators" } ":"
{ $subsections
neach
nmap
sequences.generalizations ascii fry math.parser io io.streams.string ;
IN: sequences.generalizations.tests
+[ 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
+
+[ { 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
+
: neach-test ( a b c d -- )
[ 4 nappend print ] 4 neach ;
: nmap-test ( a b c d -- e )
memoize.private generalizations ;
IN: sequences.generalizations
+MACRO: nsequence ( n seq -- )
+ [ [nsequence] ] keep
+ '[ @ _ like ] ;
+
+MACRO: narray ( n -- )
+ '[ _ { } nsequence ] ;
+
+MACRO: firstn-unsafe ( n -- )
+ [firstn] ;
+
+MACRO: firstn ( n -- )
+ dup zero? [ drop [ drop ] ] [
+ [ 1 - swap bounds-check 2drop ]
+ [ firstn-unsafe ]
+ bi-curry '[ _ _ bi ]
+ ] if ;
+
+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 ;
+
+: nappend-as ( n exemplar -- seq )
+ [ narray concat ] dip like ; inline
+
+: nappend ( n -- seq ) narray concat ; inline
+
MACRO: nmin-length ( n -- )
dup 1 - [ min ] n*quot
'[ [ length ] _ napply @ ] ;
: nnth-unsafe ( n seq... n -- )
[ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
+
MACRO: nset-nth-unsafe ( n -- )
[ [ drop ] ]
[ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
--- /dev/null
+Unrolled fixed-length sequence iteration
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: help.markup help.syntax kernel math quotations sequences
+sequences.private ;
+IN: sequences.unrolled
+
+HELP: unrolled-collect
+{ $values
+ { "n" integer } { "quot" { $quotation "( ... n -- ... value )" } } { "into" sequence }
+}
+{ $description "Unrolled version of " { $link collect } ". " { $snippet "n" } " must be a compile-time constant." } ;
+
+HELP: unrolled-each
+{ $values
+ { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... )" } }
+}
+{ $description "Unrolled version of " { $link each } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
+
+HELP: unrolled-2each
+{ $values
+ { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... )" } }
+}
+{ $description "Unrolled version of " { $link 2each } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
+
+HELP: unrolled-each-index
+{ $values
+ { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x i -- ... )" } }
+}
+{ $description "Unrolled version of " { $link each-index } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
+
+HELP: unrolled-each-integer
+{ $values
+ { "n" integer } { "quot" { $quotation "( ... i -- ... )" } }
+}
+{ $description "Unrolled version of " { $link each-integer } ". " { $snippet "n" } " must be a compile-time constant." } ;
+
+HELP: unrolled-map
+{ $values
+ { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... newx )" } }
+ { "newseq" sequence }
+}
+{ $description "Unrolled version of " { $link map } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
+
+HELP: unrolled-map-as
+{ $values
+ { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... newx )" } } { "exemplar" sequence }
+ { "newseq" sequence }
+}
+{ $description "Unrolled version of " { $link map-as } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
+
+HELP: unrolled-2map
+{ $values
+ { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... newx )" } } { "newseq" sequence }
+}
+{ $description "Unrolled version of " { $link 2map } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
+
+HELP: unrolled-2map-as
+{ $values
+ { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... newx )" } } { "exemplar" sequence } { "newseq" sequence }
+}
+{ $description "Unrolled version of " { $link 2map-as } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
+
+HELP: unrolled-map-index
+{ $values
+ { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x i -- ... newx )" } }
+ { "newseq" sequence }
+}
+{ $description "Unrolled version of " { $link map-index } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
+
+HELP: unrolled-map-integers
+{ $values
+ { "n" integer } { "quot" { $quotation "( ... n -- ... value )" } } { "exemplar" sequence } { "newseq" sequence }
+}
+{ $description "Unrolled version of " { $link map-integers } ". " { $snippet "n" } " must be a compile-time constant." } ;
+
+ARTICLE: "sequences.unrolled" "Unrolled sequence iteration combinators"
+"The " { $vocab-link "sequences.unrolled" } " vocabulary provides versions of some of the " { $link "sequences-combinators" } " that unroll their loops, that is, expand to a constant number of repetitions of a quotation rather than an explicit loop. These unrolled combinators all require a constant integer value to indicate the number of unrolled iterations to perform."
+$nl
+"Unrolled versions of high-level iteration combinators:"
+{ $subsections
+ unrolled-each
+ unrolled-each-index
+ unrolled-2each
+ unrolled-map
+ unrolled-map-index
+ unrolled-map-as
+ unrolled-2map
+ unrolled-2map-as
+}
+"Unrolled versions of low-level iteration combinators:"
+{ $subsections
+ unrolled-each-integer
+ unrolled-map-integers
+ unrolled-collect
+} ;
+
+ABOUT: "sequences.unrolled"
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: compiler.test make math.parser sequences
+sequences.unrolled tools.test ;
+IN: sequences.unrolled.tests
+
+[ { "0" "1" "2" } ] [ { 0 1 2 } 3 [ number>string ] unrolled-map ] unit-test
+[ { "0" "1" "2" } ] [ { 0 1 2 } [ 3 [ number>string ] unrolled-map ] compile-call ] unit-test
+
+[ { "0" "1" "2" } ] [ [ { 0 1 2 } 3 [ number>string , ] unrolled-each ] { } make ] unit-test
+
+[ { "a0" "b1" "c2" } ]
+[ [ { "a" "b" "c" } 3 [ number>string append , ] unrolled-each-index ] { } make ] unit-test
+
+[ { "aI" "bII" "cIII" } ]
+[ [ { "a" "b" "c" } { "I" "II" "III" } 3 [ append , ] unrolled-2each ] { } make ] unit-test
+
+[ { "aI" "bII" "cIII" } ]
+[ { "a" "b" "c" } { "I" "II" "III" } 3 [ append ] unrolled-2map ] unit-test
+
+[ { "a0" "b1" "c2" } ]
+[ { "a" "b" "c" } 3 [ number>string append ] unrolled-map-index ] unit-test
+
+[ { 0 1 2 } 4 [ number>string ] unrolled-map ] [ unrolled-bounds-error? ] must-fail-with
+[ { 0 1 2 3 } { 0 1 2 } 4 [ number>string append ] unrolled-2map ] [ unrolled-2bounds-error? ] must-fail-with
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: combinators.short-circuit fry generalizations kernel
+locals macros math quotations sequences ;
+FROM: sequences.private => (each) (each-index) (collect) (2each) ;
+IN: sequences.unrolled
+
+<PRIVATE
+MACRO: (unrolled-each-integer) ( n -- )
+ [ iota >quotation ] keep '[ _ dip _ napply ] ;
+PRIVATE>
+
+: unrolled-each-integer ( ... n quot: ( ... i -- ... ) -- ... )
+ swap (unrolled-each-integer) ; inline
+
+: unrolled-collect ( ... n quot: ( ... n -- ... value ) into -- ... )
+ (collect) unrolled-each-integer ; inline
+
+: unrolled-map-integers ( ... n quot: ( ... n -- ... value ) exemplar -- ... newseq )
+ [ over ] dip [ [ unrolled-collect ] keep ] new-like ; inline
+
+ERROR: unrolled-bounds-error
+ seq unroll-length ;
+
+ERROR: unrolled-2bounds-error
+ xseq yseq unroll-length ;
+
+<PRIVATE
+: unrolled-bounds-check ( seq len quot -- seq len quot )
+ 2over swap length > [ 2over unrolled-bounds-error ] when ; inline
+
+:: unrolled-2bounds-check ( xseq yseq len quot -- xseq yseq len quot )
+ { [ len xseq length > ] [ len yseq length > ] } 0||
+ [ xseq yseq len unrolled-2bounds-error ]
+ [ xseq yseq len quot ] if ; inline
+
+: (unrolled-each) ( seq len quot -- len quot )
+ swapd (each) nip ; inline
+
+: (unrolled-each-index) ( seq len quot -- len quot )
+ swapd (each-index) nip ; inline
+
+: (unrolled-2each) ( xseq yseq len quot -- len quot )
+ [ '[ _ ] 2dip ] dip (2each) nip ; inline
+
+: unrolled-each-unsafe ( ... seq len quot: ( ... x -- ... ) -- ... )
+ (unrolled-each) unrolled-each-integer ; inline
+
+: unrolled-2each-unsafe ( ... xseq yseq len quot: ( ... x y -- ... ) -- ... )
+ (unrolled-2each) unrolled-each-integer ; inline
+
+: unrolled-each-index-unsafe ( ... seq len quot: ( ... x -- ... ) -- ... )
+ (unrolled-each-index) unrolled-each-integer ; inline
+
+: unrolled-map-as-unsafe ( ... seq len quot: ( ... x -- ... newx ) exemplar -- ... newseq )
+ [ (unrolled-each) ] dip unrolled-map-integers ; inline
+
+: unrolled-2map-as-unsafe ( ... xseq yseq len quot: ( ... x y -- ... newx ) exemplar -- ... newseq )
+ [ (unrolled-2each) ] dip unrolled-map-integers ; inline
+
+PRIVATE>
+
+: unrolled-each ( ... seq len quot: ( ... x -- ... ) -- ... )
+ unrolled-bounds-check unrolled-each-unsafe ; inline
+
+: unrolled-2each ( ... xseq yseq len quot: ( ... x y -- ... ) -- ... )
+ unrolled-2bounds-check unrolled-2each-unsafe ; inline
+
+: unrolled-each-index ( ... seq len quot: ( ... x i -- ... ) -- ... )
+ unrolled-bounds-check unrolled-each-index-unsafe ; inline
+
+: unrolled-map-as ( ... seq len quot: ( ... x -- ... newx ) exemplar -- ... newseq )
+ [ unrolled-bounds-check ] dip unrolled-map-as-unsafe ; inline
+
+: unrolled-2map-as ( ... xseq yseq len quot: ( ... x y -- ... newx ) exemplar -- ... newseq )
+ [ unrolled-2bounds-check ] dip unrolled-2map-as-unsafe ; inline
+
+: unrolled-map ( ... seq len quot: ( ... x -- ... newx ) -- ... newseq )
+ pick unrolled-map-as ; inline
+
+: unrolled-2map ( ... xseq yseq len quot: ( ... x y -- ... newx ) -- ... newseq )
+ 4 npick unrolled-2map-as ; inline
+
+: unrolled-map-index ( ... seq len quot: ( ... x i -- ... newx ) -- ... newseq )
+ [ dup length iota ] 2dip unrolled-2map ; inline
+
! Copyright (C) 2007 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators effects.parser generalizations
-hashtables kernel locals locals.backend macros make math
-parser sequences ;
+USING: accessors assocs combinators effects.parser
+generalizations sequences.generalizations hashtables kernel
+locals locals.backend macros make math parser sequences ;
IN: shuffle
<PRIVATE
{ { $snippet "(T-array)" } { "Constructor for arrays with elements of type " { $snippet "T" } ", where the initial contents are uninitialized; stack effect " { $snippet "( len -- array )" } } }
{ { $snippet "malloc-T-array" } { "Constructor for arrays with elements of type " { $snippet "T" } " backed by newly-allocated unmanaged memory; stack effect " { $snippet "( alien len -- array )" } } }
{ { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } " backed by raw memory; stack effect " { $snippet "( alien len -- array )" } } }
- { { $snippet "byte-array>T-array" } { "Converts a byte array into a specialized array by interpreting the bytes in as machine-specific values. Code which uses this word is unportable" } }
+ { { $snippet "T-array-cast" } { "Converts a byte array into a specialized array by interpreting the bytes in as machine-specific values. Code which uses this word is unportable" } }
{ { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
{ { $snippet "T-array{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } }
}
] unit-test
[ ushort-array{ 1234 } ] [
- little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array
+ little-endian? B{ 210 4 } B{ 4 210 } ? ushort-array-cast
] unit-test
-[ B{ 210 4 1 } byte-array>ushort-array ] must-fail
+[ B{ 210 4 1 } ushort-array-cast ] must-fail
[ { 3 1 3 3 7 } ] [
int-array{ 3 1 3 3 7 } malloc-byte-array 5 <direct-int-array> >array
FUNCTOR: define-array ( T -- )
-A DEFINES-CLASS ${T}-array
-<A> DEFINES <${A}>
-(A) DEFINES (${A})
-<direct-A> DEFINES <direct-${A}>
-malloc-A DEFINES malloc-${A}
->A DEFINES >${A}
-byte-array>A DEFINES byte-array>${A}
-
-A{ DEFINES ${A}{
-A@ DEFINES ${A}@
-
-NTH [ T dup c-getter array-accessor ]
-SET-NTH [ T dup c-setter array-accessor ]
+A DEFINES-CLASS ${T}-array
+<A> DEFINES <${A}>
+(A) DEFINES (${A})
+<direct-A> DEFINES <direct-${A}>
+malloc-A DEFINES malloc-${A}
+>A DEFINES >${A}
+A-cast DEFINES ${A}-cast
+A{ DEFINES ${A}{
+A@ DEFINES ${A}@
WHERE
: malloc-A ( len -- specialized-array )
[ \ T heap-size calloc ] keep <direct-A> ; inline
-: byte-array>A ( byte-array -- specialized-array )
- >c-ptr dup byte-array? [
- dup length \ T heap-size /mod 0 =
- [ <direct-A> ]
- [ drop \ T bad-byte-array-length ] if
- ] [ not-a-byte-array ] if ; inline
+: A-cast ( byte-array -- specialized-array )
+ binary-object \ T heap-size /mod 0 =
+ [ <direct-A> ] [ drop \ T bad-byte-array-length ] if ; inline
M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
M: A length length>> ; inline
-M: A nth-unsafe underlying>> NTH call ; inline
+M: A nth-unsafe underlying>> \ T alien-element ; inline
-M: A set-nth-unsafe underlying>> SET-NTH call ; inline
+M: A set-nth-unsafe underlying>> \ T set-alien-element ; inline
: >A ( seq -- specialized-array ) A new clone-like ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors combinators math namespaces
-init sets words assocs alien.libraries alien alien.private
-alien.c-types fry stack-checker.backend
-stack-checker.errors stack-checker.visitor
-stack-checker.dependencies ;
+USING: kernel arrays sequences accessors combinators math
+namespaces init sets words assocs alien.libraries alien
+alien.private alien.c-types fry quotations strings
+stack-checker.backend stack-checker.errors stack-checker.visitor
+stack-checker.dependencies compiler.utilities ;
IN: stack-checker.alien
-TUPLE: alien-node-params return parameters abi in-d out-d ;
+TUPLE: alien-node-params
+return parameters
+{ abi abi initial: cdecl }
+in-d
+out-d ;
-TUPLE: alien-invoke-params < alien-node-params library function ;
+TUPLE: alien-invoke-params < alien-node-params library { function string } ;
TUPLE: alien-indirect-params < alien-node-params ;
-TUPLE: alien-assembly-params < alien-node-params quot ;
+TUPLE: alien-assembly-params < alien-node-params { quot callable } ;
-TUPLE: alien-callback-params < alien-node-params quot xt ;
+TUPLE: alien-callback-params < alien-node-params { quot callable } xt ;
: param-prep-quot ( params -- quot )
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
: callback-bottom ( params -- )
xt>> '[ _ callback-xt ] infer-quot-here ;
+: callback-return-quot ( ctype -- quot )
+ return>> [ [ ] ] [ c-type c-type-unboxer-quot ] if-void ;
+
+: 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 ;
+
: infer-alien-callback ( -- )
alien-callback-params new
pop-quot
pop-params
pop-return
"( callback )" <uninterned-word> >>xt
+ dup wrap-callback-quot >>quot
dup callback-bottom
#alien-callback, ;
system-info dwNumberOfProcessors>> ;
: memory-status ( -- MEMORYSTATUSEX )
- "MEMORYSTATUSEX" <struct>
+ MEMORYSTATUSEX <struct>
dup class heap-size >>dwLength
dup GlobalMemoryStatusEx win32-error=0/f ;
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math sorting words parser io summary
-quotations sequences prettyprint continuations effects
-definitions compiler.units namespaces assocs tools.time generic
-inspector fry locals generalizations macros ;
+quotations sequences sequences.generalizations prettyprint
+continuations effects definitions compiler.units namespaces
+assocs tools.time generic inspector fry locals generalizations
+macros ;
IN: tools.annotations
<PRIVATE
sort-keys <reversed>
[ 0 [ first max ] reduce 3 /f ] keep
[ first < ] with filter
- [ second ] map ;
+ values ;
: complete ( full short -- score )
[ dupd fuzzy score ] 2keep
classes.struct combinators combinators.smart continuations fry
generalizations generic grouping io io.styles kernel make math
math.order math.parser math.statistics memory memory.private
-layouts namespaces parser prettyprint sequences sorting
-splitting strings system vm words hints hashtables ;
+layouts namespaces parser prettyprint sequences
+sequences.generalizations sorting splitting strings system vm
+words hints hashtables ;
IN: tools.memory
<PRIVATE
! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators compiler.units
-continuations debugger effects fry generalizations io io.files
-io.styles kernel lexer locals macros math.parser namespaces
-parser vocabs.parser prettyprint quotations sequences
-source-files splitting stack-checker summary unicode.case
-vectors vocabs vocabs.loader vocabs.files vocabs.metadata words
-tools.errors source-files.errors io.streams.string make
-compiler.errors ;
+continuations debugger effects fry generalizations
+sequences.generalizations io io.files io.styles kernel lexer
+locals macros math.parser namespaces parser vocabs.parser
+prettyprint quotations sequences source-files splitting
+stack-checker summary unicode.case vectors vocabs vocabs.loader
+vocabs.files vocabs.metadata words tools.errors
+source-files.errors io.streams.string make compiler.errors ;
IN: tools.test
TUPLE: test-failure < source-file-error continuation ;
: client-area>RECT ( hwnd -- RECT )
RECT <struct>
[ GetClientRect win32-error=0/f ]
- [ >c-ptr byte-array>POINT-array [ ClientToScreen drop ] with each ]
+ [ >c-ptr POINT-array-cast [ ClientToScreen drop ] with each ]
[ nip ] 2tri ;
: hwnd>RECT ( hwnd -- RECT )
750 milliseconds blink-interval set-global
: stop-blinking ( editor -- )
- [ [ cancel-alarm ] when* f ] change-blink-alarm drop ;
+ [ [ stop-alarm ] when* f ] change-blink-alarm drop ;
: start-blinking ( editor -- )
[ stop-blinking ] [
[ drag-gesture ]
300 milliseconds
100 milliseconds
- add-alarm drag-timer get-global >box
+ <alarm>
+ [ drag-timer get-global >box ]
+ [ start-alarm ] bi
] when ;
: stop-drag-timer ( -- )
hand-buttons get-global empty? [
drag-timer get-global ?box
- [ cancel-alarm ] [ drop ] if
+ [ stop-alarm ] [ drop ] if
] when ;
: fire-motion ( -- )
} cleave
: postprocess-class ( -- )
- combine-map [ [ second ] map ] map concat
+ combine-map [ values ] map concat
[ combining-class not ] filter
[ 0 swap class-map set-at ] each ;
alien.syntax byte-arrays classes.struct combinators
combinators.short-circuit combinators.smart continuations
generalizations io kernel libc locals macros math namespaces
-sequences stack-checker strings system unix.time unix.types
-vocabs vocabs.loader unix.ffi ;
+sequences sequences.generalizations stack-checker strings system
+unix.time unix.types vocabs vocabs.loader unix.ffi ;
IN: unix
ERROR: unix-error errno message ;
] 2map ;
: (make-callbacks) ( implementations -- sequence )
- dup [ first ] map (make-iunknown-methods)
+ dup keys (make-iunknown-methods)
[ [ first2 ] 2dip swap (make-interface-callbacks) ]
curry map-index ;
--- /dev/null
+Niklas Waern
--- /dev/null
+Niklas Waern
--- /dev/null
+! Copyright (C) 2010 Niklas Waern.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math ;
+IN: x11.xinput2.constants
+
+! From XI2.h
+
+CONSTANT: XInput_2_0 7
+
+CONSTANT: XI_2_Major 2
+CONSTANT: XI_2_Minor 0
+
+! Property event flags
+CONSTANT: XIPropertyDeleted 0
+CONSTANT: XIPropertyCreated 1
+CONSTANT: XIPropertyModified 2
+
+! Enter/Leave and Focus In/Out modes
+CONSTANT: XINotifyNormal 0
+CONSTANT: XINotifyGrab 1
+CONSTANT: XINotifyUngrab 2
+CONSTANT: XINotifyWhileGrabbed 3
+CONSTANT: XINotifyPassiveGrab 4
+CONSTANT: XINotifyPassiveUngrab 5
+
+! Enter/Leave and Focus In/Out detail
+CONSTANT: XINotifyAncestor 0
+CONSTANT: XINotifyVirtual 1
+CONSTANT: XINotifyInferior 2
+CONSTANT: XINotifyNonlinear 3
+CONSTANT: XINotifyNonlinearVirtual 4
+CONSTANT: XINotifyPointer 5
+CONSTANT: XINotifyPointerRoot 6
+CONSTANT: XINotifyDetailNone 7
+
+! Passive grab types
+CONSTANT: XIGrabtypeButton 0
+CONSTANT: XIGrabtypeKeycode 1
+CONSTANT: XIGrabtypeEnter 2
+CONSTANT: XIGrabtypeFocusIn 3
+
+! Passive grab modifier
+: XIAnyModifier ( -- n ) 31 2^ ; inline
+: XIAnyButton ( -- n ) 0 ; inline
+: XIAnyKeycode ( -- n ) 0 ; inline
+
+! XIAllowEvents event-modes
+CONSTANT: XIAsyncDevice 0
+CONSTANT: XISyncDevice 1
+CONSTANT: XIReplayDevice 2
+CONSTANT: XIAsyncPairedDevice 3
+CONSTANT: XIAsyncPair 4
+CONSTANT: XISyncPair 5
+
+! DeviceChangedEvent change reasons
+CONSTANT: XISlaveSwitch 1
+CONSTANT: XIDeviceChange 2
+
+! Hierarchy flags
+: XIMasterAdded ( -- n ) 0 2^ ; inline
+: XIMasterRemoved ( -- n ) 1 2^ ; inline
+: XISlaveAdded ( -- n ) 2 2^ ; inline
+: XISlaveRemoved ( -- n ) 3 2^ ; inline
+: XISlaveAttached ( -- n ) 4 2^ ; inline
+: XISlaveDetached ( -- n ) 5 2^ ; inline
+: XIDeviceEnabled ( -- n ) 6 2^ ; inline
+: XIDeviceDisabled ( -- n ) 7 2^ ; inline
+
+! ChangeHierarchy constants
+CONSTANT: XIAddMaster 1
+CONSTANT: XIRemoveMaster 2
+CONSTANT: XIAttachSlave 3
+CONSTANT: XIDetachSlave 4
+
+CONSTANT: XIAttachToMaster 1
+CONSTANT: XIFloating 2
+
+! Valuator modes
+CONSTANT: XIModeRelative 0
+CONSTANT: XIModeAbsolute 1
+
+! Device types
+CONSTANT: XIMasterPointer 1
+CONSTANT: XIMasterKeyboard 2
+CONSTANT: XISlavePointer 3
+CONSTANT: XISlaveKeyboard 4
+CONSTANT: XIFloatingSlave 5
+
+! Device classes
+CONSTANT: XIKeyClass 0
+CONSTANT: XIButtonClass 1
+CONSTANT: XIValuatorClass 2
+
+! Device event flags (common)
+! Device event flags (key events only)
+: XIKeyRepeat ( -- n ) 16 2^ ; inline
+! Device event flags (pointer events only)
+
+! Fake device ID's for event selection
+CONSTANT: XIAllDevices 0
+CONSTANT: XIAllMasterDevices 1
+
+! Event types
+CONSTANT: XI_DeviceChanged 1
+CONSTANT: XI_KeyPress 2
+CONSTANT: XI_KeyRelease 3
+CONSTANT: XI_ButtonPress 4
+CONSTANT: XI_ButtonRelease 5
+CONSTANT: XI_Motion 6
+CONSTANT: XI_Enter 7
+CONSTANT: XI_Leave 8
+CONSTANT: XI_FocusIn 9
+CONSTANT: XI_FocusOut 10
+CONSTANT: XI_HierarchyChanged 11
+CONSTANT: XI_PropertyEvent 12
+CONSTANT: XI_RawKeyPress 13
+CONSTANT: XI_RawKeyRelease 14
+CONSTANT: XI_RawButtonPress 15
+CONSTANT: XI_RawButtonRelease 16
+CONSTANT: XI_RawMotion 17
+: XI_LASTEVENT ( -- n ) XI_RawMotion ; inline
+
+! Event masks
+: XI_DeviceChangedMask ( -- n ) XI_DeviceChanged 2^ ; inline
+: XI_KeyPressMask ( -- n ) XI_KeyPress 2^ ; inline
+: XI_KeyReleaseMask ( -- n ) XI_KeyRelease 2^ ; inline
+: XI_ButtonPressMask ( -- n ) XI_ButtonPress 2^ ; inline
+: XI_ButtonReleaseMask ( -- n ) XI_ButtonRelease 2^ ; inline
+: XI_MotionMask ( -- n ) XI_Motion 2^ ; inline
+: XI_EnterMask ( -- n ) XI_Enter 2^ ; inline
+: XI_LeaveMask ( -- n ) XI_Leave 2^ ; inline
+: XI_FocusInMask ( -- n ) XI_FocusIn 2^ ; inline
+: XI_FocusOutMask ( -- n ) XI_FocusOut 2^ ; inline
+: XI_HierarchyChangedMask ( -- n ) XI_HierarchyChanged 2^ ; inline
+: XI_PropertyEventMask ( -- n ) XI_PropertyEvent 2^ ; inline
+: XI_RawKeyPressMask ( -- n ) XI_RawKeyPress 2^ ; inline
+: XI_RawKeyReleaseMask ( -- n ) XI_RawKeyRelease 2^ ; inline
+: XI_RawButtonPressMask ( -- n ) XI_RawButtonPress 2^ ; inline
+: XI_RawButtonReleaseMask ( -- n ) XI_RawButtonRelease 2^ ; inline
+: XI_RawMotionMask ( -- n ) XI_RawMotion 2^ ; inline
+
--- /dev/null
+Niklas Waern
--- /dev/null
+! Copyright (C) 2010 Niklas Waern.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+classes.struct locals sequences x11.syntax x11.xlib ;
+EXCLUDE: math => float ;
+IN: x11.xinput2.ffi
+
+<< "xinput2" "libXi.so" cdecl add-library >>
+
+LIBRARY: xinput2
+
+
+! *********
+! * XI2.h *
+! *********
+<PRIVATE
+: mask-index ( event -- n ) -3 shift ;
+: bitmask ( event -- n ) 7 bitand 2^ ;
+PRIVATE>
+
+:: XISetMask ( mask event -- )
+ event mask-index :> index
+ event bitmask index mask nth bitor
+ index mask set-nth ; inline
+
+:: XIClearMask ( mask event -- )
+ event mask-index :> index
+ event bitmask bitnot index mask nth bitand
+ index mask set-nth ; inline
+
+:: XIMaskIsSet ( mask event -- n )
+ event mask-index :> index
+ event bitmask index mask nth bitand ;
+
+: XIMaskLen ( event -- n ) 7 + -3 shift ;
+
+
+! *************
+! * XInput2.h *
+! *************
+STRUCT: XIAddMasterInfo
+ { type int }
+ { name c-string }
+ { send_core Bool }
+ { enable Bool } ;
+
+STRUCT: XIRemoveMasterInfo
+ { type int }
+ { deviceid int }
+ { return_mode int }
+ { return_pointer int }
+ { return_keyboard int } ;
+
+STRUCT: XIAttachSlaveInfo
+ { type int }
+ { deviceid int }
+ { new_master int } ;
+
+STRUCT: XIDetachSlaveInfo
+ { type int }
+ { deviceid int } ;
+
+UNION-STRUCT: XIAnyHierarchyChangeInfo
+ { type int }
+ { add XIAddMasterInfo }
+ { remove XIRemoveMasterInfo }
+ { attach XIAttachSlaveInfo }
+ { detach XIDetachSlaveInfo } ;
+
+STRUCT: XIModifierState
+ { base int }
+ { latched int }
+ { locked int }
+ { effective int } ;
+
+TYPEDEF: XIModifierState XIGroupState
+
+STRUCT: XIButtonState
+ { mask_len int }
+ { mask uchar* } ;
+
+STRUCT: XIValuatorState
+ { mask_len int }
+ { mask uchar* }
+ { values double* } ;
+
+STRUCT: XIEventMask
+ { deviceid int }
+ { mask_len int }
+ { mask uchar* } ;
+
+STRUCT: XIAnyClassInfo
+ { type int }
+ { sourceid int } ;
+
+STRUCT: XIButtonClassInfo
+ { type int }
+ { sourceid int }
+ { num_buttons int }
+ { labels Atom* }
+ { state XIButtonState } ;
+
+STRUCT: XIKeyClassInfo
+ { type int }
+ { sourceid int }
+ { num_keycodes int }
+ { keycodes int* } ;
+
+STRUCT: XIValuatorClassInfo
+ { type int }
+ { sourceid int }
+ { number int }
+ { label Atom }
+ { min double }
+ { max double }
+ { value double }
+ { resolution int }
+ { mode int } ;
+
+STRUCT: XIDeviceInfo
+ { deviceid int }
+ { name c-string }
+ { use int }
+ { attachment int }
+ { enabled Bool }
+ { num_classes int }
+ { classes XIAnyClassInfo** } ;
+
+STRUCT: XIGrabModifiers
+ { modifiers int }
+ { status int } ;
+
+
+! Generic XI2 event. All XI2 events have the same header.
+STRUCT: XIEvent
+ { type int }
+ { serial ulong }
+ { send_event Bool }
+ { display Display* }
+ { extension int }
+ { evtype int }
+ { time Time } ;
+
+STRUCT: XIHierarchyInfo
+ { deviceid int }
+ { attachment int }
+ { use int }
+ { enabled Bool }
+ { flags int } ;
+
+! Notifies the client that the device hierarcy has been changed
+! The client is expected to re-query the server for the device
+! hierarchy.
+STRUCT: XIHierarchyEvent
+ { type int }
+ { serial ulong }
+ { send_event Bool }
+ { display Display }
+ { extension int }
+ { evtype int }
+ { time Time }
+ { flags int }
+ { num_info int }
+ { info XIHierarchyInfo* } ;
+
+! Notifies the client that the classes have been changed.
+! This happens when the slave device that sends through the
+! master changes.
+STRUCT: XIDeviceChangedEvent
+ { type int }
+ { serial ulong }
+ { send_event Bool }
+ { display Display* }
+ { extension int }
+ { evtype int }
+ { time Time }
+ { deviceid int }
+ { sourceid int }
+ { reason int }
+ { num_classes int }
+ { classes XIAnyClassInfo** } ;
+
+STRUCT: XIDeviceEvent
+ { type int }
+ { serial ulong }
+ { send_event Bool }
+ { display Display* }
+ { extension int }
+ { evtype int }
+ { time Time }
+ { deviceid int }
+ { sourceid int }
+ { detail int }
+ { root Window }
+ { event Window }
+ { child Window }
+ { root_x double }
+ { root_y double }
+ { event_x double }
+ { event_y double }
+ { flags int }
+ { buttons XIButtonState }
+ { valuators XIValuatorState }
+ { mods XIModifierState }
+ { group XIGroupState } ;
+
+STRUCT: XIRawEvent
+ { type int }
+ { serial ulong }
+ { send_event Bool }
+ { display Display* }
+ { extension int }
+ { evtype int }
+ { time Time }
+ { deviceid int }
+ { sourceid int }
+ { detail int }
+ { flags int }
+ { valuators XIValuatorState }
+ { raw_values double* } ;
+
+STRUCT: XIEnterEvent
+ { type int }
+ { serial ulong }
+ { send_event Bool }
+ { display Display* }
+ { extension int }
+ { evtype int }
+ { time Time }
+ { deviceid int }
+ { sourceid int }
+ { detail int }
+ { root Window }
+ { event Window }
+ { child Window }
+ { root_x double }
+ { root_y double }
+ { event_x double }
+ { event_y double }
+ { mode int }
+ { focus Bool }
+ { same_screen Bool }
+ { buttons XIButtonState }
+ { mods XIModifierState }
+ { group XIGroupState } ;
+
+TYPEDEF: XIEnterEvent XILeaveEvent
+TYPEDEF: XIEnterEvent XIFocusInEvent
+TYPEDEF: XIEnterEvent XIFocusOutEvent
+
+STRUCT: XIPropertyEvent
+ { type int }
+ { serial ulong }
+ { send_event Bool }
+ { display Display* }
+ { extension int }
+ { evtype int }
+ { time Time }
+ { deviceid int }
+ { property Atom }
+ { what int } ;
+
+
+
+X-FUNCTION: Bool XIQueryPointer (
+ Display* display,
+ int deviceid,
+ Window win,
+ Window* root,
+ Window* child,
+ double* root_x,
+ double* root_y,
+ double* win_x,
+ double* win_y,
+ XIButtonState* buttons,
+ XIModifierState* mods,
+ XIGroupState* group ) ;
+
+X-FUNCTION: Bool XIWarpPointer (
+ Display* display,
+ int deviceid,
+ Window src_win,
+ Window dst_win,
+ double src_x,
+ double src_y,
+ uint src_width,
+ uint src_height,
+ double dst_x,
+ double dst_y ) ;
+
+X-FUNCTION: Status XIDefineCursor (
+ Display* display,
+ int deviceid,
+ Window win,
+ Cursor cursor ) ;
+
+X-FUNCTION: Status XIUndefineCursor (
+ Display* display,
+ int deviceid,
+ Window win ) ;
+
+X-FUNCTION: Status XIChangeHierarchy (
+ Display* display,
+ XIAnyHierarchyChangeInfo* changes,
+ int num_changes ) ;
+
+X-FUNCTION: Status XISetClientPointer (
+ Display* dpy,
+ Window win,
+ int deviceid ) ;
+
+X-FUNCTION: Bool XIGetClientPointer (
+ Display* dpy,
+ Window win,
+ int* deviceid ) ;
+
+X-FUNCTION: int XISelectEvents (
+ Display* dpy,
+ Window win,
+ XIEventMask* masks,
+ int num_masks ) ;
+
+X-FUNCTION: XIEventMask* XIGetSelectedEvents (
+ Display* dpy,
+ Window win,
+ int* num_masks_return ) ;
+
+X-FUNCTION: Status XIQueryVersion (
+ Display* display,
+ int* major_version_inout,
+ int* minor_version_inout ) ;
+
+X-FUNCTION: XIDeviceInfo* XIQueryDevice (
+ Display* dpy,
+ int deviceid,
+ int* ndevices_return ) ;
+
+X-FUNCTION: Status XISetFocus (
+ Display* dpy,
+ int deviceid,
+ Window focus,
+ Time time ) ;
+
+X-FUNCTION: Status XIGetFocus (
+ Display* dpy,
+ int deviceid,
+ Window* focus_return ) ;
+
+X-FUNCTION: Status XIGrabDevice (
+ Display* dpy,
+ int deviceid,
+ Window grab_window,
+ Time time,
+ Cursor cursor,
+ int grab_mode,
+ int paired_device_mode,
+ Bool owner_events,
+ XIEventMask* mask ) ;
+
+X-FUNCTION: Status XIUngrabDevice (
+ Display* dpy,
+ int deviceid,
+ Time time ) ;
+
+X-FUNCTION: Status XIAllowEvents (
+ Display* display,
+ int deviceid,
+ int event_mode,
+ Time time ) ;
+
+X-FUNCTION: int XIGrabButton (
+ Display* display,
+ int deviceid,
+ int button,
+ Window grab_window,
+ Cursor cursor,
+ int grab_mode,
+ int paired_device_mode,
+ int owner_events,
+ XIEventMask* mask,
+ int num_modifiers,
+ XIGrabModifiers* modifiers_inout ) ;
+
+X-FUNCTION: int XIGrabKeycode (
+ Display* display,
+ int deviceid,
+ int keycode,
+ Window grab_window,
+ int grab_mode,
+ int paired_device_mode,
+ int owner_events,
+ XIEventMask* mask,
+ int num_modifiers,
+ XIGrabModifiers* modifiers_inout ) ;
+
+X-FUNCTION: int XIGrabEnter (
+ Display* display,
+ int deviceid,
+ Window grab_window,
+ Cursor cursor,
+ int grab_mode,
+ int paired_device_mode,
+ int owner_events,
+ XIEventMask* mask,
+ int num_modifiers,
+ XIGrabModifiers* modifiers_inout ) ;
+
+X-FUNCTION: int XIGrabFocusIn (
+ Display* display,
+ int deviceid,
+ Window grab_window,
+ int grab_mode,
+ int paired_device_mode,
+ int owner_events,
+ XIEventMask* mask,
+ int num_modifiers,
+ XIGrabModifiers* modifiers_inout ) ;
+
+X-FUNCTION: Status XIUngrabButton (
+ Display* display,
+ int deviceid,
+ int button,
+ Window grab_window,
+ int num_modifiers,
+ XIGrabModifiers* modifiers ) ;
+
+X-FUNCTION: Status XIUngrabKeycode (
+ Display* display,
+ int deviceid,
+ int keycode,
+ Window grab_window,
+ int num_modifiers,
+ XIGrabModifiers* modifiers ) ;
+
+X-FUNCTION: Status XIUngrabEnter (
+ Display* display,
+ int deviceid,
+ Window grab_window,
+ int num_modifiers,
+ XIGrabModifiers* modifiers ) ;
+
+X-FUNCTION: Status XIUngrabFocusIn (
+ Display* display,
+ int deviceid,
+ Window grab_window,
+ int num_modifiers,
+ XIGrabModifiers* modifiers ) ;
+
+X-FUNCTION: Atom* XIListProperties (
+ Display* display,
+ int deviceid,
+ int* num_props_return ) ;
+
+X-FUNCTION: void XIChangeProperty (
+ Display* display,
+ int deviceid,
+ Atom property,
+ Atom type,
+ int format,
+ int mode,
+ uchar* data,
+ int num_items ) ;
+
+X-FUNCTION: void XIDeleteProperty (
+ Display* display,
+ int deviceid,
+ Atom property ) ;
+
+X-FUNCTION: Status XIGetProperty (
+ Display* display,
+ int deviceid,
+ Atom property,
+ long offset,
+ long length,
+ Bool delete_property,
+ Atom type,
+ Atom* type_return,
+ int* format_return,
+ ulong* num_items_return,
+ ulong* bytes_after_return,
+ uchar** data ) ;
+
+X-FUNCTION: void XIFreeDeviceInfo ( XIDeviceInfo* info ) ;
+
--- /dev/null
+! Copyright (C) 2010 Niklas Waern.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types combinators kernel namespaces x11
+x11.constants x11.xinput2.ffi ;
+IN: x11.xinput2
+
+: (xi2-available?) ( display -- ? )
+ 2 0 [ <int> ] bi@
+ XIQueryVersion
+ {
+ { BadRequest [ f ] }
+ { Success [ t ] }
+ [ "Internal Xlib error." throw ]
+ } case ;
+
+: xi2-available? ( -- ? ) dpy get (xi2-available?) ; inline
+
CONSTANT: ColormapNotify 32
CONSTANT: ClientMessage 33
CONSTANT: MappingNotify 34
-CONSTANT: LASTEvent 35
+CONSTANT: GenericEvent 35
+CONSTANT: LASTEvent 36
STRUCT: XAnyEvent
{ type int }
{ window Window }
{ pad int[8] } ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Newer things, needed for XInput2 support. Not in the book.
+
+! GenericEvent is the standard event for all newer extensions.
+STRUCT: XGenericEvent
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ extension int }
+{ evtype int } ;
+
+STRUCT: XGenericEventCookie
+{ type int }
+{ serial ulong }
+{ send_event Bool }
+{ display Display* }
+{ extension int }
+{ evtype int }
+{ cookie uint }
+{ data void* } ;
+
+X-FUNCTION: Bool XGetEventData ( Display* dpy, XGenericEventCookie* cookie ) ;
+X-FUNCTION: void XFreeEventData ( Display* dpy, XGenericEventCookie* cookie ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
UNION-STRUCT: XEvent
{ int int }
{ XAnyEvent XAnyEvent }
{ XMappingEvent XMappingEvent }
{ XErrorEvent XErrorEvent }
{ XKeymapEvent XKeymapEvent }
+{ XGenericEvent XGenericEvent }
+{ XGenericEventCookie XGenericEventCookie }
{ padding long[24] } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
uint width,
uint height ) ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Appendix C - Extensions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+X-FUNCTION: Bool XQueryExtension (
+ Display* display,
+ c-string name,
+ int* major_opcode_return,
+ int* first_event_return,
+ int* first_error_return ) ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Appendix D - Compatibility Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit fry generalizations inverse kernel
-namespaces sequences sorting strings unicode.categories
-xml.data xml.syntax xml.syntax.private ;
+namespaces sequences sequences.generalizations sorting strings
+unicode.categories xml.data xml.syntax xml.syntax.private ;
IN: xml.syntax.inverse
: remove-blanks ( seq -- newseq )
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: words assocs kernel accessors parser vocabs.parser effects.parser
-sequences summary lexer splitting combinators locals
-memoize sequences.deep xml.data xml.state xml namespaces present
-arrays generalizations strings make math macros multiline
-combinators.short-circuit sorting fry unicode.categories
-effects ;
+USING: words assocs kernel accessors parser vocabs.parser
+effects.parser sequences summary lexer splitting combinators
+locals memoize sequences.deep xml.data xml.state xml namespaces
+present arrays generalizations sequences.generalizations strings
+make math macros multiline combinators.short-circuit sorting fry
+unicode.categories effects ;
IN: xml.syntax
<PRIVATE
{ <effect> <terminated-effect> <variable-effect> } related-words
ARTICLE: "effects-variables" "Stack effect row variables"
-"The stack of effect of many " { $link POSTPONE: inline } " combinators can have variable stack effects, depending on the effect of the quotation they call. For example, the quotation parameter to " { $link each } " receives an element from the input sequence each time it is called, but it can also manipulate values on the stack below the element as long as it leaves the same number of elements on the stack. (This is how " { $link reduce } " is implemented in terms of " { $snippet "each" } ".) The stack effect of an " { $snippet "each" } " expression thus depends on the stack effect of its input quotation:"
+"The stack effect of many " { $link POSTPONE: inline } " combinators can have variable stack effects, depending on the effect of the quotation they call. For example, the quotation parameter to " { $link each } " receives an element from the input sequence each time it is called, but it can also manipulate values on the stack below the element as long as it leaves the same number of elements on the stack. (This is how " { $link reduce } " is implemented in terms of " { $snippet "each" } ".) The stack effect of an " { $snippet "each" } " expression thus depends on the stack effect of its input quotation:"
{ $example
"""USING: io sequences stack-checker ;
[ [ write ] each ] infer."""
"test.txt" temp-file binary [
3 4 * read
] with-file-reader
- byte-array>int-array
+ int-array-cast
] unit-test
[ ] [
[ t ] [
"test.txt" temp-file binary file-contents
- byte-array>pt-array
+ pt-array-cast
pt-array-1 rest-slice sequence=
] unit-test
! Writing specialized arrays to byte writers
[ int-array{ 1 2 3 } ] [
binary [ int-array{ 1 2 3 } write ] with-byte-writer
- byte-array>int-array
+ int-array-cast
] unit-test
"test.txt" temp-file "rb" fopen <c-reader> [
3 4 * read
] with-input-stream
- byte-array>int-array
+ int-array-cast
] unit-test
! Writing strings to binary streams should fail
[ f ] if
] [ 3drop t ] if-iterate? ; inline recursive
-: each-integer ( n quot -- )
+: each-integer ( ... n quot: ( ... i -- ... ) -- ... )
iterate-prep (each-integer) ; inline
-: times ( n quot -- )
+: times ( ... n quot: ( ... -- ... ) -- ... )
[ drop ] prepose each-integer ; inline
-: find-integer ( n quot -- i )
+: find-integer ( ... n quot: ( ... i -- ... ? ) -- ... i )
iterate-prep (find-integer) ; inline
-: all-integers? ( n quot -- ? )
+: all-integers? ( ... n quot: ( ... i -- ... ? ) -- ... ? )
iterate-prep (all-integers?) ; inline
: find-last-integer ( ... n quot: ( ... i -- ... ? ) -- ... i )
"More information on integers can be found in " { $link "integers" } "." ;
ARTICLE: "syntax-ratios" "Ratio syntax"
-"The printed representation of a ratio is a pair of integers separated by a slash (/), prefixed by an optional whole number part followed by a plus (+). No intermediate whitespace is permitted. Here are some examples:"
+"The printed representation of a ratio is a pair of integers separated by a slash (" { $snippet "/" } "). A ratio can also be written as a proper fraction by following an integer part with " { $snippet "+" } " or " { $snippet "-" } " (matching the sign of the integer) and a ratio. No intermediate whitespace is permitted within a ratio literal. Here are some examples:"
{ $code
"75/33"
"1/10"
"-5/-6"
"1+1/3"
- "-10+1/7"
+ "-10-1/7"
}
-"More information on ratios can be found in " { $link "rationals" } ;
+"More information on ratios can be found in " { $link "rationals" } "." ;
ARTICLE: "syntax-floats" "Float syntax"
"Floating point literals are specified when a literal number contains a decimal point or exponent. Exponents are marked by an " { $snippet "e" } " or " { $snippet "E" } ":"
[ float-array{ 1.0 1.0 3.0 3.0 5.0 5.0 } ]
[
int-array{ 1 3 5 } [ dup ] data-map( int -- float[2] )
- byte-array>float-array
+ float-array-cast
] unit-test
[
}
] [
3 iota [ float-4-with ] data-map( object -- float-4 )
- byte-array>float-4-array
+ float-4-array-cast
] unit-test
[
}
] [
12 iota [ float-4-boa ] data-map( object[4] -- float-4 )
- byte-array>float-4-array
+ float-4-array-cast
] unit-test
[ float-array{ 1.0 1.0 3.0 3.0 5.0 5.0 0.0 0.0 } ]
[ ] data-map( object -- float ) ;
[ float-array{ 0.0 0.5 1.0 } ]
-[ 2 data-map-compiler-bug-test byte-array>float-array ]
+[ 2 data-map-compiler-bug-test float-array-cast ]
unit-test
! (c)2009 Joe Groff bsd license
USING: accessors alien audio classes.struct fry calendar alarms
combinators combinators.short-circuit destructors generalizations
-kernel literals locals math openal sequences specialized-arrays strings ;
+kernel literals locals math openal sequences
+sequences.generalizations specialized-arrays strings ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAYS: c:float c:uchar c:uint ;
IN: audio.engine
dup al-sources>> [
{
[ make-engine-current ]
- [ update-alarm>> [ cancel-alarm ] when* ]
+ [ update-alarm>> [ stop-alarm ] when* ]
[ clips>> clone [ dispose ] each ]
[ al-sources>> free-sources ]
[
] 20 milliseconds every :> alarm
"Press Enter to stop the test." print
readln drop
- alarm cancel-alarm
+ alarm stop-alarm
engine dispose ;
MAIN: audio-engine-test
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit
generalizations kernel locals math.order math.ranges
-sequences.parser sequences sorting.functor sorting.slots
-unicode.categories ;
+sequences.parser sequences sequences.generalizations
+sorting.functor sorting.slots unicode.categories ;
IN: c.lexer
: take-c-comment ( sequence-parser -- seq/f )
! Copyright (C) 2010 Erik Charlebois
! See http:// factorcode.org/license.txt for BSD license.
-USING: accessors alien chipmunk.ffi classes.struct game.worlds kernel
-locals math method-chains opengl.gl random sequences specialized-arrays
-specialized-arrays.instances.alien.c-types.void* ui ui.gadgets.worlds
+USING: accessors alien chipmunk.ffi classes.struct game.loop
+game.worlds kernel literals locals math method-chains opengl.gl
+random sequences specialized-arrays ui ui.gadgets.worlds
ui.pixel-formats ;
+SPECIALIZED-ARRAY: void*
IN: chipmunk.demo
CONSTANT: image-width 188
{ windowed double-buffered }
}
{ pref-dim { 640 480 } }
- { tick-interval-micros 16666 }
+ { tick-interval-nanos $[ 60 fps ] }
}
clone
open-window
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.tuple
-effects.parser fry generalizations generic.standard kernel
-lexer locals macros parser sequences sets slots vocabs words ;
+effects.parser fry generalizations sequences.generalizations
+generic.standard kernel lexer locals macros parser sequences
+sets slots vocabs words ;
IN: constructors
! An experiment
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien.c-types alien.data continuations cuda cuda.ffi
+cuda.libraries fry kernel namespaces ;
+IN: cuda.contexts
+
+: create-context ( device flags -- context )
+ swap
+ [ CUcontext <c-object> ] 2dip
+ [ cuCtxCreate cuda-error ] 3keep 2drop *void* ; inline
+
+: sync-context ( -- )
+ cuCtxSynchronize cuda-error ; inline
+
+: context-device ( -- n )
+ CUdevice <c-object> [ cuCtxGetDevice cuda-error ] keep *int ; inline
+
+: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
+
+: (set-up-cuda-context) ( device flags create-quot -- )
+ H{ } clone cuda-modules set-global
+ H{ } clone cuda-functions set
+ call ; inline
+
+: (with-cuda-context) ( context quot -- )
+ swap '[ [ sync-context ] ignore-errors _ destroy-context ] [ ] cleanup ; inline
+
+: with-cuda-context ( device flags quot -- )
+ [ [ create-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline
+
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.data alien.parser alien.strings
alien.syntax arrays assocs byte-arrays classes.struct
-combinators continuations cuda.ffi cuda.memory cuda.utils
+combinators continuations cuda.ffi
destructors fry init io io.backend io.encodings.string
io.encodings.utf8 kernel lexer locals macros math math.parser
namespaces opengl.gl.extensions parser prettyprint quotations
-sequences words cuda.libraries ;
+sequences words ;
QUALIFIED-WITH: alien.c-types c
IN: cuda
-TUPLE: launcher
-{ device integer initial: 0 }
-{ device-flags initial: 0 } ;
+TUPLE: cuda-error code ;
-: <launcher> ( device-id -- launcher )
- launcher new
- swap >>device ; inline
+: cuda-error ( code -- )
+ dup CUDA_SUCCESS = [ drop ] [ \ cuda-error boa throw ] if ;
-TUPLE: function-launcher
-dim-grid dim-block shared-size stream ;
+: cuda-version ( -- n )
+ c:int <c-object> [ cuDriverGetVersion cuda-error ] keep c:*int ;
-: with-cuda-context ( flags device quot -- )
- H{ } clone cuda-modules set-global
- H{ } clone cuda-functions set
- [ create-context ] dip
- [ '[ _ @ ] ]
- [ drop '[ _ destroy-context ] ] 2bi
- [ ] cleanup ; inline
+: init-cuda ( -- )
+ 0 cuInit cuda-error ; inline
-: with-cuda-program ( flags device quot -- )
- [ dup cuda-device set ] 2dip
- '[ cuda-context set _ call ] with-cuda-context ; inline
-
-: with-cuda ( launcher quot -- )
- init-cuda [
- [ cuda-launcher set ]
- [ [ device>> ] [ device-flags>> ] bi ] bi
- ] [ with-cuda-program ] bi* ; inline
-
-: c-type>cuda-setter ( c-type -- n cuda-type )
- {
- { [ dup c:int = ] [ drop 4 [ cuda-int* ] ] }
- { [ dup c:uint = ] [ drop 4 [ cuda-int* ] ] }
- { [ dup c:float = ] [ drop 4 [ cuda-float* ] ] }
- { [ dup c:pointer? ] [ drop 4 [ cuda-int* ] ] }
- { [ dup c:void* = ] [ drop 4 [ cuda-int* ] ] }
- } cond ;
-
-<PRIVATE
-: block-dim ( block -- x y z )
- dup sequence? [ 3 1 pad-tail first3 ] [ 1 1 ] if ; inline
-: grid-dim ( block -- x y )
- dup sequence? [ 2 1 pad-tail first2 ] [ 1 ] if ; inline
-PRIVATE>
-
-: run-function-launcher ( function-launcher function -- )
- swap
- {
- [ dim-block>> block-dim function-block-shape* ]
- [ shared-size>> function-shared-size* ]
- [
- dim-grid>>
- [ grid-dim launch-function-grid* ]
- [ launch-function* ] if*
- ]
- } 2cleave ;
-
-: cuda-argument-setter ( offset c-type -- offset' quot )
- c-type>cuda-setter
- [ over [ + ] dip ] dip
- '[ swap _ swap _ call ] ;
-
-MACRO: cuda-arguments ( c-types -- quot: ( args... function -- ) )
- [ 0 ] dip [ cuda-argument-setter ] map reverse
- swap '[ _ param-size* ] suffix
- '[ _ cleave ] ;
-
-: define-cuda-word ( word module-name function-name arguments -- )
- [
- '[
- _ _ cached-function
- [ nip _ cuda-arguments ]
- [ run-function-launcher ] 2bi
- ]
- ]
- [ 2nip \ function-launcher suffix c:void function-effect ]
- 3bi define-declared ;
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.strings cuda cuda.devices
-cuda.memory cuda.syntax cuda.utils destructors io
-io.encodings.string io.encodings.utf8 kernel locals math
-math.parser namespaces sequences byte-arrays strings ;
+USING: accessors alien.c-types alien.strings byte-arrays cuda
+cuda.contexts cuda.devices cuda.libraries cuda.memory cuda.syntax
+destructors io io.encodings.string io.encodings.utf8 kernel locals
+math math.parser namespaces sequences strings ;
IN: cuda.demos.hello-world
-CUDA-LIBRARY: hello vocab:cuda/demos/hello-world/hello.ptx
+CUDA-LIBRARY: hello cuda32 vocab:cuda/demos/hello-world/hello.ptx
CUDA-FUNCTION: helloWorld ( char* string-ptr ) ;
: cuda-hello-world ( -- )
+ init-cuda
[
[
- cuda-launcher get device>> number>string
+ context-device number>string
"CUDA device " ": " surround write
"Hello World!" >byte-array [ - ] map-index host>device &cuda-free
- [ { 2 1 } { 6 1 1 } 2<<< helloWorld ]
+ [ { 2 1 } { 6 1 1 } <grid> helloWorld ]
[ 12 device>host >string print ] bi
] with-destructors
] with-each-cuda-device ;
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types cuda cuda.syntax locals ;
+USING: alien.c-types cuda cuda.contexts cuda.libraries cuda.syntax locals ;
IN: cuda.demos.prefix-sum
-CUDA-LIBRARY: prefix-sum vocab:cuda/demos/prefix-sum/prefix-sum.ptx
+CUDA-LIBRARY: prefix-sum cuda32 vocab:cuda/demos/prefix-sum/prefix-sum.ptx
CUDA-FUNCTION: prefix_sum_block ( uint* in, uint* out, uint n ) ;
:: cuda-prefix-sum ( -- )
- T{ launcher { device 0 } }
- [
- ! { 1 1 1 } { 2 1 } 0 3<<< prefix_sum_block
- ] with-cuda ;
+ init-cuda
+ 0 0 [
+ ! { 1 1 1 } { 2 1 } 0 <grid-shared> prefix_sum_block
+ ] with-cuda-context ;
MAIN: cuda-prefix-sum
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data alien.strings arrays
-assocs byte-arrays classes.struct combinators cuda cuda.ffi
-cuda.syntax cuda.utils fry io io.encodings.utf8 kernel locals
-math math.order math.parser namespaces prettyprint sequences ;
+assocs byte-arrays classes.struct combinators cuda
+cuda.contexts cuda.ffi cuda.libraries fry io io.encodings.utf8
+kernel locals math math.order math.parser namespaces
+prettyprint sequences ;
IN: cuda.devices
: #cuda-devices ( -- n )
#cuda-devices iota [ n>cuda-device ] map ;
: with-each-cuda-device ( quot -- )
- [ enumerate-cuda-devices ] dip '[ <launcher> _ with-cuda ] each ; inline
+ [ enumerate-cuda-devices ] dip '[ 0 _ with-cuda-context ] each ; inline
: cuda-device-properties ( n -- properties )
[ CUdevprop <struct> ] dip
: up/i ( x y -- z )
[ 1 - + ] keep /i ; inline
+: context-device-properties ( -- props )
+ context-device cuda-device-properties ; inline
+
:: (distribute-jobs) ( job-count per-job-shared max-shared-size max-block-size
-- grid-size block-size per-block-shared )
per-job-shared [ max-block-size ] [ max-shared-size swap /i max-block-size min ] if-zero
grid-size block-size per-block-shared ; inline
: distribute-jobs ( job-count per-job-shared -- launcher )
- cuda-device get cuda-device-properties
- [ sharedMemPerBlock>> ] [ maxThreadsDim>> first ] bi
- (distribute-jobs) 3<<< ; inline
+ context-device-properties
+ [ sharedMemPerBlock>> ] [ maxThreadsPerBlock>> ] bi
+ (distribute-jobs) <grid-shared> ; inline
SYMBOLS: CUdouble CUlonglong CUulonglong ;
-: >cuda-param-type ( c-type -- c-type' )
- {
- { CUdeviceptr [ void* ] }
- { double [ CUdouble ] }
- { longlong [ CUlonglong ] }
- { ulonglong [ CUulonglong ] }
- [ ]
- } case ;
-
<<
: always-8-byte-align ( c-type -- c-type )
8 >>align 8 >>align-first ;
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien.c-types alien.syntax cuda.ffi opengl.gl ;
+IN: cuda.gl.ffi
+
+LIBRARY: cuda
+
+FUNCTION: CUresult cuGLCtxCreate ( CUcontext* pCtx, uint Flags, CUdevice device ) ;
+FUNCTION: CUresult cuGraphicsGLRegisterBuffer ( CUgraphicsResource* pCudaResource, GLuint buffer, uint Flags ) ;
+FUNCTION: CUresult cuGraphicsGLRegisterImage ( CUgraphicsResource* pCudaResource, GLuint image, GLenum target, uint Flags ) ;
+
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors alien.c-types alien.data alien.destructors
+alien.enums continuations cuda cuda.contexts cuda.ffi
+cuda.gl.ffi destructors fry gpu.buffers kernel ;
+IN: cuda.gl
+
+: create-gl-cuda-context ( device flags -- context )
+ swap
+ [ CUcontext <c-object> ] 2dip
+ [ cuGLCtxCreate cuda-error ] 3keep 2drop *void* ; inline
+
+: with-gl-cuda-context ( device flags quot -- )
+ [ [ create-gl-cuda-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline
+
+: gl-buffer>resource ( gl-buffer flags -- resource )
+ enum>number
+ [ CUgraphicsResource <c-object> ] 2dip
+ [ cuGraphicsGLRegisterBuffer cuda-error ] 3keep 2drop *void* ; inline
+
+: buffer>resource ( buffer flags -- resource )
+ [ handle>> ] dip gl-buffer>resource ; inline
+
+: map-resource ( resource -- device-ptr size )
+ [ 1 swap <void*> f cuGraphicsMapResources cuda-error ] [
+ [ CUdeviceptr <c-object> uint <c-object> ] dip
+ [ cuGraphicsResourceGetMappedPointer cuda-error ] 3keep drop
+ [ *uint ] [ *uint ] bi*
+ ] bi ; inline
+
+: unmap-resource ( resource -- )
+ 1 swap <void*> f cuGraphicsUnmapResources cuda-error ; inline
+
+DESTRUCTOR: unmap-resource
+
+: free-resource ( resource -- )
+ cuGraphicsUnregisterResource cuda-error ; inline
+
+DESTRUCTOR: free-resource
+
+: with-mapped-resource ( ..a resource quot: ( ..a device-ptr size -- ..b ) -- ..b )
+ over [ map-resource ] 2dip '[ _ unmap-resource ] [ ] cleanup ; inline
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.data arrays assocs
-cuda.ffi cuda.utils io.backend kernel namespaces sequences ;
+USING: accessors alien.data alien.parser arrays assocs
+byte-arrays classes.struct combinators combinators.short-circuit
+cuda cuda.ffi fry generalizations io.backend kernel macros math
+namespaces sequences variants words ;
+FROM: classes.struct.private => compute-struct-offsets write-struct-slot ;
+QUALIFIED-WITH: alien.c-types c
IN: cuda.libraries
+VARIANT: cuda-abi
+ cuda32 cuda64 ;
+
+SYMBOL: cuda-modules
+SYMBOL: cuda-functions
+
SYMBOL: cuda-libraries
cuda-libraries [ H{ } clone ] initialize
SYMBOL: current-cuda-library
-TUPLE: cuda-library name path handle ;
+: ?delete-at ( key assoc -- old/key ? )
+ 2dup delete-at* [ 2nip t ] [ 2drop f ] if ; inline
-: <cuda-library> ( name path -- obj )
- \ cuda-library new
- swap >>path
- swap >>name ;
+: cuda-param-size ( function n -- )
+ cuParamSetSize cuda-error ; inline
-: add-cuda-library ( name path -- )
- normalize-path <cuda-library>
- dup name>> cuda-libraries get-global set-at ;
+: cuda-vector ( function offset ptr n -- )
+ cuParamSetv cuda-error ; inline
-: ?delete-at ( key assoc -- old/key ? )
- 2dup delete-at* [ 2nip t ] [ 2drop f ] if ; inline
+: launch-function-grid ( function width height -- )
+ cuLaunchGrid cuda-error ; inline
-ERROR: no-cuda-library name ;
+: function-block-shape ( function x y z -- )
+ cuFuncSetBlockShape cuda-error ; inline
+
+: function-shared-size ( function n -- )
+ cuFuncSetSharedSize cuda-error ; inline
+
+TUPLE: grid
+ { dim-grid read-only }
+ { dim-block read-only }
+ { shared-size read-only initial: 0 }
+ { stream read-only } ;
+
+: <grid> ( dim-grid dim-block -- grid )
+ 0 f grid boa ; inline
+
+: <grid-shared> ( dim-grid dim-block shared-size -- grid )
+ f grid boa ; inline
+
+: <grid-shared-stream> ( dim-grid dim-block shared-size stream -- grid )
+ grid boa ; inline
+
+<PRIVATE
+GENERIC: block-dim ( block-size -- x y z ) foldable
+M: integer block-dim 1 1 ; inline
+M: sequence block-dim
+ dup length {
+ { 0 [ drop 1 1 1 ] }
+ { 1 [ first 1 1 ] }
+ { 2 [ first2 1 ] }
+ [ drop first3 ]
+ } case ; inline
+
+GENERIC: grid-dim ( grid-size -- x y ) foldable
+M: integer grid-dim 1 ; inline
+M: sequence grid-dim
+ dup length {
+ { 0 [ drop 1 1 ] }
+ { 1 [ first 1 ] }
+ [ drop first2 ]
+ } case ; inline
+PRIVATE>
: load-module ( path -- module )
[ CUmodule <c-object> ] dip
- [ cuModuleLoad cuda-error ] 2keep drop *void* ;
+ [ cuModuleLoad cuda-error ] 2keep drop c:*void* ;
: unload-module ( module -- )
cuModuleUnload cuda-error ;
: load-cuda-library ( library -- handle )
path>> load-module ;
+ERROR: no-cuda-library name ;
+
: lookup-cuda-library ( name -- cuda-library )
cuda-libraries get ?at [ no-cuda-library ] unless ;
: unload-cuda-library ( name -- )
remove-cuda-library handle>> unload-module ;
+: launch-function ( function -- ) cuLaunch cuda-error ; inline
+
+: run-grid ( grid function -- )
+ swap
+ {
+ [ dim-block>> block-dim function-block-shape ]
+ [ shared-size>> function-shared-size ]
+ [
+ dim-grid>>
+ [ grid-dim launch-function-grid ]
+ [ launch-function ] if*
+ ]
+ } 2cleave ; inline
+
+<PRIVATE
+: make-param-buffer ( function size -- buffer size )
+ [ cuda-param-size ] [ (byte-array) ] [ ] tri ; inline
+
+: fill-param-buffer ( values... buffer quots... n -- )
+ [ cleave-curry ] [ spread* ] bi ; inline
+
+: pointer-argument-type? ( c-type -- ? )
+ { [ c:void* = ] [ CUdeviceptr = ] [ c:pointer? ] } 1|| ;
+
+: abi-pointer-type ( abi -- type )
+ {
+ { cuda32 [ c:uint ] }
+ { cuda64 [ CUulonglong ] }
+ } case ;
+
+: >argument-type ( c-type abi -- c-type' )
+ swap {
+ { [ dup pointer-argument-type? ] [ drop abi-pointer-type ] }
+ { [ dup c:double = ] [ 2drop CUdouble ] }
+ { [ dup c:longlong = ] [ 2drop CUlonglong ] }
+ { [ dup c:ulonglong = ] [ 2drop CUulonglong ] }
+ [ nip ]
+ } cond ;
+
+: >argument-struct-slot ( c-type abi -- slot )
+ >argument-type "cuda-arg" swap { } <struct-slot-spec> ;
+
+: [cuda-arguments] ( c-types abi -- quot )
+ '[ _ >argument-struct-slot ] map
+ [ compute-struct-offsets ]
+ [ [ '[ _ write-struct-slot ] ] [ ] map-as ]
+ [ length ] tri
+ '[
+ [ _ make-param-buffer [ drop @ _ fill-param-buffer ] 2keep ]
+ [ '[ _ 0 ] 2dip cuda-vector ] bi
+ ] ;
+PRIVATE>
+
+MACRO: cuda-arguments ( c-types abi -- quot: ( args... function -- ) )
+ [ [ 0 cuda-param-size ] ] swap '[ _ [cuda-arguments] ] if-empty ;
+
+: get-function-ptr ( module string -- function )
+ [ CUfunction <c-object> ] 2dip
+ [ cuModuleGetFunction cuda-error ] 3keep 2drop c:*void* ;
+
: cached-module ( module-name -- alien )
lookup-cuda-library
cuda-modules get-global [ load-cuda-library ] cache ;
: cached-function ( module-name function-name -- alien )
[ cached-module ] dip
- 2array cuda-functions get [ first2 get-function-ptr* ] cache ;
+ 2array cuda-functions get [ first2 get-function-ptr ] cache ;
+
+MACRO: cuda-invoke ( module-name function-name arguments -- )
+ pick lookup-cuda-library abi>> '[
+ _ _ cached-function
+ [ nip _ _ cuda-arguments ]
+ [ run-grid ] 2bi
+ ] ;
+
+: cuda-global* ( module-name symbol-name -- device-ptr size )
+ [ CUdeviceptr <c-object> c:uint <c-object> ] 2dip
+ [ cached-module ] dip
+ '[ _ _ cuModuleGetGlobal cuda-error ] 2keep [ c:*uint ] bi@ ; inline
+
+: cuda-global ( module-name symbol-name -- device-ptr )
+ cuda-global* drop ; inline
+
+: define-cuda-function ( word module-name function-name arguments -- )
+ [ '[ _ _ _ cuda-invoke ] ]
+ [ 2nip \ grid suffix c:void function-effect ]
+ 3bi define-inline ;
+
+: define-cuda-global ( word module-name symbol-name -- )
+ '[ _ _ cuda-global ] (( -- device-ptr )) define-inline ;
+
+TUPLE: cuda-library name abi path handle ;
+ERROR: bad-cuda-abi abi ;
+
+: check-cuda-abi ( abi -- abi )
+ dup cuda-abi? [ bad-cuda-abi ] unless ; inline
+
+: <cuda-library> ( name abi path -- obj )
+ \ cuda-library new
+ swap >>path
+ swap check-cuda-abi >>abi
+ swap >>name ; inline
+
+: add-cuda-library ( name abi path -- )
+ normalize-path <cuda-library>
+ dup name>> cuda-libraries get-global set-at ;
+
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.data alien.destructors assocs
-byte-arrays cuda.ffi cuda.utils destructors fry io.encodings.string
-io.encodings.utf8 kernel locals math namespaces sequences strings ;
+byte-arrays cuda cuda.ffi destructors fry io.encodings.string
+io.encodings.utf8 kernel locals math namespaces sequences
+strings ;
QUALIFIED-WITH: alien.c-types c
IN: cuda.memory
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.parser cuda cuda.libraries cuda.utils io.backend
-kernel lexer namespaces parser ;
+USING: alien.parser cuda cuda.libraries io.backend
+fry kernel lexer namespaces parser ;
IN: cuda.syntax
SYNTAX: CUDA-LIBRARY:
- scan scan normalize-path
- [ add-cuda-library ]
- [ drop current-cuda-library set-global ] 2bi ;
+ scan scan-word scan
+ '[ _ _ add-cuda-library ]
+ [ current-cuda-library set-global ] bi ;
SYNTAX: CUDA-FUNCTION:
- scan [ create-in current-cuda-library get ] [ ] bi
- ";" scan-c-args drop define-cuda-word ;
+ scan [ create-in current-cuda-library get ] keep
+ ";" scan-c-args drop define-cuda-function ;
-: 2<<< ( dim-grid dim-block -- function-launcher )
- 0 f function-launcher boa ; inline
-
-: 3<<< ( dim-grid dim-block shared-size -- function-launcher )
- f function-launcher boa ; inline
-
-: 4<<< ( dim-grid dim-block shared-size stream -- function-launcher )
- function-launcher boa ; inline
+SYNTAX: CUDA-GLOBAL:
+ scan [ create-in current-cuda-library get ] keep
+ define-cuda-global ;
+++ /dev/null
-! Copyright (C) 2010 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.data alien.strings arrays
-assocs byte-arrays classes.struct combinators cuda.ffi
-io io.backend io.encodings.utf8 kernel math.parser namespaces
-prettyprint sequences ;
-IN: cuda.utils
-
-SYMBOL: cuda-device
-SYMBOL: cuda-context
-SYMBOL: cuda-module
-SYMBOL: cuda-function
-SYMBOL: cuda-launcher
-
-SYMBOL: cuda-modules
-SYMBOL: cuda-functions
-
-ERROR: throw-cuda-error n ;
-
-: cuda-error ( n -- )
- dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error ] if ;
-
-: init-cuda ( -- )
- 0 cuInit cuda-error ; inline
-
-: cuda-version ( -- n )
- int <c-object> [ cuDriverGetVersion cuda-error ] keep *int ;
-
-: get-function-ptr* ( module string -- function )
- [ CUfunction <c-object> ] 2dip
- [ cuModuleGetFunction cuda-error ] 3keep 2drop *void* ;
-
-: get-function-ptr ( string -- function )
- [ cuda-module get ] dip get-function-ptr* ;
-
-: with-cuda-function ( string quot -- )
- [
- get-function-ptr* cuda-function set
- ] dip call ; inline
-
-: create-context ( flags device -- context )
- [ CUcontext <c-object> ] 2dip
- [ cuCtxCreate cuda-error ] 3keep 2drop *void* ; inline
-
-: sync-context ( -- )
- cuCtxSynchronize cuda-error ; inline
-
-: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
-
-: launch-function* ( function -- ) cuLaunch cuda-error ; inline
-
-: launch-function ( -- ) cuda-function get cuLaunch cuda-error ; inline
-
-: cuda-int* ( function offset value -- )
- cuParamSeti cuda-error ; inline
-
-: cuda-int ( offset value -- )
- [ cuda-function get ] 2dip cuda-int* ; inline
-
-: cuda-float* ( function offset value -- )
- cuParamSetf cuda-error ; inline
-
-: cuda-float ( offset value -- )
- [ cuda-function get ] 2dip cuda-float* ; inline
-
-: cuda-vector* ( function offset ptr n -- )
- cuParamSetv cuda-error ; inline
-
-: cuda-vector ( offset ptr n -- )
- [ cuda-function get ] 3dip cuda-vector* ; inline
-
-: param-size* ( function n -- )
- cuParamSetSize cuda-error ; inline
-
-: param-size ( n -- )
- [ cuda-function get ] dip param-size* ; inline
-
-: launch-function-grid* ( function width height -- )
- cuLaunchGrid cuda-error ; inline
-
-: launch-function-grid ( width height -- )
- [ cuda-function get ] 2dip
- cuLaunchGrid cuda-error ; inline
-
-: function-block-shape* ( function x y z -- )
- cuFuncSetBlockShape cuda-error ; inline
-
-: function-block-shape ( x y z -- )
- [ cuda-function get ] 3dip
- cuFuncSetBlockShape cuda-error ; inline
-
-: function-shared-size* ( function n -- )
- cuFuncSetSharedSize cuda-error ; inline
-
-: function-shared-size ( n -- )
- [ cuda-function get ] dip
- cuFuncSetSharedSize cuda-error ; inline
+++ /dev/null
-USING: accessors sequences generalizations io.encodings.utf8 db.postgresql parser combinators vocabs.parser db.sqlite
-io.files ;
-IN: db.info
-! having sensative (and likely to change) information directly in source code seems a bad idea
-: get-info ( -- lines ) current-vocab name>> "vocab:" "/dbinfo.txt" surround utf8 file-lines ;
-SYNTAX: get-psql-info <postgresql-db> get-info 5 firstn
- {
- [ >>host ]
- [ >>port ]
- [ >>username ]
- [ [ f ] [ ] if-empty >>password ]
- [ >>database ]
- } spread suffix! ;
-
-SYNTAX: get-sqlite-info get-info first <sqlite-db> suffix! ;
USING: kernel fry sequences vocabs.loader help.vocabs ui
ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.borders
-ui.gadgets.scrollers ui.tools.listener accessors ;
+ui.gadgets.scrollers ui.tools.listener accessors assocs ;
IN: demos
-: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
+: demo-vocabs ( -- seq ) "demos" tagged values concat [ name>> ] map ;
: <run-vocab-button> ( vocab-name -- button )
dup '[ drop [ _ run ] \ run call-listener ] <border-button> ;
! Copyright (c) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: words kernel sequences locals locals.parser fry
-locals.definitions accessors parser namespaces continuations
-summary definitions generalizations arrays prettyprint debugger io
-effects tools.annotations effects.parser ;
+USING: words kernel sequences sequences.generalizations locals
+locals.parser fry locals.definitions accessors parser namespaces
+continuations summary definitions generalizations arrays
+prettyprint debugger io effects tools.annotations effects.parser ;
IN: descriptive
ERROR: descriptive-error args underlying word ;
:: ecdsa-sign ( DGST -- sig )
ec-key-handle :> KEY
KEY ECDSA_size dup ssl-error <byte-array> :> SIG
- "uint" <c-object> :> LEN
+ 0 <uint> :> LEN
0 DGST dup length SIG LEN KEY ECDSA_sign ssl-error
LEN *uint SIG resize ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings alien.syntax arrays
classes.struct fry io.encodings.ascii io.mmap kernel locals math
-math.intervals sequences specialized-arrays strings typed ;
+math.intervals sequences specialized-arrays strings typed assocs ;
IN: elf
! FFI data
segment [ p_offset>> dup ] [ p_filesz>> + ] bi [a,b) :> segment-interval
sections [ dup [ sh_offset>> dup ] [ sh_size>> + ] bi [a,b) 2array ] { } map-as :> section-intervals
section-intervals [ second segment-interval interval-intersect empty-interval = not ]
- filter [ first ] map ;
+ filter keys ;
TYPED:: virtual-address-segment ( elf: Elf32/64_Ehdr address -- program-header/f )
elf elf-program-headers elf-loadable-segments [
SYMBOL: fluid
: integrate ( world -- )
- particles>> $[ 60 fps 1000000 /f ] integrate-particles! drop ;
+ particles>> 1/60 integrate-particles! drop ;
: pause ( -- )
fluid get [ not ] change-paused drop ;
{ pixel-format-attributes {
windowed double-buffered T{ depth-bits { value 24 } } } }
{ pref-dim { 1024 768 } }
- { tick-interval-micros $[ 60 fps ] }
+ { tick-interval-nanos $[ 60 fps ] }
} ;
fluids-world H{
{ grab-input? t }
{ use-game-input? t }
{ pref-dim { 1024 768 } }
- { tick-interval-micros $[ 60 fps ] }
+ { tick-interval-nanos $[ 60 fps ] }
} ;
MAIN: run-tests
IN: game.loop
HELP: fps
-{ $values { "fps" real } { "micros" integer } }
-{ $description "Converts a frames per second value into an interval length in microseconds." } ;
+{ $values { "fps" real } { "nanos" integer } }
+{ $description "Converts a frames per second value into an interval length in nanoseconds." } ;
HELP: <game-loop>
{ $values
- { "tick-interval-micros" integer } { "delegate" "a " { $link "game.loop-delegates" } }
+ { "tick-interval-nanos" integer } { "delegate" "a " { $link "game.loop-delegates" } }
{ "loop" game-loop }
}
-{ $description "Constructs a new stopped " { $link game-loop } " object. When started, the game loop will call the " { $link tick* } " method on the " { $snippet "delegate" } " every " { $snippet "tick-interval-micros" } " microseconds, and " { $link draw* } " on the same delegate object as frequently as possible. The " { $link start-loop } " and " { $link stop-loop } " words start and stop the game loop."
+{ $description "Constructs a new stopped " { $link game-loop } " object. When started, the game loop will call the " { $link tick* } " method on the " { $snippet "delegate" } " every " { $snippet "tick-interval-nanos" } " nanoseconds, and " { $link draw* } " on the same delegate object as frequently as possible. The " { $link start-loop } " and " { $link stop-loop } " words start and stop the game loop."
$nl
"To initialize the game loop with separate tick and draw delegates, use " { $link <game-loop*> } "." } ;
HELP: <game-loop*>
{ $values
- { "tick-interval-micros" integer } { "tick-delegate" "a " { $link "game.loop-delegates" } } { "draw-delegate" "a " { $link "game.loop-delegates" } }
+ { "tick-interval-nanos" integer } { "tick-delegate" "a " { $link "game.loop-delegates" } } { "draw-delegate" "a " { $link "game.loop-delegates" } }
{ "loop" game-loop }
}
-{ $description "Constructs a new stopped " { $link game-loop } " object. When started, the game loop will call the " { $link tick* } " method on the " { $snippet "tick-delegate" } " every " { $snippet "tick-interval-micros" } " microseconds, and " { $link draw* } " on the " { $snippet "draw-delegate" } " as frequently as possible. The " { $link start-loop } " and " { $link stop-loop } " words start and stop the game loop."
+{ $description "Constructs a new stopped " { $link game-loop } " object. When started, the game loop will call the " { $link tick* } " method on the " { $snippet "tick-delegate" } " every " { $snippet "tick-interval-nanos" } " nanoseconds, and " { $link draw* } " on the " { $snippet "draw-delegate" } " as frequently as possible. The " { $link start-loop } " and " { $link stop-loop } " words start and stop the game loop."
$nl
"The " { $link <game-loop> } " word provides a shorthand for initializing a game loop that uses the same object for the " { $snippet "tick-delegate" } " and " { $snippet "draw-delegate" } "." } ;
{ $values
{ "tick-slice" float } { "delegate" "a " { $link "game.loop-delegates" } }
}
-{ $description "This generic word is called by a " { $link game-loop } " on its " { $snippet "draw-delegate" } " object in a tight loop while the game loop is running. The " { $snippet "tick-slice" } " value represents what fraction of the game loop's " { $snippet "tick-interval-micros" } " time period has passed since " { $link tick* } " was most recently called on the " { $snippet "tick-delegate" } "." } ;
+{ $description "This generic word is called by a " { $link game-loop } " on its " { $snippet "draw-delegate" } " object in a tight loop while the game loop is running. The " { $snippet "tick-slice" } " value represents what fraction of the game loop's " { $snippet "tick-interval-nanos" } " time period has passed since " { $link tick* } " was most recently called on the " { $snippet "tick-delegate" } "." } ;
HELP: game-loop
{ $class-description "Objects of the " { $snippet "game-loop" } " class manage game loops. See " { $link "game.loop" } " for an overview of the game loop library. To construct a game loop, use " { $link <game-loop> } ". To start and stop a game loop, use the " { $link start-loop } " and " { $link stop-loop } " words."
{ $values
{ "delegate" "a " { $link "game.loop-delegates" } }
}
-{ $description "This generic word is called by a " { $link game-loop } " on its " { $snippet "tick-delegate" } " object at regular intervals while the game loop is running. The game loop's " { $snippet "tick-interval-micros" } " attribute determines the number of microseconds between invocations of " { $snippet "tick*" } "." } ;
+{ $description "This generic word is called by a " { $link game-loop } " on its " { $snippet "tick-delegate" } " object at regular intervals while the game loop is running. The game loop's " { $snippet "tick-interval-nanos" } " attribute determines the number of nanoseconds between invocations of " { $snippet "tick*" } "." } ;
{ draw* tick* } related-words
tick*
draw*
}
-{ $snippet "tick*" } " will be called at a regular interval determined by the game loop's " { $snippet "tick-interval-micros" } " attribute on the tick delegate. " { $snippet "draw*" } " will be invoked on the draw delegate in a tight loop, updating as frequently as possible."
+{ $snippet "tick*" } " will be called at a regular interval determined by the game loop's " { $snippet "tick-interval-nanos" } " attribute on the tick delegate. " { $snippet "draw*" } " will be invoked on the draw delegate in a tight loop, updating as frequently as possible."
$nl
"It is possible to change the " { $snippet "tick-delegate" } " and " { $snippet "draw-delegate" } " slots of a game loop while it is running, for example, to use different delegates to control a game while it's in the menu, paused, or running the main game." ;
! (c)2009 Joe Groff bsd license
-USING: accessors calendar continuations destructors kernel math
-math.order namespaces system threads ui ui.gadgets.worlds
-sequences ;
+USING: accessors alarms calendar continuations destructors fry
+kernel math math.order namespaces system ui ui.gadgets.worlds ;
IN: game.loop
TUPLE: game-loop
- { tick-interval-micros integer read-only }
+ { tick-interval-nanos integer read-only }
tick-delegate
draw-delegate
{ last-tick integer }
- thread
{ running? boolean }
{ tick-number integer }
{ frame-number integer }
{ benchmark-time integer }
{ benchmark-tick-number integer }
- { benchmark-frame-number integer } ;
+ { benchmark-frame-number integer }
+ alarm ;
GENERIC: tick* ( delegate -- )
GENERIC: draw* ( tick-slice delegate -- )
SYMBOL: game-loop
-: since-last-tick ( loop -- microseconds )
- last-tick>> system-micros swap - ;
+: since-last-tick ( loop -- nanos )
+ last-tick>> nano-count swap - ;
: tick-slice ( loop -- slice )
- [ since-last-tick ] [ tick-interval-micros>> ] bi /f 1.0 min ;
+ [ since-last-tick ] [ tick-interval-nanos>> ] bi /f 1.0 min ;
CONSTANT: MAX-FRAMES-TO-SKIP 5
: game-loop-error ( game-loop error -- )
[ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
-: fps ( fps -- micros )
- 1,000,000 swap /i ; inline
+: fps ( fps -- nanos )
+ 1,000,000,000 swap /i ; inline
<PRIVATE
: increment-tick ( loop -- )
[ 1 + ] change-tick-number
- dup tick-interval-micros>> [ + ] curry change-last-tick
+ dup tick-interval-nanos>> [ + ] curry change-last-tick
drop ;
: ?tick ( loop count -- )
- [ system-micros >>last-tick drop ] [
- over [ since-last-tick ] [ tick-interval-micros>> ] bi >=
+ [ nano-count >>last-tick drop ] [
+ over [ since-last-tick ] [ tick-interval-nanos>> ] bi >=
[ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
[ 2drop ] if
] if-zero ;
-: (run-loop) ( loop -- )
- dup running?>>
- [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
- [ drop ] if ;
-
-: run-loop ( loop -- )
- dup game-loop
- [ [ (run-loop) ] [ game-loop-error ] recover ]
- with-variable ;
-
-: benchmark-micros ( loop -- micros )
- system-micros swap benchmark-time>> - ;
+: benchmark-nanos ( loop -- nanos )
+ nano-count swap benchmark-time>> - ;
PRIVATE>
-: reset-loop-benchmark ( loop -- )
- system-micros >>benchmark-time
+: reset-loop-benchmark ( loop -- loop )
+ nano-count >>benchmark-time
dup tick-number>> >>benchmark-tick-number
- dup frame-number>> >>benchmark-frame-number
- drop ;
+ dup frame-number>> >>benchmark-frame-number ;
: benchmark-ticks-per-second ( loop -- n )
- [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-micros ] tri /f ;
+ [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-nanos ] tri /f ;
: benchmark-frames-per-second ( loop -- n )
- [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-micros ] tri /f ;
+ [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-nanos ] tri /f ;
+
+: (game-tick) ( loop -- )
+ dup running?>>
+ [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] bi ]
+ [ drop ] if ;
+
+: game-tick ( loop -- )
+ dup game-loop [
+ [ (game-tick) ] [ game-loop-error ] recover
+ ] with-variable ;
: start-loop ( loop -- )
- system-micros >>last-tick
+ nano-count >>last-tick
t >>running?
- [ reset-loop-benchmark ]
- [ [ run-loop ] curry "game loop" spawn ]
- [ thread<< ] tri ;
+ reset-loop-benchmark
+ [
+ [ '[ _ game-tick ] f ]
+ [ tick-interval-nanos>> nanoseconds ] bi
+ <alarm>
+ ] keep [ alarm<< ] [ drop start-alarm ] 2bi ;
: stop-loop ( loop -- )
f >>running?
- f >>thread
- drop ;
+ alarm>> stop-alarm ;
-: <game-loop*> ( tick-interval-micros tick-delegate draw-delegate -- loop )
- system-micros f f 0 0 system-micros 0 0
+: <game-loop*> ( tick-interval-nanos tick-delegate draw-delegate -- loop )
+ nano-count f 0 0 nano-count 0 0 f
game-loop boa ;
-: <game-loop> ( tick-interval-micros delegate -- loop )
+: <game-loop> ( tick-interval-nanos delegate -- loop )
dup <game-loop*> ; inline
M: game-loop dispose
HELP: game-attributes
{ $class-description "Extends the " { $link world-attributes } " tuple class with extra attributes for " { $link game-world } "s:" }
{ $list
-{ { $snippet "tick-interval-micros" } " specifies the number of microseconds between consecutive calls to the world's " { $link tick-game-world } " method by the game loop. An integer greater than zero must be provided." }
+{ { $snippet "tick-interval-nanos" } " specifies the number of nanoseconds between consecutive calls to the world's " { $link tick-game-world } " method by the game loop. An integer greater than zero must be provided." }
{ { $snippet "use-game-input?" } " specifies whether the game world should initialize the " { $vocab-link "game.input" } " library for use by the game. False by default." }
{ { $snippet "use-audio-engine?" } " specifies whether the game world should manage an " { $link audio-engine } " instance. False by default." }
{ { $snippet "audio-engine-device" } " specifies the string name of the OpenAL device the audio engine, if any, should try to open. The default value of " { $link POSTPONE: f } " attempts to open the default OpenAL device." }
TUPLE: game-world < world
game-loop
audio-engine
- { tick-interval-micros fixnum }
+ { tick-interval-nanos integer }
{ use-game-input? boolean }
{ use-audio-engine? boolean }
{ audio-engine-device initial: f }
M: game-world begin-world
dup use-game-input?>> [ open-game-input ] when
dup use-audio-engine?>> [ dup open-game-audio-engine >>audio-engine ] when
- dup [ tick-interval-micros>> ] [ ] bi <game-loop>
+ dup [ tick-interval-nanos>> ] [ ] bi <game-loop>
[ >>game-loop begin-game-world ] keep start-loop ;
M: game-world end-world
[ use-game-input?>> [ close-game-input ] when ] tri ;
TUPLE: game-attributes < world-attributes
- { tick-interval-micros fixnum }
+ { tick-interval-nanos integer }
{ use-game-input? boolean initial: f }
{ use-audio-engine? boolean initial: f }
{ audio-engine-device initial: f }
M: game-world apply-world-attributes
{
- [ tick-interval-micros>> >>tick-interval-micros ]
+ [ tick-interval-nanos>> >>tick-interval-nanos ]
[ use-game-input?>> >>use-game-input? ]
[ use-audio-engine?>> >>use-audio-engine? ]
[ audio-engine-device>> >>audio-engine-device ]
: filter-overlaps ( alist -- alist' )
2 clump
[ first2 [ first second ] [ first first ] bi* < ] filter
- [ first ] map ;
+ keys ;
MEMO: ip-intervals ( -- interval-map )
ip-db [ [ [ from>> ] [ to>> ] bi 2array ] keep ] { } map>assoc
! (c)2009 Joe Groff bsd license
-USING: alien byte-arrays destructors help.markup help.syntax kernel math
-quotations ;
+USING: alien alien.data byte-arrays destructors help.markup help.syntax
+kernel math quotations ;
IN: gpu.buffers
HELP: <buffer-ptr>
}
{ $description "Maps " { $snippet "buffer" } " into CPU address space with " { $snippet "access" } " for the dynamic extent of " { $snippet "quot" } ". " { $snippet "quot" } " is called with a pointer to the mapped memory on top of the stack." } ;
+HELP: with-mapped-buffer-array
+{ $values
+ { "buffer" buffer } { "access" buffer-access-mode } { "c-type" "a C type" } { "quot" { $quotation "( ..a array -- ..b )" } }
+}
+{ $description "Maps " { $snippet "buffer" } " into CPU address space with " { $snippet "access" } " for the dynamic extent of " { $snippet "quot" } ". " { $snippet "quot" } " is called with the pointer to the mapped memory wrapped in a specialized array of " { $snippet "c-type" } "." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ;
+
{ allocate-buffer allocate-byte-array buffer-size update-buffer read-buffer copy-buffer with-mapped-buffer } related-words
HELP: write-access
read-buffer
copy-buffer
with-mapped-buffer
-}
-;
+ with-mapped-buffer-array
+} ;
ABOUT: "gpu.buffers"
! (c)2009 Joe Groff bsd license
-USING: accessors alien alien.c-types arrays byte-arrays
+USING: accessors alien alien.c-types alien.data arrays byte-arrays
combinators destructors gpu kernel locals math opengl opengl.gl
typed ui.gadgets.worlds variants ;
IN: gpu.buffers
target glUnmapBuffer drop ; inline
+:: with-mapped-buffer-array ( ..a buffer access c-type quot: ( ..a array -- ..b ) -- ..b )
+ buffer buffer-size c-type heap-size /i :> len
+ buffer access [ len c-type <c-direct-array> quot call ] with-mapped-buffer ; inline
+
:: with-bound-buffer ( ..a buffer target quot: ( ..a -- ..b ) -- ..b )
target gl-target buffer glBindBuffer
quot call ; inline
{ grab-input? t }
{ use-game-input? t }
{ pref-dim { 1024 768 } }
- { tick-interval-micros $[ 60 fps ] }
+ { tick-interval-nanos $[ 60 fps ] }
} ;
{ use-game-input? t }
{ use-audio-engine? t }
{ pref-dim { 1024 768 } }
- { tick-interval-micros $[ 60 fps ] }
+ { tick-interval-nanos $[ 60 fps ] }
} ;
{ "An " { $link index-elements } " value submits vertex array elements in an order specified by an array of indexes." }
{ "A " { $link multi-index-range } " value submits multiple sequential slices of a vertex array." }
{ "A " { $link multi-index-elements } " value submits multiple separate lists of indexed vertex array elements." }
+{ "Specialized arrays of " { $link c:uchar } ", " { $link c:ushort } ", or " { $link c:uint } " elements may also be used directly as arrays of indexes." }
} } ;
ARTICLE: "gpu.render" "Rendering"
vocabs.parser words math.vectors.simd ;
FROM: math => float ;
QUALIFIED-WITH: alien.c-types c
-SPECIALIZED-ARRAY: c:float
-SPECIALIZED-ARRAY: int
-SPECIALIZED-ARRAY: uint
-SPECIALIZED-ARRAY: void*
+SPECIALIZED-ARRAYS: c:float c:int c:uchar c:ushort c:uint c:void* ;
IN: gpu.render
UNION: ?integer integer POSTPONE: f ;
index-range
multi-index-range
index-elements
- multi-index-elements ;
+ multi-index-elements
+ uchar-array
+ ushort-array
+ uint-array ;
VARIANT: primitive-mode
points-mode
GENERIC# render-vertex-indexes-instanced 1 ( primitive-mode vertex-indexes instances -- )
+GENERIC: gl-array-element-type ( array -- type )
+M: uchar-array gl-array-element-type drop GL_UNSIGNED_BYTE ; inline
+M: ushort-array gl-array-element-type drop GL_UNSIGNED_SHORT ; inline
+M: uint-array gl-array-element-type drop GL_UNSIGNED_INT ; inline
+
M: index-range render-vertex-indexes
[ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] bi* glDrawArrays ;
[ ] tri*
swap index-buffer [ swap glDrawElementsInstanced ] with-gpu-data-ptr ;
+M: specialized-array render-vertex-indexes
+ GL_ELEMENT_ARRAY_BUFFER 0 glBindBuffer
+ [ gl-primitive-mode ]
+ [ [ length ] [ gl-array-element-type ] [ >c-ptr ] tri ] bi*
+ glDrawElements ;
+
+M: specialized-array render-vertex-indexes-instanced
+ GL_ELEMENT_ARRAY_BUFFER 0 glBindBuffer
+ [ gl-primitive-mode ]
+ [ [ length ] [ gl-array-element-type ] [ >c-ptr ] tri ]
+ [ ] tri* glDrawElementsInstanced ;
+
M: multi-index-elements render-vertex-indexes
[ gl-primitive-mode ]
[ { [ counts>> ] [ index-type>> gl-index-type ] [ ptrs>> dup length ] [ buffer>> ] } cleave ]
[ [ length ] [ >int-array ] bi glDrawBuffers ] if ;
: bind-named-output-attachments ( program-instance framebuffer attachments -- )
- rot '[ first _ swap output-index ] sort-with [ second ] map
+ rot '[ first _ swap output-index ] sort-with values
bind-unnamed-output-attachments ;
: bind-output-attachments ( program-instance framebuffer attachments -- )
texture [ texture-gl-target ] [ handle>> ] bi glBindTexture
texture ; inline
-: get-texture-float ( target level enum -- value )
- 0 <float> [ glGetTexLevelParameterfv ] keep *float ; inline
-: get-texture-int ( target level enum -- value )
- 0 <int> [ glGetTexLevelParameteriv ] keep *int ; inline
-
: ?product ( x -- y )
dup number? [ product ] unless ; inline
1.0 0.0 0.5 1.0
1.0 0.0 1.0 1.0
}
-] [ { 2 2 } vertex-array byte-array>float-array ] unit-test
+] [ { 2 2 } vertex-array float-array-cast ] unit-test
--- /dev/null
+not tested
--- /dev/null
+! Copyright (C) 2010 Jon Harper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings io.pathnames images
+models opengl.textures classes ui.gadgets ;
+IN: images.viewer
+
+HELP: <image-gadget>
+{ $values
+ { "object" { $or pathname string image } }
+ { "gadget" image-gadget }
+}
+{ $description "Creates " { $instance image-gadget } " with the given image. See " { $link set-image } "." } ;
+HELP: <image-control>
+{ $values
+ { "model" model }
+ { "gadget" image-control }
+}
+{ $description "Creates " { $instance image-control } " with the given image. See " { $link set-image } "." } ;
+
+HELP: new-image-gadget
+{ $values
+ { "class" class }
+ { "gadget" image-gadget }
+}
+{ $description "Use this if the image is not available when you want to construct the gadget. Don't forget to call "
+{ $link set-image } " before grafting this gadget. You can also use this constructor if you want to extend image-gadget or image-control."
+} ;
+
+HELP: new-image-gadget*
+{ $values
+ { "object" { $or pathname string image } } { "class" class }
+ { "gadget" image-gadget }
+}
+{ $description "Use this constructor when you want to extend image-gadget or image-control." } ;
+
+HELP: set-image
+{ $values
+ { "gadget" image-gadget } { "object" { $or pathname string image } }
+}
+{ $description "Sets the image of this gadget. This word loads the image from disk if the input is a string or a pathname."
+"If the input is a model, gadget has to be " { $instance image-control } "." } ;
+
+HELP: image-control
+{ $var-description "This gadget is like " { $instance image-gadget } ", but it's image must be in " { $instance model } ". It's used to display changing images." } ;
+
+HELP: image-gadget
+{ $var-description "This gadget can render " { $instance image } "." } ;
+
+HELP: image-window
+{ $values
+ { "object" { $or pathname string image } }
+}
+{ $description "Opens a new window displaying the image." } ;
+
+HELP: image.
+{ $values
+ { "object" { $or pathname string image } }
+}
+{ $description "Displays the image in the listener." } ;
+HELP: start-control
+{ $values
+ { "gadget" gadget }
+}
+{ $description "Adds a connection between the gadget and it's model." } ;
+
+HELP: stop-control
+{ $values
+ { "gadget" gadget }
+}
+{ $description "Removes the connection between the gadget and it's model" } ;
+ARTICLE: "images.viewer" "Displaying Images"
+"The " { $vocab-link "images.viewer" } " vocabulary uses the " { $vocab-link "opengl.textures" }
+" vocabulary to display any instance of " { $link image } "."$nl
+"An " { $link image-gadget } " can be used for static images and " { $instance image-control }
+" for changing images (for example a video feed). For changing images, the image should be containted in " { $instance model }
+". Change the model value with " { $link set-model } " or mutate the image and call "
+{ $link notify-connections } " when you want to update the image. To stop refreshing the image, call " { $link stop-control } "."
+" To start refreshing again, call " { $link start-control } "."
+
+$nl
+"If the " { $link image } " or " { $link model } " containing the image "
+"is available when the object is created, use the following words to create the gadget:"
+{ $subsections <image-gadget> <image-control> }
+"The " { $link image } " or " { $link model }
+" can also be given after the construction of the object. In this case, use "
+{ $link new-image-gadget } " and " { $link set-image } "."
+" The gadget will automatically detect if the image changes size or format and reallocate a new texture if needed."
+" This means images can be set even after the gadget has been grafted. Grafted gadgets without an image will display a blank screen."
+
+{ $notes "The image can be set after the gadget has been grafted. However, for " { $instance image-gadget } ", this can "
+" be done only once. If your image is changing, you should be using " { $instance image-control } " and " { $instance model } "."
+$nl
+" Performance will be greatly reduced if you are using images that have more than 512 pixels on one of their"
+" axis." }
+
+
+$nl
+"Utility words for displaying images :"
+{ $subsections
+image. image-window }
+
+;
+ABOUT: "images.viewer"
--- /dev/null
+! Copyright (C) 2010 Jon Harper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test images.viewer images.viewer.private kernel accessors sequences images
+namespaces ui ui.gadgets.debug math opengl.textures opengl.textures.private
+models ;
+IN: images.viewer.tests
+
+: (gen-image) ( dim -- bitmap )
+ product 3 * [ 200 ] BV{ } replicate-as ;
+: gen-image ( dim -- image )
+ dup (gen-image) <image> swap >>bitmap swap >>dim
+ RGB >>component-order ubyte-components >>component-type ;
+
+[ ] [ { 50 50 } gen-image "s" set ] unit-test
+[ ] [ "s" get <image-gadget> "ig" set ] unit-test
+"ig" get [
+ [ t ] [ "ig" get image-gadget-texture single-texture? ] unit-test
+] with-grafted-gadget
+
+[ ] [ "s" get <model> "m" set ] unit-test
+[ ] [ { 150 150 } gen-image "s1" set ] unit-test
+[ ] [ "m" get <image-control> "ic" set ] unit-test
+"ic" get [
+ [ t ] [ "ic" get image-gadget-texture single-texture? ] unit-test
+ [ { 50 50 } ] [ "ic" get texture>> texture-size ] unit-test
+] with-grafted-gadget
+
+! TODO
+! test that when changing the model, the gadget updates the texture.
+! - same size images (both smaller than 512x512) (updates)
+! test that when changing the model, the gadget creates a new texture.
+! test different cases :
+! - same size images (both bigger than 512x512) (creates)
+! - different size images (both smaller than 512x512) (creates)
+! - different size images (both bigger than 512x512) (creates)
+! - different size images (1 smaller than, 1 bigger than 512x512)
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io.pathnames kernel
-models namespaces opengl opengl.gl opengl.textures sequences
+models namespaces opengl opengl.gl opengl.textures opengl.textures.private
+sequences math arrays
strings ui ui.gadgets ui.gadgets.panes ui.images ui.render
-constructors ;
+constructors locals combinators.short-circuit
+literals destructors ui.gadgets.worlds continuations ;
IN: images.viewer
TUPLE: image-gadget < gadget image texture ;
+<PRIVATE
+M: image-gadget pref-dim* image>> [ dim>> ] [ { 640 480 } ] if* ;
-M: image-gadget pref-dim* image>> dim>> ;
-
+: (image-gadget-texture) ( gadget -- texture )
+ dup image>> { 0 0 } <texture> >>texture texture>> ;
: image-gadget-texture ( gadget -- texture )
- dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
+ dup texture>> [ ] [ (image-gadget-texture) ] ?if ;
M: image-gadget draw-gadget* ( gadget -- )
dup image>> [
drop
] if ;
-TUPLE: image-control < image-gadget ;
-
-CONSTRUCTOR: image-control ( model -- image-control ) ;
-
-M: image-control pref-dim* image>> [ dim>> ] [ { 640 480 } ] if* ;
-
-M: image-control model-changed
- swap value>> >>image relayout ;
+: delete-current-texture ( image-gadget -- )
+ [ texture>> [ dispose ] when* ]
+ [ f >>texture drop ] bi ;
-! Todo: delete texture on ungraft
+! In unit tests, find-gl-context throws no-world-found when using with-grafted-gadget.
+M: image-gadget ungraft* [ dup find-gl-context delete-current-texture ] [ 2drop ] recover ;
+PRIVATE>
+TUPLE: image-control < image-gadget image-updated? ;
+<PRIVATE
-GENERIC: <image-gadget> ( object -- gadget )
+: (bind-2d-texture) ( texture-id -- )
+ [ GL_TEXTURE_2D ] dip glBindTexture ;
+: bind-2d-texture ( single-texture -- )
+ texture>> (bind-2d-texture) ;
+: (update-texture) ( image single-texture -- )
+ bind-2d-texture tex-sub-image ;
+! works only for single-texture
+: update-texture ( image-gadget -- )
+ [ image>> ] [ texture>> ] bi
+ (update-texture) ;
+GENERIC: texture-size ( texture -- dim )
+M: single-texture texture-size dim>> ;
-M: image <image-gadget>
- \ image-gadget new
- swap >>image ;
+:: grid-width ( grid element-quot -- width )
+ grid [ 0 ] [
+ first element-quot [ + ] map-reduce
+ ] if-empty ; inline
+: grid-dim ( grid -- dim )
+ [ [ dim>> first ] grid-width ] [ flip [ dim>> second ] grid-width ] bi 2array ;
+M: multi-texture texture-size
+ grid>> grid-dim ;
+: same-size? ( image-gadget -- ? )
+ [ texture>> texture-size ] [ image>> dim>> ] bi = ;
+: (texture-format) ( texture-id -- format )
+ (bind-2d-texture) GL_TEXTURE_2D 0
+ GL_TEXTURE_INTERNAL_FORMAT get-texture-int ;
+! works only for single-texture
+: texture-format ( image-gadget -- format/f )
+ texture>> [
+ texture>> [
+ (texture-format)
+ ] [ f ] if*
+ ] [ f ] if* ;
+: same-internal-format? ( image-gadget -- ? )
+ [ texture-format ] [ image>> image-format 2drop ] bi = ;
-M: string <image-gadget> load-image <image-gadget> ;
-
-M: pathname <image-gadget> string>> load-image <image-gadget> ;
+! TODO: also keep multitextures if possible ?
+: keep-same-texture? ( image-gadget -- ? )
+ { [ texture>> single-texture? ]
+ [ same-size? ]
+ [ same-internal-format? ] } 1&& ;
+: ?update-texture ( image-gadget -- )
+ dup image-updated?>> [
+ f >>image-updated?
+ dup keep-same-texture? [ update-texture ] [ delete-current-texture ] if
+ ] [ drop ] if ;
+M: image-control model-changed
+ swap value>> >>image t >>image-updated? relayout ;
+M: image-control draw-gadget* [ ?update-texture ] [ call-next-method ] bi ;
+PRIVATE>
+GENERIC: set-image ( gadget object -- gadget )
+M: image set-image >>image ;
+M: string set-image load-image >>image ;
+M: pathname set-image string>> load-image >>image ;
+M: model set-image [ value>> >>image drop ] [ >>model ] 2bi ;
+: new-image-gadget ( class -- gadget ) new ;
+: new-image-gadget* ( object class -- gadget )
+ new-image-gadget swap set-image ;
+: <image-gadget> ( object -- gadget )
+ \ image-gadget new-image-gadget* ;
+: <image-control> ( model -- gadget )
+ \ image-control new-image-gadget* ;
: image-window ( object -- ) <image-gadget> "Image" open-window ;
+! move these words to ui.gadgets because they affect all controls ?
+: stop-control ( gadget -- ) dup model>> [ remove-connection ] [ drop ] if* ;
+: start-control ( gadget -- ) dup model>> [ add-connection ] [ drop ] if* ;
+
: image. ( object -- ) <image-gadget> gadget. ;
+
+<PRIVATE
+M: image-control graft* start-control ;
+M: image-control ungraft* [ stop-control ] [ call-next-method ] bi ;
+PRIVATE>
: kill-update-axes ( gadget -- )
COLOR: gray <solid> >>interior
- [ [ cancel-alarm ] when* f ] change-alarm
+ [ [ stop-alarm ] when* f ] change-alarm
relayout-1 ;
: (update-axes) ( gadget controller-state -- )
drop ;
M: joystick-demo-gadget ungraft*
- alarm>> [ cancel-alarm ] when* ;
+ alarm>> [ stop-alarm ] when* ;
: joystick-window ( controller -- )
[ <joystick-demo-gadget> ] [ product-string ] bi
drop ;
M: key-caps-gadget ungraft*
- alarm>> [ cancel-alarm ] when*
+ alarm>> [ stop-alarm ] when*
close-game-input ;
M: key-caps-gadget handle-gesture
: bigraded-betti ( u-generators z-generators -- seq )
[ basis graded ] bi@ tensor bigraded-ker/im-d
- [ [ [ first ] map ] map ] keep
- [ [ second ] map 2 head* { 0 0 } prepend ] map
+ [ [ keys ] map ] keep
+ [ values 2 head* { 0 0 } prepend ] map
rest dup first length 0 <array> suffix
[ v- ] 2map ;
LLVMGetFirstFunction [ (functions) ] { } make [ <function> ] map ;
: function-effect ( function -- effect )
- [ params>> [ first ] map ] [ return>> void? 0 1 ? ] bi <effect> ;
+ [ params>> keys ] [ return>> void? 0 1 ? ] bi <effect> ;
: install-function ( function -- )
dup name>> "alien.llvm" create-vocab drop
[ normalize-path ] [ file-name ] bi
[ load-into-jit ] keep install-module ;
-<< "alien.llvm" create-vocab drop >>
\ No newline at end of file
+<< "alien.llvm" create-vocab drop >>
! (c)Joe Groff bsd license
-USING: accessors classes.struct fry generalizations kernel locals
-math math.combinatorics math.functions math.matrices.simd math.vectors
-math.vectors.simd math.quaternions sequences sequences.private specialized-arrays
+USING: accessors classes.struct fry generalizations kernel
+locals math math.combinatorics math.functions math.matrices.simd
+math.vectors math.vectors.simd math.quaternions sequences
+sequences.generalizations sequences.private specialized-arrays
typed ;
FROM: sequences.private => nth-unsafe ;
FROM: math.quaternions.private => (q*sign) ;
{ windowed double-buffered }
}
{ pref-dim { 1024 768 } }
- { tick-interval-micros 16666 }
+ { tick-interval-nanos $[ 60 fps ] }
{ use-game-input? t }
{ model-path model-path }
}
USING: kernel math sequences vectors classes classes.algebra
combinators arrays words assocs parser namespaces make
definitions prettyprint prettyprint.backend prettyprint.custom
-quotations generalizations debugger io compiler.units
-kernel.private effects accessors hashtables sorting shuffle
-math.order sets see effects.parser ;
+quotations generalizations sequences.generalizations debugger io
+compiler.units kernel.private effects accessors hashtables
+sorting shuffle math.order sets see effects.parser ;
FROM: namespaces => set ;
IN: multi-methods
TYPED:: perlin-noise-map ( table: byte-array transform: matrix4 coords: float-4-array -- map: float-array )
coords [| coord | table transform coord m4.v perlin-noise ] data-map( float-4 -- c:float )
- byte-array>float-array ;
+ float-array-cast ;
: perlin-noise-image ( table transform dim -- image )
[ perlin-noise-map-coords perlin-noise-map ] [ 5/7. 0.5 float-map>image ] bi ;
! The contents of this file are licensed under the Simplified BSD License
! A copy of the license is available at http://factorcode.org/license.txt
USING: grouping kernel math math.ranges project-euler.common
-sequences sequences.cords ;
+sequences sequences.cords assocs ;
IN: project-euler.206
! http://projecteuler.net/index.php?section=problems&id=206
: form-fitting? ( n -- ? )
number>digits 2 group [ first ] map
- { 1 2 3 4 5 6 7 8 9 0 } = ;
+ { 1 2 3 4 5 6 7 8 9 0 } sequence= ;
: candidates ( -- seq )
lo lo 40 + [ hi 100 <range> ] bi@ cord-append ;
] unless ;
: stop-site-watcher ( -- )
- running-site-watcher get [ cancel-alarm ] when* ;
+ running-site-watcher get [ stop-alarm ] when* ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators.short-circuit
continuations fry kernel namespaces quotations sequences sets
-generalizations slots locals.types splitting math
-locals.rewrite.closures generic words combinators locals smalltalk.ast
-smalltalk.compiler.lexenv smalltalk.compiler.assignment
-smalltalk.compiler.return smalltalk.selectors smalltalk.classes ;
+generalizations sequences.generalizations slots locals.types
+splitting math locals.rewrite.closures generic words combinators
+locals smalltalk.ast smalltalk.compiler.lexenv
+smalltalk.compiler.assignment smalltalk.compiler.return
+smalltalk.selectors smalltalk.classes ;
IN: smalltalk.compiler
GENERIC: compile-ast ( lexenv ast -- quot )
{ use-game-input? t }
{ grab-input? t }
{ pref-dim { 1024 768 } }
- { tick-interval-micros $[ 60 fps ] }
+ { tick-interval-nanos $[ 60 fps ] }
} ;
[ [ tick ] curry 100 milliseconds every ] keep alarm<< ;
M: tetris-gadget ungraft* ( gadget -- )
- [ cancel-alarm f ] change-alarm drop ;
+ [ stop-alarm f ] change-alarm drop ;
: tetris-window ( -- )
[
return parent->alien_offset(obj);
}
-/* For FFI callbacks receiving structs by value */
-cell factor_vm::from_value_struct(void *src, cell size)
-{
- byte_array *bytes = allot_byte_array(size);
- memcpy(bytes->data<void>(),src,size);
- return tag<byte_array>(bytes);
-}
-
-VM_C_API cell from_value_struct(void *src, cell size, factor_vm *parent)
-{
- return parent->from_value_struct(src,size);
-}
-
-/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
-cell factor_vm::from_small_struct(cell x, cell y, cell size)
-{
- cell data[2];
- data[0] = x;
- data[1] = y;
- return from_value_struct(data,size);
-}
-
-VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *parent)
-{
- return parent->from_small_struct(x,y,size);
-}
-
-/* On OS X/PPC, complex numbers are returned in registers. */
-cell factor_vm::from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
-{
- cell data[4];
- data[0] = x1;
- data[1] = x2;
- data[2] = x3;
- data[3] = x4;
- return from_value_struct(data,size);
-}
-
-VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent)
-{
- return parent->from_medium_struct(x1, x2, x3, x4, size);
-}
-
}
VM_C_API char *alien_offset(cell object, factor_vm *vm);
VM_C_API char *pinned_alien_offset(cell object, factor_vm *vm);
VM_C_API cell allot_alien(void *address, factor_vm *vm);
-VM_C_API cell from_value_struct(void *src, cell size, factor_vm *vm);
-VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *vm);
-VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *vm);
}
return array;
}
+VM_C_API cell allot_byte_array(cell size, factor_vm *parent)
+{
+ return tag<byte_array>(parent->allot_byte_array(size));
+}
+
void factor_vm::primitive_byte_array()
{
cell size = unbox_array_size();
return data;
}
+VM_C_API cell allot_byte_array(cell size, factor_vm *parent);
+
}
set-context-object primitives */
cell context_objects[context_object_count];
- /* temporary area used by FFI code generation */
- s64 long_long_return;
-
context(cell datastack_size, cell retainstack_size, cell callstack_size);
~context();
}
}
-VM_C_API s64 *to_signed_8(cell obj, factor_vm *parent)
+VM_C_API void to_signed_8(cell obj, s64 *out, factor_vm *parent)
{
- parent->ctx->long_long_return = parent->to_signed_8(obj);
- return &parent->ctx->long_long_return;
+ *out = parent->to_signed_8(obj);
}
cell factor_vm::from_unsigned_8(u64 n)
}
}
-VM_C_API s64 *to_unsigned_8(cell obj, factor_vm *parent)
+VM_C_API void to_unsigned_8(cell obj, u64 *out, factor_vm *parent)
{
- parent->ctx->long_long_return = parent->to_unsigned_8(obj);
- return &parent->ctx->long_long_return;
+ *out = parent->to_unsigned_8(obj);
}
VM_C_API cell from_float(float flo, factor_vm *parent)
VM_C_API cell from_signed_8(s64 n, factor_vm *vm);
VM_C_API cell from_unsigned_8(u64 n, factor_vm *vm);
-VM_C_API s64 *to_signed_8(cell obj, factor_vm *vm);
-VM_C_API s64 *to_unsigned_8(cell obj, factor_vm *vm);
+VM_C_API void to_signed_8(cell obj, s64 *out, factor_vm *parent);
+VM_C_API void to_unsigned_8(cell obj, u64 *out, factor_vm *parent);
VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm);
VM_C_API cell to_cell(cell tagged, factor_vm *vm);
void primitive_dlclose();
void primitive_dll_validp();
char *alien_offset(cell obj);
- cell from_value_struct(void *src, cell size);
- cell from_small_struct(cell x, cell y, cell size);
- cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
// quotations
void primitive_jit_compile();
projects / factor.git / commitdiff