<|start_filename|>test/FunctionApplicationSpec.hs<|end_filename|>
{-# OPTIONS_GHC -Wall #-}
module FunctionApplicationSpec (spec) where
import Test.Hspec
import Utils

import Syntax
import Kinds

spec :: Spec
spec = 
  describe "LDGV parser function application and let tests" $ do
    it "parses simple function application" $ do
      "val f (g:Int) (n:Int) = g n" `shouldParseDecl`
        DFun "f" [(MMany,"g",TInt),(MMany,"n",TInt)]
          (App (Var "g") (Var "n"))
          Nothing

    it "parses function application to two arguments" $ do
      "val f (g:Int) (n:Int) = g n n" `shouldParseDecl`
        DFun "f" [(MMany,"g",TInt),(MMany,"n",TInt)]
          (App (App (Var "g") (Var "n")) (Var "n"))
          Nothing

    it "parses let around infix op" $ do
      "val f (m:Int) (n:Int) = let x = m in n + n" `shouldParseDecl`
        DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)]
         (Let "x" (Var "m")
          (Math $ Add (Var "n") (Var "n")))
         Nothing

    it "parses nested let" $ do
      "val f (m:Int) (n:Int) = let x = m in let y = x in x + y" `shouldParseDecl`
        DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)] 
         (Let "x" (Var "m")
          (Let "y" (Var "x")
           (Math $ Add (Var "x") (Var "y"))))
          Nothing

    it "parses nested let(pair)" $ do
      "val f (m:Int) (n:Int) = let <x,y> = m in let z = x in z + y + n" `shouldParseDecl`
        DFun "f" [(MMany,"m",TInt),(MMany,"n",TInt)] 
         (LetPair "x" "y" (Var "m")
          (Let "z" (Var "x")
           (Math $ Add (Math $ Add (Var "z") (Var "y")) (Var "n")))) 
          Nothing

    it "parses nested let(pair)1" $ do
      "val sendNode (n : Node) (c : NodeC) = let < tag , v > = n in (let c = send c tag in   send c v)" `shouldParseDecl`
        DFun "sendNode" [(MMany,"n",TName False "Node"),(MMany,"c",TName False "NodeC")]
          (LetPair "tag" "v" (Var "n")
            (Let "c" (App (Send (Var "c")) (Var "tag")) 
             (App (Send (Var "c")) (Var "v"))))
          Nothing

    it "parses nested let(pair)2" $ do
      "val sendNode (n : Node) (c : NodeC) = let < tag , v > = n in let c = send c tag in   send c v" `shouldParseDecl`
        DFun "sendNode" [(MMany,"n",TName False "Node"),(MMany,"c",TName False "NodeC")]
          (LetPair "tag" "v" (Var "n")
            (Let "c" (App (Send (Var "c")) (Var "tag")) 
             (App (Send (Var "c")) (Var "v"))))
          Nothing


<|start_filename|>src/C/Compile.hs<|end_filename|>
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wall #-}

module C.Compile
  ( Env(..)
  , defaultEnv
  , compile
  , link
  , cflags
  , listBackends
  ) where

import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Traversable
import Paths_ldgv
import System.FilePath
import System.IO
import System.Process.Typed
import qualified Control.Monad.Fail as Fail

data Env = Env
  { envCC :: !String
  , envFlags :: ![String]
  , envVerbose :: !Bool
  }
  deriving stock (Show)

defaultEnv :: Env
defaultEnv = Env
  { envCC = "cc"
  , envFlags = []
  , envVerbose = False
  }

compile :: (MonadReader Env m, MonadIO m) => FilePath -> FilePath -> m ()
compile result src = do
  cc <- asks envCC
  defaultFlags <- liftIO cflags
  customFlags <- asks envFlags
  let args = "-o" : result : "-c" : src : defaultFlags ++ customFlags
  run cc args

link :: (MonadReader Env m, MonadIO m, Fail.MonadFail m) => FilePath -> [FilePath] -> String -> m ()
link result srcs backend = do
  cc <- asks envCC
  defaultFlagsCC <- liftIO cflags
  defaultFlagsLD <- liftIO ldflags
  customFlags <- asks envFlags
  backendSrcs <-
    if | pathSeparator `elem` backend ->
           pure [backend]
       | Just additional <- lookup backend knownBackends -> liftIO $
           traverse backendFile $ backendImplFileName backend : additional
       | otherwise -> Fail.fail $
           "unknown backend ›" ++ backend ++ "‹, use ›./" ++ backend ++ "‹ to refer to a file"

  let args = "-o" : result : concat
        [ srcs
        , defaultFlagsCC
        , defaultFlagsLD
        , backendSrcs
        , customFlags
        ]
  run cc args

run :: (MonadReader Env m, MonadIO m) => String -> [String] -> m ()
run exe args = do
  verbose <- asks envVerbose
  when verbose $ liftIO do
    hPutStrLn stderr $ unwords $ fmap show $ exe:args
  runProcess_ $ proc exe args

basePath :: FilePath
basePath = "c-support/runtime"

cflags :: IO [String]
cflags = do
  dataDir <- getDataDir
  pure ["-pthread", "-Wall", "-O2", "-fomit-frame-pointer", "-std=c11", "-I" ++ dataDir </> basePath ]

ldflags :: IO [String]
ldflags = do
  supportImpl <- backendFile "LDST.c"
  pure [supportImpl]

listBackends :: IO [(String, FilePath)]
listBackends = do
  for knownBackends \(b, _) -> (b,) <$> backendFile (backendImplFileName b)

knownBackends :: [(String, [FilePath])]
knownBackends =
  [ ("serial", [])
  , ("concurrent", ["thpool.c"])
  ]

backendImplFileName :: String -> FilePath
backendImplFileName b = "LDST_" ++ b <.> "c"

backendFile :: String -> IO FilePath
backendFile filename = getDataFileName $ basePath </> filename


<|start_filename|>c-support/runtime/LDST_serial.c<|end_filename|>
//
// LDST_serial.c
//
// Serial LDST backend.

#include <stdbool.h>
#include <string.h>
#include <stdlib.h>
#include "LDST.h"
#include "LDST_debug.h"

typedef struct cont_stack {
  LDST_t             q_val;
  LDST_cont_t       *q_cont;
  struct cont_stack *q_next;
} cont_stack_t;

struct LDST_chan {
  LDST_t           chan_value;
  LDST_cont_t     *chan_cont;
};

struct LDST_ctxt {
  bool executing;
  int blocked_count;
  cont_stack_t *runnables;
};

LDST_ctxt_t *LDST_context_create(void) {
  LDST_ctxt_t *ctxt = malloc(sizeof *ctxt);
  if (ctxt == 0)
    return 0;

  ctxt->executing = false;
  ctxt->blocked_count = 0;
  ctxt->runnables = 0;
  return ctxt;
}

LDST_res_t LDST_context_wait(LDST_ctxt_t *ctxt) {
  return ctxt->blocked_count > 0 ? LDST_DEADLOCK : LDST_OK;
}

void LDST_context_destroy(LDST_ctxt_t *ctxt) {
  free(ctxt);
}

static LDST_res_t enqueue(LDST_ctxt_t *ctxt, LDST_cont_t *cont, LDST_t value, const char *reason) {
  LOG("enqueue " PTR_FMT " (%s)", PTR_VAL(cont), reason);

  cont_stack_t *runnable = malloc(sizeof(cont_stack_t));
  if (!runnable) {
    return LDST_NO_MEM;
  }

  runnable->q_val  = value;
  runnable->q_cont = cont;
  runnable->q_next = ctxt->runnables;
  ctxt->runnables = runnable;
  return LDST_OK;
}

static void reset_channel(LDST_chan_t *chan) {
  memset(chan, 0, sizeof(LDST_chan_t));
}

LDST_res_t LDST_chan_new(LDST_ctxt_t *ctxt, LDST_chan_t **chan) {
  LDST_chan_t *new_chan = malloc(sizeof(LDST_chan_t));
  LOG("created channel " PTR_FMT, PTR_VAL(new_chan));
  if (!new_chan)
    return LDST_NO_MEM;

  reset_channel(new_chan);
  *chan = new_chan;
  return LDST_OK;
}

static bool should_suspend(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_chan_t *chan) {
  if (chan->chan_cont) {
    ctxt->blocked_count--;
    return false;
  }

  chan->chan_cont = k;
  ctxt->blocked_count++;
  return true;
}

LDST_res_t LDST_chan_send(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *channel, LDST_t value) {
  LOG("send on " PTR_FMT, PTR_VAL(channel));

  LDST_chan_t *chan = channel;
  if (should_suspend(k, ctxt, chan)) {
    LOG("send blocked " PTR_FMT, PTR_VAL(k));
    chan->chan_value = value;
    return LDST_OK;
  }

  // Enqueue the receiving side.
  LDST_res_t res;
  res = LDST_make_recv_result(chan, value, &value);
  if (res != LDST_OK) {
    return res;
  }
  res = enqueue(ctxt, chan->chan_cont, value, "value received");
  if (res != LDST_OK) {
    free(value.val_pair);
    return res;
  }

  // Continue the current thread.
  reset_channel(chan);
  value.val_chan = chan;
  return LDST_invoke(k, ctxt, value);
}

LDST_res_t LDST_chan_recv(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_chan_t *chan) {
  LOG("recv on " PTR_FMT, PTR_VAL(chan));

  if (should_suspend(k, ctxt, chan)) {
    LOG("recv blocked " PTR_FMT, PTR_VAL(k));
    return LDST_OK;
  }

  // Enqueue the sending side.
  LDST_res_t res;
  LDST_t value = { .val_chan = chan };
  res = enqueue(ctxt, chan->chan_cont, value, "value transferred");
  if (res != LDST_OK)
    return res;

  // Create the result value for the calling thread.
  res = LDST_make_recv_result(chan, chan->chan_value, &value);
  if (res != LDST_OK)
    return res;

  // Continue the current thread.
  reset_channel(chan);
  return LDST_invoke(k, ctxt, value);
}

static LDST_res_t run_runnables(LDST_ctxt_t *ctxt) {
  if (ctxt->executing) {
    return LDST_OK;
  }

  LOG("start executing");
  ctxt->executing = true;

  LDST_res_t res = LDST_OK;
  cont_stack_t *runnable;
  while (res == LDST_OK && (runnable = ctxt->runnables)) {
    LOG("BEGIN " PTR_FMT, PTR_VAL(runnable->q_cont));
    ctxt->runnables = runnable->q_next;
    res = LDST_invoke(runnable->q_cont, ctxt, runnable->q_val);
    LOG("  END " PTR_FMT, PTR_VAL(runnable->q_cont));
    free(runnable);
  }

  ctxt->executing = false;
  if (res != LDST_OK)
    return res;

  if (ctxt->blocked_count > 0)
    return LDST_DEADLOCK;

  return LDST_OK;
}

LDST_res_t LDST_fork(LDST_ctxt_t *ctxt, LDST_lam_t op, LDST_t value) {
  LDST_cont_t *k = malloc(sizeof(LDST_cont_t));
  if (!k) {
    return LDST_NO_MEM;
  }

  k->k_lam = op;
  k->k_next = 0;
  LDST_res_t res = enqueue(ctxt, k, value, "fork");
  if (res != LDST_OK) {
    free(k);
    return res;
  }

  return run_runnables(ctxt);
}


<|start_filename|>c-support/runtime/LDST_debug.h<|end_filename|>
//
// LDST_debug.h
//
// Debug macros.  This provides formatted output to stderr, colorized on which
// thread it is running and with support for colorized pointer/address output
// to differentiate the pointer values better.
//

#ifndef LDST_DEBUG_H__
#define LDST_DEBUG_H__

#include <inttypes.h>
#include <pthread.h>
#include <stdint.h>
#include <stdio.h>

#ifdef LDST_DEBUG

#define LDST_DBG_COLOR(n)     (int)((n) * ((n) + 3) % (228L - 21L) + 21L)
#define LDST_DBG_COLOR_FMT    "\033[38;5;%dm"
#define LDST_DBG_COLOR_RESET  "\033[m"

#define PTR_FMT     LDST_DBG_COLOR_FMT "%p" LDST_DBG_COLOR_RESET
#define PTR_VAL(p)  LDST_DBG_COLOR((uintptr_t)(p)), p

#ifdef __APPLE__
#define LDST_DBG_THREADID(var) pthread_threadid_np(0, &var)
#else
// `pthread` is a pointer, just use this value.
#define LDST_DBG_THREADID(var) var = (uintptr_t)pthread_self();
#endif

#define LOG(fmt, ...) do {                                  \
  uint64_t tid__ ## __LINE__;                               \
  LDST_DBG_THREADID(tid__ ## __LINE__);                     \
  printf(                                                   \
    LDST_DBG_COLOR_FMT                                      \
      "[%" PRId64 "] %s:%d  " fmt                           \
    LDST_DBG_COLOR_RESET "\n",                              \
      LDST_DBG_COLOR(tid__ ## __LINE__),                    \
      tid__ ## __LINE__, __func__, __LINE__,                \
      ##__VA_ARGS__);                                       \
} while (0)

#else  // LDST_DEBUG

#define LOG(fmt, ...)

#endif  // LDST_DEBUG

#endif  // LDST_DEBUG_H__


<|start_filename|>test/FunctionSignaturesSpec.hs<|end_filename|>
{-# LANGUAGE BlockArguments #-}
{-# OPTIONS_GHC -Wall #-}
module FunctionSignaturesSpec (spec) where

import Test.Hspec

import Kinds
import Syntax
import Typechecker

spec :: Spec
spec = do
  let tcShouldFail :: [Decl] -> Expectation
      tcShouldFail decls = typecheck decls `shouldNotBe` Right ()

  let tcShouldSucceed :: [Decl] -> Expectation
      tcShouldSucceed decls = typecheck decls `shouldBe` Right ()

  describe "duplicate signatures" do
    it "raises an error if the types agree" do
      tcShouldFail 
        [ DSig "main" Many TInt
        , DSig "main" Many TInt
        ]

    it "raises an error if the types disagree" do
      tcShouldFail
        [ DSig "main" Many TInt
        , DSig "main" Many TUnit
        ]

  describe "duplicate definitions" do
    it "raises an error if the types agree" do
      let decls a r = replicate 2 $ DFun "main" a (Lit LUnit) r
      tcShouldFail $ decls [] Nothing
      tcShouldFail $ decls [] (Just TUnit)
      tcShouldFail $ decls [(MMany, "a", TInt)] Nothing
      tcShouldFail $ decls [(MMany, "a", TInt)] (Just TUnit)

    it "raises an error if the types disagree" do
      tcShouldFail
        [ DFun "main" [] (Lit LUnit) Nothing
        , DFun "main" [(MMany, "a", TInt)] (Lit LUnit) Nothing
        ]

  describe "signature and definition" do
    describe "agreeing types" do
      it "typechecks to give a signature but no return type" do
        tcShouldSucceed
          [ DSig "main" Many $ TFun MMany "a" TInt TUnit
          , DFun "main" [(MMany, "a", TInt)] (Lit LUnit) Nothing
          ]
      it "typechecks to give a signature and return type" do
        tcShouldSucceed
          [ DSig "main" Many $ TFun MMany "a" TInt TUnit
          , DFun "main" [(MMany, "a", TInt)] (Lit LUnit) (Just TUnit)
          ]
      it "typechecks if the parameter names differ" do
        tcShouldSucceed
          [ DSig "main" Many $ TFun MMany "a" TInt TUnit
          , DFun "main" [(MMany, "b", TInt)] (Lit LUnit) Nothing
          ]

    describe "disagreeing types" do
      it "raises an error if the types don't match" do
        tcShouldFail
          [ DSig "main" Many TInt
          , DFun "main" [] (Lit LUnit) Nothing
          ]
      it "raises an error if the returns type doesn't match" do
        -- The function definition would be alright by itself but the return
        -- type has to be equivalent with the given signature.
        tcShouldFail
          [ DSig "main" Many $ TLab ["'A", "'B"]
          , DFun "main" [] (Lit $ LLab "'A") (Just $ TLab ["'A"])
          ]


<|start_filename|>exe/Output.hs<|end_filename|>
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Output where

import Control.Monad.Reader
import Prettyprinter
import Prettyprinter.Util (reflow)
import System.Exit
import System.IO
import qualified Data.Text as Text
import qualified Prettyprinter.Render.Terminal as Terminal
import qualified System.Console.Terminal.Size as Terminal

newtype TerminalSize = TerminalSize (Maybe Int)

type Action = ReaderT TerminalSize IO

runTerminalSize :: Action a -> IO a
runTerminalSize action = do
  !mcols <- stderrColumns
  runReaderT action (TerminalSize mcols)

-- | Tries to determine the size of the terminal attached to stderr using the
-- terminal-size package.
--
-- On windows only @"System.Console.Terminal.Size".'Terminal.size'@ is
-- available, this isn't suitable for the non-windows case: if stdout is
-- redirected but stderr goes to the terminal it will return @Nothing@ instead
-- of the actual terminal dimensions.
stderrColumns :: MonadIO m => m (Maybe Int)
stderrColumns = liftIO $ fmap Terminal.width <$!> size
  where
    size =
#if defined(mingw32_HOST_OS)
      Terminal.size
#else
      Terminal.hSize stderr
#endif


data MsgLevel
  = MsgError
  | MsgWarning

msgWarning :: (MonadReader TerminalSize m, MonadIO m) => String -> m ()
msgWarning = formatMsg MsgWarning Nothing

msgFatal :: (MonadReader TerminalSize m, MonadIO m) => String -> m a
msgFatal msg = formatMsg MsgError Nothing msg >> liftIO exitFailure

formatMsg :: (MonadIO m, MonadReader TerminalSize m) => MsgLevel -> Maybe FilePath -> String -> m ()
formatMsg level mfile msg = do
  let levelDoc =
        let (levelString, color) = case level of
              MsgError -> ("error", Terminal.Red)
              MsgWarning -> ("warning", Terminal.Yellow)
         in annotate (Terminal.color color) $ levelString <> ": "

  let fileDoc = flip foldMap mfile \file ->
        pretty file <> ": "

  let doc = mconcat
        [ annotate Terminal.bold $ fileDoc <> levelDoc
        , nest 4 $ reflow $ Text.pack msg
        ]

  TerminalSize mcols <- ask
  let prettyWidth = maybe Unbounded (\cols -> AvailablePerLine (min cols 80) 0.9) mcols
  let prettyOpts = defaultLayoutOptions { layoutPageWidth = prettyWidth }
  liftIO $ Terminal.renderIO stderr $ layoutPretty prettyOpts doc
  liftIO $ hPutChar stderr '\n'


<|start_filename|>c-support/runtime/LDST_concurrent.c<|end_filename|>
//
// LDST_concurrent.c
//
// Concurrent LDST backend.
//

#include <pthread.h>
#include <stdatomic.h>
#include <stdbool.h>
#include "LDST.h"
#include "LDST_debug.h"
#include "thpool.h"

#ifndef LDST_THREADPOOL_SIZE
#define LDST_THREADPOOL_SIZE 4
#endif

struct LDST_chan {
  pthread_mutex_t  chan_mut;
  LDST_t           chan_value;
  LDST_cont_t     *chan_cont;
};

struct LDST_ctxt {
  threadpool  pool;
  LDST_res_t  error;
  atomic_int  blocked_count;
};

struct Operation {
  LDST_ctxt_t     *ctxt;
  LDST_cont_t     *cont;
  LDST_t           val;
};

LDST_ctxt_t *LDST_context_create(void) {
  LDST_ctxt_t *ctxt = malloc(sizeof *ctxt);
  if (!ctxt) {
    return 0;
  }

  ctxt->pool = thpool_init(LDST_THREADPOOL_SIZE);
  if (!ctxt->pool) {
    free(ctxt);
    return 0;
  }

  ctxt->error = LDST_OK;
  atomic_init(&ctxt->blocked_count, 0);
  return ctxt;
}

LDST_res_t LDST_context_wait(LDST_ctxt_t *ctxt) {
  LOG("waiting on " PTR_FMT, PTR_VAL(ctxt));
  thpool_wait(ctxt->pool);
  LOG("finished   " PTR_FMT, PTR_VAL(ctxt));
  LDST_res_t res = ctxt->error;
  return res == LDST_OK && atomic_load_explicit(&ctxt->blocked_count, memory_order_relaxed) > 0
    ? LDST_DEADLOCK
    : res;
}

void LDST_context_destroy(LDST_ctxt_t *ctxt) {
  thpool_destroy(ctxt->pool);
  free(ctxt);
}

LDST_res_t LDST_chan_new(LDST_ctxt_t *ctxt, LDST_chan_t **chan) {
  LDST_chan_t *new_chan = malloc(sizeof *new_chan);
  LOG("created channel " PTR_FMT, PTR_VAL(new_chan));
  if (!new_chan)
    return LDST_NO_MEM;

  if (pthread_mutex_init(&new_chan->chan_mut, 0) != 0) {
    free(new_chan);
    return LDST_ERR_UNKNOWN;
  }

  new_chan->chan_cont = 0;
  *chan = new_chan;
  return LDST_OK;
}

static void run_work(void *vop) {
  // Unpack the information about what to actually run.
  struct Operation *op = vop;
  LDST_ctxt_t *ctxt = op->ctxt;
  LDST_cont_t *k = op->cont;
  LDST_t val = op->val;
  free(op);

  if (ctxt->error != LDST_OK) {
    // Don't do anything if there is already an error.
    return;
  }

  LOG("starting work " PTR_FMT " (k=" PTR_FMT ", ctxt=" PTR_FMT ")", PTR_VAL(op), PTR_VAL(k), PTR_VAL(ctxt));
  LDST_res_t res = LDST_invoke(k, ctxt, val);
  LOG("work done " PTR_FMT " (res=%d)", PTR_VAL(vop), res);

  // We don't keep track of all errors but only care about remembering any one
  // if there is one.
  if (res != LDST_OK)
    ctxt->error = res;
}

static LDST_res_t enqueue(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_t arg) {
  struct Operation *op = malloc(sizeof *op);
  if (!op)
    return LDST_NO_MEM;

  op->cont = k;
  op->val = arg;
  op->ctxt = ctxt;

  LOG("enqueuing work " PTR_FMT " (k=" PTR_FMT ", ctxt=" PTR_FMT ")", PTR_VAL(op), PTR_VAL(k), PTR_VAL(ctxt));
  bool ok = thpool_add_work(ctxt->pool, run_work, op) == 0;
  return ok ? LDST_OK : LDST_ERR_UNKNOWN;
}

/// Returns the continuation in `chan` and sets it to `NULL` or returns `NULL`
/// and stores `k` if there is none.
///
/// REQUIRES: chan->chan_mut is locked.
static LDST_cont_t *should_suspend(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_chan_t *chan) {
  LDST_cont_t *stored = chan->chan_cont;
  if (stored) {
    chan->chan_cont = 0;
    atomic_fetch_sub_explicit(&ctxt->blocked_count, 1, memory_order_relaxed);
  } else {
    chan->chan_cont = k;
    atomic_fetch_add_explicit(&ctxt->blocked_count, 1, memory_order_relaxed);
  }
  return stored;
}

static LDST_res_t suspend_if_needed(
    LDST_cont_t *k,
    LDST_ctxt_t *ctxt,
    LDST_chan_t *chan,
    LDST_cont_t **stored_k,
    LDST_t *value)
{
  pthread_mutex_t *mutex = &chan->chan_mut;
  if (pthread_mutex_lock(mutex) != 0) {
    return LDST_ERR_UNKNOWN;
  }

  *stored_k = should_suspend(k, ctxt, chan);
  if (*stored_k == 0 && value != 0) {
      chan->chan_value = *value;
  }

  if (pthread_mutex_unlock(mutex) != 0) {
    return LDST_ERR_UNKNOWN;
  }

  return LDST_OK;
}

LDST_res_t LDST_chan_send(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *channel, LDST_t value) {
  LDST_res_t res;
  LDST_cont_t *recv_k;
  LDST_chan_t *chan = channel;

  res = suspend_if_needed(k, ctxt, chan, &recv_k, &value);
  if (res != LDST_OK) {
    return res;
  }

  LOG("send on " PTR_FMT "%s", PTR_VAL(chan), recv_k ? "" : " [blocked]");
  if (!recv_k) {
    // We suspend the current thread because the receiving side has not arrived yet.
    return LDST_OK;
  }

  // Enqueue the receiving side.
  res = LDST_make_recv_result(chan, value, &value);
  if (res != LDST_OK) {
    return res;
  }

  res = enqueue(recv_k, ctxt, value);
  if (res != LDST_OK) {
    free(value.val_pair);
    return res;
  }

  // Continue the current thread.
  value.val_chan = chan;
  return LDST_invoke(k, ctxt, value);
}

LDST_res_t LDST_chan_recv(LDST_cont_t *k, LDST_ctxt_t *ctxt, LDST_chan_t *chan) {
  LDST_res_t res;
  LDST_cont_t *send_k;

  res = suspend_if_needed(k, ctxt, chan, &send_k, 0);
  if (res != LDST_OK) {
    return res;
  }

  LOG("recv on " PTR_FMT "%s", PTR_VAL(chan), send_k ? "" : " [blocked]");
  if (!send_k) {
    // We suspend the current thread because the sending side has not arrived yet.
    return LDST_OK;
  }

  // Create the result value for the calling thread. This either must happen
  // before the `enqueue` to benefit from the implicit channel lock or when
  // the channel mutex is still held.
  LDST_t value;
  res = LDST_make_recv_result(chan, chan->chan_value, &value);
  if (res != LDST_OK) {
    return res;
  }

  // Enqueue the sending side.
  LDST_t chan_value = { .val_chan = chan };
  res = enqueue(send_k, ctxt, chan_value);
  if (res != LDST_OK) {
    free(value.val_pair);
    return res;
  }

  // Continue the current thread.
  return LDST_invoke(k, ctxt, value);
}

LDST_res_t LDST_fork(LDST_ctxt_t *ctxt, LDST_lam_t op, LDST_t value) {
  LOG("forking execution");
  LDST_cont_t *k = malloc(sizeof(LDST_cont_t));
  if (!k) {
    return LDST_NO_MEM;
  }

  k->k_lam = op;
  k->k_next = 0;

  LDST_res_t res = enqueue(k, ctxt, value);
  if (res != LDST_OK) {
    free(k);
  }

  return res;
}

/*
struct SyncInfo {
  LDST_lam_t        op;
  LDST_t           *result;
  bool              has_result;
};

static LDST_res_t assign_k(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *vinfo, LDST_t val) {
  struct SyncInfo *info = vinfo;
  *info->result = val;
  LOG("result assigned, posting");
  //uv_sem_post(&info->sem);
  return LDST_invoke(k, ctxt, val);
}

static LDST_res_t assign(LDST_cont_t *then_k, LDST_ctxt_t *ctxt, void *vinfo, LDST_t arg) {
  struct SyncInfo *info = vinfo;
  LDST_cont_t *k = malloc(sizeof(LDST_cont_t));
  if (!k)
    return LDST_NO_MEM;

  k->k_lam.lam_fp = assign_k;
  k->k_lam.lam_closure = vinfo;
  k->k_next = then_k;
  return info->op.lam_fp(k, ctxt, info->op.lam_closure, arg);
}

LDST_res_t LDST_sync(LDST_ctxt_t *ctxt, LDST_t *result, LDST_lam_t op, LDST_t value) {
  struct SyncInfo info = { .op = op, .result = result };
  if (pthread_mutex_init(&info.result_mutex, 0) != 0)
    return LDST_ERR_UNKNOWN;

  if (pthread_cond_init(&info.result_cond, 0) != 0) {
    pthread_mutex_destroy(&info.result_mutex);
    return LDST_ERR_UNKNOWN;
  }

  LOG("initial fork");
  LDST_lam_t storing_op = { assign, &info };
  LDST_res_t res = LDST_fork(ctxt, storing_op, value);

  LOG("waiting for completion, fork=%d", res);
  thpool_wait(ctxt->pool);


  LOG("result available");
//  uv_sem_destroy(&info.sem);
//  uv_loop_close(&sync_loop);

  res = LDST_merge_res(atomic_load_explicit(&detached_res, memory_order_relaxed), res);
  return atomic_load_explicit(&BlockedCount, memory_order_relaxed) > 0
    ? LDST_merge_res(LDST_DEADLOCK, res)
    : res;
}
*/


<|start_filename|>c-support/runtime/LDST.c<|end_filename|>
//
// LDST.c
//
// Supporting functions.
//

#include <assert.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "LDST.h"
#include "LDST_debug.h"

struct SyncInfo {
  LDST_t *result;
  union {
    LDST_lam_t op;
    bool has_result;
  };
};

static LDST_res_t assign_k(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *vinfo, LDST_t val) {
  struct SyncInfo *info = vinfo;

  LOG("assigning to " PTR_FMT " (&result=" PTR_FMT ")", PTR_VAL(info), PTR_VAL(info->result));
  *info->result = val;
  info->has_result = true;
  return LDST_invoke(k, ctxt, val);
}

static LDST_res_t assign(LDST_cont_t *then_k, LDST_ctxt_t *ctxt, void *vinfo, LDST_t arg) {
  LDST_cont_t *k = malloc(sizeof(LDST_cont_t));
  if (!k)
    return LDST_NO_MEM;

  struct SyncInfo *info = vinfo;
  LDST_lam_t op = info->op;
  info->has_result = false;
  k->k_lam.lam_fp = assign_k;
  k->k_lam.lam_closure = info;
  k->k_next = then_k;
  return op.lam_fp(k, ctxt, op.lam_closure, arg);
}

LDST_res_t LDST_sync(LDST_ctxt_t *ctxt, LDST_t *result, LDST_lam_t op, LDST_t arg) {
  LDST_res_t res;
  struct SyncInfo info = { result, { .op = op } };
  LDST_lam_t assign_op = { assign, &info };

  LOG("beginning sync " PTR_FMT " (&result=" PTR_FMT ")", PTR_VAL(&info), PTR_VAL(result));
  res = LDST_fork(ctxt, assign_op, arg);
  if (res != LDST_OK)
    return res;

  res = LDST_context_wait(ctxt);
  if (res != LDST_OK)
    return res;

  return info.has_result ? LDST_OK : LDST_NO_RESULT;
}

struct RunInfo {
  int n;
  LDST_t *args;
};

static LDST_res_t run_impl(LDST_cont_t *k_then, LDST_ctxt_t *ctxt, void *run_info, LDST_t value) {
  struct RunInfo *info = run_info;
  LDST_cont_t *k_now = k_then;

  if (info->n > 1) {
    // Create a new continuation to apply the remaining arguments is required.
    struct RunInfo *new_info = malloc(sizeof *new_info);
    if (!new_info) {
      return LDST_NO_MEM;
    }

    k_now = malloc(sizeof(LDST_cont_t));
    if (!k_now) {
      free(new_info);
      return LDST_NO_MEM;
    }

    new_info->n = info->n - 1;
    new_info->args = info->args + 1;
    k_now->k_lam.lam_fp = run_impl;
    k_now->k_lam.lam_closure = new_info;
    k_now->k_next = k_then;
  }

  LDST_lam_t lam = value.val_lam;
  return lam.lam_fp(k_now, ctxt, lam.lam_closure, info->args[0]);
}

static LDST_res_t run_impl0(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *run_info, LDST_t value) {
  LDST_fp0_t fp = (LDST_fp0_t)value.val_lam.lam_fp;

  if (run_info) {
    LDST_cont_t *k_new = malloc(sizeof *k_new);
    k_new->k_next = k;
    k_new->k_lam.lam_fp = run_impl;
    k_new->k_lam.lam_closure = run_info;
    k = k_new;
  }

  return fp(k, ctxt);
}

LDST_res_t LDST_run(LDST_ctxt_t *ctxt, LDST_t *result, LDST_fp0_t f, int n, LDST_t *args) {
  struct RunInfo *info = 0;
  if (n > 0) {
    info = malloc(sizeof *info);

    if (!info)
      return LDST_NO_MEM;

    info->n = n;
    info->args = args;
  }

  LDST_lam_t lambda = { run_impl0, info };
  LDST_t arg0 = { .val_lam = { (LDST_fp_t)f, 0 } };
  return LDST_sync(ctxt, result, lambda, arg0);
}

LDST_t LDST_main(LDST_fp0_t f) {
  LDST_t result;
  LDST_ctxt_t *ctxt = LDST_context_create();
  LDST_res_t err = ctxt ? LDST_run(ctxt, &result, f, 0, 0) : LDST_NO_MEM;

  switch (err) {
    case LDST_OK:
      return result;
    case LDST_NO_MEM:
      fputs("error: out of memory\n", stderr);
      break;
    case LDST_DEADLOCK:
      fputs("error: deadlocked\n", stderr);
      break;
    case LDST_UNMATCHED_LABEL:
      fputs("error: unmatched label\n", stderr);
      break;
    case LDST_NO_RESULT:
      fputs("error: result not available\n", stderr);
      break;
    default:
      fputs("error: unknown error\n", stderr);
      break;
  }
  exit(err);
}

static LDST_res_t nat_fold_k(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *void_closure, LDST_t v) {
  // closure[0] = f
  // closure[1] = n
  // closure[2] = i
  // closure[3] = a
  LDST_t *closure = void_closure;

  LDST_cont_t *new_k = malloc(sizeof(LDST_cont_t));
  if (!new_k)
    return LDST_NO_MEM;

  new_k->k_lam.lam_fp = LDST_nat_fold;
  new_k->k_lam.lam_closure = closure;
  new_k->k_next = k;

  LDST_t a = closure[3];
  LDST_lam_t f = v.val_lam;
  return f.lam_fp(new_k, ctxt, f.lam_closure, a);
}

/*
 * natrec n { z, n'. T. (a : T). e }  ~  foldr (\n' a -> e) z n
 *
 * ==> Pseudo Haskell (f == \n' a. e)
 *
 *   nat-fold f n z = go 0 z
 *     where go i a = if n == i then a else go (i+1) (f i a)
 *
 * ==> Eta reduction, explicit currying, capture lists
 *
 *   nat-fold f n = go [f n i=0]
 *   go [f n i] a = if n == i then a else go [f n i=i-1] (f i a)
 *
 * This function (`ldst_nat_fold`) directly corresponds to `go` (first
 * argument already applied) and therefore has to be called with the correct
 * closure: A list of three values in the order of `f`, `n`, `i`.
 */
LDST_res_t LDST_nat_fold(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *void_closure, LDST_t a) {
  // closure[0] = f
  // closure[1] = n
  // closure[2] = i
  LDST_t *closure = void_closure;
  int n = closure[1].val_int;
  int i = closure[2].val_int;

  if (n == i)
    return LDST_invoke(k, ctxt, a);

  // The closure is reused both for the continuation and in there (see
  // `nat_fold_k`) it is also used as the closure to the recusive call to
  // `ldst_nat_fold` (this function).
  LDST_t *new_closure = malloc(4 * sizeof(LDST_t));
  if (!new_closure)
    return LDST_NO_MEM;

  LDST_cont_t *new_k = malloc(sizeof(LDST_cont_t));
  if (!new_k) {
    free(new_closure);
    return LDST_NO_MEM;
  }

  LDST_lam_t f = closure[0].val_lam;
  new_closure[0].val_lam = f;
  new_closure[1].val_int = n;
  new_closure[2].val_int = i + 1;
  new_closure[3] = a;

  new_k->k_lam.lam_fp = nat_fold_k;
  new_k->k_lam.lam_closure = new_closure;
  new_k->k_next = k;

  LDST_t idx = { .val_int = i };
  return f.lam_fp(new_k, ctxt, f.lam_closure, idx);
}

// The recv operator returns a pair where the first element is the received
// value and the second element is the "new" channel.
LDST_res_t LDST_make_recv_result(LDST_chan_t *chan, LDST_t value, LDST_t *result) {
  LDST_t *received_pair = malloc(2 * sizeof(LDST_t));
  if (!received_pair)
    return LDST_NO_MEM;

  received_pair[0] = value;
  received_pair[1].val_chan = chan;
  result->val_pair = received_pair;
  return LDST_OK;
}

struct CurryInfo {
  LDST_lam_t dest;
  int captured_count;
  int remaining_count;
  LDST_t captures[];
};

static LDST_res_t curry_impl(LDST_cont_t *k, LDST_ctxt_t *ctxt, void *closure, LDST_t arg) {
  struct CurryInfo *info = closure;
  assert(info->remaining_count > 0 && "no arguments left to curry");

  int old_capture_size = info->captured_count * sizeof(LDST_t);
  int new_capture_size = old_capture_size + sizeof(LDST_t);

  if (info->remaining_count == 1) {
    // `arg` is the last remaining argument, meaning we can now invoke the
    // function.
    LDST_t *captures = malloc(new_capture_size);
    if (!captures)
      return LDST_NO_MEM;

    memcpy(captures, info->captures, old_capture_size);
    captures[info->captured_count] = arg;

    arg.val_pair = captures;
    return info->dest.lam_fp(k, ctxt, info->dest.lam_closure, arg);
  }

  struct CurryInfo *new_info = malloc(sizeof *new_info + new_capture_size);
  if (!new_info)
    return LDST_NO_MEM;

  new_info->dest = info->dest;
  new_info->captured_count = info->captured_count + 1;
  new_info->remaining_count = info->remaining_count - 1;
  memcpy(new_info->captures, info->captures, old_capture_size);
  new_info->captures[info->captured_count] = arg;

  LDST_t result = { .val_lam = { curry_impl, new_info } };
  return LDST_invoke(k, ctxt, result);
}

LDST_res_t LDST_curry(LDST_t *value, LDST_lam_t uncurried, int n) {
  if (n < 1) {
    // The function has to take at least one argument.
    return LDST_ERR_UNKNOWN;
  }

  struct CurryInfo *info = malloc(sizeof *info);
  if (!info) {
    return LDST_NO_MEM;
  }

  info->dest = uncurried;
  info->captured_count = 0;
  info->remaining_count = n;

  value->val_lam.lam_fp = curry_impl;
  value->val_lam.lam_closure = info;
  return LDST_OK;
}
