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

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