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? [ struct-small-enough? not ] [ drop f ] if ;
 275
 276 : alien-parameters ( params -- seq )
 277     dup parameters>>
 278     swap return>> large-struct? [ "void*" prefix ] when ;
 279
 280 : alien-return ( params -- ctype )
 281     return>> dup large-struct? [ drop "void" ] when ;
 282
 283 : c-type-stack-align ( type -- align )
 284     dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
 285
 286 : parameter-align ( n type -- n delta )
 287     over >r c-type-stack-align align dup r> - ;
 288
 289 : parameter-sizes ( types -- total offsets )
 290     #! Compute stack frame locations.
 291     [
 292         0 [
 293             [ parameter-align drop dup , ] keep stack-size +
 294         ] reduce cell align
 295     ] { } make ;
 296
 297 : return-size ( ctype -- n )
 298     #! Amount of space we reserve for a return value.
 299     dup large-struct? [ heap-size ] [ drop 0 ] if ;
 300
 301 : alien-stack-frame ( params -- n )
 302     alien-parameters parameter-sizes drop ;
 303
 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
 308     + 2 cells + ;
 309
 310 : set-stack-frame ( n -- )
 311     dup [ frame-required ] when* \ stack-frame set ;
 312
 313 : with-stack-frame ( n quot -- )
 314     swap set-stack-frame
 315     call
 316     f set-stack-frame ; inline
 317
 318 GENERIC: reg-size ( register-class -- n )
 319
 320 M: int-regs reg-size drop cell ;
 321
 322 M: single-float-regs reg-size drop 4 ;
 323
 324 M: double-float-regs reg-size drop 8 ;
 325
 326 M: stack-params reg-size drop "void*" heap-size ;
 327
 328 GENERIC: reg-class-variable ( register-class -- symbol )
 329
 330 M: reg-class reg-class-variable ;
 331
 332 M: float-regs reg-class-variable drop float-regs ;
 333
 334 M: stack-params reg-class-variable drop stack-params ;
 335
 336 GENERIC: inc-reg-class ( register-class -- )
 337
 338 M: reg-class inc-reg-class
 339     dup reg-class-variable inc
 340     fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
 341
 342 M: float-regs inc-reg-class
 343     dup call-next-method
 344     fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
 345
 346 : reg-class-full? ( class -- ? )
 347     [ reg-class-variable get ] [ param-regs length ] bi >= ;
 348
 349 : spill-param ( reg-class -- n reg-class )
 350     stack-params get
 351     >r reg-size stack-params +@ r>
 352     stack-params ;
 353
 354 : fastcall-param ( reg-class -- n reg-class )
 355     [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
 356
 357 : alloc-parameter ( parameter -- reg reg-class )
 358     c-type-reg-class dup reg-class-full?
 359     [ spill-param ] [ fastcall-param ] if
 360     [ param-reg ] keep ;
 361
 362 : (flatten-int-type) ( size -- types )
 363     cell /i "void*" c-type <repetition> ;
 364
 365 GENERIC: flatten-value-type ( type -- types )
 366
 367 M: object flatten-value-type 1array ;
 368
 369 M: struct-type flatten-value-type ( type -- types )
 370     stack-size cell align (flatten-int-type) ;
 371
 372 M: long-long-type flatten-value-type ( type -- types )
 373     stack-size cell align (flatten-int-type) ;
 374
 375 : flatten-value-types ( params -- params )
 376     #! Convert value type structs to consecutive void*s.
 377     [
 378         0 [
 379             c-type
 380             [ parameter-align (flatten-int-type) % ] keep
 381             [ stack-size cell align + ] keep
 382             flatten-value-type %
 383         ] reduce drop
 384     ] { } make ;
 385
 386 : each-parameter ( parameters quot -- )
 387     >r [ parameter-sizes nip ] keep r> 2each ; inline
 388
 389 : reverse-each-parameter ( parameters quot -- )
 390     >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
 391
 392 : reset-freg-counts ( -- )
 393     { int-regs float-regs stack-params } [ 0 swap set ] each ;
 394
 395 : with-param-regs ( quot -- )
 396     #! In quot you can call alloc-parameter
 397     [ reset-freg-counts call ] with-scope ; inline
 398
 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
 402     #! %save-param-reg).
 403     >r
 404     alien-parameters
 405     flatten-value-types
 406     r> [ >r alloc-parameter r> execute ] curry each-parameter ;
 407     inline
 408
 409 : unbox-parameters ( offset node -- )
 410     parameters>> [
 411         %prepare-unbox >r over + r> unbox-parameter
 412     ] reverse-each-parameter drop ;
 413
 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 ;
 421
 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.
 426     [
 427         [ prepare-box-struct ] keep
 428         [ unbox-parameters ] keep
 429         \ %load-param-reg move-parameters
 430     ] with-param-regs ;
 431
 432 : box-return* ( node -- )
 433     return>> [ ] [ box-return ] if-void ;
 434
 435 TUPLE: no-such-library name ;
 436
 437 M: no-such-library summary
 438     drop "Library not found" ;
 439
 440 M: no-such-library compiler-error-type
 441     drop +linkage+ ;
 442
 443 : no-such-library ( name -- )
 444     \ no-such-library boa
 445     compiling-word get compiler-error ;
 446
 447 TUPLE: no-such-symbol name ;
 448
 449 M: no-such-symbol summary
 450     drop "Symbol not found" ;
 451
 452 M: no-such-symbol compiler-error-type
 453     drop +linkage+ ;
 454
 455 : no-such-symbol ( name -- )
 456     \ no-such-symbol boa
 457     compiling-word get compiler-error ;
 458
 459 : check-dlsym ( symbols dll -- )
 460     dup dll-valid? [
 461         dupd [ dlsym ] curry contains?
 462         [ drop ] [ no-such-symbol ] if
 463     ] [
 464         dll-path no-such-library drop
 465     ] if ;
 466
 467 : stdcall-mangle ( symbol node -- symbol )
 468     "@"
 469     swap parameters>> parameter-sizes drop
 470     number>string 3append ;
 471
 472 : alien-invoke-dlsym ( params -- symbols dll )
 473     dup function>> dup pick stdcall-mangle 2array
 474     swap library>> library dup [ dll>> ] when
 475     2dup check-dlsym ;
 476
 477 M: #alien-invoke generate-node
 478     params>>
 479     dup alien-invoke-frame [
 480         end-basic-block
 481         %prepare-alien-invoke
 482         dup objects>registers
 483         %prepare-var-args
 484         dup alien-invoke-dlsym %alien-invoke
 485         dup %cleanup
 486         box-return*
 487         iterate-next
 488     ] with-stack-frame ;
 489
 490 ! #alien-indirect
 491 M: #alien-indirect generate-node
 492     params>>
 493     dup alien-invoke-frame [
 494         ! Flush registers
 495         end-basic-block
 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
 501         %prepare-var-args
 502         ! Call alien in temporary storage
 503         %alien-indirect
 504         dup %cleanup
 505         box-return*
 506         iterate-next
 507     ] with-stack-frame ;
 508
 509 ! #alien-callback
 510 : box-parameters ( params -- )
 511     alien-parameters [ box-parameter ] each-parameter ;
 512
 513 : registers>objects ( node -- )
 514     [
 515         dup \ %save-param-reg move-parameters
 516         "nest_stacks" f %alien-invoke
 517         box-parameters
 518     ] with-param-regs ;
 519
 520 TUPLE: callback-context ;
 521
 522 : current-callback 2 getenv ;
 523
 524 : wait-to-return ( token -- )
 525     dup current-callback eq? [
 526         drop
 527     ] [
 528         yield wait-to-return
 529     ] if ;
 530
 531 : do-callback ( quot token -- )
 532     init-catchstack
 533     dup 2 setenv
 534     slip
 535     wait-to-return ; inline
 536
 537 : callback-return-quot ( ctype -- quot )
 538     return>> {
 539         { [ dup "void" = ] [ drop [ ] ] }
 540         { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
 541         [ c-type c-type-unboxer-quot ]
 542     } cond ;
 543
 544 : callback-prep-quot ( params -- quot )
 545     parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
 546
 547 : wrap-callback-quot ( params -- quot )
 548     [
 549         [ callback-prep-quot ]
 550         [ quot>> ]
 551         [ callback-return-quot ] tri 3append ,
 552         [ callback-context new do-callback ] %
 553     ] [ ] make ;
 554
 555 : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
 556
 557 : callback-unwind ( params -- n )
 558     {
 559         { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
 560         { [ dup return>> large-struct? ] [ drop 4 ] }
 561         [ drop 0 ]
 562     } cond ;
 563
 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.
 567     dup alien-return
 568     [ %unnest-stacks ] [ %callback-value ] if-void
 569     callback-unwind %unwind ;
 570
 571 : generate-callback ( params -- )
 572     dup xt>> dup [
 573         init-templates
 574         %prologue-later
 575         dup alien-stack-frame [
 576             [ registers>objects ]
 577             [ wrap-callback-quot %alien-callback ]
 578             [ %callback-return ]
 579             tri
 580         ] with-stack-frame
 581     ] with-generator ;
 582
 583 M: #alien-callback generate-node
 584     end-basic-block
 585     params>> generate-callback iterate-next ;