|
|
|
module "/pliant/install/ring2.pli" module "/pliant/language/context/memory.pli"
|
|
module "/pliant/install/ring2.pli" module "/pliant/language/context/memory.pli"
|
|
|
|
|
|
module "/pliant/language/stream/stream.pli"
|
|
constant flag_init 100h
|
|
constant flag_init 100h
|
|
|
|
constant flag_drop 200h constant flag_dropped 400h
|
|
constant flag_update 200h constant flag_drop 400h constant flag_dropped 800h
|
|
|
|
|
|
|
|
|
|
method p update stream -> status oarg_rw CachePrototype p ; arg_rw Stream stream ; arg ExtendedStatus status generic status := failure "not implemented"
method p dump stream -> status oarg_rw CachePrototype p ; arg_rw Stream stream ; arg ExtendedStatus status generic status := failure "not implemented"
method p sleep oarg_rw CachePrototype p generic
|
|
method p drop oarg_rw CachePrototype p generic
|
|
method p drop oarg_rw CachePrototype p generic
|
|
|
|
|
|
# update accordingly: # /pliant/graphic/color/gamut.pli # /pliant/storage/database/prototype.pli
|
|
|
|
|
|
|
|
|
|
|
gvar Dictionary cache gvar (Array List_ class_count) lru gvar Sem sem
|
|
gvar Dictionary cache gvar (Array List_ class_count) lru gvar Sem sem
|
|
|
|
|
|
method cp update_begin arg_rw CachePrototype cp cp flags := cp:flags .or. flag_update
method cp update_end arg_rw CachePrototype cp cp flags := cp:flags .and. .not. (cast flag_update Int)
method cp is_update -> c arg CachePrototype cp ; arg CBool c c := (cp:flags .and. flag_update)<>0
|
|
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)
|
|
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)
|
|
|
|
while exists:obj and ((addressof:obj translate Int -2)
|
|
while exists:obj and (addressof:obj map Int -2)<>2
|
|
obj :> (addressof obj:list_node:next) map CacheProto 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 obj drop sem request cache remove obj:id addressof:obj obj flags := flag_dropped sem release obj :> null map CachePrototype restart shrink status := failure
|
|
obj :> (addressof obj:list_node:next) map CacheProto 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 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 broadcast_prototype object param fun oarg_rw CachePrototype object ; arg_rw Universal param ; arg Function fun indirect
function cache_broadcast fun param arg Function fun ; arg_rw Universal param sem request for (var Int i) 0 lru:size-1 var Link:CachePrototype obj :> (addressof lru:i:first) map CachePrototype while exists:obj broadcast_prototype obj param fun obj :> (addressof obj:list_node:next) map CachePrototype sem release
|
|
function cache_open id type obj -> newone arg Str id ; arg Type type ; arg_w Link:CachePrototype obj 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_open id type obj -> newone arg Str id ; arg Type type ; arg_w Link:CachePrototype obj 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
|
|
|
|
export CachePrototype '. drop'
|
|
export CachePrototype '. id' '. update' '. dump' '. sleep' '. drop' export '. update_begin' '. update_end' '. is_update'
|
|
export cache_shrink
|
|
export cache_shrink
|
|
|
|
|
|
|
export cache_open cache_setup cache_ready cache_cancel export cache_search export cache_delete
|
|
export cache_open cache_setup cache_ready cache_cancel export cache_search export cache_delete
|