[OpenSPARC-T2-SAM] / obp / obp / pkg / selftest / test.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: test.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: @(#)test.fth 1.11 03/04/04
purpose: test, test-dev, test-all, obdiag definitions 
copyright: Copyright 2000-2003 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\
\ There are no public interfaces in this file.
\
hex
headers

headerless

create has-no-selftest  ( -- p$adr )	\  This location becomes the throw-code
   ,"  device has no selftest method"	\  and will also supply the message

: .testing ( $adr,len -- $adr,len )
   ??cr ." Testing " 2dup type cr
;

[ifnexist] "selftest"
: "selftest" ( -- $adr,len ) " selftest" ;
[then]

0 value tested-device		\ phandle of current device under test.
h# 100  buffer: error-buffer

: abort-selftest-msg ( -- )
   error-buffer count  set-abort-message -2 throw
;

: (save-string) ( str,len -- )  error-buffer $cat  ;

: save-signed ( n -- )
   l->n push-decimal (.) pop-base
   (save-string)
;

: .error-message ( str,len -- )
   ??cr ." Error: " type cr
;

\ This is not exactly the same as execute-device-method because using
\ that routine doesn't permit the catching of a throw from selftest vs
\ a throw from a failed open, resulting in incorrect 'missing selftest'
\ messages.

\  XXX  The  silent?  param is ambiguous and confusing.  See BugId 4788803

: ($call-selftest) ( path$ silent? -- status )
   -rot 					( silent? path$ )
   0 package(  current-device >r         	( silent? path$ )
   ['] open-path catch if			( silent? ??path$ )
      \ failure to open is not a fail.		( silent? path$ )
      3drop 0 0					( status throw? )
   else						( silent? )

      \  XXX  Search for selftest is unnecessary.  See BugId 4788803
      \
      "selftest" my-voc (search-wordlist) 0= if	( silent? )
         drop true has-no-selftest		( status throw-code )
      else					( silent? acf )
         swap 0= if                             ( acf )
            error-buffer count .testing 2drop
         then                                   ( acf )
         catch				      ( ?? throw-code | status throw=0 )
         mark-as-no-boot
      then					( status throw-code? )
      close-chain
      device-end
   then						( status throw-code? )
   r> push-device  )package
   throw					( status )
;

\ We call diag-hook only when selftest returns non-zero
\ error code; in case of erroneous failures of the
\ selftest, like abort, throw or incorrect number
\ of arguments returned by the selftest, diag-hook is
\ not called. In such cases ,however test-dev always
\ returns non-zero status on the stack and prints an 
\ associated message; test stores an associated message
\ in the abort-buffer and the message is printed by OBP;
\ test-all prints an associated messages for every
\ selftest which completes abnormally as well.

: do-diag-hook ( status -- )  tested-device diag-hook  ;

\ a catch on stacked-$call-selftest can only return 0 or -2.
\ -2 for a throw from a selftest, 0 otherwise.

: stacked-$call-selftest ( dev$ not-silent? -- status )
   \ push a few zeroes just in case a bad selftest consumes
   \ the stack (we will throw anyway but this ensures that
   \ the caller's stack remains unharmed)

    >r 2>r  0 0 0 0 0  2r>  r>			( 0 0 0 0 0 $dev not-silent? )
    depth 2- >r 	\  Expected result depth

   \  XXX  Test for no-selftest is unnecessary.  See BugId 4788803
   \
   ['] ($call-selftest) catch ?dup  if		( 0 0 0 0 0 ?? catch? )
      dup has-no-selftest = if			( ?? no-selftest-throw-code )
         count (save-string)	 		( ?? ) 
      else					( ?? catch? )
         "  selftest terminated abnormally"	( ?? catch? str,len )
         (save-string)				( ?? catch? )
         dup -2 = if				( ?? catch? )
            drop " , reason: " (save-string)	( ?? )
            abort-message (save-string)		( ?? )
         else					( ?? catch? ) 
            dup in-dictionary?  if		( ?? catch? )
               " , reason: " (save-string)	( ?? catch? )
               count (save-string) 		( ?? ) 
            else				( ?? catch? )
               " , throw code = " (save-string)	( ?? catch? )
               save-signed 			( ?? )  
            then				( ?? ) 
         then					( ?? )
      then					( ?? )
      abort-selftest-msg			( ?? )
   then						( ?? )
   depth r> - ?dup if				( ?? delta )
      "  selftest resulted in net stack depth change of "
      (save-string)  save-signed			( ?? )
      abort-selftest-msg			( )
   then						( 0 0 0 0 0 status )
   nip nip nip nip nip		        	( status )
;

\ sets or modifies "status" property for the tested device
\ based on results of testing: if selftest passes, and there
\ is no "status" property, declare "status" property and
\ set it to "okay"; if there is already "status" property,
\ do nothing; Note that if the "status" property is set
\ to "fail", subsequent passes will not change "status"
\ to "okay".
\ if selftest fails and there is no "status" property, create
\ "status"="fail"; if "status" property exists but doesn't
\ start with "fail" change "status"="fail".

: "status" ( -- $adr,len ) " status" ;
: "fail"   ( -- $adr,len ) " fail"   ;

: set-fail-property ( -- )  "fail" "status" string-property ;
: set-okay-property ( -- ) " okay" "status" string-property ;

: set-status-property ( status -- )
   my-self current-device 2>r                           ( R: ih ph)
   0 to my-self tested-device to current-device         ( R: ih ph)
   ?dup  if                                             ( R: ih ph)
      do-diag-hook                                      ( R: ih ph)
      "status" tested-device get-package-property  if   ( R: ih ph)
         set-fail-property      \ create status="fail"  ( R: ih ph)
      else                                              ( R: ih ph)
         decode-string drop nip nip "fail" comp  if     ( R: ih ph)
            set-fail-property   \ change status="fail"  ( R: ih ph)
         then                                           ( R: ih ph)
      then                                              ( R: ih ph)
   else                                                 ( R: ih ph)
      "status" tested-device get-package-property  if   ( R: ih ph)
         set-okay-property                              ( R: ih ph)
      else                                              ( R: ih ph)
         2drop                                          ( R: ih ph)
      then                                              ( R: ih ph)
   then                                                 ( R: ih ph)
   2r> push-device to my-self                           ( R: )
;

\ If not-silent? is true then we print the error-message here,
\ if not then we propogate the catch code assuming our caller
\ is catching.

: $call-selftest ( not-silent? dev$ -- status )
   rot >r                                       ( dev$ )      ( R: not-silent? )
   r@ ['] stacked-$call-selftest catch -2 = if  ( ?? )
      r> if                                     ( ?? )        ( R:  )
         3drop abort-message .error-message     ( ?? )
      else                                      ( ?? )
         -2 throw                               ( ?? )      
      then                                      ( ?? )
      true                                      ( fail )
   else                                         ( ?? status ) ( R: not-silent? )
      dup dup set-status-property  if           ( status )
         "  selftest failed, return code = "    ( status $adr,len )
	 (save-string)                          ( status )
         dup save-signed                        ( status )
         r> if                                  ( status )    ( R:  )
            error-buffer count .error-message   ( status ) 
         else                                   ( status )
            abort-selftest-msg                  ( ) 
         then                                   ( status )
      else                                      ( status )    ( R: not-silent? )
         r> drop                                ( status )    ( R:  )
      then                                      ( status )
   then                                         ( status )
;

: (test-dev)  ( not-silent? name,len -- status )
   0 error-buffer c!				( not-silent? dev$ )
   2dup locate-device if			( not-silent? dev$ )
      " Device " (save-string) (save-string)	( not-silent? )
      "  not found" (save-string)		( not-silent? )
      if                                        ( )
         error-buffer count .error-message      ( )
         true exit                              ( status )
      else                                      ( )
         abort-selftest-msg                     ( )
      then                                      ( )
   then						( not-silent? dev$ phandle )
   to tested-device				( not-silent? dev$ )
   2dup (save-string)				( not-silent? dev$ )
   tested-device load-selftest-dropin drop	( not-silent? dev$ )
   $call-selftest				( status )
;

headerless
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: test.fth
	4	\
	5	\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
	6	\
	7	\ - Do no alter or remove copyright notices
	8	\
	9	\ - Redistribution and use of this software in source and binary forms, with
	10	\ or without modification, are permitted provided that the following
	11	\ conditions are met:
	12	\
	13	\ - Redistribution of source code must retain the above copyright notice,
	14	\ this list of conditions and the following disclaimer.
	15	\
	16	\ - Redistribution in binary form must reproduce the above copyright notice,
	17	\ this list of conditions and the following disclaimer in the
	18	\ documentation and/or other materials provided with the distribution.
	19	\
	20	\ Neither the name of Sun Microsystems, Inc. or the names of contributors
	21	\ may be used to endorse or promote products derived from this software
	22	\ without specific prior written permission.
	23	\
	24	\ This software is provided "AS IS," without a warranty of any kind.
	25	\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
	26	\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
	27	\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
	28	\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
	29	\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
	30	\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
	31	\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
	32	\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
	33	\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
	34	\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
	35	\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
	36	\
	37	\ You acknowledge that this software is not designed, licensed or
	38	\ intended for use in the design, construction, operation or maintenance of
	39	\ any nuclear facility.
	40	\
	41	\ ========== Copyright Header End ============================================
	42	id: @(#)test.fth 1.11 03/04/04
	43	purpose: test, test-dev, test-all, obdiag definitions
	44	copyright: Copyright 2000-2003 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	\
	48	\ There are no public interfaces in this file.
	49	\
	50	hex
	51	headers
	52
	53	headerless
	54
	55	create has-no-selftest ( -- p$adr ) \ This location becomes the throw-code
	56	," device has no selftest method" \ and will also supply the message
	57
	58	: .testing ( $adr,len -- $adr,len )
	59	??cr ." Testing " 2dup type cr
	60	;
	61
	62	[ifnexist] "selftest"
	63	: "selftest" ( -- $adr,len ) " selftest" ;
	64	[then]
65
66	0 value tested-device \ phandle of current device under test.
67	h# 100 buffer: error-buffer
68
69	: abort-selftest-msg ( -- )
70	error-buffer count set-abort-message -2 throw
71	;
72
73	: (save-string) ( str,len -- ) error-buffer $cat ;
74
75	: save-signed ( n -- )
76	l->n push-decimal (.) pop-base
77	(save-string)
78	;
79
80	: .error-message ( str,len -- )
81	??cr ." Error: " type cr
82	;
83
84	\ This is not exactly the same as execute-device-method because using
85	\ that routine doesn't permit the catching of a throw from selftest vs
86	\ a throw from a failed open, resulting in incorrect 'missing selftest'
87	\ messages.
88
89	\ XXX The silent? param is ambiguous and confusing. See BugId 4788803
90
91	: ($call-selftest) ( path$ silent? -- status )
92	-rot ( silent? path$ )
93	0 package( current-device >r ( silent? path$ )
94	['] open-path catch if ( silent? ??path$ )
95	\ failure to open is not a fail. ( silent? path$ )
96	3drop 0 0 ( status throw? )
97	else ( silent? )
98
99	\ XXX Search for selftest is unnecessary. See BugId 4788803
100	\
101	"selftest" my-voc (search-wordlist) 0= if ( silent? )
102	drop true has-no-selftest ( status throw-code )
103	else ( silent? acf )
104	swap 0= if ( acf )
105	error-buffer count .testing 2drop
106	then ( acf )
107	catch ( ?? throw-code \| status throw=0 )
108	mark-as-no-boot
109	then ( status throw-code? )
110	close-chain
111	device-end
112	then ( status throw-code? )
113	r> push-device )package
114	throw ( status )
115	;
116
117	\ We call diag-hook only when selftest returns non-zero
118	\ error code; in case of erroneous failures of the
119	\ selftest, like abort, throw or incorrect number
120	\ of arguments returned by the selftest, diag-hook is
121	\ not called. In such cases ,however test-dev always
122	\ returns non-zero status on the stack and prints an
123	\ associated message; test stores an associated message
124	\ in the abort-buffer and the message is printed by OBP;
125	\ test-all prints an associated messages for every
126	\ selftest which completes abnormally as well.
127
128	: do-diag-hook ( status -- ) tested-device diag-hook ;
129
130	\ a catch on stacked-$call-selftest can only return 0 or -2.
131	\ -2 for a throw from a selftest, 0 otherwise.
132
133	: stacked-$call-selftest ( dev$ not-silent? -- status )
134	\ push a few zeroes just in case a bad selftest consumes
135	\ the stack (we will throw anyway but this ensures that
136	\ the caller's stack remains unharmed)
137
138	>r 2>r 0 0 0 0 0 2r> r> ( 0 0 0 0 0 $dev not-silent? )
139	depth 2- >r \ Expected result depth
140
141	\ XXX Test for no-selftest is unnecessary. See BugId 4788803
142	\
143	['] ($call-selftest) catch ?dup if ( 0 0 0 0 0 ?? catch? )
144	dup has-no-selftest = if ( ?? no-selftest-throw-code )
145	count (save-string) ( ?? )
146	else ( ?? catch? )
147	" selftest terminated abnormally" ( ?? catch? str,len )
148	(save-string) ( ?? catch? )
149	dup -2 = if ( ?? catch? )
150	drop " , reason: " (save-string) ( ?? )
151	abort-message (save-string) ( ?? )
152	else ( ?? catch? )
153	dup in-dictionary? if ( ?? catch? )
154	" , reason: " (save-string) ( ?? catch? )
155	count (save-string) ( ?? )
156	else ( ?? catch? )
157	" , throw code = " (save-string) ( ?? catch? )
158	save-signed ( ?? )
159	then ( ?? )
160	then ( ?? )
161	then ( ?? )
162	abort-selftest-msg ( ?? )
163	then ( ?? )
164	depth r> - ?dup if ( ?? delta )
165	" selftest resulted in net stack depth change of "
166	(save-string) save-signed ( ?? )
167	abort-selftest-msg ( )
168	then ( 0 0 0 0 0 status )
169	nip nip nip nip nip ( status )
170	;
171
172	\ sets or modifies "status" property for the tested device
173	\ based on results of testing: if selftest passes, and there
174	\ is no "status" property, declare "status" property and
175	\ set it to "okay"; if there is already "status" property,
176	\ do nothing; Note that if the "status" property is set
177	\ to "fail", subsequent passes will not change "status"
178	\ to "okay".
179	\ if selftest fails and there is no "status" property, create
180	\ "status"="fail"; if "status" property exists but doesn't
181	\ start with "fail" change "status"="fail".
182
183	: "status" ( -- $adr,len ) " status" ;
184	: "fail" ( -- $adr,len ) " fail" ;
185
186	: set-fail-property ( -- ) "fail" "status" string-property ;
187	: set-okay-property ( -- ) " okay" "status" string-property ;
188
189	: set-status-property ( status -- )
190	my-self current-device 2>r ( R: ih ph)
191	0 to my-self tested-device to current-device ( R: ih ph)
192	?dup if ( R: ih ph)
193	do-diag-hook ( R: ih ph)
194	"status" tested-device get-package-property if ( R: ih ph)
195	set-fail-property \ create status="fail" ( R: ih ph)
196	else ( R: ih ph)
197	decode-string drop nip nip "fail" comp if ( R: ih ph)
198	set-fail-property \ change status="fail" ( R: ih ph)
199	then ( R: ih ph)
200	then ( R: ih ph)
201	else ( R: ih ph)
202	"status" tested-device get-package-property if ( R: ih ph)
203	set-okay-property ( R: ih ph)
204	else ( R: ih ph)
205	2drop ( R: ih ph)
206	then ( R: ih ph)
207	then ( R: ih ph)
208	2r> push-device to my-self ( R: )
209	;
210
211	\ If not-silent? is true then we print the error-message here,
212	\ if not then we propogate the catch code assuming our caller
213	\ is catching.
214
215	: $call-selftest ( not-silent? dev$ -- status )
216	rot >r ( dev$ ) ( R: not-silent? )
217	r@ ['] stacked-$call-selftest catch -2 = if ( ?? )
218	r> if ( ?? ) ( R: )
219	3drop abort-message .error-message ( ?? )
220	else ( ?? )
221	-2 throw ( ?? )
222	then ( ?? )
223	true ( fail )
224	else ( ?? status ) ( R: not-silent? )
225	dup dup set-status-property if ( status )
226	" selftest failed, return code = " ( status $adr,len )
227	(save-string) ( status )
228	dup save-signed ( status )
229	r> if ( status ) ( R: )
230	error-buffer count .error-message ( status )
231	else ( status )
232	abort-selftest-msg ( )
233	then ( status )
234	else ( status ) ( R: not-silent? )
235	r> drop ( status ) ( R: )
236	then ( status )
237	then ( status )
238	;
239
240	: (test-dev) ( not-silent? name,len -- status )
241	0 error-buffer c! ( not-silent? dev$ )
242	2dup locate-device if ( not-silent? dev$ )
243	" Device " (save-string) (save-string) ( not-silent? )
244	" not found" (save-string) ( not-silent? )
245	if ( )
246	error-buffer count .error-message ( )
247	true exit ( status )
248	else ( )
249	abort-selftest-msg ( )
250	then ( )
251	then ( not-silent? dev$ phandle )
252	to tested-device ( not-silent? dev$ )
253	2dup (save-string) ( not-silent? dev$ )
254	tested-device load-selftest-dropin drop ( not-silent? dev$ )
255	$call-selftest ( status )
256	;
257
258	headerless