httpd responder changes, fix gc race

TODO.FACTOR.txt

@@ -22,15 +22,19 @@ FFI:
 
 - clean up listener's action popups
 - jedit ==> jedit-word, jedit takes a file name
-- introduce ifte* and ?str-head/?str-tail where appropriate
 - namespace clone drops static var bindings
+- add a socket timeout
+- fix error postoning -- not all errors thrown by i/o code are
+  postponed
+- sbuf-hashcode
+- vector-hashcode
+- some way to run httpd from command line
 
 + bignums:
 
 - move some s48_ functions into bignum.c
 - remove unused functions
 
-- add a socket timeout
 - >lower, >upper for strings
 - accept multi-line input in listener
 
@@ -75,12 +79,6 @@ FFI:
 
 + native:
 
-- fix error postoning -- not all errors thrown by i/o code are
-  postponed
-- sbuf-hashcode
-- vector-hashcode
-- irc: stack underflow?
-- gc call in the middle of some ops might affect callstack
 - better i/o scheduler
 
 + JVM compiler:
@@ -98,7 +96,6 @@ FFI:
 
 + misc:
 
-- some way to run httpd from command line
 - don't rehash strings on every startup
 - 'cascading' styles
 - ditch expand
@@ -106,7 +103,6 @@ FFI:
 
 + httpd:
 
-- 'default responder' for when we go to root
 - wiki responder:
   - port to native
   - text styles

library/httpd/default-responders.factor

@@ -75,6 +75,8 @@ global [ <namespace> "httpd-responders" set ] bind
     [ resource-responder ] "get" set
 ] extend add-responder
 
+"file" set-default-responder
+
 !        <responder> [
 !            "wiki" "responder" set
 !            [ wiki-get-responder ] "get" set

library/httpd/responder.factor

@@ -76,25 +76,44 @@ USE: strings
         "404" "httpd-responders" get get*
     ] unless* ;
 
+: default-responder ( -- responder )
+    "default" get-responder ;
+
+: set-default-responder ( name -- )
+    get-responder "default" "httpd-responders" get set* ;
+
 : responder-argument ( argument -- argument )
     dup f-or-"" [ drop "default-argument" get ] when ;
 
 : call-responder ( method argument responder -- )
     [ responder-argument swap get call ] bind ;
 
-: trim-/ ( url -- url )
+: serve-default-responder ( method url -- )
-    #! Trim a leading /, if there is one.
+    default-responder call-responder ;
-    "/" ?str-head drop ;
+
+: serve-explicit-responder ( method url -- )
+    "/" split1 dup [
+        swap get-responder call-responder
+    ] [
+        ! Just a responder name by itself
+        drop "request" get "/" cat2 redirect drop
+    ] ifte ;
 
 : log-responder ( url -- )
     "Calling responder " swap cat2 log ;
 
+: trim-/ ( url -- url )
+    #! Trim a leading /, if there is one.
+    "/" ?str-head drop ;
+
 : serve-responder ( method url -- )
-    dup log-responder trim-/ "/" split1 dup [
+    #! Responder URLs come in two forms:
-        swap get-responder call-responder
+    #! /foo/bar... - default-responder used
+    #! /responder/foo/bar - responder foo, argument bar
+    dup log-responder trim-/ "responder/" ?str-head [
+        serve-explicit-responder
     ] [
-        ! Just a responder name by itself
+        serve-default-responder
-        drop "/" swap "/" cat3 redirect drop
     ] ifte ;
 
 : no-such-responder ( -- )

native/memory.c

@@ -36,6 +36,7 @@ void init_arena(CELL size)
 	init_zone(&prior,size);
 	allot_profiling = false;
 	gc_in_progress = false;
+	gc_protect = false;
 }
 
 void allot_profile_step(CELL a)
@@ -59,21 +60,21 @@ void allot_profile_step(CELL a)
 
 void check_memory(void)
 {
-	if(active.here > active.alarm)
+	if(gc_protect)
-	{
+		return;
-		if(active.here > active.limit)
-		{
-			fprintf(stderr,"Out of memory\n");
-			fprintf(stderr,"active.base  = %ld\n",active.base);
-			fprintf(stderr,"active.here  = %ld\n",active.here);
-			fprintf(stderr,"active.limit = %ld\n",active.limit);
-			fflush(stderr);
-			exit(1);
-		}
 
-		/* Execute the 'garbage-collection' word */
+	if(active.here > active.limit)
-		call(userenv[GC_ENV]);
+	{
+		fprintf(stderr,"Out of memory\n");
+		fprintf(stderr,"active.base  = %ld\n",active.base);
+		fprintf(stderr,"active.here  = %ld\n",active.here);
+		fprintf(stderr,"active.limit = %ld\n",active.limit);
+		fflush(stderr);
+		exit(1);
 	}
+
+	/* Execute the 'garbage-collection' word */
+	call(userenv[GC_ENV]);
 }
 
 void flip_zones()

native/memory.h

@@ -10,6 +10,9 @@ ZONE prior;
 
 bool allot_profiling;
 
+/* we can temporarily disable GC */
+bool gc_protect;
+
 void* alloc_guarded(CELL size);
 void init_zone(ZONE* zone, CELL size);
 void init_arena(CELL size);
@@ -29,7 +32,8 @@ INLINE void* allot(CELL a)
 	active.here += align8(a);
 	if(allot_profiling)
 		allot_profile_step(align8(a));
-	check_memory();
+	if(active.here > active.alarm)
+		check_memory();
 	return (void*)h;
 }
 

native/stack.c

@@ -101,7 +101,10 @@ void primitive_datastack(void)
 
 void primitive_callstack(void)
 {
+	/* we don't want gc word to end up on callstack. */
+	gc_protect = true;
 	dpush(tag_object(stack_to_vector(cs_bot,cs)));
+	gc_protect = false;
 }
 
 /* Returns top of stack */