Ignore:
Timestamp:
Oct 14, 2008, 6:30:00 PM (13 years ago)
Author:
gz
Message:

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/misc.lisp

    r10938 r11089  
    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
     
    88108                  (%get-cstring ret)
    89109                  1)))
     110            #+solaris-target
     111            (rlet ((info :processor_info_t))
     112              (do* ((i 0 (1+ i)))
     113                   ((and (= 0 (#_processor_info i info))
     114                         (= (pref info :processor_info_t.pi_state)
     115                            #$P_ONLINE))
     116                    (%get-cstring (pref info :processor_info_t.pi_processor_type)))))
     117            #+windows-target
     118            (getenv "PROCESSOR_IDENTIFIER")
    90119            )))
    91120
     
    93122(defun software-type ()
    94123  "Return a string describing the supporting software."
    95   (%uname 0))
     124  #-windows-target (%uname 0)
     125  #+windows-target "Microsoft Windows")
    96126
    97127
     
    99129  "Return a string describing version of the supporting software, or NIL
    100130   if not available."
    101   (%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  )
    102146
    103147
     
    365409;;
    366410
     411
     412(defun %page-fault-info ()
     413  #-(or darwin-target windows-target)
     414  (rlet ((usage :rusage))
     415    (%%rusage usage)
     416    (values (pref usage :rusage.ru_minflt)
     417            (pref usage :rusage.ru_majflt)
     418            (pref usage :rusage.ru_nswap)))
     419  #+darwin-target
     420  (rlet ((count #>mach_msg_type_number_t #$TASK_EVENTS_INFO_COUNT)
     421         (info #>task_events_info))
     422    (#_task_info (#_mach_task_self) #$TASK_EVENTS_INFO info count)
     423    (values (pref info #>task_events_info.cow_faults)
     424            (pref info #>task_events_info.faults)
     425            (pref info #>task_events_info.pageins)))
     426  #+windows-target
     427  ;; Um, don't know how to determine this, or anything like it.
     428  (values 0 0 0))
     429
     430
     431         
    367432(defparameter *report-time-function* nil
    368433  "If non-NULL, should be a function which accepts the following
     
    418483             0
    419484             (* (logand (+ 2 (uvsize i)) (lognot 1)) 4))))
    420     (rlet ((start :rusage)
    421            (stop :rusage)
    422            (timediff :timeval))
    423       (let* ((initial-real-time (get-internal-real-time))
    424              (initial-gc-time (gctime))
    425              (initial-consed (total-bytes-allocated))           
    426              (initial-overhead (integer-size-in-bytes initial-consed)))
    427         (%%rusage start)
    428         (let* ((results (multiple-value-list (funcall thunk))))
    429           (declare (dynamic-extent results))
    430           (%%rusage stop)         
    431           (let* ((new-consed (total-bytes-allocated))               
    432                  (bytes-consed
    433                   (- new-consed (+ initial-overhead initial-consed)))
    434                  (elapsed-real-time
    435                   (- (get-internal-real-time) initial-real-time))
    436                  (elapsed-gc-time (- (gctime) initial-gc-time))
    437                  (elapsed-user-time
    438                   (progn
    439                     (%sub-timevals timediff
    440                                    (pref stop :rusage.ru_utime)
    441                                    (pref start :rusage.ru_utime))
    442                     (ecase internal-time-units-per-second
    443                       (1000000 (timeval->microseconds timediff))
    444                       (1000 (timeval->milliseconds timediff)))))
    445                  (elapsed-system-time
    446                   (progn
    447                     (%sub-timevals timediff
    448                                    (pref stop :rusage.ru_stime)
    449                                    (pref start :rusage.ru_stime))
    450                     (ecase internal-time-units-per-second
    451                       (1000000 (timeval->microseconds timediff))
    452                       (1000 (timeval->milliseconds timediff)))))
    453                  (elapsed-minor (- (pref stop :rusage.ru_minflt)
    454                                    (pref start :rusage.ru_minflt)))
    455                  (elapsed-major (- (pref stop :rusage.ru_majflt)
    456                                    (pref start :rusage.ru_majflt)))
    457                  (elapsed-swaps (- (pref stop :rusage.ru_nswap)
    458                                    (pref start :rusage.ru_nswap))))
    459             (funcall (or *report-time-function*
    460                          #'standard-report-time)
    461                      :form form
    462                      :results results
    463                      :elapsed-time elapsed-real-time
    464                      :user-time elapsed-user-time
    465                      :system-time elapsed-system-time
    466                      :gc-time elapsed-gc-time
    467                      :bytes-allocated bytes-consed
    468                      :minor-page-faults elapsed-minor
    469                      :major-page-faults elapsed-major
    470                      :swaps elapsed-swaps)))))))
     485    (multiple-value-bind (user-start system-start)
     486        (%internal-run-time)
     487      (multiple-value-bind (minor-start major-start swaps-start)
     488          (%page-fault-info)
     489        (let* ((initial-real-time (get-internal-real-time))
     490               (initial-gc-time (gctime))
     491               (initial-consed (total-bytes-allocated))           
     492               (initial-overhead (integer-size-in-bytes initial-consed)))
     493          (let* ((results (multiple-value-list (funcall thunk))))
     494            (declare (dynamic-extent results))
     495            (multiple-value-bind (user-end system-end)
     496                (%internal-run-time)
     497              (multiple-value-bind (minor-end major-end swaps-end)
     498                  (%page-fault-info)
     499                (let* ((new-consed (total-bytes-allocated))                 
     500                       (bytes-consed
     501                        (- new-consed (+ initial-overhead initial-consed)))
     502                       (elapsed-real-time
     503                        (- (get-internal-real-time) initial-real-time))
     504                       (elapsed-gc-time (- (gctime) initial-gc-time))
     505                       (elapsed-user-time
     506                        (- user-end user-start))
     507                       (elapsed-system-time
     508                        (- system-end system-start))
     509                       (elapsed-minor (- minor-end minor-start))
     510                       (elapsed-major (- major-end major-start))
     511                       (elapsed-swaps (- swaps-end swaps-start)))
     512                  (funcall (or *report-time-function*
     513                               #'standard-report-time)
     514                           :form form
     515                           :results results
     516                           :elapsed-time elapsed-real-time
     517                           :user-time elapsed-user-time
     518                           :system-time elapsed-system-time
     519                           :gc-time elapsed-gc-time
     520                           :bytes-allocated bytes-consed
     521                           :minor-page-faults elapsed-minor
     522                           :major-page-faults elapsed-major
     523                           :swaps elapsed-swaps))))))))))
    471524
    472525
     
    684737  disassemble."
    685738  (#+ppc-target ppc-xdisassemble
     739   #+x8632-target x8632-xdisassemble
    686740   #+x8664-target x8664-xdisassemble
    687741   (require-type (function-for-disassembly thing) 'compiled-function)))
     
    705759
    706760(%fhave 'df #'disassemble)
     761
     762(defloadvar *use-cygwin-svn*
     763    #+windows-target (not (null (getenv "CYGWIN")))
     764    #-windows-target nil)
    707765
    708766(defun svn-info-component (component)
     
    758816     (when f (read f)))
    759817   (with-output-to-string (s)
    760     (multiple-value-bind (status exit-code)
    761         (external-process-status
    762          (run-program "svnversion"  (list  (native-translated-namestring "ccl:") (or (svn-url) "")):output s))
    763       (when (and (eq :exited status) (zerop exit-code))
    764         (with-input-from-string (output (get-output-stream-string s))
    765           (let* ((line (read-line output nil nil)))
    766             (when (and line (parse-integer line :junk-allowed t) )
    767               (return-from local-svn-revision line)))))))))
     818     (let* ((root (native-translated-namestring "ccl:")))
     819       (when *use-cygwin-svn*
     820         (setq root (cygpath root)))
     821       (multiple-value-bind (status exit-code)
     822           (external-process-status
     823            (run-program "svnversion"  (list  (native-translated-namestring "ccl:") (or (svn-url) "")):output s))
     824         (when (and (eq :exited status) (zerop exit-code))
     825           (with-input-from-string (output (get-output-stream-string s))
     826             (let* ((line (read-line output nil nil)))
     827               (when (and line (parse-integer line :junk-allowed t) )
     828                 (return-from local-svn-revision line))))))))))
    768829
    769830
     
    782843    (when gc-first (gc))
    783844    (%map-areas (lambda (thing)
    784                   (if (consp thing)
     845                  (if (listp thing)
    785846                    (incf nconses)
    786847                    (let* ((typecode (typecode thing)))
     
    823884                    ((= lowtag ppc64::lowtag-nodeheader)
    824885                     (%svref *nodeheader-types* (ash i -2)))))))
    825     #+ppc32-target
     886    #+(or ppc32-target x8632-target)
    826887    (dotimes (i 256)
    827       (let* ((fulltag (logand i ppc32::fulltagmask)))
     888      (let* ((fulltag (logand i target::fulltagmask)))
    828889        (setf (%svref a i)
    829               (cond ((= fulltag ppc32::fulltag-immheader)
     890              (cond ((= fulltag target::fulltag-immheader)
    830891                     (%svref *immheader-types* (ash i -3)))
    831                     ((= fulltag ppc32::fulltag-nodeheader)
     892                    ((= fulltag target::fulltag-nodeheader)
    832893                     (%svref *nodeheader-types* (ash i -3)))))))
    833894    a))
     
    861922  "Allocates some memory, freezes it and lets it become garbage.
    862923   This will add the memory to the list of free static conses."
    863   (let ((l (make-array *static-cons-chunk*)))
     924  (let ((l (make-array (1- (* 2 *static-cons-chunk*)))))
    864925    (declare (ignore l))
    865926    (freeze))
     
    883944       
    884945
     946(defparameter *weak-gc-method-names*
     947  '((:traditional . 0)
     948    (:non-circular . 1)))
     949
     950
     951(defun weak-gc-method ()
     952  (or (car (rassoc (%get-kernel-global 'weak-gc-method)
     953                   *weak-gc-method-names*))
     954      :traditional))
     955
     956
     957(defun (setf weak-gc-method) (name)
     958  (setf (%get-kernel-global 'weak-gc-method)
     959        (or (cdr (assoc name *weak-gc-method-names*))
     960            0))
     961  name)
Note: See TracChangeset for help on using the changeset viewer.