/pliant/language/data/cache.pli
 
 1  module "/pliant/install/ring2.pli" 
 2  module "/pliant/language/context/memory.pli" 
 3  module "/pliant/language/stream/stream.pli" 
 4   
 5  constant debug true 
 6   
 7  public 
 8    constant cache_class_timeout 0 
 9    constant cache_class_cheap 1 
 10    constant cache_class_standard 2 
 11    constant cache_class_costy 3 
 12    constant cache_class_should_keep 4 # if droped, will corrupt one client connection, not all of them 
 13    constant cache_class_must_keep 5 # never drop: would not crash the server, but seriously corrupt service 
 14   
 15  constant flag_class_bits (cast 15 Int) 
 16  constant class_count 6 
 17   
 18  constant flag_init 100h 
 19  constant flag_update 200h 
 20  constant flag_drop 400h 
 21  constant flag_dropped 800h 
 22   
 23   
 24  type CachePrototype 
 25    field ListNode_ list_node 
 26    field Str id # we should use a new data type so that we don't need two copies of the name, one here, and one in the dictionary 
 27    field Int flags 
 28   
 29  method p update stream -> status 
 30    oarg_rw CachePrototype p ; arg_rw Stream stream ; arg ExtendedStatus status 
 31    generic 
 32    status := failure "not implemented" 
 33   
 34  method p dump stream -> status 
 35    oarg_rw CachePrototype p ; arg_rw Stream stream ; arg ExtendedStatus status 
 36    generic 
 37    status := failure "not implemented" 
 38   
 39  method p sleep 
 40    oarg_rw CachePrototype p 
 41    generic 
 42   
 43  method p drop 
 44    oarg_rw CachePrototype p 
 45    generic 
 46   
 47  # update accordingly: 
 48  # /pliant/graphic/color/gamut.pli 
 49  # /pliant/storage/database/prototype.pli 
 50   
 51   
 52  gvar Dictionary cache 
 53  gvar (Array List_ class_count) lru 
 54  gvar Sem sem 
 55   
 56  method cp class -> c 
 57    arg CachePrototype cp ; arg Int c 
 58    := cp:flags .and. flag_class_bits 
 59   
 60  method cp list -> l 
 61    arg CachePrototype cp ; arg_RW List_ l 
 62    :> lru cp:class 
 63   
 64   
 65  method cp update_begin 
 66    arg_rw CachePrototype cp 
 67    cp flags := cp:flags .or. flag_update 
 68   
 69  method cp update_end 
 70    arg_rw CachePrototype cp 
 71    cp flags := cp:flags .and. .not. (cast flag_update Int) 
 72   
 73  method cp is_update -> c 
 74    arg CachePrototype cp ; arg CBool c 
 75    := (cp:flags .and. flag_update)<>0 
 76   
 77   
 78  function cache_shrink mem class -> status 
 79    arg Int mem class ; arg Status status 
 80    part shrink 
 81      if memory_current_used<mem 
 82        return success 
 83      sem request 
 84      var Int := 0 
 85      part scan 
 86        var Link:CachePrototype obj :> (addressof lru:c:first) map CachePrototype 
 87        while exists:obj and (addressof:obj map Int -2)<>2 
 88          obj :> (addressof obj:list_node:next) map CachePrototype 
 89        if not exists:obj and c<class 
 90          += 1 
 91          restart scan 
 92      if exists:obj 
 93        obj:list remove obj:list_node 
 94        obj flags += flag_drop 
 95      sem release 
 96      if exists:obj 
 97        check (obj:flags .and. flag_init)=# there is no link, so it cannot be at init state 
 98        obj drop 
 99        sem request 
 100        cache remove obj:id addressof:obj 
 101        obj flags := flag_dropped 
 102        sem release 
 103        obj :> null map CachePrototype 
 104        restart shrink 
 105    status := failure 
 106   
 107  function cache_shrink -> status 
 108    arg Status status 
 109    status := cache_shrink memory_assigned cache_class_costy 
 110    if status=failure and memory_overflow=defined and memory_current_used>memory_assigned\2+memory_overflow\2 
 111      status := cache_shrink memory_assigned cache_class_should_keep 
 112   
 113   
 114  function broadcast_prototype object param fun 
 115    oarg_rw CachePrototype object ; arg_rw Universal param ; arg Function fun 
 116    indirect 
 117   
 118  function cache_broadcast fun param 
 119    arg Function fun ; arg_rw Universal param 
 120    sem request 
 121    for (var Int i) lru:size-1 
 122      var Link:CachePrototype obj :> (addressof lru:i:first) map CachePrototype 
 123      while exists:obj 
 124        broadcast_prototype obj param fun 
 125        obj :> (addressof obj:list_node:next) map CachePrototype 
 126    sem release 
 127   
 128   
 129  function cache_open id type obj -> newone 
 130    arg Str id ; arg Type type ; arg_w Link:CachePrototype obj ; arg CBool newone 
 131    part fetch 
 132      cache_shrink 
 133      sem request 
 134      obj :> (cache first id) map CachePrototype 
 135      if exists:obj 
 136        if (obj:flags .and. flag_drop)=0 
 137          var Pointer:List_ :> obj list 
 138          remove obj:list_node 
 139          append obj:list_node 
 140        newone := false 
 141      else 
 142        obj :> (entry_new type) map CachePrototype 
 143        obj id := id 
 144        obj flags := flag_init+cache_class_standard 
 145        cache insert id true addressof:obj 
 146        obj:list append obj:list_node 
 147        newone := true 
 148      sem release 
 149      if not newone 
 150        while (obj:flags .and. flag_init+flag_drop)<>0 
 151          os_yield 
 152        if (obj:flags .and. flag_dropped)<>0 
 153          restart fetch 
 154   
 155  function cache_ready obj 
 156    arg_rw Link:CachePrototype obj 
 157    sem request 
 158    obj flags -= flag_init 
 159    sem release 
 160   
 161  function cache_cancel obj 
 162    arg_rw Link:CachePrototype obj 
 163    sem request 
 164    cache remove obj:id addressof:obj 
 165    obj:list remove obj:list_node 
 166    obj flags := flag_dropped 
 167    sem release 
 168     
 169   
 170  function cache_setup obj class 
 171    arg_rw Link:CachePrototype obj ; arg Int class 
 172    sem request 
 173    if (obj:flags .and. flag_drop)=0 
 174      obj:list remove obj:list_node 
 175      obj flags := (obj:flags .and. .not. flag_class_bits) .or. class 
 176      obj:list append obj:list_node 
 177    sem release 
 178     
 179   
 180  function cache_search id obj -> found 
 181    arg Str id ; arg_w Link:CachePrototype obj ; arg CBool found 
 182    part fetch 
 183      sem rd_request 
 184      obj :> (cache first id) map CachePrototype 
 185      sem rd_release 
 186      found := exists obj 
 187      if found 
 188        while (obj:flags .and. flag_init+flag_drop)<>0 
 189          os_yield 
 190        if (obj:flags .and. flag_dropped)<>0 
 191          restart fetch 
 192   
 193   
 194  function cache_delete id 
 195    arg Str id 
 196    sem request 
 197    var Link:CachePrototype obj :> (cache first id) map CachePrototype 
 198    if exists:obj and (obj:flags .and. flag_drop)=0 
 199      cache remove id addressof:obj 
 200      obj:list remove obj:list_node 
 201      obj flags := flag_dropped 
 202    sem release 
 203    if exists:obj 
 204      while (obj:flags .and. flag_init+flag_drop)<>0 
 205        os_yield 
 206     
 207   
 208  export CachePrototype '. id' '. update' '. dump' '. sleep' '. drop' 
 209  export '. update_begin' '. update_end' '. is_update' 
 210  export cache_shrink 
 211  export cache_broadcast 
 212  export cache_open cache_setup cache_ready cache_cancel 
 213  export cache_search 
 214  export cache_delete 
 215   
 216   
 217  function clear_the_cache parameter 
 218    arg Address parameter 
 219    cache_shrink 0 cache_class_should_keep 
 220   
 221  gvar DelayedAction da 
 222  da function :> the_function clear_the_cache Address 
 223  pliant_shutdown_actions append addressof:da 
 224     
 225   
 226  doc 
 227    [Usage sequence is:] 
 228    listing 
 229      if (cache_open "/myorg/myapp/category/object_id" my_app_type 0 (var Link:CachePrototype obj)) 
 230        # object setup code 
 231        cache_ready obj