Changeset 10641


Ignore:
Timestamp:
Sep 8, 2008, 6:06:18 AM (11 years ago)
Author:
gb
Message:

Enviromental inquiry changes for Windows.
Handle TIME reporting differently, to account for Windows differences.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/misc.lisp

    r10336 r10641  
    3030(defun machine-instance ()
    3131  "Return a string giving the name of the local machine."
    32   (%uname 1))
     32  #-windows-target (%uname 1)
     33  #+windows-target
     34  (rlet ((nsize #>DWORD 0))
     35    (if (eql 0 (#_GetComputerNameExW #$ComputerNameDnsFullyQualified
     36                                     +null-ptr+
     37                                     nsize))
     38      (%stack-block ((buf (* 2 (pref nsize #>DWORD))))
     39        (#_GetComputerNameExW #$ComputerNameDnsFullyQualified
     40                              buf
     41                              nsize)
     42        (%get-native-utf-16-cstring buf))
     43      "localhost"))
     44  )
    3345
    3446
    3547(defun machine-type ()
    3648  "Returns a string describing the type of the local machine."
    37   (%uname 4))
     49  #-windows-target (%uname 4)
     50  #+windows-target
     51  (rlet ((info #>SYSTEM_INFO))
     52    (#_GetSystemInfo info)
     53    (case (pref info #>SYSTEM_INFO.nil.nil.wProcessorArchitecture)
     54      (#.#$PROCESSOR_ARCHITECTURE_AMD64 "x64")
     55      (#.#$PROCESSOR_ARCHITECTURE_INTEL "x86")
     56      (t "unknown")))
     57  )
    3858
    3959
     
    95115                            #$P_ONLINE))
    96116                    (%get-cstring (pref info :processor_info_t.pi_processor_type)))))
     117            #+windows-target
     118            (getenv "PROCESSOR_IDENTIFIER")
    97119            )))
    98120
     
    100122(defun software-type ()
    101123  "Return a string describing the supporting software."
    102   (%uname 0))
     124  #-windows-target (%uname 0)
     125  #+windows-target "Microsoft Windows")
    103126
    104127
     
    106129  "Return a string describing version of the supporting software, or NIL
    107130   if not available."
    108   (%uname 2))
     131  #-windows-target (%uname 2)
     132  #+windows-target
     133  (rletZ ((info #>OSVERSIONINFOEX))
     134    (setf (pref info #>OSVERSIONINFOEX.dwOSVersionInfoSize)
     135          (record-length #>OSVERSIONINFOEX))
     136    (#_GetVersionExA info)
     137    (format nil "~d.~d Build ~d (~a)"
     138            (pref info #>OSVERSIONINFOEX.dwMajorVersion)
     139            (pref info #>OSVERSIONINFOEX.dwMinorVersion)
     140            (pref info #>OSVERSIONINFOEX.dwBuildNumber)
     141            (if (eql (pref info #>OSVERSIONINFOEX.wProductType)
     142                     #$VER_NT_WORKSTATION)
     143              "Workstation"
     144              "Server")))
     145  )
    109146
    110147
     
    375412;;
    376413
     414
     415(defun %page-fault-info ()
     416  #-(or darwin-target windows-target)
     417  (rlet ((usage :rusage))
     418    (%%rusage usage)
     419    (values (pref usage :rusage.ru_minflt)
     420            (pref usage :rusage.ru_majflt)
     421            (pref usage :rusage.ru_nswap)))
     422  #+darwin-target
     423  (rlet ((count #>mach_msg_type_number_t #$TASK_EVENTS_INFO_COUNT)
     424         (info #>task_events_info))
     425    (#_task_info (#_mach_task_self) #$TASK_EVENTS_INFO info count)
     426    (values (pref info #>task_events_info.cow_faults)
     427            (pref info #>task_events_info.faults)
     428            (pref info #>task_events_info.pageins)))
     429  #+windows-target
     430  ;; Um, don't know how to determine this, or anything like it.
     431  (values 0 0 0))
     432
     433
     434         
    377435(defparameter *report-time-function* nil
    378436  "If non-NULL, should be a function which accepts the following
     
    428486             0
    429487             (* (logand (+ 2 (uvsize i)) (lognot 1)) 4))))
    430     (rlet ((start :rusage)
    431            (stop :rusage)
    432            (timediff :timeval))
    433       (let* ((initial-real-time (get-internal-real-time))
    434              (initial-gc-time (gctime))
    435              (initial-consed (total-bytes-allocated))           
    436              (initial-overhead (integer-size-in-bytes initial-consed)))
    437         (%%rusage start)
    438         (let* ((results (multiple-value-list (funcall thunk))))
    439           (declare (dynamic-extent results))
    440           (%%rusage stop)         
    441           (let* ((new-consed (total-bytes-allocated))               
    442                  (bytes-consed
    443                   (- new-consed (+ initial-overhead initial-consed)))
    444                  (elapsed-real-time
    445                   (- (get-internal-real-time) initial-real-time))
    446                  (elapsed-gc-time (- (gctime) initial-gc-time))
    447                  (elapsed-user-time
    448                   (progn
    449                     (%sub-timevals timediff
    450                                    (pref stop :rusage.ru_utime)
    451                                    (pref start :rusage.ru_utime))
    452                     (ecase internal-time-units-per-second
    453                       (1000000 (timeval->microseconds timediff))
    454                       (1000 (timeval->milliseconds timediff)))))
    455                  (elapsed-system-time
    456                   (progn
    457                     (%sub-timevals timediff
    458                                    (pref stop :rusage.ru_stime)
    459                                    (pref start :rusage.ru_stime))
    460                     (ecase internal-time-units-per-second
    461                       (1000000 (timeval->microseconds timediff))
    462                       (1000 (timeval->milliseconds timediff)))))
    463                  (elapsed-minor (- (pref stop :rusage.ru_minflt)
    464                                    (pref start :rusage.ru_minflt)))
    465                  (elapsed-major (- (pref stop :rusage.ru_majflt)
    466                                    (pref start :rusage.ru_majflt)))
    467                  (elapsed-swaps (- (pref stop :rusage.ru_nswap)
    468                                    (pref start :rusage.ru_nswap))))
    469             (funcall (or *report-time-function*
    470                          #'standard-report-time)
    471                      :form form
    472                      :results results
    473                      :elapsed-time elapsed-real-time
    474                      :user-time elapsed-user-time
    475                      :system-time elapsed-system-time
    476                      :gc-time elapsed-gc-time
    477                      :bytes-allocated bytes-consed
    478                      :minor-page-faults elapsed-minor
    479                      :major-page-faults elapsed-major
    480                      :swaps elapsed-swaps)))))))
     488    (multiple-value-bind (user-start system-start)
     489        (%internal-run-time)
     490      (multiple-value-bind (minor-start major-start swaps-start)
     491          (%page-fault-info)
     492        (let* ((initial-real-time (get-internal-real-time))
     493               (initial-gc-time (gctime))
     494               (initial-consed (total-bytes-allocated))           
     495               (initial-overhead (integer-size-in-bytes initial-consed)))
     496          (let* ((results (multiple-value-list (funcall thunk))))
     497            (declare (dynamic-extent results))
     498            (multiple-value-bind (user-end system-end)
     499                (%internal-run-time)
     500              (multiple-value-bind (minor-end major-end swaps-end)
     501                  (%page-fault-info)
     502                (let* ((new-consed (total-bytes-allocated))                 
     503                       (bytes-consed
     504                        (- new-consed (+ initial-overhead initial-consed)))
     505                       (elapsed-real-time
     506                        (- (get-internal-real-time) initial-real-time))
     507                       (elapsed-gc-time (- (gctime) initial-gc-time))
     508                       (elapsed-user-time
     509                        (- user-end user-start))
     510                       (elapsed-system-time
     511                        (- system-end system-start))
     512                       (elapsed-minor (- minor-end minor-start))
     513                       (elapsed-major (- major-end major-start))
     514                       (elapsed-swaps (- swaps-end swaps-start)))
     515                  (funcall (or *report-time-function*
     516                               #'standard-report-time)
     517                           :form form
     518                           :results results
     519                           :elapsed-time elapsed-real-time
     520                           :user-time elapsed-user-time
     521                           :system-time elapsed-system-time
     522                           :gc-time elapsed-gc-time
     523                           :bytes-allocated bytes-consed
     524                           :minor-page-faults elapsed-minor
     525                           :major-page-faults elapsed-major
     526                           :swaps elapsed-swaps))))))))))
    481527
    482528
     
    717763(%fhave 'df #'disassemble)
    718764
     765(defloadvar *use-cygwin-svn*
     766    #+windows-target (not (null (getenv "CYGWIN")))
     767    #-windows-target nil)
     768
    719769(defun svn-info-component (component)
    720770  (let* ((component-length (length component)))
     
    769819     (when f (read f)))
    770820   (with-output-to-string (s)
    771     (multiple-value-bind (status exit-code)
    772         (external-process-status
    773          (run-program "svnversion"  (list  (native-translated-namestring "ccl:") (or (svn-url) "")):output s))
    774       (when (and (eq :exited status) (zerop exit-code))
    775         (with-input-from-string (output (get-output-stream-string s))
    776           (let* ((line (read-line output nil nil)))
    777             (when (and line (parse-integer line :junk-allowed t) )
    778               (return-from local-svn-revision line)))))))))
     821     (let* ((root (native-translated-namestring "ccl:")))
     822       (when *use-cygwin-svn*
     823         (setq root (cygpath root)))
     824       (multiple-value-bind (status exit-code)
     825           (external-process-status
     826            (run-program "svnversion"  (list  (native-translated-namestring "ccl:") (or (svn-url) "")):output s))
     827         (when (and (eq :exited status) (zerop exit-code))
     828           (with-input-from-string (output (get-output-stream-string s))
     829             (let* ((line (read-line output nil nil)))
     830               (when (and line (parse-integer line :junk-allowed t) )
     831                 (return-from local-svn-revision line))))))))))
    779832
    780833
Note: See TracChangeset for help on using the changeset viewer.