unfinished/compiler/backend/alien/alien.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: compiler.backend.alien
   4
   5 ! #alien-invoke
   6 : set-stack-frame ( n -- )
   7     dup [ frame-required ] when* \ stack-frame set ;
   8
   9 : with-stack-frame ( n quot -- )
  10     swap set-stack-frame
  11     call
  12     f set-stack-frame ; inline
  13
  14 GENERIC: reg-size ( register-class -- n )
  15
  16 M: int-regs reg-size drop cell ;
  17
  18 M: single-float-regs reg-size drop 4 ;
  19
  20 M: double-float-regs reg-size drop 8 ;
  21
  22 GENERIC: reg-class-variable ( register-class -- symbol )
  23
  24 M: reg-class reg-class-variable ;
  25
  26 M: float-regs reg-class-variable drop float-regs ;
  27
  28 GENERIC: inc-reg-class ( register-class -- )
  29
  30 M: reg-class inc-reg-class
  31     dup reg-class-variable inc
  32     fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
  33
  34 M: float-regs inc-reg-class
  35     dup call-next-method
  36     fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
  37
  38 GENERIC: reg-class-full? ( class -- ? )
  39
  40 M: stack-params reg-class-full? drop t ;
  41
  42 M: object reg-class-full?
  43     [ reg-class-variable get ] [ param-regs length ] bi >= ;
  44
  45 : spill-param ( reg-class -- n reg-class )
  46     stack-params get
  47     >r reg-size stack-params +@ r>
  48     stack-params ;
  49
  50 : fastcall-param ( reg-class -- n reg-class )
  51     [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
  52
  53 : alloc-parameter ( parameter -- reg reg-class )
  54     c-type-reg-class dup reg-class-full?
  55     [ spill-param ] [ fastcall-param ] if
  56     [ param-reg ] keep ;
  57
  58 : (flatten-int-type) ( size -- )
  59     cell /i "void*" c-type <repetition> % ;
  60
  61 GENERIC: flatten-value-type ( type -- )
  62
  63 M: object flatten-value-type , ;
  64
  65 M: struct-type flatten-value-type ( type -- )
  66     stack-size cell align (flatten-int-type) ;
  67
  68 M: long-long-type flatten-value-type ( type -- )
  69     stack-size cell align (flatten-int-type) ;
  70
  71 : flatten-value-types ( params -- params )
  72     #! Convert value type structs to consecutive void*s.
  73     [
  74         0 [
  75             c-type
  76             [ parameter-align (flatten-int-type) ] keep
  77             [ stack-size cell align + ] keep
  78             flatten-value-type
  79         ] reduce drop
  80     ] { } make ;
  81
  82 : each-parameter ( parameters quot -- )
  83     >r [ parameter-sizes nip ] keep r> 2each ; inline
  84
  85 : reverse-each-parameter ( parameters quot -- )
  86     >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
  87
  88 : reset-freg-counts ( -- )
  89     { int-regs float-regs stack-params } [ 0 swap set ] each ;
  90
  91 : with-param-regs ( quot -- )
  92     #! In quot you can call alloc-parameter
  93     [ reset-freg-counts call ] with-scope ; inline
  94
  95 : move-parameters ( node word -- )
  96     #! Moves values from C stack to registers (if word is
  97     #! %load-param-reg) and registers to C stack (if word is
  98     #! %save-param-reg).
  99     >r
 100     alien-parameters
 101     flatten-value-types
 102     r> [ >r alloc-parameter r> execute ] curry each-parameter ;
 103     inline
 104
 105 : unbox-parameters ( offset node -- )
 106     parameters>> [
 107         %prepare-unbox >r over + r> unbox-parameter
 108     ] reverse-each-parameter drop ;
 109
 110 : prepare-box-struct ( node -- offset )
 111     #! Return offset on C stack where to store unboxed
 112     #! parameters. If the C function is returning a structure,
 113     #! the first parameter is an implicit target area pointer,
 114     #! so we need to use a different offset.
 115     return>> dup large-struct?
 116     [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
 117
 118 : objects>registers ( params -- )
 119     #! Generate code for unboxing a list of C types, then
 120     #! generate code for moving these parameters to register on
 121     #! architectures where parameters are passed in registers.
 122     [
 123         [ prepare-box-struct ] keep
 124         [ unbox-parameters ] keep
 125         \ %load-param-reg move-parameters
 126     ] with-param-regs ;
 127
 128 : box-return* ( node -- )
 129     return>> [ ] [ box-return ] if-void ;
 130
 131 TUPLE: no-such-library name ;
 132
 133 M: no-such-library summary
 134     drop "Library not found" ;
 135
 136 M: no-such-library compiler-error-type
 137     drop +linkage+ ;
 138
 139 : no-such-library ( name -- )
 140     \ no-such-library boa
 141     compiling-word get compiler-error ;
 142
 143 TUPLE: no-such-symbol name ;
 144
 145 M: no-such-symbol summary
 146     drop "Symbol not found" ;
 147
 148 M: no-such-symbol compiler-error-type
 149     drop +linkage+ ;
 150
 151 : no-such-symbol ( name -- )
 152     \ no-such-symbol boa
 153     compiling-word get compiler-error ;
 154
 155 : check-dlsym ( symbols dll -- )
 156     dup dll-valid? [
 157         dupd [ dlsym ] curry contains?
 158         [ drop ] [ no-such-symbol ] if
 159     ] [
 160         dll-path no-such-library drop
 161     ] if ;
 162
 163 : stdcall-mangle ( symbol node -- symbol )
 164     "@"
 165     swap parameters>> parameter-sizes drop
 166     number>string 3append ;
 167
 168 : alien-invoke-dlsym ( params -- symbols dll )
 169     dup function>> dup pick stdcall-mangle 2array
 170     swap library>> library dup [ dll>> ] when
 171     2dup check-dlsym ;
 172
 173 M: #alien-invoke generate-node
 174     params>>
 175     dup alien-invoke-frame [
 176         end-basic-block
 177         %prepare-alien-invoke
 178         dup objects>registers
 179         %prepare-var-args
 180         dup alien-invoke-dlsym %alien-invoke
 181         dup %cleanup
 182         box-return*
 183         iterate-next
 184     ] with-stack-frame ;
 185
 186 ! #alien-indirect
 187 M: #alien-indirect generate-node
 188     params>>
 189     dup alien-invoke-frame [
 190         ! Flush registers
 191         end-basic-block
 192         ! Save registers for GC
 193         %prepare-alien-invoke
 194         ! Save alien at top of stack to temporary storage
 195         %prepare-alien-indirect
 196         dup objects>registers
 197         %prepare-var-args
 198         ! Call alien in temporary storage
 199         %alien-indirect
 200         dup %cleanup
 201         box-return*
 202         iterate-next
 203     ] with-stack-frame ;
 204
 205 ! #alien-callback
 206 : box-parameters ( params -- )
 207     alien-parameters [ box-parameter ] each-parameter ;
 208
 209 : registers>objects ( node -- )
 210     [
 211         dup \ %save-param-reg move-parameters
 212         "nest_stacks" f %alien-invoke
 213         box-parameters
 214     ] with-param-regs ;
 215
 216 TUPLE: callback-context ;
 217
 218 : current-callback 2 getenv ;
 219
 220 : wait-to-return ( token -- )
 221     dup current-callback eq? [
 222         drop
 223     ] [
 224         yield wait-to-return
 225     ] if ;
 226
 227 : do-callback ( quot token -- )
 228     init-catchstack
 229     dup 2 setenv
 230     slip
 231     wait-to-return ; inline
 232
 233 : callback-return-quot ( ctype -- quot )
 234     return>> {
 235         { [ dup "void" = ] [ drop [ ] ] }
 236         { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
 237         [ c-type c-type-unboxer-quot ]
 238     } cond ;
 239
 240 : callback-prep-quot ( params -- quot )
 241     parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
 242
 243 : wrap-callback-quot ( params -- quot )
 244     [
 245         [ callback-prep-quot ]
 246         [ quot>> ]
 247         [ callback-return-quot ] tri 3append ,
 248         [ callback-context new do-callback ] %
 249     ] [ ] make ;
 250
 251 : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
 252
 253 : callback-unwind ( params -- n )
 254     {
 255         { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
 256         { [ dup return>> large-struct? ] [ drop 4 ] }
 257         [ drop 0 ]
 258     } cond ;
 259
 260 : %callback-return ( params -- )
 261     #! All the extra book-keeping for %unwind is only for x86.
 262     #! On other platforms its an alias for %return.
 263     dup alien-return
 264     [ %unnest-stacks ] [ %callback-value ] if-void
 265     callback-unwind %unwind ;
 266
 267 : generate-callback ( params -- )
 268     dup xt>> dup [
 269         init-templates
 270         %prologue
 271         dup alien-stack-frame [
 272             [ registers>objects ]
 273             [ wrap-callback-quot %alien-callback ]
 274             [ %callback-return ]
 275             tri
 276         ] with-stack-frame
 277     ] with-cfg-builder ;
 278
 279 M: #alien-callback generate-node
 280     end-basic-block
 281     params>> generate-callback iterate-next ;