Changeset 8717


Ignore:
Timestamp:
Mar 11, 2008, 6:43:10 PM (11 years ago)
Author:
gb
Message:

Need windows support here; started to add some. Obviously untested
and may not even compile.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/win64/level-0/l0-cfm-support.lisp

    r8587 r8717  
    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 windows-target)  0
     81                                  #-(or linux-target darwin-target windows-target)  -2))
    8282
    8383#+(or linux-target freebsd-target)
     
    458458
    459459;;; end darwin-target
     460  ) 
     461
     462#+windows-target
     463(progn
     464  (defvar *current-process-handle* (ff-call (foreign-symbol-entry "GetCurrentProcess") :address))
     465  (defvar *enum-process-modules-addr* (foreign-symbol-entry "EnumProcessModules"))
     466  (defvar *get-module-file-name-addr* (foreign-symbol-entry "GetModuleFileName"))
     467  (defvar *get-module-base-name-addr* (foreign-symbol-entry "GetModuleBaseName"))
     468  (defvar *get-module-handle-ex-addr* (foreign-symbol-entry "GetModuleHandleEx"))
     469 
     470  (defun hmodule-pathname (hmodule)
     471    (do* ((bufsize 64))
     472         ()
     473      (%stack-block ((name bufsize))
     474        (let* ((needed (ff-call *get-module-file-name-addr*
     475                                :address *current-process-handle*
     476                                :address hmodule
     477                                :address buf
     478                                :signed-fullword bufsize)))
     479          (if (eql 0 needed)
     480            (return nil)
     481            (if (< bufsize needed)
     482              (setq bufsize needed)
     483              (%str-from-ptr buf needed)))))))
     484
     485  (defun hmodule-basename (hmodule)
     486    (do* ((bufsize 64))
     487         ()
     488      (%stack-block ((name bufsize))
     489        (let* ((needed (ff-call *get-module-base-name-addr*
     490                                :address *current-process-handle*
     491                                :address hmodule
     492                                :address buf
     493                                :signed-fullword bufsize)))
     494          (if (eql 0 needed)
     495            (return nil)
     496            (if (< bufsize needed)
     497              (setq bufsize needed)
     498              (%str-from-ptr buf needed)))))))
     499
     500  (defun existing-shlib-for-hmodule (hmodule)
     501    (dolist (shlib *shared-libraries*)
     502      (when (eql hmodule (shlib.map shlib)) (return shlib))))
     503     
     504 
     505  (defun shared-library-from-hmodule (hmodule)
     506    (or (existing-shlib-for-hmodule hmodule)
     507        (let* ((shlib (%cons-shlib (hmodule-basename hmodule)
     508                                   (hmodule-pathname hmodule)
     509                                   hmodule
     510                                   hmodule)))
     511          (push shlib *shared-libraries*)
     512          shlib)))
     513
     514  (defun shlib-containing-entry (addr &optional name)
     515    (shlib-containing-address addr name))
     516
     517  (defun shlib-containing-address (addr &optional name)
     518    (declare (ignore name))
     519    (rlet ((phmodule :address +null-ptr+))
     520      (let* ((found (ff-call *get-module-handle-ex-addr*
     521                             :>DWORD (logior
     522                                      GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS
     523                                      GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT)
     524                             :address addr
     525                             :address phmodule
     526                             :>BOOL)))
     527        (unless (eql 0 found)
     528          (let* ((hmodule (pref phmodule :address)))
     529            (dolist (lib *shared-libraries*)
     530              (when (eql (shlib.map lib)  hmodule)
     531                (return lib))))))))
     532
     533  (defun open-shared-library (name)
     534    "If the library denoted by name can be loaded by the operating system,
     535return an object of type SHLIB that describes the library; if the library
     536is already open, increment a reference count. If the library can't be
     537loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from
     538the operating system."
     539    (let* ((hmodule (with-cstrs ((name name))
     540                      (ff-call
     541                       (%kernel-import target::kernel-import-GetSharedLibrary)
     542                       :address name
     543                       :unsigned-fullword 0
     544                       :address)))
     545           (shlib (unless (%null-ptr-p hmodule)
     546                    (shared-library-from-hmodule hmodule))))
     547      (if shlib
     548        (progn
     549          (incf (shlib.opencount shlib))
     550          (setf (shlib.handle shlib) hmodule)
     551          shlib)
     552        (error "Can't open shared library ~s" name))))
     553
     554  (defun iterate-over-hmodules (f)
     555    ;; El-bizarro Windows interface
     556    (%stack-block ((pcbneeded 4))       ; sizeof #>DWORD
     557      (do* ((cb 64))
     558           ()
     559        (%stack-block ((modules cbneeded))
     560          (ff-call *enum-process-modules-addr*
     561                   :address *current-process-handle*
     562                   :address modules
     563                   #>DWORD cb
     564                   :address pcbneeded)
     565          (let* ((cbneeded (pref pcbneeded #>DWORD)))
     566            (if (< cb
     567 
     568
     569           
     570;;; end windows-target
    460571
    461572
     
    612723)
    613724
    614 #-(or linux-target darwin-target freebsd-target)
     725#-(or linux-target darwin-target freebsd-target windows-target)
    615726(defun shlib-containing-entry (entry &optional name)
    616727  (declare (ignore entry name))
Note: See TracChangeset for help on using the changeset viewer.