Changeset 10652


Ignore:
Timestamp:
Sep 8, 2008, 11:36:57 AM (11 years ago)
Author:
gb
Message:

Windows changes.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-0/l0-cfm-support.lisp

    r10281 r10652  
    7878(defvar *rtld-default*)
    7979(setq *rtld-next* (%incf-ptr (%null-ptr) -1)
    80       *rtld-default* (%int-to-ptr #+(or linux-target darwin-target)  0
    81                                   #-(or linux-target darwin-target)  -2))
     80      *rtld-default* (%int-to-ptr #+(or linux-target darwin-target wwindow-target)  0
     81                                  #-(or linux-target darwin-target windows-target)  -2))
    8282
    8383#+(or linux-target freebsd-target solaris-target)
     
    459459
    460460;;; end darwin-target
     461  ) 
     462
     463#+windows-target
     464(progn
     465  (defvar *current-process-handle*)
     466  (defvar *enum-process-modules-addr*)
     467  (defvar *get-module-file-name-addr*)
     468  (defvar *get-module-base-name-addr*)
     469  (defvar *get-module-handle-ex-addr*)
     470
     471
     472  (defun init-windows-ffi ()
     473    (setq *current-process-handle* (ff-call (foreign-symbol-entry "GetCurrentProcess") :address))
     474    (setq *enum-process-modules-addr* (foreign-symbol-entry "EnumProcessModules"))   
     475    (setq *get-module-file-name-addr* (foreign-symbol-entry "GetModuleFileNameA"))
     476    (setq *get-module-base-name-addr* (foreign-symbol-entry "GetModuleBaseNameA"))
     477    (setq *get-module-handle-ex-addr* (foreign-symbol-entry "GetModuleHandleExA")))
     478
     479  (init-windows-ffi)
     480 
     481  (defun hmodule-pathname (hmodule)
     482    (do* ((bufsize 64))
     483         ()
     484      (%stack-block ((name bufsize))
     485        (let* ((needed (ff-call *get-module-file-name-addr*
     486                                :address *current-process-handle*
     487                                :address hmodule
     488                                :address name
     489                                :signed-fullword bufsize
     490                                :signed-fullword)))
     491          (if (eql 0 needed)
     492            (return nil)
     493            (if (< bufsize needed)
     494              (setq bufsize needed)
     495              (return (%str-from-ptr name needed))))))))
     496
     497  (defun hmodule-basename (hmodule)
     498    (do* ((bufsize 64))
     499         ()
     500      (%stack-block ((name bufsize))
     501        (let* ((needed (ff-call *get-module-base-name-addr*
     502                                :address *current-process-handle*
     503                                :address hmodule
     504                                :address name
     505                                :signed-fullword bufsize
     506                                :signed-fullword)))
     507          (if (eql 0 needed)
     508            (return nil)
     509            (if (< bufsize needed)
     510              (setq bufsize needed)
     511              (return (%str-from-ptr name needed))))))))
     512
     513  (defun existing-shlib-for-hmodule (hmodule)
     514    (dolist (shlib *shared-libraries*)
     515      (when (eql hmodule (shlib.map shlib)) (return shlib))))
     516     
     517 
     518  (defun shared-library-from-hmodule (hmodule)
     519    (or (existing-shlib-for-hmodule hmodule)
     520        (let* ((shlib (%cons-shlib (hmodule-basename hmodule)
     521                                   (hmodule-pathname hmodule)
     522                                   hmodule
     523                                   hmodule)))
     524          (push shlib *shared-libraries*)
     525          shlib)))
     526
     527  (defun for-each-loaded-module (f)
     528    (let* ((have (* 16 (record-length #>HMODULE))))
     529      (rlet ((pneed #>DWORD))
     530        (loop
     531          (%stack-block ((modules have))
     532            (ff-call *enum-process-modules-addr*
     533                     :address *current-process-handle*
     534                     :address modules
     535                     #>DWORD have
     536                     :address pneed)
     537            (let* ((need (pref pneed #>DWORD)))
     538              (if (> need have)
     539                (setq have need)
     540                (return
     541                  (do* ((i 0 (+ i (record-length #>HMODULE))))
     542                       ((= i need))
     543                    (funcall f (%get-ptr modules i)))))))))))
     544
     545  (defun init-shared-libraries ()
     546    (for-each-loaded-module #'shared-library-from-hmodule))
     547 
     548  (defun shlib-containing-entry (addr &optional name)
     549    (with-macptrs ((p (%int-to-ptr addr)))
     550      (shlib-containing-address p name)))
     551
     552  (defun shlib-containing-address (addr &optional name)
     553    (declare (ignore name))
     554    (rlet ((phmodule :address +null-ptr+))
     555      (let* ((found (ff-call *get-module-handle-ex-addr*
     556                             #>DWORD (logior
     557                                      #$GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS
     558                                      #$GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT)
     559                             :address addr
     560                             :address phmodule
     561                             #>BOOL)))
     562        (unless (eql 0 found)
     563          (let* ((hmodule (pref phmodule :address)))
     564            (dolist (lib *shared-libraries*)
     565              (when (eql (shlib.map lib)  hmodule)
     566                (return lib))))))))
     567
     568
     569  (defun open-shared-library (name)
     570    "If the library denoted by name can be loaded by the operating system,
     571return an object of type SHLIB that describes the library; if the library
     572is already open, increment a reference count. If the library can't be
     573loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from
     574the operating system."
     575    (let* ((hmodule (with-cstrs ((name name))
     576                      (ff-call
     577                       (%kernel-import target::kernel-import-GetSharedLibrary)
     578                       :address name
     579                       :unsigned-fullword 0
     580                       :address)))
     581           (shlib (unless (%null-ptr-p hmodule)
     582                    (shared-library-from-hmodule hmodule))))
     583      (if shlib
     584        (progn
     585          (incf (shlib.opencount shlib))
     586          (setf (shlib.handle shlib) hmodule)
     587          shlib)
     588        (error "Can't open shared library ~s" name))))
     589
     590(init-shared-libraries)
     591
     592;;; end windows-target
    461593
    462594
     
    638770)
    639771
    640 #-(or linux-target darwin-target freebsd-target solaris-target)
     772#-(or linux-target darwin-target freebsd-target solaris-target windows-target)
    641773(defun shlib-containing-entry (entry &optional name)
    642774  (declare (ignore entry name))
     
    686818    (resolve-eep eep nil)
    687819    eep))
    688 
    689 
    690820
    691821(defun load-fv (name type)
Note: See TracChangeset for help on using the changeset viewer.