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 sequences accessors combinators math namespaces
   4 init sets words assocs alien.libraries alien alien.c-types
   5 cpu.architecture fry stack-checker.backend stack-checker.errors
   6 stack-checker.visitor stack-checker.dependencies ;
   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-assembly-params < alien-node-params quot ;
  16
  17 TUPLE: alien-callback-params < alien-node-params quot xt ;
  18
  19 : param-prep-quot ( params -- quot )
  20     parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
  21
  22 : infer-params ( params -- )
  23     param-prep-quot infer-quot-here ;
  24
  25 : alien-stack ( params extra -- )
  26     over parameters>> length + consume-d >>in-d
  27     dup return>> void? 0 1 ? produce-d >>out-d
  28     drop ;
  29
  30 : return-prep-quot ( params -- quot )
  31     return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
  32
  33 : infer-return ( params -- )
  34     return-prep-quot infer-quot-here ;
  35
  36 : pop-return ( params -- params )
  37     pop-literal [ depends-on-c-type ] [ nip >>return ] bi ;
  38
  39 : pop-library ( params -- params )
  40     pop-literal nip >>library ;
  41
  42 : pop-function ( params -- params )
  43     pop-literal nip >>function ;
  44
  45 : pop-params ( params -- params )
  46     pop-literal [ [ depends-on-c-type ] each ] [ nip >>parameters ] bi ;
  47
  48 : pop-abi ( params -- params )
  49     pop-literal nip >>abi ;
  50
  51 : pop-quot ( params -- params )
  52     pop-literal nip >>quot ;
  53
  54 : infer-alien-invoke ( -- )
  55     alien-invoke-params new
  56     ! Compile-time parameters
  57     pop-params
  58     pop-function
  59     pop-library
  60     pop-return
  61     ! Set ABI
  62     dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
  63     ! Quotation which coerces parameters to required types
  64     dup infer-params
  65     ! Magic #: consume exactly the number of inputs
  66     dup 0 alien-stack
  67     ! Add node to IR
  68     dup #alien-invoke,
  69     ! Quotation which coerces return value to required type
  70     infer-return ;
  71
  72 : infer-alien-indirect ( -- )
  73     alien-indirect-params new
  74     ! Compile-time parameters
  75     pop-abi
  76     pop-params
  77     pop-return
  78     ! Quotation which coerces parameters to required types
  79     1 infer->r
  80     dup infer-params
  81     1 infer-r>
  82     ! Magic #: consume the function pointer, too
  83     dup 1 alien-stack
  84     ! Add node to IR
  85     dup #alien-indirect,
  86     ! Quotation which coerces return value to required type
  87     infer-return ;
  88
  89 : infer-alien-assembly ( -- )
  90     alien-assembly-params new
  91     ! Compile-time parameters
  92     pop-quot
  93     pop-abi
  94     pop-params
  95     pop-return
  96     ! Quotation which coerces parameters to required types
  97     dup infer-params
  98     ! Magic #: consume exactly the number of inputs
  99     dup 0 alien-stack
 100     ! Add node to IR
 101     dup #alien-assembly,
 102     ! Quotation which coerces return value to required type
 103     infer-return ;
 104
 105 : callback-xt ( word return-rewind -- alien )
 106     [ callbacks get ] dip '[ _ <callback> ] cache ;
 107
 108 : callback-bottom ( params -- )
 109     [ xt>> ] [ callback-return-rewind ] bi
 110     '[ _ _ callback-xt ] infer-quot-here ;
 111
 112 : infer-alien-callback ( -- )
 113     alien-callback-params new
 114     pop-quot
 115     pop-abi
 116     pop-params
 117     pop-return
 118     "( callback )" <uninterned-word> >>xt
 119     dup callback-bottom
 120     #alien-callback, ;