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 : check-dlsym ( symbol library -- )
  63     {
  64         { [ dup library-dll dll-valid? not ] [
  65             [ library-dll dll-path ] [ dlerror>> ] bi
  66             cfg get word>> no-such-library-error drop
  67         ] }
  68         { [ 2dup library-dll dlsym not ] [
  69             drop dlerror cfg get word>> no-such-symbol-error
  70         ] }
  71         [ 2drop ]
  72     } cond ;
  73
  74 : caller-linkage ( params -- symbol dll )
  75     [ function>> ] [ library>> lookup-library ] bi
  76     2dup check-dlsym library-dll ;
  77
  78 : caller-return ( params -- )
  79     return>> [ ] [
  80         [
  81             building get last reg-outputs>>
  82             flip [ { } { } ] [ first2 ] if-empty
  83         ] dip
  84         base-type box-return ds-push
  85     ] if-void ;
  86
  87 M: #alien-invoke emit-node
  88     params>>
  89     [
  90         {
  91             [ caller-parameters ]
  92             [ prepare-caller-return ]
  93             [ caller-stack-frame ]
  94             [ caller-linkage ]
  95         } cleave
  96         <gc-map> ##alien-invoke,
  97     ]
  98     [ caller-return ]
  99     bi ;
 100
 101 M: #alien-indirect emit-node ( node -- )
 102     params>>
 103     [
 104         [ ds-pop ^^unbox-any-c-ptr ] dip
 105         [ caller-parameters ]
 106         [ prepare-caller-return ]
 107         [ caller-stack-frame ] tri
 108         <gc-map> ##alien-indirect,
 109     ]
 110     [ caller-return ]
 111     bi ;
 112
 113 M: #alien-assembly emit-node ( node -- )
 114     params>>
 115     [
 116         {
 117             [ caller-parameters ]
 118             [ prepare-caller-return ]
 119             [ caller-stack-frame ]
 120             [ quot>> ]
 121         } cleave ##alien-assembly,
 122     ]
 123     [ caller-return ]
 124     bi ;
 125
 126 : callee-parameter ( rep on-stack? odd-register? -- dst )
 127     [ next-vreg dup ] 3dip next-parameter ;
 128
 129 : prepare-struct-callee ( c-type -- vreg )
 130     large-struct?
 131     [ int-rep struct-return-on-stack? f callee-parameter ] [ f ] if ;
 132
 133 : (callee-parameters) ( params -- vregs reps )
 134     [ flatten-parameter-type ] map
 135     [ [ [ first3 callee-parameter ] map ] map ]
 136     [ [ keys ] map ]
 137     bi ;
 138
 139 : box-parameters ( vregs reps params -- )
 140     parameters>> [ base-type box-parameter ds-push ] 3each ;
 141
 142 : callee-parameters ( params -- vregs reps reg-outputs stack-outputs )
 143     [ abi>> ] [ return>> ] [ parameters>> ] tri
 144     '[
 145         _ prepare-struct-callee struct-return-area set
 146         _ [ base-type ] map (callee-parameters)
 147     ] with-param-regs* ;
 148
 149 : callee-return ( params -- reg-inputs )
 150     return>> [ { } ] [
 151         [ ds-pop ] dip
 152         base-type unbox-return store-return
 153     ] if-void ;
 154
 155 : callback-stack-cleanup ( params -- )
 156     [ xt>> ]
 157     [ [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup ] bi
 158     "stack-cleanup" set-word-prop ;
 159
 160 : needs-frame-pointer ( -- )
 161     cfg get t >>frame-pointer? drop ;
 162
 163 : emit-callback-body ( nodes -- )
 164     [ last #return? t assert= ] [ but-last emit-nodes ] bi ;
 165
 166 : emit-callback-return ( params -- )
 167     basic-block get [ callee-return ##callback-outputs, ] [ drop ] if ;
 168
 169 M: #alien-callback emit-node
 170     dup params>> xt>> dup
 171     [
 172         needs-frame-pointer begin-word
 173         {
 174             [ params>> callee-parameters ##callback-inputs, ]
 175             [ params>> box-parameters ]
 176             [ child>> emit-callback-body ]
 177             [ params>> emit-callback-return ]
 178             [ params>> callback-stack-cleanup ]
 179         } cleave
 180         basic-block get [ end-word ] when
 181     ] with-cfg-builder ;