--- gforth/prims2x.fs	2001/02/24 09:58:31	1.82
+++ gforth/prims2x.fs	2001/03/11 21:47:27	1.90
@@ -60,8 +60,8 @@ warnings off
 			\ different directory with the wordlibraries)
 include ./search.fs			
 include ./extend.fs
-[THEN]
 include ./stuff.fs
+[THEN]
 
 [IFUNDEF] environment?
 include ./environ.fs
@@ -484,13 +484,14 @@ does> ( item -- )
     item declaration ;
 
 \ types pointed to by stacks for use in combined prims
-s" Cell"  single 0 create-type cell-type
-s" Float" single 0 create-type float-type
-
-s" sp" save-mem cell-type  s" (Cell)" make-stack data-stack 
-s" fp" save-mem float-type s" "       make-stack fp-stack
-s" rp" save-mem cell-type  s" (Cell)" make-stack return-stack
-s" IP" save-mem cell-type  s" error don't use # on results" make-stack inst-stream
+\ !! output-c-combined shouldn't use these names!
+s" Cell"  single 0 create-type w
+s" Float" single 0 create-type r
+
+s" sp" save-mem w s" (Cell)" make-stack data-stack 
+s" fp" save-mem r s" "       make-stack fp-stack
+s" rp" save-mem w s" (Cell)" make-stack return-stack
+s" IP" save-mem w s" error don't use # on results" make-stack inst-stream
 ' inst-in-index inst-stream stack-in-index-xt !
 ' inst-stream <is> inst-stream-f
 \ !! initialize stack-in and stack-out
@@ -584,20 +585,28 @@ s" IP" save-mem cell-type  s" error don'
 : stores ( -- )
     prim prim-effect-out prim prim-effect-out-end @ ['] store map-items ;
 
+: output-super-end ( -- )
+    prim prim-c-code 2@ s" SET_IP" search if
+	." SUPER_END;" cr
+    endif
+    2drop ;
+
 : output-c-tail ( -- )
     \ the final part of the generated C code
+    output-super-end
     ." NEXT_P1;" cr
     stores
     fill-tos
-    ." NEXT_P2;" cr ;
+    ." NEXT_P2;" ;
 
-: type-c ( c-addr u -- )
-    \ like TYPE, but replaces "TAIL;" with tail code
+: type-c-code ( c-addr u xt -- )
+    \ like TYPE, but replaces "TAIL;" with tail code produced by xt
+    { xt }
     begin ( c-addr1 u1 )
 	2dup s" TAIL;" search
     while ( c-addr1 u1 c-addr3 u3 )
 	2dup 2>r drop nip over - type
-	output-c-tail
+	xt execute
 	2r> 5 /string
 	\ !! resync #line missing
     repeat
@@ -633,7 +642,7 @@ s" IP" save-mem cell-type  s" error don'
  stack-pointer-updates
  ." {" cr
  ." #line " c-line @ . quote c-filename 2@ type quote cr
- prim prim-c-code 2@ type-c
+ prim prim-c-code 2@ ['] output-c-tail type-c-code
  ." }" cr
  output-c-tail
  ." }" cr
@@ -659,6 +668,17 @@ s" IP" save-mem cell-type  s" error don'
     ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
     ." } else " ;
 
+: output-profile ( -- )
+    \ generate code for postprocessing the VM block profile stuff
+    ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
+    ."   add_inst(b, " quote  prim prim-name 2@ type quote ." );" cr
+    ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
+    prim prim-c-code 2@  s" SET_IP"    search nip nip
+    prim prim-c-code 2@  s" SUPER_END" search nip nip or if
+	."   return;" cr
+    endif
+    ." } else " cr ;
+
 : gen-arg-parm { item -- }
     item item-stack @ inst-stream = if
 	." , " item item-type @ type-c-name 2@ type space
@@ -899,6 +919,8 @@ s" IP" save-mem cell-type  s" error don'
 : process-combined ( -- )
     combined combined-prims num-combined @ cells
     combinations ['] constant insert-wordlist
+    combined-prims num-combined @ 1- th ( last-part )
+    @ prim-c-code 2@ prim prim-c-code 2! \ used by output-super-end
     prim compute-effects
     prim init-effects
     output-combined perform ;
@@ -921,7 +943,14 @@ s" IP" save-mem cell-type  s" error don'
     fetches ;
 
 : part-output-c-tail ( -- )
-    output-c-tail ;
+    stores ;
+
+: output-combined-tail ( -- )
+    part-output-c-tail
+    prim >r combined to prim
+    in-part @ >r in-part off
+    output-c-tail
+    r> in-part ! r> to prim ;
 
 : output-part ( p -- )
     to prim
@@ -934,7 +963,7 @@ s" IP" save-mem cell-type  s" error don'
     prim add-depths \ !! right place?
     ." {" cr
     ." #line " c-line @ . quote c-filename 2@ type quote cr
-    prim prim-c-code 2@ type-c \ !! deal with TAIL
+    prim prim-c-code 2@ ['] output-combined-tail type-c-code
     ." }" cr
     part-output-c-tail
     ." }" cr ;
@@ -968,13 +997,13 @@ s" IP" save-mem cell-type  s" error don'
 ;
 
 
-\ compile VM insts
+\ peephole optimization rules
 
 \ in order for this to work as intended, shorter combinations for each
 \ length must be present, and the longer combinations must follow
 \ shorter ones (this restriction may go away in the future).
   
-: output-pregen-combined ( -- )
+: output-peephole ( -- )
     combined-prims num-combined @ 1- cells combinations search-wordlist
     s" the prefix for this combination must be defined earlier" ?print-error
     ." {"
@@ -984,6 +1013,15 @@ s" IP" save-mem cell-type  s" error don'
     combined prim-c-name 2@ type ."  */"
     cr ;
 
+: output-forth-peephole ( -- )
+    combined-prims num-combined @ 1- cells combinations search-wordlist
+    s" the prefix for this combination must be defined earlier" ?print-error
+    execute prim-num @ 5 .r
+    combined-prims num-combined @ 1- th @ prim-num @ 5 .r
+    combined prim-num @ 5 .r ."  prim, \ "
+    combined prim-c-name 2@ type
+    cr ;
+
 
 \ the parser
 
@@ -1138,7 +1176,7 @@ Variable c-flag
 )) <- simple-primitive ( -- )
 
 (( {{ init-combined }}
-   ` = (( white ++ {{ start }} forth-ident {{ end add-prim }} )) ++
+   ` = white ** (( {{ start }} forth-ident {{ end add-prim }} white ** )) ++
    nleof {{ process-combined }}
 )) <- combined-primitive