basis/stack-checker/alien/alien.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences accessors combinators math namespaces
   4 init sets words alien.libraries
   5 alien alien.c-types
   6 stack-checker.backend stack-checker.errors stack-checker.visitor ;
   7 IN: stack-checker.alien
   8
   9 TUPLE: alien-node-params return parameters abi in-d out-d ;
  10
  11 TUPLE: alien-invoke-params < alien-node-params library function ;
  12
  13 TUPLE: alien-indirect-params < alien-node-params ;
  14
  15 TUPLE: alien-callback-params < alien-node-params quot xt ;
  16
  17 : param-prep-quot ( node -- quot )
  18     parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
  19
  20 : alien-stack ( params extra -- )
  21     over parameters>> length + consume-d >>in-d
  22     dup return>> void? 0 1 ? produce-d >>out-d
  23     drop ;
  24
  25 : return-prep-quot ( node -- quot )
  26     return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
  27
  28 : infer-alien-invoke ( -- )
  29     alien-invoke-params new
  30     ! Compile-time parameters
  31     pop-literal nip >>parameters
  32     pop-literal nip >>function
  33     pop-literal nip >>library
  34     pop-literal nip >>return
  35     ! Quotation which coerces parameters to required types
  36     dup param-prep-quot infer-quot-here
  37     ! Set ABI
  38     dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
  39     ! Magic #: consume exactly the number of inputs
  40     dup 0 alien-stack
  41     ! Add node to IR
  42     dup #alien-invoke,
  43     ! Quotation which coerces return value to required type
  44     return-prep-quot infer-quot-here ;
  45
  46 : infer-alien-indirect ( -- )
  47     alien-indirect-params new
  48     ! Compile-time parameters
  49     pop-literal nip >>abi
  50     pop-literal nip >>parameters
  51     pop-literal nip >>return
  52     ! Quotation which coerces parameters to required types
  53     dup param-prep-quot [ dip ] curry infer-quot-here
  54     ! Magic #: consume the function pointer, too
  55     dup 1 alien-stack
  56     ! Add node to IR
  57     dup #alien-indirect,
  58     ! Quotation which coerces return value to required type
  59     return-prep-quot infer-quot-here ;
  60
  61 : register-callback ( word -- ) callbacks get conjoin ;
  62
  63 : callback-bottom ( params -- )
  64     xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
  65     infer-quot-here ;
  66
  67 : infer-alien-callback ( -- )
  68     alien-callback-params new
  69     pop-literal nip >>quot
  70     pop-literal nip >>abi
  71     pop-literal nip >>parameters
  72     pop-literal nip >>return
  73     gensym >>xt
  74     dup callback-bottom
  75     #alien-callback, ;