@effekt-lang/effekt 0.2.1 → 0.3.0

package/libraries/chez/common/text/regex.effekt

@@ -0,0 +1,31 @@
+module text/regex
+
+import immutable/cslist
+
+extern include chez "pregexp.scm"
+
+extern type Regex
+
+record Match(matched: String, index: Int)
+
+extern pure def regex(str: String): Regex =
+  chez "(pregexp ${str})"
+
+def exec(reg: Regex, str: String): Option[Match] = {
+  val matched = reg.unsafeMatchString(str)
+  if (matched.isUndefined) { None() }
+  else { Some(Match(matched, reg.unsafeMatchIndex(str))) }
+}
+
+extern pure def unsafeMatchIndex(reg: Regex, str: String): Int =
+  chez "(let ([m (pregexp-match-positions ${reg} ${str})]) (if m (car (car m)) #f))"
+
+// we ignore the captures for now and only return the whole match
+extern pure def unsafeMatchString(reg: Regex, str: String): String =
+  chez "(let ([m (pregexp-match ${reg} ${str})]) (if m (car m) #f))"
+
+extern pure def split(reg: Regex, str: String): CSList[String] =
+  chez "(pregexp-split ${reg} ${str})"
+
+// def split(str: String, sep: String): Array[String] =
+//   toArray(split(sep.regex, str))

package/libraries/chez/lift/effekt.ss

@@ -0,0 +1,118 @@
+(define-syntax delayed
+  (syntax-rules ()
+    [(_ e ...)
+      (lambda (k) (k
+        (begin e ...)))]))
+
+
+;; EVIDENCE
+
+(define (here x) x)
+
+; (define-syntax lift
+;   (syntax-rules ()
+;     [(_ m)
+;      (lambda (k1)
+;        (lambda (k2)
+;          (m (lambda (a) ((k1 a) k2)))))]))
+
+(define (lift m)
+  (lambda (k1)
+    (lambda (k2)
+      (m (lambda (a) ((k1 a) k2))))))
+
+(define-syntax nested-helper
+  (syntax-rules ()
+    [(_ (ev) acc) (ev acc)]
+    [(_ (ev1 ev2 ...) acc)
+      (nested-helper (ev2 ...) (ev1 acc))]))
+
+(define-syntax nested
+  (syntax-rules ()
+    [(_ ev1 ...) (lambda (m) (nested-helper (ev1 ...) m))]))
+
+
+;; HANDLING
+
+; (define (reset m) (m (lambda (v) (lambda (k) (k v)))))
+
+(define-syntax reset
+  (syntax-rules ()
+    [(_ m)
+     (m (lambda (v) (lambda (k) (k v))))]))
+
+; ;; EXAMPLE
+; ; (handle ([Fail_22 (Fail_109 () resume_120 (Nil_74))])
+; ;       (let ((tmp86_121 ((Fail_109  Fail_22))))
+; ;         (Cons_73  tmp86_121  (Nil_74))))
+
+
+; capabilities first take evidence than require selection!
+(define-syntax handle
+  (syntax-rules ()
+    [(_ (cap1 ...) body)
+     (reset (body lift cap1 ...))]))
+
+
+(define-syntax shift
+  (syntax-rules ()
+    [(_ ev body)
+     (ev body)]))
+
+; capabilities first take evidence than require selection!
+(define-syntax handle-old
+  (syntax-rules ()
+    [(_ ((cap1 (op1 (arg1 ...) kid exp) ...) ...) body)
+     (reset (body lift
+       (cap1 (define-effect-op ev (arg1 ...) kid exp) ...) ...))]))
+
+(define-syntax define-effect-op
+  (syntax-rules ()
+    [(_ ev1 (arg1 ...) kid exp ...)
+     (lambda (ev1 arg1 ...)
+        ; we apply the outer evidence to the body of the operation
+        (ev1 (lambda (resume)
+          ; k itself also gets evidence!
+          (let ([kid (lambda (ev v) (ev (resume v)))])
+            exp ...))))]))
+
+(define (with-region-non-mono body)
+  (define arena (make-arena))
+
+  (define (lift m) (lambda (k)
+    ; on suspend
+    (define fields (backup arena))
+    (m (lambda (a)
+      ; on resume
+      (restore fields)
+      (k a)))))
+
+  (body lift arena))
+
+(define (with-region body)
+  (define arena (make-arena))
+
+  (body arena))
+
+
+; An Arena is a pointer to a list of cells
+(define (make-arena) (box '()))
+
+(define (fresh arena init)
+  (let* ([cell (box init)]
+         [cells (unbox arena)])
+    (set-box! arena (cons cell cells))
+    cell))
+
+; Backup = List<(Cell, Value)>
+
+; Arena -> Backup
+(define (backup arena)
+  (let ([fields (unbox arena)])
+    (map (lambda (cell) (cons cell (unbox cell))) fields)))
+
+; Backup -> ()
+(define (restore data)
+  (for-each (lambda (cell-data)
+    (set-box! (car cell-data) (cdr cell-data)))
+    data))

package/libraries/chez/monadic/effekt.ss

@@ -0,0 +1,84 @@
+(define-syntax delayed
+  (syntax-rules ()
+    [(_ e)
+      (lambda (mk) (underflow e mk))]))
+
+; Control = MetaCont -> Step
+
+; a -> Control a
+(define (pure v)
+  (lambda (mk) (underflow v mk)))
+
+; Step a =  (a | Control x), MetaCont x a
+
+; (a | Control a), MetaCont -> a
+(define (trampoline c mk)
+  (if (null? mk) c
+      (call-with-values
+        (lambda () (c mk))
+        trampoline)))
+
+; a, MetaCont -> Step
+(define (underflow v mk)
+  (if (null? mk) (values v mk)
+    (let* ([stack (car mk)]
+           [rest  (cdr mk)]
+           [frames (Stack-frames stack)]
+           [arena (Stack-arena stack)]
+           [prompt (Stack-prompt stack)])
+      (if (null? frames) (underflow v rest)
+          (values ((car frames) v) (cons (make-Stack (cdr frames) arena prompt) rest))))))
+
+; Control, Prompt -> Control
+(define (reset p c)
+  (lambda (mk)
+    (c (cons (make-Stack '() (make-arena) p) mk))))
+
+; Prompt, Body -> Control
+(define (shift p f)
+  (lambda (mk)
+    (let-values ([(k mkrest) (splitSeq p mk)])
+      (let ([cont (lambda (a) (lambda (mk) (underflow a (appendSeq k mk))))])
+      (values (f cont) mkrest)))))
+
+; Frame, MetaCont -> MetaCont
+(define (push-frame f mk)
+  (if (null? mk) (error 'push-frame "Cannot push frame, meta cont ~s is empty" mk)
+    (let ([stack (car mk)]
+          [rest  (cdr mk)])
+      (let ([frames (Stack-frames stack)]
+            [arena (Stack-arena stack)]
+            [prompt (Stack-prompt stack)])
+          (cons (make-Stack (cons f frames) arena prompt) rest)))))
+
+(define-syntax then
+  (syntax-rules ()
+    [(_ m f)
+     (lambda (k) (values m (push-frame f k)))]))
+
+(define toplevel 0)
+
+; Control a -> a
+(define (run c)
+  (trampoline c (cons (make-Stack '() (make-arena) toplevel) '())))
+
+(define newPrompt (lambda () (string #\p)))
+
+(define-syntax handle
+  (syntax-rules ()
+    [(_ ((cap1 (op1 (arg1 ...) kid exp) ...) ...) body)
+     (let ([p (newPrompt)])
+       (reset p (body
+        (cap1 (define-effect-op p (arg1 ...) kid exp) ...)
+        ...)))]))
+
+
+(define-syntax define-effect-op
+  (syntax-rules ()
+    [(_ p (arg1 ...) kid exp ...)
+     (lambda (arg1 ...)
+        (shift p (lambda (kid) exp ...)))]))
+
+; state(init) { cell => ... }
+(define (state init body)
+  (with-region (lambda (arena) (body (fresh arena init)))))

package/libraries/chez/monadic/seq0.ss

@@ -0,0 +1,76 @@
+; [ [f1, f2, f3, f4| fields | prompt], [f1, f2, f3, f4| fields | prompt]... ]
+(define-record Stack (
+  [immutable frames]
+  [immutable arena]
+  [immutable prompt]))
+
+(define-record Substack (
+  [immutable frames]
+  [immutable arena]
+  [immutable field-backup]
+  [immutable prompt]))
+
+; MetaCont = (non-empty-list-of Stack)
+; SubCont = (non-empty-list-of Stack)
+
+
+; An Arena is a pointer to a list of cells
+(define (make-arena) (box '()))
+
+(define (fresh arena init)
+  (let* ([cell (box init)]
+         [cells (unbox arena)])
+    (set-box! arena (cons cell cells))
+    cell))
+
+; with-region { arena => ... }
+(define (with-region body)
+  (lambda (mk)
+    (let* ([stack (car mk)]
+           [arena (Stack-arena stack)])
+      ((body arena) mk))))
+
+; Backup = List<(Cell, Value)>
+
+; Arena -> Backup
+(define (backup arena)
+  (let ([fields (unbox arena)])
+    (map (lambda (cell) (cons cell (unbox cell))) fields)))
+
+; Backup -> ()
+(define (restore data)
+  (for-each (lambda (cell-data)
+    (set-box! (car cell-data) (cdr cell-data)))
+    data))
+
+; Prompt MetaCont -> SubCont, MetaCont
+(define (splitSeq p seq)
+  (define (split sub s)
+    (if (null? s)
+        (error 'splitSeq "prompt ~s not found on stack" p)
+        (let* ([stack (car s)]
+           [frames (Stack-frames stack)]
+           [arena (Stack-arena stack)]
+           [prompt (Stack-prompt stack)]
+           [rest  (cdr s)])
+          (define sub* (cons (make-Substack frames arena (backup arena) prompt) sub))
+          (if (not (eq? prompt p))
+            (split sub* rest)
+            (values sub* rest)))))
+  (split (list) seq))
+
+
+(define (appendSeq subcont meta)
+  (if (null? subcont)
+    meta
+    (let* ([stack (car subcont)]
+           [frames  (Substack-frames stack)]
+           [arena  (Substack-arena stack)]
+           [fields (Substack-field-backup stack)]
+           [prompt (Substack-prompt stack)]
+           [_ (restore fields)]
+           [rest  (cdr subcont)])
+      (appendSeq rest (cons (make-Stack frames arena prompt) meta)))))
+
+; (define ex (list (make-Stack '(1 2 3) (list (box 1)) 4) (make-Stack '(1 2 3) (list (box 2)) 3) (make-Stack '(1 2 3) (list (box 3)) 2) (make-Stack '(4 5 6) (list (box 4)) 1)))
+; (let-values ([(cont meta) (splitSeq 2 ex)]) (appendSeq cont meta))

package/libraries/common/args.effekt

@@ -0,0 +1,95 @@
+module args
+
+extern io def commandLineArgs(): List[String] =
+  js { js::commandLineArgs() }
+  chez { chez::commandLineArgs() }
+  ml { ml::commandLineArgs() }
+  llvm { llvm::commandLineArgs() }
+
+namespace js {
+  extern type Args // = Array[String]
+
+  extern io def nativeArgs(): Args = js "process.argv.slice(1)"
+
+  extern io def argCount(args: Args): Int = js "${args}.length"
+
+  extern io def argument(args: Args, i: Int): String = js "${args}[${i}]"
+
+  def commandLineArgs(): List[String] = {
+    def toList(args: Args, start: Int, acc: List[String]): List[String] =
+      if (start < 1) { acc }
+      else args.toList(start - 1, Cons(args.argument(start), acc))
+
+    val args = nativeArgs()
+    args.toList(args.argCount - 1, Nil())
+  }
+}
+
+namespace chez {
+  extern type Args // = CSList[String]
+
+  extern io def nativeArgs(): Args =
+    chez "(cdr (command-line))"
+
+  extern pure def isEmpty(l: Args): Bool =
+    chez "(null? ${l})"
+
+  extern pure def head(l: Args): String =
+    chez "(car ${l})"
+
+  extern pure def tail(l: Args): Args =
+    chez "(cdr ${l})"
+
+  def toList(l: Args): List[String] =
+    if (l.isEmpty) Nil() else Cons(l.head, l.tail.toList)
+
+  def commandLineArgs(): List[String] = nativeArgs().toList
+}
+
+namespace ml {
+
+  // MLList[String]
+  // we inline these from mllist to not have a dependency
+  extern type Args
+
+  extern io def nativeArgs(): Args =
+    ml "CommandLine.arguments ()"
+
+  extern pure def isEmpty(args: Args): Bool =
+    ml "null ${args}"
+
+  extern io def first(a: Args): String =
+    ml "hd ${a}"
+
+  extern io def rest(a: Args): Args =
+    ml "tl ${a}"
+
+
+  def commandLineArgs(): List[String] = {
+    def toList(args: Args): List[String] =
+      if (args.isEmpty) Nil() else Cons(args.first, args.rest.toList)
+    nativeArgs().toList
+  }
+}
+
+namespace llvm {
+  extern io def argCount(): Int =
+    llvm """
+      %c = call %Int @c_get_argc()
+      ret %Int %c
+    """
+
+  extern io def argument(i: Int): String =
+    llvm """
+      %s = call %Pos @c_get_arg(%Int ${i})
+      ret %Pos %s
+    """
+
+  def commandLineArgs(): List[String] = {
+    def toList(start: Int, acc: List[String]): List[String] =
+      if (start < 1) { acc }
+      else toList(start - 1, Cons(argument(start), acc))
+
+    toList(argCount() - 1, Nil())
+  }
+}

package/libraries/common/array.effekt

@@ -0,0 +1,225 @@
+module array
+
+import effekt
+import exception
+import list
+
+/**
+ * A mutable 0-indexed fixed-sized array.
+ */
+extern type Array[T]
+
+/**
+ * Allocates a new array of size `size`, keeping its values _undefined_.
+ * Prefer using `array` constructor instead to ensure that values are defined.
+ */
+extern global def allocate[T](size: Int): Array[T] =
+  js "(new Array(${size}))"
+  chez "(make-vector ${size})" // creates an array filled with 0s on CS
+  llvm """
+    %z = call %Pos @c_array_new(%Int ${size})
+    ret %Pos %z
+  """
+
+/**
+ * Creates a new Array of size `size` filled with the value `init`
+ */
+extern global def array[T](size: Int, init: T): Array[T] =
+  ml "Array.array (${size}, ${init})"
+  default {
+    val arr = allocate[T](size);
+    each(0, size) { i =>
+      unsafeSet(arr, i, init)
+    };
+    arr
+  }
+
+/**
+ * Converts a List `list` to an Array
+ */
+def fromList[T](list: List[T]): Array[T] = {
+  val listSize = list.size();
+  val arr = allocate(listSize);
+
+  foreachIndex(list) { (i, head) =>
+    arr.unsafeSet(i, head)
+  }
+  return arr;
+}
+
+/**
+ * Gets the length of the array in constant time.
+ */
+extern pure def size[T](arr: Array[T]): Int =
+  js "${arr}.length"
+  chez "(vector-length ${arr})"
+  ml "Array.length ${arr}"
+  llvm """
+    %z = call %Int @c_array_size(%Pos ${arr})
+    ret %Int %z
+  """
+
+/**
+ * Gets the element of the `arr` at given `index` in constant time.
+ * Unchecked Precondition: `index` is in bounds (0 ≤ index < arr.size)
+ *
+ * Prefer using `get` instead.
+ */
+extern global def unsafeGet[T](arr: Array[T], index: Int): T =
+  js "${arr}[${index}]"
+  chez "(vector-ref ${arr} ${index})"
+  ml "Array.sub (${arr}, ${index})"
+  llvm """
+    %z = call %Pos @c_array_get(%Pos ${arr}, %Int ${index})
+    ret %Pos %z
+  """
+
+extern js """
+function array$set(arr, index, value) {
+  arr[index] = value;
+  return $effekt.unit
+}
+"""
+
+ /**
+ * Sets the element of the `arr` at given `index` to `value` in constant time.
+ * Unchecked Precondition: `index` is in bounds (0 ≤ index < arr.size)
+ *
+ * Prefer using `set` instead.
+ */
+extern global def unsafeSet[T](arr: Array[T], index: Int, value: T): Unit =
+  js "array$set(${arr}, ${index}, ${value})"
+  chez "(begin (vector-set! ${arr} ${index} ${value}) #f)"
+  ml "Array.update (${arr}, ${index}, ${value})"
+  llvm """
+    %z = call %Pos @c_array_set(%Pos ${arr}, %Int ${index}, %Pos ${value})
+    ret %Pos %z
+  """
+
+/**
+ * Creates a copy of `arr`
+ */
+def copy[T](arr: Array[T]): Array[T] = {
+  with on[OutOfBounds].default { <> }; // should not happen
+  val len = arr.size;
+  val newArray = allocate[T](len);
+  copy[T](arr, 0, newArray, 0, len);
+  newArray
+}
+
+/**
+ * Copies `length`-many elements from `from` to `to`
+ * starting at `start` (in `from`) and `offset` (in `to`)
+ */
+def copy[T](from: Array[T], start: Int, to: Array[T], offset: Int, length: Int): Unit / Exception[OutOfBounds] = {
+  val startValid  = start >= 0 && start + length <= from.size
+  val offsetValid = offset >= 0 && offset + length <= to.size
+
+  def go(i: Int, j: Int, length: Int): Unit =
+    if (length > 0) {
+      to.unsafeSet(j, from.unsafeGet(i))
+      go(i + 1, j + 1, length - 1)
+    }
+
+  if (startValid && offsetValid) go(start, offset, length)
+  else do raise(OutOfBounds(), "Array index out of bounds, when copying")
+}
+
+// Derived operations:
+
+/**
+ * Gets the element of the `arr` at given `index` in constant time,
+ * throwing an `Exception[OutOfBounds]` unless `0 ≤ index < arr.size`.
+ */
+def get[T](arr: Array[T], index: Int): T / Exception[OutOfBounds] =
+  if (index >= 0 && index < arr.size) arr.unsafeGet(index)
+  else do raise(OutOfBounds(), "Array index out of bounds: " ++ show(index))
+
+/**
+ * Sets the element of the `arr` at given `index` to `value` in constant time,
+ * throwing an `Exception[OutOfBounds]` unless `0 ≤ index < arr.size`.
+ */
+def set[T](arr: Array[T], index: Int, value: T): Unit / Exception[OutOfBounds] =
+  if (index >= 0 && index < arr.size) unsafeSet(arr, index, value)
+  else do raise(OutOfBounds(), "Array index out of bounds: " ++ show(index))
+
+/**
+ * Builds a new Array of size `size` from a computation `index` which gets an index
+ * and returns a value that will be on that position in the resulting array
+ */
+def build[T](size: Int) { index: Int => T }: Array[T] = {
+  val arr = allocate[T](size);
+  each(0, size) { i =>
+    unsafeSet(arr, i, index(i))
+  };
+  arr
+}
+
+// Utility functions:
+
+def toList[T](arr: Array[T]): List[T] = {
+  var i = arr.size - 1;
+  var l = Nil[T]()
+  while (i >= 0) {
+    l = Cons(arr.unsafeGet(i), l)
+    i = i - 1
+  }
+  l
+}
+
+def foreach[T](arr: Array[T]){ action: T => Unit }: Unit =
+  each(0, arr.size) { i =>
+    val x: T = arr.unsafeGet(i)
+    action(x)
+  }
+
+def foreach[T](arr: Array[T]){ action: (T) {Control} => Unit }: Unit =
+  each(0, arr.size) { (i) {label} =>
+    val x: T = arr.unsafeGet(i)
+    action(x) {label}
+  }
+
+def foreachIndex[T](arr: Array[T]){ action: (Int, T) => Unit }: Unit =
+  each(0, arr.size) { i =>
+    val x: T = arr.unsafeGet(i)
+    action(i, x)
+  }
+
+def foreachIndex[T](arr: Array[T]){ action: (Int, T) {Control} => Unit }: Unit =
+  each(0, arr.size) { (i) {label} =>
+    val x: T = arr.unsafeGet(i)
+    action(i, x) {label}
+  }
+
+def sum(list: Array[Int]): Int = {
+  var acc = 0
+  list.foreach { x =>
+    acc = acc + x
+  }
+  acc
+}
+
+// Show Instances
+// --------------
+
+def show[A](arr: Array[A]) { showA: A => String }: String = {
+  var output = "Array("
+  val lastIndex = arr.size - 1
+
+  arr.foreachIndex { (index, a) =>
+    if (index == lastIndex) output = output ++ showA(a)
+    else output = output ++ showA(a) ++ ", "
+  }
+  output = output ++ ")"
+
+  output
+}
+def show(l: Array[Int]): String = show(l) { e => show(e) }
+def show(l: Array[Double]): String = show(l) { e => show(e) }
+def show(l: Array[Bool]): String = show(l) { e => show(e) }
+def show(l: Array[String]): String = show(l) { e => e }
+
+def println(l: Array[Int]): Unit = println(show(l))
+def println(l: Array[Double]): Unit = println(show(l))
+def println(l: Array[Bool]): Unit = println(show(l))
+def println(l: Array[String]): Unit = println(show(l))

package/libraries/common/bench.effekt

@@ -0,0 +1,60 @@
+module bench
+
+/**
+ * The current time (since UNIX Epoch) in nanoseconds.
+ *
+ * The actual precision varies across the different backends.
+ * - js: Milliseconds
+ * - chez: Microseconds
+ * - ml: Microseconds
+ */
+extern io def timestamp(): Int =
+  js "Date.now() * 1000000"
+  chez "(timestamp)"
+  ml "IntInf.toInt (Time.toNanoseconds (Time.now ()))"
+  llvm """
+    %time_ptr = alloca { i64, i64 }
+    call i32 @clock_gettime(i32 0, ptr %time_ptr)
+    %time = load {i64, i64}, ptr %time_ptr
+    %time_seconds = extractvalue {i64, i64} %time, 0
+    %time_nanoseconds = extractvalue {i64, i64} %time, 1
+    %time_seconds_nanoseconds = mul nsw i64 %time_seconds, 1000000000
+    %result = add nsw i64 %time_seconds_nanoseconds, %time_nanoseconds
+    ret %Int %result
+  """
+
+extern llvm """
+  declare i32 @clock_gettime(i32, ptr)
+"""
+
+/**
+ * High-precision timestamp in nanoseconds that should be for measurements.
+ *
+ * This timestamp should only be used for **relative** measurements,
+ * as gives no guarantees on the absolute time (unlike a UNIX timestamp).
+ */
+extern io def relativeTimestamp(): Int =
+  js "Math.round(performance.now() * 1000000)"
+  default { timestamp() }
+
+/**
+ * Runs the block and returns the time in nanoseconds
+ */
+def timed { block: => Unit }: Int = {
+  val before = relativeTimestamp()
+  block()
+  val after = relativeTimestamp()
+  after - before
+}
+
+def measure(warmup: Int, iterations: Int) { block: => Unit }: Unit = {
+  def run(n: Int, report: Bool): Unit = {
+    if (n <= 0) { () } else {
+      val time = timed { block() };
+      if (report) { println(time) } else { () };
+      run(n - 1, report)
+    }
+  }
+  run(warmup, false)
+  run(iterations, true)
+}