1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
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
191
192
193
194
195
196
197
|
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Caching.ExpiringCacheMap.Internal
-- Copyright: (c) 2014 Edward L. Blake
-- License: BSD-style
-- Maintainer: Edward L. Blake <edwardlblake@gmail.com>
-- Stability: experimental
-- Portability: portable
--
-- A module with internal functions used in common by HashECM and OrdECM.
-- Assume these functions to change from version to version.
--
module Caching.ExpiringCacheMap.Internal.Internal (
updateUses,
detECM,
getStatsString,
detNotExpired
) where
import qualified Data.List as L
import Caching.ExpiringCacheMap.Types
import Caching.ExpiringCacheMap.Internal.Types
updateUses :: (Eq k) => ([(k, ECMIncr)], ECMULength) -> k
-> ECMIncr -> ECMULength -> ([(k, ECMIncr)] -> [(k, ECMIncr)])
-> ([(k, ECMIncr)], ECMULength)
{-# INLINE updateUses #-}
updateUses (usesl, lcount) id incr' compactlistsize compactUses
| lcount >= 5 =
case usesl of
(id', _) : rest | id' == id ->
((id', incr') : rest, lcount)
latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : (id4, oincr4) : rest ->
case True of
_ | id1 == id -> ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : (id4, oincr4) : rest, lcount)
_ | id2 == id -> ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : (id4, oincr4) : rest, lcount)
_ | id3 == id -> ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id4, oincr4) : rest, lcount)
_ | id4 == id -> ((id4, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : rest, lcount)
_ -> justPrepend
{-
if id1 == id
then ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : (id4, oincr4) : rest, lcount)
else if id2 == id
then ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : (id4, oincr4) : rest, lcount)
else if id3 == id
then ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id4, oincr4) : rest, lcount)
else if id4 == id
then ((id4, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : rest, lcount)
else justPrepend
-}
_ -> justPrepend
| otherwise =
case usesl of
(id', _) : rest | id' == id ->
((id', incr') : rest, lcount)
latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : rest ->
case True of
_ | id1 == id -> ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : rest, lcount)
_ | id2 == id -> ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : rest, lcount)
_ | id3 == id -> ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : rest, lcount)
_ -> justPrepend
{-
if id1 == id
then ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : rest, lcount)
else if id2 == id
then ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : rest, lcount)
else if id3 == id
then ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : rest, lcount)
else justPrepend
-}
latest : (id1, oincr1) : (id2, oincr2) : rest ->
case True of
_ | id1 == id -> ((id1, incr') : latest : (id2, oincr2) : rest, lcount)
_ | id2 == id -> ((id2, incr') : latest : (id1, oincr1) : rest, lcount)
_ -> justPrepend
{-
if id1 == id
then ((id1, incr') : latest : (id2, oincr2) : rest, lcount)
else if id2 == id
then ((id2, incr') : latest : (id1, oincr1) : rest, lcount)
else justPrepend
-}
latest : (id', _) : rest ->
if id' == id
then ((id', incr') : latest : rest, lcount)
else justPrepend
_ -> justPrepend
where
justPrepend =
if lcount > compactlistsize
then let newusesl = compactUses usesl
in ((id, incr') : newusesl, (+1) $! (L.length newusesl) )
else ((id, incr') : usesl, lcount + 1)
detECM
:: (Monad m, Eq k) =>
Maybe (TimeUnits, TimeUnits, v)
-> Maybe s
-> m (TimeUnits, (Maybe s, v))
-> ( ((TimeUnits, TimeUnits, v) -> mp k (TimeUnits, TimeUnits, v)),
((TimeUnits, TimeUnits, v) -> [(k, ECMIncr)] -> mp k (TimeUnits, TimeUnits, v)),
([(k, ECMIncr)] -> [(k, ECMIncr)]),
ECMMapSize,
ECMULength)
-> m TimeUnits
-> (((TimeUnits, TimeUnits, v) -> Bool)
-> mp k (TimeUnits, TimeUnits, v) -> mp k (TimeUnits, TimeUnits, v))
-> ECMMapSize
-> (mp k (TimeUnits, TimeUnits, v) -> ECMMapSize)
-> ([(k, ECMIncr)], ECMULength)
-> ECMIncr
-> ECMIncr
-> mp k (TimeUnits, TimeUnits, v)
-> m ((CacheState s mp k v, v), Bool)
{-# INLINE detECM #-}
detECM result retr_state retr_id etc gettime filt cmapsize newsize uses' incr' timecheckmodulo maps =
case result of
Nothing -> do
(expirytime, (retr_state', r)) <- retr_id
time <- gettime
let (newmaps,mapsize',newuses) = insertAndPerhapsRemoveSome etc cmapsize newsize filt time r expirytime uses'
return $! ((CacheState (retr_state', newmaps, mapsize', newuses, incr'), r), False)
Just (_accesstime, _expirytime, m) -> do
if incr' `mod` timecheckmodulo == 0
then do
time <- gettime
return $! let maps' = filterExpired time maps
in ((CacheState (retr_state, maps', (+0) $! newsize maps', uses', incr'), m), True)
else return ((CacheState (retr_state, maps, cmapsize, uses', incr'), m), False)
where
filterExpired = filterExpired' filt
{-# INLINE insertAndPerhapsRemoveSome #-}
insertAndPerhapsRemoveSome (insert_id1, insert_id2, mnub, minimumkeep, removalsize) cmapsize newsize filt time r expirytime uses =
if cmapsize >= removalsize
then
let (keepuses, _removekeys) = getKeepAndRemove usesl
newmaps = insert_id2 (time, expirytime, r) keepuses
newmaps' = filterExpired time newmaps
in (newmaps', (+0) $! newsize newmaps', (keepuses, (+0) $! (L.length keepuses)))
else
let newmaps = insert_id1 (time, expirytime, r)
in (newmaps, cmapsize + 1, uses) -- filterExpired time
where
(usesl, _lcount) = uses
getKeepAndRemove =
finalTup . splitAt minimumkeep . reverse .
sortI . map swap2 . mnub
where swap2 (a,b) = (b,a)
finalTup (l1,l2) =
(map (\(c,k) -> (k,c)) l1, map (\(c,k) -> k) l2)
sortI = L.sortBy (\(l,_) (r,_) -> compare l r)
filterExpired = filterExpired' filt
{-# INLINE filterExpired' #-}
filterExpired' filt time =
filt (\(accesstime, expirytime, _value) ->
(accesstime <= time) &&
(accesstime > (time - expirytime)))
detNotExpired
:: TimeUnits -> [(k, (TimeUnits, TimeUnits, v))] -> [k]
{-# INLINE detNotExpired #-}
detNotExpired _time l = detNotExpired' _time l []
{-# INLINE detNotExpired' #-}
detNotExpired' _time [] l = reverse l
detNotExpired' time ((key, (accesstime, expirytime, _value)) : r) l
| (accesstime <= time) && (accesstime > (time - expirytime)) =
detNotExpired' time r (key:l)
| otherwise =
detNotExpired' time r l
-- | Debugging function
--
getStatsString ecm = do
CacheState (_retr_state, _maps, _mapsize, uses, _incr) <- ro m'uses
return $ show uses
where
ECM ( m'uses, _retr, _gettime, _minimumkeep, _timecheckmodulo, _removalsize,
_compactlistsize, _enter, ro ) = ecm
|
