Commit 59c796f8 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-08-17 15:23:47 by simonpj]

-------------------------------
	Use merge-sort not quicksort
	Nuke quicksort altogether
	-------------------------------

Quicksort has O(n**2) behaviour worst case, and this occasionally bites.
In particular, when compiling large files consisting only of static data,
we get loads of top-level delarations -- and that led to more than half the
total compile time being spent in the strongly connected component analysis
for the occurrence analyser.  Switching to merge sort completely solved the
problem.

I've nuked quicksort altogether to make sure this does not happen again.
parent c8898df0
......@@ -57,7 +57,7 @@ import Name ( Name )
import TyCon ( TyCon, tyConFamilySize )
import Bitmap ( Bitmap, mAX_SMALL_BITMAP_SIZE,
mkBitmap, intsToReverseBitmap )
import Util ( isn'tIn, sortLt )
import Util ( isn'tIn, sortLe )
import CmdLineOpts ( opt_Unregisterised )
import FastString ( LitString )
import Outputable
......@@ -350,7 +350,7 @@ buildContLiveness name live_slots
-- (subtract one for the frame-header = return address).
rel_slots :: [WordOff]
rel_slots = sortLt (<)
rel_slots = sortLe (<=)
[ start_sp - ofs -- Get slots relative to top of frame
| ofs <- live_slots ]
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgStackery.lhs,v 1.25 2004/08/13 13:06:12 simonmar Exp $
% $Id: CgStackery.lhs,v 1.26 2004/08/17 15:23:48 simonpj Exp $
%
\section[CgStackery]{Stack management functions}
......@@ -31,7 +31,7 @@ import Cmm
import CmmUtils ( CmmStmts, mkLblExpr )
import CLabel ( mkUpdInfoLabel )
import Constants
import Util ( sortLt )
import Util ( sortLe )
import FastString ( LitString )
import OrdList ( toOL )
import Outputable
......@@ -312,7 +312,7 @@ Explicitly free some stack space.
freeStackSlots :: [VirtualSpOffset] -> Code
freeStackSlots extra_free
= do { stk_usg <- getStkUsage
; let all_free = addFreeSlots (freeStk stk_usg) (sortLt (<) extra_free)
; let all_free = addFreeSlots (freeStk stk_usg) (sortLe (<=) extra_free)
; let (new_vsp, new_free) = trim (virtSp stk_usg) all_free
; setStkUsage (stk_usg { virtSp = new_vsp, freeStk = new_free }) }
......
......@@ -51,7 +51,7 @@ import Literal ( Literal(..) )
import CLabel ( CLabel, mkAsmTempLabel )
import Digraph ( SCC(..), stronglyConnComp )
import ListSetOps ( assocDefault )
import Util ( filterOut, sortLt )
import Util ( filterOut, sortLe )
import Char ( ord )
import FastString ( LitString, FastString, unpackFS )
import Outputable
......@@ -352,12 +352,12 @@ emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
Nothing -> return Nothing
Just stmts -> do id <- forkCgStmts stmts; return (Just id)
; stmts <- mk_switch tag_expr (sortLt lt branches)
; stmts <- mk_switch tag_expr (sortLe le branches)
mb_deflt_id lo_tag hi_tag
; emitCgStmts stmts
}
where
(t1,_) `lt` (t2,_) = t1 < t2
(t1,_) `le` (t2,_) = t1 <= t2
mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
......@@ -475,10 +475,10 @@ emitLitSwitch scrut [] deflt
emitLitSwitch scrut branches deflt_blk
= do { scrut' <- assignTemp scrut
; deflt_blk_id <- forkCgStmts deflt_blk
; blk <- mk_lit_switch scrut' deflt_blk_id (sortLt lt branches)
; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
; emitCgStmts blk }
where
lt (t1,_) (t2,_) = t1 < t2
le (t1,_) (t2,_) = t1 <= t2
mk_lit_switch :: CmmExpr -> BlockId
-> [(Literal,CgStmts)]
......
......@@ -730,7 +730,7 @@ doCase d s p (_,scrut)
-- things that are pointers, whereas in CgBindery the code builds the
-- bitmap from the free slots and unboxed bindings.
-- (ToDo: merge?)
bitmap = intsToReverseBitmap d{-size-} (sortLt (<) rel_slots)
bitmap = intsToReverseBitmap d{-size-} (sortLe (<=) rel_slots)
where
binds = fmToList p
rel_slots = concat (map spread binds)
......
......@@ -220,7 +220,7 @@ import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
)
import Outputable
import DriverUtil ( createDirectoryHierarchy, directoryOf )
import Util ( sortLt, seqList )
import Util ( sortLe, seqList )
import Binary ( getBinFileWithDict )
import BinIface ( writeBinIface, v_IgnoreHiWay )
import Unique ( Unique, Uniquable(..) )
......@@ -286,9 +286,9 @@ mkIface hsc_env location maybe_old_iface
; deprecs = mkIfaceDeprec src_deprecs
; iface_rules
| omit_prags = []
| otherwise = sortLt lt_rule $
| otherwise = sortLe le_rule $
map (coreRuleToIfaceRule this_mod_name ext_nm) rules
; iface_insts = sortLt lt_inst (map dfunToIfaceInst insts)
; iface_insts = sortLe le_inst (map dfunToIfaceInst insts)
; intermediate_iface = ModIface {
mi_module = this_mod,
......@@ -333,8 +333,8 @@ mkIface hsc_env location maybe_old_iface
; return new_iface }
where
r1 `lt_rule` r2 = ifRuleName r1 < ifRuleName r2
i1 `lt_inst` i2 = ifDFun i1 < ifDFun i2
r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2
dflags = hsc_dflags hsc_env
ghci_mode = hsc_mode hsc_env
......@@ -649,7 +649,7 @@ anyNothing p (x:xs) = isNothing (p x) || anyNothing p xs
mkIfaceDeprec :: Deprecations -> IfaceDeprecs
mkIfaceDeprec NoDeprecs = NoDeprecs
mkIfaceDeprec (DeprecAll t) = DeprecAll t
mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLt (<) (nameEnvElts env))
mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLe (<=) (nameEnvElts env))
----------------------
bump_unless :: Bool -> Version -> Version
......@@ -745,7 +745,7 @@ mk_usage_info pit hpt dir_imp_mods dep_mods proto_used_names
used_occs = lookupModuleEnv ent_map mod `orElse` []
ent_vers :: [(OccName,Version)]
ent_vers = [ (occ, version_env occ `orElse` initialVersion)
| occ <- sortLt (<) used_occs]
| occ <- sortLe (<=) used_occs]
\end{code}
\begin{code}
......
......@@ -23,7 +23,7 @@ module ErrUtils (
import Bag ( Bag, bagToList, isEmptyBag, emptyBag )
import SrcLoc ( SrcSpan )
import Util ( sortLt )
import Util ( sortLe )
import Outputable
import qualified Pretty
import SrcLoc ( srcSpanStart )
......@@ -130,10 +130,13 @@ pprBagOfErrors bag_of_errors
errMsgContext = unqual } <- sorted_errs ]
where
bag_ls = bagToList bag_of_errors
sorted_errs = sortLt occ'ed_before bag_ls
sorted_errs = sortLe occ'ed_before bag_ls
occ'ed_before err1 err2 =
LT == compare (head (errMsgSpans err1)) (head (errMsgSpans err2))
case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
LT -> True
EQ -> True
GT -> False
pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc
pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
......
......@@ -53,7 +53,7 @@ import SrcLoc ( noSrcLoc, Located(..), mkGeneralSrcSpan,
unLoc, noLoc, srcLocSpan, SrcSpan )
import BasicTypes ( DeprecTxt )
import ListSetOps ( removeDups )
import Util ( sortLt, notNull, isSingleton )
import Util ( sortLe, notNull, isSingleton )
import List ( partition )
import IO ( openFile, IOMode(..) )
\end{code}
......@@ -1010,8 +1010,11 @@ addDupDeclErr (n:ns)
nest 2 (ptext SLIT("other declarations at:")),
nest 4 (vcat (map ppr sorted_locs))]
where
sorted_locs = sortLt occ'ed_before (map nameSrcLoc ns)
occ'ed_before a b = LT == compare a b
sorted_locs = sortLe occ'ed_before (map nameSrcLoc ns)
occ'ed_before a b = case compare a b of
LT -> True
EQ -> True
GT -> False
dupExportWarn occ_name ie1 ie2
= hsep [quotes (ppr occ_name),
......
......@@ -72,7 +72,7 @@ import OccName ( occNameUserString )
import Type ( isUnLiftedType, Type )
import BasicTypes ( TopLevelFlag(..) )
import UniqSupply
import Util ( sortLt, isSingleton, count )
import Util ( sortLe, isSingleton, count )
import Outputable
import FastString
\end{code}
......@@ -730,14 +730,14 @@ abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
-- whose level is greater than the destination level
-- These are the ones we are going to abstract out
abstractVars dest_lvl env fvs
= uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
= uniq (sortLe le [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
where
-- Sort the variables so we don't get
-- mixed-up tyvars and Ids; it's just messy
v1 `lt` v2 = case (isId v1, isId v2) of
v1 `le` v2 = case (isId v1, isId v2) of
(True, False) -> False
(False, True) -> True
other -> v1 < v2 -- Same family
other -> v1 <= v2 -- Same family
uniq :: [Var] -> [Var]
-- Remove adjacent duplicates; the sort will have brought them together
......
......@@ -15,7 +15,7 @@ import StgSyn
import Id ( Id )
import VarSet
import VarEnv
import Util ( sortLt )
import Util ( sortLe )
import Maybes ( orElse )
import Maybes ( expectJust )
import Bitmap ( intsToBitmap )
......@@ -151,7 +151,7 @@ constructSRT table (SRTEntries entries)
where
ints = map (expectJust "constructSRT" . lookupVarEnv table)
(varSetElems entries)
sorted_ints = sortLt (<) ints
sorted_ints = sortLe (<=) ints
offset = head sorted_ints
bitmap_entries = map (subtract offset) sorted_ints
len = last bitmap_entries + 1
......
......@@ -35,7 +35,7 @@ import BasicTypes ( Activation, CompilerPhase, isActive )
import Outputable
import FastString
import Maybe ( isJust, isNothing, fromMaybe )
import Util ( sortLt )
import Util ( sortLe )
import Bag
import List ( isPrefixOf )
\end{code}
......@@ -292,7 +292,7 @@ match e1 (Lam x2 e2) tpl_vars kont subst
match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
= match e1 e2 tpl_vars case_kont subst
where
case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2))
case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLe le_alt alts2))
tpl_vars kont subst
match (Type ty1) (Type ty2) tpl_vars kont subst
......@@ -347,7 +347,7 @@ match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst
subst
match_alts alts1 alts2 tpl_vars kont subst = match_fail
lt_alt (con1, _, _) (con2, _, _) = con1 < con2
le_alt (con1, _, _) (con2, _, _) = con1 <= con2
----------------------------------------
bind :: [CoreBndr] -- Template binders
......
......@@ -49,7 +49,7 @@ import Var ( TyVar, tyVarKind, idType, varName )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
import SrcLoc ( srcLocSpan, Located(..) )
import Util ( zipWithEqual, sortLt, notNull )
import Util ( zipWithEqual, sortLe, notNull )
import ListSetOps ( removeDups, assocMaybe )
import Outputable
import Bag
......@@ -714,7 +714,7 @@ solveDerivEqns orig_eqns
= addSrcSpan (srcLocSpan (getSrcLoc tc)) $
addErrCtxt (derivCtxt (Just clas) tc) $
tcSimplifyDeriv tyvars deriv_rhs `thenM` \ theta ->
returnM (sortLt (<) theta) -- Canonicalise before returning the soluction
returnM (sortLe (<=) theta) -- Canonicalise before returning the soluction
mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta
= mkDictFunId dfun_name tyvars theta
......
......@@ -120,7 +120,7 @@ import Panic ( ghcError, GhcException(..) )
#endif
import FastString ( mkFastString )
import Util ( sortLt )
import Util ( sortLe )
import Bag ( unionBags, snocBag )
import Maybe ( isJust )
......@@ -1135,9 +1135,9 @@ ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
ppr_sigs :: [Var] -> SDoc
ppr_sigs ids
-- Print type signatures; sort by OccName
= vcat (map ppr_sig (sortLt lt_sig ids))
= vcat (map ppr_sig (sortLe le_sig ids))
where
lt_sig id1 id2 = getOccName id1 < getOccName id2
le_sig id1 id2 = getOccName id1 <= getOccName id2
ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
ppr_rules :: [IdCoreRule] -> SDoc
......
......@@ -32,7 +32,7 @@ module Digraph(
------------------------------------------------------------------------------
import Util ( sortLt )
import Util ( sortLe )
-- Extensions
import MONAD_ST
......@@ -100,8 +100,8 @@ stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEd
stronglyConnCompR edges
= map decode forest
where
(graph, vertex_fn) = graphFromEdges edges
forest = scc graph
(graph, vertex_fn) = _scc_ "graphFromEdges" graphFromEdges edges
forest = _scc_ "Digraph.scc" scc graph
decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
| otherwise = AcyclicSCC (vertex_fn v)
decode other = CyclicSCC (dec other [])
......@@ -163,14 +163,16 @@ graphFromEdges edges
where
max_v = length edges - 1
bounds = (0,max_v) :: (Vertex, Vertex)
sorted_edges = sortLt lt edges
sorted_edges = let
(_,k1,_) `le` (_,k2,_) = case k1 `compare` k2 of { GT -> False; other -> True }
in
sortLe le edges
edges1 = zipWith (,) [0..] sorted_edges
graph = array bounds [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1]
vertex_map = array bounds edges1
(_,k1,_) `lt` (_,k2,_) = case k1 `compare` k2 of { LT -> True; other -> False }
-- key_vertex :: key -> Maybe Vertex
-- returns Nothing for non-interesting vertices
......
......@@ -23,7 +23,7 @@ module ListSetOps (
import Outputable
import Unique ( Unique )
import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
import Util ( isn'tIn, isIn, mapAccumR, sortLt )
import Util ( isn'tIn, isIn, mapAccumR, sortLe )
import List ( union )
\end{code}
......@@ -156,10 +156,10 @@ equivClasses :: (a -> a -> Ordering) -- Comparison
equivClasses cmp stuff@[] = []
equivClasses cmp stuff@[item] = [stuff]
equivClasses cmp items
= runs eq (sortLt lt items)
= runs eq (sortLe le items)
where
eq a b = case cmp a b of { EQ -> True; _ -> False }
lt a b = case cmp a b of { LT -> True; _ -> False }
le a b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
\end{code}
The first cases in @equivClasses@ above are just to cut to the point
......
......@@ -21,7 +21,7 @@ module Util (
nTimes,
-- sorting
sortLt, naturalMergeSortLe,
sortLe,
-- transitive closures
transitiveClosure,
......@@ -330,126 +330,6 @@ isn'tIn msg x ys
# endif /* DEBUG */
\end{code}
%************************************************************************
%* *
\subsection[Utils-sorting]{Sorting}
%* *
%************************************************************************
%************************************************************************
%* *
\subsubsection[Utils-quicksorting]{Quicksorts}
%* *
%************************************************************************
\begin{code}
#if NOT_USED
-- tail-recursive, etc., "quicker sort" [as per Meira thesis]
quicksort :: (a -> a -> Bool) -- Less-than predicate
-> [a] -- Input list
-> [a] -- Result list in increasing order
quicksort lt [] = []
quicksort lt [x] = [x]
quicksort lt (x:xs) = split x [] [] xs
where
split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
| True = split x lo (y:hi) ys
#endif
\end{code}
Quicksort variant from Lennart's Haskell-library contribution. This
is a {\em stable} sort.
\begin{code}
sortLt :: (a -> a -> Bool) -- Less-than predicate
-> [a] -- Input list
-> [a] -- Result list
sortLt lt l = qsort lt l []
-- qsort is stable and does not concatenate.
qsort :: (a -> a -> Bool) -- Less-than predicate
-> [a] -- xs, Input list
-> [a] -- r, Concatenate this list to the sorted input list
-> [a] -- Result = sort xs ++ r
qsort lt [] r = r
qsort lt [x] r = x:r
qsort lt (x:xs) r = qpart lt x xs [] [] r
-- qpart partitions and sorts the sublists
-- rlt contains things less than x,
-- rge contains the ones greater than or equal to x.
-- Both have equal elements reversed with respect to the original list.
qpart lt x [] rlt rge r =
-- rlt and rge are in reverse order and must be sorted with an
-- anti-stable sorting
rqsort lt rlt (x : rqsort lt rge r)
qpart lt x (y:ys) rlt rge r =
if lt y x then
-- y < x
qpart lt x ys (y:rlt) rge r
else
-- y >= x
qpart lt x ys rlt (y:rge) r
-- rqsort is as qsort but anti-stable, i.e. reverses equal elements
rqsort lt [] r = r
rqsort lt [x] r = x:r
rqsort lt (x:xs) r = rqpart lt x xs [] [] r
rqpart lt x [] rle rgt r =
qsort lt rle (x : qsort lt rgt r)
rqpart lt x (y:ys) rle rgt r =
if lt x y then
-- y > x
rqpart lt x ys rle (y:rgt) r
else
-- y <= x
rqpart lt x ys (y:rle) rgt r
\end{code}
%************************************************************************
%* *
\subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
%* *
%************************************************************************
\begin{code}
#if NOT_USED
mergesort :: (a -> a -> Ordering) -> [a] -> [a]
mergesort cmp xs = merge_lists (split_into_runs [] xs)
where
a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
split_into_runs [] [] = []
split_into_runs run [] = [run]
split_into_runs [] (x:xs) = split_into_runs [x] xs
split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
| True = rl : (split_into_runs [x] xs)
merge_lists [] = []
merge_lists (x:xs) = merge x (merge_lists xs)
merge [] ys = ys
merge xs [] = xs
merge xl@(x:xs) yl@(y:ys)
= case cmp x y of
EQ -> x : y : (merge xs ys)
LT -> x : (merge xs yl)
GT -> y : (merge xl ys)
#endif
\end{code}
%************************************************************************
%* *
\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
......@@ -554,7 +434,8 @@ naturalMergeSort = generalNaturalMergeSort (<=)
mergeSortLe le = generalMergeSort le
#endif
naturalMergeSortLe le = generalNaturalMergeSort le
sortLe :: (a->a->Bool) -> [a] -> [a]
sortLe le = generalNaturalMergeSort le
\end{code}
%************************************************************************
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment