basis/stack-checker/alien/alien.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel arrays sequences accessors combinators math
   4 namespaces init sets words assocs alien.libraries alien
   5 alien.private alien.c-types fry quotations strings
   6 stack-checker.backend stack-checker.errors stack-checker.visitor
   7 stack-checker.dependencies stack-checker.state
   8 compiler.utilities effects ;
   9 FROM: kernel.private => declare ;
  10 IN: stack-checker.alien
  11
  12 TUPLE: alien-node-params
  13 return parameters
  14 { abi abi initial: cdecl }
  15 in-d
  16 out-d ;
  17
  18 TUPLE: alien-invoke-params < alien-node-params library { function string } ;
  19
  20 TUPLE: alien-indirect-params < alien-node-params ;
  21
  22 TUPLE: alien-assembly-params < alien-node-params { quot callable } ;
  23
  24 TUPLE: alien-callback-params < alien-node-params xt ;
  25
  26 : param-prep-quot ( params -- quot )
  27     parameters>> [ c-type c-type-unboxer-quot ] map deep-spread>quot ;
  28
  29 : alien-stack ( params extra -- )
  30     over parameters>> length + consume-d >>in-d
  31     dup return>> void? 0 1 ? produce-d >>out-d
  32     drop ;
  33
  34 : return-prep-quot ( params -- quot )
  35     return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
  36
  37 : infer-return ( params -- )
  38     return-prep-quot infer-quot-here ;
  39
  40 : pop-return ( params -- params )
  41     pop-literal [ depends-on-c-type ] [ nip >>return ] bi ;
  42
  43 : pop-library ( params -- params )
  44     pop-literal nip >>library ;
  45
  46 : pop-function ( params -- params )
  47     pop-literal nip >>function ;
  48
  49 : pop-params ( params -- params )
  50     pop-literal [ [ depends-on-c-type ] each ] [ nip >>parameters ] bi ;
  51
  52 : pop-abi ( params -- params )
  53     pop-literal nip >>abi ;
  54
  55 : pop-quot ( params -- params )
  56     pop-literal nip >>quot ;
  57
  58 : infer-alien-invoke ( -- )
  59     alien-invoke-params new
  60     ! Compile-time parameters
  61     pop-params
  62     pop-function
  63     pop-library
  64     pop-return
  65     ! Set ABI
  66     dup library>> library-abi >>abi
  67     ! Quotation which coerces parameters to required types
  68     dup param-prep-quot infer-quot-here
  69     ! Magic #: consume exactly the number of inputs
  70     dup 0 alien-stack
  71     ! Add node to IR
  72     dup #alien-invoke,
  73     ! Quotation which coerces return value to required type
  74     infer-return ;
  75
  76 : infer-alien-indirect ( -- )
  77     alien-indirect-params new
  78     ! Compile-time parameters
  79     pop-abi
  80     pop-params
  81     pop-return
  82     ! Coerce parameters to required types
  83     dup param-prep-quot '[ _ [ >c-ptr ] bi* ] infer-quot-here
  84     ! Magic #: consume the function pointer, too
  85     dup 1 alien-stack
  86     ! Add node to IR
  87     dup #alien-indirect,
  88     ! Quotation which coerces return value to required type
  89     infer-return ;
  90
  91 : infer-alien-assembly ( -- )
  92     alien-assembly-params new
  93     ! Compile-time parameters
  94     pop-quot
  95     pop-abi
  96     pop-params
  97     pop-return
  98     ! Quotation which coerces parameters to required types
  99     dup param-prep-quot infer-quot-here
 100     ! Magic #: consume exactly the number of inputs
 101     dup 0 alien-stack
 102     ! Add node to IR
 103     dup #alien-assembly,
 104     ! Quotation which coerces return value to required type
 105     infer-return ;
 106
 107 : callback-xt ( word -- alien )
 108     callbacks get [ dup "stack-cleanup" word-prop <callback> ] cache ;
 109
 110 : callback-bottom ( params -- )
 111     "( callback )" <uninterned-word> >>xt
 112     xt>> '[ _ callback-xt { alien } declare ] infer-quot-here ;
 113
 114 : callback-return-quot ( ctype -- quot )
 115     return>> [ [ ] ] [ c-type c-type-unboxer-quot ] if-void ;
 116
 117 : callback-parameter-quot ( params -- quot )
 118     parameters>> [ c-type ] map
 119     [ [ c-type-class ] map '[ _ declare ] ]
 120     [ [ c-type-boxer-quot ] map deep-spread>quot ]
 121     bi append ;
 122
 123 GENERIC: wrap-callback-quot ( params quot -- quot' )
 124
 125 SYMBOL: wait-for-callback-hook
 126
 127 wait-for-callback-hook [ [ drop ] ] initialize
 128
 129 M: callable wrap-callback-quot
 130     swap [ callback-parameter-quot ] [ callback-return-quot ] bi surround
 131     wait-for-callback-hook get
 132     '[ _ _ do-callback ]
 133     >quotation ;
 134
 135 : callback-effect ( params -- effect )
 136     [ parameters>> length "x" <array> ] [ return>> void? { } { "x" } ? ] bi
 137     <effect> ;
 138
 139 : infer-callback-quot ( params quot -- child )
 140     [
 141         init-inference
 142         nest-visitor
 143         infer-quot-here
 144         end-infer
 145         callback-effect check-effect
 146         stack-visitor get
 147     ] with-scope ;
 148
 149 : infer-alien-callback ( -- )
 150     pop-literal nip [
 151         alien-callback-params new
 152         pop-abi
 153         pop-params
 154         pop-return
 155         dup callback-bottom
 156         dup
 157         dup
 158     ] dip wrap-callback-quot infer-callback-quot
 159     #alien-callback, ;