From 95c1abe468165ee909de907e1c13ee72a9c94379 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Wed, 6 Mar 2013 19:41:37 -0800
Subject: [PATCH] heaps: performance improvements.

---
 basis/heaps/heaps.factor | 28 +++++++++++++++++++---------
 1 file changed, 19 insertions(+), 9 deletions(-)

diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor
index f103c25659..049b27d058 100644
--- a/basis/heaps/heaps.factor
+++ b/basis/heaps/heaps.factor
@@ -1,8 +1,10 @@
 ! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman,
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences arrays assocs sequences.private
-growable accessors math.order summary vectors fry combinators ;
+USING: accessors arrays assocs combinators fry growable kernel
+kernel.private math math.order math.private sequences
+sequences.private summary vectors ;
+
 IN: heaps
 
 GENERIC: heap-push* ( value key heap -- entry )
@@ -43,14 +45,17 @@ M: heap heap-size ( heap -- n )
 
 <PRIVATE
 
-: left ( n -- m ) 1 shift 1 + ; inline
+: left ( n -- m )
+    { fixnum } declare 1 fixnum-shift-fast 1 fixnum+fast ; inline
 
-: right ( n -- m ) 1 shift 2 + ; inline
+: right ( n -- m )
+    { fixnum } declare 1 fixnum-shift-fast 2 fixnum+fast ; inline
 
-: up ( n -- m ) 1 - 2/ ; inline
+: up ( n -- m )
+    { fixnum } declare 1 fixnum-fast 2/ ; inline
 
 : data-nth ( n heap -- entry )
-    data>> nth-unsafe ; inline
+    data>> nth-unsafe { entry } declare ; inline
 
 : left-value ( n heap -- entry )
     [ left ] dip data-nth ; inline
@@ -150,12 +155,12 @@ M: heap heap-peek ( heap -- value key )
 
 ERROR: bad-heap-delete ;
 
-M: bad-heap-delete summary 
+M: bad-heap-delete summary
     drop "Invalid entry passed to heap-delete" ;
 
 : entry>index ( entry heap -- n )
     over heap>> eq? [ bad-heap-delete ] unless
-    index>> ;
+    index>> { fixnum } declare ; inline
 
 M: heap heap-delete ( entry heap -- )
     [ entry>index ] [ ] bi
@@ -180,7 +185,12 @@ M: heap heap-pop ( heap -- value key )
     [ dup heap-pop swap 2array ]
     produce nip ;
 
+ERROR: not-a-heap obj ;
+
+: check-heap ( heap -- heap )
+    dup heap? [ not-a-heap ] unless ; inline
+
 : slurp-heap ( heap quot: ( elt -- ) -- )
-    over heap-empty? [ 2drop ] [
+    [ check-heap ] dip over heap-empty? [ 2drop ] [
         [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
     ] if ; inline recursive