Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f, 1.33, 1.34 gkernext.f, 1.3, 1.4 gmeta-compiler.f, 1.12, 1.13 gmeta-fkernel.f, 1.2, 1.3
|
From: Alex M. <ale...@us...> - 2007-03-22 02:14:08
|
Update of /cvsroot/win32forth/win32forth-stc/src/kernel In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv12049/src/kernel Modified Files: gkernel.f gkernext.f gmeta-compiler.f gmeta-fkernel.f Log Message: arm: variable inline length control, support stack effects properly Index: gmeta-compiler.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gmeta-compiler.f,v retrieving revision 1.12 retrieving revision 1.13 diff -C2 -d -r1.12 -r1.13 *** gmeta-compiler.f 22 Jan 2007 21:51:40 -0000 1.12 --- gmeta-compiler.f 22 Mar 2007 02:13:56 -0000 1.13 *************** *** 56,59 **** --- 56,61 ---- \ FORWARD words are used in the kernel before they are defined. + sys-warning-off + vocabulary meta \ metacompiler implementation vocabulary target \ target words *************** *** 551,555 **** 2dup ste-o ! ste-i ! ! last-h @ n>ste dup>r 1+ tsys-c! r> tsys-c! ; \ resolution of cts --- 553,557 ---- 2dup ste-o ! ste-i ! ! last-h @ n>ste dup>r 1+ tsys-c! r> tsys-c! ; \ resolution of cts *************** *** 664,667 **** --- 666,681 ---- ' ofa-meta is ofa-calc + : ste-meta ( -- ) \ generate adjustment offset + ste-i @ ste-o @ + 2dup or 0< not -rot - cells and \ zero if either -ve + dup if >r + macro[ + lea ebp, r@ [ebp] \ !! use lea not add/sub to preserve cc + ]macro r> + then drop ste-reset \ reset + ; + + ' ste-meta is ste-adjust + : init-assembler ( -- ) \ prepare for assembly code [ assembler ] clear-labels *************** *** 686,697 **** previous ; ! : t-ecxaddr ( n -- ) \ generate a mov ecx, # n $c1c7 tcode-w, \ mov ecx, # tcode-, ; \ the value ! : t-dogen ( xt type-of-name <-name-> -- ) \ generate do code 2>r code 2r> t-tfa! \ type ! t-align t-here t-ecxaddr make-tjmp, \ name -> mov ecx, # here | jmp xt macro[ c; ]macro ofa-meta ; --- 700,722 ---- previous ; ! : t-ecxaddr-# ( n -- ) \ generate a mov ecx, # n $c1c7 tcode-w, \ mov ecx, # tcode-, ; \ the value ! : t-ecxaddr-@ ( n -- ) \ generate a mov ecx, n ! $0D8B tcode-w, \ mov ecx, ! tcode-, ; \ the value ! ! : t-dogen-# ( xt type-of-name <-name-> -- ) \ generate do code 2>r code 2r> t-tfa! \ type ! t-align t-here t-ecxaddr-# make-tjmp, \ name -> mov ecx, # here | jmp xt ! macro[ c; ]macro ! ofa-meta ; ! ! : t-dogen-@ ( xt type-of-name <-name-> -- ) \ generate do code ! 2>r code 2r> ! t-tfa! \ type ! t-align t-here t-ecxaddr-@ make-tjmp, \ name -> mov ecx, here | jmp xt macro[ c; ]macro ofa-meta ; *************** *** 1017,1021 **** : variable ( -<name>- ) \ create a variable (changable) t-align t-here meta-constant ! s" 't-ptr dovar" evaluate tvar t-dogen 0 t-, 0 1 in/out --- 1042,1046 ---- : variable ( -<name>- ) \ create a variable (changable) t-align t-here meta-constant ! s" 't-ptr dovar" evaluate tvar t-dogen-# 0 t-, 0 1 in/out *************** *** 1024,1028 **** : create ( -<name>- ) \ create a ptr to here t-align t-here meta-constant ! s" 't-ptr dovar" evaluate tvar t-dogen 0 1 in/out ; --- 1049,1053 ---- : create ( -<name>- ) \ create a ptr to here t-align t-here meta-constant ! s" 't-ptr dovar" evaluate tvar t-dogen-# 0 1 in/out ; *************** *** 1038,1042 **** : value ( n -<name>- ) \ create a self fetching changeable value ! s" 't-ptr doval" evaluate tval t-dogen t-, 0 1 in/out --- 1063,1067 ---- : value ( n -<name>- ) \ create a self fetching changeable value ! s" 't-ptr dovar" evaluate tval t-dogen-@ t-, 0 1 in/out Index: gmeta-fkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gmeta-fkernel.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** gmeta-fkernel.f 4 Oct 2006 10:27:37 -0000 1.2 --- gmeta-fkernel.f 22 Mar 2007 02:13:56 -0000 1.3 *************** *** 98,103 **** \ ======================= LOAD COMPILER ============================= - defer ofa-calc - KERN-NEXT $FLOAD \ load kernel extension for NEXT, EXEC code KERN-CMP $FLOAD \ load the compiler --- 98,101 ---- Index: gkernext.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernext.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** gkernext.f 13 Nov 2006 00:49:28 -0000 1.3 --- gkernext.f 22 Mar 2007 02:13:56 -0000 1.4 *************** *** 39,91 **** cr .( Loading NEXT ASM Support) ! get-current also forth definitions ! ! variable ste-i -1 ste-i ! \ # of input cells, -ve is unknown ! variable ste-o -1 ste-o ! \ # of output cells, -ve is unknown ! ! : ste-reset ( -- ) \ reset stack effects ! ste-i on ste-o on ; ! ! : ste-zero ( -- ) \ zero stack effects ! ste-i off ste-o off ; ! : ste-adjust ( -- ) \ generate adjustment offset ! ste-i @ ste-o @ ! 2dup or 0< not -rot - cells and \ zero if either -ve ! dup if >r ! macro[ ! lea ebp, r@ [ebp] \ !! use lea not add/sub to preserve cc ! ]macro r> ! then drop ste-reset \ reset ! ; ! : ste-calc ( in out -- ) \ calculate stack effects ! 2dup or ste-i @ or ste-o @ or 0< \ if any -ve ! if ! 2drop ste-reset \ set both -ve ! else ! over ste-o @ - dup 0> \ get in stk value ! if ! dup ste-i +! ste-o +! \ adjust ! else ! drop ! then ! swap - ste-o +! ! then ! ; ! ! previous set-current macro: next ( -- ) \ assemble the code to do a next a; ofa-calc \ resolve the optimizer field address ! ret ;macro macro: next; ( -- ) \ terminate code word - ste-adjust \ adjust stack next c; \ and return - ste-reset ;macro - --- 39,59 ---- cr .( Loading NEXT ASM Support) ! [DEFINED] setsize [IF] \ when meta-compiling ! defer ofa-calc \ these are overriden by ! defer ste-adjust \ meta compiler equivalents ! [THEN] macro: next ( -- ) \ assemble the code to do a next a; + ste-adjust \ adjust stack + ste-reset ofa-calc \ resolve the optimizer field address ! ret ;macro macro: next; ( -- ) \ terminate code word next c; \ and return ;macro Index: gkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v retrieving revision 1.33 retrieving revision 1.34 diff -C2 -d -r1.33 -r1.34 *** gkernel.f 15 Mar 2007 17:55:15 -0000 1.33 --- gkernel.f 22 Mar 2007 02:13:56 -0000 1.34 *************** *** 241,265 **** jmp ecx \ go execute next c; - \ -------------------------- Primitives ----------------------------- code dovar ( -- n ) \ variable mov -4 [ebp], eax - lea ebp, -4 [ebp] mov eax, ecx ! next c; ! ! code doval ( -- n ) \ value ! mov -4 [ebp], eax ! lea ebp, -4 [ebp] ! mov eax, [ecx] ! next c; code dousr ( -- n ) \ user mov -4 [ebp], eax mov eax, [ecx] \ offset - lea ebp, -4 [ebp] add eax, ebx ! next c; \ ------------------------- Vector Variables -------------------------- --- 241,259 ---- jmp ecx \ go execute next c; \ -------------------------- Primitives ----------------------------- code dovar ( -- n ) \ variable + 0 1 in/out mov -4 [ebp], eax mov eax, ecx ! next; code dousr ( -- n ) \ user + 0 1 in/out mov -4 [ebp], eax mov eax, [ecx] \ offset add eax, ebx ! next; ! \ ------------------------- Vector Variables -------------------------- *************** *** 2244,2250 **** : (syswarn) ( xt -- xt ) \ warn if system word in app word ! dup sys-addr? \ address in system space ! in-sys? 0= and \ not currently system pointer ! if warn_sysword warnmsg then ; code -aligned ( addr1 -- addr2 ) --- 2238,2246 ---- : (syswarn) ( xt -- xt ) \ warn if system word in app word ! sys-warning? if ! dup sys-addr? \ address in system space ! in-sys? 0= and \ not currently system pointer ! if warn_sysword warnmsg then ! then ; code -aligned ( addr1 -- addr2 ) *************** *** 2272,2279 **** : code-allot ( n1 -- ) >code allot dp> ; : code-, ( n -- ) >code , dp> ; - : code-c! ( n -- ) >code c! dp> ; - : code-w! ( n -- ) >code w! dp> ; : code-w, ( n -- ) >code w, dp> ; : code-c, ( n -- ) >code c, dp> ; \ : code-align ( -- ) >code \ cell allot \ align to 16byte boundary --- 2268,2276 ---- : code-allot ( n1 -- ) >code allot dp> ; : code-, ( n -- ) >code , dp> ; : code-w, ( n -- ) >code w, dp> ; : code-c, ( n -- ) >code c, dp> ; + : code-! ( n -- ) >code ! dp> ; + : code-w! ( n -- ) >code w! dp> ; + : code-c! ( n -- ) >code c! dp> ; \ : code-align ( -- ) >code \ cell allot \ align to 16byte boundary *************** *** 2392,2397 **** 0 | value tail-call \ see exit for use - \ *enhance if in-application, needs to issue warning if a call into system space : xt-call, ( xt -- ) \ core routine for generation a call sync-code \ ensure outstanding code generated $e8 xt-rel, \ compile call to xt on the stack --- 2389,2394 ---- 0 | value tail-call \ see exit for use : xt-call, ( xt -- ) \ core routine for generation a call + (syswarn) \ check the xt issue warning if a call into system space sync-code \ ensure outstanding code generated $e8 xt-rel, \ compile call to xt on the stack *************** *** 2424,2434 **** : (copy-code) ( addr -- ) count copy-code ; \ routine to copy the code : xt-inline, ( xt -- ) \ inline the xt dup >name n>ofa \ get the length ! w@ copy-code ; \ and copy the code : inline ( -- ) \ code will be inlined ! tail-call 0= if \ there's a tail-call, so not inlineable ! ['] xt-inline, compiles-last then ; --- 2421,2437 ---- : (copy-code) ( addr -- ) count copy-code ; \ routine to copy the code + -1 value xt-inline-max \ max length of an inline, -1 is unlimited + : xt-inline, ( xt -- ) \ inline the xt dup >name n>ofa \ get the length ! w@ dup xt-inline-max u> not if \ if short enough ! copy-code \ copy the code ! else ! drop xt-call, \ otherwise generate a call ! then ; : inline ( -- ) \ code will be inlined ! tail-call 0= if \ there's no calls, so inlineable ! ['] xt-inline, compiles-last \ tail-call is set for any call then ; *************** *** 2438,2441 **** --- 2441,2477 ---- \ -------------------- Various support words -------------------------- + variable ste-i -1 ste-i ! \ # of input cells, -ve is unknown + variable ste-o -1 ste-o ! \ # of output cells, -ve is unknown + + : ste-reset ( -- ) \ reset stack effects + ste-i on ste-o on ; + + : ste-zero ( -- ) \ zero stack effects + ste-i off ste-o off ; + + : ste-adjust ( -- ) \ generate adjustment offset + ste-i @ ste-o @ + 2dup or 0< not -rot - cells and \ zero if either -ve + dup if + $6D8D code-w, code-c, \ lea ebp, n [ebp] + else drop then + ste-reset \ reset + ; + + : ste-calc ( in out -- ) \ calculate stack effects + 2dup or ste-i @ or ste-o @ or 0< \ if any -ve + if + 2drop ste-reset \ set both -ve + else + over ste-o @ - dup 0> \ get in stk value + if + dup ste-i +! ste-o +! \ adjust + else + drop + then + swap - ste-o +! + then + ; + : (in/out@) ( nfa -- in out ) \ get the ste values n>ste dup sc@ swap 1+ sc@ ; *************** *** 2444,2453 **** last @ (in/out@) ; ! : (in/out!) ( in out -- ) \ set the ste values last @ n>ste dup>r 1+ c! r> c! ; - ' (in/out!) alias in/out immediate \ immediate version - \ ---------------------------- Defining Words -------------------------------- --- 2480,2488 ---- last @ (in/out@) ; ! : in/out ( in out -- ) \ set the ste values ! 2dup ste-o ! ste-i ! \ set calc values last @ n>ste dup>r 1+ c! r> c! ; \ ---------------------------- Defining Words -------------------------------- *************** *** 2474,2481 **** $C1C7 code-w, code-, ; \ mov ecx, # 2 equ body-off \ the offset where a body is - 7 equ addr-off \ the offset of the address part ! : >body ( xt -- body ) body-off + @ ; \ get body of created word : literal ( n -- ) \ compile time --- 2509,2524 ---- $C1C7 code-w, code-, ; \ mov ecx, # + : mov-ecx,n ( n -- ) \ generate a mov ecx, n + sync-code \ generate pending code + $0D8B code-w, code-, ; \ mov ecx, + 2 equ body-off \ the offset where a body is ! \ : >body ( xt -- body ) body-off + @ ; \ get body of created word ! ! code >body ! 1 1 in/out ! mov eax, body-off [eax] \ body-off + @ ! next; : literal ( n -- ) \ compile time *************** *** 2486,2501 **** mov-tos,#n ; ! : dogen ( xt type-of-name <-name-> -- ) \ generate do code header \ header tfa! \ set the type ! here mov-ecx,#n xt-jmp, \ name -> mov ecx, # here | jmp xt ofa-calc ; \ length calculation : (comp-cons) ( xt -- ) execute postpone literal ; \ execute & compile a literal ! : constant ( n "name" ) \ compile time ( -- n ) \ run time >system \ constant value in system space ! ['] doval tcon dogen , dp> ['] (comp-cons) compiles-last \ make the defined word compile this --- 2529,2550 ---- mov-tos,#n ; ! : dogen-# ( xt type-of-name <-name-> -- ) \ generate do code header \ header tfa! \ set the type ! here mov-ecx,#n xt-jmp, \ name -> mov ecx, # here | jmp xt ! ofa-calc ; \ length calculation ! ! : dogen-@ ( xt type-of-name <-name-> -- ) \ generate do code ! header \ header ! tfa! \ set the type ! here mov-ecx,n xt-jmp, \ name -> mov ecx, here | jmp xt ofa-calc ; \ length calculation : (comp-cons) ( xt -- ) execute postpone literal ; \ execute & compile a literal ! : constant ( n "name" ) \ compile time ( -- n ) \ run time >system \ constant value in system space ! ['] dovar tcon dogen-@ , \ equivalent of does> @ dp> ['] (comp-cons) compiles-last \ make the defined word compile this *************** *** 2506,2510 **** : create ( -<name>- ) \ pointer ! ['] dovar tcre dogen ['] (comp-create) compiles-last \ doesn't work because of DOES> , needs fixed ??? 0 1 in/out --- 2555,2559 ---- : create ( -<name>- ) \ pointer ! ['] dovar tcre dogen-# ['] (comp-create) compiles-last \ doesn't work because of DOES> , needs fixed ??? 0 1 in/out *************** *** 2513,2517 **** : variable ( "name") \ compile time ( -- n ) \ run time ! ['] dovar tvar dogen 0 , ['] (comp-cons) compiles-last 0 1 in/out --- 2562,2566 ---- : variable ( "name") \ compile time ( -- n ) \ run time ! ['] dovar tvar dogen-# 0 , ['] (comp-cons) compiles-last 0 1 in/out *************** *** 2522,2530 **** : value ( n -<name>- ) \ self fetching value ! ['] doval tval dogen , ['] (comp-val) compiles-last \ make the defined word compile this 0 1 in/out ; 1 0 in/out ! : 2literal ( n m -- ) \ run-time skeleton for 2literal (comp-only) \ compile only --- 2571,2579 ---- : value ( n -<name>- ) \ self fetching value ! ['] dovar tval dogen-@ , ['] (comp-val) compiles-last \ make the defined word compile this 0 1 in/out ; 1 0 in/out ! : 2literal ( n m -- ) \ run-time skeleton for 2literal (comp-only) \ compile only *************** *** 3633,3637 **** : user ( n -<name>- ) \ create a user variable ! ['] dousr tusr dogen , 0 1 in/out ; 1 0 in/out --- 3682,3686 ---- : user ( n -<name>- ) \ create a user variable ! ['] dousr tusr dogen-# , 0 1 in/out ; 1 0 in/out *************** *** 4602,4608 **** --- 4651,4660 ---- ofa (ofa-calc) ; + defer ; immediate \ changed to suit the type of colon def + |: ;noname ( -- ) \ ; for :noname postpone exit \ this may compile _localfree postpone [ ?csp \ stop compiling, check stack + ['] (comp-only) is ; ; *************** *** 4612,4617 **** reveal ; \ reveal the name - defer ; immediate \ changed to suit the type of colon def - \ Words to support : --- 4664,4667 ---- *************** *** 4686,4689 **** --- 4736,4741 ---- \ uses the return address to calcuate the body of does>. + 7 equ addr-off \ the offset of the address part + : (;code) ( -- ) \ compile code for does> r@ 1+ \ code for does> (after ret) *************** *** 4718,4722 **** 0 to localstk \ can have its own locals cs-leave -stack \ clear the stack used for leave addresses ! code-here latestxt @ (compiles-set) \ make the defined word compile this ; --- 4770,4774 ---- 0 to localstk \ can have its own locals cs-leave -stack \ clear the stack used for leave addresses ! code-here compiles-last \ make the defined word compile this ; |
