Successfully added mutexes protecting freelist access. No behaviour change.

src/c/io/io.c

@@ -167,7 +167,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) {
                 env );
 
     lisp_stdin = lock_object( make_read_stream( file_to_url_file( stdin ),
-                                                c_cons( c_cons
+                                                make_cons( make_cons
                                                         ( c_string_to_lisp_keyword
                                                           ( L"url" ),
                                                           c_string_to_lisp_string
@@ -182,7 +182,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) {
         lisp_stdout =
             lock_object( make_write_stream
                          ( file_to_url_file( stdout ),
-                           c_cons( c_cons
+                           make_cons( make_cons
                                    ( c_string_to_lisp_keyword( L"url" ),
                                      c_string_to_lisp_string
                                      ( L"::system:standard-output" ) ),
@@ -195,7 +195,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) {
         lisp_stderr =
             lock_object( make_write_stream
                          ( file_to_url_file( stderr ),
-                           c_cons( c_cons
+                           make_cons( make_cons
                                    ( c_string_to_lisp_keyword( L"url" ),
                                      c_string_to_lisp_string
                                      ( L"::system:standard-output" ) ),
@@ -422,7 +422,7 @@ struct pso_pointer add_meta_integer( struct pso_pointer meta, char32_t *key,
                                      long int value ) {
 	// todo: issue #21: must have stack frame passed in.
     return
-        c_cons( c_cons
+        make_cons( make_cons
                 ( c_string_to_lisp_keyword( key ), make_integer( value ) ),
                 meta );
 }
@@ -435,7 +435,7 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, char32_t *key,
     mbstowcs( buffer, value, strlen( value ) + 1 );
 
     return
-        c_cons( c_cons
+        make_cons( make_cons
                 ( c_string_to_lisp_keyword( key ),
                   c_string_to_lisp_string( buffer ) ), meta );
 }

src/c/memory/memory.c

@@ -7,18 +7,23 @@
  *  Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+#include <pthread.h>
 #include <stdbool.h>
 #include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
 
 #include "debug.h"
 
 #include "memory/memory.h"
 #include "memory/node.h"
+#include "memory/page.h"
 #include "memory/pointer.h"
 #include "memory/pso.h"
 #include "memory/pso2.h"
 #include "memory/tags.h"
 
+#include "ops/truth.h"
 #include "payloads/exception.h"
 
 #include "ops/bind.h"
@@ -29,6 +34,11 @@
  */
 struct pso_pointer freelists[MAX_SIZE_CLASS];
 
+/**
+ * Mutices to lock the freelists during access.
+ */
+pthread_mutex_t freelists_mutices[MAX_SIZE_CLASS];
+
 /**
  * @brief Flag to prevent re-initialisation.
  */
@@ -63,3 +73,64 @@ struct pso_pointer initialise_memory( uint32_t node ) {
 
     return t;
 }
+
+/**
+ * @brief Pop an object off the freelist for the specified `size_class`.
+ */
+struct pso_pointer pop_freelist( uint8_t size_class) {
+	// `t`, because if `allocate_page` fails it will be set to `nil`.
+	struct pso_pointer result = t;
+		
+	if ( size_class <= MAX_SIZE_CLASS ) {
+	    if ( nilp( freelists[size_class] ) ) {
+	        result = allocate_page( size_class );
+	    }
+
+	    if ( nilp( result ) ) {
+	        fputws( L"FATAL: Page space exhausted\n", stderr );
+	        exit( 1 );          // TODO: we don't want to do this! Somehow, we need to
+	        // recover a workable environment, ideally by throwing a pre-made
+	        // exception.
+	    }
+
+	    if ( !exceptionp( result ) && !nilp( result ) ) {
+			pthread_mutex_lock( &freelists_mutices[size_class]);
+	        result = freelists[size_class];
+	        struct pso2 *object = pointer_to_object( result );
+	        freelists[size_class] = object->payload.free.next;
+			pthread_mutex_unlock(&freelists_mutices[size_class]);
+
+	        /* the object ought already to have the right size class in its tag
+	         * because it was popped off the freelist for that size class. */
+	        if ( object->header.tag.bytes.size_class != size_class ) {
+	            // TODO: return an exception instead? Or warn, set it, and continue?
+	        }
+	        /* the objext ought to have a reference count ot zero, because it's 
+	         * on the freelist, but again we should sanity check. */
+	        if ( object->header.count != 0 ) {
+	            fwprintf( stderr, 
+					L"WARNING: Request to allocate object of size class %d, which is not implemented", 
+					size_class);
+	        }
+	    }
+	}                           // TODO: else throw exception
+	
+	return result;
+}
+
+void push_freelist( struct pso_pointer p) {
+	struct pso2 *obj = pointer_to_object( p );
+	uint8_t size_class = ( obj->header.tag.bytes.size_class );
+
+	strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG,
+	         TAGLENGTH );
+	
+	pthread_mutex_lock( &freelists_mutices[size_class]);
+
+	if ( size_class <= MAX_SIZE_CLASS ) {
+		obj->payload.free.next = freelists[size_class];
+		freelists[size_class] = p;
+	}
+	
+	pthread_mutex_unlock(&freelists_mutices[size_class]);
+}

src/c/memory/memory.h

@@ -9,6 +9,7 @@
 
 #ifndef __psse_memory_memory_h
 #define __psse_memory_memory_h
+#include <pthread.h>
 
 #include "memory/pointer.h"
 
@@ -25,6 +26,10 @@
 
 struct pso_pointer initialise_memory(  );
 
+struct pso_pointer pop_freelist( uint8_t size_class);
+void push_freelist( struct pso_pointer p);
+
 extern struct pso_pointer out_of_memory_exception;
 extern struct pso_pointer freelists[];
+extern pthread_mutex_t freelists_mutices[];
 #endif

src/c/memory/page.c

@@ -319,11 +319,11 @@ struct pso_pointer allocate_page( uint8_t size_class ) {
                               L"\nAllocated page %d for objects of size class %x.\n",
                               npages_allocated, size_class );
 
+				pthread_mutex_lock( &freelists_mutices[size_class]);
                 freelists[size_class] =
                     initialise_page( ( union page * ) pg, npages_allocated,
                                      size_class, freelists[size_class] );
-
+				pthread_mutex_unlock( &freelists_mutices[size_class]);
-//                result = freelists[size_class];
 
                 debug_printf( DEBUG_ALLOC, 0,
                               L"Initialised page %d; freelist for size class %x updated with head at page %d, offset %d.\n",

src/c/memory/pso.c

@@ -19,6 +19,7 @@
 #include <stdint.h>
 #include <stdlib.h>
 #include <string.h>
+#include <wchar.h>
 
 #include "debug.h"
 
@@ -35,15 +36,24 @@
 
  /**
   * @brief Allocate an object of this size_class with this tag.
+  *
+  * All objects that are allocated (after completion of init)) should be linked
+  * onto the `locals` slot on a stack frame. This guarantees
+  * 1. that they get `inc_ref`ed; and that, 
+  * 2. if nothing else hangs onto them they will be reclaimed when that stack
+  *    frame is reclaimed.
+  * for some objects (e.g. those cons cells on the locals list) this isn't 
+  * possible due to infinite recursion, but those special cases need to be
+  * audited carefully
   * 
+  * @param stack_pointer C (NOT Lisp!) pointer to an active stack frame (or
+  *	NULL, but only during initialisation).
   * @param tag The tag. Only the first three bytes will be used;
   * @param size_class The size class for the object to be allocated;
   * @return struct pso_pointer a pointer to the newly allocated object
   */
-struct pso_pointer allocate( char *tag, uint8_t size_class ) {
+struct pso_pointer allocate( /* struct pso4 * stack_pointer,*/ char *tag, uint8_t size_class ) {
 	// todo: issue #21: must have stack frame passed in.
-    // `t`, because if `allocate_page` fails it will be set to `nil`.
-    struct pso_pointer result = t;
 
 #ifdef DEBUG
     debug_printf( DEBUG_ALLOC, 0,
@@ -51,41 +61,26 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) {
                   size_class, tag );
 #endif
 
-    if ( size_class <= MAX_SIZE_CLASS ) {
+	struct pso_pointer result = pop_freelist(size_class); 
-        if ( nilp( freelists[size_class] ) ) {
-            result = allocate_page( size_class );
-        }
 
-        if ( nilp( result ) ) {
+	if (!nilp( result)) {
-            fputws( L"FATAL: Page space exhausted\n", stderr );
+		strncpy( ( char * ) ( pointer_to_object(result)->header.tag.bytes.mnemonic ), tag,
-            exit( 1 );          // TODO: we don't want to do this! Somehow, we need to
+		         TAGLENGTH );
-            // recover a workable environment, ideally by throwing a pre-made
+	
-            // exception.
+		debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ",
-        }
+		              result.page, result.offset );
-
+//			if ( stack_pointer != NULL && 
-        if ( !exceptionp( result ) && !nilp( result ) ) {
+//				(stack_pointer->header.tag.value & 0xffffff) == STACKTV) {
-            result = freelists[size_class];
+//				struct pso_pointer locals = make_cons(result,
-            struct pso2 *object = pointer_to_object( result );
+//					 stack_pointer->payload.stack_frame.locals);
-            freelists[size_class] = object->payload.free.next;
+//				stack_pointer->payload.stack_frame.locals = locals;
-
+//				
-            strncpy( ( char * ) ( object->header.tag.bytes.mnemonic ), tag,
+//			} else {
-                     TAGLENGTH );
+//				fputws( L"WARNING: No stack frame passed to `allocate`.\n", stderr);
-
+//			}
-            debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ",
+		} else {
-                          result.page, result.offset );
+	//		TODO: throw exception
-
+		}
-            /* the object ought already to have the right size class in its tag
-             * because it was popped off the freelist for that size class. */
-            if ( object->header.tag.bytes.size_class != size_class ) {
-                // TODO: return an exception instead? Or warn, set it, and continue?
-            }
-            /* the objext ought to have a reference count ot zero, because it's 
-             * on the freelist, but again we should sanity check. */
-            if ( object->header.count != 0 ) {
-                // TODO: return an exception instead? Or warn, set it, and continue?
-            }
-        }
-    }                           // TODO: else throw exception
 
 #ifdef DEBUG
     debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC,
@@ -208,19 +203,7 @@ struct pso_pointer free_object( struct pso_pointer p ) {
         obj->payload.words[i] = 0;
     }
 
-
+	push_freelist(p);
-
-    strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG,
-             TAGLENGTH );
-#ifdef DEBUG
-    debug_printf( DEBUG_ALLOC, 0,
-                  L"Freeing object of size class %d at {%d, %d, %d}",
-                  size_class, p.node, p.page, p.offset );
-#endif
-
-    /* TODO: obtain mutex on freelist */
-    obj->payload.free.next = freelists[size_class];
-    freelists[size_class] = p;
 
     return result;
 }

src/c/ops/bind.c

@@ -35,12 +35,12 @@ struct pso_pointer lisp_bind(
     struct pso_pointer value = fetch_arg( frame, 1 );
     struct pso_pointer store = fetch_arg( frame, 2 );
 
-    return c_cons( c_cons( key, value ), store );
+    return make_cons( make_cons( key, value ), store );
 }
 
 struct pso_pointer c_bind( struct pso_pointer key,
                            struct pso_pointer value,
                            struct pso_pointer store ) {
 	// todo: issue #21: must have stack frame passed in.
-    return c_cons( c_cons( key, value ), store );
+    return make_cons( make_cons( key, value ), store );
 }

src/c/ops/eval_apply.c

@@ -84,11 +84,11 @@ struct pso_pointer eval(
             //         break;
         default:
             result =
-                make_exception( c_cons
+                make_exception( make_cons
                                 ( c_string_to_lisp_string
                                   ( L"Can't yet evaluate things of this type: " ),
                                   result ), frame_pointer,
-                                c_cons( c_cons
+                                make_cons( make_cons
                                         ( c_string_to_lisp_keyword( L"tag" ),
                                           get_tag_string( result ) ), nil ),
                                 nil );

src/c/ops/list_ops.c

@@ -66,7 +66,7 @@ struct pso_pointer cons(
     struct pso4 *frame = pointer_to_pso4( frame_pointer );
 
 #endif
-    return c_cons( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) );
+    return make_cons( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) );
 }
 
 #endif

src/c/ops/repl.c

@@ -52,7 +52,7 @@ void c_repl( bool show_prompt ) {
     signal( SIGINT, int_handler );
     debug_print( L"Entered repl\n", DEBUG_REPL, 0 );
 
-    struct pso_pointer env = consp( oblist ) ? oblist : c_cons( oblist, nil );
+    struct pso_pointer env = consp( oblist ) ? oblist : make_cons( oblist, nil );
     struct pso_pointer input_stream = c_assoc( lisp_io_in, env );
     struct pso_pointer output_stream = c_assoc( lisp_io_out, env );
 

src/c/ops/reverse.c

@@ -44,7 +44,7 @@ struct pso_pointer c_reverse( struct pso_pointer sequence ) {
         struct pso2 *object = pointer_to_object( cursor );
         switch ( get_tag_value( cursor ) ) {
             case CONSTV:
-                result = c_cons( c_car( cursor ), result );
+                result = make_cons( c_car( cursor ), result );
                 break;
             case KEYTV:
                 // TODO: should you be able to reverse keywords and symbols?
@@ -65,7 +65,7 @@ struct pso_pointer c_reverse( struct pso_pointer sequence ) {
                 break;
             default:
                 result =
-                    make_exception( c_cons( c_string_to_lisp_string
+                    make_exception( make_cons( c_string_to_lisp_string
                                             ( L"Invalid object in sequence" ),
                                             cursor ), nil, nil, nil );
                 goto exit;

src/c/payloads/cons.c

@@ -30,7 +30,7 @@
  * @param cdr the pointer which should form the cdr of this cons cell.
  * @return struct pso_pointer a pointer to the newly allocated cons cell.
  */
-struct pso_pointer c_cons(struct pso_pointer car, struct pso_pointer cdr) {
+struct pso_pointer make_cons(struct pso_pointer car, struct pso_pointer cdr) {
 	// todo: issue #21: must have stack frame passed in.
     struct pso_pointer result = allocate( CONSTAG, 2 );
 
@@ -84,7 +84,7 @@ struct pso_pointer c_cdr(struct pso_pointer p) {
             break;
         default:
             result =
-                make_exception( c_cons
+                make_exception( make_cons
                                 ( c_string_to_lisp_string
                                   ( L"Invalid type for cdr" ),
                                   get_tag_string( p ) ), nil, nil, nil );

src/c/payloads/cons.h

@@ -31,7 +31,7 @@ struct pso_pointer c_car( struct pso_pointer cons );
 struct pso_pointer c_cdr( struct pso_pointer cons );
 
 // todo: issue #21: must have stack frame passed in.
-struct pso_pointer c_cons( struct pso_pointer car, struct pso_pointer cdr );
+struct pso_pointer make_cons( struct pso_pointer car, struct pso_pointer cdr );
 
 struct pso_pointer destroy_cons( struct pso_pointer fp,
                                  struct pso_pointer env );

src/c/payloads/stack.c

@@ -72,7 +72,7 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
 
         for ( ; cursor < arg_count; cursor++ ) {
             more_args =
-                c_cons( va_arg( args, struct pso_pointer ), more_args );
+                make_cons( va_arg( args, struct pso_pointer ), more_args );
         }
 
         frame->payload.stack_frame.more = c_reverse( more_args );

src/c/payloads/stack.h

@@ -31,6 +31,10 @@ struct stack_frame_payload {
     struct pso_pointer more;
     /** the function to be called. */
     struct pso_pointer function;
+	/** the execute-time environment */
+	struct pso_pointer env;
+	/** a list of objects created in the context of this frame */
+	struct pso_pointer locals;
     /** the number of arguments provided. */
     uint32_t args;
     /** the depth of the stack below this frame */