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