Patch title: Release 85 bulk changes
Abstract:
File: /pliant/language/data/cache.pli
Key:
    Removed line
    Added line
module "/pliant/install/ring2.pli"
module "/pliant/language/context/memory.pli"

constant debug true

public
  constant cache_class_timeout 0
  constant cache_class_cheap 1
  constant cache_class_standard 2
  constant cache_class_costy 3
  constant cache_class_should_keep 4 # if droped, will corrupt one client connection, not all of them
  constant cache_class_must_keep 5 # never drop: would not crash the server, but seriously corrupt service

constant flag_class_bits (cast 15 Int)
constant class_count 6

constant flag_init 100h
constant flag_drop 200h
constant flag_dropped 400h


type CachePrototype
  field ListNode_ list_node
  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
  field Int flags

method p drop
  oarg_rw CachePrototype p
  generic


gvar Dictionary cache
gvar (Array List_ class_count) lru
gvar Sem sem

method cp class -> c
  arg CachePrototype cp ; arg Int c
  c := cp:flags .and. flag_class_bits

method cp list -> l
  arg CachePrototype cp ; arg_RW List_ l
  l :> lru cp:class


function cache_shrink mem class -> status
  arg Int mem class ; arg Status status
  part shrink
    if memory_current_used<mem
      return success
    sem request
    var Int c := 0
    part scan
      var Link:CachePrototype obj :> (addressof lru:c:first) map CachePrototype
      while exists:obj and ((addressof:obj translate Int -2) map Int)<>2
        obj :> (addressof obj:list_node:next) map CachePrototype
      if not exists:obj and c<class
        c += 1
        restart scan
    if exists:obj
      obj:list remove obj:list_node
      obj flags += flag_drop
    sem release
    if exists:obj
      check (obj:flags .and. flag_init)=0 # there is no link, so it cannot be at init state
      obj drop
      sem request
      cache remove obj:id addressof:obj
      obj flags := flag_dropped
      sem release
      obj :> null map CachePrototype
      restart shrink
  status := failure

function cache_shrink -> status
  arg Status status
  status := cache_shrink memory_assigned cache_class_costy
  if status=failure and memory_overflow=defined and memory_current_used>memory_assigned\2+memory_overflow\2
    status := cache_shrink memory_assigned cache_class_should_keep


function cache_cleanup
  check cache_class_timeout=0
  sem request
  for (var Int c) cache_class_timeout+1 class_count-1
    var Link:CachePrototype obj :> (addressof lru:c:first) map CachePrototype
    while exists:obj
      var Pointer:CachePrototype next :> (addressof obj:list_node:next) map CachePrototype
      if ((addressof:obj translate Int -2) map Int)=2
        obj:list remove obj:list_node
        obj flags := (obj:flags .and. .not. flag_class_bits) .or. cache_class_timeout
        obj:list append obj:list_node
      obj :> next
  sem release


function cache_open id type obj -> newone
  arg Str id ; arg Type type ; arg_w Link:CachePrototype obj ; arg CBool newone
  part fetch
    cache_shrink
    sem request
    obj :> (cache first id) map CachePrototype
    if exists:obj
      if (obj:flags .and. flag_drop)=0
        var Pointer:List_ l :> obj list
        l remove obj:list_node
        l append obj:list_node
      newone := false
    else
      obj :> (entry_new type) map CachePrototype
      obj id := id
      obj flags := flag_init+cache_class_standard
      cache insert id true addressof:obj
      obj:list append obj:list_node
      newone := true
    sem release
    if not newone
      while (obj:flags .and. flag_init+flag_drop)<>0
        os_yield
      if (obj:flags .and. flag_dropped)<>0
        restart fetch

function cache_ready obj
  arg_rw Link:CachePrototype obj
  sem request
  obj flags -= flag_init
  sem release

function cache_cancel obj
  arg_rw Link:CachePrototype obj
  sem request
  cache remove obj:id addressof:obj
  obj:list remove obj:list_node
  obj flags := flag_dropped
  sem release
  

function cache_setup obj class
  arg_rw Link:CachePrototype obj ; arg Int class
  sem request
  if (obj:flags .and. flag_drop)=0
    obj:list remove obj:list_node
    obj flags := (obj:flags .and. .not. flag_class_bits) .or. class
    obj:list append obj:list_node
  sem release
  

function cache_search id obj -> found
  arg Str id ; arg_w Link:CachePrototype obj ; arg CBool found
  part fetch
    sem rd_request
    obj :> (cache first id) map CachePrototype
    sem rd_release
    found := exists obj
    if found
      while (obj:flags .and. flag_init+flag_drop)<>0
        os_yield
      if (obj:flags .and. flag_dropped)<>0
        restart fetch


function cache_delete id
  arg Str id
  sem request
  var Link:CachePrototype obj :> (cache first id) map CachePrototype
  if exists:obj and (obj:flags .and. flag_drop)<>0
    cache remove id addressof:obj
    obj:list remove obj:list_node
    obj flags := flag_dropped
  sem release
  if exists:obj
    while (obj:flags .and. flag_init+flag_drop)<>0
      os_yield
  

export CachePrototype '. drop' 
export cache_shrink
export cache_open cache_setup cache_ready cache_cancel
export cache_search
export cache_delete


function clear_the_cache parameter
  arg Address parameter
  cache_shrink 0 cache_class_should_keep

gvar DelayedAction da
da function :> the_function clear_the_cache Address
pliant_shutdown_actions append addressof:da
  

doc
  [Usage sequence is:]
  listing
    if (cache_open "/myorg/myapp/category/object_id" my_app_type 0 (var Link:CachePrototype obj))
      # object setup code
      cache_ready obj