Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
167 lines (147 sloc) 5.13 KB
-- Copyright (c) 2017-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is licensed under the BSD-style license found in the
-- LICENSE file in the root directory of this source tree. An additional grant
-- of patent rights can be found in the PATENTS file in the same directory.
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-| A library for safely interacting with frequently updating shared
objects within a haskell binary. See more documentation at <https://github.com/fbsamples/ghc-hotswap/>.
Assuming you have some structure of data called `Foo`.
In common types:
```
type FooExport = IO (StablePtr Foo)
```
In the shared object:
```
foreign export ccall "hs_mySOFunction"
hsHandle :: FooExport
hsHandle :: FooExport
hsHandle = newStablePtr Foo
{ ...
}
```
In the main binary:
```
main = do
myData <- registerHotswap "hs_mySOFunction" "/path/to/lib.o"
(withSO myData) $ \Foo{..} -> do
-- first version
...
(swapSO myData) "/path/to/next_lib.o"
(withSO myData) $ \Foo{..} -> do
-- next version
...
```
-}
module GHC.Hotswap
( UpdatableSO
, swapSO
, withSO
, registerHotswap
) where
import qualified Control.Concurrent.ReadWriteLock as L
import Control.Concurrent.MVar
import Control.DeepSeq
import Control.Exception
import Control.Monad
import GHCi.ObjLink
import Foreign
-- | Access control for a shared object that return a type `a` from the
-- shared object
data UpdatableSO a = UpdatableSO
{ swapSO :: FilePath -> IO ()
-- ^ Loads and links the new object such that future calls to `withSO` will
-- use the new objects. Existing calls in the old object will complete as
-- normal and the old object will be unloaded when all references to it
-- are dropped.
-- The underlying work is not thread safe, so it's on the caller to
-- appropriately serialize these calls to avoid accidentally skipping an
-- update.
, withSO :: forall b . (a -> IO b) -> IO b
-- ^ Accessor for information out of the shared object. Use this to run
-- something with data from the latest shared object. You are guaranteed
-- to access the latest object and the object will be retained until
-- the call finishes.
-- Always eventually return from calling this function, otherwise
-- objects will not be dropped.
}
-- | Internal state associated with a single instance of a shared object
data SOState a = SOState
{ lock :: L.RWLock -- Protects the data so we know when to safely delete
, path :: FilePath -- The local path to the object
, val :: a -- The extracted value we wanted
}
-- | Loads a shared object, pulls out the particular symbol name, and returns
-- a control structure for interacting with the data
registerHotswap
:: NFData a
=> String -- exported c-name of the (:: IO (StablePtr a)) symbol
-> FilePath -- path to the first instance of the shared object
-> IO (UpdatableSO a) -- control structure
registerHotswap symbolName firstPath = do
firstVal <- force <$> loadNewSO symbolName firstPath
firstLock <- L.new
sMVar <- newMVar SOState
{ lock = firstLock
, path = firstPath
, val = firstVal
}
return UpdatableSO
{ swapSO = updateState sMVar symbolName
, withSO = unWrap sMVar
}
-- | Safely runs an action on a value from the shared object
unWrap :: MVar (SOState a) -> (a -> IO b) -> IO b
unWrap mvar action = do
SOState{..} <- readMVar mvar
L.withRead lock $ action val
-- | Safely updates the state to handle an updated shared object
updateState
:: NFData a
=> MVar (SOState a) -- State to edit
-> String -- exported c-name of the symbol to lookup
-> FilePath -- path to the next instance of the shared object
-> IO ()
updateState mvar symbolName nextPath = do
newVal <- force <$> loadNewSO symbolName nextPath
-- Build a new state for this version
newLock <- L.new
let
newState = SOState
{ lock = newLock
, path = nextPath
, val = newVal
}
-- Swapping in the new state means all new calls to `withSO` from the client
-- will use the new value. After this it's impossible for a new read lock to
-- grab the old state
oldState <- swapMVar mvar newState
-- All readers in oldState will fall out, so we're safe to destroy state here
L.withWrite (lock oldState) $
unloadObj (path oldState)
-- Extract the function pointer as a callable Haskell function
foreign import ccall "dynamic"
callExport :: FunPtr (IO (StablePtr a)) -> IO (StablePtr a)
-- | Nuts and bolts for bringing in a new object
loadNewSO :: String -> FilePath -> IO a
loadNewSO symName newSO = do
-- initObjLinker is idempotent
initObjLinker DontRetainCAFs
loadObj newSO
resolved <- resolveObjs
unless resolved $ do
unloadObj newSO
throwIO (ErrorCall $ "Unable to resolve objects for " ++ newSO)
c_sym <- lookupSymbol symName
h <- case c_sym of
Nothing -> do
unloadObj newSO
throwIO (ErrorCall "Could not find symbol")
Just p_sym ->
bracket (callExport $ castPtrToFunPtr p_sym) freeStablePtr deRefStablePtr
-- Dump the symbol table to make room for when the next object comes in
purgeObj newSO
return h