← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to misc/test-sgc.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
misc/test-sgc.lsp
 
1
(in-package 'si)
 
2
(or (fboundp 'get-usage) (load "/public/gcl/misc/rusage"))
 
3
(gbc-time 0)
 
4
(defun cv (x) (/ x (float INTERNAL-TIME-UNITS-PER-SECOND)))
 
5
(defvar *all-times* nil)
 
6
(defmacro with-timing (&rest forms)
 
7
  `(let ((usg0 (get-usage t nil))
 
8
        (t1 (gbc-time))
 
9
        (t2 (get-internal-run-time))
 
10
        (t3 (get-internal-real-time)))
 
11
    (prog1 ,@forms
 
12
      (setq t1 (- (gbc-time ) t1))
 
13
      (setq t2 (-  (get-internal-run-time) t2))
 
14
      (setq t3 (-  (get-internal-real-time) t3))
 
15
      (let ((usg (get-usage t nil)))
 
16
        (let ((ans
 
17
               (format nil
 
18
                "Run= ~3,2f Elap= ~3,2f Gc= ~3,2f Fault= ~3d"
 
19
                (cv t2) (cv t3) (cv t1)
 
20
                (- (|rusage|-|ru_majflt| usg) (|rusage|-|ru_majflt| usg0)))))
 
21
          (push (list ',(car forms) ans ) *all-times*)
 
22
          (print ans))))))
 
23
 
 
24
 
 
25
(setq si::*notify-gbc* t)
 
26
(allocate 'cons 520 t)
 
27
(allocate 'fixnum 40)
 
28
 
 
29
(si::sgc-on nil)
 
30
(si::allocate-sgc 'symbol 20  30 30)
 
31
(si::allocate-sgc 'cons 50  3000 40)
 
32
 
 
33
(si::allocate-sgc 'vector 1 10 30)
 
34
(si::allocate-sgc 'string 1 10 30)
 
35
(gbc nil)
 
36
(si::sgc-on t)
 
37
(print (in-package "MAXIMA"))
 
38
(setq $joe #$expand((x+y+z)^20)$)
 
39
 
 
40
 
 
41
(defun test (form)
 
42
  (gbc nil)
 
43
  (eval form)
 
44
  (push (list form 'cons-pages (si::allocated-pages 'cons)) si::*all-times*)
 
45
  
 
46
  (gbc nil)
 
47
  (si::with-timing (sloop for i below 3 do (displa ($factor $joe))))
 
48
  )
 
49
 
 
50
(test '(si::sgc-on nil))
 
51
(test '(si::sgc-on t))
 
52
(test '(si::sgc-on nil))
 
53
(test '(si::sgc-on t))
 
54
 
 
55
(print si::*all-times*)
 
56
      
 
57
      
 
58