basis/compiler/codegen/codegen.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces make math math.order math.parser sequences accessors
   4 kernel kernel.private layouts assocs words summary arrays
   5 combinators classes.algebra alien alien.c-types alien.structs
   6 alien.strings alien.arrays alien.complex sets libc call
   7 continuations.private fry cpu.architecture
   8 compiler.errors
   9 compiler.alien
  10 compiler.cfg
  11 compiler.cfg.instructions
  12 compiler.cfg.registers
  13 compiler.cfg.builder
  14 compiler.codegen.fixup
  15 compiler.utilities ;
  16 IN: compiler.codegen
  17
  18 GENERIC: generate-insn ( insn -- )
  19
  20 SYMBOL: registers
  21
  22 : register ( vreg -- operand )
  23     registers get at [ "Bad value" throw ] unless* ;
  24
  25 : ?register ( obj -- operand )
  26     dup vreg? [ register ] when ;
  27
  28 : generate-insns ( insns -- code )
  29     [
  30         [
  31             dup regs>> registers set
  32             generate-insn
  33         ] each
  34     ] { } make fixup ;
  35
  36 TUPLE: asm label code calls ;
  37
  38 SYMBOL: calls
  39
  40 : add-call ( word -- )
  41     #! Compile this word later.
  42     calls get push ;
  43
  44 SYMBOL: compiling-word
  45
  46 : compiled-stack-traces? ( -- ? ) 59 getenv ;
  47
  48 ! Mapping _label IDs to label instances
  49 SYMBOL: labels
  50
  51 : init-generator ( word -- )
  52     H{ } clone labels set
  53     V{ } clone literal-table set
  54     V{ } clone calls set
  55     compiling-word set
  56     compiled-stack-traces? compiling-word get f ? add-literal drop ;
  57
  58 : generate ( mr -- asm )
  59     [
  60         [ label>> ]
  61         [ word>> init-generator ]
  62         [ instructions>> generate-insns ] tri
  63         calls get
  64         asm boa
  65     ] with-scope ;
  66
  67 : lookup-label ( id -- label )
  68     labels get [ drop <label> ] cache ;
  69
  70 M: ##load-immediate generate-insn
  71     [ dst>> register ] [ val>> ] bi %load-immediate ;
  72
  73 M: ##load-reference generate-insn
  74     [ dst>> register ] [ obj>> ] bi %load-reference ;
  75
  76 M: ##peek generate-insn
  77     [ dst>> register ] [ loc>> ] bi %peek ;
  78
  79 M: ##replace generate-insn
  80     [ src>> register ] [ loc>> ] bi %replace ;
  81
  82 M: ##inc-d generate-insn n>> %inc-d ;
  83
  84 M: ##inc-r generate-insn n>> %inc-r ;
  85
  86 M: ##call generate-insn
  87     word>> dup sub-primitive>>
  88     [ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
  89
  90 M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
  91
  92 M: ##return generate-insn drop %return ;
  93
  94 M: ##dispatch-label generate-insn label>> %dispatch-label ;
  95
  96 M: ##dispatch generate-insn
  97     [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
  98
  99 : >slot< ( insn -- dst obj slot tag )
 100     {
 101         [ dst>> register ]
 102         [ obj>> register ]
 103         [ slot>> ?register ]
 104         [ tag>> ]
 105     } cleave ; inline
 106
 107 M: ##slot generate-insn
 108     [ >slot< ] [ temp>> register ] bi %slot ;
 109
 110 M: ##slot-imm generate-insn
 111     >slot< %slot-imm ;
 112
 113 : >set-slot< ( insn -- src obj slot tag )
 114     {
 115         [ src>> register ]
 116         [ obj>> register ]
 117         [ slot>> ?register ]
 118         [ tag>> ]
 119     } cleave ; inline
 120
 121 M: ##set-slot generate-insn
 122     [ >set-slot< ] [ temp>> register ] bi %set-slot ;
 123
 124 M: ##set-slot-imm generate-insn
 125     >set-slot< %set-slot-imm ;
 126
 127 M: ##string-nth generate-insn
 128     {
 129         [ dst>> register ]
 130         [ obj>> register ]
 131         [ index>> register ]
 132         [ temp>> register ]
 133     } cleave %string-nth ;
 134
 135 M: ##set-string-nth-fast generate-insn
 136     {
 137         [ src>> register ]
 138         [ obj>> register ]
 139         [ index>> register ]
 140         [ temp>> register ]
 141     } cleave %set-string-nth-fast ;
 142
 143 : dst/src ( insn -- dst src )
 144     [ dst>> register ] [ src>> register ] bi ; inline
 145
 146 : dst/src1/src2 ( insn -- dst src1 src2 )
 147     [ dst>> register ]
 148     [ src1>> register ]
 149     [ src2>> ?register ] tri ; inline
 150
 151 M: ##add     generate-insn dst/src1/src2 %add     ;
 152 M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
 153 M: ##sub     generate-insn dst/src1/src2 %sub     ;
 154 M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
 155 M: ##mul     generate-insn dst/src1/src2 %mul     ;
 156 M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
 157 M: ##and     generate-insn dst/src1/src2 %and     ;
 158 M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
 159 M: ##or      generate-insn dst/src1/src2 %or      ;
 160 M: ##or-imm  generate-insn dst/src1/src2 %or-imm  ;
 161 M: ##xor     generate-insn dst/src1/src2 %xor     ;
 162 M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
 163 M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
 164 M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
 165 M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
 166 M: ##not     generate-insn dst/src       %not     ;
 167 M: ##log2    generate-insn dst/src       %log2    ;
 168
 169 : src1/src2 ( insn -- src1 src2 )
 170     [ src1>> register ] [ src2>> register ] bi ; inline
 171
 172 : src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 )
 173     [ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline
 174
 175 M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
 176 M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
 177 M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
 178 M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
 179 M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
 180 M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ;
 181
 182 : dst/src/temp ( insn -- dst src temp )
 183     [ dst/src ] [ temp>> register ] bi ; inline
 184
 185 M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
 186 M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
 187
 188 M: ##add-float generate-insn dst/src1/src2 %add-float ;
 189 M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
 190 M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
 191 M: ##div-float generate-insn dst/src1/src2 %div-float ;
 192
 193 M: ##integer>float generate-insn dst/src %integer>float ;
 194 M: ##float>integer generate-insn dst/src %float>integer ;
 195
 196 M: ##copy             generate-insn dst/src %copy ;
 197 M: ##copy-float       generate-insn dst/src %copy-float ;
 198 M: ##unbox-float      generate-insn dst/src %unbox-float ;
 199 M: ##unbox-any-c-ptr  generate-insn dst/src/temp %unbox-any-c-ptr ;
 200 M: ##box-float        generate-insn dst/src/temp %box-float ;
 201 M: ##box-alien        generate-insn dst/src/temp %box-alien ;
 202
 203 M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
 204 M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
 205 M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
 206 M: ##alien-signed-1   generate-insn dst/src %alien-signed-1   ;
 207 M: ##alien-signed-2   generate-insn dst/src %alien-signed-2   ;
 208 M: ##alien-signed-4   generate-insn dst/src %alien-signed-4   ;
 209 M: ##alien-cell       generate-insn dst/src %alien-cell       ;
 210 M: ##alien-float      generate-insn dst/src %alien-float      ;
 211 M: ##alien-double     generate-insn dst/src %alien-double     ;
 212
 213 : >alien-setter< ( insn -- src value )
 214     [ src>> register ] [ value>> register ] bi ; inline
 215
 216 M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
 217 M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
 218 M: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
 219 M: ##set-alien-cell      generate-insn >alien-setter< %set-alien-cell      ;
 220 M: ##set-alien-float     generate-insn >alien-setter< %set-alien-float     ;
 221 M: ##set-alien-double    generate-insn >alien-setter< %set-alien-double    ;
 222
 223 M: ##allot generate-insn
 224     {
 225         [ dst>> register ]
 226         [ size>> ]
 227         [ class>> ]
 228         [ temp>> register ]
 229     } cleave
 230     %allot ;
 231
 232 M: ##write-barrier generate-insn
 233     [ src>> register ]
 234     [ card#>> register ]
 235     [ table>> register ]
 236     tri %write-barrier ;
 237
 238 M: _gc generate-insn drop %gc ;
 239
 240 M: ##loop-entry generate-insn drop %loop-entry ;
 241
 242 M: ##alien-global generate-insn
 243     [ dst>> register ] [ symbol>> ] [ library>> ] tri
 244     %alien-global ;
 245
 246 ! ##alien-invoke
 247 GENERIC: reg-size ( register-class -- n )
 248
 249 M: int-regs reg-size drop cell ;
 250
 251 M: single-float-regs reg-size drop 4 ;
 252
 253 M: double-float-regs reg-size drop 8 ;
 254
 255 M: stack-params reg-size drop "void*" heap-size ;
 256
 257 GENERIC: reg-class-variable ( register-class -- symbol )
 258
 259 M: reg-class reg-class-variable ;
 260
 261 M: float-regs reg-class-variable drop float-regs ;
 262
 263 GENERIC: inc-reg-class ( register-class -- )
 264
 265 : ?dummy-stack-params ( reg-class -- )
 266     dummy-stack-params? [ reg-size cell align stack-params +@ ] [ drop ] if ;
 267
 268 : ?dummy-int-params ( reg-class -- )
 269     dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
 270
 271 : ?dummy-fp-params ( reg-class -- )
 272     drop dummy-fp-params? [ float-regs inc ] when ;
 273
 274 M: int-regs inc-reg-class
 275     [ reg-class-variable inc ]
 276     [ ?dummy-stack-params ]
 277     [ ?dummy-fp-params ]
 278     tri ;
 279
 280 M: float-regs inc-reg-class
 281     [ reg-class-variable inc ]
 282     [ ?dummy-stack-params ]
 283     [ ?dummy-int-params ]
 284     tri ;
 285
 286 GENERIC: reg-class-full? ( class -- ? )
 287
 288 M: stack-params reg-class-full? drop t ;
 289
 290 M: object reg-class-full?
 291     [ reg-class-variable get ] [ param-regs length ] bi >= ;
 292
 293 : spill-param ( reg-class -- n reg-class )
 294     stack-params get
 295     [ reg-size cell align stack-params +@ ] dip
 296     stack-params ;
 297
 298 : fastcall-param ( reg-class -- n reg-class )
 299     [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
 300
 301 : alloc-parameter ( parameter -- reg reg-class )
 302     c-type-reg-class dup reg-class-full?
 303     [ spill-param ] [ fastcall-param ] if
 304     [ param-reg ] keep ;
 305
 306 : (flatten-int-type) ( size -- seq )
 307     cell /i "void*" c-type <repetition> ;
 308
 309 GENERIC: flatten-value-type ( type -- types )
 310
 311 M: object flatten-value-type 1array ;
 312
 313 M: struct-type flatten-value-type ( type -- types )
 314     stack-size cell align (flatten-int-type) ;
 315
 316 M: long-long-type flatten-value-type ( type -- types )
 317     stack-size cell align (flatten-int-type) ;
 318
 319 : flatten-value-types ( params -- params )
 320     #! Convert value type structs to consecutive void*s.
 321     [
 322         0 [
 323             c-type
 324             [ parameter-align (flatten-int-type) % ] keep
 325             [ stack-size cell align + ] keep
 326             flatten-value-type %
 327         ] reduce drop
 328     ] { } make ;
 329
 330 : each-parameter ( parameters quot -- )
 331     [ [ parameter-sizes nip ] keep ] dip 2each ; inline
 332
 333 : reverse-each-parameter ( parameters quot -- )
 334     [ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
 335
 336 : reset-freg-counts ( -- )
 337     { int-regs float-regs stack-params } [ 0 swap set ] each ;
 338
 339 : with-param-regs ( quot -- )
 340     #! In quot you can call alloc-parameter
 341     [ reset-freg-counts call ] with-scope ; inline
 342
 343 : move-parameters ( node word -- )
 344     #! Moves values from C stack to registers (if word is
 345     #! %load-param-reg) and registers to C stack (if word is
 346     #! %save-param-reg).
 347     [ alien-parameters flatten-value-types ]
 348     [ '[ alloc-parameter _ execute ] ]
 349     bi* each-parameter ; inline
 350
 351 : unbox-parameters ( offset node -- )
 352     parameters>> [
 353         %prepare-unbox [ over + ] dip unbox-parameter
 354     ] reverse-each-parameter drop ;
 355
 356 : prepare-box-struct ( node -- offset )
 357     #! Return offset on C stack where to store unboxed
 358     #! parameters. If the C function is returning a structure,
 359     #! the first parameter is an implicit target area pointer,
 360     #! so we need to use a different offset.
 361     return>> large-struct?
 362     [ %prepare-box-struct cell ] [ 0 ] if ;
 363
 364 : objects>registers ( params -- )
 365     #! Generate code for unboxing a list of C types, then
 366     #! generate code for moving these parameters to register on
 367     #! architectures where parameters are passed in registers.
 368     [
 369         [ prepare-box-struct ] keep
 370         [ unbox-parameters ] keep
 371         \ %load-param-reg move-parameters
 372     ] with-param-regs ;
 373
 374 : box-return* ( node -- )
 375     return>> [ ] [ box-return ] if-void ;
 376
 377 TUPLE: no-such-library name ;
 378
 379 M: no-such-library summary
 380     drop "Library not found" ;
 381
 382 M: no-such-library compiler-error-type
 383     drop +linkage+ ;
 384
 385 : no-such-library ( name -- )
 386     \ no-such-library boa
 387     compiling-word get compiler-error ;
 388
 389 TUPLE: no-such-symbol name ;
 390
 391 M: no-such-symbol summary
 392     drop "Symbol not found" ;
 393
 394 M: no-such-symbol compiler-error-type
 395     drop +linkage+ ;
 396
 397 : no-such-symbol ( name -- )
 398     \ no-such-symbol boa
 399     compiling-word get compiler-error ;
 400
 401 : check-dlsym ( symbols dll -- )
 402     dup dll-valid? [
 403         dupd '[ _ dlsym ] any?
 404         [ drop ] [ no-such-symbol ] if
 405     ] [
 406         dll-path no-such-library drop
 407     ] if ;
 408
 409 : stdcall-mangle ( symbol node -- symbol )
 410     "@"
 411     swap parameters>> parameter-sizes drop
 412     number>string 3append ;
 413
 414 : alien-invoke-dlsym ( params -- symbols dll )
 415     dup function>> dup pick stdcall-mangle 2array
 416     swap library>> library dup [ dll>> ] when
 417     2dup check-dlsym ;
 418
 419 M: ##alien-invoke generate-insn
 420     params>>
 421     ! Save registers for GC
 422     %prepare-alien-invoke
 423     ! Unbox parameters
 424     dup objects>registers
 425     %prepare-var-args
 426     ! Call function
 427     dup alien-invoke-dlsym %alien-invoke
 428     ! Box return value
 429     dup %cleanup
 430     box-return* ;
 431
 432 ! ##alien-indirect
 433 M: ##alien-indirect generate-insn
 434     params>>
 435     ! Save registers for GC
 436     %prepare-alien-invoke
 437     ! Save alien at top of stack to temporary storage
 438     %prepare-alien-indirect
 439     ! Unbox parameters
 440     dup objects>registers
 441     %prepare-var-args
 442     ! Call alien in temporary storage
 443     %alien-indirect
 444     ! Box return value
 445     dup %cleanup
 446     box-return* ;
 447
 448 ! ##alien-callback
 449 : box-parameters ( params -- )
 450     alien-parameters [ box-parameter ] each-parameter ;
 451
 452 : registers>objects ( node -- )
 453     [
 454         dup \ %save-param-reg move-parameters
 455         "nest_stacks" f %alien-invoke
 456         box-parameters
 457     ] with-param-regs ;
 458
 459 TUPLE: callback-context ;
 460
 461 : current-callback ( -- id ) 2 getenv ;
 462
 463 : wait-to-return ( token -- )
 464     dup current-callback eq? [
 465         drop
 466     ] [
 467         yield-hook get call( -- ) wait-to-return
 468     ] if ;
 469
 470 : do-callback ( quot token -- )
 471     init-catchstack
 472     dup 2 setenv
 473     slip
 474     wait-to-return ; inline
 475
 476 : callback-return-quot ( ctype -- quot )
 477     return>> {
 478         { [ dup "void" = ] [ drop [ ] ] }
 479         { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
 480         [ c-type c-type-unboxer-quot ]
 481     } cond ;
 482
 483 : callback-prep-quot ( params -- quot )
 484     parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
 485
 486 : wrap-callback-quot ( params -- quot )
 487     [
 488         [ callback-prep-quot ]
 489         [ quot>> ]
 490         [ callback-return-quot ] tri 3append ,
 491         [ callback-context new do-callback ] %
 492     ] [ ] make ;
 493
 494 : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
 495
 496 M: ##callback-return generate-insn
 497     #! All the extra book-keeping for %unwind is only for x86.
 498     #! On other platforms its an alias for %return.
 499     params>> %callback-return ;
 500
 501 M: ##alien-callback generate-insn
 502     params>>
 503     [ registers>objects ]
 504     [ wrap-callback-quot %alien-callback ]
 505     [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
 506     tri ;
 507
 508 M: _prologue generate-insn
 509     stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
 510
 511 M: _epilogue generate-insn
 512     stack-frame>> total-size>> %epilogue ;
 513
 514 M: _label generate-insn
 515     id>> lookup-label , ;
 516
 517 M: _branch generate-insn
 518     label>> lookup-label %jump-label ;
 519
 520 : >compare< ( insn -- dst temp cc src1 src2 )
 521     {
 522         [ dst>> register ]
 523         [ temp>> register ]
 524         [ cc>> ]
 525         [ src1>> register ]
 526         [ src2>> ?register ]
 527     } cleave ; inline
 528
 529 M: ##compare generate-insn >compare< %compare ;
 530 M: ##compare-imm generate-insn >compare< %compare-imm ;
 531 M: ##compare-float generate-insn >compare< %compare-float ;
 532
 533 : >binary-branch< ( insn -- label cc src1 src2 )
 534     {
 535         [ label>> lookup-label ]
 536         [ cc>> ]
 537         [ src1>> register ]
 538         [ src2>> ?register ]
 539     } cleave ; inline
 540
 541 M: _compare-branch generate-insn
 542     >binary-branch< %compare-branch ;
 543
 544 M: _compare-imm-branch generate-insn
 545     >binary-branch< %compare-imm-branch ;
 546
 547 M: _compare-float-branch generate-insn
 548     >binary-branch< %compare-float-branch ;
 549
 550 M: _spill generate-insn
 551     [ src>> ] [ n>> ] [ class>> ] tri {
 552         { int-regs [ %spill-integer ] }
 553         { double-float-regs [ %spill-float ] }
 554     } case ;
 555
 556 M: _reload generate-insn
 557     [ dst>> ] [ n>> ] [ class>> ] tri {
 558         { int-regs [ %reload-integer ] }
 559         { double-float-regs [ %reload-float ] }
 560     } case ;
 561
 562 M: _spill-counts generate-insn drop ;