Seed.hs (23034B)
1 -- Copyright 2023 The Plunder Authors 2 -- Use of this source code is governed by a BSD-style license that can be 3 -- found in the LICENSE file. 4 5 module Fan.Seed 6 ( loadSeed, saveSeed -- seed = everything in one go 7 , saveGermPin, loadGerm 8 , loadPod, savePod -- save each pin, then save table of seeds 9 , savePin, savePin' -- save one pin with header 10 , LoadErr(..) 11 , splitBlob 12 , loadHead 13 , loadBody 14 , Seed.withContext 15 , Seed.Ctx 16 ) 17 where 18 19 20 import Data.Bits 21 import Data.Sorted 22 import Fan.Convert 23 import Fan.Types 24 import Foreign.ForeignPtr 25 import Foreign.Marshal.Alloc 26 import Foreign.Marshal.Utils 27 import Foreign.Ptr 28 import Foreign.Storable 29 import PlunderPrelude 30 31 import Control.Monad.Primitive (touch) 32 import Control.Monad.Trans.Except (runExcept, throwE) 33 import Control.Monad.Trans.State.Strict (State(..), StateT(..), evalState, 34 evalStateT, execState, execStateT, get, 35 modify', put, runState) 36 37 import Fan.Eval (boom, evalArity, mkLawPreNormalized, mkPin', mkRow, 38 tabValsRow, (%%)) 39 import Fan.Trace (doTrk) 40 import Foreign.C.Types (CBool(..)) 41 import GHC.Word (Word(..)) 42 import Hash256 (Hash256, hashToByteString, toHash256) 43 import Loot.Backend (loadClosure, loadShallow) 44 import Loot.ReplExe (closureRex, dieFan, showFan, trkFan) 45 import Rex (GRex(..), RuneShape(..), TextShape(..), rexLine) 46 import Rex.Print (RexColor, RexColorScheme(NoColors)) 47 48 import qualified Data.ByteString as BS 49 import qualified Data.ByteString.Internal as BS 50 import qualified Data.ByteString.Unsafe as BS 51 import qualified Data.Map as M 52 import qualified Data.Set as S 53 import qualified Data.Vector as V 54 import qualified Data.Vector.Mutable as VM 55 import qualified Fan.Prof as Prof 56 import qualified Fan.Seed.FFI as Seed 57 import qualified Fan.Seed.FragLoader as JFL 58 import qualified GHC.Exts as GHC 59 60 61 -------------------------------------------------------------------------------- 62 63 savePin' :: Seed.Ctx -> Pin -> IO (Vector Pin, ByteString, ByteString) 64 savePin' ctx p = do 65 body <- saveGermPin' ctx p 66 head <- saveHead p 67 pure (p.refs, head, body) 68 69 savePin :: Pin -> IO (Vector Pin, ByteString, ByteString) 70 savePin pin = Seed.withContext \ctx -> savePin' ctx pin 71 72 saveHead :: Pin -> IO ByteString 73 saveHead pin = do 74 ptr <- mallocForeignPtrBytes size 75 withForeignPtr ptr \buf -> do 76 poke buf (fromIntegral numPins :: Word64) 77 for_ (zip [0..] (toList pin.refs)) \(i, dep) -> do 78 let dst = buf `plusPtr` (8 + (i*32)) 79 poke (castPtr dst :: Ptr Hash256) dep.hash 80 pure (BS.BS (castForeignPtr ptr) size) 81 where 82 numPins = length pin.refs 83 84 size :: Int 85 size = 8 + (32*numPins) 86 87 loadBody :: Vector Pin -> ByteString -> Either LoadErr Fan 88 loadBody refs bs = unsafePerformIO (loadGerm refs bs) 89 90 loadHead :: ByteString -> Either LoadErr (Vector Hash256) 91 loadHead bs@(BS.BS fp siz) = do 92 let siz = length bs 93 94 when (siz < 8) do 95 Left $ HEAD_TOO_SMALL_NO_LENGTH 96 97 -- TODO: Handle words that don't fit in ints 98 let !numPins = unsafePerformIO do 99 res <- withForeignPtr (castForeignPtr fp) peek 100 pure (fromIntegral (res :: Word64)) 101 102 let required = (8 + numPins * 32) :: Int 103 104 when (fromIntegral siz < required) do 105 Left $ HEAD_TOO_SMALL (fromIntegral siz) (fromIntegral required) 106 107 let f remain = (toHash256 (take 32 remain), drop 32 remain) 108 109 pure $ V.unfoldrExactN numPins f $ drop 8 bs 110 111 splitBlob :: ByteString -> Either LoadErr (ByteString, ByteString) 112 splitBlob bs@(BS.BS fp siz) = do 113 when (siz < 8) do 114 Left HEAD_TOO_SMALL_NO_LENGTH 115 116 -- TODO: Handle words that don't fit in ints 117 let !numPins = unsafePerformIO do 118 res <- withForeignPtr (castForeignPtr fp) peek 119 pure (fromIntegral (res :: Word64)) 120 121 let required = (8 + fromIntegral numPins * 32) :: Int 122 123 when (siz < required) do 124 Left $ HEAD_TOO_SMALL (fromIntegral siz) (fromIntegral required) 125 126 pure (take required bs, drop required bs) 127 128 129 -------------------------------------------------------------------------------- 130 131 data LoadErr 132 = EOF Text 133 | EMPTY_INPUT 134 | INPUT_NOT_WORD64_PADDED 135 | LEAF_HAS_IMPOSSIBLE_SIZE 136 | NAT_HAS_TRAILING_ZEROS 137 | GERM_BAD_HOLE_COUNT { passed :: Nat, required :: Nat } 138 | POD_INTEGRITY_CHECK_FAILED Hash256 Pin 139 | POD_MALFORMED Fan 140 | POD_NO_MAGIC 141 | POD_MISSING_HASH 142 | POD_NO_ROUND 143 | POD_NO_PINS 144 | HEAD_TOO_SMALL_NO_LENGTH 145 | HEAD_TOO_SMALL { bufferSize :: Nat, requiredSize :: Nat } 146 deriving (Eq, Ord, Show, Generic, Exception) 147 148 instance ToNoun LoadErr where 149 toNoun = \case 150 EOF loc -> toNoun ("EOF"::Text, loc) 151 EMPTY_INPUT -> toNoun ("EMPTY_INPUT"::Text) 152 INPUT_NOT_WORD64_PADDED -> toNoun ("INPUT_NOT_WORD64_PADDED"::Text) 153 LEAF_HAS_IMPOSSIBLE_SIZE -> toNoun ("LEAF_HAS_IMPOSSIBLE_SIZE"::Text) 154 NAT_HAS_TRAILING_ZEROS -> toNoun ("NAT_HAS_TRAILING_ZEROS"::Text) 155 GERM_BAD_HOLE_COUNT p r -> toNoun ("GERM_BAD_HOLE_COUNT"::Text, p, r) 156 POD_INTEGRITY_CHECK_FAILED h p -> toNoun ("POD_INTEGRITY_CHECK_FAILED"::Text, h, p) 157 POD_MALFORMED f -> toNoun ("POD_MALFORMED"::Text, f) 158 POD_NO_MAGIC -> toNoun ("POD_NO_MAGIC"::Text) 159 POD_MISSING_HASH -> toNoun ("POD_MISSING_HASH"::Text) 160 POD_NO_ROUND -> toNoun ("POD_NO_ROUND"::Text) 161 HEAD_TOO_SMALL_NO_LENGTH -> toNoun ("HEAD_TOO_SMALL_NO_LENGTH"::Text) 162 HEAD_TOO_SMALL s r -> toNoun ("HEAD_TOO_SMALL"::Text, s, r) 163 164 instance (ToNoun a, ToNoun b) => ToNoun (Either a b) where 165 toNoun (Left x) = ROW $ arrayFromListN 2 [0, toNoun x] 166 toNoun (Right x) = ROW $ arrayFromListN 2 [1, toNoun x] 167 168 trkM :: Monad m => Fan -> m () 169 trkM msg = do 170 let !() = doTrk msg () 171 pure () 172 173 loadSeed :: ByteString -> IO (Either LoadErr Fan) 174 loadSeed = loadGerm mempty 175 176 loadGerm :: Vector Pin -> ByteString -> IO (Either LoadErr Fan) 177 loadGerm holes germBar@(BS.BS fp bufByteSz) = 178 Prof.withSimpleTracingEvent "loadGerm" "load" $ try do 179 -- trkM $ REX $ planRexFull $ toNoun ("LOAD"::Text, (.hash) <$> holes) 180 withForeignPtr fp \byteBuf -> do 181 evalStateT (go byteBuf) 0 182 where 183 holesFan = PIN <$> holes 184 185 (bufWordSz, overflow) = bufByteSz `quotRem` 8 186 187 needWords :: Text -> Int -> StateT Int IO () 188 needWords location need = do 189 used <- get 190 when ((used + need) > bufWordSz) do 191 throwIO (EOF location) 192 193 go :: Ptr Word8 -> StateT Int IO Fan 194 go byteBuf = do 195 when (overflow /= 0) do throwIO INPUT_NOT_WORD64_PADDED 196 197 let wordBuf :: Ptr Word = castPtr byteBuf 198 199 needWords "header" 5 200 201 numHolesW :: Word <- liftIO $ peekElemOff wordBuf 0 202 numBigsW :: Word <- liftIO $ peekElemOff wordBuf 1 203 numWordsW :: Word <- liftIO $ peekElemOff wordBuf 2 204 numBytesW :: Word <- liftIO $ peekElemOff wordBuf 3 205 numFragsW :: Word <- liftIO $ peekElemOff wordBuf 4 206 207 put 5 208 209 let numHoles = fromIntegral numHolesW :: Int 210 let numBigs = fromIntegral numBigsW :: Int 211 let numWords = fromIntegral numWordsW :: Int 212 let numBytes = fromIntegral numBytesW :: Int 213 let numFrags = fromIntegral numFragsW :: Int 214 215 let numAtoms = numBytes + numWords + numBigs 216 let numLeaves = numHoles + numAtoms 217 let tableSize = numLeaves + numFrags 218 219 when (numHoles /= length holes) do 220 throwIO GERM_BAD_HOLE_COUNT { passed = fromIntegral (length holes) 221 , required = fromIntegral (numHoles) 222 } 223 224 when (tableSize == 0) do throwIO EMPTY_INPUT 225 226 table :: VM.IOVector Fan <- VM.unsafeNew (fromIntegral tableSize) 227 228 for (take numHoles [0..]) \i -> do 229 VM.unsafeWrite table i (holesFan V.! i) 230 231 -- BigNat widths 232 needWords "bignat widths" numBigs 233 bigWidths <- liftIO $ V.generateM (fromIntegral numBigs) \i -> 234 peekElemOff wordBuf (5+i) 235 modify' (+ numBigs) 236 237 -- BigNats 238 needWords "bignat data" (fromIntegral $ sum bigWidths) 239 for_ (take numBigs [0..]) \i -> do 240 let wid = bigWidths V.! i 241 off <- get 242 put $! (off + fromIntegral wid) 243 let pntr = castForeignPtr (fp `plusForeignPtr` (off * 8)) 244 let valu = NAT $ NatJ# (EXO wid pntr) 245 VM.unsafeWrite table (numHoles + i) valu 246 247 -- Words 248 needWords "words" numWords 249 wordSection <- get 250 for_ (take numWords [0..]) \i -> do 251 !(W# w) <- liftIO (peekElemOff wordBuf (wordSection + i)) 252 VM.unsafeWrite table (numHoles + numBigs + i) (NAT $ NatS# w) 253 modify' (+ numWords) 254 255 -- Bytes 256 let (byteWords, byteExtra) = numBytes `quotRem` 8 257 258 needWords "bytes" (byteWords + if byteExtra == 0 then 0 else 1) 259 260 bytesSection <- get <&> \off -> (byteBuf `plusPtr` (off * 8)) 261 for_ (take numBytes [0..]) \i -> do 262 byt :: Word8 <- liftIO (peekByteOff bytesSection i) 263 let !(W# w) = fromIntegral byt 264 VM.unsafeWrite table (numHoles + numBigs + numWords + i) (NAT (NatS# w)) 265 266 modify' (+ byteWords) 267 268 -- Fragments 269 do 270 off <- get 271 let usedBits = byteExtra * 8 272 let fragPtr = wordBuf `plusPtr` (8 * off) 273 let endPtr = wordBuf `plusPtr` bufByteSz 274 finalPtr <- liftIO $ JFL.loadFrags2 True 275 table 276 (numLeaves, numFrags) 277 usedBits 278 (fragPtr, endPtr) 279 280 -- TODO: This fires even though things are working? What gives? 281 when ((finalPtr > endPtr) && False) do 282 throwIO (EOF "fragments") 283 284 -- Return final value 285 VM.read table (tableSize - 1) 286 287 288 -------------------------------------------------------------------------------- 289 290 {-# INLINE saveSeed #-} 291 saveSeed :: Fan -> IO ByteString 292 saveSeed top = Seed.withContext \ctx -> saveSeed' ctx top 293 294 {-# INLINE saveSeed' #-} 295 saveSeed' :: Seed.Ctx -> Fan -> IO ByteString 296 saveSeed' ctx top = do 297 vPins <- newIORef mempty 298 vZoo <- newIORef Nothing 299 saveWorker ctx vZoo vPins top 300 301 {- 302 This is just broken off into a separate function for syntactic reasons 303 (to make avoid needing to move the whole `where` block into let 304 clauses within the top-level `do` block) 305 -} 306 {-# INLINE saveWorker #-} 307 saveWorker 308 :: Seed.Ctx 309 -> IORef (Maybe Seed.CNode) 310 -> IORef (Map Hash256 Seed.CNode) 311 -> Fan 312 -> IO ByteString 313 saveWorker !ctx !vZoo !vPins !top = do 314 315 _ <- Prof.withSimpleTracingEvent "walk" "save" do 316 loop top 317 318 () <- Prof.withSimpleTracingEvent "done" "save" do 319 Seed.c_done ctx 320 321 wid <- Prof.withSimpleTracingEvent "size" "save" do 322 Seed.c_size ctx 323 324 ptr <- mallocForeignPtrBytes (fromIntegral wid) 325 326 Prof.withSimpleTracingEvent "write" "save" do 327 withForeignPtr ptr \buf -> do 328 void (fillBytes buf 0 $ fromIntegral wid) 329 written <- Seed.c_save ctx wid buf 330 unless (wid == written) do 331 error $ unlines $ concat 332 [ [ "INTERNAL ERROR IN save_seed()" 333 , "" 334 , "When serializing a fan value (using seed), the number" 335 , "of bytes written did not match the pre-computed buffer" 336 , "size. This is is an internal invariant violation and" 337 , "is fatal, please submit a bug report!" 338 , "" 339 , "Here is the plan value that we were trying to" 340 , "serialize:" 341 , "" 342 ] 343 , fmap ("\t" <>) $ lines $ unpack $ showFan top 344 , [ "pre-calculated size: " <> show wid 345 , "" 346 , "written size: " <> show written 347 ] 348 ] 349 350 Prof.withSimpleTracingEvent "wipe" "save" do 351 Seed.c_wipe ctx 352 353 -- Need to make sure no bars or atoms are collected while the C code 354 -- still has reference to them. 355 touch top 356 357 pure (BS.BS ptr $ fromIntegral wid) 358 where 359 -- COW 3 = (0 0 4 0) 360 doCow :: Nat -> IO Seed.CNode 361 doCow n = do 362 z <- Seed.c_word ctx 0 363 zz <- Seed.c_cons ctx z z 364 r <- doNat (n+1) 365 zzr <- Seed.c_cons ctx zz r 366 zzrz <- Seed.c_cons ctx zzr z 367 pure zzrz 368 369 -- Keys must be given in descending order. 370 -- 371 -- Example Shape: 372 -- 373 -- %[y x] = (0 1 2 (0 0 3 0 y x)) 374 -- 375 -- Example Insertion Order: 376 -- 377 -- 0 378 -- (0 0) 379 -- 3 380 -- (0 0 3) 381 -- (0 0 3 0) 382 -- y 383 -- (0 0 3 0 y) 384 -- x 385 -- (0 0 3 0 y x) 386 -- ((0 0 3) (0 0 3 0 y x)) 387 doSet :: Int -> [Fan] -> IO Seed.CNode 388 doSet len keyz = do 389 let go acc [] = pure acc 390 go acc (x:xs) = do key <- loop x 391 acc' <- Seed.c_cons ctx acc key 392 go acc' xs 393 z <- Seed.c_word ctx 0 394 o <- Seed.c_word ctx 1 395 zo <- Seed.c_cons ctx z o 396 t <- Seed.c_word ctx 2 397 zot <- Seed.c_cons ctx zo t 398 zzrz <- doCow (fromIntegral len) 399 row <- go zzrz keyz 400 Seed.c_cons ctx zot row 401 402 doNat (NatS# w) = do 403 -- print ("WORD"::Text, W# w) 404 Seed.c_word ctx (fromIntegral (W# w)) 405 406 doNat n@(NatJ# x) = do 407 withForeignPtr x.ptr \buf -> do 408 Seed.c_nat ctx (fromIntegral x.sz) (castPtr buf) 409 410 loop :: Fan -> IO Seed.CNode 411 loop = \case 412 NAT n -> do 413 doNat n 414 415 PIN pin -> do 416 let hax = pin.hash 417 (lookup hax <$> readIORef vPins) >>= \case 418 Just p -> do 419 Prof.withSimpleTracingEvent "touch" "save" do 420 Seed.c_touch ctx p 421 pure p 422 423 Nothing -> do 424 four <- Seed.c_word ctx 4 425 item <- loop pin.item 426 node <- Seed.c_cons ctx four item 427 modifyIORef vPins (insertMap hax node) 428 pure node 429 430 -- bar b = (0 1 1 (BARNAT b)) 431 BAR (BS.BS fpt wid) -> do 432 withForeignPtr fpt \buf -> do 433 zoo <- readIORef vZoo >>= \case 434 Just zoo -> do 435 Seed.c_touch ctx zoo 436 pure zoo 437 Nothing -> do 438 zer <- Seed.c_word ctx 0 439 one <- Seed.c_word ctx 1 440 zo <- Seed.c_cons ctx zer one 441 zoo <- Seed.c_cons ctx zo one 442 pure zoo 443 bod <- Seed.c_barnat ctx (fromIntegral wid) buf 444 res <- Seed.c_cons ctx zoo bod 445 pure res 446 447 COw n -> 448 doCow n 449 450 SET ks -> do 451 let wid = length ks 452 let keyz = ssetToDescList ks 453 doSet wid keyz 454 455 -- This needs to have the same behaviors as a head-first traversal 456 -- using `boom`. Rows are represented as 457 -- 458 -- [a b c]=((COW 3) c b a) 459 -- 460 -- So, that examples should be loaded by running: 461 -- 462 -- x = loop (COW 3) 463 -- y = loop c 464 -- x = (cons x y) 465 -- y = loop b 466 -- x = (cons x y) 467 -- y = loop a 468 -- return (cons x y) 469 -- 470 -- So, we basically want to fold over: 471 -- 472 -- (COW n : reverse (toList row)) 473 -- 474 -- Except that we want to do that as a traversal so that we 475 -- don't need to allocate anything. 476 -- 477 ROW !row -> do 478 let go !acc !i = 479 if i<0 then do 480 pure acc 481 else do 482 x <- loop (row!i) 483 y <- Seed.c_cons ctx acc x 484 go y (i-1) 485 486 start <- doCow (fromIntegral $ length row) 487 let lastIx = length row - 1 488 go start lastIx 489 490 -- #[3=4 5=6] = (%[3 5] [4 6]) 491 TAb tab -> do 492 ks <- doSet (length tab) (fst <$> tabToDescPairsList tab) 493 vs <- loop (tabValsRow tab) 494 kv <- Seed.c_cons ctx ks vs 495 pure kv 496 497 KLO _ env -> do 498 let !end = sizeofSmallArray env 499 500 let go !acc !i | i>=end = pure acc 501 go !acc !i = do 502 !x <- loop (env .! i) 503 !y <- Seed.c_cons ctx acc x 504 go y (i+1) 505 506 !start <- loop (env .! 0) 507 go start 1 508 509 FUN (L (LN nv) av bv _) -> do 510 z <- Seed.c_word ctx 0 511 n <- doNat nv 512 zn <- Seed.c_cons ctx z n 513 a <- doNat av 514 zna <- Seed.c_cons ctx zn a 515 b <- loop bv 516 znab <- Seed.c_cons ctx zna b 517 pure znab 518 519 -------------------------------------------------------------------------------- 520 521 saveGerm :: Fan -> IO ByteString 522 saveGerm val = do 523 pin <- mkPin' val -- cheap, just to have a uniform interface. 524 -- This is only used for Pin.refs, which allows 525 -- saveGermPin to take advantage of the cache 526 -- instead of recalculating. 527 Seed.withContext \ctx -> do 528 saveGermPin' ctx pin 529 530 saveGermPin :: Pin -> IO ByteString 531 saveGermPin pin = 532 Seed.withContext \ctx -> do 533 saveGermPin' ctx pin 534 535 saveGermPin' :: Seed.Ctx -> Pin -> IO ByteString 536 saveGermPin' ctx pin = do 537 538 tab <- 539 Prof.withSimpleTracingEvent "setup" "save" do 540 -- Create entries for each seed. 541 for_ pin.refs \_ -> Seed.c_hole ctx 542 543 -- We can serialize "with holes for each pin" by just using 544 -- pre-filling the pin cache with the corresponding hole. 545 let tab :: Map Hash256 Seed.CNode 546 tab = mapFromList (zip hashes [0..]) 547 where hashes = toList ((.hash) <$> pin.refs) 548 549 evaluate tab 550 551 vPins <- newIORef tab 552 vZoo <- newIORef Nothing 553 res <- saveWorker ctx vZoo vPins pin.item 554 555 pure res 556 557 {- 558 TODO: A better representation might be: 559 560 - (Vector (ByteString, [Nat])), using the index as a key instead 561 - of the hashes. 562 -} 563 564 type PinStorage = Vector (ByteString, Vector Nat) 565 566 data Pod = POD 567 { top :: !Hash256 568 , pinStorage :: !PinStorage 569 } 570 571 instance ToNoun Pod where 572 toNoun p = ROW $ arrayFromListN 2 [toNoun p.top, toNoun p.pinStorage] 573 574 instance FromNoun Pod where 575 fromNoun n = do 576 r <- getRawRow n 577 guard (length r == 2) 578 POD <$> fromNoun (r!0) 579 <*> fromNoun (r!1) 580 581 magicHeader :: ByteString 582 magicHeader = "SEEDPOD:" 583 584 planRexFull :: Any -> GRex a 585 planRexFull = fmap absurd . itemizeRexes . closureRex Nothing . loadClosure 586 587 savePod :: Pin -> IO ByteString 588 savePod pin = 589 Prof.withSimpleTracingEvent "savePod" "save" do 590 liftIO $ Seed.withContext \ctx -> do 591 pod <- collect ctx pin 592 payload <- saveSeed' ctx (toNoun pod) 593 pure (magicHeader <> payload) 594 595 {- 596 We should have a version of this that is given a callback which 597 loads the blob, either from disk or from local cache. 598 -} 599 collect :: Seed.Ctx -> Pin -> IO Pod 600 collect ctx topPin = do 601 Prof.withSimpleTracingEvent "collect" "save" do 602 (haz, tab) <- runStateT (collectWorker ctx topPin) mempty 603 pure (POD haz $ finish tab) 604 where 605 finish :: PinStorageAcc -> PinStorage 606 finish (hashes, list) = 607 V.fromListN (length hashes) (reverse list) 608 609 type PinStorageAcc = (Map Hash256 Nat, [(ByteString, Vector Nat)]) 610 611 collectWorker :: Seed.Ctx -> Pin -> StateT PinStorageAcc IO Hash256 612 collectWorker ctx pin = do 613 haz <- evaluate pin.hash 614 t1 <- fst <$> get 615 unless (member haz t1) do 616 traverse_ (collectWorker ctx) pin.refs 617 body <- liftIO (saveGermPin' ctx pin) 618 refs <- do 619 t2 <- fst <$> get 620 for (pin.refs <&> (.hash)) \h -> do 621 case lookup h t2 of 622 Nothing -> error "impossible: already inserted" 623 Just ix -> pure ix 624 haz <- evaluate pin.hash 625 modify' \(tab, acc) -> ( insertMap haz (fromIntegral $ length tab) tab 626 , (body, refs) : acc 627 ) 628 pure haz 629 630 reconstruct :: Pod -> IO (Either LoadErr Pin) 631 reconstruct pod = try 632 if null pod.pinStorage then 633 throwIO POD_NO_PINS 634 else 635 flip evalStateT mempty do 636 loop $ fromIntegral $ pred $ length pod.pinStorage 637 where 638 build :: Nat -> StateT (Map Nat Pin) IO Pin 639 build ix = do 640 -- TODO: Overflow and out of bounds checking 641 let (body, refs) = pod.pinStorage V.! fromIntegral ix 642 643 deps <- traverse loop refs 644 fan <- liftIO $ loadGerm deps body >>= either throwIO pure 645 pin <- liftIO $ mkPin' fan 646 modify' (insertMap ix pin) 647 pure pin 648 649 loop :: Nat -> StateT (Map Nat Pin) IO Pin 650 loop hash = do 651 tab <- get 652 case lookup hash tab of 653 Just f -> pure f 654 Nothing -> build hash 655 656 -- | Loads a previously packed bytestring pack to a full Fan value. 657 loadPod :: ByteString -> IO (Either LoadErr Pin) 658 loadPod bs = try do 659 (pin, pod) <- Prof.withSimpleTracingEvent "loadPod" "load" do 660 let (header, payload) = splitAt 8 bs 661 662 when (header /= magicHeader) do 663 throwIO POD_NO_MAGIC 664 665 val <- loadSeed payload >>= either throwIO pure 666 667 pod <- case fromNoun val of 668 Nothing -> throwIO (POD_MALFORMED val) 669 Just pod -> pure pod 670 671 pin <- reconstruct pod >>= either throwIO pure 672 673 pure (pin, pod) 674 675 Prof.withSimpleTracingEvent "validate" "load" do 676 when (pod.top /= pin.hash) do 677 throwIO (POD_INTEGRITY_CHECK_FAILED pod.top pin) 678 679 pure pin 680 681 itemizeRexes :: [GRex a] -> GRex a 682 itemizeRexes [x] = x 683 itemizeRexes rs = go rs 684 where 685 go [] = N OPEN "*" [] Nothing 686 go [x] = N OPEN "*" [x] Nothing 687 go (x:xs) = N OPEN "*" [x] (Just $ go xs)