tricu

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

Embedding.hs (2627B)

      1 {-# LANGUAGE ForeignFunctionInterface #-}
      2 {-# LANGUAGE OverloadedStrings #-}
      3 -- Bundle loading and IO extend the internal reducer and value boundary.
      4 module Embedding (module Embedding, module EmbeddingCore) where
      5 
      6 import EmbeddingCore
      7 import Control.Monad.State.Strict
      8 import qualified Data.Map.Lazy as L
      9 import qualified Data.Vector as V
     10 import Data.Word
     11 import Foreign
     12 import Foreign.C.Types
     13 import Runtime.Value (ofList)
     14 import qualified Wire
     15 import qualified IODriver
     16 import qualified IO.Driver as IO
     17 import qualified IO.Protocol as Protocol
     18 
     19 loadBundle :: Word64 -> Ptr Word8 -> CSize -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
     20 loadBundle ctx ptr len namePtr nameLen out = withContext ctx $ do
     21   bytes <- liftIO (readBytes ptr len)
     22   name <- liftIO (readText namePtr nameLen)
     23   bundle <- liftIO (checked 3 (Wire.decodeBundle bytes))
     24   liftIO (checked 3 (Wire.verifyBundle bundle))
     25   exported <- case filter ((== name) . Wire.exportName) (Wire.manifestExports (Wire.bundleManifest bundle)) of
     26     [value] -> pure value
     27     _ -> liftIO (fault 3 "bundle export not found")
     28   liftIO (require (Wire.exportKind exported == "term" && Wire.exportAbi exported == "arboricx.abi.tree.v1") "unsupported export ABI")
     29   let terms = Wire.reconstructBundleTerms (Wire.bundleNodes bundle)
     30   publish out (terms V.! fromIntegral (Wire.exportRoot exported))
     31 runIO :: Word64 -> Word64 -> Ptr Word32 -> Ptr Word64 -> Ptr Word64 -> IO Word32
     32 runIO ctx program outcome out cleanup = withContext ctx $ do
     33   liftIO (require (outcome /= nullPtr && out /= nullPtr && cleanup /= nullPtr &&
     34     castPtr outcome /= out && castPtr outcome /= cleanup && out /= cleanup) "invalid IO outputs")
     35   tree <- lookupRoot program
     36   (version,action) <- liftIO (checked 3 (IODriver.checkIOSentinel tree))
     37   liftIO (require (version == 2) "unsupported IO version")
     38   result <- liftIO (IO.runDetailed action)
     39   let (tag,value,problems) = case result of
     40         IO.Completed v -> (0,v,[])
     41         IO.Failed v ps -> (1,v,ps)
     42         IO.Cancelled v ps -> (2,v,ps)
     43   -- Reserve both IDs before publishing any output. Neither payload is forced.
     44   valueId <- liftIO newIdentity
     45   cleanupId <- liftIO newIdentity
     46   modify' (\c -> c {roots = L.insert valueId value $
     47     L.insert cleanupId (ofList (map Protocol.problemTree problems)) (roots c)})
     48   pure (poke outcome tag >> poke out valueId >> poke cleanup cleanupId)
     49 foreign export ccall "tricu_load_bundle" loadBundle :: Word64 -> Ptr Word8 -> CSize -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
     50 foreign export ccall "tricu_run_io" runIO :: Word64 -> Word64 -> Ptr Word32 -> Ptr Word64 -> Ptr Word64 -> IO Word32