basis/compiler/codegen/codegen.factor

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