-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathether.fs
1013 lines (808 loc) · 32.1 KB
/
ether.fs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
\ Ethernet driver for TM4C1294 contributed by Bernd Paysan
\ needs basisdefinitions.txt
compiletoflash
\ -------------------------------------------
\ Compatibility layer for ANS standard code
\ -------------------------------------------
: variable> ( x -- ) variable ; \ Initialised Variable
: variable ( -- ) 0 variable ; \ Uninitialised Variable
: 2variable> ( xd -- ) 2variable ; \ Initialised Variable
: 2variable ( -- ) 0. 2variable ; \ Uninitialised Variable
\ -----------------------------------------------------------
\ Multitasking, Catch and Throw
\ -----------------------------------------------------------
\ field
: +field ( offset size "name" -- ) <builds over , + does> @ + ;
: cfield: ( u1 "name" -- u2 ) 1 +field ;
: field: ( u1 "name" -- u2 ) aligned 1 cells +field ;
\ multitasker
0 0 flashvar-here 3 cells - 3 nvariable boot-task \ boot task has no extra stackspace
boot-task boot-task ! \ for compilation into RAM
boot-task variable> up \ user pointer
: next-task ( -- task ) up @ inline ;
: save-task ( -- save ) up @ cell+ inline ;
: handler ( -- handler ) up @ cell+ cell+ inline ;
: (pause) [ $B430 h, ] \ push { r4 r5 } to save I and I'
rp@ sp@ save-task ! \ save return stack and stack pointer
next-task @ up ! eint \ switch to next task
save-task @ sp! rp! \ restore pointers
unloop ; \ pop { r4 r5 } to restore the loop registers
128 cells Constant stackspace \ 128 stack elements for a background task
: task: ( "name" -- ) stackspace cell+ 2* cell+ buffer: ;
: active? ( task -- ? ) \ Checks if a task is currently inside of round-robin list
next-task
begin
( Task-Address )
2dup = if 2drop true exit then
@ dup next-task = \ Stop when end of circular list is reached
until
2drop false
;
: (wake) ( task -- ) \ wake a task
dup active? IF drop exit THEN
next-task @ over ! next-task ! ;
: wake ( task -- ) dint (wake) eint ;
: activate ( task r:continue -- )
r> swap >r 0 r@ cell+ cell+ ! \ no handler
r@ stackspace cell+ cell+ + dup r@ cell+ !
dup stackspace + tuck 2 cells - swap ! !
r> wake ;
: multitask ( -- ) ['] (pause) hook-pause ! ;
: singletask ( -- ) ['] nop hook-pause ! ;
: prev-task ( -- addr )
\ Find the task that has the currently running one in its next field
next-task begin dup @ up @ <> while @ repeat ;
: sleep [ $BF30 h, ] inline ; \ WFI Opcode, Wait For Interrupt, enters sleep mode
task: lowpower-task
: lowpower& ( -- )
lowpower-task activate
begin
dint next-task dup @ = if eint sleep then
\ Is this task the only one remaining in round-robin list ?
pause
again
;
: stop ( -- ) \ Remove current task from round robin list
\ Store the "next" of the current task into the "next" field of the previous task
\ which short-circuits and unlinks the currently running one.
dint next-task @ prev-task !
\ Do final task switch out of the current task
\ which is not linked in anymore in round-robin list.
pause \ pause contains an eint
;
: kill ( task -- ) activate stop ;
\ --------------------------------------------------
\ Multitasking insight
\ --------------------------------------------------
: tasks ( -- ) \ Show tasks currently in round-robin list
hook-pause @ singletask \ Stop multitasking as this list may be changed during printout.
\ Start with current task.
next-task cr
begin
( Task-Address )
dup ." Task Address: " hex.
dup @ ." Next Task: " hex.
dup 1 cells + @ ." Stack: " hex.
dup 2 cells + @ ." Handler: " hex. cr
@ dup next-task = \ Stop when end of circular list is reached
until
drop
hook-pause ! \ Restore old state of multitasking
;
\ --------------------------------------------------
\ Exception handling
\ --------------------------------------------------
: catch ( x1 .. xn xt -- y1 .. yn throwcode / z1 .. zm 0 )
[ $B430 h, ] \ push { r4 r5 } to save I and I'
sp@ >r handler @ >r rp@ handler ! execute
r> handler ! rdrop 0 unloop ;
: throw ( throwcode -- ) dup IF
handler @ 0= IF stop THEN \ unhandled error: stop task
handler @ rp! r> handler ! r> swap >r sp! drop r>
UNLOOP EXIT
ELSE drop THEN ;
' nop variable> flush-hook
: term-flush flush-hook @ execute ;
: quit-loop ( -- ) BEGIN term-flush query interpret ." ok" cr AGAIN ;
: quit-catch ( -- ) BEGIN ['] quit-loop catch
dup IF ." Throw: " . cr ELSE drop THEN AGAIN ;
: sysfault ( -- ) -9 throw ;
: init ( -- )
init multitask
['] quit-catch hook-quit !
['] sysfault irq-fault ! ;
init
quit \ Activate Multitasking and new Catch/Throw mechanism
\ --------------------------------------------------
\ Ethernet drivers
\ --------------------------------------------------
: bounds ( addr len -- end start ) over + swap inline 2-foldable ;
$400EC000 constant Ethernet-Base
$400FE000 constant USB-Base \ for unique device ID
USB-Base $F20 + Constant UNIQUEID0
USB-Base $F24 + Constant UNIQUEID1
USB-Base $F28 + Constant UNIQUEID2
USB-Base $F2C + Constant UNIQUEID3
\ Ethernet MAC (Ethernet Offset)
Ethernet-Base $000 + constant EMACCFG \ RW $0000.8000 Ethernet MAC Configuration
Ethernet-Base $004 + constant EMACFRAMEFLTR \ RW $0000.0000 Ethernet MAC Frame Filter
Ethernet-Base $008 + constant EMACHASHTBLH \ RW $0000.0000 Ethernet MAC Hash Table High
Ethernet-Base $00C + constant EMACHASHTBLL \ RW $0000.0000 Ethernet MAC Hash Table Low
Ethernet-Base $010 + constant EMACMIIADDR \ RW $0000.0000 Ethernet MAC MII Address
Ethernet-Base $014 + constant EMACMIIDATA \ RW $0000.0000 Ethernet MAC MII Data Register
Ethernet-Base $018 + constant EMACFLOWCTL \ RW $0000.0000 Ethernet MAC Flow Control
Ethernet-Base $01C + constant EMACVLANTG \ RW $0000.0000 Ethernet MAC VLAN Tag
Ethernet-Base $024 + constant EMACSTATUS \ RO $0000.0000 Ethernet MAC Status
Ethernet-Base $028 + constant EMACRWUFF \ RW $0000.0000 Ethernet MAC Remote Wake-Up Frame Filter
Ethernet-Base $02C + constant EMACPMTCTLSTAT \ RW $0000.0000 Ethernet MAC PMT Control and Status Register
Ethernet-Base $038 + constant EMACRIS \ RO $0000.0000 Ethernet MAC Raw Interrupt Status
Ethernet-Base $03C + constant EMACIM \ RW $0000.0000 Ethernet MAC Interrupt Mask
Ethernet-Base $040 + constant EMACADDR0H \ RW $8000.FFFF Ethernet MAC Address 0 High
Ethernet-Base $044 + constant EMACADDR0L \ RW $FFFF.FFFF Ethernet MAC Address 0 Low Register
Ethernet-Base $048 + constant EMACADDR1H \ RW $0000.FFFF Ethernet MAC Address 1 High
Ethernet-Base $04C + constant EMACADDR1L \ RW $FFFF.FFFF Ethernet MAC Address 1 Low
Ethernet-Base $050 + constant EMACADDR2H \ RW $0000.FFFF Ethernet MAC Address 2 High
Ethernet-Base $054 + constant EMACADDR2L \ RW $FFFF.FFFF Ethernet MAC Address 2 Low
Ethernet-Base $058 + constant EMACADDR3H \ RW $0000.FFFF Ethernet MAC Address 3 High
Ethernet-Base $05C + constant EMACADDR3L \ RW $FFFF.FFFF Ethernet MAC Address 3 Low
Ethernet-Base $0DC + constant EMACWDOGTO \ RW $0000.0000 Ethernet MAC Watchdog Timeout
Ethernet-Base $100 + constant EMACMMCCTRL \ RW $0000.0000 Ethernet MAC MMC Control
Ethernet-Base $104 + constant EMACMMCRXRIS \ RO $0000.0000 Ethernet MAC MMC Receive Raw Interrupt Status
Ethernet-Base $108 + constant EMACMMCTXRIS \ R $0000.0000 Ethernet MAC MMC Transmit Raw Interrupt Status
Ethernet-Base $10C + constant EMACMMCRXIM \ RW $0000.0000 Ethernet MAC MMC Receive Interrupt Mask
Ethernet-Base $110 + constant EMACMMCTXIM \ RW $0000.0000 Ethernet MAC MMC Transmit Interrupt Mask
Ethernet-Base $118 + constant EMACTXCNTGB \ RO $0000.0000 Ethernet MAC Transmit Frame Count for Good and Bad Frames
Ethernet-Base $14C + constant EMACTXCNTSCOL \ RO $0000.0000 Ethernet MAC Transmit Frame Count for Frames Transmitted after Single Collision
Ethernet-Base $150 + constant EMACTXCNTMCOL \ RO $0000.0000 Ethernet MAC Transmit Frame Count for Frames Transmitted after Multiple Collisions
Ethernet-Base $164 + constant EMACTXOCTCNTG \ RO $0000.0000 Ethernet MAC Transmit Octet Count Good
Ethernet-Base $180 + constant EMACRXCNTGB \ RO $0000.0000 Ethernet MAC Receive Frame Count for Good and Bad Frames
Ethernet-Base $194 + constant EMACRXCNTCRCERR \ RO $0000.0000 Ethernet MAC Receive Frame Count for CRC Error Frames
Ethernet-Base $198 + constant EMACRXCNTALGNERR \ RO $0000.0000 Ethernet MAC Receive Frame Count for Alignment Error Frames
Ethernet-Base $1C4 + constant EMACRXCNTGUNI \ RO $0000.0000 Ethernet MAC Receive Frame Count for Good Unicast Frames
Ethernet-Base $584 + constant EMACVLNINCREP \ RW $0000.0000 Ethernet MAC VLAN Tag Inclusion or Replacement
Ethernet-Base $588 + constant EMACVLANHASH \ RW $0000.0000 Ethernet MAC VLAN Hash Table
Ethernet-Base $700 + constant EMACTIMSTCTRL \ RW $0000.2000 Ethernet MAC Timestamp Control
Ethernet-Base $704 + constant EMACSUBSECINC \ RW $0000.0000 Ethernet MAC Sub-Second Increment
Ethernet-Base $708 + constant EMACTIMSEC \ RO $0000.0000 Ethernet MAC System Time - Seconds
Ethernet-Base $70C + constant EMACTIMNANO \ RO $0000.0000 Ethernet MAC System Time - Nanoseconds
Ethernet-Base $710 + constant EMACTIMSECU \ RW $0000.0000 Ethernet MAC System Time - Seconds Update
Ethernet-Base $714 + constant EMACTIMNANOU \ RW $0000.0000 Ethernet MAC System Time - Nanoseconds Update
Ethernet-Base $718 + constant EMACTIMADD \ RW $0000.0000 Ethernet MAC Timestamp Addend
Ethernet-Base $71C + constant EMACTARGSEC \ RW $0000.0000 Ethernet MAC Target Time Seconds
Ethernet-Base $720 + constant EMACTARGNANO \ RW $0000.0000 Ethernet MAC Target Time Nanoseconds
Ethernet-Base $724 + constant EMACHWORDSEC \ RW $0000.0000 Ethernet MAC System Time-Higher Word Seconds
Ethernet-Base $728 + constant EMACTIMSTAT \ RO $0000.0000 Ethernet MAC Timestamp Status
Ethernet-Base $72C + constant EMACPPSCTRL \ RW $0000.0000 Ethernet MAC PPS Control
Ethernet-Base $760 + constant EMACPPS0INTVL \ RW $0000.0000 Ethernet MAC PPS0 Interval
Ethernet-Base $764 + constant EMACPPS0WIDTH \ RW $0000.0000 Ethernet MAC PPS0 Width
Ethernet-Base $C00 + constant EMACDMABUSMOD \ RW $0002.0101 Ethernet MAC DMA Bus Mode
Ethernet-Base $C04 + constant EMACTXPOLLD \ WO $0000.0000 Ethernet MAC Transmit Poll Demand
Ethernet-Base $C08 + constant EMACRXPOLLD \ WO $0000.0000 Ethernet MAC Receive Poll Demand
Ethernet-Base $C0C + constant EMACRXDLADDR \ RW $0000.0000 Ethernet MAC Receive Descriptor List Address
Ethernet-Base $C10 + constant EMACTXDLADDR \ RW $0000.0000 Ethernet MAC Transmit Descriptor List Address
Ethernet-Base $C14 + constant EMACDMARIS \ RW $0000.0000 Ethernet MAC DMA Interrupt Status
Ethernet-Base $C18 + constant EMACDMAOPMODE \ RW $0000.0000 Ethernet MAC DMA Operation Mode
Ethernet-Base $C1C + constant EMACDMAIM \ RW $0000.0000 Ethernet MAC DMA Interrupt Mask Register
Ethernet-Base $C20 + constant EMACMFBOC \ RO $0000.0000 Ethernet MAC Missed Frame and Buffer Overflow Counter
Ethernet-Base $C24 + constant EMACRXINTWDT \ RW $0000.0000 Ethernet MAC Receive Interrupt Watchdog Timer
Ethernet-Base $C48 + constant EMACHOSTXDESC \ R $0000.0000 Ethernet MAC Current Host Transmit Descriptor
Ethernet-Base $C4C + constant EMACHOSRXDESC \ RO $0000.0000 Ethernet MAC Current Host Receive Descriptor
Ethernet-Base $C50 + constant EMACHOSTXBA \ R $0000.0000 Ethernet MAC Current Host Transmit Buffer Address
Ethernet-Base $C54 + constant EMACHOSRXBA \ R $0000.0000 Ethernet MAC Current Host Receive Buffer Address
Ethernet-Base $FC0 + constant EMACPP \ RO $0000.0103 Ethernet MAC Peripheral Property Register
Ethernet-Base $FC4 + constant EMACPC \ RW $0080.040E Ethernet MAC Peripheral Configuration Register
Ethernet-Base $FC8 + constant EMACCC \ RO $0000.0000 Ethernet MAC Clock Configuration Register
Ethernet-Base $FD0 + constant EPHYRIS \ RO $0000.0000 Ethernet PHY Raw Interrupt Status
Ethernet-Base $FD4 + constant EPHYIM \ RW $0000.0000 Ethernet PHY Interrupt Mask
Ethernet-Base $FD8 + constant EPHYMISC \ RW $0000.0000 Ethernet PHY Masked Interrupt Status and Clear
\ Constants for EMACDMAIM
1 16 lshift constant NIE
1 6 lshift constant RIE
\ Dies geht natürlich nur, während ins RAM kompiliert wird. Später Pufferinitialisationen für Flash entwickeln.
1 31 lshift constant own
1524 Constant ether-size \ aligned to 4
ether-size buffer: RX-Puffer-0
ether-size buffer: RX-Puffer-1
ether-size buffer: RX-Puffer-2
ether-size buffer: RX-Puffer-3
ether-size buffer: RX-Puffer-4
ether-size buffer: RX-Puffer-5
ether-size buffer: RX-Puffer-6
ether-size buffer: RX-Puffer-7
ether-size buffer: TX-Puffer
ether-size buffer: TX-Puffer-2
1 15 lshift constant RER
8 4 * Constant desc-size
8 Constant descs# \ reserve 8 descriptors
8 Constant txdescs# \ reserve 2 descriptors
desc-size descs# * 1- Constant descs-mask
desc-size txdescs# * 1- Constant txdescs-mask
1 30 lshift constant IC
1 29 lshift constant LS \ Last Segment of Frame
1 28 lshift constant FS \ First Segment of Frame
1 25 lshift constant TTSE \ time stamp enable
3 22 lshift constant CIC:cs \ IP header checksum insertion
1 21 lshift constant TER \ Transmit End of Ring
1 17 lshift constant TTSS \ time stamp status
LS FS or TTSE or CIC:cs or TTSS or Constant TDES0
TDES0 own or Constant TDES0:own
2 29 lshift constant SAIC:RS \ replace source
Variable rx-head \ descriptor to add new buffers
Variable rx-tail \ descriptor to receive buffers
Variable tx-head \ descriptor to send new buffers
desc-size descs# * buffer: RX-Descriptors
desc-size txdescs# * buffer: TX-Descriptors
: RX-Descriptor RX-Descriptors rx-head @ + ;
: RX-Descriptor' RX-Descriptors rx-tail @ + ;
: TX-Descriptor TX-Descriptors tx-head @ + ;
: TX-Descriptor' TX-Descriptors tx-head @ desc-size - txdescs-mask and + ;
\ ip header offsets
0
6 +field eth-dest
6 +field eth-src
2 +field eth-type
dup Constant ether-header#
1 +field ip-version
1 +field ip-tos
2 +field ip-len
2 +field ip-id
2 +field ip-frag
1 +field ip-ttl
1 +field ip-protocol
2 +field ip-hdrcs
4 +field ip-src
4 +field ip-dest
dup Constant ip-header#
2 +field udp-src
2 +field udp-dest
2 +field udp-len
2 +field udp-cs
Constant udp-header#
ip-header#
1 +field icmp-type
1 +field icmp-code
2 +field icmp-cs
Constant icmp-header#
\ dump a packet
: byte. ( u -- )
base @ hex swap
0 <# # # #> type
base !
;
: word. ( u -- )
base @ hex swap
0 <# # # # # #> type
base !
;
: mac. ( addr -- )
dup c@ byte. ." :"
dup 1 + c@ byte. ." :"
dup 2 + c@ byte. ." :"
dup 3 + c@ byte. ." :"
dup 4 + c@ byte. ." :"
5 + c@ byte. space
;
: packetdump ( addr len )
0 ?do ( addr )
i $7 and 0= if space then \ Alle 8 Zeichen ein zusätzliches Leerzeichen
i $F and 0= if cr then \ Alle 16 Zeichen einen Zeilenumbruch
dup i + c@ byte. space
loop
drop
cr
;
: .packet ( addr len -- )
singletask
dup ." Länge " u.
over eth-dest ." Ziel-MAC " mac.
over eth-src ." Quell-MAC " mac.
." Ethertype " over eth-type dup c@ byte. 1+ c@ byte. cr
( length addr )
packetdump
multitask
;
1 5 lshift constant UNF \ Transmit Underflow
1 2 lshift constant TU \ Transmit Unavailabl
create mymac
$00 c,
$1A c,
$B6 c,
uniqueid0 @ dup c,
8 rshift c,
uniqueid3 3 + c@ c,
$00 c,
$80 c, \ use unique ID
mymac 5 + c@ 24 lshift 10 +
Variable> myip \ in network byte order
3 cells buffer: routing \ router addr, subnet mask, broadcast address
: tc, ( addr char -- addr' ) over c! 1+ ;
: tw, ( addr word -- addr' ) >r r@ 8 rshift tc, r> tc, ;
: tl, ( addr word -- addr' ) >r r@ $10 rshift tw, r> tw, ;
: t$, ( addr addr1 u1 -- addr' ) rot 2dup + >r swap move r> ;
: tz, ( addr u -- addr' ) 2dup 0 fill + ;
: ffmac, ( addr -- addr' ) 6 0 DO $FF tc, LOOP ;
: tx-buffer+ ( addr u -- )
\ send this block
SAIC:RS or TX-Descriptor cell+ 2! \ TDES1+2: Puffergröße+Addr und ein paar Flags
TDES0:own
tx-head @ desc-size + txdescs-mask u>= TER and or
TX-Descriptor ! \ TDES0: Zum Abschicken an den DMA übergeben
unf tu or emacdmaris ! \ Transmit Buffer Underflow löschen
-1 EMACTXPOLLD ! \ polltx to tell TX logic to go on
tx-head @ desc-size + txdescs-mask and tx-head !
; \ Sendelogik anstuppsen
: tx-buffer+2 ( addrhdr uhdr addrdata udata -- )
\ send these two blocks, one is a prefabbed header, the other dynamic data
16 lshift rot or swap TX-Descriptor 3 cells + ! \ TDES3: Addr2
tx-buffer+ ;
: rx-buffer+ ( addr u -- )
ether-size min \ no more than 1522 bytes
own RX-Descriptor !
rx-head @ desc-size + descs-mask u>= RER and or
RX-Descriptor cell+ 2!
rx-head @ desc-size + descs-mask and rx-head !
-1 EMACRXPOLLD ! ;
: .send ( -- ) singletask
." Losschicken: " cr
." EMACDMARIS: " emacdmaris @ hex. cr
TX-Descriptor' cell+ 2@ $3FFF and .packet
;
task: ethernet-task
: ethernet-handler ( -- )
-1 EMACDMARIS ! ;
: rx-tail+ ( -- ) rx-tail @ desc-size + descs-mask and rx-tail ! ;
: desc@ ( desc -- addr u )
>r r@ 8 + @ r> @ 16 rshift $3FFF and ;
: dump-rx ( desc -- ) desc@ .packet cr ;
: rx-ipv6 ( desc -- )
." IPv6 packet received" cr dump-rx ;
\ arp protocol: reply to requests (no caching and doing our own requests)
10 constant /arp
16 constant arp-cache#
/arp arp-cache# * buffer: arp-cache
Variable arp#
: arp-cache+ ( addr u -- )
arp-cache arp# @ + swap move
/arp arp# @ + dup /arp arp-cache# * u< and arp# ! ;
: ip>mac ( ip-addr -- macaddr/0 ) \ look up MAC for IP in ARP cache
arp-cache /arp arp-cache# * bounds DO
dup i 6 + @ = IF drop I UNLOOP EXIT THEN
/arp +LOOP drop 0 ;
: >reply ( addr u -- addr u )
over dup 6 + swap 6 move ;
: rx-arp ( desc -- ) desc@ over ether-header# + >r
r@ 2@ $01000406 $00080100 d= \ is it an arp request?
IF myip @ r@ 24 + @ = \ is it actually for our IP?
IF \ arp request for us: do in-place reply
>reply r> 7 + 2 tc, \ set reply flag
dup dup 10 + 10 move \ move request tuple to reply tuple
mymac 6 t$, myip 4 t$, \ set my mac
2drop 42 tx-buffer+ EXIT \ reply it
THEN
rdrop 2drop EXIT \ not my IP
THEN
r@ 2@ $02000406 $00080100 d= \ is it an arp reply?
IF
2drop r> 8 + 10 arp-cache+ EXIT
THEN
." ARP unknown packet received " r@ 2@ hex. hex. cr
rdrop .packet cr ;
: fill-arp1 ( -- ) \ generic ARP request
TX-Puffer
\ Ziel-MAC-Adresse, Broadcast
ffmac,
\ Quell-MAC-Adresse, wird ersetzt
ffmac,
\ Ethertype: ARP
$0806 tw,
\ Rest im Puffer: ARP-Request, damit wir auch eine Antwort kriegen
1 tw, $800 tw, $06040001 tl,
\ my mac my ip my mac my ip
mymac 6 t$, myip 4 t$, ;
: grat-arp ( -- ) \ Send Packet
\ fill buffer with gratious arp information
fill-arp1 mymac 6 t$, myip 4 t$, drop
TX-Puffer 42 tx-buffer+ ;
: req-arp ( ip-addr -- ) >r
fill-arp1 ffmac, r> tl, drop
TX-Puffer 42 tx-buffer+ ;
\ IP header debugging
: be-w@ ( addr -- w ) count >r c@ r> 8 lshift or ;
: be-w! ( w addr -- ) over 8 rshift over c! 1+ c! ;
: be-l@ ( addr -- l ) count >r count >r count >r c@
r> 8 lshift or r> 16 lshift or r> 24 lshift or ;
: be-l! ( l addr -- ) \ store l in network byte order
over 16 rshift over be-w! 2 + be-w! ;
: w>< ( x' -- x' ) \ swap two bytes be/le
dup 8 lshift swap 8 rshift $FF and or $FFFF and ;
: l>< ( x -- x' ) \ swap four bytes be/le
dup 16 rshift w>< swap w>< 16 lshift or ;
: .iphdr ( addr len -- addr len ) singletask
." IP packet received" cr
." Ethernet length: " dup >r . cr
." IP length: " dup ip-len be-w@ . cr
." IP type: " dup ip-protocol c@ . cr
r> ;
: .ippacket ( addr len -- ) .iphdr .packet cr ;
\ systick
-1 variable> last-tick
\ IP routing
: ip>lan ( ip -- ip' ) \ if routable, replace by default GW
dup routing 2@ over and >r and r> <> IF
drop routing @
THEN ;
Create ip-hdr-template
$FF c, $FF c, $FF c, $FF c, $FF c, $FF c, \ will be replaced with my mac
$08 c, $00 c, \ protocol: IP
$45 c, $00 c, $00 c, $00 c, \ ip-version, ip-tos, ip-len
$00 c, $00 c, $40 c, $00 c, \ ip-id, ip-frag
$40 c, $00 c, $00 c, $00 c, \ ip-ttl, ip-protocol, ip-checksum
$8000 variable> udp-myport# \ user-specified ports...
: ip-socket ( ip addr -- ) >r
ip-hdr-template r@ 6 + 20 move \ default flags
myip @ r@ ip-src !
l>< dup r@ ip-dest ! ip>lan
3 >r \ four tries before giving up
BEGIN dup ip>mac dup 0= WHILE drop
dup l>< req-arp EMACTIMSEC @ rx-tail @
BEGIN pause 2dup EMACTIMSEC @ rx-tail @ d<> UNTIL 2drop
r> 1- dup >r 0< IF -37 throw THEN
REPEAT rdrop
r> 6 move drop ;
: udp-socket ( ip port addr -- source-port ) >r
swap \ ip is in host byte order
r@ ip-socket
17 r@ ip-protocol c! \ set protocol to UDP
0 r@ udp-len !
r@ udp-dest be-w! \ dest port
udp-myport# @ dup r> udp-src be-w! \ generate new source port
1 udp-myport# +! ;
\ icmp
: ip-reply ( addr destaddr -- addr destaddr' )
over eth-src over eth-dest 6 move eth-src ffmac,
$800 tw, over ip-version 10 t$, 0 tw, \ checksum 0
myip 4 t$, over ip-src 4 t$, ;
\ : >carries ( n -- n' )
\ dup 16 rshift swap $FFFF and + ;
\ : ip-cs ( addr u -- cs )
\ 0 -rot bounds ?DO I be-w@ + 2 +LOOP >carries >carries
\ $FFFF xor ;
: icmp-rx ( addr len -- )
over icmp-type c@ 8 = IF
icmp-header# - 4 - >r TX-Puffer ip-reply
0 tl, \ type 0, code 0, cs not set
over icmp-header# + over r@ move \ copy rest
2drop \ the engine calculates the header for us
\ dup 4 - r@ 4 + ip-cs swap 2 - over hex. dup hex. cr be-w!
TX-Puffer r> icmp-header# + tx-buffer+
ELSE
singletask
." ICMP received" cr
.ippacket
THEN ;
\ udp
udp-header# aligned buffer: term-hdr
udp-header# aligned buffer: data-hdr
: udp-reply ( addr destaddr -- addr destaddr' )
ip-reply
over udp-dest be-w@ tw, \ swap dest/src
over udp-src be-w@ tw,
0 tl, ; \ length+CS stub
: sendv ( addr u hdr -- ) >r
dup 8 + r@ udp-len be-w!
dup 28 + r@ ip-len be-w!
r> udp-header# 2swap tx-buffer+2 ;
: udp-data ( addr u -- ) \ just setup the reply buffer
drop data-hdr udp-reply 2drop ;
\ inject strings into terminal
: /string ( addr1 u1 n -- addr2 u2 )
tuck - >r + r> ;
1472 Constant udp-max# \ 1518 maximum for non-VLAN packets
udp-max# buffer: inject-buffer
udp-max# buffer: emit-buffer
2Variable inject-keys
Variable emit-chars
: term-type ( addr u -- ) \ unbuffered type
term-hdr @ IF term-hdr sendv ELSE 2drop THEN ;
: (term-flush) ( -- )
emit-chars @ IF emit-buffer emit-chars @ term-type 0 emit-chars ! THEN ;
true variable> serial?
true variable> flush-key?
: udp-key? ( -- flag ) serial-key? inject-keys @ 0<> or ;
: udp-key ( -- key )
flush-key? @ IF term-flush THEN
BEGIN
serial-key? IF serial-key EXIT THEN
inject-keys 2@ dup IF
over c@ >r 1 /string inject-keys 2!
r> dup 3 = IF drop true flush-key? !
ELSE EXIT THEN
ELSE 2drop THEN
AGAIN ;
: udp-emit ( char -- ) serial? @ IF dup serial-emit THEN
emit-buffer emit-chars @ + c!
1 emit-chars +! emit-chars @ udp-max# u>= IF term-flush THEN ;
: >udp-data ( addr u hdr -- addr' u' )
>r over r> udp-reply 2drop
udp-header# - >r
dup udp-len be-w@ 8 - r> umin >r \ careful: smaller limit wins!
udp-header# + r> ;
: udp-term ( addr u -- ) term-hdr >udp-data
>r inject-buffer r@ move
inject-buffer r> inject-keys 2! ;
: udp-io ( -- )
['] udp-emit hook-emit !
['] udp-key? hook-key? !
['] udp-key hook-key !
['] (term-flush) flush-hook ! ;
: include ( "name" -- ) false flush-key? !
2 emit term-flush 1000 0 DO LOOP \ wait a bit
token type term-flush ;
: .udphdr ( addr len -- )
." UDP src: " over udp-src be-w@ . cr
." UDP dest: " over udp-dest be-w@ . cr ;
: .udppacket ( addr len -- ) .iphdr .udphdr .packet cr ;
\ DHCP, UDP port 58 (only discover+request)
: chars, ( addr u -- ) bounds ?do I c@ c, LOOP ;
$63825363 Constant dhcp-magic \ DHCP magic
mymac 2@ xor Variable> dhcp-xid
Create dhcp-head
$45 c, $10 c, $00 c, $00 c,
$00 c, $00 c, $40 c, $00 c,
$40 c, $11 c,
Create dhcp-discover
53 c, 1 c, 1 c, \ message type: discover
\ 61 c, 7 c, mymac 6 chars, 0 c, \ again: my mac
\ 60 c, 13 c, char " parse net2o-ec 1.0" chars, 0 c, \ vendor id
\ 12 c, 9 c, char " parse net2o-ec" chars, 0 c, \ host id
55 c, 6 c, 58 c, 59 c, 1 c, 28 c, 33 c, 3 c, \ parameter request list
$FF c,
here dhcp-discover - Constant dhcp-discover#
: new-dhcp ( -- )
1 dhcp-xid +! ; \ new "random" ID number
: dhcp-part-1 ( start -- addr u )
ffmac, ffmac, \ broadcast, my mac wird ersetzt
$0800 tw, \ IPv4
dhcp-head 10 t$, 0 tw, \ constant part of header
0 tl, -1 tl, \ my ip: 0.0.0.0, dest: 255.255.255.255
68 tw, 67 tw, 0 tw, 0 tw, \ DHCP ports + len + checksum
$01010600 tl, dhcp-xid @ tl,
20 tz, \ 20 bytes all zero are ok
mymac over 6 move 6 + 10 tz, \ 16 bytes for mac
192 tz, \ no server host name, no boot file
dhcp-magic tl, ;
: dhcp-discover ( -- ) \ generate a dhcp discover
TX-Puffer dhcp-part-1
dhcp-discover dhcp-discover# t$,
TX-Puffer udp-header# + tuck - TX-Puffer sendv ;
Variable dhcp-server-ip
: dhcp-request ( ip -- ) >r \ generate a dhcp request
TX-Puffer dhcp-part-1
dhcp-server-ip @ TX-Puffer $3E + !
r@ l>< TX-Puffer $3A + !
53 tc, 1 tc, 3 tc, \ message type: request
50 tc, 4 tc, r> tl,
51 tc, 4 tc, 24 60 60 * * tl, \ request for a day
54 tc, 4 tc, dhcp-server-ip be-l@ tl,
$FF tc,
TX-Puffer udp-header# + tuck - TX-Puffer sendv ;
Variable lease-time
10 Variable> lease-threshold
Variable dhcp-type
: next-dhcp ( addr u -- addr' u' )
over 1+ c@ 2 + /string ;
: dhcp-options ( addr u -- ) -1 dhcp-type !
BEGIN
case over c@
51 of over 2 + be-l@ dup lease-time !
3 rshift lease-threshold ! endof
53 of over 2 + c@ dhcp-type ! endof
54 of over 2 + @ dhcp-server-ip ! endof
3 of over 2 + @ routing ! endof
1 of over 2 + @ routing cell+ ! endof
28 of over 2 + @ routing cell+ cell+ ! endof
$FF of 2drop EXIT endof
endcase
next-dhcp
dup 1- 0< UNTIL 2drop ;
: dhcp-offer ( addr u -- ) \ receive the offer
udp-header# /string
dup $F0 u<= IF
." DHCP too short" cr 2drop EXIT THEN
over c@ 2 <> IF 2drop EXIT THEN \ not an offer
\ over $EC + be-l@ dhcp-magic <>
\ IF ." Wrong magic" cr 2drop EXIT THEN \ not dhcp
\ over cell+ be-l@ dhcp-xid @ <> IF
\ ." not our request: " over cell+ be-l@ u. cr
\ .packet EXIT THEN \ not our request
over $10 + be-l@ >r
$F0 /string dhcp-options
case dhcp-type @
2 of r@ dhcp-request endof
5 of r@ l>< myip ! new-dhcp
routing be-l@ req-arp endof \ ack
6 of 0 lease-time ! new-dhcp endof \ nack
endcase rdrop ;
: dhcp-tick ( -- )
last-tick @ EMACTIMSEC @ dup last-tick ! -
lease-time +!
lease-time @ 0< IF dhcp-discover EXIT THEN
lease-time @ lease-threshold @ < IF
myip be-l@ dhcp-request
THEN ;
\ UDP dispatcher
' .udppacket 0
' .udppacket 0
' .udppacket 0
' .udppacket 0
' .udppacket 0
10 nvariable free-udpports
' dhcp-offer 68
' udp-data 4202
' udp-term 4201
6 nvariable udpports
\ udp port dispatcher
: udp-rx ( addr u -- )
over udp-dest be-w@
\ ." udp packet port: " dup . cr
udpports 16 cells bounds do
dup i @ = if
drop i cell+ @ execute unloop exit
then
2 cells +loop drop 2drop ;
\ ip handler
' .ippacket 0
' .ippacket 0
' .ippacket 0
' .ippacket 0
' .ippacket 0
' .ippacket 0
12 nvariable free-iptypes
' udp-rx 17
' icmp-rx 1
4 nvariable iptypes
: rx-ip ( desc -- ) desc@ over ip-protocol c@
\ ." ip packet type: " dup . cr
iptypes 16 cells bounds do
dup i @ = if
drop i cell+ @ execute unloop exit
then
2 cells +loop drop .ippacket ;
\ ethernet handler
' dump-rx 0
' dump-rx 0
' dump-rx 0
' dump-rx 0
' dump-rx 0
10 nvariable free-ethertypes
' rx-arp $0806
' rx-ipv6 $86DD
' rx-ip $0800
6 nvariable ethertypes
: rx-ethertype ( descriptor ethertype -- )
ethertypes 16 cells bounds do
dup i @ = if
drop i cell+ @ execute unloop exit
then
2 cells +loop drop dump-rx ;
: handle-rx ( descriptor -- )
dup 8 + @ eth-type be-w@ rx-ethertype ;
: sys-tick? ( -- )
EMACTIMSEC @ last-tick @ <> IF
dhcp-tick
THEN ;
: ether-loop ( -- )
BEGIN
BEGIN pause sys-tick? RX-Descriptor' @ own and 0= UNTIL
RX-Descriptor' dup >r handle-rx
r> 8 + @ ether-size rx-buffer+
rx-tail+
AGAIN ;
: ethernet& ( -- )
ethernet-task activate
BEGIN ['] ether-loop catch drop AGAIN
;
$400FE000 constant Sysctl-Base
Sysctl-Base $630 + constant RCGCEPHY
Sysctl-Base $69C + constant RCGCEMAC
Sysctl-Base $0B0 + constant RSCLKCFG
Sysctl-Base $07C + constant MOSCCTL
Sysctl-Base $930 + constant PCEPHY
Sysctl-Base $99C + constant PCEMAC
\ Constants for EMACDMABUSMOD
1 7 lshift constant ATDS
\ Constants for EMACCFG
1 14 lshift constant FES
1 11 lshift constant DUPM
1 3 lshift constant TE
1 2 lshift constant RE
\ Constants for MOSCCTL
1 4 lshift constant OSCRNG
PORTF_BASE $420 + constant PORTF_AFSEL ( Alternate Function Select )
PORTF_BASE $52C + constant PORTF_PCTL ( Pin Control )
: clocks-enable ( -- )
\ Enable MOSC and use this as system clock:
OSCRNG MOSCCTL ! \ High range for MOSC
\ while we wait for the clock to stabilize...
50 0 do loop
3 20 lshift RSCLKCFG ! \ MOSC as oscillator
\ Enable clock for Ethernet:
1 RCGCEMAC ! 1 RCGCEPHY ! ;
: descs-setup ( -- ) 0 term-hdr !
RX-Descriptors desc-size descs# * 0 fill
TX-Descriptors desc-size txdescs# * 0 fill
arp-cache /arp arp-cache# * 0 fill
\ allow eight frames to be received
rx-puffer-7 rx-puffer-0 do
i ether-size rx-buffer+
ether-size negate +loop ;
: enable-emac ( -- )
1 PCEMAC ! \ Enable EMAC
1 PCEPHY ! \ Enable EPHY
;
: reset-emac ( -- )
\ Write to the Ethernet MAC DMA Bus Mode (EMACDMABUSMOD) register to set Host bus parameters.
." Reset Ethernet" cr
1 EMACDMABUSMOD ! \ Reset MAC
begin EMACDMABUSMOD @ 1 and not until \ Wait for Reset to complete
." Reset complete" cr
EMACDMABUSMOD @ ATDS or EMACDMABUSMOD ! ;
: emac-leds ( -- )
\ Set Ethernet LEDs on Port F:
$11 PORTF_AFSEL !
$50005 PORTF_PCTL ! ;
: emac-irqs ( -- )
56 nvic-enable \ Enable ethernet vector in NVIC
['] ethernet-handler irq-ethernet !
\ Write to the Ethernet MAC DMA Interrupt Mask Register (EMACDMAIM) register to mask unnecessary interrupt causes.
RIE NIE or EMACDMAIM ! \ Interrupts: Receive and normal interrupt summary
;
: emac-init ( -- )
mymac cell+ @ EMACADDR0H !
mymac @ EMACADDR0L !
\ Create the transmit and receive descriptor lists and then write to the Ethernet MAC Receive
\ Descriptor List Address (EMACRXDLADDR) register and the Ethernet MAC Transmit
\ Descriptor List Address (EMACTXDLADDR) register providing the DMA with the starting
\ address of each list.
RX-Descriptors EMACRXDLADDR !
TX-Descriptors EMACTXDLADDR !
\ Write to the Ethernet MAC Frame Filter (EMACFRAMEFLTR) register, the Ethernet MAC
\ Hash Table High (EMACHASHTBLH) and the Ethernet MAC Hash Table Low
\ (EMACHASHTBLL) for desired filtering options.
0 EMACFRAMEFLTR ! \ no filtering, normal mode
\ Write to the Ethernet MAC Configuration Register (EMACCFG) to configure the operating
\ mode and enable the transmit operation.
3 28 lshift \ saddr=replace with addr0
FES or \ 100 Mbps
DUPM or \ Full Duplex
TE or \ Transmitter Enable
RE or \ Receiver Enable
EMACCFG !
\ Program Bit 15 (PS) and Bit 11 (DM) of the EMACCFG register based on the line status received
\ or read from the PHY status register after auto-negotiation.
\ Hardwired to Full-Duplex, store&forward, 100 Mbps here.
1 21 lshift 1 13 lshift or 2 or EMACDMAOPMODE ! ;
: emactime-init ( -- )
1 18 lshift EMACCC !
40 EMACSUBSECINC !
$305 EMACTIMSTCTRL !
;
: init ( -- )
init
clocks-enable
descs-setup enable-emac
reset-emac emac-leds emac-irqs emac-init
\ start background task
ethernet& udp-io emactime-init
." Mecrisp-Stellaris ethernet terminal ready" cr
;