basis/compiler/cfg/intrinsics/alien/alien.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel sequences alien math classes.algebra fry
   4 locals combinators combinators.short-circuit cpu.architecture
   5 compiler.tree.propagation.info compiler.cfg.hats
   6 compiler.cfg.registers compiler.cfg.stacks
   7 compiler.cfg.instructions compiler.cfg.utilities
   8 compiler.cfg.builder.blocks ;
   9 IN: compiler.cfg.intrinsics.alien
  10
  11 : emit-<displaced-alien>? ( node -- ? )
  12     node-input-infos {
  13         [ first class>> fixnum class<= ]
  14         [ second class>> c-ptr class<= ]
  15     } 1&& ;
  16
  17 : emit-<displaced-alien> ( node -- )
  18     dup emit-<displaced-alien>? [
  19         [ 2inputs [ ^^untag-fixnum ] dip ] dip
  20         node-input-infos second class>>
  21         ^^box-displaced-alien ds-push
  22     ] [ emit-primitive ] if ;
  23
  24 :: inline-alien ( node quot test -- )
  25     [let | infos [ node node-input-infos ] |
  26         infos test call
  27         [ infos quot call ]
  28         [ node emit-primitive ]
  29         if
  30     ] ; inline
  31
  32 : inline-alien-getter? ( infos -- ? )
  33     [ first class>> c-ptr class<= ]
  34     [ second class>> fixnum class<= ]
  35     bi and ;
  36
  37 : ^^unbox-c-ptr ( src class -- dst )
  38     [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
  39
  40 : prepare-alien-accessor ( info -- ptr-vreg offset )
  41     class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
  42
  43 : prepare-alien-getter ( infos -- ptr-vreg offset )
  44     first prepare-alien-accessor ;
  45
  46 : inline-alien-getter ( node quot -- )
  47     '[ prepare-alien-getter @ ds-push ]
  48     [ inline-alien-getter? ] inline-alien ; inline
  49
  50 : inline-alien-setter? ( infos class -- ? )
  51     '[ first class>> _ class<= ]
  52     [ second class>> c-ptr class<= ]
  53     [ third class>> fixnum class<= ]
  54     tri and and ;
  55
  56 : prepare-alien-setter ( infos -- ptr-vreg offset )
  57     second prepare-alien-accessor ;
  58
  59 : inline-alien-integer-setter ( node quot -- )
  60     '[ prepare-alien-setter ds-pop ^^untag-fixnum @ ]
  61     [ fixnum inline-alien-setter? ]
  62     inline-alien ; inline
  63
  64 : inline-alien-cell-setter ( node quot -- )
  65     '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
  66     [ pinned-c-ptr inline-alien-setter? ]
  67     inline-alien ; inline
  68
  69 : inline-alien-float-setter ( node quot -- )
  70     '[ prepare-alien-setter ds-pop @ ]
  71     [ float inline-alien-setter? ]
  72     inline-alien ; inline
  73
  74 : emit-alien-unsigned-getter ( node n -- )
  75     '[
  76         _ {
  77             { 1 [ ^^alien-unsigned-1 ] }
  78             { 2 [ ^^alien-unsigned-2 ] }
  79             { 4 [ ^^alien-unsigned-4 ] }
  80         } case ^^tag-fixnum
  81     ] inline-alien-getter ;
  82
  83 : emit-alien-signed-getter ( node n -- )
  84     '[
  85         _ {
  86             { 1 [ ^^alien-signed-1 ] }
  87             { 2 [ ^^alien-signed-2 ] }
  88             { 4 [ ^^alien-signed-4 ] }
  89         } case ^^tag-fixnum
  90     ] inline-alien-getter ;
  91
  92 : emit-alien-integer-setter ( node n -- )
  93     '[
  94         _ {
  95             { 1 [ ##set-alien-integer-1 ] }
  96             { 2 [ ##set-alien-integer-2 ] }
  97             { 4 [ ##set-alien-integer-4 ] }
  98         } case
  99     ] inline-alien-integer-setter ;
 100
 101 : emit-alien-cell-getter ( node -- )
 102     [ ^^alien-cell ^^box-alien ] inline-alien-getter ;
 103
 104 : emit-alien-cell-setter ( node -- )
 105     [ ##set-alien-cell ] inline-alien-cell-setter ;
 106
 107 : emit-alien-float-getter ( node rep -- )
 108     '[
 109         _ {
 110             { float-rep [ ^^alien-float ] }
 111             { double-rep [ ^^alien-double ] }
 112         } case
 113     ] inline-alien-getter ;
 114
 115 : emit-alien-float-setter ( node rep -- )
 116     '[
 117         _ {
 118             { float-rep [ ##set-alien-float ] }
 119             { double-rep [ ##set-alien-double ] }
 120         } case
 121     ] inline-alien-float-setter ;