msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

first draft of the new allocator with transactions support

Browse Source
This commit is contained in:
Krasimir Angelov
2022-05-20 13:55:45 +02:00
parent 546dc01b5d
commit 5594679a83
24 changed files with 1582 additions and 2372 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
src/runtime/haskell/PGF2/FFI.hsc
View File

@@ -73,8 +73,6 @@ foreign import ccall pgf_merge_pgf :: Ptr PgfDB -> Ptr PGF -> CString -> Ptr Pgf
foreign import ccall pgf_write_pgf :: CString -> Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -> IO ()
foreign import ccall "pgf_free_revision" pgf_free_revision_ :: Ptr PgfDB -> Ptr PGF -> IO ()
foreign import ccall "&pgf_free_revision" pgf_free_revision :: FinalizerEnvPtr PgfDB PGF
foreign import ccall "pgf_free_concr_revision" pgf_free_concr_revision_ :: Ptr PgfDB -> Ptr Concr -> IO ()
@@ -177,11 +175,13 @@ foreign import ccall pgf_infer_expr :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Ex
foreign import ccall pgf_check_type :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Type) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO ()
foreign import ccall pgf_clone_revision :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PGF)
foreign import ccall pgf_start_transaction :: Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -> IO (Ptr PGF)
foreign import ccall pgf_commit_revision :: Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -> IO ()
foreign import ccall pgf_commit_transaction :: Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -> IO ()
foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PGF)
foreign import ccall pgf_rollback_transaction :: Ptr PgfDB -> Ptr PGF -> IO ()
foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfExn -> IO (Ptr PGF)
foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> StablePtr Type -> CSize -> Ptr CChar -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()

41
src/runtime/haskell/PGF2/Transactions.hsc
View File

@@ -3,7 +3,6 @@ module PGF2.Transactions
-- abstract syntax
, modifyPGF
, branchPGF
, checkoutPGF
, createFunction
, dropFunction
@@ -81,53 +80,39 @@ instance Monad (Transaction k) where
the new function @foo@.
-}
modifyPGF :: PGF -> Transaction PGF a -> IO PGF
modifyPGF = branchPGF_ nullPtr
{- | @branchPGF gr branch_name t@ is similar to @modifyPGF gr t@,
except that it stores the result as a branch with the given name.
-}
branchPGF :: PGF -> String -> Transaction PGF a -> IO PGF
branchPGF p name t =
withText name $ \c_name ->
branchPGF_ c_name p t
branchPGF_ :: Ptr PgfText -> PGF -> Transaction PGF a -> IO PGF
branchPGF_ c_name p (Transaction f) =
modifyPGF p (Transaction f) =
withForeignPtr (a_revision p) $ \c_revision ->
withPgfExn "branchPGF" $ \c_exn ->
withPgfExn "modifyPGF" $ \c_exn ->
mask $ \restore -> do
c_revision <- pgf_clone_revision (a_db p) c_revision c_name c_exn
c_revision <- pgf_start_transaction (a_db p) c_revision c_exn
ex_type <- (#peek PgfExn, type) c_exn
if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
then do ((restore (f (a_db p) c_revision c_revision c_exn))
`catch`
(\e -> do
pgf_free_revision_ (a_db p) c_revision
pgf_rollback_transaction (a_db p) c_revision
throwIO (e :: SomeException)))
ex_type <- (#peek PgfExn, type) c_exn
if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
then do pgf_commit_revision (a_db p) c_revision c_exn
then do pgf_commit_transaction (a_db p) c_revision c_exn
ex_type <- (#peek PgfExn, type) c_exn
if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
then do fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision
langs <- getConcretes (a_db p) fptr
return (PGF (a_db p) fptr langs)
else do pgf_free_revision_ (a_db p) c_revision
else do pgf_rollback_transaction (a_db p) c_revision
return p
else do pgf_free_revision_ (a_db p) c_revision
else do pgf_rollback_transaction (a_db p) c_revision
return p
else return p
{- | Retrieves the branch with the given name -}
checkoutPGF :: PGF -> String -> IO (Maybe PGF)
checkoutPGF p name =
withText name $ \c_name -> do
c_revision <- withPgfExn "checkoutPGF" (pgf_checkout_revision (a_db p) c_name)
if c_revision == nullPtr
then return Nothing
else do fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision
langs <- getConcretes (a_db p) fptr
return (Just (PGF (a_db p) fptr langs))
checkoutPGF :: PGF -> IO PGF
checkoutPGF p = do
c_revision <- withPgfExn "checkoutPGF" (pgf_checkout_revision (a_db p))
fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision
langs <- getConcretes (a_db p) fptr
return (PGF (a_db p) fptr langs)
createFunction :: Fun -> Type -> Int -> [[Instr]] -> Float -> Transaction PGF ()
createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_exn ->

15
src/runtime/haskell/tests/transactions.hs
View File

@@ -9,13 +9,12 @@ main = do
gr1 <- readPGF "tests/basic.pgf"
let Just ty = readType "(N -> N) -> P (s z)"
gr2 <- modifyPGF gr1 (createFunction "foo" ty 0 [] pi >>
createCategory "Q" [(Explicit,"x",ty)] pi)
gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty 0 [] pi >>
createCategory "R" [(Explicit,"x",ty)] pi)
print 1
gr2 <- modifyPGF gr1 (createFunction "foo" ty 0 [] pi >>
createCategory "Q" [(Explicit,"x",ty)] pi)
print 2
Just gr4 <- checkoutPGF gr1 "master"
Just gr5 <- checkoutPGF gr1 "bar_branch"
gr4 <- checkoutPGF gr1
gr6 <- modifyPGF gr1 (dropFunction "ind" >> dropCategory "S")
@@ -28,14 +27,10 @@ main = do
TestList $
[TestCase (assertEqual "original functions" ["c","floatLit","ind","intLit","nat","s","stringLit","z"] (functions gr1))
,TestCase (assertEqual "extended functions" ["c","floatLit","foo","ind","intLit","nat","s","stringLit","z"] (functions gr2))
,TestCase (assertEqual "branched functions" ["bar","c","floatLit","ind","intLit","nat","s","stringLit","z"] (functions gr3))
,TestCase (assertEqual "checked-out extended functions" ["c","floatLit","foo","ind","intLit","nat","s","stringLit","z"] (functions gr4))
,TestCase (assertEqual "checked-out branched functions" ["bar","c","floatLit","ind","intLit","nat","s","stringLit","z"] (functions gr5))
,TestCase (assertEqual "original categories" ["Float","Int","N","P","S","String"] (categories gr1))
,TestCase (assertEqual "extended categories" ["Float","Int","N","P","Q","S","String"] (categories gr2))
,TestCase (assertEqual "branched categories" ["Float","Int","N","P","R","S","String"] (categories gr3))
,TestCase (assertEqual "Q context" (Just [(Explicit,"x",ty)]) (categoryContext gr2 "Q"))
,TestCase (assertEqual "R context" (Just [(Explicit,"x",ty)]) (categoryContext gr3 "R"))
,TestCase (assertEqual "reduced functions" ["c","floatLit","intLit","nat","s","stringLit","z"] (functions gr6))
,TestCase (assertEqual "reduced categories" ["Float","Int","N","P","String"] (categories gr6))
,TestCase (assertEqual "old function type" Nothing (functionType gr1 "foo"))