\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: domain-services.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: @(#)domain-services.fth 1.8 07/06/22
copyright: Copyright 2007 Sun Microsystems, Inc. All Rights Reserved
copyright: Use is subject to license terms.
vocabulary domain-services
also domain-services definitions
fload ${BP}/arch/sun4v/ds-h.fth
\ node = domain-services-port
\ return pointer to the id property in the accociated channel endpoint
: get-endpoint-id ( node -- id | -1 )
" fwd" ascii a md-find-prop ?dup if ( arc )
md-decode-prop drop " id" ascii v md-find-prop ?dup if ( prop )
md-decode-prop drop exit ( id )
\ if this is a domain-service port attempt to open it unless we've already
\ opened a port. node = domain-service-port
: open-ds-channel ( node -- )
cached-ldc-id -1 <> if drop exit then ( node )
dup md-node-name " domain-services-port" $= if ( node )
get-endpoint-id dup -1 <> if ( id )
dup ldc-mode-reliable ldc-open if ( id )
to cached-ldc-id exit ( )
\ When operating on the default MDs OBP uses a private channel
: try-openboot-channel ( -- error? )
md-root-node " openboot" md-find-node ?dup if ( node )
['] open-ds-channel swap md-applyto-fwds ( )
\ if we haven't cached an id then the open failed
cached-ldc-id -1 = ( error? )
\ When operating on zeus MDs Openboot may use 1 of 2 centrally located
\ channels depending on whether it is the primary domain or a guest
: try-other-channels ( -- error? )
md-root-node " domain-services" md-find-node ?dup if ( node )
['] open-ds-channel swap md-applyto-fwds ( )
\ if we haven't cached an id then the opens failed
cached-ldc-id -1 = ( error? )
\ Find and bring up the domain services LDC channel
\ if we are reopening, the channel will be cached so skip the search
: init-ldc-channel ( -- error? )
cached-ldc-id -1 <> if ( )
cached-ldc-id ldc-mode-reliable ldc-open 0= ( error? )
try-openboot-channel dup if ( error? )
try-other-channels and ( error? )
: ldc-channel-reconfigured? ( -- reconfigured? )
\ send a domain service packet over the ldc channel
: send-ds-pkt ( buf len -- error? )
tuck ldc-write ?dup if ( len len' status )
dup LDC-NOTUP = if ( len len' status )
DS-CLOSED to domain-service-state ( len len' status )
\ receive a domain service packet from the ldc channel
\ wait up to 1 second for a response
: receive-ds-pkt ( buf len -- error? )
\ Re-try 10 times, @ 10 seconds as lower layer tries for 1 sec
d# 10 ( buf len timeout )
begin ( buf len timeout )
1 ms 1- dup ( buf len timeout timeout )
-rot 2dup ldc-read ?dup if ( timeout buf len len' status )
nip ( timeout buf len status )
LDC-NOTUP = if ( timeout buf len )
DS-CLOSED to domain-service-state ( )
3drop LDC-NOTUP exit ( LDC-NOTUP )
else ( timeout buf len len' )
\ assemble a domain service version packet
: assemble-init-req ( major minor -- size )
ds-pkt-buffer ( major minor buf )
DS-INIT-REQ over msg-type! ( major minor buf )
/ds-init-req over payload-len! ( major minor buf )
>payload ( major minor payload )
tuck >init-minor-ver w! ( major payload )
tuck >init-major-ver w! ( buf )
payload>pkt dup pkt-size@ ( buf size )
\ wait for a domain service version response
: wait-for-init-resp ( -- buf len error? )
ds-pkt-buffer /ds-hdr /ds-init-ack + ( buf len )
2dup receive-ds-pkt dup ( buf len error? error? )
LDC-NOTUP = if ( buf len error? )
" Waiting for DS init response but LDC is Not Up!"
]cmn-end ( buf len error? )
exit ( buf len LDC-NOTUP )
over >msg-type l@ ( buf len type )
dup DS-INIT-ACK = if drop 0 exit then ( buf len 0 )
DS-INIT-NACK = if -1 exit then ( buf len -1 )
: init-ack? ( type -- ack? ) DS-INIT-ACK = ;
\ parse domain service version response
: parse-init-req ( pkt len -- major/minor type )
drop dup >msg-type l@ tuck ( type pkt type )
>payload >init-ack-minor-vers w@ ( type minor )
>payload >init-nack-major-vers w@ ( type major )
swap ( major/minor type )
\ assemble and send a domain service version request
: ds-init-request ( major minor -- major/minor type 0 | error )
assemble-init-req ( buf size )
send-ds-pkt ?dup if ( error )
cmn-warn[ " Sending DS Init request but LDC is NOT Up!" ]cmn-end
wait-for-init-resp ?dup 0= if ( buf len )
parse-init-req 0 ( major/minor type 0 )
then ( major/minor type 0 | error )
\ This can later be turned into a begin while loop that handles
\ multiple versions... however right now only 1.0 is supported
: ds-init-handshake ( -- error? )
ds-major ds-minor ( major minor )
ds-init-request ?dup if exit then ( major/minor type | error? )
\ initialize domain-services protocal link
init-ldc-channel ?dup 0= if
" Unable to complete Domain Service protocol version handshake"
\ If error is LDC reset then leave the state as DS-CLOSE
DS-ERROR to domain-service-state
cmn-warn[ " Unable to connect to Domain Service providers" ]cmn-end
DS-OPEN to domain-service-state
\ assemble a particular service registration version request
: assemble-reg-req ( major minor svc-handle $svc-id -- buf len )
ds-pkt-buffer ( major minor svc-handle $svc-id pkt )
DS-REG-REQ over msg-type! ( major minor svc-handle $svc-id pkt )
over /ds-reg-req + over payload-len! ( major minor svc-handle $svc-id pkt )
>payload ( major minor svc-handle $svc-id pay )
-rot 2 pick >reg-svc-id swap move ( major minor svc-handle payload )
tuck >reg-svc-handle x! ( major minor payload )
tuck >reg-minor-ver w! ( major payload )
tuck >reg-major-ver w! ( payload )
payload>pkt dup pkt-size@ ( buf len )
\ wait for a service registration version response
: wait-for-reg-resp ( -- buf len error? )
ds-pkt-buffer /ds-hdr /ds-reg-ack + ( buf len )
2dup receive-ds-pkt dup ( buf len error? error? )
LDC-NOTUP = if ( buf len error? )
" Waiting for DS registration response but LDC is Not Up!"
]cmn-end ( buf len error? )
exit ( buf len LDC-NOTUP )
over >msg-type l@ ( buf len type )
dup DS-REG-ACK = if drop 0 exit then ( buf len 0 )
DS-REG-NACK = if -1 exit then ( buf len -1 )
\ assemble a service unregistration request
: assemble-unreg-req ( svc-handle -- pkt size )
ds-pkt-buffer ( svc-handle pkt )
DS-UNREG over msg-type! ( svc-handle pkt )
/ds-unreg-req over payload-len! ( svc-handle pkt )
tuck >payload >unreg-svc-handle x! ( pkt )
dup pkt-size@ ( pkt len )
\ wait for service unregistration response
: wait-for-unreg-resp ( -- error? )
ds-pkt-buffer /ds-hdr /ds-unreg-req + ( buf len )
2dup receive-ds-pkt dup ( buf len error? error? )
LDC-NOTUP = if ( buf len error? )
" Waiting for DS unregister response but LDC is Not Up!"
]cmn-end ( buf len error? )
-rot 2drop exit ( LDC-NOTUP )
over >msg-type l@ ( buf len type )
dup DS-UNREG-ACK = if 3drop 0 exit then ( 0 )
DS-UNREG-NACK = if 2drop -1 exit then ( -1 )
: reg-ack? ( type -- ack? ) DS-REG-ACK = ;
\ parse a service registration request-response
: parse-reg-req ( pkt len -- major/minor type )
drop dup >msg-type l@ tuck ( type pkt type )
>payload >regack-minor-vers w@ ( type minor )
>payload >regnack-major-vers w@ ( type major )
swap ( major/minor type )
\ assemble and send a service registration request
: ds-reg-request ( $svc-id svc-handle major minor -- major/minor type 0 | error )
assemble-reg-req ( buf size )
dup LDC-NOTUP = if ( LDC-NOTUP )
cmn-warn[ " Sending DS Reg request but LDC is Not Up!" ]cmn-end
wait-for-reg-resp ?dup if ( buf len error )
parse-reg-req reg-ack? 0 ( major/minor ack? 0 )
\ assemble a domain service data packet
: assemble-data-pkt ( buf len svc-handle -- pkt len' )
ds-pkt-buffer ( buf len svc-handle pkt )
DS-DATA over msg-type! ( buf len svc-handle pkt )
tuck >payload >data-svc-handle x! ( buf len pkt )
over /ds-data + over payload-len! ( buf len pkt )
>payload /ds-data + swap move ( )
dup pkt-size@ ( pkt len )
\ extracts start and length of a Data pkt
: data-payload ( pkt -- payload-buf payload-len )
dup >payload /ds-data + ( pkt payload-buf )
swap payload-len@ /ds-data - ( payload-buf payload-len )
\ receive a data packet from the domain-service channel
\ (only copy payload to buf)
: wait-for-data-pkt ( buf len svc-handle -- len' 0 | error )
ds-pkt-buffer rot ( buf svc-handle pkt len )
/ds-hdr + /ds-data + ( buf svc-handle pkt len' )
2dup receive-ds-pkt ?dup if ( buf svc-handle pkt len status )
>r 2drop 2drop r> exit ( error )
then ( buf svc-handle pkt len )
over msg-type@ DS-DATA = if ( buf svc-handle pkt len )
-rot 2dup >payload ( buf len svc-handle pkt svc-h pay )
>data-svc-handle x@ = if ( buf len svc-handle pkt )
rot -1 ( buf svc-handle pkt len -1 )
rot 0 ( buf svc-handle pkt len 0 )
0 ( buf svc-handle pkt len 0 )
then ( buf svc-handle pkt len good? )
until ( buf svc-handle pkt len )
drop nip data-payload ( buf payload payload-len )
>r swap r@ move r> 0 ( len' 0 )
\ Bring up domain service channel unless it's in the ERROR state
: check-domain-service-state ( -- error? )
\ If we think the channel is open, but some other entity (Solaris)
\ has reconfigured it, we play it safe and tranistion to an error state
domain-service-state DS-OPEN = if
ldc-channel-reconfigured? if
DS-ERROR to domain-service-state
domain-service-state case
DS-CLOSED of ds-init endof
\ Wrap buffer in a domain service packet and send it on the specified channel
: send-ds-data ( buf len svc-handle -- error? )
check-domain-service-state if
assemble-data-pkt ( pkt len )
\ Receive a data packet from the specified channel
: receive-ds-data ( buf len svc-handle -- len' 0 | error )
check-domain-service-state if
then ( buf len svc-handle )
wait-for-data-pkt ( len' 0 | error )
\ Register a particular domain service
\ Don't print an error message because there may be a backup service available
: register-domain-service ( maj min svc-han $svc-id -- maj/min ack? 0 | error )
check-domain-service-state if
3drop 2drop -1 exit ( -1 )
then ( maj min svc-han $svc-id )
ds-reg-request ( maj/min ack? 0 | error )
\ unregister a particular domain service
: unregister-domain-service ( svc-handle -- error? )
check-domain-service-state if
assemble-unreg-req ( pkt size )
send-ds-pkt ?dup 0= if ( )
wait-for-unreg-resp ( error? )
dup LDC-NOTUP = if ( LDC-NOTUP )
cmn-warn[ " Sending Unreg request but LDC is Not Up!" ]cmn-end
previous definitions \ domain-services
projects / OpenSPARC-T2-SAM / blob