/pliant/language/compiler/expression/freeze.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/ring3.pli" 
 18   
 19   
 20  gvar Int freeze_counter := 0 
 21   
 22   
 23  method e uses a -> answer 
 24    arg Expression e ; arg Argument a ; arg CBool answer 
 25    var Pointer:Arrow :> e:instructions first  
 26    while c<>null 
 27      var Pointer:Instruction instr :> map Instruction 
 28      for (var Int i) instr:size-1 
 29        var Pointer:Argument arg :> instr i 
 30        if addressof:arg=addressof:a 
 31          return true 
 32        while arg:where=argument_indirect 
 33          var Pointer:Argument arg :> arg pointer 
 34          if addressof:arg=addressof:a 
 35            return true 
 36      :> e:instructions next c 
 37    answer := false 
 38   
 39  method final freeze expressions byaddress functions type 
 40    arg_rw Expression final ; arg_rw List expressions byaddress ; arg_rw List functions ; arg_rw Link:Type type 
 41    var Pointer:Module module :> final module 
 42    var Address mark := module mark 
 43    var Pointer:Arrow :> pliant_general_dictionary first "pliant locals" 
 44    var Link:List external_locals 
 45    if c=null 
 46      external_locals :> new List 
 47      module define "pliant locals" addressof:external_locals 
 48    else 
 49      check (addressof entry_type:c)=addressof:List 
 50      external_locals :> map List 
 51    var List instructions instructions2 
 52    type :> new Type 
 53    freeze_counter := freeze_counter+1 
 54    type name := "(Freeze "+string:freeze_counter+")" 
 55    type position := final position 
 56    var Link:Argument newadr :> argument local Address 
 57    var Link:Argument newobj :> argument indirect type newadr 0 
 58    instructions append addressof:(instruction (the_function entry_new Type -> Address) (argument mapped_constant Type type) newadr) 
 59    var Pointer:Arrow :> expressions first 
 60    while r<>null 
 61      check (addressof entry_type:r)=addressof:Expression 
 62      var Pointer:Expression :> map Expression 
 63      var Link:Function fun :> new Function 
 64      var Link:Array arguments :> new Array 
 65      arguments 'size :=' 1 
 66      module define "pliant arguments" addressof:arguments 
 67      var Link:Argument arg :> argument local Address 
 68      arguments := addressof:arg 
 69      var Relation originals := var Relation empty_relation 
 70      var Link:List intern_locals :> new List 
 71      module define "pliant locals" addressof:intern_locals 
 72      var Pointer:Arrow :> external_locals first 
 73      while c<>null 
 74        check (addressof entry_type:c)=(addressof LocalVariable) 
 75        var Link:LocalVariable :> map LocalVariable 
 76        var Pointer:Type :> l:body type 
 77        var Link:LocalVariable l2 :> new LocalVariable 
 78        l2 name := name 
 79        l2 function :> fun 
 80        l2 body :> argument local t 
 81        l2:body name := l:body name 
 82        l2 access := access 
 83        module define l:name addressof:l2 
 84        intern_locals append addressof:l2 
 85        originals define addressof:l2 null addressof:l 
 86        :> external_locals next c 
 87      fun name := "frozen expression at "+e:position 
 88      fun position := position 
 89      fun define_argument Address access_read+access_byvalue "" null 
 90      fun terminate_arguments 0 
 91      functions append addressof:fun 
 92      module define "pliant function" addressof:fun 
 93      compile 
 94      if error_notified 
 95        module rewind mark 
 96        if error_top_record:id=error_id_compile and final:error_message=""  
 97          final error_message := error_top_record message 
 98        return 
 99      var Link:Argument da :> argument local DelayedAction 
 100      var Link:Argument adr :> argument local Address 
 101      instructions2 append addressof:(instruction (the_function 'address Universal' Universal -> Address) da adr) 
 102      var Link:Argument field :> argument indirect Arrow adr 0 
 103      instructions2 append addressof:(instruction (the_function 'arrow Universal' Universal -> Arrow) (argument mapped_constant Function fun) field) 
 104      field :> argument indirect Arrow adr Arrow:size 
 105      instructions2 append addressof:(instruction (the_function 'arrow Universal' Universal -> Arrow) newobj field) 
 106      var Pointer:Arrow :> intern_locals first 
 107      while c<>null 
 108        check (addressof entry_type:c)=addressof:LocalVariable 
 109        var Link:LocalVariable l2 :> map LocalVariable 
 110        var Link:LocalVariable :> (originals query addressof:l2 null) map LocalVariable 
 111        if addressof:l<>null and (uses l2:body) 
 112          var Int := 0 
 113          while i<type:nb_fields and (type field i):name<>l2:name 
 114            := i+1 
 115          var Pointer:Type :> l2:body type 
 116          var CBool := (t:flags .and. type_flag_do_not_copy)=0 
 117          var Pointer:Arrow c2 :> byaddress first 
 118          while c2<>null 
 119            check (addressof entry_type:c2)=addressof:Ident 
 120            if (cast (c2 map Ident) Str)=l2:name 
 121              := false 
 122            c2 :> byaddress next c2 
 123          var Int offset 
 124          if i<>type:nb_fields 
 125            offset := (type field i) offset 
 126          else 
 127            offset := type size 
 128            if v 
 129              type define_field l2:name null 
 130            else 
 131              type define_field Address l2:name null 
 132            var Link:Argument field :> argument indirect Address newadr offset 
 133            if v 
 134              instructions append addressof:(instruction (the_function 'copy Universal' Universal Universal Type) l:body field (argument mapped_constant Type t)) 
 135            else 
 136              instructions append addressof:(instruction (the_function 'address Universal' Universal -> Address) l:body field) 
 137          l2:body locate argument_indirect 
 138          if v 
 139            l2:body pointer :> arg ; l2:body offset := offset 
 140          else 
 141            l2:body pointer :> (argument indirect Address arg offset) ; l2:body offset := 0 
 142        :> intern_locals next c 
 143      var Link:GeneratorContext gc :> new GeneratorContext 
 144      gc setup fun 
 145      gc optimize 
 146      set_result da access_read_write 
 147      module rewind mark 
 148      :> expressions next r 
 149    type terminate_fields 
 150    :> functions first 
 151    while r<>null 
 152      check (addressof entry_type:r)=addressof:Function 
 153      var Pointer:Function :> map Function 
 154      (arg 0) type :> pointerto type 
 155      :> functions next r 
 156    :> instructions first 
 157    while r<>null 
 158      final add (map Instruction) 
 159      :> instructions next r 
 160    :> instructions2 first 
 161    while r<>null 
 162      final add (map Instruction) 
 163      :> instructions2 next r 
 164   
 165   
 166  method e freeze  
 167    arg_rw Expression e 
 168    var List expressions byaddress functions ; var Link:Type type 
 169    expressions append addressof:e 
 170    freeze expressions byaddress functions type 
 171   
 172   
 173  meta 'pliant share arguments' e 
 174    var Pointer:Arrow :> e:module first "pliant shared" 
 175    if r=null 
 176      return 
 177    if e:size<1 
 178      return 
 179    for (var Int i) e:size-1 
 180      if not e:i:is_pure_ident 
 181        return 
 182    for (var Int i) e:size-1 
 183      e:compile ? 
 184    var Pointer:List byaddress :> map List 
 185    for (var Int i) e:size-1 
 186      var Pointer:Arrow :> byaddress first 
 187      while r<>null and (map Ident)<>(e:i:value map Ident) 
 188        :> byaddress next r 
 189      if r=null 
 190        byaddress append addressof:(e:i:value map Ident) 
 191    if e:size=1 
 192      set_result e:0:result e:0:access 
 193    else 
 194      set_void_result 
 195   
 196   
 197  export '. freeze' 
 198  export 'pliant share arguments'