From a1b730e86733335f32624fda57475139c52f2c4f Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 26 Nov 2011 20:20:55 -0800
Subject: [PATCH] namespaces: make set-global/get-global foldable Store the
 globals hashtable as an array of boxes so that the key-to-reference mapping
 is constant. Use a singleton and an unfoldable "box-at" word so that
 get-global and set-global optimize to direct operations on the associated box
 when the variable name is a compile-time constant. Fixes #200.

---
 basis/bootstrap/image/image.factor      |  4 ++--
 core/namespaces/namespaces-tests.factor |  5 ++++-
 core/namespaces/namespaces.factor       | 28 +++++++++++++++++++++++--
 3 files changed, 32 insertions(+), 5 deletions(-)

diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index dc8343e6fa..f162cd71fe 100755
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -503,11 +503,11 @@ M: quotation '
     {
         dictionary source-files builtins
         update-map implementors-map
-    } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
+    } [ [ bootstrap-word ] [ get 1array ] bi ] H{ } map>assoc
     {
         class<=-cache class-not-cache classes-intersect-cache
         class-and-cache class-or-cache next-method-quot-cache
-    } [ H{ } clone ] H{ } map>assoc assoc-union
+    } [ H{ } clone 1array ] H{ } map>assoc assoc-union
     bootstrap-global set ;
 
 : emit-jit-data ( -- )
diff --git a/core/namespaces/namespaces-tests.factor b/core/namespaces/namespaces-tests.factor
index 1397028f24..12ca3f6a20 100644
--- a/core/namespaces/namespaces-tests.factor
+++ b/core/namespaces/namespaces-tests.factor
@@ -1,4 +1,5 @@
-USING: kernel namespaces tools.test words ;
+USING: assocs compiler.tree.debugger kernel namespaces
+tools.test words ;
 IN: namespaces.tests
 
 H{ } clone "test-namespace" set
@@ -35,3 +36,5 @@ SYMBOL: toggle-test
 [ t ] [ toggle-test [ on ] [ get ] bi ] unit-test
 [ f ] [ toggle-test [ off ] [ get ] bi ] unit-test
 
+[ t ] [ [ test-initialize get-global ] { at* set-at } inlined? ] unit-test
+[ t ] [ [ test-initialize set-global ] { at* set-at } inlined? ] unit-test
diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor
index 6e2256806e..dc2b34a21b 100644
--- a/core/namespaces/namespaces.factor
+++ b/core/namespaces/namespaces.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2003, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel vectors sequences hashtables
+USING: kernel vectors sequences sequences.private hashtables
 arrays kernel.private math strings assocs ;
 IN: namespaces
 
@@ -11,13 +11,37 @@ IN: namespaces
 : >n ( namespace -- ) namestack* push ;
 : ndrop ( -- ) namestack* pop* ;
 
+SINGLETON: +globals+
+
+: get-global-hashtable ( -- table )
+    OBJ-GLOBAL special-object { hashtable } declare ; inline
+
+: box-at ( key -- box )
+    get-global-hashtable
+    2dup at [ 2nip ] [ [ f 1array ] 2dip [ set-at ] 2curry keep ] if* ; foldable
+
+: box> ( box -- value )
+    0 swap nth-unsafe ; inline
+
+: >box ( value box -- )
+    0 swap set-nth-unsafe ; inline
+
+M: +globals+ at*
+    drop box-at box> dup ; inline
+
+M: +globals+ set-at
+    drop box-at >box ; inline
+
+M: +globals+ delete-at
+    drop box-at f swap >box ; inline
+
 PRIVATE>
 
 : namespace ( -- namespace ) namestack* last ; inline
 : namestack ( -- namestack ) namestack* clone ;
 : set-namestack ( namestack -- )
     >vector CONTEXT-OBJ-NAMESTACK set-context-object ;
-: global ( -- g ) OBJ-GLOBAL special-object { hashtable } declare ; inline
+: global ( -- g ) +globals+ ; inline
 : init-namespaces ( -- ) global 1array set-namestack ;
 : get ( variable -- value ) namestack* assoc-stack ; inline
 : set ( value variable -- ) namespace set-at ;