Cyclic equal (alpha)

runtime/Std.i

@@ -43,4 +43,8 @@ F,s__Infix_42;
 F,s__Infix_47;
 F,s__Infix_37;
 L,"++",T,"+";
- 
+F,enableGC;
+F,disableGC;
+F,random;
+F,time;
+F,rawTag;

runtime/gc_runtime.s

@@ -9,7 +9,7 @@ __gc_stack_top:	        .long	0
 
 			.globl	__pre_gc
 			.globl	__post_gc
-			.globl	L__gc_init
+			.globl	__gc_init
 			.globl	__gc_root_scan_stack
 			.globl	__gc_stack_top
 			.globl	__gc_stack_bottom
@@ -17,9 +17,9 @@ __gc_stack_top:	        .long	0
 			.extern	gc_test_and_copy_root
 			.text
 
-L__gc_init:		movl	%ebp, __gc_stack_bottom
+__gc_init:		movl	%ebp, __gc_stack_bottom
 			addl	$4, __gc_stack_bottom
-			call	init_pool
+			call	__init
 			ret
 
 	// if __gc_stack_top is equal to 0

runtime/runtime.c

@@ -11,6 +11,7 @@
 # include <assert.h>
 # include <errno.h>
 # include <regex.h>
+# include <time.h>
 # include <limits.h>
 
 # define __ENABLE_GC__
@@ -172,6 +173,13 @@ extern void* Bsexp (int n, ...);
 
 void *global_sysargs;
 
+// Gets a raw tag
+extern int LrawTag (void *p) {
+  ASSERT_UNBOXED ("rawTag, 0", p);
+  
+  return TAG(TO_DATA(p)->tag);
+}
+
 // Functional synonym for built-in operator ":";
 void* Ls__Infix_58 (void *p, void *q) {
   void *res;
@@ -1374,6 +1382,24 @@ extern int Lwrite (int n) {
   return 0;
 }
 
+extern int Lrandom (int n) {
+  ASSERT_UNBOXED("Lrandom, 0", n);
+
+  if (UNBOX(n) <= 0) {
+    failure ("invalid range in random: %d\n", UNBOX(n));
+  }
+  
+  return BOX (random () % UNBOX(n));
+}
+
+extern int Ltime () {
+  struct timespec t;
+  
+  clock_gettime (CLOCK_MONOTONIC_RAW, &t);
+  
+  return BOX(t.tv_sec * 1000000 + t.tv_nsec / 1000);
+}
+
 extern void set_args (int argc, char *argv[]) {
   data *a;
   int n = argc, *p = NULL;
@@ -1418,15 +1444,25 @@ extern void set_args (int argc, char *argv[]) {
 
 /* GC starts here */
 
+static int enable_GC = 1;
+
+extern void LenableGC () {
+  enable_GC = 1;
+}
+
+extern void LdisableGC () {
+  enable_GC = 0;
+}
+
 extern const size_t __start_custom_data, __stop_custom_data;
 
 # ifdef __ENABLE_GC__
 
-extern void L__gc_init ();
+extern void __gc_init ();
 
 # else
 
-# define L__gc_init __gc_init_subst
+# define __gc_init __gc_init_subst
 void __gc_init_subst () {}
 
 # endif
@@ -1737,8 +1773,11 @@ static inline void init_extra_roots (void) {
   extra_roots.current_free = 0;
 }
 
-extern void init_pool (void) {
+extern void __init (void) {
   size_t space_size = SPACE_SIZE * sizeof(size_t);
+
+  srandom (time (NULL));
+  
   from_space.begin = mmap (NULL, space_size, PROT_READ | PROT_WRITE,
     			   MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0);
   to_space.begin   = NULL;
@@ -1756,6 +1795,10 @@ extern void init_pool (void) {
 }
 
 static void* gc (size_t size) {
+  if (! enable_GC) {
+    Lfailure ("GC disabled");
+  }
+  
   current = to_space.begin;
 #ifdef DEBUG_PRINT
   print_indent ();

spec/06.standard_library.tex

@@ -89,6 +89,11 @@ is automatically created and closed within the call.}
 \descr{\lstinline|fun getEnv (name)|}{Returns a value for an environment variable "\lstinline|name|". The argument is a string, the
 return value is either "\lstinline|0|" (if not environment variable with given name is set), or a string value.}
 
+\descr{\lstinline|fun random (n)|}{Returns a pseudo-random number in the interval $0..n-1$. The seed is auto-initialized by current time at 
+program start time.}
+
+\descr{\lstinline|fun time ()|}{Returns the elapsed time from program start in microseconds.}
+
 \section{Unit \texttt{Array}}
 \label{sec:array}
 
@@ -107,10 +112,10 @@ Array processing functions:
 \descr{\lstinline|fun listArray (l)|}{Converts a list to array (preserving the order of elements).}
 
 \descr{\lstinline|fun foldlArray (f, acc, a)|}{Folds an array "\lstinline|a|" with a function "\lstinline|f|" and initial value "\lstinline|acc|"
-  is the left-to-right manner. The function "\lstinline|f|" takes two arguments~--- an accumulator and an array element.}
+  in a left-to-right manner. The function "\lstinline|f|" takes two arguments~--- an accumulator and an array element.}
 
 \descr{\lstinline|fun foldrArray (f, acc, a)|}{Folds an array "\lstinline|a|" with a function "\lstinline|f|" and initial value "\lstinline|acc|"
-  is the right-to-left manner. The function "\lstinline|f|" takes two arguments~--- an accumulator and an array element.}
+  in a right-to-left manner. The function "\lstinline|f|" takes two arguments~--- an accumulator and an array element.}
 
 \descr{\lstinline|fun iterArray (f, a)|}{Applies a function "\lstinline|f|" to each element of an array "\lstinline|a|"; does not return a value.}
 

src/X86.ml

@@ -416,7 +416,7 @@ let compile cmd env imports code =
 	           Repmovsl
                   ] @
                   (if f = "main"
-                   then [Call "L__gc_init"; Push (I (12, ebp)); Push (I (8, ebp)); Call "set_args"; Binop ("+", L 8, esp)]
+                   then [Call "__gc_init"; Push (I (12, ebp)); Push (I (8, ebp)); Call "set_args"; Binop ("+", L 8, esp)]
                    else []
                   ) @
                   (if f = cmd#topname

src/version.ml

@@ -1 +1 @@
-let version = "Version 1.00, 9d0b8e811, Mon May 4 02:45:34 2020 +0300"
+let version = "Version 1.00, c73f43e81, Thu Jul 23 12:52:42 2020 +0300"

stdlib/Array.lama

@@ -18,7 +18,7 @@ public fun initArray (n, f) {
 }
 
 public fun mapArray (f, a) {
-  initArray (a.length, fun (i) {a[i]})
+  initArray (a.length, fun (i) {f (a[i])})
 }
 
 public fun arrayList (a) {

stdlib/Collection.lama

@@ -48,13 +48,16 @@ public fun validateColl (t) {
 }
 
 fun makeCompare (sort) {
+  fun c (x, y) {
+    if   x == y then 0
+    elif x < y  then -1
+    else 1
+    fi  
+  }
+  
   case sort of
-    Hash -> fun (x, y) {
-              if   x == y then 0
-              elif x < y  then -1
-              else 1
-              fi
-            }
+    Hash -> c
+  | Ptr  -> c
   | _    -> compare
   esac
 }
@@ -66,6 +69,7 @@ fun insertColl (m, pk, v, sort) {
   fun append (v, vs) {
     case sort of
       Map  -> v : vs
+    | Ptr  -> v : vs
     | Set  -> v
     | Hash ->
        case find (fun (x) {compare (x, [pk, v]) == 0}, vs) of
@@ -159,6 +163,7 @@ fun findColl (m, pk, sort) {
   fun extract (vv) {
     case sort of
       Map  -> case vv of v : _ -> Some (v) | _ -> None esac
+    | Ptr  -> case vv of v : _ -> Some (v) | _ -> None esac
     | Set  -> Some (vv)
     | Hash -> case find (fun (x) {compare (x.fst, pk) == 0}, vv) of
                 Some (p) -> Some (p.snd)
@@ -189,6 +194,7 @@ fun removeColl (m, pk, sort) {
   fun delete (vs) {
     case sort of
       Map  -> case vs of {} -> {} | _ : vv -> vv esac
+    | Ptr  -> case vs of {} -> {} | _ : vv -> vv esac
     | Set  -> false
     | Hash -> remove (fun (x) {x.fst == pk}, vs)
     esac
@@ -216,6 +222,7 @@ fun contents (m, sort) {
   fun append (k, vs, acc) {
     case sort of
       Map -> case vs of {} -> acc | v : _ -> [k, v] : acc esac
+    | Ptr -> case vs of {} -> acc | v : _ -> [k, v] : acc esac
     | Set -> if vs then k : acc else acc fi
     esac
   }
@@ -230,6 +237,19 @@ fun contents (m, sort) {
   inner (m, {})
 }
 
+-- Map on raw pointers (experimental)
+public fun emptyPtrMap () {
+  {}
+}
+
+public fun addPtrMap (m, k, v) {
+  insertColl (m, k, v, Ptr)
+}
+
+public fun findPtrMap (m, k) {
+  findColl (m, k, Ptr)
+}
+
 -- Map structure
 public fun emptyMap () {
   {}

stdlib/Random.lama

@@ -0,0 +1,51 @@
+-- Random data structures generator.
+-- (C) Dmitry Boulytchev, JetBrains Research, St. Petersburg State University, 2020
+--
+-- This unit provides an implementation for random data structures generator
+
+import Array;
+
+-- Generates a random signed 31-bit integer
+public fun randomInt () {
+  if random (2)
+  then random (1073741823) 
+  else 0 - random (1073741823)
+  fi
+}
+
+-- Generates a printable ASCII string of given length
+public fun randomString (len) {
+  local s = makeString (len);
+
+  for local i = 0;, i < len, i := i+1
+  do
+    s [i] := 32 + random (94) -- printable ASCII set
+  od;
+
+  s
+}
+
+-- Generates a random array of (deep) size n. f is element-generation
+-- function which takes the size of the element
+public fun randomArray (f, n) {
+  mapArray (f, split (n))  
+}
+
+-- Splits a number in a random sequence of summands
+public fun split (n) {
+  local k = random (n) + 1,
+        a = makeArray (k),
+        m = n;
+
+  for local i = 0;, i < k, i := i + 1
+  do
+    if i == k - 1
+    then a[i] := m
+    else 
+      a [i] := random (m - k + i + 1) + 1;
+      m := m - a [i]
+    fi
+  od;
+
+  a
+}

stdlib/Timer.lama

@@ -0,0 +1,14 @@
+-- Timer.
+-- (C) Dmitry Boulytchev, JetBrains Research, St. Petersburg State University, 2020
+--
+-- This unit provides an implementation for simple timer. A timer is a function which
+-- measures an elapsed time (in microseconds) since its creation.
+
+-- Creates a new timer
+public fun timer () {
+  local t = time ();
+
+  fun () {
+    time () - t
+  }
+}

stdlib/regression/orig/test30.log

@@ -0,0 +1,100 @@
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1
+1

stdlib/regression/test30.lama

@@ -0,0 +1,147 @@
+import Collection;
+import Ref;
+import Random;
+import Array;
+import Fun;
+
+local m = emptyPtrMap ();
+
+fun eq (x, y) {
+  local m = ref (emptyPtrMap ());
+
+  fun alreadyEq (x, y) {
+    fun find (x) {
+      fun walk (r) {
+        case r of
+          [#unboxed] -> r
+        | [x]        -> walk (x)
+        esac
+      }
+      
+      case findPtrMap (deref (m), x) of
+        Some (r) -> Some (walk (r))
+      | x        -> x
+      esac
+    }
+
+    case [find (x), find (y)] of
+      [None, None] ->
+        local v = [1];
+        m ::= addPtrMap (addPtrMap (deref (m), x, v), y, v);
+        false
+         
+    | [None, Some (ry)] ->
+        m ::= addPtrMap (deref (m), x, ry);
+        false
+         
+    | [Some (rx), None] ->
+        m ::= addPtrMap (deref (m), y, rx);
+        false
+        
+    | [Some (rx), Some (ry)] ->
+        if rx == ry
+        then true
+        else
+          rx [0] := ry;
+          false
+        fi
+    esac    
+  }
+  
+  fun eqrec (x, y) {
+    if alreadyEq (x, y)
+    then true
+    else
+      case [x, y] of
+        [#array, #array] ->
+          if x.length == y.length
+          then
+            local continue = true;
+            
+            for local i = 0;, i<x.length && continue, i := i + 1 do
+              continue := eqrec (x[i], y[i]) 
+            od;            
+            continue
+          else false
+          fi
+      | [#unboxed, #unboxed] -> x == y
+      | [#string, #string]   -> compare (x, y) == 0
+      | [#unboxed, #array] -> false
+      | [#array, #unboxed] -> false
+      | _ -> failure ("eq not supported: %s, %s", x.string, y.string)
+      esac
+    fi
+  }
+
+  eqrec (x, y)  
+}
+
+fun genCyclicArrays (n) {
+  fun genrec (n, stacka, stackb, depth) {
+    fun peek (k, stack) {
+      case stack of
+        [x, prev] -> if k == 0 then x else peek (k-1, prev) fi
+      esac
+    }
+    
+    if n == 1
+    then
+      case if random (2)
+           then randomString (16)
+           else randomInt ()
+           fi of
+        x -> [x, clone (x)]
+      esac           
+    else
+      local a     = split (n),
+            b     = mapArray (id, a),
+            index = initArray (random (a.length + 1), fun (_) {random (a.length)});
+      
+      fun shared (i)  {
+        local found = false;
+        
+        for local j=0;, j < index.length && 1 - found, j := j + 1
+        do
+          found := i == index[j]
+        od;
+
+        found
+      }
+      
+      for local i=0;, i < a.length, i := i + 1
+      do
+        if shared (i)
+        then
+          if depth == 0
+          then
+            a[i] := a;
+            b[i] := b
+          else
+            case random (depth) of
+              r -> a [i] := peek (r, stacka);
+                   b [i] := peek (r, stackb)
+            esac
+          fi
+        else
+          case genrec (a[i], [a, stacka], [b, stackb], depth + 1) of
+            [ai, bi] -> a [i] := ai;
+                        b [i] := bi
+          esac
+        fi
+      od;
+
+      [a, b]
+    fi
+  }
+
+  genrec (n, [], [], 0)
+}
+
+disableGC ();
+
+for local i=0;, i<100, i:=i+1
+do
+  case genCyclicArrays (1000) of
+    [a, b] -> printf ("%d\n", eq (a, b))
+  esac
+od