\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: compilin.fth
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ - Do no alter or remove copyright notices
\ - Redistribution and use of this software in source and binary forms, with
\ or without modification, are permitted provided that the following
\ - Redistribution of source code must retain the above copyright notice,
\ this list of conditions and the following disclaimer.
\ - Redistribution in binary form must reproduce the above copyright notice,
\ this list of conditions and the following disclaimer in the
\ documentation and/or other materials provided with the distribution.
\ Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\ This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ ========== Copyright Header End ============================================
id: @(#)compilin.fth 3.15 03/12/08 13:22:30
copyright: Copyright 1994-2003 Sun Microsystems, Inc. All Rights Reserved
copyright: Copyright 1985-1994 Bradley Forthware, Inc.
copyright: Use is subject to license terms.
h# 80 constant metacompiling
\ Non-immediate version which is compiled inside several
\ meta and transition words
: literal-t ( n -- ) n->l-t compile-t (lit) ,-t ;
\ symbols \ entries are does> words
\ labels \ entries are constants
\ Compiling: order: transition symbols labels
\ If found in transition, execute it
\ If found in symbols, execute it
\ If is immediate, complain (should have been in transition)
: metacompile-do-literal ( n -- )
state @ metacompiling = if
2 = if where ." oops double number " cr source type cr drop then
: metacompile-do-defined ( acf -1 | acf 1 -- )
: $metacompile-do-undefined ( adr len -- ) \ compile a forward reference
\ XXX need to include labels in the search path when interpreting
\ XXX switch search order when going from metacompiling to interpreting
\ interpreting is just the normal interpret state, with labels in the search
\ compiling is just the normal compile state, with labels in the search path
\ metacompiling is the special state.
: meta-base ( -- ) only forth also labels also meta also ;
: meta-compile ( -- ) meta-base definitions ;
: meta-assemble ( -- ) meta-base assembler ;
: extend-meta-assembler ( -- ) meta-assemble also definitions ;
: meta-asm[ ( -- ) also meta assembler ; immediate
: ]meta-asm ( -- ) previous ; immediate
\ "resolves" gives a name to the run-time clause specified by the most-
\ recently-defined "does>" or ";code" word. A number of defining words
\ assume that their appropriate run-time clause will be resolved with a
\ particular word. For instance, "vocabulary" refers to a run-time clause
\ called <vocabulary>. When the run-time code for vocabularies is defined
\ in the kernel source, "resolves" is used to associate its address with
\ the name <vocabulary>. See the kernel source for examples.
doestarget @ safe-parse-word $findsymbol resolution!
\ This is a smart equ which defines words that can be later used
\ inside colon definitions, in which case they will compile their
\ value as a literal. Perhaps these should be created in the
: $equ ( value adr len -- )
[ forth ] ['] labels $vcreate , immediate
does> \ ( -- value ) or ( -- )
[ meta ] state @ metacompiling = if literal-t then
: equ \ name ( value -- )
\ Tools for building control constructs. The details of the branch
\ target (offset or absolute, # of bytes, etc) are hidden in
\ /branch branch, and branch! which are defined earlier.
: >mark ( -- addr ) here-t here-t branch, ;
: >resolve ( addr -- ) here-t branch! ;
: <mark ( -- addr ) here-t ;
: <resolve ( addr -- ) branch, ;
: ?comp ( -- ) state @ metacompiling <> abort" compile only" ;
\ "Transition" words. Versions of compiling words which are defined
\ in the host environment but which compile code into the target
\ Once compiling words are redefined, care must be taken to select
\ the old instance of that word for use in other definitions. For instance,
\ when "if" is redefined, subsequent definitions will frequently want to use
\ the old "if", so the search order must be explicitly controlled in order
\ to access the old one instead of the new one.
: target ( -- ) only forth also transition ; immediate
\ Set the search path to exclude the transition vocabulary so that
\ we can define transition words but still use the normal versions
\ of compiling words like if and [compile]
: host ( -- ) only forth also meta ; immediate
\ Transition version of control constructs.
: of ( [ addresses ] 4 -- 5 )
host ?comp 4 ?pairs compile-t (of) >mark 5 target
: case ( -- 4 ) host ?comp csp @ !csp 4 target ; immediate
: endof ( [ addresses ] 5 -- [ one more address ] 4 )
host 5 ?pairs compile-t (endof) >mark swap >resolve 4 target
: endcase ( [ addresses ] 4 -- )
host 4 ?pairs compile-t (endcase)
begin sp@ csp @ <> while >resolve repeat
: if host ?comp compile-t ?branch >mark target ; immediate
: ahead host ?comp compile-t branch >mark target ; immediate
: else host ?comp compile-t branch >mark
swap >resolve target ; immediate
: then host ?comp >resolve target ; immediate
: begin host ?comp <mark target ; immediate
: until host ?comp compile-t ?branch <resolve target ; immediate
: while host ?comp compile-t ?branch >mark swap target ; immediate
: again host ?comp compile-t branch <resolve target ; immediate
: repeat host ?comp compile-t branch <resolve >resolve target ; immediate
: ?do host ?comp compile-t (?do) >mark target ; immediate
: do host ?comp compile-t (do) >mark target ; immediate
: leave host ?comp compile-t (leave) target ; immediate
: ?leave host ?comp compile-t (?leave) target ; immediate
: loop host ?comp compile-t (loop)
dup /branch + <resolve >resolve target ; immediate
: +loop host ?comp compile-t (+loop)
dup /branch + <resolve >resolve target ; immediate
\ Transition version of words which compile numeric literals
: ascii \ string ( -- char )
host bl word 1+ c@ state @ if literal-t then target
: control \ string ( -- char )
host bl word 1+ c@ bl 1- and state @ if literal-t then target
: [char] \ string ( -- char )
host bl word 1+ c@ literal-t target
parse-word $handle-literal? 0= if
." Bogus number after th" cr
parse-word $handle-literal? 0= if
." Bogus number after td" cr
\ From now on we start to see familiar words with "-h" suffixes. These
\ are aliases for the familiar word, used because we have redefined the
\ word to operate in the target environment, but we still need to use the
\ original word. Rather that having to do [ forth ] foo [ meta ] all the
\ time, we make an alias foo-h for foo.
alias immediate-h immediate
\ Transition versions of tick and bracket-tick. Forward references
\ are not permitted with tick because there is no way to know how
\ the address will be used. The mechanism for eventually resolving
\ forward references depends on the assumption that the forward
\ reference resolves to a compilation address that is compiled into
\ a definition. This assumption doesn't hold for tick'ed words, so
\ we don't allow them to be forward references.
2dup $sfind if ( adr len acf ) \ The word has already been seen
dup resolved? ( adr len acf flag )
if nip nip resolution@ ( resolution ) exit then
then ( adr len adr len | adr len )
type ." hasn't been defined yet, so ' won't work" cr
compile-t (') safe-parse-word $compile-t
: place-t ( adr len to-t -- )
2dup + 1+ 0 swap c!-t \ Put a null byte at the end
2dup c!-t 1+ swap cmove-t
\ Emplace a string into the target dictionary
: ,"-t \ string" ( -- ) \ cram the string at here
td 34 ( ascii " ) word count ( adr len )
over 2+ note-string-t allot-t talign-t ( adr len here )
: ." host compile-t (.") ,"-t target ; immediate
: abort" host compile-t (abort") ,"-t target ; immediate
: " host compile-t (") ,"-t target ; immediate
: p" host compile-t ("s) ,"-t target ; immediate
\ Bogus 1024 constant b/buf
meta also assembler definitions
\ Some debugging words. Allow the printing of the name of words as they
\ are defined. threshhold is the number of words that must be defined
\ before any printing starts, and granularity is the interval between
\ words that are printed after the threshhold is crossed. This is very
\ useful if the metacompiler crashes, because it helps you to locate
\ where the crash occurred. If needed, start with threshhold = 0 and
\ granularity = 20, then set threshhold to whatever word was printed
\ before the crash and granularity to 1.
variable #words 0 #words !
variable threshold 10000 threshold !
variable granularity 10 granularity !
variable prev-depth 0 prev-depth ! ( expected depth )
base @ decimal #words @ 5 .r space base !
[ also meta ] .lastname [ previous ]
depth 0 <> if space .x then cr
.debug depth prev-depth !
if #words @ granularity @ mod
0 value lastacf-t \ acf of the most-recently-created target word
variable show? \ True if we should show all the symbols
\ The kernel can be compiled in 3 modes:
\ always-headers: All words have headers (default mode)
\ never-headers: No words have headers
\ sometimes-headers: Words have headers unless "headerless" is active
\ -1 : never 0 : always 1 : yes 2 : no
variable header-control 0 header-control !
: headerless ( -- ) header-control @ 0> if 2 header-control ! then ;
: headers ( -- ) header-control @ 0> if 1 header-control ! then ;
: always-headers ( -- ) 0 header-control ! ;
: sometimes-headers ( -- ) 1 header-control ! ;
: never-headers ( -- ) -1 header-control ! ;
: make-header? ( -- flag ) header-control @ 0 1 between ;
: initmeta ( -- ) initmeta 0 is lastacf-t ;
\ Creates a header in the target image
: $really-header-t ( str -- )
\ Find the metacompiler's copy of the threads
2dup current-t @ $hash-t ( str thread )
-rot dup 1+ /link-t + ( thread str,len n )
here-t + dup acf-aligned-t swap - allot-t ( thread str,len )
tuck here-t over 1+ note-string-t allot-t ( thread len str,len adr )
place-cstr-t over + c!-t ( thread )
here-t 1- dup c@-t h# 80 or swap c!-t
\ get the link to the top word ( thread )
dup link-t@ ( thread top-word )
\ link the existing list to the new word
\ link the thread to the new word
here-t 8 u.r ( drop ) space type cr
: $meta-execute ( pstr -- )
['] meta $vfind if execute else type ." ?" abort then
: $header-t ( name$ cf$ -- ) \ Make a header in the target area
xref-header-hook \ for Xreferencing
2dup $create-s \ symbol table entry
\ Make header unless headerless
make-header? if 2dup $really-header-t then
show? @ if showsym else 2drop then
here-t is lastacf-t \ Remember where the code field starts
here-t lastacf-s @ resolution! \ resolve it
header-control @ 3 and lastacf-s @ info!
\ Construct the list of "actions" that may be performed
\ when a given target-word is the target of "is"
\ Make these words state-smart so they can be used both
\ when the "is" is applied at meta-compile time and when it
\ is being compiled-in. The meta-compiling-state part will
\ compile-in the appropriate run-time variant of "is".
\ Support function for noting misuses:
: don't-use-with-is ( $adr,len -- bufr ) \ Start off the message
" Don't you know not to use IS with " "temp pack ( $adr,len bufr )
dup 2swap ( bufr bufr $adr,len )
: don't-use-is-while-metacomp ( bufr -- ) \ Finish off the message.
dup " while metacompiling" rot $cat ( bufr )
: don't-use-interp-is ( $adr,len -- ) \ Interpret-time message
don't-use-is-while-metacomp
\ The interpret-time variants
\ I would have liked to call these is<whatever>-interp but there are
\ a few of 'em scattered around for use in the defining process; I'll
\ just continue to call them is<whatever>
: isuser ( n acf-t -- ) >user-t n-t! ;
: istuser ( acf-t1 acf-t -- ) >user-t token-t! ;
: isvalue ( n acf-t -- ) >user-t n-t! ;
: isdefer ( acf-t1 acf-t -- ) >user-t token-t! ;
\ We'll allow a constant to be changed at metacompile-time
: isconstant ( n acf-t -- ) >body-t !-t ;
\ : iscreate ( acf-t -- addr ) >body-t ; \ This isn't used
\ In-dictionary variables are a leftover from the earliest FORTH
\ implementations. They have no place in a ROMable target-system
\ and we are deprecating support for them; but Just In Case you
\ ever want to restore support for them, define the command-line
\ symbol: in-dictionary-variables
[ifdef] in-dictionary-variables
: isvariable ( n acf-t -- ) >body-t !-t ;
: isvocabulary ( threads acf-t -- )
>user-t ( threads threadsaddr-t )
over link-t@ over link-t! ( threads threadsaddr-t )
/link-t + swap /link-t + swap
\ The meta-compile-time variants
\ Support function for noting misuses:
: don't-use-meta-is ( $adr,len -- ) \ Meta-compile-time message
don't-use-with-is ( bufr )
dup " inside a definition" rot $cat ( bufr )
don't-use-is-while-metacomp
: don't-use-is-at-all ( [ | n ] $adr,len -- ) \ Dispatch to proper message
state @ metacompiling = if ( $adr,len )
don't-use-meta-is \ Dispatch to meta-compile-time message
rot drop don't-use-interp-is \ Dispatch to interpret-time message
: isvocabulary-meta ( acf-s -- )
drop " a VOCABULARY definition" don't-use-meta-is
: isvalue-meta ( acf-s -- ) compile-t (is-user) compile,-t ;
: isdefer-meta ( acf-s -- ) compile-t (is-defer) compile,-t ;
: isuser-meta ( acf-s -- ) compile-t (is-user) compile,-t ;
: istuser-meta ( acf-s -- ) compile-t (is-defer) compile,-t ;
[ifdef] in-dictionary-variables
: isvariable-meta ( acf -- ) compile-t (is-const) ;
\ The actual is<whatever>-action words.
: isvalue-action ( [ | n ] acf-s acf-t -- )
state @ metacompiling = if ( acf-s acf-t )
: isdefer-action ( [ | acf-t1 ] acf-s acf-t -- )
state @ metacompiling = if ( acf-s acf-t )
else ( acf-t1 acf-s acf-t )
: isuser-action ( [ | n ] acf-s acf-t -- )
state @ metacompiling = if ( acf-s acf-t )
: istuser-action ( acf1 acf -- )
state @ metacompiling = if
: isconstant-action ( [ | n ] acf-s acf-t -- n )
state @ metacompiling = if ( acf-s acf-t )
2drop " a CONSTANT" don't-use-meta-is
: iscreate-action ( [ | acf-t1 ] acf-s acf-t -- ) \ Don't do this!
2drop " a CREATE definition"
[ifdef] in-dictionary-variables
: isvariable-action ( n acf -- )
state @ metacompiling = if
: isvocabulary-action ( [ | threads ] acf-s acf-t -- )
state @ metacompiling = if ( acf-s acf-t )
else ( threads acf-s acf-t )
: iscolon-action ( [ | acf-t1 ] acf-s acf-t -- )
2drop " a Colon or Code definition"
\ Perform a create for the target system. This includes making or
\ resolving a symbol table entry. A partial code field may be generated.
: header-t \ name ( name-str -- )
safe-parse-word 2swap $header-t
\ Automatic allocation of space in the user area
: ualigned-t ( n -- n' ) #ualign-t 1- + #ualign-t negate and ;
: ualloc-t ( n -- next-user-# ) \ allocate n bytes and leave a user number
( #bytes ) #user-t @ over #ualign-t >= if
: constant \ name ( n -- )
safe-parse-word 3dup $equ
" constant-cf" $header-t s->l-t ,-t
['] isconstant-action setaction ?debug
['] iscreate-action setaction ?debug
[ifdef] in-dictionary-variables
" variable-cf" header-t 0 n->n-t ,-t
['] isvariable-action setaction ?debug
\ isuser is in target.fth
\ X : isuser ( n acf -- ) >user-t n-t! ;
: user \ name ( user# -- )
" user-cf" header-t n->n-t ,user#-t
['] isuser-action setaction ?debug
\ istuser is in target.fth
\ X : istuser ( acf1 acf -- ) >user-t token-t! ;
/token-t ualloc-t user ['] istuser-action setaction
: isauser ( adr acf -- ) >user-t a-t! ;
/a-t ualloc-t user ['] istuser-action setaction
\ isvalue is in target.fth
\ X : isvalue ( n acf -- ) >user-t n-t! ;
safe-parse-word 3dup $equ
" value-cf" $header-t /n-t ualloc-t n->n-t ,user#-t
['] isvalue-action setaction ?debug
\ : buffer: \ name ( size -- )
\ /n-t ualloc-t n->n-t ,user#-t \ user#
\ here-t buffer-link-t a-t@ a,-t buffer-link-t ha-t!
" code-cf" header-t entercode ?debug
show? @ if 2dup showsym then
['] labels $vcreate here-t , immediate-h
metacompiling of literal-t endof
true of [compile] literal endof
safe-parse-word 2dup " label-cf" $header-t entercode ( name$ )
\ Creates a label that will only exist in the metacompiler;
\ When later executed, the label returns the target address where the
\ label was defined. No changes are made to the target image as a result
: mlabel \ name ( -- ) ( Later: -- adr-t )
safe-parse-word align-t acf-align-t $label
: mloclabel \ name ( -- ) ( Later: -- adr-t )
: code-field: \ name ( -- )
mlabel meta-assemble entercode
\ This vocabulary allocates space for its threads in the user area
\ instead of in the dictionary. It is therefore ROMable. The existence
\ of the voc-link in the dictionary does not compromise this, since
\ the voc-link is only written once, when the vocabulary is created.
lastacf-t voc-link-t link-t@ a,-t
: set-threads-t ( name$ -- )
threads-t lastacf-t isvocabulary
lastacf-t >user-t clear-threads-t
: definitions-t ( -- ) context-t @ >user-t current-t ! ;
\ If we make several metacompiled vocabularies, we need to initialize
\ the threads with link, to make them relocatable
: vocabulary \ name ( -- )
safe-parse-word 2dup " vocabulary-cf" $header-t ( name )
\ The 1 extra thread is the "last" field
#threads-t /link-t * ualloc-t ( name$ user# )
n->n-t ,user#-t ( name$ )
2dup set-threads-t ( name$ )
['] isvocabulary-action setaction
['] meta $vcreate lastacf-t , does> @ context-t !
\ /defer-t is the number of user area bytes to alloc for a deferred word
\ isdefer is in target.fth
\ X : isdefer ( acf acf -- ) >user-t token-t! ;
" defer-cf" header-t /defer-t ualloc-t n->n-t ,user#-t
['] isdefer-action setaction
: compile-in-user-area ( -- compilation-base here )
0 dp-t ! userarea-t is compilation-base \ Select user area
: restore-dictionary ( compilation-base here -- )
dp-t ! is compilation-base
\ XXX the alignment should be done in startdoes; it is incorrect
\ to assume that acf alignment is sufficient (code alignment might
align-t acf-align-t here-t doestarget !
" startdoes" $meta-execute
?csp compile-t (;code) align-t acf-align-t here-t doestarget !
" start;code" $meta-execute
[compile] [ reveal-t entercode
: [compile] \ name ( -- )
host safe-parse-word $compile-t target
\ Initialization of variables, defers, vocabularies, etc.
\ Because this word is immediate, it can be used in the
\ interpretive state as well as inside target-compiled
\ The secret is that the "action" words set (via setaction )
\ for each defining-type are themselves state-smart, and will
\ Do The Right Thing in either state.
safe-parse-word $sfind if ( acf-s )
dup resolution@ ( acf-s acf-t )
only forth also meta also definitions
: metacompile-do-undefined ( pstr -- ) \ compile a forward reference
['] metacompile-do-defined is-h do-defined
['] $metacompile-do-undefined is-h $do-undefined
['] metacompile-do-undefined is-h do-undefined
['] metacompile-do-literal is-h do-literal
only forth labels also forth symbols also forth transition
?comp ?csp compile-t unnest reveal-t [compile] [-t
only forth also meta also definitions
flags-t @ th 40 toggle-t \ fix target header
immediate-s \ fix symbol table
!csp " colon-cf" header-t hide-t ]-t ?debug
['] iscolon-action setaction
\ These are meta compiler versions of the fm/lib/chains.fth file
\ the same rules apply just the implementation changes.
: (overload:-t) ( str,len chain? -- )
-rot 2dup $sfind if ( chain? str,len acf )
resolved? if ( chain? str,len )
2dup ( chain? str,len str,len )
type ." must exist!" abort ( )
else ( chain? str,len str,len )
2drop 0 0 ( chain? str,len str,len )
then ( chain? str,len link,len )
2swap ( chain? link,len str,len )
show? @ 0= if warning-t dup @ >r off then ( chain? link,len str,len )
header-control @ >r ( chain? link,len str,len )
r@ if headerless then ( chain? link,len str,len )
" colon-cf" $header-t hide-t ]-t ?debug ( chain? link,len )
['] iscolon-action setaction ( chain? link,len )
?dup if $compile-t else drop then ( )
show? @ 0= if r> warning-t ! then ( )
!csp safe-parse-word ( str,len )
: overload:-t \ name ( -- )
!csp safe-parse-word ( str,len )
\ Create functional equivalents of [ifexist] and [ifnexist]
\ for use during metacompilation; these will search only the
\ target dictionary instead of the host dictionary.
\ If the word is found in the LABELS vocabulary, it "exists".
\ Otherwise, if it is found in the SYMBOLS vocabulary it
\ "exists" only if it is RESOLVED.
\ We look in the SYMBOLS vocabulary first because things are
\ more likely to be there.
: meta-defined? ( -- meta-defined? ) \ name
safe-parse-word $sfind if
else ['] labels $vfind nip ?dup nip
: [ifnexist]-t ( -- ) \ name
meta-defined? 0= postpone [if]
: [ifexist]-t ( -- ) \ name
meta-defined? postpone [if]
\ Turn on the metacompiler by
\ changing the words used by the assembler to store into the dictionary.
\ They should store into the target dictionary instead of the host one.
only forth meta also forth also definitions
meta assembler definitions
: 'body \ name ( -- apf )
alias [ifexist] [ifexist]-t
alias [ifnexist] [ifnexist]-t
alias overload: overload:-t
alias [defined] [defined]
alias [ifexist] [ifexist]-t
alias [ifnexist] [ifnexist]-t
only forth also meta assembler definitions
only forth also definitions
projects / OpenSPARC-T2-SAM / blob