diff --git a/GHC/Hotswap.hs b/GHC/Hotswap.hs new file mode 100644 --- /dev/null +++ b/GHC/Hotswap.hs @@ -0,0 +1,166 @@ +-- 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 . + +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +BSD License + +For ghc-hotswap software + +Copyright (c) 2017-present, Facebook, Inc. All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + * Neither the name Facebook nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/PATENTS b/PATENTS new file mode 100644 --- /dev/null +++ b/PATENTS @@ -0,0 +1,33 @@ +Additional Grant of Patent Rights Version 2 + +"Software" means the ghc-hotswap software contributed by Facebook, Inc. + +Facebook, Inc. ("Facebook") hereby grants to each recipient of the Software +("you") a perpetual, worldwide, royalty-free, non-exclusive, irrevocable +(subject to the termination provision below) license under any Necessary +Claims, to make, have made, use, sell, offer to sell, import, and otherwise +transfer the Software. For avoidance of doubt, no license is granted under +Facebook’s rights in any patent claims that are infringed by (i) modifications +to the Software made by you or any third party or (ii) the Software in +combination with any software or other technology. + +The license granted hereunder will terminate, automatically and without notice, +if you (or any of your subsidiaries, corporate affiliates or agents) initiate +directly or indirectly, or take a direct financial interest in, any Patent +Assertion: (i) against Facebook or any of its subsidiaries or corporate +affiliates, (ii) against any party if such Patent Assertion arises in whole or +in part from any software, technology, product or service of Facebook or any of +its subsidiaries or corporate affiliates, or (iii) against any party relating +to the Software. Notwithstanding the foregoing, if Facebook or any of its +subsidiaries or corporate affiliates files a lawsuit alleging patent +infringement against you in the first instance, and you respond by filing a +patent infringement counterclaim in that lawsuit against that party that is +unrelated to the Software, the license granted here under will not terminate +under section (i) of this paragraph due to such counterclaim. + +A "Necessary Claim" is a claim of a patent owned by Facebook that is +necessarily infringed by the Software standing alone. + +A "Patent Assertion" is any lawsuit or other action alleging direct, indirect, +or contributory infringement or inducement to infringe any patent, including a +cross-claim or counterclaim. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ghc-hotswap.cabal b/ghc-hotswap.cabal new file mode 100644 --- /dev/null +++ b/ghc-hotswap.cabal @@ -0,0 +1,29 @@ +name: ghc-hotswap +version: 0.1.0.0 +synopsis: Library for hot-swapping shared objects in GHC +description: + Convenience API for safely hot-swapping shared objects using GHC's GHCi linker +homepage: https://github.com/fbsamples/ghc-hotswap +bug-reports: https://github.com/fbsamples/ghc-hotswap/issues +license: OtherLicense +license-files: LICENSE,PATENTS +author: Facebook, Inc. +maintainer: The Haxl Team +copyright: (c) 2017-present, Facebook, Inc. All rights reserved. +category: System +build-type: Simple +cabal-version: >=1.10 +stability: alpha + +library + exposed-modules: GHC.Hotswap + build-depends: base >= 4.9.1.0 && < 5.0 + , concurrent-extra >= 0.7.0.11 && < 0.8 + , deepseq >= 1.4.2.0 && < 1.5 + , ghci >= 8.2 && < 8.6 + + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/fbsamples/ghc-hotswap/ghc-hotswap