!IF DEFINED(PLATFORM)
LINK_FLAGS = /nologo shell32.lib
-CL_FLAGS = /nologo /O2 /W3
+CL_FLAGS = /nologo /O2 /W3 /D_CRT_SECURE_NO_WARNINGS
!IF DEFINED(DEBUG)
LINK_FLAGS = $(LINK_FLAGS) /DEBUG
M: array c-type-align-first first c-type-align-first ;
-M: array unbox-parameter drop void* unbox-parameter ;
-
-M: array unbox-return drop void* unbox-return ;
-
-M: array box-parameter drop void* box-parameter ;
-
-M: array box-return drop void* box-return ;
+M: array base-type drop void* base-type ;
M: array stack-size drop void* stack-size ;
-M: array flatten-c-type drop { int-rep } ;
-
PREDICATE: string-type < pair
first2 [ c-string = ] [ word? ] bi* and ;
M: string-type c-type-boxed-class drop object ;
-M: string-type heap-size
- drop void* heap-size ;
-
-M: string-type c-type-align
- drop void* c-type-align ;
-
-M: string-type c-type-align-first
- drop void* c-type-align-first ;
-
-M: string-type unbox-parameter
- drop void* unbox-parameter ;
-
-M: string-type unbox-return
- drop void* unbox-return ;
+M: string-type heap-size drop void* heap-size ;
-M: string-type box-parameter
- drop void* box-parameter ;
+M: string-type c-type-align drop void* c-type-align ;
-M: string-type box-return
- drop void* box-return ;
+M: string-type c-type-align-first drop void* c-type-align-first ;
-M: string-type stack-size
- drop void* stack-size ;
+M: string-type base-type drop void* base-type ;
-M: string-type c-type-rep
- drop int-rep ;
+M: string-type stack-size drop void* stack-size ;
-M: string-type flatten-c-type
- drop { int-rep } ;
+M: string-type c-type-rep drop int-rep ;
M: string-type c-type-boxer-quot
second dup binary =
{ $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: box-parameter
-{ $values { "n" math:integer } { "c-type" "a C type" } }
-{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
-{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
-
-HELP: box-return
-{ $values { "c-type" "a C type" } }
-{ $description "Generates code for converting a C value stored in return registers into a Factor object to be pushed on the data stack." }
-{ $notes "This is an internal word used by the compiler when compiling alien calls." } ;
-
-HELP: unbox-return
-{ $values { "c-type" "a C type" } }
-{ $description "Generates code for converting a Factor value on the data stack into a C value to be stored in the return registers." }
-{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
-
HELP: define-deref
{ $values { "c-type" "a C type" } }
{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
dup "c-type" word-prop resolve-typedef
[ ] [ no-c-type ] ?if ;
-GENERIC: c-struct? ( c-type -- ? )
-
-M: object c-struct? drop f ;
-
-M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
-
-! These words being foldable means that words need to be
-! recompiled if a C type is redefined. Even so, folding the
-! size facilitates some optimizations.
GENERIC: c-type-class ( name -- class )
M: abstract-c-type c-type-class class>> ;
M: abstract-c-type c-type-align-first align-first>> ;
-: c-type-box ( n c-type -- )
- [ rep>> ] [ boxer>> ] bi %box ;
-
-: c-type-unbox ( n c-type -- )
- [ rep>> ] [ unboxer>> ] bi %unbox ;
-
-GENERIC: box-parameter ( n c-type -- )
-
-M: c-type box-parameter c-type-box ;
-
-GENERIC: box-return ( c-type -- )
-
-M: c-type box-return f swap c-type-box ;
-
-GENERIC: unbox-parameter ( n c-type -- )
-
-M: c-type unbox-parameter c-type-unbox ;
+GENERIC: base-type ( c-type -- c-type )
-GENERIC: unbox-return ( c-type -- )
+M: c-type-name base-type c-type ;
-M: c-type unbox-return f swap c-type-unbox ;
+M: c-type base-type ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
M: c-type stack-size size>> cell align ;
-: (flatten-c-type) ( type rep -- seq )
- [ stack-size cell /i ] dip <repetition> ; inline
-
-GENERIC: flatten-c-type ( type -- reps )
-
-M: c-type flatten-c-type rep>> 1array ;
-M: c-type-name flatten-c-type c-type flatten-c-type ;
-
-: flatten-c-types ( types -- reps )
- [ flatten-c-type ] map concat ;
-
MIXIN: value-type
: c-getter ( name -- quot )
c-type-setter
c-type-align
c-type-align-first
- box-parameter
- box-return
- unbox-parameter
- unbox-return
+ base-type
heap-size
- stack-size
- flatten-c-type ;
+ stack-size ;
CONSULT: c-type-protocol c-type-name
c-type ;
: <long-long-type> ( -- c-type )
long-long-type new ;
-M: long-long-type unbox-parameter ( n c-type -- )
- unboxer>> %unbox-long-long ;
-
-M: long-long-type unbox-return ( c-type -- )
- f swap unbox-parameter ;
-
-M: long-long-type box-parameter ( n c-type -- )
- boxer>> %box-long-long ;
-
-M: long-long-type box-return ( c-type -- )
- f swap box-parameter ;
-
-M: long-long-type flatten-c-type
- int-rep (flatten-c-type) ;
-
: define-deref ( c-type -- )
[ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
(( c-ptr -- value )) define-inline ;
[ append-dimensions ] bi ;
: new-fortran-type ( out? dims size class -- type )
- new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;
+ new [ [ size<< ] [ dims<< ] [ out?<< ] tri ] keep ;
GENERIC: (fortran-type>c-type) ( type -- c-type )
{ POSTPONE: TYPEDEF: typedef } related-words
-HELP: c-struct?
-{ $values { "c-type" "a C type" } { "?" "a boolean" } }
-{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
-
HELP: C-GLOBAL:
{ $syntax "C-GLOBAL: type name" }
{ $values { "type" "a C type" } { "name" "a C global variable name" } }
[ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline
: set-abp ( abp bitstream -- )
- [ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline
+ [ 8 /mod ] dip [ bit-pos<< ] [ byte-pos<< ] bi ; inline
: seek ( n bitstream -- )
[ get-abp + ] [ set-abp ] bi ; inline
byte bs widthed>> |widthed :> new-byte
new-byte #bits>> 8 = [
new-byte bits>> bs bytes>> push
- zero-widthed bs (>>widthed)
+ zero-widthed bs widthed<<
remainder widthed>bytes
- [ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
+ [ bs bytes>> push-all ] [ bs widthed<< ] bi*
] [
- byte bs (>>widthed)
+ byte bs widthed<<
] if ;
: enough-bits? ( n bs -- ? )
n 8 /mod :> ( #bytes #bits )
bs [ #bytes + ] change-byte-pos
bit-pos>> #bits + dup 8 >= [
- 8 - bs (>>bit-pos)
+ 8 - bs bit-pos<<
bs [ 1 + ] change-byte-pos drop
] [
- bs (>>bit-pos)
+ bs bit-pos<<
] if ;
:: (peek) ( n bs endian> subseq-endian -- bits )
" done" print flush
+ "alien.syntax" require
+ "alien.complex" require
"io.streams.byte-array.fast" require
] unless
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
: load-help ( -- )
"help.lint" require
"help.vocabs" require
- "alien.syntax" require
- "compiler" require
t load-help? set-global
- [ vocab ] load-vocab-hook [
+ [ dup vocab [ ] [ no-vocab ] ?if ] load-vocab-hook [
dictionary get values
[ docs-loaded?>> not ] filter
[ load-docs ] each
-USING: vocabs.loader sequences ;
+USING: vocabs.loader sequences system combinators ;
IN: bootstrap.tools
{
"vocabs.refresh"
"vocabs.refresh.monitor"
} [ require ] each
+
+{
+ { [ os windows? ] [ "debugger.windows" require ] }
+ { [ os unix? ] [ "debugger.unix" require ] }
+} cond
\r
: >box ( value box -- )\r
dup occupied>>\r
- [ box-full ] [ t >>occupied (>>value) ] if ; inline\r
+ [ box-full ] [ t >>occupied value<< ] if ; inline\r
\r
ERROR: box-empty box ;\r
\r
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ;
HELP: timestamp
-{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two duarionts with the " { $link <=> } " word." } ;
+{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two durations with the " { $link <=> } " word." } ;
{ timestamp duration } related-words
: update-md5 ( md5 -- )
[ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
- [ (>>old-state) ] [ (>>state) ] bi ;
+ [ old-state<< ] [ state<< ] bi ;
CONSTANT: T
$[
state [ H [ w+ ] 2map ] change-H drop ; inline
M:: sha1-state checksum-block ( bytes state -- )
- bytes prepare-sha1-message-schedule state (>>W)
+ bytes prepare-sha1-message-schedule state W<<
bytes
state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ;
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
- circular-wrap (>>start) ; inline
+ circular-wrap start<< ; inline
: rotate-circular ( circular -- )
[ 1 ] dip change-circular-start ; inline
M: struct-c-type c-type ;
-: if-value-struct ( ctype true false -- )
- [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
-
-M: struct-c-type unbox-parameter
- [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
-
-M: struct-c-type box-parameter
- [ %box-large-struct ] [ box-parameter ] if-value-struct ;
-
-: if-small-struct ( c-type true false -- ? )
- [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
-
-M: struct-c-type unbox-return
- [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
-
-M: struct-c-type box-return
- [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
+M: struct-c-type base-type ;
M: struct-c-type stack-size
- [ heap-size cell align ] [ stack-size ] if-value-struct ;
-
-HOOK: flatten-struct-type cpu ( type -- reps )
+ dup value-struct? [ heap-size cell align ] [ drop cell ] if ;
-M: object flatten-struct-type int-rep (flatten-c-type) ;
+HOOK: flatten-struct-type cpu ( type -- pairs )
-M: struct-c-type flatten-c-type flatten-struct-type ;
+M: object flatten-struct-type
+ stack-size cell /i { int-rep f } <repetition> ;
-M: struct-c-type c-struct? drop t ;
+: large-struct? ( type -- ? )
+ {
+ { [ dup void? ] [ drop f ] }
+ { [ dup base-type struct-c-type? not ] [ drop f ] }
+ [ return-struct-in-registers? not ]
+ } cond ;
<PRIVATE
: struct-slot-values-quot ( class -- quot )
M: struct-slot-spec compute-slot-offset
[ type>> over c-type-align-at 8 * align ] keep
- [ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;
+ [ [ 8 /i ] dip offset<< ] [ type>> heap-size 8 * + ] 2bi ;
M: struct-bit-slot-spec compute-slot-offset
- [ (>>offset) ] [ bits>> + ] 2bi ;
+ [ offset<< ] [ bits>> + ] 2bi ;
: compute-struct-offsets ( slots -- size )
0 [ compute-slot-offset ] reduce 8 align 8 /i ;
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
-classes.struct continuations combinators compiler compiler.alien
+classes.struct continuations combinators compiler
core-graphics.types stack-checker kernel math namespaces make
quotations sequences strings words cocoa.runtime cocoa.types io
macros memoize io.encodings.utf8 effects layouts libc
+++ /dev/null
-! Copyright (C) 2008, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces make math sequences layouts
-alien.c-types cpu.architecture ;
-IN: compiler.alien
-
-: large-struct? ( type -- ? )
- dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
-
-: alien-parameters ( params -- seq )
- dup parameters>>
- swap return>> large-struct? [ struct-return-pointer-type prefix ] when ;
-
-: alien-return ( params -- type )
- return>> dup large-struct? [ drop void ] when ;
+++ /dev/null
-Common code used for analysis and code generation of alien bindings
USING: arrays compiler.cfg.alias-analysis compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
-cpu.architecture tools.test ;
+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
+[
+ V{
+ T{ ##allot f 1 16 byte-array }
+ T{ ##load-reference f 2 10 }
+ 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= }
+ }
+] [
+ V{
+ T{ ##allot f 1 16 byte-array }
+ T{ ##load-reference f 2 10 }
+ 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= }
+ } 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: ##read analyze-aliases*
+M: ##box-displaced-alien analyze-aliases
+ [ call-next-method ]
+ [ base>> heap-ac get merge-acs ] bi ;
+
+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#
-M: ##copy analyze-aliases*
+ src slot# vreg idempotent? [ insn# dead-store ] [
+ src heap-ac get merge-acs
+ insn insn#>> slot# vreg remember-set-slot
+ src slot# vreg load-slot
+ ] if
+
+ insn ;
+
+M: ##copy analyze-aliases
#! The output vreg gets the same alias class as the input
#! vreg, since they both contain the same value.
dup record-copy ;
[ [ 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
-
-: compute-live-stores ( -- )
- histories get
- values [
- values [ [ store? ] filter [ insn#>> ] map ] map concat
- ] map concat fast-set
- live-stores set ;
+GENERIC: eliminate-dead-stores ( insn -- ? )
-GENERIC: eliminate-dead-stores* ( insn -- insn' )
+M: ##set-slot-imm eliminate-dead-stores
+ insn#>> dead-stores get in? not ;
-: (eliminate-dead-stores) ( insn -- insn' )
- dup insn-slot# [
- insn# get live-stores get in? [
- drop f
- ] unless
- ] when ;
-
-M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
+M: insn eliminate-dead-stores drop t ;
-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 ;
! before stack analysis.
: join-block? ( bb -- ? )
{
- [ kill-block? not ]
+ [ kill-block?>> not ]
[ predecessors>> length 1 = ]
- [ predecessor kill-block? not ]
+ [ predecessor kill-block?>> not ]
[ predecessor successors>> length 1 = ]
[ [ predecessor ] keep back-edge? not ]
} 1&& ;
[ instructions>> ] bi@ dup pop* push-all ;
: update-successors ( bb pred -- )
- [ successors>> ] dip (>>successors) ;
+ [ successors>> ] dip successors<< ;
: join-block ( bb pred -- )
[ join-instructions ] [ update-successors ] 2bi ;
-! Copyright (C) 2009 Doug Coleman, Slava Pestov.
+! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit kernel math math.order
-sequences assocs namespaces vectors fry arrays splitting
-compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors
-compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
+USING: accessors combinators combinators.short-circuit kernel
+math math.order sequences assocs namespaces vectors fry arrays
+splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
+compiler.cfg.predecessors compiler.cfg.renaming
+compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
: clone-instructions ( insns -- insns' )
! 'back-edge?' work.
<basic-block>
swap
- [ instructions>> clone-instructions >>instructions ]
- [ successors>> clone >>successors ]
- [ number>> >>number ]
- tri ;
+ {
+ [ instructions>> clone-instructions >>instructions ]
+ [ successors>> clone >>successors ]
+ [ kill-block?>> >>kill-block? ]
+ [ number>> >>number ]
+ } cleave ;
: new-blocks ( bb -- copies )
dup predecessors>> [
frame-required? on
stack-frame [ max-stack-frame ] change ;
-UNION: stack-frame-insn
- ##alien-invoke
- ##alien-indirect
- ##alien-assembly
- ##alien-callback ;
-
-M: stack-frame-insn compute-stack-frame*
+M: ##stack-frame compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame* drop frame-required? on ;
--- /dev/null
+! 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
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
+IN: compiler.cfg.builder.alien.params
+
+: alloc-stack-param ( rep -- n )
+ stack-params get
+ [ rep-size cell align stack-params +@ ] dip ;
+
+: ?dummy-stack-params ( rep -- )
+ dummy-stack-params? [ alloc-stack-param drop ] [ drop ] if ;
+
+: ?dummy-int-params ( rep -- )
+ dummy-int-params? [
+ rep-size cell /i 1 max
+ [ int-regs get [ pop* ] unless-empty ] times
+ ] [ drop ] if ;
+
+: ?dummy-fp-params ( rep -- )
+ drop dummy-fp-params? [ float-regs get [ pop* ] unless-empty ] when ;
+
+GENERIC: next-reg-param ( rep -- reg )
+
+M: int-rep next-reg-param
+ [ ?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 ;
+
+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 ;
+
+M: reg-class reg-class-full? get empty? ;
+
+: init-reg-class ( abi reg-class -- )
+ [ swap param-regs <reversed> >vector ] keep set ;
+
+: with-param-regs ( abi quot -- )
+ '[
+ [ int-regs init-reg-class ]
+ [ float-regs init-reg-class ] bi
+ 0 stack-params set
+ @
+ ] with-scope ; inline
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays fry kernel make math namespaces sequences
compiler.cfg compiler.cfg.instructions compiler.cfg.stacks
call
##branch begin-basic-block ; inline
+: make-kill-block ( -- )
+ basic-block get t >>kill-block? drop ;
+
: call-height ( #call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
[
[ word>> ##call ]
[ call-height adjust-d ] bi
+ make-kill-block
] emit-trivial-block ;
: begin-branch ( -- ) clone-current-height (begin-basic-block) ;
[ ] find nip [ second current-height set ] [ end-basic-block ] if* ;
: emit-conditional ( branches -- )
- ! branchies is a sequence of pairs as above
+ ! branches is a sequence of pairs as above
end-basic-block
[ merge-heights begin-basic-block ]
[ set-successors ]
compiler.cfg.predecessors
compiler.cfg.builder.blocks
compiler.cfg.stacks
-compiler.cfg.stacks.local
-compiler.alien ;
+compiler.cfg.stacks.local ;
IN: compiler.cfg.builder
! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
[ basic-block get [ emit-node ] [ drop ] if ] each ;
: begin-word ( -- )
+ make-kill-block
##prologue
##branch
begin-basic-block ;
: emit-call ( word height -- )
over loops get key?
[ drop loops get at emit-loop-call ]
- [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
- if ;
+ [
+ [
+ [ ##call ] [ adjust-d ] bi*
+ make-kill-block
+ ] emit-trivial-block
+ ] if ;
! #recursive
: recursive-height ( #recursive -- n )
! #return
: emit-return ( -- )
- ##branch begin-basic-block ##epilogue ##return ;
+ ##branch
+ begin-basic-block
+ make-kill-block
+ ##epilogue
+ ##return ;
M: #return emit-node drop emit-return ;
! #terminate
M: #terminate emit-node drop ##no-tco end-basic-block ;
-! FFI
-: return-size ( ctype -- n )
- #! Amount of space we reserve for a return value.
- {
- { [ dup c-struct? not ] [ drop 0 ] }
- { [ dup large-struct? not ] [ drop 2 cells ] }
- [ heap-size ]
- } cond ;
-
-: <alien-stack-frame> ( params -- stack-frame )
- stack-frame new
- swap
- [ return>> return-size >>return ]
- [ alien-parameters [ stack-size ] map-sum >>params ] bi
- t >>calls-vm? ;
-
-: alien-node-height ( params -- )
- [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
-
-: emit-alien-node ( node quot -- )
- [
- [ params>> dup dup <alien-stack-frame> ] dip call
- alien-node-height
- ] emit-trivial-block ; inline
-
-M: #alien-invoke emit-node
- [ ##alien-invoke ] emit-alien-node ;
-
-M: #alien-indirect emit-node
- [ ##alien-indirect ] emit-alien-node ;
-
-M: #alien-assembly emit-node
- [ ##alien-assembly ] emit-alien-node ;
-
-M: #alien-callback emit-node
- dup params>> xt>> dup
- [
- ##prologue
- [ ##alien-callback ] emit-alien-node
- ##epilogue
- ##return
- ] with-cfg-builder ;
-
! No-op nodes
M: #introduce emit-node drop ;
{ instructions vector }
{ successors vector }
{ predecessors vector }
+{ kill-block? boolean }
{ unlikely? boolean } ;
: <basic-block> ( -- bb )
compiler.utilities ;
IN: compiler.cfg.checker
-! Check invariants
-
-ERROR: bad-kill-block bb ;
-
-: check-kill-block ( bb -- )
- dup instructions>> dup penultimate ##epilogue? [
- {
- [ length 2 = ]
- [ last { [ ##return? ] [ ##jump? ] } 1|| ]
- } 1&&
- ] [ last ##branch? ] if
- [ drop ] [ bad-kill-block ] if ;
-
-ERROR: last-insn-not-a-jump bb ;
-
-: check-last-instruction ( bb -- )
- dup instructions>> last {
- [ ##branch? ]
- [ ##dispatch? ]
- [ conditional-branch-insn? ]
- [ ##no-tco? ]
- } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
-
-ERROR: bad-kill-insn bb ;
-
-: check-kill-instructions ( bb -- )
- dup instructions>> [ kill-vreg-insn? ] any?
- [ bad-kill-insn ] [ drop ] if ;
-
-: check-normal-block ( bb -- )
- [ check-last-instruction ]
- [ check-kill-instructions ]
- bi ;
-
ERROR: bad-successors ;
: check-successors ( bb -- )
dup successors>> [ predecessors>> member-eq? ] with all?
[ bad-successors ] unless ;
-: check-basic-block ( bb -- )
- [ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ]
- [ check-successors ]
- bi ;
-
: check-cfg ( cfg -- )
- [ check-basic-block ] each-basic-block ;
+ [ check-successors ] each-basic-block ;
: <dfa-worklist> ( cfg dfa -- queue )
block-order <hashed-dlist> [ push-all-front ] keep ;
-GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
-
-M: kill-block compute-in-set 3drop f ;
-
-M:: basic-block compute-in-set ( bb out-sets dfa -- set )
+:: compute-in-set ( bb out-sets dfa -- set )
! Only consider initialized sets.
- bb dfa predecessors
- [ out-sets key? ] filter
- [ out-sets at ] map
- bb dfa join-sets ;
+ bb kill-block?>> [ f ] [
+ bb dfa predecessors
+ [ out-sets key? ] filter
+ [ out-sets at ] map
+ bb dfa join-sets
+ ] if ;
:: update-in-set ( bb in-sets out-sets dfa -- ? )
bb out-sets dfa compute-in-set
bb in-sets maybe-set-at ; inline
-GENERIC# compute-out-set 2 ( bb out-sets dfa -- set )
-
-M: kill-block compute-out-set 3drop f ;
-
-M:: basic-block compute-out-set ( bb in-sets dfa -- set )
- bb in-sets at bb dfa transfer-set ;
+:: compute-out-set ( bb in-sets dfa -- set )
+ bb kill-block?>> [ f ] [ bb in-sets at bb dfa transfer-set ] if ;
:: update-out-set ( bb in-sets out-sets dfa -- ? )
bb in-sets dfa compute-out-set
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 ;
bi v+ supremum
] if-empty
node insn>> temp-vregs length +
- dup node (>>registers) ;
+ dup node registers<< ;
! Constructing fan-in trees
! 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 ;
>>instructions t >>unlikely? ;
:: insert-guard ( body check bb -- )
- bb predecessors>> check (>>predecessors)
- V{ bb body } check (>>successors)
+ bb predecessors>> check predecessors<<
+ V{ bb body } check successors<<
- V{ check } body (>>predecessors)
- V{ bb } body (>>successors)
+ V{ check } body predecessors<<
+ V{ bb } body successors<<
- V{ check body } bb (>>predecessors)
+ V{ check body } bb predecessors<<
check predecessors>> [ bb check update-successors ] each ;
: new-insn ( ... class -- insn ) f swap boa ; inline
-! Virtual CPU instructions, used by CFG and machine IRs
+! 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/tagged-rep
literal: val ;
+INSN: ##load-float
+def: dst/float-rep
+literal: val ;
+
INSN: ##load-double
def: dst/double-rep
literal: val ;
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
temp: temp/int-rep
literal: rep vcc ;
-INSN: _test-vector-branch
-literal: label
-use: src1
-temp: temp/int-rep
-literal: rep vcc ;
-
PURE-INSN: ##add-vector
def: dst
use: src1 src2
literal: offset ;
! FFI
+INSN: ##stack-frame
+literal: stack-frame ;
+
+INSN: ##unbox
+def: dst
+use: src/tagged-rep
+literal: unboxer rep ;
+
+INSN: ##store-reg-param
+use: src
+literal: reg rep ;
+
+INSN: ##store-stack-param
+use: src
+literal: n rep ;
+
+INSN: ##store-return
+use: src
+literal: rep ;
+
+INSN: ##store-struct-return
+use: src/int-rep
+literal: c-type ;
+
+INSN: ##store-long-long-return
+use: src1/int-rep src2/int-rep ;
+
+INSN: ##prepare-struct-area
+def: dst/int-rep ;
+
+INSN: ##box
+def: dst/tagged-rep
+literal: n rep boxer ;
+
+INSN: ##box-long-long
+def: dst/tagged-rep
+literal: n boxer ;
+
+INSN: ##box-small-struct
+def: dst/tagged-rep
+literal: c-type ;
+
+INSN: ##box-large-struct
+def: dst/tagged-rep
+literal: n c-type ;
+
INSN: ##alien-invoke
-literal: params stack-frame ;
+literal: symbols dll ;
+
+INSN: ##cleanup
+literal: n ;
INSN: ##alien-indirect
-literal: params stack-frame ;
+use: src/int-rep ;
INSN: ##alien-assembly
-literal: params stack-frame ;
+literal: quot ;
+
+INSN: ##save-param-reg
+literal: offset reg rep ;
+
+INSN: ##begin-callback ;
INSN: ##alien-callback
-literal: params stack-frame ;
+literal: quot ;
+
+INSN: ##end-callback ;
! Control flow
INSN: ##phi
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
INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ;
+INSN: ##restore-context
+temp: temp1/int-rep temp2/int-rep ;
+
! GC checks
INSN: ##check-nursery-branch
literal: size cc
##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: clobber-insn
##call-gc
##unary-float-function
-##binary-float-function ;
-
-! Instructions that kill all live vregs
-UNION: kill-vreg-insn
-##call
-##prologue
-##epilogue
+##binary-float-function
+##box
+##box-long-long
+##box-small-struct
+##box-large-struct
+##unbox
+##store-reg-param
+##store-return
+##store-struct-return
+##store-long-long-return
##alien-invoke
##alien-indirect
-##alien-callback ;
+##alien-assembly
+##save-param-reg
+##begin-callback
+##end-callback ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
##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 ;
byte-arrays layouts classes.tuple.private fry locals
compiler.tree.propagation.info compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stacks
-compiler.cfg.utilities compiler.cfg.builder.blocks ;
+compiler.cfg.utilities compiler.cfg.builder.blocks
+compiler.constants cpu.architecture alien.c-types ;
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )
dup node-input-infos first literal>> dup expand-(byte-array)?
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
+:: zero-byte-array ( len reg -- )
+ 0 ^^load-literal :> elt
+ reg ^^tagged>integer :> reg
+ len cell align cell /i iota [
+ [ elt reg ] dip cells byte-array-offset + int-rep f ##store-memory-imm
+ ] each ;
+
:: emit-<byte-array> ( node -- )
node node-input-infos first literal>> dup expand-<byte-array>? [
:> len
- 0 ^^load-literal :> elt
len emit-allot-byte-array :> reg
- len cell align cell /i reg elt byte-array store-initial-element
+ len reg zero-byte-array
] [ drop node emit-primitive ] if ;
[ ds-drop ds-drop ds-push ] with-branch ;
: emit-overflow-case ( word -- final-bb )
- [ ##call -1 adjust-d ] with-branch ;
+ [
+ ##call
+ -1 adjust-d
+ make-kill-block
+ ] with-branch ;
: emit-fixnum-overflow-op ( quot word -- )
! Inputs to the final instruction need to be copied because
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 ;
[ ^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 ]
: 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
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs heaps kernel namespaces sequences fry math
-math.order combinators arrays sorting compiler.utilities locals
+USING: accessors assocs binary-search combinators
+combinators.short-circuit heaps kernel namespaces
+sequences fry locals math math.order arrays sorting
+compiler.utilities
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
[ drop assign-blocked-register ]
} cond ;
-: spill-at-sync-point ( live-interval n -- ? )
- ! If the live interval has a usage at 'n', don't spill it,
- ! since this means its being defined by the sync point
- ! instruction. Output t if this is the case.
- 2dup [ uses>> ] dip '[ n>> _ = ] any?
- [ 2drop t ] [ spill f ] if ;
+: 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 ;
: handle-sync-point ( n -- )
- [ active-intervals get values ] dip
- '[ [ _ spill-at-sync-point ] filter! drop ] each ;
+ active-intervals get values
+ [ [ spill-at-sync-point ] with filter! drop ] with each ;
:: handle-progress ( n sync? -- )
n {
} cond ;
: (allocate-registers) ( -- )
- ! If a live interval begins at the same location as a sync point,
- ! process the sync point before the live interval. This ensures that the
- ! return value of C function calls doesn't get spilled and reloaded
- ! unnecessarily.
- unhandled-sync-points get unhandled-intervals get smallest-heap
+ unhandled-intervals get unhandled-sync-points get smallest-heap
dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
: finish-allocation ( -- )
] [ 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 )
+ last-use [ def-rep>> ] [ use-rep>> ] bi or ; inline
+
: assign-spill ( live-interval -- )
- dup [ vreg>> ] [ last-use rep>> ] bi
- assign-spill-slot >>spill-to drop ;
+ dup last-use-rep dup [
+ >>spill-rep
+ dup [ vreg>> ] [ spill-rep>> ] bi
+ assign-spill-slot >>spill-to drop
+ ] [ 2drop ] if ;
: spill-before ( before -- before/f )
! If the interval does not have any usages before the spill location,
! then it is the second child of an interval that was split. We reload
- ! the value and let the resolve pass insert a split later.
+ ! the value and let the resolve pass insert a spill later.
dup uses>> empty? [ drop f ] [
{
[ ]
} cleave
] if ;
+: first-use-rep ( live-interval -- rep/f )
+ first-use use-rep>> ; inline
+
: assign-reload ( live-interval -- )
- dup [ vreg>> ] [ first-use rep>> ] bi
- assign-spill-slot >>reload-from drop ;
+ dup first-use-rep dup [
+ >>reload-rep
+ dup [ vreg>> ] [ reload-rep>> ] bi
+ assign-spill-slot >>reload-from drop
+ ] [ 2drop ] if ;
: spill-after ( after -- after/f )
! If the interval has no more usages after the spill location,
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting namespaces
+USING: accessors arrays assocs binary-search combinators
+combinators.short-circuit fry hints kernel locals
+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>> _ <= ] partition ;
+:: 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 ;
: check-split ( live-interval n -- )
check-allocation? get [
[ [ start>> ] dip > [ splitting-too-early ] when ]
- [ [ end>> ] dip <= [ splitting-too-late ] when ]
+ [ [ end>> ] dip < [ splitting-too-late ] when ]
[ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
2tri
] [ 2drop ] if ; inline
live-interval n check-split
live-interval clone :> before
live-interval clone :> after
- live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
- live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
+ live-interval uses>> n split-uses before after [ uses<< ] bi-curry@ bi*
+ live-interval ranges>> n split-ranges before after [ ranges<< ] bi-curry@ bi*
before split-before
after split-after ;
init-unhandled ;
: insert-spill ( live-interval -- )
- [ reg>> ] [ last-use rep>> ] [ spill-to>> ] tri ##spill ;
+ [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill ;
: handle-spill ( live-interval -- )
dup spill-to>> [ insert-spill ] [ drop ] if ;
pending-interval-heap get (expire-old-intervals) ;
: insert-reload ( live-interval -- )
- [ reg>> ] [ first-use rep>> ] [ reload-from>> ] tri ##reload ;
-
-: insert-reload? ( live-interval -- ? )
- ! Don't insert a reload if the register will be written to
- ! before being read again.
- {
- [ reload-from>> ]
- [ first-use type>> +use+ eq? ]
- } 1&& ;
+ [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload ;
: handle-reload ( live-interval -- )
- dup insert-reload? [ insert-reload ] [ drop ] if ;
+ dup reload-from>> [ insert-reload ] [ drop ] if ;
: activate-interval ( live-interval -- )
[ add-pending ] [ handle-reload ] bi ;
{ 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 }
{ reg-class float-regs }
{ start 0 }
{ end 2 }
- { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } } }
+ { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } } }
{ ranges V{ T{ live-range f 0 2 } } }
{ spill-to T{ spill-slot f 0 } }
+ { spill-rep float-rep }
}
T{ live-interval
{ vreg 1 }
{ reg-class float-regs }
{ start 5 }
{ end 5 }
- { uses V{ T{ vreg-use f float-rep 5 } } }
+ { uses V{ T{ vreg-use f 5 f float-rep } } }
{ ranges V{ T{ live-range f 5 5 } } }
{ reload-from T{ spill-slot f 0 } }
+ { reload-rep float-rep }
}
] [
T{ live-interval
{ reg-class float-regs }
{ start 0 }
{ end 5 }
- { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
+ { 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
[
- T{ live-interval
- { vreg 2 }
- { reg-class float-regs }
- { start 0 }
- { end 1 }
- { uses V{ T{ vreg-use f float-rep 0 } } }
- { ranges V{ T{ live-range f 0 1 } } }
- { spill-to T{ spill-slot f 4 } }
- }
+ f
T{ live-interval
{ vreg 2 }
{ reg-class float-regs }
{ start 1 }
{ end 5 }
- { uses V{ T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
+ { uses V{ T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } }
{ ranges V{ T{ live-range f 1 5 } } }
{ reload-from T{ spill-slot f 4 } }
+ { reload-rep float-rep }
}
] [
T{ live-interval
{ reg-class float-regs }
{ start 0 }
{ end 5 }
- { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
+ { 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
[
{ vreg 3 }
{ reg-class float-regs }
{ start 0 }
- { end 1 }
- { uses V{ T{ vreg-use f float-rep 0 } } }
- { ranges V{ T{ live-range f 0 1 } } }
+ { end 2 }
+ { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } } }
+ { ranges V{ T{ live-range f 0 2 } } }
{ spill-to T{ spill-slot f 8 } }
+ { spill-rep float-rep }
}
+ f
+] [
T{ live-interval
{ vreg 3 }
{ reg-class float-regs }
+ { start 0 }
+ { end 5 }
+ { 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
+
+[
+ T{ live-interval
+ { vreg 4 }
+ { reg-class float-regs }
+ { start 0 }
+ { end 1 }
+ { uses V{ T{ vreg-use f 0 float-rep f } } }
+ { ranges V{ T{ live-range f 0 1 } } }
+ { spill-to T{ spill-slot f 12 } }
+ { spill-rep float-rep }
+ }
+ T{ live-interval
+ { vreg 4 }
+ { reg-class float-regs }
{ start 20 }
{ end 30 }
- { uses V{ T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } }
+ { uses V{ T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
{ ranges V{ T{ live-range f 20 30 } } }
- { reload-from T{ spill-slot f 8 } }
+ { reload-from T{ spill-slot f 12 } }
+ { reload-rep float-rep }
}
] [
T{ live-interval
- { vreg 3 }
+ { vreg 4 }
{ reg-class float-regs }
{ start 0 }
{ end 30 }
- { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } }
+ { 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
+[
+ T{ live-interval
+ { vreg 5 }
+ { reg-class float-regs }
+ { start 0 }
+ { end 1 }
+ { uses V{ T{ vreg-use f 0 float-rep f } } }
+ { ranges V{ T{ live-range f 0 1 } } }
+ { spill-to T{ spill-slot f 16 } }
+ { spill-rep float-rep }
+ }
+ T{ live-interval
+ { vreg 5 }
+ { reg-class float-regs }
+ { start 20 }
+ { end 30 }
+ { uses V{ T{ vreg-use f 20 float-rep f } T{ vreg-use f 30 f float-rep } } }
+ { ranges V{ T{ live-range f 20 30 } } }
+ }
+] [
+ T{ live-interval
+ { vreg 5 }
+ { reg-class float-regs }
+ { start 0 }
+ { end 30 }
+ { 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
+[
+ T{ live-interval
+ { vreg 6 }
+ { reg-class float-regs }
+ { start 0 }
+ { end 11 }
+ { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 10 double-rep float-rep } } }
+ { ranges V{ T{ live-range f 0 11 } } }
+ { spill-to T{ spill-slot f 24 } }
+ { spill-rep double-rep }
+ }
+ T{ live-interval
+ { vreg 6 }
+ { reg-class float-regs }
+ { start 20 }
+ { end 20 }
+ { uses V{ T{ vreg-use f 20 f double-rep } } }
+ { ranges V{ T{ live-range f 20 20 } } }
+ { reload-from T{ spill-slot f 24 } }
+ { reload-rep double-rep }
+ }
+] [
+ T{ live-interval
+ { vreg 6 }
+ { reg-class float-regs }
+ { start 0 }
+ { end 20 }
+ { 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{
{ reg 1 }
{ start 1 }
{ end 15 }
- { uses V{ T{ vreg-use f int-rep 1 } T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 7 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 15 } } }
+ { uses V{ T{ vreg-use f 1 int-rep f } T{ vreg-use f 3 f int-rep } T{ vreg-use f 7 f int-rep } T{ vreg-use f 10 f int-rep } T{ vreg-use f 15 f int-rep } } }
}
T{ live-interval
{ vreg 2 }
{ reg 2 }
{ start 3 }
{ end 8 }
- { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 4 } T{ vreg-use f int-rep 8 } } }
+ { uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 4 f int-rep } T{ vreg-use f 8 f int-rep } } }
}
T{ live-interval
{ vreg 3 }
{ reg 3 }
{ start 3 }
{ end 10 }
- { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 10 } } }
+ { uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 10 f int-rep } } }
}
}
}
{ reg-class int-regs }
{ start 5 }
{ end 5 }
- { uses V{ T{ vreg-use f int-rep 5 } } }
+ { uses V{ T{ vreg-use f 5 int-rep f } } }
}
spill-status
] unit-test
{ reg 1 }
{ start 1 }
{ end 15 }
- { uses V{ T{ vreg-use f int-rep 1 } } }
+ { uses V{ T{ vreg-use f 1 int-rep f } } }
}
T{ live-interval
{ vreg 2 }
{ reg 2 }
{ start 3 }
{ end 8 }
- { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 8 } } }
+ { uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 8 f int-rep } } }
}
}
}
{ reg-class int-regs }
{ start 5 }
{ end 5 }
- { uses V{ T{ vreg-use f int-rep 5 } } }
+ { uses V{ T{ vreg-use f 5 int-rep f } } }
}
spill-status
] unit-test
{ reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
+ { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
}
{ reg-class int-regs }
{ start 0 }
{ end 10 }
- { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } } }
+ { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
{ reg-class int-regs }
{ start 11 }
{ end 20 }
- { uses V{ T{ vreg-use f int-rep 11 } T{ vreg-use f int-rep 20 } } }
+ { uses V{ T{ vreg-use f 11 int-rep f } T{ vreg-use f 20 f int-rep } } }
{ ranges V{ T{ live-range f 11 20 } } }
}
}
{ reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
+ { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ reg-class int-regs }
{ start 30 }
{ end 60 }
- { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 60 } } }
+ { uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 60 f int-rep } } }
{ ranges V{ T{ live-range f 30 60 } } }
}
}
{ reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
+ { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ reg-class int-regs }
{ start 30 }
{ end 200 }
- { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 200 } } }
+ { uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 200 f int-rep } } }
{ ranges V{ T{ live-range f 30 200 } } }
}
}
{ reg-class int-regs }
{ start 0 }
{ end 100 }
- { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
+ { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ reg-class int-regs }
{ start 30 }
{ end 100 }
- { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 100 } } }
+ { uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 100 f int-rep } } }
{ ranges V{ T{ live-range f 30 100 } } }
}
}
{ reg-class int-regs }
{ start 0 }
{ end 20 }
- { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } }
+ { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } T{ vreg-use f 20 f int-rep } } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
{ reg-class int-regs }
{ start 0 }
{ end 20 }
- { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } }
+ { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } T{ vreg-use f 20 f int-rep } } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
{ reg-class int-regs }
{ start 4 }
{ end 8 }
- { uses V{ T{ vreg-use f int-rep 6 } } }
+ { uses V{ T{ vreg-use f 6 int-rep f } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
T{ live-interval
{ reg-class int-regs }
{ start 4 }
{ end 8 }
- { uses V{ T{ vreg-use f int-rep 8 } } }
+ { uses V{ T{ vreg-use f 8 int-rep f } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
{ reg-class int-regs }
{ start 4 }
{ end 8 }
- { uses V{ T{ vreg-use f int-rep 8 } } }
+ { uses V{ T{ vreg-use f 8 int-rep f } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
}
{ reg-class int-regs }
{ start 0 }
{ end 10 }
- { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 6 } T{ vreg-use f int-rep 10 } } }
+ { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 6 f int-rep } T{ vreg-use f 10 f int-rep } } }
{ ranges V{ T{ live-range f 0 10 } } }
}
{ reg-class int-regs }
{ start 2 }
{ end 8 }
- { uses V{ T{ vreg-use f int-rep 8 } } }
+ { uses V{ T{ vreg-use f 8 int-rep f } } }
{ ranges V{ T{ live-range f 2 8 } } }
}
}
{ start 8 }
{ end 10 }
{ ranges V{ T{ live-range f 8 10 } } }
- { uses V{ T{ vreg-use f int-rep 8 } T{ vreg-use f int-rep 10 } } }
+ { uses V{ T{ vreg-use f 8 int-rep f } T{ vreg-use f 10 f int-rep } } }
}
register-status
] unit-test
C: <live-range> live-range
-SYMBOLS: +def+ +use+ +memory+ ;
+TUPLE: vreg-use n def-rep use-rep ;
-TUPLE: vreg-use rep n type ;
-
-C: <vreg-use> vreg-use
+: <vreg-use> ( n -- vreg-use ) vreg-use new swap >>n ;
TUPLE: live-interval
vreg
-reg spill-to reload-from
+reg spill-to spill-rep reload-from reload-rep
start end ranges uses
reg-class ;
: last-use ( live-interval -- use ) uses>> last ; inline
+: new-use ( insn# uses -- use )
+ [ <vreg-use> dup ] dip push ;
+
+: last-use? ( insn# uses -- use/f )
+ [ drop f ] [ last [ n>> = ] keep and ] if-empty ;
+
+: (add-use) ( insn# live-interval -- use )
+ uses>> 2dup last-use? dup [ 2nip ] [ drop new-use ] if ;
+
GENERIC: covers? ( insn# obj -- ? )
M: f covers? 2drop f ;
covers?
] if ;
+:: find-use ( insn# live-interval -- vreg-use )
+ insn# live-interval uses>> [ n>> <=> ] with search nip
+ dup [ dup n>> insn# = [ drop f ] unless ] when ;
+
: add-new-range ( from to live-interval -- )
[ <live-range> ] dip ranges>> push ;
: shorten-range ( n live-interval -- )
dup ranges>> empty?
- [ dupd add-new-range ] [ ranges>> last (>>from) ] if ;
+ [ dupd add-new-range ] [ ranges>> last from<< ] if ;
: extend-range ( from to live-range -- )
ranges>> last
2dup extend-range?
[ extend-range ] [ add-new-range ] if ;
-:: add-use ( rep n type live-interval -- )
- type +memory+ eq? [
- rep n type <vreg-use>
- live-interval uses>> push
- ] unless ;
-
: <live-interval> ( vreg reg-class -- live-interval )
\ live-interval new
V{ } clone >>uses
M: insn compute-live-intervals* drop ;
-:: record-def ( vreg n type -- )
- vreg rep-of :> rep
+:: record-def ( vreg n -- )
vreg live-interval :> live-interval
n live-interval shorten-range
- rep n type live-interval add-use ;
+ n live-interval (add-use) vreg rep-of >>def-rep drop ;
-:: record-use ( vreg n type -- )
- vreg rep-of :> rep
+:: record-use ( vreg n -- )
vreg live-interval :> live-interval
from get n live-interval add-range
- rep n type live-interval add-use ;
+ n live-interval (add-use) vreg rep-of >>use-rep drop ;
:: record-temp ( vreg n -- )
- vreg rep-of :> rep
vreg live-interval :> live-interval
n n live-interval add-range
- rep n +def+ live-interval add-use ;
-
-M:: vreg-insn compute-live-intervals* ( insn -- )
- insn insn#>> :> n
-
- insn defs-vreg [ n +def+ record-def ] when*
- insn uses-vregs [ n +use+ record-use ] each
- insn temp-vregs [ n record-temp ] each ;
+ n live-interval (add-use) vreg rep-of >>def-rep drop ;
-M:: clobber-insn compute-live-intervals* ( insn -- )
- insn insn#>> :> n
-
- insn defs-vreg [ n +use+ record-def ] when*
- insn uses-vregs [ n +memory+ record-use ] each
- insn temp-vregs [ n record-temp ] each ;
+M: vreg-insn compute-live-intervals* ( insn -- )
+ dup insn#>>
+ [ [ defs-vreg ] dip '[ _ record-def ] when* ]
+ [ [ uses-vregs ] dip '[ _ record-use ] each ]
+ [ [ temp-vregs ] dip '[ _ record-temp ] each ]
+ 2tri ;
: handle-live-out ( bb -- )
live-out dup assoc-empty? [ 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 ;
-! When a float is unboxed, we replace the ##load-reference with a ##load-double
-! if the architecture supports it
+! When a constant float is unboxed, we replace the
+! ##load-reference with a ##load-float or ##load-double if the
+! architecture supports it
+: convert-to-load-float? ( insn -- ? )
+ {
+ [ drop fused-unboxing? ]
+ [ dst>> rep-of float-rep? ]
+ [ obj>> float? ]
+ } 1&& ;
+
: convert-to-load-double? ( insn -- ? )
{
[ drop fused-unboxing? ]
M: ##load-reference optimize-insn
{
+ {
+ [ dup convert-to-load-float? ]
+ [ [ dst>> ] [ obj>> ] bi ##load-float here ]
+ }
{
[ dup convert-to-load-double? ]
[ [ dst>> ] [ obj>> ] bi ##load-double here ]
[ 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
} 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 -- )
- dup kill-block? [ drop ] [
- [
- [
- H{ } clone alternatives set
- [ conversions-for-insn ] each
- ] V{ } make
- ] change-instructions drop
- ] if ;
+: conversions-for-block ( insns -- insns )
+ [
+ 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 -- )
[ reverse-post-order ] dip each ; inline
: optimize-basic-block ( bb quot -- )
- [ drop basic-block set ]
- [ change-instructions drop ] 2bi ; inline
+ over kill-block?>> [ 2drop ] [
+ over basic-block set
+ change-instructions drop
+ ] if ; inline
: 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, 2010 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs compiler.cfg.def-use
-compiler.cfg.dependence compiler.cfg.instructions
-compiler.cfg.liveness compiler.cfg.rpo cpu.architecture fry
-kernel locals make math namespaces sequences sets ;
+USING: accessors arrays assocs fry kernel locals make math
+namespaces sequences sets combinators.short-circuit
+compiler.cfg.def-use compiler.cfg.dependence
+compiler.cfg.instructions compiler.cfg.liveness compiler.cfg.rpo
+cpu.architecture ;
IN: compiler.cfg.scheduling
! Instruction scheduling to reduce register pressure, from:
: schedule-instructions ( cfg -- cfg' )
dup [
- dup might-spill?
- [ schedule-block ]
- [ drop ] if
+ dup { [ kill-block?>> not ] [ might-spill? ] } 1&&
+ [ schedule-block ] [ drop ] if
] each-basic-block ;
-! 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 ;
: try-to-coalesce ( dst src -- ) 2array copies get push ;
-M: insn prepare-insn
+M: insn prepare-insn drop ;
+
+M: vreg-insn prepare-insn
[ temp-vregs [ leader-map get conjoin ] each ]
[
[ defs-vreg ] [ uses-vregs ] bi
-! 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-edge ( from to -- )
! If both blocks are subroutine calls, don't bother
! computing anything.
- 2dup [ kill-block? ] both? [ 2drop ] [
+ 2dup [ kill-block?>> ] both? [ 2drop ] [
2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make
[ 2drop ] [ insert-basic-block ] if-empty
] if ;
compiler.cfg.rpo compiler.utilities ;
IN: compiler.cfg.utilities
-PREDICATE: kill-block < basic-block
- instructions>> {
- [ length 2 >= ]
- [ penultimate kill-vreg-insn? ]
- } 1&& ;
-
: back-edge? ( from to -- ? )
[ number>> ] bi@ >= ;
:: insert-basic-block ( from to insns -- )
! Insert basic block on the edge between 'from' and 'to'.
<basic-block> :> bb
- insns V{ } like bb (>>instructions)
- V{ from } bb (>>predecessors)
- V{ to } bb (>>successors)
+ insns V{ } like bb instructions<<
+ V{ from } bb predecessors<<
+ V{ to } bb successors<<
from to bb update-predecessors
from to bb update-successors ;
! 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>insn ##load-integer? ] [ t >test-imm ] }
+ { [ dup src2>> vreg>insn ##load-integer? ] [ f >test-imm ] }
+ { [ dup diagonal? not ] [ drop f ] }
+ { [ dup src1>> vreg>insn ##and? ] [ simplify-test ] }
+ { [ dup src1>> vreg>insn ##and-imm? ] [ simplify-test-imm ] }
+ [ drop f ]
+ } cond ;
+
+M: ##test-branch rewrite
+ {
+ { [ dup src1>> vreg>insn ##load-integer? ] [ t >test-imm-branch ] }
+ { [ dup src2>> vreg>insn ##load-integer? ] [ f >test-imm-branch ] }
+ { [ dup diagonal? not ] [ drop f ] }
+ { [ dup src1>> vreg>insn ##and? ] [ simplify-test-branch ] }
+ { [ dup src1>> vreg>insn ##and-imm? ] [ simplify-test-imm-branch ] }
+ [ 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 ;
[ ##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
+
+! 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
[
{
+++ /dev/null
-! Copyright (C) 2008, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.complex alien.c-types
-alien.libraries alien.private alien.strings arrays
-classes.struct combinators compiler.alien
-compiler.cfg.instructions compiler.codegen
-compiler.codegen.fixup compiler.errors compiler.utilities
-cpu.architecture fry kernel layouts libc locals make math
-math.order math.parser namespaces quotations sequences strings
-system ;
-FROM: compiler.errors => no-such-symbol ;
-IN: compiler.codegen.alien
-
-! ##alien-invoke
-GENERIC: next-fastcall-param ( rep -- )
-
-: ?dummy-stack-params ( rep -- )
- dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
-
-: ?dummy-int-params ( rep -- )
- dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
-
-: ?dummy-fp-params ( rep -- )
- drop dummy-fp-params? [ float-regs inc ] when ;
-
-M: int-rep next-fastcall-param
- int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
-
-M: float-rep next-fastcall-param
- float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-
-M: double-rep next-fastcall-param
- float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-
-GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
-
-M: stack-params reg-class-full? 2drop t ;
-
-M: reg-class reg-class-full?
- [ get ] swap '[ _ param-regs length ] bi >= ;
-
-: alloc-stack-param ( rep -- n reg-class rep )
- stack-params get
- [ rep-size cell align stack-params +@ ] dip
- stack-params dup ;
-
-: alloc-fastcall-param ( rep -- n reg-class rep )
- [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
-
-:: alloc-parameter ( rep abi -- reg rep )
- rep dup reg-class-of abi reg-class-full?
- [ alloc-stack-param ] [ alloc-fastcall-param ] if
- [ abi param-reg ] dip ;
-
-: reset-fastcall-counts ( -- )
- { int-regs float-regs stack-params } [ 0 swap set ] each ;
-
-: with-param-regs ( quot -- )
- #! In quot you can call alloc-parameter
- [ reset-fastcall-counts call ] with-scope ; inline
-
-:: move-parameters ( params word -- )
- #! Moves values from C stack to registers (if word is
- #! %load-param-reg) and registers to C stack (if word is
- #! %save-param-reg).
- 0 params alien-parameters flatten-c-types [
- [ params abi>> alloc-parameter word execute( offset reg rep -- ) ]
- [ rep-size cell align + ]
- 2bi
- ] each drop ; inline
-
-: parameter-offsets ( types -- offsets )
- 0 [ stack-size + ] accumulate nip ;
-
-: each-parameter ( parameters quot -- )
- [ [ parameter-offsets ] keep ] dip 2each ; inline
-
-: reverse-each-parameter ( parameters quot -- )
- [ [ parameter-offsets ] keep ] dip 2reverse-each ; inline
-
-: prepare-unbox-parameters ( parameters -- offsets types indices )
- [ parameter-offsets ] [ ] [ length iota <reversed> ] tri ;
-
-: unbox-parameters ( offset node -- )
- parameters>> swap
- '[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
- [ length neg %inc-d ]
- bi ;
-
-: prepare-box-struct ( node -- offset )
- #! Return offset on C stack where to store unboxed
- #! parameters. If the C function is returning a structure,
- #! the first parameter is an implicit target area pointer,
- #! so we need to use a different offset.
- return>> large-struct?
- [ %prepare-box-struct cell ] [ 0 ] if ;
-
-: objects>registers ( params -- )
- #! Generate code for unboxing a list of C types, then
- #! generate code for moving these parameters to registers on
- #! architectures where parameters are passed in registers.
- [
- [ prepare-box-struct ] keep
- [ unbox-parameters ] keep
- \ %load-param-reg move-parameters
- ] with-param-regs ;
-
-: box-return* ( node -- )
- return>> [ ] [ box-return %push-stack ] 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 ] [ compiling-word get no-such-symbol ] if
- ] [
- dll-path compiling-word get 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 ;
-
-M: ##alien-invoke generate-insn
- params>>
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Call function
- dup alien-invoke-dlsym %alien-invoke
- ! Box return value
- dup %cleanup
- box-return* ;
-
-M: ##alien-assembly generate-insn
- params>>
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Generate assembly
- dup quot>> call( -- )
- ! Box return value
- box-return* ;
-
-! ##alien-indirect
-M: ##alien-indirect generate-insn
- params>>
- ! Save alien at top of stack to temporary storage
- %prepare-alien-indirect
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Call alien in temporary storage
- %alien-indirect
- ! Box return value
- dup %cleanup
- box-return* ;
-
-! ##alien-callback
-: box-parameters ( params -- )
- alien-parameters [ box-parameter %push-context-stack ] each-parameter ;
-
-: registers>objects ( node -- )
- ! Generate code for boxing input parameters in a callback.
- [
- dup \ %save-param-reg move-parameters
- %begin-callback
- box-parameters
- ] with-param-regs ;
-
-: callback-return-quot ( ctype -- quot )
- return>> {
- { [ dup void? ] [ drop [ ] ] }
- { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
- [ c-type c-type-unboxer-quot ]
- } cond ;
-
-: callback-prep-quot ( params -- quot )
- parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
-
-: wrap-callback-quot ( params -- quot )
- [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
- yield-hook get
- '[ _ _ do-callback ]
- >quotation ;
-
-M: ##alien-callback generate-insn
- params>>
- [ registers>objects ]
- [ wrap-callback-quot %alien-callback ]
- [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;
+++ /dev/null
-Slava Pestov
compiler.constants words ;
IN: compiler.codegen.tests
-[ ] [ gensym [ ] with-fixup drop ] unit-test
-[ ] [ gensym [ \ + %call ] with-fixup drop ] unit-test
+[ ] [ [ ] with-fixup drop ] unit-test
+[ ] [ [ \ + %call ] with-fixup drop ] unit-test
-[ ] [ gensym [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
-[ ] [ gensym [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
+[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
+[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
! Error checking
-[ gensym [ <label> dup define-label %jump-label ] with-fixup ] must-fail
-[ gensym [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
-[ gensym [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail
+[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail
] tri ;
: generate ( cfg -- code )
- dup label>> [
+ [
H{ } clone labels set
linearization-order
[ number-blocks ] [ [ generate-block ] each ] bi
! Special cases
M: ##no-tco generate-insn drop ;
+M: ##stack-frame generate-insn drop ;
+
M: ##prologue generate-insn
drop
cfg get stack-frame>>
CODEGEN: ##load-integer %load-immediate
CODEGEN: ##load-tagged %load-immediate
CODEGEN: ##load-reference %load-reference
+CODEGEN: ##load-float %load-float
CODEGEN: ##load-double %load-double
CODEGEN: ##load-vector %load-vector
CODEGEN: ##peek %peek
CODEGEN: ##gather-vector-2 %gather-vector-2
CODEGEN: ##gather-vector-4 %gather-vector-4
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
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
+CODEGEN: ##restore-context %restore-context
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: ##alien-global %alien-global
CODEGEN: ##spill %spill
CODEGEN: ##reload %reload
+! Conditional branches
<<
SYNTAX: CONDITIONAL:
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
CONDITIONAL: ##fixnum-add %fixnum-add
CONDITIONAL: ##fixnum-sub %fixnum-sub
CONDITIONAL: ##fixnum-mul %fixnum-mul
+
+! FFI
+CODEGEN: ##unbox %unbox
+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: ##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: ##alien-invoke %alien-invoke
+CODEGEN: ##cleanup %cleanup
+CODEGEN: ##alien-indirect %alien-indirect
+CODEGEN: ##begin-callback %begin-callback
+CODEGEN: ##alien-callback %alien-callback
+CODEGEN: ##end-callback %end-callback
+
+M: ##alien-assembly generate-insn quot>> call( -- ) ;
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
-: push-double ( value vector -- )
- [ length ] [ B{ 0 0 0 0 0 0 0 0 } swap push-all ] [ underlying>> ] tri
- swap set-alien-double ;
-
-! Owner
-SYMBOL: compiling-word
-
! Parameter table
SYMBOL: parameter-table
[ [ compute-relative-label ] map concat ]
bi* ;
-: init-fixup ( word -- )
- compiling-word set
+: init-fixup ( -- )
V{ } clone parameter-table set
V{ } clone literal-table set
V{ } clone label-table set
: align-code ( n -- )
alignment (align-code) ;
-GENERIC# emit-data 1 ( obj label -- )
-
-M: float emit-data
- 8 align-code
- resolve-label
- building get push-double ;
-
-M: byte-array emit-data
- 16 align-code
+: emit-data ( obj label -- )
+ over length align-code
resolve-label
building get push-all ;
: emit-binary-literals ( -- )
binary-literal-table get [ emit-data ] assoc-each ;
-: with-fixup ( word quot -- code )
+: with-fixup ( quot -- code )
'[
init-fixup
@
compiler.cfg
compiler.cfg.builder
+compiler.cfg.builder.alien
compiler.cfg.optimizer
compiler.cfg.finalization
-compiler.codegen
-compiler.codegen.alien ;
+compiler.codegen ;
IN: compiler
SYMBOL: compiled
{ 1 1 } [ indirect-test-1 ] must-infer-as
-[ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
-
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
[ 100 ] [ "p" get ?promise ] unit-test
-! Regression: calling an undefined function would raise a protection fault
-FUNCTION: void this_does_not_exist ( ) ;
-
-[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
-
! More alien-assembly tests are in cpu.* vocabs
: assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
] when ;
[ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test
+
+! Alias analysis bug
+[ t ] [
+ [
+ 10 10 <byte-array> [ <displaced-alien> underlying>> ] keep eq?
+ ] compile-call
+] unit-test
--- /dev/null
+USING: tools.test namespaces assocs alien.syntax kernel\r
+compiler.errors accessors alien ;\r
+FROM: alien.libraries => add-library ;\r
+IN: compiler.tests.linkage-errors\r
+\r
+! Regression: calling an undefined function would raise a protection fault\r
+FUNCTION: void this_does_not_exist ( ) ;\r
+\r
+[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with\r
+\r
+[ T{ no-such-symbol { name "this_does_not_exist" } } ]\r
+[ \ this_does_not_exist linkage-errors get at error>> ] unit-test\r
+\r
+<< "no_such_library" "no_such_library" cdecl add-library >>\r
+\r
+LIBRARY: no_such_library\r
+\r
+FUNCTION: void no_such_function ( ) ;\r
+\r
+[ T{ no-such-library { name "no_such_library" } } ]\r
+[ \ no_such_function linkage-errors get at error>> ] unit-test\r
[ 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
: update-inline-cache ( word/quot ic -- )
[ effect-counter ] dip
- [ (>>value) ] [ (>>counter) ] bi-curry bi* ; inline
+ [ value<< ] [ counter<< ] bi-curry bi* ; inline
SINGLETON: +unknown+
: save-effect ( effect quot -- )
[ effect-counter ] dip
- [ (>>cached-effect) ] [ (>>cache-counter) ] bi-curry bi* ;
+ [ cached-effect<< ] [ cache-counter<< ] bi-curry bi* ;
M: quotation cached-effect
dup cached-effect-valid?
word already-inlined? [ f ] [
#call word splicing-body [
word add-to-history
- #call (>>body)
+ #call body<<
#call propagate-body
] [ f ] if*
] if ;
2drop alien \ f class-or <class-info>
] "outputs" set-word-prop
+\ <displaced-alien> [
+ [ interval>> 0 swap interval-contains? ] dip
+ class>> alien class-or alien ? <class-info>
+] "outputs" set-word-prop
+
{ <tuple> <tuple-boa> } [
[
literal>> dup array? [ first ] [ drop tuple ] if <class-info>
[ ] [ "IN: compiler.tree.propagation.tests TUPLE: foo baz bar ;" eval( -- ) ] unit-test
[ 3 ] [ "USE: kernel IN: compiler.tree.propagation.tests 2 3 foo boa baz" eval( -- x ) ] unit-test
+
+! Non-zero displacement for <displaced-alien> restricts the output type
+[ t ] [
+ [ { byte-array } declare <displaced-alien> ] final-classes
+ first byte-array alien class-or class=
+] unit-test
+
+[ V{ alien } ] [
+ [ { alien } declare <displaced-alien> ] final-classes
+] unit-test
+
+[ t ] [
+ [ { POSTPONE: f } declare <displaced-alien> ] final-classes
+ first \ f alien class-or class=
+] unit-test
+
+[ V{ alien } ] [
+ [ { byte-array } declare [ 10 bitand 2 + ] dip <displaced-alien> ] final-classes
+] unit-test
(simd-hlshift)
(simd-hrshift)
(simd-vshuffle-elements)
+ (simd-vshuffle2-elements)
(simd-vshuffle-bytes)
(simd-vmerge-head)
(simd-vmerge-tail)
] with-scope ;
M: #return-recursive node-call-graph
- nip dup label>> (>>return) ;
+ nip dup label>> return<< ;
M: #call-recursive node-call-graph
[ dup label>> call-site boa ] keep
tdesc\r
[\r
code next-size\r
- [ code (>>value) code clone quot call code next-code ] each\r
+ [ code value<< code clone quot call code next-code ] each\r
] each ; inline\r
\r
: update-reverse-table ( huffman-code n table -- )\r
size>> h>> ; inline
: set-CGRect-x ( x CGRect -- )
- origin>> (>>x) ; inline
+ origin>> x<< ; inline
: set-CGRect-y ( y CGRect -- )
- origin>> (>>y) ; inline
+ origin>> y<< ; inline
: set-CGRect-w ( w CGRect -- )
- size>> (>>w) ; inline
+ size>> w<< ; inline
: set-CGRect-h ( h CGRect -- )
- size>> (>>h) ; inline
+ size>> h<< ; inline
: <CGRect> ( x y w h -- rect )
[ CGPoint <struct-boa> ] [ CGSize <struct-boa> ] 2bi*
HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
+HOOK: %load-float cpu ( reg val -- )
HOOK: %load-double cpu ( reg val -- )
HOOK: %load-vector cpu ( reg val rep -- )
HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 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: %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 %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 -- )
M: stack-params param-reg 2drop ;
-! Does this architecture support %load-double, %load-vector and
-! objects in %compare-imm?
+! Does this architecture support %load-float, %load-double,
+! and %load-vector?
HOOK: fused-unboxing? cpu ( -- ? )
! Can this value be an immediate operand for %add-imm, %sub-imm,
: immediate-shift-count? ( n -- ? )
0 cell-bits 1 - between? ;
-! What c-type describes the implicit struct return pointer for
-! large structs?
-HOOK: struct-return-pointer-type cpu ( -- c-type )
-
! Is this structure small enough to be returned in registers?
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
! If t, all int parameters are shadowed by dummy FP parameters
HOOK: dummy-fp-params? cpu ( -- ? )
-! Load a value (from the data stack in the ds register).
-! The value is then passed as a parameter to a VM to_*() function
-HOOK: %pop-stack cpu ( n -- )
+! If t, long longs are never passed in param regs
+HOOK: long-long-on-stack? cpu ( -- ? )
-! Store a value (to the data stack in the VM's current context)
-! The value is passed to a VM to_*() function -- used for
-! callback returns
-HOOK: %pop-context-stack cpu ( -- )
+! If t, floats are never passed in param regs
+HOOK: float-on-stack? cpu ( -- ? )
-! Store a value (to the data stack in the ds register).
-! The value was returned from a VM from_*() function
-HOOK: %push-stack cpu ( -- )
+! If t, the struct return pointer is never passed in a param reg
+HOOK: struct-return-on-stack? cpu ( -- ? )
-! Store a value (to the data stack in the VM's current context)
-! The value is returned from a VM from_*() function -- used for
-! callback parameters
-HOOK: %push-context-stack cpu ( -- )
+! Call a function to convert a tagged pointer into a value that
+! can be passed to a C function, or returned from a callback
+HOOK: %unbox cpu ( dst src func rep -- )
-! Call a function to convert a tagged pointer returned by
-! %pop-stack or %pop-context-stack into a value that can be
-! passed to a C function, or returned from a callback
-HOOK: %unbox cpu ( n rep func -- )
+HOOK: %store-reg-param cpu ( src reg rep -- )
-HOOK: %unbox-long-long cpu ( n func -- )
+HOOK: %store-stack-param cpu ( src n rep -- )
-HOOK: %unbox-small-struct cpu ( c-type -- )
+HOOK: %store-return cpu ( src rep -- )
-HOOK: %unbox-large-struct cpu ( n c-type -- )
+HOOK: %store-struct-return cpu ( src reps -- )
+
+HOOK: %store-long-long-return cpu ( src1 src2 -- )
+
+HOOK: %prepare-struct-area cpu ( dst -- )
! 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 by %push-stack or
-! %push-context-stack
-HOOK: %box cpu ( n rep func -- )
-
-HOOK: %box-long-long cpu ( n func -- )
+! which is then pushed on the data stack
+HOOK: %box cpu ( dst n rep func -- )
-HOOK: %prepare-box-struct cpu ( -- )
+HOOK: %box-long-long cpu ( dst n func -- )
-HOOK: %box-small-struct cpu ( c-type -- )
+HOOK: %box-small-struct cpu ( dst c-type -- )
-HOOK: %box-large-struct cpu ( n c-type -- )
+HOOK: %box-large-struct cpu ( dst n c-type -- )
HOOK: %save-param-reg cpu ( stack reg rep -- )
-HOOK: %load-param-reg cpu ( stack reg rep -- )
-
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 ( params -- )
+HOOK: %cleanup cpu ( n -- )
-M: object %cleanup ( params -- ) drop ;
+M: object %cleanup ( n -- ) drop ;
-HOOK: %prepare-alien-indirect cpu ( -- )
-
-HOOK: %alien-indirect cpu ( -- )
+HOOK: %alien-indirect cpu ( src -- )
HOOK: %begin-callback cpu ( -- )
HOOK: %end-callback cpu ( -- )
-HOOK: %end-callback-value cpu ( c-type -- )
-
-HOOK: stack-cleanup cpu ( params -- n )
+HOOK: stack-cleanup cpu ( stack-size return abi -- n )
-M: object stack-cleanup drop 0 ;
+M: object stack-cleanup 3drop 0 ;
IN: cpu.ppc.linux
<<
-t "longlong" c-type (>>stack-align?)
-t "ulonglong" c-type (>>stack-align?)
+t "longlong" c-type stack-align?<<
+t "ulonglong" c-type stack-align?<<
>>
M: linux reserved-area-size 2 cells ;
USING: accessors assocs sequences kernel combinators
classes.algebra byte-arrays make math math.order math.ranges
system namespaces locals layouts words alien alien.accessors
-alien.c-types alien.complex alien.data literals cpu.architecture
-cpu.ppc.assembler cpu.ppc.assembler.backend
+alien.c-types alien.complex alien.data alien.libraries
+literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.comparisons compiler.codegen.fixup
compiler.cfg.intrinsics compiler.cfg.stack-frame
"end" resolve-label
] with-scope ;
+: (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type )
+ [ [ 0 assert= ] bi@ swapd ] 2dip ; inline
+
M: ppc %load-memory-imm ( dst base offset rep c-type -- )
[
{
{ c:uchar [ LBZ ] }
{ c:short [ LHA ] }
{ c:ushort [ LHZ ] }
+ { c:int [ LWZ ] }
+ { c:uint [ LWZ ] }
} case
] [
{
} case
] ?if ;
-: (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type )
- [ [ 0 assert= ] bi@ swapd ] 2dip ; inline
-
M: ppc %load-memory ( dst base displacement scale offset rep c-type -- )
(%memory) [
{
{ c:uchar [ LBZX ] }
{ c:short [ LHAX ] }
{ c:ushort [ LHZX ] }
+ { c:int [ LWZX ] }
+ { c:uint [ LWZX ] }
} case
] [
{
{ c:uchar [ STB ] }
{ c:short [ STH ] }
{ c:ushort [ STH ] }
+ { c:int [ STW ] }
+ { c:uint [ STW ] }
} case
] [
{
{ c:uchar [ STBX ] }
{ c:short [ STHX ] }
{ c:ushort [ STHX ] }
+ { c:int [ STWX ] }
+ { c:uint [ STWX ] }
} case
] [
{
M:: ppc %load-param-reg ( stack reg rep -- )
reg stack local@ rep load-from-frame ;
-M: ppc %pop-stack ( n -- )
- [ 3 ] dip <ds-loc> loc>operand LWZ ;
-
-M: ppc %push-stack ( -- )
- ds-reg ds-reg 4 ADDI
- int-regs return-reg ds-reg 0 STW ;
-
-M: ppc %push-context-stack ( -- )
- 11 %context
- 12 11 "datastack" context-field-offset LWZ
- 12 12 4 ADDI
- 12 11 "datastack" context-field-offset STW
- int-regs return-reg 12 0 STW ;
-
-M: ppc %pop-context-stack ( -- )
- 11 %context
- 12 11 "datastack" context-field-offset LWZ
- int-regs return-reg 12 0 LWZ
- 12 12 4 SUBI
- 12 11 "datastack" context-field-offset STW ;
-
-M: ppc %unbox ( n rep func -- )
- ! Value must be in r3
- 4 %load-vm-addr
- ! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- over [ [ reg-class-of return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+GENERIC: load-param ( reg src -- )
+
+M: integer load-param int-rep %copy ;
-M: ppc %unbox-long-long ( n func -- )
+M: spill-slot load-param [ 1 ] dip n>> spill@ LWZ ;
+
+GENERIC: store-param ( reg dst -- )
+
+M: integer store-param swap int-rep %copy ;
+
+M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
+
+:: call-unbox-func ( src func -- )
+ 3 src load-param
4 %load-vm-addr
- ! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- [
- [ [ 3 1 ] dip local@ STW ]
- [ [ 4 1 ] dip cell + local@ STW ] bi
- ] when* ;
+ func f %alien-invoke ;
-M: ppc %unbox-large-struct ( n c-type -- )
- ! Value must be in r3
- ! Compute destination address and load struct size
- [ [ 4 1 ] dip local@ ADDI ] [ heap-size 5 LI ] bi*
- 6 %load-vm-addr
- ! Call the function
- "to_value_struct" f %alien-invoke ;
+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* ;
-M:: ppc %box ( n rep func -- )
- ! If the source is a stack location, load it into freg #0.
- ! If the source is f, then we assume the value is already in
- ! freg #0.
+M:: ppc %unbox-long-long ( src n func -- )
+ src func call-unbox-func
+ ! Store the return value on the C stack
+ n [
+ 3 1 n local@ STW
+ 4 1 n cell + local@ STW
+ ] when ;
+
+M:: ppc %unbox-large-struct ( src n c-type -- )
+ 4 src load-param
+ 3 1 n local@ ADDI
+ c-type heap-size 5 LI
+ "memcpy" "libc" load-library %alien-invoke ;
+
+M:: ppc %box ( dst n rep func -- )
n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
rep double-rep? 5 4 ? %load-vm-addr
- func f %alien-invoke ;
+ func f %alien-invoke
+ 3 dst store-param ;
-M: ppc %box-long-long ( n func -- )
- [
- [
- [ [ 3 1 ] dip local@ LWZ ]
- [ [ 4 1 ] dip cell + local@ LWZ ] bi
- ] when*
- 5 %load-vm-addr
- ] dip f %alien-invoke ;
+M:: ppc %box-long-long ( dst n func -- )
+ n [
+ 3 1 n local@ LWZ
+ 4 1 n cell + local@ LWZ
+ ] when
+ 5 %load-vm-addr
+ func f %alien-invoke
+ 3 dst store-param ;
: struct-return@ ( n -- n )
[ stack-frame get params>> ] unless* local@ ;
3 1 f struct-return@ ADDI
3 1 0 local@ STW ;
-M: ppc %box-large-struct ( n c-type -- )
+M:: ppc %box-large-struct ( dst n c-type -- )
! If n = f, then we're boxing a returned struct
! Compute destination address and load struct size
- [ [ 3 1 ] dip struct-return@ ADDI ] [ heap-size 4 LI ] bi*
+ 3 1 n struct-return@ ADDI
+ c-type heap-size 4 LI
5 %load-vm-addr
! Call the function
- "from_value_struct" f %alien-invoke ;
+ "from_value_struct" f %alien-invoke
+ 3 dst store-param ;
M:: ppc %restore-context ( temp1 temp2 -- )
temp1 %context
M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
-M: ppc %prepare-alien-indirect ( -- )
- 3 ds-reg 0 LWZ
- ds-reg ds-reg 4 SUBI
- 4 %load-vm-addr
- "pinned_alien_offset" f %alien-invoke
- 16 3 MR ;
-
-M: ppc %alien-indirect ( -- )
- 16 MTLR BLRL ;
+M: ppc %alien-indirect ( src -- )
+ [ 11 ] dip load-param 11 MTLR BLRL ;
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
M: ppc immediate-store? drop f ;
-M: ppc struct-return-pointer-type void* ;
-
M: ppc return-struct-in-registers? ( c-type -- ? )
c-type return-in-registers?>> ;
-M: ppc %box-small-struct ( c-type -- )
+M:: ppc %box-small-struct ( dst c-type -- )
#! Box a <= 16-byte struct returned in r3:r4:r5:r6
- heap-size 7 LI
+ c-type heap-size 7 LI
8 %load-vm-addr
- "from_medium_struct" f %alien-invoke ;
+ "from_medium_struct" f %alien-invoke
+ 3 dst store-param ;
: %unbox-struct-1 ( -- )
! Alien must be in r3.
- 4 %load-vm-addr
- "alien_offset" f %alien-invoke
3 3 0 LWZ ;
: %unbox-struct-2 ( -- )
! Alien must be in r3.
- 4 %load-vm-addr
- "alien_offset" f %alien-invoke
4 3 4 LWZ
3 3 0 LWZ ;
: %unbox-struct-4 ( -- )
! Alien must be in r3.
- 4 %load-vm-addr
- "alien_offset" f %alien-invoke
6 3 12 LWZ
5 3 8 LWZ
4 3 4 LWZ
3 3 0 LWZ ;
+M:: ppc %unbox-small-struct ( src c-type -- )
+ src 3 load-param
+ c-type heap-size {
+ { [ dup 4 <= ] [ drop %unbox-struct-1 ] }
+ { [ dup 8 <= ] [ drop %unbox-struct-2 ] }
+ { [ dup 16 <= ] [ drop %unbox-struct-4 ] }
+ } cond ;
+
M: ppc %begin-callback ( -- )
3 %load-vm-addr
"begin_callback" f %alien-invoke ;
M: ppc %alien-callback ( quot -- )
- 3 4 %restore-context
3 swap %load-reference
4 3 quot-entry-point-offset LWZ
4 MTLR
- BLRL
- 3 4 %save-context ;
+ BLRL ;
M: ppc %end-callback ( -- )
3 %load-vm-addr
"end_callback" f %alien-invoke ;
-M: ppc %end-callback-value ( ctype -- )
- ! Save top of data stack
- 16 ds-reg 0 LWZ
- %end-callback
- ! Restore top of data stack
- 3 16 MR
- ! Unbox former top of data stack to return registers
- unbox-return ;
-
-M: ppc %unbox-small-struct ( size -- )
- heap-size cell align cell /i {
- { 1 [ %unbox-struct-1 ] }
- { 2 [ %unbox-struct-2 ] }
- { 4 [ %unbox-struct-4 ] }
- } case ;
-
enable-float-functions
USE: vocabs.loader
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
-command-line make words compiler compiler.units
-compiler.constants compiler.alien compiler.codegen
-compiler.codegen.alien 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 ;
+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 ;
FROM: layouts => cell ;
IN: cpu.x86.32
M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
-M: x86.32 %load-double ( dst val -- )
- [ 0 [] MOVSD ] dip rc-absolute rel-binary-literal ;
-
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 ;
os { linux netbsd solaris } member? not
and or ;
-: struct-return@ ( n -- operand )
- [ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
-
-! On x86, parameters are usually never passed in registers, except with Microsoft's
-! "thiscall" and "fastcall" abis
+! 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 } ] }
+ { thiscall [ { ECX } ] }
{ fastcall [ { ECX EDX } ] }
[ drop { } ]
} case ;
M: int-rep load-return-reg drop EAX swap MOV ;
M: int-rep store-return-reg drop EAX MOV ;
-M: float-rep load-return-reg drop FLDS ;
-M: float-rep store-return-reg drop FSTPS ;
-
-M: double-rep load-return-reg drop FLDL ;
-M: double-rep store-return-reg drop FSTPL ;
+:: load-float-return ( src x87-insn sse-insn -- )
+ src register? [
+ ESP 4 SUB
+ ESP [] src sse-insn execute
+ ESP [] x87-insn execute
+ ESP 4 ADD
+ ] [
+ src x87-insn execute
+ ] if ; inline
+
+:: store-float-return ( dst x87-insn sse-insn -- )
+ dst register? [
+ ESP 4 SUB
+ ESP [] x87-insn execute
+ dst ESP [] sse-insn execute
+ ESP 4 ADD
+ ] [
+ dst x87-insn execute
+ ] if ; inline
+
+M: float-rep load-return-reg
+ drop \ FLDS \ MOVSS load-float-return ;
+
+M: float-rep store-return-reg
+ drop \ FSTPS \ MOVSS store-float-return ;
+
+M: double-rep load-return-reg
+ drop \ FLDL \ MOVSD load-float-return ;
+
+M: double-rep store-return-reg
+ drop \ FSTPL \ MOVSD store-float-return ;
M: x86.32 %prologue ( n -- )
dup PUSH
M: x86.32 %prepare-jump
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
+:: call-unbox-func ( src func -- )
+ EAX src tagged-rep %copy
+ 4 save-vm-ptr
+ 0 stack@ EAX MOV
+ func f %alien-invoke ;
+
+M:: x86.32 %unbox ( dst src func rep -- )
+ src func call-unbox-func
+ dst ?spill-slot rep store-return-reg ;
+
+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 -- )
+ EAX src int-rep %copy
+ EDX EAX 4 [+] MOV
+ EAX EAX [] MOV ;
+
M: stack-params copy-register*
drop
{
M: x86.32 %save-param-reg [ local@ ] 2dip %copy ;
-M: x86.32 %load-param-reg [ swap local@ ] dip %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
#! parameter being passed to a callback from C.
over [ [ local@ ] dip load-return-reg ] [ 2drop ] if ;
-M:: x86.32 %box ( n rep func -- )
+M:: x86.32 %box ( dst n rep func -- )
n rep (%box)
rep rep-size save-vm-ptr
0 stack@ rep store-return-reg
- func f %alien-invoke ;
+ func f %alien-invoke
+ dst EAX tagged-rep %copy ;
: (%box-long-long) ( n -- )
[
- EDX over next-stack@ MOV
- EAX swap cell - next-stack@ MOV
+ [ EDX swap next-stack@ MOV ]
+ [ EAX swap cell - next-stack@ MOV ] bi
] when* ;
-M: x86.32 %box-long-long ( n func -- )
- [ (%box-long-long) ] dip
+M:: x86.32 %box-long-long ( dst n func -- )
+ n (%box-long-long)
8 save-vm-ptr
4 stack@ EDX MOV
0 stack@ EAX MOV
- f %alien-invoke ;
+ func f %alien-invoke
+ dst EAX tagged-rep %copy ;
-M:: x86.32 %box-large-struct ( n c-type -- )
+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 %prepare-box-struct ( -- )
- ! Compute target address for value struct return
- EAX f struct-return@ LEA
- ! Store it as the first parameter
- 0 local@ EAX MOV ;
+ "from_value_struct" f %alien-invoke
+ dst EAX tagged-rep %copy ;
-M: x86.32 %box-small-struct ( c-type -- )
+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@ swap heap-size MOV
- 4 stack@ EDX MOV
- 0 stack@ EAX MOV
- "from_small_struct" f %alien-invoke ;
-
-M: x86.32 %pop-stack ( n -- )
- EAX swap ds-reg reg-stack MOV ;
-
-M: x86.32 %pop-context-stack ( -- )
- temp-reg %context
- EAX temp-reg "datastack" context-field-offset [+] MOV
- EAX EAX [] MOV
- temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
-
-: call-unbox-func ( func -- )
- 4 save-vm-ptr
- 0 stack@ EAX MOV
- f %alien-invoke ;
-
-M: x86.32 %unbox ( n rep func -- )
- #! The value being unboxed must already be in EAX.
- #! If n is f, we're unboxing a return value about to be
- #! returned by the callback. Otherwise, we're unboxing
- #! a parameter to a C function about to be called.
- call-unbox-func
- ! Store the return value on the C stack
- over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ;
-
-M: x86.32 %unbox-long-long ( n func -- )
- call-unbox-func
- ! Store the return value on the C stack
- [
- [ local@ EAX MOV ]
- [ 4 + local@ EDX MOV ] bi
- ] when* ;
-
-: %unbox-struct-1 ( -- )
- #! Alien must be in EAX.
- 4 save-vm-ptr
- 0 stack@ EAX MOV
- "alien_offset" f %alien-invoke
- ! Load first cell
- EAX EAX [] MOV ;
-
-: %unbox-struct-2 ( -- )
- #! Alien must be in EAX.
- 4 save-vm-ptr
- 0 stack@ EAX MOV
- "alien_offset" f %alien-invoke
- ! Load second cell
- EDX EAX 4 [+] MOV
- ! Load first cell
- EAX EAX [] MOV ;
-
-M: x86 %unbox-small-struct ( size -- )
- #! Alien must be in EAX.
- heap-size cell align cell /i {
- { 1 [ %unbox-struct-1 ] }
- { 2 [ %unbox-struct-2 ] }
- } case ;
-
-M:: x86.32 %unbox-large-struct ( n c-type -- )
- ! Alien must be in EAX.
- ! Compute destination address
- EDX n local@ LEA
- 12 save-vm-ptr
8 stack@ c-type heap-size MOV
4 stack@ EDX MOV
0 stack@ EAX MOV
- "to_value_struct" f %alien-invoke ;
-
-M: x86.32 %prepare-alien-indirect ( -- )
- EAX ds-reg [] MOV
- ds-reg 4 SUB
- 4 save-vm-ptr
- 0 stack@ EAX MOV
- "pinned_alien_offset" f %alien-invoke
- EBP EAX MOV ;
-
-M: x86.32 %alien-indirect ( -- )
- EBP CALL ;
+ "from_small_struct" f %alien-invoke
+ dst EAX tagged-rep %copy ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
- ESP 4 [+] 0 MOV
+ 4 stack@ 0 MOV
"begin_callback" f %alien-invoke ;
M: x86.32 %alien-callback ( quot -- )
- EAX EDX %restore-context
- EAX swap %load-reference
- EAX quot-entry-point-offset [+] CALL
- EAX EDX %save-context ;
+ [ EAX ] dip %load-reference
+ EAX quot-entry-point-offset [+] CALL ;
M: x86.32 %end-callback ( -- )
0 save-vm-ptr
"end_callback" f %alien-invoke ;
-M: x86.32 %end-callback-value ( ctype -- )
- %pop-context-stack
- 4 stack@ EAX MOV
- %end-callback
- ! Place former top of data stack back in EAX
- EAX 4 stack@ MOV
- ! Unbox EAX
- unbox-return ;
-
GENERIC: float-function-param ( stack-slot dst src -- )
M:: spill-slot float-function-param ( stack-slot dst src -- )
func "libm" load-library %alien-invoke
dst float-function-return ;
-: funny-large-struct-return? ( params -- ? )
+: funny-large-struct-return? ( return abi -- ? )
#! MINGW ABI incompatibility disaster
- [ return>> large-struct? ]
- [ abi>> mingw = os windows? not or ]
- bi and ;
-
-: stack-arg-size ( params -- n )
- dup abi>> '[
- alien-parameters flatten-c-types
- [ _ alloc-parameter 2drop ] each
- stack-params get
- ] with-param-regs ;
-
-M: x86.32 stack-cleanup ( params -- n )
+ [ large-struct? ] [ mingw eq? os windows? not or ] bi* and ;
+
+M:: x86.32 stack-cleanup ( stack-size return abi -- n )
#! a) Functions which are stdcall/fastcall/thiscall have to
#! clean up the caller's stack frame.
#! b) Functions returning large structs on MINGW have to
#! fix ESP.
{
- { [ dup abi>> callee-cleanup? ] [ stack-arg-size ] }
- { [ dup funny-large-struct-return? ] [ drop 4 ] }
- [ drop 0 ]
+ { [ abi callee-cleanup? ] [ stack-size ] }
+ { [ return abi funny-large-struct-return? ] [ 4 ] }
+ [ 0 ]
} cond ;
-M: x86.32 %cleanup ( params -- )
- stack-cleanup [ ESP swap SUB ] unless-zero ;
+M: x86.32 %cleanup ( n -- )
+ [ ESP swap SUB ] unless-zero ;
M:: x86.32 %call-gc ( gc-roots -- )
4 save-vm-ptr
M: x86.32 dummy-fp-params? f ;
-! Dreadful
-M: struct-c-type flatten-c-type stack-params (flatten-c-type) ;
-M: long-long-type flatten-c-type stack-params (flatten-c-type) ;
-M: c-type flatten-c-type dup rep>> int-rep? int-rep stack-params ? (flatten-c-type) ;
+M: x86.32 long-long-on-stack? t ;
+
+M: x86.32 float-on-stack? t ;
+
+M: x86.32 flatten-struct-type
+ stack-size cell /i { int-rep t } <repetition> ;
-M: x86.32 struct-return-pointer-type
- os linux? void* (stack-value) ? ;
+M: x86.32 struct-return-on-stack? os linux? not ;
check-sse
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.libraries
-slots splitting assocs combinators locals compiler.constants
+slots splitting assocs combinators fry locals compiler.constants
classes.struct compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics compiler.cfg.stack-frame
M: x86.64 %vm-field ( dst offset -- )
[ vm-reg ] dip [+] MOV ;
-M: x86.64 %load-double ( dst val -- )
- [ 0 [RIP+] MOVSD ] dip rc-relative rel-binary-literal ;
-
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 ;
[ (align-code) ]
bi ;
-M: stack-params copy-register*
- drop
- {
- { [ dup integer? ] [ R11 swap next-stack@ MOV R11 MOV ] }
- { [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
- } cond ;
-
-M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
-
-M: x86.64 %load-param-reg [ swap param@ ] dip %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 -- )
[
call
] with-scope ; inline
-M: x86.64 %pop-stack ( n -- )
- param-reg-0 swap ds-reg reg-stack MOV ;
-
-M: x86.64 %pop-context-stack ( -- )
- temp-reg %context
- param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
- param-reg-0 param-reg-0 [] MOV
- temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
-
-M:: x86.64 %unbox ( n rep func -- )
- param-reg-1 %mov-vm-ptr
- ! Call the unboxer
- func f %alien-invoke
- ! Store the return value on the C stack if this is an
- ! alien-invoke, otherwise leave it the return register if
- ! this is the end of alien-callback
- n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
+: each-struct-component ( c-type quot -- )
+ '[
+ flatten-struct-type
+ [ [ first ] dip @ ] each-index
+ ] with-return-regs ; inline
-: %unbox-struct-field ( rep i -- )
- ! Alien must be in param-reg-0.
+: %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 %unbox-small-struct ( c-type -- )
- ! Alien must be in param-reg-0.
- param-reg-1 %mov-vm-ptr
- "alien_offset" f %alien-invoke
- ! Move alien_offset() return value to R11 so that we don't
- ! clobber it.
- R11 RAX MOV
- [
- flatten-struct-type [ %unbox-struct-field ] each-index
- ] with-return-regs ;
-
-M:: x86.64 %unbox-large-struct ( n c-type -- )
- ! Source is in param-reg-0
- ! Load destination address into param-reg-1
- param-reg-1 n param@ LEA
- ! Load structure size into param-reg-2
- param-reg-2 c-type heap-size MOV
- param-reg-3 %mov-vm-ptr
- ! Copy the struct to the C stack
- "to_value_struct" f %alien-invoke ;
-
-: load-return-value ( rep -- )
- [ [ 0 ] dip reg-class-of cdecl param-reg ]
- [ reg-class-of return-reg ]
- [ ]
- tri %copy ;
-
-M:: x86.64 %box ( n rep func -- )
- n [
- n
- 0 rep reg-class-of cdecl param-reg
- rep %load-param-reg
- ] [
- rep load-return-value
- ] if
+M:: x86.64 %store-return ( src rep -- )
+ rep reg-class-of return-reg src rep %copy ;
+
+M:: x86.64 %store-struct-return ( src c-type -- )
+ ! Move src to R11 so that we don't clobber it.
+ R11 src int-rep %copy
+ c-type [ %unbox-struct-component ] each-struct-component ;
+
+M: stack-params copy-register*
+ drop
+ {
+ { [ dup integer? ] [ R11 swap next-stack@ MOV R11 MOV ] }
+ { [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
+ } cond ;
+
+M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
+
+M:: x86.64 %box ( dst n rep func -- )
+ 0 rep reg-class-of cdecl param-reg
+ n [ n param@ ] [ rep reg-class-of return-reg ] if rep %copy
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
- func f %alien-invoke ;
+ func f %alien-invoke
+ dst RAX tagged-rep %copy ;
-: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
+: box-struct-component@ ( i -- operand ) 1 + cells param@ ;
-: %box-struct-field ( rep i -- )
- box-struct-field@ swap reg-class-of {
+: %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 ( c-type -- )
+M:: x86.64 %box-small-struct ( dst c-type -- )
#! Box a <= 16-byte struct.
- [
- [ flatten-struct-type [ %box-struct-field ] each-index ]
- [ param-reg-2 swap heap-size MOV ] bi
- param-reg-0 0 box-struct-field@ MOV
- param-reg-1 1 box-struct-field@ MOV
- param-reg-3 %mov-vm-ptr
- "from_small_struct" f %alien-invoke
- ] with-return-regs ;
-
-: struct-return@ ( n -- operand )
+ 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 ( n c-type -- )
+M:: x86.64 %box-large-struct ( dst n c-type -- )
! Struct size is parameter 2
- param-reg-1 swap heap-size MOV
+ param-reg-1 c-type heap-size MOV
! Compute destination address
- param-reg-0 swap struct-return@ LEA
+ 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 ;
-
-M: x86.64 %prepare-box-struct ( -- )
- ! Compute target address for value struct return
- RAX f struct-return@ LEA
- ! Store it as the first parameter
- 0 param@ RAX MOV ;
-
-M: x86.64 %prepare-var-args RAX RAX XOR ;
+ "from_value_struct" f %alien-invoke
+ dst RAX tagged-rep %copy ;
M: x86.64 %alien-invoke
R11 0 MOV
rc-absolute-cell rel-dlsym
R11 CALL ;
-M: x86.64 %prepare-alien-indirect ( -- )
- param-reg-0 ds-reg [] MOV
- ds-reg 8 SUB
- param-reg-1 %mov-vm-ptr
- "pinned_alien_offset" f %alien-invoke
- nv-reg RAX MOV ;
-
-M: x86.64 %alien-indirect ( -- )
- nv-reg CALL ;
-
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
param-reg-1 0 MOV
"begin_callback" f %alien-invoke ;
M: x86.64 %alien-callback ( quot -- )
- param-reg-0 param-reg-1 %restore-context
- param-reg-0 swap %load-reference
- param-reg-0 quot-entry-point-offset [+] CALL
- param-reg-0 param-reg-1 %save-context ;
+ [ param-reg-0 ] dip %load-reference
+ param-reg-0 quot-entry-point-offset [+] CALL ;
M: x86.64 %end-callback ( -- )
param-reg-0 %mov-vm-ptr
"end_callback" f %alien-invoke ;
-M: x86.64 %end-callback-value ( ctype -- )
- %pop-context-stack
- nv-reg param-reg-0 MOV
- %end-callback
- param-reg-0 nv-reg MOV
- ! Unbox former top of data stack to return registers
- unbox-return ;
-
: float-function-param ( i src -- )
[ float-regs cdecl param-regs nth ] dip double-rep %copy ;
param-reg-1 %mov-vm-ptr
"inline_gc" f %alien-invoke ;
-M: x86.64 struct-return-pointer-type void* ;
+M: x86.64 long-long-on-stack? f ;
+
+M: x86.64 float-on-stack? f ;
+
+M: x86.64 struct-return-on-stack? f ;
! The result of reading 4 bytes from memory is a fixnum on
! x86-64.
{ [ os unix? ] [ "cpu.x86.64.unix" require ] }
{ [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
} cond
-
-check-sse
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.codegen.alien compiler.cfg.registers ;
+cpu.x86 compiler.cfg.builder.alien compiler.cfg.registers ;
IN: cpu.x86.64.unix
M: int-regs param-regs
struct-types&offset split-struct [
[ c-type c-type-rep reg-class-of ] map
int-regs swap member? int-rep double-rep ?
+ f 2array
] map ;
: flatten-large-struct ( c-type -- seq )
- stack-params (flatten-c-type) ;
+ stack-size cell /i { int-rep t } <repetition> ;
M: x86.64 flatten-struct-type ( c-type -- seq )
dup heap-size 16 >
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
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: float-rep copy-memory* drop MOVSS ;
M: double-rep copy-memory* drop MOVSD ;
+: ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ;
+
M: x86 %copy ( dst src rep -- )
2over eq? [ 3drop ] [
- [ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
+ [ [ ?spill-slot ] bi@ ] dip
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
] if ;
M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
-M: x86 %push-stack ( -- )
- ds-reg cell ADD
- ds-reg [] int-regs return-reg MOV ;
-
-M: x86 %push-context-stack ( -- )
- temp-reg %context
- temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
- temp-reg temp-reg "datastack" context-field-offset [+] MOV
- temp-reg [] int-regs return-reg MOV ;
-
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
:: (%boolean) ( dst temp insn -- )
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 ;
{ 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 ;
} 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 %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 ;
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 ;
+enable-float-intrinsics
+enable-float-functions
+enable-float-min/max
+enable-fsqrt
: check-sse ( -- )
[ { (sse-version) } compile ] with-optimizer
- "Checking for multimedia extensions: " write sse-version
- [ sse-string write " detected" print ] [ enable-sse2 ] bi ;
+ sse-version 20 < [
+ "Factor requires SSE2, which your CPU does not support." print
+ flush
+ 1 exit
+ ] when ;
M: wrong-values summary drop "Quotation's stack effect does not match call site" ;
M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ;
-
-{
- { [ os windows? ] [ "debugger.windows" require ] }
- { [ os unix? ] [ "debugger.unix" require ] }
-} cond
M: consultation where loc>> ;
-M: consultation set-where (>>loc) ;
+M: consultation set-where loc<< ;
M: consultation forget*
[ unconsult-methods ] [ unregister-consult ] bi ;
M: dlist-node node-value obj>> ;
: set-prev-when ( dlist-node dlist-node/f -- )
- [ (>>prev) ] [ drop ] if* ; inline
+ [ prev<< ] [ drop ] if* ; inline
: set-next-when ( dlist-node dlist-node/f -- )
- [ (>>next) ] [ drop ] if* ; inline
+ [ next<< ] [ drop ] if* ; inline
: set-next-prev ( dlist-node -- )
dup next>> set-prev-when ; inline
M: dlist push-front* ( obj dlist -- dlist-node )
[ front>> f swap <dlist-node> dup dup set-next-prev ] keep
- [ (>>front) ] keep
+ [ front<< ] keep
set-back-to-front ;
M: dlist push-back* ( obj dlist -- dlist-node )
[ back>> f <dlist-node> ] keep
[ back>> set-next-when ] 2keep
- [ (>>back) ] 2keep
+ [ back<< ] 2keep
set-front-to-back ;
ERROR: empty-dlist ;
: handle-USER ( ftp-command -- )
[
- tokenized>> second client get (>>user)
+ tokenized>> second client get user<<
"Please specify the password." 331 server-response
] [
2drop "bad USER" ftp-error
: handle-PASS ( ftp-command -- )
[
- tokenized>> second client get (>>password)
+ tokenized>> second client get password<<
"Login successful" 230 server-response
] [
2drop "PASS error" ftp-error
] if ;
: expect-connection ( -- port )
- <promise> client get (>>extra-connection)
+ <promise> client get extra-connection<<
random-local-server
[ [ passive-loop ] curry in-thread ]
[ addr>> port>> ] bi ;
{
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
[ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]
- [ [ children>> ] dip "button" deep-tag-named (>>children) ]
+ [ [ children>> ] dip "button" deep-tag-named children<< ]
[ nip ]
} 2cleave compile-chloe-tag ;
: fill-controller-state ( XINPUT_STATE -- controller-state )
Gamepad>> controller-state new dup rot
{
- [ wButtons>> HEX: f bitand >pov swap (>>pov) ]
- [ wButtons>> fill-buttons swap (>>buttons) ]
- [ sThumbLX>> >axis swap (>>x) ]
- [ sThumbLY>> >axis swap (>>y) ]
- [ sThumbRX>> >axis swap (>>rx) ]
- [ sThumbRY>> >axis swap (>>ry) ]
- [ bLeftTrigger>> >trigger swap (>>z) ]
- [ bRightTrigger>> >trigger swap (>>rz) ]
+ [ wButtons>> HEX: f bitand >pov swap pov<< ]
+ [ wButtons>> fill-buttons swap buttons<< ]
+ [ sThumbLX>> >axis swap x<< ]
+ [ sThumbLY>> >axis swap y<< ]
+ [ sThumbRX>> >axis swap rx<< ]
+ [ sThumbRY>> >axis swap ry<< ]
+ [ bLeftTrigger>> >trigger swap z<< ]
+ [ bRightTrigger>> >trigger swap rz<< ]
} 2cleave ;
PRIVATE>
M: link where name>> article loc>> ;
-M: link set-where name>> article (>>loc) ;
+M: link set-where name>> article loc<< ;
M: link forget* name>> remove-article ;
M: tip where loc>> ;
-M: tip set-where (>>loc) ;
+M: tip set-where loc<< ;
: <tip> ( content -- tip ) f tip boa ;
HINTS: M\ hashtable blahblah { object fixnum object } { object word object } ;
-[ t ] [ M\ hashtable blahblah { count>> (>>count) } inlined? ] unit-test
+[ t ] [ M\ hashtable blahblah { count>> count<< } inlined? ] unit-test
: jpeg> ( -- jpeg-image ) jpeg-image get ;
: apply-diff ( dc color -- dc' )
- [ diff>> + dup ] [ (>>diff) ] bi ;
+ [ diff>> + dup ] [ diff<< ] bi ;
: fetch-tables ( component -- )
[ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
read1 8 assert=
2 read be>
2 read be>
- swap 2array jpeg> (>>dim)
+ swap 2array jpeg> dim<<
read1
[
read1 read4/4 read1 <jpeg-color-info>
[ drop
read1 jpeg> color-info>> nth clone
read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
- ] map jpeg> (>>components)
+ ] map jpeg> components<<
read1 0 assert=
read1 63 assert=
read1 16 /mod [ 0 assert= ] bi@
: baseline-decompress ( -- )
jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
- >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
+ >byte-array bs:<msb0-bit-reader> jpeg> bitstream<<
jpeg>
[ bitstream>> ]
[ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
ERROR: seek-before-start n ;
: set-seek-ptr ( n handle -- )
- [ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ;
+ [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
M: winnt tell-handle ( handle -- n ) ptr>> ;
char encoding type>> value? [
char find-type
[ stream stream-write ]
- [ encoding (>>type) ] bi*
+ [ encoding type<< ] bi*
] unless
char encoding type>> value-at stream stream-write-num ;
stream stream-read1 {
{ ESC [
stream read-escape [
- encoding (>>type)
+ encoding type<<
stream encoding decode-char
] [ replacement-char ] if*
] }
M: winnt fill-redirection ( process args -- )
dup lpStartupInfo>>
- [ [ redirect-stdout ] dip (>>hStdOutput) ]
- [ [ redirect-stderr ] dip (>>hStdError) ]
- [ [ redirect-stdin ] dip (>>hStdInput) ] 3tri ;
+ [ [ redirect-stdout ] dip hStdOutput<< ]
+ [ [ redirect-stderr ] dip hStdError<< ]
+ [ [ redirect-stdin ] dip hStdInput<< ] 3tri ;
M: monitor timeout timeout>> ;
-M: monitor set-timeout (>>timeout) ;
+M: monitor set-timeout timeout<< ;
<PRIVATE
M: port timeout timeout>> ;
-M: port set-timeout (>>timeout) ;
+M: port set-timeout timeout<< ;
: <port> ( handle class -- port )
new-disposable swap >>handle ; inline
handle>> closesocket drop ;\r
\r
: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
- [ empty-sockaddr/size ] [ protocol-family ] bi pick (>>family) ;\r
+ [ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ;\r
\r
: opened-socket ( handle -- win32-socket )\r
<win32-socket> |dispose dup add-completion ;\r
:: limited-stream-seek ( n seek-type stream -- )
seek-type {
- { seek-absolute [ n stream (>>current) ] }
+ { seek-absolute [ n stream current<< ] }
{ seek-relative [ stream [ n + ] change-current drop ] }
- { seek-end [ stream stop>> n - stream (>>current) ] }
+ { seek-end [ stream stop>> n - stream current<< ] }
[ bad-seek-type ]
} case ;
[ rect-bounds ] dip vmin <rect> ;
: set-rect-bounds ( rect1 rect -- )
- [ [ loc>> ] dip (>>loc) ]
- [ [ dim>> ] dip (>>dim) ]
+ [ [ loc>> ] dip loc<< ]
+ [ [ dim>> ] dip dim<< ]
2bi ; inline
USE: vocabs.loader
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 ;
] 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
-
: update-velocity ( dt actor -- )
[ acceleration>> n*v ] [ velocity>> v+ ] [ ] tri
- (>>velocity) ; inline
+ velocity<< ; inline
: update-position ( dt actor -- )
[ velocity>> n*v ] [ position>> v+ ] [ ] tri
- (>>position) ; inline
+ position<< ; inline
M: actor advance ( dt actor -- )
[ >float ] dip
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 ;
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 )
[ 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
+
+! 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
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 ;
: (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)
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 )
((change-model)) set-model ; inline
: (change-model) ( model quot -- )
- ((change-model)) (>>value) ; inline
+ ((change-model)) value<< ; inline
GENERIC: range-value ( model -- value )
GENERIC: range-page-value ( model -- value )
s [
s left-recursion? [ s throw ] unless
s head>> l head>> eq? [
- l head>> s (>>head)
+ l head>> s head<<
l head>> [ s rule-id>> suffix ] change-involved-set drop
l s next>> (setup-lr)
] unless
:: setup-lr ( r l -- )
l head>> [
- r rule-id V{ } clone V{ } clone peg-head boa l (>>head)
+ r rule-id V{ } clone V{ } clone peg-head boa l head<<
] unless
l lrstack get (setup-lr) ;
:: lr-answer ( r p m -- ast )
m ans>> head>> :> h
h rule-id>> r rule-id eq? [
- m ans>> seed>> m (>>ans)
+ m ans>> seed>> m ans<<
m ans>> failed? [
fail
] [
lr lrstack set lr p memo-entry boa dup p r rule-id set-memo :> m
r eval-rule :> ans
lrstack get next>> lrstack set
- pos get m (>>pos)
+ pos get m pos<<
lr head>> [
m ans>> left-recursion? [
- ans lr (>>seed)
+ ans lr seed<<
r p m lr-answer
] [ ans ] if
] [
- ans m (>>ans)
+ ans m ans<<
ans
] if ; inline
: calc-seq-result ( prev-result current-result -- next-result )
[
- [ remaining>> swap (>>remaining) ] 2keep
+ [ remaining>> swap remaining<< ] 2keep
ast>> dup ignore? [
drop
] [
: (repeat) ( quot: ( -- result ) result -- result )
over call [
- [ remaining>> swap (>>remaining) ] 2keep
+ [ remaining>> swap remaining<< ] 2keep
ast>> swap [ ast>> push ] keep
(repeat)
] [
dup pprinter get last-newline>> = [
drop
] [
- pprinter get (>>last-newline)
+ pprinter get last-newline<<
line-limit? [
"..." write pprinter get return
] when
: pprinter-manifest ( -- manifest )
<manifest>
- [ [ pprinter-use get keys >vector ] dip (>>search-vocabs) ]
- [ [ pprinter-in get ] dip (>>current-vocab) ]
+ [ [ pprinter-use get keys >vector ] dip search-vocabs<< ]
+ [ [ pprinter-in get ] dip current-vocab<< ]
[ ]
tri ;
M:: sfmt generate ( sfmt -- )
sfmt state>> :> state
sfmt uint-4-array>> :> array
- state n>> 2 - array nth state (>>r1)
- state n>> 1 - array nth state (>>r2)
+ state n>> 2 - array nth state r1<<
+ state n>> 1 - array nth state r2<<
state m>> :> m
state n>> :> n
state mask>> :> mask
mask state r1>> state r2>> formula :> r
r i array set-nth-unsafe
- state r2>> state (>>r1)
- r state (>>r2)
+ state r2>> state r1<<
+ r state r2<<
] each
! n m - 1 + n [a,b) [
mask state r1>> state r2>> formula :> r
r i array set-nth-unsafe
- state r2>> state (>>r1)
- r state (>>r2)
+ state r2>> state r1<<
+ r state r2<<
] each
- 0 state (>>index) ;
+ 0 state index<< ;
: period-certified? ( sfmt -- ? )
[ uint-4-array>> first ]
TUPLE: obj-ref obj ;
C: <obj-ref> obj-ref
M: obj-ref get-ref obj>> ;
-M: obj-ref set-ref (>>obj) ;
+M: obj-ref set-ref obj<< ;
INSTANCE: obj-ref ref
TUPLE: var-ref var ;
[ transitions>> keys ] bi*
[ intersects? ] with filter
fast-set
- ] keep (>>final-states) ;
+ ] keep final-states<< ;
: initialize-dfa ( nfa -- dfa )
<transition-table>
[ [ [ 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
:: with-sequence-parser ( sequence-parser quot -- seq/f )
sequence-parser n>> :> n
sequence-parser quot call [
- n sequence-parser (>>n) f
+ n sequence-parser n<< f
] unless* ; inline
: offset ( sequence-parser offset -- char/f )
sequence-parser [ growing length - 1 + ] change-n drop
! sequence-parser advance drop
] [
- saved sequence-parser (>>n)
+ saved sequence-parser n<<
f
] if ;
! 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 cpu.architecture fry stack-checker.backend
+alien.c-types fry stack-checker.backend
stack-checker.errors stack-checker.visitor
stack-checker.dependencies ;
IN: stack-checker.alien
: param-prep-quot ( params -- quot )
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
-: infer-params ( params -- )
- param-prep-quot infer-quot-here ;
-
: alien-stack ( params extra -- )
over parameters>> length + consume-d >>in-d
dup return>> void? 0 1 ? produce-d >>out-d
! Set ABI
dup library>> library-abi >>abi
! Quotation which coerces parameters to required types
- dup infer-params
+ dup param-prep-quot infer-quot-here
! Magic #: consume exactly the number of inputs
dup 0 alien-stack
! Add node to IR
pop-abi
pop-params
pop-return
- ! Quotation which coerces parameters to required types
- 1 infer->r
- dup infer-params
- 1 infer-r>
+ ! Coerce parameters to required types
+ dup param-prep-quot '[ _ [ >c-ptr ] bi* ] infer-quot-here
! Magic #: consume the function pointer, too
dup 1 alien-stack
! Add node to IR
pop-params
pop-return
! Quotation which coerces parameters to required types
- dup infer-params
+ dup param-prep-quot infer-quot-here
! Magic #: consume exactly the number of inputs
dup 0 alien-stack
! Add node to IR
! Quotation which coerces return value to required type
infer-return ;
-: callback-xt ( word return-rewind -- alien )
- [ callbacks get ] dip '[ _ <callback> ] cache ;
+: callback-xt ( word -- alien )
+ callbacks get [ dup "stack-cleanup" word-prop <callback> ] cache ;
: callback-bottom ( params -- )
- [ xt>> ] [ stack-cleanup ] bi '[ _ _ callback-xt ] infer-quot-here ;
+ xt>> '[ _ callback-xt ] infer-quot-here ;
: infer-alien-callback ( -- )
alien-callback-params new
: associate-thread ( walker -- )
walker-thread tset
[ f walker-thread tget send-synchronous drop ]
- self (>>exit-handler) ;
+ self exit-handler<< ;
: start-walker-thread ( status continuation -- thread' )
self [
window world window-loc>> auto-position
world window save-position
window install-window-delegate
- view window <window-handle> world (>>handle)
+ view window <window-handle> world handle<<
window f -> makeKeyAndOrderFront: ;
M: cocoa-ui-backend (close-window) ( handle -- )
: handle-wm-size ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
- dup { 0 0 } = [ 2drop ] [ swap window [ (>>dim) ] [ drop ] if* ] if ;
+ dup { 0 0 } = [ 2drop ] [ swap window [ dim<< ] [ drop ] if* ] if ;
: handle-wm-move ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
- swap window [ (>>window-loc) ] [ drop ] if* ;
+ swap window [ window-loc<< ] [ drop ] if* ;
CONSTANT: wm-keydown-codes
H{
] unless ;
:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
- ? hwnd window (>>active?)
+ ? hwnd window active?<<
hwnd uMsg wParam lParam DefWindowProc ;
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
swap [ push ] [ remove! drop ] if ;
: mouse-scroll ( wParam -- array )
- >lo-hi [ -120 /f ] map ;
+ >lo-hi [ -80 /f ] map ;
: mouse-event>gesture ( uMsg -- button )
key-modifiers swap message>button
M: x-clipboard copy-clipboard
[ x-clipboard@ own-selection ] keep
- (>>contents) ;
+ contents<< ;
M: x-clipboard paste-clipboard
[ find-world handle>> window>> ] dip atom>> convert-selection ;
M: clipboard clipboard-contents contents>> ;
-M: clipboard set-clipboard-contents (>>contents) ;
+M: clipboard set-clipboard-contents contents<< ;
: <clipboard> ( -- clipboard ) "" clipboard boa ;
PRIVATE>
-M: gadget (>>dim) ( dim gadget -- )
+M: gadget dim<< ( dim gadget -- )
2dup dim>> =
[ 2drop ]
[ [ nip ] [ call-next-method ] 2bi dim-changed ] if ;
: pref-dim ( gadget -- dim )
dup pref-dim>> [ ] [
[ pref-dim* ] [ ] [ layout-state>> ] tri
- [ drop ] [ dupd (>>pref-dim) ] if
+ [ drop ] [ dupd pref-dim<< ] if
] ?if ;
: pref-dims ( gadgets -- seq ) [ pref-dim ] map ;
ERROR: not-a-string object ;
-M: label (>>string) ( string label -- )
+M: label string<< ( string label -- )
[
{
{ [ dup string-array? ] [ ] }
{ [ dup string? ] [ ?string-lines ] }
[ not-a-string ]
} cond
- ] dip (>>text) ; inline
+ ] dip text<< ; inline
: label-theme ( gadget -- gadget )
sans-serif-font >>font ; inline
: pack-layout ( pack sizes -- )
[ round-dims packed-dims ] [ drop ] 2bi
- [ children>> [ (>>dim) ] 2each ]
- [ [ packed-locs ] [ children>> ] bi [ (>>loc) ] 2each ] 2bi ;
+ [ children>> [ dim<< ] 2each ]
+ [ [ packed-locs ] [ children>> ] bi [ loc<< ] 2each ] 2bi ;
: <pack> ( orientation -- pack )
pack new
: show-status ( string/f gadget -- )
dup find-world dup [
dup status>> [
- [ (>>status-owner) ] [ status>> set-model ] bi
+ [ status-owner<< ] [ status>> set-model ] bi
] [ 3drop ] if
] [ 3drop ] if ;
: hide-status ( gadget -- )
dup find-world dup [
[ status-owner>> eq? ] keep
- '[ f _ [ (>>status-owner) ] [ status>> set-model ] 2bi ] when
+ '[ f _ [ status-owner<< ] [ status>> set-model ] 2bi ] when
] [ 2drop ] if ;
: window-resource ( resource -- resource )
M: world resize-world
drop ;
-M: world (>>dim)
+M: world dim<<
[ call-next-method ]
[
dup active?>> [
dup send-lose-focus
f swap t focus-child
] when*
- dupd (>>focus) [
+ dupd focus<< [
send-gain-focus
] when*
] [
- (>>focus)
+ focus<<
] if ;
: modifier ( mod modifiers -- seq )
TUPLE: dummy obj ;
M: dummy history-value obj>> ;
-M: dummy set-history-value (>>obj) ;
+M: dummy set-history-value obj<< ;
dummy new <history> "history" set
[ ] [ <promise> "promise" set ] unit-test
[
- self "interactor" get (>>thread)
+ self "interactor" get thread<<
"interactor" get stream-read-quot "promise" get fulfill
] "Interactor test" spawn drop
[ ] [ <promise> "promise" set ] unit-test
[
- self "interactor" get (>>thread)
+ self "interactor" get thread<<
"interactor" get stream-readln "promise" get fulfill
] "Interactor test" spawn drop
: define-main-window ( word attributes quot -- )
[
'[ [ f _ clone @ open-window ] with-ui ] (( -- )) define-declared
- ] [ 2drop current-vocab (>>main) ] 3bi ;
+ ] [ 2drop current-vocab main<< ] 3bi ;
SYNTAX: MAIN-WINDOW:
CREATE
unroll-factor 0 <array>
[ unroll-factor 1 - swap set-nth ] keep f
] dip [ node boa dup ] keep
- dup [ (>>prev) ] [ 2drop ] if ; inline
+ dup [ prev<< ] [ 2drop ] if ; inline
: normalize-back ( list -- )
dup back>> [
[
unroll-factor 0 <array> [ set-first ] keep
] dip [ f node boa dup ] keep
- dup [ (>>next) ] [ 2drop ] if ; inline
+ dup [ next<< ] [ 2drop ] if ; inline
: normalize-front ( list -- )
dup front>> [
M: value-word definition drop f ;
: set-value ( value word -- )
- def>> first (>>obj) ;
+ def>> first obj<< ;
SYNTAX: to:
scan-word literalize suffix!
alien.syntax kernel system namespaces combinators sequences fry
math accessors macros words quotations libc continuations
generalizations splitting locals assocs init specialized-arrays
-classes.struct strings arrays literals ;
+classes.struct strings arrays literals sequences.generalizations ;
SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT
IN: windows.directx.dinput.constants
: (flags) ( array -- n )
0 [ (flag) bitor ] reduce ;
-: <DIOBJECTDATAFORMAT>-quot ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- quot )
+: <DIOBJECTDATAFORMAT> ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- object )
{
[ drop f ]
[ second rot [ (offsetof) ] [ (sizeof) ] 2bi ]
[ third * + ]
[ fourth (flags) ]
[ 4 swap nth (flag) ]
- [ first dup word? [ '[ _ get ] ] [ drop [ f ] ] if ]
} cleave
- [ DIOBJECTDATAFORMAT <struct-boa> ] dip
- curry ;
+ DIOBJECTDATAFORMAT <struct-boa> ;
-: set-DIOBJECTDATAFORMAT ( array struct pguid n -- array )
- [ [ clone ] dip >>pguid ] dip pick set-nth ;
+: make-DIOBJECTDATAFORMAT-arrays ( struct array -- values vars )
+ [ [ <DIOBJECTDATAFORMAT> ] [ first ] bi ] with
+ DIOBJECTDATAFORMAT-array{ } { } 1 2 mnmap-as ;
-:: make-DIOBJECTDATAFORMAT-array-quot ( struct array -- quot )
- array length '[ _ malloc-DIOBJECTDATAFORMAT-array ]
- array [| args i |
- struct args <DIOBJECTDATAFORMAT>-quot
- i '[ @ _ set-DIOBJECTDATAFORMAT ]
- ] map-index [ ] join compose ;
+: make-DIOBJECTDATAFORMAT-array-quot ( struct arr -- quot )
+ [ nip length ] [ make-DIOBJECTDATAFORMAT-arrays ] 2bi '[
+ _ malloc-DIOBJECTDATAFORMAT-array
+ [ _ dup byte-length memcpy ]
+ [ _ [ get >>pguid drop ] 2each ]
+ [ ] tri
+ ] ;
>>
USING: alien.strings continuations io
io.encodings.ascii kernel namespaces x11.xlib x11.io
vocabs vocabs.loader ;
+FROM: alien.c-types => c-bool> ;
IN: x11
SYMBOL: dpy
: init-locale ( -- )
LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
- XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ;
+ XSupportsLocale c-bool> [ "XSupportsLocale() failed" print flush ] unless ;
: flush-dpy ( -- ) dpy get XFlush drop ;
2nip set-second
] [
[ assure-name swap 2array ] dip
- [ alist>> ?push ] keep (>>alist)
+ [ alist>> ?push ] keep alist<<
] if* ;
M: attrs assoc-size alist>> length ;
TAG: MODE parse-mode-tag
dup "NAME" attr [
mode new {
- { "FILE" f (>>file) }
- { "FILE_NAME_GLOB" f (>>file-name-glob) }
- { "FIRST_LINE_GLOB" f (>>first-line-glob) }
+ { "FILE" f file<< }
+ { "FILE_NAME_GLOB" f file-name-glob<< }
+ { "FIRST_LINE_GLOB" f first-line-glob<< }
} init-from-tag
] dip
rot set-at ;
over [ assoc-union! ] [ nip clone ] if ;
: import-keywords ( parent child -- )
- over [ [ keywords>> ] bi@ ?update ] dip (>>keywords) ;
+ over [ [ keywords>> ] bi@ ?update ] dip keywords<< ;
: import-rules ( parent child -- )
swap [ add-rule ] curry each-rule ;
TAG: KEYWORDS parse-rule-tag
rule-set get ignore-case?>> <keyword-map>
swap children-tags [ over parse-keyword-tag ] each
- swap (>>keywords) ;
+ swap keywords<< ;
: ?<regexp> ( string/f -- regexp/f )
dup [ rule-set get ignore-case?>> <?insensitive-regexp> ] when ;
: (parse-rules-tag) ( tag -- rule-set )
<rule-set> dup rule-set set
{
- { "SET" string>rule-set-name (>>name) }
- { "IGNORE_CASE" string>boolean (>>ignore-case?) }
- { "HIGHLIGHT_DIGITS" string>boolean (>>highlight-digits?) }
- { "DIGIT_RE" ?<regexp> (>>digit-re) }
+ { "SET" string>rule-set-name name<< }
+ { "IGNORE_CASE" string>boolean ignore-case?<< }
+ { "HIGHLIGHT_DIGITS" string>boolean highlight-digits?<< }
+ { "DIGIT_RE" ?<regexp> digit-re<< }
{ "ESCAPE" f add-escape-rule }
- { "DEFAULT" string>token (>>default) }
- { "NO_WORD_SEP" f (>>no-word-sep) }
+ { "DEFAULT" string>token default<< }
+ { "NO_WORD_SEP" f no-word-sep<< }
} init-from-tag ;
: parse-rules-tag ( tag -- rule-set )
swap position-attrs <matcher> ;
: shared-tag-attrs ( -- )
- { "TYPE" string>token (>>body-token) } , ; inline
+ { "TYPE" string>token body-token<< } , ; inline
: parse-delegate ( string -- pair )
"::" split1 [ rule-set get swap ] unless* 2array ;
: delegate-attr ( -- )
- { "DELEGATE" f (>>delegate) } , ;
+ { "DELEGATE" f delegate<< } , ;
: regexp-attr ( -- )
- { "HASH_CHAR" f (>>chars) } , ;
+ { "HASH_CHAR" f chars<< } , ;
: match-type-attr ( -- )
- { "MATCH_TYPE" string>match-type (>>match-token) } , ;
+ { "MATCH_TYPE" string>match-type match-token<< } , ;
: span-attrs ( -- )
- { "NO_LINE_BREAK" string>boolean (>>no-line-break?) } ,
- { "NO_WORD_BREAK" string>boolean (>>no-word-break?) } ,
- { "NO_ESCAPE" string>boolean (>>no-escape?) } , ;
+ { "NO_LINE_BREAK" string>boolean no-line-break?<< } ,
+ { "NO_WORD_BREAK" string>boolean no-word-break?<< } ,
+ { "NO_ESCAPE" string>boolean no-escape?<< } , ;
: literal-start ( -- )
[ parse-literal-matcher >>start drop ] , ;
add-remaining-token
[ rule-match-token* next-token, ] keep
! ... end subst ...
- dup context get (>>in-rule)
+ dup context get in-rule<<
delegate>> push-context ;
M: span-rule handle-rule-end
?end-rule
mark-token add-remaining-token
[ rule-match-token* next-token, ] keep
- f context get (>>end)
- context get (>>in-rule) ;
+ f context get end<<
+ context get in-rule<< ;
M: mark-following-rule handle-rule-end
nip rule-match-token* prev-token,
- f context get (>>in-rule) ;
+ f context get in-rule<< ;
M: mark-previous-rule handle-rule-start
?end-rule
: init-span ( rule -- )
dup delegate>> [ drop ] [
dup body-token>> standard-rule-set
- swap (>>delegate)
+ swap delegate<<
] if ;
: init-eol-span ( rule -- )
: add-escape-rule ( string ruleset -- )
over [
[ <escape-rule> ] dip
- 2dup (>>escape-rule)
+ 2dup escape-rule<<
add-rule
] [
2drop
"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
{ $table
{ "Reader" "Writer" "Setter" "Changer" }
- { { $snippet "name>>" } { $snippet "(>>name)" } { $snippet ">>name" } { $snippet "change-name" } }
- { { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } }
- { { $snippet "position>>" } { $snippet "(>>position)" } { $snippet ">>position" } { $snippet "change-position" } }
+ { { $snippet "name>>" } { $snippet "name<<" } { $snippet ">>name" } { $snippet "change-name" } }
+ { { $snippet "salary>>" } { $snippet "salary<<" } { $snippet ">>salary" } { $snippet "change-salary" } }
+ { { $snippet "position>>" } { $snippet "position<<" } { $snippet ">>position" } { $snippet "change-position" } }
}
"We can define a constructor which makes an empty employee:"
{ $code ": <employee> ( -- employee )"
[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test
-[ f ] [ \ reshape-test \ (>>x) method ] unit-test
+[ f ] [ \ reshape-test \ x<< method ] unit-test
[ "tuple" get 5 >>x ] must-fail
] [
2dup capacity > [ 2dup expand ] when
] if
- (>>length) ;
+ length<< ;
: new-size ( old -- new ) 1 + 3 * ; inline
2dup length >= [
2dup capacity >= [ over new-size over expand ] when
[ >fixnum ] dip
- over 1 fixnum+fast over (>>length)
+ over 1 fixnum+fast over length<<
] [
[ >fixnum ] dip
] if ; inline
M: growable lengthen ( n seq -- )
2dup length > [
2dup capacity > [ over new-size over expand ] when
- 2dup (>>length)
+ 2dup length<<
] when 2drop ; inline
M: growable shorten ( n seq -- )
growable-check
2dup length < [
2dup contract
- 2dup (>>length)
+ 2dup length<<
] when 2drop ; inline
M: growable new-resizable new-sequence 0 over set-length ; inline
: push-unsafe ( elt seq -- )
[ length ] keep
[ underlying>> set-array-nth ]
- [ [ 1 fixnum+fast { array-capacity } declare ] dip (>>length) ]
+ [ [ 1 fixnum+fast { array-capacity } declare ] dip length<< ]
2bi ; inline
PRIVATE>
: (stream-seek) ( n seek-type stream -- )
swap {
- { seek-absolute [ (>>i) ] }
+ { seek-absolute [ i<< ] }
{ seek-relative [ [ + ] change-i drop ] }
- { seek-end [ [ underlying>> length + ] [ (>>i) ] bi ] }
+ { seek-end [ [ underlying>> length + ] [ i<< ] bi ] }
[ bad-seek-type ]
} case ;
: change-lexer-column ( lexer quot -- )
[ [ column>> ] [ line-text>> ] bi ] prepose keep
- (>>column) ; inline
+ column<< ; inline
GENERIC: skip-blank ( lexer -- )
[ 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 )
{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or else outputs one of the endpoints." } ;
HELP: between?
-{ $values { "x" object } { "y" object } { "z" real } { "?" "a boolean" } }
+{ $values { "x" object } { "y" object } { "z" object } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
{ "selector" quotation } { "accum1" vector } { "accum2" vector } }
{ $description "Creates two new vectors to accumultate values based on a predicate. The first vector accumulates values for which the predicate yields true; the second for false." } ;
-HELP: 2reverse-each
-{ $values
- { "seq1" sequence } { "seq2" sequence } { "quot" quotation } }
-{ $description "Reverse the sequences using the " { $link <reversed> } " word and calls " { $link 2each } " on the reversed sequences." }
-{ $examples { $example "USING: sequences math prettyprint ;"
- "{ 10 20 30 } { 1 2 3 } [ + . ] 2reverse-each"
- "33\n22\n11"
-} } ;
-
HELP: 2unclip-slice
{ $values
{ "seq1" sequence } { "seq2" sequence }
: 2each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
(2each) each-integer ; inline
-: 2reverse-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
- [ [ <reversed> ] bi@ ] dip 2each ; inline
-
: 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
[ -rot ] dip 2each ; inline
"The following uses writers, and requires some stack shuffling:"
{ $code
"<email>"
- " \"Happy birthday\" over (>>subject)"
- " { \"bob@bigcorp.com\" } over (>>to)"
- " \"alice@bigcorp.com\" over (>>from)"
+ " \"Happy birthday\" over subject<<"
+ " { \"bob@bigcorp.com\" } over to<<"
+ " \"alice@bigcorp.com\" over from<<"
"send-email"
}
"Even if some of the slot values come from the stack underneath the tuple being constructed, setters win:"
"The above has less shuffling than the writer version:"
{ $code
"<email>"
- " [ (>>subject) ] keep"
- " [ (>>to) ] keep"
- " \"alice@bigcorp.com\" over (>>from)"
+ " [ subject<< ] keep"
+ " [ to<< ] keep"
+ " \"alice@bigcorp.com\" over from<<"
"send-email"
}
"The changer word abstracts a common pattern where a slot value is read then stored again; so the following is not idiomatic code:"
TUPLE: protocol-slot-test-tuple x ;
M: protocol-slot-test-tuple my-protocol-slot-test>> x>> sq ;
-M: protocol-slot-test-tuple (>>my-protocol-slot-test) [ sqrt ] dip (>>x) ;
+M: protocol-slot-test-tuple my-protocol-slot-test<< [ sqrt ] dip x<< ;
[ 9 ] [ T{ protocol-slot-test-tuple { x 3 } } my-protocol-slot-test>> ] unit-test
] 2bi ;
: writer-word ( name -- word )
- "(>>" ")" surround "accessors" create
+ "<<" append "accessors" create
dup t "writer" set-word-prop ;
ERROR: bad-slot-value value class ;
definitions ;
: record-top-level-form ( quot file -- )
- (>>top-level-form)
+ top-level-form<<
[ ] [ H{ } notify-definition-observers ] if-bootstrapping ;
: record-checksum ( lines source-file -- )
- [ crc32 checksum-lines ] dip (>>checksum) ;
+ [ crc32 checksum-lines ] dip checksum<< ;
: record-definitions ( file -- )
new-definitions get >>definitions drop ;
[ column>> ] [ line-text>> ] bi
] dip swap subseq
] [
- lexer get (>>column)
+ lexer get column<<
] bi ;
: rest-of-line ( lexer -- seq )
"))" parse-effect suffix!
] define-core-syntax
- "MAIN:" [ scan-word current-vocab (>>main) ] define-core-syntax
+ "MAIN:" [ scan-word current-vocab main<< ] define-core-syntax
"<<" [
[
: set-current-vocab ( name -- )
create-vocab
- [ manifest get (>>current-vocab) ] [ (add-qualified) ] bi ;
+ [ manifest get current-vocab<< ] [ (add-qualified) ] bi ;
: with-current-vocab ( name quot -- )
manifest get clone manifest [
: (set-tag) ( -- )
elements get id>> 31 bitand
- dup elements get (>>tag)
+ dup elements get tag<<
31 < [
[ "unsupported tag encoding: #{" %
get-id # "}" %
: set-tagclass ( -- )
get-id -6 shift tag-classes nth
- elements get (>>tagclass) ;
+ elements get tagclass<< ;
: set-encoding ( -- )
get-id HEX: 20 bitand
zero? "primitive" "constructed" ?
- elements get (>>encoding) ;
+ elements get encoding<< ;
: set-content-length ( -- )
read1
dup 127 <= [
127 bitand read be>
- ] unless elements get (>>contentlength) ;
+ ] unless elements get contentlength<< ;
: set-newobj ( -- )
elements get contentlength>> read
- elements get (>>newobj) ;
+ elements get newobj<< ;
: set-objtype ( syntax -- )
builtin-syntax 2array [
elements get encoding>> swap at
elements get tag>>
swap at [
- elements get (>>objtype)
+ elements get objtype<<
] when*
] each ;
} case ;
: set-id ( -- boolean )
- read1 dup elements get (>>id) ;
+ read1 dup elements get id<< ;
: read-ber ( syntax -- object )
element new
] with-scope ; inline
: set-tag ( value -- )
- tagnum get (>>value) ;
+ tagnum get value<< ;
M: string >ber ( str -- byte-array )
tagnum get value>> 1array "C" pack-native swap dup
first2 {
[ [ [ 1 + ] change-count ] bi@ 2drop ]
[ 2dup = [ [ 1 + ] change-self-count ] when 2drop ]
- [ [ [ color>> ] bi@ complement-color ] [ [ (>>color) ] bi-curry@ bi ] 2bi ]
+ [ [ [ color>> ] bi@ complement-color ] [ [ color<< ] bi-curry@ bi ] 2bi ]
[ [ mailbox>> f swap mailbox-put ] bi@ ]
} 2cleave ;
sequence-parser current quote-char = [
sequence-parser advance* string
] [
- start-n sequence-parser (>>n) f
+ start-n sequence-parser n<< f
] if ;
: (take-token) ( sequence-parser -- string )
SLOT: (n)
SLOT: (vectored)
-FUNCTOR: define-vectored-accessors ( S>> (>>S) T -- )
+FUNCTOR: define-vectored-accessors ( S>> S<< T -- )
WHERE
M: T S>>
[ (n)>> ] [ (vectored)>> S>> ] bi nth-unsafe ; inline
-M: T (>>S)
+M: T S<<
[ (n)>> ] [ (vectored)>> S>> ] bi set-nth-unsafe ; inline
;FUNCTOR
: cfg-vertex, ( bb -- )
[ number>> number>string ]
- [ kill-block? { "color=grey" "style=filled" } { } ? ]
+ [ kill-block?>> { "color=grey" "style=filled" } { } ? ]
bi node-style, ;
: cfgs ( cfgs -- )
#! Return the 16-bit pseudo register AF.
[ a>> 8 shift ] keep f>> bitor ;
-: (>>af) ( value cpu -- )
+: af<< ( value cpu -- )
#! Set the value of the 16-bit pseudo register AF
[ >word< ] dip swap >>f swap >>a drop ;
#! Return the 16-bit pseudo register BC.
[ b>> 8 shift ] keep c>> bitor ;
-: (>>bc) ( value cpu -- )
+: bc<< ( value cpu -- )
#! Set the value of the 16-bit pseudo register BC
[ >word< ] dip swap >>c swap >>b drop ;
#! Return the 16-bit pseudo register DE.
[ d>> 8 shift ] keep e>> bitor ;
-: (>>de) ( value cpu -- )
+: de<< ( value cpu -- )
#! Set the value of the 16-bit pseudo register DE
[ >word< ] dip swap >>e swap >>d drop ;
#! Return the 16-bit pseudo register HL.
[ h>> 8 shift ] keep l>> bitor ;
-: (>>hl) ( value cpu -- )
+: hl<< ( value cpu -- )
#! Set the value of the 16-bit pseudo register HL
[ >word< ] dip swap >>l swap >>h drop ;
[ pc>> ] keep
[ read-byte ] keep
[ pc>> 1 + ] keep
- (>>pc) ;
+ pc<< ;
: next-word ( cpu -- word )
#! Return the value of the word at PC, and increment PC.
[ pc>> ] keep
[ read-word ] keep
[ pc>> 2 + ] keep
- (>>pc) ;
+ pc<< ;
: write-byte ( value addr cpu -- )
: cpu-a-bitand ( quot cpu -- )
#! A &= quot call
- [ a>> swap call bitand ] keep (>>a) ; inline
+ [ a>> swap call bitand ] keep a<< ; inline
: cpu-a-bitor ( quot cpu -- )
#! A |= quot call
- [ a>> swap call bitor ] keep (>>a) ; inline
+ [ a>> swap call bitor ] keep a<< ; inline
: cpu-a-bitxor ( quot cpu -- )
#! A ^= quot call
- [ a>> swap call bitxor ] keep (>>a) ; inline
+ [ a>> swap call bitxor ] keep a<< ; inline
: cpu-a-bitxor= ( value cpu -- )
#! cpu-a ^= value
- [ a>> bitxor ] keep (>>a) ;
+ [ a>> bitxor ] keep a<< ;
: cpu-f-bitand ( quot cpu -- )
#! F &= quot call
- [ f>> swap call bitand ] keep (>>f) ; inline
+ [ f>> swap call bitand ] keep f<< ; inline
: cpu-f-bitor ( quot cpu -- )
#! F |= quot call
- [ f>> swap call bitor ] keep (>>f) ; inline
+ [ f>> swap call bitor ] keep f<< ; inline
: cpu-f-bitxor ( quot cpu -- )
#! F |= quot call
- [ f>> swap call bitxor ] keep (>>f) ; inline
+ [ f>> swap call bitxor ] keep f<< ; inline
: cpu-f-bitor= ( value cpu -- )
#! cpu-f |= value
- [ f>> bitor ] keep (>>f) ;
+ [ f>> bitor ] keep f<< ;
: cpu-f-bitand= ( value cpu -- )
#! cpu-f &= value
- [ f>> bitand ] keep (>>f) ;
+ [ f>> bitand ] keep f<< ;
: cpu-f-bitxor= ( value cpu -- )
#! cpu-f ^= value
- [ f>> bitxor ] keep (>>f) ;
+ [ f>> bitxor ] keep f<< ;
: set-flag ( cpu flag -- )
swap cpu-f-bitor= ;
: decrement-sp ( n cpu -- )
#! Decrement the stackpointer by n.
[ sp>> ] keep
- [ swap - ] dip (>>sp) ;
+ [ swap - ] dip sp<< ;
: save-pc ( cpu -- )
#! Save the value of the PC on the stack.
: call-sub ( addr cpu -- )
#! Call the address as a subroutine.
dup push-pc
- [ HEX: FFFF bitand ] dip (>>pc) ;
+ [ HEX: FFFF bitand ] dip pc<< ;
: ret-from-sub ( cpu -- )
- [ pop-pc ] keep (>>pc) ;
+ [ pop-pc ] keep pc<< ;
: interrupt ( number cpu -- )
#! Perform a hardware interrupt
! "***Interrupt: " write over 16 >base print
dup f>> interrupt-flag bitand 0 = not [
dup push-pc
- (>>pc)
+ pc<<
] [
2drop
] if ;
: inc-cycles ( n cpu -- )
#! Increment the number of cpu cycles
- [ cycles>> + ] keep (>>cycles) ;
+ [ cycles>> + ] keep cycles<< ;
: instruction-cycles ( -- vector )
#! Return a 256 element vector containing the cycles for
#! Read the next instruction from the cpu's program
#! counter, and increment the program counter.
[ pc>> ] keep ! pc cpu
- [ over 1 + swap (>>pc) ] keep
+ [ over 1 + swap pc<< ] keep
read-byte ;
: get-cycles ( n -- opcode )
over 16667 < [
2drop
] [
- [ [ 16667 - ] dip (>>cycles) ] keep
+ [ [ 16667 - ] dip cycles<< ] keep
dup last-interrupt>> HEX: 10 = [
- HEX: 08 over (>>last-interrupt) HEX: 08 swap interrupt
+ HEX: 08 over last-interrupt<< HEX: 08 swap interrupt
] [
- HEX: 10 over (>>last-interrupt) HEX: 10 swap interrupt
+ HEX: 10 over last-interrupt<< HEX: 10 swap interrupt
] if
] if ;
#! where the 1st item is the getter and the 2nd is the setter
#! for that register.
H{
- { "A" { a>> (>>a) } }
- { "B" { b>> (>>b) } }
- { "C" { c>> (>>c) } }
- { "D" { d>> (>>d) } }
- { "E" { e>> (>>e) } }
- { "H" { h>> (>>h) } }
- { "L" { l>> (>>l) } }
- { "AF" { af>> (>>af) } }
- { "BC" { bc>> (>>bc) } }
- { "DE" { de>> (>>de) } }
- { "HL" { hl>> (>>hl) } }
- { "SP" { sp>> (>>sp) } }
+ { "A" { a>> a<< } }
+ { "B" { b>> b<< } }
+ { "C" { c>> c<< } }
+ { "D" { d>> d<< } }
+ { "E" { e>> e<< } }
+ { "H" { h>> h<< } }
+ { "L" { l>> l<< } }
+ { "AF" { af>> af<< } }
+ { "BC" { bc>> bc<< } }
+ { "DE" { de>> de<< } }
+ { "HL" { hl>> hl<< } }
+ { "SP" { sp>> sp<< } }
} at ;
#! Given a string containing a flag name, return a vector
#! where the 1st item is a word that tests that flag.
H{
- { "NZ" { flag-nz? } }
- { "NC" { flag-nc? } }
- { "PO" { flag-po? } }
- { "PE" { flag-pe? } }
+ { "NZ" { flag-nz? } }
+ { "NC" { flag-nc? } }
+ { "PO" { flag-po? } }
+ { "PE" { flag-pe? } }
{ "Z" { flag-z? } }
{ "C" { flag-c? } }
{ "P" { flag-p? } }
- { "M" { flag-m? } }
+ { "M" { flag-m? } }
} at ;
SYMBOLS: $1 $2 $3 $4 ;
: (emulate-RST) ( n cpu -- )
#! RST nn
[ sp>> 2 - dup ] keep ! sp sp cpu
- [ (>>sp) ] keep ! sp cpu
+ [ sp<< ] keep ! sp cpu
[ pc>> ] keep ! sp pc cpu
swapd [ write-word ] keep ! cpu
- [ 8 * ] dip (>>pc) ;
+ [ 8 * ] dip pc<< ;
: (emulate-CALL) ( cpu -- )
#! 205 - CALL nn
[ next-word HEX: FFFF bitand ] keep ! addr cpu
[ sp>> 2 - dup ] keep ! addr sp sp cpu
- [ (>>sp) ] keep ! addr sp cpu
+ [ sp<< ] keep ! addr sp cpu
[ pc>> ] keep ! addr sp pc cpu
swapd [ write-word ] keep ! addr cpu
- (>>pc) ;
+ pc<< ;
: (emulate-RLCA) ( cpu -- )
#! The content of the accumulator is rotated left
[ a>> -7 shift ] keep
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
[ a>> 1 shift HEX: FF bitand ] keep
- [ bitor ] dip (>>a) ;
+ [ bitor ] dip a<< ;
: (emulate-RRCA) ( cpu -- )
#! The content of the accumulator is rotated right
[ a>> 1 bitand 7 shift ] keep
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
[ a>> 254 bitand -1 shift ] keep
- [ bitor ] dip (>>a) ;
+ [ bitor ] dip a<< ;
: (emulate-RLA) ( cpu -- )
#! The content of the accumulator is rotated left
[ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
[ a>> 127 bitand 7 shift ] keep
dup a>> 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
- [ bitor ] dip (>>a) ;
+ [ bitor ] dip a<< ;
: (emulate-RRA) ( cpu -- )
#! The content of the accumulator is rotated right
[ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
[ a>> 254 bitand -1 shift ] keep
dup a>> 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
- [ bitor ] dip (>>a) ;
+ [ bitor ] dip a<< ;
: (emulate-CPL) ( cpu -- )
#! The contents of the accumulator are complemented
] keep
[ a>> + ] keep
[ update-flags ] 2keep
- [ swap HEX: FF bitand swap (>>a) ] keep
+ [ swap HEX: FF bitand swap a<< ] keep
[
dup carry-flag swap flag-set? swap
a>> -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
] keep
[ a>> + ] keep
[ update-flags ] 2keep
- swap HEX: FF bitand swap (>>a) ;
+ swap HEX: FF bitand swap a<< ;
: patterns ( -- hashtable )
#! table of code quotation patterns for each type of instruction.
H{
- { "NOP" [ drop ] }
- { "RET-NN" [ ret-from-sub ] }
- { "RST-0" [ 0 swap (emulate-RST) ] }
- { "RST-8" [ 8 swap (emulate-RST) ] }
- { "RST-10H" [ HEX: 10 swap (emulate-RST) ] }
- { "RST-18H" [ HEX: 18 swap (emulate-RST) ] }
- { "RST-20H" [ HEX: 20 swap (emulate-RST) ] }
- { "RST-28H" [ HEX: 28 swap (emulate-RST) ] }
- { "RST-30H" [ HEX: 30 swap (emulate-RST) ] }
- { "RST-38H" [ HEX: 38 swap (emulate-RST) ] }
- { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
- { "CP-N" [ [ a>> ] keep [ next-byte ] keep sub-byte drop ] }
- { "CP-R" [ [ a>> ] keep [ $1 ] keep sub-byte drop ] }
- { "CP-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
- { "OR-N" [ [ a>> ] keep [ next-byte ] keep [ or-byte ] keep (>>a) ] }
- { "OR-R" [ [ a>> ] keep [ $1 ] keep [ or-byte ] keep (>>a) ] }
- { "OR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep (>>a) ] }
- { "XOR-N" [ [ a>> ] keep [ next-byte ] keep [ xor-byte ] keep (>>a) ] }
- { "XOR-R" [ [ a>> ] keep [ $1 ] keep [ xor-byte ] keep (>>a) ] }
- { "XOR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep (>>a) ] }
- { "AND-N" [ [ a>> ] keep [ next-byte ] keep [ and-byte ] keep (>>a) ] }
- { "AND-R" [ [ a>> ] keep [ $1 ] keep [ and-byte ] keep (>>a) ] }
- { "AND-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep (>>a) ] }
- { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
- { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
- { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
- { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
- { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
- { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
- { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] }
- { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
- { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
- { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
- { "SUB-R" [ [ a>> ] keep [ $1 ] keep [ sub-byte ] keep (>>a) ] }
- { "SUB-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep (>>a) ] }
- { "SUB-N" [ [ a>> ] keep [ next-byte ] keep [ sub-byte ] keep (>>a) ] }
- { "CPL" [ (emulate-CPL) ] }
- { "DAA" [ (emulate-DAA) ] }
- { "RLA" [ (emulate-RLA) ] }
- { "RRA" [ (emulate-RRA) ] }
- { "CCF" [ carry-flag swap cpu-f-bitxor= ] }
- { "SCF" [ carry-flag swap cpu-f-bitor= ] }
- { "RLCA" [ (emulate-RLCA) ] }
- { "RRCA" [ (emulate-RRCA) ] }
- { "HALT" [ drop ] }
- { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] }
- { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] }
- { "POP-RR" [ [ pop-sp ] keep $2 ] }
- { "PUSH-RR" [ [ $1 ] keep push-sp ] }
- { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] }
- { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] }
- { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] }
- { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] }
- { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
- { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] }
- { "JP-NN" [ [ pc>> ] keep [ read-word ] keep (>>pc) ] }
- { "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ (>>pc) ] keep [ cycles>> ] keep swap 5 + swap (>>cycles) ] [ [ pc>> 2 + ] keep (>>pc) ] if ] }
- { "JP-(RR)" [ [ $1 ] keep (>>pc) ] }
- { "CALL-NN" [ (emulate-CALL) ] }
- { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ pc>> 2 + ] keep (>>pc) ] if ] }
- { "LD-RR,NN" [ [ next-word ] keep $2 ] }
- { "LD-RR,RR" [ [ $3 ] keep $2 ] }
- { "LD-R,N" [ [ next-byte ] keep $2 ] }
- { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] }
- { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] }
- { "LD-R,R" [ [ $3 ] keep $2 ] }
- { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] }
- { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] }
- { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] }
- { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] }
- { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] }
- { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] }
- { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep (>>a) ] }
- { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
- { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
+ { "NOP" [ drop ] }
+ { "RET-NN" [ ret-from-sub ] }
+ { "RST-0" [ 0 swap (emulate-RST) ] }
+ { "RST-8" [ 8 swap (emulate-RST) ] }
+ { "RST-10H" [ HEX: 10 swap (emulate-RST) ] }
+ { "RST-18H" [ HEX: 18 swap (emulate-RST) ] }
+ { "RST-20H" [ HEX: 20 swap (emulate-RST) ] }
+ { "RST-28H" [ HEX: 28 swap (emulate-RST) ] }
+ { "RST-30H" [ HEX: 30 swap (emulate-RST) ] }
+ { "RST-38H" [ HEX: 38 swap (emulate-RST) ] }
+ { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
+ { "CP-N" [ [ a>> ] keep [ next-byte ] keep sub-byte drop ] }
+ { "CP-R" [ [ a>> ] keep [ $1 ] keep sub-byte drop ] }
+ { "CP-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
+ { "OR-N" [ [ a>> ] keep [ next-byte ] keep [ or-byte ] keep a<< ] }
+ { "OR-R" [ [ a>> ] keep [ $1 ] keep [ or-byte ] keep a<< ] }
+ { "OR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep a<< ] }
+ { "XOR-N" [ [ a>> ] keep [ next-byte ] keep [ xor-byte ] keep a<< ] }
+ { "XOR-R" [ [ a>> ] keep [ $1 ] keep [ xor-byte ] keep a<< ] }
+ { "XOR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep a<< ] }
+ { "AND-N" [ [ a>> ] keep [ next-byte ] keep [ and-byte ] keep a<< ] }
+ { "AND-R" [ [ a>> ] keep [ $1 ] keep [ and-byte ] keep a<< ] }
+ { "AND-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep a<< ] }
+ { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
+ { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
+ { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
+ { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
+ { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
+ { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
+ { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] }
+ { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
+ { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
+ { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
+ { "SUB-R" [ [ a>> ] keep [ $1 ] keep [ sub-byte ] keep a<< ] }
+ { "SUB-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep a<< ] }
+ { "SUB-N" [ [ a>> ] keep [ next-byte ] keep [ sub-byte ] keep a<< ] }
+ { "CPL" [ (emulate-CPL) ] }
+ { "DAA" [ (emulate-DAA) ] }
+ { "RLA" [ (emulate-RLA) ] }
+ { "RRA" [ (emulate-RRA) ] }
+ { "CCF" [ carry-flag swap cpu-f-bitxor= ] }
+ { "SCF" [ carry-flag swap cpu-f-bitor= ] }
+ { "RLCA" [ (emulate-RLCA) ] }
+ { "RRCA" [ (emulate-RRCA) ] }
+ { "HALT" [ drop ] }
+ { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] }
+ { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] }
+ { "POP-RR" [ [ pop-sp ] keep $2 ] }
+ { "PUSH-RR" [ [ $1 ] keep push-sp ] }
+ { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] }
+ { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] }
+ { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] }
+ { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] }
+ { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
+ { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] }
+ { "JP-NN" [ [ pc>> ] keep [ read-word ] keep pc<< ] }
+ { "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ pc<< ] keep [ cycles>> ] keep swap 5 + swap cycles<< ] [ [ pc>> 2 + ] keep pc<< ] if ] }
+ { "JP-(RR)" [ [ $1 ] keep pc<< ] }
+ { "CALL-NN" [ (emulate-CALL) ] }
+ { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ pc>> 2 + ] keep pc<< ] if ] }
+ { "LD-RR,NN" [ [ next-word ] keep $2 ] }
+ { "LD-RR,RR" [ [ $3 ] keep $2 ] }
+ { "LD-R,N" [ [ next-byte ] keep $2 ] }
+ { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] }
+ { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] }
+ { "LD-R,R" [ [ $3 ] keep $2 ] }
+ { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] }
+ { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] }
+ { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] }
+ { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] }
+ { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] }
+ { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] }
+ { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep a<< ] }
+ { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
+ { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
} ;
: 8-bit-registers ( -- parser )
over get-cycles over inc-cycles\r
[ swap instructions nth call( cpu -- ) ] keep\r
[ pc>> HEX: FFFF bitand ] keep \r
- [ (>>pc) ] keep \r
+ [ pc<< ] keep \r
process-interrupts ;\r
\r
: test-step ( cpu -- cpu )\r
combinators continuations cuda.ffi cuda.memory cuda.utils
destructors fry init io io.backend io.encodings.string
io.encodings.utf8 kernel lexer locals macros math math.parser
-namespaces nested-comments opengl.gl.extensions parser
-prettyprint quotations sequences words cuda.libraries ;
-QUALIFIED-WITH: alien.c-types a
+namespaces opengl.gl.extensions parser prettyprint quotations
+sequences words cuda.libraries ;
+QUALIFIED-WITH: alien.c-types c
IN: cuda
TUPLE: launcher
swap >>device ; inline
TUPLE: function-launcher
-dim-block dim-grid shared-size stream ;
+dim-grid dim-block shared-size stream ;
-: with-cuda-context ( flags device quot -- )
+: (set-up-cuda-context) ( flags device create-quot -- )
H{ } clone cuda-modules set-global
H{ } clone cuda-functions set
- [ create-context ] dip
+ call ; inline
+
+: (with-cuda-context) ( context quot -- )
[ '[ _ @ ] ]
- [ drop '[ _ destroy-context ] ] 2bi
+ [ drop '[ [ sync-context ] ignore-errors _ destroy-context ] ] 2bi
[ ] cleanup ; inline
+: with-cuda-context ( flags device quot -- )
+ [ [ create-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; 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
- [ H{ } clone cuda-memory-hashtable ] 2dip '[
- _
+ init-cuda [
[ cuda-launcher set ]
[ [ device>> ] [ device-flags>> ] bi ] bi
- _ with-cuda-program
- ] with-variable ; inline
+ ] [ with-cuda-program ] bi* ; inline
: c-type>cuda-setter ( c-type -- n cuda-type )
{
- { [ dup a:int = ] [ drop 4 [ cuda-int* ] ] }
- { [ dup a:uint = ] [ drop 4 [ cuda-int* ] ] }
- { [ dup a:float = ] [ drop 4 [ cuda-float* ] ] }
- { [ dup a:pointer? ] [ drop 4 [ ptr>> cuda-int* ] ] }
- { [ dup a:void* = ] [ drop 4 [ ptr>> cuda-int* ] ] }
+ { [ 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>> first3 function-block-shape* ]
+ [ dim-block>> block-dim function-block-shape* ]
[ shared-size>> function-shared-size* ]
[
- dim-grid>> [
- launch-function*
- ] [
- first2 launch-function-grid*
- ] if-empty
+ dim-grid>>
+ [ grid-dim launch-function-grid* ]
+ [ launch-function* ] if*
]
} 2cleave ;
[ run-function-launcher ] 2bi
]
]
- [ 2nip \ function-launcher suffix a:void function-effect ]
+ [ 2nip \ function-launcher suffix c:void function-effect ]
3bi define-declared ;
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 ;
+math.parser namespaces sequences byte-arrays strings ;
IN: cuda.demos.hello-world
CUDA-LIBRARY: hello vocab:cuda/demos/hello-world/hello.ptx
: cuda-hello-world ( -- )
[
- cuda-launcher get device>> number>string
- "CUDA device " ": " surround write
- "Hello World!" [ - ] map-index host>device
+ [
+ cuda-launcher get device>> number>string
+ "CUDA device " ": " surround write
+ "Hello World!" >byte-array [ - ] map-index host>device &cuda-free
- [ { 6 1 1 } { 2 1 } 2<<< helloWorld ]
- [ device>host utf8 decode print ] bi
+ [ { 2 1 } { 6 1 1 } 2<<< helloWorld ]
+ [ 12 device>host >string print ] bi
+ ] with-destructors
] with-each-cuda-device ;
MAIN: cuda-hello-world
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: cuda.devices tools.test ;
+IN: cuda.devices.tests
+
+[ 1 5 100 ] [ 5 20 100 10 (distribute-jobs) ] unit-test
+[ 2 5 100 ] [ 10 20 100 10 (distribute-jobs) ] unit-test
+[ 2 5 100 ] [ 10 20 200 5 (distribute-jobs) ] unit-test
+[ 2 5 100 ] [ 10 20 300 6 (distribute-jobs) ] unit-test
+[ 2 6 120 ] [ 11 20 300 6 (distribute-jobs) ] unit-test
+[ 1 10 200 ] [ 10 20 200 10 (distribute-jobs) ] unit-test
+[ 1 10 0 ] [ 10 0 200 10 (distribute-jobs) ] unit-test
+[ 2 5 0 ] [ 10 0 200 9 (distribute-jobs) ] unit-test
+
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.data alien.strings arrays assocs
-byte-arrays classes.struct combinators cuda cuda.ffi cuda.utils
-fry io io.encodings.utf8 kernel math.parser prettyprint
-sequences ;
+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 ;
IN: cuda.devices
: #cuda-devices ( -- n )
- init-cuda
int <c-object> [ cuDeviceGetCount cuda-error ] keep *int ;
: n>cuda-device ( n -- device )
- init-cuda
[ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ;
: enumerate-cuda-devices ( -- devices )
[ enumerate-cuda-devices ] dip '[ <launcher> _ with-cuda ] each ; inline
: cuda-device-properties ( n -- properties )
- init-cuda
- [ CUdevprop <c-object> ] dip
- [ cuDeviceGetProperties cuda-error ] 2keep drop
- CUdevprop memory>struct ;
+ [ CUdevprop <struct> ] dip
+ [ cuDeviceGetProperties cuda-error ] 2keep drop ;
: cuda-devices ( -- assoc )
enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
: cuda-device-name ( n -- string )
- init-cuda
[ 256 [ <byte-array> ] keep ] dip
[ cuDeviceGetName cuda-error ]
[ 2drop utf8 alien>string ] 3bi ;
: cuda-device-capability ( n -- pair )
- init-cuda
[ int <c-object> int <c-object> ] dip
[ cuDeviceComputeCapability cuda-error ]
[ drop [ *int ] bi@ ] 3bi 2array ;
: cuda-device-memory ( n -- bytes )
- init-cuda
[ uint <c-object> ] dip
[ cuDeviceTotalMem cuda-error ]
[ drop *uint ] 2bi ;
: cuda-device-attribute ( attribute n -- n )
- init-cuda
[ int <c-object> ] 2dip
[ cuDeviceGetAttribute cuda-error ]
[ 2drop *int ] 3bi ;
: cuda-device. ( n -- )
- init-cuda
{
[ "Device: " write number>string print ]
[ "Name: " write cuda-device-name print ]
"CUDA Version: " write cuda-version number>string print nl
#cuda-devices iota [ nl ] [ cuda-device. ] interleave ;
+: up/i ( x y -- z )
+ [ 1 - + ] keep /i ; 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
+ job-count min :> job-max-block-size
+ job-count job-max-block-size up/i :> grid-size
+ job-count grid-size up/i :> block-size
+ block-size per-job-shared * :> per-block-shared
+
+ 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
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien.c-types alien.syntax cuda.ffi opengl.gl ;
+IN: cuda.gl.ffi
+
+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
+continuations cuda cuda.ffi cuda.gl.ffi cuda.utils destructors
+fry gpu.buffers kernel ;
+IN: cuda.gl
+
+: create-gl-cuda-context ( flags device -- context )
+ [ CUcontext <c-object> ] 2dip
+ [ cuGLCtxCreate cuda-error ] 3keep 2drop *void* ; inline
+
+: with-gl-cuda-context ( flags device quot -- )
+ [ [ create-gl-cuda-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline
+
+: gl-buffer>resource ( gl-buffer flags -- resource )
+ [ 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 alien.data assocs byte-arrays cuda.ffi
-cuda.utils destructors io.encodings.string io.encodings.utf8
-kernel locals namespaces sequences strings ;
-QUALIFIED-WITH: alien.c-types a
+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 ;
+QUALIFIED-WITH: alien.c-types c
IN: cuda.memory
-SYMBOL: cuda-memory-hashtable
-
-TUPLE: cuda-memory < disposable ptr length ;
-
-: <cuda-memory> ( ptr length -- obj )
- cuda-memory new-disposable
- swap >>length
- swap >>ptr ;
-
-: add-cuda-memory ( obj -- obj )
- dup dup ptr>> cuda-memory-hashtable get set-at ;
-
-: delete-cuda-memory ( obj -- )
- cuda-memory-hashtable delete-at ;
-
-ERROR: invalid-cuda-memory ptr ;
-
-: cuda-memory-length ( cuda-memory -- n )
- ptr>> cuda-memory-hashtable get ?at [
- length>>
- ] [
- invalid-cuda-memory
- ] if ;
-
-M: cuda-memory byte-length length>> ;
-
: cuda-malloc ( n -- ptr )
[ CUdeviceptr <c-object> ] dip
- [ cuMemAlloc cuda-error ] 2keep
- [ a:*int ] dip <cuda-memory> add-cuda-memory ;
+ '[ _ cuMemAlloc cuda-error ] keep
+ c:*int ; inline
+
+: cuda-malloc-type ( n type -- ptr )
+ c:heap-size * cuda-malloc ; inline
-: cuda-free* ( ptr -- )
- cuMemFree cuda-error ;
+: cuda-free ( ptr -- )
+ cuMemFree cuda-error ; inline
-M: cuda-memory dispose ( ptr -- )
- ptr>> cuda-free* ;
+DESTRUCTOR: cuda-free
: memcpy-device>device ( dest-ptr src-ptr count -- )
- cuMemcpyDtoD cuda-error ;
+ cuMemcpyDtoD cuda-error ; inline
: memcpy-device>array ( dest-array dest-index src-ptr count -- )
- cuMemcpyDtoA cuda-error ;
+ cuMemcpyDtoA cuda-error ; inline
: memcpy-array>device ( dest-ptr src-array src-index count -- )
- cuMemcpyAtoD cuda-error ;
+ cuMemcpyAtoD cuda-error ; inline
: memcpy-array>host ( dest-ptr src-array src-index count -- )
- cuMemcpyAtoH cuda-error ;
+ cuMemcpyAtoH cuda-error ; inline
: memcpy-host>array ( dest-array dest-index src-ptr count -- )
- cuMemcpyHtoA cuda-error ;
+ cuMemcpyHtoA cuda-error ; inline
: memcpy-array>array ( dest-array dest-index src-array src-ptr count -- )
- cuMemcpyAtoA cuda-error ;
+ cuMemcpyAtoA cuda-error ; inline
-GENERIC: host>device ( obj -- ptr )
+: memcpy-host>device ( dest-ptr src-ptr count -- )
+ cuMemcpyHtoD cuda-error ; inline
-M: string host>device utf8 encode host>device ;
+: memcpy-device>host ( dest-ptr src-ptr count -- )
+ cuMemcpyDtoH cuda-error ; inline
-M: byte-array host>device ( byte-array -- ptr )
- [ length cuda-malloc ] keep
- [ [ ptr>> ] dip dup length cuMemcpyHtoD cuda-error ]
- [ drop ] 2bi ;
+: host>device ( data -- ptr )
+ [ >c-ptr ] [ byte-length ] bi
+ [ nip cuda-malloc dup ] [ memcpy-host>device ] 2bi ; inline
-:: device>host ( ptr -- seq )
- ptr byte-length <byte-array>
- [ ptr [ ptr>> ] [ byte-length ] bi cuMemcpyDtoH cuda-error ] keep ;
+: device>host ( ptr len -- byte-array )
+ [ nip <byte-array> dup ] [ memcpy-device>host ] 2bi ; inline
scan [ create-in current-cuda-library get ] [ ] bi
";" scan-c-args drop define-cuda-word ;
-: 2<<< ( dim-block dim-grid -- function-launcher )
- 0 f function-launcher boa ;
+: 2<<< ( dim-grid dim-block -- function-launcher )
+ 0 f function-launcher boa ; inline
-: 3<<< ( dim-block dim-grid shared-size -- function-launcher )
- f function-launcher boa ;
+: 3<<< ( dim-grid dim-block shared-size -- function-launcher )
+ f function-launcher boa ; inline
-: 4<<< ( dim-block dim-grid shared-size stream -- function-launcher )
- function-launcher boa ;
+: 4<<< ( dim-grid dim-block shared-size stream -- function-launcher )
+ function-launcher boa ; inline
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors alien.c-types classes.struct kernel math ;
+FROM: alien.c-types => float ;
+IN: cuda.types
+
+STRUCT: char1
+ { x char } ;
+STRUCT: char2
+ { x char }
+ { y char } ;
+STRUCT: char3
+ { x char }
+ { y char }
+ { z char } ;
+STRUCT: char4
+ { x char }
+ { y char }
+ { z char }
+ { w char } ;
+
+STRUCT: uchar1
+ { x uchar } ;
+STRUCT: uchar2
+ { x uchar }
+ { y uchar } ;
+STRUCT: uchar3
+ { x uchar }
+ { y uchar }
+ { z uchar } ;
+STRUCT: uchar4
+ { x uchar }
+ { y uchar }
+ { z uchar }
+ { w uchar } ;
+
+STRUCT: short1
+ { x short } ;
+STRUCT: short2
+ { x short }
+ { y short } ;
+STRUCT: short3
+ { x short }
+ { y short }
+ { z short } ;
+STRUCT: short4
+ { x short }
+ { y short }
+ { z short }
+ { w short } ;
+
+STRUCT: ushort1
+ { x ushort } ;
+STRUCT: ushort2
+ { x ushort }
+ { y ushort } ;
+STRUCT: ushort3
+ { x ushort }
+ { y ushort }
+ { z ushort } ;
+STRUCT: ushort4
+ { x ushort }
+ { y ushort }
+ { z ushort }
+ { w ushort } ;
+
+STRUCT: int1
+ { x int } ;
+STRUCT: int2
+ { x int }
+ { y int } ;
+STRUCT: int3
+ { x int }
+ { y int }
+ { z int } ;
+STRUCT: int4
+ { x int }
+ { y int }
+ { z int }
+ { w int } ;
+
+STRUCT: uint1
+ { x uint } ;
+STRUCT: uint2
+ { x uint }
+ { y uint } ;
+STRUCT: uint3
+ { x uint }
+ { y uint }
+ { z uint } ;
+STRUCT: uint4
+ { x uint }
+ { y uint }
+ { z uint }
+ { w uint } ;
+
+STRUCT: long1
+ { x long } ;
+STRUCT: long2
+ { x long }
+ { y long } ;
+STRUCT: long3
+ { x long }
+ { y long }
+ { z long } ;
+STRUCT: long4
+ { x long }
+ { y long }
+ { z long }
+ { w long } ;
+
+STRUCT: ulong1
+ { x ulong } ;
+STRUCT: ulong2
+ { x ulong }
+ { y ulong } ;
+STRUCT: ulong3
+ { x ulong }
+ { y ulong }
+ { z ulong } ;
+STRUCT: ulong4
+ { x ulong }
+ { y ulong }
+ { z ulong }
+ { w ulong } ;
+
+STRUCT: longlong1
+ { x longlong } ;
+STRUCT: longlong2
+ { x longlong }
+ { y longlong } ;
+STRUCT: longlong3
+ { x longlong }
+ { y longlong }
+ { z longlong } ;
+STRUCT: longlong4
+ { x longlong }
+ { y longlong }
+ { z longlong }
+ { w longlong } ;
+
+STRUCT: ulonglong1
+ { x ulonglong } ;
+STRUCT: ulonglong2
+ { x ulonglong }
+ { y ulonglong } ;
+STRUCT: ulonglong3
+ { x ulonglong }
+ { y ulonglong }
+ { z ulonglong } ;
+STRUCT: ulonglong4
+ { x ulonglong }
+ { y ulonglong }
+ { z ulonglong }
+ { w ulonglong } ;
+
+STRUCT: float1
+ { x float } ;
+STRUCT: float2
+ { x float }
+ { y float } ;
+STRUCT: float3
+ { x float }
+ { y float }
+ { z float } ;
+STRUCT: float4
+ { x float }
+ { y float }
+ { z float }
+ { w float } ;
+
+STRUCT: double1
+ { x double } ;
+STRUCT: double2
+ { x double }
+ { y double } ;
+STRUCT: double3
+ { x double }
+ { y double }
+ { z double } ;
+STRUCT: double4
+ { x double }
+ { y double }
+ { z double }
+ { w double } ;
+
+char2 c-type
+ 2 >>align
+ 2 >>align-first
+ drop
+char4 c-type
+ 4 >>align
+ 4 >>align-first
+ drop
+
+uchar2 c-type
+ 2 >>align
+ 2 >>align-first
+ drop
+uchar4 c-type
+ 4 >>align
+ 4 >>align-first
+ drop
+
+short2 c-type
+ 4 >>align
+ 4 >>align-first
+ drop
+short4 c-type
+ 8 >>align
+ 8 >>align-first
+ drop
+
+ushort2 c-type
+ 4 >>align
+ 4 >>align-first
+ drop
+ushort4 c-type
+ 8 >>align
+ 8 >>align-first
+ drop
+
+int2 c-type
+ 8 >>align
+ 8 >>align-first
+ drop
+int4 c-type
+ 16 >>align
+ 16 >>align-first
+ drop
+
+uint2 c-type
+ 8 >>align
+ 8 >>align-first
+ drop
+uint4 c-type
+ 16 >>align
+ 16 >>align-first
+ drop
+
+long2 c-type
+ long heap-size 2 * >>align
+ long heap-size 2 * >>align-first
+ drop
+long4 c-type
+ 16 >>align
+ 16 >>align-first
+ drop
+
+ulong2 c-type
+ long heap-size 2 * >>align
+ long heap-size 2 * >>align-first
+ drop
+ulong4 c-type
+ 16 >>align
+ 16 >>align-first
+ drop
+
+longlong2 c-type
+ 16 >>align
+ 16 >>align-first
+ drop
+longlong4 c-type
+ 16 >>align
+ 16 >>align-first
+ drop
+
+ulonglong2 c-type
+ 16 >>align
+ 16 >>align-first
+ drop
+ulonglong4 c-type
+ 16 >>align
+ 16 >>align-first
+ drop
+
+float2 c-type
+ 8 >>align
+ 8 >>align-first
+ drop
+float4 c-type
+ 16 >>align
+ 16 >>align-first
+ drop
+
+double2 c-type
+ 16 >>align
+ 16 >>align-first
+ drop
+double4 c-type
+ 16 >>align
+ 16 >>align-first
+ drop
! 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
+assocs byte-arrays classes.struct combinators cuda.ffi
+io io.backend io.encodings.utf8 kernel math.parser namespaces
prettyprint sequences ;
IN: cuda.utils
dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error ] if ;
: init-cuda ( -- )
- 0 cuInit cuda-error ;
+ 0 cuInit cuda-error ; inline
: cuda-version ( -- n )
int <c-object> [ cuDriverGetVersion cuda-error ] keep *int ;
: create-context ( flags device -- context )
[ CUcontext <c-object> ] 2dip
- [ cuCtxCreate cuda-error ] 3keep 2drop *void* ;
+ [ cuCtxCreate cuda-error ] 3keep 2drop *void* ; inline
-: destroy-context ( context -- ) cuCtxDestroy cuda-error ;
+: sync-context ( -- )
+ cuCtxSynchronize cuda-error ; inline
-: launch-function* ( function -- ) cuLaunch cuda-error ;
+: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
-: launch-function ( -- ) cuda-function get cuLaunch cuda-error ;
+: launch-function* ( function -- ) cuLaunch cuda-error ; inline
+
+: launch-function ( -- ) cuda-function get cuLaunch cuda-error ; inline
: cuda-int* ( function offset value -- )
- cuParamSeti cuda-error ;
+ cuParamSeti cuda-error ; inline
: cuda-int ( offset value -- )
- [ cuda-function get ] 2dip cuda-int* ;
+ [ cuda-function get ] 2dip cuda-int* ; inline
: cuda-float* ( function offset value -- )
- cuParamSetf cuda-error ;
+ cuParamSetf cuda-error ; inline
: cuda-float ( offset value -- )
- [ cuda-function get ] 2dip cuda-float* ;
+ [ cuda-function get ] 2dip cuda-float* ; inline
: cuda-vector* ( function offset ptr n -- )
- cuParamSetv cuda-error ;
+ cuParamSetv cuda-error ; inline
: cuda-vector ( offset ptr n -- )
- [ cuda-function get ] 3dip cuda-vector* ;
+ [ cuda-function get ] 3dip cuda-vector* ; inline
: param-size* ( function n -- )
- cuParamSetSize cuda-error ;
+ cuParamSetSize cuda-error ; inline
: param-size ( n -- )
- [ cuda-function get ] dip param-size* ;
+ [ cuda-function get ] dip param-size* ; inline
: launch-function-grid* ( function width height -- )
- cuLaunchGrid cuda-error ;
+ cuLaunchGrid cuda-error ; inline
: launch-function-grid ( width height -- )
[ cuda-function get ] 2dip
- cuLaunchGrid cuda-error ;
+ cuLaunchGrid cuda-error ; inline
: function-block-shape* ( function x y z -- )
- cuFuncSetBlockShape cuda-error ;
+ cuFuncSetBlockShape cuda-error ; inline
: function-block-shape ( x y z -- )
[ cuda-function get ] 3dip
- cuFuncSetBlockShape cuda-error ;
+ cuFuncSetBlockShape cuda-error ; inline
: function-shared-size* ( function n -- )
- cuFuncSetSharedSize cuda-error ;
+ cuFuncSetSharedSize cuda-error ; inline
: function-shared-size ( n -- )
[ cuda-function get ] dip
- cuFuncSetSharedSize cuda-error ;
+ cuFuncSetSharedSize cuda-error ; inline
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Sam Anklesaria.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel parser vocabs.parser words ;
-IN: enter
-! main words are usually only used for entry, doing initialization, etc
-! it makes sense, then to define it all at once, rather than factoring it out into a seperate word
-! and then declaring it main
-SYNTAX: ENTER: gensym [ parse-definition (( -- )) define-declared ] keep current-vocab (>>main) ;
\ No newline at end of file
triple
world handle>> hWnd>>
fullscreen? [
- enable-fullscreen world (>>saved-position)
+ enable-fullscreen world saved-position<<
] [
[ world saved-position>> ] 2dip disable-fullscreen
] if
- fullscreen? world (>>fullscreen?)
+ fullscreen? world fullscreen?<<
] when ;
: set-fullscreen ( gadget triple fullscreen? -- )
t >>running?
[ reset-loop-benchmark ]
[ [ run-loop ] curry "game loop" spawn ]
- [ (>>thread) ] tri ;
+ [ thread<< ] tri ;
: stop-loop ( loop -- )
f >>running?
[ material new swap >>name current-material set ]
[ cm swap md set-at ] bi
] }
- { "Ka" [ 3 head strings>numbers cm (>>ambient-reflectivity) ] }
- { "Kd" [ 3 head strings>numbers cm (>>diffuse-reflectivity) ] }
- { "Ks" [ 3 head strings>numbers cm (>>specular-reflectivity) ] }
- { "Tf" [ 3 head strings>numbers cm (>>transmission-filter) ] }
- { "d" [ first string>number cm (>>dissolve) ] }
- { "Ns" [ first string>number cm (>>specular-exponent) ] }
- { "Ni" [ first string>number cm (>>refraction-index) ] }
- { "map_Ka" [ first cm (>>ambient-map) ] }
- { "map_Kd" [ first cm (>>diffuse-map) ] }
- { "map_Ks" [ first cm (>>specular-map) ] }
- { "map_Ns" [ first cm (>>specular-exponent-map) ] }
- { "map_d" [ first cm (>>dissolve-map) ] }
- { "map_bump" [ first cm (>>bump-map) ] }
- { "bump" [ first cm (>>bump-map) ] }
- { "disp" [ first cm (>>displacement-map) ] }
- { "refl" [ first cm (>>reflection-map) ] }
+ { "Ka" [ 3 head strings>numbers cm ambient-reflectivity<< ] }
+ { "Kd" [ 3 head strings>numbers cm diffuse-reflectivity<< ] }
+ { "Ks" [ 3 head strings>numbers cm specular-reflectivity<< ] }
+ { "Tf" [ 3 head strings>numbers cm transmission-filter<< ] }
+ { "d" [ first string>number cm dissolve<< ] }
+ { "Ns" [ first string>number cm specular-exponent<< ] }
+ { "Ni" [ first string>number cm refraction-index<< ] }
+ { "map_Ka" [ first cm ambient-map<< ] }
+ { "map_Kd" [ first cm diffuse-map<< ] }
+ { "map_Ks" [ first cm specular-map<< ] }
+ { "map_Ns" [ first cm specular-exponent-map<< ] }
+ { "map_d" [ first cm dissolve-map<< ] }
+ { "map_bump" [ first cm bump-map<< ] }
+ { "bump" [ first cm bump-map<< ] }
+ { "disp" [ first cm displacement-map<< ] }
+ { "refl" [ first cm reflection-map<< ] }
[ 2drop ]
} case
] unless-empty ;
M: indexed-seq new-resizable
[ dseq>> ] [ iseq>> ] [ rassoc>> ] tri <indexed-seq>
dup -rot
- [ [ dseq>> new-resizable ] keep (>>dseq) ]
- [ [ iseq>> new-resizable ] keep (>>iseq) ]
- [ [ rassoc>> clone nip ] keep (>>rassoc) ]
+ [ [ dseq>> new-resizable ] keep dseq<< ]
+ [ [ iseq>> new-resizable ] keep iseq<< ]
+ [ [ rassoc>> clone nip ] keep rassoc<< ]
2tri ;
! (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
{ "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 ]
: configure-termios ( serial -- )
dup termios>>
{
- [ [ iflag>> ] dip over [ (>>iflag) ] [ 2drop ] if ]
- [ [ oflag>> ] dip over [ (>>oflag) ] [ 2drop ] if ]
+ [ [ iflag>> ] dip over [ iflag<< ] [ 2drop ] if ]
+ [ [ oflag>> ] dip over [ oflag<< ] [ 2drop ] if ]
[
[
[ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor
- ] dip (>>cflag)
+ ] dip cflag<<
]
- [ [ lflag>> ] dip over [ (>>lflag) ] [ 2drop ] if ]
+ [ [ lflag>> ] dip over [ lflag<< ] [ 2drop ] if ]
} 2cleave ;
: tciflush ( serial -- )
2bi ;
M: irc-server-chat (attach-chat)
- irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ;
+ irc> [ client<< ] [ chats>> +server-chat+ set-at ] 2bi ;
GENERIC: remove-chat ( irc-chat -- )
M: irc-nick-chat remove-chat name>> unregister-chat ;
: apply-mode ( ? participant mode -- )
{
- { CHAR: o [ (>>operator) ] }
- { CHAR: v [ (>>voice) ] }
+ { CHAR: o [ operator<< ] }
+ { CHAR: v [ voice<< ] }
[ 3drop ]
} case ;
GENERIC: set-irc-command ( irc-message -- )
M: irc-message set-irc-command
- [ irc-command-string ] [ (>>command) ] bi ;
+ [ irc-command-string ] [ command<< ] bi ;
: irc-message>string ( irc-message -- string )
{
[ >>parameters ]
[ >>trailing ]
tri*
- [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
+ [ prefix<< ] [ fill-irc-message-slots ] [ swap >>line ] tri
dup sender >>sender ;
:: move-axis ( gadget x y z -- )
x y z (xyz>loc) :> ( xy z )
- xy gadget indicator>> (>>loc)
- z gadget z-indicator>> (>>loc) ;
+ xy gadget indicator>> loc<<
+ z gadget z-indicator>> loc<< ;
: move-pov ( gadget pov -- )
swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ]
gadget controller>> read-controller buttons>> length iota [
number>string [ drop ] <border-button>
shelf over add-gadget drop
- ] map gadget (>>buttons) ;
+ ] map gadget buttons<< ;
: add-button-gadgets ( gadget shelf -- gadget shelf )
[ (add-button-gadgets) ] 2keep ;
: update-key-caps-state ( gadget -- )
read-keyboard keys>> over keys>>
- [ [ (>>selected?) ] [ drop ] if* ] 2each
+ [ [ selected?<< ] [ drop ] if* ] 2each
relayout-1 ;
M: key-caps-gadget graft*
] "" append-outputs-as send-everyone ;
: handle-quit ( string -- )
- client [ (>>object) ] [ t >>quit? drop ] bi ;
+ client [ object<< ] [ t >>quit? drop ] bi ;
: handle-help ( string -- )
[
] [
[ username swap warn-name-changed ]
[ username clients rename-at ]
- [ client (>>username) ] tri
+ [ client username<< ] tri
] if
] if-empty ;
M: chat-server handle-already-logged-in
username username-taken-string send-line
- t client (>>quit?) ;
+ t client quit?<< ;
M: chat-server handle-managed-client*
- readln dup f = [ t client (>>quit?) ] when
+ readln dup f = [ t client quit?<< ] when
[
"/" ?head [ handle-command ] [ handle-chat ] if
] unless-empty ;
username clients key? [
handle-already-logged-in
] [
- t client (>>logged-in?)
+ t client logged-in?<<
client username clients set-at
] if ;
M: model-world begin-game-world
init-gpu
{ 0.0 0.0 2.0 } 0 0 set-wasd-view
- [ <model-state> [ fill-model-state ] keep ] [ (>>model-state) ] bi ;
+ [ <model-state> [ fill-model-state ] keep ] [ model-state<< ] bi ;
M: model-world apply-world-attributes
{
[ model-path>> >>model-path ]
[ [ value>> ] dip set-model f ]
[ 2drop t ] if 100 milliseconds sleep
] 2curry "models.conditional" spawn-server
- ] keep (>>thread) ;
+ ] keep thread<< ;
: <conditional> ( condition -- model )
f conditional new-model swap >>condition ;
M: mdb-persistent id>> ( object -- id )
dup class id-slot reader-word execute( object -- id ) ;
-M: mdb-persistent (>>id) ( object value -- )
+M: mdb-persistent id<< ( object value -- )
over class id-slot writer-word execute( object value -- ) ;
] if-key ; inline
M: pair set-at
- [ (>>value) ] [
+ [ value<< ] [
[ set-at ]
[ [ associate ] dip swap >>hash drop ] if-hash
] if-key ; inline
: (init) ( from to astar -- )
swap >>goal
- H{ } clone over astar>> (>>g)
- { } <hash-set> over astar>> (>>in-closed-set)
+ H{ } clone over astar>> g<<
+ { } <hash-set> over astar>> in-closed-set<<
H{ } clone >>origin
H{ } clone >>in-open-set
<min-heap> >>open-set
PRIVATE>
: find-path ( start target astar -- path/f )
- (astar) new [ (>>astar) ] keep [ (init) ] [ (find-path) ] bi ;
+ (astar) new [ astar<< ] keep [ (init) ] [ (find-path) ] bi ;
: <astar> ( neighbours cost heuristic -- astar )
astar-simple new swap >>heuristic swap >>cost swap >>neighbours ;
: get-ok-and-total ( -- total )
stream [
readln dup "+OK" head? [
- " " split second string>number dup account (>>count)
+ " " split second string>number dup account count<<
] [ throw ] if
] with-stream* ;
: (list) ( -- )
stream [
"LIST" command
- readlns account (>>list)
+ readlns account list<<
] with-stream* ;
: (uidls) ( -- )
stream [
"UIDL" command
- readlns account (>>uidls)
+ readlns account uidls<<
] with-stream* ;
PRIVATE>
: capa ( -- array )
stream [
"CAPA" command
- readlns dup account (>>capa)
+ readlns dup account capa<<
] with-stream* ;
: count ( -- n )
"TOP " _ number>string append " "
append _ number>string append
command
- readlns dup raw (>>top)
+ readlns dup raw top<<
] with-stream* ;
: headers ( -- assoc )
: retrieve ( message# -- seq )
[ stream ] dip '[
"RETR " _ number>string append command
- readlns dup raw (>>content)
+ readlns dup raw content<<
] with-stream* ;
: delete ( message# -- )
SYNTAX: SOLUTION:
scan-word
[ name>> "-main" append create-in ] keep
- [ drop current-vocab (>>main) ]
+ [ drop current-vocab main<< ]
[ [ . ] swap prefix (( -- )) define-declared ]
2bi ;
: leaf-insert ( value point leaf -- )
2dup leaf-replaceable?
- [ [ (>>point) ] [ (>>value) ] bi ]
+ [ [ point<< ] [ value<< ] bi ]
[ split-leaf ] if ;
: node-insert ( value point node -- )
[ [ i>> ] [ Q>> ] bi nth-unsafe * ]
[ c>> + ] tri
- [ >fixnum -32 shift cmwc (>>c) ]
+ [ >fixnum -32 shift cmwc c<< ]
[ cmwc [ b>> bitand ] [ c>> + ] bi 32 bits ] bi
dup cmwc r>> > [
dupd <repeating> swap like ;
M: repeating length len>> ;
-M: repeating set-length (>>len) ;
+M: repeating set-length len<< ;
M: repeating virtual@ ( n seq -- n' seq' ) circular>> ;
[ [ \ tuple ] ] [ "Object" lexenv get lookup-reader ] unit-test
[ [ fake-local ] ] [ "jumble" lexenv get lookup-writer ] unit-test
-[ [ fake-self (>>y) ] ] [ "y" lexenv get lookup-writer ] unit-test
+[ [ fake-self y<< ] ] [ "y" lexenv get lookup-writer ] unit-test
[ "blahblah" lexenv get lookup-writer ] must-fail
\ No newline at end of file
: init-sounds ( cpu -- )
init-openal
- [ 9 gen-sources swap (>>sounds) ] keep
+ [ 9 gen-sources swap sounds<< ] keep
[ SOUND-SHOT "vocab:space-invaders/resources/Shot.wav" init-sound ] keep
[ SOUND-UFO "vocab:space-invaders/resources/Ufo.wav" init-sound ] keep
[ sounds>> SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep
[ SOUND-WALK3 "vocab:space-invaders/resources/Walk3.wav" init-sound ] keep
[ SOUND-WALK4 "vocab:space-invaders/resources/Walk4.wav" init-sound ] keep
[ SOUND-UFO-HIT "vocab:space-invaders/resources/UfoHit.wav" init-sound ] keep
- f swap (>>looping?) ;
+ f swap looping?<< ;
: cpu-init ( cpu -- cpu )
- make-opengl-bitmap over (>>bitmap)
+ make-opengl-bitmap over bitmap<<
[ init-sounds ] keep
[ reset ] keep ;
#! Bit 5 = player one left
#! Bit 6 = player one right
[ port1>> dup HEX: FE bitand ] keep
- (>>port1) ;
+ port1<< ;
: read-port2 ( cpu -- byte )
#! Port 2 maps player 2 controls and dip switches
: write-port2 ( value cpu -- )
#! Setting this value affects the value read from port 3
- (>>port2o) ;
+ port2o<< ;
:: bit-newly-set? ( old-value new-value bit -- bool )
new-value bit bit? [ old-value bit bit? not ] dip and ;
#! Bit 4 = Extended play sound
over 0 bit? over looping?>> not and [
dup SOUND-UFO play-invaders-sound
- t over (>>looping?)
+ t over looping?<<
] when
over 0 bit? not over looping?>> and [
dup SOUND-UFO stop-invaders-sound
- f over (>>looping?)
+ f over looping?<<
] when
2dup 0 port3-newly-set? [ dup SOUND-UFO play-invaders-sound ] when
2dup 1 port3-newly-set? [ dup SOUND-SHOT play-invaders-sound ] when
2dup 2 port3-newly-set? [ dup SOUND-BASE-HIT play-invaders-sound ] when
2dup 3 port3-newly-set? [ dup SOUND-INVADER-HIT play-invaders-sound ] when
- (>>port3o) ;
+ port3o<< ;
: write-port4 ( value cpu -- )
#! Affects the value returned by reading port 3
[ port4hi>> ] keep
- [ (>>port4lo) ] keep
- (>>port4hi) ;
+ [ port4lo<< ] keep
+ port4hi<< ;
: write-port5 ( value cpu -- )
#! Plays sounds
2dup 2 port5-newly-set? [ dup SOUND-WALK3 play-invaders-sound ] when
2dup 3 port5-newly-set? [ dup SOUND-WALK4 play-invaders-sound ] when
2dup 4 port5-newly-set? [ dup SOUND-UFO-HIT play-invaders-sound ] when
- (>>port5o) ;
+ port5o<< ;
M: space-invaders write-port ( value port cpu -- )
#! Write a byte to the hardware port, where 'port' is
over get-cycles over inc-cycles
[ swap instructions nth call( cpu -- ) ] keep
[ pc>> HEX: FFFF bitand ] keep
- (>>pc) ;
+ pc<< ;
: gui-frame/2 ( cpu -- )
[ gui-step ] keep
over 16667 < [ ! cycles cpu
nip gui-frame/2
] [
- [ [ 16667 - ] dip (>>cycles) ] keep
+ [ [ 16667 - ] dip cycles<< ] keep
dup last-interrupt>> HEX: 10 = [
- HEX: 08 over (>>last-interrupt) HEX: 08 swap interrupt
+ HEX: 08 over last-interrupt<< HEX: 08 swap interrupt
] [
- HEX: 10 over (>>last-interrupt) HEX: 10 swap interrupt
+ HEX: 10 over last-interrupt<< HEX: 10 swap interrupt
] if
] if ;
dup gui-frame/2 gui-frame/2 ;
: coin-down ( cpu -- )
- [ port1>> 1 bitor ] keep (>>port1) ;
+ [ port1>> 1 bitor ] keep port1<< ;
: coin-up ( cpu -- )
- [ port1>> 255 1 - bitand ] keep (>>port1) ;
+ [ port1>> 255 1 - bitand ] keep port1<< ;
: player1-down ( cpu -- )
- [ port1>> 4 bitor ] keep (>>port1) ;
+ [ port1>> 4 bitor ] keep port1<< ;
: player1-up ( cpu -- )
- [ port1>> 255 4 - bitand ] keep (>>port1) ;
+ [ port1>> 255 4 - bitand ] keep port1<< ;
: player2-down ( cpu -- )
- [ port1>> 2 bitor ] keep (>>port1) ;
+ [ port1>> 2 bitor ] keep port1<< ;
: player2-up ( cpu -- )
- [ port1>> 255 2 - bitand ] keep (>>port1) ;
+ [ port1>> 255 2 - bitand ] keep port1<< ;
: fire-down ( cpu -- )
- [ port1>> HEX: 10 bitor ] keep (>>port1) ;
+ [ port1>> HEX: 10 bitor ] keep port1<< ;
: fire-up ( cpu -- )
- [ port1>> 255 HEX: 10 - bitand ] keep (>>port1) ;
+ [ port1>> 255 HEX: 10 - bitand ] keep port1<< ;
: left-down ( cpu -- )
- [ port1>> HEX: 20 bitor ] keep (>>port1) ;
+ [ port1>> HEX: 20 bitor ] keep port1<< ;
: left-up ( cpu -- )
- [ port1>> 255 HEX: 20 - bitand ] keep (>>port1) ;
+ [ port1>> 255 HEX: 20 - bitand ] keep port1<< ;
: right-down ( cpu -- )
- [ port1>> HEX: 40 bitor ] keep (>>port1) ;
+ [ port1>> HEX: 40 bitor ] keep port1<< ;
: right-up ( cpu -- )
- [ port1>> 255 HEX: 40 - bitand ] keep (>>port1) ;
+ [ port1>> 255 HEX: 40 - bitand ] keep port1<< ;
TUPLE: invaders-gadget < gadget cpu quit? windowed? ;
invaders-gadget H{
- { T{ key-down f f "ESC" } [ t over (>>quit?) dup windowed?>> [ close-window ] [ drop ] if ] }
+ { T{ key-down f f "ESC" } [ t over quit?<< dup windowed?>> [ close-window ] [ drop ] if ] }
{ T{ key-down f f "BACKSPACE" } [ cpu>> coin-down ] }
{ T{ key-up f f "BACKSPACE" } [ cpu>> coin-up ] }
{ T{ key-down f f "1" } [ cpu>> player1-down ] }
M: invaders-gadget graft* ( gadget -- )
dup cpu>> init-sounds
- f over (>>quit?)
+ f over quit?<<
[ system:system-micros swap invaders-process ] curry
"Space invaders" threads:spawn drop ;
M: invaders-gadget ungraft* ( gadget -- )
- t swap (>>quit?) ;
+ t swap quit?<< ;
: (run) ( title cpu rom-info -- )
over load-rom* <invaders-gadget> t >>windowed? swap open-window ;
[ sample-freq>> -rot sine-wave ] keep swap >>data ;
: >silent-buffer ( seconds buffer -- buffer )
- [ sample-freq>> * >integer 0 <repetition> ] [ (>>data) ] [ ] tri ;
+ [ sample-freq>> * >integer 0 <repetition> ] [ data<< ] [ ] tri ;
TUPLE: harmonic n amplitude ;
C: <harmonic> harmonic
harmonic amplitude>> <scaled> ;
: >note ( harmonics note buffer -- buffer )
- [ [ note-harmonic-data ] 2curry map <summed> ] [ (>>data) ] [ ] tri ;
+ [ [ note-harmonic-data ] 2curry map <summed> ] [ data<< ] [ ] tri ;
read-keyboard keys>> :> keys
key-left-shift keys nth
- VELOCITY-MODIFIER-FAST VELOCITY-MODIFIER-NORMAL ? player (>>velocity-modifier)
+ VELOCITY-MODIFIER-FAST VELOCITY-MODIFIER-NORMAL ? player velocity-modifier<<
{
[ key-1 keys nth 1 f ? ]
[ key-3 keys nth 3 f ? ]
[ key-4 keys nth 4 f ? ]
[ key-5 keys nth 10000 f ? ]
- } 0|| player (>>reverse-time)
+ } 0|| player reverse-time<<
key-w keys nth [ player walk-forward ] when
key-s keys nth [ player walk-backward ] when
world history>> :> history
history length 0 > [
history length reverse-time 1 - - 1 max history set-length
- history pop world (>>player)
+ history pop world player<<
] when ;
: tick-player-forward ( world player -- )
[ tetris>> ?update ] [ relayout-1 ] bi ;
M: tetris-gadget graft* ( gadget -- )
- [ [ tick ] curry 100 milliseconds every ] keep (>>alarm) ;
+ [ [ tick ] curry 100 milliseconds every ] keep alarm<< ;
M: tetris-gadget ungraft* ( gadget -- )
[ cancel-alarm f ] change-alarm drop ;
: <tokyo-abstractdb> ( name -- tokyo-abstractdb )
tcadbnew [ swap tcadbopen drop ] keep
- tokyo-abstractdb new [ (>>handle) ] keep ;
+ tokyo-abstractdb new [ handle<< ] keep ;
: <tokyo-remotedb> ( host port -- tokyo-remotedb )
[ tcrdbnew dup ] 2dip tcrdbopen drop
- tokyo-remotedb new [ (>>handle) ] keep ;
+ tokyo-remotedb new [ handle<< ] keep ;
: single-rotate ( node -- node )
0 >>balance
0 over node+link
- (>>balance) rotate ;
+ balance<< rotate ;
: pick-balances ( a node -- balance balance )
balance>> {
[
node+link [
node-link current-side get neg
- over pick-balances rot 0 swap (>>balance)
- ] keep (>>balance)
+ over pick-balances rot 0 swap balance<<
+ ] keep balance<<
] keep swap >>balance
dup node+link [ rotate ] with-other-side
over set-node+link rotate ;
: (avl-set) ( value key node -- node taller? )
2dup key>> = [
- -rot pick (>>key) over (>>value) f
+ -rot pick key<< over value<< f
] [ avl-insert ] if ;
: avl-set ( value key node -- node taller? )
: delete-select-rotate ( node -- node shorter? )
dup node+link balance>> zero? [
- current-side get neg over (>>balance)
- current-side get over node+link (>>balance) rotate f
+ current-side get neg over balance<<
+ current-side get over node+link balance<< rotate f
] [
select-rotate t
] if ;
: balance-delete ( node -- node shorter? )
current-side get over balance>> {
- { [ dup zero? ] [ drop neg over (>>balance) f ] }
+ { [ dup zero? ] [ drop neg over balance<< f ] }
{ [ dupd = ] [ drop 0 >>balance t ] }
[ dupd neg increase-balance rebalance-delete ]
} cond ;
: rotate-right ( node -- node )
dup left>>
- [ right>> swap (>>left) ] 2keep
- [ (>>right) ] keep ;
+ [ right>> swap left<< ] 2keep
+ [ right<< ] keep ;
: rotate-left ( node -- node )
dup right>>
- [ left>> swap (>>right) ] 2keep
- [ (>>left) ] keep ;
+ [ left>> swap right<< ] 2keep
+ [ left<< ] keep ;
: link-right ( left right key node -- left right key node )
- swap [ [ swap (>>left) ] 2keep
+ swap [ [ swap left<< ] 2keep
nip dup left>> ] dip swap ;
: link-left ( left right key node -- left right key node )
- swap [ rot [ (>>right) ] 2keep
+ swap [ rot [ right<< ] 2keep
drop dup right>> swapd ] dip swap ;
: cmp ( key node -- obj node <=> )
} case ;
: assemble ( head left right node -- root )
- [ right>> swap (>>left) ] keep
- [ left>> swap (>>right) ] keep
- [ swap left>> swap (>>right) ] 2keep
- [ swap right>> swap (>>left) ] keep ;
+ [ right>> swap left<< ] keep
+ [ left>> swap right<< ] keep
+ [ swap left>> swap right<< ] 2keep
+ [ swap right>> swap left<< ] keep ;
: splay-at ( key node -- node )
[ T{ node } clone dup dup ] 2dip
(splay) nip assemble ;
: do-splay ( key tree -- )
- [ root>> splay-at ] keep (>>root) ;
+ [ root>> splay-at ] keep root<< ;
: splay-split ( key tree -- node node )
2dup do-splay root>> cmp +lt+ = [
- nip dup left>> swap f over (>>left)
+ nip dup left>> swap f over left<<
] [
- nip dup right>> swap f over (>>right) swap
+ nip dup right>> swap f over right<< swap
] if ;
: get-splay ( key tree -- node ? )
: splay-join ( n2 n1 -- node )
splay-largest [
- [ (>>right) ] keep
+ [ right<< ] keep
] [
drop f
] if* ;
[ get-splay nip ] keep [
dup dec-count
dup right>> swap left>> splay-join
- swap (>>root)
+ swap root<<
] [ drop ] if* ;
: set-splay ( value key tree -- )
- 2dup get-splay [ 2nip (>>value) ] [
+ 2dup get-splay [ 2nip value<< ] [
drop dup inc-count
2dup splay-split rot
- [ [ swapd ] dip node boa ] dip (>>root)
+ [ [ swapd ] dip node boa ] dip root<<
] if ;
: new-root ( value key tree -- )
1 >>count
- [ swap <node> ] dip (>>root) ;
+ [ swap <node> ] dip root<< ;
M: splay set-at ( value key tree -- )
dup root>> [ set-splay ] [ new-root ] if ;
go-left? xor [ left>> ] [ right>> ] if ;
: set-node-link@ ( left parent ? -- )
- go-left? xor [ (>>left) ] [ (>>right) ] if ;
+ go-left? xor [ left<< ] [ right<< ] if ;
: node-link ( node -- child ) f node-link@ ;
dup list-empty? [
2drop
] [
- [ control-value length rem ] [ (>>index) ] [ ] tri
+ [ control-value length rem ] [ index<< ] [ ] tri
[ relayout-1 ] [ scroll>selected ] bi
] if ;
: [global-getter] ( box -- quot )
'[ _ value>> ] ;
: [global-setter] ( box -- quot )
- '[ _ (>>value) ] ;
+ '[ _ value<< ] ;
: define-global ( word -- )
global-box new [ [global-getter] ] [ [global-setter] ] bi (define-variable) ;
#define DEFINE_ALIEN_ACCESSOR(name,type,from,to) \
VM_C_API void primitive_alien_##name(factor_vm *parent) \
{ \
- parent->ctx->push(from(*(type*)(parent->alien_pointer()),parent)); \
+ parent->ctx->push(parent->from(*(type*)(parent->alien_pointer()))); \
} \
VM_C_API void primitive_set_alien_##name(factor_vm *parent) \
{ \
type *ptr = (type *)parent->alien_pointer(); \
- type value = (type)to(parent->ctx->pop(),parent); \
+ type value = (type)parent->to(parent->ctx->pop()); \
*ptr = value; \
}
return parent->alien_offset(obj);
}
-/* For FFI calls passing structs by value. Cannot allocate */
-void factor_vm::to_value_struct(cell src, void *dest, cell size)
-{
- memcpy(dest,alien_offset(src),size);
-}
-
-VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *parent)
-{
- return parent->to_value_struct(src,dest,size);
-}
-
/* For FFI callbacks receiving structs by value */
cell factor_vm::from_value_struct(void *src, cell 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 void to_value_struct(cell src, void *dest, cell size, 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);
}
/* allocates memory */
-#define FOO_TO_BIGNUM(name,type,utype) \
+#define FOO_TO_BIGNUM(name,type,stype,utype) \
bignum * factor_vm::name##_to_bignum(type n) \
{ \
int negative_p; \
if (n == 1) return (BIGNUM_ONE (0)); \
if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
{ \
- utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \
+ utype accumulator = ((negative_p = (n < (type)0)) ? ((type)(-(stype)n)) : n); \
do \
{ \
(*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
} \
}
-FOO_TO_BIGNUM(cell,cell,cell)
-FOO_TO_BIGNUM(fixnum,fixnum,cell)
-FOO_TO_BIGNUM(long_long,s64,u64)
-FOO_TO_BIGNUM(ulong_long,u64,u64)
+FOO_TO_BIGNUM(cell,cell,fixnum,cell)
+FOO_TO_BIGNUM(fixnum,fixnum,fixnum,cell)
+FOO_TO_BIGNUM(long_long,s64,s64,u64)
+FOO_TO_BIGNUM(ulong_long,u64,s64,u64)
/* cannot allocate memory */
-#define BIGNUM_TO_FOO(name,type,utype) \
+#define BIGNUM_TO_FOO(name,type,stype,utype) \
type factor_vm::bignum_to_##name(bignum * bignum) \
{ \
if (BIGNUM_ZERO_P (bignum)) \
bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
while (start < scan) \
accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
- return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? ((type)(-(stype)accumulator)) : accumulator); \
} \
}
-BIGNUM_TO_FOO(cell,cell,cell);
-BIGNUM_TO_FOO(fixnum,fixnum,cell);
-BIGNUM_TO_FOO(long_long,s64,u64)
-BIGNUM_TO_FOO(ulong_long,u64,u64)
+BIGNUM_TO_FOO(cell,cell,fixnum,cell);
+BIGNUM_TO_FOO(fixnum,fixnum,fixnum,cell);
+BIGNUM_TO_FOO(long_long,s64,s64,u64)
+BIGNUM_TO_FOO(ulong_long,u64,s64,u64)
double factor_vm::bignum_to_double(bignum * bignum)
{
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();
init_callbacks(p->callback_size);
load_image(p);
init_c_io();
- init_inline_caching(p->max_pic_size);
+ init_inline_caching((int)p->max_pic_size);
if(p->signals)
init_signals();
break;
}
- catch(const must_start_gc_again e)
+ catch(const must_start_gc_again &)
{
/* We come back here if a generation is full */
start_gc_again();
data_root<byte_array> buf(allot_uninitialized_array<byte_array>(size),this);
- int c = safe_fread(buf.untagged() + 1,1,size,file);
+ size_t c = safe_fread(buf.untagged() + 1,1,size,file);
if(c == 0)
ctx->push(false_object);
else
{
FILE *file = pop_file_handle();
fixnum ch = to_fixnum(ctx->pop());
- safe_fputc(ch, file);
+ safe_fputc((int)ch, file);
}
void factor_vm::primitive_fwrite()
void factor_vm::primitive_fseek()
{
FILE *file = pop_file_handle();
- int whence = to_fixnum(ctx->pop());
- off_t offset = to_signed_8(ctx->pop());
+ int whence = (int)to_fixnum(ctx->pop());
+ off_t offset = (off_t)to_signed_8(ctx->pop());
safe_fseek(file,offset,whence);
}
}
}
-VM_C_API s64 to_signed_8(cell obj, factor_vm *parent)
+VM_C_API s64 *to_signed_8(cell obj, factor_vm *parent)
{
- return parent->to_signed_8(obj);
+ parent->ctx->long_long_return = parent->to_signed_8(obj);
+ return &parent->ctx->long_long_return;
}
cell factor_vm::from_unsigned_8(u64 n)
}
}
-VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent)
+VM_C_API s64 *to_unsigned_8(cell obj, factor_vm *parent)
{
- return parent->to_unsigned_8(obj);
+ parent->ctx->long_long_return = parent->to_unsigned_8(obj);
+ return &parent->ctx->long_long_return;
}
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 u64 to_unsigned_8(cell obj, 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 fixnum to_fixnum(cell tagged, factor_vm *vm);
VM_C_API cell to_cell(cell tagged, factor_vm *vm);
_(unsigned_2,u16,from_unsigned_2,to_cell) \
_(signed_1,s8,from_signed_1,to_fixnum) \
_(unsigned_1,u8,from_unsigned_1,to_cell) \
- _(float,float,from_float,to_float) \
- _(double,double,from_double,to_double) \
+ _(float,float,allot_float,to_float) \
+ _(double,double,allot_float,to_double) \
_(cell,void *,allot_alien,pinned_alien_offset)
#define DECLARE_PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent);
void primitive_dlclose();
void primitive_dll_validp();
char *alien_offset(cell obj);
- void to_value_struct(cell src, void *dest, cell size);
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);
projects / factor.git / commitdiff