home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / sos / microbench.scm < prev    next >
Text File  |  1999-01-02  |  7KB  |  273 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: microbench.scm,v 1.2 1999/01/02 06:19:10 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1993-1999 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;;;; Micro-benchmarks for SOS
  22.  
  23. (declare (usual-integrations))
  24.  
  25. (define (f1 x)
  26.   x)
  27.  
  28. (define (f2 x y)
  29.   y
  30.   x)
  31.  
  32. (define (rf . x)
  33.   x)
  34.  
  35. (define (get-f5)
  36.   (lambda (x)
  37.     x))
  38.  
  39. (define (get-f6 y)
  40.   (lambda (x)
  41.     x
  42.     y))
  43.  
  44. (define (fv x)
  45.   (vector-ref x 1))
  46.  
  47. (define-class <c1> ()
  48.   x)
  49.  
  50. (define-class <c2> (<c1>)
  51.   )
  52.  
  53. (define-class <c3> (<c1>)
  54.   )
  55.  
  56. (define fx1 (slot-accessor <c1> 'X))
  57. (define fx2 (slot-accessor <c1> 'X))
  58. (define fx3 (slot-accessor <c1> 'X))
  59.  
  60. (define-generic fx1* (instance))
  61. (define-generic fx2* (instance))
  62. (define-generic fx3* (instance))
  63. (let ((method (slot-accessor-method <c1> 'X)))
  64.   (add-method fx1* method)
  65.   (add-method fx2* method)
  66.   (add-method fx3* method))
  67.  
  68. (define-generic g1 (instance))
  69. (define-method g1 ((instance <c1>)) instance)
  70. (define (get-g1) g1)
  71.  
  72. (define-generic g2 (instance))
  73. (define-method g2 ((instance <c1>)) instance)
  74. (define-method g2 ((instance <c2>)) instance)
  75.  
  76. (define-generic g3 (instance other))
  77. (define-method g3 ((instance <c1>) other) other instance)
  78.  
  79. (define (null-test)
  80.   (let ((i1 ((instance-constructor <c1> '())))
  81.     (i2 ((instance-constructor <c2> '())))
  82.     (i3 ((instance-constructor <c3> '()))))
  83.     (do ((i 0 (fix:+ i 1)))
  84.     ((fix:= i 100000)))))
  85.  
  86. (define (f1-test)
  87.   (let ((i1 ((instance-constructor <c1> '())))
  88.     (i2 ((instance-constructor <c2> '())))
  89.     (i3 ((instance-constructor <c3> '()))))
  90.     (do ((i 0 (fix:+ i 1)))
  91.     ((fix:= i 100000))
  92.       (f1 i1))))
  93.  
  94. (define (f2-test)
  95.   (let ((i1 ((instance-constructor <c1> '())))
  96.     (i2 ((instance-constructor <c2> '())))
  97.     (i3 ((instance-constructor <c3> '()))))
  98.     (do ((i 0 (fix:+ i 1)))
  99.     ((fix:= i 100000))
  100.       (f2 i1 i2))))
  101.  
  102. (define (f3-test)
  103.   (let ((i1 ((instance-constructor <c1> '())))
  104.     (i2 ((instance-constructor <c2> '())))
  105.     (i3 ((instance-constructor <c3> '()))))
  106.     (do ((i 0 (fix:+ i 1)))
  107.     ((fix:= i 100000))
  108.       (rf i1))))
  109.  
  110. (define (f4-test)
  111.   (let ((i1 ((instance-constructor <c1> '())))
  112.     (i2 ((instance-constructor <c2> '())))
  113.     (i3 ((instance-constructor <c3> '()))))
  114.     (do ((i 0 (fix:+ i 1)))
  115.     ((fix:= i 100000))
  116.       (rf i1 i2))))
  117.  
  118. (define (f5-test)
  119.   (let ((i1 ((instance-constructor <c1> '())))
  120.     (i2 ((instance-constructor <c2> '())))
  121.     (i3 ((instance-constructor <c3> '())))
  122.     (f5 (get-f5)))
  123.     (do ((i 0 (fix:+ i 1)))
  124.     ((fix:= i 100000))
  125.       (f5 i1))))
  126.  
  127. (define (f6-test)
  128.   (let ((i1 ((instance-constructor <c1> '())))
  129.     (i2 ((instance-constructor <c2> '())))
  130.     (i3 ((instance-constructor <c3> '())))
  131.     (f6 (get-f6 0)))
  132.     (do ((i 0 (fix:+ i 1)))
  133.     ((fix:= i 100000))
  134.       (f6 i1))))
  135.  
  136. (define (fv-test)
  137.   (let ((i1 (vector 'A 'B)))
  138.     (do ((i 0 (fix:+ i 1)))
  139.     ((fix:= i 100000))
  140.       (fv i1))))
  141.  
  142. (define (fx1-test)
  143.   (let ((i1 ((instance-constructor <c1> '())))
  144.     (i2 ((instance-constructor <c2> '())))
  145.     (i3 ((instance-constructor <c3> '()))))
  146.     (set-slot-value! i1 'X 0)
  147.     (do ((i 0 (fix:+ i 1)))
  148.     ((fix:= i 100000))
  149.       (fx1 i1))))
  150.  
  151. (define (fx2-test)
  152.   (let ((i1 ((instance-constructor <c1> '())))
  153.     (i2 ((instance-constructor <c2> '())))
  154.     (i3 ((instance-constructor <c3> '()))))
  155.     (set-slot-value! i1 'X 0)
  156.     (set-slot-value! i2 'X 0)
  157.     (do ((i 0 (fix:+ i 1)))
  158.     ((fix:= i 100000))
  159.       (fx2 i1)
  160.       (fx2 i2))))
  161.  
  162. (define (fx3-test)
  163.   (let ((i1 ((instance-constructor <c1> '())))
  164.     (i2 ((instance-constructor <c2> '())))
  165.     (i3 ((instance-constructor <c3> '()))))
  166.     (set-slot-value! i1 'X 0)
  167.     (set-slot-value! i2 'X 0)
  168.     (set-slot-value! i3 'X 0)
  169.     (do ((i 0 (fix:+ i 1)))
  170.     ((fix:= i 100000))
  171.       (fx3 i1)
  172.       (fx3 i2)
  173.       (fx3 i3))))
  174.  
  175. (define (fx1*-test)
  176.   (let ((i1 ((instance-constructor <c1> '())))
  177.     (i2 ((instance-constructor <c2> '())))
  178.     (i3 ((instance-constructor <c3> '()))))
  179.     (set-slot-value! i1 'X 0)
  180.     (do ((i 0 (fix:+ i 1)))
  181.     ((fix:= i 100000))
  182.       (fx1* i1))))
  183.  
  184. (define (fx2*-test)
  185.   (let ((i1 ((instance-constructor <c1> '())))
  186.     (i2 ((instance-constructor <c2> '())))
  187.     (i3 ((instance-constructor <c3> '()))))
  188.     (set-slot-value! i1 'X 0)
  189.     (set-slot-value! i2 'X 0)
  190.     (do ((i 0 (fix:+ i 1)))
  191.     ((fix:= i 100000))
  192.       (fx2* i1)
  193.       (fx2* i2))))
  194.  
  195. (define (fx3*-test)
  196.   (let ((i1 ((instance-constructor <c1> '())))
  197.     (i2 ((instance-constructor <c2> '())))
  198.     (i3 ((instance-constructor <c3> '()))))
  199.     (set-slot-value! i1 'X 0)
  200.     (set-slot-value! i2 'X 0)
  201.     (set-slot-value! i3 'X 0)
  202.     (do ((i 0 (fix:+ i 1)))
  203.     ((fix:= i 100000))
  204.       (fx3* i1)
  205.       (fx3* i2)
  206.       (fx3* i3))))
  207.  
  208. (define (g1-test)
  209.   (let ((i1 ((instance-constructor <c1> '())))
  210.     (i2 ((instance-constructor <c2> '())))
  211.     (i3 ((instance-constructor <c3> '()))))
  212.     (do ((i 0 (fix:+ i 1)))
  213.     ((fix:= i 100000))
  214.       (g1 i1))))
  215.  
  216. (define (g2-test)
  217.   (let ((i1 ((instance-constructor <c1> '())))
  218.     (i2 ((instance-constructor <c2> '())))
  219.     (i3 ((instance-constructor <c3> '()))))
  220.     (do ((i 0 (fix:+ i 1)))
  221.     ((fix:= i 100000))
  222.       (g2 i1)
  223.       (g2 i2))))
  224.  
  225. (define (g3-test)
  226.   (let ((i1 ((instance-constructor <c1> '())))
  227.     (i2 ((instance-constructor <c2> '())))
  228.     (i3 ((instance-constructor <c3> '()))))
  229.     (do ((i 0 (fix:+ i 1)))
  230.     ((fix:= i 100000))
  231.       (g3 i1 i2))))
  232.  
  233. (define (g4-test)
  234.   (let ((i1 ((instance-constructor <c1> '())))
  235.     (i2 ((instance-constructor <c2> '())))
  236.     (i3 ((instance-constructor <c3> '())))
  237.     (g1 (get-g1)))
  238.     (do ((i 0 (fix:+ i 1)))
  239.     ((fix:= i 100000))
  240.       (g1 i1))))
  241.  
  242. (define (run-test test)
  243.   (test)                ;warm up
  244.   (let loop ((n 3) (time 0))
  245.     (if (= n 0)
  246.     (/ time 300)
  247.     (begin
  248.       (gc-flip)
  249.       (let ((process-start (process-time-clock)))
  250.         (test)
  251.         (let ((process-end (process-time-clock)))
  252.           (loop (- n 1)
  253.             (+ time (- process-end process-start)))))))))
  254.  
  255. (define (run-tests)
  256.   (let ((f1-time (run-test f1-test)))
  257.     (let ((report
  258.        (lambda (name time scale)
  259.          (fluid-let ((flonum-unparser-cutoff '(ABSOLUTE 2)))
  260.            (newline)
  261.            (write name)
  262.            (write-string "-test:\t")
  263.            (write (exact->inexact time))
  264.            (write-string "\t")
  265.            (write (exact->inexact (/ (/ time scale) f1-time)))))))
  266.       (report 'f1 f1-time 1)
  267.       (for-each (lambda (name test scale)
  268.           (report name (run-test test) scale))
  269.         '(f2 f3 f4 f5 f6 fv fx1 fx2 fx3 fx1* fx2* fx3* g1 g2 g3 g4)
  270.         (list f2-test f3-test f4-test f5-test f6-test fv-test
  271.               fx1-test fx2-test fx3-test fx1*-test fx2*-test fx3*-test
  272.               g1-test g2-test g3-test g4-test)
  273.         '(1 1 1 1 1 1 1 2 3 1 2 3 1 2 1 1)))))