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 prettyprint
6 quotations sequences system threads words vectors sets deques
7 continuations.private summary alien alien.c-types
8 alien.structs alien.strings alien.arrays libc compiler.errors
10 compiler.tree compiler.tree.builder compiler.tree.combinators
11 compiler.tree.propagation.info compiler.generator.fixup
12 compiler.generator.registers 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 -- ? )
275 heap-size struct-small-enough? not
278 : alien-parameters ( params -- seq )
280 swap return>> large-struct? [ "void*" prefix ] when ;
282 : alien-return ( params -- ctype )
283 return>> dup large-struct? [ drop "void" ] when ;
285 : c-type-stack-align ( type -- align )
286 dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
288 : parameter-align ( n type -- n delta )
289 over >r c-type-stack-align align dup r> - ;
291 : parameter-sizes ( types -- total offsets )
292 #! Compute stack frame locations.
295 [ parameter-align drop dup , ] keep stack-size +
299 : return-size ( ctype -- n )
300 #! Amount of space we reserve for a return value.
301 dup large-struct? [ heap-size ] [ drop 0 ] if ;
303 : alien-stack-frame ( params -- n )
304 alien-parameters parameter-sizes drop ;
306 : alien-invoke-frame ( params -- n )
307 #! One cell is temporary storage, temp@
308 dup return>> return-size
309 swap alien-stack-frame +
312 : set-stack-frame ( n -- )
313 dup [ frame-required ] when* \ stack-frame set ;
315 : with-stack-frame ( n quot -- )
318 f set-stack-frame ; inline
320 GENERIC: reg-size ( register-class -- n )
322 M: int-regs reg-size drop cell ;
324 M: single-float-regs reg-size drop 4 ;
326 M: double-float-regs reg-size drop 8 ;
328 M: stack-params reg-size drop "void*" heap-size ;
330 GENERIC: reg-class-variable ( register-class -- symbol )
332 M: reg-class reg-class-variable ;
334 M: float-regs reg-class-variable drop float-regs ;
336 M: stack-params reg-class-variable drop stack-params ;
338 GENERIC: inc-reg-class ( register-class -- )
340 M: reg-class inc-reg-class
341 dup reg-class-variable inc
342 fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
344 M: float-regs inc-reg-class
346 fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
348 : reg-class-full? ( class -- ? )
349 [ reg-class-variable get ] [ param-regs length ] bi >= ;
351 : spill-param ( reg-class -- n reg-class )
353 >r reg-size stack-params +@ r>
356 : fastcall-param ( reg-class -- n reg-class )
357 [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
359 : alloc-parameter ( parameter -- reg reg-class )
360 c-type-reg-class dup reg-class-full?
361 [ spill-param ] [ fastcall-param ] if
364 : (flatten-int-type) ( size -- )
365 cell /i "void*" c-type <repetition> % ;
367 GENERIC: flatten-value-type ( type -- )
369 M: object flatten-value-type , ;
371 M: struct-type flatten-value-type ( type -- )
372 stack-size cell align (flatten-int-type) ;
374 M: long-long-type flatten-value-type ( type -- )
375 stack-size cell align (flatten-int-type) ;
377 : flatten-value-types ( params -- params )
378 #! Convert value type structs to consecutive void*s.
382 [ parameter-align (flatten-int-type) ] keep
383 [ stack-size cell align + ] keep
388 : each-parameter ( parameters quot -- )
389 >r [ parameter-sizes nip ] keep r> 2each ; inline
391 : reverse-each-parameter ( parameters quot -- )
392 >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
394 : reset-freg-counts ( -- )
395 { int-regs float-regs stack-params } [ 0 swap set ] each ;
397 : with-param-regs ( quot -- )
398 #! In quot you can call alloc-parameter
399 [ reset-freg-counts call ] with-scope ; inline
401 : move-parameters ( node word -- )
402 #! Moves values from C stack to registers (if word is
403 #! %load-param-reg) and registers to C stack (if word is
408 r> [ >r alloc-parameter r> execute ] curry each-parameter ;
411 : unbox-parameters ( offset node -- )
413 %prepare-unbox >r over + r> unbox-parameter
414 ] reverse-each-parameter drop ;
416 : prepare-box-struct ( node -- offset )
417 #! Return offset on C stack where to store unboxed
418 #! parameters. If the C function is returning a structure,
419 #! the first parameter is an implicit target area pointer,
420 #! so we need to use a different offset.
421 return>> dup large-struct?
422 [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
424 : objects>registers ( params -- )
425 #! Generate code for unboxing a list of C types, then
426 #! generate code for moving these parameters to register on
427 #! architectures where parameters are passed in registers.
429 [ prepare-box-struct ] keep
430 [ unbox-parameters ] keep
431 \ %load-param-reg move-parameters
434 : box-return* ( node -- )
435 return>> [ ] [ box-return ] if-void ;
437 TUPLE: no-such-library name ;
439 M: no-such-library summary
440 drop "Library not found" ;
442 M: no-such-library compiler-error-type
445 : no-such-library ( name -- )
446 \ no-such-library boa
447 compiling-word get compiler-error ;
449 TUPLE: no-such-symbol name ;
451 M: no-such-symbol summary
452 drop "Symbol not found" ;
454 M: no-such-symbol compiler-error-type
457 : no-such-symbol ( name -- )
459 compiling-word get compiler-error ;
461 : check-dlsym ( symbols dll -- )
463 dupd [ dlsym ] curry contains?
464 [ drop ] [ no-such-symbol ] if
466 dll-path no-such-library drop
469 : stdcall-mangle ( symbol node -- symbol )
471 swap parameters>> parameter-sizes drop
472 number>string 3append ;
474 : alien-invoke-dlsym ( params -- symbols dll )
475 dup function>> dup pick stdcall-mangle 2array
476 swap library>> library dup [ dll>> ] when
479 M: #alien-invoke generate-node
481 dup alien-invoke-frame [
483 %prepare-alien-invoke
484 dup objects>registers
486 dup alien-invoke-dlsym %alien-invoke
493 M: #alien-indirect generate-node
495 dup alien-invoke-frame [
498 ! Save registers for GC
499 %prepare-alien-invoke
500 ! Save alien at top of stack to temporary storage
501 %prepare-alien-indirect
502 dup objects>registers
504 ! Call alien in temporary storage
512 : box-parameters ( params -- )
513 alien-parameters [ box-parameter ] each-parameter ;
515 : registers>objects ( node -- )
517 dup \ %save-param-reg move-parameters
518 "nest_stacks" f %alien-invoke
522 TUPLE: callback-context ;
524 : current-callback 2 getenv ;
526 : wait-to-return ( token -- )
527 dup current-callback eq? [
533 : do-callback ( quot token -- )
537 wait-to-return ; inline
539 : callback-return-quot ( ctype -- quot )
541 { [ dup "void" = ] [ drop [ ] ] }
542 { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
543 [ c-type c-type-unboxer-quot ]
546 : callback-prep-quot ( params -- quot )
547 parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
549 : wrap-callback-quot ( params -- quot )
551 [ callback-prep-quot ]
553 [ callback-return-quot ] tri 3append ,
554 [ callback-context new do-callback ] %
557 : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
559 : callback-unwind ( params -- n )
561 { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
562 { [ dup return>> large-struct? ] [ drop 4 ] }
566 : %callback-return ( params -- )
567 #! All the extra book-keeping for %unwind is only for x86.
568 #! On other platforms its an alias for %return.
570 [ %unnest-stacks ] [ %callback-value ] if-void
571 callback-unwind %unwind ;
573 : generate-callback ( params -- )
577 dup alien-stack-frame [
578 [ registers>objects ]
579 [ wrap-callback-quot %alien-callback ]
585 M: #alien-callback generate-node
587 params>> generate-callback iterate-next ;