2011-03-16 Basile Starynkevitch <basile@starynkevitch.net>

	* melt/xtramelt-ana-base.melt (make_empty_basicblock): New.
	(loop_body_tuple): Move the function after basic block primitives.

	* testsuite/melt/twrongprim-1.melt: New file.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@171032 138bc75d-0d04-0410-961f-82ee72b054a4

3 files changed, 93 insertions, 53 deletions

diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT
index 0ca824341cc..fc8584ece2a 100644
--- a/gcc/ChangeLog.MELT
+++ b/gcc/ChangeLog.MELT
@@ -1,4 +1,11 @@
 
+2011-03-16  Basile Starynkevitch  <basile@starynkevitch.net>
+
+	* melt/xtramelt-ana-base.melt (make_empty_basicblock): New.
+	(loop_body_tuple): Move the function after basic block primitives.
+
+	* testsuite/melt/twrongprim-1.melt: New file.
+
 2011-03-15  Basile Starynkevitch  <basile@starynkevitch.net>
 
 	* melt/xtramelt-ana-base.melt (loop_body_tuple): More, and avoid
diff --git a/gcc/melt/xtramelt-ana-base.melt b/gcc/melt/xtramelt-ana-base.melt
index 2a28667625f..b7e57216059 100644
--- a/gcc/melt/xtramelt-ana-base.melt
+++ b/gcc/melt/xtramelt-ana-base.melt
@@ -243,58 +243,6 @@
  }while(0)  }#
 )
 
-;; retrieve the loop body as a tuple of boxed basic_block-s
-(defun loop_body_tuple (discr :loop lo) 
-  (debugloop lo "loop_body_tuple lo")
-  (if (null discr) (setq discr discr_multiple))
-  (if lo
-      (let ( (:long loopnbnodes 0) 
-	     )
-	(code_chunk 
-	 getloopnbnodeschunk
-	 #{/*$GETLOOPNBNODESCHUNK*/
-	 $LOOPNBNODES = $LO?($LO -> num_nodes):0 ; }#
-	 )
-	(let ( (tupbody (make_multiple discr loopnbnodes))
-	       )
-	  (if (null tupbody) (return)) 
-	  ;; first, fill the tuple with empty basic block boxes
-	  (foreach_long_upto 
-	   (0 (-i loopnbnodes 1))
-	   (:long ix)
-	   (debuglong "loop_body_tuple ix" ix)
-	   (let ( (curbb (make_basicblock discr_basic_block (null_basicblock))) 
-		  )
-	     (debug_msg curbb "loop_body_tuple curbb")
-	     (multiple_put_nth tupbody ix curbb)
-	   ))
-	  (debug_msg tupbody "loop_body_tuple empty tupbody")
-	  (let ( (ourbb ())
-		 )
-	  ;; retrieve the malloc-ed array of basic blocks and use it to fill the tuple
-	  ;; then free it
-	  (code_chunk
-	   fillbbboxeschunk
-	   #{ /*$FILLBBBOXESCHUNK*/
-	   long $FILLBBBOXESCHUNK#_ix = 0	       ;
-	   basic_block* $FILLBBBOXESCHUNK#_bbtab = 0   ;
-	   $FILLBBBOXESCHUNK#_bbtab = get_loop_body ($LO) ; /* a malloc-ed array */
-	   for ($FILLBBBOXESCHUNK#_ix = 0		  ;
-				      $FILLBBBOXESCHUNK#_ix < $LOOPNBNODES ;
-				      $FILLBBBOXESCHUNK#_ix++) {
-	   $OURBB = melt_multiple_nth ($TUPBODY, $FILLBBBOXESCHUNK#_ix)	;
-	   meltgc_basicblock_updatebox
-                ($OURBB, 
-		 $FILLBBBOXESCHUNK#_bbtab[$FILLBBBOXESCHUNK#_ix]) ;
-	   }
-	   free ($FILLBBBOXESCHUNK#_bbtab), $FILLBBBOXESCHUNK#_bbtab=0 ;
-	   $OURBB = (melt_ptr_t)0;
-	   /*end $FILLBBBOXESCHUNK*/
-	   }#)
-	  )
-	  (debug_msg tupbody "loop_body_tuple return tupbody")
-	  (return tupbody)
-	  ))))
 
 
 (defprimitive loop_can_be_parallel (:loop lo) :long
@@ -1893,7 +1841,7 @@
 (defprimitive null_basicblock () :basic_block #{((basic_block)0)}#)
 
 (defprimitive make_basicblock (discr :basic_block bb) :value
- #{(meltgc_new_basicblock((meltobject_ptr_t)($discr),($bb)))}# )
+ #{/*make_basicblock*/(meltgc_new_basicblock((meltobject_ptr_t)($discr),($bb)))}# )
 
 
 (defprimitive basicblock_content (v) :basic_block
@@ -2792,6 +2740,68 @@ and discriminant $DIS, usually $DISCR_MIXED_LOCATION.}#
 (defprimitive loop_content (v) :loop
   #{(melt_loop_content((melt_ptr_t)($v)))}# )
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; internal routine to make an empty basicblock boc
+(defun make_empty_basicblock ()
+  (make_basicblock discr_basic_block (null_basicblock)))
+
+;; retrieve the loop body as a tuple of boxed basic_block-s
+(defun loop_body_tuple (discr :loop lo) 
+  (debugloop lo "loop_body_tuple lo")
+  (if (null discr) (setq discr discr_multiple))
+  (if lo
+      (let ( (:long loopnbnodes 0) 
+	     )
+	(code_chunk 
+	 getloopnbnodeschunk
+	 #{/*$GETLOOPNBNODESCHUNK*/
+	 $LOOPNBNODES = $LO?($LO -> num_nodes):0 ; }#
+	 )
+	(let ( (tupbody (make_multiple discr loopnbnodes))
+	       )
+	  (if (null tupbody) (return)) 
+	  ;; first, fill the tuple with empty basic block boxes
+	  (foreach_long_upto 
+	   (0 (-i loopnbnodes 1))
+	   (:long ix)
+	   (debuglong "loop_body_tuple ix" ix)
+	   (comment "loop_body_tuple before making empty basic block")
+	   (let ( (curbb (make_empty_basicblock)) 
+		  )
+	     (debug_msg curbb "loop_body_tuple curbb")
+	     (multiple_put_nth tupbody ix curbb)
+	   ))
+	  (debug_msg tupbody "loop_body_tuple empty tupbody")
+	  (let ( (ourbb ())
+		 )
+	  ;; retrieve the malloc-ed array of basic blocks and use it to fill the tuple
+	  ;; then free it
+	  (code_chunk
+	   fillbbboxeschunk
+	   #{ /*$FILLBBBOXESCHUNK*/
+	   long $FILLBBBOXESCHUNK#_ix = 0	       ;
+	   basic_block* $FILLBBBOXESCHUNK#_bbtab = 0   ;
+	   $FILLBBBOXESCHUNK#_bbtab = get_loop_body ($LO) ; /* a malloc-ed array */
+	   for ($FILLBBBOXESCHUNK#_ix = 0		  ;
+				      $FILLBBBOXESCHUNK#_ix < $LOOPNBNODES ;
+				      $FILLBBBOXESCHUNK#_ix++) {
+	   $OURBB = melt_multiple_nth ($TUPBODY, $FILLBBBOXESCHUNK#_ix)	;
+	   meltgc_basicblock_updatebox
+                ($OURBB, 
+		 $FILLBBBOXESCHUNK#_bbtab[$FILLBBBOXESCHUNK#_ix]) ;
+	   }
+	   free ($FILLBBBOXESCHUNK#_bbtab), $FILLBBBOXESCHUNK#_bbtab=0 ;
+	   $OURBB = (melt_ptr_t)0;
+	   /*end $FILLBBBOXESCHUNK*/
+	   }#)
+	  )
+	  (debug_msg tupbody "loop_body_tuple return tupbody")
+	  (return tupbody)
+	  ))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; safe queries to the cfun (when cfun is null, return null or 0)
 (defprimitive has_cfun () :long #{ cfun != NULL }#)
 
diff --git a/gcc/testsuite/melt/twrongprim-1.melt b/gcc/testsuite/melt/twrongprim-1.melt
new file mode 100644
index 00000000000..301b828129c
--- /dev/null
+++ b/gcc/testsuite/melt/twrongprim-1.melt
@@ -0,0 +1,23 @@
+;; -*- lisp -*-
+;; file twrongprim-1.melt
+
+;; demonstrate a bug in MELT rev 171018. The function make_empty_bb
+;; calls a forwardly defined primitive which is incorrectly translated
+;; to nil without any error messages...
+
+#| run in buildir/gcc
+ ./cc1 -fmelt=translatefile  -fmelt-module-path=melt-modules:.  \
+    -fmelt-source-path=melt-sources:.:$GCCMELT_SOURCE/gcc/melt \
+    -fmelt-tempdir=/tmp \
+    -fmelt-arg=$GCCMELT_SOURCE/gcc/testsuite/melt/twrongprim-1.melt \
+    -fmelt-debug empty-file-for-melt.c
+|#
+
+;; internal routine to make an empty basicblock boc
+(defun make_empty_bb ()
+  (make_bb discr_basic_block (null_basicblock)))
+
+(defprimitive make_bb (discr :basic_block bb) :value
+ #{/*make_bb*/(meltgc_new_basicblock((meltobject_ptr_t)($discr),($bb)))}# )
+
+;; eof twrongprim-1.melt