cpuinfo.rkt
#lang racket
;; Copyright Neil Van Dyke. See file "info.rkt".

(require (planet neil/mcfly))

(doc (section "Introduction")

     (para "This package makes it easy to get particular information about the
host machine CPUs from Racket, such as an English description of the models of
CPU and their configuration (of physical processors, cores, and
hyperthreading), and what virtualization method the CPUs support.")

     (para "This package uses the "
           (filepath "/proc/cpuinfo")
           " interface, such as in Linux.")

     (para "Examples are sensitive to what machine "
           (racket get-cpuinfo)
           " in run on, so imagine you are using the laptop on which the
author of this package is typing this documentation, when we do:")

     (racketinput
      (define my-cpuinfo (get-cpuinfo)))

     (para (racket my-cpuinfo)
           " now contains the information gotten from the "
           (filepath "/proc/cpuinfo")
           " kernel interface.  We can ask for an English language summary:")

     (racketinput
      (cpuinfo->english my-cpuinfo))
     (racketresultblock
      "single-processor (Intel Core Duo T2500 2.00GHz), dual-core")

     (para
      "This package tries to distinguish physical processors, cores, and
hyperthreading correctly, so, on a different machine, you might see a result
more like:")

     (racketinput
      (cpuinfo->english my-cpuinfo))
     (racketresultblock
      "dual-processor (Intel Xeon 3.60GHz), dual-core total, plus hyperthreading")

     (para
      "For more information how this package determines whether hyperthreading
is in use, see "
      (hyperlink "http://www.richweb.com/cpu_info"
                 "Richweb's Understanding Linux /proc/cpuinfo")
      ".")

     (para
      "Back to our original example machine, we can also ask what support the
processor has for KVM virtualization:")

     (racketinput
      (cpuinfo-kvm-support my-cpuinfo))
     (racketresultblock intel-vt-x)

     (para
      "Finally, we can access the raw "
      (racket cpuinfo)
      " info, as a list of alists of symbols to strings:")

     (racketinput my-cpuinfo)
     (racketresultblock
      (((processor . "0")
        (vendor-id . "GenuineIntel")
        (cpu-family . "6")
        (model . "14")
        (model-name . "Intel(R) Core(TM) Duo CPU T2500 @ 2.00GHz")
        (stepping . "12")
        (cpu-mhz . "1333.000")
        (cache-size . "2048 KB")
        (physical-id . "0")
        (siblings . "2")
        (core-id . "0")
        (cpu-cores . "2")
        (apicid . "0")
        (initial-apicid . "0")
        (fdiv-bug . "no")
        (hlt-bug . "no")
        (f00f-bug . "no")
        (coma-bug . "no")
        (fpu . "yes")
        (fpu-exception . "yes")
        (cpuid-level . "10")
        (wp . "yes")
        (flags
         .
         "fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe nx constant_tsc arch_perfmon bts aperfmperf pni monitor vmx est tm2 xtpr pdcm")
        (bogomips . "3990.15")
        (clflush-size . "64")
        (cache-alignment . "64")
        (address-sizes . "32 bits physical, 32 bits virtual")
        (power-management . ""))
       ((processor . "1")
        (vendor-id . "GenuineIntel")
        (cpu-family . "6")
        (model . "14")
        (model-name . "Intel(R) Core(TM) Duo CPU T2500 @ 2.00GHz")
        (stepping . "12")
        (cpu-mhz . "2000.000")
        (cache-size . "2048 KB")
        (physical-id . "0")
        (siblings . "2")
        (core-id . "1")
        (cpu-cores . "2")
        (apicid . "1")
        (initial-apicid . "1")
        (fdiv-bug . "no")
        (hlt-bug . "no")
        (f00f-bug . "no")
        (coma-bug . "no")
        (fpu . "yes")
        (fpu-exception . "yes")
        (cpuid-level . "10")
        (wp . "yes")
        (flags
         .
         "fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe nx constant_tsc arch_perfmon bts aperfmperf pni monitor vmx est tm2 xtpr pdcm")
        (bogomips . "3990.07")
        (clflush-size . "64")
        (cache-alignment . "64")
        (address-sizes . "32 bits physical, 32 bits virtual")
        (power-management . ""))))

     (para "This package was originally written for the About box of RackOut,
since processor arrangement might be important for video decoding
performance."))

(doc (section "Interface"))

(module+ test
  (require (planet neil/overeasy:2)))

(define (%cpuinfo:name->symbol name-string)
  (or (hash-ref
       #hash(
             ("processor"        . processor)
             ("vendor_id"        . vendor-id)
             ("cpu family"       . cpu-family)
             ("model"            . model)
             ("model name"       . model-name)
             ("stepping"         . stepping)
             ("cpu MHz"          . cpu-mhz)
             ("cache size"       . cache-size)
             ("physical id"      . physical-id)
             ("siblings"         . siblings)
             ("core id"          . core-id)
             ("cpu cores"        . cpu-cores)
             ("apicid"           . apicid)
             ("initial apicid"   . initial-apicid)
             ("fdiv_bug"         . fdiv-bug)
             ("hlt_bug"          . hlt-bug)
             ("f00f_bug"         . f00f-bug)
             ("coma_bug"         . coma-bug)
             ("fpu"              . fpu)
             ("fpu_exception"    . fpu-exception)
             ("cpuid level"      . cpuid-level)
             ("wp"               . wp)
             ("flags"            . flags)
             ("bogomips"         . bogomips)
             ("clflush size"     . clflush-size)
             ("cache_alignment"  . cache-alignment)
             ("address sizes"    . address-sizes)
             ("power management" . power-management)
             )
       name-string
       #f)
      (string->symbol (regexp-replace* #rx"[ _]"
                                       (string-downcase name-string)
                                       "-"))))

(module+ test

  (test (%cpuinfo:name->symbol "cpu MHz")    'cpu-mhz)
  (test (%cpuinfo:name->symbol "giga Watts") 'giga-watts)
  (test (%cpuinfo:name->symbol "a b c")      'a-b-c)
  (test (%cpuinfo:name->symbol "a_b_c")      'a-b-c))

(doc (defproc (parse-proc-cpuinfo (in input-port?))
         cpuinfo?
       (para "Parse "
             (racket cpuinfo)
             " from input port.  This is useful if the input is not coming directly from file "
             (filepath "/proc/cpuinfo")
             " on the host machine; otherwise, you would normally just use "
             (racket get-cpuinfo)
             " instead.")))
(provide parse-proc-cpuinfo)
(define (parse-proc-cpuinfo in)
  (let loop ((reverse-entries '())
             (reverse-entry   '()))
    (cond ((eof-object? (peek-byte in))
           (if (null? reverse-entry)
               (reverse reverse-entries)
               (reverse (cons (reverse reverse-entry)
                              reverse-entries))))
          ((regexp-try-match #rx#"^[ \t]*([^:\r\n]*):[ \t]*([^\r\n]*)\r?\n" in)
           => (lambda (m)
                (apply (lambda (all name val)
                         (loop reverse-entries
                               (cons (cons (%cpuinfo:name->symbol (string-trim (bytes->string/latin-1 name)))
                                           (string-normalize-spaces (bytes->string/latin-1 val)))
                                     reverse-entry)))
                       m)))
          ((regexp-try-match #rx#"^[ \t]*\r?\n" in)
           (if (null? reverse-entry)
               (loop reverse-entries
                     '())
               (loop (cons (reverse reverse-entry)
                           reverse-entries)
                     '())))
          (else (error 'parse-proc-cpuinfo
                       "could not parse line ~S in ~S"
                       (regexp-match #rx#"[^ \r\n]*" in)
                       in)))))

(module+ test

  ;; (string-append (number->string 6 16) (number->string 14 16) (number->string 12 16))
  ;; => "6ec"

  (define sample-1-input-bstr
    (bytes-append
     #"processor\t: 0\n"
     #"vendor_id\t: GenuineIntel\n"
     #"cpu family\t: 6\n"
     #"model\t\t: 14\n"
     #"model name\t: Intel(R) Core(TM) Duo CPU      T2500  @ 2.00GHz\n"
     #"stepping\t: 12\n"
     #"cpu MHz\t\t: 1000.000\n"
     #"cache size\t: 2048 KB\n"
     #"physical id\t: 0\n"
     #"siblings\t: 2\n"
     #"core id\t\t: 0\n"
     #"cpu cores\t: 2\n"
     #"apicid\t\t: 0\n"
     #"initial apicid\t: 0\n"
     #"fdiv_bug\t: no\n"
     #"hlt_bug\t\t: no\n"
     #"f00f_bug\t: no\n"
     #"coma_bug\t: no\n"
     #"fpu\t\t: yes\n"
     #"fpu_exception\t: yes\n"
     #"cpuid level\t: 10\n"
     #"wp\t\t: yes\n"
     #"flags\t\t: fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe nx constant_tsc arch_perfmon bts aperfmperf pni monitor vmx est tm2 xtpr pdcm\n"
     #"bogomips\t: 3990.14\n"
     #"clflush size\t: 64\n"
     #"cache_alignment\t: 64\n"
     #"address sizes\t: 32 bits physical, 32 bits virtual\n"
     #"power management:\n"
     #"\n"
     #"processor\t: 1\n"
     #"vendor_id\t: GenuineIntel\n"
     #"cpu family\t: 6\n"
     #"model\t\t: 14\n"
     #"model name\t: Intel(R) Core(TM) Duo CPU      T2500  @ 2.00GHz\n"
     #"stepping\t: 12\n"
     #"cpu MHz\t\t: 1000.000\n"
     #"cache size\t: 2048 KB\n"
     #"physical id\t: 0\n"
     #"siblings\t: 2\n"
     #"core id\t\t: 1\n"
     #"cpu cores\t: 2\n"
     #"apicid\t\t: 1\n"
     #"initial apicid\t: 1\n"
     #"fdiv_bug\t: no\n"
     #"hlt_bug\t\t: no\n"
     #"f00f_bug\t: no\n"
     #"coma_bug\t: no\n"
     #"fpu\t\t: yes\n"
     #"fpu_exception\t: yes\n"
     #"cpuid level\t: 10\n"
     #"wp\t\t: yes\n"
     #"flags\t\t: fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe nx constant_tsc arch_perfmon bts aperfmperf pni monitor vmx est tm2 xtpr pdcm\n"
     #"bogomips\t: 3990.07\n"
     #"clflush size\t: 64\n"
     #"cache_alignment\t: 64\n"
     #"address sizes\t: 32 bits physical, 32 bits virtual\n"
     #"power management:\n"))

  (define sample-1-output
    '(((processor        . "0")
       (vendor-id        . "GenuineIntel")
       (cpu-family       . "6")
       (model            . "14")
       (model-name       . "Intel(R) Core(TM) Duo CPU T2500 @ 2.00GHz")
       (stepping         . "12")
       (cpu-mhz          . "1000.000")
       (cache-size       . "2048 KB")
       (physical-id      . "0")
       (siblings         . "2")
       (core-id          . "0")
       (cpu-cores        . "2")
       (apicid           . "0")
       (initial-apicid   . "0")
       (fdiv-bug         . "no")
       (hlt-bug          . "no")
       (f00f-bug         . "no")
       (coma-bug         . "no")
       (fpu              . "yes")
       (fpu-exception    . "yes")
       (cpuid-level      . "10")
       (wp               . "yes")
       (flags            . "fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe nx constant_tsc arch_perfmon bts aperfmperf pni monitor vmx est tm2 xtpr pdcm")
       (bogomips         . "3990.14")
       (clflush-size     . "64")
       (cache-alignment  . "64")
       (address-sizes    . "32 bits physical, 32 bits virtual")
       (power-management . ""))
      ((processor        . "1")
       (vendor-id        . "GenuineIntel")
       (cpu-family       . "6")
       (model            . "14")
       (model-name       . "Intel(R) Core(TM) Duo CPU T2500 @ 2.00GHz")
       (stepping         . "12")
       (cpu-mhz          . "1000.000")
       (cache-size       . "2048 KB")
       (physical-id      . "0")
       (siblings         . "2")
       (core-id          . "1")
       (cpu-cores        . "2")
       (apicid           . "1")
       (initial-apicid   . "1")
       (fdiv-bug         . "no")
       (hlt-bug          . "no")
       (f00f-bug         . "no")
       (coma-bug         . "no")
       (fpu              . "yes")
       (fpu-exception    . "yes")
       (cpuid-level      . "10")
       (wp               . "yes")
       (flags            . "fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe nx constant_tsc arch_perfmon bts aperfmperf pni monitor vmx est tm2 xtpr pdcm")
       (bogomips         . "3990.07")
       (clflush-size     . "64")
       (cache-alignment  . "64")
       (address-sizes    . "32 bits physical, 32 bits virtual")
       (power-management . ""))))

  (test (parse-proc-cpuinfo (open-input-bytes sample-1-input-bstr))
        sample-1-output)

  (define sample-2-input-bstr
    (bytes-append
     #"processor\t: 0\n"
     #"vendor_id\t: GenuineIntel\n"
     #"cpu family\t: 6\n"
     #"model\t\t: 28\n"
     #"model name\t: Intel(R) Atom(TM) CPU D410   @ 1.66GHz\n"
     #"stepping\t: 10\n"
     #"cpu MHz\t\t: 1666.770\n"
     #"cache size\t: 512 KB\n"
     #"physical id\t: 0\n"
     #"siblings\t: 2\n"
     #"core id\t\t: 0\n"
     #"cpu cores\t: 1\n"
     #"apicid\t\t: 0\n"
     #"initial apicid\t: 0\n"
     #"fdiv_bug\t: no\n"
     #"hlt_bug\t\t: no\n"
     #"f00f_bug\t: no\n"
     #"coma_bug\t: no\n"
     #"fpu\t\t: yes\n"
     #"fpu_exception\t: yes\n"
     #"cpuid level\t: 10\n"
     #"wp\t\t: yes\n"
     #"flags\t\t: fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe nx lm constant_tsc arch_perfmon pebs bts pni monitor ds_cpl tm2 ssse3 cx16 xtpr lahf_lm\n"
     #"bogomips\t: 3337.78\n"
     #"clflush size\t: 64\n"
     #"power management:\n"
     #"\n"
     #"processor\t: 1\n"
     #"vendor_id\t: GenuineIntel\n"
     #"cpu family\t: 6\n"
     #"model\t\t: 28\n"
     #"model name\t: Intel(R) Atom(TM) CPU D410   @ 1.66GHz\n"
     #"stepping\t: 10\n"
     #"cpu MHz\t\t: 1666.770\n"
     #"cache size\t: 512 KB\n"
     #"physical id\t: 0\n"
     #"siblings\t: 2\n"
     #"core id\t\t: 0\n"
     #"cpu cores\t: 1\n"
     #"apicid\t\t: 1\n"
     #"initial apicid\t: 1\n"
     #"fdiv_bug\t: no\n"
     #"hlt_bug\t\t: no\n"
     #"f00f_bug\t: no\n"
     #"coma_bug\t: no\n"
     #"fpu\t\t: yes\n"
     #"fpu_exception\t: yes\n"
     #"cpuid level\t: 10\n"
     #"wp\t\t: yes\n"
     #"flags\t\t: fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe nx lm constant_tsc arch_perfmon pebs bts pni monitor ds_cpl tm2 ssse3 cx16 xtpr lahf_lm\n"
     #"bogomips\t: 3333.32\n"
     #"clflush size\t: 64\n"
     #"power management:\n"))

  (define sample-2-output
    '(((processor . "0")
       (vendor-id . "GenuineIntel")
       (cpu-family . "6")
       (model . "28")
       (model-name . "Intel(R) Atom(TM) CPU D410 @ 1.66GHz")
       (stepping . "10")
       (cpu-mhz . "1666.770")
       (cache-size . "512 KB")
       (physical-id . "0")
       (siblings . "2")
       (core-id . "0")
       (cpu-cores . "1")
       (apicid . "0")
       (initial-apicid . "0")
       (fdiv-bug . "no")
       (hlt-bug . "no")
       (f00f-bug . "no")
       (coma-bug . "no")
       (fpu . "yes")
       (fpu-exception . "yes")
       (cpuid-level . "10")
       (wp . "yes")
       (flags . "fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe nx lm constant_tsc arch_perfmon pebs bts pni monitor ds_cpl tm2 ssse3 cx16 xtpr lahf_lm")
       (bogomips . "3337.78")
       (clflush-size . "64")
       (power-management . ""))
      ((processor . "1")
       (vendor-id . "GenuineIntel")
       (cpu-family . "6")
       (model . "28")
       (model-name . "Intel(R) Atom(TM) CPU D410 @ 1.66GHz")
       (stepping . "10")
       (cpu-mhz . "1666.770")
       (cache-size . "512 KB")
       (physical-id . "0")
       (siblings . "2")
       (core-id . "0")
       (cpu-cores . "1")
       (apicid . "1")
       (initial-apicid . "1")
       (fdiv-bug . "no")
       (hlt-bug . "no")
       (f00f-bug . "no")
       (coma-bug . "no")
       (fpu . "yes")
       (fpu-exception . "yes")
       (cpuid-level . "10")
       (wp . "yes")
       (flags . "fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe nx lm constant_tsc arch_perfmon pebs bts pni monitor ds_cpl tm2 ssse3 cx16 xtpr lahf_lm")
       (bogomips . "3333.32")
       (clflush-size . "64")
       (power-management . ""))))

  (test (parse-proc-cpuinfo (open-input-bytes sample-2-input-bstr))
        sample-2-output)

  (define sample-3-input-bstr
    (bytes-append
     #"Processor\t: ARMv6-compatible processor rev 7 (v6l)\n"
     #"BogoMIPS\t: 697.95\n"
     #"Features\t: swp half thumb fastmult vfp edsp java tls \n"
     #"CPU implementer\t: 0x41\n"
     #"CPU architecture: 7\n"
     #"CPU variant\t: 0x0\n"
     #"CPU part\t: 0xb76\n"
     #"CPU revision\t: 7\n"
     #"\n"
     #"Hardware\t: BCM2708\n"
     #"Revision\t: 000f\n"
     #"Serial\t\t: 00000000e541a365\n"))

  (define sample-3-output
    '(((processor        . "ARMv6-compatible processor rev 7 (v6l)")
       (bogomips         . "697.95")
       (features         . "swp half thumb fastmult vfp edsp java tls")
       (cpu-implementer  . "0x41")
       (cpu-architecture . "7")
       (cpu-variant      . "0x0")
       (cpu-part         . "0xb76")
       (cpu-revision     . "7"))
      ((hardware . "BCM2708")
       (revision . "000f")
       (serial   . "00000000e541a365"))))

  (test (parse-proc-cpuinfo (open-input-bytes sample-3-input-bstr))
        sample-3-output))

(doc (defproc (get-cpuinfo)
         cpuinfo?
       (para "Get the "
             (racket cpuinfo)
             " for the host machine.")))
(provide get-cpuinfo)
(define (get-cpuinfo)
  (call-with-input-file "/proc/cpuinfo" parse-proc-cpuinfo))

(define (%cpuinfo:normalize-cpuinfo-model-name str)
  (string-normalize-spaces
   (regexp-replace* #rx"(?:\\((?:R|TM|tm)\\)| (?:CPU|processor|@ ))"
                    str
                    " ")))

(module+ test

  (test (%cpuinfo:normalize-cpuinfo-model-name
         "Intel(R) Core(TM) Duo CPU      T2500  @ 2.00GHz")
        "Intel Core Duo T2500 2.00GHz")

  (test (%cpuinfo:normalize-cpuinfo-model-name
         "Intel(R) Xeon(TM) CPU 3.60GHz")
        "Intel Xeon 3.60GHz")

  (test (%cpuinfo:normalize-cpuinfo-model-name
         "AMD Duron(tm) processor")
        "AMD Duron")

  (test (%cpuinfo:normalize-cpuinfo-model-name
         "ARMv6-compatible processor rev 7 (v6l)")
        "ARMv6-compatible rev 7 (v6l)"))

(define (%cpuinfo:alist-get-or-false key alist)
  (cond ((assq key alist) => cdr)
        (else #f)))

(define (%cpuinfo:cpuinfo->counts cpuinfo)
  (let loop ((entries                    cpuinfo)
             (name-to-physical-hash-hash (make-immutable-hash))
             (name-to-hyperthread-hash   (make-immutable-hash)))
    (if (null? entries)
        (begin
          (log-debug "%cpuinfo:cpuinfo->counts: name-to-physical-hash-hash ~S"
                     name-to-physical-hash-hash)
          (map (lambda (name-to-physical-hash-pair)
                 (let ((model-name (car name-to-physical-hash-pair)))
                   (vector model-name
                           (map cdr
                                (sort (map (lambda (physical-hash-pair)
                                             (cons (string->number (car physical-hash-pair))
                                                   (hash-count (cdr physical-hash-pair))))
                                           (hash->list (cdr name-to-physical-hash-pair)))
                                      <
                                      #:key car))
                           (hash-ref name-to-hyperthread-hash model-name #false))))
               (sort (hash->list name-to-physical-hash-hash)
                     string<?
                     #:key car)))
        (let* ((entry       (car entries))
               (model-name
                (or (%cpuinfo:alist-get-or-false 'model-name entry)
                    (cond ((%cpuinfo:alist-get-or-false 'processor entry)
                           => (lambda (processor)
                                (if (regexp-match? #rx"^[0-9]+$" processor)
                                    #false
                                    processor)))
                          (else #false))))
               (model-name (and model-name
                                (%cpuinfo:normalize-cpuinfo-model-name model-name)))
               (physical-id (or (%cpuinfo:alist-get-or-false 'physical-id entry) "-1"))
               (core-id     (or (%cpuinfo:alist-get-or-false 'core-id     entry) "-1")))
          (if model-name
              (loop (cdr entries)
                    (hash-update name-to-physical-hash-hash
                                 model-name
                                 (lambda (physical-hash)
                                   (hash-update physical-hash
                                                physical-id
                                                (lambda (core-hash)
                                                  (hash-update core-hash
                                                               core-id
                                                               (lambda (old-val)
                                                                 (and old-val
                                                                      (log-warning (format "%cpuinfo:cpuinfo->counts: multiple entries for model-name ~S physical-id ~S core-id ~S"
                                                                                           model-name
                                                                                           physical-id
                                                                                           core-id)))
                                                                 #true)
                                                               #false))
                                                make-immutable-hash))
                                 make-immutable-hash)
                    (let ((cpu-cores (%cpuinfo:alist-get-or-false 'cpu-cores entry))
                          (siblings  (%cpuinfo:alist-get-or-false 'siblings  entry)))
                      (if (and cpu-cores
                               siblings
                               (not (equal? cpu-cores siblings)))
                          (hash-set name-to-hyperthread-hash
                                    model-name
                                    #true)
                          name-to-hyperthread-hash)))
              (loop (cdr entries)
                    name-to-physical-hash-hash
                    name-to-hyperthread-hash))))))

(module+ test

  (test (%cpuinfo:cpuinfo->counts sample-1-output)
        '(#("Intel Core Duo T2500 2.00GHz"
            (2)
            #false)))

  (test (%cpuinfo:cpuinfo->counts sample-2-output)
        '(#("Intel Atom D410 1.66GHz"
            (1)
            #true)))

  (test (%cpuinfo:cpuinfo->counts sample-3-output)
        '(#("ARMv6-compatible rev 7 (v6l)"
            (1)
            #false))))

(define (%cpuinfo:dualquadetc num)
  (case num
    ((1) "single")
    ((2) "dual")
    ((3) "triple")
    ((4) "quad")
    (else (number->string num))))

(define (%cpuinfo:add-count-english count reverse-strings)
  (let* ((model-name      (vector-ref count 0))
         (processors      (vector-ref count 1))
         (hyperthreading? (vector-ref count 2))
         (physical-count  (length processors))
         (core-count      (apply + processors)))
    `(,@(if hyperthreading?
            '(", plus hyperthreading")
            '())
      ,@(if core-count
            `(,(if (= 1 physical-count)
                   "-core"
                   "-core total")
              ,(%cpuinfo:dualquadetc core-count)
              ", ")
            '())
      ")"
      ,model-name
      "-processor ("
      ,(%cpuinfo:dualquadetc physical-count)
      ,@reverse-strings)))

(define (%cpuinfo:counts->english counts)
  (if (null? counts)
      "no processor"
      (let loop ((counts          counts)
                 (reverse-strings (if (null? (cdr counts))
                                      '()
                                      '("multiple processor models: "))))
        (let* ((reverse-strings (%cpuinfo:add-count-english (car counts)
                                                            reverse-strings))
               (counts          (cdr counts)))
          (if (null? counts)
              (apply string-append (reverse reverse-strings))
              (loop counts
                    (cons "; " reverse-strings)))))))

(doc (defproc (cpuinfo->english (cpuinfo cpuinfo?))
         string?
       (para "Yield an English language summary of "
             (racket cpuinfo)
             ".  This is useful for a human to understand pertinent information
about their CPUs, such as in the About box of an application program.  The
exact format of this message is subject to change in future versions of this
package.")))
(provide cpuinfo->english)
(define (cpuinfo->english cpuinfo)
  (%cpuinfo:counts->english (%cpuinfo:cpuinfo->counts cpuinfo)))

(module+ test

  (define (test-counts+english cpuinfo)
    (let ((counts (%cpuinfo:cpuinfo->counts cpuinfo)))
      (values counts
              (%cpuinfo:counts->english counts))))

  (test (test-counts+english '())
        (values '()
                "no processor"))

  (test (test-counts+english sample-1-output)
        (values '(#("Intel Core Duo T2500 2.00GHz"
                    (2)
                    #false))
                "single-processor (Intel Core Duo T2500 2.00GHz), dual-core"))

  (test (test-counts+english sample-2-output)
        (values '(#("Intel Atom D410 1.66GHz"
                    (1)
                    #true))
                "single-processor (Intel Atom D410 1.66GHz), single-core, plus hyperthreading"))

  (test (test-counts+english sample-3-output)
        (values '(#("ARMv6-compatible rev 7 (v6l)"
                    (1)
                    #false))
                "single-processor (ARMv6-compatible rev 7 (v6l)), single-core"))

  ;; Some of these examples are from "http://www.richweb.com/cpu_info".

  (test 'richweb-example-1
        (test-counts+english '(((processor  . "0")
                                (model-name . "AMD Duron(tm) processor"))))
        (values '(#("AMD Duron"
                    (1)
                    #false))
                "single-processor (AMD Duron), single-core"))

  (test 'richweb-example-2
        (test-counts+english '(
                               ((processor   . "0")
                                (model-name  . "Intel(R) Pentium(R) 4 CPU 2.80GHz")
                                (cache-size  . "1024 KB")
                                (physical-id . "0")
                                (siblings    . "2")
                                (core-id             . "0")
                                (cpu-cores   . "1"))
                               ((processor   . "1")
                                (model-name  . "Intel(R) Pentium(R) 4 CPU 2.80GHz")
                                (cache-size  . "1024 KB")
                                (physical-id . "0")
                                (siblings    . "2")
                                (core-id             . "0")
                                (cpu-cores   . "1"))))
        (values '(#("Intel Pentium 4 2.80GHz"
                    (1)
                    #true))
                "single-processor (Intel Pentium 4 2.80GHz), single-core, plus hyperthreading"))

  (test 'richweb-example-3
        (test-counts+english '(((processor   . "0")
                                (model-name  . "Intel(R) Xeon(R) CPU E5410 @ 2.33GHz")
                                (cache-size  . "6144 KB")
                                (physical-id . "0")
                                (siblings    . "4")
                                (core-id             . "0")
                                (cpu-cores   . "4"))
                               ((processor   . "1")
                                (model-name  . "Intel(R) Xeon(R) CPU E5410 @ 2.33GHz")
                                (cache-size  . "6144 KB")
                                (physical-id . "0")
                                (siblings    . "4")
                                (core-id             . "1")
                                (cpu-cores   . "4"))
                               ((processor   . "2")
                                (model-name  . "Intel(R) Xeon(R) CPU E5410 @ 2.33GHz")
                                (cache-size  . "6144 KB")
                                (physical-id . "0")
                                (siblings    . "4")
                                (core-id             . "2")
                                (cpu-cores   . "4"))
                               ((processor   . "3")
                                (model-name  . "Intel(R) Xeon(R) CPU E5410 @ 2.33GHz")
                                (cache-size  . "6144 KB")
                                (physical-id . "0")
                                (siblings    . "4")
                                (core-id             . "3")
                                (cpu-cores   . "4"))))
        (values '(#("Intel Xeon E5410 2.33GHz"
                    (4)
                    #false))
                "single-processor (Intel Xeon E5410 2.33GHz), quad-core"))

  (test 'richweb-example-3a
        (test-counts+english '(((processor   . "0")
                                (model-name  . "Intel(R) Pentium(R) D CPU 3.00GHz")
                                (cache-size  . "2048 KB")
                                (physical-id . "0")
                                (siblings    . "2")
                                (core-id             . "0")
                                (cpu-cores   . "2"))
                               ((processor   . "1")
                                (model-name  . "Intel(R) Pentium(R) D CPU 3.00GHz")
                                (cache-size  . "2048 KB")
                                (physical-id . "0")
                                (siblings    . "2")
                                (core-id             . "1")
                                (cpu-cores   . "2"))))
        (values '(#("Intel Pentium D 3.00GHz"
                    (2)
                    #false))
                "single-processor (Intel Pentium D 3.00GHz), dual-core"))

  (test 'richweb-example-4
        (test-counts+english '(((processor   . "0")
                                (model-name  . "Intel(R) Xeon(TM) CPU 3.60GHz")
                                (cache-size  . "1024 KB")
                                (physical-id . "0")
                                (siblings    . "2")
                                (core-id             . "0")
                                (cpu-cores   . "1"))
                               ((processor  . "1")
                                (model-name . "Intel(R) Xeon(TM) CPU 3.60GHz")
                                (cache-size . "1024 KB")
                                (physical-id        . "3")
                                (siblings   . "2")
                                (core-id            . "0")
                                (cpu-cores  . "1"))
                               ((processor  . "2")
                                (model-name . "Intel(R) Xeon(TM) CPU 3.60GHz")
                                (cache-size . "1024 KB")
                                (physical-id        . "0")
                                (siblings   . "2")
                                (core-id            . "0")
                                (cpu-cores  . "1"))
                               ((processor  . "3")
                                (model-name . "Intel(R) Xeon(TM) CPU 3.60GHz")
                                (cache-size . "1024 KB")
                                (physical-id        . "3")
                                (siblings   . "2")
                                (core-id            . "0")
                                (cpu-cores  . "1"))))
        (values '(#("Intel Xeon 3.60GHz"
                    (1 1)
                    #true))
                "dual-processor (Intel Xeon 3.60GHz), dual-core total, plus hyperthreading"))

  (test 'richweb-example-5
        (test-counts+english
         '(((processor . "0")
            (model-name        . "Intel(R) Xeon(R) CPU 5160 @ 3.00GHz")
            (cache-size        . "4096 KB")
            (physical-id       . "0")
            (siblings  . "2")
            (core-id           . "0")
            (cpu-cores . "2"))
           ((processor . "1")
            (model-name        . "Intel(R) Xeon(R) CPU 5160 @ 3.00GHz")
            (cache-size        . "4096 KB")
            (physical-id       . "0")
            (siblings  . "2")
            (core-id           . "1")
            (cpu-cores . "2"))
           ((processor . "2")
            (model-name        . "Intel(R) Xeon(R) CPU 5160 @ 3.00GHz")
            (cache-size        . "4096 KB")
            (physical-id       . "3")
            (siblings  . "2")
            (core-id           . "0")
            (cpu-cores . "2"))
           ((processor . "3")
            (model-name        . "Intel(R) Xeon(R) CPU 5160 @ 3.00GHz")
            (cache-size        . "4096 KB")
            (physical-id       . "3")
            (siblings  . "2")
            (core-id           . "1")
            (cpu-cores . "2"))))
        (values '(#("Intel Xeon 5160 3.00GHz"
                    (2 2)
                    #false))
                "dual-processor (Intel Xeon 5160 3.00GHz), quad-core total")))

(doc (defproc (cpuinfo-kvm-support (cpuinfo cpuinfo?))
         (or/c #f  'amd-v 'intel-vt-x)
       (para "Returns a symbol for the kind of Linux KVM virtualization support
at least one processor in "
             (racket cpuinfo)
             " has, or "
             (racket #f)
             " if none could be determined.  See "
             (hyperlink "http://www.linux-kvm.org/page/Processor_support"
                        "Linux KVM hardware support page")
             ".")))
(provide cpuinfo-kvm-support)
(define (cpuinfo-kvm-support cpuinfo)
  (let loop ((cpuinfo cpuinfo))
    (if (null? cpuinfo)
        #f
        (let ((part (car cpuinfo)))
          (cond ((%cpuinfo:alist-get-or-false 'model-name part)
                 => (lambda (model-name)
                      (cond ((%cpuinfo:alist-get-or-false 'flags part)
                             => (lambda (flags)
                                  (let ((flags-list (regexp-split #rx" +" flags)))
                                    (cond ((regexp-match? #rx"^Intel[ (]" model-name)
                                           (if (member "vmx" flags-list)
                                               'intel-vt-x
                                               (loop (cdr cpuinfo))))
                                          ((regexp-match? #rx"^AMD[ (]" model-name)
                                           (if (member "svm" flags-list)
                                               'amd-v
                                               (loop (cdr cpuinfo))))
                                          (else (loop (cdr cpuinfo)))))))
                            (else (loop (cdr cpuinfo))))))
                (else (loop (cdr cpuinfo))))))))

(module+ test

  (test (cpuinfo-kvm-support sample-1-output)
        'intel-vt-x)

  (test (cpuinfo-kvm-support sample-2-output)
        #f)

  (test (cpuinfo-kvm-support
         '(((processor . "0")
            (model-name . "AMD Duron XXXL")
            (flags . "fpu vme de pse tsc msr pae mce cx8 apic mtrr pge mca cmov pat pse36 clflush mmx fxsr sse sse2 ht syscall nx mmxext fxsr_opt rdtscp lm 3dnowext 3dnow rep_good extd_apicid pni cx16 lahf_lm cmp_legacy svm extapic cr8_legacy"))))
        'amd-v)

  (test (cpuinfo-kvm-support
         '(((processor . "0")
            (model-name . "AMD Foo")
            (flags . "fpu"))
           ((processor . "1")
            (model-name . "AMD Bar")
            (flags . "fpu vme de pse tsc msr pae mce cx8 apic mtrr pge mca cmov pat pse36 clflush mmx fxsr sse sse2 ht syscall nx mmxext fxsr_opt rdtscp lm 3dnowext 3dnow rep_good extd_apicid pni cx16 lahf_lm cmp_legacy svm extapic cr8_legacy"))))
        'amd-v))

(doc (section "Known Issues")

     (itemlist

      (item
       "Need testing with a broader range of "
       (filepath "/proc/cpuinfo")
       ", for different kinds of processors.")

      (item
       "Could use info about operating systems that do not provide "
       (filepath "/proc/cpuinfo")
       ", but provide some other practical means to get CPU information.")

      (item
       "The code for counting physical processors, cores, and hyperthreading is
not exposed.  This is intentional, since the interface is more likely to
change, but it could be exposed anyway.")

      (item
       "Would be nice if we could get the "
       (hyperlink "http://www.intel.com/support/processors/sb/cs-016552.htm"
                  "Intel sSpec")
       " number, but we'd have to keep and update a large table, and (from
perusing Intel specs pages) it looks like sometimes we couldn't narrow it down
to a single number and we'd have to yield a list of possible ones instead of
the exact one.  Or we might at least provide an Intel CPUID feature.  See "
       (hyperlink "http://ark.intel.com/" "Intel ARK")
       " and "
       (hyperlink "http://world.std.com/~swmcd/steven/tech/cpu.html"
                  "Steven W. McDougall's page on identifying Intel CPUs"))))

(doc history

     (#:planet 1:1 #:date "2013-01-12"
               (itemlist

                (item "Added support for Raspberry Pi running Raspbian.")))

     (#:planet 1:0 #:date "2012-11-15"
               (itemlist

                (item "Initial release."))))