Patch title: Release 85 bulk changes
Abstract:
File: /pliant/language/data/variables_context.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

# scope "/pliant/language/" "/pliant/install/"
module "/pliant/install/ring2.pli"


constant context_maximal_size 2^16


#----------------------------------------------------------------------


type VariablesContext
  field Pointer:VariablesContext next previous
(addressof:VariablesContext map Type) flags := VariablesContext:flags .and. .not. type_flag_scalar

gvar Pointer:VariablesContext first_context last_context
gvar FastSem sem

function record_context c
  arg_rw VariablesContext c
  sem request
  c previous :> last_context
  c next :> null map VariablesContext
  if exists:last_context
    last_context next :> c
  else
    first_context :> c
  last_context :> c
  sem release

function unrecord_context c
  arg_rw VariablesContext c
  sem request
  check not (exists c:next) or (addressof c:next:previous)=addressof:c
  check not (exists c:previous) or (addressof c:previous:next)=addressof:c
  if (exists c:next)
    c:next previous :> c previous
  else
    last_context :> c previous
  if (exists c:previous)
    c:previous next :> c next
  else
    first_context :> c next
  sem release

function allocate_context -> c
  arg_RW VariablesContext c
  c :> (memory_page_reserve null context_maximal_size) map VariablesContext
  var Pointer:Type t :> VariablesContext
  var Int s := t:size+memory_page_size-1 ; s := s-s%memory_page_size
  memory_page_commit addressof:c s
  t build_instance addressof:c
  record_context c

function free_context c
  arg_rw VariablesContext c
  unrecord_context c
  var Pointer:Type t :> VariablesContext
  t destroy_instance addressof:c
  var Int s := t:size+memory_page_size-1 ; s := s-s%memory_page_size
  memory_page_decommit addressof:c s
  memory_page_release addressof:c context_maximal_size

function current_context -> c
  arg_RW VariablesContext c
  c :> current_thread_header:variables_context map VariablesContext

  
#----------------------------------------------------------------------


function define_context_variable type name init
  arg Type type ; arg Str name ; arg Address init
  var Pointer:VariablesContext c :> first_context
  var Pointer:Type t :> VariablesContext
  var Int s1 := t:size+memory_page_size-1 ; s1 := s1-s1%memory_page_size
  t define_field type name init
  t terminate_fields
  var Int offset := (t field t:nb_fields-1) offset
  var Int s2 := t:size+memory_page_size-1 ; s2 := s2-s2%memory_page_size
  if s2>context_maximal_size
    error error_id_starvation "Too many context variables"
  while exists:c
    if s2<>s1
      memory_page_commit (addressof:c translate Byte s1) s2-s1
    type build_instance (addressof:c translate Byte offset)
    if init<>null
      type copy_instance init (addressof:c translate Byte offset)
    c :> c next

meta cvar e
  if e:size<2
    return
  var Pointer:Type type :> (e:0 constant Type) map Type
  if not exists:type
    return
  var Int last := e:size-1 ; var Address init := null
  if e:size>=4 and e:(last-1):ident="<-" and (e:last constant type)<>null
    init := e:last constant type
    last -= 2
  for (var Int i) 1 last
    if e:i:ident=""
      return
  for (var Int i) 1 last
    define_context_variable type e:i:ident init
    var Pointer:Type t :> VariablesContext
    var Int offset := (t field t:nb_fields-1) offset
    var Link:Function f :> new Function
    f name := e:i:ident
    f define_argument type access_write+access_mapped+access_result_read+access_result_write e:i:ident null
    f terminate_arguments function_flag_has_side_effects+function_flag_inline_instructions
    var Link:Argument context :> argument indirect VariablesContext (argument local Address) 0
    f:inline_instructions append addressof:(instruction (the_function current_context -> VariablesContext) context)
    var Link:Argument field :> argument indirect type (argument local Address) 0
    f:inline_instructions append addressof:(instruction (the_function 'translate Universal' Universal Int -> Universal) context (argument constant Int offset) field)
    (f arg 0) inline_argument :> field
    e define f:name addressof:f e:i:module
  e set_void_result


function detached_context old
  arg_rw Pointer:VariablesContext old
  old :> (current_thread_header variables_context) map VariablesContext
  var Pointer:VariablesContext c :> allocate_context
  c := old
  current_thread_header variables_context := addressof:c
  
function new_context old
  arg_rw Pointer:VariablesContext old
  old :> (current_thread_header variables_context) map VariablesContext
  var Pointer:VariablesContext c :> allocate_context
  current_thread_header variables_context := addressof:c
  
function restore_context old
  arg Pointer:VariablesContext old       
  current_thread_header variables_context := addressof:old
  
meta within_detached_variables_context e
  if e:size<>1
    return
  var Link:Argument old :> argument local Pointer:VariablesContext
  e add (instruction (the_function detached_context Pointer:VariablesContext) old)
  e:0 compile
  e suckup e:0
  e add (instruction (the_function restore_context Pointer:VariablesContext) old)
  e set_void_result
  
meta within_new_variables_context e
  if e:size<>1
    return
  var Link:Argument old :> argument local Pointer:VariablesContext
  e add (instruction (the_function new_context Pointer:VariablesContext) old)
  e:0 compile
  e suckup e:0
  e add (instruction (the_function restore_context Pointer:VariablesContext) old)
  e set_void_result

export cvar within_detached_variables_context within_new_variables_context


#----------------------------------------------------------------------


if true # do not save the contexts in .dump files

  function restore_variables_contexts p fh
    arg Address p ; arg Int fh
    first_context :> null map VariablesContext
    last_context:> null map VariablesContext
    current_thread_header variables_context := addressof allocate_context
  
  restore_variables_contexts null 0
  gvar DelayedAction da2
  da2 function :> the_function restore_variables_contexts Address Int
  pliant_restore_actions append addressof:da2

else # save the contexts in .dump files (buggy)

  first_context :> null map VariablesContext
  last_context:> null map VariablesContext
  current_thread_header variables_context := addressof allocate_context
    
  function backup_variables_contexts p fh
    arg Address p ; arg Int fh
    var Pointer:Type t :> VariablesContext
    var Pointer:VariablesContext c :> first_context
    while exists:c
      file_write fh addressof:c t:size
      c :> c next
    file_write fh (addressof current_thread_header:variables_context) Address:size
    
  function restore_variables_contexts p fh
    arg Address p ; arg Int fh
    var Pointer:Type t :> VariablesContext
    var Int s := t:size+memory_page_size-1 ; s := s-s%memory_page_size
    var Pointer:VariablesContext c :> first_context
    while exists:c
      memory_page_reserve addressof:c context_maximal_size
      memory_page_commit addressof:c s
      file_read fh addressof:c t:size
      c :> c next
    file_read fh (addressof current_thread_header:variables_context) Address:size
    
  gvar DelayedAction da1
  da1 function :> the_function backup_variables_contexts Address Int
  pliant_backup_actions append addressof:da1
  gvar DelayedAction da2
  da2 function :> the_function restore_variables_contexts Address Int
  pliant_restore_actions append addressof:da2