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