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