Patch title: Release 90 bulk changes
File: /language/optimizer/gcc.pli
    Removed line
    Added line
# Copyright  Hubert Tonneau
# 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
# 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.

module "/pliant/language/basic/unsafe.pli"
module "/pliant/language/context/internals.pli"
module "/pliant/language/compiler/internals.pli"
module "/pliant/language/optimizer/internals.pli"
module "/pliant/language/generator/internals.pli"
module "/pliant/language/misc/hooks.pli"
module "/pliant/language/stream/light.pli"
submodule "gcc_base.pli"

constant trace false
constant gcc_executable "gcc"
constant gcc_executable "gcc-2.95"
constant use_kernel_functions os_api="linux"

# ---------------------------------------------------------------------------
#    recreate the missing functions so that this module can be loaded first
# ---------------------------------------------------------------------------

function maybe solution try
  arg_rw Str solution ; arg Str try
  if solution=""
    var Int h := file_open try 1
    if h<>-1
      solution := try
      file_close h

function libc_filename -> filename
  arg Str filename
  filename := ""
  if os_kernel="FreeBSD"
    maybe filename "/usr/lib/"       # This is supposed to be a symlink
    maybe filename "/usr/lib/"     # ... For FreeBSD 3.X
    maybe filename "/usr/lib/"   # ... For FreeBSD 2.X
  eif os_kernel="OpenBSD"
    maybe filename "/usr/lib/"   # OpenBSD 2.7
    maybe filename "/usr/lib/"   # OpenBSD 2.6
    maybe filename "/usr/lib/"   # OpenBSD 2.5
    maybe filename "/lib/" 
    maybe filename "/lib/" 

constant os_libc_filename libc_filename


# constants

constant compare_inferior  1
constant compare_equal     2
constant compare_superior  4
constant compare_different 8

constant type_flag_atomic 1
constant type_flag_scalar 2
constant type_flag_mapper 32
constant argument_constant 1
constant argument_register 2
constant argument_indirect 3
constant argument_local 4
constant argument_a_register 5

constant access_read 1
constant access_write 2
constant access_byvalue 16
constant access_mapped 32

constant function_flag_allocated_exe 1
constant function_flag_later 8
constant function_flag_varargs 1*2^4
constant function_flag_external 2*2^4
constant function_flag_kernel 4*2^4
constant function_flag_generic 8*2^4
constant function_flag_indirect 16*2^4
constant function_flag_has_side_effects 8*2^16
constant function_flag_has_no_side_effect 16*2^16

# errors

function error msg
  arg Str msg
  var ErrorID id ; addressof:id map Int := 7
  error_notify id null msg

# strings

method s '' i -> s2
  arg Str s s2 ; arg Int i
  s2 := s i 1

method s number -> i
  arg Str s ; arg Int i
  i := 0
  memory_copy s:characters addressof:i 1

function string i -> s
  arg Int i ; arg Str s
  s := 'convert to string' i
function replace s pattern with -> answer
  arg Str s pattern with answer
  answer := s
  var Int i := 0
  while i<answer:len
    if (answer i pattern:len)=pattern
      answer := (answer 0 i)+with+(answer i+pattern:len answer:len)
      i := i+with:len
      i := i+1

# shunt

function shunt c s1 s2 -> s
  arg CBool c ; arg Str s1 s2 s
  if c
    s := s1
    s := s2
function shunt c i1 i2 -> i
  arg CBool c ; arg Int i1 i2 i
  if c
    i := i1
    i := i2

# new

function new t v -> s
  arg Type t ; arg Str v ; arg_RW Str s
  if addressof:t<>addressof:Str
    error "unexpected use of new function"
  s :> new Str
  s := v

function new t v -> i
  arg Type t ; arg Int v ; arg_RW Int i
  if addressof:t<>addressof:Int
    error "unexpected use of new function"
  i :> new Int
  i := v

# meta programming

method i '' u -> iu
  arg Instruction i ; arg Int u ; arg_C Link:Argument iu
  return ((addressof i:arguments:u) map Link:Argument)

method e size -> s
  arg Expression e ; arg Int s
  return e:arguments:size

method e '' i -> ei
  arg Expression e ; arg Int i ; arg_C Expression ei
  return (e:arguments:i map Expression)

method e ident -> id
  arg Expression e ; arg Str id
  if addressof:(entry_type e:value)<>addressof:Ident
    return ""
  id := cast (e:value map Ident) Str

function argument_local t -> a
  arg Type t ; arg_RW Argument a
  a :> new Argument
  a locate t argument_local

function instruction fun a -> i
  arg Function fun ; arg Argument a ; arg_RW Instruction i
  i :> new Instruction
  i function :> fun
  i:arguments 'size :=' 1
  i:arguments 0 := addressof a
function instruction fun a1 a2 -> i
  arg Function fun ; arg Argument a1 a2 ; arg_RW Instruction i
  i :> new Instruction
  i function :> fun
  i:arguments 'size :=' 2
  i:arguments 0 := addressof a1
  i:arguments 1 := addressof a2
# parsing

type Parser
  field Str remain
  field CBool ok
  field Pointer:Str pending

function parse_begin s -> p
  arg Str s ; arg Parser p
  p remain := s
  p ok := true
  p pending :> null map Str

method p drop_spaces
  arg_rw Parser p
  var Int j := 0
  while j<p:remain:len and ((p:remain j 1)=" " or (p:remain j 1)="[tab]")
    j := j+1
  p remain := p:remain j p:remain:len

method p store_pending i forward
  arg_rw Parser p ; arg Int i forward
  if i<>0 and (addressof p:pending)=null
    p ok := false
  var Int j := i
  while j>0 and ((p:remain j-1 1)=" " or (p:remain j-1 1)="[tab]")
    j := j-1
  if (addressof p:pending)<>null
    p pending := p:remain 0 j
    p pending :> null map Str
  if forward<>0
    p remain := p:remain forward p:remain:len

function parse_end p -> ok
  arg_rw Parser p ; arg CBool ok
  p drop_spaces
  p store_pending p:remain:len p:remain:len
  ok := p ok

function parse_some_spaces p
  arg_rw Parser p
  var Int i := 0
  while i<p:remain:len and (p:remain i 1)<>" " and (p:remain i 1)<>"[tab]"
    i := i+1
  var Int j := i
  while j<p:remain:len and ((p:remain j 1)=" " or (p:remain j 1)="[tab]")
    j := j+1
  if j=i
    p ok := false
  p store_pending i j

function parse_a_pattern p s
  arg_rw Parser p ; arg Str s
  p drop_spaces
  var Int i := 0
  while i<p:remain:len and (p:remain i s:len)<>s
    i := i+1
  if i=p:remain:len
    p ok := false
  p store_pending i i+s:len

function parse_an_str p value
  arg_rw Parser p ; arg_w Str value
  p drop_spaces
  if (addressof p:pending)<>null
    p ok := false
  p pending :> value

function parse_an_int p value
  arg_rw Parser p ; arg_w Int value
  p drop_spaces
  value := 0
  var Int i := 0
  while i<p:remain:len and ((p:remain i 1)<"0" or (p:remain i 1)>"9")
    i := i+1
  if i=p:remain:len
    p ok := false
  var Int j := i
  while j<p:remain:len and (p:remain j 1)>="0" and (p:remain j 1)<="9"
    var Int ch := 0
    memory_copy (p:remain:characters translate Byte j) addressof:ch 1
    value := 10*value+ch-48
    j := j+1
  p store_pending i j

meta '. parse' e
  if e:size<1 or not (e:0 cast Str)
  var Link:Argument p :> argument_local Parser
  var Link:Argument r :> argument_local CBool
  e suckup e:0
  e add (instruction (the_function parse_begin Str -> Parser) e:0:result p)
  var Int i := 1
  while i<e:size
    if e:i:ident="_"
      e add (instruction (the_function parse_some_spaces Parser) p)
      i := i+1
    eif e:i:ident="pattern" and e:i:size=1 and (e:i:0 cast Str)
      e suckup e:i:0
      e add (instruction (the_function parse_a_pattern Parser Str) p e:i:0:result)
      i := i+1
    eif e:i:ident="any"
      if e:i:size=0
        var Link:Argument drop :> argument_local Str
        e add (instruction (the_function parse_an_str Parser Str) p drop)
      eif e:i:size=1 and (e:i:0 cast Str)
        e suckup e:i:0
        e add (instruction (the_function parse_an_str Parser Str) p e:i:0:result)
      i := i+1
    eif (e:i constant Str)<>null
      e suckup e:i
      e add (instruction (the_function parse_a_pattern Parser Str) p e:i:result)
      i := i+1
    eif (e:i cast Int)
      e suckup e:i
      e add (instruction (the_function parse_an_int Parser Int) p e:i:result)
      i := i+1
  e add (instruction (the_function parse_end Parser -> CBool) p r)
  e set_result r access_read

# streams

type Stream
  field Int handle
  field CBool some_cached ; field Int cache
  field Int line_number

method s open filename flags
  arg_rw Stream s ; arg Str filename ; arg Int flags
  s some_cached := false ; s cache := 0
  if (filename 0 5)="file:"
    s handle := file_open (filename 5 filename:len) flags
    error "attempted to access file "+filename
    s handle := -1
  s line_number := 1

method s writeline line
  arg_rw Stream s ; arg Str line
  file_write s:handle line:characters line:len
  file_write s:handle "[lf]":characters 1
method s close
  arg_rw Stream s
  file_close s:handle

method s atend -> c
  arg_rw Stream s ; arg CBool c
  if s:some_cached
    c := false
    s some_cached := (file_read s:handle (addressof s:cache) 1)=1
    c := not s:some_cached
method s readline -> l
  arg_rw Stream s ; arg Str l
  s line_number := s:line_number+1
  l := ""
  while not s:atend
    s some_cached := false
    if s:cache=10
      l := l+" "
      memory_copy (addressof s:cache) (l:characters translate Byte l:len-1) 1

constant in 1
constant out 2

function file_os_name filename -> osname
  arg Str filename osname
  if (filename 0 5)="file:"
    osname := filename 5 filename:len
    error "unsupported filename "+filename
    osname := ""

# debugger

method s '+=' sub
  arg_rw Str s ; arg Str sub
  s := s+sub

method l '+=' s
  arg_rw List l ; arg Str s
  l append addressof:(new Str s)

method l '+=' sub
  arg_rw List l ; arg List sub
  var Pointer:Arrow a :> sub first
  while a<>null
    l append a
    a :> sub next a

function is_hexa hexa binary high_indian maxi -> h
  arg Str hexa ; arg Address binary ; arg CBool high_indian h ; arg Int maxi
  if hexa:len%2<>0 or hexa:len>2*maxi
    return false
  memory_clear binary hexa:len\2
  for (var Int i) 0 hexa:len-1
    var Str c := hexa i 1 ; var Int d
    if c>="0" and c<="9"
      d := c:number-"0":number
    eif c>="A" and c<="F"
      d := 10+c:number-"A":number
    eif c>="a" and c<="f"
      d := 10+c:number-"a":number
      return false
    var Address adr := binary translate Byte (shunt high_indian hexa:len\2-1-i\2 i\2)
    var Int b := 0
    memory_copy adr addressof:b 1
    b := b+(shunt i%2=0 16*d d)
    memory_copy addressof:b adr 1
  h := true

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

if use_kernel_functions

  function os_clone flags stack -> pid
    arg Int flags pid ; arg Address stack
    kernel_function 120
  function os_execve cmd args env -> err
    arg Address cmd ; arg Address args env ; arg Int err
    kernel_function 11

  function os_waitpid pid status options -> pid2
    arg Int pid pid2 options ; arg_w Int status
    kernel_function 7

  function os_exit retcode
    arg Int retcode
    kernel_function 1

  function os_getpid -> pid
    arg Int pid
    kernel_function 20

  function os_mkdir path mode -> err
    arg Address path ; arg Int mode ; arg Int err
    kernel_function 39

  function os_rmdir path -> err
    arg Address path ; arg Int err
    kernel_function 40

  function os_chmod path mode -> err
    arg Address path ; arg Int mode ; arg Int err
    kernel_function 15

  function os_stat filename stat -> err
    arg Address filename ; arg Address  stat ; arg Int err
    kernel_function 106

  function os_unlink filename -> err
    arg Address filename ; arg Int err
    kernel_function 10

  gvar Address args
  constant stack_size 65536
  function execute1 cmd -> retcode
    arg Str cmd ; arg Int retcode
    args := memory_allocate (cmd:len+1)*Address:size null
    var Int nb := 0
    var Int base := 0
    for (var Int i) 0 cmd:len
      if i=cmd:len or cmd:i=" "
        if i>base
          var Pointer:Address arg :> (args translate Address nb) map Address
          arg := memory_allocate i-base+1 args
          for (var Int j) base i-1
            memory_copy (cmd:characters translate Byte j) (arg translate Byte j-base) 1
          memory_clear (arg translate Byte i-base) 1
          nb := nb+1
        base := i+1
    (args translate Address nb) map Address := null
    var Address stack := memory_allocate stack_size null
    if stack=null
      return -1
    var Int pid := os_clone 0 (stack translate Byte stack_size-256)
    if pid=0
      os_execve (args map Address) args linux_process_env
      os_exit 99
    eif pid=(-1)
      retcode := -1
      var Int status := 0
      os_waitpid pid status 127*256^3+256^3
      retcode := status\256%256
    memory_free stack
    for (var Int i) 0 nb-1
      memory_free ((args translate Address i) map Address)
    memory_free args

  gvar List paths
  paths append addressof:(new Str "/bin/")
  paths append addressof:(new Str "/sbin/")
  paths append addressof:(new Str "/usr/bin/")
  paths append addressof:(new Str "/usr/sbin/")
  paths append addressof:(new Str "/usr/local/bin/")
  paths append addressof:(new Str "/usr/local/sbin/")

  function execute cmd -> retcode
    arg Str cmd ; arg Int retcode
    if (cmd 0 1)<>"/"
      var Address buf := memory_allocate 1024 null
      var Pointer:Arrow a :> paths first
      while a<>null
        var Str filename := (a map Str)+(cmd 0 (cmd search " " cmd:len))+"[0]"
        if (os_stat filename:characters buf)=0
          memory_free buf
          return (execute1 (a map Str)+cmd)
        a :> paths next a
      memory_free buf
      retcode := 99
      retcode := execute1 cmd


  function os_getpid -> pid
    arg Int pid
    external os_libc_filename "getpid"

  function os_mkdir path mode -> err
    arg Address path ; arg Int mode ; arg Int err
    external os_libc_filename "mkdir"

  function os_rmdir path -> err
    arg Address path ; arg Int err
    external os_libc_filename "rmdir"

  function os_chmod path mode -> err
    arg Address path ; arg Int mode ; arg Int err
    external os_libc_filename "chmod"

  function os_system cmd -> ret
    arg Address cmd  ; arg Int ret
    external os_libc_filename "system"

  function os_unlink filename -> ret
    arg Address filename ; arg Int ret
    external os_libc_filename "unlink"

if false

  gvar Str temp_path := ""
  function file_temporary -> name
    arg Str name
    var Int try_count := 0
    while temp_path=""
      temp_path := "file:/tmp/pliant"+'convert to string':os_getpid+"_gcc"+'convert to string':try_count+"/"
      var Str os_temp := (temp_path 5 temp_path:len)+"[0]"
      if (os_mkdir os_temp:characters 7*8^2)<>0
        temp_path := "" ; try_count := try_count+1
    name := temp_path+"gcc.c"
  function file_delete filename
    arg Str filename
    if (filename 0 6)="file:/"
      var Str os_name := (filename 5 filename:len)+"[0]"
      os_unlink os_name:characters
      var Str os_temp := (temp_path 5 temp_path:len)+"[0]"
      if (os_rmdir os_temp:characters)=0
        temp_path := ""

  function reset_gcc parameter filehandle
    arg Address parameter ; arg Int filehandle
    temp_path := ""
  gvar DelayedAction da
  da function :> the_function reset_gcc Address Int
  pliant_restore_actions append addressof:da
  reset_gcc null 0

  function file_temporary -> name
    arg Str name
    name := "file:/tmp/pliant_"+string:os_getpid+"_gcc.c"
  function file_delete filename
    arg Str filename
    if (filename 0 6)="file:/"
      var Str os_name := (filename 5 filename:len)+"[0]"
      os_unlink os_name:characters

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

function query_gcc_version -> version
  arg Int version
  if use_kernel_functions
    version := 2095002
    var Str temp := file_temporary
    os_system (gcc_executable+" -v 2>"+file_os_name:temp+"[0]"):characters
    (var Stream lst) open temp in
    while not lst:atend
      var Str l := lst readline
      if (l parse "gcc" "version" (var Int major) "." (var Int minor) "." (var Int patch) any:(var Str drop)) 
        version := major*1000^2+minor*1000+patch
        if trace
          console "gcc version is "+string:version+"[lf]"
    file_delete temp

function query_as_version -> version
  arg Int version
  if use_kernel_functions
    version := 2009005
    var Str empty := file_temporary
    (var Stream lst) open empty out
    lst close
    var Str temp := file_temporary
    os_system ("as -v "+file_os_name:empty+" 2>"+file_os_name:temp+"[0]"):characters
    (var Stream lst) open temp in
    while not lst:atend
      var Str l := lst readline
      if (l parse "GNU" "assembler" "version" (var Int major) "." (var Int minor) "." (var Int patch) any:(var Str drop)) 
        version := major*1000^2+minor*1000+patch
        if trace
          console "as version is "+string:version+"[lf]"
    file_delete temp
    file_delete empty

constant gcc_version query_gcc_version
constant as_version query_as_version

# ---------------------------------------------------------------------------
#    special C functions
# ---------------------------------------------------------------------------

function c_inline fun text
  arg Function fun ; arg Str text
  gcc_inline_functions define addressof:fun null addressof:(new Str text)

c_inline (the_function 'do nothing') "/* nop */"
c_inline (the_function 'compare' Int Int -> Int) "$3 = $1<$2 ? "+string:compare_inferior+" : $1>$2 ? "+string:compare_superior+" : "+string:compare_equal+";"
c_inline (the_function 'compare' Address Address -> Int) "$3 = $1<$2 ? "+string:compare_inferior+" : $1>$2 ? "+string:compare_superior+" : "+string:compare_equal+";"
# FIXME c_inline (the_function 'compare' Address Address -> Int) "$3 = $1=$2 ? "+string:compare_equal+" : "+string:compare_different+";"
c_inline (the_function 'compare apply mode' Int Int -> CBool) "$3 = $1 & $2;"
c_inline (the_function 'jump anyway') "goto $label;"
c_inline (the_function 'jump if' CBool) "if($1) goto $label;"
c_inline (the_function 'jump if not' CBool) "if(!$1) goto $label;"
c_inline (the_function 'not' CBool -> CBool) "$2 = ! $1;"

c_inline (the_function '+' Int Int -> Int) "$3 = $1 + $2;"
c_inline (the_function '-' Int Int -> Int) "$3 = $1 - $2;"
c_inline (the_function '*' Int Int -> Int) "$3 = $1 * $2;"
c_inline (the_function '\' Int Int -> Int) "$3 = $1 / $2;"
c_inline (the_function '%' Int Int -> Int) "$3 = $1 % $2;"
c_inline (the_function '.or.' Int Int -> Int) "$3 = $1 | $2;"
c_inline (the_function '.and.' Int Int -> Int) "$3 = $1 & $2;"
c_inline (the_function '.not.' Int -> Int) "$2 = ~ $1;"

c_inline (the_function i386_mov Int Int) "$2 = $1;"
c_inline (the_function 'copy atomic' Int Int) "$2 = $1;"
c_inline (the_function 'address Universal' Universal -> Address) "$2 = (int)@1;"
c_inline (the_function 'translate Universal' Universal Int -> Universal) "$3 = (int)@1+$2;"

function inline_pointers f inline
  arg Function f ; arg_rw Str inline
  if (f:name 0 5)="cast " and f:nb_args_with_result=2
    if (f arg 0):type:name="(Pointer "+(f arg 1):type:name+")" or (f arg 0):type:name="(Link "+(f arg 1):type:name+")"
      inline := "@2 = $1;"

gcc_inline_generators append addressof:(the_function inline_pointers Function Str)
gcc_compare_functions define addressof:(the_function compare Int Int -> Int) null addressof:(new Str "$3 = $1 compare $2;")
gcc_compare_functions define addressof:(the_function compare Address Address -> Int) null addressof:(new Str "$3 = $1 compare $2;")

# ---------------------------------------------------------------------------
#    types / functions and arguments extra methods
# ---------------------------------------------------------------------------

method t is_atomic -> a
  arg Type t ; arg CBool a
  a := ('.and.' t:flags type_flag_atomic)<>0

method t is_scalar -> s
  arg Type t ; arg CBool s
  s := ('.and.' t:flags type_flag_scalar)<>0

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

method f has_result -> r
  arg Function f ; arg CBool r
  r := f:nb_args_with_result>f:nb_args

method f has_byvalue_result -> r
  arg Function f ; arg CBool r
  r := f:has_result and { var Pointer:FunctionPrototype fp :> f arg f:nb_args ; ('.and.' fp:access access_byvalue+access_mapped)<>0 }

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

method a set_byvalue
  arg_rw Argument a
  a user_field := addressof void

method a set_byaddress
  arg_rw Argument a
  a user_field := null

method a byvalue -> v
  arg Argument a ; arg CBool v
  v := a:user_field<>null

# ---------------------------------------------------------------------------
#    required datas
# ---------------------------------------------------------------------------

type CListing
  field List listing
  field Int arguments_count <- 0

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

function c_compatible_name n -> c
  arg Str n c
  c := ""
  for (var Int i) 0 n:len-1
    if n:i>="a" and n:i<="z" or n:i>="A" and n:i<="Z" or n:i>="0" and n:i<="9" and c:len>0 or n:i="_"
      c := c + n:i
  if c=""
    c := "_"

method fp c_prototype -> p
  arg FunctionPrototype fp ; arg Str p
  var Pointer:Type t :> fp type
  if ('.and.' fp:access access_byvalue+access_mapped)<>0
    p := "int"
    p := "int *"

method l c_name a -> n
  arg_rw CListing l ; arg_rw Argument a ; arg Str n
  var Pointer:Arrow c :> a:properties first "pliant gcc name"
  if c<>null
    n := c map Str
    n := "v"+(string l:arguments_count) ; l arguments_count := l:arguments_count+1
    var Link:Str nn :> new Str ; nn := n
    a:properties insert "pliant gcc name" true addressof:nn

method l c_prototype f middle parameters -> p
  arg_rw CListing l ; arg Function f ; arg Str middle ; arg Array parameters  ; arg Str p
  if f:has_byvalue_result
    p := (f arg f:nb_args) c_prototype
    p := "void"
  p := p+" "+middle+"("
  var CBool first := true
  for (var Int i) 0 f:nb_args-(shunt ('.and.' f:flags function_flag_indirect)<>0 2 1)
    if not first
      p := p+","
    p := p+(f arg i):c_prototype
    if parameters:size>i
      p := p+" "+(l c_name (parameters:i map Argument))
      if ('.and.' (f arg i):access access_byvalue)=0
        (parameters:i map Argument) set_byaddress
    first := false
  if f:has_result and not f:has_byvalue_result
    if not first
      p := p+","
    p := p+(f arg f:nb_args):c_prototype
    if parameters:size>f:nb_args
      p := p+" "+(l c_name ((parameters f:nb_args) map Argument))
      if ('.and.' (f arg f:nb_args):access access_byvalue)=0
        (parameters:(f:nb_args) map Argument) set_byaddress
  if ('.and.' f:flags function_flag_external+function_flag_varargs)<>0 and not first
    p := p+",..."
  p := p+")"

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

function hexa i -> h
  arg Int i ; arg Str h
  if i<0
    var Int low := 0 ; memory_copy addressof:i addressof:low 2
    var Int high := 0 ; memory_copy (addressof:i translate Byte 2) addressof:high 2
    h :=  hexa low
    h := hexa:high+("000" 0 4-h:len)+h
  eif i<16
    h := ("0123456789ABCDEF" i 1)
    h := (hexa i\16)+(hexa i%16)

function c_hexa a -> n
  arg Address a ; arg Str n
  n := "0x"+hexa:(cast a Int)

method l c_arg a byvalue -> n
  arg_rw CListing l ; arg_rw Argument a ; arg CBool byvalue ; arg Str n
  if a:where=argument_constant
    if byvalue
      n := string (a:constant map Int)
      if n="?"
        n := c_hexa (a:constant map Address)
      n := "(int *)"+(c_hexa a:constant)
  eif a:where=argument_local or a:where=0 # where=0 is for parameters
    n := (shunt not byvalue and a:byvalue "&" "")+(shunt byvalue and not a:byvalue "*" "")+(l c_name a)
  eif a:where=argument_indirect
    var Str p
    p := l c_arg a:pointer true
    if a:offset=0
      n := (shunt byvalue "*" "")+"(int *)"+p
    eif a:offset%Int:size=0
      n := (shunt byvalue "*" "")+"((int *)"+p+"+"+(string a:offset\Int:size)+")"
      n := (shunt byvalue "*" "")+"(int *)((char *)"+p+"+"+(string a:offset)+")"
    error "unsupported argument"

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

method i c_label -> n
  arg Instruction i ; arg Str n
  if i:order>=0
    n := "l"+(string i:order)
    n := "ll"+(string -(i:order))

function auto_inline f inline fun
  arg Function f ; arg_rw Str inline ; arg Function fun

function c_inline f -> inline
  arg Function f ; arg Str inline
  if (gcc_inline_functions query addressof:f null)<>null
    inline := (gcc_inline_functions query addressof:f null) map Str
    inline := ""
    var Pointer:Arrow a :> gcc_inline_generators first
    while a<>null
      auto_inline f inline (a map Function)
      if inline:len>0
      a :> gcc_inline_generators next a

method f is_gcc_simple_function -> c
  arg Pointer:Function f ; arg CBool c
  if ('.and.' f:flags function_flag_has_side_effects+function_flag_later)<>0
    return false
  if f:executable=null
    return false
  for (var Int i) 0 f:nb_args_with_result-1
    if ('.and.' (f arg i):access access_byvalue)=0
      return false
    if ('.and.' (f arg i):type:flags type_flag_mapper)<>0
      return false
  c := true

method l c_instruction instr prototypes header gc -> s
  arg_rw CListing l ; arg_rw Instruction instr ; arg_rw Relation prototypes ; arg_rw List header ; arg_rw GeneratorContext gc ; arg Str s
  var Pointer:Function f :> instr function
  if (gcc_inline_instructions query addressof:instr null)<>null
    s := (gcc_inline_instructions query addressof:instr null) map Str
    gcc_inline_instructions define addressof:instr null null
    s := c_inline f
  if s<>""
    for (var Int i) 0 f:nb_args_with_result-1
      if (s search "$"+(string i+1) -1)<>-1
        s := replace s "$"+(string i+1) (l c_arg instr:i true)
      if (s search "@"+(string i+1) -1)<>-1
        s := replace s "@"+(string i+1) (l c_arg instr:i false)
    if (addressof instr:jump)<>null
      s := replace s "$label" instr:jump:c_label
    if (addressof f:generate_assembly)<>null
      error "assembly function "+f:name
    if ('.and.' f:flags function_flag_kernel)<>0
      s := "asm volatile ( [dq]int $0x80[dq] :"
      if f:has_byvalue_result
        s '+=' " [dq]=a[dq] ("
        s '+=' (l c_arg instr:(f:nb_args) ('.and.' (f arg f:nb_args):access access_byvalue)<>0)
        s '+=' ")"
      s '+=' " :"
      var Int i8 := 0
      memory_copy (f:executable translate Byte 1) addressof:i8 1
      s '+=' " [dq]"+(shunt f:has_byvalue_result "0" "a")+"[dq] ("+string:i8+")"
      for (var Int i) 0 f:nb_args-1
        s '+=' " , [dq]"+"bcdSD":i+"[dq] ("
        s '+=' (l c_arg instr:i ('.and.' (f arg i):access access_byvalue)<>0)
        s '+=' ")"
      s '+=' ");"
      s := ""
      if f:has_byvalue_result
        var Pointer:Argument a :> instr f:nb_args
        var Pointer:FunctionPrototype fp :> f arg f:nb_args
        if ('.and.' fp:access access_mapped)<>0
          if a:where<>argument_indirect or a:offset<>0
            error "expected an indirect result"
            s '+=' (l c_arg a:pointer true)+" = "
          s '+=' (l c_arg a true)+" = "
      if ('.and.' f:flags function_flag_generic)<>0
        var Int offset := Type:size-pliant_nb_generic_indices*2*Int:size
        var Str adroftype :="((int *)"+(l c_arg instr:0 false)+")[lb]-1[rb]"
        var Str ptrfunexe := "((int *)"+adroftype+")[lb]"+(string (offset+f:generic_index*2*Int:size)\Int:size)+"[rb]"
        s '+=' "(("+(l c_prototype f "(*)" (var Array empty_parameters))+")("+ptrfunexe+"))"
      eif ('.and.' f:flags function_flag_indirect)<>0
        s '+=' "(("+(l c_prototype f "(*)" (var Array empty_parameters))+")"
        s '+=' "*"+(l c_arg instr:(f:nb_args-1) false)
        s '+=' ")"
        var Str fname := (c_hexa f:executable) 2 8 ; fname := "f"+((c_hexa addressof:f) 2 999)+"_"+("00000000" 0 8-fname:len)+fname
        if addressof:f=(addressof gc:function)
          fname := "foo"
        if (prototypes query addressof:f null)=null
          var Str attributs := ""
          if f:is_gcc_simple_function
            attributs '+=' " __attribute__ ((const))"
          header '+=' (l c_prototype f fname (var Array empty_parameters))+attributs+";     // "+f:name+" "+f:position
          prototypes define addressof:f null addressof:f
        s '+=' fname
      s '+=' "("
      var CBool first := true
      for (var Int i) 0 (shunt f:has_byvalue_result f:nb_args f:nb_args_with_result)-1
        if ('.and.' f:flags function_flag_indirect)=0 or i<>f:nb_args-1
          if not first
            s '+=' ","
          s '+=' (l c_arg instr:i ('.and.' (f arg i):access access_byvalue)<>0)
          first := false
      s '+=' ")"
      if (addressof instr:jump)<>null
        s '+=' " goto "+instr:jump:c_label
      s '+=' ";"

# ---------------------------------------------------------------------------
#    generating the C listing
# ---------------------------------------------------------------------------

function quoted_ident string -> id
  arg Str string ; arg Str id
  for (var Int i) 0 string:len-1
    var Str c := string i
    if not ( c>="a" and c<="z" or c>="A" and c<="Z" or c>="0" and c<="9" and i>0 or c="_")
      return "'"+string+"'"
  return (shunt string<>"" string "''")

method l generate_c_listing gc
  arg_rw CListing l ; arg_rw GeneratorContext gc
  var Pointer:Arrow c :> gc:arguments first
  while c<>null
    var Pointer:Argument a :> c map Argument
    a set_byvalue
    c :> gc:arguments next c
  var Pointer:Function fun :> gc function
  var Pointer:Array parameters :> (gc:module first "pliant arguments") map Array
  var List header variables init terminate body ; var Relation prototypes
  if addressof:(entry_type addressof:fun)<>addressof:Meta
    var Str p := "function "+(quoted_ident fun:name)
    for (var Int i) 0 fun:nb_args-1
      p := p+" "+(fun arg i):name
    if fun:nb_args_with_result>fun:nb_args
      p := p+" -> "+(fun arg fun:nb_args):name
    header '+=' "// "+p
    var Str p := "  "
    for (var Int i) 0 fun:nb_args_with_result-1
      p := p+(shunt i=0 "" " ; ")+"arg "+(fun arg i):type:name+" "+(fun arg i):name
    header '+=' "// "+p
    header '+=' "// meta "+(quoted_ident fun:name)+" "+(fun arg 0):name
  header '+=' "//"
  header '+=' "// "+fun:position
  header '+=' ""
  variables '+=' ""
  variables '+=' (l c_prototype fun "foo" parameters)
  variables '+=' "{"
  if (gcc_inline_functions query addressof:fun null)=null
    var Pointer:Arrow c :> gc:arguments first
    while c<>null
      var Pointer:Argument a :> c map Argument
      var Int i := 0
      while i<parameters:size and parameters:i<>addressof:a and ( (parameters:i map Argument):where<>argument_indirect or (addressof (parameters:i map Argument):pointer)<>addressof:a )
        i := i+1
      if i<fun:nb_args
        if ('.and.' (fun arg i):access access_byvalue)=0
          a set_byaddress
      eif a:where=argument_local or a:where=argument_register or a:where=argument_a_register
        var Str s
        if a:type:is_atomic
          s := "int "+(l c_name a)+";"
          s := "int "+(l c_name a)+"[lb]"+(string (a:type:size+Int:size-1)\Int:size)+"[rb];"
          a set_byaddress
        if gcc_verbose
          s '+=' "     // type "+a:type:name
        variables '+=' s
        if not a:type:is_scalar
          var Pointer:Function f :> the_function '. build_instance' Type Address
          s := "((void (*)(int *,int *))"+(c_hexa f:executable)+")"
          s '+=' "((int *)"+c_hexa:(addressof a:type)+","+(l c_arg a false)+");"
          init '+=' s
          f :> the_function '. destroy_instance' Type Address
          var Str s := "((void (*)(int *,int *))"+(c_hexa f:executable)+")"
          s '+=' "((int *)"+c_hexa:(addressof a:type)+","+(l c_arg a false)+");"
          terminate '+=' s
      eif fun:has_byvalue_result and addressof:a=(parameters fun:nb_args)
        variables '+=' "int "+(l c_name a)+";"
      c :> gc:arguments next c
    var Pointer:Instruction instr :> gc first_instruction
    while addressof:instr<>null
      var Pointer:Function f :> instr function
      if instr:backward_jumps:first<>null
        body '+=' instr:c_label+":"
      var Str s := l c_instruction instr prototypes header gc
      if (gcc_compare_functions query addressof:f null)<>null
        var Pointer:Instruction instr2 :> instr next_instruction
        if addressof:instr2<>null
          var Pointer:Function f2 :> instr2 function
          if addressof:f2=addressof:(the_function 'compare apply mode' Int Int -> CBool)
            var Pointer:Argument a :> instr 2
            if (addressof a:first_instruction)=addressof:instr and (addressof a:last_instruction)=addressof:instr2
              if instr2:1:where=argument_constant
                var Int mode := instr2:1:constant map Int
                var Str cmp
                if mode=1
                  cmp := "<"
                eif mode=2
                  cmp := "=="
                eif mode=4
                  cmp := ">"
                eif mode=3
                  cmp := "<="
                eif mode=5 or mode=13
                  cmp := "!="
                eif mode=6
                  cmp := ">="
                  cmp := ""
                if cmp<>""
                  s := (gcc_compare_functions query addressof:f null) map Str
                  s := replace s "compare" cmp
                  for (var Int i) 0 2
                    var Pointer:Argument ii
                    if i<2
                      ii :> instr i
                      ii :> instr2 i
                    if (s search "$"+(string i+1) -1)<>-1
                      s := replace s "$"+(string i+1) (l c_arg ii true)
                    if (s search "@"+(string i+1) -1)<>-1
                      s := replace s "@"+(string i+1) (l c_arg ii false)
                  instr :> instr2
      if s<>""
        if gcc_verbose
          s '+=' "     // "+instr:function:name+" "+instr:position
        body '+=' s
      instr :> instr next_instruction
    if fun:has_byvalue_result and (addressof ((parameters fun:nb_args) map Argument):first_instruction)<>null
      terminate '+=' "return "+(l c_name ((parameters fun:nb_args) map Argument))+";"
    s := (gcc_inline_functions query addressof:fun null) map Str
    for (var Int i) 0 fun:nb_args_with_result-1
      var Pointer:Argument a :> parameters:i map Argument
      if ('.and.' (fun arg i):access access_byvalue)<>0
        a set_byvalue
        a set_byaddress
      if (s search "$"+(string i+1) -1)<>-1
        s := replace s "$"+(string i+1) (l c_arg a true)
      if (s search "@"+(string i+1) -1)<>-1
        s := replace s "@"+(string i+1) (l c_arg a false)
    body '+=' s
    if fun:has_byvalue_result
      var Pointer:Argument a :> (parameters fun:nb_args) map Argument
      variables '+=' "int "+(l c_name a)+";"
      terminate '+=' "return "+(l c_name a)+";"
  terminate '+=' "}"
  l:listing '+=' header ; l:listing '+=' variables ; l:listing '+=' init ; l:listing '+=' body ; l:listing '+=' terminate
  var Pointer:Arrow c :> gc:arguments first
  while c<>null
    var Pointer:Argument a :> c map Argument
    a user_field := null
    c :> gc:arguments next c

method l write filename
  arg CListing l ; arg Str filename
  var List full
  (var Stream s) open filename out
  var Pointer:Arrow c :> l:listing first
  while c<>null
    s writeline (c map Str)
    c :> l:listing next c
  s close

# ---------------------------------------------------------------------------
#    calling gcc
# ---------------------------------------------------------------------------

function c_compile filename -> ok
  arg Str filename ; arg CBool ok
  var Str c_compiler_program := gcc_executable
  var Str c_compiler_options := ""
  c_compiler_options '+=' " -O2 -m486"
  if os_api="linux"
    c_compiler_options '+=' " -mregparm=3 -mrtd"
  if pliant_debugging_level_variable=0
    c_compiler_options '+=' " -fomit-frame-pointer"
    c_compiler_options '+=' " -g"
  c_compiler_options '+=' " -Werror"
  c_compiler_options '+=' " -c -Wa,-al="+(replace file_os_name:filename ".c" ".lst")
  if as_version>=2009005
    c_compiler_options '+=' " -pipe"
  var Str cmd := c_compiler_program+c_compiler_options+" -o /dev/null "+file_os_name:filename
  var Int err
  if use_kernel_functions
    err := execute cmd
    err := os_system (cmd+"[0]"):characters
  ok := err=0
  if not ok
    console cmd+"[lf]error code returned is "+'convert to string':err+"[lf]"

# ---------------------------------------------------------------------------
#    installing the compiled code
# ---------------------------------------------------------------------------

method li load_compiled_code filename old_fun -> new_fun
  arg_rw CListing li ; arg Str filename ; arg Function old_fun ; arg_RW Function new_fun
  new_fun :> new Function
  if pliant_debugging_level_variable>0
    var Link:List deb :> new List
    new_fun externals := addressof deb
  (var Stream lst) open (replace filename ".c" ".lst") in
  (var Stream src) open filename in
  var Int const_reserved := 256
  var Address const_buffer := memory_allocate const_reserved null
  var Int const_cursor := 0
  var Int code_reserved := 256
  var Address code_buffer := memory_allocate code_reserved null
  var Int code_cursor := 0
  var List refs calls
  var Int section := 0 ; var Str l2 := ""
  var Str last_position := "" ; var Link:Str last_module :> new Str
  var CBool found := false
  while not lst:atend or l2<>""
    var Str l
    if l2=""
      l := lst readline
      l := l2 ; l2 := ""
    var Int o := 0
    if (l parse (var Int line) _ any:(var Str offset) _ any:(var Str bytes) _ any:(var Str asm)) and (is_hexa offset addressof:o true 4)
      while not lst:atend and { l2 := lst readline ; (l2 parse (var Int line2) any:(var Str extrabytes)) and line2=line or { extrabytes := "" ; not (l2 parse (var Int line2) any) }}
        bytes '+=' extrabytes
      if o<>(shunt section=1 const_cursor (shunt section=2 code_cursor -1))
        error "failed to parse assembly listing (1)[lf]"+l
      if section=1
        var Int n := bytes:len\2
        if const_cursor+n>const_reserved
          const_reserved := const_reserved*2
          const_buffer := memory_resize const_buffer const_reserved null
        if not (is_hexa bytes (const_buffer translate Byte const_cursor) false n)
          error "failed to parse assembly listing (2)[lf]"+l
        const_cursor := const_cursor+n
      eif section=2
        var Int n := bytes:len\2
        if code_cursor+n>code_reserved
          code_reserved := code_reserved*2
          code_buffer := memory_resize code_buffer code_reserved null
        if not (is_hexa bytes (code_buffer translate Byte code_cursor) false n)
          error "failed to parse assembly listing (3)[lf]"+l
        code_cursor := code_cursor+n
        if (asm parse "call" any:(var Str foo))
          var Pointer:Address a :> (code_buffer translate Byte code_cursor-Int:size) map Address
          if (foo search "%" -1)<>(-1)
          eif (foo parse (var Int fixedadr))
            a := cast fixedadr Address
            calls append addressof:(new Int code_cursor-Int:size)
          eif foo="foo"
            a := null
            calls append addressof:(new Int code_cursor-Int:size)
          eif (foo parse "f" any "_" any:(var Str hex)) and (is_hexa hex addressof:a true 4)
            calls append addressof:(new Int code_cursor-Int:size)
            error "unsupported assembly instruction: "+asm
        if (asm parse any ".LC" (var Int i) any)
          refs append addressof:(new Int code_cursor-Int:size)
        eif (asm search ".LC" -1)<>(-1)
          error "unexpected assembly instruction: "+asm
    eif (l parse (var Int line) ".section" ".rodata")
      section := 1
    eif (l parse (var Int line) ".section" any)
      error "unsupported section: "+l
    eif (l parse (var Int line) ".text")
      section := 2
    eif (l parse (var Int line) ".stabn" (var Int i) "," i "," (var Int sline) "," any)
      while src:line_number<sline
        if src:atend
          sline := 0
        l := src readline
      if (l parse any "//" "instruction" (var Int i) _ any)
        var Pointer:Instruction instr :> (cast i Address) map Instruction
        if pliant_debugging_level_variable>0 and instr:position<>last_position
          var Link:DebuggerInstructionRecord r :> new DebuggerInstructionRecord
          r code_offset := code_cursor
          r position := instr position
          deb append addressof:r
          last_position := instr position
    eif (l parse (var Int line) "foo" ":")
      found := true
      if code_cursor<>0
        error "function "+old_fun:name+" "+old_fun:position+" entry point is not at beginning"
  if not found
    error "function "+old_fun:name+" "+old_fun:position+" as no entry point"
  new_fun executable_size := code_cursor+const_cursor
  new_fun executable := memory_allocate new_fun:executable_size null
  if (new_fun:flags\function_flag_allocated_exe)%2=0
    new_fun flags := new_fun:flags+function_flag_allocated_exe
  memory_copy code_buffer new_fun:executable code_cursor
  var Address const_startup := new_fun:executable translate Byte code_cursor
  memory_copy const_buffer const_startup const_cursor
  memory_free const_buffer
  memory_free code_buffer
  var Pointer:Arrow c :> refs first
  while c<>null
    var Pointer:Address a :> (new_fun:executable translate Byte (c map Int)) map Address
    a := a translate Byte (cast const_startup Int)
    c :> refs next c
  var Pointer:Arrow c :> calls first
  while c<>null
    var Pointer:Address a :> (new_fun:executable translate Byte (c map Int)) map Address
    if a=null
      a := new_fun executable
    a := a translate Byte -(cast (addressof:a translate Address 1) Int)
    c :> calls next c
  lst close
  src close  

# ---------------------------------------------------------------------------
#    recording and testing the new feature
# ---------------------------------------------------------------------------

if trace
  gvar Int counter := 0

function generate_c_code gc
  arg_rw GeneratorContext gc
  if not gcc_is_active
  if gc:function:name="_noname_"
  if ('.and.' gc:function:flags function_flag_later+function_flag_varargs+function_flag_external+function_flag_kernel+function_flag_indirect+function_flag_generic)<>0
  var Pointer:Instruction instr :> gc first_instruction
  while addressof:instr<>null
    var Pointer:Function f :> instr function
    if ('.and.' f:flags function_flag_later+function_flag_external)<>0
    if gcc_version<2095000 and ('.and.' f:flags function_flag_kernel)<>0 and f:nb_args>=5
    instr :> instr next_instruction
  if trace
    counter := counter+1
    console string:counter+": "+gc:function:name+"  "+(replace gc:function:position " (internals)" "")+"  "
  var Link:CListing l :> new CListing
  l generate_c_listing gc
  var Str filename := shunt gcc_verbose gcc_listing_filename file_temporary
  l write filename
  var CBool ok := c_compile filename
  var Link:Function new_fun :> l load_compiled_code filename gc:function
  if ok
    if not gcc_verbose
      file_delete filename
      file_delete (replace filename ".c" ".lst")
    error "failed to compile C listing for function "+gc:function:name+" in "+gc:module:name
  gc:locals insert "gcc compiled function" true addressof:new_fun
  var Link:Int flags :> new Int
  flags := gc:function:flags
  gc:locals insert "gcc compiled function flags" true addressof:flags

function use_c_compiled_code gc
  arg_rw GeneratorContext gc
  var Pointer:Arrow c :> gc:locals first "gcc compiled function"
  if c=null
  var Pointer:Function new_fun :> c map Function
  var Pointer:Function f :> gc function
  if gcc_verbose
    console gcc_listing_filename+" "+(string f:executable_size)+"->"+(string new_fun:executable_size)
    if ('.and.' f:flags function_flag_has_side_effects)<>0
      if ('.and.' f:flags function_flag_has_no_side_effect)=0
        console " (has side effects)"
    console "[lf]"
    gcc_verbose := false
  if ('.and.' f:flags function_flag_allocated_exe)<>0
    memory_free f:executable
  if new_fun:flags\function_flag_allocated_exe%2=1
    new_fun flags := new_fun:flags-function_flag_allocated_exe
  f executable := new_fun executable
  f executable_size := new_fun executable_size
  var Pointer:Arrow c :> gc:locals first "gcc compiled function flags"
  if c<>null
    f flags := c map Int
  var Link:List ext :> new List
  if f:externals=null
  eif addressof:(entry_type f:externals)<>addressof:List
    ext append f:externals
    var Pointer:Arrow c :> (f:externals map List) first
    while c<>null
      if (addressof entry_type:c)<>addressof:FunctionExternal and (addressof entry_type:c)<>addressof:DebuggerInstructionRecord and (addressof entry_type:c)<>addressof:DebuggerVariableRecord
        ext append c
      c :> (f:externals map List) next c
  if new_fun:externals=null
  eif addressof:(entry_type new_fun:externals)<>addressof:List
    ext append new_fun:externals
    var Pointer:Arrow c :> (new_fun:externals map List) first
    while c<>null
      ext append c
      c :> (new_fun:externals map List) next c
  f externals := addressof ext
  if false
    console gc:function:name
    var Int total := 0
    for (var Int i) 0 f:executable_size-1
      var Int ch := 0
      memory_copy (f:executable translate Byte i) addressof:ch 1
      console " "+("0123456789ABCDEF" ch\16 1)+("0123456789ABCDEF" ch%16 1)
      total := total+ch
    console " : "+string:total+"[lf]"

function optimizer_section name -> ptr
  arg Str name ; arg Pointer:Arrow ptr
  ptr :> 'pliant optimizer sections' first
  while ptr<>null and (ptr map Str)<>name
    ptr :> 'pliant optimizer sections' next ptr
  if ptr=null
    error "The optimizing section "+name+" does not exist"

function set_new_optimizing_sections
  var Link:Str section1 :> new Str "pliant optimizer wrap to gcc"
  var Link:Str section2 :> new Str "pliant optimizer back from gcc"
  'pliant optimizer sections' insert_before optimizer_section:"pliant optimizer allocate locals" addressof:section1
  'pliant optimizer sections' insert_after optimizer_section:"pliant optimizer conclude" addressof:section2
alias 'pliant optimizer wrap to gcc' generate_c_code in "/pliant/language/optimizer/basic.pli"
alias 'pliant optimizer back from gcc' use_c_compiled_code in "/pliant/language/optimizer/basic.pli"

gcc_is_available := true ; gcc_is_active := true
console "  using GCC optimizer[lf]"