M: string-type c-type-getter
drop [ alien-cell ] ;
+M: string-type c-type-copier
+ drop [ ] ;
+
M: string-type c-type-setter
drop [ set-alien-cell ] ;
M: c-type c-type-getter getter>> ;
+GENERIC: c-type-copier ( name -- quot )
+
+M: c-type c-type-copier drop [ ] ;
+
GENERIC: c-type-setter ( name -- quot )
M: c-type c-type-setter setter>> ;
MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
[ c-type-getter ] [ c-type-boxer-quot ] bi append ;
+MACRO: alien-copy-value ( c-type -- quot: ( c-ptr offset -- value ) )
+ [ c-type-getter ] [ c-type-copier ] [ c-type-boxer-quot ] tri 3append ;
+
MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
[ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
[ c-type-setter ]
c-type-unboxer-quot
c-type-rep
c-type-getter
+ c-type-copier
c-type-setter
c-type-align
c-type-align-first
USING: alien alien.c-types help.syntax help.markup libc
kernel.private byte-arrays math strings hashtables alien.syntax
alien.strings sequences io.encodings.string debugger destructors
-vocabs.loader classes.struct ;
+vocabs.loader classes.struct quotations ;
IN: alien.data
HELP: <c-array>
{ string>alien alien>string malloc-string } related-words
+HELP: with-scoped-allocation
+{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } }
+{ $description "Allocates values on the call stack, calls the quotation, then deallocates the values as soon as the quotation returns."
+$nl
+"A scoped allocation specifier is either:"
+{ $list
+ "a C type name,"
+ { "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." }
+}
+"If no initial value is specified, the contents of the allocated memory are undefined." }
+{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." }
+{ $examples
+ { $example
+ "USING: accessors alien.c-types alien.data
+classes.struct kernel math math.functions
+prettyprint ;
+IN: scratchpad
+
+STRUCT: point { x int } { y int } ;
+
+: scoped-allocation-test ( -- x )
+ { point } [
+ 3 >>x 4 >>y
+ [ x>> sq ] [ y>> sq ] bi + sqrt
+ ] with-scoped-allocation ;
+
+scoped-allocation-test ."
+"5.0"
+ }
+} ;
+
+HELP: with-out-parameters
+{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } { "values..." "zero or more values" } }
+{ $description "Allocates values on the call stack, calls the quotation, then copies all stack allocated values to the data heap after the quotation returns."
+$nl
+"A scoped allocation specifier is either:"
+{ $list
+ "a C type name,"
+ { "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." }
+}
+"If no initial value is specified, the contents of the allocated memory are undefined." }
+{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." } ;
+
ARTICLE: "malloc" "Manual memory management"
"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
$nl
USING: accessors alien alien.c-types alien.arrays alien.strings
arrays byte-arrays cpu.architecture fry io io.encodings.binary
io.files io.streams.memory kernel libc math math.functions
-sequences words macros combinators generalizations ;
+sequences words macros combinators generalizations
+stack-checker.dependencies combinators.short-circuit ;
QUALIFIED: math
IN: alien.data
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
-M: value-type c-type-setter ( type -- quot )
+M: value-type c-type-copier
+ heap-size '[ _ memory>byte-array ] ;
+
+M: value-type c-type-setter
[ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
M: array c-type-boxer-quot
! to still be abl to access scope-allocated data.
;
+MACRO: (simple-local-allot) ( c-type -- quot )
+ [ depends-on-c-type ]
+ [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ;
+
+: [hairy-local-allot] ( c-type initial -- quot )
+ over '[ _ (simple-local-allot) _ over 0 _ set-alien-value ] ;
+
+: hairy-local-allot? ( obj -- ? )
+ {
+ [ array? ]
+ [ length 3 = ]
+ [ second initial: eq? ]
+ } 1&& ;
+
+MACRO: (hairy-local-allot) ( obj -- quot )
+ dup hairy-local-allot?
+ [ first3 nip [hairy-local-allot] ]
+ [ '[ _ (simple-local-allot) ] ]
+ if ;
+
MACRO: (local-allots) ( c-types -- quot )
- [ '[ _ [ heap-size ] [ c-type-align ] bi (local-allot) ] ] map [ ] join ;
+ [ '[ _ (hairy-local-allot) ] ] map [ ] join ;
MACRO: box-values ( c-types -- quot )
[ c-type-boxer-quot ] map '[ _ spread ] ;
MACRO: out-parameters ( c-types -- quot )
- [ length ] [ [ '[ 0 _ alien-value ] ] map ] bi
+ [ dup hairy-local-allot? [ first ] when ] map
+ [ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi
'[ _ nkeep _ spread ] ;
PRIVATE>
[ [ (local-allots) ] [ box-values ] bi ] dip call
(cleanup-allot) ; inline
-: with-out-parameters ( c-types quot finish -- values )
- [ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call
+: with-out-parameters ( c-types quot -- values... )
+ [ drop (local-allots) ] [ swap out-parameters ] 2bi
(cleanup-allot) ; inline
GENERIC: binary-zero? ( value -- ? )
M: integer binary-zero? zero? ; inline
M: math:float binary-zero? double>bits zero? ; inline
M: complex binary-zero? >rect [ binary-zero? ] both? ; inline
-
dup midnight time- ;
: since-1970 ( duration -- timestamp )
- unix-1970 time+ >local-time ;
+ unix-1970 time+ ;
: timestamp>unix-time ( timestamp -- seconds )
unix-1970 time- second>> ;
: digest-value ( ctx -- value )
handle>>
{ { int EVP_MAX_MD_SIZE } int }
- [ EVP_DigestFinal_ex ssl-error ]
- [ memory>byte-array ]
- with-out-parameters ;
+ [ EVP_DigestFinal_ex ssl-error ] with-out-parameters
+ memory>byte-array ;
PRIVATE>
objc-methods get set-at ;
: each-method-in-class ( class quot -- )
- [ { uint } [ class_copyMethodList ] [ ] with-out-parameters ] dip
+ [ { uint } [ class_copyMethodList ] with-out-parameters ] dip
over 0 = [ 3drop ] [
[ <direct-void*-array> ] dip
[ each ] [ drop (free) ] 2bi
: nib-objects ( anNSNib -- objects/f )
f
- { void* } [ -> instantiateNibWithOwner:topLevelObjects: ] [ ]
+ { void* } [ -> instantiateNibWithOwner:topLevelObjects: ]
with-out-parameters
swap [ CF>array ] [ drop f ] if ;
\ No newline at end of file
: (read-plist) ( NSData -- id )
NSPropertyListSerialization swap kCFPropertyListImmutable f
{ void* }
- [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] [ ]
+ [ -> propertyListFromData:mutabilityOption:format:errorDescription: ]
with-out-parameters
[ -> release "read-plist failed" throw ] when* ;
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
- T{ ##alien-invoke f "free" }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
T{ ##slot-imm f 2 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
- T{ ##alien-invoke f "free" }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
T{ ##slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##set-slot-imm f 1 0 1 0 }
- T{ ##alien-invoke f "free" }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
T{ ##slot-imm f 2 0 1 0 }
}
] [
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##set-slot-imm f 1 0 1 0 }
- T{ ##alien-invoke f "free" }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
T{ ##slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##set-slot-imm f 1 0 1 0 }
- T{ ##alien-invoke f "free" }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
T{ ##set-slot-imm f 2 0 1 0 }
}
] [
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##set-slot-imm f 1 0 1 0 }
- T{ ##alien-invoke f "free" }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
T{ ##set-slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
- T{ ##alien-invoke f "free" }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
T{ ##set-slot-imm f 1 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
- T{ ##alien-invoke f "free" }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
T{ ##set-slot-imm f 1 0 1 0 }
} test-alias-analysis
] unit-test
! anywhere its used as a tagged pointer. Boxing allocates
! a new value, except boxing instructions haven't been
! inserted yet.
- dup defs-vreg [
- over defs-vreg-rep { int-rep tagged-rep } member?
+ dup [
+ { int-rep tagged-rep } member?
[ set-heap-ac ] [ set-new-ac ] if
- ] when* ;
+ ] each-def-rep ;
M: ##phi analyze-aliases
- dup defs-vreg set-heap-ac ;
+ dup dst>> set-heap-ac ;
M: ##allocation analyze-aliases
#! A freshly allocated object is distinct from any other
allot-area-align [ a max ] change
allot-area-size [ a align [ insn offset<< ] [ s + ] bi ] change ;
-M: ##stack-frame compute-stack-frame*
+M: alien-call-insn compute-stack-frame*
frame-required
- stack-frame>> param-area-size [ max ] change ;
+ stack-size>> param-area-size [ max ] change ;
: vm-frame-required ( -- )
frame-required
M: ##box compute-stack-frame* drop vm-frame-required ;
M: ##unbox compute-stack-frame* drop vm-frame-required ;
M: ##box-long-long compute-stack-frame* drop vm-frame-required ;
-M: ##begin-callback compute-stack-frame* drop vm-frame-required ;
-M: ##end-callback compute-stack-frame* drop vm-frame-required ;
+M: ##callback-inputs compute-stack-frame* drop vm-frame-required ;
+M: ##callback-outputs compute-stack-frame* drop vm-frame-required ;
M: ##unary-float-function compute-stack-frame* drop vm-frame-required ;
M: ##binary-float-function compute-stack-frame* drop vm-frame-required ;
FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien
+: with-param-regs* ( quot -- reg-values stack-values )
+ '[
+ V{ } clone reg-values set
+ V{ } clone stack-values set
+ @
+ reg-values get
+ stack-values get
+ stack-params get
+ struct-return-area get
+ ] with-param-regs
+ struct-return-area set
+ stack-params set ; inline
+
: unbox-parameters ( parameters -- vregs reps )
[
[ length iota <reversed> ] keep
] keep
] [ drop f ] if ;
-: caller-parameter ( vreg rep on-stack? -- insn )
- [ dup reg-class-of reg-class-full? ] dip or
- [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
- [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
- if ;
-
: (caller-parameters) ( vregs reps -- )
- ! Place ##store-stack-param instructions first. This ensures
- ! that no registers are used after the ##store-reg-param
- ! instructions.
- [ first2 caller-parameter ] 2map
- [ ##store-stack-param? ] partition [ % ] bi@ ;
+ [ first2 next-parameter ] 2each ;
-: caller-parameters ( params -- stack-size )
+: caller-parameters ( params -- reg-inputs stack-inputs )
[ abi>> ] [ parameters>> ] [ return>> ] tri
'[
_ unbox-parameters
_ prepare-struct-caller struct-return-area set
(caller-parameters)
- stack-params get
- struct-return-area get
- ] with-param-regs
- struct-return-area set ;
+ ] with-param-regs* ;
+
+: prepare-caller-return ( params -- reg-outputs )
+ return>> [ { } ] [ base-type load-return ] if-void ;
-: box-return* ( node -- )
- return>> [ ] [ base-type box-return ds-push ] if-void ;
+: caller-stack-frame ( params -- cleanup stack-size )
+ [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup
+ stack-params get ;
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
} 2cleave
4array ;
-: alien-invoke-dlsym ( params -- symbols dll )
+: caller-linkage ( params -- symbols dll )
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
[ library>> load-library ]
bi 2dup check-dlsym ;
-: emit-stack-frame ( stack-size params -- )
- [ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
- [ drop ##stack-frame ]
- 2bi ;
+: caller-return ( params -- )
+ return>> [ ] [
+ [
+ building get last reg-outputs>>
+ flip [ { } { } ] [ first2 ] if-empty
+ ] dip
+ base-type box-return ds-push
+ ] if-void ;
M: #alien-invoke emit-node
params>>
- {
- [ caller-parameters ]
- [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
- [ emit-stack-frame ]
- [ box-return* ]
- } cleave ;
+ [
+ {
+ [ caller-parameters ]
+ [ prepare-caller-return ]
+ [ caller-stack-frame ]
+ [ caller-linkage ]
+ } cleave
+ <gc-map> ##alien-invoke
+ ]
+ [ caller-return ]
+ bi ;
M: #alien-indirect emit-node ( node -- )
params>>
[
- ds-pop ^^unbox-any-c-ptr
- [ caller-parameters ] dip
+ [ ds-pop ^^unbox-any-c-ptr ] dip
+ [ caller-parameters ]
+ [ prepare-caller-return ]
+ [ caller-stack-frame ] tri
<gc-map> ##alien-indirect
]
- [ emit-stack-frame ]
- [ box-return* ]
- tri ;
+ [ caller-return ]
+ bi ;
M: #alien-assembly emit-node
- params>> {
- [ caller-parameters ]
- [ quot>> <gc-map> ##alien-assembly ]
- [ emit-stack-frame ]
- [ box-return* ]
- } cleave ;
-
-: callee-parameter ( rep on-stack? -- dst insn )
- [ next-vreg dup ] 2dip
- [ dup reg-class-of reg-class-full? ] dip or
- [ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]
- [ [ next-reg-param ] keep \ ##load-reg-param new-insn ]
- if ;
+ params>>
+ [
+ {
+ [ caller-parameters ]
+ [ prepare-caller-return ]
+ [ caller-stack-frame ]
+ [ quot>> ]
+ } cleave <gc-map> ##alien-assembly
+ ]
+ [ caller-return ]
+ bi ;
+
+: callee-parameter ( rep on-stack? -- dst )
+ [ next-vreg dup ] 2dip next-parameter ;
: prepare-struct-callee ( c-type -- vreg )
large-struct?
- [ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;
+ [ int-rep struct-return-on-stack? callee-parameter ] [ f ] if ;
: (callee-parameters) ( params -- vregs reps )
[ flatten-parameter-type ] map
- [
- [ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap
- concat [ ##load-reg-param? ] partition [ % ] bi@
- ]
+ [ [ [ first2 callee-parameter ] map ] map ]
[ [ keys ] map ]
bi ;
: box-parameters ( vregs reps params -- )
- ##begin-callback [ box-parameter ds-push ] 3each ;
+ parameters>> [ base-type box-parameter ds-push ] 3each ;
-: callee-parameters ( params -- stack-size )
+: callee-parameters ( params -- vregs reps reg-outputs stack-outputs )
[ abi>> ] [ return>> ] [ parameters>> ] tri
'[
_ prepare-struct-callee struct-return-area set
- _ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi
- stack-params get
- struct-return-area get
- ] with-param-regs
- struct-return-area set ;
-
-: callback-stack-cleanup ( stack-size params -- )
- [ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
+ _ [ base-type ] map (callee-parameters)
+ ] with-param-regs* ;
+
+: callee-return ( params -- reg-inputs )
+ return>> [ { } ] [
+ [ ds-pop ] dip
+ base-type unbox-return store-return
+ ] if-void ;
+
+: callback-stack-cleanup ( params -- )
+ [ xt>> ]
+ [ [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup ] bi
"stack-cleanup" set-word-prop ;
: needs-frame-pointer ( -- )
begin-word
{
- [ callee-parameters ]
+ [ callee-parameters ##callback-inputs ]
+ [ box-parameters ]
[
[
make-kill-block
quot>> ##alien-callback
] emit-trivial-block
]
- [
- return>> [ ##end-callback ] [
- [ ds-pop ] dip
- ##end-callback
- base-type unbox-return
- ] if-void
- ]
+ [ callee-return ##callback-outputs ]
[ callback-stack-cleanup ]
} cleave
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays assocs classes.struct fry
-kernel layouts locals math namespaces sequences
-sequences.generalizations system
+USING: accessors alien.c-types arrays assocs combinators
+classes.struct fry kernel layouts locals math namespaces
+sequences sequences.generalizations system
compiler.cfg.builder.alien.params compiler.cfg.hats
-compiler.cfg.instructions cpu.architecture ;
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.intrinsics.allot cpu.architecture ;
IN: compiler.cfg.builder.alien.boxing
SYMBOL: struct-return-area
GENERIC: unbox ( src c-type -- vregs reps )
M: c-type unbox
- [ unboxer>> ] [ rep>> ] bi
- [ ^^unbox 1array ] [ nip f 2array 1array ] 2bi ;
+ [ rep>> ] [ unboxer>> ] bi
+ [
+ {
+ ! { "to_float" [ drop ] }
+ ! { "to_double" [ drop ] }
+ ! { "alien_offset" [ drop ^^unbox-any-c-ptr ] }
+ [ swap ^^unbox ]
+ } case 1array
+ ]
+ [ drop f 2array 1array ] 2bi ;
M: long-long-type unbox
- [ 8 cell f ^^local-allot ] dip '[ _ unboxer>> ##unbox-long-long ] keep
- 0 cell [ int-rep f ^^load-memory-imm ] bi-curry@ bi 2array
+ [ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long 2array
int-rep long-long-on-stack? 2array dup 2array ;
-M: struct-c-type unbox ( src c-type -- vregs )
+M: struct-c-type unbox ( src c-type -- vregs reps )
[ ^^unbox-any-c-ptr ] dip explode-struct ;
: frob-struct ( c-type -- c-type )
1array { { int-rep f } }
] if ;
-GENERIC: unbox-return ( src c-type -- )
+: store-return ( vregs reps -- triples )
+ [ [ dup next-return-reg 3array ] 2map ] with-return-regs ;
-: store-return ( vregs reps -- )
- [
- [ [ next-return-reg ] keep ##store-reg-param ] 2each
- ] with-return-regs ;
+GENERIC: unbox-return ( src c-type -- vregs reps )
-: (unbox-return) ( src c-type -- vregs reps )
+M: abstract-c-type unbox-return
! Don't care about on-stack? flag when looking at return
! values.
unbox keys ;
-M: c-type unbox-return (unbox-return) store-return ;
-
-M: long-long-type unbox-return (unbox-return) store-return ;
-
M: struct-c-type unbox-return
dup return-struct-in-registers?
- [ (unbox-return) store-return ]
- [ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ;
+ [ call-next-method ]
+ [ [ struct-return-area get ] 2dip unbox keys implode-struct { } { } ] if ;
GENERIC: flatten-parameter-type ( c-type -- reps )
-M: c-type flatten-parameter-type flatten-c-type ;
-
-M: long-long-type flatten-parameter-type flatten-c-type ;
+M: abstract-c-type flatten-parameter-type flatten-c-type ;
M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
GENERIC: box ( vregs reps c-type -- dst )
M: c-type box
- [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* <gc-map> ^^box ;
+ [ [ first ] bi@ ] [ boxer>> ] bi*
+ {
+ ! { "from_float" [ drop ] }
+ ! { "from_double" [ drop ] }
+ ! { "allot_alien" [ drop ^^box-alien ] }
+ [ swap <gc-map> ^^box ]
+ } case ;
M: long-long-type box
- [ first2 ] [ drop ] [ boxer>> ] tri* <gc-map> ^^box-long-long ;
+ [ first2 ] [ drop ] [ boxer>> ] tri*
+ <gc-map> ^^box-long-long ;
M: struct-c-type box
- '[ _ heap-size <gc-map> ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
+ '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
implode-struct ;
GENERIC: box-parameter ( vregs reps c-type -- dst )
-M: c-type box-parameter box ;
-
-M: long-long-type box-parameter box ;
+M: abstract-c-type box-parameter box ;
M: struct-c-type box-parameter
dup value-struct?
[ [ [ drop first ] dip explode-struct keys ] keep ] unless
box ;
-GENERIC: box-return ( c-type -- dst )
+GENERIC: load-return ( c-type -- triples )
-: load-return ( c-type -- vregs reps )
+M: abstract-c-type load-return
[
flatten-c-type keys
- [ [ [ next-return-reg ] keep ^^load-reg-param ] map ] keep
+ [ [ next-vreg ] dip dup next-return-reg 3array ] map
] with-return-regs ;
-M: c-type box-return [ load-return ] keep box ;
+M: struct-c-type load-return
+ dup return-struct-in-registers?
+ [ call-next-method ] [ drop { } ] if ;
+
+GENERIC: box-return ( vregs reps c-type -- dst )
-M: long-long-type box-return [ load-return ] keep box ;
+M: abstract-c-type box-return box ;
M: struct-c-type box-return
+ dup return-struct-in-registers?
+ [ call-next-method ]
[
- dup return-struct-in-registers?
- [ load-return ]
- [ [ struct-return-area get ] dip explode-struct keys ] if
- ] keep box ;
+ [
+ [ [ { } assert-sequence= ] bi@ struct-return-area get ] dip
+ explode-struct keys
+ ] keep box
+ ] if ;
! 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 assocs ;
+namespaces sequences vectors assocs arrays ;
IN: compiler.cfg.builder.alien.params
SYMBOL: stack-params
: with-param-regs ( abi quot -- )
'[ param-regs init-regs 0 stack-params set @ ] with-scope ; inline
+SYMBOLS: stack-values reg-values ;
+
+: next-parameter ( vreg rep on-stack? -- )
+ [ dup dup reg-class-of reg-class-full? ] dip or
+ [ alloc-stack-param stack-values ] [ next-reg-param reg-values ] if
+ [ 3array ] dip get push ;
+
: next-return-reg ( rep -- reg ) reg-class-of get pop ;
: with-return-regs ( quot -- )
] if ;
M: vreg-insn visit-insn
- defs-vreg [ dup record-copy ] when* ;
+ defs-vregs [ dup record-copy ] each ;
M: insn visit-insn drop ;
GENERIC: build-liveness-graph ( insn -- )
-: add-edges ( insn register -- )
- [ uses-vregs ] dip liveness-graph get [ union ] change-at ;
+: add-edges ( uses def -- )
+ liveness-graph get [ union ] change-at ;
: setter-liveness-graph ( insn vreg -- )
- dup allocation? [ add-edges ] [ 2drop ] if ;
+ dup allocation? [ [ uses-vregs ] dip add-edges ] [ 2drop ] if ;
M: ##set-slot build-liveness-graph
dup obj>> setter-liveness-graph ;
[ dst>> allocations get adjoin ] [ call-next-method ] bi ;
M: vreg-insn build-liveness-graph
- dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
+ [ uses-vregs ] [ defs-vregs ] bi [ add-edges ] with each ;
M: insn build-liveness-graph drop ;
M: ##write-barrier-imm compute-live-vregs
dup src>> setter-live-vregs ;
-M: ##fixnum-add compute-live-vregs record-live ;
+M: flushable-insn compute-live-vregs drop ;
-M: ##fixnum-sub compute-live-vregs record-live ;
-
-M: ##fixnum-mul compute-live-vregs record-live ;
-
-M: vreg-insn compute-live-vregs
- dup defs-vreg [ drop ] [ record-live ] if ;
+M: vreg-insn compute-live-vregs record-live ;
M: insn compute-live-vregs drop ;
M: ##write-barrier-imm live-insn? src>> live-vreg? ;
-M: ##fixnum-add live-insn? drop t ;
-
-M: ##fixnum-sub live-insn? drop t ;
-
-M: ##fixnum-mul live-insn? drop t ;
-
-M: vreg-insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
+M: flushable-insn live-insn? defs-vregs [ live-vreg? ] any? ;
-M: insn live-insn? defs-vreg drop t ;
+M: insn live-insn? drop t ;
: eliminate-dead-code ( cfg -- cfg' )
! Even though we don't use predecessors directly, we depend
post-order [
instructions>> [
[ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
- [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
- bi [ suffix ] when*
+ [ [ defs-vregs ] [ defs-vreg-reps ] bi zip ]
+ bi append
] map concat
] map concat >hashtable representations set ;
5 6 edge
cfg new 1 get >>entry 0 set
-[ ] [ 0 get [ compute-defs ] [ compute-uses ] bi ] unit-test
+[ ] [ 0 get compute-defs ] unit-test
FROM: sets => members ;
IN: compiler.cfg.def-use
-GENERIC: defs-vreg ( insn -- vreg/f )
+GENERIC: defs-vregs ( insn -- seq )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
-M: insn defs-vreg drop f ;
+M: insn defs-vregs drop { } ;
M: insn temp-vregs drop { } ;
M: insn uses-vregs drop { } ;
-M: ##phi uses-vregs inputs>> values ;
-
<PRIVATE
: slot-array-quot ( slots -- quot )
[ '[ _ cleave _ narray ] ]
} case ;
-: define-defs-vreg-method ( insn -- )
- dup insn-def-slot dup [
- [ \ defs-vreg create-method ]
- [ name>> reader-word 1quotation ] bi*
+: define-vregs-method ( insn slots word -- )
+ [ [ drop ] ] dip '[
+ [ _ create-method ]
+ [ [ name>> ] map slot-array-quot ] bi*
define
- ] [ 2drop ] if ;
+ ] if-empty ; inline
+
+: define-defs-vregs-method ( insn -- )
+ dup insn-def-slots \ defs-vregs define-vregs-method ;
: define-uses-vregs-method ( insn -- )
- dup insn-use-slots [ drop ] [
- [ \ uses-vregs create-method ]
- [ [ name>> ] map slot-array-quot ] bi*
- define
- ] if-empty ;
+ dup insn-use-slots \ uses-vregs define-vregs-method ;
: define-temp-vregs-method ( insn -- )
- dup insn-temp-slots [ drop ] [
- [ \ temp-vregs create-method ]
- [ [ name>> ] map slot-array-quot ] bi*
- define
- ] if-empty ;
+ dup insn-temp-slots \ temp-vregs define-vregs-method ;
PRIVATE>
+CONSTANT: special-vreg-insns
+{ ##phi ##alien-invoke ##alien-indirect ##alien-assembly ##callback-inputs ##callback-outputs }
+
+M: ##phi defs-vregs dst>> 1array ;
+
+M: alien-call-insn defs-vregs
+ reg-outputs>> [ first ] map ;
+
+M: ##callback-inputs defs-vregs
+ [ reg-outputs>> ] [ stack-outputs>> ] bi append [ first ] map ;
+
+M: ##callback-outputs defs-vregs drop { } ;
+
+M: ##phi uses-vregs inputs>> values ;
+
+M: alien-call-insn uses-vregs
+ [ reg-inputs>> ] [ stack-inputs>> ] bi append [ first ] map ;
+
+M: ##alien-indirect uses-vregs
+ [ call-next-method ] [ src>> ] bi prefix ;
+
+M: ##callback-inputs uses-vregs
+ drop { } ;
+
+M: ##callback-outputs uses-vregs
+ reg-inputs>> [ first ] map ;
+
[
insn-classes get
- [ [ define-defs-vreg-method ] each ]
- [ { ##phi } diff [ define-uses-vregs-method ] each ]
+ [ special-vreg-insns diff [ define-defs-vregs-method ] each ]
+ [ special-vreg-insns diff [ define-uses-vregs-method ] each ]
[ [ define-temp-vregs-method ] each ]
tri
] with-compilation-unit
: insn-of ( vreg -- insn ) insns get at ;
: set-def-of ( obj insn assoc -- )
- swap defs-vreg dup [ swap set-at ] [ 3drop ] if ;
+ swap defs-vregs [ swap set-at ] with with each ;
: compute-defs ( cfg -- )
H{ } clone [
] each
] each-basic-block
] keep insns set ;
-
-:: compute-uses ( cfg -- )
- ! Here, a phi node uses its argument in the block that it comes from.
- H{ } clone :> use
- cfg [| block |
- block instructions>> [
- dup ##phi?
- [ inputs>> [ use adjoin-at ] assoc-each ]
- [ uses-vregs [ block swap use adjoin-at ] each ]
- if
- ] each
- ] each-basic-block
- use [ members ] assoc-map uses set ;
children parent
registers parent-index ;
-M: node equal? [ number>> ] bi@ = ;
+M: node equal? over node? [ [ number>> ] bi@ = ] [ 2drop f ] if ;
M: node hashcode* nip number>> ;
! we only care about local def-use
H{ } clone :> definers
nodes [| node |
- node insn>> defs-vreg [ node swap definers set-at ] when*
+ node insn>> defs-vregs [ node swap definers set-at ] each
node insn>> uses-vregs [ definers at [ node +data+ precedes ] when* ] each
] each ;
UNION: memory-insn
##load-memory ##load-memory-imm
- ##store-memory ##store-memory-imm ;
-
-UNION: alien-call-insn
- ##save-context
- ##alien-invoke ##alien-indirect ##alien-callback
- ##unary-float-function ##binary-float-function ;
+ ##store-memory ##store-memory-imm
+ alien-call-insn
+ slot-insn ;
: chain ( node var -- )
dup get [
GENERIC: add-control-edge ( node insn -- )
-M: stack-insn add-control-edge
- loc>> chain ;
-
-M: memory-insn add-control-edge
- drop memory-insn chain ;
+M: stack-insn add-control-edge loc>> chain ;
-M: slot-insn add-control-edge
- drop slot-insn chain ;
-
-M: alien-call-insn add-control-edge
- drop alien-call-insn chain ;
+M: memory-insn add-control-edge drop memory-insn chain ;
M: object add-control-edge 2drop ;
: add-control-edges ( nodes -- )
- [
- [ dup insn>> add-control-edge ] each
- ] with-scope ;
+ [ [ dup insn>> add-control-edge ] each ] with-scope ;
: set-follows ( nodes -- )
[
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.gc-checks
-compiler.cfg.representations compiler.cfg.save-contexts
-compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
-compiler.cfg.linear-scan compiler.cfg.scheduling
+USING: kernel compiler.cfg.representations
+compiler.cfg.scheduling compiler.cfg.gc-checks
+compiler.cfg.save-contexts compiler.cfg.ssa.destruction
+compiler.cfg.build-stack-frame compiler.cfg.linear-scan
compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.finalization
: finalize-cfg ( cfg -- cfg' )
select-representations
- ! schedule-instructions
+ schedule-instructions
insert-gc-checks
dup compute-uninitialized-sets
insert-save-contexts
seen-allocation? [ call-index , ] when
insn-index 1 + f ;
+M: ##callback-inputs gc-check-offsets* gc-check-here ;
M: ##phi gc-check-offsets* gc-check-here ;
M: gc-map-insn gc-check-offsets* gc-check-here ;
M: ##allocation gc-check-offsets* 3drop t ;
GENERIC: allocation-size* ( insn -- n )
M: ##allot allocation-size* size>> ;
-
M: ##box-alien allocation-size* drop 5 cells ;
-
M: ##box-displaced-alien allocation-size* drop 5 cells ;
: allocation-size ( insns -- n )
PRIVATE>
insn-classes get [
- dup [ insn-def-slot ] [ name>> "##" head? ] bi and
+ dup [ insn-def-slots length 1 = ] [ name>> "##" head? ] bi and
[ define-hat ] [ drop ] if
] each
! Instructions which use vregs
TUPLE: vreg-insn < insn ;
+! Instructions which do not have side effects; used for
+! dead code elimination
+TUPLE: flushable-insn < vreg-insn ;
+
! Instructions which are referentially transparent; used for
! value numbering
-TUPLE: pure-insn < vreg-insn ;
+TUPLE: foldable-insn < flushable-insn ;
! Constants
-INSN: ##load-integer
+FOLDABLE-INSN: ##load-integer
def: dst/int-rep
literal: val ;
-INSN: ##load-reference
+FOLDABLE-INSN: ##load-reference
def: dst/tagged-rep
literal: obj ;
-! These three are inserted by representation selection
-INSN: ##load-tagged
+! These four are inserted by representation selection
+FLUSHABLE-INSN: ##load-tagged
def: dst/tagged-rep
literal: val ;
-INSN: ##load-float
+FLUSHABLE-INSN: ##load-float
def: dst/float-rep
literal: val ;
-INSN: ##load-double
+FLUSHABLE-INSN: ##load-double
def: dst/double-rep
literal: val ;
-INSN: ##load-vector
+FLUSHABLE-INSN: ##load-vector
def: dst
literal: val rep ;
! Stack operations
-INSN: ##peek
+FLUSHABLE-INSN: ##peek
def: dst/tagged-rep
literal: loc ;
-INSN: ##replace
+VREG-INSN: ##replace
use: src/tagged-rep
literal: loc ;
INSN: ##no-tco ;
! Jump tables
-INSN: ##dispatch
+VREG-INSN: ##dispatch
use: src/int-rep
temp: temp/int-rep ;
! Slot access
-INSN: ##slot
+FLUSHABLE-INSN: ##slot
def: dst/tagged-rep
use: obj/tagged-rep slot/int-rep
literal: scale tag ;
-INSN: ##slot-imm
+FLUSHABLE-INSN: ##slot-imm
def: dst/tagged-rep
use: obj/tagged-rep
literal: slot tag ;
-INSN: ##set-slot
+VREG-INSN: ##set-slot
use: src/tagged-rep obj/tagged-rep slot/int-rep
literal: scale tag ;
-INSN: ##set-slot-imm
+VREG-INSN: ##set-slot-imm
use: src/tagged-rep obj/tagged-rep
literal: slot tag ;
! Register transfers
-INSN: ##copy
+FOLDABLE-INSN: ##copy
def: dst
use: src
literal: rep ;
-PURE-INSN: ##tagged>integer
+FOLDABLE-INSN: ##tagged>integer
def: dst/int-rep
use: src/tagged-rep ;
! Integer arithmetic
-PURE-INSN: ##add
+FOLDABLE-INSN: ##add
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##add-imm
+FOLDABLE-INSN: ##add-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##sub
+FOLDABLE-INSN: ##sub
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##sub-imm
+FOLDABLE-INSN: ##sub-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##mul
+FOLDABLE-INSN: ##mul
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##mul-imm
+FOLDABLE-INSN: ##mul-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##and
+FOLDABLE-INSN: ##and
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##and-imm
+FOLDABLE-INSN: ##and-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##or
+FOLDABLE-INSN: ##or
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##or-imm
+FOLDABLE-INSN: ##or-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##xor
+FOLDABLE-INSN: ##xor
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##xor-imm
+FOLDABLE-INSN: ##xor-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##shl
+FOLDABLE-INSN: ##shl
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##shl-imm
+FOLDABLE-INSN: ##shl-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##shr
+FOLDABLE-INSN: ##shr
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##shr-imm
+FOLDABLE-INSN: ##shr-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##sar
+FOLDABLE-INSN: ##sar
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##sar-imm
+FOLDABLE-INSN: ##sar-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##min
+FOLDABLE-INSN: ##min
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##max
+FOLDABLE-INSN: ##max
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##not
+FOLDABLE-INSN: ##not
def: dst/int-rep
use: src/int-rep ;
-PURE-INSN: ##neg
+FOLDABLE-INSN: ##neg
def: dst/int-rep
use: src/int-rep ;
-PURE-INSN: ##log2
+FOLDABLE-INSN: ##log2
def: dst/int-rep
use: src/int-rep ;
-PURE-INSN: ##bit-count
+FOLDABLE-INSN: ##bit-count
def: dst/int-rep
use: src/int-rep ;
! Float arithmetic
-PURE-INSN: ##add-float
+FOLDABLE-INSN: ##add-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##sub-float
+FOLDABLE-INSN: ##sub-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##mul-float
+FOLDABLE-INSN: ##mul-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##div-float
+FOLDABLE-INSN: ##div-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##min-float
+FOLDABLE-INSN: ##min-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##max-float
+FOLDABLE-INSN: ##max-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##sqrt
+FOLDABLE-INSN: ##sqrt
def: dst/double-rep
use: src/double-rep ;
! libc intrinsics
-PURE-INSN: ##unary-float-function
+FOLDABLE-INSN: ##unary-float-function
def: dst/double-rep
use: src/double-rep
literal: func ;
-PURE-INSN: ##binary-float-function
+FOLDABLE-INSN: ##binary-float-function
def: dst/double-rep
use: src1/double-rep src2/double-rep
literal: func ;
! Single/double float conversion
-PURE-INSN: ##single>double-float
+FOLDABLE-INSN: ##single>double-float
def: dst/double-rep
use: src/float-rep ;
-PURE-INSN: ##double>single-float
+FOLDABLE-INSN: ##double>single-float
def: dst/float-rep
use: src/double-rep ;
! Float/integer conversion
-PURE-INSN: ##float>integer
+FOLDABLE-INSN: ##float>integer
def: dst/int-rep
use: src/double-rep ;
-PURE-INSN: ##integer>float
+FOLDABLE-INSN: ##integer>float
def: dst/double-rep
use: src/int-rep ;
! SIMD operations
-PURE-INSN: ##zero-vector
+FOLDABLE-INSN: ##zero-vector
def: dst
literal: rep ;
-PURE-INSN: ##fill-vector
+FOLDABLE-INSN: ##fill-vector
def: dst
literal: rep ;
-PURE-INSN: ##gather-vector-2
+FOLDABLE-INSN: ##gather-vector-2
def: dst
use: src1/scalar-rep src2/scalar-rep
literal: rep ;
-PURE-INSN: ##gather-int-vector-2
+FOLDABLE-INSN: ##gather-int-vector-2
def: dst
use: src1/int-rep src2/int-rep
literal: rep ;
-PURE-INSN: ##gather-vector-4
+FOLDABLE-INSN: ##gather-vector-4
def: dst
use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep
literal: rep ;
-PURE-INSN: ##gather-int-vector-4
+FOLDABLE-INSN: ##gather-int-vector-4
def: dst
use: src1/int-rep src2/int-rep src3/int-rep src4/int-rep
literal: rep ;
-PURE-INSN: ##select-vector
+FOLDABLE-INSN: ##select-vector
def: dst/int-rep
use: src
literal: n rep ;
-PURE-INSN: ##shuffle-vector
+FOLDABLE-INSN: ##shuffle-vector
def: dst
use: src shuffle
literal: rep ;
-PURE-INSN: ##shuffle-vector-halves-imm
+FOLDABLE-INSN: ##shuffle-vector-halves-imm
def: dst
use: src1 src2
literal: shuffle rep ;
-PURE-INSN: ##shuffle-vector-imm
+FOLDABLE-INSN: ##shuffle-vector-imm
def: dst
use: src
literal: shuffle rep ;
-PURE-INSN: ##tail>head-vector
+FOLDABLE-INSN: ##tail>head-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##merge-vector-head
+FOLDABLE-INSN: ##merge-vector-head
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##merge-vector-tail
+FOLDABLE-INSN: ##merge-vector-tail
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##float-pack-vector
+FOLDABLE-INSN: ##float-pack-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##signed-pack-vector
+FOLDABLE-INSN: ##signed-pack-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##unsigned-pack-vector
+FOLDABLE-INSN: ##unsigned-pack-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##unpack-vector-head
+FOLDABLE-INSN: ##unpack-vector-head
def: dst
use: src
literal: rep ;
-PURE-INSN: ##unpack-vector-tail
+FOLDABLE-INSN: ##unpack-vector-tail
def: dst
use: src
literal: rep ;
-PURE-INSN: ##integer>float-vector
+FOLDABLE-INSN: ##integer>float-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##float>integer-vector
+FOLDABLE-INSN: ##float>integer-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##compare-vector
+FOLDABLE-INSN: ##compare-vector
def: dst
use: src1 src2
literal: rep cc ;
-PURE-INSN: ##test-vector
+FOLDABLE-INSN: ##test-vector
def: dst/tagged-rep
use: src1
temp: temp/int-rep
literal: rep vcc ;
-INSN: ##test-vector-branch
+VREG-INSN: ##test-vector-branch
use: src1
temp: temp/int-rep
literal: rep vcc ;
-PURE-INSN: ##add-vector
+FOLDABLE-INSN: ##add-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##saturated-add-vector
+FOLDABLE-INSN: ##saturated-add-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##add-sub-vector
+FOLDABLE-INSN: ##add-sub-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##sub-vector
+FOLDABLE-INSN: ##sub-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##saturated-sub-vector
+FOLDABLE-INSN: ##saturated-sub-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##mul-vector
+FOLDABLE-INSN: ##mul-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##mul-high-vector
+FOLDABLE-INSN: ##mul-high-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##mul-horizontal-add-vector
+FOLDABLE-INSN: ##mul-horizontal-add-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##saturated-mul-vector
+FOLDABLE-INSN: ##saturated-mul-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##div-vector
+FOLDABLE-INSN: ##div-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##min-vector
+FOLDABLE-INSN: ##min-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##max-vector
+FOLDABLE-INSN: ##max-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##avg-vector
+FOLDABLE-INSN: ##avg-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##dot-vector
+FOLDABLE-INSN: ##dot-vector
def: dst/scalar-rep
use: src1 src2
literal: rep ;
-PURE-INSN: ##sad-vector
+FOLDABLE-INSN: ##sad-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##horizontal-add-vector
+FOLDABLE-INSN: ##horizontal-add-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##horizontal-sub-vector
+FOLDABLE-INSN: ##horizontal-sub-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##horizontal-shl-vector-imm
+FOLDABLE-INSN: ##horizontal-shl-vector-imm
def: dst
use: src1
literal: src2 rep ;
-PURE-INSN: ##horizontal-shr-vector-imm
+FOLDABLE-INSN: ##horizontal-shr-vector-imm
def: dst
use: src1
literal: src2 rep ;
-PURE-INSN: ##abs-vector
+FOLDABLE-INSN: ##abs-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##sqrt-vector
+FOLDABLE-INSN: ##sqrt-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##and-vector
+FOLDABLE-INSN: ##and-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##andn-vector
+FOLDABLE-INSN: ##andn-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##or-vector
+FOLDABLE-INSN: ##or-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##xor-vector
+FOLDABLE-INSN: ##xor-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##not-vector
+FOLDABLE-INSN: ##not-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##shl-vector-imm
+FOLDABLE-INSN: ##shl-vector-imm
def: dst
use: src1
literal: src2 rep ;
-PURE-INSN: ##shr-vector-imm
+FOLDABLE-INSN: ##shr-vector-imm
def: dst
use: src1
literal: src2 rep ;
-PURE-INSN: ##shl-vector
+FOLDABLE-INSN: ##shl-vector
def: dst
use: src1 src2/int-scalar-rep
literal: rep ;
-PURE-INSN: ##shr-vector
+FOLDABLE-INSN: ##shr-vector
def: dst
use: src1 src2/int-scalar-rep
literal: rep ;
! Scalar/vector conversion
-PURE-INSN: ##scalar>integer
+FOLDABLE-INSN: ##scalar>integer
def: dst/int-rep
use: src
literal: rep ;
-PURE-INSN: ##integer>scalar
+FOLDABLE-INSN: ##integer>scalar
def: dst
use: src/int-rep
literal: rep ;
-PURE-INSN: ##vector>scalar
+FOLDABLE-INSN: ##vector>scalar
def: dst/scalar-rep
use: src
literal: rep ;
-PURE-INSN: ##scalar>vector
+FOLDABLE-INSN: ##scalar>vector
def: dst
use: src/scalar-rep
literal: rep ;
! Boxing and unboxing aliens
-PURE-INSN: ##box-alien
+FOLDABLE-INSN: ##box-alien
def: dst/tagged-rep
use: src/int-rep
temp: temp/int-rep ;
-PURE-INSN: ##box-displaced-alien
+FOLDABLE-INSN: ##box-displaced-alien
def: dst/tagged-rep
use: displacement/int-rep base/tagged-rep
temp: temp/int-rep
literal: base-class ;
-PURE-INSN: ##unbox-any-c-ptr
+FOLDABLE-INSN: ##unbox-any-c-ptr
def: dst/int-rep
use: src/tagged-rep ;
-PURE-INSN: ##unbox-alien
+FOLDABLE-INSN: ##unbox-alien
def: dst/int-rep
use: src/tagged-rep ;
! Raw memory accessors
-INSN: ##load-memory
+FLUSHABLE-INSN: ##load-memory
def: dst
use: base/int-rep displacement/int-rep
literal: scale offset rep c-type ;
-INSN: ##load-memory-imm
+FLUSHABLE-INSN: ##load-memory-imm
def: dst
use: base/int-rep
literal: offset rep c-type ;
-INSN: ##store-memory
+VREG-INSN: ##store-memory
use: src base/int-rep displacement/int-rep
literal: scale offset rep c-type ;
-INSN: ##store-memory-imm
+VREG-INSN: ##store-memory-imm
use: src base/int-rep
literal: offset rep c-type ;
! Memory allocation
-INSN: ##allot
+FLUSHABLE-INSN: ##allot
def: dst/tagged-rep
literal: size class
temp: temp/int-rep ;
-INSN: ##write-barrier
+VREG-INSN: ##write-barrier
use: src/tagged-rep slot/int-rep
literal: scale tag
temp: temp1/int-rep temp2/int-rep ;
-INSN: ##write-barrier-imm
+VREG-INSN: ##write-barrier-imm
use: src/tagged-rep
literal: slot tag
temp: temp1/int-rep temp2/int-rep ;
-INSN: ##alien-global
+FLUSHABLE-INSN: ##alien-global
def: dst/int-rep
literal: symbol library ;
-INSN: ##vm-field
+FLUSHABLE-INSN: ##vm-field
def: dst/tagged-rep
literal: offset ;
-INSN: ##set-vm-field
+VREG-INSN: ##set-vm-field
use: src/tagged-rep
literal: offset ;
! FFI
-INSN: ##stack-frame
-literal: stack-frame ;
-
-INSN: ##unbox
+FOLDABLE-INSN: ##unbox
def: dst
use: src/tagged-rep
literal: unboxer rep ;
-INSN: ##unbox-long-long
-use: src/tagged-rep out/int-rep
+FOLDABLE-INSN: ##unbox-long-long
+def: dst1/int-rep dst2/int-rep
+use: src/tagged-rep
literal: unboxer ;
-INSN: ##store-reg-param
-use: src
-literal: reg rep ;
-
-INSN: ##store-stack-param
-use: src
-literal: n rep ;
-
-INSN: ##load-reg-param
-def: dst
-literal: reg rep ;
-
-INSN: ##load-stack-param
-def: dst
-literal: n rep ;
-
-INSN: ##local-allot
+FLUSHABLE-INSN: ##local-allot
def: dst/int-rep
literal: size align offset ;
-INSN: ##box
+FOLDABLE-INSN: ##box
def: dst/tagged-rep
use: src
literal: boxer rep gc-map ;
-INSN: ##box-long-long
+FOLDABLE-INSN: ##box-long-long
def: dst/tagged-rep
use: src1/int-rep src2/int-rep
literal: boxer gc-map ;
-INSN: ##allot-byte-array
-def: dst/tagged-rep
-literal: size gc-map ;
-
-INSN: ##prepare-var-args ;
+! Alien call inputs and outputs are arrays of triples with shape
+! { vreg rep stack#/reg }
-INSN: ##alien-invoke
-literal: symbols dll gc-map ;
-
-INSN: ##cleanup
-literal: n ;
+VREG-INSN: ##alien-invoke
+literal: reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map ;
-INSN: ##alien-indirect
+VREG-INSN: ##alien-indirect
use: src/int-rep
-literal: gc-map ;
+literal: reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map ;
-INSN: ##alien-assembly
-literal: quot gc-map ;
+VREG-INSN: ##alien-assembly
+literal: reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map ;
-INSN: ##begin-callback ;
+VREG-INSN: ##callback-inputs
+literal: reg-outputs stack-outputs ;
INSN: ##alien-callback
literal: quot ;
-INSN: ##end-callback ;
+VREG-INSN: ##callback-outputs
+literal: reg-inputs ;
! Control flow
-INSN: ##phi
+FLUSHABLE-INSN: ##phi
def: dst
literal: inputs ;
INSN: ##branch ;
! Tagged conditionals
-INSN: ##compare-branch
+VREG-INSN: ##compare-branch
use: src1/tagged-rep src2/tagged-rep
literal: cc ;
-INSN: ##compare-imm-branch
+VREG-INSN: ##compare-imm-branch
use: src1/tagged-rep
literal: src2 cc ;
-PURE-INSN: ##compare
+FOLDABLE-INSN: ##compare
def: dst/tagged-rep
use: src1/tagged-rep src2/tagged-rep
literal: cc
temp: temp/int-rep ;
-PURE-INSN: ##compare-imm
+FOLDABLE-INSN: ##compare-imm
def: dst/tagged-rep
use: src1/tagged-rep
literal: src2 cc
temp: temp/int-rep ;
! Integer conditionals
-INSN: ##compare-integer-branch
+VREG-INSN: ##compare-integer-branch
use: src1/int-rep src2/int-rep
literal: cc ;
-INSN: ##compare-integer-imm-branch
+VREG-INSN: ##compare-integer-imm-branch
use: src1/int-rep
literal: src2 cc ;
-INSN: ##test-branch
+VREG-INSN: ##test-branch
use: src1/int-rep src2/int-rep
literal: cc ;
-INSN: ##test-imm-branch
+VREG-INSN: ##test-imm-branch
use: src1/int-rep
literal: src2 cc ;
-PURE-INSN: ##compare-integer
+FOLDABLE-INSN: ##compare-integer
def: dst/tagged-rep
use: src1/int-rep src2/int-rep
literal: cc
temp: temp/int-rep ;
-PURE-INSN: ##compare-integer-imm
+FOLDABLE-INSN: ##compare-integer-imm
def: dst/tagged-rep
use: src1/int-rep
literal: src2 cc
temp: temp/int-rep ;
-PURE-INSN: ##test
+FOLDABLE-INSN: ##test
def: dst/tagged-rep
use: src1/int-rep src2/int-rep
literal: cc
temp: temp/int-rep ;
-PURE-INSN: ##test-imm
+FOLDABLE-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
+VREG-INSN: ##compare-float-ordered-branch
use: src1/double-rep src2/double-rep
literal: cc ;
-INSN: ##compare-float-unordered-branch
+VREG-INSN: ##compare-float-unordered-branch
use: src1/double-rep src2/double-rep
literal: cc ;
-PURE-INSN: ##compare-float-ordered
+FOLDABLE-INSN: ##compare-float-ordered
def: dst/tagged-rep
use: src1/double-rep src2/double-rep
literal: cc
temp: temp/int-rep ;
-PURE-INSN: ##compare-float-unordered
+FOLDABLE-INSN: ##compare-float-unordered
def: dst/tagged-rep
use: src1/double-rep src2/double-rep
literal: cc
temp: temp/int-rep ;
! Overflowing arithmetic
-INSN: ##fixnum-add
+VREG-INSN: ##fixnum-add
def: dst/tagged-rep
use: src1/tagged-rep src2/tagged-rep
literal: cc ;
-INSN: ##fixnum-sub
+VREG-INSN: ##fixnum-sub
def: dst/tagged-rep
use: src1/tagged-rep src2/tagged-rep
literal: cc ;
-INSN: ##fixnum-mul
+VREG-INSN: ##fixnum-mul
def: dst/tagged-rep
use: src1/tagged-rep src2/int-rep
literal: cc ;
-INSN: ##save-context
+VREG-INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ;
! GC checks
-INSN: ##check-nursery-branch
+VREG-INSN: ##check-nursery-branch
literal: size cc
temp: temp1/int-rep temp2/int-rep ;
-INSN: ##call-gc literal: gc-map ;
+INSN: ##call-gc
+literal: gc-map ;
! Spills and reloads, inserted by register allocator
TUPLE: spill-slot { n integer } ;
C: <spill-slot> spill-slot
-INSN: ##spill
+VREG-INSN: ##spill
use: src
literal: rep dst ;
-INSN: ##reload
+VREG-INSN: ##reload
def: dst
literal: rep src ;
##call-gc
##box
##box-long-long
-##allot-byte-array
factor-call-insn ;
M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;
: <gc-map> ( -- gc-map ) gc-map new ;
+UNION: alien-call-insn
+##alien-invoke
+##alien-indirect
+##alien-assembly ;
+
! Instructions that clobber registers. They receive inputs and
! produce outputs in spill slots.
UNION: hairy-clobber-insn
-##load-reg-param
-##store-reg-param
##call-gc
-##alien-invoke
-##alien-indirect
-##alien-assembly
-##begin-callback
-##end-callback ;
+alien-call-insn
+##callback-inputs
+##callback-outputs
+##unbox-long-long ;
! Instructions that clobber registers but are allowed to produce
! outputs in registers. Inputs are in spill slots, except for
##unary-float-function
##binary-float-function
##unbox
-##unbox-long-long
##box
-##box-long-long
-##allot-byte-array ;
+##box-long-long ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
] reduce drop
] { } make ;
-: find-def-slot ( slots -- slot/f )
- [ type>> def eq? ] find nip ;
-
-: insn-def-slot ( class -- slot/f )
- "insn-slots" word-prop find-def-slot ;
+: insn-def-slots ( class -- slot/f )
+ "insn-slots" word-prop [ type>> def eq? ] filter ;
: insn-use-slots ( class -- slots )
"insn-slots" word-prop [ type>> use eq? ] filter ;
: vreg-insn-word ( -- word )
"vreg-insn" "compiler.cfg.instructions" lookup ;
-: pure-insn-word ( -- word )
- "pure-insn" "compiler.cfg.instructions" lookup ;
+: flushable-insn-word ( -- word )
+ "flushable-insn" "compiler.cfg.instructions" lookup ;
+
+: foldable-insn-word ( -- word )
+ "foldable-insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
boa-effect in>> but-last { } <effect> ;
: 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
+: define-insn-tuple ( class superclass specs -- )
[ 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 pure? specs -- )
+: define-insn ( class superclass specs -- )
parse-insn-slot-specs
{
[ nip "insn-slots" set-word-prop ]
[ nip define-insn-ctor ]
} 3cleave ;
-SYNTAX: INSN: CREATE-CLASS f ";" parse-tokens define-insn ;
+SYNTAX: INSN:
+ CREATE-CLASS insn-word ";" parse-tokens define-insn ;
+
+SYNTAX: VREG-INSN:
+ CREATE-CLASS vreg-insn-word ";" parse-tokens define-insn ;
+
+SYNTAX: FLUSHABLE-INSN:
+ CREATE-CLASS flushable-insn-word ";" parse-tokens define-insn ;
-SYNTAX: PURE-INSN: CREATE-CLASS t ";" parse-tokens define-insn ;
+SYNTAX: FOLDABLE-INSN:
+ CREATE-CLASS foldable-insn-word ";" parse-tokens define-insn ;
: bytes>cells ( m -- n ) cell align cell /i ;
-: ^^allot-byte-array ( n -- dst )
- 16 + byte-array ^^allot ;
+: ^^allot-byte-array ( len -- dst )
+ dup 16 + byte-array ^^allot [ byte-array store-length ] keep ;
: emit-allot-byte-array ( len -- dst )
- ds-drop
- dup ^^allot-byte-array
- [ byte-array store-length ] [ ds-push ] [ ] tri ;
+ ds-drop ^^allot-byte-array dup ds-push ;
: emit-(byte-array) ( node -- )
dup node-input-infos first literal>> dup expand-(byte-array)?
2dup spill-at-sync-point?
[ swap n>> spill f ] [ 2drop t ] if ;
-GENERIC: handle-progress* ( obj -- )
+: handle-interval ( live-interval -- )
+ [ start>> deactivate-intervals ]
+ [ start>> activate-intervals ]
+ [ assign-register ]
+ tri ;
-M: live-interval handle-progress* drop ;
-
-M: sync-point handle-progress*
+: (handle-sync-point) ( sync-point -- )
active-intervals get values
[ [ spill-at-sync-point ] with filter! drop ] with each ;
-:: handle-progress ( n obj -- )
- n progress set
- n deactivate-intervals
- obj handle-progress*
- n activate-intervals ;
-
-GENERIC: handle ( obj -- )
-
-M: live-interval handle ( live-interval -- )
- [ [ start>> ] keep handle-progress ] [ assign-register ] bi ;
-
-M: sync-point handle ( sync-point -- )
- [ n>> ] keep handle-progress ;
+: handle-sync-point ( sync-point -- )
+ [ n>> deactivate-intervals ]
+ [ (handle-sync-point) ]
+ [ n>> activate-intervals ]
+ tri ;
-: smallest-heap ( heap1 heap2 -- heap )
- ! If heap1 and heap2 have the same key, favors heap1.
+:: (allocate-registers-step) ( unhandled-intervals unhandled-sync-points -- )
{
- { [ dup heap-empty? ] [ drop ] }
- { [ over heap-empty? ] [ nip ] }
- [ [ [ heap-peek nip ] bi@ <= ] most ]
+ {
+ [ unhandled-intervals heap-empty? ]
+ [ unhandled-sync-points heap-pop drop handle-sync-point ]
+ }
+ {
+ [ unhandled-sync-points heap-empty? ]
+ [ unhandled-intervals heap-pop drop handle-interval ]
+ }
+ [
+ unhandled-intervals heap-peek :> ( i ik )
+ unhandled-sync-points heap-peek :> ( s sk )
+ {
+ {
+ [ ik sk < ]
+ [ unhandled-intervals heap-pop* i handle-interval ]
+ }
+ {
+ [ ik sk > ]
+ [ unhandled-sync-points heap-pop* s handle-sync-point ]
+ }
+ [
+ unhandled-intervals heap-pop*
+ i handle-interval
+ s (handle-sync-point)
+ ]
+ } cond
+ ]
} cond ;
-: (allocate-registers) ( -- )
- unhandled-intervals get unhandled-sync-points get smallest-heap
- dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
+: (allocate-registers) ( unhandled-intervals unhandled-sync-points -- )
+ 2dup [ heap-empty? ] both? [ 2drop ] [
+ [ (allocate-registers-step) ]
+ [ (allocate-registers) ]
+ 2bi
+ ] if ;
: finish-allocation ( -- )
active-intervals inactive-intervals
: allocate-registers ( live-intervals sync-point machine-registers -- live-intervals )
init-allocator
init-unhandled
- (allocate-registers)
+ unhandled-intervals get unhandled-sync-points get (allocate-registers)
finish-allocation
handled-intervals get ;
! Any active intervals which have ended are moved to handled
! Any active intervals which cover the current position
! are moved to inactive
+ dup progress set
active-intervals {
{ [ 2dup finished? ] [ finish ] }
{ [ 2dup covers? not ] [ deactivate ] }
compiler.cfg.debugger
compiler.cfg.def-use
compiler.cfg.comparisons
+compiler.cfg.ssa.destruction
compiler.cfg.linear-scan
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
check-allocation? on
check-numbering? on
+! Live interval calculation
+
+! A value is defined and never used; make sure it has the right
+! live range
+V{
+ T{ ##load-integer f 1 0 }
+ T{ ##replace-imm f D 0 "hi" }
+ T{ ##branch }
+} 0 test-bb
+
+: test-live-intervals ( -- )
+ cfg new 0 get >>entry
+ [ cfg set ] [ number-instructions ] [ compute-live-intervals ] tri
+ 2drop ;
+
+[ ] [
+ H{
+ { 1 int-rep }
+ } representations set
+ H{
+ { 1 1 }
+ } leader-map set
+ test-live-intervals
+] unit-test
+
+[ 0 0 ] [
+ 1 live-intervals get at [ start>> ] [ end>> ] bi
+] unit-test
+
+! Live range and interval splitting
[
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
{ T{ live-range f 16 20 } }
covers?
] if ;
+: (find-use) ( insn# live-interval -- vreg-use )
+ uses>> [ n>> <=> ] with search nip ;
+
:: find-use ( insn# live-interval -- vreg-use )
- insn# live-interval uses>> [ n>> <=> ] with search nip
+ insn# live-interval (find-use)
dup [ dup n>> insn# = [ drop f ] unless ] when ;
: add-new-range ( from to live-interval -- )
M: vreg-insn compute-live-intervals* ( insn -- )
dup insn#>>
- [ [ defs-vreg ] dip '[ _ record-def ] when* ]
+ [ [ defs-vregs ] dip '[ _ record-def ] each ]
[ [ uses-vregs ] dip '[ _ record-use ] each ]
[ [ temp-vregs ] dip '[ _ record-temp ] each ]
2tri ;
GENERIC: visit-insn ( live-set insn -- live-set )
: kill-defs ( live-set insn -- live-set )
- defs-vreg [ over delete-at ] when* ; inline
+ defs-vregs [ over delete-at ] each ; inline
: gen-uses ( live-set insn -- live-set )
uses-vregs [ over conjoin ] each ; inline
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry functors generic.parser
kernel lexer namespaces parser sequences slots words sets
M: insn rename-insn-defs drop ;
-insn-classes get [ insn-def-slot ] filter [
+insn-classes get special-vreg-insns diff [ insn-def-slots empty? not ] filter [
[ \ rename-insn-defs create-method-in ]
- [ insn-def-slot name>> 1array DEF-QUOT slot-change-quot ] bi
+ [ insn-def-slots [ name>> ] map DEF-QUOT slot-change-quot ] bi
define
] each
+M: ##phi rename-insn-defs DEF-QUOT change-dst drop ;
+
+M: alien-call-insn rename-insn-defs
+ [ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs drop ;
+
+M: ##callback-inputs rename-insn-defs
+ [ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs
+ [ [ first3 DEF-QUOT 2dip 3array ] map ] change-stack-outputs
+ drop ;
+
GENERIC: rename-insn-uses ( insn -- )
M: insn rename-insn-uses drop ;
-insn-classes get { ##phi } diff [ insn-use-slots empty? not ] filter [
+insn-classes get special-vreg-insns diff [ insn-use-slots empty? not ] filter [
[ \ rename-insn-uses create-method-in ]
[ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
define
] each
+M: alien-call-insn rename-insn-uses
+ [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs
+ [ [ first3 USE-QUOT 2dip 3array ] map ] change-stack-inputs
+ drop ;
+
+M: ##alien-indirect rename-insn-uses
+ USE-QUOT change-src call-next-method ;
+
+M: ##callback-outputs rename-insn-uses
+ [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs drop ;
+
M: ##phi rename-insn-uses
[ USE-QUOT assoc-map ] change-inputs drop ;
: init-components ( cfg components -- )
'[
instructions>> [
- defs-vreg [ _ add-atom ] when*
+ defs-vregs [ _ add-atom ] each
] each
] each-basic-block ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays fry namespaces generic
words sets combinators generalizations sequences.generalizations
cpu.architecture compiler.units compiler.cfg.utilities
compiler.cfg compiler.cfg.rpo compiler.cfg.instructions
compiler.cfg.def-use ;
-FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ;
+FROM: compiler.cfg.instructions.syntax => insn-def-slots
+insn-use-slots insn-temp-slots scalar-rep ;
FROM: namespaces => set ;
IN: compiler.cfg.representations.preferred
-GENERIC: defs-vreg-rep ( insn -- rep/f )
+GENERIC: defs-vreg-reps ( insn -- reps )
GENERIC: temp-vreg-reps ( insn -- reps )
GENERIC: uses-vreg-reps ( insn -- reps )
-M: insn defs-vreg-rep drop f ;
+M: insn defs-vreg-reps drop { } ;
M: insn temp-vreg-reps drop { } ;
M: insn uses-vreg-reps drop { } ;
[ [ drop ] swap suffix ]
} case ;
-: define-defs-vreg-rep-method ( insn -- )
- dup insn-def-slot dup [
- [ \ defs-vreg-rep create-method ]
- [ rep>> rep-getter-quot ]
- bi* define
- ] [ 2drop ] if ;
-
: reps-getter-quot ( reps -- quot )
dup [ rep>> { f scalar-rep } member-eq? not ] all? [
[ rep>> ] map [ drop ] swap suffix
} case
] if ;
-: define-uses-vreg-reps-method ( insn -- )
- dup insn-use-slots [ drop ] [
- [ \ uses-vreg-reps create-method ]
+: define-vreg-reps-method ( insn slots word -- )
+ [ [ drop ] ] dip '[
+ [ _ create-method ]
[ reps-getter-quot ]
bi* define
] if-empty ;
+: define-defs-vreg-reps-method ( insn -- )
+ dup insn-def-slots \ defs-vreg-reps define-vreg-reps-method ;
+
+: define-uses-vreg-reps-method ( insn -- )
+ dup insn-use-slots \ uses-vreg-reps define-vreg-reps-method ;
+
: define-temp-vreg-reps-method ( insn -- )
- dup insn-temp-slots [ drop ] [
- [ \ temp-vreg-reps create-method ]
- [ reps-getter-quot ]
- bi* define
- ] if-empty ;
+ dup insn-temp-slots \ temp-vreg-reps define-vreg-reps-method ;
PRIVATE>
+M: alien-call-insn defs-vreg-reps
+ reg-outputs>> [ second ] map ;
+
+M: ##callback-inputs defs-vreg-reps
+ [ reg-outputs>> ] [ stack-outputs>> ] bi append [ second ] map ;
+
+M: ##callback-outputs defs-vreg-reps drop { } ;
+
+M: alien-call-insn uses-vreg-reps
+ [ reg-inputs>> ] [ stack-inputs>> ] bi append [ second ] map ;
+
+M: ##alien-indirect uses-vreg-reps
+ call-next-method int-rep prefix ;
+
+M: ##callback-inputs uses-vreg-reps
+ drop { } ;
+
+M: ##callback-outputs uses-vreg-reps
+ reg-inputs>> [ second ] map ;
+
[
insn-classes get
- [ [ define-defs-vreg-rep-method ] each ]
- [ { ##phi } diff [ define-uses-vreg-reps-method ] each ]
+ [ special-vreg-insns diff [ define-defs-vreg-reps-method ] each ]
+ [ special-vreg-insns diff [ define-uses-vreg-reps-method ] each ]
[ [ define-temp-vreg-reps-method ] each ]
tri
] with-compilation-unit
: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
- [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
+ [ [ defs-vregs ] [ defs-vreg-reps ] bi ] dip 2each ; inline
: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
: each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline
-
-: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
- '[
- [ basic-block set ] [
- [
- _ each-rep
- ] each-non-phi
- ] bi
- ] each-basic-block ; inline
} uses-vreg-reps
] unit-test
-[ double-rep ] [
+[ { double-rep } ] [
T{ ##load-memory-imm
{ dst 5 }
{ base 3 }
{ offset 0 }
{ rep double-rep }
- } defs-vreg-rep
+ } defs-vreg-reps
] unit-test
H{ } clone representations set
V{
T{ ##inc-d f 3 }
- T{ ##load-reg-param f 0 RCX int-rep }
- T{ ##load-reg-param f 1 RDX int-rep }
- T{ ##load-reg-param f 2 R8 int-rep }
- T{ ##begin-callback }
T{ ##box f 4 3 "from_signed_4" int-rep
T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
}
[
V{
T{ ##inc-d f 3 }
- T{ ##load-reg-param f 0 RCX int-rep }
- T{ ##load-reg-param f 1 RDX int-rep }
- T{ ##load-reg-param f 2 R8 int-rep }
T{ ##save-context f 5 6 }
- T{ ##begin-callback }
T{ ##box f 4 3 "from_signed_4" int-rep
T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
}
M: ##inc-d modifies-context? drop t ;
M: ##inc-r modifies-context? drop t ;
-M: ##load-reg-param modifies-context? drop t ;
+M: ##callback-inputs modifies-context? drop t ;
M: insn modifies-context? drop f ;
: save-context-offset ( bb -- n )
-USING: compiler.cfg.scheduling vocabs.loader namespaces tools.test ;
+USING: compiler.cfg.scheduling compiler.cfg.instructions
+vocabs.loader namespaces tools.test arrays kernel ;
IN: compiler.cfg.scheduling.tests
! Recompile compiler.cfg.scheduling with extra tests,
[ ] [ "compiler.cfg.scheduling" reload ] unit-test
[ ] [ "compiler.cfg.dependence" reload ] unit-test
] with-variable
+
+[
+ { }
+ { }
+ { T{ ##test-branch } }
+] [
+ V{ T{ ##test-branch } }
+ split-3-ways
+ [ >array ] tri@
+] unit-test
+
+[
+ { T{ ##inc-d } T{ ##inc-r } T{ ##callback-inputs } }
+ { T{ ##add } T{ ##sub } T{ ##mul } }
+ { T{ ##test-branch } }
+] [
+ V{
+ T{ ##inc-d }
+ T{ ##inc-r }
+ T{ ##callback-inputs }
+ T{ ##add }
+ T{ ##sub }
+ T{ ##mul }
+ T{ ##test-branch }
+ }
+ split-3-ways
+ [ >array ] tri@
+] unit-test
+
+[
+ { }
+ { T{ ##add } T{ ##sub } T{ ##mul } }
+ { T{ ##dispatch } }
+] [
+ V{
+ T{ ##add }
+ T{ ##sub }
+ T{ ##mul }
+ T{ ##dispatch }
+ }
+ split-3-ways
+ [ >array ] tri@
+] unit-test
, (reorder)
] when* ;
-: cut-by ( seq quot -- before after )
- dupd find drop [ cut ] [ f ] if* ; inline
+UNION: initial-insn ##phi ##inc-d ##inc-r ##callback-inputs ;
-UNION: initial-insn
- ##phi ##inc-d ##inc-r ;
+UNION: final-insn
+##branch
+##dispatch
+conditional-branch-insn
+##epilogue ##return
+##callback-outputs ;
-: split-3-ways ( insns -- first middle last )
- [ initial-insn? not ] cut-by unclip-last ;
+: initial-insn-end ( insns -- n )
+ [ initial-insn? not ] find drop 0 or ;
+
+: final-insn-start ( insns -- n )
+ [ final-insn? not ] find-last drop [ 1 + ] [ 0 ] if* ;
+
+:: split-3-ways ( insns -- first middle last )
+ insns initial-insn-end :> a
+ insns final-insn-start :> b
+ insns a head-slice
+ a b insns <slice>
+ insns b tail-slice ;
: reorder ( insns -- insns' )
split-3-ways [
build-dependence-graph
build-fan-in-trees
[ (reorder) ] V{ } make reverse
- ] dip suffix append ;
+ ] dip 3append ;
ERROR: not-all-instructions-were-scheduled old-bb new-bb ;
[ [ length ] bi@ = ] [ [ unique ] bi@ = ] 2bi and
[ old-bb new-bb not-all-instructions-were-scheduled ] unless ;
-ERROR: definition-after-usage vreg old-bb new-bb ;
+ERROR: definition-after-usage vregs old-bb new-bb ;
:: check-usages ( new-bb old-bb -- )
HS{ } clone :> useds
new-bb instructions>> split-3-ways drop nip
[| insn |
insn uses-vregs [ useds adjoin ] each
- insn defs-vreg :> def-reg
- def-reg useds in?
- [ def-reg old-bb new-bb definition-after-usage ] when
+ insn defs-vregs :> defs-vregs
+ defs-vregs useds intersects?
+ [ defs-vregs old-bb new-bb definition-after-usage ] when
] each ;
: check-scheduling ( new-bb old-bb -- )
: might-spill? ( bb -- ? )
[ live-in assoc-size ]
- [ instructions>> [ defs-vreg ] count ] bi
+ [ instructions>> [ defs-vregs length ] map-sum ] bi
+ num-registers >= ;
: schedule-instructions ( cfg -- cfg' )
! Set of vregs defined in more than one basic block
SYMBOL: defs-multi
-: compute-insn-defs ( bb insn -- )
- defs-vreg dup [
+GENERIC: compute-insn-defs ( bb insn -- )
+
+M: insn compute-insn-defs 2drop ;
+
+M: vreg-insn compute-insn-defs
+ defs-vregs [
defs get [ conjoin-at ] [ drop ] [ at assoc-size 1 > ] 2tri
[ defs-multi get conjoin ] [ drop ] if
- ] [ 2drop ] if ;
+ ] with each ;
: compute-defs ( cfg -- )
H{ } clone defs set
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel locals fry sequences
+USING: accessors assocs kernel locals fry sequences sets
cpu.architecture
compiler.cfg.rpo
compiler.cfg.def-use
! ##fixnum-add, ##fixnum-sub or ##fixnum-mul) then we don't
! need to insert a copy since in fact doing so will result
! in incorrect code.
- [ instructions>> last defs-vreg ] dip eq? not ;
+ [ instructions>> last defs-vregs ] dip swap in? not ;
:: insert-copy ( bb src rep -- bb dst )
bb src insert-copy? [
SYMBOL: copies
: value-of ( vreg -- value )
- insn-of dup ##tagged>integer? [ src>> ] [ dst>> ] if ;
+ dup insn-of dup ##tagged>integer? [ nip src>> ] [ drop ] if ;
: init-coalescing ( -- )
defs get
M: vreg-insn prepare-insn
[ temp-vregs [ leader-map get conjoin ] each ]
[
- [ defs-vreg ] [ uses-vregs ] bi
- 2dup empty? not and [
- first
+ [ defs-vregs ] [ uses-vregs ] bi
+ 2dup [ empty? not ] both? [
+ [ first ] bi@
2dup [ rep-of reg-class-of ] bi@ eq?
[ maybe-eliminate-copy-later ] [ 2drop ] if
] [ 2drop ] if
SYMBOLS: local-def-indices local-kill-indices ;
-: record-def ( n insn -- )
- defs-vreg dup [ local-def-indices get set-at ] [ 2drop ] if ;
+: record-defs ( n insn -- )
+ defs-vregs [ local-def-indices get set-at ] with each ;
: 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.
- dup uses-vregs dup empty? [ 3drop ] [
+ dup uses-vregs [ 2drop ] [
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 ;
+ ] if-empty ;
GENERIC: record-insn ( n insn -- )
M: ##phi record-insn
- record-def ;
+ record-defs ;
M: vreg-insn record-insn
- [ 2 * ] dip [ record-def ] [ record-uses ] 2bi ;
+ [ 2 * ] dip [ record-defs ] [ record-uses ] 2bi ;
M: insn record-insn
2drop ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes classes.algebra combinators fry
generic.parser kernel math namespaces quotations sequences slots
-words make
+words make sets
compiler.cfg.instructions
compiler.cfg.instructions.syntax
compiler.cfg.value-numbering.graph ;
[ drop \ >expr create-method-in ] [ >expr-quot ] 2bi define ;
insn-classes get
-[ pure-insn class<= ] filter
+[ foldable-insn class<= ] filter
+{ ##copy ##load-integer ##load-reference } diff
[
dup "insn-slots" word-prop input-values
define->expr-method
[ redundant-instruction ] [ useful-instruction ] ?if ;
M: insn process-instruction
+ dup rewrite [ process-instruction ] [ ] ?if ;
+
+M: foldable-insn process-instruction
dup rewrite
[ process-instruction ]
- [ dup defs-vreg [ check-redundancy ] when ] ?if ;
+ [ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if ;
M: ##copy process-instruction
dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
! Special cases
M: ##no-tco generate-insn drop ;
-M: ##stack-frame generate-insn drop ;
-
M: ##prologue generate-insn
drop
cfg get stack-frame>>
! FFI
CODEGEN: ##unbox %unbox
CODEGEN: ##unbox-long-long %unbox-long-long
-CODEGEN: ##store-reg-param %store-reg-param
-CODEGEN: ##store-stack-param %store-stack-param
-CODEGEN: ##load-reg-param %load-reg-param
-CODEGEN: ##load-stack-param %load-stack-param
CODEGEN: ##local-allot %local-allot
CODEGEN: ##box %box
CODEGEN: ##box-long-long %box-long-long
-CODEGEN: ##allot-byte-array %allot-byte-array
-CODEGEN: ##prepare-var-args %prepare-var-args
CODEGEN: ##alien-invoke %alien-invoke
-CODEGEN: ##cleanup %cleanup
CODEGEN: ##alien-indirect %alien-indirect
-CODEGEN: ##begin-callback %begin-callback
+CODEGEN: ##alien-assembly %alien-assembly
+CODEGEN: ##callback-inputs %callback-inputs
CODEGEN: ##alien-callback %alien-callback
-CODEGEN: ##end-callback %end-callback
-
-M: ##alien-assembly generate-insn
- [ gc-map>> gc-map set ] [ quot>> call( -- ) ] bi ;
+CODEGEN: ##callback-outputs %callback-outputs
[ 3 ] [ blah ] unit-test
-: out-param-test ( -- b )
- { int } [ [ 12 ] dip 0 int set-alien-value ] [ ] with-out-parameters ;
+: out-param-test-1 ( -- b )
+ { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
-[ 12 ] [ out-param-test ] unit-test
+[ 12 ] [ out-param-test-1 ] unit-test
+
+: out-param-test-2 ( -- b )
+ { { int initial: 12 } } [ drop ] with-out-parameters ;
+
+[ 12 ] [ out-param-test-2 ] unit-test
+
+: out-param-test-3 ( -- x y )
+ { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
+ with-out-parameters
+ [ x>> ] [ y>> ] bi ;
+
+[ 3.0 4.0 ] [ out-param-test-3 ] unit-test
: out-param-callback ( -- a )
void { int pointer: int } cdecl
{ int } [
swap void { int pointer: int } cdecl
alien-indirect
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
[ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test
[
{ BitmapData }
[ BitmapData memory>struct ALIEN: 123 >>Scan0 drop ]
- [ clone ]
with-out-parameters Scan0>>
] compile-call
] unit-test
USING: compiler.test compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval quotations compiler.errors
-definitions ;
+definitions generic.single ;
IN: compiler.tests.simple
! Test empty word
! Don't want compiler error to stick around
[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test
+
+! Make sure time bombs literalize
+[ [ \ + call ] compile-call ] [ no-method? ] must-fail-with
[ T{ color f f f f } ]
[ [ color new ] compile-call ] unit-test
+
+SYMBOL: foo
+
+[ [ foo new ] compile-call ] must-fail
+
+[ [ foo boa ] compile-call ] must-fail
[ 0 swap <CFRange> kCFStringEncodingUTF8 0 f ] keep
4 * 1 + <byte-array> [
dup length
- { CFIndex } [ CFStringGetBytes drop ] [ ]
- with-out-parameters
+ { CFIndex } [ CFStringGetBytes drop ] with-out-parameters
] keep
swap head-slice utf8 decode ;
: typographic-bounds ( line -- width ascent descent leading )
{ CGFloat CGFloat CGFloat }
- [ CTLineGetTypographicBounds ] [ ] with-out-parameters ; inline
+ [ CTLineGetTypographicBounds ] with-out-parameters ; inline
: store-typographic-bounds ( metrics width ascent descent leading -- metrics )
{
! can be passed to a C function, or returned from a callback
HOOK: %unbox cpu ( dst src func rep -- )
-HOOK: %unbox-long-long cpu ( src out func -- )
-
-HOOK: %store-reg-param cpu ( src reg rep -- )
-
-HOOK: %store-stack-param cpu ( src n rep -- )
+HOOK: %unbox-long-long cpu ( dst1 dst2 src func -- )
HOOK: %local-allot cpu ( dst size align offset -- )
HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- )
-HOOK: %allot-byte-array cpu ( dst size gc-map -- )
-
HOOK: %save-context cpu ( temp1 temp2 -- )
-HOOK: %prepare-var-args cpu ( -- )
-
-M: object %prepare-var-args ;
+HOOK: %c-invoke cpu ( symbols dll gc-map -- )
-HOOK: %alien-invoke cpu ( function library gc-map -- )
+HOOK: %alien-invoke cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- )
-HOOK: %cleanup cpu ( n -- )
+HOOK: %alien-indirect cpu ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- )
-M: object %cleanup ( n -- ) drop ;
+HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- )
-HOOK: %alien-indirect cpu ( src gc-map -- )
-
-HOOK: %load-reg-param cpu ( dst reg rep -- )
-
-HOOK: %load-stack-param cpu ( dst n rep -- )
-
-HOOK: %begin-callback cpu ( -- )
+HOOK: %callback-inputs cpu ( reg-outputs stack-outputs -- )
HOOK: %alien-callback cpu ( quot -- )
-HOOK: %end-callback cpu ( -- )
+HOOK: %callback-outputs cpu ( reg-inputs -- )
HOOK: stack-cleanup cpu ( stack-size return abi -- n )
-
-M: object stack-cleanup 3drop 0 ;
M:: ppc %unary-float-function ( dst src func -- )
0 src float-function-param
- func f %alien-invoke
+ func f %c-invoke
dst float-function-return ;
M:: ppc %binary-float-function ( dst src1 src2 func -- )
0 src1 float-function-param
1 src2 float-function-param
- func f %alien-invoke
+ func f %c-invoke
dst float-function-return ;
! Internal format is always double-precision on PowerPC
M: ppc %call-gc ( gc-roots -- )
3 swap gc-root-offsets %load-reference
4 %load-vm-addr
- "inline_gc" f %alien-invoke ;
+ "inline_gc" f %c-invoke ;
M: ppc %prologue ( n -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
:: call-unbox-func ( src func -- )
3 src load-param
4 %load-vm-addr
- func f %alien-invoke ;
+ func f %c-invoke ;
M:: ppc %unbox ( src n rep func -- )
src func call-unbox-func
4 src load-param
3 1 n local@ ADDI
c-type heap-size 5 LI
- "memcpy" "libc" load-library %alien-invoke ;
+ "memcpy" "libc" load-library %c-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 %c-invoke
3 dst store-param ;
M:: ppc %box-long-long ( dst n func -- )
4 1 n cell + local@ LWZ
] when
5 %load-vm-addr
- func f %alien-invoke
+ func f %c-invoke
3 dst store-param ;
: struct-return@ ( n -- n )
c-type heap-size 4 LI
5 %load-vm-addr
! Call the function
- "from_value_struct" f %alien-invoke
+ "from_value_struct" f %c-invoke
3 dst store-param ;
M:: ppc %restore-context ( temp1 temp2 -- )
ds-reg temp1 "datastack" context-field-offset STW
rs-reg temp1 "retainstack" context-field-offset STW ;
-M: ppc %alien-invoke ( symbol dll -- )
+M: ppc %c-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
M: ppc %alien-indirect ( src -- )
#! Box a <= 16-byte struct returned in r3:r4:r5:r6
c-type heap-size 7 LI
8 %load-vm-addr
- "from_medium_struct" f %alien-invoke
+ "from_medium_struct" f %c-invoke
3 dst store-param ;
: %unbox-struct-1 ( -- )
M: ppc %begin-callback ( -- )
3 %load-vm-addr
- "begin_callback" f %alien-invoke ;
+ "begin_callback" f %c-invoke ;
M: ppc %alien-callback ( quot -- )
3 swap %load-reference
M: ppc %end-callback ( -- )
3 %load-vm-addr
- "end_callback" f %alien-invoke ;
+ "end_callback" f %c-invoke ;
enable-float-functions
M: x86.32 %prepare-jump
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
+M: x86.32 %load-stack-param ( dst rep n -- )
+ next-stack@ swap pick register? [ %copy ] [
+ {
+ { int-rep [ [ EAX ] dip MOV ?spill-slot EAX MOV ] }
+ { float-rep [ FLDS ?spill-slot FSTPS ] }
+ { double-rep [ FLDL ?spill-slot FSTPL ] }
+ } case
+ ] if ;
+
+M: x86.32 %store-stack-param ( src rep n -- )
+ stack@ swap pick register? [ [ swap ] dip %copy ] [
+ {
+ { int-rep [ [ [ EAX ] dip ?spill-slot MOV ] [ EAX MOV ] bi* ] }
+ { float-rep [ [ ?spill-slot FLDS ] [ FSTPS ] bi* ] }
+ { double-rep [ [ ?spill-slot FLDL ] [ FSTPL ] bi* ] }
+ } case
+ ] if ;
+
:: load-float-return ( dst x87-insn rep -- )
dst register? [
ESP 4 SUB
dst ?spill-slot x87-insn execute
] if ; inline
-M: x86.32 %load-reg-param ( dst reg rep -- )
- {
+M: x86.32 %load-reg-param ( vreg rep reg -- )
+ swap {
{ int-rep [ int-rep %copy ] }
{ float-rep [ drop \ FSTPS float-rep load-float-return ] }
{ double-rep [ drop \ FSTPL double-rep load-float-return ] }
src ?spill-slot x87-insn execute
] if ; inline
-M: x86.32 %store-reg-param ( src reg rep -- )
- {
+M: x86.32 %store-reg-param ( vreg rep reg -- )
+ swap {
{ int-rep [ swap int-rep %copy ] }
{ float-rep [ drop \ FLDS float-rep store-float-return ] }
{ double-rep [ drop \ FLDL double-rep store-float-return ] }
EAX src tagged-rep %copy
4 save-vm-ptr
0 stack@ EAX MOV
- func f f %alien-invoke ;
+ func f f %c-invoke ;
M:: x86.32 %unbox ( dst src func rep -- )
src func call-unbox-func
dst rep %load-return ;
-M:: x86.32 %unbox-long-long ( src out func -- )
- EAX src int-rep %copy
- 0 stack@ EAX MOV
- EAX out int-rep %copy
- 4 stack@ EAX MOV
- 8 save-vm-ptr
- func f f %alien-invoke ;
+M:: x86.32 %unbox-long-long ( dst1 dst2 src func -- )
+ src int-rep 0 %store-stack-param
+ 4 save-vm-ptr
+ func f f %c-invoke
+ dst1 EAX int-rep %copy
+ dst2 EDX int-rep %copy ;
M:: x86.32 %box ( dst src func rep gc-map -- )
+ src rep 0 %store-stack-param
rep rep-size save-vm-ptr
- src rep %store-return
- 0 stack@ rep %load-return
- func f gc-map %alien-invoke
+ func f gc-map %c-invoke
dst EAX tagged-rep %copy ;
M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- )
+ src1 int-rep 0 %store-stack-param
+ src2 int-rep 4 %store-stack-param
8 save-vm-ptr
- EAX src1 int-rep %copy
- 0 stack@ EAX int-rep %copy
- EAX src2 int-rep %copy
- 4 stack@ EAX int-rep %copy
- func f gc-map %alien-invoke
+ func f gc-map %c-invoke
dst EAX tagged-rep %copy ;
-M:: x86.32 %allot-byte-array ( dst size gc-map -- )
- 4 save-vm-ptr
- 0 stack@ size MOV
- "allot_byte_array" f gc-map %alien-invoke
- dst EAX tagged-rep %copy ;
-
-M: x86.32 %alien-invoke
+M: x86.32 %c-invoke
[ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
4 stack@ 0 MOV
- "begin_callback" f f %alien-invoke ;
+ "begin_callback" f f %c-invoke ;
M: x86.32 %alien-callback ( quot -- )
[ EAX ] dip %load-reference
M: x86.32 %end-callback ( -- )
0 save-vm-ptr
- "end_callback" f f %alien-invoke ;
-
-GENERIC: float-function-param ( n dst src -- )
-
-M:: spill-slot float-function-param ( n dst src -- )
- ! We can clobber dst here since its going to contain the
- ! final result
- dst src double-rep %copy
- dst n double-rep %store-stack-param ;
-
-M:: register float-function-param ( n dst src -- )
- src n double-rep %store-stack-param ;
+ "end_callback" f f %c-invoke ;
M:: x86.32 %unary-float-function ( dst src func -- )
- 0 dst src float-function-param
- func "libm" load-library f %alien-invoke
+ src double-rep 0 %store-stack-param
+ func "libm" load-library f %c-invoke
dst double-rep %load-return ;
M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
- 0 dst src1 float-function-param
- 8 dst src2 float-function-param
- func "libm" load-library f %alien-invoke
+ src1 double-rep 0 %store-stack-param
+ src2 double-rep 8 %store-stack-param
+ func "libm" load-library f %c-invoke
dst double-rep %load-return ;
: funny-large-struct-return? ( return abi -- ? )
dup load-decks-offset
[+] card-mark <byte> MOV ;
-M:: x86.64 %load-reg-param ( dst reg rep -- )
- dst reg rep %copy ;
+M:: x86.64 %load-stack-param ( vreg rep n -- )
+ rep return-reg n next-stack@ rep %copy
+ vreg rep return-reg rep %copy ;
-M:: x86.64 %store-reg-param ( src reg rep -- )
- reg src rep %copy ;
+M:: x86.64 %store-stack-param ( vreg rep n -- )
+ rep return-reg vreg rep %copy
+ n reserved-stack-space + stack@ rep return-reg rep %copy ;
+
+M:: x86.64 %load-reg-param ( vreg rep reg -- )
+ vreg reg rep %copy ;
+
+M:: x86.64 %store-reg-param ( vreg rep reg -- )
+ reg vreg rep %copy ;
M:: x86.64 %unbox ( dst src func rep -- )
param-reg-0 src tagged-rep %copy
param-reg-1 %mov-vm-ptr
- func f f %alien-invoke
+ func f f %c-invoke
dst rep %load-return ;
M:: x86.64 %box ( dst src func rep gc-map -- )
0 rep reg-class-of cdecl param-regs at nth src rep %copy
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
- func f gc-map %alien-invoke
+ func f gc-map %c-invoke
dst int-rep %load-return ;
-M:: x86.64 %allot-byte-array ( dst size gc-map -- )
- param-reg-0 size MOV
- param-reg-1 %mov-vm-ptr
- "allot_byte_array" f gc-map %alien-invoke
- dst int-rep %load-return ;
-
-M: x86.64 %alien-invoke
+M: x86.64 %c-invoke
[ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip
gc-map-here ;
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
param-reg-1 0 MOV
- "begin_callback" f f %alien-invoke ;
+ "begin_callback" f f %c-invoke ;
M: x86.64 %alien-callback ( quot -- )
[ param-reg-0 ] dip %load-reference
M: x86.64 %end-callback ( -- )
param-reg-0 %mov-vm-ptr
- "end_callback" f f %alien-invoke ;
+ "end_callback" f f %c-invoke ;
: float-function-param ( i src -- )
[ float-regs cdecl param-regs at nth ] dip double-rep %copy ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
- func "libm" load-library f %alien-invoke
+ func "libm" load-library f %c-invoke
dst double-rep %load-return ;
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
! src2 is always a spill slot
0 src1 float-function-param
1 src2 float-function-param
- func "libm" load-library f %alien-invoke
+ func "libm" load-library f %c-invoke
dst double-rep %load-return ;
+M: x86.64 stack-cleanup 3drop 0 ;
+
+M: x86.64 %cleanup 0 assert= ;
+
M: x86.64 long-long-on-stack? f ;
M: x86.64 float-on-stack? f ;
M:: x86 %reload ( dst rep src -- )
dst src rep %copy ;
-M:: x86 %store-stack-param ( src n rep -- )
- n reserved-stack-space + stack@ src rep %copy ;
-
-: %load-return ( dst rep -- )
- [ reg-class-of return-regs at first ] keep %load-reg-param ;
-
-: %store-return ( dst rep -- )
- [ reg-class-of return-regs at first ] keep %store-reg-param ;
+M:: x86 %local-allot ( dst size align offset -- )
+ dst offset local-allot-offset special-offset stack@ LEA ;
: next-stack@ ( n -- operand )
#! nth parameter from the next stack frame. Used to box
#! set up by the caller.
[ frame-reg ] dip 2 cells + reserved-stack-space + [+] ;
-M:: x86 %load-stack-param ( dst n rep -- )
- dst n next-stack@ rep %copy ;
+: return-reg ( rep -- reg )
+ reg-class-of return-regs at first ;
-M:: x86 %local-allot ( dst size align offset -- )
- dst offset local-allot-offset special-offset stack@ LEA ;
+HOOK: %load-stack-param cpu ( vreg rep n -- )
+
+HOOK: %store-stack-param cpu ( vreg rep n -- )
+
+HOOK: %load-reg-param cpu ( vreg rep reg -- )
+
+HOOK: %store-reg-param cpu ( vreg rep reg -- )
+
+: %load-return ( dst rep -- )
+ dup return-reg %load-reg-param ;
+
+: %store-return ( dst rep -- )
+ dup return-reg %store-reg-param ;
+
+HOOK: %prepare-var-args cpu ( -- )
+
+HOOK: %cleanup cpu ( n -- )
+
+:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot -- )
+ stack-inputs [ first3 %store-stack-param ] each
+ reg-inputs [ first3 %store-reg-param ] each
+ quot call
+ cleanup %cleanup
+ reg-outputs [ first3 %load-reg-param ] each ; inline
+
+M: x86 %alien-invoke ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- )
+ '[ _ _ _ %c-invoke ] emit-alien-insn ;
+
+M:: x86 %alien-indirect ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- )
+ reg-inputs stack-inputs reg-outputs cleanup stack-size [
+ src ?spill-slot CALL
+ gc-map gc-map-here
+ ] emit-alien-insn ;
+
+M: x86 %alien-assembly ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- )
+ '[ _ _ gc-map set call( -- ) ] emit-alien-insn ;
+
+HOOK: %begin-callback cpu ( -- )
+
+M: x86 %callback-inputs ( reg-outputs stack-outputs -- )
+ [ [ first3 %load-reg-param ] each ]
+ [ [ first3 %load-stack-param ] each ] bi*
+ %begin-callback ;
+
+HOOK: %end-callback cpu ( -- )
-M: x86 %alien-indirect ( src gc-map -- )
- [ ?spill-slot CALL ] [ gc-map-here ] bi* ;
+M: x86 %callback-outputs ( reg-inputs -- )
+ %end-callback
+ [ first3 %store-reg-param ] each ;
M: x86 %loop-entry 16 alignment [ NOP ] times ;
:: (%compare-float) ( dst src1 src2 cc temp compare -- )
cc {
- { cc< [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
- { cc<= [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
- { cc> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
- { cc>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
- { cc= [ src1 src2 \ compare call( a b -- ) dst temp \ %cmov-float= (%boolean) ] }
- { cc<> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVNE (%boolean) ] }
- { cc<>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVNP (%boolean) ] }
- { cc/< [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
- { cc/<= [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
- { cc/> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
- { cc/>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
- { cc/= [ src1 src2 \ compare call( a b -- ) dst temp \ %cmov-float/= (%boolean) ] }
- { cc/<> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVE (%boolean) ] }
- { cc/<>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVP (%boolean) ] }
+ { cc< [ src2 src1 compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
+ { cc<= [ src2 src1 compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+ { cc> [ src1 src2 compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
+ { cc>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+ { cc= [ src1 src2 compare call( a b -- ) dst temp \ %cmov-float= (%boolean) ] }
+ { cc<> [ src1 src2 compare call( a b -- ) dst temp \ CMOVNE (%boolean) ] }
+ { cc<>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVNP (%boolean) ] }
+ { cc/< [ src2 src1 compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+ { cc/<= [ src2 src1 compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
+ { cc/> [ src1 src2 compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+ { cc/>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
+ { cc/= [ src1 src2 compare call( a b -- ) dst temp \ %cmov-float/= (%boolean) ] }
+ { cc/<> [ src1 src2 compare call( a b -- ) dst temp \ CMOVE (%boolean) ] }
+ { cc/<>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVP (%boolean) ] }
} case ; inline
: %jump-float= ( label -- )
:: (%compare-float-branch) ( label src1 src2 cc compare -- )
cc {
- { cc< [ src2 src1 \ compare call( a b -- ) label JA ] }
- { cc<= [ src2 src1 \ compare call( a b -- ) label JAE ] }
- { cc> [ src1 src2 \ compare call( a b -- ) label JA ] }
- { cc>= [ src1 src2 \ compare call( a b -- ) label JAE ] }
- { cc= [ src1 src2 \ compare call( a b -- ) label %jump-float= ] }
- { cc<> [ src1 src2 \ compare call( a b -- ) label JNE ] }
- { cc<>= [ src1 src2 \ compare call( a b -- ) label JNP ] }
- { cc/< [ src2 src1 \ compare call( a b -- ) label JBE ] }
- { cc/<= [ src2 src1 \ compare call( a b -- ) label JB ] }
- { cc/> [ src1 src2 \ compare call( a b -- ) label JBE ] }
- { cc/>= [ src1 src2 \ compare call( a b -- ) label JB ] }
- { cc/= [ src1 src2 \ compare call( a b -- ) label %jump-float/= ] }
- { cc/<> [ src1 src2 \ compare call( a b -- ) label JE ] }
- { cc/<>= [ src1 src2 \ compare call( a b -- ) label JP ] }
+ { cc< [ src2 src1 compare call( a b -- ) label JA ] }
+ { cc<= [ src2 src1 compare call( a b -- ) label JAE ] }
+ { cc> [ src1 src2 compare call( a b -- ) label JA ] }
+ { cc>= [ src1 src2 compare call( a b -- ) label JAE ] }
+ { cc= [ src1 src2 compare call( a b -- ) label %jump-float= ] }
+ { cc<> [ src1 src2 compare call( a b -- ) label JNE ] }
+ { cc<>= [ src1 src2 compare call( a b -- ) label JNP ] }
+ { cc/< [ src2 src1 compare call( a b -- ) label JBE ] }
+ { cc/<= [ src2 src1 compare call( a b -- ) label JB ] }
+ { cc/> [ src1 src2 compare call( a b -- ) label JBE ] }
+ { cc/>= [ src1 src2 compare call( a b -- ) label JB ] }
+ { cc/= [ src1 src2 compare call( a b -- ) label %jump-float/= ] }
+ { cc/<> [ src1 src2 compare call( a b -- ) label JE ] }
+ { cc/<>= [ src1 src2 compare call( a b -- ) label JP ] }
} case ;
enable-min/max
] [
&postgresql-free
] if
- ] [ ] with-out-parameters memory>byte-array
+ ] with-out-parameters memory>byte-array
] with-destructors
] [
drop pq-get-is-null nip [ f ] [ B{ } clone ] if
: sqlite-open ( path -- db )
normalize-path
- { void* } [ sqlite3_open sqlite-check-result ] [ ]
+ { void* } [ sqlite3_open sqlite-check-result ]
with-out-parameters ;
: sqlite-close ( db -- )
: sqlite-prepare ( db sql -- handle )
utf8 encode dup length
{ void* void* }
- [ sqlite3_prepare_v2 sqlite-check-result ] [ drop ]
- with-out-parameters ;
+ [ sqlite3_prepare_v2 sqlite-check-result ]
+ with-out-parameters drop ;
: sqlite-bind-parameter-index ( handle name -- index )
sqlite3_bind_parameter_index ;
: query-pointer ( -- x y buttons )
dpy get dup XDefaultRootWindow
{ int int int int int int int }
- [ XQueryPointer drop ] [ ] with-out-parameters
+ [ XQueryPointer drop ] with-out-parameters
[ 4 ndrop ] 3dip ;
SYMBOL: mouse-reset?
nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
master-completion-port get-global
{ int void* pointer: OVERLAPPED }
- [ timeout GetQueuedCompletionStatus zero? ] [ ] with-out-parameters
+ [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
:> ( error? bytes key overlapped )
bytes overlapped error? ;
: (open-process-token) ( handle -- handle )
flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY }
{ PHANDLE }
- [ OpenProcessToken win32-error=0/f ] [ ]
+ [ OpenProcessToken win32-error=0/f ]
with-out-parameters ;
: open-process-token ( -- handle )
TUPLE: windows-file-info < file-info attributes ;
: get-compressed-file-size ( path -- n )
- { DWORD } [ GetCompressedFileSize ] [ ] with-out-parameters
+ { DWORD } [ GetCompressedFileSize ] with-out-parameters
over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] if ;
: set-windows-size-on-disk ( file-info path -- file-info )
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
{ { ushort path-length } DWORD DWORD DWORD { ushort path-length } }
[ [ path-length ] 4dip path-length GetVolumeInformation win32-error=0/f ]
- [ [ utf16n alien>string ] 4dip utf16n alien>string ]
- with-out-parameters ;
+ with-out-parameters
+ [ utf16n alien>string ] 4dip utf16n alien>string ;
: file-system-space ( normalized-path -- available-space total-space free-space )
{ ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER }
- [ GetDiskFreeSpaceEx win32-error=0/f ] [ ]
+ [ GetDiskFreeSpaceEx win32-error=0/f ]
with-out-parameters ;
: calculate-file-system-info ( file-system-info -- file-system-info' )
: volume>paths ( string -- array )
{ { ushort names-buf-length } uint }
[ [ names-buf-length ] dip GetVolumePathNamesForVolumeName win32-error=0/f ]
- [ head utf16n alien>string { CHAR: \0 } split ]
- with-out-parameters ;
+ with-out-parameters
+ head utf16n alien>string { CHAR: \0 } split ;
: find-first-volume ( -- string handle )
{ { ushort path-length } }
[ path-length FindFirstVolume dup win32-error=0/f ]
- [ utf16n alien>string ]
- with-out-parameters swap ;
+ with-out-parameters utf16n alien>string swap ;
: find-next-volume ( handle -- string/f )
{ { ushort path-length } }
- [ path-length FindNextVolume ]
- [
- swap 0 = [
- GetLastError ERROR_NO_MORE_FILES =
- [ drop f ] [ win32-error-string throw ] if
- ] [ utf16n alien>string ] if
- ] with-out-parameters ;
+ [ path-length FindNextVolume ] with-out-parameters
+ swap 0 = [
+ GetLastError ERROR_NO_MORE_FILES =
+ [ drop f ] [ win32-error-string throw ] if
+ ] [ utf16n alien>string ] if ;
: find-volumes ( -- array )
find-first-volume
normalize-path open-read &dispose handle>>
{ FILETIME FILETIME FILETIME }
[ GetFileTime win32-error=0/f ]
- [ [ FILETIME>timestamp >local-time ] tri@ ]
with-out-parameters
+ [ FILETIME>timestamp >local-time ] tri@
] with-destructors ;
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
M: unix wait-for-processes ( -- ? )
- { int } [ -1 swap WNOHANG waitpid ] [ ] with-out-parameters
+ { int } [ -1 swap WNOHANG waitpid ] with-out-parameters
swap dup 0 <= [
2drop t
] [
: exit-code ( process -- n )
hProcess>>
- { DWORD } [ GetExitCodeProcess ] [ ] with-out-parameters
+ { DWORD } [ GetExitCodeProcess ] with-out-parameters
swap win32-error=0/f ;
: process-exited ( process -- )
WSAIoctl SOCKET_ERROR = [
winsock-error-string throw
] when
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
TUPLE: ConnectEx-args port
s name namelen lpSendBuffer dwSendDataLength
dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;
: master-port ( -- port )
- MACH_PORT_NULL { uint } [ IOMasterPort mach-error ] [ ] with-out-parameters ;
+ MACH_PORT_NULL { uint } [ IOMasterPort mach-error ] with-out-parameters ;
: io-services-matching-dictionary ( nsdictionary -- iterator )
master-port swap
- { uint } [ IOServiceGetMatchingServices mach-error ] [ ] with-out-parameters ;
+ { uint } [ IOServiceGetMatchingServices mach-error ] with-out-parameters ;
: io-services-matching-service ( service -- iterator )
IOServiceMatching io-services-matching-dictionary ;
: free ( alien -- )
>c-ptr [ delete-malloc ] [ (free) ] bi ;
+FUNCTION: void memset ( void* buf, int char, size_t size ) ;
+
FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ;
FUNCTION: int memcmp ( void* a, void* b, ulong size ) ;
{ $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } }
{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ;
+HELP: all-subsets
+{ $values { "seq" sequence } { "subsets" sequence } }
+{ $description
+ "Returns all the subsets of a sequence."
+}
+{ $examples
+ { $example
+ "USING: math.combinatorics prettyprint ;"
+ "{ 1 2 3 } all-subsets ."
+ "{ { } { 1 } { 2 } { 3 } { 1 2 } { 1 3 } { 2 3 } { 1 2 3 } }"
+ }
+} ;
+
+HELP: selections
+{ $values { "seq" sequence } { "n" integer } { "selections" sequence } }
+{ $description
+ "Returns all the ways to take n (possibly the same) items from the "
+ "sequence of items."
+}
+{ $examples
+ { $example
+ "USING: math.combinatorics prettyprint ;"
+ "{ 1 2 } 2 selections ."
+ "{ { 1 1 } { 1 2 } { 2 1 } { 2 2 } }"
+ }
+} ;
[ { { "a" "b" } { "a" "c" }
{ "a" "d" } { "b" "c" }
{ "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test
+
+[ { { } } ] [ { } all-subsets ] unit-test
+
+[ { { } { 1 } { 2 } { 3 } { 1 2 } { 1 3 } { 2 3 } { 1 2 3 } } ]
+[ { 1 2 3 } all-subsets ] unit-test
+
+[ { } ] [ { 1 2 } 0 selections ] unit-test
+
+[ { { 1 2 } } ] [ { 1 2 } 1 selections ] unit-test
+
+[ { { 1 1 } { 1 2 } { 2 1 } { 2 2 } } ]
+[ { 1 2 } 2 selections ] unit-test
+
+[ { { 1 1 1 } { 1 1 2 } { 1 2 1 } { 1 2 2 }
+ { 2 1 1 } { 2 1 2 } { 2 2 1 } { 2 2 2 } } ]
+[ { 1 2 } 3 selections ] unit-test
+
-! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer.
+! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer, John Benediktsson.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs binary-search fry kernel locals math math.order
- math.ranges namespaces sequences sorting ;
+ math.ranges namespaces sequences sorting make sequences.deep arrays
+ combinators ;
IN: math.combinatorics
<PRIVATE
: reduce-combinations ( seq k identity quot -- result )
[ -rot ] dip each-combination ; inline
+
+: all-subsets ( seq -- subsets )
+ dup length [0,b] [
+ [ dupd all-combinations [ , ] each ] each
+ ] { } make nip ;
+
+: (selections) ( seq n -- selections )
+ dupd [ dup 1 > ] [
+ swap pick cartesian-product [
+ [ [ dup length 1 > [ flatten ] when , ] each ] each
+ ] { } make swap 1 -
+ ] while drop nip ;
+
+: selections ( seq n -- selections )
+ {
+ { 0 [ drop { } ] }
+ { 1 [ 1array ] }
+ [ (selections) ]
+ } case ;
+
{ c:int float-4 } [
[ 123 swap 0 c:int c:set-alien-value ]
[ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi*
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
[ 123 float-4{ 1 2 3 4 } ] [ simd-stack-test ] unit-test
{ c:int } [
123 swap 0 c:int c:set-alien-value
>float (simd-stack-spill-test) float-4-with swap cos v*n
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
[ ] [
1.047197551196598 simd-stack-spill-test
: framebuffer-attachment ( attachment -- id )
GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
- { uint } [ glGetFramebufferAttachmentParameteriv ] [ ] with-out-parameters ;
+ { uint } [ glGetFramebufferAttachmentParameteriv ] with-out-parameters ;
swap glPushAttrib call glPopAttrib ; inline
: (gen-gl-object) ( quot -- id )
- [ 1 { uint } ] dip [ ] with-out-parameters ; inline
+ [ 1 { uint } ] dip with-out-parameters ; inline
: (delete-gl-object) ( id quot -- )
[ 1 swap <uint> ] dip call ; inline
dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
: gl-shader-get-int ( shader enum -- value )
- { int } [ glGetShaderiv ] [ ] with-out-parameters ;
+ { int } [ glGetShaderiv ] with-out-parameters ;
: gl-shader-ok? ( shader -- ? )
GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
: gl-program-get-int ( program enum -- value )
- { int } [ glGetProgramiv ] [ ] with-out-parameters ;
+ { int } [ glGetProgramiv ] with-out-parameters ;
: gl-program-ok? ( program -- ? )
GL_LINK_STATUS gl-program-get-int c-bool> ;
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
: get-texture-float ( target level enum -- value )
- { float } [ glGetTexLevelParameterfv ] [ ] with-out-parameters ; inline
+ { float } [ glGetTexLevelParameterfv ] with-out-parameters ; inline
: get-texture-int ( target level enum -- value )
- { int } [ glGetTexLevelParameteriv ] [ ] with-out-parameters ; inline
+ { int } [ glGetTexLevelParameteriv ] with-out-parameters ; inline
: line-offset>x ( layout n -- x )
#! n is an index into the UTF8 encoding of the text
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
- 0 { int } [ pango_layout_line_index_to_x ] [ ] with-out-parameters
+ 0 { int } [ pango_layout_line_index_to_x ] with-out-parameters
pango>float ;
: x>line-offset ( layout x -- n )
[ first-line ] dip
float>pango
{ int int }
- [ pango_layout_line_x_to_index drop ] [ ] with-out-parameters
+ [ pango_layout_line_x_to_index drop ] with-out-parameters
swap
] [ drop string>> ] 2bi utf8-index> + ;
type
flags
CryptAcquireContextW
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
: acquire-crypto-context ( provider type -- handle )
CRYPT_MACHINE_KEYSET
infer-quot-here
] dip recursive-state set ;
-: time-bomb ( error -- )
- '[ _ throw ] infer-quot-here ;
+: time-bomb-quot ( obj generic -- quot )
+ [ literalize ] [ "default-method" word-prop ] bi* [ ] 2sequence ;
-ERROR: bad-call obj ;
-
-M: bad-call summary
- drop "call must be given a callable" ;
+: time-bomb ( obj generic -- )
+ time-bomb-quot infer-quot-here ;
: infer-literal-quot ( literal -- )
dup recursive-quotation? [
[ [ recursion>> ] keep add-local-quotation ]
bi infer-quot
] [
- value>> \ bad-call boa time-bomb
+ value>> \ call time-bomb
] if
] if ;
\ compose [ infer-compose ] "special" set-word-prop
-ERROR: bad-executable obj ;
-
-M: bad-executable summary
- drop "execute must be given a word" ;
-
: infer-execute ( -- )
pop-literal nip
dup word? [
apply-object
] [
- \ bad-executable boa time-bomb
+ \ execute time-bomb
] if ;
\ execute [ infer-execute ] "special" set-word-prop
[ depends-on-tuple-layout ]
[ [ "boa-check" word-prop [ ] or ] dip ] 2bi
'[ @ _ <tuple-boa> ]
- ] [ drop f ] if
+ ] [
+ \ boa time-bomb
+ ] if
] 1 define-transform
\ boa t "no-compile" set-word-prop
ABOUT: "tools.test"
HELP: unit-test
-{ $syntax "[ output ] [ input ] unit-test" }
+{ $syntax "{ output } [ input ] unit-test" }
{ $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } }
{ $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ;
[ drop f ]
[
first
- { int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] [ ]
+ { int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ]
with-out-parameters
] if-empty ;
: arb-make-pixel-format ( world attributes -- pf )
[ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 { int int }
- [ wglChoosePixelFormatARB win32-error=0/f ] [ ] with-out-parameters drop ;
+ [ wglChoosePixelFormatARB win32-error=0/f ] with-out-parameters drop ;
: arb-pixel-format-attribute ( pixel-format attribute -- value )
>WGL_ARB
[ drop f ] [
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
first <int> { int }
- [ wglGetPixelFormatAttribivARB win32-error=0/f ] [ ]
+ [ wglGetPixelFormatAttribivARB win32-error=0/f ]
with-out-parameters
] if-empty ;
XGetWindowProperty
Success assert=
]
+ with-out-parameters
[| type format n-atoms bytes-after atoms |
atoms n-atoms <direct-ulong-array> >array
atoms XFree
- ]
- with-out-parameters ;
+ ] call ;
: net-wm-hint-supported? ( atom -- ? )
supported-net-wm-hints member? ;
[ handle>> ] [ >glx-visual ] bi*
[ 2drop f ] [
first
- { int } [ glXGetConfig drop ] [ ] with-out-parameters
+ { int } [ glXGetConfig drop ] with-out-parameters
] if-empty ;
CONSTANT: modifiers
[ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ;
GENERIC# apply-world-attributes 1 ( world attributes -- world )
+
M: world apply-world-attributes
{
[ title>> >>title ]
GENERIC: begin-world ( world -- )
GENERIC: end-world ( world -- )
-
GENERIC: resize-world ( world -- )
-M: world begin-world
- drop ;
-M: world end-world
- drop ;
-M: world resize-world
- drop ;
+M: world begin-world drop ;
+M: world end-world drop ;
+M: world resize-world drop ;
M: world dim<<
[ call-next-method ]
[ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
] bi ;
+: dispose-window-resources ( world -- )
+ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ;
+
M: world ungraft*
{
[ set-gl-context ]
[ hand-clicked close-global ]
[ hand-gadget close-global ]
[ end-world ]
- [ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
- [ [ (close-window) f ] change-handle drop ]
+ [ dispose-window-resources ]
[ unfocus-world ]
+ [ [ (close-window) f ] change-handle drop ]
[ promise>> t swap fulfill ]
} cleave ;
: composition-enabled? ( -- ? )
windows-major 6 >=
- [ { bool } [ DwmIsCompositionEnabled drop ] [ ] with-out-parameters ]
+ [ { bool } [ DwmIsCompositionEnabled drop ] with-out-parameters ]
[ f ] if ;
[ nip ]
[
swap (bitmap-info) DIB_RGB_COLORS { void* }
- [ f 0 CreateDIBSection ] [ ] with-out-parameters
+ [ f 0 CreateDIBSection ] with-out-parameters
] 2bi
[ [ SelectObject drop ] keep ] dip ;
swap ! icp
FALSE ! fTrailing
] if
- { int } [ ScriptStringCPtoX ole32-error ] [ ] with-out-parameters ;
+ { int } [ ScriptStringCPtoX ole32-error ] with-out-parameters ;
: x>line-offset ( x script-string -- n trailing )
ssa>> ! ssa
swap ! iX
- { int int } [ ScriptStringXtoCP ole32-error ] [ ] with-out-parameters ;
+ { int int } [ ScriptStringXtoCP ole32-error ] with-out-parameters ;
<PRIVATE
combinators system ;
IN: gdbm.ffi
-<< "libgdbm" os {
- { [ unix? ] [ "libgdbm.so" ] }
- { [ winnt? ] [ "gdbm.dll" ] }
- { [ macosx? ] [ "libgdbm.dylib" ] }
+<< "libgdbm" {
+ { [ os macosx? ] [ "libgdbm.dylib" ] }
+ { [ os unix? ] [ "libgdbm.so" ] }
+ { [ os winnt? ] [ "gdbm.dll" ] }
} cond cdecl add-library >>
LIBRARY: libgdbm
return array;
}
-VM_C_API cell allot_byte_array(cell size, factor_vm *parent)
-{
- return tag<byte_array>(parent->allot_byte_array(size));
-}
-
void factor_vm::primitive_byte_array()
{
cell size = unbox_array_size();
return data;
}
-VM_C_API cell allot_byte_array(cell size, factor_vm *parent);
-
}
}
}
-VM_C_API void to_signed_8(cell obj, s64 *out, factor_vm *parent)
+VM_C_API s64 to_signed_8(cell obj, factor_vm *parent)
{
- *out = parent->to_signed_8(obj);
+ return parent->to_signed_8(obj);
}
cell factor_vm::from_unsigned_8(u64 n)
}
}
-VM_C_API void to_unsigned_8(cell obj, u64 *out, factor_vm *parent)
+VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent)
{
- *out = parent->to_unsigned_8(obj);
+ return parent->to_unsigned_8(obj);
}
VM_C_API cell from_float(float flo, factor_vm *parent)
VM_C_API cell from_signed_8(s64 n, factor_vm *vm);
VM_C_API cell from_unsigned_8(u64 n, factor_vm *vm);
-VM_C_API void to_signed_8(cell obj, s64 *out, factor_vm *parent);
-VM_C_API void to_unsigned_8(cell obj, u64 *out, factor_vm *parent);
+VM_C_API s64 to_signed_8(cell obj, factor_vm *parent);
+VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent);
VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm);
VM_C_API cell to_cell(cell tagged, factor_vm *vm);
projects / factor.git / commitdiff