library/compiler/alien/alien-invoke.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: alien
   4 USING: arrays assembler compiler errors generic hashtables
   5 inference io kernel kernel-internals math namespaces parser
   6 prettyprint sequences strings words ;
   7
   8 TUPLE: alien-invoke library function return parameters ;
   9 C: alien-invoke make-node ;
  10
  11 : alien-invoke-stack ( node -- )
  12     dup alien-invoke-parameters length over consume-values
  13     dup alien-invoke-return "void" = 0 1 ? swap produce-values ;
  14
  15 : alien-invoke-dlsym ( node -- symbol dll )
  16     dup alien-invoke-function swap alien-invoke-library
  17     load-library ;
  18
  19 TUPLE: alien-invoke-error library symbol ;
  20
  21 M: alien-invoke-error summary
  22     drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ;
  23
  24 : alien-invoke ( ... return library function parameters -- ... )
  25     pick pick <alien-invoke-error> throw ;
  26
  27 : ensure-dlsym ( node -- )
  28     [ alien-invoke-dlsym dlsym drop ]
  29     [ inference-warning ] recover ;
  30
  31 \ alien-invoke [ string object string object ] [ ] <effect>
  32 "infer-effect" set-word-prop
  33
  34 \ alien-invoke [
  35     empty-node <alien-invoke> dup node,
  36     pop-literal nip over set-alien-invoke-parameters
  37     pop-literal nip over set-alien-invoke-function
  38     pop-literal nip over set-alien-invoke-library
  39     pop-literal nip over set-alien-invoke-return
  40     dup ensure-dlsym
  41     alien-invoke-stack
  42 ] "infer" set-word-prop
  43
  44 : unbox-parameter ( stack# type -- )
  45     c-type [ "reg-class" get "unboxer" get call ] bind ;
  46
  47 : unbox-parameters ( parameters -- )
  48     [ unbox-parameter ] reverse-each-parameter ;
  49
  50 : objects>registers ( parameters -- )
  51     #! Generate code for boxing a list of C types, then generate
  52     #! code for moving these parameters to register on
  53     #! architectures where parameters are passed in registers
  54     #! (PowerPC, AMD64).
  55     dup unbox-parameters
  56     "save_stacks" f %alien-invoke
  57     \ %stack>freg move-parameters ;
  58
  59 : box-return ( ctype -- )
  60     [ ] [ f swap box-parameter ] if-void ;
  61
  62 : generate-invoke-cleanup ( node -- )
  63     dup alien-invoke-library library-abi "stdcall" = [
  64         drop
  65     ] [
  66         alien-invoke-parameters stack-space %cleanup
  67     ] if ;
  68
  69 M: alien-invoke generate-node
  70     end-basic-block compile-gc
  71     dup alien-invoke-parameters objects>registers
  72     dup alien-invoke-dlsym %alien-invoke
  73     dup generate-invoke-cleanup
  74     alien-invoke-return box-return
  75     iterate-next ;
  76
  77 M: alien-invoke stack-reserve*
  78     alien-invoke-parameters stack-space ;
  79
  80 : parse-arglist ( return seq -- types effect )
  81     2 group unpair
  82     rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
  83
  84 : (define-c-word) ( type lib func types stack-effect -- )
  85     >r over create-in dup reset-generic >r
  86     [ alien-invoke ] curry curry curry curry
  87     r> swap define-compound word r>
  88     "declared-effect" set-word-prop ;
  89
  90 : define-c-word ( return library function parameters -- )
  91     [ "()" subseq? not ] subset >r pick r> parse-arglist
  92     (define-c-word) ;