From c92e54b5608001ee25f2236ea7789b3bda14c8ea Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Sep 2009 02:22:54 -0500
Subject: [PATCH] compiler.cfg.intrinsics: fix type detection on the alien type
for vector accessors
---
.../cfg/intrinsics/alien/alien.factor | 21 ++++++++++++-------
.../compiler/cfg/intrinsics/simd/simd.factor | 12 +++++------
2 files changed, 18 insertions(+), 15 deletions(-)
diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor
index e9fe896502..2b903813a0 100644
--- a/basis/compiler/cfg/intrinsics/alien/alien.factor
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@@ -20,10 +20,6 @@ IN: compiler.cfg.intrinsics.alien
^^box-displaced-alien ds-push
] [ emit-primitive ] if ;
-: prepare-alien-accessor ( infos -- offset-vreg )
- <reversed> second class>>
- [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
-
:: inline-alien ( node quot test -- )
[let | infos [ node node-input-infos ] |
infos test call
@@ -37,8 +33,14 @@ IN: compiler.cfg.intrinsics.alien
[ second class>> fixnum class<= ]
bi and ;
+: prepare-alien-accessor ( info -- offset-vreg )
+ class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+
+: prepare-alien-getter ( infos -- offset-vreg )
+ first prepare-alien-accessor ;
+
: inline-alien-getter ( node quot -- )
- '[ prepare-alien-accessor @ ds-push ]
+ '[ prepare-alien-getter @ ds-push ]
[ inline-alien-getter? ] inline-alien ; inline
: inline-alien-setter? ( infos class -- ? )
@@ -47,18 +49,21 @@ IN: compiler.cfg.intrinsics.alien
[ third class>> fixnum class<= ]
tri and and ;
+: prepare-alien-setter ( infos -- offset-vreg )
+ second prepare-alien-accessor ;
+
: inline-alien-integer-setter ( node quot -- )
- '[ prepare-alien-accessor ds-pop ^^untag-fixnum @ ]
+ '[ prepare-alien-setter ds-pop ^^untag-fixnum @ ]
[ fixnum inline-alien-setter? ]
inline-alien ; inline
: inline-alien-cell-setter ( node quot -- )
- '[ [ prepare-alien-accessor ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
+ '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
[ pinned-c-ptr inline-alien-setter? ]
inline-alien ; inline
: inline-alien-float-setter ( node quot -- )
- '[ prepare-alien-accessor ds-pop @ ]
+ '[ prepare-alien-setter ds-pop @ ]
[ float inline-alien-setter? ]
inline-alien ; inline
diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor
index 25b30c95da..f1a6f986df 100644
--- a/basis/compiler/cfg/intrinsics/simd/simd.factor
+++ b/basis/compiler/cfg/intrinsics/simd/simd.factor
@@ -35,15 +35,10 @@ IN: compiler.cfg.intrinsics.simd
ds-push
] emit-vector-op ;
-: inline-alien-vector-setter ( node quot -- )
- '[ ds-drop prepare-alien-accessor ds-pop @ ]
- [ byte-array inline-alien-setter? ]
- inline-alien ; inline
-
: emit-alien-vector ( node -- )
dup [
'[
- ds-drop prepare-alien-accessor
+ ds-drop prepare-alien-getter
_ ^^alien-vector ds-push
]
[ inline-alien-getter? ] inline-alien
@@ -52,6 +47,9 @@ IN: compiler.cfg.intrinsics.simd
: emit-set-alien-vector ( node -- )
dup [
'[
+ ds-drop prepare-alien-setter ds-pop
_ ##set-alien-vector
- ] inline-alien-vector-setter
+ ]
+ [ byte-array inline-alien-setter? ]
+ inline-alien
] with emit-vector-op ;