detect leaked memory at the end of the program

main.leg

@@ -1,6 +1,6 @@
 # main.leg -- C parser + interpreter
 #
-# Last edited: 2025-03-21 11:45:50 by piumarta on m1mbp.local
+# Last edited: 2025-03-21 12:07:42 by piumarta on m1mbp
 
 %{
 ;
@@ -128,7 +128,7 @@ struct Symbol  	   { type_t _type;  char *name; oop value; };
 struct Pair   	   { type_t _type;  oop head, tail; };
 struct String  	   { type_t _type;  int size;  char *elements; };
 struct List   	   { type_t _type;  int size;  oop *elements; };
-struct Memory      { type_t _type;  void *base;  size_t size; };
+struct Memory      { type_t _type;  void *base;  size_t size;  int heap, free; };
 struct Reference   { type_t _type;  oop target; };
 struct Closure	   { type_t _type;  oop function, environment; };
 struct Call   	   { type_t _type;  oop function, arguments, token; };
@@ -633,12 +633,14 @@ oop Map_get(oop map, oop key)
 
 #endif
 
-oop newMemory(void *base, size_t size)
+oop newMemory(void *base, size_t size, int heap)
 {
-    oop obj = new(Memory);
-    obj->Memory.base = base;
-    obj->Memory.size = size;
-    return obj;
+  oop obj = new(Memory);
+  obj->Memory.base = base;
+  obj->Memory.size = size;
+  obj->Memory.heap = heap;
+  obj->Memory.free = 0;
+  return obj;
 }
 
 CTOR1(Reference,   target);
@@ -2522,6 +2524,8 @@ oop prim_assert(int argc, oop *argv, oop env) // array
     return nil;
 }
 
+oop heap = 0;
+
 oop prim_malloc(int argc, oop *argv, oop env) // array
 {
     if (argc != 1) fatal("malloc: wrong number of arguments");
@@ -2531,9 +2535,11 @@ oop prim_malloc(int argc, oop *argv, oop env) // array
 	if (size >= 0) {
 	    if (size > 10*1024*1024)
 		fatal("cowardly refusing to allocate memory of size %zd", size);
-	    void *mem = MALLOC(size);
-	    if (!mem) fatal("malloc(%zd) failed", size);
-	    return newPointer(t_pvoid, newMemory(mem, size), 0);
+	    void *ptr = MALLOC(size);
+	    if (!ptr) fatal("malloc(%zd) failed", size);
+	    oop mem = newMemory(ptr, size, 1);
+	    List_append(heap, mem);
+	    return newPointer(t_pvoid, mem, 0);
 	}
     }
     fatal("malloc: invalid argument: %s", toString(arg));
@@ -2542,17 +2548,23 @@ oop prim_malloc(int argc, oop *argv, oop env) // array
 
 oop prim_free(int argc, oop *argv, oop env) // array
 {
-    if (argc != 1) fatal("free: wrong number of arguments");
-    oop arg = argv[0];
-    if (!is(Pointer,arg)) fatal("free: argument is not a pointer");
-    oop base = get(arg, Pointer,base);
-    switch (getType(base)) {
-	case Integer:	fatal("attempt to free arbitrary pointer %s", toString(arg));
-	case Variable:	fatal("attempt to free pointer to variable %s", toString(arg));
-	case Memory:	FREE(get(base, Memory,base));  break;
-	default:	assert(!"this cannot happen");
+  if (argc != 1) fatal("free: wrong number of arguments");
+  oop arg = argv[0];
+  if (!is(Pointer,arg)) fatal("free: argument is not a pointer");
+  oop base = get(arg, Pointer,base);
+  switch (getType(base)) {
+    case Integer:	fatal("attempt to free arbitrary pointer %s", toString(arg));
+    case Variable:	fatal("attempt to free pointer to variable %s", toString(arg));
+    case Memory: {
+      if (!get(base, Memory,heap)) fatal("freed memory was not allocated in the heap: %s", toString(base));
+      if ( get(base, Memory,free)) fatal("memory freed more than once: %s", toString(base));
+      FREE(get(base, Memory,base));
+      set(base, Memory,free, get(base, Memory,free) + 1);
+      break;
     }
-    return nil;
+    default:	assert(!"this cannot happen");
+  }
+  return nil;
 }
 
 oop prim_exit(int argc, oop *argv, oop env) // array
@@ -3132,41 +3144,41 @@ oop typeCheck(oop exp, oop fntype)
     return 0;
 }
 
-oop getPointer(oop ptr)
+oop getPointer(oop ptr, int delta)
 {
-    oop base   = get(ptr, Pointer,base);
-    int offset = get(ptr, Pointer,offset);
-    oop type   = get(get(ptr, Pointer,type), Tpointer,target);
-    int scale  = typeSize(type);
-    switch (getType(base)) {
-	case Variable: {
-	    if (offset != 0) fatal("pointer to variable no longer points to its variable");
-	    return get(base, Variable,value);
-	}
-	case Memory: {
-	    void *addr = get(base, Memory,base) + offset * scale;
-	    assert(addr < get(base, Memory,base) + get(base, Memory,size));
-	    switch (getType(type)) {
-		case Tchar:    	return newInteger(*(char   *)addr);
-		case Tshort:   	return newInteger(*(short  *)addr);
-		case Tint:     	return newInteger(*(int    *)addr);
-		case Tlong:    	return newInteger(*(long   *)addr);
-		case Tfloat:   	return newFloat  (*(float  *)addr);
-		case Tdouble:  	return newFloat  (*(double *)addr);
-		case Tstruct:   return newStruct(type, base);
-		default:
-		    println(ptr);
-		    fatal("cannot load '%s' from memory pointer", getTypeName(type));
-		    break;
-	    }
-	    break;
-	}
+  oop base   = get(ptr, Pointer,base);
+  int offset = get(ptr, Pointer,offset) + delta;
+  oop type   = get(get(ptr, Pointer,type), Tpointer,target);
+  int scale  = typeSize(type);
+  switch (getType(base)) {
+    case Variable: {
+      if (offset != 0) fatal("pointer to variable no longer points to its variable: %s", toString(ptr));
+      return get(base, Variable,value);
+    }
+    case Memory: {
+      void *addr = get(base, Memory,base) + offset * scale;
+      assert(addr < get(base, Memory,base) + get(base, Memory,size));
+      switch (getType(type)) {
+	case Tchar:    	return newInteger(*(char   *)addr);
+	case Tshort:   	return newInteger(*(short  *)addr);
+	case Tint:     	return newInteger(*(int    *)addr);
+	case Tlong:    	return newInteger(*(long   *)addr);
+	case Tfloat:   	return newFloat  (*(float  *)addr);
+	case Tdouble:  	return newFloat  (*(double *)addr);
+	case Tstruct:   return newStruct(type, base);
 	default:
-	    break;
+	  println(ptr);
+	  fatal("cannot load '%s' from memory pointer", getTypeName(type));
+	  break;
+      }
+      break;
     }
-    println(ptr);
-    fatal("cannot load '%s' through pointer", getTypeName(type));
-    return 0;
+    default:
+      break;
+  }
+  println(ptr);
+  fatal("cannot load '%s' through pointer", getTypeName(type));
+  return 0;
 }
 
 oop getMemory(oop memory, int offset, oop type)
@@ -3187,9 +3199,9 @@ oop getMemory(oop memory, int offset, oop type)
 	    void *value = *(void **)addr;
 	    oop target = get(type, Tpointer,target);
 	    switch (getType(target)) {
-		case Tstruct: 	return newPointer(type, newMemory(value, typeSize(target)), 0);
-		case Tchar:	return newPointer(t_pchar, newMemory(value, strlen(value)+1), 0);
-		default:	break;
+	      case Tstruct: 	return newPointer(   type, newMemory(value, typeSize(target), 0), 0);
+	      case Tchar:	return newPointer(t_pchar, newMemory(value, strlen(value)+1,  0), 0);
+	      default:	break;
 	    }
 	    fatal("cannot load pointer to '%s' from memory", getTypeName(target));
 	}
@@ -3326,7 +3338,7 @@ oop assign(oop lhs, oop rhs)
 		    case String: {
 			if (t_pchar == ltype) {
 			    char *chars  = STRDUP(String_cString(rhs));
-			    oop   memory = newMemory(chars, strlen(chars) + 1);
+			    oop   memory = newMemory(chars, strlen(chars) + 1, 0);
 			    rhs = newPointer(ltype, memory, 0);
 			    break;
 			}
@@ -3537,7 +3549,7 @@ void initialiseVariable(oop var, int local)
 	    int   size    = _integerValue(get(type, Tarray,size));
 	    int   memsize = typeSize(target) * size;
 	    void *mem     = CALLOC(size, typeSize(target));
-	    oop   memory  = newMemory(mem, memsize);
+	    oop   memory  = newMemory(mem, memsize, 0);
 	    oop   value   = newArray(type, memory, size);
 	    if (isNil(init)) { // size and types checked during typeCheck
 		if (local)
@@ -3564,7 +3576,7 @@ void initialiseVariable(oop var, int local)
 	case Tstruct: {
 	    int   size   = get(type, Tstruct,size);
 	    void *mem    = CALLOC(1, size);
-	    oop   memory = newMemory(mem, size);
+	    oop   memory = newMemory(mem, size, 0);
 	    oop   value  = newStruct(type, memory);
 	    if (isNil(init)) {
 		if (local)
@@ -3729,7 +3741,7 @@ oop eval(oop exp)
 	    oop rhs = get(exp, Dereference,rhs);
 	    rhs = eval(rhs);
 	    switch (getType(rhs)) {
-		case Pointer:	RETURN(getPointer(rhs));
+	      case Pointer:	RETURN(getPointer(rhs, 0));
 		default:	break;
 	    }
 	    println(rhs);
@@ -3867,9 +3879,9 @@ oop eval(oop exp)
 	    int index = _integerValue(ondex);
 	    oop lhs = eval(get(exp, Index,lhs));
 	    switch (getType(lhs)) {
-		case Array: 	RETURN(getArray(lhs, index));
-		case Pointer: 	assert(0);
-		default: break;
+	      case Array: 	RETURN(getArray(lhs, index));
+	      case Pointer: 	RETURN(getPointer(lhs, index));
+	      default: break;
 	    }
 	    println(lhs);
 	    assert(0);
@@ -4750,6 +4762,7 @@ int main(int argc, char **argv)
     false    = newInteger(0);
     true     = newInteger(1);
     s_etc    = newSymbol("...");
+    heap     = newList();
 
 # define _(X) s_##X = intern(#X);
     _do_primitives(_);
@@ -4801,18 +4814,18 @@ int main(int argc, char **argv)
     int cargs = List_size(args);
     int vsize = sizeof(char *) * cargs;
     oop vargs = newArray(newTarray(t_pchar, newInteger(cargs)),
-			 newMemory(malloc(vsize), vsize),
+			 newMemory(malloc(vsize), vsize, 0),
 			 cargs);
     List_do(args, arg) {
 	char *elts = String_cString(arg);
-	oop   mem  = newMemory(elts, get(arg, String,size));
+	oop   mem  = newMemory(elts, get(arg, String,size), 0);
 	setArray(vargs, do_index, newPointer(t_pchar, mem, 0));
     }
 
     args = newList();
     List_append(args, newInteger(cargs));
     List_append(args, vargs);
-    List_append(args, newPointer(t_ppchar, newMemory(0, 0), 0));
+    List_append(args, newPointer(t_ppchar, newMemory(0, 0, 0), 0));
 
     oop entry = Scope_lookup(intern("main"));
     if (!entry || isNil(entry)) fatal("main is not defined");
@@ -4848,5 +4861,10 @@ int main(int argc, char **argv)
 
     assert(1 == List_size(scopes));
 
+    List_do(heap, mem) {
+      if (!get(mem, Memory,free))
+	printf("allocated memory not freed at end of program: %s\n", toString(mem));
+    }
+
     return _integerValue(result);
 }