Commit af9e6d3d authored by Bernd Paysan's avatar Bernd Paysan
Browse files

First steps to get peephole optimizing into cross

parent d53714f2

Makefile.in

+6 −1
Original line number Diff line number Diff line
@@ -516,7 +516,7 @@ bench: gforth-fast$(EXE) gforth.fi 
		@echo 'Each benchmark takes about 30s on a 486-66 (gcc-2.6.3 -DFORCE_REG)'

		time $(FORTH_FAST) siev.fs -e "main bye"

		time $(FORTH_FAST) bubble.fs -e "main bye"

		time $(FORTH_FAST) -m 160000 matrix.fs -e "main bye"

		time $(FORTH_FAST) -m 200000 matrix.fs -e "main bye"

		time $(FORTH_FAST) fib.fs -e "main bye"



# -------------	Make forth images
@@ -625,6 +625,11 @@ kernel/prim.fs: prim.b prims2x.fs kernel/prim0.fs 
		$(CP) $@- $@

		$(RM) $@-



kernel/peephole.fs:	prim.b prims2x.fs

		$(FORTH) -m 1000000 prims2x.fs -e "forth-flag on s\" prim.b\" ' noop ' output-forth-peephole process-file bye" >$@-

		$(CP) $@- $@

		$(RM) $@-



gforth$(EXE):		engines

		-$(CP) gforth$(EXE) gforth~

		$(CP) engine/$@ $@

cross.fs

+111 −99
Original line number Diff line number Diff line
@@ -656,27 +656,93 @@ hex 
4713 Constant <imm>             4714 Constant <do:>

4715 Constant <skip>



\ iForth makes only immediate directly after create

\ make atonce trick! ?

\  Compiler States



Variable atonce atonce off

Variable comp-state

0 Constant interpreting

1 Constant compiling

2 Constant resolving

3 Constant assembling



: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;

Defer lit, ( n -- )

Defer alit, ( n -- )



Defer branch, ( target-addr -- )	\ compiles a branch

Defer ?branch, ( target-addr -- )	\ compiles a ?branch

Defer branchmark, ( -- branch-addr )	\ reserves room for a branch

Defer ?branchmark, ( -- branch-addr )	\ reserves room for a ?branch

Defer ?domark, ( -- branch-addr )	\ reserves room for a ?do branch

Defer branchto, ( -- )			\ actual program position is target of a branch (do e.g. alignment)

Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark

Defer branchfrom, ( -- )		\ ?!

Defer branchtomark, ( -- target-addr )	\ marks a branch destination



Defer colon, ( tcfa -- )		\ compiles call to tcfa at current position

Defer colonmark, ( -- addr )		\ marks a colon call

Defer colon-resolve ( tcfa addr -- )



Defer addr-resolve ( target-addr addr -- )

Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )



: GhostHeader <fwd> , 0 , ['] NoExec , ;

Defer do,	( -- do-token )

Defer ?do,	( -- ?do-token )

Defer for,	( -- for-token )

Defer loop,	( do-token / ?do-token -- )

Defer +loop,	( do-token / ?do-token -- )

Defer next,	( for-token )



[IFUNDEF] ca>native

defer ca>native	

[THEN]



\ ghost structure



: >magic ;		\ type of ghost

: >link cell+ ;		\ pointer where ghost is in target, or if unresolved

			\ points to the where we have to resolve (linked-list)

: >exec cell+ cell+ ;	\ execution symantics (while target compiling) of ghost

: >end 3 cells + ;	\ room for additional tags

: >comp 3 cells + ;     \ compilation semantics

: >end 4 cells + ;	\ room for additional tags

			\ for builder (create, variable...) words the

			\ execution symantics of words built are placed here



\ resolve structure



: >next ;		\ link to next field

: >tag cell+ ;		\ indecates type of reference: 0: call, 1: address, 2: doer

: >taddr cell+ cell+ ;	

: >ghost 3 cells + ;

: >file 4 cells + ;

: >line 5 cells + ;



\ refer variables



Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>

Variable last-ghost	\ last ghost that is created

Variable last-header-ghost \ last ghost definitions with header



: (refered) ( ghost addr tag -- )

\G creates a reference to ghost at address taddr

    rot >r here r@ >link @ , r> >link ! 

    ( taddr tag ) ,

    ( taddr ) , 

    last-header-ghost @ , 

    loadfile , 

    sourceline# , 

  ;



\ iForth makes only immediate directly after create

\ make atonce trick! ?



Variable atonce atonce off



: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;



: is-forward   ( ghost -- )

  colonmark, 0 (refered) ; \ compile space for call



: GhostHeader <fwd> , 0 , ['] NoExec , ['] is-forward , ;



: Make-Ghost ( "name" -- ghost )

  >in @ GhostName swap >in !

  <T Create atonce @ IF immediate atonce off THEN
@@ -743,9 +809,10 @@ ghost (does>) ghost noop 2drop 
ghost (.")      ghost (S")      ghost (ABORT")  2drop drop

ghost '                                         drop

ghost :docol    ghost :doesjump ghost :dodoes   2drop drop

ghost :dovar					drop

ghost :dovar	ghost :dodefer  ghost :dofield  2drop drop

ghost over      ghost =         ghost drop      2drop drop

ghost - drop

ghost call      ghost useraddr  ghost execute   2drop drop

ghost +         ghost -         ghost @         2drop drop

ghost 2drop drop

ghost 2dup drop
@@ -1268,45 +1335,6 @@ previous 


\ \ --------------------        Compiler Plug Ins               01aug97jaw



\  Compiler States



Variable comp-state

0 Constant interpreting

1 Constant compiling

2 Constant resolving

3 Constant assembling



Defer lit, ( n -- )

Defer alit, ( n -- )



Defer branch, ( target-addr -- )	\ compiles a branch

Defer ?branch, ( target-addr -- )	\ compiles a ?branch

Defer branchmark, ( -- branch-addr )	\ reserves room for a branch

Defer ?branchmark, ( -- branch-addr )	\ reserves room for a ?branch

Defer ?domark, ( -- branch-addr )	\ reserves room for a ?do branch

Defer branchto, ( -- )			\ actual program position is target of a branch (do e.g. alignment)

Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark

Defer branchfrom, ( -- )		\ ?!

Defer branchtomark, ( -- target-addr )	\ marks a branch destination



Defer colon, ( tcfa -- )		\ compiles call to tcfa at current position

Defer colonmark, ( -- addr )		\ marks a colon call

Defer colon-resolve ( tcfa addr -- )



Defer addr-resolve ( target-addr addr -- )

Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )



Defer do,	( -- do-token )

Defer ?do,	( -- ?do-token )

Defer for,	( -- for-token )

Defer loop,	( do-token / ?do-token -- )

Defer +loop,	( do-token / ?do-token -- )

Defer next,	( for-token )



[IFUNDEF] ca>native

defer ca>native	

[THEN]



>TARGET

DEFER >body             \ we need the system >body

			\ and the target >body
@@ -1342,25 +1370,6 @@ DEFER comp[ \ ends compilation 
: compile, colon, ;

>CROSS



\ resolve structure



: >next ;		\ link to next field

: >tag cell+ ;		\ indecates type of reference: 0: call, 1: address, 2: doer

: >taddr cell+ cell+ ;	

: >ghost 3 cells + ;

: >file 4 cells + ;

: >line 5 cells + ;



: (refered) ( ghost addr tag -- )

\G creates a reference to ghost at address taddr

    rot >r here r@ >link @ , r> >link ! 

    ( taddr tag ) ,

    ( taddr ) , 

    last-header-ghost @ , 

    loadfile , 

    sourceline# , 

  ;



: refered ( ghost tag -- )

\G creates a resolve structure

    T here aligned H swap (refered)
@@ -1430,6 +1439,9 @@ Exists-Warnings on 
  ELSE  true abort" CROSS: Ghostnames inconsistent "

  THEN ;



: is-resolved   ( ghost -- )

  >link @ colon, ; \ compile-call



: resolve  ( ghost tcfa -- )

\G resolve referencies to ghost with tcfa

    \ is ghost resolved?, second resolve means another definition with the
@@ -1439,6 +1451,7 @@ Exists-Warnings on 
    swap >r r@ >link @ swap \ ( list tcfa R: ghost )

    \ mark ghost as resolved

    dup r@ >link ! <res> r@ >magic !

    r@ >comp @ ['] is-forward = IF  ['] is-resolved r@ >comp !  THEN

    \ loop through forward referencies

    r> -rot 

    comp-state @ >r Resolving comp-state !
@@ -1450,17 +1463,11 @@ Exists-Warnings on 


\ gexecute ghost,                                      01nov92py



: is-forward   ( ghost -- )

  colonmark, 0 (refered) ; \ compile space for call



: is-resolved   ( ghost -- )

  >link @ colon, ; \ compile-call



: gexecute   ( ghost -- )

  dup @ <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;

    dup >comp @ execute ;



: addr,  ( ghost -- )

  dup @ <fwd> = IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;

  dup forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;



\ !! : ghost,     ghost  gexecute ;
@@ -1868,33 +1875,27 @@ Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond 
\ some special literals					27jan97jaw



\ !! Known Bug: Special Literals and plug-ins work only correct

\ on 16 and 32 Bit Targets and 32 Bit Hosts!

\ on targets with char = 8 bit



Cond: MAXU

  restrict? 

  tcell 1 cells u> 

  IF	compile lit tcell 0 ?DO FF T c, H LOOP 

  ELSE	ffffffff lit, THEN

  compile lit tcell 0 ?DO FF T c, H LOOP 

  ;Cond



Cond: MINI

  restrict?

  tcell 1 cells u>

  IF	compile lit bigendian 

  compile lit bigendian 

  IF	80 T c, H tcell 1 ?DO 0 T c, H LOOP 

  ELSE  tcell 1 ?DO 0 T c, H LOOP 80 T c, H

  THEN

  ELSE	tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN

  ;Cond

 

Cond: MAXI

 restrict?

 tcell 1 cells u>

 IF	compile lit bigendian 

 compile lit bigendian 

 IF 	7F T c, H tcell 1 ?DO FF T c, H LOOP

 ELSE 	tcell 1 ?DO FF T c, H LOOP 7F T c, H

 THEN

 ELSE	tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN

 ;Cond



>CROSS
@@ -2007,8 +2008,6 @@ Cond: DOES> restrict? 
  Make-Ghost 		( Create-xt do:-xt ghost )

  rot swap		( do:-xt Create-xt ghost )

  >exec ! , ;

\  rot swap >exec dup @ ['] NoExec <>

\  IF 2drop ELSE ! THEN , ;



: gdoes,  ( ghost -- )

\ makes the codefield for a word that is built
@@ -2034,8 +2033,9 @@ Cond: DOES> restrict? 
\ stores execution semantic in the built word

\ if the word already has a semantic (concerns S", IS, .", DOES>)

\ then keep it

  >end @ >exec @ r> >exec dup @ ['] NoExec =

  IF ! ELSE 2drop THEN ;

  >end @

  dup >exec @ r@ >exec dup @ ['] NoExec =  IF ! ELSE 2drop THEN

  >comp @ r> >comp ! ;



: RTCreate ( <name> -- )

\ creates a new word with code-field in ram
@@ -2067,27 +2067,34 @@ Cond: DOES> restrict? 
  postpone TCreate 

  [ [THEN] ] ;



: g>body ( ghost -- body )

    >link @ T >body H ;

: gdoes>  ( ghost -- addr flag )

  executed-ghost @

  state @ IF  gexecute true EXIT  THEN

  >link @ T >body H false ;

  g>body false ;



\ DO: ;DO                                               11may93jaw

\ changed to ?EXIT                                      10may93jaw



: DO:     ( -- addr [xt] [colon-sys] )

: DO:     ( -- ghost [xt] [colon-sys] )

  here ghostheader

  :noname postpone gdoes> postpone ?EXIT ;



: by:     ( -- addr [xt] [colon-sys] ) \ name

: by:     ( -- ghost [xt] [colon-sys] ) \ name

  ghost

  :noname postpone gdoes> postpone ?EXIT ;



: ;DO ( addr [xt] [colon-sys] -- addr )

: ;DO ( ghost [xt] [colon-sys] -- ghost )

  postpone ;    ( S addr xt )

  over >exec ! ; immediate



: by      ( -- addr ) \ Name

: compile: ( ghost -- ghost [xt] [colon-sys] )

    :noname  postpone g>body ;

: ;compile ( ghost [xt] [colon-sys] -- ghost )

    postpone ;  over >comp ! ;



: by      ( -- ghost ) \ Name

  ghost >end @ ;



>TARGET
@@ -2095,6 +2102,7 @@ Cond: DOES> restrict? 


Build:  ( n -- ) ;

by: :docon ( ghost -- n ) T @ H ;DO

\ compile: alit, compile @ ;compile

Builder (Constant)



Build:  ( n -- ) T , H ;
@@ -2111,6 +2119,7 @@ Builder 2Constant 


BuildSmart: ;

by: :dovar ( ghost -- addr ) ;DO

\ compile: alit, ;compile

Builder Create



T has? rom H [IF]
@@ -2162,6 +2171,7 @@ Variable tudp 0 tudp ! 


Build: 0 u, X , ;

by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO

\ compile: compile useraddr @ , ;compile

Builder User



Build: 0 u, X , 0 u, drop ;
@@ -2182,6 +2192,7 @@ Builder AValue 


BuildSmart:  ( -- ) [T'] noop T A, H ;

by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO

\ compile: alit, compile @ compile execute ;compile

Builder Defer



Build: ( inter comp -- ) swap T immediate A, A, H ;
@@ -2198,6 +2209,7 @@ Builder interpret/compile: 


Build: ;

by: :dofield T @ H + ;DO

\ compile: T @ H lit, compile + ;compile

Builder (Field)



Build: ( align1 offset1 align size "name" --  align2 offset2 )

prim

+1 −0
Original line number Diff line number Diff line
@@ -126,6 +126,7 @@ 
\ these m4 macros would collide with identifiers

undefine(`index')

undefine(`shift')

undefine(`symbols')



noop	( -- )		gforth

:

prims2x.fs

+9 −0
Original line number Diff line number Diff line
@@ -1013,6 +1013,15 @@ s" IP" save-mem w s" error don't use # on results" make-stack inst-stream 
    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