Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f, 1.17, 1.18 gmeta-compiler.f, 1.6, 1.7
|
From: Alex M. <ale...@us...> - 2006-10-23 14:29:13
|
Update of /cvsroot/win32forth/win32forth-stc/src/kernel In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv22521 Modified Files: gkernel.f gmeta-compiler.f Log Message: arm: literals optimisation changes Index: gmeta-compiler.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gmeta-compiler.f,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** gmeta-compiler.f 8 Oct 2006 20:39:34 -0000 1.6 --- gmeta-compiler.f 23 Oct 2006 14:28:58 -0000 1.7 *************** *** 250,255 **** ; - in-application \ start in-application - \ ====================================================================== \ Modify assembler to place code into target --- 250,253 ---- *************** *** 258,268 **** in-code? off \ we're building in target - : stack ( n -- ) \ usage; n stack <name> - create here , cells allot ; - : spush ( x stack -- ) cell over +! @ ! ; - : spop ( stack -- x ) - dup dup @ = abort" META: aux cs stack o/flow" dup @ @ -cell rot +! ; - : -stack ( stack -- ) dup ! ; - 20 stack acs --- 256,259 ---- *************** *** 1289,1298 **** : meta-number? ( ^str -- d n ) \ an extensible version of NUMBER ! count temp$ place ! temp$ count ['] number catch if drop false else double? abort" META: Doubles not supported in meta-compiler" [ also hidden ] ! float? abort" META: Floats not supported in metacompiler" [ previous ] drop true then ; --- 1280,1289 ---- : meta-number? ( ^str -- d n ) \ an extensible version of NUMBER ! count temp$ dup>r place ! r> count ['] number catch if drop false else double? abort" META: Doubles not supported in meta-compiler" [ also hidden ] ! float? abort" META: Floats not supported in metacompiler" [ previous ] drop true then ; *************** *** 1342,1346 **** begin token find \ no locals or class words if execute ! else meta-number? if [transition] literal else drop t-in @ >in ! --- 1333,1337 ---- begin token find \ no locals or class words if execute ! else meta-number? if [transition] literal else drop t-in @ >in ! *************** *** 1368,1371 **** --- 1359,1364 ---- : : COLON: ; \ standard colon def + in-application \ start in-application + .olly Index: gkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v retrieving revision 1.17 retrieving revision 1.18 diff -C2 -d -r1.17 -r1.18 *** gkernel.f 8 Oct 2006 20:37:41 -0000 1.17 --- gkernel.f 23 Oct 2006 14:28:58 -0000 1.18 *************** *** 49,54 **** ------------------------------------------------------------------------ - Currently requires Win32Forth version 6.10 or greater to meta-compile. - Philosophy ---------- --- 49,52 ---- *************** *** 366,369 **** --- 364,368 ---- -340 equ throw_auxstacku \ " aux stack underflow" -341 equ throw_auxstacko \ " aux stack overflow" + -350 equ throw_ctexecute \ " ct is immediate" \ Warnings *************** *** 406,409 **** --- 405,409 ---- throw_msgs link, throw_auxstacku , ," aux stack underflow" throw_msgs link, throw_auxstacko , ," aux stack overflow" + throw_msgs link, throw_ctexecute , ," ct is immediate" \ Warnings *************** *** 2343,2350 **** : >name ( xt -- nfa ) >ct ct>name ; \ get the name - : compile-for ( xt2 <name> -- ) ' >comp! ; \ parsing; set the compilation word - - : name-compiles ( xt -- ) latestxt @ >comp! ; \ sets xt as compilation for name - \ ------------------------- Code generation words --------------------------- --- 2343,2346 ---- *************** *** 2373,2376 **** --- 2369,2387 ---- code-here to tail-call ; \ possible tail call + : (compiles-set) ( xt1 xt2 -- ) \ set the correct ct token + >ct dup @ \ ( xt1 ct ct ) + dup ['] execute = if \ can't set if execute (immediate) + throw_ctexecute throw + then + ['] compile, = if \ it's a standard word + cell- \ set the compile action (comp) + then ! ; + + : compiles-last ( xt -- ) + latestxt @ (compiles-set) ; \ sets xt as compilation for last name + + : compiles-for ( xt <name> -- ) + ' (compiles-set) ; \ parsing; set the compilation word + \ The kernel has no assembler, so there's no "postponed assembly" possible. \ To overcome this, the code is pre-assembled using "gcode" and copied *************** *** 2386,2399 **** \ ---------------------------- Defining Words -------------------------------- ! $C0C7 equ mov-eax-#n \ cheap assembler... ! $C1C7 equ mov-ecx-#n ! ! : moveax#, ( n -- ) \ generate a mov eax, # n sync-code \ generate pending code ! mov-eax-#n code-w, code-, ; \ mov eax, # ! : movecx#, ( n -- ) \ generate a mov ecx, # n sync-code \ generate pending code ! mov-ecx-#n code-w, code-, ; \ mov ecx, # 2 equ body-off \ the offset where a body is --- 2397,2407 ---- \ ---------------------------- Defining Words -------------------------------- ! : mov-eax,#n ( n -- ) \ generate a mov eax, # n sync-code \ generate pending code ! $C0C7 code-w, code-, ; \ mov eax, # ! : mov-ecx,#n ( n -- ) \ generate a mov ecx, # n sync-code \ generate pending code ! $C1C7 code-w, code-, ; \ mov ecx, # 2 equ body-off \ the offset where a body is *************** *** 2407,2422 **** compilation> ( -- xt ) drop postpone dup \ push on stack, generate literal ! moveax#, ; : dogen ( xt <-name-> -- ) \ generate do code header \ header ! here movecx#, xt-jmp, \ name -> mov ecx, # here | jmp xt ofa-calc \ length calculation _next (copy-code) ; \ stops disasm - 0 1 in/out : create ( -<name>- ) \ pointer - ['] dovar dogen - ; - : (comp-cons) ( xt -- ) execute postpone literal ; \ execute & compile a literal --- 2415,2426 ---- compilation> ( -- xt ) drop postpone dup \ push on stack, generate literal ! mov-eax,#n ; : dogen ( xt <-name-> -- ) \ generate do code header \ header ! here mov-ecx,#n xt-jmp, \ name -> mov ecx, # here | jmp xt ofa-calc \ length calculation _next (copy-code) ; \ stops disasm : (comp-cons) ( xt -- ) execute postpone literal ; \ execute & compile a literal *************** *** 2426,2436 **** ['] doval dogen , dp> ! ['] (comp-cons) name-compiles \ make the defined word compile this ; 0 1 in/out : variable ( "name") \ compile time ( -- n ) \ run time ! here 0 , constant ! ; : (comp-val) ( n -- ) --- 2430,2447 ---- ['] doval dogen , dp> ! ['] (comp-cons) compiles-last \ make the defined word compile this ! ; ! ! : (comp-create) ( xt -- ) >body postpone literal ; ! ! 0 1 in/out : create ( -<name>- ) \ pointer ! ['] dovar dogen ! \ ['] (comp-create) compiles-last \ doesn't work because of DOES> needs fixed ; 0 1 in/out : variable ( "name") \ compile time ( -- n ) \ run time ! create 0 , ! ['] (comp-cons) compiles-last ; : (comp-val) ( n -- ) *************** *** 2439,2443 **** 0 1 in/out : value ( n -<name>- ) \ self fetching value ['] doval dogen , ! ['] (comp-val) name-compiles \ make the defined word compile this ; --- 2450,2454 ---- 0 1 in/out : value ( n -<name>- ) \ self fetching value ['] doval dogen , ! ['] (comp-val) compiles-last \ make the defined word compile this ; *************** *** 3024,3028 **** "parse type compilation> drop ! [s"] postpone type ; --- 3035,3039 ---- "parse type compilation> drop ! postpone s" postpone type ; *************** *** 4133,4139 **** cell over +! @ ! ; ! : sempty? ( stack -- f ) \ check if empty ! dup @ cell- = ; : spop ( stack -- x ) \ pop off stack dup sempty? throw_auxstacku ?throw --- 4144,4153 ---- cell over +! @ ! ; ! : sdepth ( stack -- n ) ! dup @ cell- swap - 2 rshift ; + : sempty? ( stack -- f ) \ check if empty + sdepth 0= ; + : spop ( stack -- x ) \ pop off stack dup sempty? throw_auxstacku ?throw *************** *** 4154,4161 **** xor throw_mismatch ?throw ; ! : >mark ( -- addr ) code-here ; \ mark a link for later resolution by : <resolve ( orig -- ) \ fixup relative jump at orig dup code-here swap - swap cell- ! ; : >resolve ( dest -- ) \ fixup relative jump to dest code-here - code-here cell- ! ; --- 4168,4177 ---- xor throw_mismatch ?throw ; ! : >mark ( -- addr ) sync-code code-here ; \ mark a link for later resolution by : <resolve ( orig -- ) \ fixup relative jump at orig + sync-code dup code-here swap - swap cell- ! ; : >resolve ( dest -- ) \ fixup relative jump to dest + sync-code code-here - code-here cell- ! ; *************** *** 4438,4441 **** --- 4454,4458 ---- : [ ( -- ) + sync-code state off ['] (interpret-i) is (interpret) ; immediate \ turn off compiling *************** *** 4497,4500 **** --- 4514,4518 ---- : (ofa-calc) ( ofa -- ) + sync-code \ ensure all generated code-here swap - \ length of the code last @ n>ofa w! \ save length *************** *** 4538,4542 **** : : ( -<name>- -- ) \ forth's primary function defining word header hide ! ['] ;name (:noname) \ set the named ; word ; --- 4556,4560 ---- : : ( -<name>- -- ) \ forth's primary function defining word header hide ! ['] ;name (:noname) \ set the named ; word ; *************** *** 4548,4552 **** 0 to localstk \ can have its own locals cs-leave -stack \ clear the stack used for leave addresses ! code-here latestxt @ >ct ! \ make the defined word compile this ; --- 4566,4570 ---- 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 ; *************** *** 4586,4590 **** \ the user's code, and that it is still fetchable through >BODY. \ ! \ DOES> has a dependancy on movecx#, which generates this code; \ \ ( $...... C7C1nnnnnnnn ) mov ecx, # $nnnnnnnn --- 4604,4608 ---- \ the user's code, and that it is still fetchable through >BODY. \ ! \ DOES> has a dependancy on mov-ecx,#n which generates this code; \ \ ( $...... C7C1nnnnnnnn ) mov ecx, # $nnnnnnnn *************** *** 4782,4786 **** #wordlist dup \ wid address header code-here swap voc>vxt ! \ set the xt for this name ! movecx#, ['] dovoc xt-jmp, \ set ecx, jmp to dovoc postpone unnest postpone unnest ; --- 4800,4804 ---- #wordlist dup \ wid address header code-here swap voc>vxt ! \ set the xt for this name ! mov-ecx,#n ['] dovoc xt-jmp, \ set ecx, jmp to dovoc postpone unnest postpone unnest ; *************** *** 5454,5458 **** ' >body postpone literal postpone @ ; ! ' to alias is immediate \ is or to works with defer & value \ -------------------- Task support & initialisation ------------------------ --- 5472,5476 ---- ' >body postpone literal postpone @ ; ! ' to alias is \ immediate \ is or to works with defer & value \ -------------------- Task support & initialisation ------------------------ |
