/pliant/language/optimizer/consteval.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/ring1.pli" 
 18   
 19   
 20  function remove_dead_code e 
 21    arg_rw Expression e 
 22    var Pointer:Arrow c :> e:instructions first ; var Int counter := 0 
 23    while c<>null 
 24      var Pointer:Instruction i :> c map Instruction 
 25      i order := counter 
 26      if (addressof i:function)=addressof:(the_function 'jump if' CBool) and i:0:where=argument_constant 
 27        if (i:0:constant map CBool) 
 28          i function :> the_function 'jump anyway' 
 29        else 
 30          i function :> the_function 'do nothing' 
 31          i jump :> null map Instruction 
 32        i 'size :=' 0 
 33      eif (addressof i:function)=addressof:(the_function 'jump if not' CBool) and i:0:where=argument_constant 
 34        if (i:0:constant map CBool) 
 35          i function :> the_function 'do nothing' 
 36          i jump :> null map Instruction 
 37        else 
 38          i function :> the_function 'jump anyway' 
 39        i 'size :=' 0 
 40      c :> e:instructions next c ; counter := counter+1 
 41    var Pointer:Arrow c :> e:instructions first  
 42    while c<>null 
 43      var Pointer:Arrow c2 :> e:instructions next c 
 44      var Pointer:Instruction i :> c map Instruction 
 45      if (addressof i:function)=(addressof the_function:'jump anyway') and (addressof i:jump)<>(cast -1 Address) and i:jump:order>i:order 
 46        var Pointer:Arrow c3 :> e:instructions first 
 47        while c3<>null and { var Pointer:Instruction j :> c3 map Instruction ; ( (addressof j:jump)=null or (addressof j:jump)=(cast -1 Address) or (j:order>i:order and j:order<i:jump:order) or j:jump:order<=i:order or j:jump:order>=i:jump:order ) } 
 48          c3 :> e:instructions next c3 
 49        if c3=null 
 50          var Pointer:Instruction i2 :> i jump 
 51          while c<>addressof:i2 
 52            c :> e:instructions remove c 
 53          c2 :> c 
 54      c :> c2 
 55   
 56   
 57  function evaluate_constant_expression e 
 58    arg_rw Expression e 
 59    # console "constant expression at "+e:position+"[lf]" 
 60    var Address cst := e evaluate 
 61    if error_notified 
 62      return 
 63    if cst<>null 
 64      e set_constant_result cst 
 65    else 
 66      error error_id_unexpected "Failed to evaluate expression at "+e:position 
 67      e set_void_result 
 68   
 69   
 70  method f may_map arg_num -> c 
 71    arg Function f ; arg Int arg_num ; arg CBool c 
 72    var Pointer:FunctionPrototype fp :> f arg arg_num 
 73    if ('.and.' fp:access access_byvalue)<>0  
 74      return false 
 75    for (var Int i) 0 f:nb_args_with_result-1 
 76      var Pointer:FunctionPrototype fp :> f arg i 
 77      if ('.and.' fp:access access_write)<>0 
 78        var Int b 
 79        if arg_num<30 
 80          b := arg_num 
 81        else 
 82          b := 30 
 83        if fp:maps<0 # bit 31 is set 
 84          if ('.and.' fp:type:flags type_flag_mapper)<>0 
 85            return true 
 86        else 
 87          if ('.and.' fp:maps 2^b)<>0 or ( ('.and.' fp:access access_mapped)<>0 and i<>arg_num ) 
 88            return true 
 89    return false 
 90   
 91  function look_for_constant_expression e 
 92    arg_rw Expression e 
 93    if (addressof e:result)=null 
 94      return 
 95    if ('.and.' e:access access_read+access_write)<>access_read  
 96      return 
 97    if e:result:where<>argument_local and (e:result:where<>argument_indirect or e:result:pointer:where<>argument_local) 
 98      return 
 99    if e:instructions:first=null 
 100      return 
 101    var List temporaries 
 102    var List requires 
 103    var Pointer:Arrow c :> e:instructions first 
 104    while c<>null 
 105      if entry_type:c<>Instruction 
 106        error error_id_unexpected "Expression instructions list should contain only instructions" 
 107        return 
 108      var Pointer:Instruction instr :> c map Instruction 
 109      if (instr:function nb_args_with_result)<>instr:size 
 110        error_notify error_id_unexpected null "The number of parameter in the instruction is not consistent with the function it calls" 
 111        return 
 112      if (addressof instr:jump)<>null 
 113        return  
 114      if ('.and.' instr:function:flags function_flag_has_side_effects+function_flag_later+function_flag_under_construction)<>0 
 115        return 
 116      for (var Int i) 0 instr:size-1 
 117        var Int arw := '.and.' (instr:function arg i):access access_read+access_write 
 118        if (instr:function may_map i) 
 119          return 
 120        if instr:i:where=argument_constant 
 121          requires append instr:i:constant 
 122        eif (addressof instr:i)=(addressof e:result) 
 123          if arw<>access_write # access is not write only 
 124            return  
 125        eif instr:i:where<>argument_local and instr:i:where<>argument_a_register 
 126          return  
 127        eif arw=access_write # access is write only 
 128          temporaries append (addressof instr:i) 
 129        eif arw<>access_read # access is not read only 
 130          return 
 131        else 
 132          var Pointer:Arrow c2 
 133          c2 :> temporaries first 
 134          while c2<>null and c2<>(addressof instr:i) 
 135            c2 :> temporaries next c2 
 136          if c2=null 
 137            return  
 138          temporaries remove c2 
 139      c :> e:instructions next c 
 140    if temporaries:first<>null 
 141      return 
 142    evaluate_constant_expression e 
 143    if error_notified 
 144      return 
 145    e:result requires := requires 
 146   
 147   
 148  alias 'pliant postcompile rewrite' remove_dead_code in "/pliant/language/optimizer/basic.pli" 
 149  alias 'pliant postcompile rewrite' look_for_constant_expression in "/pliant/language/optimizer/basic.pli" 
 150   
 151   
 152  meta constant e 
 153    if e:size=1 
 154      evaluate_constant_expression e:0 
 155      e suckup e:0 
 156      e set_result e:0:result e:0:access 
 157   
 158  export constant '. may_map'