From: simonpj <unknown>
Date: Tue, 17 Aug 2004 15:24:13 +0000 (+0000)
Subject: [project @ 2004-08-17 15:23:47 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~1722
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=59c796f8e77325d35f29ddd3e724bfa780466d40

[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.
---

diff --git a/ghc/compiler/codeGen/CgCallConv.hs b/ghc/compiler/codeGen/CgCallConv.hs
index fa98f96..7be8b84 100644
--- a/ghc/compiler/codeGen/CgCallConv.hs
+++ b/ghc/compiler/codeGen/CgCallConv.hs
@@ -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 ]
 
diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs
index 206dcc2..2dddb3d 100644
--- a/ghc/compiler/codeGen/CgStackery.lhs
+++ b/ghc/compiler/codeGen/CgStackery.lhs
@@ -1,7 +1,7 @@
 %
 % (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 }) }
 
diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs
index e74bd14..9d789be 100644
--- a/ghc/compiler/codeGen/CgUtils.hs
+++ b/ghc/compiler/codeGen/CgUtils.hs
@@ -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)]
diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index f7256f3..485a285 100644
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -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)
diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs
index 135bb1b..c7a71b7 100644
--- a/ghc/compiler/iface/MkIface.lhs
+++ b/ghc/compiler/iface/MkIface.lhs
@@ -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}
diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index 3a53644..bf9a663 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -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
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 1c18fef..9e15a4b 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -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), 
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index e4d9fc6..2d95727 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -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
diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs
index 34e61ce..cd118d7 100644
--- a/ghc/compiler/simplStg/SRT.lhs
+++ b/ghc/compiler/simplStg/SRT.lhs
@@ -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
diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index ebfa2df..4f53859 100644
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -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
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index b8a5f1d..82a6d26 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -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
diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index 52ac93b..7371d1c 100644
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -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
diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs
index cd0e17d..0eff6da 100644
--- a/ghc/compiler/utils/Digraph.lhs
+++ b/ghc/compiler/utils/Digraph.lhs
@@ -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
diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs
index 8d4912d..b93a045 100644
--- a/ghc/compiler/utils/ListSetOps.lhs
+++ b/ghc/compiler/utils/ListSetOps.lhs
@@ -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
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index ed7ee9a..34a5b53 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -21,7 +21,7 @@ module Util (
 	nTimes,
 
 	-- sorting
-	sortLt, naturalMergeSortLe,
+	sortLe,
 
 	-- transitive closures
 	transitiveClosure,
@@ -332,126 +332,6 @@ isn'tIn msg x ys
 
 %************************************************************************
 %*									*
-\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}
 
 %************************************************************************