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.c-types alien.libraries alien.strings arrays
   4 assocs classes.struct combinators compiler.cfg compiler.cfg.builder
   5 compiler.cfg.builder.alien.boxing compiler.cfg.builder.alien.params
   6 compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers
   7 compiler.cfg.stacks compiler.cfg.stacks.local compiler.errors
   8 compiler.tree cpu.architecture fry kernel layouts make math namespaces
   9 sequences sequences.generalizations words ;
  10 IN: compiler.cfg.builder.alien
  11
  12 : with-param-regs ( abi quot -- reg-values stack-values )
  13     '[
  14         param-regs init-regs
  15         0 stack-params set
  16         V{ } clone reg-values set
  17         V{ } clone stack-values set
  18         0 int-reg-reps set
  19         0 float-reg-reps set
  20         @
  21         reg-values get
  22         stack-values get
  23         stack-params get
  24         struct-return-area get
  25     ] with-scope
  26     struct-return-area set
  27     stack-params set ; inline
  28
  29 : unbox-parameters ( parameters -- vregs reps )
  30     [
  31         [ length <iota> <reversed> ] keep
  32         [ [ <ds-loc> peek-loc ] [ base-type ] bi* unbox-parameter ]
  33         2 2 mnmap [ concat ] bi@
  34     ]
  35     [ length neg <ds-loc> inc-stack ] bi ;
  36
  37 : prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
  38     dup large-struct? [
  39         heap-size cell f ^^local-allot [
  40             '[ _ prefix ]
  41             [ int-rep struct-return-on-stack? f 3array prefix ] bi*
  42         ] keep
  43     ] [ drop f ] if ;
  44
  45 : (caller-parameters) ( vregs reps -- )
  46     [ first3 next-parameter ] 2each ;
  47
  48 : caller-parameters ( params -- reg-inputs stack-inputs )
  49     [ abi>> ] [ parameters>> ] [ return>> ] tri
  50     '[
  51         _ unbox-parameters
  52         _ prepare-struct-caller struct-return-area set
  53         (caller-parameters)
  54     ] with-param-regs ;
  55
  56 : prepare-caller-return ( params -- reg-outputs )
  57     return>> [ { } ] [ base-type load-return ] if-void ;
  58
  59 : caller-stack-cleanup ( params stack-size -- cleanup )
  60     swap [ return>> ] [ abi>> ] bi stack-cleanup ;
  61
  62 : check-dlsym ( symbol library/f -- )
  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/f )
  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 : params>alien-insn-params ( params --
  88                              varargs? reg-inputs stack-inputs
  89                              reg-outputs dead-outputs
  90                              cleanup stack-size )
  91     {
  92         [ varargs?>> ]
  93         [ caller-parameters ]
  94         [ prepare-caller-return { } ]
  95         [ stack-params get [ caller-stack-cleanup ] keep ]
  96     } cleave ;
  97
  98 M: #alien-invoke emit-node ( block node -- block' )
  99     params>>
 100     [
 101         [ params>alien-insn-params ]
 102         [ caller-linkage ] bi
 103         <gc-map> ##alien-invoke,
 104     ]
 105     [ caller-return ] bi ;
 106
 107 M: #alien-indirect emit-node ( block node -- block' )
 108     params>>
 109     [
 110         [ ds-pop ^^unbox-any-c-ptr ] dip
 111         params>alien-insn-params
 112         <gc-map> ##alien-indirect,
 113     ]
 114     [ caller-return ] bi ;
 115
 116 M: #alien-assembly emit-node ( block node -- block' )
 117     params>>
 118     [
 119         [ params>alien-insn-params ]
 120         [ quot>> ] bi
 121         ##alien-assembly,
 122     ]
 123     [ caller-return ] bi ;
 124
 125 : callee-parameter ( rep on-stack? odd-register? -- dst )
 126     [ next-vreg dup ] 3dip next-parameter ;
 127
 128 : prepare-struct-callee ( c-type -- vreg )
 129     large-struct?
 130     [ int-rep struct-return-on-stack? f callee-parameter ] [ f ] if ;
 131
 132 : (callee-parameters) ( params -- vregs reps )
 133     [ flatten-parameter-type ] map
 134     [ [ [ first3 callee-parameter ] map ] map ]
 135     [ [ keys ] map ] bi ;
 136
 137 : box-parameters ( vregs reps params -- )
 138     parameters>> [ base-type box-parameter ds-push ] 3each ;
 139
 140 : callee-parameters ( params -- vregs reps reg-outputs stack-outputs )
 141     [ abi>> ] [ return>> ] [ parameters>> ] tri
 142     '[
 143         _ prepare-struct-callee struct-return-area set
 144         _ [ base-type ] map (callee-parameters)
 145     ] with-param-regs ;
 146
 147 : callee-return ( params -- reg-inputs )
 148     return>> [ { } ] [
 149         [ ds-pop ] dip
 150         base-type unbox-return store-return
 151     ] if-void ;
 152
 153 : emit-callback-body ( block nodes -- block' )
 154     dup last #return? t assert= but-last emit-nodes ;
 155
 156 : emit-callback-inputs ( params -- )
 157     [ callee-parameters ##callback-inputs, ] keep box-parameters ;
 158
 159 : callback-stack-cleanup ( params -- )
 160     [ xt>> ]
 161     [ [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup ] bi
 162     "stack-cleanup" set-word-prop ;
 163
 164 : emit-callback-return ( block params -- )
 165     swap [ callee-return ##callback-outputs, ] [ drop ] if ;
 166
 167 : emit-callback-outputs ( block params -- )
 168     [ emit-callback-return ] keep callback-stack-cleanup ;
 169
 170 M: #alien-callback emit-node ( block node -- block' )
 171     dup params>> xt>> dup
 172     [
 173         t cfg get frame-pointer?<<
 174         begin-word
 175         over params>> emit-callback-inputs
 176         over child>> emit-callback-body
 177         [ swap params>> emit-callback-outputs ] keep
 178         [ end-word drop ] when*
 179     ] with-cfg-builder ;