Fix lm type gc miscounts fdskldsi

Makefile

@@ -8,7 +8,9 @@ LSTSFLAGS = MALLOC_CHECK_=3
 # recommendation: ulimit -s unlimited
 
 dev: install-production
-	sh profile-promises.sh
+	lm tests/promises/lm-type/can-unify.lsts
+	gcc tmp.c
+	./a.out
 
 build: compile-production
 	time env $(LSTSFLAGS) ./production --v23 --c -o deploy1.c SRC/index.lsts

SRC/tctx-unify.lsts

@@ -163,20 +163,6 @@ let unify-inner(fpt: Type, pt: Type, blame: AST): Maybe<TypeContext> = (
    ctx
 );
 
-let unify(fpt: List<Type>, pt: List<Type>, blame: AST): Maybe<TypeContext> = (
-   let ctx = (None : Maybe<TypeContext>)();
-   let yes = Some(mk-tctx());
-   match Tuple( fpt, pt ) {
-      Tuple{ first:[lp1..lps], second:[rp1..rps] } => (
-         ctx = unify-inner(lp1,rp1,blame);
-         if non-zero(ctx) { ctx = union(ctx, unify(lps,rps,blame)); }
-      );
-      Tuple{ first:[], second:[] } => ctx = yes;
-      Tuple{} => ();
-   };
-   ctx
-);
-
 let unify(fpt: Vector<Type>, pt: Vector<Type>, blame: AST): Maybe<TypeContext> = (
    let ctx = (None : Maybe<TypeContext>)();
    let yes = Some(mk-tctx());

SRC/type-can-unify.lsts

@@ -1,17 +1,6 @@
 
 let $"<:"(pt: Type, fpt: Type): Bool = can-unify(fpt,pt);
 
-let can-unify(fpt: List<Type>, pt: List<Type>): Bool = (
-   if fpt.length == pt.length {
-      let ok = true;
-      while ok and non-zero(fpt) {
-         if not(can-unify(head(fpt), head(pt))) then (ok = false);
-         fpt = tail(fpt); pt = tail(pt);
-      };
-      ok
-   } else false
-);
-
 let can-unify(fpt: Vector<Type>, pt: Vector<Type>): Bool = (
    let fptv = fpt[:];
    let ptv = pt[:];
@@ -37,7 +26,7 @@ let can-unify(fpt: VectorView<Type>, pt: VectorView<Type>): Bool = (
 );
 
 let can-unify(fpt: Type, pt: Type): Bool = (
-   match Tuple(fpt, pt) {
+   let return = match Tuple(fpt, pt) {
       Tuple{ first:TAny{} } => true;
       Tuple{ first:TGround{tag:c"Any"} } => true;
       Tuple{ first:TGround{tag:c"MustNotRetain"} } => true;
@@ -156,9 +145,10 @@ let can-unify(fpt: Type, pt: Type): Bool = (
           first:TGround{tag:c"Arrow", parameters:[lrng.. ldom..]},
           second:TGround{tag:c"Arrow", parameters:[rrng.. rdom..]}
       } => (
-         if can-unify(rdom, ldom) {
+         let ra = if can-unify(rdom, ldom) {
             can-unify(lrng, rrng)
-         } else false
+         } else false;
+         ra
       );
 
       Tuple{
@@ -167,4 +157,5 @@ let can-unify(fpt: Type, pt: Type): Bool = (
       } => (ltn==rtn or (ltn.has-suffix(c"::") and rtn.has-prefix(ltn))) and can-unify(lps,rps);
       _ => false;
    };
+   return
 );

SRC/type-constructor.lsts

@@ -49,7 +49,7 @@ let $"&&"(lt: Type, rt: Type): Type = (
          result = result.push(first);
          result = result.push(second);
          result = result.sort;
-         TAnd(result)
+         TAnd(result);
       );
    };
 );

SRC/type-resurrect.lsts

@@ -11,13 +11,6 @@ let .resurrect(tt: Type): Type = (
    }
 );
 
-let .resurrect(tt: List<Type>): List<Type> = (
-   match tt {
-      [hd..tl] => cons(hd.resurrect, tl.resurrect);
-      [] => tt;
-   }
-);
-
 let .resurrect(tt: Vector<Type>): Vector<Type> = (
    let next = mk-vector(type(Type));
    for vector t in tt {

SRC/type-without-any-phi.lsts

@@ -24,13 +24,6 @@ let .without-any-phi(tt: Type): Type = (
    }
 );
 
-let .without-any-phi(tt: List<Type>): List<Type> = (
-   match tt {
-      [hd..tl] => cons( hd.without-any-phi, tl.without-any-phi );
-      tl => tl;
-   }
-);
-
 let .without-any-phi(tt: Vector<Type>): Vector<Type> = (
    let next = mk-vector(type(Type));
    for vector t in tt {

SRC/type-without-phi.lsts

@@ -27,13 +27,6 @@ let .without-phi(tt: Type): Type = (
    }
 );
 
-let .without-phi(tt: List<Type>): List<Type> = (
-   match tt {
-      [hd..tl] => cons( hd.without-phi, tl.without-phi );
-      tl => tl;
-   }
-);
-
 let .without-phi(tt: Vector<Type>): Vector<Type> = (
    let next = mk-vector(type(Type));
    for vector t in tt {

lib/core/array.lsts

@@ -95,13 +95,15 @@ let safe-realloc(ptr: t[], len: USize, ty: Type<t>): t[] = (
    safe-realloc-impl(ptr as ?[], nb) as t[]
 );
 
+# Disabling free here makes GC miscounts fail immediately due to lack of data overwrite
+# TODO: create a compiler option to disable free (--nofree)
 let safe-free(ptr: ?[]): Nil = (
    # BEFORE CHANGING THIS: talk to alex
 
    # TODO: wrap counter adjustments in conditional compilation
    safe-alloc-block-count = safe-alloc-block-count - 1;
 
-   free(ptr as C<"void">[]);
+   #free(ptr as C<"void">[]);
    ()
 );
 

lib/core/vector.lsts

@@ -27,7 +27,7 @@ let .release(x: VectorView<t>): Nil = (
 );
 
 let .retain(x: VectorView<t>): VectorView<t> = (
-   x.data.retain;
+   mark-as-released(x.data.retain);
    x
 );
 
@@ -74,7 +74,7 @@ let $"[]"(v: Vector<t>, idx: USize): t = (
 # new allocations = 0
 let $"[]"(v: VectorView<t>, idx: USize): t = (
    if not(idx < v.end-offset - v.start-offset) then fail(c"Vector Index Out Of Bounds");
-   v.data.data[v.start-offset+idx]
+   v.data[v.start-offset+idx]
 );
 
 # new allocations = 1

tests/promises/gc/double-field-counting.lsts

@@ -0,0 +1,4 @@
+
+import lib/core/bedrock.lsts;
+
+VectorView(mk-vector(type(U8)).push(1), 0, 1).data.data;

tests/promises/lm-type/can-unify.lsts

@@ -14,7 +14,6 @@ assert( t0(c"Any") <: ta );
 assert( ta <: t0(c"Any") );
 assert( safe-alloc-block-count == 0 );
 
-assert( t2(c"Arrow",t0(c"A"),t0(c"A")) <: t2(c"Arrow",t0(c"A"),t0(c"A")) );
 assert( not(t2(c"Arrow",t0(c"A") && t0(c"B"),t0(c"A")) <: t2(c"Arrow",t0(c"A"),t0(c"A"))) );
 assert( t2(c"Arrow",t0(c"A"),t0(c"A")) <: t2(c"Arrow",t0(c"A") && t0(c"B"),t0(c"A")) );
 assert( t2(c"Arrow",t0(c"A"),t0(c"A") && t0(c"B")) <: t2(c"Arrow",t0(c"A"),t0(c"A")) );