conDbgc.l (1935B)
1 # 15nov10abu 2 # (c) Software Lab. Alexander Burger 3 4 ### Concurrent DB Garbage Collector ### 5 # *DbgcDly *DbgcPid 6 7 (default *DbgcDly 64) 8 9 (if (fork) 10 (setq *DbgcPid @) 11 12 (wait 60000) 13 (undef 'upd) 14 (de upd Lst 15 (wipe Lst) 16 (let *DbgcDly (>> 1 *DbgcDly) 17 (for S Lst 18 (when (ext? S) 19 (mark S T) 20 (markData (val S)) 21 (maps markData S) ) 22 (wipe S) ) ) ) 23 24 (de markExt (S) 25 (unless (mark S T) 26 (wait *DbgcDly) 27 (markData (val S)) 28 (maps markData S) 29 (wipe S) ) ) 30 31 (de markData (X) 32 (while (pair X) 33 (markData (pop 'X)) ) 34 (and (ext? X) (markExt X)) ) 35 36 (loop 37 (let MS (+ (/ (usec) 1000) 86400000) 38 (markExt *DB) 39 (while (> MS (/ (usec) 1000)) 40 (wait 60000) ) ) 41 (let Cnt 0 42 (for (F . @) (or *Dbs (2)) 43 (for (S (seq F) S (seq S)) 44 (wait *DbgcDly) 45 (unless (mark S) 46 (sync) 47 (if (mark S) 48 (tell) 49 (and (isa '+Entity S) (zap> S)) 50 (zap S) 51 (commit) 52 (inc 'Cnt) ) ) ) ) 53 (when *Blob 54 (use (@S @R F S) 55 (let Pat (conc (chop *Blob) '(@S "." @R)) 56 (in (list 'find *Blob "-type" "f") 57 (while (setq F (line)) 58 (wait *DbgcDly) 59 (when (match Pat F) 60 (unless 61 (and 62 (setq S (extern (pack (replace @S '/)))) 63 (get S (intern (pack @R))) ) 64 (inc 'Cnt) 65 (call 'rm (pack F)) ) 66 (wipe S) ) ) ) ) ) ) 67 (msg Cnt " conDbgc") ) 68 (mark 0) ) ) 69 70 # vi:et:ts=3:sw=3