\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: cmn-msg-format.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: @(#)cmn-msg-format.fth 1.16 06/06/15 17:20:05
purpose: Common messaging framework
copyright: Copyright 2006 Sun Microsystems, Inc. All Rights Reserved.
copyright: Use is subject to license terms.
defer platform-fatal-hook ' noop is platform-fatal-hook
defer platform-error-hook ' noop is platform-error-hook
defer platform-warning-hook ' noop is platform-warning-hook
defer platform-note-hook ' noop is platform-note-hook
defer platform-cmn-end-hook ' noop is platform-cmn-end-hook
defer platform-cmn-end-hook2 ' noop is platform-cmn-end-hook2
\ System FATAL and ERROR flags
\ If you set the fatal state the machine will suppress the boot command
\ and will not attempt to auto-boot, it will also print an ugly message.
\ If you set the error-state? an auto-boot? may not happen.
0 value system-fatal-state?
0 value system-error-state?
headers vocabulary cmn-messaging
also cmn-messaging definitions
\ Message categories are as follows:
\ we are converting these numbers into the matching bitpatterns that the
\ verbosity framework uses so we can use simple AND logic to determine if
\ the message is printed.
VRBS-MAX VRBS-DEBUG or constant cmn-type
h# 40 cmn-type or constant cmn-msg
VRBS-MED cmn-msg or constant cmn-note
VRBS-MIN cmn-note or constant cmn-warning
h# 80 cmn-warning or constant cmn-error
VRBS-NONE cmn-error or constant cmn-fatal
\ Message Frame Data Structure Format
\ Each message frame contains the following fields:
\ 8 bytes - address of the parent frame (0 if no parent)
\ 8 bytes - address of the first child frame (0 if no children)
\ 8 bytes - address of the next peer frame (0 if no more peers)
\ 8 bytes - address of the message buffer (allocated dynamically)
\ 8 bytes - phandle of the device pathname associated with message
\ 1 byte - category of common message
\ 1 byte - message completion flag (true/false)
/n field >cmn-parent \ address of the parent frame
/n field >cmn-child \ address of the first child frame
/n field >cmn-peer \ address of the peer frame
/n field >cmn-message \ address of the message buffer
/n field >cmn-phandle \ phandle of the device pathname
/c field >cmn-category \ category of common message
/c field >cmn-completion \ message completion flag
\ Message Data Structure Format
\ Each message contains the following fields:
\ 2 bytes - max length of the current string
\ 2 bytes - length of the current text sting
\ N bytes - current text sting itself
/w field >cmn-message>maxlen \ max length of the long string
/w field >cmn-message>lstr \ start of long counted text string
\ Size of initial message buffer and size of each increment
d# 255 constant max-message-len
variable current-frame$ 0 current-frame$ ! \ pointer to the current message frame
\ Long packed strings format: first 2 bytes - count, then string itself.
\ long-count takes long packed string address from the stack and returns
\ the string address and the length of the string on the stack.
: long-count ( lpstr -- str,len) dup wa1+ swap w@ ;
\ Concatenates a string to the end of packed long string
: $long-cat ( adr len lpstr -- )
>r r@ long-count ca+ ( adr len end-adr ) ( r: lpstr )
swap dup >r ( adr end-adr len ) ( r: lpstr len )
cmove r> r> ( len lpstr )
\ Concatenates a given number of spaces to end of packed long string
: $long-spaces ( n lpstr -- )
>r r@ long-count ca+ ( n end-adr ) ( r: lpstr )
over bl fill r> ( n lpstr )
\ Returns phandle for active instance or 0 if no instance
: ?phandle ( -- phandle|0) my-self dup if ihandle>phandle then ;
\ Add a new child to the current frame.
\ If this is the first child, it becomes the frame's >cmn-child.
\ Otherwise it becomes the last entry in the >cmn-peer chain starting from >cmn-child.
: add-new-child ( new-frame-addr -- )
current-frame$ @ >cmn-child
: current>message ( -- addr) current-frame$ @ >cmn-message ;
: current>string ( -- addr) current>message @ >cmn-message>lstr ;
: current>maxlen ( -- addr) current>message @ >cmn-message>maxlen ;
\ Ensures that current>string is long enough to $long-cat n bytes
: expand-current>string ( n -- )
\ Calculate length of new string
current>string w@ + ( len )
\ Retrieve the max length of the current message buffer and compare
dup current>maxlen w@ > if \ Need allocate bigger message buffer
\ Calculate the size of the new message frame
max-message-len / 1+ max-message-len * ( new-len )
\ Allocate new message buffer
dup /cmn-message + alloc-mem ( new-len new-buffer-addr )
\ Erase new message buffer header
dup /cmn-message erase ( new-len new-buffer-addr )
\ Move old message to the new bigger buffer
dup >cmn-message>lstr current>string long-count rot $long-cat ( new-len new-buffer-addr )
\ Update new buffer maxlen field
tuck >cmn-message>maxlen w! ( new-buffer-addr )
\ Release old message buffer
current>message @ ( new-buffer-addr old-buffer-addr )
current>maxlen w@ ( new-buffer-addr old-buffer-addr old-len )
/cmn-message + free-mem ( new-buffer-addr )
\ Update message frame >cmn-message pointer
\ Like "type", but buffered into current message frame
: buffered-type ( adr,len -- )
dup expand-current>string ( adr,len )
current>string $long-cat ( )
\ Like "spaces", but buffered into current message frame
: buffered-spaces ( n -- )
dup expand-current>string ( adr,len )
current>string $long-spaces
\ There is one [ifdef] in this file: [ifdef] cmn-reentrant?
\ this is a place holder so that the entire cmn-append code becomes
\ FWARC/2004/311 format encoder extension
\ This works by parsing the string from left->right, recursing until all the
\ tokens are encoded, and then pushing the stack items into the fmt-data
\ structures on the return (unnesting) path.
\ Once the sequence is complete the stack is logically empty and the entire
\ sequence is replayed left-to-right.
\ Each fmt-data structure will contain the acf of the number->string encoder
\ appropriate for the encoding and the actual stack data.
\ After each node is processed the node is released.
\ Everything ends up being funnelled through the (fmt-s) routine, so buffering
\ the constructed message should be trivial - though it will be assembled in
\ 1) man printf and read, this covers the basics.
\ 2) the delta with printf is the % behaviour; printf will consume
\ the %<illegal> and this implemention does not.
\ If you want to print a %x (a reserved sequence) you need to
\ escape the % by using another one. %%x
\ %d - signed decimal 32bit value
\ %x - unsigned hex 32bit value
\ %ld - signed decimal 64bit value
\ %lx - unsigned hex 64bit value
\ In addition you can encode field widths for all the valid encodings.
\ An example using decimal.
\ %5d - put a 32bit signed decimal number in
\ a field width of 5, the number is truncated
\ %-5d - put a 32bit signed decimal number in
\ a field width of 5, the number is truncated
\ A simple example, print a name and an age and a newline.
\ : display-record ( name$ age -- )
\ cmn-type[ " %s is %d years old"r"n" ]cmn-end
\ Note that the arguments are used in the order they appear in the stack
\ diagram - from left to right, NOT by their stack positions.
\ Extending the example a little, to put the name and age in fixed width
\ fields: 10 characters for the name, left justified and 3 for the age.
\ : display-record ( name$ age -- )
\ cmn-type[ " %-10s is %3d years old"r"n" ]cmn-end
/n field >fmt-next \ next format block
/c field >fmt-width \ field width
/c field >fmt-flags \ bit0 = Long Value, bit1 = unsigned
/n field >fmt-encode \ type encoder
2 /n* field >fmt-args \ data for encoder
\ a primitive sign extending c@ would be nice - like <w@
: <c@ ( n -- x ) c@ dup h# 80 and if d# 256 - then ;
>r r@ >fmt-args 2@ ( str len )
r> >fmt-width <c@ ( str len )
tuck buffered-type ( len' )
negate buffered-spaces exit ( )
r> over - buffered-spaces ( )
: (fmt-cpy) ( ptr -- ) >fmt-args 2@ buffered-type ;
r@ >fmt-args @ r@ >fmt-data c!
r@ >fmt-data 1 r@ >fmt-args 2!
>r r@ >fmt-args dup @ ( dptr data )
r@ >fmt-flags c@ case ( dptr data )
0 of over l! dup <l@ (.) endof \ signed 32 bit
1 of (.) endof \ 64 bit, signed
2 of over l! dup l@ (u.) endof \ unsigned 32 bit
3 of (u.) endof \ 64 bit, unsigned
: (fmt-.d) ( ptr -- ) decimal (fmt-.n) ;
: (fmt-.x) ( ptr -- ) hex (fmt-.n) ;
: (fmt-save) ( ?? items ptr -- )
1 of r@ >fmt-args ! endof ( )
2 of r@ >fmt-args 2! endof ( )
." Can't support " .d ." arguments in common messaging string" cr
: (fmt-push) ( ?? items code acf -- node )
/fmt-data alloc-mem >r ( )
r@ >fmt-encode ! ( ?? items code )
wbsplit ( ?? items width flags )
r@ >fmt-flags c! ( ?? items width )
r@ >fmt-width c! ( ?? items )
0 r@ >fmt-next ! ( ?? items )
fmt-tail dup @ ( node ptr tail )
r@ ( node ptr tail node )
>r r@ r@ >fmt-encode @ execute ( ptr )
r> /fmt-data free-mem ( ptr )
: (fmt-valid?) ( ptr -- flag )
ascii d of true endof \ decimal
ascii x of true endof \ hex
ascii c of true endof \ char
ascii s of true endof \ string
ascii p of true endof \ pointer
\ verify that the string contains a valid encoder sequence.
\ return the skip size (2 for ld), (1 for d) for example.
: (sfmt-valid?) ( str,len -- str,len,n,-1 | str,len,0 )
over c@ ascii l = if ( str,len )
over 1+ (fmt-valid?) if ( str,len )
exit ( str,len,n,-1 | str,len,0 )
over (fmt-valid?) if ( str,len )
1 true ( str,len,1,true )
then ( str,len,n,-1 | str,len,0 )
\ an optimisation for tokens..
: ((fmt-.x)) h# 200 or ['] (fmt-.x) 1 false ;
\ convert the character encoding into field widths, and the encoder
: (fmt-decode) ( flags,ptr -- flags,acf,n,flag )
ascii d of ['] (fmt-.d) 1 false endof \ decimal
ascii x of ((fmt-.x)) endof \ hex (unsigned)
ascii c of ['] (fmt-c) 1 false endof \ char
ascii s of ['] (fmt-s) 2 false endof \ string
ascii p of ((fmt-.x)) endof \ hex pointer
>r 2 ['] (fmt-cpy) true r>
\ return true if this string does not have a valid encoding
\ else return false, the field with and the encoding acf
: (scan-for-fmt) ( str$ -- str$,w,acf,n,0 | str$,true )
over c@ ascii % = if ( str$ )
\ %% forces a % which is a special case
1 /string true ( str$,true )
\ Simple fieldless sequence?
(sfmt-valid?) if ( str$,n )
0 r@ 1- bwjoin ( str$,w )
r> 1- r> + (fmt-decode) ( str$,w,acf,n,flag )
\ field is left justified?
over c@ ascii - = if ( str,len 1 )
3 pick + 0 ( str,len sign num,len )
begin ( str,len sign num,len )
2dup + c@ d# 10 digit nip while ( str,len sign num,n )
repeat ( str,len sign num,len )
\ verify the token following the numbers (if any)
?dup if ( str,len sign num,len )
rot /string ( str,len num,len )
tuck ( str,len len num,len )
$number if ( str,len len )
drop true exit ( str,len,true )
3 pick + r> over >r >r ( str,len len fmt )
2 pick 2 pick - ( str,len len fmt,len )
(sfmt-valid?) if ( str,len len fmt,len s )
r> over bwjoin ( str$ s' code )
swap r> + ( str$ code fmt' )
(fmt-decode) ( str$ code,acf,n,flag )
else ( str,len len fmt,len )
2r> 3drop ( str,len len fmt )
\ the meat of the parsing
: (fmt-parse) ( str,len -- )
dup 0= if 2drop exit then
ascii % left-parse-string ?dup if ( right$ left$ )
2 0 ['] (fmt-cpy) (fmt-push) drop ( right$ )
(scan-for-fmt) if ( right$ )
\ we have a % to print, fake it with a %c conversion
ascii % 1 0 ['] (fmt-c) (fmt-push) drop ( right$ )
>r 0 -rot (fmt-push) ( right$ ptr )
>r (fmt-parse) ( right$ )
r> r> swap (fmt-save) ( )
previous definitions also cmn-messaging
: cmn-append ( ?? str,len -- )
\ Check if there is a current frame to append to
." Missing cmn-xxx[ caused cmn-append with '" type
." ' argument to fail"r"n"
fmt-head dup @ >r off fmt-tail dup @ >r off
fmt-head off fmt-tail off
[ifdef] cmn-reentrant? r> fmt-tail ! r> fmt-head ! [then]
previous also cmn-messaging definitions
: cmn-[ ( msg-category -- )
\ Allocate buffer for a new message text string
max-message-len /cmn-message + alloc-mem ( category message-addr)
\ Clear the buffer headers with zeroes
dup /cmn-message erase ( category message-addr)
\ Compile buffer length at the beginning into cmn>messsage>maxlen field
max-message-len over >cmn-message>maxlen w! ( category message-addr)
\ Allocate pointer data structure for a new message frame
/cmn-frame alloc-mem >r ( category message-addr ) ( r: frame-addr)
\ Clear the pointer data structure with zeroes
r@ /cmn-frame erase ( category message-addr )
\ Set >cmn-message field;
\ Store the pointer to the message text string buffer into >cmn-message field
\ of the message frame pointer data structure
r@ >cmn-message ! ( category )
\ Compile the current message category into >cmn-category field
\ of the message frame pointer data structure
\ Store phandle into current >cmn-phandle field
\ of the message frame pointer data structure
?phandle r@ >cmn-phandle ! ( )
\ Store the pointer to the parent frame into >cmn-parent field
\ of the message frame pointer data structure
current-frame$ @ r@ >cmn-parent !
current-frame$ @ if r@ add-new-child then
\ Store the pointer to the current message frame pointer
\ data structure into current-frame$
r> current-frame$ ! ( ) ( r: )
\ The 'lose' is patched to cmn-end, later in this file
\ we dont want or need to use a defer!!
" ...(text may have been truncated due to an exception)"r"n" lose
\ Prints the content of the message between cmn-xxx[ and ]cmn-end
: .message-content ( frame-addr -- )
>cmn-message @ >cmn-message>lstr long-count type
\ Prints device path followed by colon
: .devpath ( frame-addr -- )
>cmn-phandle @ ?dup if ( phandle)
\ Selects individual format based on message category
: (print-message) ( frame-addr -- )
\ Release messaging frame and message buffer after message was printed
: release-frame ( frame-addr -- )
\ Release message buffer first
dup >cmn-message @ ( frame-addr message-addr)
dup >cmn-message>maxlen w@ /cmn-message + ( frame-addr message-addr message-maxlen )
\ Then release message frame
\ Print message based on type and verbosity level
: print-message ( frame -- )
fw-verbosity diagnostic-mode? or over >cmn-category c@ and if (print-message) else drop then
\ Common messaging frame printing code
: print-messaging-tree ( frame-addr -- ) recursive
begin ?dup while ( frame-addr )
dup print-message ( frame-addr )
dup >cmn-child @ ( frame-addr child-addr)
print-messaging-tree ( frame-addr)
dup >cmn-peer @ ( frame-addr peer-addr)
swap release-frame ( peer-addr)
\ ]cmn-end should always fetch address from current >cmn-parent
\ field and store it into current-frame$
true current-frame$ @ >cmn-completion c! \ Message completed
current-frame$ dup @ ( current-frame$ current-frame-addr )
>cmn-parent @ ( current-frame$ parent-frame-addr )
?dup if ( current-frame$ parent-frame-addr )
dup @ ( current-frame$ root-frame-addr )
platform-cmn-end-hook ( current-frame$ )
print-messaging-tree ( current-frame$ )
platform-cmn-end-hook2 ( )
\ Fixup the forward reference in cmn-[
previous definitions also cmn-messaging
: ]cmn-end ( str,len -- ) cmn-append " "r"n" cmn-end pop-checkpt ;
: cmn-fatal[ ( -- ) platform-fatal-hook true is system-fatal-state? cmn-fatal cmn-[ ;
: cmn-error[ ( -- ) platform-error-hook true is system-error-state? cmn-error cmn-[ ;
: cmn-warn[ ( -- ) platform-warning-hook cmn-warning cmn-[ ;
: cmn-note[ ( -- ) platform-note-hook cmn-note cmn-[ ;
: cmn-msg[ ( -- ) cmn-msg cmn-[ ;
: cmn-type[ ( -- ) cmn-type cmn-[ ;
\ Close and print all messaging frames currently opened
: flush-cmn-messages ( -- )
begin current-frame$ @ while " " ]cmn-end repeat
\ Need name here because it is now calling cmn-append
also magic-properties definitions
\ Name now automatically cmn-appends the name of the node
\ to the current cmn-messaging frame which must be started
\ with cmn-msg[. Used for OBP probing output. Executes type
\ if there is no active messaging frame.
: name ( value-str name-str -- value-str name-str )
2over decode-string current-frame$ @ if
projects / OpenSPARC-T2-SAM / blob