??cr .( ** V. 0.71 optmizing compiler using generated inline primitives) cr
warning @ warning off
\ optimizing inline compiler
\ using inlined generated & optimized primitives
\ By reading last-compiled the compiler knows about code sequences without branching.
\ It also knows about "inlineable" primitives - they are found in the table opt-primitives -
\ and about optimizable words like constants, variables ...
\ During normal compilation a table is created holding these code parts that can be optimized.
\ Now the word 'optimize' replaces those sequences with assembler code.
\ Branching just after an optimizable area is included into the new primitive without use
\ of the forth virtial machine if possible.
\ Copyright hs 23.01.98

\ possible problem with existing applications:
\   applications changing the value of a constant by is or other methods can't use inlined
\   constants in the optimized code, you should set i-constant? to false

only forth also definitions
false constant i-constant?

system also hidden also definitions forth decimal
: [fth]		forth ; immediate
: [ass]		arm-assembler ; immediate

512 cells buffer: *opts			\ buffer of 2cells entries
0 constant #opts			\ entries in buffer *opts
0 pointer  opt?				\ list to be optimized already in use ?
0 constant #opwords			\ length of current optimizer list
: clear-opts	*opts 512 cells erase  0 is #opts  0 is opt?  0 is #opwords ;
: mark-opt	opt? #opwords  *opts #opts 2* cells+ 2!
		0 is opt?  0 is #opwords  #opts 1+ is #opts ; 	
: opt-target?	( addr -- flag )
	0 #opts 0 do over *opts i 2* cells+ 2@ 1 > -rot = and if drop true leave then loop nip ;
create opt-primitives
  ' bl word-type a,
  ' !ops word-type a,
  ' p_tasks word-type a,
  ' origin word-type a,
  ' cstrbuf word-type a,
  ' dp word-type a,
  ' (lit) a,    ' (dlit) a,   ' i a,         ' j a,          ' k a,
  ' noop a,     ' and a,      ' or a,        ' xor a,        ' not a,
  ' invert a,   ' cnot a,     ' lshift a,    ' rshift a,     ' >>a a,
  ' + a,        ' - a,        ' negate a,    ' ?negate a,    ' abs a,
  ' min a,      ' max a,      ' umin a,      ' umax a,       ' up@ a,
  ' sp@ a,      ' up! a,      ' rp@ a,       ' sp! a,        ' rp! a,
  ' >r a,       ' r> a,       ' r@ a,        ' >ip a,        ' ip> a,
  ' ip@ a,      ' ip>token a, ' 2>r a,       ' 2r> a,        ' 2r@ a,
  ' tuck a,     ' nip a,      ' lwsplit a,   ' wljoin a,     ' wflip a,
  ' flip a,     ' 0= a,       ' 0<> a,       ' 0< a,         ' 0>= a,
  ' 0> a,       ' 0<= a,      ' > a,         ' < a,          ' = a,
  ' <> a,       ' u< a,       ' u>= a,       ' >= a,         ' <= a,
  ' drop a,     ' dup a,      ' ?dup a,      ' over a,       ' swap a,
  ' rot a,      ' -rot a,     ' 2drop a,     ' 3drop a,      ' 2dup a,
  ' 2swap a,    ' 3dup a,     ' pick a,      ' between a,    ' 1+ a,
  ' 2+ a,       ' 1- a,       ' 2- a,        ' 2/ a,         ' u2/ a,
  ' 2* a,       ' 4* a,       ' 8* a,        ' on a,         ' off a,
  ' +! a,       ' @ a,        ' @+ a,        ' c@ a,         ' ! a,
  ' !+ a,       ' c! a,       ' 2@ a,        ' 2! a,         ' s>d a,
  ' d+ a,       ' d- a,       ' d< a,        ' d> a,         ' du< a,
  ' dnegate a,  ' ?dnegate a, ' dabs a,      ' d0= a,        ' d0< a,
  ' d2* a,      ' d2/ a,      ' m+ a,        
  ' /link a,    ' /token a,   ' #align a,    ' #acf-align a, ' /char a,
  ' /cell a,    ' chars a,    ' cells a,     ' char+ a,      ' cell+ a,
  ' chars+ a,   ' cells+ a,   ' next-char a, ' count a,      ' roll a,
  ' >body a,    ' body> a,    ' * a,         ' u* a,         ' (unloop) a,
  ' (leave) a,  ' exit a,     ' ?exit a,     ' (?leave) a,
StrongARM? [if]	' um* a,      ' m* a,	[then]  0 a,

: optimizable?	( cfa -- flag )
	dup ['] / = if drop true exit then	dup ['] /mod = if drop true exit then
	dup ['] mod = if drop true exit then
	word-type opt-primitives find-in-table if false else drop true then ;
: copy-code	( adr -- )	begin dup @  ['] noop @ <> while dup @ ,  cell+  repeat drop ;
code (/mod)	\ r0:n.dividend top:s.divisor -- r0:s.rem top:s.quot )
	(s n.dividend s.divisor -- s.rem s.quot )
		r5	lk	mov	r0	0 #	cmp
	lt if	r0	r0 0 #	rsb	top	0 #	cmp
	  lt if	top	top 0 #	rsb
		' (32/32division)	dolink branch	\ r0 / top =   r0.rem top.quot
		r0	r0 0 #	rsb
	  else	r4	top	mov
		' (32/32division)	dolink branch	\ r0 / top =   r0.rem top.quot
		top	top 0 #	rsb	r0	0 #	cmp
		top	1	ne decr	r0	r4 r0	ne sub
	  then
	else	top	0 #	cmp
	  lt if	r4	top	mov	top	top 0 #	rsb
		' (32/32division)	dolink branch	\ r0 / top =   r0.rem top.quot
		top	top 0 #	rsb	r0	0 #	cmp
		top	1	ne decr	r0	r0 r4	ne add
	  else	' (32/32division)	dolink branch	\ r0 / top =   r0.rem top.quot
	  then
	then	pc	r5		mov end-code

code fast-i			r0 rp 4 d) ldr  top r6 r0 s add c;
: make-fast-i	( end start --)	?do i 2@  ['] i cell+ 2@ d= if ['] fast-i 2@  i 2! then /cell +loop ;
: push-top	( -- )		[ass] top sp push [fth] ;
: pop-top	( -- )		[ass] top sp pop [fth] ;
: test-top	( -- )		[ass] top 0 # cmp  top sp pop [fth] ;
: test-top/r0	( -- )		[ass] r0 top cmp   top sp pop [fth] ;
: increase-ip	( n -- )	[ass] ip swap s incr [fth] ;
: correct-ip	( n - )
	[ass] opcode [fth] @ locals| mode diff |
	diff abs 1020 < if [ass] ip diff incr [fth] else [ass] r4 diff # mov mode opcode !  ip ip r4 add [fth] then ;
: comp_lit	( n -- )	push-top [ass] top swap # mov [fth] ;
: comp_dlit	( d -- )	swap comp_lit comp_lit ;
: ass-lksub	( off reg -- )	swap [ass] r7 swap # sub [fth] ;
: ass-lkadd	( off reg -- )	swap [ass] r7 swap # add [fth] ;
: ass-regsub	( off reg )	swap [ass] decr [fth] ;
: ass-regadd	( off reg )	swap [ass] decr [fth] ;
: ass-adr	\ ( to-register offset -- ) assembles an addressess instruction sequence
	dup abs swap 0> locals| dir offset reg | dir
	if	offset [ass] imm? [fth] if offset reg ass-lksub exit then
		offset	h# ff  2 lshift and 		reg ass-lksub
		offset  h# ff 10 lshift and ?dup	if reg ass-regsub then
		offset  h# ff 18 lshift and ?dup	if reg ass-regsub then
		offset  h# ff 26 lshift and ?dup	if reg ass-regsub then
	else	offset [ass] imm? [fth] if offset reg ass-lkadd exit then
		offset	h# ff  2 lshift and 		reg ass-lkadd
		offset  h# ff 10 lshift and ?dup	if reg ass-regadd then
		offset  h# ff 18 lshift and ?dup	if reg ass-regadd then
		offset  h# ff 26 lshift and ?dup	if reg ass-regadd then
	then ;
: comp_adr	( base addr --)	@ >body - push-top [ass] top swap ass-adr [fth] ;
: comp_con	( base addr-- )	comp_adr [ass] top top ) ldr [fth] ;
: comp_true	( -- )		push-top [ass] top -1 # mov [fth] ;
: comp_false	( -- )		push-top [ass] top 0 # mov [fth] ;
: comp_user	( adrs -- )	push-top @ >body @ [ass] top swap # mov  top top up add [fth] ;
: comp_const	( base addr-- )	i-constant? if nip a@ >body @ comp_lit else comp_adr [ass] top top ) ldr [fth] then ;
: arith?	( addr -- flag)	here -1 cells+ @ h# fc100000 and  h# e0100000 = ;
: get-reg#	( addr -- reg )	@ 12 rshift 15 and ;
: push-rx?	( addr -- flag)	@ h# ffff0fff and h# e52d0004 = ;
: pop-rx?	( addr -- flag)	@ h# ffff0fff and h# e49d0004 = ;
: mov-rx?	( addr -- flag)	@ h# ffff0000 and h# e3a00000 = ;
: sublktop?	( addr -- flag)	@ h# fffff000 and h# e247a000 = ;
: subtoptop?	( addr -- flag)	@ h# fffff000 and h# e24aa000 = ;
: topldr?	( addr -- flag)	@ h# e59aa000 = ;
: push-top?	( addr -- flag)	@ h# e52da004 = ;
: mov-top?	( addr -- flag)	@ h# fffff000 and h# e3a0a000 = ;
: mvn-top?	( addr -- flag)	@ h# fffff000 and h# e3e0a000 = ;
: imm-val?	( addr -- flag)	@ dup h# ff and swap 8 rshift h# 0f and 2* [ass] rotr [fth] ;
: short-imm?	( -- imm -1|0 )
	here -2 cells+ push-top? here -1 cells+ mov-top? and if	here -1 cells+ imm-val? -2 cells allot true exit then
	here -2 cells+ push-top? here -1 cells+ mvn-top? and if	here -1 cells+ imm-val? invert -2 cells allot true exit	then
	false ;
: comp_?dup	arith?
	if [ass] top sp ne push [fth] else ['] ?dup copy-code then ;
: comp_+	short-imm?
	if	dup [ass] imm? [fth]
		if [ass] top top rot # s add [fth] else	[ass] r0 swap # mov  top top r0 s add [fth] then
	else	['] + copy-code
	then ;
: comp_-	short-imm?
	if	dup [ass] imm? [fth]
		if [ass] top top rot # s sub [fth] else	[ass] r0 swap # mov  top top r0 s sub [fth] then
	else	['] - copy-code
	then ;
: comp_and	short-imm?
	if	dup [ass] imm? [fth]
		if [ass] top top rot # s and [fth] else	[ass] r0 swap # mov  top top r0 s and [fth] then
	else	['] and copy-code
	then ;
: comp_or	short-imm?
	if	dup [ass] imm? [fth]
		if [ass] top top rot # s orr [fth] else	[ass] r0 swap # mov  top top r0 s orr [fth] then
	else	['] or copy-code
	then ;
: comp_xor	short-imm?
	if	dup [ass] imm? [fth]
		if [ass] top top rot # s eor [fth] else	[ass] r0 swap # mov  top top r0 s eor [fth] then
	else	['] xor copy-code
	then ;
: comp_=	short-imm?
	if	dup [ass] imm? [fth]
		if [ass] top swap # cmp	[fth] else [ass] r0 swap # mov top r0 cmp [fth] then
		[ass] top -1 # eq mov  top 0 # ne mov [fth]
	else	['] = copy-code
	then ;
: comp_<	short-imm?
	if	dup [ass] imm? [fth]
		if [ass] top swap # cmp	[fth] else [ass] r0 swap # mov top r0 cmp [fth] then
		[ass] top -1 # lt mov  top 0 # ge mov [fth]
	else	['] < copy-code
	then ;
: comp_>	short-imm?
	if	dup [ass] imm? [fth]
		if [ass] top swap # cmp	[fth] else [ass] r0 swap # mov top r0 cmp [fth] then
		[ass] top -1 # gt mov  top 0 # le mov [fth]
	else	['] > copy-code
	then ;
: comp_<>	short-imm?
	if	dup [ass] imm? [fth]
		if [ass] top top rot # s sub [fth] else [ass] r0 swap # mov  top r0 top s sub [fth] then
		[ass] top -1 # ne mov [fth]
	else	['] <> copy-code
	then ;
: comp_*	short-imm?
	if	case
		-2	of [ass] top top 0 # rsb  top top 1 #lsl mov		endof
		-1	of [ass] top top 0 # rsb [fth]				endof
		1	of							endof
		2	of [ass] top top 1 #lsl mov	[fth]			endof
		3	of [ass] top top top 1 #lsl add	[fth]			endof
		4	of [ass] top top 2 #lsl mov	[fth]			endof
		5	of [ass] top top top 2 #lsl add	[fth]			endof
		6	of [ass] top top 1 #lsl mov top top top 1 #lsl add [fth] endof
		7	of [ass] top top top 3 #lsl rsb	[fth]			endof
		8	of [ass] top top 3 #lsl mov	[fth]			endof
		9	of [ass] top top top 3 #lsl add	[fth]			endof
		10	of [ass] top top 1 #lsl mov top top top 2 #lsl add [fth] endof
		16	of [ass] top top 4 #lsl mov	[fth]			endof
		32	of [ass] top top 5 #lsl mov	[fth]			endof
		64	of [ass] top top 6 #lsl mov	[fth]			endof
		128	of [ass] top top 7 #lsl mov	[fth]			endof
		256	of [ass] top top 8 #lsl mov	[fth]			endof
			dup [ass] r0 swap # mov  top r0 top mul	[fth]
		endcase
	else	['] * copy-code
	then ;
: comp_swap	short-imm?
	if [ass] r0 swap # mov  r0 sp push [fth] else ['] swap copy-code then ;
: comp_rot	short-imm?
	if [ass] r1 top mov  top sp pop  r0 swap # mov  r0 r1 2 sp db! stm [fth] else ['] rot copy-code then ;
: comp_-rot	short-imm?
	if [ass] r0 swap # mov  r1 sp ) ldr  r0 sp ) str r1 sp push [fth] else ['] -rot copy-code then ;
: comp_over	short-imm?	( n1 imm -- n1 imm n1 )
	if [ass] r0 swap # mov  r0 top 2 sp db! stm [fth] else	['] over copy-code then ;
: comp_/	short-imm?
	if [ass] r0 top mov  top swap # mov [fth] else [ass] r0 sp pop [fth] then
	[ass] ['] (/mod) dolink branch [fth] ;
: comp_/mod	short-imm?
	if [ass] r0 top mov  top swap # mov [fth] else [ass] r0 sp pop [fth] then
	[ass]  ['] (/mod) dolink branch  r0 sp push [fth] ;
: comp_mod	short-imm?
	if [ass] r0 top mov  top swap # mov [fth] else [ass] r0 sp pop [fth] then
	[ass]  ['] (/mod) dolink branch  top r0 mov [fth] ;

\ Type 0		rx sp push	rz sp pop
: peep0	( adrs end -- )
	swap dup get-reg# over cell+ get-reg# here locals| ohere r-pop r-push adrs end | adrs dp !
	r-pop r-push =
	if	adrs 2 cells+ adrs		end over - move	ohere dp ! -2 cells allot
	else	[ass] r-pop r-push mov [fth]
		adrs 2 cells+ adrs 1 cells +	end over - move	ohere dp ! -1 cells allot
	then ;
\ Type 1		rx sp push	ry ### mov/top pc ### sub	rz sp pop
: peep1	( adrs end -- )
	swap dup get-reg# over cell+ get-reg# 0 here locals| ohere r-pop r-mov r-push adrs end |
	adrs 2 cells+ get-reg# is r-pop  adrs dp !
	[ass] r-pop r-push mov [fth]
	r-mov r-pop =
	if	adrs 3 cells+  adrs 1 cells+  end over - move	ohere dp ! -2 cells allot
	else	adrs 3 cells+  adrs 2 cells+  end over - move	ohere dp ! -1 cells allot
	then ;

\ Type 2		rx sp pop	ry sp pop
: peep2	( adrs end -- )
	swap dup get-reg# over cell+ get-reg# here locals| ohere r-pop2 r-pop1 adrs end | adrs dp !
	r-pop1 r-pop2 =
	if	[ass] sp /cell incr [fth] 	ohere dp ! then
	r-pop1 r-pop2 <
	if	[ass] r-pop1 r-pop2 2 sp ia! ldm	[fth]
		adrs 2 cells+  adrs 1 cells+  end over - move	ohere dp ! -1 cells allot
	then
	r-pop1 r-pop2 > if ohere dp ! then ;
\ Type 3		rx sp push	top pc ### sub  top top ### sub/top top) ldr  	rz sp pop
: peep3	( adrs end -- )
	swap dup get-reg# over 3 cells+ get-reg# here locals| ohere r-pop r-push adrs end | adrs dp !
	[ass] r-pop r-push mov   [fth]
	d# 10 r-pop =
	if	adrs 4 cells+  adrs 1 cells+  end over - move	ohere dp ! -3 cells allot
	else	adrs 4 cells+  adrs 3 cells+  end over - move	ohere dp ! -1 cells allot
	then ;

\ Type 4		rx sp push	top pc ### sub  top top ### sub	 top top) ldr	rz sp pop
: peep4	( adrs end -- )
	swap dup get-reg# over 4 cells+ get-reg# here locals| ohere r-pop r-push adrs end | adrs dp !
	[ass] r-pop r-push mov   [fth]
	d# 10 r-pop =
	if	adrs 5 cells+  adrs 1 cells+  end over - move	ohere dp ! -4 cells allot
	else	adrs 5 cells+  adrs 4 cells+  end over - move	ohere dp ! -1 cells allot
	then ;
\ Type 5		rx sp pop	rx sp push
: peep5	( adrs end -- )
	swap dup get-reg# over cell+ get-reg# here locals| ohere r-push r-pop adrs end | adrs dp !
	r-pop r-push =
	if	[ass] r-pop sp ) ldr [fth]
		adrs 2 cells+ adrs 1 cells +	end over - move		ohere dp ! -1 cells allot
	then ;
\ Type 6		rx sp push   code-i code-i  ry sp pop
: peep6	( adrs )
	dup get-reg# over 3 cells+ get-reg# here locals| ohere r-pop r-push adrs | adrs dp !
	[ass] r2 r-push mov [fth] 2 cells dp +!  [ass] r-pop r2 mov [fth]
	ohere dp ! ;	
\ Type 7 top sp ) ldr  top sp pop
: peep7	( adrs end )
	>r dup cell+ swap r> over - move -1 cells allot ;

: resolve-branches	( end start -- )
\	??cr cr	cr cr 2dup last @ .id 2 spaces .h .h cr
	?do	\ i dis1  exit? drop
		i @ h# f0000000 and h# f0000000 =  i @ h# 00ffffff and origin here between and
		if	i @ h# 0f000000 and 4 lshift  i @ h# 00ffffff and @ i [ass] put-call [fth]
			i @ h# 0fffffff and or i !
		then
	/cell +loop ;
: peephole-code-area	( start end -- )
	0 0 0 0 0 locals| cnt #peep r-mov r-push r-pop end start |
	begin	#peep 0>=  cnt 100 < and
	while	end start
	  do	-1 is #peep
	  	i push-rx?
		if	i cell+ pop-rx?                                                 if 0 is #peep	then
			i cell+ dup mov-rx? swap sublktop? or  i 2 cells+ pop-rx? and   if 1 is #peep	then
                        i cell+ sublktop?  i 2 cells+ dup subtoptop? swap topldr? or and  i 3 cells+ pop-rx? and
				if 3 is #peep	then
                        i cell+ sublktop?  i 2 cells+ subtoptop? and  i 3 cells+ topldr? and   i 4 cells+ pop-rx? and
                        	if 4 is #peep	then
			i cell+ 2@  ['] i cell+ 2@ d=  i 3 cells+ pop-rx? and           if 6 is #peep	then
		then
		i pop-rx?  i cell+ push-rx? and						if 5 is #peep	then
		i pop-rx? i cell+ pop-rx? and						if 2 is #peep	then	 
		i @ h# e59da000 = i cell+ @ dup h# e59da004 = swap h# E49DA004 = or and	if 7 is #peep	then
		#peep
 		case	0 of	i end peep0	endof	1 of	i end peep1	endof	2 of	i end peep2	endof
			3 of	i end peep3	endof	4 of	i end peep4	endof	5 of	i end peep5	endof
			6 of	i peep6		endof	7 of	i end peep7	endof
		endcase #peep 0>= ?leave
	  /cell +loop
	  cnt 1+ is cnt
	repeat ;
gdefer tested?
: wtype?	( addr cfa -- flag ) word-type swap @ word-type = ;
: comp_tested?	( start adrs )
	locals| adrs start | [ass]  ['] eq [fth] is tested?
	start adrs > if test-top exit then
	adrs -1 cells+ @
	case
		['] 0<>	of -2 cells allot [ass] ['] eq [fth] is tested? test-top	endof
		['] 0=	of -2 cells allot [ass] ['] ne [fth] is tested?	test-top	endof
		['] 0>	of -2 cells allot [ass] ['] le [fth] is tested?	test-top	endof
		['] 0<	of -1 cells allot [ass] ['] ge [fth] is tested?	test-top	endof
		['] 0>=	of -1 cells allot [ass] ['] lt [fth] is tested?	test-top	endof
		['] 0<=	of -3 cells allot [ass] ['] gt [fth] is tested?	test-top	endof
		['] >	of -2 cells allot [ass] ['] le [fth] is tested?	pop-top		endof
		['] u>	of -2 cells allot [ass] ['] ls [fth] is tested?	test-top/r0	endof
		['] <	of -2 cells allot [ass] ['] ge [fth] is tested?	pop-top		endof
		['] u<	of -2 cells allot [ass] ['] cs [fth] is tested?	test-top/r0	endof
		['] =	of -2 cells allot [ass] ['] ne [fth] is tested?	pop-top		endof
		['] <>	of -1 cells allot [ass] ['] eq [fth] is tested?	pop-top		endof
		['] <=	of -2 cells allot [ass] ['] gt [fth] is tested?	pop-top		endof
		['] >=	of -2 cells allot [ass] ['] lt [fth] is tested?	pop-top		endof
		['] and	of pop-top	endof	['] or	of pop-top	endof
		['] xor	of pop-top	endof   ['] +	of pop-top	endof
		['] -	of pop-top	endof   ['] not	of pop-top	endof
	 	['] invert of pop-top	endof
		test-top
	endcase ;
: invert-last-condition		[ass] opcode [fth] dup @ h# 10000000 xor swap ! ;
: do-peep	\ ( addr -- ) remove pc relative code if possible
	locals| codebegin |
	0  here codebegin do i sublktop? or /cell +loop 0= if codebegin dup cell+ swap here over - move -1 cells allot then
	codebegin here 0 , 0 , 0 , 0 , peephole-code-area -4 cells allot  ;
: inline-cfa-area	( addr first-cfa cells -- )
	0 , over here locals| codebegin adrs cnt start inlines |
	[ass] r7 pc 2 cells # sub [fth]
	cnt 0
	do	adrs @ dup word-type =	\ do appropriate compilation for primitives
		if	adrs @		\ cfa of instruction
			case	['] (lit)	of adrs cell+ dup @ comp_lit is adrs			endof
				['] (dlit)	of adrs cell+ 2@ comp_dlit	adrs 2 cells+ is adrs	endof
				['] (leave)	of adrs @ copy-code [ass] pc 1 ip ia! ldm [fth]	endof
				['] exit	of [ass] ip rp )+ ldr  pc 1 ip ia! ldm [fth] 		endof
				['] ?exit	of start adrs comp_tested?	
						   [ass] ip rp )+ tested? invert-last-condition ldr
						   pc 1 ip ia! tested? invert-last-condition ldm [fth]	endof
				['] (?leave)	of start adrs comp_tested?
						   [ass] tested? invert-last-condition postpone if
						   rp 8 incr  ip rp )+ ldr  ip ip ) ldr
						   pc 1 ip ia! ldm postpone then [fth]			endof
				['] ?dup	of	comp_?dup	endof
				['] +		of	comp_+		endof
				['] -		of	comp_-		endof
				['] and		of	comp_and	endof
				['] or		of	comp_or		endof
				['] xor		of	comp_xor	endof
				['] =		of	comp_=		endof
				['] >		of	comp_>		endof
				['] <		of	comp_<		endof
				['] <>		of	comp_<>		endof
				['] *		of	comp_*		endof
				['] u*		of	comp_*		endof
				['] swap	of	comp_swap	endof
				['] rot		of	comp_rot	endof
				['] over	of	comp_over	endof
				['] /mod	of	comp_/mod	endof
				['] -rot	of	comp_-rot	endof
				adrs @ copy-code
			endcase
		else	adrs @ ['] true =	if comp_true			else
			adrs @ ['] false =	if comp_false			else
( secondary ..)		adrs @ ['] / =		if comp_/			else
( secondary ..)		adrs @ ['] mod =	if comp_mod			else
( variables )		adrs ['] p_tasks wtype?	if codebegin adrs comp_adr	else
( create )		adrs ['] !ops wtype?	if codebegin adrs comp_adr	else
( constants )		adrs ['] bl wtype?	if codebegin adrs comp_const	else
( pointer )		adrs ['] origin wtype?	if codebegin adrs comp_const	else
( buffer )		adrs ['] *opts wtype?	if codebegin adrs comp_const	else
( user vars )		adrs ['] dp wtype?	if adrs comp_user then
			then then then then then then then then then
		then	adrs cell+ is adrs
	loop
	adrs start - h# 0ff00000 + codebegin /cell - !	\ leave length for decompiler
	\ patch address of executed code in first optimized cfa
	codebegin start a!
	adrs @ ['] ?branch =
	if	start adrs comp_tested?		\ compile testcode if flags aren't set already
                adrs cell+ @ opt-target?
                if	adrs cell+ @ start - tested? correct-ip
			adrs cell+ @ h# 00ffffff and  h# f0000000 or
			tested? [ass] opcode [fth] @ 4 rshift h# 0f000000 and or ,
			[ass] al [fth]
		else	adrs start - [ass] ip ip rot d) tested? ldr  tested? next [fth]
		then
		adrs 2 cells+ inlines 3 cells+ @ = inlines 2 cells+ @ 1 > and
		if adrs start - 2 cells+ increase-ip else adrs start - cell+ increase-ip [ass] next [fth]
		then	codebegin do-peep exit
	then
	adrs @ ['] branch =
	if	adrs cell+ @ opt-target?
		if	adrs cell+ @ start - increase-ip
			adrs cell+ @ h# 00ffffff and  h# fe000000 or ,
		else	adrs start - [ass] ip ip rot d) ldr  next [fth]
		then	codebegin do-peep exit
	then
	adrs @ ['] (loop) =
	if	[ass] r0 rp ) ldr  r0 1 s incr  r0 rp ) vc str [fth]
		adrs cell+ @ opt-target?
		if	adrs cell+ @ start =	\ just one primitive in loop
			if	-3 cells allot [ass] r6 1 s incr [fth]
				here codebegin make-fast-i
			then
			adrs cell+ @ start - [ass] vc  [fth] correct-ip
			adrs cell+ @ h# 00ffffff and  h# f7000000 or ,
			[ass] rp 3 cells incr [fth] adrs start - cell+ increase-ip
		else	adrs start - dup
			[ass] ip ip rot d) vc ldr  vc next  rp 3 cells incr [fth]
			cell+ increase-ip
		then	[ass] next [fth] codebegin do-peep exit
	then
	adrs @ ['] (+loop) =
	if	short-imm?
		if	adrs cell+ @ start =
			if	[ass] r1 swap # mov  r6 r6 r1 s add  [fth]
				here codebegin  make-fast-i
			else	[ass] r1 swap # mov  r0 rp ) ldr  r0 r0 r1 s add  r0 rp ) vc str [fth]	
			then
		else	adrs cell+ @ start =
			if	[ass] r6 r6 top s add  top sp pop  [fth]
				here codebegin  make-fast-i
			else	[ass] r0 rp ) ldr  r0 top r0 s add  top sp pop  r0 rp ) vc str [fth]
			then
		then
		adrs cell+ @ opt-target?
		if	adrs cell+ @ start - [ass] vc [fth] correct-ip
			adrs cell+ @ h# 00ffffff and  h# f7000000 or ,
			[ass] rp 3 cells incr [fth]
			adrs start - cell+ increase-ip 	
		else	adrs start - dup
			[ass]	ip ip rot d) vc ldr  vc next  rp 3 cells incr
			cell+ increase-ip [fth]
		then	[ass] next [fth] codebegin do-peep exit
	then
	adrs ['] wtype? wtype?	\ secondaries are called directly
	if	adrs start - /cell - correct-ip
		[ass] r0 ip )+ ldr  ip rp push  ip r0 /cell # add next   [fth]
		codebegin do-peep exit
	then
	\ no end optimizing possible
	adrs  inlines 3 cells+ @ =  inlines 2 cells+ @ 1 > and	\ continue just after this code
	if      adrs start - increase-ip
	else	adrs @ ['] unnest =
		if [ass] ip rp )+ ldr [fth] else adrs start - /cell - increase-ip then
		[ass] next [fth]
	then
	codebegin do-peep ;
: optimize
	here
	#opts 0 ?do *opts i 2* cells+ dup 2@ dup 1 > if inline-cfa-area else 3drop then loop
	here swap resolve-branches  clear-opts flush-cache ;
: opt_compile,	( cfa -- cfa cfa )
	dup  last-compiled @ 0=  opt? 0<> and	if mark-opt then
	dup optimizable?
	if	opt?	if #opwords 1+ else here is opt?  1 then is #opwords
	else	opt?	if mark-opt then
	then ;

forth definitions
: :	postpone : clear-opts ; immediate
: ;	[compile] ; optimize ; immediate

patch opt_compile, dup compile,
warning !
decimal only forth also definitions
