Forth 12.1: several optimizations

git-svn-id: svn://kolibrios.org@4868 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
Kirill Lipatov (Leency) 2014-04-21 20:16:27 +00:00
parent 09488af869
commit 154d1426af
4 changed files with 57 additions and 459 deletions

View File

@ -1,137 +0,0 @@
macro debug_print str
{
local ..string, ..label
jmp ..label
..string db str,0
..label:
pushf
pushad
mov edx,..string
call debug_outstr
popad
popf
}
dps fix debug_print
macro debug_print_dec arg
{
pushf
pushad
if ~arg eq eax
mov eax,arg
end if
call debug_outdec
popad
popf
}
dpd fix debug_print_dec
;---------------------------------
debug_outdec: ;(eax - num, edi-str)
push 10 ;2
pop ecx ;1
push -'0' ;2
.l0:
xor edx,edx ;2
div ecx ;2
push edx ;1
test eax,eax ;2
jnz .l0 ;2
.l1:
pop eax ;1
add al,'0' ;2
call debug_outchar ; stosb
jnz .l1 ;2
ret ;1
;---------------------------------
debug_outchar: ; al - char
pushf
pushad
mov cl,al
mov eax,63
mov ebx,1
int 0x40
popad
popf
ret
debug_outstr:
mov eax,63
mov ebx,1
@@:
mov cl,[edx]
test cl,cl
jz @f
int 40h
inc edx
jmp @b
@@:
ret
_debug_crlf db 13, 10, 0
macro newline
{
pushf
pushad
mov edx, _debug_crlf
call debug_outstr
popad
popf
}
macro print message
{
dps message
newline
}
macro pregs
{
dps "EAX: "
dpd eax
dps " EBX: "
dpd ebx
newline
dps "ECX: "
dpd ecx
dps " EDX: "
dpd edx
newline
}
macro debug_print_hex arg
{
pushf
pushad
if ~arg eq eax
mov eax, arg
end if
call debug_outhex
popad
popf
}
dph fix debug_print_hex
debug_outhex:
; eax - number
mov edx, 8
.new_char:
rol eax, 4
movzx ecx, al
and cl, 0x0f
mov cl, [__hexdigits + ecx]
pushad
mcall 63, 1
popad
dec edx
jnz .new_char
ret
__hexdigits:
db '0123456789ABCDEF'

View File

@ -1 +1,3 @@
fasm.exe meforth.ASM
pause

View File

@ -1,6 +1,6 @@
; KolSPForth v12
SYSTEM equ EMUL
SYSTEM equ EMUL
;Memory Map
;
@ -86,18 +86,19 @@ cfa_#F_CFA:
}
;; Main entry points and COLD start data
;; Main entry points and COLD start data
use32
format binary as ""
org 0x0
db 'MENUET01' ; 8 byte id
dd 0x01 ; header version
dd ORIG ; start of code
dd I_END ; size of image
MEMS: dd EM ; memory for app
dd SPP ; esp
db 'MENUET01'
dd 0x01
dd ORIG ; start of code
dd I_END ; size of image
MEMS: dd EM ; memory for app
dd SPP ; esp
if SYSTEM eq MEOS
dd FINFO.path
else
@ -107,7 +108,7 @@ end if
lang fix ru
include 'MACROS.INC'
include "proc32.inc"
include '..\..\proc32.inc'
align 4
proc strncmp stdcall, s1:dword, s2:dword, n:dword
@ -179,47 +180,53 @@ BYE: mcall -1
draw_cursor:
draw_window:
pusha
mcall 12,1
mov [fRed],ebx
mcall 0, <0,FW_WIDTH>, <0,FW_HEIGHT>, 0x03000000, 0x805080D0, 0x005080D0
mcall 4, <8,8>, 0x10DDEEFF, header, header.size
pusha
mcall 12,1
mov [fRed],ebx
mcall 0, <0,FW_WIDTH>, <0,FW_HEIGHT>, 0x54000000
; mcall 0,,,COL_WINDOW_BG, ,title ; define window
mcall 71, 1, header
mcall 9,pinfo,-1
mov eax,[pinfo.x_size]
cdq
sub eax,20
mov ebx,6
div ebx
mov [pinfo.x_start],eax
mcall 9,pinfo,-1
mov eax,[pinfo.x_size]
cdq
sub eax,20
mov ebx,6
div ebx
mov [pinfo.x_start],eax
mov eax,[pinfo.y_size]
cdq
sub eax,40
mov ebx,ROWH
div ebx
mov eax,[pinfo.y_size]
cdq
sub eax,40
mov ebx,ROWH
div ebx
mov [pinfo.y_start],eax
call erase_screen
mcall 12, 2
if ~ SYSTEM eq EMUL
mcall 67,-1,-1,FW_WIDTH,FW_HEIGHT
end if
popa
ret
mov [pinfo.y_start],eax
call erase_screen
mcall 12, 2
mcall 67,-1,-1,FW_WIDTH,FW_HEIGHT
popa
ret
lsz header,\
ru,'”®àâ ¤«ï MenuetOS (SPF)',\
en,'EXAMPLE APPLICATION',\
fr,"L'exemplaire programme"
erase_screen:
mov ebx,[pinfo.x_size]
add ebx,10 shl 16-20
mov ecx,[pinfo.y_size]
add ecx,30 shl 16-35
mcall 13,,,0;xff
ret
macro GetSkinHeight
{
mov eax,48
mov ebx,4
int 0x40
}
erase_screen:
GetSkinHeight
mov ecx,eax
shl ecx,16
add ecx,[pinfo.y_size]
sub ecx,eax
sub ecx,4
mov ebx,[pinfo.x_size]
add ebx,5 shl 16 - 9
mcall 13,,,0;xff
ret
AHEADER 0,"CC_LINES",cfa_CC_LINES
@ -463,6 +470,8 @@ cfa_AHEADER 0,'READ_GIF',READ_GIF ;( gif_ptr, out_ptr -- result )
last_ebp dd 0
include 'amain.asm'
header db 'Kolibri Forth v12.1',0
FINFO:
.mode dd 0
@ -471,17 +480,9 @@ cfa_AHEADER 0,'READ_GIF',READ_GIF ;( gif_ptr, out_ptr -- result )
.buf dd 0
.work dd os_work
.path:
if SYSTEM eq MEOS
; .path db 0
; .path db '/HD/1/FORTH/AUTORUN.DAT',0
; db '/RD/1/AUTOLOAD.F'
else
db '/RD/1/AUTOLOAD.F'
; db '/RD/1/EXAMPLE.F'
; db '/RD/1/PICTURE.F'
; db '/RD/1/AUTORUN.DAT'
; db '/HD/1/FORTH/AUTORUN.DAT'
end if
; db '/RD/1/PICTURE.F'
db 0
.end_path:

View File

@ -1,268 +0,0 @@
; Macroinstructions for defining and calling procedures
macro stdcall proc,[arg] ; directly call STDCALL procedure
{ common
if ~ arg eq
reverse
pushd arg
common
end if
call proc }
macro invoke proc,[arg] ; indirectly call STDCALL procedure
{ common
if ~ arg eq
reverse
pushd arg
common
end if
call [proc] }
macro ccall proc,[arg] ; directly call CDECL procedure
{ common
size@ccall = 0
if ~ arg eq
reverse
pushd arg
size@ccall = size@ccall+4
common
end if
call proc
if size@ccall
add esp,size@ccall
end if }
macro cinvoke proc,[arg] ; indirectly call CDECL procedure
{ common
size@ccall = 0
if ~ arg eq
reverse
pushd arg
size@ccall = size@ccall+4
common
end if
call [proc]
if size@ccall
add esp,size@ccall
end if }
macro proc [args] ; define procedure
{ common
match name params, args>
\{ define@proc name,<params \} }
prologue@proc equ prologuedef
macro prologuedef procname,flag,parmbytes,localbytes,reglist
{ if parmbytes | localbytes
push ebp
mov ebp,esp
if localbytes
sub esp,localbytes
end if
end if
irps reg, reglist \{ push reg \} }
epilogue@proc equ epiloguedef
macro epiloguedef procname,flag,parmbytes,localbytes,reglist
{ irps reg, reglist \{ reverse pop reg \}
if parmbytes | localbytes
leave
end if
if (flag and 10000b) | (parmbytes=0)
retn
else
retn parmbytes
end if }
macro define@proc name,statement
{ local params,flag,regs,parmbytes,localbytes,current
if used name
name:
match =stdcall args, statement \{ params equ args
flag = 11b \}
match =stdcall, statement \{ params equ
flag = 11b \}
match =c args, statement \{ params equ args
flag = 10001b \}
match =c, statement \{ params equ
flag = 10001b \}
match =params, params \{ params equ statement
flag = 0 \}
virtual at ebp+8
match =uses reglist=,args, params \{ regs equ reglist
params equ args \}
match =regs =uses reglist, regs params \{ regs equ reglist
params equ \}
match =regs, regs \{ regs equ \}
match =,args, params \{ defargs@proc args \}
match =args@proc args, args@proc params \{ defargs@proc args \}
parmbytes = $ - (ebp+8)
end virtual
name # % = parmbytes/4
all@vars equ
current = 0
match prologue:reglist, prologue@proc:<regs> \{ prologue name,flag,parmbytes,localbytes,reglist \}
macro locals
\{ virtual at ebp-localbytes+current
macro label . \\{ deflocal@proc .,:, \\}
struc db [val] \\{ \common deflocal@proc .,db,val \\}
struc dw [val] \\{ \common deflocal@proc .,dw,val \\}
struc dp [val] \\{ \common deflocal@proc .,dp,val \\}
struc dd [val] \\{ \common deflocal@proc .,dd,val \\}
struc dt [val] \\{ \common deflocal@proc .,dt,val \\}
struc dq [val] \\{ \common deflocal@proc .,dq,val \\}
struc rb cnt \\{ deflocal@proc .,rb cnt, \\}
struc rw cnt \\{ deflocal@proc .,rw cnt, \\}
struc rp cnt \\{ deflocal@proc .,rp cnt, \\}
struc rd cnt \\{ deflocal@proc .,rd cnt, \\}
struc rt cnt \\{ deflocal@proc .,rt cnt, \\}
struc rq cnt \\{ deflocal@proc .,rq cnt, \\} \}
macro endl
\{ purge label
restruc db,dw,dp,dd,dt,dq
restruc rb,rw,rp,rd,rt,rq
restruc byte,word,dword,pword,tword,qword
current = $-(ebp-localbytes)
end virtual \}
macro ret operand
\{ match any, operand \\{ retn operand \\}
match , operand \\{ match epilogue:reglist, epilogue@proc:<regs>
\\\{ epilogue name,flag,parmbytes,localbytes,reglist \\\} \\} \}
macro finish@proc \{ localbytes = (((current-1) shr 2)+1) shl 2
end if \} }
macro defargs@proc [arg]
{ common
if ~ arg eq
forward
local ..arg,current@arg
match argname:type, arg
\{ current@arg equ argname
label ..arg type
argname equ ..arg
if dqword eq type
dd ?,?,?,?
else if tbyte eq type
dd ?,?,?
else if qword eq type | pword eq type
dd ?,?
else
dd ?
end if \}
match =current@arg,current@arg
\{ current@arg equ arg
arg equ ..arg
..arg dd ? \}
common
args@proc equ current@arg
forward
restore current@arg
common
end if }
macro deflocal@proc name,def,[val]
{ common
match vars, all@vars \{ all@vars equ all@vars, \}
all@vars equ all@vars name
forward
local ..var,..tmp
..var def val
match =?, val \{ ..tmp equ \}
match any =dup (=?), val \{ ..tmp equ \}
match tmp : value, ..tmp : val
\{ tmp: end virtual
initlocal@proc ..var,def value
virtual at tmp\}
common
match first rest, ..var, \{ name equ first \} }
macro initlocal@proc name,def
{ virtual at name
def
size@initlocal = $ - name
end virtual
position@initlocal = 0
while size@initlocal > position@initlocal
virtual at name
def
if size@initlocal - position@initlocal < 2
current@initlocal = 1
load byte@initlocal byte from name+position@initlocal
else if size@initlocal - position@initlocal < 4
current@initlocal = 2
load word@initlocal word from name+position@initlocal
else
current@initlocal = 4
load dword@initlocal dword from name+position@initlocal
end if
end virtual
if current@initlocal = 1
mov byte [name+position@initlocal],byte@initlocal
else if current@initlocal = 2
mov word [name+position@initlocal],word@initlocal
else
mov dword [name+position@initlocal],dword@initlocal
end if
position@initlocal = position@initlocal + current@initlocal
end while }
macro endp
{ purge ret,locals,endl
finish@proc
purge finish@proc
restore regs@proc
match all,args@proc \{ restore all \}
restore args@proc
match all,all@vars \{ restore all \} }
macro local [var]
{ common
locals
forward done@local equ
match varname[count]:vartype, var
\{ match =BYTE, vartype \\{ varname rb count
restore done@local \\}
match =WORD, vartype \\{ varname rw count
restore done@local \\}
match =DWORD, vartype \\{ varname rd count
restore done@local \\}
match =PWORD, vartype \\{ varname rp count
restore done@local \\}
match =QWORD, vartype \\{ varname rq count
restore done@local \\}
match =TBYTE, vartype \\{ varname rt count
restore done@local \\}
match =DQWORD, vartype \\{ label varname dqword
rq count+count
restore done@local \\}
match , done@local \\{ virtual
varname vartype
end virtual
rb count*sizeof.\#vartype
restore done@local \\} \}
match :varname:vartype, done@local:var
\{ match =BYTE, vartype \\{ varname db ?
restore done@local \\}
match =WORD, vartype \\{ varname dw ?
restore done@local \\}
match =DWORD, vartype \\{ varname dd ?
restore done@local \\}
match =PWORD, vartype \\{ varname dp ?
restore done@local \\}
match =QWORD, vartype \\{ varname dq ?
restore done@local \\}
match =TBYTE, vartype \\{ varname dt ?
restore done@local \\}
match =DQWORD, vartype \\{ label varname dqword
dq ?,?
restore done@local \\}
match , done@local \\{ varname vartype
restore done@local \\} \}
match ,done@local
\{ var
restore done@local \}
common
endl }