basis/stack-checker/alien/alien.factor

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