--- gforth/prims2x.fs	2001/02/23 10:43:40	1.81
+++ gforth/prims2x.fs	2001/03/18 10:33:25	1.91
@@ -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
@@ -101,7 +101,7 @@ skipsynclines on
     loop
     drop ;
 
-: wordlist-insert { c-addr u wordlist xt -- }
+: insert-wordlist { c-addr u wordlist xt -- }
     \ adds name "addr u" to wordlist using defining word xt
     \ xt may cause additional stack effects
     get-current >r wordlist set-current
@@ -209,6 +209,7 @@ struct%
     cell% 2* field prim-c-code
     cell% 2* field prim-forth-code
     cell% 2* field prim-stack-string
+    cell%    field prim-num            \ ordinal number
     cell%    field prim-items-wordlist \ unique items
     item% max-effect * field prim-effect-in
     item% max-effect * field prim-effect-out
@@ -242,10 +243,7 @@ create min-depth     max-stacks cells al
 wordlist constant primitives
 
 : create-prim ( prim -- )
-    get-current >r
-    primitives set-current
-    dup prim-name 2@ nextname constant
-    r> set-current ;
+    dup prim-name 2@ primitives ['] constant insert-wordlist ;
 
 : stack-in ( stack -- addr )
     \ address of number of stack items in effect in
@@ -486,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
@@ -525,10 +524,9 @@ s" IP" save-mem cell-type  s" error don'
 
 : process-simple ( -- )
     prim prim { W^ key } key cell
-    combinations ['] constant wordlist-insert
+    combinations ['] constant insert-wordlist
     declarations compute-offsets
-    output @ execute
-    1 function-number +! ;
+    output @ execute ;
 
 : flush-a-tos { stack -- }
     stack stack-out @ 0<> stack stack-in @ 0= and
@@ -587,38 +585,62 @@ s" IP" save-mem cell-type  s" error don'
 : stores ( -- )
     prim prim-effect-out prim prim-effect-out-end @ ['] store map-items ;
 
+: print-debug-arg { item -- }
+    ." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); "
+    ." printarg_" item item-type @ print-type-prefix
+    ." (" item item-name 2@ type ." );" cr ;
+    
+: print-debug-args ( -- )
+    ." #ifdef VM_DEBUG" cr
+    ." if (vm_debug) {" cr
+    prim prim-effect-in prim prim-effect-in-end @ ['] print-debug-arg map-items
+\    ." fputc('\n', vm_out);" cr
+    ." }" cr
+    ." #endif" cr ;
+
+: print-debug-result { item -- }
+    item item-first @ if
+	item print-debug-arg
+    endif ;
+
+: print-debug-results ( -- )
+    cr
+    ." #ifdef VM_DEBUG" cr
+    ." if (vm_debug) {" cr
+    ." fputs(" quote ."  -- " quote ." , vm_out); "
+    prim prim-effect-out prim prim-effect-out-end @ ['] print-debug-result map-items
+    ." fputc('\n', vm_out);" cr
+    ." }" cr
+    ." #endif" cr ;
+
+: 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
+    print-debug-results
     ." 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
     2drop type ;
 
-: print-debug-arg { item -- }
-    ." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); "
-    ." printarg_" item item-type @ print-type-prefix
-    ." (" item item-name 2@ type ." );" cr ;
-    
-: print-debug-args ( -- )
-    ." #ifdef VM_DEBUG" cr
-    ." if (vm_debug) {" cr
-    prim prim-effect-in prim prim-effect-in-end @ ['] print-debug-arg map-items
-    ." fputc('\n', vm_out);" cr
-    ." }" cr
-    ." #endif" cr ;
-
 : print-entry ( -- )
     ." I_" prim prim-c-name 2@ type ." :" ;
     
@@ -636,7 +658,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
@@ -660,7 +682,21 @@ s" IP" save-mem cell-type  s" error don'
     ."   fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr
     disasm-args
     ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
-    ." } else " ;
+    ."   goto _endif_;" cr
+    ." }" cr ;
+
+: 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
+    else
+	."   goto _endif_;" cr
+    endif
+    ." }" cr ;
 
 : gen-arg-parm { item -- }
     item item-stack @ inst-stream = if
@@ -759,14 +795,12 @@ s" IP" save-mem cell-type  s" error don'
 
 [IFDEF] documentation
 : register-doc ( -- )
-    get-current documentation set-current
-    prim prim-name 2@ nextname create
+    prim prim-name 2@ documentation ['] create insert-wordlist
     prim prim-name 2@ 2,
     prim prim-stack-string 2@ condition-stack-effect 2,
     prim prim-wordset 2@ 2,
     prim prim-c-name 2@ condition-pronounciation 2,
-    prim prim-doc 2@ 2,
-    set-current ;
+    prim prim-doc 2@ 2, ;
 [THEN]
 
 
@@ -903,7 +937,9 @@ s" IP" save-mem cell-type  s" error don'
 
 : process-combined ( -- )
     combined combined-prims num-combined @ cells
-    combinations ['] constant wordlist-insert
+    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 ;
@@ -926,7 +962,15 @@ s" IP" save-mem cell-type  s" error don'
     fetches ;
 
 : part-output-c-tail ( -- )
-    output-c-tail ;
+    print-debug-results
+    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
@@ -939,7 +983,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 ;
@@ -973,18 +1017,31 @@ 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
-    execute prim-c-name 2@ type space
-    combined-prims num-combined @ 1- th @ prim-c-name 2@ type ."  -> "
-    combined prim-c-name 2@ type cr ;
+    ." {"
+    execute prim-num @ 5 .r ." ,"
+    combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ,"
+    combined prim-num @ 5 .r ." }, /* "
+    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
 
@@ -1139,14 +1196,15 @@ 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
 
 (( {{ make-prim to prim 0 to combined
       line @ name-line ! filename 2@ name-filename 2!
+      function-number @ prim prim-num !
       start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }}  white ++
-   (( simple-primitive || combined-primitive ))
+   (( simple-primitive || combined-primitive )) {{ 1 function-number +! }}
 )) <- primitive ( -- )
 
 (( (( comment || primitive || nl white ** )) ** eof ))