diff options
| -rw-r--r-- | gcc/ChangeLog.MELT | 11 | ||||
| -rw-r--r-- | gcc/melt/warmelt-first.melt | 8 | ||||
| -rw-r--r-- | gcc/melt/xtramelt-probe.melt | 163 |
3 files changed, 171 insertions, 11 deletions
diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT index 1d00d88a6cd..0c931c2797e 100644 --- a/gcc/ChangeLog.MELT +++ b/gcc/ChangeLog.MELT @@ -1,4 +1,15 @@ +2012-05-31 Basile Starynkevitch <basile@starynkevitch.net> + * melt/warmelt-first.melt (foreach_in_multiple): Emit better comment. + + * melt/xtramelt-probe.melt (class_probed_file): Add + probedfile_linesbucket field. + (class_probed_interesting_location): New class wirh probiloc_* fields. + (class_probed_data): Add probedata_ilocvec & probedata_nbiloc + fields. + (probe_get_interesting_location): New function. + (start_probe): Export function. + 2012-05-30 Basile Starynkevitch <basile@starynkevitch.net> {{Regenerate}} diff --git a/gcc/melt/warmelt-first.melt b/gcc/melt/warmelt-first.melt index 1df8a70eef4..f7b4076884f 100644 --- a/gcc/melt/warmelt-first.melt +++ b/gcc/melt/warmelt-first.melt @@ -3691,7 +3691,7 @@ of pairs.}# eachtup ;state (comp :long ix) ;local formals :doc #{Iterate in the given tuple $TUP for each component $COMP at index $IX}# - #{ /* start $eachtup: */ + #{ /* start foreach_in_multiple $EACHTUP */ long $eachtup#_ln = melt_multiple_length((melt_ptr_t)$tup); for ($ix = 0; ($ix >= 0) && ($ix < $eachtup#_ln); @@ -3699,7 +3699,7 @@ of pairs.}# $comp = melt_multiple_nth((melt_ptr_t)($tup), $ix); }# #{ if ($ix<0) break; - } /* end $eachtup */ }# + } /* end foreach_in_multiple $EACHTUP */ }# ) (defciterator foreach_in_multiple_backward @@ -3708,7 +3708,7 @@ of pairs.}# (comp :long ix) ;local formals :doc #{Iterate backwards from last to first in the given tuple $TUP for each component $COMP at index $IX}# - #{ /* start $eachtupback: */ + #{ /* start foreach_in_multiple_backward $EACHTUPBACK */ long $eachtupback#_ln = melt_multiple_length((melt_ptr_t)$tup); long $eachtupback#_ix = 0; for ($eachtupback#_ix = $eachtupback#_ln - 1; @@ -3716,7 +3716,7 @@ of pairs.}# $eachtupback#_ix--) { $comp = melt_multiple_nth((melt_ptr_t)($tup), $eachtupback#_ix); $ix = $eachtupback#_ix;}# - #{ } /* end $eachtupback */ }# + #{ } /* end foreach_in_multiple_backward $EACHTUPBACK */ }# ) ;;; iterator on tuple , if the called f returns nil the iteration is stopped diff --git a/gcc/melt/xtramelt-probe.melt b/gcc/melt/xtramelt-probe.melt index df5a6fc72fa..dd8abc77386 100644 --- a/gcc/melt/xtramelt-probe.melt +++ b/gcc/melt/xtramelt-probe.melt @@ -137,24 +137,38 @@ :doc #{$CLASS_PROBED_FILE describes a source file known to the probe. $PROBEDFILE_RANK is its unique rank inside $CLASS_PROBE_DATA, $PROBEDFILE_PATH is the given -perhaps relative- path, - $PROBEDFILE_REALPATH is the real absolute file path, and + $PROBEDFILE_REALPATH is the real absolute file path, + $PROBEDFILE_LINESBUCKET is the bucket of interesting lines and $PROBEDFILE_DATA is available to clients.}# :super class_proped :fields ( probedfile_rank ;the rank probedfile_path ;the first given path probedfile_realpath ;the real path + probedfile_linesbucket ;bucket of interesting lines, + ;values are tuples of + ;class_probed_interesting_location probedfile_data ;supplementary client data ) ) - + +(defclass class_probed_interesting_location + :doc #{$CLASS_PROBED_INTERESTING LOCATION describes an interesting source file location. +}# + :super class_proped + :fields (probiloc_file ;the instance of class_probed_file + probiloc_lineno ;boxed line number + probiloc_column ;boxed column number + probiloc_rank ;unique rank in probedata_ilocvec + )) + (defclass class_probe_data :doc #{Singleton $CLASS_PROBE_DATA for probe related data. $PROBEDATA_FILESVEC is a tuple of $CLASS_PROBED_FILE-s, and $PROBEDATA_FILEDICT is a dictionnary mapping given and real paths to them. $PROBEDATA_AUX is an auxiliary data. $PROBEDATA_CMDTOPROBEFD and $PROBEDATA_REQFROMPROBEFD gives the boxed integers for command & - request file descriptors to & from the probe.}# + request file descriptors to & from the probe. $PROBEDATA_ILOCVEC is a tuple of $CLASS_PROBED_INTERESTING_LOCATION}# :super class_proped :fields ( @@ -167,6 +181,8 @@ probedata_cmdtoprobefd ;; boxed file descriptor for requests from probe probedata_reqfromprobefd + probedata_ilocvec ;vector of interesting locations + probedata_nbiloc ;number of interesting locations ;; auxiliary data probedata_aux )) @@ -197,7 +213,7 @@ ))))))) - +;;;;;;;;;;;;;;;; (defun probe_get_file_of_name (probedata name) :doc #{Given a source file $NAME, gives its corresponding $CLASS_PROBED_FILE, perhaps creating it and displaying it in the @@ -240,15 +256,18 @@ (if filix ;skip slot 0 (unless curfil (let ( + (linbuck (make_bucketlong discr_bucket_longs 15)) (newfil (instance class_probed_file :probedfile_rank (make_integerbox discr_constant_integer filix) :probedfile_path name :probedfile_realpath realpath + :probedfile_linesbucket linbuck :probedfile_data () )) ) + (bucketlong_setaux linbuck newfil) (multiple_put_nth filesvec filix newfil) (mapstring_putstr filedict name newfil) (mapstring_putstr filedict realpath newfil) @@ -260,6 +279,129 @@ ))))) + + +;;;;;;;;;;;;;;;; get or build an interesting location +(defun probe_get_interesting_location (probedata file :long lineno col) + :doc #{Return the instance of $CLASS_PROBED_INTERESTING_LOCATION + with the $PROBEDATA for given $FILE at line $LINENO and column + $COL. May register a new location at the probe.}# + (debug "probe_get_interesting_location probedata=" probedata + " file=" file " lineno=" lineno " col=" col) + (assert_msg "check probedata" (is_a probedata class_probe_data)) + (if (is_string file) + (let ( (filename file) + (pfile (probe_get_file_of_name probedata filename)) + ) + (debug "probe_get_interesting_location pfile=" pfile) + (setq file pfile))) + (assert_msg "check file" (is_a file class_probed_file)) + (assert_msg "check lineno" (>=i lineno 1)) + (let ( + (linbuck (get_field :probedfile_linesbucket file)) + (loctup (bucketlong_get linbuck lineno)) + ) + (assert_msg "check linbuck" (is_bucketlong linbuck)) + (unless (is_multiple loctup) + (setq loctup (make_multiple discr_multiple 3)) + (let ( (newlinbuck (bucketlong_put linbuck lineno loctup)) + ) + (when (!= newlinbuck linbuck) + (bucketlong_setaux newlinbuck file) + (put_fields file :probedfile_linesbucket newlinbuck) + (setq linbuck newlinbuck))) + ) + ;; find inside loctup the iloc if existing + (debug "probe_get_interesting_location loctup=" loctup) + (foreach_in_multiple + (loctup) + (curloc :long locix) + (when curloc + (assert_msg "check curloc" + (is_a curloc class_probed_interesting_location)) + (assert_msg "check curloc file" + (== (get_field :probiloc_file curloc) file)) + (assert_msg "check curloc lineno" + (==i (get_int (get_field :probiloc_lineno curloc)) lineno)) + (when (==i (get_int (get_field :probiloc_column curloc)) col) + (debug "probe_get_interesting_location return found curloc=" curloc) + (return curloc)) + )) + ;; build and insert a new interesting location + (let ( (newiloc (instance class_probed_interesting_location + :probiloc_file file + :probiloc_lineno (make_integerbox discr_constant_integer lineno) + :probiloc_column (make_integerbox discr_constant_integer col) + :probiloc_rank () ;filled later + )) + (lastloc (multiple_nth loctup -1)) + ) + (if lastloc + ;; the loctup of current line is full + (let ( (:long loctuplen (multiple_length loctup)) + (:long newtuplen (+i (+i loctuplen 2) (/i loctuplen 5))) + (newtup (make_multiple discr_multiple newtuplen)) + ) + ;; copy the old loctup + (foreach_in_multiple + (loctup) + (curloc :long ix) + (multiple_put_nth newtup ix curloc)) + (setq loctup newtup) + ;; update the bucket entry + (let ( (newlinbuck (bucketlong_put linbuck lineno loctup)) + ) + (when (!= newlinbuck linbuck) + (bucketlong_setaux newlinbuck file) + (put_fields file :probedfile_linesbucket newlinbuck) + (setq linbuck newlinbuck))) + ;; insert newiloc + (multiple_put_nth loctup loctuplen newiloc) + (put_int newiloc loctuplen) + )) + ;; put the newiloc in an empty position of loctup + (foreach_in_multiple + (loctup) + (curloc :long ix) + (unless curloc + (multiple_put_nth loctup ix newiloc) + (put_int newiloc ix) + (setq ix -1) ;;to break the forach_in_multiple + (void) + )) + ;; insert the newiloc inside the vector of interesting locations + (let ( (ilocvec (get_field :probedata_ilocvec probedata)) + (:long ilocveclen (multiple_length ilocvec)) + (:long nbiloc (get_int (get_field :probedata_nbiloc probedata))) + (:long newrank (+i nbiloc 1)) + (:long filerank (get_int (get_field :probedfile_rank file))) + ) + (assert_msg "check ilocveclen" (>i ilocveclen 2)) + ;; grow the vector if it is full + (if (multiple_nth ilocvec -1) + (let ( (:long newveclen (+i 11 (+i ilocveclen (/i ilocveclen 4)))) + (newvec (make_multiple discr_multiple newveclen)) + ) + (foreach_in_multiple + (ilocvec) + (curiloc :long ilocix) + (multiple_put_nth newvec ilocix curiloc)) + (put_fields probedata :probedata_ilocvec newvec) + (setq ilocvec newvec) + (setq ilocveclen newveclen))) + (assert_msg "check newrank" (<i newrank ilocveclen)) + (assert_msg "check empty newrank" (null (multiple_nth ilocvec newrank))) + (put_fields newiloc :probiloc_rank (make_integerbox discr_constant_integer newrank)) + (multiple_put_nth ilocvec newrank newiloc) + (debug "probe_get_interesting_location newiloc=" newiloc + " newrank=" newrank " filerank=" filerank " lineno=" lineno " col=" col) + (send_command_to_probe 'marklocation_pcd newrank filerank lineno col) + (debug "probe_get_interesting_location return newiloc=" newiloc) + (return newiloc) + )))) + + + ;; the internal request processor (defun probe_request_processor (inch inlist) (debug "probe_request_processor start inch=" inch " inlist=" inlist) @@ -335,7 +477,7 @@ (defun start_probe () - :doc #{Internal function to start the probe. Return the probe data}# + :doc #{function to start the probe. Return the probe data. Can be used by any mode wanting the probe.}# (debug "start_probe") (let ( (mainfilename (make_string_real_access_path discr_string (main_input_filename))) @@ -344,7 +486,9 @@ (probedata (instance class_probe_data :probedata_reqhdict (make_mapstring discr_map_strings 53) :probedata_filesvec filesvec - :probedata_filedict filedict)) + :probedata_filedict filedict + :probedata_ilocvec (make_multiple discr_multiple 10) + :probedata_nbiloc '0)) (:long toprobenumfd -1) (:long fromprobenumfd -1) ) @@ -392,13 +536,18 @@ ) (install_melt_mode probe_mode) -(export_class class_probed_file class_probe_data) +(export_class + class_probed_file + class_probe_data + class_probed_interesting_location) (export_values probe_get_data probe_get_file_of_name + probe_get_interesting_location probe_register_request_verb send_command_to_probe send_object_to_probe + start_probe ) ;; eof xtramelt-probe.melt |