UniqFM.lhs 21.8 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1994-1998
3
4
5
6
7
%
\section[UniqFM]{Specialised finite maps, for things with @Uniques@}

Based on @FiniteMaps@ (as you would expect).

8
Basically, the things need to be in class @Uniquable@, and we use the
9
@getUnique@ method to grab their @Uniques@.
10
11
12
13
14
15
16
17

(A similar thing to @UniqSet@, as opposed to @Set@.)

\begin{code}
module UniqFM (
	UniqFM,   -- abstract type

	emptyUFM,
18
19
	unitUFM,
	unitDirectlyUFM,
20
21
	listToUFM,
	listToUFM_Directly,
22
23
	addToUFM,addToUFM_C,
	addListToUFM,addListToUFM_C,
24
	addToUFM_Directly,
25
	addListToUFM_Directly,
26
	delFromUFM,
27
	delFromUFM_Directly,
28
29
30
31
32
	delListFromUFM,
	plusUFM,
	plusUFM_C,
	minusUFM,
	intersectUFM,
sof's avatar
sof committed
33
34
	intersectUFM_C,
	foldUFM,
35
	mapUFM,
36
	elemUFM,
37
38
	filterUFM,
	sizeUFM,
39
	hashUFM,
40
	isNullUFM,
41
42
	lookupUFM, lookupUFM_Directly,
	lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
sof's avatar
sof committed
43
	eltsUFM, keysUFM,
44
	ufmToList 
45
46
    ) where

47
#include "HsVersions.h"
sof's avatar
sof committed
48

49
import {-# SOURCE #-} Name	( Name )
50

51
import Unique		( Uniquable(..), Unique, u2i, mkUniqueGrimily )
52
import Panic
53
import GlaExts		-- Lots of Int# operations
54
import FastTypes
55
import Outputable
56
57
58
59
60
61
62
63
\end{code}

%************************************************************************
%*									*
\subsection{The @UniqFM@ type, and signatures for the functions}
%*									*
%************************************************************************

64
We use @FiniteMaps@, with a (@getUnique@-able) @Unique@ as ``key''.
65
66
67
68

\begin{code}
emptyUFM	:: UniqFM elt
isNullUFM	:: UniqFM elt -> Bool
69
unitUFM		:: Uniquable key => key -> elt -> UniqFM elt
70
unitDirectlyUFM -- got the Unique already
71
		:: Unique -> elt -> UniqFM elt
72
listToUFM	:: Uniquable key => [(key,elt)] -> UniqFM elt
73
74
75
listToUFM_Directly
		:: [(Unique, elt)] -> UniqFM elt

76
77
addToUFM	:: Uniquable key => UniqFM elt -> key -> elt  -> UniqFM elt
addListToUFM	:: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
78
79
80
addToUFM_Directly
		:: UniqFM elt -> Unique -> elt -> UniqFM elt

81
82
83
84
85
addToUFM_C	:: Uniquable key => (elt -> elt -> elt)	-- old -> new -> result
			   -> UniqFM elt 		-- old
			   -> key -> elt 		-- new
			   -> UniqFM elt		-- result

86
addListToUFM_C	:: Uniquable key => (elt -> elt -> elt)
87
88
89
			   -> UniqFM elt -> [(key,elt)]
			   -> UniqFM elt

90
91
delFromUFM	:: Uniquable key => UniqFM elt -> key	 -> UniqFM elt
delListFromUFM	:: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
92
delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108

plusUFM		:: UniqFM elt -> UniqFM elt -> UniqFM elt

plusUFM_C	:: (elt -> elt -> elt)
		-> UniqFM elt -> UniqFM elt -> UniqFM elt

minusUFM	:: UniqFM elt -> UniqFM elt -> UniqFM elt

intersectUFM	:: UniqFM elt -> UniqFM elt -> UniqFM elt
intersectUFM_C	:: (elt -> elt -> elt)
		-> UniqFM elt -> UniqFM elt -> UniqFM elt
foldUFM		:: (elt -> a -> a) -> a -> UniqFM elt -> a
mapUFM		:: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
filterUFM	:: (elt -> Bool) -> UniqFM elt -> UniqFM elt

sizeUFM		:: UniqFM elt -> Int
109
hashUFM		:: UniqFM elt -> Int
110
elemUFM		:: Uniquable key => key -> UniqFM elt -> Bool
111

112
lookupUFM	:: Uniquable key => UniqFM elt -> key -> Maybe elt
113
lookupUFM_Directly  -- when you've got the Unique already
114
115
		:: UniqFM elt -> Unique -> Maybe elt
lookupWithDefaultUFM
116
		:: Uniquable key => UniqFM elt -> elt -> key -> elt
117
118
lookupWithDefaultUFM_Directly
		:: UniqFM elt -> elt -> Unique -> elt
119

120
keysUFM		:: UniqFM elt -> [Unique]	-- Get the keys
121
122
123
124
125
126
127
128
129
130
131
eltsUFM		:: UniqFM elt -> [elt]
ufmToList	:: UniqFM elt -> [(Unique, elt)]
\end{code}

%************************************************************************
%*									*
\subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
%*									*
%************************************************************************

\begin{code}
132
133
-- Turn off for now, these need to be updated (SDM 4/98)

134
135
#if 0
#ifdef __GLASGOW_HASKELL__
136
137
138
-- I don't think HBC was too happy about this (WDP 94/10)

{-# SPECIALIZE
139
    addListToUFM :: UniqFM elt -> [(Name,   elt)] -> UniqFM elt
140
141
  #-}
{-# SPECIALIZE
142
    addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name,  elt)] -> UniqFM elt
143
144
  #-}
{-# SPECIALIZE
145
    addToUFM	:: UniqFM elt -> Unique -> elt  -> UniqFM elt
146
147
  #-}
{-# SPECIALIZE
148
    listToUFM	:: [(Unique, elt)]     -> UniqFM elt
149
150
  #-}
{-# SPECIALIZE
151
152
    lookupUFM	:: UniqFM elt -> Name   -> Maybe elt
		 , UniqFM elt -> Unique -> Maybe elt
153
154
  #-}

155
156
#endif {- __GLASGOW_HASKELL__ -}
#endif
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
\end{code}

%************************************************************************
%*									*
\subsection{Andy Gill's underlying @UniqFM@ machinery}
%*									*
%************************************************************************

``Uniq Finite maps'' are the heart and soul of the compiler's
lookup-tables/environments.  Important stuff!  It works well with
Dense and Sparse ranges.
Both @Uq@ Finite maps and @Hash@ Finite Maps
are built ontop of Int Finite Maps.

This code is explained in the paper:
\begin{display}
	A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
	"A Cheap balancing act that grows on a tree"
	Glasgow FP Workshop, Sep 1994, pp??-??
\end{display}

%************************************************************************
%*									*
\subsubsection{The @UniqFM@ type, and signatures for the functions}
%*									*
%************************************************************************

@UniqFM a@ is a mapping from Unique to a.

First, the DataType itself; which is either a Node, a Leaf, or an Empty.

\begin{code}
data UniqFM ele
  = EmptyUFM
191
192
193
  | LeafUFM FastInt ele
  | NodeUFM FastInt	    -- the switching
	    FastInt	    -- the delta
194
195
196
197
	    (UniqFM ele)
	    (UniqFM ele)

{-
198
199
200
201
202
203
204
205
-- for debugging only :-)
instance Outputable (UniqFM a) where
	ppr(NodeUFM a b t1 t2) =
		sep [text "NodeUFM " <+> int IBOX(a) <+> int IBOX(b),
		     nest 1 (parens (ppr t1)),
		     nest 1 (parens (ppr t2))]
	ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
	ppr (EmptyUFM)    = empty
206
-}
207
208
209
-- and when not debugging the package itself...
instance Outputable a => Outputable (UniqFM a) where
    ppr ufm = ppr (ufmToList ufm)
210
211
212
213
214
215
216
217
218
219
220
221
\end{code}

%************************************************************************
%*									*
\subsubsection{The @UniqFM@ functions}
%*									*
%************************************************************************

First the ways of building a UniqFM.

\begin{code}
emptyUFM		     = EmptyUFM
222
unitUFM	     key elt = mkLeafUFM (u2i (getUnique key)) elt
223
unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

listToUFM key_elt_pairs
  = addListToUFM_C use_snd EmptyUFM key_elt_pairs

listToUFM_Directly uniq_elt_pairs
  = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
\end{code}

Now ways of adding things to UniqFMs.

There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
but the semantics of this operation demands a linear insertion;
perhaps the version without the combinator function
could be optimised using it.

\begin{code}
addToUFM fm key elt = addToUFM_C use_snd fm key elt

addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt

addToUFM_C combiner fm key elt
245
  = insert_ele combiner fm (u2i (getUnique key)) elt
246
247

addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
248
addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
249
250

addListToUFM_C combiner fm key_elt_pairs
251
 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getUnique k)) e)
252
253
254
255
256
257
258
259
260
261
262
263
	 fm key_elt_pairs

addListToUFM_directly_C combiner fm uniq_elt_pairs
 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e)
	 fm uniq_elt_pairs
\end{code}

Now ways of removing things from UniqFM.

\begin{code}
delListFromUFM fm lst = foldl delFromUFM fm lst

264
delFromUFM          fm key = delete fm (u2i (getUnique key))
265
delFromUFM_Directly fm u   = delete fm (u2i u)
266
267
268
269
270
271
272

delete EmptyUFM _   = EmptyUFM
delete fm       key = del_ele fm
  where
    del_ele :: UniqFM a -> UniqFM a

    del_ele lf@(LeafUFM j _)
273
      | j ==# key	= EmptyUFM
274
275
276
      | otherwise	= lf	-- no delete!

    del_ele nd@(NodeUFM j p t1 t2)
277
      | j ># key
278
      = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
279
      | otherwise
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
      = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)

    del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
\end{code}

Now ways of adding two UniqFM's together.

\begin{code}
plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2

plusUFM_C f EmptyUFM tr	= tr
plusUFM_C f tr EmptyUFM	= tr
plusUFM_C f fm1 fm2	= mix_trees fm1 fm2
    where
	mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
	mix_trees t1 (LeafUFM i a) = insert_ele f	 t1 i a

	mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
	  = mix_branches
		(ask_about_common_ancestor
			(NodeUFMData j p)
			(NodeUFMData j' p'))
	  where
		-- Given a disjoint j,j' (p >^ p' && p' >^ p):
		--
		--	  j		j'			(C j j')
		--	 / \	+      / \	==>		/	\
		--     t1   t2	    t1'	  t2'		       j	 j'
		--					      / \	/ \
		--					     t1	 t2   t1'  t2'
		-- Fast, Ehh !
		--
	  mix_branches (NewRoot nd False)
		= mkLLNodeUFM nd left_t right_t
	  mix_branches (NewRoot nd True)
		= mkLLNodeUFM nd right_t left_t

		-- Now, if j == j':
		--
		--	  j		j'			 j
		--	 / \	+      / \	==>		/ \
		--     t1   t2	    t1'	  t2'		t1 + t1'   t2 + t2'
322
		--
323
324
325
326
327
328
329
330
331
332
333
334
335
	  mix_branches (SameRoot)
		= mkSSNodeUFM (NodeUFMData j p)
			(mix_trees t1 t1')
			(mix_trees t2 t2')
		-- Now the 4 different other ways; all like this:
		--
		-- Given j >^ j' (and, say,  j > j')
		--
		--	  j		j'			 j
		--	 / \	+      / \	==>		/ \
		--     t1   t2	    t1'	  t2'		      t1   t2 + j'
		--						       / \
		--						     t1'  t2'
336
	  mix_branches (LeftRoot Leftt) -- | trace "LL" True
337
338
	    = mkSLNodeUFM
		(NodeUFMData j p)
339
		(mix_trees t1 right_t)
340
341
		t2

342
	  mix_branches (LeftRoot Rightt) -- | trace "LR" True
343
344
345
	    = mkLSNodeUFM
		(NodeUFMData j p)
		t1
346
		(mix_trees t2 right_t)
347

348
	  mix_branches (RightRoot Leftt) -- | trace "RL" True
349
350
	    = mkSLNodeUFM
		(NodeUFMData j' p')
351
		(mix_trees left_t t1')
352
353
		t2'

354
	  mix_branches (RightRoot Rightt) -- | trace "RR" True
355
356
357
	    = mkLSNodeUFM
		(NodeUFMData j' p')
		t1'
358
		(mix_trees left_t t2')
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373

	mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
\end{code}

And ways of subtracting them. First the base cases,
then the full D&C approach.

\begin{code}
minusUFM EmptyUFM _  = EmptyUFM
minusUFM t1 EmptyUFM = t1
minusUFM fm1 fm2     = minus_trees fm1 fm2
    where
	--
	-- Notice the asymetry of subtraction
	--
374
375
	minus_trees lf@(LeafUFM i a) t2 =
		case lookUp t2 i of
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
		  Nothing -> lf
		  Just b -> EmptyUFM

	minus_trees t1 (LeafUFM i _) = delete t1 i

	minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
	  = minus_branches
		(ask_about_common_ancestor
			(NodeUFMData j p)
			(NodeUFMData j' p'))
	  where
		-- Given a disjoint j,j' (p >^ p' && p' >^ p):
		--
		--	  j		j'		   j
		--	 / \	+      / \	==>	  / \
		--     t1   t2	    t1'	  t2'		 t1  t2
392
393
		--
		--
394
395
396
397
398
399
400
401
402
		-- Fast, Ehh !
		--
	  minus_branches (NewRoot nd _) = left_t

		-- Now, if j == j':
		--
		--	  j		j'			 j
		--	 / \	+      / \	==>		/ \
		--     t1   t2	    t1'	  t2'		t1 + t1'   t2 + t2'
403
		--
404
405
406
407
408
409
410
411
412
413
	  minus_branches (SameRoot)
		= mkSSNodeUFM (NodeUFMData j p)
			(minus_trees t1 t1')
			(minus_trees t2 t2')
		-- Now the 4 different other ways; all like this:
		-- again, with asymatry

		--
		-- The left is above the right
		--
414
	  minus_branches (LeftRoot Leftt)
415
416
	    = mkSLNodeUFM
		(NodeUFMData j p)
417
		(minus_trees t1 right_t)
418
		t2
419
	  minus_branches (LeftRoot Rightt)
420
421
422
	    = mkLSNodeUFM
		(NodeUFMData j p)
		t1
423
		(minus_trees t2 right_t)
424
425
426
427

		--
		-- The right is above the left
		--
428
	  minus_branches (RightRoot Leftt)
429
	    = minus_trees left_t t1'
430
	  minus_branches (RightRoot Rightt)
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
	    = minus_trees left_t t2'

	minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
\end{code}

And taking the intersection of two UniqFM's.

\begin{code}
intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2

intersectUFM_C f EmptyUFM _ = EmptyUFM
intersectUFM_C f _ EmptyUFM = EmptyUFM
intersectUFM_C f fm1 fm2    = intersect_trees fm1 fm2
    where
	intersect_trees (LeafUFM i a) t2 =
446
		case lookUp t2 i of
447
448
449
450
		  Nothing -> EmptyUFM
		  Just b -> mkLeafUFM i (f a b)

	intersect_trees t1 (LeafUFM i a) =
451
		case lookUp t1 i of
452
453
454
455
456
457
458
459
460
461
462
		  Nothing -> EmptyUFM
		  Just b -> mkLeafUFM i (f b a)

	intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
	  = intersect_branches
		(ask_about_common_ancestor
			(NodeUFMData j p)
			(NodeUFMData j' p'))
	  where
		-- Given a disjoint j,j' (p >^ p' && p' >^ p):
		--
463
		--	  j		j'
464
		--	 / \	+      / \	==>		EmptyUFM
465
466
		--     t1   t2	    t1'	  t2'
		--
467
468
469
470
471
472
473
474
475
		-- Fast, Ehh !
		--
	  intersect_branches (NewRoot nd _) = EmptyUFM

		-- Now, if j == j':
		--
		--	  j		j'			 j
		--	 / \	+      / \	==>		/ \
		--     t1   t2	    t1'	  t2'		t1 x t1'   t2 x t2'
476
		--
477
478
479
480
481
482
483
484
485
486
487
	  intersect_branches (SameRoot)
		= mkSSNodeUFM (NodeUFMData j p)
			(intersect_trees t1 t1')
			(intersect_trees t2 t2')
		-- Now the 4 different other ways; all like this:
		--
		-- Given j >^ j' (and, say,  j > j')
		--
		--	  j		j'		       t2 + j'
		--	 / \	+      / \	==>		   / \
		--     t1   t2	    t1'	  t2'			 t1'  t2'
488
		--
489
		-- This does cut down the search space quite a bit.
490
491

	  intersect_branches (LeftRoot Leftt)
492
	    = intersect_trees t1 right_t
493
	  intersect_branches (LeftRoot Rightt)
494
	    = intersect_trees t2 right_t
495
	  intersect_branches (RightRoot Leftt)
496
	    = intersect_trees left_t t1'
497
	  intersect_branches (RightRoot Rightt)
498
499
500
501
502
503
504
505
	    = intersect_trees left_t t2'

	intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
\end{code}

Now the usual set of `collection' operators, like map, fold, etc.

\begin{code}
sof's avatar
sof committed
506
507
508
509
foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
foldUFM f a (LeafUFM _ obj)     = f obj a
foldUFM f a EmptyUFM	        = a
\end{code}
510

sof's avatar
sof committed
511
\begin{code}
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
mapUFM fn EmptyUFM    = EmptyUFM
mapUFM fn fm	      = map_tree fn fm

filterUFM fn EmptyUFM = EmptyUFM
filterUFM fn fm	      = filter_tree fn fm
\end{code}

Note, this takes a long time, O(n), but
because we dont want to do this very often, we put up with this.
O'rable, but how often do we look at the size of
a finite map?

\begin{code}
sizeUFM EmptyUFM	    = 0
sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
sizeUFM (LeafUFM _ _)	    = 1

isNullUFM EmptyUFM = True
isNullUFM _	   = False
531
532
533
534

-- hashing is used in VarSet.uniqAway, and should be fast
-- We use a cheap and cheerful method for now
hashUFM EmptyUFM          = 0
535
536
hashUFM (NodeUFM n _ _ _) = iBox n
hashUFM (LeafUFM n _)     = iBox n
537
538
539
540
541
542
\end{code}

looking up in a hurry is the {\em whole point} of this binary tree lark.
Lookup up a binary tree is easy (and fast).

\begin{code}
543
elemUFM key fm = case lookUp fm (u2i (getUnique key)) of
544
545
546
			Nothing -> False
			Just _  -> True

547
lookupUFM	   fm key = lookUp fm (u2i (getUnique key))
548
lookupUFM_Directly fm key = lookUp fm (u2i key)
549
550

lookupWithDefaultUFM fm deflt key
551
  = case lookUp fm (u2i (getUnique key)) of
552
553
554
555
      Nothing  -> deflt
      Just elt -> elt

lookupWithDefaultUFM_Directly fm deflt key
556
  = case lookUp fm (u2i key) of
557
558
559
      Nothing  -> deflt
      Just elt -> elt

560
561
lookUp EmptyUFM _   = Nothing
lookUp fm i	    = lookup_tree fm
562
563
564
565
  where
	lookup_tree :: UniqFM a -> Maybe a

	lookup_tree (LeafUFM j b)
566
	  | j ==# i	= Just b
567
568
	  | otherwise	= Nothing
	lookup_tree (NodeUFM j p t1 t2)
569
	  | j ># i	= lookup_tree t1
570
571
572
573
574
575
576
577
	  | otherwise	= lookup_tree t2

	lookup_tree EmptyUFM = panic "lookup Failed"
\end{code}

folds are *wonderful* things.

\begin{code}
sof's avatar
sof committed
578
eltsUFM fm = foldUFM (:) [] fm
579

sof's avatar
sof committed
580
ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
581

582
keysUFM fm = fold_tree (\ iu elt rest -> mkUniqueGrimily iu : rest) [] fm
sof's avatar
sof committed
583
584
585
586

fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
fold_tree f a (LeafUFM iu obj)    = f iu obj a
fold_tree f a EmptyUFM		  = a
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
\end{code}

%************************************************************************
%*									*
\subsubsection{The @UniqFM@ type, and its functions}
%*									*
%************************************************************************

You should always use these to build the tree.
There are 4 versions of mkNodeUFM, depending on
the strictness of the two sub-tree arguments.
The strictness is used *both* to prune out
empty trees, *and* to improve performance,
stoping needless thunks lying around.
The rule of thumb (from experence with these trees)
is make thunks strict, but data structures lazy.
If in doubt, use mkSSNodeUFM, which has the `strongest'
functionality, but may do a few needless evaluations.

\begin{code}
607
mkLeafUFM :: FastInt -> a -> UniqFM a
608
609
610
611
612
613
614
mkLeafUFM i a	  = LeafUFM i a

-- The *ONLY* ways of building a NodeUFM.

mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
mkSSNodeUFM (NodeUFMData j p) t1 t2
615
  = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
616
617
618
619
    NodeUFM j p t1 t2

mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
mkSLNodeUFM (NodeUFMData j p) t1 t2
620
  = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
621
622
623
624
    NodeUFM j p t1 t2

mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
mkLSNodeUFM (NodeUFMData j p) t1 t2
625
  = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
626
627
628
    NodeUFM j p t1 t2

mkLLNodeUFM (NodeUFMData j p) t1 t2
629
  = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
630
631
632
633
634
635
636
637
638
639
640
641
642
    NodeUFM j p t1 t2

correctNodeUFM
	:: Int
	-> Int
	-> UniqFM a
	-> UniqFM a
	-> Bool

correctNodeUFM j p t1 t2
  = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
  where
    correct low high _ (LeafUFM i _)
643
      = low <= iBox i && iBox i <= high
644
    correct low high above_p (NodeUFM j p _ _)
645
      = low <= iBox j && iBox j <= high && above_p > iBox p
646
647
648
649
650
651
652
653
654
655
    correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
\end{code}

Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
and if necessary do $\lambda$ lifting on our functions that are bound.

\begin{code}
insert_ele
	:: (a -> a -> a)
	-> UniqFM a
656
	-> FastInt
657
658
659
660
661
662
	-> a
	-> UniqFM a

insert_ele f EmptyUFM i new = mkLeafUFM i new

insert_ele f (LeafUFM j old) i new
663
  | j ># i =
664
665
666
667
668
	  mkLLNodeUFM (getCommonNodeUFMData
			  (indexToRoot i)
			  (indexToRoot j))
		 (mkLeafUFM i new)
		 (mkLeafUFM j old)
669
  | j ==# i  = mkLeafUFM j (f old new)
670
671
672
673
674
675
676
677
  | otherwise =
	  mkLLNodeUFM (getCommonNodeUFMData
			  (indexToRoot i)
			  (indexToRoot j))
		 (mkLeafUFM j old)
		 (mkLeafUFM i new)

insert_ele f n@(NodeUFM j p t1 t2) i a
678
679
  | i <# j
    = if (i >=# (j -# p))
680
681
682
683
684
685
686
      then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
      else mkLLNodeUFM (getCommonNodeUFMData
			  (indexToRoot i)
			  ((NodeUFMData j p)))
		  (mkLeafUFM i a)
		  n
  | otherwise
687
    = if (i <=# ((j -# _ILIT(1)) +# p))
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
      then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
      else mkLLNodeUFM (getCommonNodeUFMData
			  (indexToRoot i)
			  ((NodeUFMData j p)))
		  n
		  (mkLeafUFM i a)
\end{code}



\begin{code}
map_tree f (NodeUFM j p t1 t2)
  = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
map_tree f (LeafUFM i obj)
  = mkLeafUFM i (f obj)

map_tree f _ = panic "map_tree failed"
\end{code}

\begin{code}
filter_tree f nd@(NodeUFM j p t1 t2)
  = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)

711
filter_tree f lf@(LeafUFM i obj)
712
713
  | f obj = lf
  | otherwise = EmptyUFM
sof's avatar
sof committed
714
filter_tree f _ = panic "filter_tree failed"
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
\end{code}

%************************************************************************
%*									*
\subsubsection{The @UniqFM@ type, and signatures for the functions}
%*									*
%************************************************************************

Now some Utilities;

This is the information that is held inside a NodeUFM, packaged up for
consumer use.

\begin{code}
data NodeUFMData
730
731
  = NodeUFMData FastInt
		FastInt
732
733
734
735
736
\end{code}

This is the information used when computing new NodeUFMs.

\begin{code}
737
data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
738
739
740
741
742
743
744
745
746
747
748
data CommonRoot
  = LeftRoot  Side	-- which side is the right down ?
  | RightRoot Side	-- which side is the left down ?
  | SameRoot		-- they are the same !
  | NewRoot NodeUFMData	-- here's the new, common, root
	    Bool	-- do you need to swap left and right ?
\end{code}

This specifies the relationship between NodeUFMData and CalcNodeUFMData.

\begin{code}
749
indexToRoot :: FastInt -> NodeUFMData
750
751
752

indexToRoot i
  = let
753
	l = (_ILIT(1) :: FastInt)
754
    in
755
    NodeUFMData (((i `shiftR_` l) `shiftL_` l) +# _ILIT(1)) l
756
757
758
759

getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData

getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
760
761
762
  | p ==# p2	= getCommonNodeUFMData_ p j j2
  | p <# p2	= getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2
  | otherwise	= getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2))
763
  where
764
765
766
    l  = (_ILIT(1) :: FastInt)
    j  = i  `quotFastInt` (p  `shiftL_` l)
    j2 = i2 `quotFastInt` (p2 `shiftL_` l)
767

768
    getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
769
770

    getCommonNodeUFMData_ p j j_
771
772
      | j ==# j_
      = NodeUFMData (((j `shiftL_` l) +# l) *# p) p
773
774
775
776
777
778
      | otherwise
      = getCommonNodeUFMData_ (p `shiftL_`  l) (j `shiftR_` l) (j_ `shiftR_` l)

ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot

ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
779
  | j ==# j2 = SameRoot
780
781
782
  | otherwise
  = case getCommonNodeUFMData x y of
      nd@(NodeUFMData j3 p3)
783
784
785
	| j3 ==# j  -> LeftRoot (decideSide (j ># j2))
	| j3 ==# j2 -> RightRoot (decideSide (j <# j2))
	| otherwise   -> NewRoot nd (j ># j2)
786
787
    where
	decideSide :: Bool -> Side
788
789
	decideSide True	 = Leftt
	decideSide False = Rightt
790
791
792
793
794
795
796
\end{code}

This might be better in Util.lhs ?


Now the bit twiddling functions.
\begin{code}
797
798
shiftL_ :: FastInt -> FastInt -> FastInt
shiftR_ :: FastInt -> FastInt -> FastInt
799
800
801
802

#if __GLASGOW_HASKELL__
{-# INLINE shiftL_ #-}
{-# INLINE shiftR_ #-}
803
804
805
#if __GLASGOW_HASKELL__ >= 503
shiftL_ n p = word2Int#((int2Word# n) `uncheckedShiftL#` p)
#else
806
shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
807
#endif
808
809
shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
  where
810
811
812
#if __GLASGOW_HASKELL__ >= 503
    shiftr x y = uncheckedShiftRL# x y
#else
sof's avatar
sof committed
813
    shiftr x y = shiftRL# x y
814
#endif
815
816
817
818
819
820
821
822
823
824
825
826

#else {- not GHC -}
shiftL_ n p = n * (2 ^ p)
shiftR_ n p = n `quot` (2 ^ p)

#endif {- not GHC -}
\end{code}

\begin{code}
use_snd :: a -> b -> b
use_snd a b = b
\end{code}