obp/obp/fm/kernel/hashcach.fth

\ ========== Copyright Header Begin ==========================================
\
\ Hypervisor Software File: hashcach.fth
\
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\
\  - Do no alter or remove copyright notices
\
\  - Redistribution and use of this software in source and binary forms, with
\    or without modification, are permitted provided that the following
\    conditions are met:
\
\  - Redistribution of source code must retain the above copyright notice,
\    this list of conditions and the following disclaimer.
\
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\    Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\
\     This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility.
\
\ ========== Copyright Header End ============================================
\ hashcach.fth 3.6 01/05/18
\ Copyright 1985-1994 Bradley Forthware
\ Copyright 1994-2001 Sun Microsystems, Inc.  All Rights Reserved

\ Dictionary cache to speed up "find".  Only the Forth vocabulary is
\ cached; this eliminates a lot of cache flushing and is simpler than
\ caching all vocabularies.

hex

headerless
100 /link * constant /hashcache
/hashcache buffer: hashcache


: link+  ( adr index -- adr' )
\t16 wa+
\t32 la+
;
: vhash  ( adr,len -- cache-adr )
   7 and  swap c@ 1f and  3 <<  +  hashcache swap  link+
;
: match?  ( adr len cache-adr  -- flag )
   another-link?   if     ( adr len acf )
      >name name>string   ( adr len adr2,len2 )
      2swap               ( nameadr,len stradr,len )
      rot                 ( nameadr stradr slen nlen )
      over =  if          ( nadr sadr slen )
         comp 0=
      else                ( nadr sadr slen )
         3drop false
      then
   else                   ( adr len )
      2drop false
   then
;

headers
: clear-hashcache  ( -- )
   hashcache  /hashcache bounds  ?do  i !null-link  /link +loop
;
headerless
clear-hashcache
chain: init  ( -- )  clear-hashcache  ;

: probe-cache  ( adr len voc-acf -- find-results )
   dup ['] forth =  if               ( adr len voc-acf )
      drop 2dup vhash                ( adr len cache-adr )
      3dup match?  if                ( adr len cache-adr )
         link@ >link true            ( adr len alf true )
      else                           ( adr len adr2 )
         >r                          ( adr len )
         ['] forth >threads  $find-next  if   ( adr len alf )
            r> over link> swap link!  true    ( adr len alf true)
         else                                 ( adr len )
            r> drop false                     ( adr len false )
         then                            ( adr len false | adr len alf true )
      then
      find-fixup                              ( find-results )
      r> drop exit
   then
   >first                                     ( find-results )
;

: forth?  ( -- flag )  current-voc  ['] forth =  ;

: replace-entry  ( -- )  last @ name>  last @ name>string vhash  link!  ;
: clear-entry  ( -- )  last @ name>string vhash  !null-link  ;

: cached-make  ( adr len voc-acf -- )
   $create-word   forth? if  replace-entry  then
;

: cached-hide  ( -- voc-acf )  forth? if  clear-entry  then  current-voc  ;

: cached-reveal  ( -- )
   hidden-voc get-token?  if  drop forth? if  replace-entry  then  then
   hidden-voc
;

: cached-remove  ( alf acf -- alf prev-link )
   over l>name name>string vhash  !null-link  >threads
;


[ifexist] patch
patch cached-hide current-voc hide              \ fm/kernel/voccom
patch cached-reveal hidden-voc reveal           \ fm/kernel/voccom
patch cached-make $create-word ($header)        \ fm/kernel/voccom
patch cached-remove >threads remove-word        \ fm/kernel/tagvoc
patch probe-cache >first $find-word             \ fm/kernel/tagvoc
[else]
where ." WARNING: Falling back to unsafe code patching" cr
' cached-hide ' hide >body token!
' cached-reveal ' reveal >body token!
' cached-make ' ($header) >body /token + token!
' cached-remove ' remove-word >body token!
' probe-cache ' $find-word >body token!
[then]

headers