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
-- (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}
import CmmUtils ( CmmStmts, mkLblExpr )
import CLabel ( mkUpdInfoLabel )
import Constants
-import Util ( sortLt )
+import Util ( sortLe )
import FastString ( LitString )
import OrdList ( toOL )
import Outputable
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 }) }
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
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)]
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)]
-- 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)
)
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(..) )
; 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,
; 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
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
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}
import Bag ( Bag, bagToList, isEmptyBag, emptyBag )
import SrcLoc ( SrcSpan )
-import Util ( sortLt )
+import Util ( sortLe )
import Outputable
import qualified Pretty
import SrcLoc ( srcSpanStart )
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
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}
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),
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}
-- 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
import Id ( Id )
import VarSet
import VarEnv
-import Util ( sortLt )
+import Util ( sortLe )
import Maybes ( orElse )
import Maybes ( expectJust )
import Bitmap ( intsToBitmap )
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
import Outputable
import FastString
import Maybe ( isJust, isNothing, fromMaybe )
-import Util ( sortLt )
+import Util ( sortLe )
import Bag
import List ( isPrefixOf )
\end{code}
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
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
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
= 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
#endif
import FastString ( mkFastString )
-import Util ( sortLt )
+import Util ( sortLe )
import Bag ( unionBags, snocBag )
import Maybe ( isJust )
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
------------------------------------------------------------------------------
-import Util ( sortLt )
+import Util ( sortLe )
-- Extensions
import MONAD_ST
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 [])
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
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}
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
nTimes,
-- sorting
- sortLt, naturalMergeSortLe,
+ sortLe,
-- transitive closures
transitiveClosure,
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
mergeSortLe le = generalMergeSort le
#endif
-naturalMergeSortLe le = generalNaturalMergeSort le
+sortLe :: (a->a->Bool) -> [a] -> [a]
+sortLe le = generalNaturalMergeSort le
\end{code}
%************************************************************************
projects / ghc-hetmet.git / commitdiff