Megatest

Check-in [28c2958fa3]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:minor improvements to debugger
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.61
Files: files | file ages | folders
SHA1: 28c2958fa3df1974b730b2c10d83009433a4a692
User & Date: matt on 2016-05-13 00:06:09
Other Links: branch diff | manifest | tags
Context
2016-05-13
00:22
Decrease notification rate on some messages check-in: ea28efec2e user: matt tags: v1.61
00:06
minor improvements to debugger check-in: 28c2958fa3 user: matt tags: v1.61
2016-05-12
23:09
Added variable watcher debugger thingy (might help until feathers is usable) check-in: 4daccede49 user: matt tags: v1.61
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified debugger.scm from [d03c93cb9e] to [f446c83fb1].

︙
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

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








-
+
+








-
+






-
+








		 (dialog
		  (let ((pause #f)
			(mtrx  (matrix
				#:expand "YES"
				#:numlin 30
				#:numcol 3
				#:numlin-visible 20
				#:numcol-visible 3
				#:numcol-visible 2
				#:alignment1 "ALEFT"
				)))
		    (set! pause (button "Pause" 
					#:action (lambda (obj)
						   (set! *debugger-control* (not *debugger-control*))
						   (attribute-set! pause "BGCOLOR" (if *debugger-control*
										       "200 0 0"
										       "0 0 200")))))
		    (set! *debugger-matrix* mtrx)
		    (attribute-set! mtrx "WIDTH1" "200")
		    (attribute-set! mtrx "WIDTH1" "300")
		    (vbox
		     mtrx
		     (hbox
		      pause)))))
		(main-loop)))))))

(define (debugger-start #!key (start 1))
(define (debugger-start #!key (start 2))
  (set! *debugger-rownum* start))

(define (debugger-trace-var varname varval)
  (let ((oldval (attribute *debugger-matrix* (conc *debugger-rownum* ":1")))
	(newval (conc varval)))
    (if (not (equal? oldval newval))
	(begin
︙
56
57
58
59
60
61
62
63


64
65
66
67
68
69
70
71

57
58
59
60
61
62
63

64
65
66
67
68
69
70
71
72
73








-
+
+









  (attribute-set! *debugger-matrix* "REDRAW" "ALL")
  (let loop ()
    (if *debugger-control*
	(begin
	  (print "PAUSED!")
	  (thread-sleep! 1)
	  (loop))
	(thread-sleep! 0.01))))
	;;(thread-sleep! 0.01)
	)))
		  
;;    ;; lets use the debugger eh?
;;    (debugger-start)
;;    (debugger-trace-var "can-run-more"     can-run-more)
;;    (debugger-trace-var "hed"              hed)
;;    (debugger-trace-var "prereqs-not-met"  (runs:pretty-string prereqs-not-met))
;;    (debugger-pauser)

Modified rmt.scm from [b7f6f86358] to [b3e339430d].

︙
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

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








-
+














-
+








	(if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)
	    (client:setup run-id)
	    #f))))

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected
  ;; clean out old connections
  (mutex-lock! *db-multi-sync-mutex*)
  ;; (mutex-lock! *db-multi-sync-mutex*)
  (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin
    (for-each 
     (lambda (run-id)
       (let ((connection (hash-table-ref/default *runremote* run-id #f)))
         (if (and (vector? connection)
        	  (< (http-transport:server-dat-get-last-access connection) expire-time))
             (begin
               (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses")
               ;; SHOULD CLOSE THE CONNECTION HERE
	       (case *transport-type*
		 ((nmsg)(nn-close (http-transport:server-dat-get-socket 
				   (hash-table-ref *runremote* run-id)))))
               (hash-table-delete! *runremote* run-id)))))
     (hash-table-keys *runremote*)))
  (mutex-unlock! *db-multi-sync-mutex*)
  ;; (mutex-unlock! *db-multi-sync-mutex*)
  ;; (mutex-lock! *send-receive-mutex*)
  (let* ((run-id          (if rid rid 0))
	 (connection-info (rmt:get-connection-info run-id)))
    ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also)
    (if connection-info
	;; use the server if have connection info
	(let* ((dat     (case *transport-type*
︙

Modified runs.scm from [68632cd62e] to [f4173c79cf].

︙
488
489
490
491
492
493
494
495


496
497
498
499
500
501
502

488
489
490
491
492
493
494

495
496
497
498
499
500
501
502
503








-
+
+








		      "\n (member 'toplevel testmode): " (member 'toplevel testmode)
		      "\n (null? non-completed):    " (null? non-completed)
		      "\n reruns:          " reruns
		      "\n items:           " items
		      "\n can-run-more:    " can-run-more)

    ;; lets use the debugger eh?
    (debugger-start)
    (debugger-start start: 2)
    (debugger-trace-var "runs:expand-items" "")
    (debugger-trace-var "can-run-more"     can-run-more)
    (debugger-trace-var "hed"              hed)
    (debugger-trace-var "prereqs-not-met"  (runs:pretty-string prereqs-not-met))
    (debugger-pauser)

    (cond
     ;; all prereqs met, fire off the test
︙
1039
1040
1041
1042
1043
1044
1045
1046

1047


1048
1049

1050
1051
1052
1053
1054
1055
1056

1040
1041
1042
1043
1044
1045
1046

1047
1048
1049
1050
1051

1052
1053
1054
1055
1056
1057
1058
1059








-
+

+
+

-
+








		     "\n  reruns:      " reruns
		     "\n  regfull:     " regfull
		     "\n  reglen:      " reglen
		     "\n  length reg:  " (length reg)
		     "\n  reg:         " reg)

	;; lets use the debugger eh?
	(debugger-start start: 5)
	(debugger-start start: 7)
	(debugger-trace-var "runs:run-tests-queue" "")
	(debugger-trace-var "hed"              hed)
	(debugger-trace-var "tal"              tal)
	(debugger-trace-var "items"            items)
	(debugger-trace-var "hed"              hed)
	(debugger-trace-var "item-path"        item-path)
	(debugger-trace-var "waitons"          waitons) 
	(debugger-pauser)


	;; check for hed in waitons => this would be circular, remove it and issue an
	;; error
	(if (member test-name waitons)
︙

This page was generated in about 0.119s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00