From fc4b39d65fb2aaf875988047454fcc7abdad1be2 Mon Sep 17 00:00:00 2001
From: krasimir <krasimir@chalmers.se>
Date: Mon, 27 Apr 2015 16:28:45 +0000
Subject: [PATCH] make linearizeAll in the Haskell binding lazy

---
 src/runtime/haskell-bind/PGF2.hsc | 27 +++++++++++++++------------
 1 file changed, 15 insertions(+), 12 deletions(-)

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 07bbcbc96..870a6eb02 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -458,19 +458,20 @@ linearize lang e = unsafePerformIO $
 
 linearizeAll :: Concr -> Expr -> [String]
 linearizeAll lang e = unsafePerformIO $
-  withGuPool $ \pl ->
-    do exn <- gu_new_exn pl
-       cts <- pgf_lzr_concretize (concr lang) (expr e) exn pl
-       failed <- gu_exn_is_raised exn
-       if failed
-         then throwExn exn
-         else collect cts exn pl
+  do pl <- gu_new_pool
+     exn <- gu_new_exn pl
+     cts <- pgf_lzr_concretize (concr lang) (expr e) exn pl
+     failed <- gu_exn_is_raised exn
+     if failed
+       then throwExn exn pl
+       else collect cts exn pl
   where
     collect cts exn pl = do
       ctree <- alloca $ \ptr -> do gu_enum_next cts ptr pl
                                    peek ptr
       if ctree == nullPtr
-        then return []
+        then do gu_pool_free pl
+                return []
         else do (sb,out) <- newOut pl
                 ctree <- pgf_lzr_wrap_linref ctree pl
                 pgf_lzr_linearize_simple (concr lang) ctree 0 out exn pl
@@ -479,19 +480,21 @@ linearizeAll lang e = unsafePerformIO $
                   then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist
                           if is_nonexist
                             then collect cts exn pl
-                            else throwExn exn
+                            else throwExn exn pl
                   else do lin <- gu_string_buf_freeze sb pl
                           s <- peekCString lin
-                          ss <- collect cts exn pl
+                          ss <- unsafeInterleaveIO (collect cts exn pl)
                           return (s:ss)
 
-    throwExn exn = do
+    throwExn exn pl = do
       is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
       if is_exn
         then do c_msg <- (#peek GuExn, data.data) exn
                 msg <- peekCString c_msg
+                gu_pool_free pl
                 throwIO (PGFError msg)
-        else throwIO (PGFError "The abstract tree cannot be linearized")
+        else do gu_pool_free pl
+                throwIO (PGFError "The abstract tree cannot be linearized")
 
 alignWords :: Concr -> Expr -> [(String, [Int])]
 alignWords lang e = unsafePerformIO $