basis/compiler/generator/generator.factor

   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
  14
  15 SYMBOL: compile-queue
  16 SYMBOL: compiled
  17
  18 : queue-compile ( word -- )
  19     {
  20         { [ dup "forgotten" word-prop ] [ ] }
  21         { [ dup compiled get key? ] [ ] }
  22         { [ dup inlined-block? ] [ ] }
  23         { [ dup primitive? ] [ ] }
  24         [ dup compile-queue get push-front ]
  25     } cond drop ;
  26
  27 : maybe-compile ( word -- )
  28     dup compiled>> [ drop ] [ queue-compile ] if ;
  29
  30 SYMBOL: compiling-word
  31
  32 SYMBOL: compiling-label
  33
  34 SYMBOL: compiling-loops
  35
  36 ! Label of current word, after prologue, makes recursion faster
  37 SYMBOL: current-label-start
  38
  39 : compiled-stack-traces? ( -- ? ) 59 getenv ;
  40
  41 : begin-compiling ( word label -- )
  42     H{ } clone compiling-loops set
  43     compiling-label set
  44     compiling-word set
  45     compiled-stack-traces?
  46     compiling-word get f ?
  47     1vector literal-table set
  48     f compiling-label get compiled get set-at ;
  49
  50 : save-machine-code ( literals relocation labels code -- )
  51     4array compiling-label get compiled get set-at ;
  52
  53 : with-generator ( nodes word label quot -- )
  54     [
  55         >r begin-compiling r>
  56         { } make fixup
  57         save-machine-code
  58     ] with-scope ; inline
  59
  60 GENERIC: generate-node ( node -- next )
  61
  62 : generate-nodes ( nodes -- )
  63     [ current-node generate-node ] iterate-nodes
  64     end-basic-block ;
  65
  66 : init-generate-nodes ( -- )
  67     init-templates
  68     %save-word-xt
  69     %prologue-later
  70     current-label-start define-label
  71     current-label-start resolve-label ;
  72
  73 : generate ( nodes word label -- )
  74     [
  75         init-generate-nodes
  76         [ generate-nodes ] with-node-iterator
  77     ] with-generator ;
  78
  79 : intrinsics ( #call -- quot )
  80     word>> "intrinsics" word-prop ;
  81
  82 : if-intrinsics ( #call -- quot )
  83     word>> "if-intrinsics" word-prop ;
  84
  85 ! node
  86 M: node generate-node drop iterate-next ;
  87
  88 : %jump ( word -- )
  89     dup compiling-label get eq?
  90     [ drop current-label-start get ] [ %epilogue-later ] if
  91     %jump-label ;
  92
  93 : generate-call ( label -- next )
  94     dup maybe-compile
  95     end-basic-block
  96     dup compiling-loops get at [
  97         %jump-label f
  98     ] [
  99         tail-call? [
 100             %jump f
 101         ] [
 102             0 frame-required
 103             %call
 104             iterate-next
 105         ] if
 106     ] ?if ;
 107
 108 ! #recursive
 109 : compile-recursive ( node -- next )
 110     dup label>> id>> generate-call >r
 111     [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
 112     r> ;
 113
 114 : compiling-loop ( word -- )
 115     <label> dup resolve-label swap compiling-loops get set-at ;
 116
 117 : compile-loop ( node -- next )
 118     end-basic-block
 119     [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
 120     iterate-next ;
 121
 122 M: #recursive generate-node
 123     dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
 124
 125 ! #if
 126 : end-false-branch ( label -- )
 127     tail-call? [ %return drop ] [ %jump-label ] if ;
 128
 129 : generate-branch ( nodes -- )
 130     [ copy-templates generate-nodes ] with-scope ;
 131
 132 : generate-if ( node label -- next )
 133     <label> [
 134         >r >r children>> first2 swap generate-branch
 135         r> r> end-false-branch resolve-label
 136         generate-branch
 137         init-templates
 138     ] keep resolve-label iterate-next ;
 139
 140 M: #if generate-node
 141     [ <label> dup %jump-f ]
 142     H{ { +input+ { { f "flag" } } } }
 143     with-template
 144     generate-if ;
 145
 146 ! #dispatch
 147 : dispatch-branch ( nodes word -- label )
 148     gensym [
 149         [
 150             copy-templates
 151             %save-dispatch-xt
 152             %prologue-later
 153             [ generate-nodes ] with-node-iterator
 154             %return
 155         ] with-generator
 156     ] keep ;
 157
 158 : dispatch-branches ( node -- )
 159     children>> [
 160         compiling-word get dispatch-branch
 161         %dispatch-label
 162     ] each ;
 163
 164 : generate-dispatch ( node -- )
 165     %dispatch dispatch-branches init-templates ;
 166
 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
 171     tail-call? [
 172         generate-dispatch iterate-next
 173     ] [
 174         compiling-word get gensym [
 175             [
 176                 init-generate-nodes
 177                 generate-dispatch
 178             ] with-generator
 179         ] keep generate-call
 180     ] if ;
 181
 182 ! #call
 183 : define-intrinsics ( word intrinsics -- )
 184     "intrinsics" set-word-prop ;
 185
 186 : define-intrinsic ( word quot assoc -- )
 187     2array 1array define-intrinsics ;
 188
 189 : define-if>branch-intrinsics ( word intrinsics -- )
 190     "if-intrinsics" set-word-prop ;
 191
 192 : if>boolean-intrinsic ( quot -- )
 193     "false" define-label
 194     "end" define-label
 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
 200     "end" resolve-label
 201     "if-scratch" get phantom-push ; inline
 202
 203 : define-if>boolean-intrinsics ( word intrinsics -- )
 204     [
 205         >r [ if>boolean-intrinsic ] curry r>
 206         { { f "if-scratch" } } +scratch+ associate assoc-union
 207     ] assoc-map "intrinsics" set-word-prop ;
 208
 209 : define-if-intrinsics ( word intrinsics -- )
 210     [ +input+ associate ] assoc-map
 211     2dup define-if>branch-intrinsics
 212     define-if>boolean-intrinsics ;
 213
 214 : define-if-intrinsic ( word quot inputs -- )
 215     2array 1array define-if-intrinsics ;
 216
 217 : do-if-intrinsic ( pair -- next )
 218     <label> [ swap do-template skip-next ] keep generate-if ;
 219
 220 : find-intrinsic ( #call -- pair/f )
 221     intrinsics find-template ;
 222
 223 : find-if-intrinsic ( #call -- pair/f )
 224     node@ {
 225         { [ dup length 2 < ] [ 2drop f ] }
 226         { [ dup second #if? ] [ drop if-intrinsics find-template ] }
 227         [ 2drop f ]
 228     } cond ;
 229
 230 M: #call generate-node
 231     dup node-input-infos [ class>> ] map set-operand-classes
 232     dup find-if-intrinsic [
 233         do-if-intrinsic
 234     ] [
 235         dup find-intrinsic [
 236             do-template iterate-next
 237         ] [
 238             word>> generate-call
 239         ] ?if
 240     ] ?if ;
 241
 242 ! #call-recursive
 243 M: #call-recursive generate-node label>> id>> generate-call ;
 244
 245 ! #push
 246 M: #push generate-node
 247     literal>> <constant> phantom-push iterate-next ;
 248
 249 ! #shuffle
 250 M: #shuffle generate-node
 251     shuffle-effect phantom-shuffle iterate-next ;
 252
 253 M: #>r generate-node
 254     [ in-d>> length ] [ out-r>> empty? ] bi
 255     [ phantom-drop ] [ phantom->r ] if
 256     iterate-next ;
 257
 258 M: #r> generate-node
 259     [ in-r>> length ] [ out-d>> empty? ] bi
 260     [ phantom-rdrop ] [ phantom-r> ] if
 261     iterate-next ;
 262
 263 ! #return
 264 M: #return generate-node
 265     drop end-basic-block %return f ;
 266
 267 M: #return-recursive generate-node
 268     end-basic-block
 269     label>> id>> compiling-loops get key?
 270     [ %return ] unless f ;
 271
 272 ! #alien-invoke
 273 : large-struct? ( ctype -- ? )
 274     dup c-struct? [
 275         heap-size struct-small-enough? not
 276     ] [ drop f ] if ;
 277
 278 : alien-parameters ( params -- seq )
 279     dup parameters>>
 280     swap return>> large-struct? [ "void*" prefix ] when ;
 281
 282 : alien-return ( params -- ctype )
 283     return>> dup large-struct? [ drop "void" ] when ;
 284
 285 : c-type-stack-align ( type -- align )
 286     dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
 287
 288 : parameter-align ( n type -- n delta )
 289     over >r c-type-stack-align align dup r> - ;
 290
 291 : parameter-sizes ( types -- total offsets )
 292     #! Compute stack frame locations.
 293     [
 294         0 [
 295             [ parameter-align drop dup , ] keep stack-size +
 296         ] reduce cell align
 297     ] { } make ;
 298
 299 : return-size ( ctype -- n )
 300     #! Amount of space we reserve for a return value.
 301     dup large-struct? [ heap-size ] [ drop 0 ] if ;
 302
 303 : alien-stack-frame ( params -- n )
 304     alien-parameters parameter-sizes drop ;
 305
 306 : alien-invoke-frame ( params -- n )
 307     #! One cell is temporary storage, temp@
 308     dup return>> return-size
 309     swap alien-stack-frame +
 310     cell + ;
 311
 312 : set-stack-frame ( n -- )
 313     dup [ frame-required ] when* \ stack-frame set ;
 314
 315 : with-stack-frame ( n quot -- )
 316     swap set-stack-frame
 317     call
 318     f set-stack-frame ; inline
 319
 320 GENERIC: reg-size ( register-class -- n )
 321
 322 M: int-regs reg-size drop cell ;
 323
 324 M: single-float-regs reg-size drop 4 ;
 325
 326 M: double-float-regs reg-size drop 8 ;
 327
 328 M: stack-params reg-size drop "void*" heap-size ;
 329
 330 GENERIC: reg-class-variable ( register-class -- symbol )
 331
 332 M: reg-class reg-class-variable ;
 333
 334 M: float-regs reg-class-variable drop float-regs ;
 335
 336 M: stack-params reg-class-variable drop stack-params ;
 337
 338 GENERIC: inc-reg-class ( register-class -- )
 339
 340 M: reg-class inc-reg-class
 341     dup reg-class-variable inc
 342     fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
 343
 344 M: float-regs inc-reg-class
 345     dup call-next-method
 346     fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
 347
 348 : reg-class-full? ( class -- ? )
 349     [ reg-class-variable get ] [ param-regs length ] bi >= ;
 350
 351 : spill-param ( reg-class -- n reg-class )
 352     stack-params get
 353     >r reg-size stack-params +@ r>
 354     stack-params ;
 355
 356 : fastcall-param ( reg-class -- n reg-class )
 357     [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
 358
 359 : alloc-parameter ( parameter -- reg reg-class )
 360     c-type-reg-class dup reg-class-full?
 361     [ spill-param ] [ fastcall-param ] if
 362     [ param-reg ] keep ;
 363
 364 : (flatten-int-type) ( size -- )
 365     cell /i "void*" c-type <repetition> % ;
 366
 367 GENERIC: flatten-value-type ( type -- )
 368
 369 M: object flatten-value-type , ;
 370
 371 M: struct-type flatten-value-type ( type -- )
 372     stack-size cell align (flatten-int-type) ;
 373
 374 M: long-long-type flatten-value-type ( type -- )
 375     stack-size cell align (flatten-int-type) ;
 376
 377 : flatten-value-types ( params -- params )
 378     #! Convert value type structs to consecutive void*s.
 379     [
 380         0 [
 381             c-type
 382             [ parameter-align (flatten-int-type) ] keep
 383             [ stack-size cell align + ] keep
 384             flatten-value-type
 385         ] reduce drop
 386     ] { } make ;
 387
 388 : each-parameter ( parameters quot -- )
 389     >r [ parameter-sizes nip ] keep r> 2each ; inline
 390
 391 : reverse-each-parameter ( parameters quot -- )
 392     >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
 393
 394 : reset-freg-counts ( -- )
 395     { int-regs float-regs stack-params } [ 0 swap set ] each ;
 396
 397 : with-param-regs ( quot -- )
 398     #! In quot you can call alloc-parameter
 399     [ reset-freg-counts call ] with-scope ; inline
 400
 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
 404     #! %save-param-reg).
 405     >r
 406     alien-parameters
 407     flatten-value-types
 408     r> [ >r alloc-parameter r> execute ] curry each-parameter ;
 409     inline
 410
 411 : unbox-parameters ( offset node -- )
 412     parameters>> [
 413         %prepare-unbox >r over + r> unbox-parameter
 414     ] reverse-each-parameter drop ;
 415
 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 ;
 423
 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.
 428     [
 429         [ prepare-box-struct ] keep
 430         [ unbox-parameters ] keep
 431         \ %load-param-reg move-parameters
 432     ] with-param-regs ;
 433
 434 : box-return* ( node -- )
 435     return>> [ ] [ box-return ] if-void ;
 436
 437 TUPLE: no-such-library name ;
 438
 439 M: no-such-library summary
 440     drop "Library not found" ;
 441
 442 M: no-such-library compiler-error-type
 443     drop +linkage+ ;
 444
 445 : no-such-library ( name -- )
 446     \ no-such-library boa
 447     compiling-word get compiler-error ;
 448
 449 TUPLE: no-such-symbol name ;
 450
 451 M: no-such-symbol summary
 452     drop "Symbol not found" ;
 453
 454 M: no-such-symbol compiler-error-type
 455     drop +linkage+ ;
 456
 457 : no-such-symbol ( name -- )
 458     \ no-such-symbol boa
 459     compiling-word get compiler-error ;
 460
 461 : check-dlsym ( symbols dll -- )
 462     dup dll-valid? [
 463         dupd [ dlsym ] curry contains?
 464         [ drop ] [ no-such-symbol ] if
 465     ] [
 466         dll-path no-such-library drop
 467     ] if ;
 468
 469 : stdcall-mangle ( symbol node -- symbol )
 470     "@"
 471     swap parameters>> parameter-sizes drop
 472     number>string 3append ;
 473
 474 : alien-invoke-dlsym ( params -- symbols dll )
 475     dup function>> dup pick stdcall-mangle 2array
 476     swap library>> library dup [ dll>> ] when
 477     2dup check-dlsym ;
 478
 479 M: #alien-invoke generate-node
 480     params>>
 481     dup alien-invoke-frame [
 482         end-basic-block
 483         %prepare-alien-invoke
 484         dup objects>registers
 485         %prepare-var-args
 486         dup alien-invoke-dlsym %alien-invoke
 487         dup %cleanup
 488         box-return*
 489         iterate-next
 490     ] with-stack-frame ;
 491
 492 ! #alien-indirect
 493 M: #alien-indirect generate-node
 494     params>>
 495     dup alien-invoke-frame [
 496         ! Flush registers
 497         end-basic-block
 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
 503         %prepare-var-args
 504         ! Call alien in temporary storage
 505         %alien-indirect
 506         dup %cleanup
 507         box-return*
 508         iterate-next
 509     ] with-stack-frame ;
 510
 511 ! #alien-callback
 512 : box-parameters ( params -- )
 513     alien-parameters [ box-parameter ] each-parameter ;
 514
 515 : registers>objects ( node -- )
 516     [
 517         dup \ %save-param-reg move-parameters
 518         "nest_stacks" f %alien-invoke
 519         box-parameters
 520     ] with-param-regs ;
 521
 522 TUPLE: callback-context ;
 523
 524 : current-callback 2 getenv ;
 525
 526 : wait-to-return ( token -- )
 527     dup current-callback eq? [
 528         drop
 529     ] [
 530         yield wait-to-return
 531     ] if ;
 532
 533 : do-callback ( quot token -- )
 534     init-catchstack
 535     dup 2 setenv
 536     slip
 537     wait-to-return ; inline
 538
 539 : callback-return-quot ( ctype -- quot )
 540     return>> {
 541         { [ dup "void" = ] [ drop [ ] ] }
 542         { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
 543         [ c-type c-type-unboxer-quot ]
 544     } cond ;
 545
 546 : callback-prep-quot ( params -- quot )
 547     parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
 548
 549 : wrap-callback-quot ( params -- quot )
 550     [
 551         [ callback-prep-quot ]
 552         [ quot>> ]
 553         [ callback-return-quot ] tri 3append ,
 554         [ callback-context new do-callback ] %
 555     ] [ ] make ;
 556
 557 : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
 558
 559 : callback-unwind ( params -- n )
 560     {
 561         { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
 562         { [ dup return>> large-struct? ] [ drop 4 ] }
 563         [ drop 0 ]
 564     } cond ;
 565
 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.
 569     dup alien-return
 570     [ %unnest-stacks ] [ %callback-value ] if-void
 571     callback-unwind %unwind ;
 572
 573 : generate-callback ( params -- )
 574     dup xt>> dup [
 575         init-templates
 576         %prologue-later
 577         dup alien-stack-frame [
 578             [ registers>objects ]
 579             [ wrap-callback-quot %alien-callback ]
 580             [ %callback-return ]
 581             tri
 582         ] with-stack-frame
 583     ] with-generator ;
 584
 585 M: #alien-callback generate-node
 586     end-basic-block
 587     params>> generate-callback iterate-next ;