{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -- only for DB.Binary instances on Module see FIXME below {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.StgToJS.Object -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Sylvain Henry -- Jeffrey Young -- Luite Stegeman -- Josh Meredith -- Stability : experimental -- -- Serialization/deserialization of binary .o files for the JavaScript backend -- The .o files contain dependency information and generated code. -- All strings are mapped to a central string table, which helps reduce -- file size and gives us efficient hash consing on read -- -- Binary intermediate JavaScript object files: -- serialized [Text] -> ([ClosureInfo], JStat) blocks -- -- file layout: -- - header ["GHCJSOBJ", length of symbol table, length of dependencies, length of index] -- - compiler version tag -- - symbol table -- - dependency info -- - closureinfo index -- - closureinfo data (offsets described by index) -- FIXME: Jeff (2022,03): There are orphan instances for DB.Binary Module and -- ModuleName. These are needed in StgToJS.Linker.Types for @Base@ serialization -- in @putBase@. We end up in this situation because Base now holds a @Module@ -- type instead of GHCJS's previous @Package@ type. In addition to this GHC uses -- GHC.Utils.Binary for binary instances rather than Data.Binary (even though -- Data.Binary is a boot lib) so to fix the situation we must: -- - 1. Choose to use GHC.Utils.Binary or Data.Binary -- - 2. Remove Binary since this is redundant -- - 3. Adapt the Linker types, like Base to the new Binary methods ----------------------------------------------------------------------------- module GHC.StgToJS.Object ( object , object' , readDepsFile , readDepsFileEither , hReadDeps , hReadDepsEither , readDeps, readDepsMaybe , readObjectFile , readObjectFileKeys , readObject , readObjectKeys , serializeStat , emptySymbolTable , isGlobalUnit , isExportsUnit -- XXX verify that this is used -- XXX probably should instead do something that just inspects the header instead of exporting it , Header(..), getHeader, moduleNameTag , SymbolTable , ObjUnit (..) , Deps (..), BlockDeps (..), DepsLocation (..) , ExpFun (..), ExportedFun (..) , versionTag, versionTagLength ) where import GHC.Prelude import Control.Exception (bracket) import Control.Monad import Data.Array import Data.Monoid import qualified Data.Binary as DB import qualified Data.Binary.Get as DB import qualified Data.Binary.Put as DB import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as C8 (pack, unpack) import qualified Data.ByteString.Short as SBS import Data.Function (on) import Data.Int import Data.IntSet (IntSet) import qualified Data.IntSet as IS import Data.IORef import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (catMaybes) import Data.Word import Data.Char (isSpace) import GHC.Generics import GHC.Settings.Constants (hiVersion) import System.IO (openBinaryFile, withBinaryFile, Handle, hClose, hSeek, SeekMode(..), IOMode(..) ) import GHC.JS.Syntax import GHC.StgToJS.Types import GHC.Unit.Module import GHC.Data.FastString import GHC.Data.ShortText as ST import GHC.Float (castDoubleToWord64, castWord64ToDouble) import GHC.Utils.Binary hiding (SymbolTable) import GHC.Utils.Misc import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text) data Header = Header { hdrModuleName :: !BS.ByteString , hdrSymbsLen :: !Int64 , hdrDepsLen :: !Int64 , hdrIdxLen :: !Int64 } deriving (Eq, Ord, Show) -- | dependencies for a single module data Deps = Deps { depsModule :: !Module -- ^ module , depsRequired :: !IntSet -- ^ blocks that always need to be linked when this object is loaded (e.g. everything that contains initializer code or foreign exports) , depsHaskellExported :: !(Map ExportedFun Int) -- ^ exported Haskell functions -> block , depsBlocks :: !(Array Int BlockDeps) -- ^ info about each block } deriving (Generic) instance Outputable Deps where ppr d = vcat [ hcat [ text "module: ", pprModule (depsModule d) ] , hcat [ text "exports: ", ppr (M.keys (depsHaskellExported d)) ] ] -- | Where are the dependencies data DepsLocation = ObjectFile FilePath -- ^ In an object file at path | ArchiveFile FilePath -- ^ In a Ar file at path | InMemory String ByteString -- ^ In memory deriving (Eq, Show) instance Outputable DepsLocation where ppr x = text (show x) data BlockDeps = BlockDeps { blockBlockDeps :: [Int] -- ^ dependencies on blocks in this object , blockFunDeps :: [ExportedFun] -- ^ dependencies on exported symbols in other objects -- , blockForeignExported :: [ExpFun] -- , blockForeignImported :: [ForeignRef] } deriving (Generic) data ExpFun = ExpFun { isIO :: !Bool , args :: [JSFFIType] , result :: !JSFFIType } deriving (Eq, Ord, Show) trim :: String -> String trim = let f = dropWhile isSpace . reverse in f . f {- | we use the convention that the first unit (0) is a module-global unit that's always included when something from the module is loaded. everything in a module implicitly depends on the global block. the global unit itself can't have dependencies -} isGlobalUnit :: Int -> Bool isGlobalUnit n = n == 0 -- fixme document, exports unit is always linked isExportsUnit :: Int -> Bool isExportsUnit n = n == 1 data JSFFIType = Int8Type | Int16Type | Int32Type | Int64Type | Word8Type | Word16Type | Word32Type | Word64Type | DoubleType | ByteArrayType | PtrType | RefType deriving (Show, Ord, Eq, Enum) data ExportedFun = ExportedFun { funModule :: !Module , funSymbol :: !ShortText } deriving (Eq, Ord) instance Outputable ExportedFun where ppr (ExportedFun m f) = vcat [ hcat [ text "module: ", pprModule m ] , hcat [ text "symbol: ", ppr f ] ] -- we need to store the size separately, since getting a HashMap's size is O(n) data SymbolTable = SymbolTable !Int !(Map ShortText Int) deriving (Show) emptySymbolTable :: SymbolTable emptySymbolTable = SymbolTable 0 M.empty insertSymbol :: ShortText -> SymbolTable -> (SymbolTable, Int) insertSymbol s st@(SymbolTable n t) = case M.lookup s t of Just k -> (st, k) Nothing -> (SymbolTable (n+1) (M.insert s n t), n) data ObjEnv = ObjEnv { oeSymbols :: SymbolTableR , _oeName :: String } data SymbolTableR = SymbolTableR { strText :: Array Int ShortText , _strString :: Array Int String } runGetS :: HasDebugCallStack => String -> SymbolTableR -> (BinHandle -> IO a) -> ByteString -> IO a runGetS name st m bl = do let bs = B.toStrict bl bh0 <- unpackBinBuffer (BS.length bs) bs let bh = setUserData bh0 (newReadState undefined (readTable (ObjEnv st name))) m bh runPutS :: SymbolTable -> (BinHandle -> IO ()) -> IO (SymbolTable, ByteString) runPutS st ps = do bh0 <- openBinMem (1024 * 1024) t_r <- newIORef st let bh = setUserData bh0 (newWriteState undefined undefined (insertTable t_r)) ps bh (,) <$> readIORef t_r <*> (B.fromStrict <$> packBinBuffer bh) insertTable :: IORef SymbolTable -> BinHandle -> FastString -> IO () insertTable t_r bh s = do t <- readIORef t_r let (t', n) = insertSymbol (ST.pack $ unpackFS s) t writeIORef t_r t' put_ bh n return () readTable :: ObjEnv -> BinHandle -> IO FastString readTable e bh = do n :: Int <- get bh return . mkFastString . ST.unpack $ strText (oeSymbols e) ! fromIntegral n -- unexpected :: String -> GetS a -- unexpected err = ask >>= \e -> -- error (oeName e ++ ": " ++ err) -- one toplevel block in the object file data ObjUnit = ObjUnit { oiSymbols :: [ShortText] -- toplevel symbols (stored in index) , oiClInfo :: [ClosureInfo] -- closure information of all closures in block , oiStatic :: [StaticInfo] -- static closure data , oiStat :: JStat -- the code , oiRaw :: ShortText -- raw JS code , oiFExports :: [ExpFun] , oiFImports :: [ForeignJSRef] } -- | build an object file object :: ModuleName -- ^ the module name -> Deps -- ^ the dependencies -> [ObjUnit] -- ^ units, the first unit is the module-global one -> IO ByteString -- ^ serialized object object mname ds units = do (xs, symbs) <- go emptySymbolTable units object' mname symbs ds xs where go st0 (ObjUnit sy cl si st str fe fi : ys) = do (st1, bs ) <- serializeStat st0 cl si st str fe fi (bss, st2) <- go st1 ys return ((sy,B.fromChunks [bs]):bss, st2) go st0 [] = return ([], st0) serializeStat :: SymbolTable -> [ClosureInfo] -> [StaticInfo] -> JStat -> ShortText -> [ExpFun] -> [ForeignJSRef] -> IO (SymbolTable, BS.ByteString) serializeStat st ci si s sraw fe fi = do -- TODO: Did any of the Objectable instances previously used here interact with the `State`? (st', bs) <- runPutS st $ \bh -> do put_ bh ci put_ bh si put_ bh s put_ bh sraw put_ bh fe put_ bh fi return (st', B.toStrict bs) -- tag to store the module name in the object file moduleNameTag :: ModuleName -> BS.ByteString moduleNameTag (ModuleName fs) = case compare len moduleNameLength of EQ -> tag LT -> tag <> BS.replicate (moduleNameLength - len) 0 -- pad with 0s GT -> BS.drop (len - moduleNameLength) tag -- take only the ending chars where !tag = SBS.fromShort (fs_sbs fs) !len = n_chars fs object' :: ModuleName -- ^ module -> SymbolTable -- ^ final symbol table -> Deps -- ^ dependencies -> [([ShortText],ByteString)] -- ^ serialized units and their exported symbols, the first unit is module-global -> IO ByteString object' mod_name st0 deps0 os = do (sti, idx) <- putIndex st0 os let symbs = putSymbolTable sti deps1 <- putDepsSection deps0 let hdr = putHeader (Header (moduleNameTag mod_name) (bl symbs) (bl deps1) (bl idx)) return $ hdr <> symbs <> deps1 <> idx <> mconcat (map snd os) where bl = fromIntegral . B.length putIndex :: SymbolTable -> [([ShortText], ByteString)] -> IO (SymbolTable, ByteString) putIndex st xs = runPutS st (\bh -> put_ bh $ zip symbols offsets) where (symbols, values) = unzip xs offsets = scanl (+) 0 (map B.length values) getIndex :: HasDebugCallStack => String -> SymbolTableR -> ByteString -> IO [([ShortText], Int64)] getIndex name st bs = runGetS name st get bs putDeps :: SymbolTable -> Deps -> IO (SymbolTable, ByteString) putDeps st deps = runPutS st (\bh -> put_ bh deps) getDeps :: HasDebugCallStack => String -> SymbolTableR -> ByteString -> IO Deps getDeps name st bs = runGetS name st get bs toI32 :: Int -> Int32 toI32 = fromIntegral fromI32 :: Int32 -> Int fromI32 = fromIntegral putDepsSection :: Deps -> IO ByteString putDepsSection deps = do (st, depsbs) <- putDeps emptySymbolTable deps let stbs = putSymbolTable st return $ DB.runPut (DB.putWord32le (fromIntegral $ B.length stbs)) <> stbs <> depsbs getDepsSection :: HasDebugCallStack => String -> ByteString -> IO Deps getDepsSection name bs = let symbsLen = fromIntegral $ DB.runGet DB.getWord32le bs symbs = getSymbolTable (B.drop 4 bs) in getDeps name symbs (B.drop (4+symbsLen) bs) instance Binary Deps where put_ bh (Deps m r e b) = do put_ bh m put_ bh (map toI32 $ IS.toList r) put_ bh (map (\(x,y) -> (x, toI32 y)) $ M.toList e) put_ bh (elems b) get bh = Deps <$> get bh <*> (IS.fromList . map fromI32 <$> get bh) <*> (M.fromList . map (\(x,y) -> (x, fromI32 y)) <$> get bh) <*> ((\xs -> listArray (0, length xs - 1) xs) <$> get bh) instance Binary BlockDeps where put_ bh (BlockDeps bbd bfd) = put_ bh bbd >> put_ bh bfd get bh = BlockDeps <$> get bh <*> get bh instance Binary ForeignJSRef where put_ bh (ForeignJSRef span pat safety cconv arg_tys res_ty) = put_ bh span >> put_ bh pat >> putEnum bh safety >> putEnum bh cconv >> put_ bh arg_tys >> put_ bh res_ty get bh = ForeignJSRef <$> get bh <*> get bh <*> getEnum bh <*> getEnum bh <*> get bh <*> get bh instance Binary ExpFun where put_ bh (ExpFun isIO args res) = put_ bh isIO >> put_ bh args >> put_ bh res get bh = ExpFun <$> get bh <*> get bh <*> get bh -- | reads only the part necessary to get bh the dependencies -- so it's potentially more efficient than readDeps <$> B.readFile file readDepsFile :: FilePath -> IO Deps readDepsFile file = withBinaryFile file ReadMode (hReadDeps file) readDepsFileEither :: FilePath -> IO (Either String Deps) readDepsFileEither file = withBinaryFile file ReadMode (hReadDepsEither file) hReadDeps :: String -> Handle -> IO Deps hReadDeps name h = do res <- hReadDepsEither name h case res of Left err -> error ("hReadDeps: not a valid GHCJS object: " ++ name ++ "\n " ++ err) Right deps -> pure deps hReadDepsEither :: String -> Handle -> IO (Either String Deps) hReadDepsEither name h = do mhdr <- getHeader <$> B.hGet h headerLength case mhdr of Left err -> pure (Left err) Right hdr -> do hSeek h RelativeSeek (fromIntegral $ hdrSymbsLen hdr) Right <$> (getDepsSection name =<< B.hGet h (fromIntegral $ hdrDepsLen hdr)) readDepsEither :: String -> ByteString -> IO (Either String Deps) readDepsEither name bs = case getHeader bs of Left err -> return $ Left err Right hdr -> let depsStart = fromIntegral headerLength + fromIntegral (hdrSymbsLen hdr) in Right <$> getDepsSection name (B.drop depsStart bs) -- | call with contents of the file readDeps :: String -> B.ByteString -> IO Deps readDeps name bs = do mdeps <- readDepsEither name bs case mdeps of Left err -> error ("readDeps: not a valid GHCJS object: " ++ name ++ "\n " ++ err) Right deps -> return deps readDepsMaybe :: String -> ByteString -> IO (Maybe Deps) readDepsMaybe name bs = either (const Nothing) Just <$> readDepsEither name bs -- | extract the linkable units from an object file readObjectFile :: FilePath -> IO [ObjUnit] readObjectFile = readObjectFileKeys (\_ _ -> True) readObjectFileKeys :: (Int -> [ShortText] -> Bool) -> FilePath -> IO [ObjUnit] readObjectFileKeys p file = bracket (openBinaryFile file ReadMode) hClose $ \h -> do mhdr <- getHeader <$> B.hGet h headerLength case mhdr of Left err -> error ("readObjectFileKeys: not a valid GHCJS object: " ++ file ++ "\n " ++ err) Right hdr -> do bss <- B.hGet h (fromIntegral $ hdrSymbsLen hdr) hSeek h RelativeSeek (fromIntegral $ hdrDepsLen hdr) bsi <- B.fromStrict <$> BS.hGetContents h readObjectKeys' file p (getSymbolTable bss) bsi (B.drop (fromIntegral $ hdrIdxLen hdr) bsi) readObject :: String -> ByteString -> IO [ObjUnit] readObject name = readObjectKeys name (\_ _ -> True) readObjectKeys :: HasDebugCallStack => String -> (Int -> [ShortText] -> Bool) -> ByteString -> IO [ObjUnit] readObjectKeys name p bs = case getHeader bs of Left err -> error ("readObjectKeys: not a valid GHCJS object: " ++ name ++ "\n " ++ err) Right hdr -> let bssymbs = B.drop (fromIntegral headerLength) bs bsidx = B.drop (fromIntegral $ hdrSymbsLen hdr + hdrDepsLen hdr) bssymbs bsobjs = B.drop (fromIntegral $ hdrIdxLen hdr) bsidx in readObjectKeys' name p (getSymbolTable bssymbs) bsidx bsobjs readObjectKeys' :: HasDebugCallStack => String -> (Int -> [ShortText] -> Bool) -> SymbolTableR -> ByteString -> ByteString -> IO [ObjUnit] readObjectKeys' name p st bsidx bsobjs = do idx <- getIndex name st bsidx catMaybes <$> zipWithM readObj [0..] idx where readObj n (x,off) | p n x = do (ci, si, s, sraw, fe, fi) <- runGetS name st getOU (B.drop off bsobjs) return $ Just (ObjUnit x ci si s sraw fe fi) | otherwise = return Nothing getOU bh = (,,,,,) <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh getSymbolTable :: HasDebugCallStack => ByteString -> SymbolTableR getSymbolTable bs = SymbolTableR (listArray (0,n-1) xs) (listArray (0,n-1) (map ST.unpack xs)) where (n,xs) = DB.runGet getter bs getter :: DB.Get (Int, [ShortText]) getter = do l <- DB.getWord32le let l' = fromIntegral l (l',) <$> replicateM l' DB.get putSymbolTable :: SymbolTable -> ByteString putSymbolTable (SymbolTable _ hm) = st where st = DB.runPut $ do DB.putWord32le (fromIntegral $ length xs) mapM_ DB.put xs -- fixme: this is a workaround for some weird issue sometimes causing zero-length -- strings when using the Data.Text instance directly -- mapM_ (DB.put . TE.encodeUtf8) xs xs :: [ShortText] xs = map fst . sortBy (compare `on` snd) . M.toList $ hm headerLength :: Int headerLength = 32 + versionTagLength + moduleNameLength -- human readable version string in object versionTag :: ByteString versionTag = B.take 32 . C8.pack $ show hiVersion ++ replicate versionTagLength ' ' versionTagLength :: Int versionTagLength = 32 -- last part of the module name, to disambiguate files moduleNameLength :: Int moduleNameLength = 128 getHeader :: HasDebugCallStack => ByteString -> Either String Header getHeader bs | B.length bs < fromIntegral headerLength = Left "not enough input, file truncated?" | magic /= "GHCJSOBJ" = Left $ "magic number incorrect, not a JavaScript .o file?" | tag /= versionTag = Left $ "incorrect version, expected " ++ show hiVersion ++ " but got " ++ (trim . C8.unpack $ tag) | otherwise = Right (Header mn sl dl il) where g = fromIntegral <$> DB.getWord64le (magic, tag, mn, sl, dl, il) = DB.runGet ((,,,,,) <$> DB.getByteString 8 <*> DB.getLazyByteString (fromIntegral versionTagLength) <*> DB.getByteString (fromIntegral moduleNameLength) <*> g <*> g <*> g ) bs putHeader :: Header -> ByteString putHeader (Header mn sl dl il) = DB.runPut $ do DB.putByteString "GHCJSOBJ" DB.putLazyByteString versionTag DB.putByteString mn mapM_ (DB.putWord64le . fromIntegral) [sl, dl, il] tag :: BinHandle -> Word8 -> IO () tag = put_ getTag :: BinHandle -> IO Word8 getTag = get instance Binary ShortText where put_ bh t = put_ bh (mkFastString $ ST.unpack t) get bh = ST.pack . unpackFS <$> get bh -- put_ bh t = do -- symbols <- St.get -- let (symbols', n) = insertSymbol t symbols -- St.put symbols' -- lift (DB.putWord32le $ fromIntegral n) -- get bh = do -- st <- oeSymbols <$> ask -- n <- lift DB.getWord32le -- return (strText st ! fromIntegral n) instance Binary JStat where put_ bh (DeclStat i) = tag bh 1 >> put_ bh i put_ bh (ReturnStat e) = tag bh 2 >> put_ bh e put_ bh (IfStat e s1 s2) = tag bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 put_ bh (WhileStat b e s) = tag bh 4 >> put_ bh b >> put_ bh e >> put_ bh s put_ bh (ForInStat b i e s) = tag bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s put_ bh (SwitchStat e ss s) = tag bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s put_ bh (TryStat s1 i s2 s3) = tag bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 put_ bh (BlockStat xs) = tag bh 8 >> put_ bh xs put_ bh (ApplStat e es) = tag bh 9 >> put_ bh e >> put_ bh es put_ bh (UOpStat o e) = tag bh 10 >> put_ bh o >> put_ bh e put_ bh (AssignStat e1 e2) = tag bh 11 >> put_ bh e1 >> put_ bh e2 put_ _ (UnsatBlock {}) = error "put_ bh JStat: UnsatBlock" put_ bh (LabelStat l s) = tag bh 12 >> put_ bh l >> put_ bh s put_ bh (BreakStat ml) = tag bh 13 >> put_ bh ml put_ bh (ContinueStat ml) = tag bh 14 >> put_ bh ml get bh = getTag bh >>= \case 1 -> DeclStat <$> get bh 2 -> ReturnStat <$> get bh 3 -> IfStat <$> get bh <*> get bh <*> get bh 4 -> WhileStat <$> get bh <*> get bh <*> get bh 5 -> ForInStat <$> get bh <*> get bh <*> get bh <*> get bh 6 -> SwitchStat <$> get bh <*> get bh <*> get bh 7 -> TryStat <$> get bh <*> get bh <*> get bh <*> get bh 8 -> BlockStat <$> get bh 9 -> ApplStat <$> get bh <*> get bh 10 -> UOpStat <$> get bh <*> get bh 11 -> AssignStat <$> get bh <*> get bh 12 -> LabelStat <$> get bh <*> get bh 13 -> BreakStat <$> get bh 14 -> ContinueStat <$> get bh n -> error ("Binary get bh JStat: invalid tag: " ++ show n) instance Binary JExpr where put_ bh (ValExpr v) = tag bh 1 >> put_ bh v put_ bh (SelExpr e i) = tag bh 2 >> put_ bh e >> put_ bh i put_ bh (IdxExpr e1 e2) = tag bh 3 >> put_ bh e1 >> put_ bh e2 put_ bh (InfixExpr o e1 e2) = tag bh 4 >> put_ bh o >> put_ bh e1 >> put_ bh e2 put_ bh (UOpExpr o e) = tag bh 5 >> put_ bh o >> put_ bh e put_ bh (IfExpr e1 e2 e3) = tag bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3 put_ bh (ApplExpr e es) = tag bh 7 >> put_ bh e >> put_ bh es put_ _ (UnsatExpr {}) = error "put_ bh JExpr: UnsatExpr" get bh = getTag bh >>= \case 1 -> ValExpr <$> get bh 2 -> SelExpr <$> get bh <*> get bh 3 -> IdxExpr <$> get bh <*> get bh 4 -> InfixExpr <$> get bh <*> get bh <*> get bh 5 -> UOpExpr <$> get bh <*> get bh 6 -> IfExpr <$> get bh <*> get bh <*> get bh 7 -> ApplExpr <$> get bh <*> get bh n -> error ("Binary get bh JExpr: invalid tag: " ++ show n) instance Binary JVal where put_ bh (JVar i) = tag bh 1 >> put_ bh i put_ bh (JList es) = tag bh 2 >> put_ bh es put_ bh (JDouble d) = tag bh 3 >> put_ bh d put_ bh (JInt i) = tag bh 4 >> put_ bh i put_ bh (JStr xs) = tag bh 5 >> put_ bh xs put_ bh (JRegEx xs) = tag bh 6 >> put_ bh xs put_ bh (JHash m) = tag bh 7 >> put_ bh (M.toList m) put_ bh (JFunc is s) = tag bh 8 >> put_ bh is >> put_ bh s put_ _ (UnsatVal {}) = error "put_ bh JVal: UnsatVal" get bh = getTag bh >>= \case 1 -> JVar <$> get bh 2 -> JList <$> get bh 3 -> JDouble <$> get bh 4 -> JInt <$> get bh 5 -> JStr <$> get bh 6 -> JRegEx <$> get bh 7 -> JHash . M.fromList <$> get bh 8 -> JFunc <$> get bh <*> get bh n -> error ("Binary get bh JVal: invalid tag: " ++ show n) instance Binary Ident where put_ bh (TxtI xs) = put_ bh xs get bh = TxtI <$> get bh -- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this instance Binary SaneDouble where put_ bh (SaneDouble d) | isNaN d = tag bh 1 | isInfinite d && d > 0 = tag bh 2 | isInfinite d && d < 0 = tag bh 3 | isNegativeZero d = tag bh 4 | otherwise = tag bh 5 >> put_ bh (castDoubleToWord64 d) get bh = getTag bh >>= \case 1 -> pure $ SaneDouble (0 / 0) 2 -> pure $ SaneDouble (1 / 0) 3 -> pure $ SaneDouble ((-1) / 0) 4 -> pure $ SaneDouble (-0) 5 -> SaneDouble . castWord64ToDouble <$> get bh n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n) instance Binary ClosureInfo where put_ bh (ClosureInfo v regs name layo typ static) = do put_ bh v >> put_ bh regs >> put_ bh name >> put_ bh layo >> put_ bh typ >> put_ bh static get bh = ClosureInfo <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh instance Binary JSFFIType where put_ bh = putEnum bh get bh = getEnum bh instance Binary VarType where put_ bh = putEnum bh get bh = getEnum bh instance Binary CIRegs where put_ bh CIRegsUnknown = tag bh 1 put_ bh (CIRegs skip types) = tag bh 2 >> put_ bh skip >> put_ bh types get bh = getTag bh >>= \case 1 -> pure CIRegsUnknown 2 -> CIRegs <$> get bh <*> get bh n -> error ("Binary get bh CIRegs: invalid tag: " ++ show n) instance Binary JOp where put_ bh = putEnum bh get bh = getEnum bh instance Binary JUOp where put_ bh = putEnum bh get bh = getEnum bh -- 16 bit sizes should be enough... instance Binary CILayout where put_ bh CILayoutVariable = tag bh 1 put_ bh (CILayoutUnknown size) = tag bh 2 >> put_ bh size put_ bh (CILayoutFixed size types) = tag bh 3 >> put_ bh size >> put_ bh types get bh = getTag bh >>= \case 1 -> pure CILayoutVariable 2 -> CILayoutUnknown <$> get bh 3 -> CILayoutFixed <$> get bh <*> get bh n -> error ("Binary get bh CILayout: invalid tag: " ++ show n) instance Binary CIStatic where put_ bh (CIStaticRefs refs) = tag bh 1 >> put_ bh refs get bh = getTag bh >>= \case 1 -> CIStaticRefs <$> get bh n -> error ("Binary get bh CIStatic: invalid tag: " ++ show n) instance Binary CIType where put_ bh (CIFun arity regs) = tag bh 1 >> put_ bh arity >> put_ bh regs put_ bh CIThunk = tag bh 2 put_ bh (CICon conTag) = tag bh 3 >> put_ bh conTag put_ bh CIPap = tag bh 4 put_ bh CIBlackhole = tag bh 5 put_ bh CIStackFrame = tag bh 6 get bh = getTag bh >>= \case 1 -> CIFun <$> get bh <*> get bh 2 -> pure CIThunk 3 -> CICon <$> get bh 4 -> pure CIPap 5 -> pure CIBlackhole 6 -> pure CIStackFrame n -> error ("Binary get bh CIType: invalid tag: " ++ show n) instance Binary ExportedFun where put_ bh (ExportedFun modu symb) = put_ bh modu >> put_ bh symb get bh = ExportedFun <$> get bh <*> get bh instance DB.Binary Module where put (Module unit mod_name) = DB.put unit >> DB.put mod_name get = Module <$> DB.get <*> DB.get instance DB.Binary ModuleName where put (ModuleName fs) = DB.put fs get = ModuleName <$> DB.get instance DB.Binary Unit where put = \case RealUnit (Definite uid) -> DB.put (0 :: Int) >> DB.put uid VirtUnit uid -> DB.put (1 :: Int) >> DB.put uid HoleUnit -> DB.put (2 :: Int) get = DB.get >>= \case (0 :: Int) -> RealUnit . Definite <$> DB.get 1 -> VirtUnit <$> DB.get _ -> pure HoleUnit instance DB.Binary UnitId where put (UnitId fs) = DB.put fs get = UnitId <$> DB.get instance DB.Binary InstantiatedUnit where put indef = do DB.put (instUnitInstanceOf indef) DB.put (instUnitInsts indef) get = mkInstantiatedUnitSorted <$> DB.get <*> DB.get instance DB.Binary FastString where put fs = DB.put (unpackFS fs) get = mkFastString <$> DB.get putEnum :: Enum a => BinHandle -> a -> IO () putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n) | otherwise = put_ bh n where n = fromIntegral $ fromEnum x :: Word16 getEnum :: Enum a => BinHandle -> IO a getEnum bh = toEnum . fromIntegral <$> (get bh :: IO Word16) instance Binary StaticInfo where put_ bh (StaticInfo ident val cc) = put_ bh ident >> put_ bh val >> put_ bh cc get bh = StaticInfo <$> get bh <*> get bh <*> get bh instance Binary StaticVal where put_ bh (StaticFun f args) = tag bh 1 >> put_ bh f >> put_ bh args put_ bh (StaticThunk t) = tag bh 2 >> put_ bh t put_ bh (StaticUnboxed u) = tag bh 3 >> put_ bh u put_ bh (StaticData dc args) = tag bh 4 >> put_ bh dc >> put_ bh args put_ bh (StaticList xs t) = tag bh 5 >> put_ bh xs >> put_ bh t get bh = getTag bh >>= \case 1 -> StaticFun <$> get bh <*> get bh 2 -> StaticThunk <$> get bh 3 -> StaticUnboxed <$> get bh 4 -> StaticData <$> get bh <*> get bh 5 -> StaticList <$> get bh <*> get bh n -> error ("Binary get bh StaticVal: invalid tag " ++ show n) instance Binary StaticUnboxed where put_ bh (StaticUnboxedBool b) = tag bh 1 >> put_ bh b put_ bh (StaticUnboxedInt i) = tag bh 2 >> put_ bh i put_ bh (StaticUnboxedDouble d) = tag bh 3 >> put_ bh d put_ bh (StaticUnboxedString str) = tag bh 4 >> put_ bh str put_ bh (StaticUnboxedStringOffset str) = tag bh 5 >> put_ bh str get bh = getTag bh >>= \case 1 -> StaticUnboxedBool <$> get bh 2 -> StaticUnboxedInt <$> get bh 3 -> StaticUnboxedDouble <$> get bh 4 -> StaticUnboxedString <$> get bh 5 -> StaticUnboxedStringOffset <$> get bh n -> error ("Binary get bh StaticUnboxed: invalid tag " ++ show n) instance Binary StaticArg where put_ bh (StaticObjArg i) = tag bh 1 >> put_ bh i put_ bh (StaticLitArg p) = tag bh 2 >> put_ bh p put_ bh (StaticConArg c args) = tag bh 3 >> put_ bh c >> put_ bh args get bh = getTag bh >>= \case 1 -> StaticObjArg <$> get bh 2 -> StaticLitArg <$> get bh 3 -> StaticConArg <$> get bh <*> get bh n -> error ("Binary get bh StaticArg: invalid tag " ++ show n) instance Binary StaticLit where put_ bh (BoolLit b) = tag bh 1 >> put_ bh b put_ bh (IntLit i) = tag bh 2 >> put_ bh i put_ bh NullLit = tag bh 3 put_ bh (DoubleLit d) = tag bh 4 >> put_ bh d put_ bh (StringLit t) = tag bh 5 >> put_ bh t put_ bh (BinLit b) = tag bh 6 >> put_ bh b put_ bh (LabelLit b t) = tag bh 7 >> put_ bh b >> put_ bh t get bh = getTag bh >>= \case 1 -> BoolLit <$> get bh 2 -> IntLit <$> get bh 3 -> pure NullLit 4 -> DoubleLit <$> get bh 5 -> StringLit <$> get bh 6 -> BinLit <$> get bh 7 -> LabelLit <$> get bh <*> get bh n -> error ("Binary get bh StaticLit: invalid tag " ++ show n)