109 lines
4.6 KiB
Diff
109 lines
4.6 KiB
Diff
# UNDF: UNDF-2026-000000078
|
|
diff --git a/compiler/GHC/Data/Graph/Directed/Internal.hs b/compiler/GHC/Data/Graph/Directed/Internal.hs
|
|
index 159e1ff..c560954 100644
|
|
--- a/compiler/GHC/Data/Graph/Directed/Internal.hs
|
|
+++ b/compiler/GHC/Data/Graph/Directed/Internal.hs
|
|
@@ -7,6 +7,7 @@ import Data.Array
|
|
import qualified Data.Graph as G
|
|
import Data.Graph ( Vertex, SCC(..) ) -- Used in the underlying representation
|
|
import Data.Tree
|
|
+import qualified Data.IntSet as IntSet
|
|
|
|
data Graph node = Graph {
|
|
gr_int_graph :: IntGraph,
|
|
@@ -70,10 +71,13 @@ scc :: IntGraph -> [SCC Vertex]
|
|
scc graph = map decode forest
|
|
where
|
|
forest = {-# SCC "Digraph.scc" #-} G.scc graph
|
|
+ -- CWE-407 fix: precompute IntSet adjacency for O(1) self-loop check
|
|
+ -- was: v `elem` (graph ! v) — O(degree) per vertex
|
|
+ graphSets = fmap IntSet.fromList graph -- Array Vertex IntSet
|
|
|
|
decode (Node v []) | mentions_itself v = CyclicSCC [v]
|
|
| otherwise = AcyclicSCC v
|
|
decode other = CyclicSCC (dec other [])
|
|
where dec (Node v ts) vs = v : foldr dec vs ts
|
|
- mentions_itself v = v `elem` (graph ! v)
|
|
+ mentions_itself v = v `IntSet.member` (graphSets ! v)
|
|
|
|
diff --git a/compiler/GHC/Data/Graph/Inductive/Graph.hs b/compiler/GHC/Data/Graph/Inductive/Graph.hs
|
|
index 80d17d4..6ee3558 100644
|
|
--- a/compiler/GHC/Data/Graph/Inductive/Graph.hs
|
|
+++ b/compiler/GHC/Data/Graph/Inductive/Graph.hs
|
|
@@ -176,6 +176,17 @@ class Graph gr where
|
|
labEdges :: gr a b -> [LEdge b]
|
|
labEdges = ufold (\(_,v,_,s)->(map (\(l,w)->(v,w,l)) s ++)) []
|
|
|
|
+ -- | True if there is a directed edge between two nodes.
|
|
+ -- Default implementation is O(degree); implementations may override for O(1).
|
|
+ -- CWE-407 fix: override in PatriciaTree with IM.member for O(log degree).
|
|
+ hasEdge :: gr a b -> Edge -> Bool
|
|
+ hasEdge gr (v,w) = w `elem` suc gr v
|
|
+
|
|
+ -- | True if there is an undirected edge between two nodes.
|
|
+ -- Default implementation is O(degree); implementations may override for O(1).
|
|
+ hasNeighbor :: gr a b -> Node -> Node -> Bool
|
|
+ hasNeighbor gr v w = w `elem` neighbors gr v
|
|
+
|
|
class (Graph gr) => DynGraph gr where
|
|
-- | Merge the 'Context' into the 'DynGraph'.
|
|
--
|
|
@@ -484,14 +495,6 @@ indeg' = length . context1l'
|
|
deg' :: Context a b -> Int
|
|
deg' (p,_,_,s) = length p+length s
|
|
|
|
--- | Checks if there is a directed edge between two nodes.
|
|
-hasEdge :: Graph gr => gr a b -> Edge -> Bool
|
|
-hasEdge gr (v,w) = w `elem` suc gr v
|
|
-
|
|
--- | Checks if there is an undirected edge between two nodes.
|
|
-hasNeighbor :: Graph gr => gr a b -> Node -> Node -> Bool
|
|
-hasNeighbor gr v w = w `elem` neighbors gr v
|
|
-
|
|
-- | Checks if there is a labelled edge between two nodes.
|
|
hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool
|
|
hasLEdge gr (v,w,l) = (w,l) `elem` lsuc gr v
|
|
diff --git a/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs b/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs
|
|
index 09ec8af..54bb2bc 100644
|
|
--- a/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs
|
|
+++ b/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs
|
|
@@ -104,6 +104,17 @@ instance Graph Gr where
|
|
label <- labels
|
|
return (node, next, label)
|
|
|
|
+ -- CWE-407 fix: O(log degree) IntMap lookup vs O(degree) elem on list
|
|
+ hasEdge (Gr g) (v,w) =
|
|
+ case IM.lookup v g of
|
|
+ Nothing -> False
|
|
+ Just (_, _, s) -> IM.member w s
|
|
+
|
|
+ hasNeighbor (Gr g) v w =
|
|
+ case IM.lookup v g of
|
|
+ Nothing -> False
|
|
+ Just (p, _, s) -> IM.member w p || IM.member w s
|
|
+
|
|
instance DynGraph Gr where
|
|
(p, v, l, s) & (Gr g)
|
|
= let !g1 = IM.insert v (preds, l, succs) g
|
|
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
|
|
index da19c17..c779e88 100644
|
|
--- a/compiler/GHC/Tc/TyCl/Utils.hs
|
|
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
|
|
@@ -884,6 +884,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
|
|
-- Find a representative constructor, con1
|
|
rec_sel_info@(RSI { rsi_def = cons_w_field })
|
|
= conLikesRecSelInfo all_cons [lbl]
|
|
+ cons_w_field_set = mkUniqSet cons_w_field -- CWE-407 fix: O(1) lookup in dealt_with
|
|
con1 = assert (not (null cons_w_field)) $ head cons_w_field
|
|
|
|
-- Construct the IdDetails
|
|
@@ -970,7 +971,8 @@ mkOneRecordSelector all_cons idDetails fl has_sel
|
|
dealt_with :: ConLike -> Bool
|
|
dealt_with (PatSynCon _) = False -- We can't predict overlap
|
|
dealt_with con@(RealDataCon dc)
|
|
- = con `elem` cons_w_field || dataConCannotMatch inst_tys dc
|
|
+ = con `elementOfUniqSet` cons_w_field_set -- CWE-407 fix: O(1) vs O(n) elem
|
|
+ || dataConCannotMatch inst_tys dc
|
|
where
|
|
inst_tys = dataConResRepTyArgs dc
|
|
|