core/alien/compiler/compiler.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays generator generator.registers generator.fixup
   4 hashtables kernel math namespaces sequences words
   5 inference.state inference.backend inference.dataflow system
   6 math.parser classes alien.arrays alien.c-types alien.strings
   7 alien.structs alien.syntax cpu.architecture alien summary
   8 quotations assocs kernel.private threads continuations.private
   9 libc combinators compiler.errors continuations layouts accessors
  10 init sets ;
  11 IN: alien.compiler
  12
  13 TUPLE: #alien-node < node return parameters abi ;
  14
  15 TUPLE: #alien-callback < #alien-node quot xt ;
  16
  17 TUPLE: #alien-indirect < #alien-node ;
  18
  19 TUPLE: #alien-invoke < #alien-node library function ;
  20
  21 : large-struct? ( ctype -- ? )
  22     dup c-struct? [
  23         heap-size struct-small-enough? not
  24     ] [ drop f ] if ;
  25
  26 : alien-node-parameters* ( node -- seq )
  27     dup parameters>>
  28     swap return>> large-struct? [ "void*" prefix ] when ;
  29
  30 : alien-node-return* ( node -- ctype )
  31     return>> dup large-struct? [ drop "void" ] when ;
  32
  33 : c-type-stack-align ( type -- align )
  34     dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
  35
  36 : parameter-align ( n type -- n delta )
  37     over >r c-type-stack-align align dup r> - ;
  38
  39 : parameter-sizes ( types -- total offsets )
  40     #! Compute stack frame locations.
  41     [
  42         0 [
  43             [ parameter-align drop dup , ] keep stack-size +
  44         ] reduce cell align
  45     ] { } make ;
  46
  47 : return-size ( ctype -- n )
  48     #! Amount of space we reserve for a return value.
  49     dup large-struct? [ heap-size ] [ drop 0 ] if ;
  50
  51 : alien-stack-frame ( node -- n )
  52     alien-node-parameters* parameter-sizes drop ;
  53
  54 : alien-invoke-frame ( node -- n )
  55     #! One cell is temporary storage, temp@
  56     dup return>> return-size
  57     swap alien-stack-frame +
  58     cell + ;
  59
  60 : set-stack-frame ( n -- )
  61     dup [ frame-required ] when* \ stack-frame set ;
  62
  63 : with-stack-frame ( n quot -- )
  64     swap set-stack-frame
  65     call
  66     f set-stack-frame ; inline
  67
  68 GENERIC: reg-size ( register-class -- n )
  69
  70 M: int-regs reg-size drop cell ;
  71
  72 M: single-float-regs reg-size drop 4 ;
  73
  74 M: double-float-regs reg-size drop 8 ;
  75
  76 GENERIC: reg-class-variable ( register-class -- symbol )
  77
  78 M: reg-class reg-class-variable ;
  79
  80 M: float-regs reg-class-variable drop float-regs ;
  81
  82 GENERIC: inc-reg-class ( register-class -- )
  83
  84 M: reg-class inc-reg-class
  85     dup reg-class-variable inc
  86     fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
  87
  88 M: float-regs inc-reg-class
  89     dup call-next-method
  90     fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
  91
  92 : reg-class-full? ( class -- ? )
  93     [ reg-class-variable get ] [ param-regs length ] bi >= ;
  94
  95 : spill-param ( reg-class -- n reg-class )
  96     stack-params get
  97     >r reg-size stack-params +@ r>
  98     stack-params ;
  99
 100 : fastcall-param ( reg-class -- n reg-class )
 101     [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
 102
 103 : alloc-parameter ( parameter -- reg reg-class )
 104     c-type-reg-class dup reg-class-full?
 105     [ spill-param ] [ fastcall-param ] if
 106     [ param-reg ] keep ;
 107
 108 : (flatten-int-type) ( size -- )
 109     cell /i "void*" c-type <repetition> % ;
 110
 111 GENERIC: flatten-value-type ( type -- )
 112
 113 M: object flatten-value-type , ;
 114
 115 M: struct-type flatten-value-type ( type -- )
 116     stack-size cell align (flatten-int-type) ;
 117
 118 M: long-long-type flatten-value-type ( type -- )
 119     stack-size cell align (flatten-int-type) ;
 120
 121 : flatten-value-types ( params -- params )
 122     #! Convert value type structs to consecutive void*s.
 123     [
 124         0 [
 125             c-type
 126             [ parameter-align (flatten-int-type) ] keep
 127             [ stack-size cell align + ] keep
 128             flatten-value-type
 129         ] reduce drop
 130     ] { } make ;
 131
 132 : each-parameter ( parameters quot -- )
 133     >r [ parameter-sizes nip ] keep r> 2each ; inline
 134
 135 : reverse-each-parameter ( parameters quot -- )
 136     >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
 137
 138 : reset-freg-counts ( -- )
 139     { int-regs float-regs stack-params } [ 0 swap set ] each ;
 140
 141 : with-param-regs ( quot -- )
 142     #! In quot you can call alloc-parameter
 143     [ reset-freg-counts call ] with-scope ; inline
 144
 145 : move-parameters ( node word -- )
 146     #! Moves values from C stack to registers (if word is
 147     #! %load-param-reg) and registers to C stack (if word is
 148     #! %save-param-reg).
 149     >r
 150     alien-node-parameters*
 151     flatten-value-types
 152     r> [ >r alloc-parameter r> execute ] curry each-parameter ;
 153     inline
 154
 155 : if-void ( type true false -- )
 156     pick "void" = [ drop nip call ] [ nip call ] if ; inline
 157
 158 : alien-invoke-stack ( node extra -- )
 159     over parameters>> length + dup reify-curries
 160     over consume-values
 161     dup return>> "void" = 0 1 ?
 162     swap produce-values ;
 163
 164 : param-prep-quot ( node -- quot )
 165     parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
 166
 167 : unbox-parameters ( offset node -- )
 168     parameters>> [
 169         %prepare-unbox >r over + r> unbox-parameter
 170     ] reverse-each-parameter drop ;
 171
 172 : prepare-box-struct ( node -- offset )
 173     #! Return offset on C stack where to store unboxed
 174     #! parameters. If the C function is returning a structure,
 175     #! the first parameter is an implicit target area pointer,
 176     #! so we need to use a different offset.
 177     return>> dup large-struct?
 178     [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
 179
 180 : objects>registers ( node -- )
 181     #! Generate code for unboxing a list of C types, then
 182     #! generate code for moving these parameters to register on
 183     #! architectures where parameters are passed in registers.
 184     [
 185         [ prepare-box-struct ] keep
 186         [ unbox-parameters ] keep
 187         \ %load-param-reg move-parameters
 188     ] with-param-regs ;
 189
 190 : box-return* ( node -- )
 191     return>> [ ] [ box-return ] if-void ;
 192
 193 : callback-prep-quot ( node -- quot )
 194     parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
 195
 196 : return-prep-quot ( node -- quot )
 197     return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
 198
 199 M: alien-invoke-error summary
 200     drop
 201     "Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
 202
 203 : pop-parameters ( -- seq )
 204     pop-literal nip [ expand-constants ] map ;
 205
 206 : stdcall-mangle ( symbol node -- symbol )
 207     "@"
 208     swap parameters>> parameter-sizes drop
 209     number>string 3append ;
 210
 211 TUPLE: no-such-library name ;
 212
 213 M: no-such-library summary
 214     drop "Library not found" ;
 215
 216 M: no-such-library compiler-error-type
 217     drop +linkage+ ;
 218
 219 : no-such-library ( name -- )
 220     \ no-such-library boa
 221     compiling-word get compiler-error ;
 222
 223 TUPLE: no-such-symbol name ;
 224
 225 M: no-such-symbol summary
 226     drop "Symbol not found" ;
 227
 228 M: no-such-symbol compiler-error-type
 229     drop +linkage+ ;
 230
 231 : no-such-symbol ( name -- )
 232     \ no-such-symbol boa
 233     compiling-word get compiler-error ;
 234
 235 : check-dlsym ( symbols dll -- )
 236     dup dll-valid? [
 237         dupd [ dlsym ] curry contains?
 238         [ drop ] [ no-such-symbol ] if
 239     ] [
 240         dll-path no-such-library drop
 241     ] if ;
 242
 243 : alien-invoke-dlsym ( node -- symbols dll )
 244     dup function>> dup pick stdcall-mangle 2array
 245     swap library>> library dup [ dll>> ] when
 246     2dup check-dlsym ;
 247
 248 \ alien-invoke [
 249     ! Four literals
 250     4 ensure-values
 251     #alien-invoke new
 252     ! Compile-time parameters
 253     pop-parameters >>parameters
 254     pop-literal nip >>function
 255     pop-literal nip >>library
 256     pop-literal nip >>return
 257     ! Quotation which coerces parameters to required types
 258     dup param-prep-quot recursive-state get infer-quot
 259     ! Set ABI
 260     dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
 261     ! Add node to IR
 262     dup node,
 263     ! Magic #: consume exactly the number of inputs
 264     dup 0 alien-invoke-stack
 265     ! Quotation which coerces return value to required type
 266     return-prep-quot recursive-state get infer-quot
 267 ] "infer" set-word-prop
 268
 269 M: #alien-invoke generate-node
 270     dup alien-invoke-frame [
 271         end-basic-block
 272         %prepare-alien-invoke
 273         dup objects>registers
 274         %prepare-var-args
 275         dup alien-invoke-dlsym %alien-invoke
 276         dup %cleanup
 277         box-return*
 278         iterate-next
 279     ] with-stack-frame ;
 280
 281 M: alien-indirect-error summary
 282     drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
 283
 284 \ alien-indirect [
 285     ! Three literals and function pointer
 286     4 ensure-values
 287     4 reify-curries
 288     #alien-indirect new
 289     ! Compile-time parameters
 290     pop-literal nip >>abi
 291     pop-parameters >>parameters
 292     pop-literal nip >>return
 293     ! Quotation which coerces parameters to required types
 294     dup param-prep-quot [ dip ] curry recursive-state get infer-quot
 295     ! Add node to IR
 296     dup node,
 297     ! Magic #: consume the function pointer, too
 298     dup 1 alien-invoke-stack
 299     ! Quotation which coerces return value to required type
 300     return-prep-quot recursive-state get infer-quot
 301 ] "infer" set-word-prop
 302
 303 M: #alien-indirect generate-node
 304     dup alien-invoke-frame [
 305         ! Flush registers
 306         end-basic-block
 307         ! Save registers for GC
 308         %prepare-alien-invoke
 309         ! Save alien at top of stack to temporary storage
 310         %prepare-alien-indirect
 311         dup objects>registers
 312         %prepare-var-args
 313         ! Call alien in temporary storage
 314         %alien-indirect
 315         dup %cleanup
 316         box-return*
 317         iterate-next
 318     ] with-stack-frame ;
 319
 320 ! Callbacks are registered in a global hashtable. If you clear
 321 ! this hashtable, they will all be blown away by code GC, beware
 322 SYMBOL: callbacks
 323
 324 [ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
 325
 326 : register-callback ( word -- ) callbacks get conjoin ;
 327
 328 M: alien-callback-error summary
 329     drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
 330
 331 : callback-bottom ( node -- )
 332     xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
 333     recursive-state get infer-quot ;
 334
 335 \ alien-callback [
 336     4 ensure-values
 337     #alien-callback new dup node,
 338     pop-literal nip >>quot
 339     pop-literal nip >>abi
 340     pop-parameters >>parameters
 341     pop-literal nip >>return
 342     gensym >>xt
 343     callback-bottom
 344 ] "infer" set-word-prop
 345
 346 : box-parameters ( node -- )
 347     alien-node-parameters* [ box-parameter ] each-parameter ;
 348
 349 : registers>objects ( node -- )
 350     [
 351         dup \ %save-param-reg move-parameters
 352         "nest_stacks" f %alien-invoke
 353         box-parameters
 354     ] with-param-regs ;
 355
 356 TUPLE: callback-context ;
 357
 358 : current-callback 2 getenv ;
 359
 360 : wait-to-return ( token -- )
 361     dup current-callback eq? [
 362         drop
 363     ] [
 364         yield wait-to-return
 365     ] if ;
 366
 367 : do-callback ( quot token -- )
 368     init-catchstack
 369     dup 2 setenv
 370     slip
 371     wait-to-return ; inline
 372
 373 : callback-return-quot ( ctype -- quot )
 374     return>> {
 375         { [ dup "void" = ] [ drop [ ] ] }
 376         { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
 377         [ c-type c-type-unboxer-quot ]
 378     } cond ;
 379
 380 : wrap-callback-quot ( node -- quot )
 381     [
 382         [ callback-prep-quot ]
 383         [ quot>> ]
 384         [ callback-return-quot ] tri 3append ,
 385         [ callback-context new do-callback ] %
 386     ] [ ] make ;
 387
 388 : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
 389
 390 : callback-unwind ( node -- n )
 391     {
 392         { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
 393         { [ dup return>> large-struct? ] [ drop 4 ] }
 394         [ drop 0 ]
 395     } cond ;
 396
 397 : %callback-return ( node -- )
 398     #! All the extra book-keeping for %unwind is only for x86.
 399     #! On other platforms its an alias for %return.
 400     dup alien-node-return*
 401     [ %unnest-stacks ] [ %callback-value ] if-void
 402     callback-unwind %unwind ;
 403
 404 : generate-callback ( node -- )
 405     dup xt>> dup [
 406         init-templates
 407         %prologue-later
 408         dup alien-stack-frame [
 409             [ registers>objects ]
 410             [ wrap-callback-quot %alien-callback ]
 411             [ %callback-return ]
 412             tri
 413         ] with-stack-frame
 414     ] with-generator ;
 415
 416 M: #alien-callback generate-node
 417     end-basic-block generate-callback iterate-next ;