projects / OpenSPARC-T2-SAM / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 architecture model.
[OpenSPARC-T2-SAM] / obp / obp / dev / sun4v-devices / ldc / methods.fth
CommitLineData
920dae64
AT		 1\ ========== Copyright Header Begin ==========================================
2\
3\ Hypervisor Software File: methods.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 ============================================
42id: @(#)methods.fth 1.6 07/06/22
43purpose: Implements Logical Domain Communication methods
44copyright: Copyright 2007 Sun Microsystems, Inc. All Rights Reserved
45copyright: Use is subject to license terms.
46
47\ The LDC protocol document can be found at
48\ http://cpubringup.sfbay.sun.com/twiki/pub/LDoms/ArchDesign/vio.txt
49
50headerless
51
52false value debug-ldc?
53false value debug-ldc-pkt?
54
55fload ${BP}/dev/utilities/cif.fth
56defer claim 0 " claim" do-cif is claim
57defer release 0 " release" do-cif is release
58
59fload ${BP}/dev/sun4v-devices/ldc/ldc-struct.fth
60fload ${BP}/arch/sun4v/hv-errcode.fth
61
62pagesize invert 1+ value page#mask
63
64d# 5000 value #hcall-retries \ mod by 5, ~1000 ms (1 sec.)
65
66h# 80 constant fast-trap
67h# 2000 constant mapt-size
68
691 value major-version \ major and minor numbers
700 value minor-version \ used during version negotiation
710 value possible-version \ intermediate storage for version
72
730 value ldc-rx-qva \ RX queue virtual address
740 value ldc-tx-qva \ TX queue virtual address
750 value ldc-rx-qra \ RX queue real address
760 value ldc-tx-qra \ TX queue real address
770 value msgid \ our msgid
780 value rmsgid \ his msgid received
790 value my-ackid \ my ack id
800 value my-chan-id \ channel id
81
820 value receive-buf \ receieve buffer pointer
830 value map-table-va \ map table va exported to HV
840 value map-table-ra \ map table ra exported to HV
850 value mt-cookie-addr \ Internal cookie table
86
870 value env-wrapper
880 value #pkts-to-write \ No of packets to write
89
90\ Current receive queue pointers
910 value rx-headp \ RX queue head pointer
920 value rx-tailp \ RX queue tail pointer
93
94\ Current send queue pointers
950 value tx-headp \ TX queue head pointer
960 value tx-tailp \ TX queue head pointer
97
980 value resources-available? \ Do not aquire resources on every open
99
100\ Default xfer mode is unreliable mode
101ldc-mode-unreliable value ldc-xfer-mode
102
103\ Convert virtual address to real address
104: >ra ( va -- ra )
105 dup >physical drop ( vaddr papage )
106 swap page#mask invert and or ( ra )
107;
108
109\ Code below is needed so FCODE can handle 64 bit addresses
110: xrshift ( x n -- x' )
111 swap xlsplit rot ( lo hi n )
112 dup d# 32 >= if ( lo hi n )
113 rot drop 0 swap d# 32 - ( lo' 0 n' )
114 then ( lo' hi' n' )
115 2dup rshift >r ( lo' hi' n' ) ( r: res.hi )
116 1 over lshift 1- rot and ( lo' n' bits )
117 d# 32 2 pick - lshift -rot rshift or ( res.lo )
118 r> ( res.lo res.hi ) ( r: )
119 lxjoin ( x' )
120;
121
122: x= ( x1 x2 -- =? ) - xlsplit or 0= ;
123
124\ number of interations through wait-1ms? before delay
1255 constant wait-mod
126
127\ Wait 1 ms if i is 5, 10, 15, ... (not if i=0)
128: wait-1ms? ( i -- )
129 ?dup if
130 wait-mod mod 0= if 1 ms then
131 then
132;
133
134\ The "status" values are defined by sun4v APIs. See API specification
135\ for details
136
137\ %o0 - ldc_channel
138\ %o1 - base raddr
139\ %o2 - #entries
140\ #entries = 0 unconfigures the queue
141\ Configure LDC RX Queue
142: hcall-ldc-rx-qconf ( chid addr #ents -- status )
143 3 1 tt-ldc-rx-qconf fast-trap htrap
144;
145
146\ %o0 - ldc_channel
147\ %o1 - base raddr
148\ %o2 - #entries
149\ Configure LDC TX Queue
150: hcall-ldc-tx-qconf ( chid addr #ents -- status )
151 3 1 tt-ldc-tx-qconf fast-trap htrap
152;
153
154\ arg0 channel (%o0)
155\ ret0 status (%o0)
156\ ret1 base raddr (%o1)
157\ ret2 #entries (%o2)
158\ Get LDC RX Queue Info
159: hcall-ldc-rx-qinfo ( chid -- #ents base status )
160 1 3 tt-ldc-rx-qinfo fast-trap htrap
161;
162
163\ arg0 channel (%o0)
164\ ret0 status (%o0)
165\ ret1 base raddr (%o1)
166\ ret2 #entries (%o2)
167\ Get LDC TX Queue Info
168: hcall-ldc-tx-qinfo ( chid -- #ents base status )
169 1 3 tt-ldc-tx-qinfo fast-trap htrap
170;
171
172\ arg0 channel (%o0)
173\ ret0 status (%o0)
174\ ret1 head offset (%o1)
175\ ret2 tail offset (%o2)
176\ ret3 channel state (%o3) UP-1, DOWN-0
177\ Get LDC RX state
178: hcall-ldc-rx-get-state ( chid -- state tail head status )
179 1 4 tt-ldc-rx-get-state fast-trap htrap ( state tail head status )
180;
181
182\ arg0 channel (%o0)
183\ ret0 status (%o0)
184\ ret1 head offset (%o1)
185\ ret2 tail offset (%o2)
186\ ret3 channel state (%o3) UP-1, DOWN-0
187\ Get LDC TX state
188: hcall-ldc-tx-get-state ( chid -- state tail head status )
189 1 4 tt-ldc-tx-get-state fast-trap htrap ( state tail head status )
190;
191
192\ arg0 channel (%o0)
193\ arg1 head offset (%o1)
194\ ret0 status (%o0)
195\ Set LDC RX Queue Head
196: hcall-ldc-rx-set-qhead ( chid head -- status )
197 2 1 tt-ldc-rx-set-qhead fast-trap htrap
198;
199
200\ arg0 channel (%o0)
201\ arg1 tail offset (%o1)
202\ ret0 status (%o0)
203\ Set LDC TX Queue Tail
204: hcall-ldc-tx-set-qtail ( chid tail -- status )
205 2 1 tt-ldc-tx-set-qtail fast-trap htrap
206;
207
208\ %o0 - channel
209\ %o1 - base RA of map_table (-1 disables mapping for given channel)
210\ %o2 - table entries
211\ Binds the identified table with the given LDC
212: hcall-ldc-set-map-table ( chid table-ra ent# -- status )
213 3 1 tt-ldc-set-map-table fast-trap htrap
214;
215
216\ Input:
217\ %o0 = channel
218\ %o1 = flags
219\ %o2 = cookieaddr
220\ %o3 = raddr
221\ %o4 = length
222\ Output:
223\ %o0 = status
224\ %o1 = actual length copied
225\ Copy in/out the data from the given cookie_addr for length
226\ bytes (multiple of 8) to/from the real address given.
227\ For EOK actual length copied is returned.
228: hcall-ldc-copy ( chid direction caddr raddr len -- bytes status )
229 5 2 tt-ldc-copy fast-trap htrap
230;
231
232\ Get LDC RX state, retry if HV-EWOULDBLOCK is returned
233: ldc-rx-get-state ( chid -- state tail head status )
234 >r 0 0 0 0 r> #hcall-retries 0 do ( state tail head status chid )
235 >r 2drop 2drop r@ ( chid ) ( R: chid )
236 hcall-ldc-rx-get-state ( state tail head status )
237 dup HV-EWOULDBLOCK <> if ( state tail head status )
238 r> drop unloop exit ( state tail head status )
239 then ( state tail head status )
240 r> i wait-1ms? ( state tail head status chid )
241 loop drop ( state tail head status )
242;
243
244\ Get LDC TX state, retry if HV-EWOULDBLOCK is returned
245: ldc-tx-get-state ( chid -- state tail head status )
246 >r 0 0 0 0 r> #hcall-retries 0 do ( state tail head status chid )
247 >r 2drop 2drop r@ ( chid ) ( R: chid )
248 hcall-ldc-tx-get-state ( state tail head status )
249 dup HV-EWOULDBLOCK <> if ( state tail head status )
250 r> drop unloop exit ( state tail head status )
251 then ( state tail head status )
252 r> i wait-1ms? ( state tail head status chid )
253 loop drop ( state tail head status )
254;
255
256\ Set LDC RX Queue Head, retry if HV-EWOULDBLOCK is returned
257: ldc-rx-set-qhead ( chid head -- status )
258 0 #hcall-retries 0 do ( chid head status )
259 drop 2dup ( chid head chid head )
260 hcall-ldc-rx-set-qhead ( chid head status )
261 dup HV-EWOULDBLOCK <> if ( chid head status )
262 nip nip unloop exit ( status )
263 then
264 i wait-1ms? ( chid head status )
265 loop ( chid head status )
266 nip nip ( status )
267;
268
269\ Set LDC TX Queue Tail, retry if HV-EWOULDBLOCK is returned
270: ldc-tx-set-qtail ( chid tail -- status )
271 0 #hcall-retries 0 do ( chid tail status )
272 drop 2dup ( chid tail chid tail )
273 hcall-ldc-tx-set-qtail ( chid tail status )
274 dup HV-EWOULDBLOCK <> if ( chid tail status )
275 nip nip unloop exit ( status )
276 then
277 i wait-1ms? ( chid tail status )
278 loop ( chid tail status )
279 nip nip ( status )
280;
281
282
283: dump-hv-qptrs ( tail hd -- tail hd )
284 debug-ldc? if
285 2dup ." head: " u. ." tail: " u. cr
286 then
287;
288
289: dump-hv-qinfo ( -- )
290 debug-ldc? if
291 my-chan-id hcall-ldc-rx-qinfo ." Hypervisor rx qinfo -- status: " .
292 ." base addr: " u. ." ent#: " u. cr
293 my-chan-id hcall-ldc-tx-qinfo ." Hypervisor tx qinfo -- status: " .
294 ." base addr: " u. ." ent#: " u. cr
295 then
296;
297
298: dump-ldc-initinfo ( -- )
299 debug-ldc? if
300 ." Channel ID: " my-chan-id u.
301 ." Rcv-qva: " ldc-rx-qva u.
302 ." Send-qva: " ldc-tx-qva u. cr
303 then
304;
305
306\ Update Hypervisor Queue head we are working on
307: set-ldc-rx-qhead ( headvirtual -- status )
308 ldc-rx-qva - my-chan-id swap ( id head )
309 debug-ldc-pkt? if 2dup ." Set qhead: " ." Head: " u. ." id: " u. cr then
310 ldc-rx-set-qhead ( status )
311;
312
313\ Update TX tail, wrap around if needed
314: update-tx-qtail ( -- )
315 tx-tailp /ldc-msg-pkt + ( tail' )
316 ldc-tx-qva tuck - ldc-queue-size mod ( txq rem )
317 + to tx-tailp ( )
318;
319
320\ Update Hypervisor TX Queue tail
321: set-ldc-tx-qtail ( tailv -- status )
322 ldc-tx-qva - my-chan-id swap ( id tail-off )
323 debug-ldc-pkt? if 2dup ." Set qtail: " ." tail: " u. ." id: " u. cr then
324 ldc-tx-set-qtail ( status )
325;
326
327\ Register with Hypervisor our Queue configuration (id, qsize, qraddr)
328: ldc-init-qconf ( -- error? )
329 my-chan-id ldc-rx-qra ldc-queue-entries ( id rxra #ent )
330 hcall-ldc-rx-qconf ( rx-flag )
331 debug-ldc? if dup ." RX qconf returned: " u. cr then
332
333 my-chan-id ldc-tx-qra ldc-queue-entries ( rx-flag id txra #ent )
334 hcall-ldc-tx-qconf ( rx-flag tx-flag )
335 debug-ldc? if dup ." TX qconf returned: " u. cr then
336 or ( error? )
337
338 \ TX queue head/tail pointer may not be 0 after previous unconfigure
339 >r my-chan-id ldc-tx-get-state ( up? tl hd status ) ( R: error? )
340 r> or nip rot drop swap ( error?' tl )
341 ldc-tx-qva + to tx-tailp
342;
343
344\ Check the requested LDC transfer mode, returns true if reliable mode
345: ldc-reliable-mode? ( -- yes? )
346 ldc-xfer-mode ldc-mode-reliable =
347;
348
349\ Loop till TX head=tail or receives an error
350\ status <> 0 means an error
351: wait-for-txq-drain ( -- status )
352 #hcall-retries 0 do ( )
353 my-chan-id ldc-tx-get-state ( up? tl hd status )
354 dup HV-EOK <> if
355 dup ( up? tl hd status status )
356 cmn-note[
357 " hcall TX get state returns error: %d" ]cmn-end
358 nip nip nip unloop exit ( status )
359 then ( up? tl hd HV-EOK )
360 >r = if ( up? ) ( R: HV-EOK )
361 drop r> unloop exit ( HV-EOK )
362 else ( up? ) ( R: HV-EOK )
363 ldc-up <> if ( R: HV-EOK )
364 \ LDC is not up, no need to waste time looping
365 LDC-NOTUP r> drop unloop exit ( LDC-NOTUP )
366 then
367 r> drop ( )
368 then
369 i wait-1ms? ( )
370 loop
371 true
372;
373
374\ Send Control packets to Hypervisor
375: ldc-send-ctrl-pkt ( -- error? )
376 ldc-xfer-mode tx-tailp >ldc-env c! ( )
377
378 debug-ldc-pkt? if
379 ." Packet to be sent:" cr
380 tx-tailp h# 40 " dump" evaluate cr
381 then
382
383 update-tx-qtail ( )
384
385 tx-tailp set-ldc-tx-qtail ( status )
386 dup HV-EOK <> if ( status )
387 exit
388 else
389 drop ( )
390 then ( )
391
392 wait-for-txq-drain ( status )
393;
394
395\ For reliable mode transfer, set up the ackid field appropriately
396: setup-more-header ( ctrl type -- )
397 tx-tailp tuck >ldc-type c! ( ctrl tail )
398 over ldc-ver = if ( ctrl tail )
399 possible-version over >ldc-version l! ( ctrl tail )
400 else
401 \ msgid are not exchanged until version negotiation is complete
402 msgid over >ldc-msgid l! ( ctrl tail )
403 msgid 1+ to msgid ( ctrl tail )
404 then
405
406 tuck >ldc-ctrl c! ( tail )
407 ldc-info over >ldc-stype c! ( tail )
408
409 ldc-reliable-mode? if ( tail )
410 my-ackid swap >ldc-ackid l! ( )
411 else
412 drop ( )
413 then
414;
415
416: send-ctrl-pkts ( ctrl -- status )
417 ldc-ctrl-type setup-more-header ( )
418 ldc-send-ctrl-pkt
419;
420
421: send-version-packet ( major minor -- status )
422 swap wljoin to possible-version
423 ldc-ver send-ctrl-pkts
424;
425
426: ldc-send-rts-pkt ( -- status )
427 ldc-rts send-ctrl-pkts
428;
429
430: ldc-send-rtr-pkt ( -- status )
431 ldc-rtr send-ctrl-pkts
432;
433
434: ldc-send-rdx-pkt ( -- status )
435 ldc-rdx send-ctrl-pkts
436;
437
438: ldc-send-ack-pkt ( -- status )
439 tx-tailp ( pkt )
440 ldc-data-type over >ldc-type c! ( pkt )
441 msgid over >ldc-msgid l! ( pkt )
442 ldc-ack over >ldc-stype c! ( pkt )
443 my-ackid swap >ldc-ackid l! ( )
444 msgid 1+ to msgid ( )
445 ldc-send-ctrl-pkt ( status )
446;
447
448: ldc-set-data-pkt ( -- )
449 ldc-rts ldc-data-type ( ctrl type )
450 setup-more-header ( )
451;
452
453\ Copy LDC formatted data into TX queue, return actual len of data written
454: cp-to-txq ( addr len -- len' )
455 ldc-set-data-pkt ( addr len )
456 max-ldc-payload min tuck ( len' addr len' )
457 dup env-wrapper or tx-tailp >ldc-env c! ( len' addr len' )
458 tx-tailp ldc-data-off + swap move ( len' )
459 update-tx-qtail ( len' )
460;
461
462: add-to-receive-buf ( addr len multi? -- )
463 if tuck receive-buf w@ ( len addr len len' )
464 dup >r + receive-buf w! r> ( len addr len' )
465 receive-buf + 2+ rot cmove
466 else
467 dup receive-buf tuck ( addr len rbuf len rbuf )
468 w! 2+ swap cmove
469 then
470;
471
472: advance-to-next-pkt ( hdv -- hdv' )
473 /ldc-msg-pkt + ( nhdv )
474 ldc-rx-qva tuck - ldc-queue-size mod ( rxq rem )
475 +
476;
477
478\ Check both head & tail ptrs are less than queue size
479: bad-ptrs? ( p1 p2 -- bad? )
480 ldc-queue-size tuck ( p1 ent p2 ent )
481 <= -rot <= and 0=
482;
483
484\ wait at least "timeout" ms for an incoming packet
485: wait-for-packet ( timeout -- [status false|tail hd true] )
486 debug-ldc-pkt? if ." Start to wait for incoming packets..." cr then
487 wait-mod * 0 do ( )
488 my-chan-id ldc-rx-get-state ( up? tail hd status )
489 dup HV-EOK <> if
490 cmn-warn[ " Can't get RX queue state! " ]cmn-end ( up? tl hd status )
491 nip nip nip false unloop exit ( status false )
492 then
493 >r ( up? tail hd ) ( R: status )
494 \ Check channel state
495 rot ldc-up <> if
496 \ LDC is not up, return with LDC-NOTUP and failure status
497 r> 3drop LDC-NOTUP false unloop exit ( ldc-state false )
498 then
499
500 2dup <> if ( tail hd ) ( R: status )
501 2dup bad-ptrs? if ( tail hd ) ( R: status )
502 cmn-warn[ " Bad queue pointers, Head: Tail: " cmn-append
503 (u.) cmn-append (u.) cmn-append ]cmn-end ( )
504 r> false unloop exit ( EOK false )
505 then
506 debug-ldc-pkt? if ( tail hd ) ( R: status )
507 ." Got packets!" 2dup ." head: " u. ." tail: " u. cr
508 then ( tail hd ) ( R: status )
509 r> drop true unloop exit ( tail hd true )
510 then ( tail hd ) ( R: status )
511 r> 3drop ( )
512 i wait-1ms?
513 loop
514 HV-EOK false
515;
516
517\ Search until a CTRL packet is found or no more pkts in the queue,
518\ drop data packets on the way
519: scan-for-ctrl-pkt ( -- pkt true | false )
520 begin
521 d# 1000 \ 1 second timeout
522 wait-for-packet if ( tail hd )
523 nip ldc-rx-qva + dup ( hdv hdv )
524 advance-to-next-pkt ( hdv hdv' )
525 set-ldc-rx-qhead drop dup ( hdv hdv )
526 >ldc-type c@ ldc-ctrl-type = if ( hdv )
527 true exit ( hdv true )
528 else
529 LDC-NOTUP = if
530 cmn-warn[ " Scaning for contol packet but LDC is not Up!" ]cmn-end
531 then
532 false
533 then
534 else ( status )
535 debug-ldc? if ." Didn't receive any ctrl packets! " cr then
536 drop false exit
537 then ( false )
538 until
539;
540
541\ Check received msgid is not less than or = a packet we've already received
542\ if my-ackid = 0, do not check as the msgid does not HAVE to start at 1
543: ldc-check-msgid ( hdv -- ok? )
544 >ldc-msgid l@ dup ( rmsgid rmsgid )
545 my-ackid <= my-ackid 0<> and if ( rmsgid )
546 cmn-warn[ " Received LDC packet out of sequence (msgid)!" ]cmn-end
547 drop false exit ( false )
548 then
549 to my-ackid true ( true )
550;
551
552\ Is this packet a version ack/nack?
553: version-response? ( pkt -- version-pkt? )
554 dup >ldc-ctrl c@ ldc-ver = if ( pkt )
555 >ldc-stype c@ ldc-nack over = ( stype nack? )
556 swap ldc-ack = or ( ack/nack? )
557 else
558 drop 0
559 then
560;
561
562: parse-version-pkt ( pkt -- major minor nack? )
563 dup >ldc-version l@ lwsplit swap ( pkt major minor )
564 rot >ldc-stype c@ ldc-nack =
565;
566
567: receive-version-packet ( -- [ major minor nack? false ] | true )
568 begin
569 scan-for-ctrl-pkt ( pkt true | 0 )
570 while
571 dup version-response? if ( pkt )
572 parse-version-pkt false exit ( major minor nack? error? )
573 else
574 drop ( )
575 then
576 repeat
577 true
578;
579
580: set-negotiated-version ( major minor -- error? )
581 over major-version > dup if
582 nip nip
583 cmn-warn[ " Negotiated LDC version greater than is supported" ]cmn-end
584 else
585 -rot
586 to minor-version
587 to major-version
588 then
589;
590
591\ Negotiate a common ldc version between the endpoints.
592\ Current code assumes that we support ALL VERSIONS lower than our own
593: version-handshake ( -- error? )
594 major-version minor-version ( major minor )
595 send-version-packet if
596 true exit ( true )
597 then
598 begin
599 receive-version-packet if ( [ major' minor' nack? ] | [ ] )
600 true exit ( true )
601 then ( major' minor' nack? )
602 while ( major' minor' )
603 over 0= if ( major' minor' )
604 2drop true exit ( true )
605 then ( major' minor' )
606 send-version-packet if ( )
607 true exit ( true )
608 then
609 repeat
610 set-negotiated-version ( error? )
611;
612
613\ Send RTS, to receive a RTR pkt
614: ldc-handshake ( -- error? )
615 version-handshake ?dup if exit then
616 ldc-send-rts-pkt 0= if
617 begin
618 scan-for-ctrl-pkt if ( hdv )
619
620 debug-ldc-pkt? if
621 dup /ldc-msg-pkt " dump" evaluate cr
622 then
623
624 dup >ldc-ctrl c@ ldc-rtr = ( hdv RTR? )
625 over >ldc-env c@ ldc-xfer-mode = ( hdv RTR? mode? )
626 and if ( hdv )
627 drop
628 ldc-send-rdx-pkt if
629 cmn-warn[ " RDX sent error!" ]cmn-end
630 true ( true )
631 else
632 false ( false )
633 then
634 exit ( error? )
635 else
636 drop false ( false )
637 then
638 else
639 cmn-warn[ " Didn't receive RTR pkt! " ]cmn-end
640 true exit ( true )
641 then
642 until
643 else
644 cmn-note[ " RTS pkt sent error!" ]cmn-end true ( true )
645 then
646;
647
648\ Always mark the start bit for the first packet
649: mark-start-pkt ( -- )
650 env-wrapper start-pkt-bit or to env-wrapper
651;
652
653: mark-last-pkt ( -- )
654 env-wrapper stop-pkt-bit or to env-wrapper
655;
656
657: clear-env-wrapper ( -- ) 0 to env-wrapper ;
658
659: reset-receive-buf ( -- )
660 0 receive-buf w!
661;
662
663: get-multi-bits ( hdv -- val ) >ldc-env c@ multi-bit-mask and ;
664
665\ Both start & stop bit are set
666: single-data-pkt? ( hdv -- true? ) get-multi-bits multi-bit-mask = ;
667
668\ Only start bit is set
669: start-data-pkt? ( hdv -- true? ) get-multi-bits start-pkt-bit and ;
670
671\ stop bit is set
672: stop-data-pkt? ( hdv -- true? ) get-multi-bits stop-pkt-bit and ;
673
674: ldc-data-pkt? ( hdv -- true? ) >ldc-type c@ ldc-data-type = ;
675
676: ldc-data-ack? ( hdv -- true? )
677 dup ldc-data-pkt? swap >ldc-stype c@ ldc-ack = and
678;
679
680\ only data packets with stype=info should be included in the datagram
681: ldc-data-info? ( hdv -- true? )
682 dup ldc-data-pkt? swap >ldc-stype c@ ldc-info = and
683;
684
685: cp-single-pkt ( hdv multi -- )
686 over ldc-data-off + ( hdv multi adr )
687 rot >ldc-env c@ pkt-size-mask and ( multi adr len )
688 rot add-to-receive-buf
689;
690
691d# 1000 constant data-pkt-delay \ timeout-in-milliseconds
692
693\ Check to see if there is data available in receiving queue
694: data-in-queue? ( -- hdv true|status false )
695 rx-tailp rx-headp tuck ( hdv tailv hdv )
696 <> if
697 dup ( hdv hdv )
698 advance-to-next-pkt to rx-headp
699 true ( hdv true )
700 else ( hdv )
701 set-ldc-rx-qhead ( status )
702 dup HV-EOK <> if ( status )
703 false exit ( status false )
704 else ( status )
705 drop ( )
706 then
707 data-pkt-delay wait-for-packet if ( tail hd )
708 ldc-rx-qva +
709 to rx-headp
710 ldc-rx-qva + to rx-tailp
711 rx-headp dup ( hdv hdv )
712 advance-to-next-pkt to rx-headp
713 true ( hdv true )
714 else
715 debug-ldc? if ." Didn't receive any data packets! " cr then
716 false ( status false )
717 then
718 then
719
720 dup if
721 ldc-reliable-mode? if \ Currently OBP just emits warnings
722 over ldc-check-msgid drop \ upon out-of-sequence packet errors
723 then \ We should probably reset the
724 then \ connection and start over. (TO-DO)
725;
726
727\ Locate a Start pkt, once found, go through Cont pkts, until Stop pkt.
728\ Throw away all received pkts if msgid is out of sequence or Stop pkt
729\ isn't received.
730: cp-multi-pkts ( hdv -- status )
731 \ Scan for a Start data pkt
732 begin
733 dup start-data-pkt? 0= if ( hdv )
734 drop data-in-queue? if ( hdv' )
735 false ( hdv' false )
736 else ( status )
737 exit ( status )
738 then ( hdv )
739 else
740 true
741 then ( hdv true )
742 until ( hdv )
743
744 0 cp-single-pkt ( )
745
746 begin ( )
747 data-in-queue? 0= if ( status )
748 cmn-warn[ " Didn't receive stop pkt! " ]cmn-end
749 reset-receive-buf exit ( status )
750 then ( status )
751
752 rmsgid 1+ to rmsgid ( hdv )
753 dup true cp-single-pkt ( hdv )
754
755 dup stop-data-pkt? if ( hdv )
756 drop rx-headp set-ldc-rx-qhead exit ( status )
757 then
758 drop
759 again
760;
761
762\ Process data pkts, skip ctrl or error type of pkts
763: read-data-pkts ( -- status )
764 reset-receive-buf
765 data-pkt-delay wait-for-packet if ( tail hd )
766 ldc-rx-qva + ( tail hd' )
767 to rx-headp ( tail )
768 ldc-rx-qva + to rx-tailp ( )
769 else
770 debug-ldc? if ." Didn't receive any data packets! " cr then
771 exit ( status )
772 then
773
774 \ Scan for data type of pkts
775 begin
776 data-in-queue? if ( hdv )
777 dup ldc-data-info? if ( hdv )
778 true ( hdv true )
779 else
780 drop false ( false )
781 then ( false )
782 else
783 exit ( status )
784 then ( )
785 until
786
787 dup single-data-pkt? if ( hdv )
788 0 cp-single-pkt ( )
789 rx-headp set-ldc-rx-qhead ( status )
790 else ( hdv )
791 cp-multi-pkts ( status )
792 then
793;
794
795\ Set rx-headp to rx-tailp, throw away any un-read pkts
796: ldc-reset-rcv-queue ( -- )
797 my-chan-id ldc-rx-get-state ( state tail hd status )
798 drop over <> if ( state tail )
799 ldc-rx-qva + set-ldc-rx-qhead ( state status' )
800 then
801 2drop
802;
803
804\ Reset RX queue, Drain TX queue
805\ Exit if queue empty, down or error
806: unregister-queues ( -- )
807 ldc-reset-rcv-queue
808 my-chan-id ldc-rx-qra 0 hcall-ldc-rx-qconf hvcheck if
809 cmn-warn[ " Did not unconfigure LDC RX queue" ]cmn-end
810 then
811
812 #hcall-retries 0 do
813 my-chan-id ldc-tx-get-state ( state tail head status )
814 if 3drop
815 cmn-note[ " Unable to get TX queue state!" ]cmn-end
816 unloop exit ( )
817 then ( state tail head )
818 rot drop ( tail head )
819 = if ( )
820 my-chan-id ldc-tx-qra 0 hcall-ldc-tx-qconf hvcheck if
821 cmn-warn[ " Did not unconfigure LDC TX queue" ]cmn-end
822 then
823 unloop exit ( )
824 then
825
826 \ Print the message every 50 loops
827 debug-ldc? i d# 50 /mod drop 0= and if
828 cmn-note[ " Waiting for TX queue drain..." ]cmn-end
829 then
830 2 ms
831 loop
832;
833
834\ free send & receive memory buffer
835: release-qresources ( -- )
836 unregister-queues
837
838 ldc-queue-size ldc-rx-qva release
839 ldc-queue-size ldc-tx-qva release
840;
841
842\ Check if the RA is already registered in the map-table
843: addr-already-mapped? ( ra -- mapped? )
844 ldcmtbl-ra-shift <<
845 map-table-va x@ mt-ra-mask and x=
846;
847
848\ Add RA into map-table, increment RA with 'pagesize' for the next table entry
849: add-map-table-entries ( ra ent# -- )
850 swap pagesizeshift xrshift swap ( pfn ent# -- )
851 map-table-va over /ldc-mt-ent * erase ( pfn ent# -- )
852 0 do ( pfn )
853 dup ldcmtbl-ra-shift << mt-entry-misc or ( pfn ent )
854 map-table-va i /ldc-mt-ent * + >ldc-mt-ent1 x! ( pfn )
855 pagesize pagesizeshift xrshift + ( pfn' )
856 loop drop
857;
858
859\ Map table is channel specific, allows us to prebuild cookie table
860\ 'num' is the maximum number of cookies we expect to use
861\ each cookie entry is 8-byte in length ( addr + 8 -> next cookie addr' )
862\ Correspondent to each entry in the map-table
863: prebuild-cookie-table ( num -- )
864 mt-cookie-addr swap 0 do ( addr )
865 pagesize8K cookie-pgsz-shift << ( addr cookie' )
866 \ table_idx field
867 i pagesizeshift << or ( addr cookie )
868 over x! 8 + ( addr' )
869 loop drop
870;
871
872headers
873
874: channel-reconfigured? ( -- reconfigured? )
875 my-chan-id hcall-ldc-rx-qinfo drop ( #rxents rxbase )
876 ldc-rx-qra x= ( #rxents rxbase=? )
877 swap ldc-queue-entries = ( rxbase=? #rxents=? )
878 and 0= ( rx-changed? )
879
880 my-chan-id hcall-ldc-tx-qinfo drop ( rx-ch? #txents txbase )
881 ldc-tx-qra x= ( rx-ch? #txents txbase=? )
882 swap ldc-queue-entries = ( rx-ch? txbase= #txents= )
883 and 0= ( rx-changed? tx-changed? )
884 or ( reconfigured? )
885;
886
887\ Default to unreliable mode, change to non-default for reliable mode
888: set-ldc-mode-related ( -- )
889 ldc-reliable-mode? if
890 debug-ldc? if ." LDC is in reliable transfer mode." cr then
891 ['] max-ldc-payload-reli is max-ldc-payload
892 /ldc-data-reli to ldc-data-off
893 then
894;
895
896: ldc-copy-in ( buf cookie size -- len hvstatus )
897 0 0 #hcall-retries 0 do ( buf cookie size len hvstatus )
898 2drop 3dup ( buf cookie size buf cookie size )
899 >r swap >r >r my-chan-id ldc-mcopy-in ( buf cookie size chid direction )
900 ( r: size buf cookie )
901 r> r> >ra r> hcall-ldc-copy ( buf cookie size len hvstatus )
902 dup HV-EWOULDBLOCK <> if ( buf cookie size len hvstatus )
903 >r >r 3drop r> r> unloop exit ( len hvstatus )
904 then ( buf cookie size len hvstatus )
905 i wait-1ms? ( buf cookie size len hvstatus )
906 loop ( buf cookie size len hvstatus )
907 >r >r 3drop r> r> ( len hvstatus )
908;
909
910\ Add Real address lists into the map table
911\ Return the cookie table addr and number of cookies needed
912: ldc-add-map-table-entries ( va size -- cookie-adr cookie# )
913 >r >ra r> pagesize /mod ( ra rem quot )
914 swap if 1+ then ( ra ent# )
915 over addr-already-mapped? if ( ra ent# )
916 nip mt-cookie-addr swap exit ( cookie-addr ent# )
917 then ( ra ent# )
918 tuck add-map-table-entries ( ent# )
919 mt-cookie-addr swap ( cookie-addr ent# )
920 debug-ldc? if
921 map-table-va ." map-table: " dup u. h# 60 " dump" cr evaluate
922 then
923;
924
925: bind-map-table ( -- status )
926 0 #hcall-retries 0 do ( status )
927 drop my-chan-id map-table-ra mapt-size 3 xrshift
928 hcall-ldc-set-map-table ( status )
929 dup HV-EWOULDBLOCK <> if ( status )
930 unloop exit ( status )
931 then
932 i wait-1ms? ( status )
933 loop ( status )
934;
935
936\ Check if there is a data packet available
937: ldc-pkt-available? ( -- pkt? )
938 1 wait-for-packet if ( tail hd )
939 2drop true ( true )
940 else
941 drop false ( false )
942 then ( pkt? )
943;
944
945: allocate-resources ( -- )
946 /x pagesize 0 claim to receive-buf ( )
947 /x mapt-size 0 claim dup to map-table-va ( va )
948 >ra to map-table-ra ( )
949 debug-ldc? if ( )
950 ." map-table addr: " map-table-va u. cr ( )
951 then ( )
952 /x mapt-size 0 claim to mt-cookie-addr ( )
953
954 ldc-queue-size dup 0 claim ( va )
955 dup to ldc-rx-qva ( va )
956 >ra to ldc-rx-qra ( )
957
958 ldc-queue-size dup 0 claim ( va )
959 dup to ldc-tx-qva ( va )
960 >ra to ldc-tx-qra ( )
961
962 true to resources-available? ( )
963;
964
965: scrub-resources ( -- )
966 receive-buf pagesize erase ( )
967 map-table-va mapt-size erase ( )
968 mt-cookie-addr mapt-size erase ( )
969 ldc-rx-qva ldc-queue-size erase ( )
970 ldc-tx-qva ldc-queue-size erase ( )
971;
972
973: ldc-open ( channel-id mode -- ok? )
974 debug-ldc? if
975 ." LDC: open: " cr ( channel-id mode )
976 ." LDC: mode = " dup u. cr ( channel-id mode )
977 ." LDC: channel = " over u. cr ( channel-id mode )
978 then ( channel-id mode )
979
980 to ldc-xfer-mode ( channel-id )
981 to my-chan-id ( )
982
983 0 to msgid ( )
984 0 to my-ackid ( )
985
986 \ Do not reacquire resources on a second open (channel reset)
987 resources-available? if ( )
988 scrub-resources ( )
989 else
990 allocate-resources ( )
991 then ( )
992
993 num-cookies prebuild-cookie-table ( )
994 set-ldc-mode-related ( )
995 ldc-init-qconf ( error? )
996 ldc-handshake or ( error? )
997 bind-map-table or if
998 debug-ldc? if ." LDC: init error! " cr then
999 false ( false )
1000 else
1001 true ( true )
1002 then
1003
1004 dump-hv-qinfo
1005 dump-ldc-initinfo
1006;
1007
1008: ldc-close ( -- )
1009 release-qresources
1010 pagesize receive-buf release
1011 mapt-size map-table-va release
1012 mapt-size mt-cookie-addr release
1013 false to resources-available?
1014 debug-ldc? if ." LDC: closed. " cr then
1015;
1016
1017
1018\ Read data pkts into the receive-buf, data length read is stored in the
1019\ first word of receive-buf
1020: ldc-read ( buf len -- rd status )
1021 read-data-pkts -rot ( status buf len )
1022 receive-buf w@ ?dup if ( status buf len rd )
1023 debug-ldc-pkt? if
1024 dup receive-buf 2+ swap ( status buf len rd addr rd )
1025 cr ." Received packet: " cr " dump" evaluate cr
1026 then ( status buf len rd )
1027 -rot 2 pick ( status rd buf len rd )
1028 min receive-buf 2+ -rot move ( status rd )
1029 else ( status buf len )
1030 2drop 0
1031 then ( status 0 )
1032 swap ( rd status )
1033
1034 \ If this is reliable mode (and we actually recieved a packet)
1035 \ ack the last message read
1036 over 0<> ldc-reliable-mode? and if
1037 ldc-send-ack-pkt drop ( len status )
1038 then
1039;
1040
1041: ldc-write ( addr len -- nbytes status )
1042 dup max-ldc-payload /mod swap ( addr len quot rem )
1043 if 1+ then ( addr len #pkts )
1044 to #pkts-to-write ( addr len )
1045
1046 tuck #pkts-to-write 0 do ( len addr len )
1047 i 0= if mark-start-pkt then ( len addr len )
1048 i #pkts-to-write 1- = if ( len addr len )
1049 mark-last-pkt ( len addr len )
1050 then ( len addr len )
1051 2dup cp-to-txq ( len addr len len' )
1052
1053 tuck - >r + r> ( len addr' len'' )
1054 clear-env-wrapper ( len addr' len'' )
1055 loop
1056
1057 2drop ( len )
1058 tx-tailp set-ldc-tx-qtail ( len status )
1059 dup HV-EOK <> if ( len status )
1060 nip 0 swap exit ( 0 error )
1061 else
1062 drop ( len )
1063 then ( len )
1064 ( len )
1065 wait-for-txq-drain ( len status )
1066;
1067
1068
1069headerless
Full OpenSPARC architecture tarball including simulator, hypervisor, and OBP.