path: root/gcc/melt/ana-simple.melt

;; -*- Lisp -*-
;; file ana-simple.melt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment "
    Copyright 2009 Free Software Foundation, Inc.
    Contributed by Basile Starynkevitch <basile@starynkevitch.net>

    This file is part of GCC.

    GCC is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 3, or (at your option)
    any later version.

    GCC 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
    along with GCC; see the file COPYING3.  If not see
    <http://www.gnu.org/licenses/>.
")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; green transformation
;;; a pass which converts fprintf(stdout, ..) to printf (..)

(defun makegreenpass_gate (pass)
  (debug_msg pass "makegreenpass_gate pass at start")
  ;; always return true
  pass
)

(defclass makegreen_data_class 
  :super class_proped
  :fields (mkgreen_pass 
	   mkgreen_data))

(defun makegreen_transform (grdata :tree decl :basicblock bbent)
  (debug_msg grdata "makegreen_transform start grdata")
  (debugtree "makegreen_transform decl" decl)
  (debugbasicblock "makegreen_transform bbent" bbent)
  (each_bb_cfun 
   ()
   (:basicblock bb :tree decl)
   (debugbasicblock "makegreen_transform bb" bb)
   (eachgimple_in_basicblock 
    (bb)
    (:gimple g)
    (debuggimple "makegreen_transform g" g)
    (match g
	   (?(gimple_call ?lhs ?callfndcl ?nbargs)
	     (debugtree "makegreen_transform call lhs" lhs)
	     (debugtree "makegreen_transform call fndecl" callfndcl)
	     )
	   (?_
	    )
	   )
    )
   )
  (debug_msg grdata "makegreen_transform end grdata")
  )

(defun makegreenpass_exec (pass)
  (debug_msg pass "makegreenpass_exec pass at start")
  (let ( (grdata (instance makegreen_data_class 
			   :mkgreen_pass pass)) )
    (debug_msg grdata "makegreenpass_exec grdata")
    (each_cgraph_fun_entryblock
     ()
     (:tree decl :basicblock bbent)
     (push_cfun_decl decl)
     (debugtree "makegreenpass_exec exec eachcgraph decl" decl)
     (debugbasicblock "makegreenpass_exec bbent" bbent) 
     (shortbacktrace_dbg "makegreenpass_exec" 24)
     ;; do something useful here
     (if bbent
	 (makegreen_transform grdata decl bbent))
     (pop_cfun)
     )
    (debug_msg pass "makegreenpass_exec pass at end")
    ))

(defun makegreen_command (dispatcher arg secarg moduldata)
  (let ( (greenpass
	  (instance class_gcc_simple_ipa_pass
		    :named_name (make_stringconst discr_string "melt_greenpass")
		    :gccpass_gate makegreenpass_gate
		    :gccpass_exec makegreenpass_exec
		    :gccpass_properties_required ()
	      )
        ) )
 ;;; register our pass after the "pta" pass 
  (install_melt_gcc_pass greenpass "after" "pta" 0)
  ;;; note, register it after "ccp" does not work...
  (debug_msg greenpass "makegreen_command installed greenpass")
;; return the greenpass to accept the command
  (return greenpass)
))
(initial_command_install makegreen_command "makegreen")




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; small analysis

(defclass class_smallcfun
  :super class_named
  :fields (scfun_decl
	   scfun_entbb
	   ))

(defclass class_smallbb
  :super class_proped
  :fields (sbb_bbcont
	   ))

(defclass class_smallanalysis 
  :super class_analysis_state
  :fields (sman_cfuns			;list of class_smallcfun-s
	   sman_cfundict		;dict of class_smallcfun-s
	   sman_cfuntreemap		;treemap of class_smallcfun-s
	   sman_bbtable			;hashtable bb -> class_smallbb
	   ))

(defclass class_smallabstractenv
  :super class_proped
  :fields (abenv_maptree		;a maptree C ident -> abstract values
	   abenv_parenv			;the parent abstract env
	   abenv_pplpoly		;the PPL polyhedron
	   abenv_vectrees		;the vector naming PPL variables as trees
))

(defun put_abstrenv (abenv :tree tr :value val)
  (assert_msg "check abenv" (is_a abenv class_smallabstractenv))
  (assert_msg "check tr" tr)
  (maptree_put (get_field :abenv_maptree abenv) tr val)
)

(defun get_abstrenv (abenv :tree tr)
  (assert_msg "check abenv" (is_a abenv class_smallabstractenv))
  (maptree_get (get_field :abenv_maptree abenv) tr)
)

(defun fresh_abstrenv (abpar)
  (assert_msg "check abpar" (is_a abpar class_smallabstractenv))
  (let ( (newabenv (instance class_smallabstractenv
			     :abenv_maptree (make_maptree discr_maptrees 10)
			     :abenv_parenv abpar)) )
    (return newabenv)
))

;;; find a tree inside a small abstract env - return primarily the
;;; boxed tree and secondly its index
(defun find_tree_smallabstractenv (abenv :tree tr)
  (debug_msg abenv "find_tree_smallabstractenv abenv")
  (debugtree "find_tree_smallabstractenv tr" tr)
  (assert_msg "check abenv" (is_a abenv class_smallabstractenv))
  (let ( (:long ix -1)
	 (btree ()) 
	 (varvect (get_field :abenv_vectrees abenv))
	 (:long curix 0)
	 (:long vectlen (multiple_length varvect))
	 )
    (forever 
     loop
     (if (>=i curix vectlen) (exit loop))
     (let ( (curcomp (multiple_nth varvect curix)) )
       (if (==t (tree_content curcomp) tr)
	   (progn
	     (debug_msg curcomp "find_tree_smallabstractenv return curcomp")
	     (return curcomp curix))
	 )
       (setq curix (+i curix 1))
       )))
  (debug_msg () "find_tree_smallabstractenv return NIL")
  (return)
  )

(defun dbgout_smallabstractenv (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
  (assert_msg "check self" (is_a self class_smallabstractenv))
  (let ( (dis (discrim self)) 
	 (out (unsafe_get_field :dbgi_out dbgi)) 
	 (:long oserial (obj_serial self))
	 (:long onum (obj_num self)) 
	 ) 
    (add2sbuf_strconst out "|")
    (add2sbuf_string out (get_field :named_name dis))
    (add2sbuf_strconst out "/")
    (add2sbuf_longhex out (obj_hash self))
    (if onum
	(progn
	  (add2sbuf_strconst out "#")
	  (add2sbuf_longdec out onum)))
    (if oserial
	(progn
	  (add2sbuf_strconst out "##")
	  (add2sbuf_longdec out oserial)))
    (add2sbuf_strconst out "{")
    (let ( (:long offpar (get_int abenv_parenv)) 
	   (:long offvnam (get_int abenv_vectrees)) 
	   (:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	   (:long newmaxdepth  (-i (/i oldmaxdepth 2) 1))
	   )
      (if (<i newmaxdepth 0) (setq newmaxdepth 0))
      (if (need_dbglim depth oldmaxdepth)
	  (progn
	    (and (>i depth 0) (>i oldmaxdepth 3)
		 (put_int (unsafe_get_field :dbgi_maxdepth dbgi) newmaxdepth))
	    (dbgout_fields self dbgi (+i depth 1) 0 offpar)
					;(add2sbuf_indentnl out depth)
	    (let ( (polyv (get_field :abenv_pplpoly self)) )
	      (if polyv
		  (progn
		    (add2sbuf_strconst out "@ppl.poly@[")
		    (ppl_ppstrbuf out 
				  (get_field :abenv_pplpoly self)
				  depth 
				  (get_field :abenv_vectrees self))
		    (add2sbuf_strconst out "]@"))
		(add2sbuf_strconst out "@ppl.poly*nil*")))
	    (add2sbuf_indentnl out depth)
	    (if (need_dbglim (+i depth 2) newmaxdepth)
		(dbgout_fields self dbgi (+i depth 2) offvnam -1)
	      (add2sbuf_strconst out ".._.."))
	    (put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth)
	    )))
    (add2sbuf_strconst out "}")
    )
  )
(install_method class_smallabstractenv dbg_output dbgout_smallabstractenv)

(definstance initial_smallabstractenv class_smallabstractenv
  :abenv_maptree (make_maptree discr_maptrees 20))

(definstance smallana_cont class_container)


(defun smallana_cfun_entbb (sman :tree decltree :basicblock bbent)
  (debug_msg sman "smallana_cfun_entbb sman")
  (debugtree "smallana_cfun_entbb start decltree" decltree)
  (match 
   decltree
   ;; the joker below is acutally nil
   ( ?(tree_function_decl ?funam ?(tree_block ?treevars ?_))
      (debugtree "smallana_cfun_entbb treevars of function" treevars)
      (push_cfun_decl decltree)
      ;;;;;
      (each_param_in_fundecl
       (decltree)
       (:tree argdtree)
       (debugtree "smallana_cfun_entbb argdtree" argdtree)
       (match 
	argdtree
	( ?(tree_parm_decl
	    ?(as ?argdtype 
		 ?(tree_integer_type ?typname ?bigmin ?bigmax ?isiz)) ?argdcl ?argname)
	   (debugtree "smallana_cfun_entbb integer argdtype" argdtype)
	   (debugcstring "smallana_cfun_entbb integer argname" argname)
	   (debugcstring "smallana_cfun_entbb integer typname" typname)
	   (debug_msg bigmin "smallana_cfun_entbb integer bigmin")
	   (debug_msg bigmax "smallana_cfun_entbb integer bigmax")
	   )
	( ?(tree_parm_decl ?argdtype ?argdcl ?argname)
	   (debugtree "smallana_cfun_entbb argdtype" argdtype)
	   (debugtree "smallana_cfun_entbb argdcl" argdcl)
	   (debugcstring "smallana_cfun_entbb argname" argname)
	   )
	( ?_ 
	  ;; (assert_msg "unexpected argdtree" ())	  
	  (shortbacktrace_dbg "unexpected tree in smallana_cfun_entbb" 12)
	  )
	)
       (debugtree "smallana_cfun_entbb argdecltree" argdtree)
       )
      ;;;;
      (let ( (fname (make_stringconst discr_string funam)) 
	    (scf (instance class_smallcfun
			    :named_name fname
			    :scfun_decl (make_tree discr_tree decltree)
			    :scfun_entbb (make_basicblock discr_basicblock bbent)))
	     )
	(debug_msg fname "smallana_cfun_entbb fname")
	(list_append (get_field :sman_cfuns sman) scf)
	(mapstring_putstr (get_field :sman_cfundict sman) fname scf)
	(maptree_put (get_field :sman_cfuntreemap sman) decltree scf)
	)
      (pop_cfun)
      )
   ( ?(tree_variable_decl ?_)
      (debugtree  "smallana_cfun_entbb decl of variable" decltree)
      (inform_at_tree decltree "smallana: global variable not analyzed")
      )
   ( ?_
     (debugtree "smallana_cfun_entbb other decl" decltree)
     (inform_at_tree decltree "smallana: other declaration not analyzed")
     ;; (assert_msg "smallana_cfun_entbb @$@UNIMPLEMENTED DECL" ())
     (shortbacktrace_dbg "smallana_cfun_entbb unexepcted declree" 14)
     () )
   )
  (debug_msg sman "smallana_cfun_entbb sman")
  )


(defun smallana_gimple (sman :gimple g)
  (debuggimple "smallana_gimple gimple" g)
  (match 
   g
   ( ?(gimple_assign_single ?lhs ?rhs)
      (debugtree "smallana_gimple gimple_assign_single lhs" lhs)
      (debugtree "smallana_gimple gimple_assign_single rhs" rhs)
      )
   ( ?(gimple_assign_cast ?lhs ?rhs)
      (debugtree "smallana_gimple gimple_assign_cast lhs" lhs)
      (debugtree "smallana_gimple gimple_assign_cast rhs" rhs)
      )
   ( ?(gimple_assign_copy ?lhs ?rhs)
      (debugtree "smallana_gimple gimple_assign_copy lhs" lhs)
      (debugtree "smallana_gimple gimple_assign_copy rhs" rhs)
      )
   ( ?(gimple_assign_ssa_name_copy ?lhs ?rhs)
      (debugtree "smallana_gimple gimple_assign_ssa_name_copy lhs" lhs)
      (debugtree "smallana_gimple gimple_assign_ssa_name_copy rhs" rhs)
      )
   ( ?(gimple_assign_unary_nop ?lhs ?rhs)
      (debugtree "smallana_gimple gimple_assign_unary_nop lhs" lhs)
      (debugtree "smallana_gimple gimple_assign_unary_nop rhs" rhs)
      )
   ( ?(gimple_assign_plus ?lhs ?rhs1 ?rhs2)
      (debugtree "smallana_gimple gimple_assign_plus lhs" lhs)
      (debugtree "smallana_gimple gimple_assign_plus rhs1" rhs1)
      (debugtree "smallana_gimple gimple_assign_plus rhs2" rhs2)
      )
   ( ?(gimple_assign_pointerplus ?lhs ?rhs1 ?rhs2)
      (debugtree "smallana_gimple gimple_assign_pointerplus lhs" lhs)
      (debugtree "smallana_gimple gimple_assign_pointerplus rhs1" rhs1)
      (debugtree "smallana_gimple gimple_assign_pointerplus rhs2" rhs2)
      )
   ( ?(gimple_assign_mult ?lhs ?rhs1 ?rhs2)
      (debugtree "smallana_gimple gimple_assign_mult lhs" lhs)
      (debugtree "smallana_gimple gimple_assign_mult rhs1" rhs1)
      (debugtree "smallana_gimple gimple_assign_mult rhs2" rhs2)
      )
   ( ?(gimple_assign_binaryop ?lhs ?rhs1 ?rhs2 ?opcod)
      (debugtree "smallana_gimple gimple_assign_binaryop lhs" lhs)
      (debugtree "smallana_gimple gimple_assign_binaryop rhs1" rhs1)
      (debugtree "smallana_gimple gimple_assign_binaryop rhs2" rhs2)
      (debugtreecodenum  "smallana_gimple gimple_assign_binaryop opcod" opcod)
      ;;(shortbacktrace_dbg "smallana_gimple gimple_assign_binaryop unexpected" 15)
      (assert_msg "smallana_gimple gimple_assign_binaryop unhandled" ())
      )
   ( ?(gimple_cond_lessequal ?lhs ?rhs ?truelab ?falselab)
      (debugtree "smallana_gimple gimple_cond_lessequal lhs" lhs)
      (debugtree "smallana_gimple gimple_cond_lessequal rhs" rhs)
      (debugtree "smallana_gimple gimple_cond_lessequal truelab" truelab)
      (debugtree "smallana_gimple gimple_cond_lessequal falselab" falselab)
      (shortbacktrace_dbg "@$@unimplemented smallana_gimple gimple_cond_lessequal" 15)
      )
   ( ?(gimple_cond_notequal ?lhs ?rhs ?truelab ?falselab)
      (debugtree "smallana_gimple gimple_cond_notequal lhs" lhs)
      (debugtree "smallana_gimple gimple_cond_notequal rhs" rhs)
      (debugtree "smallana_gimple gimple_cond_notequal truelab" truelab)
      (debugtree "smallana_gimple gimple_cond_notequal falselab" falselab)
      (shortbacktrace_dbg "@$@unimplemented smallana_gimple gimple_cond_notequal" 15)
      )
   ( ?(gimple_cond_greater ?lhs ?rhs ?truelab ?falselab)
      (debugtree "smallana_gimple gimple_cond_greater lhs" lhs)
      (debugtree "smallana_gimple gimple_cond_greater rhs" rhs)
      (debugtree "smallana_gimple gimple_cond_greater truelab" truelab)
      (debugtree "smallana_gimple gimple_cond_greater falselab" falselab)
      (shortbacktrace_dbg "@$@unimplemented smallana_gimple gimple_cond_greater" 15)
      )
   ( ?(gimple_cond_true ?truelab ?falselab)
      (debugtree "smallana_gimple gimple_cond_true truelab" truelab)
      (debugtree "smallana_gimple gimple_cond_true falselab" falselab)
      (shortbacktrace_dbg "@$@unimplemented smallana_gimple gimple_cond_true" 15)
      )
   ( ?(gimple_call ?lhs ?fndecl ?_)
      (debugtree "smallana_gimple gimple_call lhs" lhs)
      (debugtree "smallana_gimple gimple_call fndecl" fndecl)
      (shortbacktrace_dbg "@$@unimplemented smallana_gimple gimple_call" 15)
      )
   ( ?(gimple_return ?retval)
      (debugtree "smallana_gimple gimple_return retval" retval)
      (shortbacktrace_dbg "@$@unimplemented smallana_gimple gimple_return" 15)
      )
   ( ?_
     (debuggimple "smallana_gimple other!gimple" g)
     ;;(shortbacktrace_dbg "smallana_gimple unexpected gimple" 15)
     (assert_msg "smallana_gimple @$@ UNIMPLEMENTED GIMPLE" ())
     )
   )
  )

(defun smallana_bb (sman :basicblock bb)
  (debug_msg sman "smallana_bb start sman")
  (assert_msg "check sman" (is_a sman class_smallanalysis))
  (debugbasicblock "smallana_bb bb" bb)
  (let ( (bbtab (get_field :sman_bbtable sman)) 
	 )
    (assert_msg "check bbtab" (is_mapbasicblock bbtab))
    (let ( (sbb (mapbasicblock_get bbtab bb)) )
      (if sbb (return))
      (setq sbb (instance class_smallbb
			  :sbb_bbcont (make_basicblock discr_basicblock bb)))
      (mapbasicblock_put bbtab bb sbb)
      (eachgimple_in_basicblock 
       (bb)
       (:gimple g)
       (smallana_gimple sman g)
       )
      (debug_msg sman "smallana_bb end sman")
      )))


(defun smallana_cfun_bb (sman :tree cfdecl :basicblock fbb)
  (debug_msg sman "smallana_bb_cfun start sman")
  (debugtree "smallana_bb_cfun cfdecl" cfdecl)
  (assert_msg "check sman" (is_a sman class_smallanalysis))
  (match cfdecl
	 ( ?(as ?decltree ?(tree_function_decl ?funam ?(tree_block ?treevars ?_)))
	    (debugtree "smallana_bb_cfun decltree" decltree)
	    (debugtree "smallana_bb_cfun treevars of function" treevars)
	    (debugcstring "smallana_cfun_entrybb funam" funam)
	    ))
  (smallana_bb sman fbb)
  (debug_msg sman "smallana_bb_cfun end sman")
  )


(defun smaninterp_cfun (sman abenv cfun)
  (debug_msg sman "smaninterp_fun sman")
  (debug_msg cfun "smaninterp_fun cfun")
  (debug_msg abenv "smaninterp_fun abenv")
  (assert_msg "check sman" (is_a sman class_smallanalysis))
  (assert_msg "check abenv" (is_a abenv class_smallabstractenv))
  (assert_msg "check cfun" (is_a cfun class_smallcfun))
  (let ( (:basicblock bbent 
		      (basicblock_content (get_field :scfun_entbb cfun)))
	 (:tree fundecl (tree_content (get_field :scfun_decl cfun)))
	 )
    (push_cfun_decl fundecl)
    (smaninterp_basicblock sman abenv bbent)
    ;(assert_msg "@$@unimplemented smaninterp_fun" ())
    (shortbacktrace_dbg "@$@unimplemented smaninterp_fun" 15)
    (pop_cfun)
    ))


(defun smaninterp_basicblock (sman abenv :basicblock bb)
  (debug_msg abenv "smaninterp_basicblock abenv")
  (assert_msg "check sman" (is_a sman class_smallanalysis))
  (assert_msg "check abenv" (is_a abenv class_smallabstractenv))
  (forever 
   bbloop
   (debugbasicblock "smaninterp_basicblock bb" bb)
   (if (null_basicblock bb)
       (exit bbloop))
   (eachgimple_in_basicblock 
    (bb)
    (:gimple g)
    (debuggimple "smaninterp_basicblock g" g)
    (smaninterp_gimple sman abenv g bb)
    )
   (setq bb (basicblock_single_succ bb))
   (debugbasicblock "smaninterp_basicblock succ bb" bb)
   )
  (debug_msg () "smaninterp_basicblock done")
  ;(assert_msg "@$@unimplemented smaninterp_basicblock" ())
  (shortbacktrace_dbg "@$@unimplemented smaninterp_basicblock" 15)
  )


;;;;;;;;;;;;;;;;
(defun sman_propagate_constraints_call (abenv newabenv tupvarbind)
  (debug_msg tupvarbind "sman_propagate_constraints_call tupvarbind")
  (assert_msg "check newabenv" (is_a newabenv class_smallabstractenv))
  (let ( (pplvarslist (make_list discr_list)) 
	 (:ppl_constraint_system consys (raw_new_ppl_empty_constraint_system))
	 (:long nbpplvars 0)
	 )
    (foreach_in_multiple
     (tupvarbind)
     (curvarbind :long bindix)
     (debug_msg curvarbind "sman_propagate_constraints_call curvarbind")
     (let ( (:tree parmtype (tree_content (multiple_nth curvarbind 0)))
	    (parmdeclval (multiple_nth curvarbind 1))
	    (:tree parmdecl (tree_content parmdeclval))
	    (:tree curarg (tree_content (multiple_nth curvarbind 2)))
	    )
       (debugtree "sman_propagate_constraints_call parmtype" parmtype)
       (debugtree "sman_propagate_constraints_call parmdecl" parmdecl)
       (debugtree "sman_propagate_constraints_call curarg" curarg)
       (messagenum_dbg  "sman_propagate_constraints_call nbpplvars" nbpplvars)
       (match 
	curarg
	( ?(tree_integer_cst ?k)
	   (messagenum_dbg  "sman_propagate_constraints_call curarg const.int. k" k)
	   ;; add the constraint {parmdecl == k}
	   (let (
		 (:ppl_coefficient coefarg (ppl_coefficient_from_tree curarg)) 
		 (:ppl_coefficient coefm1 (ppl_coefficient_from_long -1)) 
		 (:ppl_linear_expression liex (make_ppl_linear_expression))
		 )
	     (debug_ppl_coefficient "sman_propagate_constraints_call coefarg" coefarg)
	     (messagenum_dbg  "sman_propagate_constraints_call nbpplvars" nbpplvars)
	     (ppl_Linear_Expression_add_to_coefficient liex nbpplvars coefm1)
	     (ppl_Linear_Expression_add_to_inhomogeneous liex coefarg)
	     (debug_ppl_linear_expression "sman_propagate_constraints_call liex" liex)
	     (let ( (:ppl_constraint cons (make_ppl_constraint liex "==")) )
	       (debug_ppl_constraint "sman_propagate_constraints_call cons" cons)
	       (ppl_Constraint_System_insert_Constraint consys cons)
	       (ppl_delete_Constraint cons)
	       )
	     (ppl_delete_Coefficient coefm1)
	     (ppl_delete_Coefficient coefarg)
	     (ppl_delete_Linear_Expression liex)
	     )
	   (setq  nbpplvars (+i nbpplvars 1)) 
	   (list_append pplvarslist parmdeclval)
	   )
	( ?_
	  (assert_msg "sman_propagate_constraints_call @$@unimplemented curarg tree" ())))
       ))
    (let ( (:ppl_polyhedron poly (ppl_NNC_Polyhedron_from_Constraint_System consys)) 
	   (polyv (make_ppl_polyhedron_same discr_ppl_polyhedron poly))
	   )
      (debug_msg polyv "sman_propagate_constraints_call polyv")
      (assert_msg "check polyv" polyv)
      (put_fields newabenv 
		  :abenv_pplpoly polyv
		  :abenv_vectrees (list_to_multiple pplvarslist))
      ))
  (debug_msg newabenv "sman_propagate_constraints_call final newabenv")
  )

;;;;;;;;;;;;;;;;
;; pass both the relation and the opposite relation when changing signs
(defun sman_add_cmp_constraint (sman abenv polyv :tree lhs rhs :cstring rel opprel)
  (debug_msg abenv "sman_add_cmp_constraint abenv")
  (assert_msg "check sman" (is_a sman class_smallanalysis))
  (assert_msg "check abenv" (is_a abenv class_smallabstractenv))
  (debugtree "sman_add_cmp_constraint lhs" lhs)
  (debugtree "sman_add_cmp_constraint rhs" rhs)
  (debug_msg polyv "sman_add_cmp_constraint polyv")
  (assert_msg "check polyv" (== (discrim polyv) discr_ppl_polyhedron))
  (let ( (:long lvix -1) 		;left var index
	 (:long rvix -1)		;right var index
	 )
;;; handle the left hand side lhs
    (match 
     lhs
     (?(tree_ssa_name 
	?(as ?ldeclvar ?(tree_decl ?lvar ?lname ?luid)) 
	?lvalu ?lversion ?ldefg)
       (debugtree "sman_add_cmp_constraint ssa_name ldeclvar" ldeclvar)
       (debugtree "sman_add_cmp_constraint ssa_name lvar" lvar)
       (debugtree "sman_add_cmp_constraint ssa_name lvalu" lvalu)
       (messagenum_dbg "sman_add_cmp_constraint lversion" lversion)
       (debuggimple "sman_add_cmp_constraint ssa_name ldefg" ldefg)
       (multicall
	(boxtr :long trix)
	(find_tree_smallabstractenv abenv lvar)
	(debug_msg boxtr "sman_add_cmp_constraint ssa_name boxtr")
	(if boxtr 
	    (progn (setq lvix trix) ())
	  (progn 
	    (assert_msg "sman_add_cmp_constraint dont know what to do lvar" ())
	    ()
	    ))
	)
       ()
       )
     (?(tree_integer_cst ?lk)
       ()				;this is ok
       )
     (?_
      (assert_msg "unexpected lhs in sman_add_cmp_constraint" ()))
     )				    ;end match lhs
;;; handle the right hand side rhs
    (match 
     rhs
     (?(tree_ssa_name ?rvar ?rvalu ?rversion ?rdefg)
       (debugtree "sman_add_cmp_constraint ssa_name rvar" rvar)
       (debugtree "sman_add_cmp_constraint ssa_name rvalu" rvalu)
       (messagenum_dbg "sman_add_cmp_constraint rversion" rversion)
       (debuggimple "sman_add_cmp_constraint ssa_name rdefg" rdefg)
       (multicall
	(boxtr :long trix)
	(find_tree_smallabstractenv abenv rvar)
	(debug_msg boxtr "sman_add_cmp_constraint ssa_name boxtr")
	(if 
	    boxtr 
	    (progn (setq rvix trix) ())
	  (assert_msg "sman_add_cmp_constraint dont know what to do rvar" ()))
	)
       ()
       )
     (?(tree_integer_cst ?rk)
       ()				;this is ok
       )
     (?_
      (assert_msg "unexpected rhs in sman_add_cmp_constraint" ()))
     )					;end match rhs
    (cond
     ( (and (>=i lvix 0) (<i rvix 0)) ;left is variable, right is constant
       (let (
	     (:ppl_polyhedron poly (ppl_polyhedron_content polyv))
	     (:ppl_linear_expression liex (make_ppl_linear_expression))
	     (:ppl_coefficient coefright (ppl_coefficient_from_tree rhs))
	     (:ppl_coefficient coefm1 (ppl_coefficient_from_long -1)) 
	     )
	 (assert_msg "check poly" poly)
	 (ppl_Linear_Expression_add_to_coefficient liex lvix coefm1)
	 (ppl_Linear_Expression_add_to_inhomogeneous liex coefright)
	 (let ( (:ppl_constraint newcons (make_ppl_constraint liex opprel)) )
	   (debug_ppl_constraint "sman_add_cmp_constraint leftvar constraint" newcons)
	   (ppl_Polyhedron_add_constraint poly newcons)
	   (debug_ppl_polyhedron "sman_add_cmp_constraint updated poly" poly)
	   (ppl_delete_Coefficient coefm1)
	   (ppl_delete_Coefficient coefright)
	   (ppl_delete_Linear_Expression liex)
	   (ppl_delete_Constraint newcons)
	   )
	 )
       )
     ( (and (<i lvix 0) (>=i rvix 0)) ;left is constant, right is variable
       (let ( (:ppl_coefficient coefleft (ppl_coefficient_from_tree lhs))
	      (:ppl_coefficient coefm1 (ppl_coefficient_from_long -1)) 
	      (:ppl_linear_expression liex (make_ppl_linear_expression))
	      (:ppl_polyhedron poly (ppl_polyhedron_content polyv))
	      )
	 (ppl_Linear_Expression_add_to_coefficient liex rvix coefm1)
	 (ppl_Linear_Expression_add_to_inhomogeneous liex coefleft)
	 (let ( (:ppl_constraint newcons (make_ppl_constraint liex opprel)) )
	   (debug_ppl_constraint "sman_add_cmp_constraint rightvar constraint" newcons)
	   (ppl_Polyhedron_add_constraint poly newcons)
	   (ppl_delete_Coefficient coefm1)
	   (ppl_delete_Coefficient coefleft)
	   (ppl_delete_Linear_Expression liex)
	   (ppl_delete_Constraint newcons)
	   )
	 )
       ()
       )
     ( (and (>=i lvix 0) (>=i rvix 0)) ;both left & right are variable
       (let ( (:ppl_coefficient coef1 (ppl_coefficient_from_long 1))
	      (:ppl_coefficient coefm1 (ppl_coefficient_from_long -1)) 
	      (:ppl_linear_expression liex (make_ppl_linear_expression))
	      (:ppl_polyhedron poly (ppl_polyhedron_content polyv))
	      )
	 (ppl_Linear_Expression_add_to_coefficient liex lvix coef1)
	 (ppl_Linear_Expression_add_to_coefficient liex rvix coefm1)
	 (let ( (:ppl_constraint newcons (make_ppl_constraint liex rel)) )
	   (debug_ppl_constraint "sman_add_cmp_constraint bothvar constraint" newcons)
	   (ppl_Polyhedron_add_constraint poly newcons)
	   (ppl_delete_Coefficient coefm1)
	   (ppl_delete_Coefficient coef1)
	   (ppl_delete_Linear_Expression liex)
	   (ppl_delete_Constraint newcons)
	   )
	 )
       ()
       )
     (:else
      (assert_msg "unexpected left & right in sman_add_cmp_constraint" ())
      ))
    )
  (debug_msg polyv "sman_add_cmp_constraint final polyv")
  )

;;;;;;;;;;;;;;;;
;;;; utility to interpret an arithmetic compare test
(defun sman_arithm_compare
  (sman abenv
;;; the entire gimple and its containing basicblock
	:gimple g :basicblock bb 
;;; the extracted lefthandside righthandside truelab falselab
	:tree lhs rhs truelab falselab 
;;; the relation string [eg "<="] its opposite for negative numbers [eg ">="] and
;;; its negation [eg ">"] and the opposite of the negation [eg "<"]
	:cstring rel opprel notrel notopprel)
  ;; check arguments
  (assert_msg "check sman" (is_a sman class_smallanalysis))
  (assert_msg "check abenv" (is_a abenv class_smallabstractenv))
  (debuggimple "sman_arithm_compare gimple" g)
  (debugbasicblock "sman_arithm_compare bb" bb)
  (debug_msg abenv "sman_arithm_compare start abenv")
  ;; extract the polyhedron value and clone it for the other branch
  (let ( (polyv (get_field :abenv_pplpoly abenv)) 
	 (:ppl_polyhedron poly (ppl_polyhedron_content polyv))
	 (clonpolyv (make_ppl_polyhedron_cloned discr_ppl_polyhedron poly))
	 (:ppl_polyhedron clonpoly (ppl_polyhedron_content clonpolyv))
	 )
    (debug_msg polyv "sman_arithm_compare polyv before sman_add_cmp_constraint")
    ;; handle the true branch by adding the constraint from the test
    (sman_add_cmp_constraint sman abenv polyv lhs rhs rel opprel)
    (debug_msg polyv "sman_arithm_compare polyv after sman_add_cmp_constraint")
    (if (ppl_Polyhedron_is_empty poly)
	(progn
	  (debuggimple "sman_arithm_compare true branch impossible" g)
	  )
      (progn
	(debugtree "sman_arithm_compare true branch truelab" truelab)
	(debuggimple "sman_arithm_compare true branch possible g" g)
	(debugbasicblock "sman_arithm_compare true branch possible bb" bb)
	(foreach_basicblock_succ_edge 
	 (bb)
	 (:edge eg :long eix)
	 (debugedge "sman_arithm_compare true succedge eg" eg)
	 (if (edge_for_true_value eg)
	     (let ( (:basicblock tbb (edge_dest_bb eg)) 
		    (oldpolyv (get_field :abenv_pplpoly abenv))
		    )
	       ;; in the true case, the oldpolyv should be polyv
	       (assert_msg "check polyv==oldpolyv" (== oldpolyv polyv))
	       (debugbasicblock "sman_arithm_compare truesucc tbb" tbb)
	       (debug_msg abenv "sman_arithm_compare true before tbb abenv")
	       (smaninterp_basicblock sman abenv tbb)
	       (debug_msg abenv "sman_arithm_compare true after tbb abenv")
	       ))
	 )
	))
    ;; handle the false branch by adding the constraint incompatible with the test
    (debug_msg clonpolyv "sman_arithm_compare clonpolyv before sman_add_cmp_constraint")
    (sman_add_cmp_constraint sman abenv clonpolyv lhs rhs notrel notopprel)
    (debug_msg clonpolyv "sman_arithm_compare clonpolyv after sman_add_cmp_constraint")
    (if (ppl_Polyhedron_is_empty clonpoly)
	(progn
	  (debuggimple "sman_arithm_compare false branch impossible" g)
	  )
      (progn
	(debugtree "sman_arithm_compare false branch falselab" falselab)
	(debuggimple "sman_arithm_compare false branch possible" g)
	(debugbasicblock "sman_arithm_compare false branch possible bb" bb)
	(foreach_basicblock_succ_edge 
	 (bb)
	 (:edge eg :long eix)
	 (debugedge "sman_arithm_compare false succedge eg" eg)
	 (if (edge_for_false_value eg)
	     (let ( (:basicblock fbb (edge_dest_bb eg)) 
		    (oldpolyv (get_field :abenv_pplpoly abenv))
		    )
	       (debugbasicblock "sman_arithm_compare falsesucc fbb" fbb)
	       (put_fields abenv :abenv_pplpoly clonpolyv)
	       (debug_msg abenv "sman_arithm_compare false updated abenv")
	       (smaninterp_basicblock sman abenv fbb)
	       (put_fields abenv :abenv_pplpoly oldpolyv)
	       (debug_msg abenv "sman_arithm_compare false restored abenv")
	       ))
	 )
	))
    )
  (debug_msg sman "sman_arithm_compare ended sman")
)

;;;;;;;;;;;;;;;;
(defun smaninterp_gimple (sman abenv :gimple g :basicblock bb)
  (assert_msg "check sman" (is_a sman class_smallanalysis))
  (assert_msg "check abenv" (is_a abenv class_smallabstractenv))
  (debug_msg abenv "smaninterp_gimple abenv")
  (debuggimple "smaninterp_gimple g" g)
  (debugbasicblock "smaninterp_gimple bb" bb)
  ;; we really should count the number of times we are calling
  ;; smaninterp_gimple and returns immediately with a warning if calling
  ;; too often/too deeply. The point is that an small analysis of a
  ;; buggy program could make the compiler loop.
  (compile_warning "we should check that we don't call too often or too deeply in smaninterp_gimple" ())
  (match 
   g
   ;; handle calls
   (?(gimple_call ?lhs ?fndecl ?nargs)
     (debugtree "smaninterp_gimple call lhs" lhs)
     (debugtree "smaninterp_gimple call fndecl" fndecl)
     (let ( (:long argix 0) 
	    (newabenv (fresh_abstrenv abenv))
	    (tupvarbind (make_multiple discr_multiple nargs))
	    )
       (each_param_in_fundecl 
	(fndecl)
	(:tree curparamdcl)
	(messagenum_dbg  "smaninterp_gimple curparamdecl argix" argix)
	(debugtree "smaninterp_gimple curparamdecl" curparamdcl)
	(let ( (:tree curarg (gimple_call_nth_arg g argix)) )
	  (debugtree "smaninterp_gimple curarg" curarg)
	  (match 
	   curparamdcl
	   (?(tree_parm_decl ?parmtype ?parmdecl ?parmname)
	     (debugtree "smaninterp_gimple parmtype" parmtype)
	     (debugtree "smaninterp_gimple parmdecl" parmdecl)
	     (debugcstring "smaninterp_gimple parmname" parmname)
	     (multiple_put_nth tupvarbind argix
			       (make_tuple3 discr_multiple 
					    (make_tree discr_tree parmtype)
					    (make_tree discr_tree parmdecl)
					    (make_tree discr_tree curarg)))
	     )
	   (?_ 
	    (assert_msg "inexpected curparamdcl" ())
	    )
	   )
	  (setq argix (+i argix 1))
	  ))
       (debug_msg tupvarbind "smaninterp_gimple tupvarbind")
       (sman_propagate_constraints_call abenv newabenv tupvarbind)
       (debug_msg newabenv "smaninterp_gimple newabenv propagated")
       (debugtree "smaninterp_gimple call should go into fndecl" fndecl)
       (debug_msg sman "smaninterp_gimple sman")
       (let (
	     (calledcfun (maptree_get (get_field :sman_cfuntreemap sman) fndecl)) )
	 (debug_msg calledcfun "smaninterp_gimple calledcfun")
	 (if calledcfun
	     (smaninterp_cfun sman newabenv calledcfun)
	   )
	 )
       (shortbacktrace_dbg "@$@unimplemented smaninterp_gimple call" 15)
					;(assert_msg "@$@unimplemented smaninterp_gimple call" ())
       )
     )
   ;; handle conditional <=
   ( ?(gimple_cond_lessequal ?lhs ?rhs ?truelab ?falselab)
      (debugtree "smaninterp_gimple cond<= lhs" lhs)
      (debugtree "smaninterp_gimple cond<= rhs" rhs)
      (debugtree "smaninterp_gimple cond<= truelab" truelab)
      (debugtree "smaninterp_gimple cond<= falselab" falselab)
      (debug_msg abenv "smaninterp_gimple cond<= abenv before sman_arithm_compare")
      (sman_arithm_compare sman abenv
			   g bb
			   lhs rhs truelab falselab
			   "<=" ">=" ">" "<")
      (debug_msg abenv "smaninterp_gimple cond<= abenv after sman_arithm_compare")
      (assert_msg "@$@unimplemented smaninterp_gimple cond<=" ())
      )
   ;; handle conditional <
   ( ?(gimple_cond_less ?lhs ?rhs ?truelab ?falselab)
      (debugtree "smaninterp_gimple cond< lhs" lhs)
      (debugtree "smaninterp_gimple cond< rhs" rhs)
      (debugtree "smaninterp_gimple cond< truelab" truelab)
      (debugtree "smaninterp_gimple cond< falselab" falselab)
      (shortbacktrace_dbg "@$@unimplemented smaninterp_gimple cond<" 15)
      (assert_msg "@$@unimplemented smaninterp_gimple cond<" ())
      )
   ;; handle conditional >
   ( ?(gimple_cond_greater ?lhs ?rhs ?truelab ?falselab)
      (debugtree "smaninterp_gimple cond> lhs" lhs)
      (debugtree "smaninterp_gimple cond> rhs" rhs)
      (debugtree "smaninterp_gimple cond> truelab" truelab)
      (debugtree "smaninterp_gimple cond> falselab" falselab)
      (shortbacktrace_dbg "@$@unimplemented smaninterp_gimple cond>" 15)
      (assert_msg "@$@unimplemented smaninterp_gimple cond>" ())
      )
   ;; handle conditional true
   ( ?(gimple_cond_true ?truelab ?falselab)
      (debugtree "smaninterp_gimple condtrue truelab" truelab)
      (debugtree "smaninterp_gimple condtrue falselab" falselab)
      ;;(shortbacktrace_dbg "@$@unimplemented smaninterp_gimple condtrue" 15)
      (assert_msg "@$@unimplemented smaninterp_gimple condtrue" ())
      )
   ;; handle conditional false
   ( ?(gimple_cond_false ?truelab ?falselab)
      (debugtree "smaninterp_gimple condfalse truelab" truelab)
      (debugtree "smaninterp_gimple condfalse falselab" falselab)
      ;;(shortbacktrace_dbg "@$@unimplemented smaninterp_gimple condfalse" 15)
      (assert_msg "@$@unimplemented smaninterp_gimple condfalse" ())
      )
   ;; handle single assign
   ( ?(gimple_assign_single ?lhs ?rhs)
      (debugtree "smallana_gimple gimple_assign_single lhs" lhs)
      (debugtree "smallana_gimple gimple_assign_single rhs" rhs)
      (debuggimple "unimplemented smaninterp_gimple assign_single g" g)
      (assert_msg "@$@unimplemented smaninterp_gimple singleassign" ())
      )
   ;; handle cast assign
   ( ?(gimple_assign_cast ?lhs ?rhs)
      (debugtree "smallana_gimple gimple_assign_cast lhs" lhs)
      (debugtree "smallana_gimple gimple_assign_cast rhs" rhs)
      (let ( (:tree lhstype (tree_type lhs))
	     (:tree rhstype (tree_type rhs))
	     (:long widenningcast 0)
	     )
	(debugtree "smallana_gimple gimple_assign_cast lhstype" lhstype)
	(debugtree "smallana_gimple gimple_assign_cast rhstype" rhstype)
	(match 
	 rhstype
	 ( ?(tree_integer_type ?rname ?rbigmin ?rbigmax ?rsize)
	    (match 
	     lhstype
	     ( ?(tree_integer_type ?lname ?lbigmin ?lbigmax ?lsize)
		(code_chunk 
		 testinside
		 #{ 
		   mpz_t $testinside#_lminz;
		   mpz_t $testinside#_lmaxz;
		   mpz_t $testinside#_rminz;
		   mpz_t $testinside#_rmaxz;
		   mpz_init_set_ui($testinside#_lminz, 0UL);
		   mpz_init_set_ui($testinside#_lmaxz, 0UL);
		   mpz_init_set_ui($testinside#_rminz, 0UL);
		   mpz_init_set_ui($testinside#_rmaxz, 0UL);
		   if ($lsize >= $rsize 
		      && melt_fill_mpz_from_mixbigint($lbigmin, $testinside#_lminz)
	              && melt_fill_mpz_from_mixbigint($lbigmax, $testinside#_lmaxz)
		      && melt_fill_mpz_from_mixbigint($rbigmin, $testinside#_rminz)
	              && melt_fill_mpz_from_mixbigint($rbigmax, $testinside#_rmaxz)
		      && mpz_cmp($testinside#_lminz, $testinside#_rminz) <= 0
		      && mpz_cmp($testinside#_lmaxz, $testinside#_rmaxz) >= 0)
		         $widenningcast = 1;
		   mpz_clear($testinside#_lminz);
		   mpz_clear($testinside#_lmaxz);
		   mpz_clear($testinside#_rminz);
		   mpz_clear($testinside#_rmaxz);
		 }#)
		)
	    )))	 
	(if widenningcast
	    (progn
	    (assert_msg "@$@unimplemented smaninterp_gimple widenningcast" ())
	      )
	  (progn
	    (assert_msg "@$@unimplemented smaninterp_gimple non widenningcast" ())
	    ))
	(debuggimple "unimplemented smaninterp_gimple assign_cast g" g)
	(assert_msg "@$@unimplemented smaninterp_gimple castassign" ())
	))
   ;; default 
   (?_ 
    (debuggimple "unimplemented smaninterp_gimple g" g)
    (assert_msg "@$@unimplemented smaninterp_gimple" ()))
   )
  )



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun smallana_interpret (sman)
  (debug_msg sman "smallana_interpret sman")
  (assert_msg "check sman" (is_a sman class_smallanalysis))
  (let ( (mainf (mapstring_rawget (get_field :sman_cfundict sman) "main")) 
	 )
    (debug_msg mainf "smallana_interpret mainf")
    (assert_msg "check mainf" (is_a mainf class_smallcfun))
    (smaninterp_cfun sman initial_smallabstractenv mainf)
    (debug_msg sman "smallana_interpret end sman")
    )
)

;;; our small analysis gate for latessa
;; for some reason, the smallana is triggered twice, and the first run
;; is enough...
(defun smallanapass_gate (latessapass)
  (debug_msg smallana_cont "smallanapass_gate smallana_cont at start")
  (let ( (oldsman (get_field  :container_value smallana_cont)) )
    (if oldsman
	(progn
	  (shortbacktrace_dbg "smallanapass_gate already got oldsman" 20)
	  (debug_msg oldsman "smallanapass_gate already got oldsman")
	  (return ()))
      (return smallana_cont)
      )))


;;; apparently only the entrybb loop matter in the latessa pass...
(defun smallanapass_exec (latessapass)
  (debug_msg latessapass "smallanapass_exec start")
  (let ( (cfuns (make_list discr_list))
	 (cfundict (make_mapstring discr_mapstrings 20))
	 (cfuntreemap (make_maptree discr_maptrees 20))
	 (sman (instance class_smallanalysis
			 :sman_cfuns cfuns
			 :sman_cfundict cfundict
			 :sman_cfuntreemap cfuntreemap
			 :sman_bbtable (make_mapbasicblock discr_mapbasicblocks 20)
			 )) 
	 )
    (debug_msg sman "smallanapass_exec sman at start")
    ;; don't bother do_each_cfun_body here.. it is not done...
    (each_cgraph_fun_entryblock
     ()
     (:tree decl :basicblock bbent)
     (debugtree "smallana exec eachcgraph decl" decl)
     (smallana_cfun_entbb sman decl bbent)
     )
    ;;
    (debug_msg sman "smallanapass_exec sman after eachentrybb")
    ;;
    (each_bb_cfun
     ()
     (:basicblock cfbb :tree cfdecl)
     (smallana_cfun_bb sman cfdecl cfbb)
     )
    ;;
    (debug_msg sman "smallanapass_exec sman after eachbbcfun")
    ;;
    (smallana_interpret sman)
    ;;
    (put_fields  smallana_cont :container_value sman)
    (debug_msg smallana_cont "smallanapass_exec final smallana_cont")
    ))

;;; our small analysis command -fmelt=smallana
(defun smallana_command (dispatcher arg secarg moduldata)
  (let ( (smallana_ipa_gccpass 
	  (compile_warning "should create and register a simple ipa pass" ())) )
  ;; fill the ipa pass
  (put_fields smallana_ipa_gccpass
  :gccpass_gate smallanapass_gate
  :gccpass_exec smallanapass_exec)
  (debug_msg smallana_ipa_gccpass "smallana_ipa_gccpass")
  (assert_msg "$@$incomplete smallana_command" ())
  (return dispatcher)			;return non-nil to continue compilation
  ))

(initial_command_install smallana_command "smallana")

;; eof ana-simple.melt