/pliant/language/data/variables_context.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  # scope "/pliant/language/" "/pliant/install/" 
 17  module "/pliant/install/ring2.pli" 
 18   
 19   
 20  constant context_maximal_size 2^16 
 21   
 22   
 23 
 
 24   
 25   
 26  type VariablesContext 
 27    field Pointer:VariablesContext next previous 
 28  (addressof:VariablesContext map Type) flags := VariablesContext:flags .and. .not. type_flag_scalar 
 29   
 30  gvar Pointer:VariablesContext first_context last_context 
 31  gvar FastSem sem 
 32   
 33  function record_context c 
 34    arg_rw VariablesContext c 
 35    sem request 
 36    previous :> last_context 
 37    next :> null map VariablesContext 
 38    if exists:last_context 
 39      last_context next :> c 
 40    else 
 41      first_context :> c 
 42    last_context :> c 
 43    sem release 
 44   
 45  function unrecord_context c 
 46    arg_rw VariablesContext c 
 47    sem request 
 48    check not (exists c:next) or (addressof c:next:previous)=addressof:c 
 49    check not (exists c:previous) or (addressof c:previous:next)=addressof:c 
 50    if (exists c:next) 
 51      c:next previous :> previous 
 52    else 
 53      last_context :> previous 
 54    if (exists c:previous) 
 55      c:previous next :> next 
 56    else 
 57      first_context :> next 
 58    sem release 
 59   
 60  function allocate_context -> c 
 61    arg_RW VariablesContext c 
 62    :> (memory_page_reserve null context_maximal_size) map VariablesContext 
 63    var Pointer:Type :> VariablesContext 
 64    var Int := t:size+memory_page_size-1 ; := s-s%memory_page_size 
 65    memory_page_commit addressof:s 
 66    build_instance addressof:c 
 67    record_context c 
 68   
 69  function free_context c 
 70    arg_rw VariablesContext c 
 71    unrecord_context c 
 72    var Pointer:Type :> VariablesContext 
 73    destroy_instance addressof:c 
 74    var Int := t:size+memory_page_size-1 ; := s-s%memory_page_size 
 75    memory_page_decommit addressof:s 
 76    memory_page_release addressof:context_maximal_size 
 77   
 78  function current_context -> c 
 79    arg_RW VariablesContext c 
 80    :> current_thread_header:variables_context map VariablesContext 
 81   
 82     
 83 
 
 84   
 85   
 86  function define_context_variable type name init 
 87    arg Type type ; arg Str name ; arg Address init 
 88    var Pointer:VariablesContext :> first_context 
 89    var Pointer:Type :> VariablesContext 
 90    var Int s1 := t:size+memory_page_size-1 ; s1 := s1-s1%memory_page_size 
 91    define_field type name init 
 92    terminate_fields 
 93    var Int offset := (field t:nb_fields-1) offset 
 94    var Int s2 := t:size+memory_page_size-1 ; s2 := s2-s2%memory_page_size 
 95    if s2>context_maximal_size 
 96      error error_id_starvation "Too many context variables" 
 97    while exists:c 
 98      if s2<>s1 
 99        memory_page_commit (addressof:translate Byte s1) s2-s1 
 100      type build_instance (addressof:translate Byte offset) 
 101      if init<>null 
 102        type copy_instance init (addressof:translate Byte offset) 
 103      :> next 
 104   
 105  meta cvar e 
 106    if e:size<2 
 107      return 
 108    var Pointer:Type type :> (e:constant Type) map Type 
 109    if not exists:type 
 110      return 
 111    var Int last := e:size-1 ; var Address init := null 
 112    if e:size>=and e:(last-1):ident="<-" and (e:last constant type)<>null 
 113      init := e:last constant type 
 114      last -= 2 
 115    for (var Int i) last 
 116      if e:i:ident="" 
 117        return 
 118    for (var Int i) last 
 119      define_context_variable type e:i:ident init 
 120      var Pointer:Type :> VariablesContext 
 121      var Int offset := (field t:nb_fields-1) offset 
 122      var Link:Function :> new Function 
 123      name := e:i:ident 
 124      define_argument type access_write+access_mapped+access_result_read+access_result_write e:i:ident null 
 125      terminate_arguments function_flag_has_side_effects+function_flag_inline_instructions 
 126      var Link:Argument context :> argument indirect VariablesContext (argument local Address) 0 
 127      f:inline_instructions append addressof:(instruction (the_function current_context -> VariablesContext) context) 
 128      var Link:Argument field :> argument indirect type (argument local Address) 0 
 129      f:inline_instructions append addressof:(instruction (the_function 'translate Universal' Universal Int -> Universal) context (argument constant Int offset) field) 
 130      (arg 0) inline_argument :> field 
 131      define f:name addressof:e:i:module 
 132    set_void_result 
 133   
 134   
 135  function detached_context old 
 136    arg_rw Pointer:VariablesContext old 
 137    old :> (current_thread_header variables_context) map VariablesContext 
 138    var Pointer:VariablesContext :> allocate_context 
 139    := old 
 140    current_thread_header variables_context := addressof:c 
 141     
 142  function new_context old 
 143    arg_rw Pointer:VariablesContext old 
 144    old :> (current_thread_header variables_context) map VariablesContext 
 145    var Pointer:VariablesContext :> allocate_context 
 146    current_thread_header variables_context := addressof:c 
 147     
 148  function restore_context old 
 149    arg Pointer:VariablesContext old        
 150    current_thread_header variables_context := addressof:old 
 151     
 152  meta within_detached_variables_context e 
 153    if e:size<>1 
 154      return 
 155    var Link:Argument old :> argument local Pointer:VariablesContext 
 156    add (instruction (the_function detached_context Pointer:VariablesContext) old) 
 157    e:compile 
 158    suckup e:0 
 159    add (instruction (the_function restore_context Pointer:VariablesContext) old) 
 160    set_void_result 
 161     
 162  meta within_new_variables_context e 
 163    if e:size<>1 
 164      return 
 165    var Link:Argument old :> argument local Pointer:VariablesContext 
 166    add (instruction (the_function new_context Pointer:VariablesContext) old) 
 167    e:compile 
 168    suckup e:0 
 169    add (instruction (the_function restore_context Pointer:VariablesContext) old) 
 170    set_void_result 
 171   
 172  export cvar within_detached_variables_context within_new_variables_context 
 173   
 174   
 175 
 
 176   
 177   
 178  if true # do not save the contexts in .dump files 
 179   
 180    function restore_variables_contexts p fh 
 181      arg Address p ; arg Int fh 
 182      first_context :> null map VariablesContext 
 183      last_context:> null map VariablesContext 
 184      current_thread_header variables_context := addressof allocate_context 
 185     
 186    restore_variables_contexts null 0 
 187    gvar DelayedAction da2 
 188    da2 function :> the_function restore_variables_contexts Address Int 
 189    pliant_restore_actions append addressof:da2 
 190   
 191  else # save the contexts in .dump files (buggy) 
 192   
 193    first_context :> null map VariablesContext 
 194    last_context:> null map VariablesContext 
 195    current_thread_header variables_context := addressof allocate_context 
 196       
 197    function backup_variables_contexts p fh 
 198      arg Address p ; arg Int fh 
 199      var Pointer:Type t :> VariablesContext 
 200      var Pointer:VariablesContext c :> first_context 
 201      while exists:c 
 202        file_write fh addressof:c t:size 
 203        c :> c next 
 204      file_write fh (addressof current_thread_header:variables_context) Address:size 
 205       
 206    function restore_variables_contexts p fh 
 207      arg Address p ; arg Int fh 
 208      var Pointer:Type t :> VariablesContext 
 209      var Int s := t:size+memory_page_size-1 ; s := s-s%memory_page_size 
 210      var Pointer:VariablesContext c :> first_context 
 211      while exists:c 
 212        memory_page_reserve addressof:c context_maximal_size 
 213        memory_page_commit addressof:c s 
 214        file_read fh addressof:c t:size 
 215        c :> c next 
 216      file_read fh (addressof current_thread_header:variables_context) Address:size 
 217       
 218    gvar DelayedAction da1 
 219    da1 function :> the_function backup_variables_contexts Address Int 
 220    pliant_backup_actions append addressof:da1 
 221    gvar DelayedAction da2 
 222    da2 function :> the_function restore_variables_contexts Address Int 
 223    pliant_restore_actions append addressof:da2