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 ;
   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 ( node -- quot )
  20     parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
  21
  22 : alien-stack ( params extra -- )
  23     over parameters>> length + consume-d >>in-d
  24     dup return>> void? 0 1 ? produce-d >>out-d
  25     drop ;
  26
  27 : return-prep-quot ( node -- quot )
  28     return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
  29
  30 : infer-alien-invoke ( -- )
  31     alien-invoke-params new
  32     ! Compile-time parameters
  33     pop-literal nip >>parameters
  34     pop-literal nip >>function
  35     pop-literal nip >>library
  36     pop-literal nip >>return
  37     ! Quotation which coerces parameters to required types
  38     dup param-prep-quot infer-quot-here
  39     ! Set ABI
  40     dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
  41     ! Magic #: consume exactly the number of inputs
  42     dup 0 alien-stack
  43     ! Add node to IR
  44     dup #alien-invoke,
  45     ! Quotation which coerces return value to required type
  46     return-prep-quot infer-quot-here ;
  47
  48 : infer-alien-indirect ( -- )
  49     alien-indirect-params new
  50     ! Compile-time parameters
  51     pop-literal nip >>abi
  52     pop-literal nip >>parameters
  53     pop-literal nip >>return
  54     ! Quotation which coerces parameters to required types
  55     dup param-prep-quot '[ _ dip ] infer-quot-here
  56     ! Magic #: consume the function pointer, too
  57     dup 1 alien-stack
  58     ! Add node to IR
  59     dup #alien-indirect,
  60     ! Quotation which coerces return value to required type
  61     return-prep-quot infer-quot-here ;
  62
  63 : infer-alien-assembly ( -- )
  64     alien-assembly-params new
  65     ! Compile-time parameters
  66     pop-literal nip >>quot
  67     pop-literal nip >>abi
  68     pop-literal nip >>parameters
  69     pop-literal nip >>return
  70     ! Quotation which coerces parameters to required types
  71     dup param-prep-quot infer-quot-here
  72     ! Magic #: consume exactly the number of inputs
  73     dup 0 alien-stack
  74     ! Add node to IR
  75     dup #alien-assembly,
  76     ! Quotation which coerces return value to required type
  77     return-prep-quot infer-quot-here ;
  78
  79 : callback-xt ( word return-rewind -- alien )
  80     [ callbacks get ] dip '[ _ <callback> ] cache ;
  81
  82 : callback-bottom ( params -- )
  83     [ xt>> ] [ callback-return-rewind ] bi
  84     '[ _ _ callback-xt ] infer-quot-here ;
  85
  86 : infer-alien-callback ( -- )
  87     alien-callback-params new
  88     pop-literal nip >>quot
  89     pop-literal nip >>abi
  90     pop-literal nip >>parameters
  91     pop-literal nip >>return
  92     "( callback )" <uninterned-word> >>xt
  93     dup callback-bottom
  94     #alien-callback, ;