Initial commit of OpenSPARC T2 architecture model.

[OpenSPARC-T2-SAM] / obp / obp / arch / sun4v / domain-services.fth

\ ========== 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 
\    conditions are met: 
\ 
\  - 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
\ any nuclear facility. 
\ 
\ ========== Copyright Header End ============================================
id: @(#)domain-services.fth 1.8 07/06/22
purpose:
copyright: Copyright 2007 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\ FWARC 2006/055

vocabulary domain-services
also domain-services definitions

headerless

fload ${BP}/arch/sun4v/ds-h.fth

also ldc

-1 value cached-ldc-id

\ 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 )
      then
   then
   -1			\ error
;

0 value found-channel?

\ 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 )
         true to found-channel?
	 dup ldc-mode-reliable ldc-open if			( id )
	    to cached-ldc-id exit				(  )
	 then							( id )
      then							( id )
   then								( node )
   drop								(  )
;

\ 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			(  )
   then								(  )
   \ 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			(  )
   then								(  )
   \ 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? )
   else								(  )
      0 to found-channel?
      try-openboot-channel dup if				( error? )
         found-channel? 0= if
            try-other-channels and					( error? )
         then
      then							( error? )
   then								( error? )
;   

: ldc-channel-reconfigured?  ( -- reconfigured? )
   channel-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 )
      then					( len len' status )
      -rot 2drop 				( error  )
   else						( len len' )
      <> 					( error? )
   then						( error? )
;

\ 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 )
   while
      -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 )
         then				( timeout buf len )
      else				( timeout buf len len' )
         if				( timeout buf len )
            3drop 0 exit		( 0 )
         then				( timeout buf len )
      then				( timeout buf len )
      rot				( buf len timeout )
   repeat
   3drop -1				( error )
;

\ 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 )
   begin
      2dup receive-ds-pkt dup 		( buf len error? error? )
      LDC-NOTUP = if			( buf len error? )
	 cmn-warn[ 
	    " Waiting for DS init response but LDC is Not Up!"
	 ]cmn-end			( buf len error? )
	 exit				( buf len LDC-NOTUP )
      then				( buf len error? )
      0=
   while
      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 )
   repeat
   -1						( 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 )
   init-ack? if
      >payload >init-ack-minor-vers w@		( type minor )
   else
      >payload >init-nack-major-vers w@		( type major )
   then
   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 )
      dup LDC-NOTUP = if 
	 cmn-warn[ " Sending DS Init request but LDC is NOT Up!" ]cmn-end
      then				( LDC-NOTUP )
      exit  				( error )
   then					( error )
   wait-for-init-resp ?dup 0= if	( buf len )
      parse-init-req 0			( major/minor type 0 )
   else					( buf len error? )
      -rot 2drop			( error )
   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? )
   init-ack? if	
      to ds-minor 0			( 0 )
   else
      drop -1				( error )
   then
;

\ initialize domain-services protocal link
: ds-init  ( -- error? )
   init-ldc-channel ?dup 0= if
      ds-init-handshake dup if
         cmn-note[ 
         " Unable to complete Domain Service protocol version handshake" 
         ]cmn-end
      then
   then
   dup if
      \ If error is LDC reset then leave the state as DS-CLOSE
      dup LDC-NOTUP <> if
         DS-ERROR to domain-service-state
      then
      cmn-warn[ " Unable to connect to Domain Service providers" ]cmn-end
   else
      DS-OPEN to domain-service-state
   then
;

\ 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 )
   begin
      2dup receive-ds-pkt dup			( buf len error? error? )
      LDC-NOTUP = if 				( buf len error? )
	 cmn-warn[ 
	    " Waiting for DS registration response but LDC is Not Up!"
	 ]cmn-end				( buf len error? )
         exit					( buf len LDC-NOTUP )
      then					( buf len error? )
      0=
   while
      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 )
   repeat
   -1						( 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 )
   begin
      2dup receive-ds-pkt dup 			( buf len error? error? )
      LDC-NOTUP = if				( buf len error? )
         cmn-warn[ 
	    " Waiting for DS unregister response but LDC is Not Up!"
         ]cmn-end				( buf len error? )
	 -rot 2drop exit			( LDC-NOTUP )
     then					( buf len error? )
     0=
   while
      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 )
   repeat
   2drop -1					( -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 )
   reg-ack? if
      >payload >regack-minor-vers w@		( type minor )
   else
      >payload >regnack-major-vers w@		( type major )
   then
   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 )
   send-ds-pkt ?dup  if 
      dup LDC-NOTUP = if		( LDC-NOTUP )
	 cmn-warn[ " Sending DS Reg request but LDC is Not Up!" ]cmn-end
      then				( LDC-NOTUP )
      exit				( error )
   then					( error )
   wait-for-reg-resp ?dup if		( buf len error )
      -rot 2drop 			( error )
   else
      parse-reg-req reg-ack? 0		( major/minor ack? 0 )
   then
;

\ 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	( )
   ds-pkt-buffer 			( pkt )
   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' )
   begin
      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 )
         else
            rot 0			( buf svc-handle pkt len 0 )
         then
      else
         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
      then
   then

   domain-service-state case
      DS-OPEN 		of	 0	endof
      DS-CLOSED		of ds-init	endof
      DS-ERROR		of 	-1	endof
   endcase
;

headers

\ 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  
      3drop -1 exit					( -1 )  
   then
   assemble-data-pkt					( pkt len )
   send-ds-pkt						( error? )
;

\ Receive a data packet from the specified channel
: receive-ds-data  ( buf len svc-handle -- len' 0 | error )
   check-domain-service-state if
      3drop -1 exit					( -1 )
   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  
      drop -1 exit  			( -1 )
   then					( svc-handle )
   assemble-unreg-req			( pkt size )
   send-ds-pkt ?dup 0= if		(  )		
      wait-for-unreg-resp		( error? )
   else
      dup LDC-NOTUP = if		( LDC-NOTUP )
         cmn-warn[ " Sending Unreg request but LDC is Not Up!" ]cmn-end
      then				( LDC-NOTUP )
   then					( error? )
;

previous		\ ldc

previous definitions	\ domain-services