From afd15ee01761616545a3ac991e98ef20902870a8 Mon Sep 17 00:00:00 2001
From: Olle Fredriksson <fredriksson.olle@gmail.com>
Date: Mon, 6 Apr 2020 20:54:27 +0200
Subject: [PATCH] Implement lazy using unsafeDupablePerformIO

This might be faster than using an IORef, though I don't notice any
difference when measuring. The API should be safe even though it's
implemented using unsafe functions.

Ref. https://github.com/ollef/sixty/issues/2.
---
 src/Domain.hs |  2 +-
 src/Monad.hs  | 26 +++++++++++++++-----------
 2 files changed, 16 insertions(+), 12 deletions(-)

diff --git a/src/Domain.hs b/src/Domain.hs
index 72314468..4ef41d24 100644
--- a/src/Domain.hs
+++ b/src/Domain.hs
@@ -22,7 +22,7 @@ import Var (Var)
 data Value
   = Neutral !Head Spine
   | Lit !Literal
-  | Glued !Head Spine !(Lazy Value)
+  | Glued !Head Spine (Lazy Value)
   | Lam !Name !Type !Plicity !Closure
   | Pi !Name !Type !Plicity !Closure
   | Fun !Type !Plicity !Type
diff --git a/src/Monad.hs b/src/Monad.hs
index 64a982d7..8d6ac906 100644
--- a/src/Monad.hs
+++ b/src/Monad.hs
@@ -4,10 +4,11 @@ module Monad where
 
 import Protolude hiding (try, State)
 
-import Control.Monad.Base
 import Data.IORef.Lifted
+import Control.Monad.Trans.Control
 import Control.Exception.Lifted
 import Rock
+import System.IO.Unsafe (unsafeDupablePerformIO)
 
 import qualified Error
 import Query (Query)
@@ -19,19 +20,22 @@ newtype State = State
   { nextVar :: IORef Var
   }
 
-newtype Lazy a = Lazy { force :: M a }
+newtype Lazy a = Lazy a
 
-lazy :: MonadBase IO m => M a -> m (Lazy a)
-lazy m = do
-  ref <- newIORef $ panic "Can't happen, I promise!"
-  writeIORef ref $ do
-    result <- m
-    writeIORef ref $ pure result
-    pure result
-  pure $ Lazy $ join $ readIORef ref
+{-# inline force #-}
+force :: Lazy a -> M a
+force (Lazy a) =
+  a `seq` pure a
+
+{-# inline lazy #-}
+lazy :: M a -> M (Lazy a)
+lazy m =
+  liftBaseWith $ \runInIO ->
+    pure $ Lazy $ unsafeDupablePerformIO $ runInIO m
 
 eager :: a -> Lazy a
-eager = Lazy . pure
+eager =
+  Lazy
 
 freshVar :: M Var
 freshVar = do