|
| 1 | +diff -ru ghcjs/src/Gen2/Compactor.hs ghcjs-patched/src/Gen2/Compactor.hs |
| 2 | +--- ghcjs/src/Gen2/Compactor.hs 2020-06-22 15:05:01.376054868 +0000 |
| 3 | ++++ ghcjs-patched/src/Gen2/Compactor.hs 2020-06-22 15:04:48.554887970 +0000 |
| 4 | +@@ -1210,9 +1210,8 @@ |
| 5 | + where |
| 6 | + replaceHash h = fromMaybe h (M.lookup h finalHashes) |
| 7 | + hashText bs = "h$$$" <> TE.decodeUtf8 (B16.encode bs) |
| 8 | +- sccs :: [[Text]] |
| 9 | +- sccs = map fromSCC $ |
| 10 | +- G.stronglyConnComp (map (\(k, (_bs, deps)) -> (k, k, deps)) (M.toList hashes)) |
| 11 | ++ sccs :: [G.SCC (Hash, Text, [Text])] |
| 12 | ++ sccs = G.stronglyConnCompR (map (\(k, hash@(_bs, deps)) -> (hash, k, deps)) (M.toList hashes)) |
| 13 | + ks = M.keys hashes |
| 14 | + invDeps = M.fromListWith (++) (concatMap mkInvDeps $ M.toList hashes) |
| 15 | + mkInvDeps (k, (_, ds)) = map (,[k]) ds |
| 16 | +@@ -1226,7 +1225,7 @@ |
| 17 | + -> Map Text [Text] |
| 18 | + -> [Text] |
| 19 | + -> [Text] |
| 20 | +- -> [[Text]] |
| 21 | ++ -> [G.SCC (Hash, Text, [Text])] |
| 22 | + -> Map Text Hash |
| 23 | + -> Map Text BS.ByteString |
| 24 | + -> Map Text BS.ByteString |
| 25 | +@@ -1250,20 +1249,22 @@ |
| 26 | + | otherwise = Nothing |
| 27 | + newHashes :: [(Text, BS.ByteString)] |
| 28 | + newHashes = mapMaybe mkNewHash checkKeys |
| 29 | +- rootSCCs :: [[Text]] |
| 30 | ++ rootSCCs :: [G.SCC (Hash, Text, [Text])] |
| 31 | + rootSCCs = filter isRootSCC sccs |
| 32 | +- isRootSCC :: [Text] -> Bool |
| 33 | +- isRootSCC scc = not (all (`M.member` finalHashes) scc) && all check scc |
| 34 | ++ isRootSCC :: G.SCC (Hash, Text, [Text]) -> Bool |
| 35 | ++ isRootSCC scc = not (all (`M.member` finalHashes) flatSCC) && all check flatSCC |
| 36 | + where |
| 37 | ++ flatSCC = view _2 <$> G.flattenSCC scc |
| 38 | + check n = let Just (_bs, out) = M.lookup n hashes |
| 39 | + in all checkEdge out |
| 40 | + checkEdge e = e `S.member` s || e `M.member` finalHashes |
| 41 | +- s = S.fromList scc |
| 42 | +- hashRootSCC :: [Text] -> [(Text,BS.ByteString)] |
| 43 | ++ s = S.fromList flatSCC |
| 44 | ++ hashRootSCC :: G.SCC (Hash, Text, [Text]) -> [(Text,BS.ByteString)] |
| 45 | + hashRootSCC scc |
| 46 | +- | any (`M.member` finalHashes) scc = Panic.panic "Gen2.Compactor.hashRootSCC: has finalized nodes" |
| 47 | ++ | any (`M.member` finalHashes) flatSCC = Panic.panic "Gen2.Compactor.hashRootSCC: has finalized nodes" |
| 48 | + | otherwise = map makeHash toHash |
| 49 | + where |
| 50 | ++ flatSCC = view _2 <$> G.flattenSCC scc |
| 51 | + makeHash k = let Just (bs,deps) = M.lookup k hashes |
| 52 | + luds = map lookupDep deps |
| 53 | + in (k, makeFinalHash bs luds) |
| 54 | +@@ -1287,7 +1288,19 @@ |
| 55 | + BB.int64LE (fromIntegral $ length deps') <> |
| 56 | + mconcat (map BB.byteString deps') |
| 57 | + toHash :: [Text] |
| 58 | +- toHash = sortBy (compare `on` (fst . (hashes M.!))) scc |
| 59 | ++ toHash = depthFirstSCC scc |
| 60 | ++ |
| 61 | ++-- | Sort the nodes influenced by the topology. This is important so that two |
| 62 | ++-- graphs which share nodes but have different edges are hashed differently. |
| 63 | ++depthFirstSCC :: G.SCC (Hash, Text, [Text]) -> [Text] |
| 64 | ++depthFirstSCC scc = case sortedByHash of |
| 65 | ++ [] -> Panic.panic "Gen2.Compactor.depthFirstSCC: SCC has no nodes" |
| 66 | ++ (_, rootKey, _):_ -> case vertexFromKey rootKey of |
| 67 | ++ Nothing -> Panic.panic $ "Gen2.Compactor.depthFirstSCC: vertex not found for key: " <> T.unpack rootKey |
| 68 | ++ Just rootVertex -> (foldMap . foldMap) (\v -> [view _2 $ nodeFromVertex v]) $ G.dfs graph [rootVertex] |
| 69 | ++ where |
| 70 | ++ sortedByHash = sortOn (view _1) $ G.flattenSCC scc |
| 71 | ++ (graph, nodeFromVertex, vertexFromKey) = G.graphFromEdges sortedByHash |
| 72 | + |
| 73 | + makeFinalHash :: BS.ByteString -> [BS.ByteString] -> BS.ByteString |
| 74 | + makeFinalHash b bs = SHA256.hash (mconcat (b:bs)) |
0 commit comments