From 86358b1dc3c0007c808a6e8f71493a1812ebc1c0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 May 2010 00:33:36 -0400
Subject: [PATCH] alien.data: add with-scoped-allocation combinator for
 stack-allocating C data

---
 basis/alien/data/data.factor                    | 17 ++++++++++++++++-
 basis/compiler/cfg/intrinsics/intrinsics.factor |  2 ++
 basis/compiler/cfg/intrinsics/misc/misc.factor  |  6 ++++++
 basis/compiler/tests/alien.factor               |  7 ++++++-
 .../propagation/known-words/known-words.factor  |  4 +++-
 5 files changed, 33 insertions(+), 3 deletions(-)

diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor
index 9922463b33..df57e6faa4 100644
--- a/basis/alien/data/data.factor
+++ b/basis/alien/data/data.factor
@@ -1,7 +1,8 @@
 ! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
 USING: accessors alien alien.c-types alien.arrays alien.strings
 arrays byte-arrays cpu.architecture fry io io.encodings.binary
-io.files io.streams.memory kernel libc math sequences words ;
+io.files io.streams.memory kernel libc math sequences words
+macros ;
 IN: alien.data
 
 GENERIC: require-c-array ( c-type -- )
@@ -74,3 +75,17 @@ M: array c-type-boxer-quot
     unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
 
 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
+
+ERROR: local-allocation-error ;
+
+<PRIVATE
+
+: (local-allot) ( size -- alien ) local-allocation-error ;
+
+MACRO: (local-allots) ( c-types -- quot )
+    [ dup c-type-boxer-quot '[ _ heap-size (local-allot) @ ] ] map [ ] join ;
+
+PRIVATE>
+
+: with-scoped-allocation ( c-types quot -- )
+    [ (local-allots) ] dip call ; inline
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index dfdffa41db..11d063c430 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -14,6 +14,7 @@ compiler.cfg.intrinsics.misc
 compiler.cfg.comparisons ;
 QUALIFIED: alien
 QUALIFIED: alien.accessors
+QUALIFIED: alien.data.private
 QUALIFIED: alien.c-types
 QUALIFIED: kernel
 QUALIFIED: arrays
@@ -64,6 +65,7 @@ IN: compiler.cfg.intrinsics
     { byte-arrays:<byte-array> [ emit-<byte-array> ] }
     { byte-arrays:(byte-array) [ emit-(byte-array) ] }
     { kernel:<wrapper> [ emit-simple-allot ] }
+    { alien.data.private:(local-allot) [ emit-local-allot ] }
     { alien:<displaced-alien> [ emit-<displaced-alien> ] }
     { alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] }
     { alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] }
diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor
index 31c3bac37b..03b8fb47f1 100644
--- a/basis/compiler/cfg/intrinsics/misc/misc.factor
+++ b/basis/compiler/cfg/intrinsics/misc/misc.factor
@@ -52,3 +52,9 @@ IN: compiler.cfg.intrinsics.misc
         0 int-rep f ^^load-memory-imm
         hashcode-shift ^^shr-imm
     ] unary-op ;
+
+: emit-local-allot ( node -- )
+    dup node-input-infos first literal>> dup integer?
+    [ nip ds-drop f ^^local-allot ^^box-alien ds-push ]
+    [ drop emit-primitive ]
+    if ;
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index fc7e740de3..c106fb1774 100755
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -5,7 +5,7 @@ io.backend io.pathnames io.streams.string kernel
 math memory namespaces namespaces.private parser
 quotations sequences specialized-arrays stack-checker
 stack-checker.errors system threads tools.test words
-alien.complex concurrency.promises ;
+alien.complex concurrency.promises alien.data ;
 FROM: alien.c-types => float short ;
 SPECIALIZED-ARRAY: float
 SPECIALIZED-ARRAY: char
@@ -761,3 +761,8 @@ mingw? [
 
 [ S{ test-struct-11 f 7 -3 } ]
 [ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test
+
+! Stack allocation
+: blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ;
+
+[ 3 ] [ blah ] unit-test
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index aab40ec77c..c0725b4fd8 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -7,7 +7,7 @@ layouts words sequences sequences.private arrays assocs classes
 classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private
 slots.private definitions strings.private vectors hashtables
-generic quotations alien
+generic quotations alien alien.data.private
 stack-checker.dependencies
 compiler.tree.comparisons
 compiler.tree.propagation.info
@@ -338,3 +338,5 @@ flog fpow fsqrt facosh fasinh fatanh } [
 
 \ fixnum-max { fixnum fixnum } "input-classes" set-word-prop
 \ fixnum-max [ interval-max ] [ fixnum-valued ] binary-op
+
+\ (local-allot) { alien } "default-output-classes" set-word-prop