From 4b92b047ed6c5ce6ea3141b66279892b46f15c93 Mon Sep 17 00:00:00 2001 From: Mackenzie Straight Date: Sat, 25 Dec 2004 10:49:30 +0000 Subject: [PATCH] More Win32 IO work; FFI updates --- library/io/buffer.factor | 75 +++++++++++++++------ library/io/win32-console.factor | 2 + library/io/win32-io-internals.factor | 79 ++++++++++++++++++++-- library/io/win32-stream.factor | 98 ++++++++++++++++++++++++++-- library/win32/win32-errors.factor | 12 ++++ library/win32/win32-io.factor | 12 ++++ native/ffi.c | 30 +++++++++ native/ffi.h | 4 ++ native/relocate.c | 3 +- native/unix/ffi.c | 34 ++-------- native/win32/ffi.c | 40 +++--------- 11 files changed, 298 insertions(+), 91 deletions(-) diff --git a/library/io/buffer.factor b/library/io/buffer.factor index 20092ea5a3..0a44ef0716 100644 --- a/library/io/buffer.factor +++ b/library/io/buffer.factor @@ -25,7 +25,7 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: buffer +IN: kernel-internals USE: alien USE: errors @@ -36,49 +36,76 @@ USE: namespaces USE: strings USE: win32-api +SYMBOL: buf-size +SYMBOL: buf-ptr +SYMBOL: buf-fill +SYMBOL: buf-pos + : imalloc ( size -- address ) "int" "libc" "malloc" [ "int" ] alien-invoke ; : ifree ( address -- ) "void" "libc" "free" [ "int" ] alien-invoke ; +: irealloc ( address size -- address ) + "int" "libc" "realloc" [ "int" "int" ] alien-invoke ; + : ( size -- buffer ) #! Allocates and returns a new buffer. [ - dup "size" set - imalloc "buffer" set - 0 "fill" set - 0 "pos" set + dup buf-size set + imalloc buf-ptr set + 0 buf-fill set + 0 buf-pos set ] extend ; : buffer-free ( buffer -- ) #! Frees the C memory associated with the buffer. - [ "buffer" get ifree ] bind ; + [ buf-ptr get ifree ] bind ; : buffer-contents ( buffer -- string ) #! Returns the current contents of the buffer. [ - "buffer" get "pos" get + - "fill" get "pos" get - + buf-ptr get buf-pos get + + buf-fill get buf-pos get - memory>string ] bind ; +: buffer-first-n ( count buffer -- string ) + [ + buf-fill get buf-pos get - min + buf-ptr get buf-pos get + + swap memory>string + ] bind ; + : buffer-reset ( count buffer -- ) #! Reset the position to 0 and the fill pointer to count. - [ 0 "pos" set "fill" set ] bind ; + [ 0 buf-pos set buf-fill set ] bind ; : buffer-consume ( count buffer -- ) #! Consume count characters from the beginning of the buffer. - [ "pos" [ + "fill" get min ] change ] bind ; + [ + buf-pos [ + buf-fill get min ] change + buf-pos get buf-fill get = [ + 0 buf-pos set 0 buf-fill set + ] when + ] bind ; : buffer-length ( buffer -- length ) #! Returns the amount of unconsumed input in the buffer. - [ "fill" get "pos" get - max ] bind ; + [ buf-fill get buf-pos get - 0 max ] bind ; + +: buffer-size ( buffer -- size ) + [ buf-size get ] bind ; + +: buffer-capacity ( buffer -- int ) + #! Returns the amount of data that may be added to the buffer. + [ buf-size get buf-fill get - ] bind ; : buffer-set ( string buffer -- ) #! Set the contents of a buffer to string. [ - dup "buffer" get string>memory + dup buf-ptr get string>memory str-length namespace buffer-reset ] bind ; @@ -86,19 +113,27 @@ USE: win32-api #! Appends a string to the end of the buffer. If it doesn't fit, #! an error is thrown. [ - dup "size" get "fill" get - swap str-length < [ + dup buf-size get buf-fill get - swap str-length < [ "Buffer overflow" throw ] when - dup "buffer" get "fill" get + string>memory - "fill" [ swap str-length + ] change + dup buf-ptr get buf-fill get + string>memory + buf-fill [ swap str-length + ] change ] bind ; -: buffer-fill ( buffer quot -- ) - #! Execute quot with buffer as its argument, passing its result to - #! buffer-reset. - swap dup >r swap call r> buffer-reset ; inline +: buffer-extend ( length buffer -- ) + #! Increases the size of the buffer by length. + [ + buf-size get + dup buf-ptr get swap irealloc + buf-ptr set buf-size set + ] bind ; + +: buffer-fill ( count buffer -- ) + #! Increases the fill pointer by count. + [ buf-fill [ + ] change ] bind ; : buffer-ptr ( buffer -- pointer ) #! Returns the memory address of the buffer area. - [ "buffer" get ] bind ; + [ buf-ptr get ] bind ; +: buffer-pos ( buffer -- int ) + [ buf-ptr get buf-pos get + ] bind ; diff --git a/library/io/win32-console.factor b/library/io/win32-console.factor index 9d55898db8..ffaef4524f 100644 --- a/library/io/win32-console.factor +++ b/library/io/win32-console.factor @@ -84,3 +84,5 @@ M: win32-console-stream fwrite-attr ( string style stream -- ) C: win32-console-stream ( stream -- stream ) [ delegate set -11 GetStdHandle handle set ] extend ; +global [ [ ] smart-term-hook set ] bind + diff --git a/library/io/win32-io-internals.factor b/library/io/win32-io-internals.factor index 1d75e98cfb..4d668c35ae 100644 --- a/library/io/win32-io-internals.factor +++ b/library/io/win32-io-internals.factor @@ -27,20 +27,42 @@ IN: win32-io-internals USE: alien +USE: errors USE: kernel +USE: kernel-internals USE: lists USE: math USE: namespaces +USE: prettyprint +USE: vectors USE: win32-api +SYMBOL: completion-port +SYMBOL: io-queue +SYMBOL: free-list +SYMBOL: callbacks + +: handle-io-error ( -- ) + #! If a write or read call fails unexpectedly, throw an error. + GetLastError [ + ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS + ] contains? [ + win32-throw-error + ] unless ; + : win32-init-stdio ( -- ) INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort - "completion-port" set ; + completion-port set + + [ + 32 callbacks set + f free-list set + ] extend io-queue set ; : get-access ( -- file-mode ) - 0 "file-mode" get uncons >r - [ GENERIC_WRITE ] [ 0 ] ifte bitor r> - [ GENERIC_READ ] [ 0 ] ifte bitor ; + "file-mode" get uncons + [ GENERIC_WRITE ] [ 0 ] ifte >r + [ GENERIC_READ ] [ 0 ] ifte r> bitor ; : get-sharemode ( -- share-mode ) FILE_SHARE_READ FILE_SHARE_WRITE bitor FILE_SHARE_DELETE bitor ; @@ -57,6 +79,53 @@ USE: win32-api cons "file-mode" set get-access get-sharemode NULL get-create FILE_FLAG_OVERLAPPED NULL CreateFile dup INVALID_HANDLE_VALUE = [ win32-throw-error ] when - dup "completion-port" get NULL 1 CreateIoCompletionPort drop + dup completion-port get NULL 1 CreateIoCompletionPort drop ] with-scope ; +BEGIN-STRUCT: indirect-pointer + FIELD: int value +END-STRUCT + +: num-callbacks ( -- len ) + #! Returns the length of the callback vector. + io-queue get [ callbacks get vector-length ] bind ; + +: set-callback-quot ( quot index -- ) + io-queue get [ + dup >r callbacks get vector-nth car swap cons + r> callbacks get set-vector-nth + ] bind ; + +: new-overlapped ( -- index ) + #! Allocates and returns a new entry for the io queue. + #! The new index in the callback vector is returned. + io-queue get [ + "overlapped-ext" c-type [ "width" get ] bind imalloc + dup num-callbacks swap + set-overlapped-ext-user-data + unit num-callbacks dup >r callbacks get set-vector-nth r> + ] bind ; + +: alloc-io-task ( quot -- overlapped ) + io-queue get [ + free-list get [ + uncons free-list set + ] [ new-overlapped ] ifte* + [ set-callback-quot ] keep + callbacks get vector-nth car + ] bind ; + +: get-io-callback ( index -- callback ) + #! Returns and frees the io queue entry at index. + io-queue get [ + dup free-list [ cons ] change + callbacks get vector-nth cdr + ] bind ; + +: win32-next-io-task ( -- quot ) + completion-port get dup >r + dup >r INFINITE GetQueuedCompletionStatus + [ handle-io-error ] unless + r> r> indirect-pointer-value swap indirect-pointer-value + overlapped-ext-user-data get-io-callback call ; + diff --git a/library/io/win32-stream.factor b/library/io/win32-stream.factor index 230b75f435..c50219bc2d 100644 --- a/library/io/win32-stream.factor +++ b/library/io/win32-stream.factor @@ -27,38 +27,122 @@ IN: win32-stream USE: alien -USE: buffer +USE: continuations USE: generic USE: kernel +USE: kernel-internals USE: lists USE: math USE: namespaces +USE: prettyprint USE: stdio USE: streams +USE: strings +USE: threads USE: win32-api USE: win32-io-internals TRAITS: win32-stream -GENERIC: update-file-pointer + +SYMBOL: handle +SYMBOL: in-buffer +SYMBOL: out-buffer +SYMBOL: fileptr +SYMBOL: file-size + +: init-overlapped ( overlapped -- overlapped ) + 0 over set-overlapped-ext-internal + 0 over set-overlapped-ext-internal-high + fileptr get over set-overlapped-ext-offset + 0 over set-overlapped-ext-offset-high + 0 over set-overlapped-ext-event ; + +: update-file-pointer ( whence -- ) + file-size get [ fileptr [ + ] change ] when ; + +: flush-output ( -- ) + [ + alloc-io-task init-overlapped >r + handle get out-buffer get [ buffer-pos ] keep buffer-length + NULL r> WriteFile [ handle-io-error ] unless win32-next-io-task + ] callcc1 + + dup out-buffer get [ buffer-consume ] keep + swap namespace update-file-pointer + buffer-length 0 > [ flush-output ] when ; + +: do-write ( str -- ) + dup str-length out-buffer get buffer-capacity <= [ + out-buffer get buffer-append + ] [ + dup str-length out-buffer get buffer-size > [ + dup str-length out-buffer get buffer-extend do-write + ] [ flush-output do-write ] ifte + ] ifte ; + +: fill-input ( -- ) + [ + alloc-io-task init-overlapped >r + handle get in-buffer get [ buffer-pos ] keep + buffer-capacity file-size get [ fileptr get - min ] when* + NULL r> + ReadFile [ handle-io-error ] unless win32-next-io-task + ] callcc1 + + dup in-buffer get buffer-fill + namespace update-file-pointer ; + +: consume-input ( count -- str ) + in-buffer get buffer-length 0 = [ fill-input ] when + in-buffer get buffer-size min + dup in-buffer get buffer-first-n + swap in-buffer get buffer-consume ; + +: do-read-count ( sbuf count -- str ) + dup 0 = [ + drop sbuf>str + ] [ + dup consume-input + dup str-length dup 0 = [ + 3drop dup sbuf-length 0 > [ sbuf>str ] [ drop f ] ifte + ] [ + >r swap r> - >r swap [ sbuf-append ] keep r> do-read-count + ] ifte + ] ifte ; M: win32-stream fwrite-attr ( str style stream -- ) - nip fwrite ; + nip [ do-write ] bind ; M: win32-stream freadln ( stream -- str ) drop f ; M: win32-stream fread# ( count stream -- str ) - drop f ; + [ dup swap do-read-count ] bind ; M: win32-stream fflush ( stream -- ) - drop ; + [ flush-output ] bind ; M: win32-stream fclose ( stream -- ) - [ "handle" get CloseHandle drop "buffer" get buffer-free ] bind ; + [ + flush-output + handle get CloseHandle drop + in-buffer get buffer-free + out-buffer get buffer-free + ] bind ; C: win32-stream ( handle -- stream ) - [ "handle" set 4096 "buffer" set 0 "fp" set ] extend ; + [ + dup NULL GetFileSize dup INVALID_FILE_SIZE = not [ + file-size set + ] [ drop f file-size set ] ifte + handle set + 4096 in-buffer set + 4096 out-buffer set + 0 fileptr set + ] extend ; : ( path -- stream ) t f win32-open-file ; +: ( path -- stream ) + f t win32-open-file ; diff --git a/library/win32/win32-errors.factor b/library/win32/win32-errors.factor index e1c957a205..541b6876ab 100644 --- a/library/win32/win32-errors.factor +++ b/library/win32/win32-errors.factor @@ -29,8 +29,20 @@ IN: win32-api USE: buffer USE: errors USE: kernel +USE: kernel-internals +USE: lists USE: math +USE: parser USE: alien +USE: words + +: CONSTANT: CREATE + [ [ [ parsed ] each ] cons define-compound POSTPONE: parsing ] + [ ] ; parsing + +CONSTANT: ERROR_SUCCESS 0 ; +CONSTANT: ERROR_HANDLE_EOF 38 ; +CONSTANT: ERROR_IO_PENDING 997 ; : FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ; : FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 ; diff --git a/library/win32/win32-io.factor b/library/win32/win32-io.factor index b9957af9b8..e4b906d538 100644 --- a/library/win32/win32-io.factor +++ b/library/win32/win32-io.factor @@ -70,10 +70,16 @@ END-STRUCT : STD_ERROR_HANDLE -12 ; : INVALID_HANDLE_VALUE -1 ; +: INVALID_FILE_SIZE HEX: FFFFFFFF ; + +: INFINITE HEX: FFFFFFFF ; : GetStdHandle ( id -- handle ) "void*" "kernel32" "GetStdHandle" [ "int" ] alien-invoke ; +: GetFileSize ( handle out -- int ) + "int" "kernel32" "GetFileSize" [ "void*" "void*" ] alien-invoke ; + : SetConsoleTextAttribute ( handle attrs -- ? ) "bool" "kernel32" "SetConsoleTextAttribute" [ "void*" "int" ] alien-invoke ; @@ -99,6 +105,12 @@ END-STRUCT [ "void*" "void*" "void*" "int" ] alien-invoke ; +: GetQueuedCompletionStatus + ( port out-len out-key out-overlapped timeout -- ? ) + "bool" "kernel32" "GetQueuedCompletionStatus" + [ "void*" "void*" "void*" "void*" "int" ] + alien-invoke ; + : CreateFile ( name access sharemode security create flags template -- handle ) "void*" "kernel32" "CreateFileA" [ "char*" "int" "int" "void*" "int" "int" "void*" ] diff --git a/native/ffi.c b/native/ffi.c index b2b6f16e3f..732a374956 100644 --- a/native/ffi.c +++ b/native/ffi.c @@ -1,5 +1,35 @@ #include "factor.h" +void primitive_dlopen(void) +{ + maybe_garbage_collection(); + dpush(tag_object(ffi_dlopen(untag_string(dpop())))); +} + +void primitive_dlsym(void) +{ + DLL *dll; + F_STRING *sym; + + maybe_garbage_collection(); + + dll = untag_dll(dpop()); + sym = untag_string(dpop()); + dpush(tag_cell(ffi_dlsym(dll, sym))); +} + +void primitive_dlclose(void) +{ + maybe_garbage_collection(); + ffi_dlclose(untag_dll(dpop())); +} + +void primitive_dlsym_self(void) +{ + maybe_garbage_collection(); + dpush(tag_cell(ffi_dlsym(NULL, untag_string(dpop())))); +} + DLL* untag_dll(CELL tagged) { DLL* dll = (DLL*)UNTAG(tagged); diff --git a/native/ffi.h b/native/ffi.h index ad3df14a62..15838ce2bc 100644 --- a/native/ffi.h +++ b/native/ffi.h @@ -18,6 +18,10 @@ INLINE ALIEN* untag_alien(CELL tagged) return (ALIEN*)UNTAG(tagged); } +DLL *ffi_dlopen(F_STRING *path); +void *ffi_dlsym(DLL *dll, F_STRING *symbol); +void ffi_dlclose(DLL *dll); + void primitive_dlopen(void); void primitive_dlsym(void); void primitive_dlsym_self(void); diff --git a/native/relocate.c b/native/relocate.c index 7bb290a70f..fd5d43fcde 100644 --- a/native/relocate.c +++ b/native/relocate.c @@ -106,8 +106,7 @@ void relocate_primitive(F_REL* rel, bool relative) void relocate_dlsym(F_REL* rel, bool relative) { F_STRING* str = untag_string(get(rel->argument)); - char* c_str = to_c_string(str); - put(rel->offset,(CELL)dlsym(NULL,c_str) + put(rel->offset,(CELL)ffi_dlsym(NULL,str) - (relative ? rel->offset + CELLS : 0)); } diff --git a/native/unix/ffi.c b/native/unix/ffi.c index 9915b8e30b..e5c30a8868 100644 --- a/native/unix/ffi.c +++ b/native/unix/ffi.c @@ -1,16 +1,12 @@ #include "../factor.h" -void primitive_dlopen(void) +DLL *ffi_dlopen(F_STRING *path) { #ifdef FFI - char* path; void* dllptr; DLL* dll; - maybe_garbage_collection(); - - path = unbox_c_string(); - dllptr = dlopen(path,RTLD_LAZY); + dllptr = dlopen(to_c_string(path), RTLD_LAZY); if(dllptr == NULL) { @@ -20,47 +16,31 @@ void primitive_dlopen(void) dll = allot_object(DLL_TYPE,sizeof(DLL)); dll->dll = dllptr; - dpush(tag_object(dll)); + return dll; #else general_error(ERROR_FFI_DISABLED,F); #endif } -void primitive_dlsym(void) +void *ffi_dlsym(DLL *dll, F_STRING *symbol) { #ifdef FFI - DLL* dll = untag_dll(dpop()); - void* sym = dlsym(dll->dll,unbox_c_string()); + void* sym = dlsym(dll ? dll->dll : NULL, to_c_string(symbol)); if(sym == NULL) { general_error(ERROR_FFI,tag_object( from_c_string(dlerror()))); } - dpush(tag_cell((CELL)sym)); + return sym; #else general_error(ERROR_FFI_DISABLED,F); #endif } -void primitive_dlsym_self(void) -{ -#if defined(FFI) - void* sym = dlsym(NULL,unbox_c_string()); - if(sym == NULL) - { - general_error(ERROR_FFI,tag_object( - from_c_string(dlerror()))); - } - dpush(tag_cell((CELL)sym)); -#else - general_error(ERROR_FFI_DISABLED,F); -#endif -} -void primitive_dlclose(void) +void ffi_dlclose(DLL *dll) { #ifdef FFI - DLL* dll = untag_dll(dpop()); if(dlclose(dll->dll) == -1) { general_error(ERROR_FFI,tag_object( diff --git a/native/win32/ffi.c b/native/win32/ffi.c index 3adf154632..c03679707a 100644 --- a/native/win32/ffi.c +++ b/native/win32/ffi.c @@ -1,66 +1,46 @@ #include "../factor.h" -void primitive_dlopen (void) +DLL *ffi_dlopen (F_STRING *path) { #ifdef FFI - char *path; HMODULE module; DLL *dll; - maybe_garbage_collection(); - - path = unbox_c_string(); - module = LoadLibrary(path); + module = LoadLibrary(to_c_string(path)); if (!module) general_error(ERROR_FFI, tag_object(last_error())); dll = allot_object(DLL_TYPE, sizeof(DLL)); dll->dll = module; - dpush(tag_object(dll)); + + return dll; #else general_error(ERROR_FFI_DISABLED, F); #endif } -void primitive_dlsym (void) +void *ffi_dlsym (DLL *dll, F_STRING *symbol) { #ifdef FFI - DLL *dll = untag_dll(dpop()); - void *sym = GetProcAddress((HMODULE)dll->dll, unbox_c_string()); - + void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL), + to_c_string(symbol)); if (!sym) general_error(ERROR_FFI, tag_object(last_error())); - dpush(tag_cell((CELL)sym)); + return sym; #else general_error(ERROR_FFI_DISABLED, F); #endif } -void primitive_dlclose (void) +void ffi_dlclose (DLL *dll) { #ifdef FFI - DLL *dll = untag_dll(dpop()); FreeLibrary((HMODULE)dll->dll); dll->dll = NULL; #else general_error(ERROR_FFI_DISABLED, F); #endif -} - -void primitive_dlsym_self (void) -{ -#ifdef FFI - void *sym = GetProcAddress(GetModuleHandle(NULL), unbox_c_string()); - - if(sym == NULL) - { - general_error(ERROR_FFI, tag_object(last_error())); - } - dpush(tag_cell((CELL)sym)); -#else - general_error(ERROR_FFI_DISABLED, F); -#endif -} +} \ No newline at end of file