1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types alien.libraries alien.strings arrays
4 assocs classes.struct combinators compiler.cfg compiler.cfg.builder
5 compiler.cfg.builder.alien.boxing compiler.cfg.builder.alien.params
6 compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers
7 compiler.cfg.stacks compiler.cfg.stacks.local compiler.errors
8 compiler.tree cpu.architecture fry kernel layouts make math namespaces
9 sequences sequences.generalizations words ;
10 IN: compiler.cfg.builder.alien
12 : with-param-regs ( abi quot -- reg-values stack-values )
16 V{ } clone reg-values set
17 V{ } clone stack-values set
22 struct-return-area get
24 struct-return-area set
25 stack-params set ; inline
27 : unbox-parameters ( parameters -- vregs reps )
29 [ length <iota> <reversed> ] keep
30 [ [ <ds-loc> peek-loc ] [ base-type ] bi* unbox-parameter ]
31 2 2 mnmap [ concat ] bi@
33 [ length neg <ds-loc> inc-stack ] bi ;
35 : prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
37 heap-size cell f ^^local-allot [
39 [ int-rep struct-return-on-stack? f 3array prefix ] bi*
43 : (caller-parameters) ( vregs reps -- )
44 [ first3 next-parameter ] 2each ;
46 : caller-parameters ( params -- reg-inputs stack-inputs )
47 [ abi>> ] [ parameters>> ] [ return>> ] tri
50 _ prepare-struct-caller struct-return-area set
54 : prepare-caller-return ( params -- reg-outputs )
55 return>> [ { } ] [ base-type load-return ] if-void ;
57 : caller-stack-cleanup ( params stack-size -- cleanup )
58 swap [ return>> ] [ abi>> ] bi stack-cleanup ;
60 : check-dlsym ( symbol library/f -- )
62 { [ dup library-dll dll-valid? not ] [
63 [ library-dll dll-path ] [ dlerror>> ] bi
64 cfg get word>> no-such-library-error drop
66 { [ 2dup library-dll dlsym not ] [
67 drop dlerror cfg get word>> no-such-symbol-error
72 : caller-linkage ( params -- symbol dll/f )
73 [ function>> ] [ library>> lookup-library ] bi
74 2dup check-dlsym library-dll ;
76 : caller-return ( params -- )
79 building get last reg-outputs>>
80 flip [ { } { } ] [ first2 ] if-empty
82 base-type box-return ds-push
85 : params>alien-insn-params ( params --
86 varargs? reg-inputs stack-inputs
87 reg-outputs dead-outputs
92 [ prepare-caller-return { } ]
93 [ stack-params get [ caller-stack-cleanup ] keep ]
96 M: #alien-invoke emit-node ( block node -- block' )
99 [ params>alien-insn-params ]
100 [ caller-linkage ] bi
101 <gc-map> ##alien-invoke,
103 [ caller-return ] bi ;
105 M: #alien-indirect emit-node ( block node -- block' )
108 [ ds-pop ^^unbox-any-c-ptr ] dip
109 params>alien-insn-params
110 <gc-map> ##alien-indirect,
112 [ caller-return ] bi ;
114 M: #alien-assembly emit-node ( block node -- block' )
117 [ params>alien-insn-params ]
121 [ caller-return ] bi ;
123 : callee-parameter ( rep on-stack? odd-register? -- dst )
124 [ next-vreg dup ] 3dip next-parameter ;
126 : prepare-struct-callee ( c-type -- vreg )
128 [ int-rep struct-return-on-stack? f callee-parameter ] [ f ] if ;
130 : (callee-parameters) ( params -- vregs reps )
131 [ flatten-parameter-type ] map
132 [ [ [ first3 callee-parameter ] map ] map ]
133 [ [ keys ] map ] bi ;
135 : box-parameters ( vregs reps params -- )
136 parameters>> [ base-type box-parameter ds-push ] 3each ;
138 : callee-parameters ( params -- vregs reps reg-outputs stack-outputs )
139 [ abi>> ] [ return>> ] [ parameters>> ] tri
141 _ prepare-struct-callee struct-return-area set
142 _ [ base-type ] map (callee-parameters)
145 : callee-return ( params -- reg-inputs )
148 base-type unbox-return store-return
151 : emit-callback-body ( block nodes -- block' )
152 dup last #return? t assert= but-last emit-nodes ;
154 : emit-callback-inputs ( params -- )
155 [ callee-parameters ##callback-inputs, ] keep box-parameters ;
157 : callback-stack-cleanup ( params -- )
159 [ [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup ] bi
160 "stack-cleanup" set-word-prop ;
162 : emit-callback-return ( block params -- )
163 swap [ callee-return ##callback-outputs, ] [ drop ] if ;
165 : emit-callback-outputs ( block params -- )
166 [ emit-callback-return ] keep callback-stack-cleanup ;
168 M: #alien-callback emit-node ( block node -- block' )
169 dup params>> xt>> dup
171 t cfg get frame-pointer?<<
173 over params>> emit-callback-inputs
174 over child>> emit-callback-body
175 [ swap params>> emit-callback-outputs ] keep
176 [ end-word drop ] when*