Patch title: Release 94 bulk changes
Abstract:
File: /pliant/language/optimizer/extra.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"


gvar CBool active := false

function optimize_constant_instruction i gc -> i2
  arg_rw Instruction i ;  arg_rw GeneratorContext gc ; arg_RW Instruction i2
  i2 :> i
  var Pointer:Function f :> i function
  if ('.and.' f:flags function_flag_has_side_effects)<>0
    return
  if ('.and.' f:flags function_flag_later)<>0
    return
  if ('.and.' f:flags function_flag_under_construction)<>0
    return
  if f:nb_args=0 or f:nb_args_with_result=f:nb_args
    return
  for (var Int u) 0 f:nb_args-1
    if i:u:where<>argument_constant
      return
  for (var Int u) 0 f:nb_args
    if (f may_map u) or i:u:type:real_data_type<>i:u:type
      return
  if i:(f:nb_args):where<>argument_local or ('.and.' (f arg f:nb_args):access access_mapped)<>0
    return
  var Link:Type t :> i:(f:nb_args) type
  if t<>t:real_data_type
    return
  if (addressof i:jump)<>null
    return
  if ('.and.' f:flags function_flag_copy)<>0
    return
  var Link:Expression e :> new Expression
  e module :> gc module
  var Link:Instruction i3 :> new Instruction
  i3 function :> i function
  i3 'size :=' i:size
  for (var Int u) 0 f:nb_args-1
    var Link:Argument a :> new Argument ; a locate i:u:type argument_constant ; a constant := i:u constant
    i3 u :> a
  var Link:Argument a :> argument local t
  i3 f:nb_args :> a
  e add i3
  e set_result a access_read
  active := true
  var Address cst := e evaluate t function_flag_implicit+function_flag_extension+function_flag_reduction
  active := false
  if cst=null
    return
  var Link:Argument a :> new Argument ; a locate t argument_constant ; a constant := cst
  i2 :> instruction (the_function 'copy Universal' Universal Universal Type) a i:(f:nb_args) (argument mapped_constant Type t)
  gc insert_after_instruction i i2
  gc remove i

function optimize_constant gc
  arg_rw GeneratorContext gc
  if active
    return
  var Link:Instruction i :> gc first_instruction
  while addressof:i<>null
    i :> (optimize_constant_instruction i gc) next_instruction


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


function copy_int src dest
  arg Int src ; arg_w Int dest
  gcc_inline "$2 = $1;"
  dest := src

function copy_int8 src dest
  arg Int src ; arg_w Int dest
  gcc_inline "*(char *)@2 = (char)$1;"

function copy_int16 src dest
  arg Int src ; arg_w Int dest
  gcc_inline "*(short *)@2 = (short)$1;"

function optimize_copy gc
  arg_rw GeneratorContext gc
  var Pointer:Instruction instr :> gc first_instruction
  while addressof:instr<>null
    if (addressof instr:function)=addressof:(the_function 'copy scalar' Universal Universal Int)
      var Pointer:Argument targ :> instr 2 ; check targ:where=argument_constant and (entry_type targ:constant)=Int
      var Int size := instr:2:constant map Int
      if size=0
        instr :> gc remove instr
      eif size=1
        if gcc_is_active
          gc insert_after_instruction instr (instruction (the_function copy_int8 Int Int) instr:0 instr:1)
          instr :> gc remove instr
        eif processor_name="i386"
          var Link:Argument arg :> argument a_register
          var Pointer:Instruction cur :> gc insert_after_instruction instr (instruction (the_function i386_movzx8 Int -> Int) instr:0 arg)
          gc insert_after_instruction cur (instruction (the_function i386_mov8 Int -> Int) arg instr:1)
          instr :> gc remove instr
      eif processor_name="i386" and size=2
        if gcc_is_active
          gc insert_after_instruction instr (instruction (the_function copy_int16 Int Int) instr:0 instr:1)
          instr :> gc remove instr
        else
          var Link:Argument arg :> argument a_register
          var Pointer:Instruction cur :> gc insert_after_instruction instr (instruction (the_function i386_movzx16 Int -> Int) instr:0 arg)
          gc insert_after_instruction cur (instruction (the_function i386_mov16 Int -> Int) arg instr:1)
          instr :> gc remove instr
      eif size=Int:size
        gc insert_after_instruction instr (instruction (the_function copy_int Int Int) instr:0 instr:1)
        gc insert_after_instruction instr (instruction (the_function 'copy atomic' Int Int) instr:0 instr:1)
        instr :> gc remove instr
      else
        instr :> instr next_instruction
    else
      instr :> instr next_instruction


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


function optimize_translate gc
  arg_rw GeneratorContext gc
  var Link:Instruction i :> gc first_instruction
  while addressof:i<>null
    var Link:Instruction i2 :> null map Instruction
    var Pointer:Function f :> i function
    if f=(the_function 'translate Universal' Universal Int -> Universal)
      if i:0:where=argument_indirect and i:0:offset=0
        if i:1:where=argument_constant and (i:1:constant map Int)=0
          i2 :> instruction (the_function 'copy atomic' Int Int) i:0:pointer i:2
        else
          i2 :> instruction (the_function '+' Int Int -> Int) i:0:pointer i:1 i:2
        gc keep_object i:0
      else
        if i:1:where=argument_constant and (i:1:constant map Int)=0
          i2 :> instruction (the_function 'address Universal' Universal -> Address) i:0 i:2
    eif f=(the_function 'address Universal' Universal -> Address)
      if i:0:where=argument_indirect and i:0:offset=0
        i2 :> instruction (the_function 'copy atomic' Int Int) i:0:pointer i:1
        gc keep_object i:0
    if addressof:i2<>null
      gc insert_after_instruction i i2
      gc remove i
      i :> i2
    i :> i next_instruction


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


constant standard_algo false
constant new_algo true
constant nonatomic_also true
constant indirect_also false

constant undefined_mapping ((the_function '+' Int Int -> Int) arg 0):maps

function optimize_drop gc
  arg_rw GeneratorContext gc
  gc share_begin
  var Pointer:Arrow c :> gc:arguments first
  while c<>null
    var Link:Argument a :> c map Argument
    if a:is_temporary and (nonatomic_also or ('.and.' a:type:flags type_flag_atomic)<>0)
      var Link:Instruction first :> a first_instruction
      var Link:Instruction last :> a last_instruction
      if addressof:first<>null and (gcc_inline_instructions query addressof:first null)=null and (gcc_inline_instructions query addressof:last null)=null
        if standard_algo
          if ('.and.' first:function:flags function_flag_copy)<>0 and first:1=a
            if (first:0 is_stable first last) and (indirect_also or first:0:where<>argument_indirect)
              gc share_try a first:0
          eif ('.and.' last:function:flags function_flag_copy)<>0 and last:0=a
            if (last:1 is_stable first last) and (indirect_also or last:1:where<>argument_indirect)
              gc share_try a last:1
        if new_algo
          if ('.and.' first:function:flags function_flag_copy)<>0 and first:1=a
            if (first:0 is_stable first last) and (indirect_also or first:0:where<>argument_indirect)
              if not (gc share_clash a first:0)
                gc suckup a first:0
          eif ('.and.' last:function:flags function_flag_copy)<>0 and last:0=a 
            if (last:1 is_stable first last) and (indirect_also or last:1:where<>argument_indirect)
              if not (gc share_clash a last:1)
                var Int i := 0
                while i<first:size and first:i<>a
                  i := i+1
                if i<first:size and ('.and.' (first:function arg i):maps '.not.':undefined_mapping)=0
                  gc suckup a last:1
    c :> gc:arguments next c
  gc share_end


record_optimizer_function optimize_constant "pliant optimizer rewrite instructions0"
record_optimizer_function optimize_copy "pliant optimizer rewrite instructions"
record_optimizer_function optimize_translate "pliant optimizer rewrite instructions"
record_optimizer_function optimize_drop "pliant optimizer rewrite instructions"
record_optimizer_function optimize_drop "pliant optimizer rewrite instructions2"