/pliant/language/optimizer/extra.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  gvar CBool active := false 
 21   
 22  function optimize_constant_instruction i gc -> i2 
 23    arg_rw Instruction i ;  arg_rw GeneratorContext gc ; arg_RW Instruction i2 
 24    i2 :> i 
 25    var Pointer:Function :> function 
 26    if ('.and.' f:flags function_flag_has_side_effects)<>0 
 27      return 
 28    if ('.and.' f:flags function_flag_later)<>0 
 29      return 
 30    if ('.and.' f:flags function_flag_under_construction)<>0 
 31      return 
 32    if f:nb_args=or f:nb_args_with_result=f:nb_args 
 33      return 
 34    for (var Int u) f:nb_args-1 
 35      if i:u:where<>argument_constant 
 36        return 
 37    for (var Int u) f:nb_args 
 38      if (may_map u) or i:u:type:real_data_type<>i:u:type 
 39        return 
 40    if i:(f:nb_args):where<>argument_local or ('.and.' (arg f:nb_args):access access_mapped)<>0 
 41      return 
 42    var Link:Type :> i:(f:nb_args) type 
 43    if t<>t:real_data_type 
 44      return 
 45    if (addressof i:jump)<>null 
 46      return 
 47    if ('.and.' f:flags function_flag_copy)<>0 
 48      return 
 49    var Link:Expression :> new Expression 
 50    module :> gc module 
 51    var Link:Instruction i3 :> new Instruction 
 52    i3 function :> function 
 53    i3 'size :=' i:size 
 54    for (var Int u) f:nb_args-1 
 55      var Link:Argument :> new Argument ; locate i:u:type argument_constant ; constant := i:constant 
 56      i3 :> a 
 57    var Link:Argument :> argument local t 
 58    i3 f:nb_args :> a 
 59    add i3 
 60    set_result access_read 
 61    active := true 
 62    var Address cst := evaluate function_flag_implicit+function_flag_extension+function_flag_reduction 
 63    active := false 
 64    if cst=null 
 65      return 
 66    var Link:Argument :> new Argument ; locate argument_constant ; constant := cst 
 67    i2 :> instruction (the_function 'copy Universal' Universal Universal Type) i:(f:nb_args) (argument mapped_constant Type t) 
 68    gc insert_after_instruction i2 
 69    gc remove i 
 70   
 71  function optimize_constant gc 
 72    arg_rw GeneratorContext gc 
 73    if active 
 74      return 
 75    var Link:Instruction :> gc first_instruction 
 76    while addressof:i<>null 
 77      :> (optimize_constant_instruction gc) next_instruction 
 78   
 79   
 80 
 
 81   
 82   
 83  function copy_int8 src dest 
 84    arg Int src ; arg_w Int dest 
 85    gcc_inline "*(char *)@2 = (char)$1;" 
 86   
 87  function copy_int16 src dest 
 88    arg Int src ; arg_w Int dest 
 89    gcc_inline "*(short *)@2 = (short)$1;" 
 90   
 91  function optimize_copy gc 
 92    arg_rw GeneratorContext gc 
 93    var Pointer:Instruction instr :> gc first_instruction 
 94    while addressof:instr<>null 
 95      if (addressof instr:function)=addressof:(the_function 'copy scalar' Universal Universal Int) 
 96        var Pointer:Argument targ :> instr 2 ; check targ:where=argument_constant and (entry_type targ:constant)=Int 
 97        var Int size := instr:2:constant map Int 
 98        if size=0 
 99          instr :> gc remove instr 
 100        eif size=1 
 101          if gcc_is_active 
 102            gc insert_after_instruction instr (instruction (the_function copy_int8 Int Int) instr:instr:1) 
 103            instr :> gc remove instr 
 104          eif processor_name="i386" 
 105            var Link:Argument arg :> argument a_register 
 106            var Pointer:Instruction cur :> gc insert_after_instruction instr (instruction (the_function i386_movzx8 Int -> Int) instr:arg) 
 107            gc insert_after_instruction cur (instruction (the_function i386_mov8 Int -> Int) arg instr:1) 
 108            instr :> gc remove instr 
 109        eif processor_name="i386" and size=2 
 110          if gcc_is_active 
 111            gc insert_after_instruction instr (instruction (the_function copy_int16 Int Int) instr:instr:1) 
 112            instr :> gc remove instr 
 113          else 
 114            var Link:Argument arg :> argument a_register 
 115            var Pointer:Instruction cur :> gc insert_after_instruction instr (instruction (the_function i386_movzx16 Int -> Int) instr:arg) 
 116            gc insert_after_instruction cur (instruction (the_function i386_mov16 Int -> Int) arg instr:1) 
 117            instr :> gc remove instr 
 118        eif size=Int:size 
 119          gc insert_after_instruction instr (instruction (the_function 'copy atomic' Int Int) instr:instr:1) 
 120          instr :> gc remove instr 
 121        else 
 122          instr :> instr next_instruction 
 123      else 
 124        instr :> instr next_instruction 
 125   
 126   
 127 
 
 128   
 129   
 130  function optimize_translate gc 
 131    arg_rw GeneratorContext gc 
 132    var Link:Instruction :> gc first_instruction 
 133    while addressof:i<>null 
 134      var Link:Instruction i2 :> null map Instruction 
 135      var Pointer:Function :> function 
 136      if f=(the_function 'translate Universal' Universal Int -> Universal) 
 137        if i:0:where=argument_indirect and i:0:offset=0 
 138          if i:1:where=argument_constant and (i:1:constant map Int)=0 
 139            i2 :> instruction (the_function 'copy atomic' Int Int) i:0:pointer i:2 
 140          else 
 141            i2 :> instruction (the_function '+' Int Int -> Int) i:0:pointer i:i:2 
 142          gc keep_object i:0 
 143        else 
 144          if i:1:where=argument_constant and (i:1:constant map Int)=0 
 145            i2 :> instruction (the_function 'address Universal' Universal -> Address) i:i:2 
 146      eif f=(the_function 'address Universal' Universal -> Address) 
 147        if i:0:where=argument_indirect and i:0:offset=0 
 148          i2 :> instruction (the_function 'copy atomic' Int Int) i:0:pointer i:1 
 149          gc keep_object i:0 
 150      if addressof:i2<>null 
 151        gc insert_after_instruction i2 
 152        gc remove i 
 153        :> i2 
 154      :> next_instruction 
 155   
 156   
 157 
 
 158   
 159   
 160  constant standard_algo false 
 161  constant new_algo true 
 162  constant nonatomic_also true 
 163  constant indirect_also false 
 164   
 165  constant undefined_mapping ((the_function '+' Int Int -> Int) arg 0):maps 
 166   
 167  function optimize_drop gc 
 168    arg_rw GeneratorContext gc 
 169    gc share_begin 
 170    var Pointer:Arrow :> gc:arguments first 
 171    while c<>null 
 172      var Link:Argument :> map Argument 
 173      if a:is_temporary and (nonatomic_also or ('.and.' a:type:flags type_flag_atomic)<>0) 
 174        var Link:Instruction first :> first_instruction 
 175        var Link:Instruction last :> last_instruction 
 176        if addressof:first<>null and (gcc_inline_instructions query addressof:first null)=null and (gcc_inline_instructions query addressof:last null)=null 
 177          if standard_algo 
 178            if ('.and.' first:function:flags function_flag_copy)<>0 and first:1=a 
 179              if (first:0 is_stable first last) and (indirect_also or first:0:where<>argument_indirect) 
 180                gc share_try a first:0 
 181            eif ('.and.' last:function:flags function_flag_copy)<>0 and last:0=a 
 182              if (last:1 is_stable first last) and (indirect_also or last:1:where<>argument_indirect) 
 183                gc share_try a last:1 
 184          if new_algo 
 185            if ('.and.' first:function:flags function_flag_copy)<>and first:1=a 
 186              if (first:is_stable first last) and (indirect_also or first:0:where<>argument_indirect) 
 187                if not (gc share_clash first:0) 
 188                  gc suckup first:0 
 189            eif ('.and.' last:function:flags function_flag_copy)<>and last:0= 
 190              if (last:is_stable first last) and (indirect_also or last:1:where<>argument_indirect) 
 191                if not (gc share_clash last:1) 
 192                  var Int := 0 
 193                  while i<first:size and first:i<>a 
 194                    := i+1 
 195                  if i<first:size and ('.and.' (first:function arg i):maps '.not.':undefined_mapping)=0 
 196                    gc suckup last:1 
 197      :> gc:arguments next c 
 198    gc share_end 
 199   
 200   
 201  record_optimizer_function optimize_constant "pliant optimizer rewrite instructions0" 
 202  record_optimizer_function optimize_copy "pliant optimizer rewrite instructions" 
 203  record_optimizer_function optimize_translate "pliant optimizer rewrite instructions" 
 204  record_optimizer_function optimize_drop "pliant optimizer rewrite instructions" 
 205  record_optimizer_function optimize_drop "pliant optimizer rewrite instructions2"