basis/compiler/cfg/builder/alien/alien.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs arrays layouts math math.order math.parser
   4 combinators combinators.short-circuit fry make sequences
   5 sequences.generalizations alien alien.private alien.strings
   6 alien.c-types alien.libraries classes.struct namespaces kernel
   7 strings libc locals quotations words cpu.architecture
   8 compiler.utilities compiler.tree compiler.cfg
   9 compiler.cfg.builder compiler.cfg.builder.alien.params
  10 compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
  11 compiler.cfg.instructions compiler.cfg.stack-frame
  12 compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
  13 FROM: compiler.errors => no-such-symbol no-such-library ;
  14 IN: compiler.cfg.builder.alien
  15
  16 : unbox-parameters ( parameters -- vregs reps )
  17     [
  18         [ length iota <reversed> ] keep
  19         [ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
  20         2 2 mnmap [ concat ] bi@
  21     ]
  22     [ length neg ##inc-d ] bi ;
  23
  24 : prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
  25     dup large-struct? [
  26         heap-size cell f ^^local-allot [
  27             '[ _ prefix ]
  28             [ int-rep struct-return-on-stack? 2array prefix ] bi*
  29         ] keep
  30     ] [ drop f ] if ;
  31
  32 : caller-parameter ( vreg rep on-stack? -- insn )
  33     [ dup reg-class-of reg-class-full? ] dip or
  34     [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
  35     [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
  36     if ;
  37
  38 : (caller-parameters) ( vregs reps -- )
  39     ! Place ##store-stack-param instructions first. This ensures
  40     ! that no registers are used after the ##store-reg-param
  41     ! instructions.
  42     [ first2 caller-parameter ] 2map
  43     [ ##store-stack-param? ] partition [ % ] bi@ ;
  44
  45 : caller-parameters ( params -- stack-size )
  46     [ abi>> ] [ parameters>> ] [ return>> ] tri
  47     '[
  48         _ unbox-parameters
  49         _ prepare-struct-caller struct-return-area set
  50         (caller-parameters)
  51         stack-params get
  52         struct-return-area get
  53     ] with-param-regs
  54     struct-return-area set ;
  55
  56 : box-return* ( node -- )
  57     return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
  58
  59 GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
  60
  61 M: string dlsym-valid? dlsym ;
  62
  63 M: array dlsym-valid? '[ _ dlsym ] any? ;
  64
  65 : check-dlsym ( symbols dll -- )
  66     dup dll-valid? [
  67         dupd dlsym-valid?
  68         [ drop ] [ cfg get word>> no-such-symbol ] if
  69     ] [ dll-path cfg get word>> no-such-library drop ] if ;
  70
  71 : decorated-symbol ( params -- symbols )
  72     [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
  73     {
  74         [ drop ]
  75         [ "@" glue ]
  76         [ "@" glue "_" prepend ]
  77         [ "@" glue "@" prepend ]
  78     } 2cleave
  79     4array ;
  80
  81 : alien-invoke-dlsym ( params -- symbols dll )
  82     [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
  83     [ library>> load-library ]
  84     bi 2dup check-dlsym ;
  85
  86 : alien-node-height ( params -- )
  87     [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
  88
  89 : emit-alien-block ( node quot: ( params -- ) -- )
  90     '[
  91         make-kill-block
  92         params>>
  93         _ [ alien-node-height ] bi
  94     ] emit-trivial-block ; inline
  95
  96 : emit-stack-frame ( stack-size params -- )
  97     [ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
  98     [ drop ##stack-frame ]
  99     2bi ;
 100
 101 M: #alien-invoke emit-node
 102     [
 103         {
 104             [ caller-parameters ]
 105             [ ##prepare-var-args alien-invoke-dlsym ##alien-invoke ]
 106             [ emit-stack-frame ]
 107             [ box-return* ]
 108         } cleave
 109     ] emit-alien-block ;
 110
 111 M:: #alien-indirect emit-node ( node -- )
 112     node [
 113         D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
 114         [ caller-parameters src ##alien-indirect ]
 115         [ emit-stack-frame ]
 116         [ box-return* ]
 117         tri
 118     ] emit-alien-block ;
 119
 120 M: #alien-assembly emit-node
 121     [
 122         {
 123             [ caller-parameters ]
 124             [ quot>> ##alien-assembly ]
 125             [ emit-stack-frame ]
 126             [ box-return* ]
 127         } cleave
 128     ] emit-alien-block ;
 129
 130 : callee-parameter ( rep on-stack? -- dst insn )
 131     [ next-vreg dup ] 2dip
 132     [ dup reg-class-of reg-class-full? ] dip or
 133     [ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]
 134     [ [ next-reg-param ] keep \ ##load-reg-param new-insn ]
 135     if ;
 136
 137 : prepare-struct-callee ( c-type -- vreg )
 138     large-struct?
 139     [ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;
 140
 141 : (callee-parameters) ( params -- vregs reps )
 142     [ flatten-parameter-type ] map
 143     [
 144         [ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap
 145         concat [ ##load-reg-param? ] partition [ % ] bi@
 146     ]
 147     [ [ keys ] map ]
 148     bi ;
 149
 150 : box-parameters ( vregs reps params -- )
 151     ##begin-callback
 152     next-vreg next-vreg ##restore-context
 153     [
 154         next-vreg next-vreg ##save-context
 155         box-parameter
 156         1 ##inc-d D 0 ##replace
 157     ] 3each ;
 158
 159 : callee-parameters ( params -- stack-size )
 160     [ abi>> ] [ return>> ] [ parameters>> ] tri
 161     '[
 162         _ prepare-struct-callee struct-return-area set
 163         _ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi
 164         stack-params get
 165         struct-return-area get
 166     ] with-param-regs
 167     struct-return-area set ;
 168
 169 : callback-stack-cleanup ( stack-size params -- )
 170     [ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
 171     "stack-cleanup" set-word-prop ;
 172
 173 : needs-frame-pointer ( -- )
 174     cfg get t >>frame-pointer? drop ;
 175
 176 M: #alien-callback emit-node
 177     dup params>> xt>> dup
 178     [
 179         needs-frame-pointer
 180
 181         ##prologue
 182         [
 183             {
 184                 [ callee-parameters ]
 185                 [ quot>> ##alien-callback ]
 186                 [
 187                     return>> [ ##end-callback ] [
 188                         [ D 0 ^^peek ] dip
 189                         ##end-callback
 190                         base-type unbox-return
 191                     ] if-void
 192                 ]
 193                 [ callback-stack-cleanup ]
 194             } cleave
 195         ] emit-alien-block
 196         ##epilogue
 197         ##return
 198     ] with-cfg-builder ;