1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes combinators
4 cpu.architecture effects generic hashtables io kernel
5 kernel.private layouts math math.parser namespaces make
6 prettyprint quotations sequences system threads words vectors
7 sets deques continuations.private summary alien alien.c-types
8 alien.structs alien.strings alien.arrays libc compiler.errors
9 stack-checker.inlining compiler.tree compiler.tree.builder
10 compiler.tree.combinators compiler.tree.propagation.info
11 compiler.generator.fixup compiler.generator.registers
12 compiler.generator.iterator ;
13 IN: compiler.generator
18 : queue-compile ( word -- )
20 { [ dup "forgotten" word-prop ] [ ] }
21 { [ dup compiled get key? ] [ ] }
22 { [ dup inlined-block? ] [ ] }
23 { [ dup primitive? ] [ ] }
24 [ dup compile-queue get push-front ]
27 : maybe-compile ( word -- )
28 dup compiled>> [ drop ] [ queue-compile ] if ;
30 SYMBOL: compiling-word
32 SYMBOL: compiling-label
34 SYMBOL: compiling-loops
36 ! Label of current word, after prologue, makes recursion faster
37 SYMBOL: current-label-start
39 : compiled-stack-traces? ( -- ? ) 59 getenv ;
41 : begin-compiling ( word label -- )
42 H{ } clone compiling-loops set
45 compiled-stack-traces?
46 compiling-word get f ?
47 1vector literal-table set
48 f compiling-label get compiled get set-at ;
50 : save-machine-code ( literals relocation labels code -- )
51 4array compiling-label get compiled get set-at ;
53 : with-generator ( nodes word label quot -- )
60 GENERIC: generate-node ( node -- next )
62 : generate-nodes ( nodes -- )
63 [ current-node generate-node ] iterate-nodes
66 : init-generate-nodes ( -- )
70 current-label-start define-label
71 current-label-start resolve-label ;
73 : generate ( nodes word label -- )
76 [ generate-nodes ] with-node-iterator
79 : intrinsics ( #call -- quot )
80 word>> "intrinsics" word-prop ;
82 : if-intrinsics ( #call -- quot )
83 word>> "if-intrinsics" word-prop ;
86 M: node generate-node drop iterate-next ;
89 dup compiling-label get eq?
90 [ drop current-label-start get ] [ %epilogue-later ] if
93 : generate-call ( label -- next )
96 dup compiling-loops get at [
109 : compile-recursive ( node -- next )
110 dup label>> id>> generate-call >r
111 [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
114 : compiling-loop ( word -- )
115 <label> dup resolve-label swap compiling-loops get set-at ;
117 : compile-loop ( node -- next )
119 [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
122 M: #recursive generate-node
123 dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
126 : end-false-branch ( label -- )
127 tail-call? [ %return drop ] [ %jump-label ] if ;
129 : generate-branch ( nodes -- )
130 [ copy-templates generate-nodes ] with-scope ;
132 : generate-if ( node label -- next )
134 >r >r children>> first2 swap generate-branch
135 r> r> end-false-branch resolve-label
138 ] keep resolve-label iterate-next ;
141 [ <label> dup %jump-f ]
142 H{ { +input+ { { f "flag" } } } }
147 : dispatch-branch ( nodes word -- label )
153 [ generate-nodes ] with-node-iterator
158 : dispatch-branches ( node -- )
160 compiling-word get dispatch-branch
164 : generate-dispatch ( node -- )
165 %dispatch dispatch-branches init-templates ;
167 M: #dispatch generate-node
168 #! The order here is important, dispatch-branches must
169 #! run after %dispatch, so that each branch gets the
170 #! correct register state
172 generate-dispatch iterate-next
174 compiling-word get gensym [
183 : define-intrinsics ( word intrinsics -- )
184 "intrinsics" set-word-prop ;
186 : define-intrinsic ( word quot assoc -- )
187 2array 1array define-intrinsics ;
189 : define-if>branch-intrinsics ( word intrinsics -- )
190 "if-intrinsics" set-word-prop ;
192 : if>boolean-intrinsic ( quot -- )
195 "false" get swap call
196 t "if-scratch" get load-literal
197 "end" get %jump-label
198 "false" resolve-label
199 f "if-scratch" get load-literal
201 "if-scratch" get phantom-push ; inline
203 : define-if>boolean-intrinsics ( word intrinsics -- )
205 >r [ if>boolean-intrinsic ] curry r>
206 { { f "if-scratch" } } +scratch+ associate assoc-union
207 ] assoc-map "intrinsics" set-word-prop ;
209 : define-if-intrinsics ( word intrinsics -- )
210 [ +input+ associate ] assoc-map
211 2dup define-if>branch-intrinsics
212 define-if>boolean-intrinsics ;
214 : define-if-intrinsic ( word quot inputs -- )
215 2array 1array define-if-intrinsics ;
217 : do-if-intrinsic ( pair -- next )
218 <label> [ swap do-template skip-next ] keep generate-if ;
220 : find-intrinsic ( #call -- pair/f )
221 intrinsics find-template ;
223 : find-if-intrinsic ( #call -- pair/f )
225 { [ dup length 2 < ] [ 2drop f ] }
226 { [ dup second #if? ] [ drop if-intrinsics find-template ] }
230 M: #call generate-node
231 dup node-input-infos [ class>> ] map set-operand-classes
232 dup find-if-intrinsic [
236 do-template iterate-next
243 M: #call-recursive generate-node label>> id>> generate-call ;
246 M: #push generate-node
247 literal>> <constant> phantom-push iterate-next ;
250 M: #shuffle generate-node
251 shuffle-effect phantom-shuffle iterate-next ;
254 [ in-d>> length ] [ out-r>> empty? ] bi
255 [ phantom-drop ] [ phantom->r ] if
259 [ in-r>> length ] [ out-d>> empty? ] bi
260 [ phantom-rdrop ] [ phantom-r> ] if
264 M: #return generate-node
265 drop end-basic-block %return f ;
267 M: #return-recursive generate-node
269 label>> id>> compiling-loops get key?
270 [ %return ] unless f ;
273 : large-struct? ( ctype -- ? )
274 dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
276 : alien-parameters ( params -- seq )
278 swap return>> large-struct? [ "void*" prefix ] when ;
280 : alien-return ( params -- ctype )
281 return>> dup large-struct? [ drop "void" ] when ;
283 : c-type-stack-align ( type -- align )
284 dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
286 : parameter-align ( n type -- n delta )
287 over >r c-type-stack-align align dup r> - ;
289 : parameter-sizes ( types -- total offsets )
290 #! Compute stack frame locations.
293 [ parameter-align drop dup , ] keep stack-size +
297 : return-size ( ctype -- n )
298 #! Amount of space we reserve for a return value.
299 dup large-struct? [ heap-size ] [ drop 0 ] if ;
301 : alien-stack-frame ( params -- n )
302 alien-parameters parameter-sizes drop ;
304 : alien-invoke-frame ( params -- n )
305 #! Two cells for temporary storage, temp@ and on x86.64,
306 #! small struct return value unpacking
307 [ return>> return-size ] [ alien-stack-frame ] bi
310 : set-stack-frame ( n -- )
311 dup [ frame-required ] when* \ stack-frame set ;
313 : with-stack-frame ( n quot -- )
316 f set-stack-frame ; inline
318 GENERIC: reg-size ( register-class -- n )
320 M: int-regs reg-size drop cell ;
322 M: single-float-regs reg-size drop 4 ;
324 M: double-float-regs reg-size drop 8 ;
326 M: stack-params reg-size drop "void*" heap-size ;
328 GENERIC: reg-class-variable ( register-class -- symbol )
330 M: reg-class reg-class-variable ;
332 M: float-regs reg-class-variable drop float-regs ;
334 M: stack-params reg-class-variable drop stack-params ;
336 GENERIC: inc-reg-class ( register-class -- )
338 M: reg-class inc-reg-class
339 dup reg-class-variable inc
340 fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
342 M: float-regs inc-reg-class
344 fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
346 : reg-class-full? ( class -- ? )
347 [ reg-class-variable get ] [ param-regs length ] bi >= ;
349 : spill-param ( reg-class -- n reg-class )
351 >r reg-size stack-params +@ r>
354 : fastcall-param ( reg-class -- n reg-class )
355 [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
357 : alloc-parameter ( parameter -- reg reg-class )
358 c-type-reg-class dup reg-class-full?
359 [ spill-param ] [ fastcall-param ] if
362 : (flatten-int-type) ( size -- types )
363 cell /i "void*" c-type <repetition> ;
365 GENERIC: flatten-value-type ( type -- types )
367 M: object flatten-value-type 1array ;
369 M: struct-type flatten-value-type ( type -- types )
370 stack-size cell align (flatten-int-type) ;
372 M: long-long-type flatten-value-type ( type -- types )
373 stack-size cell align (flatten-int-type) ;
375 : flatten-value-types ( params -- params )
376 #! Convert value type structs to consecutive void*s.
380 [ parameter-align (flatten-int-type) % ] keep
381 [ stack-size cell align + ] keep
386 : each-parameter ( parameters quot -- )
387 >r [ parameter-sizes nip ] keep r> 2each ; inline
389 : reverse-each-parameter ( parameters quot -- )
390 >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
392 : reset-freg-counts ( -- )
393 { int-regs float-regs stack-params } [ 0 swap set ] each ;
395 : with-param-regs ( quot -- )
396 #! In quot you can call alloc-parameter
397 [ reset-freg-counts call ] with-scope ; inline
399 : move-parameters ( node word -- )
400 #! Moves values from C stack to registers (if word is
401 #! %load-param-reg) and registers to C stack (if word is
406 r> [ >r alloc-parameter r> execute ] curry each-parameter ;
409 : unbox-parameters ( offset node -- )
411 %prepare-unbox >r over + r> unbox-parameter
412 ] reverse-each-parameter drop ;
414 : prepare-box-struct ( node -- offset )
415 #! Return offset on C stack where to store unboxed
416 #! parameters. If the C function is returning a structure,
417 #! the first parameter is an implicit target area pointer,
418 #! so we need to use a different offset.
419 return>> dup large-struct?
420 [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
422 : objects>registers ( params -- )
423 #! Generate code for unboxing a list of C types, then
424 #! generate code for moving these parameters to register on
425 #! architectures where parameters are passed in registers.
427 [ prepare-box-struct ] keep
428 [ unbox-parameters ] keep
429 \ %load-param-reg move-parameters
432 : box-return* ( node -- )
433 return>> [ ] [ box-return ] if-void ;
435 TUPLE: no-such-library name ;
437 M: no-such-library summary
438 drop "Library not found" ;
440 M: no-such-library compiler-error-type
443 : no-such-library ( name -- )
444 \ no-such-library boa
445 compiling-word get compiler-error ;
447 TUPLE: no-such-symbol name ;
449 M: no-such-symbol summary
450 drop "Symbol not found" ;
452 M: no-such-symbol compiler-error-type
455 : no-such-symbol ( name -- )
457 compiling-word get compiler-error ;
459 : check-dlsym ( symbols dll -- )
461 dupd [ dlsym ] curry contains?
462 [ drop ] [ no-such-symbol ] if
464 dll-path no-such-library drop
467 : stdcall-mangle ( symbol node -- symbol )
469 swap parameters>> parameter-sizes drop
470 number>string 3append ;
472 : alien-invoke-dlsym ( params -- symbols dll )
473 dup function>> dup pick stdcall-mangle 2array
474 swap library>> library dup [ dll>> ] when
477 M: #alien-invoke generate-node
479 dup alien-invoke-frame [
481 %prepare-alien-invoke
482 dup objects>registers
484 dup alien-invoke-dlsym %alien-invoke
491 M: #alien-indirect generate-node
493 dup alien-invoke-frame [
496 ! Save registers for GC
497 %prepare-alien-invoke
498 ! Save alien at top of stack to temporary storage
499 %prepare-alien-indirect
500 dup objects>registers
502 ! Call alien in temporary storage
510 : box-parameters ( params -- )
511 alien-parameters [ box-parameter ] each-parameter ;
513 : registers>objects ( node -- )
515 dup \ %save-param-reg move-parameters
516 "nest_stacks" f %alien-invoke
520 TUPLE: callback-context ;
522 : current-callback 2 getenv ;
524 : wait-to-return ( token -- )
525 dup current-callback eq? [
531 : do-callback ( quot token -- )
535 wait-to-return ; inline
537 : callback-return-quot ( ctype -- quot )
539 { [ dup "void" = ] [ drop [ ] ] }
540 { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
541 [ c-type c-type-unboxer-quot ]
544 : callback-prep-quot ( params -- quot )
545 parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
547 : wrap-callback-quot ( params -- quot )
549 [ callback-prep-quot ]
551 [ callback-return-quot ] tri 3append ,
552 [ callback-context new do-callback ] %
555 : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
557 : callback-unwind ( params -- n )
559 { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
560 { [ dup return>> large-struct? ] [ drop 4 ] }
564 : %callback-return ( params -- )
565 #! All the extra book-keeping for %unwind is only for x86.
566 #! On other platforms its an alias for %return.
568 [ %unnest-stacks ] [ %callback-value ] if-void
569 callback-unwind %unwind ;
571 : generate-callback ( params -- )
575 dup alien-stack-frame [
576 [ registers>objects ]
577 [ wrap-callback-quot %alien-callback ]
583 M: #alien-callback generate-node
585 params>> generate-callback iterate-next ;