109 lines
3.2 KiB
Factor
109 lines
3.2 KiB
Factor
! Copyright (C) 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors kernel sequences alien math classes.algebra
|
|
fry locals combinators cpu.architecture
|
|
compiler.tree.propagation.info
|
|
compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
|
|
compiler.cfg.utilities ;
|
|
IN: compiler.cfg.intrinsics.alien
|
|
|
|
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
|
|
ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
|
|
|
|
: (prepare-alien-accessor) ( class -- offset-vreg )
|
|
[ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
|
|
|
|
: prepare-alien-accessor ( infos -- offset-vreg )
|
|
<reversed> [ second class>> ] [ first ] bi
|
|
dup value-info-small-fixnum? [
|
|
literal>> (prepare-alien-accessor-imm)
|
|
] [ drop (prepare-alien-accessor) ] if ;
|
|
|
|
:: inline-alien ( node quot test -- )
|
|
[let | infos [ node node-input-infos ] |
|
|
infos test call
|
|
[ infos prepare-alien-accessor quot call ]
|
|
[ node emit-primitive ]
|
|
if
|
|
] ; inline
|
|
|
|
: inline-alien-getter? ( infos -- ? )
|
|
[ first class>> c-ptr class<= ]
|
|
[ second class>> fixnum class<= ]
|
|
bi and ;
|
|
|
|
: inline-alien-getter ( node quot -- )
|
|
'[ @ ds-push ]
|
|
[ inline-alien-getter? ] inline-alien ; inline
|
|
|
|
: inline-alien-setter? ( infos class -- ? )
|
|
'[ first class>> _ class<= ]
|
|
[ second class>> c-ptr class<= ]
|
|
[ third class>> fixnum class<= ]
|
|
tri and and ;
|
|
|
|
: inline-alien-integer-setter ( node quot -- )
|
|
'[ ds-pop ^^untag-fixnum @ ]
|
|
[ fixnum inline-alien-setter? ]
|
|
inline-alien ; inline
|
|
|
|
: inline-alien-cell-setter ( node quot -- )
|
|
[ dup node-input-infos first class>> ] dip
|
|
'[ ds-pop _ ^^unbox-c-ptr @ ]
|
|
[ pinned-c-ptr inline-alien-setter? ]
|
|
inline-alien ; inline
|
|
|
|
: inline-alien-float-setter ( node quot -- )
|
|
'[ ds-pop ^^unbox-float @ ]
|
|
[ float inline-alien-setter? ]
|
|
inline-alien ; inline
|
|
|
|
: emit-alien-unsigned-getter ( node n -- )
|
|
'[
|
|
_ {
|
|
{ 1 [ ^^alien-unsigned-1 ] }
|
|
{ 2 [ ^^alien-unsigned-2 ] }
|
|
{ 4 [ ^^alien-unsigned-4 ] }
|
|
} case ^^tag-fixnum
|
|
] inline-alien-getter ;
|
|
|
|
: emit-alien-signed-getter ( node n -- )
|
|
'[
|
|
_ {
|
|
{ 1 [ ^^alien-signed-1 ] }
|
|
{ 2 [ ^^alien-signed-2 ] }
|
|
{ 4 [ ^^alien-signed-4 ] }
|
|
} case ^^tag-fixnum
|
|
] inline-alien-getter ;
|
|
|
|
: emit-alien-integer-setter ( node n -- )
|
|
'[
|
|
_ {
|
|
{ 1 [ ##set-alien-integer-1 ] }
|
|
{ 2 [ ##set-alien-integer-2 ] }
|
|
{ 4 [ ##set-alien-integer-4 ] }
|
|
} case
|
|
] inline-alien-integer-setter ;
|
|
|
|
: emit-alien-cell-getter ( node -- )
|
|
[ ^^alien-cell ^^box-alien ] inline-alien-getter ;
|
|
|
|
: emit-alien-cell-setter ( node -- )
|
|
[ ##set-alien-cell ] inline-alien-cell-setter ;
|
|
|
|
: emit-alien-float-getter ( node reg-class -- )
|
|
'[
|
|
_ {
|
|
{ single-float-regs [ ^^alien-float ] }
|
|
{ double-float-regs [ ^^alien-double ] }
|
|
} case ^^box-float
|
|
] inline-alien-getter ;
|
|
|
|
: emit-alien-float-setter ( node reg-class -- )
|
|
'[
|
|
_ {
|
|
{ single-float-regs [ ##set-alien-float ] }
|
|
{ double-float-regs [ ##set-alien-double ] }
|
|
} case
|
|
] inline-alien-float-setter ;
|