GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-20 18:29:33 -06:00
Code Issues Packages Projects Releases Wiki Activity

restore the sharing of sequences. Shrinks the grammar by ~45%

Browse Source
This commit is contained in:
Krasimir Angelov
2022-01-08 19:49:42 +01:00
parent cd2c6aa32a
commit 00f857559d
31 changed files with 882 additions and 353 deletions
Download Patch File Download Diff File Expand all files Collapse all files

76
src/runtime/haskell/PGF2.hsc
View File

@@ -222,11 +222,15 @@ showPGF p =
def <- bracket (pgf_print_function_internal val) free peekText
modifyIORef ref (\doc -> doc $$ text def)
ppConcr name c =
text "concrete" <+> text name <+> char '{' $$
nest 2 (ppLincats c $$
ppLins c) $$
char '}'
ppConcr name c = unsafePerformIO $ do
doc <- prepareSequences c -- run first to update all seq_id
return (text "concrete" <+> text name <+> char '{' $$
nest 2 (ppLincats c $$
ppLins c $$
(text "sequences" <+> char '{' $$
nest 2 doc $$
char '}')) $$
char '}')
ppLincats c = unsafePerformIO $ do
ref <- newIORef empty
@@ -248,32 +252,20 @@ showPGF p =
n_lindefs <- peekElemOff pcounts 1
n_linrefs <- peekElemOff pcounts 2
return (n_fields,n_lindefs,n_linrefs)
fields <- allocaBytes (3*(#size size_t)) $ \pcounts -> do
forM (init [0..n_fields]) $ \i -> do
pgf_get_lincat_field_internal val i >>= peekText
fields <- forM (init [0..n_fields]) $ \i -> do
pgf_get_lincat_field_internal val i >>= peekText
let def = text "lincat" <+> (text name <+> char '=' <+> char '[' $$
nest 2 (vcat (map (text.show) fields)) $$
char ']')
modifyIORef ref $ (\doc -> doc $$ def)
forM_ (init [0..n_lindefs]) $ \i -> do
sig <- bracket (pgf_print_lindef_sig_internal val i) free $ \c_text -> do
def <- bracket (pgf_print_lindef_internal val i) free $ \c_text -> do
fmap text (peekText c_text)
seqs <- forM (init [0..n_fields]) $ \j ->
bracket (pgf_print_lindef_seq_internal val i j) free $ \c_text -> do
fmap text (peekText c_text)
let def = text "lindef" <+> (sig <+> char '=' <+> char '[' $$
nest 2 (vcat seqs) $$
char ']')
modifyIORef ref $ (\doc -> doc $$ def)
modifyIORef ref (\doc -> doc $$ text "lindef" <+> def)
forM_ (init [0..n_linrefs]) $ \i -> do
sig <- bracket (pgf_print_linref_sig_internal val i) free $ \c_text -> do
def <- bracket (pgf_print_linref_internal val i) free $ \c_text -> do
fmap text (peekText c_text)
seq <- bracket (pgf_print_linref_seq_internal val i) free $ \c_text -> do
fmap text (peekText c_text)
let def = text "linref" <+> (sig <+> char '=' <+> char '[' $$
nest 2 seq $$
char ']')
modifyIORef ref $ (\doc -> doc $$ def)
modifyIORef ref $ (\doc -> doc $$ text "linref" <+> def)
ppLins c = unsafePerformIO $ do
ref <- newIORef empty
@@ -285,22 +277,28 @@ showPGF p =
readIORef ref
where
getLins :: IORef Doc -> ItorCallback
getLins ref itor key val exn =
allocaBytes (2*(#size size_t)) $ \pcounts -> do
pgf_get_lin_counts_internal val pcounts
n_prods <- peekElemOff pcounts 0
n_seqs <- peekElemOff pcounts 1
forM_ (init [0..n_prods]) $ \i -> do
sig <- bracket (pgf_print_lin_sig_internal val i) free $ \c_text -> do
fmap text (peekText c_text)
syms <- forM (init [0..n_seqs]) $ \j ->
bracket (pgf_print_lin_seq_internal val i j) free $ \c_text -> do
fmap text (peekText c_text)
let def = text "lin" <+> (sig <+> char '=' <+> char '[' $$
nest 2 (vcat syms) $$
char ']')
modifyIORef ref $ (\doc -> doc $$ def)
return ()
getLins ref itor key val exn = do
n_prods <- pgf_get_lin_get_prod_count val
forM_ (init [0..n_prods]) $ \i -> do
def <- bracket (pgf_print_lin_internal val i) free $ \c_text -> do
fmap text (peekText c_text)
modifyIORef ref (\doc -> doc $$ text "lin" <+> def)
return ()
prepareSequences c = do
ref <- newIORef empty
(allocaBytes (#size PgfSequenceItor) $ \itor ->
bracket (wrapSequenceItorCallback (getSequences ref)) freeHaskellFunPtr $ \fptr ->
withForeignPtr (c_revision c) $ \c_revision -> do
(#poke PgfSequenceItor, fn) itor fptr
withPgfExn "showPGF" (pgf_iter_sequences (a_db p) c_revision itor))
readIORef ref
where
getSequences :: IORef Doc -> SequenceItorCallback
getSequences ref itor val exn = do
def <- bracket (pgf_print_sequence_internal val) free $ \c_text -> do
fmap text (peekText c_text)
modifyIORef ref $ (\doc -> doc $$ def)
-- | The abstract language name is the name of the top-level
-- abstract module

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

@@ -45,6 +45,7 @@ data PgfBuildLinIface
data PgfLinBuilderIface
data PgfLinearizationOutputIface
data PgfGraphvizOptions
data PgfSequenceItor
type Wrapper a = a -> IO (FunPtr a)
type Dynamic a = FunPtr a -> a
@@ -110,23 +111,25 @@ foreign import ccall pgf_iter_lincats :: Ptr PgfDB -> Ptr Concr -> Ptr PgfItor -
foreign import ccall pgf_iter_lins :: Ptr PgfDB -> Ptr Concr -> Ptr PgfItor -> Ptr PgfExn -> IO ()
type SequenceItorCallback = Ptr PgfSequenceItor -> Ptr () -> Ptr PgfExn -> IO ()
foreign import ccall "wrapper" wrapSequenceItorCallback :: Wrapper SequenceItorCallback
foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfExn -> IO ()
foreign import ccall pgf_get_lincat_counts_internal :: Ptr () -> Ptr CSize -> IO ()
foreign import ccall pgf_get_lincat_field_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_lindef_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_lindef_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_lindef_seq_internal :: Ptr () -> CSize -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_linref_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_linref_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_get_lin_get_prod_count :: Ptr () -> IO CSize
foreign import ccall pgf_print_linref_seq_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_lin_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_get_lin_counts_internal :: Ptr () -> Ptr CSize -> IO ()
foreign import ccall pgf_print_lin_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_lin_seq_internal :: Ptr () -> CSize -> CSize -> IO (Ptr PgfText)
foreign import ccall pgf_print_sequence_internal :: Ptr () -> IO (Ptr PgfText)
type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO ()
@@ -200,6 +203,8 @@ foreign import ccall "dynamic" callLinBuilder5 :: Dynamic (Ptr PgfLinBuilderIfac
foreign import ccall "dynamic" callLinBuilder6 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr (Ptr PgfText) -> Ptr PgfExn -> IO ())
foreign import ccall "dynamic" callLinBuilder7 :: Dynamic (Ptr PgfLinBuilderIface -> Ptr PgfExn -> IO CSize)
foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()

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

@@ -13,7 +13,7 @@ module PGF2.Transactions
, setAbstractFlag
-- concrete syntax
, Token, LIndex, LVar, LParam(..)
, Token, SeqId, LIndex, LIndex, LVar, LParam(..)
, PArg(..), Symbol(..), Production(..)
, createConcrete
@@ -21,6 +21,7 @@ module PGF2.Transactions
, dropConcrete
, mergePGF
, setConcreteFlag
, SeqTable
, createLincat
, dropLincat
, createLin
@@ -35,6 +36,8 @@ import PGF2.ByteCode
import Foreign
import Foreign.C
import Control.Exception
import qualified Data.Sequence as Seq
import Data.IORef
#include <pgf/pgf.h>
@@ -197,10 +200,11 @@ setConcreteFlag name value = Transaction $ \c_db _ c_revision c_exn ->
type Token = String
type SeqId = Int
type LIndex = Int
type LVar = Int
data LParam = LParam {-# UNPACK #-} !LIndex [(LIndex,LVar)]
deriving (Eq,Show)
deriving (Eq,Ord,Show)
data Symbol
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LParam
@@ -214,21 +218,23 @@ data Symbol
| SymSOFT_SPACE -- the special SOFT_SPACE token
| SymCAPIT -- the special CAPIT token
| SymALL_CAPIT -- the special ALL_CAPIT token
deriving (Eq,Show)
deriving (Eq,Ord,Show)
data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam
deriving (Eq,Show)
data Production = Production [(LVar,LIndex)] [PArg] LParam [[Symbol]]
data Production = Production [(LVar,LIndex)] [PArg] LParam [SeqId]
deriving (Eq,Show)
createLincat :: Cat -> [String] -> [Production] -> [Production] -> Transaction Concr ()
createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr c_revision c_exn ->
type SeqTable = Seq.Seq (Either [Symbol] SeqId)
createLincat :: Cat -> [String] -> [Production] -> [Production] -> SeqTable -> Transaction Concr SeqTable
createLincat name fields lindefs linrefs seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
let n_fields = length fields
in withText name $ \c_name ->
allocaBytes (n_fields*(#size PgfText*)) $ \c_fields ->
withTexts c_fields 0 fields $
withBuildLinIface (lindefs++linrefs) $ \c_build ->
withBuildLinIface (lindefs++linrefs) seqtbl $ \c_build ->
pgf_create_lincat c_db c_abstr c_revision c_name
(fromIntegral n_fields) c_fields
(fromIntegral (length lindefs)) (fromIntegral (length linrefs))
@@ -245,19 +251,21 @@ dropLincat name = Transaction $ \c_db _ c_revision c_exn ->
withText name $ \c_name ->
pgf_drop_lincat c_db c_revision c_name c_exn
createLin :: Fun -> [Production] -> Transaction Concr ()
createLin name prods = Transaction $ \c_db c_abstr c_revision c_exn ->
createLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable
createLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
withText name $ \c_name ->
withBuildLinIface prods $ \c_build ->
withBuildLinIface prods seqtbl $ \c_build ->
pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
withBuildLinIface prods f =
allocaBytes (#size PgfBuildLinIface) $ \c_build ->
allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl ->
bracket (wrapLinBuild build) freeHaskellFunPtr $ \c_callback -> do
(#poke PgfBuildLinIface, vtbl) c_build vtbl
(#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback
f c_build
withBuildLinIface prods seqtbl f = do
ref <- newIORef seqtbl
(allocaBytes (#size PgfBuildLinIface) $ \c_build ->
allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl ->
bracket (wrapLinBuild (build ref)) freeHaskellFunPtr $ \c_callback -> do
(#poke PgfBuildLinIface, vtbl) c_build vtbl
(#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback
f c_build)
readIORef ref
where
forM_ [] c_exn f = return ()
forM_ (x:xs) c_exn f = do
@@ -266,9 +274,9 @@ withBuildLinIface prods f =
then f x >> forM_ xs c_exn f
else return ()
build _ c_builder c_exn = do
build ref _ c_builder c_exn = do
vtbl <- (#peek PgfLinBuilderIface, vtbl) c_builder
forM_ prods c_exn $ \(Production vars args res seqs) -> do
forM_ prods c_exn $ \(Production vars args res seqids) -> do
fun <- (#peek PgfLinBuilderIfaceVtbl, start_production) vtbl
callLinBuilder0 fun c_builder c_exn
fun <- (#peek PgfLinBuilderIfaceVtbl, add_argument) vtbl
@@ -279,12 +287,17 @@ withBuildLinIface prods f =
fun <- (#peek PgfLinBuilderIfaceVtbl, add_variable) vtbl
forM_ vars c_exn $ \(v,r) ->
callLinBuilder2 fun c_builder (fromIntegral v) (fromIntegral r) c_exn
forM_ seqs c_exn $ \syms -> do
fun <- (#peek PgfLinBuilderIfaceVtbl, start_sequence) vtbl
callLinBuilder1 fun c_builder (fromIntegral (length syms)) c_exn
forM_ syms c_exn (addSymbol c_builder vtbl c_exn)
fun <- (#peek PgfLinBuilderIfaceVtbl, end_sequence) vtbl
callLinBuilder0 fun c_builder c_exn
fun <- (#peek PgfLinBuilderIfaceVtbl, add_sequence_id) vtbl
seqtbl <- readIORef ref
forM_ seqids c_exn $ \seqid ->
case Seq.index seqtbl seqid of
Left syms -> do fun <- (#peek PgfLinBuilderIfaceVtbl, start_sequence) vtbl
callLinBuilder1 fun c_builder (fromIntegral (length syms)) c_exn
forM_ syms c_exn (addSymbol c_builder vtbl c_exn)
fun <- (#peek PgfLinBuilderIfaceVtbl, end_sequence) vtbl
seqid' <- callLinBuilder7 fun c_builder c_exn
writeIORef ref $! Seq.update seqid (Right (fromIntegral seqid')) seqtbl
Right seqid -> do callLinBuilder1 fun c_builder (fromIntegral seqid) c_exn
fun <- (#peek PgfLinBuilderIfaceVtbl, end_production) vtbl
callLinBuilder0 fun c_builder c_exn