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 alien alien.c-types alien.libraries
   4 alien.strings arrays assocs classes.struct combinators
   5 compiler.cfg compiler.cfg.builder
   6 compiler.cfg.builder.alien.boxing
   7 compiler.cfg.builder.alien.params compiler.cfg.hats
   8 compiler.cfg.instructions compiler.cfg.registers
   9 compiler.cfg.stacks compiler.cfg.stacks.local compiler.errors
  10 compiler.tree cpu.architecture fry kernel layouts make math
  11 math.parser namespaces sequences sequences.generalizations
  12 strings words ;
  13 IN: compiler.cfg.builder.alien
  14
  15 : with-param-regs* ( quot -- reg-values stack-values )
  16     '[
  17         V{ } clone reg-values set
  18         V{ } clone stack-values set
  19         @
  20         reg-values get
  21         stack-values get
  22         stack-params get
  23         struct-return-area get
  24     ] with-param-regs
  25     struct-return-area set
  26     stack-params set ; inline
  27
  28 : unbox-parameters ( parameters -- vregs reps )
  29     [
  30         [ length iota <reversed> ] keep
  31         [ [ <ds-loc> peek-loc ] [ base-type ] bi* unbox-parameter ]
  32         2 2 mnmap [ concat ] bi@
  33     ]
  34     [ length neg <ds-loc> inc-stack ] bi ;
  35
  36 : prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
  37     dup large-struct? [
  38         heap-size cell f ^^local-allot [
  39             '[ _ prefix ]
  40             [ int-rep struct-return-on-stack? f 3array prefix ] bi*
  41         ] keep
  42     ] [ drop f ] if ;
  43
  44 : (caller-parameters) ( vregs reps -- )
  45     [ first3 next-parameter ] 2each ;
  46
  47 : caller-parameters ( params -- reg-inputs stack-inputs )
  48     [ abi>> ] [ parameters>> ] [ return>> ] tri
  49     '[
  50         _ unbox-parameters
  51         _ prepare-struct-caller struct-return-area set
  52         (caller-parameters)
  53     ] with-param-regs* ;
  54
  55 : prepare-caller-return ( params -- reg-outputs dead-outputs )
  56     return>> [ { } ] [ base-type load-return ] if-void { } ;
  57
  58 : caller-stack-frame ( params -- cleanup stack-size )
  59     [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup
  60     stack-params get ;
  61
  62 GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
  63
  64 M: string dlsym-valid? dlsym ;
  65
  66 M: array dlsym-valid? '[ _ dlsym ] any? ;
  67
  68 : check-dlsym ( symbols library -- )
  69     {
  70         { [ dup library-dll dll-valid? not ] [
  71             [ library-dll dll-path ] [ dlerror>> ] bi
  72             cfg get word>> no-such-library-error drop
  73         ] }
  74         { [ 2dup library-dll dlsym-valid? not ] [
  75             drop dlerror cfg get word>> no-such-symbol-error
  76         ] }
  77         [ 2drop ]
  78     } cond ;
  79
  80 : decorated-symbol ( params -- symbols )
  81     [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
  82     {
  83         [ drop ]
  84         [ "@" glue ]
  85         [ "@" glue "_" prepend ]
  86         [ "@" glue "@" prepend ]
  87     } 2cleave
  88     4array ;
  89
  90 : caller-linkage ( params -- symbols dll )
  91     [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
  92     [ library>> lookup-library ]
  93     bi 2dup check-dlsym library-dll ;
  94
  95 : caller-return ( params -- )
  96     return>> [ ] [
  97         [
  98             building get last reg-outputs>>
  99             flip [ { } { } ] [ first2 ] if-empty
 100         ] dip
 101         base-type box-return ds-push
 102     ] if-void ;
 103
 104 M: #alien-invoke emit-node
 105     params>>
 106     [
 107         {
 108             [ caller-parameters ]
 109             [ prepare-caller-return ]
 110             [ caller-stack-frame ]
 111             [ caller-linkage ]
 112         } cleave
 113         <gc-map> ##alien-invoke,
 114     ]
 115     [ caller-return ]
 116     bi ;
 117
 118 M: #alien-indirect emit-node ( node -- )
 119     params>>
 120     [
 121         [ ds-pop ^^unbox-any-c-ptr ] dip
 122         [ caller-parameters ]
 123         [ prepare-caller-return ]
 124         [ caller-stack-frame ] tri
 125         <gc-map> ##alien-indirect,
 126     ]
 127     [ caller-return ]
 128     bi ;
 129
 130 M: #alien-assembly emit-node ( node -- )
 131     params>>
 132     [
 133         {
 134             [ caller-parameters ]
 135             [ prepare-caller-return ]
 136             [ caller-stack-frame ]
 137             [ quot>> ]
 138         } cleave ##alien-assembly,
 139     ]
 140     [ caller-return ]
 141     bi ;
 142
 143 : callee-parameter ( rep on-stack? odd-register? -- dst )
 144     [ next-vreg dup ] 3dip next-parameter ;
 145
 146 : prepare-struct-callee ( c-type -- vreg )
 147     large-struct?
 148     [ int-rep struct-return-on-stack? f callee-parameter ] [ f ] if ;
 149
 150 : (callee-parameters) ( params -- vregs reps )
 151     [ flatten-parameter-type ] map
 152     [ [ [ first3 callee-parameter ] map ] map ]
 153     [ [ keys ] map ]
 154     bi ;
 155
 156 : box-parameters ( vregs reps params -- )
 157     parameters>> [ base-type box-parameter ds-push ] 3each ;
 158
 159 : callee-parameters ( params -- vregs reps reg-outputs stack-outputs )
 160     [ abi>> ] [ return>> ] [ parameters>> ] tri
 161     '[
 162         _ prepare-struct-callee struct-return-area set
 163         _ [ base-type ] map (callee-parameters)
 164     ] with-param-regs* ;
 165
 166 : callee-return ( params -- reg-inputs )
 167     return>> [ { } ] [
 168         [ ds-pop ] dip
 169         base-type unbox-return store-return
 170     ] if-void ;
 171
 172 : callback-stack-cleanup ( params -- )
 173     [ xt>> ]
 174     [ [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup ] bi
 175     "stack-cleanup" set-word-prop ;
 176
 177 : needs-frame-pointer ( -- )
 178     cfg get t >>frame-pointer? drop ;
 179
 180 : emit-callback-body ( nodes -- )
 181     [ last #return? t assert= ] [ but-last emit-nodes ] bi ;
 182
 183 : emit-callback-return ( params -- )
 184     basic-block get [ callee-return ##callback-outputs, ] [ drop ] if ;
 185
 186 M: #alien-callback emit-node
 187     dup params>> xt>> dup
 188     [
 189         needs-frame-pointer
 190
 191         begin-word
 192
 193         {
 194             [ params>> callee-parameters ##callback-inputs, ]
 195             [ params>> box-parameters ]
 196             [ child>> emit-callback-body ]
 197             [ params>> emit-callback-return ]
 198             [ params>> callback-stack-cleanup ]
 199         } cleave
 200
 201         basic-block get [ end-word ] when
 202     ] with-cfg-builder ;