tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

EmbeddingCore.hs (10825B)

      1 {-# LANGUAGE ForeignFunctionInterface #-}
      2 {-# LANGUAGE ScopedTypeVariables #-}
      3 -- Shared core boundary. Imports only the reducer, value codecs and registry dependencies.
      4 module EmbeddingCore where
      5 
      6 import Control.Concurrent.MVar
      7 import Control.Exception
      8 import Control.Monad (unless)
      9 import Control.Monad.State.Strict
     10 import Data.IORef
     11 import qualified Data.Map.Strict as M
     12 import qualified Data.Map.Lazy as L
     13 import qualified Data.ByteString as BS
     14 import qualified Data.Text as Text
     15 import qualified Data.Text.Encoding as Text
     16 import Data.Word
     17 import Foreign hiding (void, toBool)
     18 import Foreign.C.Types
     19 import System.IO.Unsafe (unsafePerformIO)
     20 import Runtime.Tree
     21 import Runtime.Value hiding (toBytes)
     22 import qualified Runtime.Value as Value
     23 
     24 -- A process-wide nonreusing namespace covers contexts AND roots. No raw stable
     25 -- pointer crosses the boundary; released, foreign and stale IDs are map misses.
     26 {-# NOINLINE identities #-}
     27 identities :: IORef Integer
     28 identities = unsafePerformIO (newIORef 1)
     29 {-# NOINLINE contexts #-}
     30 contexts :: MVar (M.Map Word64 (MVar (Maybe Context)))
     31 contexts = unsafePerformIO (newMVar M.empty)
     32 -- Force map updates while keeping their tree values lazy: release removes the
     33 -- root now, and application publication preserves the suspended computation.
     34 data Context = Context { roots :: !(L.Map Word64 T), lastError :: !BS.ByteString }
     35 data Fault = Fault Word32 String deriving Show
     36 instance Exception Fault
     37 
     38 boundaryStatus :: SomeException -> IO Word32
     39 boundaryStatus e = pure $ case fromException e of
     40   Just (Fault code _) -> code
     41   Nothing -> 5
     42 
     43 type Call = StateT Context IO
     44 fault :: Word32 -> String -> IO a
     45 fault code message = throwIO (Fault code message)
     46 require :: Bool -> String -> IO ()
     47 require condition message = unless condition (fault 3 message)
     48 newIdentity :: IO Word64
     49 newIdentity = do
     50   n <- atomicModifyIORef' identities (\n -> (n+1,n))
     51   if n > toInteger (maxBound :: Word64) then fault 6 "identity namespace exhausted"
     52     else pure (fromInteger n)
     53 
     54 -- Context locking serializes lazy evaluation as well as registry changes.
     55 -- Destroy marks the cell closed before removing its name; concurrent lookups
     56 -- respect that closed state. Exceptions roll back root-table publication.
     57 -- IO effects and evaluation already performed on shared Haskell thunks persist.
     58 withContext :: Word64 -> Call (IO ()) -> IO Word32
     59 withContext identity action = handle boundaryStatus $ mask $ \restore -> do
     60   found <- withMVar contexts (pure . M.lookup identity)
     61   case found of
     62     Nothing -> pure 1
     63     Just cell -> modifyMVar cell $ \current -> case current of
     64       Nothing -> pure (Nothing, 1)
     65       Just context -> do
     66         result <- try $ do
     67           (commit, updated) <- restore (runStateT action context)
     68           commit
     69           pure updated
     70         case result of
     71           Right updated -> pure (Just updated, 0)
     72           Left (e :: SomeException) -> do
     73             let (code, message) = case fromException e of
     74                   Just (Fault c m) -> (c,m)
     75                   Nothing -> (5, displayException e)
     76             -- Force bounded diagnostic bytes inside the exception handler.
     77             let bytes = Text.encodeUtf8 (Text.pack (take 4096 message))
     78             _ <- evaluate (BS.length bytes)
     79             pure (Just context {lastError = bytes}, code)
     80 
     81 lookupRoot :: Word64 -> Call T
     82 lookupRoot identity = do
     83   table <- gets roots
     84   maybe (liftIO (fault 2 "invalid or foreign handle")) pure (L.lookup identity table)
     85 publish :: Ptr Word64 -> T -> Call (IO ())
     86 publish out tree = do
     87   liftIO (require (out /= nullPtr) "null output")
     88   identity <- liftIO newIdentity
     89   modify' (\c -> c { roots = L.insert identity tree (roots c) })
     90   pure (poke out identity)
     91 readBytes :: Ptr Word8 -> CSize -> IO BS.ByteString
     92 readBytes ptr len = do
     93   require (toInteger len <= toInteger (maxBound :: Int)) "buffer too large"
     94   require (ptr /= nullPtr || len == 0) "null input buffer"
     95   if len == 0 then pure BS.empty else BS.packCStringLen (castPtr ptr, fromIntegral len)
     96 checked :: Word32 -> Either String a -> IO a
     97 checked code = either (fault code) pure
     98 readText :: Ptr Word8 -> CSize -> IO Text.Text
     99 readText ptr len = readBytes ptr len >>= checked 3 . either (Left . show) Right . Text.decodeUtf8'
    100 outputBuffer :: Ptr (Ptr Word8) -> Ptr CSize -> BS.ByteString -> IO ()
    101 outputBuffer out len bytes = do
    102   require (out /= nullPtr && len /= nullPtr && castPtr out /= len) "invalid buffer outputs"
    103   -- Allocate even for empty output, giving every successful buffer one owner.
    104   bracketOnError (mallocBytes (max 1 (BS.length bytes))) free $ \ptr -> do
    105     BS.useAsCStringLen bytes $ \(source,n) -> copyBytes ptr (castPtr source) n
    106     poke out ptr
    107     poke len (fromIntegral (BS.length bytes))
    108 
    109 abiVersion :: IO Word32
    110 abiVersion = pure 1
    111 contextNew :: Ptr Word64 -> IO Word32
    112 contextNew out = handle boundaryStatus $ mask_ $ do
    113   if out == nullPtr then pure 3 else do
    114     identity <- newIdentity
    115     cell <- newMVar (Just (Context L.empty BS.empty))
    116     modifyMVar_ contexts (pure . M.insert identity cell)
    117     poke out identity
    118     pure 0
    119 contextFree :: Word64 -> IO Word32
    120 contextFree identity = handle boundaryStatus $ mask_ $ do
    121   found <- withMVar contexts (pure . M.lookup identity)
    122   case found of
    123     Nothing -> pure 1
    124     Just cell -> do
    125       status <- modifyMVar cell $ \current -> pure (Nothing, maybe 1 (const 0) current)
    126       modifyMVar_ contexts (pure . M.delete identity)
    127       pure status
    128 retain :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
    129 retain ctx value out = withContext ctx (lookupRoot value >>= publish out)
    130 release :: Word64 -> Word64 -> IO Word32
    131 release ctx value = withContext ctx $ do
    132   _ <- lookupRoot value
    133   modify' (\c -> c {roots = L.delete value (roots c)})
    134   pure (pure ())
    135 leaf :: Word64 -> Ptr Word64 -> IO Word32
    136 leaf ctx out = withContext ctx (publish out Leaf)
    137 stem :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
    138 stem ctx value out = withContext ctx (lookupRoot value >>= publish out . Stem)
    139 binary :: (T -> T -> T) -> Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
    140 binary constructor ctx left right out = withContext ctx $ do
    141   a <- lookupRoot left
    142   b <- lookupRoot right
    143   publish out (constructor a b)
    144 fork, application :: Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
    145 fork = binary Fork
    146 application = binary apply
    147 reduce :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
    148 reduce ctx value out = withContext ctx $ do
    149   liftIO (require (out /= nullPtr) "null output")
    150   tree <- lookupRoot value >>= liftIO . evaluate
    151   publish out tree
    152 kind :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
    153 kind ctx value out = withContext ctx $ do
    154   liftIO (require (out /= nullPtr) "null output")
    155   tree <- lookupRoot value
    156   tag <- liftIO $ evaluate $ case tree of Leaf -> 0; Stem _ -> 1; Fork _ _ -> 2
    157   pure (poke out tag)
    158 child :: Word64 -> Word64 -> Word32 -> Ptr Word64 -> IO Word32
    159 child ctx value index out = withContext ctx $ do
    160   tree <- lookupRoot value
    161   case (tree,index) of
    162     (Stem a,0) -> publish out a
    163     (Fork a _,0) -> publish out a
    164     (Fork _ b,1) -> publish out b
    165     _ -> liftIO (fault 4 "constructor has no such child")
    166 fromU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
    167 fromU64 ctx n out = withContext ctx (publish out (ofNumber (toInteger n)))
    168 toBool :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
    169 toBool ctx value out = withContext ctx $ do
    170   liftIO (require (out /= nullPtr) "null output")
    171   tree <- lookupRoot value
    172   tag <- case tree of
    173     Leaf -> pure 0
    174     Stem Leaf -> pure 1
    175     _ -> liftIO (fault 4 "invalid boolean")
    176   pure (poke out tag)
    177 toU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
    178 toU64 ctx value out = withContext ctx $ do
    179   liftIO (require (out /= nullPtr) "null output")
    180   tree <- lookupRoot value
    181   n <- liftIO (checked 4 (toNumber tree))
    182   liftIO $ do
    183     require (n <= toInteger (maxBound :: Word64)) "number exceeds uint64"
    184   pure (poke out (fromInteger n))
    185 fromBytes, fromUtf8 :: Word64 -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
    186 fromBytes ctx ptr len out = withContext ctx $ do
    187   bytes <- liftIO (readBytes ptr len)
    188   publish out (ofBytes bytes)
    189 fromUtf8 ctx ptr len out = withContext ctx $ do
    190   text <- liftIO (readText ptr len)
    191   publish out (ofString (Text.unpack text))
    192 toBytes, toUtf8 :: Word64 -> Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
    193 toBytes ctx value out len = withContext ctx $ do
    194   tree <- lookupRoot value
    195   bytes <- liftIO (checked 4 (toBytesValue tree))
    196   _ <- liftIO (evaluate (BS.length bytes))
    197   pure (outputBuffer out len bytes)
    198   where toBytesValue = Value.toBytes
    199 toUtf8 ctx value out len = withContext ctx $ do
    200   tree <- lookupRoot value
    201   text <- liftIO (checked 4 (toString tree))
    202   let bytes = Text.encodeUtf8 (Text.pack text)
    203   _ <- liftIO (evaluate (BS.length bytes))
    204   pure (outputBuffer out len bytes)
    205 lastErrorBytes :: Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
    206 lastErrorBytes ctx out len = withContext ctx $ do
    207   bytes <- gets lastError
    208   pure (outputBuffer out len bytes)
    209 
    210 foreign export ccall "tricu_abi_version" abiVersion :: IO Word32
    211 foreign export ccall "tricu_context_new" contextNew :: Ptr Word64 -> IO Word32
    212 foreign export ccall "tricu_context_free" contextFree :: Word64 -> IO Word32
    213 foreign export ccall "tricu_retain" retain :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
    214 foreign export ccall "tricu_release" release :: Word64 -> Word64 -> IO Word32
    215 foreign export ccall "tricu_leaf" leaf :: Word64 -> Ptr Word64 -> IO Word32
    216 foreign export ccall "tricu_stem" stem :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
    217 foreign export ccall "tricu_fork" fork :: Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
    218 foreign export ccall "tricu_apply" application :: Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
    219 foreign export ccall "tricu_reduce" reduce :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
    220 foreign export ccall "tricu_kind" kind :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
    221 foreign export ccall "tricu_child" child :: Word64 -> Word64 -> Word32 -> Ptr Word64 -> IO Word32
    222 foreign export ccall "tricu_from_u64" fromU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
    223 foreign export ccall "tricu_to_bool" toBool :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
    224 foreign export ccall "tricu_to_u64" toU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
    225 foreign export ccall "tricu_from_bytes" fromBytes :: Word64 -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
    226 foreign export ccall "tricu_from_utf8" fromUtf8 :: Word64 -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
    227 foreign export ccall "tricu_to_bytes" toBytes :: Word64 -> Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
    228 foreign export ccall "tricu_to_utf8" toUtf8 :: Word64 -> Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
    229 foreign export ccall "tricu_last_error" lastErrorBytes :: Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32