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

FFI rewrite part 7: compile callback bodies with the optimizing compiler

db4
Slava Pestov 2010-07-28 00:49:26 -04:00
parent 5fc9aa05b0
commit 168dd1f825
32 changed files with 193 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/cocoa/subclassing/subclassing.factor
View File

@ -95,16 +95,8 @@ SYNTAX: CLASS:
[ [ make-local ] map ] H{ } make-assoc
(parse-lambda) <lambda> ?rewrite-closures first ;
: method-effect ( quadruple -- effect )
[ third ] [ second void? { } { "x" } ? ] bi <effect> ;
: check-method ( quadruple -- )
[ fourth infer ] [ method-effect ] bi
2dup effect<= [ 2drop ] [ effect-error ] if ;
SYNTAX: METHOD:
scan-c-type
parse-selector
parse-method-body [ swap ] 2dip 4array
dup check-method
suffix! ;

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

@ -39,7 +39,6 @@ M: ##unary-float-function compute-stack-frame* drop vm-frame-required ;
M: ##binary-float-function compute-stack-frame* drop vm-frame-required ;
M: ##call compute-stack-frame* drop frame-required ;
M: ##alien-callback compute-stack-frame* drop frame-required ;
M: ##spill compute-stack-frame* drop frame-required ;
M: ##reload compute-stack-frame* drop frame-required ;

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

@ -173,24 +173,22 @@ M: #alien-assembly emit-node
: needs-frame-pointer ( -- )
cfg get t >>frame-pointer? drop ;
: emit-callback-body ( nodes -- )
[ last #return? t assert= ] [ but-last emit-nodes ] bi ;
M: #alien-callback emit-node
params>> dup xt>> dup
dup params>> xt>> dup
[
needs-frame-pointer
begin-word
{
[ callee-parameters ##callback-inputs ]
[ box-parameters ]
[
[
make-kill-block
quot>> ##alien-callback
] emit-trivial-block
]
[ callee-return ##callback-outputs ]
[ callback-stack-cleanup ]
[ params>> callee-parameters ##callback-inputs ]
[ params>> box-parameters ]
[ child>> emit-callback-body ]
[ params>> callee-return ##callback-outputs ]
[ params>> callback-stack-cleanup ]
} cleave
end-word

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

@ -99,6 +99,18 @@ M: ##write-barrier live-insn? src>> live-vreg? ;
M: ##write-barrier-imm live-insn? src>> live-vreg? ;
: filter-alien-outputs ( triples -- triples' )
[ first live-vreg? ] filter ;
M: alien-call-insn live-insn?
[ filter-alien-outputs ] change-reg-outputs
drop t ;
M: ##callback-inputs live-insn?
[ filter-alien-outputs ] change-reg-outputs
[ filter-alien-outputs ] change-stack-outputs
drop t ;
M: flushable-insn live-insn? defs-vregs [ live-vreg? ] any? ;
M: insn live-insn? drop t ;

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

@ -685,9 +685,6 @@ literal: reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map ;
VREG-INSN: ##callback-inputs
literal: reg-outputs stack-outputs ;
INSN: ##alien-callback
literal: quot ;
VREG-INSN: ##callback-outputs
literal: reg-inputs ;

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

@ -293,5 +293,4 @@ CODEGEN: ##alien-invoke %alien-invoke
CODEGEN: ##alien-indirect %alien-indirect
CODEGEN: ##alien-assembly %alien-assembly
CODEGEN: ##callback-inputs %callback-inputs
CODEGEN: ##alien-callback %alien-callback
CODEGEN: ##callback-outputs %callback-outputs

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

@ -45,6 +45,8 @@ FUNCTION: void ffi_test_0 ;
FUNCTION: int ffi_test_1 ;
[ 3 ] [ ffi_test_1 ] unit-test
[ ] [ \ ffi_test_1 def>> [ drop ] append compile-call ] unit-test
FUNCTION: int ffi_test_2 int x int y ;
[ 5 ] [ 2 3 ffi_test_2 ] unit-test
[ "hi" 3 ffi_test_2 ] must-fail

6
basis/compiler/tree/builder/builder.factor
View File

@ -20,10 +20,6 @@ M: callable (build-tree) infer-quot-here ;
: check-no-compile ( word -- )
dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
: check-effect ( word effect -- )
swap required-stack-effect 2dup effect<=
[ 2drop ] [ effect-error ] if ;
: inline-recursive? ( word -- ? )
[ "inline" word-prop ] [ "recursive" word-prop ] bi and ;
@ -33,7 +29,7 @@ M: callable (build-tree) infer-quot-here ;
M: word (build-tree)
[ check-no-compile ]
[ word-body infer-quot-here ]
[ current-effect check-effect ] tri ;
[ required-stack-effect check-effect ] tri ;
: build-tree-with ( in-stack word/quot -- nodes )
[

2
basis/compiler/tree/checker/checker.factor
View File

@ -188,7 +188,7 @@ M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #alien-node check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #alien-callback check-stack-flow* drop ;
M: #alien-callback check-stack-flow* child>> check-stack-flow ;
M: #declare check-stack-flow* drop ;

7
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -519,3 +519,10 @@ cell-bits 32 = [
14 ndrop
] cleaned-up-tree nodes>quot
] unit-test
USING: alien alien.c-types ;
[ t ] [
[ int { } cdecl [ 2 2 + ] alien-callback ]
{ + } inlined?
] unit-test

3
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -182,4 +182,7 @@ M: #recursive cleanup*
[ cleanup ] change-child
dup label>> calls>> empty? [ flatten-recursive ] when ;
M: #alien-callback cleanup*
[ cleanup ] change-child ;
M: node cleanup* ;

71
basis/compiler/tree/combinators/combinators.factor
View File

@ -1,46 +1,47 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs fry kernel accessors sequences compiler.utilities
arrays stack-checker.inlining namespaces compiler.tree
math.order ;
USING: assocs combinators combinators.short-circuit fry kernel
locals accessors sequences compiler.utilities arrays
stack-checker.inlining namespaces compiler.tree math.order ;
IN: compiler.tree.combinators
: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
dup dup '[
_ [
dup #branch? [
children>> [ _ each-node ] each
] [
dup #recursive? [
child>> _ each-node
] [ drop ] if
] if
:: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
nodes [
quot
[
{
{ [ dup #branch? ] [ children>> [ quot each-node ] each ] }
{ [ dup #recursive? ] [ child>> quot each-node ] }
{ [ dup #alien-callback? ] [ child>> quot each-node ] }
[ drop ]
} cond
] bi
] each ; inline recursive
: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
dup dup '[
@
dup #branch? [
[ [ _ map-nodes ] map ] change-children
] [
dup #recursive? [
[ _ map-nodes ] change-child
] when
] if
:: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
nodes [
quot call
{
{ [ dup #branch? ] [ [ [ quot map-nodes ] map ] change-children ] }
{ [ dup #recursive? ] [ [ quot map-nodes ] change-child ] }
{ [ dup #alien-callback? ] [ [ quot map-nodes ] change-child ] }
[ ]
} cond
] map-flat ; inline recursive
: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
dup dup '[
_ keep swap [ drop t ] [
dup #branch? [
children>> [ _ contains-node? ] any?
] [
dup #recursive? [
child>> _ contains-node?
] [ drop f ] if
] if
] if
:: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
nodes [
{
quot
[
{
{ [ dup #branch? ] [ children>> [ quot contains-node? ] any? ] }
{ [ dup #recursive? ] [ child>> quot contains-node? ] }
{ [ dup #alien-callback? ] [ child>> quot contains-node? ] }
[ drop f ]
} cond
]
} 1||
] any? ; inline recursive
: select-children ( seq flags -- seq' )

3
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -117,3 +117,6 @@ M: #terminate remove-dead-code*
M: #alien-node remove-dead-code*
maybe-drop-dead-outputs ;
M: #alien-callback remove-dead-code*
[ (remove-dead-code) ] change-child ;

13
basis/compiler/tree/debugger/debugger.factor
View File

@ -4,7 +4,7 @@ USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.custom
prettyprint.sections math words combinators
combinators.short-circuit io sorting hints
combinators.short-circuit io sorting hints sets
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
@ -22,6 +22,7 @@ compiler.tree.identities
compiler.tree.dead-code
compiler.tree.modular-arithmetic ;
FROM: fry => _ ;
FROM: namespaces => set ;
RENAME: _ match => __
IN: compiler.tree.debugger
@ -128,7 +129,8 @@ M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
M: #alien-assembly node>quot params>> , \ #alien-assembly , ;
M: #alien-callback node>quot params>> , \ #alien-callback , ;
M: #alien-callback node>quot
[ params>> , ] [ child>> nodes>quot , ] bi \ #alien-callback , ;
M: node node>quot drop ;
@ -222,7 +224,6 @@ SYMBOL: node-count
] with-scope ;
: inlined? ( quot seq/word -- ? )
[ cleaned-up-tree ] dip
dup word? [ 1array ] when
'[ dup #call? [ word>> _ member? ] [ drop f ] if ]
contains-node? not ;
dup word? [ 1array ] when swap
[ cleaned-up-tree [ dup #call? [ word>> , ] [ drop ] if ] each-node ] V{ } make
intersect empty? ;

2
basis/compiler/tree/escape-analysis/nodes/nodes.factor
View File

@ -13,7 +13,7 @@ SYMBOL: next-node
: each-with-next ( ... seq quot: ( ... elt -- ... ) -- ... )
dupd '[ 1 + _ ?nth next-node set @ ] each-index ; inline
: (escape-analysis) ( node -- )
: (escape-analysis) ( nodes -- )
[
[ node-defs-values introduce-values ]
[ escape-analysis* ]

3
basis/compiler/tree/escape-analysis/simple/simple.factor
View File

@ -100,4 +100,5 @@ M: #alien-node escape-analysis*
[ out-d>> unknown-allocations ]
bi ;
M: #alien-callback escape-analysis* drop ;
M: #alien-callback escape-analysis*
child>> (escape-analysis) ;

15
basis/compiler/tree/normalization/normalization.factor
View File

@ -109,8 +109,13 @@ M: #call-recursive normalize*
M: node normalize* ;
: normalize ( nodes -- nodes' )
dup count-introductions make-values
H{ } clone rename-map set
[ (normalize) ] [ nip ] 2bi
[ #introduce prefix ] unless-empty
rename-node-values ;
[
dup count-introductions make-values
H{ } clone rename-map set
[ (normalize) ] [ nip ] 2bi
[ #introduce prefix ] unless-empty
rename-node-values
] with-scope ;
M: #alien-callback normalize*
[ normalize ] change-child ;

4
basis/compiler/tree/propagation/nodes/nodes.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors kernel assocs
compiler.tree
@ -16,7 +16,7 @@ GENERIC: annotate-node ( node -- )
GENERIC: propagate-around ( node -- )
: (propagate) ( node -- )
: (propagate) ( nodes -- )
[ [ compute-copy-equiv ] [ propagate-around ] bi ] each ;
: extract-value-info ( values -- assoc )

2
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -153,4 +153,6 @@ M: #call propagate-after
M: #alien-node propagate-before propagate-alien-invoke ;
M: #alien-callback propagate-around child>> (propagate) ;
M: #return annotate-node dup in-d>> (annotate-node) ;

32
basis/compiler/tree/recursive/recursive-tests.factor
View File

@ -1,4 +1,4 @@
USING: tools.test kernel combinators.short-circuit math sequences accessors
USING: tools.test kernel combinators.short-circuit math sequences accessors make
compiler.tree
compiler.tree.builder
compiler.tree.combinators
@ -12,22 +12,24 @@ IN: compiler.tree.recursive.tests
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
: label-is-loop? ( nodes word -- ? )
[
{
[ drop #recursive? ]
[ drop label>> loop?>> ]
[ swap label>> word>> eq? ]
} 2&&
] curry contains-node? ;
swap [
[
dup {
[ #recursive? ]
[ label>> loop?>> ]
} 1&& [ label>> word>> , ] [ drop ] if
] each-node
] V{ } make member? ;
: label-is-not-loop? ( nodes word -- ? )
[
{
[ drop #recursive? ]
[ drop label>> loop?>> not ]
[ swap label>> word>> eq? ]
} 2&&
] curry contains-node? ;
swap [
[
dup {
[ #recursive? ]
[ label>> loop?>> not ]
} 1&& [ label>> word>> , ] [ drop ] if
] each-node
] V{ } make member? ;
: loop-test-1 ( a -- )
dup [ 1 + loop-test-1 ] [ drop ] if ; inline recursive

3
basis/compiler/tree/recursive/recursive.factor
View File

@ -61,6 +61,9 @@ M: #recursive node-call-graph
M: #branch node-call-graph
children>> [ (build-call-graph) ] with each ;
M: #alien-callback node-call-graph
child>> (build-call-graph) ;
M: node node-call-graph 2drop ;
SYMBOLS: not-loops recursive-nesting ;

5
basis/compiler/tree/tree.factor
View File

@ -154,10 +154,11 @@ TUPLE: #alien-assembly < #alien-node in-d out-d ;
: #alien-assembly ( params -- node )
\ #alien-assembly new-alien-node ;
TUPLE: #alien-callback < node params ;
TUPLE: #alien-callback < node params child ;
: #alien-callback ( params -- node )
: #alien-callback ( params child -- node )
\ #alien-callback new
swap >>child
swap >>params ;
: node, ( node -- ) stack-visitor get push ;

3
basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
View File

@ -5,7 +5,7 @@ compiler.tree.cleanup compiler.tree.escape-analysis
compiler.tree.tuple-unboxing compiler.tree.checker
compiler.tree.def-use kernel accessors sequences math
math.private sorting math.order binary-search sequences.private
slots.private ;
slots.private alien alien.c-types ;
IN: compiler.tree.tuple-unboxing.tests
: test-unboxing ( quot -- )
@ -35,6 +35,7 @@ TUPLE: empty-tuple ;
[ 1 cons boa over [ "A" throw ] when car>> ]
[ [ <=> ] sort ]
[ [ <=> ] with search ]
[ cons boa car>> void { } cdecl [ ] alien-callback ]
} [ [ ] swap [ test-unboxing ] curry unit-test ] each
! A more complicated example

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

@ -610,8 +610,6 @@ HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-si
HOOK: %callback-inputs cpu ( reg-outputs stack-outputs -- )
HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-outputs cpu ( reg-inputs -- )
HOOK: stack-cleanup cpu ( stack-size return abi -- n )

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

@ -186,10 +186,6 @@ M: x86.32 %begin-callback ( -- )
4 stack@ 0 MOV
"begin_callback" f f %c-invoke ;
M: x86.32 %alien-callback ( quot -- )
[ EAX ] dip %load-reference
EAX quot-entry-point-offset [+] CALL ;
M: x86.32 %end-callback ( -- )
0 save-vm-ptr
"end_callback" f f %c-invoke ;

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

@ -116,10 +116,6 @@ M: x86.64 %begin-callback ( -- )
param-reg-1 0 MOV
"begin_callback" f f %c-invoke ;
M: x86.64 %alien-callback ( quot -- )
[ param-reg-0 ] dip %load-reference
param-reg-0 quot-entry-point-offset [+] CALL ;
M: x86.64 %end-callback ( -- )
param-reg-0 %mov-vm-ptr
"end_callback" f f %c-invoke ;

49
basis/stack-checker/alien/alien.factor
View File

@ -4,7 +4,8 @@ USING: kernel arrays sequences accessors combinators math
namespaces init sets words assocs alien.libraries alien
alien.private alien.c-types fry quotations strings
stack-checker.backend stack-checker.errors stack-checker.visitor
stack-checker.dependencies compiler.utilities ;
stack-checker.dependencies stack-checker.state
compiler.utilities effects ;
IN: stack-checker.alien
TUPLE: alien-node-params
@ -19,7 +20,7 @@ TUPLE: alien-indirect-params < alien-node-params ;
TUPLE: alien-assembly-params < alien-node-params { quot callable } ;
TUPLE: alien-callback-params < alien-node-params { quot callable } xt ;
TUPLE: alien-callback-params < alien-node-params xt ;
: param-prep-quot ( params -- quot )
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
@ -106,6 +107,7 @@ TUPLE: alien-callback-params < alien-node-params { quot callable } xt ;
callbacks get [ dup "stack-cleanup" word-prop <callback> ] cache ;
: callback-bottom ( params -- )
"( callback )" <uninterned-word> >>xt
xt>> '[ _ callback-xt ] infer-quot-here ;
: callback-return-quot ( ctype -- quot )
@ -114,19 +116,36 @@ TUPLE: alien-callback-params < alien-node-params { quot callable } xt ;
: callback-prep-quot ( params -- quot )
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
: wrap-callback-quot ( params -- quot )
[ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
yield-hook get
'[ _ _ do-callback ]
>quotation ;
GENERIC: wrap-callback-quot ( params quot -- quot' )
M: callable wrap-callback-quot
swap [ callback-prep-quot ] [ callback-return-quot ] bi surround
yield-hook get
'[ _ _ do-callback ]
>quotation ;
: callback-effect ( params -- effect )
[ parameters>> length "x" <array> ] [ return>> void? { } { "x" } ? ] bi
<effect> ;
: infer-callback-quot ( params quot -- child )
[
init-inference
nest-visitor
infer-quot-here
end-infer
callback-effect check-effect
stack-visitor get
] with-scope ;
: infer-alien-callback ( -- )
alien-callback-params new
pop-quot
pop-abi
pop-params
pop-return
"( callback )" <uninterned-word> >>xt
dup wrap-callback-quot >>quot
dup callback-bottom
pop-literal nip [
alien-callback-params new
pop-abi
pop-params
pop-return
dup callback-bottom
dup
dup
] dip wrap-callback-quot infer-callback-quot
#alien-callback, ;

28
basis/stack-checker/stack-checker-tests.factor
View File

@ -473,3 +473,31 @@ FROM: splitting.private => split, ;
! M\ declared-effect infer-call* didn't properly unify branches
{ 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as
! Make sure alien-callback effects are checked properly
USING: alien.c-types alien ;
[ void { } cdecl [ ] alien-callback ] must-infer
[ [ void { } cdecl [ f [ drop ] unless ] alien-callback ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ void { } cdecl [ drop ] alien-callback ] infer ] [ effect-error? ] must-fail-with
[ [ int { } cdecl [ ] alien-callback ] infer ] [ effect-error? ] must-fail-with
[ int { } cdecl [ 5 ] alien-callback ] must-infer
[ int { int } cdecl [ ] alien-callback ] must-infer
[ int { int } cdecl [ 1 + ] alien-callback ] must-infer
[ void { int } cdecl [ . ] alien-callback ] must-infer
: recursive-callback-1 ( -- x )
void { } cdecl [ recursive-callback-1 drop ] alien-callback ;
\ recursive-callback-1 def>> must-infer
: recursive-callback-2 ( -- x )
void { } cdecl [ recursive-callback-2 drop ] alien-callback ; inline recursive
[ recursive-callback-2 ] must-infer

3
basis/stack-checker/state/state.factor
View File

@ -43,6 +43,9 @@ SYMBOL: literals
meta-d length "x" <array>
terminated? get <terminated-effect> ;
: check-effect ( required-effect -- )
[ current-effect ] dip 2dup effect<= [ 2drop ] [ effect-error ] if ;
: init-inference ( -- )
terminated? off
V{ } clone \ meta-d set

2
basis/stack-checker/visitor/dummy/dummy.factor
View File

@ -25,4 +25,4 @@ M: f #drop, drop ;
M: f #alien-invoke, drop ;
M: f #alien-indirect, drop ;
M: f #alien-assembly, drop ;
M: f #alien-callback, drop ;
M: f #alien-callback, 2drop ;

2
basis/stack-checker/visitor/visitor.factor
View File

@ -30,4 +30,4 @@ HOOK: #copy, stack-visitor ( inputs outputs -- )
HOOK: #alien-invoke, stack-visitor ( params -- )
HOOK: #alien-indirect, stack-visitor ( params -- )
HOOK: #alien-assembly, stack-visitor ( params -- )
HOOK: #alien-callback, stack-visitor ( params -- )
HOOK: #alien-callback, stack-visitor ( params child -- )

6
core/alien/alien.factor
View File

@ -106,12 +106,12 @@ SYMBOL: callbacks
! returning from it, to avoid a bad interaction between threads
! and callbacks. See basis/compiler/tests/alien.factor for a
! test case.
: wait-to-return ( yield-quot callback-id -- )
: wait-to-return ( yield-quot: ( -- ) callback-id -- )
dup current-callback eq?
[ 2drop ] [ over call( -- ) wait-to-return ] if ;
[ 2drop ] [ over call wait-to-return ] if ; inline recursive
! Used by compiler.codegen to wrap callback bodies
: do-callback ( callback-quot yield-quot -- )
: do-callback ( callback-quot yield-quot: ( -- ) -- )
init-namespaces
init-catchstack
current-callback