MVars revisited

First attempt at solution

type Account = MVar Double

transfer :: Double -> Account -> Account -> IO ()
transfer amount from to =
  modifyMVar_ from $ \bf -> do
    when (bf < amount) $ fail "not enough money"
    modifyMVar_ to $ \bt -> return $! bt + amount
    return $! bf - amount

First attempt at solution

type Account = MVar Double

transfer :: Double -> Account -> Account -> IO ()
transfer amount from to =
  modifyMVar_ from $ \bf -> do
    when (bf < amount) $ fail "not enough money"
    modifyMVar_ to $ \bt -> return $! bt + amount
    return $! bf - amount

Second attempt at solution

transfer :: Double -> Account -> Account -> IO ()
transfer amount from to = do
  let tryTransfer = modifyMVar from $ \ bf -> do
        when (bf < amount) $ fail "not enough money"
        mbt <- tryTakeMVar to
        case mbt of
          Just bt -> do putMVar to $! bt + amount
                        return (bf - amount, True)
          Nothing -> return (bf, False)
  ok <- tryTransfer
  unless ok $ safetransfer (- amount) to from

Software transactional memory

STM basics

STM Example

type Account = TVar Double

transfer :: Double -> Account -> Account -> STM ()
transfer amount from to = do
  modifyTVar' from (subtract amount)
  modifyTVar' to (+ amount)

main :: IO ()
main = do
  ac1 <- newTVarIO 10
  ac2 <- newTVarIO 0
  atomically $ transfer 1 ac1 ac2

Aborting

retry :: STM a
orElse :: STM a -> STM a -> STM a

Enforcing invariants

alwaysSucceeds :: STM a -> STM ()
newAccount :: Double -> STM Account
newAccount balance = do
  tv <- newTVar balance
  alwaysSucceeds $ do balance <- readTVar tv
                      when (balance < 0) $ fail "negative balance"
  return tv

bogus :: IO ()
bogus = do
  ac <- atomically $ newAccount 10
  atomically $ modifyTVar ac (subtract 15)
*Main> bogus
*** Exception: negative balance

Switching gears...

Naïve Haskell data representation

Add level of indirection to describe values

typedef struct Val {
  const struct ValInfo *info;
  struct Val *args[];
} Val;

/* Statically allocated at compile time.  Only one per
 * constructor (or closure-creating expression, etc.) */
struct ValInfo {
  struct GCInfo gcInfo;  /* for garbage collector */
  enum { CONSTRNO, FUNC, THUNK, IND } tag;
  union {
    unsigned int constrno;
    Val *(*func) (const Val *closure, const Val *arg);
    Exception *(*thunk) (Val *closure);
  };
};

Function values

Closures

Thunk values

Forcing

Currying

Code for currying example

const3 :: a -> b -> c -> a
const3 a b c = a
Val *const3_1 (Val *ignored, Val *a)
{
  v = (Val *) gc_malloc (offsetof (Val, args[1]));
  v->info = &const3_2_info;  /* func = const3_2 */
  v->args[0] = a;
  return v;
}

Val *const3_2 (Val *closure, Val *b)
{
  v = (Val *) gc_malloc (offsetof (Val, args[2]));
  v->info = &const3_3_info;  /* func = const3_3 */
  v->args[0] = b;
  v->args[1] = closure;
  return v;
}

Val *const3_3 (Val *v, Val *c)
{
  return v->args[1]->args[0];
}

Unboxed types

Unboxed types in GHC

Restrictions on unboxed types

seq revisited

Example: hypothetical seq implementation

const struct ValInfo seq_info = {
  some_gcinfo, THUNK, .thunk = &seq_thunk
};

Val *seq_2 (Val *closure, Val *b)
{ /* assume seq_1 put first arg of (seq a b) in closure */
  c = (Val *) gc_malloc (offsetof (Val, args[2]));
  c->info = &seq_info;
  c->args[0] = closure->args[0];
  c->args[1] = b;
  return c;
}

Exception *seq_thunk (Void *c)
{
  Exception *e = force (&c->args[0]);
  if (!e) {
    c->info = &ind_info;     /* ValInfo with tag = IND */
    c->args[0] = c->args[1]; /* forward to b */
  }
  return e;
}

Strictness revisited

Semantic effects of strictness

case statements revisited

newtype declarations

newtype semantics

newtype semantics

The UNPACK pragma

ByteStrings

Lazy ByteStrings

Lazy ByteString implementation