diff options
| author | krasimir <krasimir@chalmers.se> | 2015-04-27 16:28:45 +0000 |
|---|---|---|
| committer | krasimir <krasimir@chalmers.se> | 2015-04-27 16:28:45 +0000 |
| commit | fc4b39d65fb2aaf875988047454fcc7abdad1be2 (patch) | |
| tree | 3360fa99fc74af4f4ad9024ce9e2e048b91c7259 /src | |
| parent | 8efff76703b4ac8cfb56f872d9a3866c5f3ad7ba (diff) | |
make linearizeAll in the Haskell binding lazy
Diffstat (limited to 'src')
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 27 |
1 files 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 $ |