kernel'docsù*src]+utilE/Ýîîÿ N-3base'extÚ'block>(tools¢(tasking)consj)ideÎ)mksys2*buckets3*Ýîîÿù*=*\ vandys \ kernel.f \ For kernel source code \ \ To be processed by the metacompiler, to generate a new system \ \ \ The metacompiler uses two vocabularies; meta and target. The \ meta vocabulary holds definitions used by code running on the \ host, which will not interfere with "normal" Forth operations. \ The "target" vocabulary defines words like ":", ";", "if", and \ so forth, which must only be seen by code being metacompiled \ onto the target. only vocabulary target vocabulary meta meta definitions also extensions ( extensions meta forth -> meta ) ÝîîÿÚ'©'\ vandys \ Before we start the metacompilation proper, we define any words, \ variables or constants which are used by the metacompilation, \ but are not intended to be part of the resulting image. \ \ Version control 1 constant VER \ Major/minor versions 0 constant EXT Ýîîÿ\ vandys \ Constants $20 constant #compile-only \ Compile-only flag $40 constant #immediate \ ...immediate $80 constant #markb \ ...flag first byte of name 4 constant CELLL \ # bytes in a cell 32 constant NBPW \ # bits in a cell $A constant BASEE \ Default radix 8 constant #VOCS \ Depth of vocabulary stack 3 constant DEFAULT_PRIO \ Default scheduling priority 32 constant AOUT_SIZE \ # bytes in a.out header 1024 CELLL * constant #rstack \ # bytes allocated for return stack #rstack 2* constant #stack \ ...operand stack twice as big 80 constant #TIBLINE \ Size of input line to TIB 16 constant #HIST \ # lines of history kept These flags bits are in the length count byte of the name string of an entry in a vocabulary. Ýîîÿ\ vandys \ Memory allocation \ \ Our approach here is to put initial data structures down in low \ memory, and target our actual ForthOS system for the base of \ high memory (at 1 meg). \ \ at 0x10000 the low memory layout is: \ UPP: Base of user area, (8 cells padding), RPP: Top of return stack \ TIBB: TIB, plus TIB history, (8 cells padding), SPP: Top of opstack $10000 constant EM \ Start of low memory, uninitialized 64 CELLL * constant US \ Max user area size EM US - constant UPP \ Start of user area (UP0) UPP 8 CELLL * - constant RPP \ Start of return stack (RP0) #HIST 1+ #TIBLINE * #TIBLINE + constant TIBS \ Size of TIB state (TIB + history) RPP #rstack - TIBS - constant TIBB \ Terminal input buffer (TIB) TIBB 8 CELLL * - constant SPP \ Start of data stack (SP0) \ (#stack bytes below SPP are used) History state TIB itself Room for return stack, then TIB state Ýîîÿ\ vandys $100000 constant BASEM \ Base memory for interpreter \ Initialize assembly variables create _USER 4 CELLL * , \ First user variable offset variable base_mem \ First location of target image \ These get patched as the target's routines are defined variable _branch variable _?branch variable _(do) variable _(loop) variable _doLIT variable _doUSER variable _forth variable cold1 variable _exit variable _doLIST variable _doVAR variable _doCONST variable _(abort") variable _(?do) variable _(.") variable _(c") variable _up variable tnumber variable _context variable _current variable _doVOC variable _(+loop) variable _'rdwt variable _fence \ Fields back-patched once the image is fully compiled variable textlen variable entryptr1 variable entryptr2 Ýîîÿ\ vandys \ This is used to reference the patched pointers, to catch \ cases where a reference is made before the needed routine \ is defined. : _@ @ dup 0= abort" bad ordering" ; Ýîîÿ\ vandys \ Once we start using the "target" vocabulary, we won't have \ access to our regular vocabulary words. We create these words \ to provide search order control of the host compiler which will \ work even when words like "only" have their target definition \ active. : forth->forth only ; \ ( forth forth -> forth ) : meta->meta only meta definitions also extensions ; \ ( extensions meta forth -> meta ) : target->target meta->meta target definitions ; \ ( target meta forth -> target ) : meta->target target->target extensions ; \ ( extensions meta forth -> target ) : assembler->target meta->target assembler ; \ ( assembler meta forth -> target ) : target->meta meta->meta target ; \ ( target meta forth -> meta ) Ýîîÿ\ vandys \ Record of assembly code relocations (which are not word aligned) 8 constant #max_asm_reloc create asm_reloc 8 cells allot create #asm_reloc 0 , : add_reloc ( a -- ) #asm_reloc @ dup #max_asm_reloc >= abort" relocs" cells asm_reloc + ! 1 #asm_reloc +! ; \ How far from the address we search for the unaligned reloc reference 8 constant #asm_fuzz : (asm_reloc) ( l h a -- ) #asm_fuzz over + 1+ swap do 2dup i @ -rot within if drop i @ swap - BASEM + i ! unloop exit then loop 1 abort" reloc not found" ; : asm_relocs ( l h -- ) #asm_reloc @ 0 do 2dup i cells asm_reloc + @ (asm_reloc) loop 2drop ; Ýîîÿ\ vandys \ relocate ( l h -- ) \ Relocate all references in range to BASEM 1 cells constant #cell : relocate 2dup asm_relocs #asm_reloc @ . ." assembly relocations" cr 0 -rot 2dup cell+ swap do 2dup i @ -rot 1+ within if rot 1+ -rot over i @ swap - BASEM + i ! then #cell +loop 2drop . ." relocations" cr ; \ write_image ( a u n -- ) \ Write image at "a" starting at block "u" \ for "n" blocks. : write_image 0 do 2dup block BLKSIZ move update 1+ swap BLKSIZ + swap loop 2drop sync ; Ýîîÿ\ vandys \ Format of dictionary entries: \ \ Code address 32 bits \ Link to previous entry 32 bits \ Name length + flags 8 bits (high bit always set) \ Name (length bytes) \ padding (to CELLL boundary) \ then: \ Assembly code (for CODE word) \ or: \ call DOLST (for COLON word) \ .long w1,w2,... (pointers to other words) \ Ýîîÿ\ vandys \ Convert between the different addresses : nfa>cfa cell- cell- ; : nfa>lfa cell- ; : cfa>nfa cell+ cell+ ; : cfa>lfa cell+ ; : lfa>cfa cell- ; : lfa>nfa cell+ ; : ca>nfa begin 1- dup c@ $80 and until ; \ (same?) ( a1 a2 u -- ) \ Tell if range of bytes is equal : (same?) 0 do 2dup c@ swap c@ - if unloop 2drop false exit then 1+ swap 1+ loop 2drop true ; \ same? ( a1 a2 -- bool ) \ Compare dictionary entries : same? count $1F and >r swap count $1F and dup r> - if drop 2drop false exit then (same?) ; Ýîîÿ\ vandys \ Pointer to NFA of most recent entry create last 0 , : lastcode last @ nfa>cfa @ ; \ find ( a va -- ca na | a F ) \ Look up entry in indicated dictionary : find begin @ ?dup while \ Pick up next entry link 2dup same? if \ Compare to target string nip dup nfa>cfa @ swap exit then \ Found entry; return CA/NFA nfa>lfa \ Prepare to advance to next repeat false ; \ Return failure with addr \ name? ( a -- ca na | a F ) \ Look up entry across dictionary search list : name? _context _@ swap begin over @ ?dup while find ?dup if rot drop exit then swap cell+ swap repeat nip false ; Ýîîÿ\ vandys \ ">here ( b u -- a ) \ Convert pointer to counted string at here : ">here dup here c! here 1+ swap move here ; \ meta-' ( -- a ) \ Look up an entry in our target dictionary, \ return CA : meta-' bl parse ">here \ Get next word from input name? 0= if \ Look up count type abort then \ Not known \ CA is left on stack ; \ Parse word from input into dictionary, advancing "here" : token bl parse 31 min dup >r here pack$ r> 1+ allot align ; Ýîîÿ\ vandys \ (compf) ( n -- ) \ OR in a bit in last entry's attributes : (compf) last @ dup c@ rot or swap c! ; \ (create) ( -- ) \ Create a word, leaving caller to \ add appropriate code body \ In the metacompiler, there is no "overt", therefore the entry \ is placed on the search chain immediately. Yes, this limits \ the ability of a word to use a previous instance of the same \ word. : (create) align here 0 , \ CFA to be filled in _current _@ @ @ , \ Point to words in definitions dict here last ! \ Link onto chain here _current _@ @ ! \ Add to definitions dict token count space type \ Build name, trace output #markb (compf) \ 1st byte with high bit set here swap ! \ Point CFA to body ; Ýîîÿ\ vandys \ meta-words ( -- ) \ Dump words in target vocabulary : meta-words _context _@ @ \ First vocab in search order begin @ ?dup while space dup .id nfa>lfa repeat ; \ Define a code word \ Leverage our (create) word, then set the assembler in motion meta->meta assembler ( assembler meta forth -> meta ) : code (create) ASM-INIT ; : c; END-CODE ; meta->meta ( extensions meta forth -> meta ) \ Define a colon definition, but don't build the body : (:) (create) _doLIST _@ call, ; Ýîîÿ\ vandys \ Compile a user variable header : user (:) _doUSER _@ , _USER @ , CELLL _USER +! ; \ constant/ ( n -- ) \ Compile a string constant padded to length : constant/ [char] / parse dup c, here swap move 1- allot ; \ Record where to back-patch end of memory image variable loadend_ptr \ Location of prototype user area variable user0 \ Size of user area variable usize Ýîîÿ\ vandys \ fixups Patch values known after metacompilation : fixups \ Align size to 4k boundary here base_mem @ - $1000 mod $1000 swap - allot \ Summarize size ." Image size:" here base_mem @ - . ." bytes" cr \ Fix up the prototype USER area 'ttyops @ user0 @ 6 cells + ! \ Host TTY operations tnumber _@ user0 @ 20 cells + ! \ 'number here user0 @ 34 cells + ! \ cp last @ user0 @ 35 cells + ! \ last \ Patch disk I/O to simulator 'rdwt @ _'rdwt _@ ! \ Patch "forth" vocabulary word for its runtime behavior _doLIST _@ _forth _@ call! _doVOC _@ _forth _@ cell+ cell+ ! Ýîîÿ\ vandys \ Patch end-of-memory pointer into Multiboot header \ (both load end and BSS end) here loadend_ptr @ ! here loadend_ptr @ cell+ ! \ Fix fence here _fence _@ ! \ Patch a.out header for text size here base_mem @ - AOUT_SIZE - textlen @ ! ; \ compile-only Set compile-only flag of target word : compile-only #compile-only (compf) ; \ immediate Set immediate execution flag of target word : immediate #immediate (compf) ; Ýîîÿ\ vandys \ ==================================================================== \ What follows are values and run-time routines needed by metacompiled \ source. In "normal" forth, you are free to create words, and then \ use those words to create further words and/or data structures. In \ the metacompiled world, words compiled into the target are not \ executable by the host. Thus, we factor out those functions to \ this section, to make their functionality available to the \ host metacompiler. \ ==================================================================== \ Source code to support block.f 4096 constant BLKSIZ \ Byte of data in a block 80 constant BLKCOLS \ Columns in a screen BLKSIZ 2/ BLKCOLS / constant BLKROWS \ Rows in a screen (not shadow) 32 constant #BUFS \ # bufs held in memory--at least one 3 CELLL * BLKSIZ + constant BUFSIZ \ Size of in-core block buffer Ýîîÿ\ vandys \ Source code to support multi.f 4 constant NPRIO \ # distinct task priorities (0..NPRIO-1) 8192 constant #codes \ Size of private code space \ Source code to support cons.f 4 constant NSCREEN \ # virtual screens supported 80 constant CONS_COLS \ Columns on display 25 constant CONS_ROWS \ Rows on display CONS_COLS CONS_ROWS * constant RAM_SIZE \ Words on display RAM_SIZE 2 * constant RAM_BYTES \ Bytes on display 6 cells RAM_BYTES + constant SCRMEM \ # bytes of state per screen \ Initialize from string rather than individual c,'s : ,chars bl parse drop begin dup c@ bl <> while dup c@ c, 1+ repeat drop ; \ Initialize a sequence of $80 char values : pad80 ( u -- ) 0 do $80 c, loop ; Ýîîÿ\ vandys \ Source code to support ide.f 512 constant SECSIZ SECSIZ 2/ constant SECWORDS BLKSIZ SECSIZ / constant BLKSECS \ Constants for structures 64 constant (struct_max) Ýîîÿ\ vandys \ ==================================================================== \ Now we start defining words which would interfere with \ normal Forth compilation. We will place them in the "target" \ vocabulary, which is not a part of our own search path. \ ==================================================================== meta->target ( extensions meta forth -> target ) \ Create a variable without any storage allocated : create (:) _doVAR _@ , ; \ Variable : variable [ target ] create [ extensions ] 0 , ; \ Constant : constant (:) _doCONST _@ , , ; Ýîîÿ\ \ These are host-executed routines which generate code onto the \ target, mostly for control structures. \ : if _?branch _@ , here 0 , ; : else _branch _@ , here 0 , swap here swap ! ; : then here swap ! ; : begin here ; : until _?branch _@ , , ; : again _branch _@ , , ; : while [ target ] if [ extensions ] swap ; : repeat [ target ] again [ extensions ] here swap ! ; : do _(do) _@ , here 0 , ; : ?do _(?do) _@ , here 0 , ; : loop _(loop) _@ , here cell+ over ! cell+ , ; : +loop _(+loop) _@ , here cell+ over ! cell+ , ; Ýîîÿ\ vandys \ Semicolon compiles in the termination of the definition, as well \ as switching the host compiler back to interpretive state. : ; _exit _@ , [compile] [ ; : unsupported 1 abort" Unsupported operation" ; : abort" _(abort") _@ , $," ; : ." _(.") _@ , $," ; : c" _(c") _@ , $," ; : ['] meta-' _doLIT _@ , , ; : [compile] meta-' , ; : [char] char _doLIT _@ , , ; : recurse last @ nfa>cfa @ , ; Ýîîÿ\ vandys \ specTab \ Table of special words in metacompilation \ These are defined in "meta", but located here \ among target definitions because it references \ some target routines. meta->meta ( extensions meta forth -> meta ) 16 dup constant #specName \ Size of name cell+ constant #specEntry \ Size of each entry create specTab 0 target->meta ( target meta forth -> meta ) Ýîîÿ\ vandys #specName constant/ if/ ' if , 1+ \ Target specific words #specName constant/ else/ ' else , 1+ #specName constant/ then/ ' then , 1+ #specName constant/ begin/ ' begin , 1+ #specName constant/ until/ ' until , 1+ #specName constant/ again/ ' again , 1+ #specName constant/ while/ ' while , 1+ #specName constant/ repeat/ ' repeat , 1+ #specName constant/ do/ ' do , 1+ #specName constant/ ?do/ ' ?do , 1+ #specName constant/ loop/ ' loop , 1+ #specName constant/ +loop/ ' +loop , 1+ #specName constant/ ;/ ' ; , 1+ #specName constant/ abort"/ ' abort" , 1+ #specName constant/ ."/ ' ." , 1+ #specName constant/ c"/ ' c" , 1+ #specName constant/ [']/ ' ['] , 1+ #specName constant/ [compile]/ ' [compile] , 1+ #specName constant/ [char]/ ' [char] , 1+ #specName constant/ [/ ' unsupported , 1+ #specName constant/ recurse/ ' recurse , 1+ Ýîîÿ\ vandys meta->meta ( extensions meta forth -> meta ) #specName constant/ \/ ' \ , 1+ \ Hook to our host words #specName constant/ (/ ' ( , 1+ constant #specTab \ # entries in specTab \ >specName ( n -- a ) \ Return name for the given index in specTab : >specName #specEntry * specTab + ; \ >specFunc ( n -- a ) \ Return function pointer from index in specTab : >specFunc >specName #specName + @ ; Ýîîÿ\ vandys \ special? ( a -- a F | vector T ) \ Tell if the word is special \ Returns execution pointer if it is \ TBD: think about leveraging a Forth vocab : special? #specTab 0 do dup i >specName same? if drop i >specFunc true unloop exit then loop false ; Ýîîÿ\ vandys \ $immediate ( ca -- ) \ Tell if the given routine has a #immediate flag : $immediate ca>nfa c@ #immediate and ; \ $metacompile ( a -- ) \ Our 'eval hook for metacompilation : $metacompile special? if \ Special execution words execute exit then name? if \ Found in target dictionary? dup $immediate abort" immediate" , exit then dup number? if \ Literal _doLIT _@ , , drop exit then count type \ Otherwise error 1 abort" undefined" ; Ýîîÿ\ vandys \ Ok, the special? support is safely compiled into meta, back to \ definitions in target. meta->target ( extensions meta forth -> target ) \ Start compiling a target word. We have a custom 'eval vector \ to generate code referencing the target dictionary. : : (:) ['] $metacompile 'eval ! ;