From fd2aa96e65c8fa79a572791fec925877cccd9af5 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Wed, 14 Nov 2018 15:52:44 +0100 Subject: [PATCH] use interleaved IO for peeking strings when possible --- src/runtime/haskell-bind/PGF2.hsc | 52 +++++++++++++------------- src/runtime/haskell-bind/PGF2/Expr.hsc | 16 ++++---- src/runtime/haskell-bind/PGF2/FFI.hsc | 18 +++++++++ src/runtime/haskell-bind/PGF2/Type.hsc | 34 ++++++++--------- src/runtime/haskell-bind/SG.hsc | 22 +++++------ 5 files changed, 80 insertions(+), 62 deletions(-) diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 9583eb7b5..7fa5ca563 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -140,13 +140,13 @@ readPGF fpath = showPGF :: PGF -> String showPGF p = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - exn <- gu_new_exn tmpPl - pgf_print (pgf p) out exn - touchPGF p - peekUtf8CStringBuf sb + unsafePerformIO $ do + tmpPl <- gu_new_pool + (sb,out) <- newOut tmpPl + exn <- gu_new_exn tmpPl + pgf_print (pgf p) out exn + touchPGF p + peekUtf8CStringBufResult sb tmpPl -- | List of all languages available in the grammar. languages :: PGF -> Map.Map ConcName Concr @@ -410,37 +410,37 @@ graphvizDefaults = GraphvizOptions False False False True "" "" "" "" "" "" -- | Renders an abstract syntax tree in a Graphviz format. graphvizAbstractTree :: PGF -> GraphvizOptions -> Expr -> String graphvizAbstractTree p opts e = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - exn <- gu_new_exn tmpPl - c_opts <- newGraphvizOptions tmpPl opts - pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn - touchExpr e - peekUtf8CStringBuf sb + unsafePerformIO $ do + tmpPl <- gu_new_pool + (sb,out) <- newOut tmpPl + exn <- gu_new_exn tmpPl + c_opts <- newGraphvizOptions tmpPl opts + pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn + touchExpr e + peekUtf8CStringBufResult sb tmpPl graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String graphvizParseTree c opts e = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - exn <- gu_new_exn tmpPl - c_opts <- newGraphvizOptions tmpPl opts - pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn - touchExpr e - peekUtf8CStringBuf sb + unsafePerformIO $ do + tmpPl <- gu_new_pool + (sb,out) <- newOut tmpPl + exn <- gu_new_exn tmpPl + c_opts <- newGraphvizOptions tmpPl opts + pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn + touchExpr e + peekUtf8CStringBufResult sb tmpPl graphvizWordAlignment :: [Concr] -> GraphvizOptions -> Expr -> String graphvizWordAlignment cs opts e = unsafePerformIO $ - withGuPool $ \tmpPl -> withArrayLen (map concr cs) $ \n_concrs ptr -> - do (sb,out) <- newOut tmpPl + do tmpPl <- gu_new_pool + (sb,out) <- newOut tmpPl exn <- gu_new_exn tmpPl c_opts <- newGraphvizOptions tmpPl opts pgf_graphviz_word_alignment ptr (fromIntegral n_concrs) (expr e) c_opts out exn touchExpr e - peekUtf8CStringBuf sb + peekUtf8CStringBufResult sb tmpPl newGraphvizOptions :: Ptr GuPool -> GraphvizOptions -> IO (Ptr PgfGraphvizOptions) newGraphvizOptions pool opts = do diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc index d66b51c2b..47978b6e5 100644 --- a/src/runtime/haskell-bind/PGF2/Expr.hsc +++ b/src/runtime/haskell-bind/PGF2/Expr.hsc @@ -252,14 +252,14 @@ foreign import ccall "wrapper" -- of binding. showExpr :: [CId] -> Expr -> String showExpr scope e = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - printCtxt <- newPrintCtxt scope tmpPl - exn <- gu_new_exn tmpPl - pgf_print_expr (expr e) printCtxt 1 out exn - touchExpr e - peekUtf8CStringBuf sb + unsafePerformIO $ do + tmpPl <- gu_new_pool + (sb,out) <- newOut tmpPl + printCtxt <- newPrintCtxt scope tmpPl + exn <- gu_new_exn tmpPl + pgf_print_expr (expr e) printCtxt 1 out exn + touchExpr e + peekUtf8CStringBufResult sb tmpPl newPrintCtxt :: [String] -> Ptr GuPool -> IO (Ptr PgfPrintContext) newPrintCtxt [] pool = return nullPtr diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc index 563522a5d..ccad67480 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hsc +++ b/src/runtime/haskell-bind/PGF2/FFI.hsc @@ -15,6 +15,7 @@ import Control.Exception import GHC.Ptr import Data.Int import Data.Word +import System.IO.Unsafe type Touch = IO () @@ -198,6 +199,23 @@ peekUtf8CStringBuf sbuf = do len <- gu_string_buf_length sbuf peekUtf8CStringLen ptr (fromIntegral len) +peekUtf8CStringBufResult :: Ptr GuStringBuf -> Ptr GuPool -> IO String +peekUtf8CStringBufResult sbuf pool = do + fptr <- newForeignPtr gu_pool_finalizer pool + ptr <- gu_string_buf_data sbuf + len <- gu_string_buf_length sbuf + pptr <- gu_malloc pool (#size GuString*) + poke pptr ptr >> decode fptr pptr (ptr `plusPtr` fromIntegral len) + where + decode fptr pptr end = do + ptr <- peek pptr + if ptr >= end + then return [] + else do x <- gu_utf8_decode pptr + cs <- unsafeInterleaveIO (decode fptr pptr end) + touchForeignPtr fptr + return (((toEnum . fromEnum) x) : cs) + pokeUtf8CString :: String -> CString -> IO () pokeUtf8CString s ptr = alloca $ \pptr -> diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell-bind/PGF2/Type.hsc index 1228accd7..c92653648 100644 --- a/src/runtime/haskell-bind/PGF2/Type.hsc +++ b/src/runtime/haskell-bind/PGF2/Type.hsc @@ -45,14 +45,14 @@ readType str = -- of binding. showType :: [CId] -> Type -> String showType scope (Type ty touch) = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - printCtxt <- newPrintCtxt scope tmpPl - exn <- gu_new_exn tmpPl - pgf_print_type ty printCtxt 0 out exn - touch - peekUtf8CStringBuf sb + unsafePerformIO $ do + tmpPl <- gu_new_pool + (sb,out) <- newOut tmpPl + printCtxt <- newPrintCtxt scope tmpPl + exn <- gu_new_exn tmpPl + pgf_print_type ty printCtxt 0 out exn + touch + peekUtf8CStringBufResult sb tmpPl -- | creates a type from a list of hypothesises, a category and -- a list of arguments for the category. The operation @@ -128,12 +128,12 @@ unType (Type c_type touch) = unsafePerformIO $ do -- of binding. showContext :: [CId] -> [Hypo] -> String showContext scope hypos = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl - printCtxt <- newPrintCtxt scope tmpPl - exn <- gu_new_exn tmpPl - pgf_print_context c_hypos printCtxt out exn - mapM_ touchHypo hypos - peekUtf8CStringBuf sb + unsafePerformIO $ do + tmpPl <- gu_new_pool + (sb,out) <- newOut tmpPl + c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl + printCtxt <- newPrintCtxt scope tmpPl + exn <- gu_new_exn tmpPl + pgf_print_context c_hypos printCtxt out exn + mapM_ touchHypo hypos + peekUtf8CStringBufResult sb tmpPl diff --git a/src/runtime/haskell-bind/SG.hsc b/src/runtime/haskell-bind/SG.hsc index aa23de3a0..f2c6839c3 100644 --- a/src/runtime/haskell-bind/SG.hsc +++ b/src/runtime/haskell-bind/SG.hsc @@ -196,17 +196,17 @@ readTriple str = showTriple :: Expr -> Expr -> Expr -> String showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) = unsafePerformIO $ - withGuPool $ \tmpPl -> - withTriple $ \triple -> do - (sb,out) <- newOut tmpPl - let printCtxt = nullPtr - exn <- gu_new_exn tmpPl - pokeElemOff triple 0 expr1 - pokeElemOff triple 1 expr2 - pokeElemOff triple 2 expr3 - pgf_print_expr_tuple 3 triple printCtxt out exn - touch1 >> touch2 >> touch3 - peekUtf8CStringBuf sb + withTriple $ \triple -> do + tmpPl <- gu_new_pool + (sb,out) <- newOut tmpPl + let printCtxt = nullPtr + exn <- gu_new_exn tmpPl + pokeElemOff triple 0 expr1 + pokeElemOff triple 1 expr2 + pokeElemOff triple 2 expr3 + pgf_print_expr_tuple 3 triple printCtxt out exn + touch1 >> touch2 >> touch3 + peekUtf8CStringBufResult sb tmpPl insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =