From 6a658506085fae99c827d7c7a4a1f714bb45cbc0 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Mon, 22 Jun 2009 23:06:07 +0200 Subject: [PATCH 01/55] WIP: crude xt>name disassembler help --- basis/tools/disassembler/udis/udis.factor | 9 +++-- basis/tools/disassembler/utils/utils.factor | 41 +++++++++++++++++++++ 2 files changed, 47 insertions(+), 3 deletions(-) create mode 100644 basis/tools/disassembler/utils/utils.factor diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index df624cab28..2f0456ab62 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -3,7 +3,8 @@ USING: tools.disassembler namespaces combinators alien alien.syntax alien.c-types lexer parser kernel sequences layouts math math.order alien.libraries -math.parser system make fry arrays libc destructors ; +math.parser system make fry arrays libc destructors +tools.disassembler.utils splitting ; IN: tools.disassembler.udis << @@ -103,19 +104,21 @@ FUNCTION: char* ud_lookup_mnemonic ( int c ) ; dup UD_SYN_INTEL ud_set_syntax ; : with-ud ( quot: ( ud -- ) -- ) - [ [ ] dip call ] with-destructors ; inline + [ [ [ ] dip call ] with-destructors ] with-words-xt ; inline SINGLETON: udis-disassembler : buf/len ( from to -- buf len ) [ drop ] [ swap - ] 2bi ; +: resolve-call ( str -- str' ) "0x" split1-last [ resolve-xt append ] when* ; + : format-disassembly ( lines -- lines' ) dup [ second length ] [ max ] map-reduce '[ [ [ first >hex cell 2 * CHAR: 0 pad-head % ": " % ] [ second _ CHAR: \s pad-tail % " " % ] - [ third % ] + [ third resolve-call % ] tri ] "" make ] map ; diff --git a/basis/tools/disassembler/utils/utils.factor b/basis/tools/disassembler/utils/utils.factor new file mode 100644 index 0000000000..fb936cf08a --- /dev/null +++ b/basis/tools/disassembler/utils/utils.factor @@ -0,0 +1,41 @@ +USING: accessors arrays binary-search kernel math math.order +math.parser namespaces sequences sorting splitting vectors vocabs words ; +IN: tools.disassembler.utils + +SYMBOL: words-xt +SYMBOL: smallest-xt +SYMBOL: greatest-xt + +: (words-xt) ( -- assoc ) + vocabs [ words ] map concat [ [ word-xt ] keep 3array ] map + [ [ first ] bi@ <=> ] sort >vector ; + +: complete-address ( n seq -- str ) + [ first - ] [ third name>> ] bi + over zero? [ nip ] [ swap 16 >base "0x" prepend "+" glue ] if ; + +: search-xt ( n -- str/f ) + dup [ smallest-xt get < ] [ greatest-xt get > ] bi or [ + drop f + ] [ + words-xt get over [ swap first <=> ] curry search nip + 2dup second <= [ + [ complete-address ] [ drop f ] if* + ] [ + 2drop f + ] if + ] if ; + +: resolve-xt ( str -- str' ) + [ "0x" prepend ] [ 16 base> ] bi + [ search-xt [ " (" ")" surround append ] when* ] when* ; + +: resolve-call ( str -- str' ) + "0x" split1-last [ resolve-xt "0x" glue ] when* ; + +: with-words-xt ( quot -- ) + [ (words-xt) + [ words-xt set ] + [ first first smallest-xt set ] + [ last second greatest-xt set ] tri + ] prepose with-scope ; inline From 3507616f3ba86092740da54c1284d1ab27f69151 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 25 Aug 2009 17:23:23 -0500 Subject: [PATCH 02/55] use structs in a few places in windows backend --- basis/io/backend/windows/nt/nt.factor | 2 +- basis/io/backend/windows/windows.factor | 8 ++--- basis/io/files/info/windows/windows.factor | 35 ++++++++-------------- basis/windows/kernel32/kernel32.factor | 33 ++++++++++---------- 4 files changed, 35 insertions(+), 43 deletions(-) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 69a695ac72..e29aa6c618 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -3,7 +3,7 @@ destructors io io.backend io.ports io.timeouts io.backend.windows io.files.windows io.files.windows.nt io.files io.pathnames io.buffers io.streams.c io.streams.null libc kernel math namespaces sequences threads windows windows.errors windows.kernel32 strings splitting -ascii system accessors locals ; +ascii system accessors locals classes.struct ; QUALIFIED: windows.winsock IN: io.backend.windows.nt diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 5922e217b0..c7be2229cc 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -4,7 +4,8 @@ USING: alien alien.c-types arrays destructors io io.backend io.buffers io.files io.ports io.binary io.timeouts system strings kernel math namespaces sequences windows.errors windows.kernel32 windows.shell32 windows.types windows.winsock -splitting continuations math.bitwise accessors init sets assocs ; +splitting continuations math.bitwise accessors init sets assocs +classes.struct classes ; IN: io.backend.windows TUPLE: win32-handle < disposable handle ; @@ -50,6 +51,5 @@ HOOK: add-completion io-backend ( port -- ) } flags ; foldable : default-security-attributes ( -- obj ) - "SECURITY_ATTRIBUTES" - "SECURITY_ATTRIBUTES" heap-size - over set-SECURITY_ATTRIBUTES-nLength ; + SECURITY_ATTRIBUTES + dup class heap-size >>nLength ; diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 38165e4267..248eacf571 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -5,7 +5,7 @@ io.files.windows io.files.windows.nt kernel windows.kernel32 windows.time windows accessors alien.c-types combinators generalizations system alien.strings io.encodings.utf16n sequences splitting windows.errors fry continuations destructors -calendar ascii combinators.short-circuit locals ; +calendar ascii combinators.short-circuit locals classes.struct ; IN: io.files.info.windows :: round-up-to ( n multiple -- n' ) @@ -57,35 +57,26 @@ TUPLE: windows-file-info < file-info attributes ; : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info ) [ \ windows-file-info new ] dip { - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ] - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ] + [ dwFileAttributes>> win32-file-type >>type ] + [ dwFileAttributes>> win32-file-attributes >>attributes ] [ - [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] - [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size + [ nFileSizeLow>> ] + [ nFileSizeHigh>> ] bi >64bit >>size ] - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ] - [ - BY_HANDLE_FILE_INFORMATION-ftCreationTime - FILETIME>timestamp >>created - ] - [ - BY_HANDLE_FILE_INFORMATION-ftLastWriteTime - FILETIME>timestamp >>modified - ] - [ - BY_HANDLE_FILE_INFORMATION-ftLastAccessTime - FILETIME>timestamp >>accessed - ] - ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ] + [ dwFileAttributes>> >>permissions ] + [ ftCreationTime>> FILETIME>timestamp >>created ] + [ ftLastWriteTime>> FILETIME>timestamp >>modified ] + [ ftLastAccessTime>> FILETIME>timestamp >>accessed ] + ! [ nNumberOfLinks>> ] ! [ - ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ] - ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit + ! [ nFileIndexLow>> ] + ! [ nFileIndexHigh>> ] bi >64bit ! ] } cleave ; : get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION ) [ - "BY_HANDLE_FILE_INFORMATION" + BY_HANDLE_FILE_INFORMATION [ GetFileInformationByHandle win32-error=0/f ] keep ] keep CloseHandle win32-error=0/f ; diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 38c63abc72..d1fee4c388 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax kernel windows.types multiline ; +USING: alien alien.syntax kernel windows.types multiline +classes.struct ; IN: windows.kernel32 CONSTANT: MAX_PATH 260 @@ -707,17 +708,17 @@ C-STRUCT: WIN32_FIND_DATA { { "TCHAR" 260 } "cFileName" } { { "TCHAR" 14 } "cAlternateFileName" } ; -C-STRUCT: BY_HANDLE_FILE_INFORMATION - { "DWORD" "dwFileAttributes" } - { "FILETIME" "ftCreationTime" } - { "FILETIME" "ftLastAccessTime" } - { "FILETIME" "ftLastWriteTime" } - { "DWORD" "dwVolumeSerialNumber" } - { "DWORD" "nFileSizeHigh" } - { "DWORD" "nFileSizeLow" } - { "DWORD" "nNumberOfLinks" } - { "DWORD" "nFileIndexHigh" } - { "DWORD" "nFileIndexLow" } ; +STRUCT: BY_HANDLE_FILE_INFORMATION + { dwFileAttributes DWORD } + { ftCreationTime FILETIME } + { ftLastAccessTime FILETIME } + { ftLastWriteTime FILETIME } + { dwVolumeSerialNumber DWORD } + { nFileSizeHigh DWORD } + { nFileSizeLow DWORD } + { nNumberOfLinks DWORD } + { nFileIndexHigh DWORD } + { nFileIndexLow DWORD } ; TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA @@ -737,10 +738,10 @@ TYPEDEF: PFILETIME LPFILETIME TYPEDEF: int GET_FILEEX_INFO_LEVELS -C-STRUCT: SECURITY_ATTRIBUTES - { "DWORD" "nLength" } - { "LPVOID" "lpSecurityDescriptor" } - { "BOOL" "bInheritHandle" } ; +STRUCT: SECURITY_ATTRIBUTES + { nLength DWORD } + { lpSecurityDescriptor LPVOID } + { bInheritHandle BOOL } ; CONSTANT: HANDLE_FLAG_INHERIT 1 CONSTANT: HANDLE_FLAG_PROTECT_FROM_CLOSE 2 From c50eaf1c29a0b40ec330e3b33716a00bca5ef8ff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 25 Aug 2009 17:34:06 -0500 Subject: [PATCH 03/55] less aggressive open-file for file-times, use FILETIME struct now --- .../files/info/windows/windows-tests.factor | 6 +++++ basis/io/files/info/windows/windows.factor | 8 +++---- basis/windows/kernel32/kernel32.factor | 24 +++++++++---------- basis/windows/time/time.factor | 16 +++++-------- 4 files changed, 28 insertions(+), 26 deletions(-) create mode 100755 basis/io/files/info/windows/windows-tests.factor diff --git a/basis/io/files/info/windows/windows-tests.factor b/basis/io/files/info/windows/windows-tests.factor new file mode 100755 index 0000000000..8728c2c31c --- /dev/null +++ b/basis/io/files/info/windows/windows-tests.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test io.files.info.windows system kernel ; +IN: io.files.info.windows.tests + +[ ] [ vm file-times 3drop ] unit-test diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 248eacf571..587747ac34 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -188,10 +188,10 @@ M: winnt file-systems ( -- array ) : file-times ( path -- timestamp timestamp timestamp ) [ - normalize-path open-existing &dispose handle>> - "FILETIME" - "FILETIME" - "FILETIME" + normalize-path open-read &dispose handle>> + FILETIME + FILETIME + FILETIME [ GetFileTime win32-error=0/f ] 3keep [ FILETIME>timestamp >local-time ] tri@ ] with-destructors ; diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index d1fee4c388..65425c2685 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -216,15 +216,15 @@ C-STRUCT: OVERLAPPED { "DWORD" "offset-high" } { "HANDLE" "event" } ; -C-STRUCT: SYSTEMTIME - { "WORD" "wYear" } - { "WORD" "wMonth" } - { "WORD" "wDayOfWeek" } - { "WORD" "wDay" } - { "WORD" "wHour" } - { "WORD" "wMinute" } - { "WORD" "wSecond" } - { "WORD" "wMilliseconds" } ; +STRUCT: SYSTEMTIME + { wYear WORD } + { wMonth WORD } + { wDayOfWeek WORD } + { wDay WORD } + { wHour WORD } + { wMinute WORD } + { wSecond WORD } + { wMilliseconds WORD } ; C-STRUCT: TIME_ZONE_INFORMATION { "LONG" "Bias" } @@ -235,9 +235,9 @@ C-STRUCT: TIME_ZONE_INFORMATION { "SYSTEMTIME" "DaylightDate" } { "LONG" "DaylightBias" } ; -C-STRUCT: FILETIME - { "DWORD" "dwLowDateTime" } - { "DWORD" "dwHighDateTime" } ; +STRUCT: FILETIME + { dwLowDateTime DWORD } + { dwHighDateTime DWORD } ; C-STRUCT: STARTUPINFO { "DWORD" "cb" } diff --git a/basis/windows/time/time.factor b/basis/windows/time/time.factor index 71726a554a..1fe3ad065c 100644 --- a/basis/windows/time/time.factor +++ b/basis/windows/time/time.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types kernel math windows.errors -windows.kernel32 namespaces calendar math.bitwise ; +windows.kernel32 namespaces calendar math.bitwise accessors +classes.struct ; IN: windows.time : >64bit ( lo hi -- n ) @@ -11,15 +12,13 @@ IN: windows.time 1601 1 1 0 0 0 instant ; : FILETIME>windows-time ( FILETIME -- n ) - [ FILETIME-dwLowDateTime ] - [ FILETIME-dwHighDateTime ] - bi >64bit ; + [ dwLowDateTime>> ] [ dwHighDateTime>> ] bi >64bit ; : windows-time>timestamp ( n -- timestamp ) 10000000 /i seconds windows-1601 swap time+ ; : windows-time ( -- n ) - "FILETIME" [ GetSystemTimeAsFileTime ] keep + FILETIME [ GetSystemTimeAsFileTime ] keep FILETIME>windows-time ; : timestamp>windows-time ( timestamp -- n ) @@ -27,11 +26,8 @@ IN: windows.time >gmt windows-1601 (time-) 10000000 * >integer ; : windows-time>FILETIME ( n -- FILETIME ) - "FILETIME" - [ - [ [ 32 bits ] dip set-FILETIME-dwLowDateTime ] - [ [ -32 shift ] dip set-FILETIME-dwHighDateTime ] 2bi - ] keep ; + [ FILETIME ] dip + [ 32 bits >>dwLowDateTime ] [ -32 shift >>dwHighDateTime ] bi ; : timestamp>FILETIME ( timestamp -- FILETIME/f ) dup [ >gmt timestamp>windows-time windows-time>FILETIME ] when ; From 003db124e244d5001b0f74fc6b17a73d2553cf56 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 25 Aug 2009 17:46:07 -0500 Subject: [PATCH 04/55] use structs in process launcher --- basis/io/launcher/windows/nt/nt.factor | 10 ++--- basis/io/launcher/windows/windows.factor | 22 +++++------ basis/windows/kernel32/kernel32.factor | 48 ++++++++++++------------ 3 files changed, 40 insertions(+), 40 deletions(-) diff --git a/basis/io/launcher/windows/nt/nt.factor b/basis/io/launcher/windows/nt/nt.factor index e62373cbd7..16d9cbf6c9 100755 --- a/basis/io/launcher/windows/nt/nt.factor +++ b/basis/io/launcher/windows/nt/nt.factor @@ -85,7 +85,7 @@ IN: io.launcher.windows.nt : redirect-stderr ( process args -- handle ) over stderr>> +stdout+ eq? [ nip - lpStartupInfo>> STARTUPINFO-hStdOutput + lpStartupInfo>> hStdOutput>> ] [ drop stderr>> @@ -104,7 +104,7 @@ IN: io.launcher.windows.nt STD_INPUT_HANDLE GetStdHandle or ; M: winnt fill-redirection ( process args -- ) - [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput - [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError - [ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput - 2drop ; + dup lpStartupInfo>> + [ [ redirect-stdout ] dip (>>hStdOutput) ] + [ [ redirect-stderr ] dip (>>hStdError) ] + [ [ redirect-stdin ] dip (>>hStdInput) ] 3tri ; diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index d17cd1ff80..45aeec0a80 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -7,7 +7,7 @@ namespaces make io.launcher kernel sequences windows.errors splitting system threads init strings combinators io.backend accessors concurrency.flags io.files assocs io.files.private windows destructors specialized-arrays.ushort -specialized-arrays.alien ; +specialized-arrays.alien classes classes.struct ; IN: io.launcher.windows TUPLE: CreateProcess-args @@ -24,9 +24,10 @@ TUPLE: CreateProcess-args : default-CreateProcess-args ( -- obj ) CreateProcess-args new - "STARTUPINFO" - "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo - "PROCESS_INFORMATION" >>lpProcessInformation + STARTUPINFO + dup class heap-size >>cb + >>lpStartupInfo + PROCESS_INFORMATION >>lpProcessInformation TRUE >>bInheritHandles 0 >>dwCreateFlags ; @@ -108,7 +109,7 @@ TUPLE: CreateProcess-args ] when ; : fill-startup-info ( process args -- process args ) - STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ; + dup lpStartupInfo>> STARTF_USESTDHANDLES >>dwFlags drop ; HOOK: fill-redirection io-backend ( process args -- ) @@ -136,17 +137,16 @@ M: windows run-process* ( process -- handle ) ] with-destructors ; M: windows kill-process* ( handle -- ) - PROCESS_INFORMATION-hProcess - 255 TerminateProcess win32-error=0/f ; + hProcess>> 255 TerminateProcess win32-error=0/f ; : dispose-process ( process-information -- ) #! From MSDN: "Handles in PROCESS_INFORMATION must be closed #! with CloseHandle when they are no longer needed." - dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* - PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; + [ hProcess>> [ CloseHandle drop ] when* ] + [ hThread>> [ CloseHandle drop ] when* ] bi ; : exit-code ( process -- n ) - PROCESS_INFORMATION-hProcess + hProcess>> 0 [ GetExitCodeProcess ] keep *ulong swap win32-error=0/f ; @@ -157,7 +157,7 @@ M: windows kill-process* ( handle -- ) M: windows wait-for-processes ( -- ? ) processes get keys dup - [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as + [ handle>> hProcess>> ] void*-array{ } map-as [ length ] keep 0 0 WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 65425c2685..2e8be04717 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -239,33 +239,33 @@ STRUCT: FILETIME { dwLowDateTime DWORD } { dwHighDateTime DWORD } ; -C-STRUCT: STARTUPINFO - { "DWORD" "cb" } - { "LPTSTR" "lpReserved" } - { "LPTSTR" "lpDesktop" } - { "LPTSTR" "lpTitle" } - { "DWORD" "dwX" } - { "DWORD" "dwY" } - { "DWORD" "dwXSize" } - { "DWORD" "dwYSize" } - { "DWORD" "dwXCountChars" } - { "DWORD" "dwYCountChars" } - { "DWORD" "dwFillAttribute" } - { "DWORD" "dwFlags" } - { "WORD" "wShowWindow" } - { "WORD" "cbReserved2" } - { "LPBYTE" "lpReserved2" } - { "HANDLE" "hStdInput" } - { "HANDLE" "hStdOutput" } - { "HANDLE" "hStdError" } ; +STRUCT: STARTUPINFO + { cb DWORD } + { lpReserved LPTSTR } + { lpDesktop LPTSTR } + { lpTitle LPTSTR } + { dwX DWORD } + { dwY DWORD } + { dwXSize DWORD } + { dwYSize DWORD } + { dwXCountChars DWORD } + { dwYCountChars DWORD } + { dwFillAttribute DWORD } + { dwFlags DWORD } + { wShowWindow WORD } + { cbReserved2 WORD } + { lpReserved2 LPBYTE } + { hStdInput HANDLE } + { hStdOutput HANDLE } + { hStdError HANDLE } ; TYPEDEF: void* LPSTARTUPINFO -C-STRUCT: PROCESS_INFORMATION - { "HANDLE" "hProcess" } - { "HANDLE" "hThread" } - { "DWORD" "dwProcessId" } - { "DWORD" "dwThreadId" } ; +STRUCT: PROCESS_INFORMATION + { hProcess HANDLE } + { hThread HANDLE } + { dwProcessId DWORD } + { dwThreadId DWORD } ; C-STRUCT: SYSTEM_INFO { "DWORD" "dwOemId" } From d109126c4bd568c737b02198e78f4774f1044284 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 25 Aug 2009 18:19:34 -0500 Subject: [PATCH 05/55] more structs --- basis/windows/kernel32/kernel32.factor | 60 ++++++++++++------------ extra/system-info/windows/nt/nt.factor | 21 +++++---- extra/system-info/windows/windows.factor | 8 ++-- 3 files changed, 45 insertions(+), 44 deletions(-) diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 2e8be04717..50a03945f3 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -267,42 +267,42 @@ STRUCT: PROCESS_INFORMATION { dwProcessId DWORD } { dwThreadId DWORD } ; -C-STRUCT: SYSTEM_INFO - { "DWORD" "dwOemId" } - { "DWORD" "dwPageSize" } - { "LPVOID" "lpMinimumApplicationAddress" } - { "LPVOID" "lpMaximumApplicationAddress" } - { "DWORD_PTR" "dwActiveProcessorMask" } - { "DWORD" "dwNumberOfProcessors" } - { "DWORD" "dwProcessorType" } - { "DWORD" "dwAllocationGranularity" } - { "WORD" "wProcessorLevel" } - { "WORD" "wProcessorRevision" } ; +STRUCT: SYSTEM_INFO + { dwOemId DWORD } + { dwPageSize DWORD } + { lpMinimumApplicationAddress LPVOID } + { lpMaximumApplicationAddress LPVOID } + { dwActiveProcessorMask DWORD_PTR } + { dwNumberOfProcessors DWORD } + { dwProcessorType DWORD } + { dwAllocationGranularity DWORD } + { wProcessorLevel WORD } + { wProcessorRevision WORD } ; TYPEDEF: void* LPSYSTEM_INFO -C-STRUCT: MEMORYSTATUS - { "DWORD" "dwLength" } - { "DWORD" "dwMemoryLoad" } - { "SIZE_T" "dwTotalPhys" } - { "SIZE_T" "dwAvailPhys" } - { "SIZE_T" "dwTotalPageFile" } - { "SIZE_T" "dwAvailPageFile" } - { "SIZE_T" "dwTotalVirtual" } - { "SIZE_T" "dwAvailVirtual" } ; +STRUCT: MEMORYSTATUS + { dwLength DWORD } + { dwMemoryLoad DWORD } + { dwTotalPhys SIZE_T } + { dwAvailPhys SIZE_T } + { dwTotalPageFile SIZE_T } + { dwAvailPageFile SIZE_T } + { dwTotalVirtual SIZE_T } + { dwAvailVirtual SIZE_T } ; TYPEDEF: void* LPMEMORYSTATUS -C-STRUCT: MEMORYSTATUSEX - { "DWORD" "dwLength" } - { "DWORD" "dwMemoryLoad" } - { "DWORDLONG" "ullTotalPhys" } - { "DWORDLONG" "ullAvailPhys" } - { "DWORDLONG" "ullTotalPageFile" } - { "DWORDLONG" "ullAvailPageFile" } - { "DWORDLONG" "ullTotalVirtual" } - { "DWORDLONG" "ullAvailVirtual" } - { "DWORDLONG" "ullAvailExtendedVirtual" } ; +STRUCT: MEMORYSTATUSEX + { dwLength DWORD } + { dwMemoryLoad DWORD } + { ullTotalPhys DWORDLONG } + { ullAvailPhys DWORDLONG } + { ullTotalPageFile DWORDLONG } + { ullAvailPageFile DWORDLONG } + { ullTotalVirtual DWORDLONG } + { ullAvailVirtual DWORDLONG } + { ullAvailExtendedVirtual DWORDLONG } ; TYPEDEF: void* LPMEMORYSTATUSEX diff --git a/extra/system-info/windows/nt/nt.factor b/extra/system-info/windows/nt/nt.factor index 3e0cffe71d..a6b4c8176f 100755 --- a/extra/system-info/windows/nt/nt.factor +++ b/extra/system-info/windows/nt/nt.factor @@ -3,37 +3,38 @@ USING: alien alien.c-types alien.strings kernel libc math namespaces system-info.backend system-info.windows windows windows.advapi32 -windows.kernel32 system byte-arrays windows.errors ; +windows.kernel32 system byte-arrays windows.errors +classes classes.struct ; IN: system-info.windows.nt M: winnt cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; : memory-status ( -- MEMORYSTATUSEX ) - "MEMORYSTATUSEX" - "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength + "MEMORYSTATUSEX" + dup class heap-size >>dwLength dup GlobalMemoryStatusEx win32-error=0/f ; M: winnt memory-load ( -- n ) - memory-status MEMORYSTATUSEX-dwMemoryLoad ; + memory-status dwMemoryLoad>> ; M: winnt physical-mem ( -- n ) - memory-status MEMORYSTATUSEX-ullTotalPhys ; + memory-status ullTotalPhys>> ; M: winnt available-mem ( -- n ) - memory-status MEMORYSTATUSEX-ullAvailPhys ; + memory-status ullAvailPhys>> ; M: winnt total-page-file ( -- n ) - memory-status MEMORYSTATUSEX-ullTotalPageFile ; + memory-status ullTotalPageFile>> ; M: winnt available-page-file ( -- n ) - memory-status MEMORYSTATUSEX-ullAvailPageFile ; + memory-status ullAvailPageFile>> ; M: winnt total-virtual-mem ( -- n ) - memory-status MEMORYSTATUSEX-ullTotalVirtual ; + memory-status ullTotalVirtual>> ; M: winnt available-virtual-mem ( -- n ) - memory-status MEMORYSTATUSEX-ullAvailVirtual ; + memory-status ullAvailVirtual>> ; : computer-name ( -- string ) MAX_COMPUTERNAME_LENGTH 1 + diff --git a/extra/system-info/windows/windows.factor b/extra/system-info/windows/windows.factor index 4d23430131..34915d0b7b 100755 --- a/extra/system-info/windows/windows.factor +++ b/extra/system-info/windows/windows.factor @@ -7,18 +7,18 @@ system alien.strings windows.errors ; IN: system-info.windows : system-info ( -- SYSTEM_INFO ) - "SYSTEM_INFO" [ GetSystemInfo ] keep ; + SYSTEM_INFO [ GetSystemInfo ] keep ; : page-size ( -- n ) - system-info SYSTEM_INFO-dwPageSize ; + system-info dwPageSize>> ; ! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664) : processor-type ( -- n ) - system-info SYSTEM_INFO-dwProcessorType ; + system-info dwProcessorType>> ; ! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk : processor-architecture ( -- n ) - system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ; + system-info dwOemId>> HEX: ffff0000 bitand ; : os-version ( -- os-version ) "OSVERSIONINFO" From 9a876a525554d072731d09694761eef29cb96a85 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 26 Aug 2009 22:23:03 -0500 Subject: [PATCH 06/55] remove duplicate usings --- core/classes/algebra/algebra-tests.factor | 6 +++--- core/classes/classes-tests.factor | 2 +- core/classes/union/union-tests.factor | 5 ++--- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index a1e83ff72c..d111d1daa2 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -2,8 +2,8 @@ USING: alien arrays definitions generic assocs hashtables io kernel math namespaces parser prettyprint sequences strings tools.test words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate -vectors definitions source-files compiler.units growable -random stack-checker effects kernel.private sbufs math.order +vectors source-files compiler.units growable random +stack-checker effects kernel.private sbufs math.order classes.tuple accessors ; IN: classes.algebra.tests @@ -317,4 +317,4 @@ SINGLETON: sc ! UNION: u1 sa sb ; ! UNION: u2 sc ; -! [ f ] [ u1 u2 classes-intersect? ] unit-test \ No newline at end of file +! [ f ] [ u1 u2 classes-intersect? ] unit-test diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 1c1db09cf4..ba6c0fb3ef 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -2,7 +2,7 @@ USING: alien arrays generic assocs hashtables io io.streams.string kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate -classes.algebra vectors definitions source-files compiler.units +classes.algebra definitions source-files compiler.units kernel.private sorting vocabs memory eval accessors sets ; IN: classes.tests diff --git a/core/classes/union/union-tests.factor b/core/classes/union/union-tests.factor index 52550b2356..7b8036ff77 100644 --- a/core/classes/union/union-tests.factor +++ b/core/classes/union/union-tests.factor @@ -2,9 +2,8 @@ USING: alien arrays definitions generic assocs hashtables io kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate -classes.algebra vectors definitions source-files -compiler.units kernel.private sorting vocabs io.streams.string -eval see ; +classes.algebra source-files compiler.units kernel.private +sorting vocabs io.streams.string eval see ; IN: classes.union.tests ! DEFER: bah From f808f43ffbc6cbb4547d2607cf296fd0fd0e2608 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Aug 2009 04:09:12 -0500 Subject: [PATCH 07/55] A few inline declarations --- basis/alien/c-types/c-types.factor | 6 +++--- basis/bit-arrays/bit-arrays.factor | 2 +- basis/io/buffers/buffers.factor | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 9f7ac75558..400af25373 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -236,9 +236,9 @@ M: c-type stack-size size>> cell align ; GENERIC: byte-length ( seq -- n ) flushable -M: byte-array byte-length length ; +M: byte-array byte-length length ; inline -M: f byte-length drop 0 ; +M: f byte-length drop 0 ; inline : c-getter ( name -- quot ) c-type-getter [ @@ -281,7 +281,7 @@ M: memory-stream stream-read ] [ [ + ] change-index drop ] 2bi ; : byte-array>memory ( byte-array base -- ) - swap dup byte-length memcpy ; + swap dup byte-length memcpy ; inline : array-accessor ( type quot -- def ) [ diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 0b5a63a906..0f87cf4cb6 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -83,7 +83,7 @@ M: bit-array resize bit-array boa dup clean-up ; inline -M: bit-array byte-length length 7 + -3 shift ; +M: bit-array byte-length length 7 + -3 shift ; inline SYNTAX: ?{ \ } [ >bit-array ] parse-literal ; diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index c9396dd081..82c5326b1d 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -42,7 +42,7 @@ M: buffer dispose* ptr>> free ; [ fill>> ] [ pos>> ] bi - ; inline : buffer@ ( buffer -- alien ) - [ pos>> ] [ ptr>> ] bi ; + [ pos>> ] [ ptr>> ] bi ; inline : buffer-read ( n buffer -- byte-array ) [ buffer-length min ] keep From 8f19f14c1f5ef9c19e3d5c2616ac6d876999937a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Aug 2009 04:09:35 -0500 Subject: [PATCH 08/55] compiler.cfg.instructions: forgot that ##box-displaced-alien needs a GC check; fixes segfault in benchmark.mandel --- basis/compiler/cfg/instructions/instructions.factor | 7 ++++++- basis/compiler/tests/codegen.factor | 8 +++++++- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index bd93214297..b98e24253d 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -153,7 +153,12 @@ INSN: ##set-alien-double < ##alien-setter ; ! Memory allocation INSN: ##allot < ##flushable size class temp ; -UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ; +UNION: ##allocation +##allot +##box-float +##box-alien +##box-displaced-alien +##integer>bignum ; INSN: ##write-barrier < ##effect card# table ; diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 5f06fc8d2a..d45b4aa151 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -401,4 +401,10 @@ cell 4 = [ dup [ [ 1 fixnum+fast ] dip ] [ [ drop 1 ] dip ] if ; [ 2 t ] [ 0 t global-dcn-bug-1 ] unit-test -[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test \ No newline at end of file +[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test + +! Forgot a GC check +: missing-gc-check-1 ( a -- b ) { fixnum } declare ; +: missing-gc-check-2 ( -- ) 10000000 [ missing-gc-check-1 drop ] each-integer ; + +[ ] [ missing-gc-check-2 ] unit-test \ No newline at end of file From 98f93f799b7a084319b22dfca5f74601a5bd2167 Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 27 Aug 2009 04:43:45 -0500 Subject: [PATCH 09/55] cpu.ppc: fix ##box-displaced-alien --- basis/cpu/ppc/ppc.factor | 14 +++++++------- basis/cpu/x86/x86.factor | 6 +++--- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index c3d89e6d02..d21f5756b9 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -315,13 +315,13 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- ) : alien@ ( n -- n' ) cells object tag-number - ; -:: %allot-alien ( dst base displacement temp -- ) +:: %allot-alien ( dst displacement base temp -- ) dst 4 cells alien temp %allot temp \ f tag-number %load-immediate - ! Store expired slot - temp dst 1 alien@ STW ! Store underlying-alien slot - base dst 2 alien@ STW + base dst 1 alien@ STW + ! Store expired slot + temp dst 2 alien@ STW ! Store offset displacement dst 3 alien@ STW ; @@ -331,7 +331,7 @@ M:: ppc %box-alien ( dst src temp -- ) dst \ f tag-number %load-immediate 0 src 0 CMPI "f" get BEQ - dst temp src temp %allot-alien + dst src temp temp %allot-alien "f" resolve-label ] with-scope ; @@ -348,14 +348,14 @@ M:: ppc %box-displaced-alien ( dst displacement base temp -- ) "ok" get BEQ temp base header-offset LWZ 0 temp alien type-number tag-fixnum CMPI - "ok" get BEQ + "ok" get BNE ! displacement += base.displacement temp base 3 alien@ LWZ displacement displacement temp ADD ! base = base.base base base 1 alien@ LWZ "ok" resolve-label - dst base displacement temp %allot-alien + dst displacement base temp %allot-alien "end" resolve-label ] with-scope ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 456b430a9e..0d028a4862 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -255,7 +255,7 @@ M:: x86 %box-float ( dst src temp -- ) : alien@ ( reg n -- op ) cells alien tag-number - [+] ; -:: %allot-alien ( dst base displacement temp -- ) +:: %allot-alien ( dst displacement base temp -- ) dst 4 cells alien temp %allot dst 1 alien@ base MOV ! alien dst 2 alien@ \ f tag-number MOV ! expired @@ -268,7 +268,7 @@ M:: x86 %box-alien ( dst src temp -- ) dst \ f tag-number MOV src 0 CMP "end" get JE - dst \ f tag-number src temp %allot-alien + dst src \ f tag-number temp %allot-alien "end" resolve-label ] with-scope ; @@ -290,7 +290,7 @@ M:: x86 %box-displaced-alien ( dst displacement base temp -- ) ! base = base.base base base 1 alien@ MOV "ok" resolve-label - dst base displacement temp %allot-alien + dst displacement base temp %allot-alien "end" resolve-label ] with-scope ; From a17250bd1b7d1201fc91d2f65fec83004892700d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Aug 2009 11:24:26 -0500 Subject: [PATCH 10/55] use constant --- basis/cocoa/application/application.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index 66093645c1..cbf8636a75 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -18,7 +18,7 @@ NSApplicationDelegateReplyFailure ; : NSApp ( -- app ) NSApplication -> sharedApplication ; -: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline +CONSTANT: NSAnyEventMask HEX: ffffffff FUNCTION: void NSBeep ( ) ; From d4497c81efe7b7e065bb5b059d2832f72256ea6c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Aug 2009 11:43:19 -0500 Subject: [PATCH 11/55] spacing --- basis/ui/backend/cocoa/cocoa.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index c40a19851f..111e20aea2 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -211,7 +211,7 @@ CLASS: { { +name+ "FactorApplicationDelegate" } } -{ "applicationDidUpdate:" "void" { "id" "SEL" "id" } +{ "applicationDidUpdate:" "void" { "id" "SEL" "id" } [ 3drop reset-run-loop ] } ; From a76751fec25df86cc25985ec4fedf1571460c27d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 27 Aug 2009 12:05:56 -0500 Subject: [PATCH 12/55] change factor.sh update to fetch and pull in separate steps so certain platforms that exclusive-lock running scripts won't ruin the repo when factor.sh changes in the future --- build-support/factor.sh | 40 ++++++++++++++++++++++++++++++++++++---- 1 file changed, 36 insertions(+), 4 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index b179811bda..1bddb935ab 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -14,6 +14,7 @@ WORD= NO_UI= GIT_PROTOCOL=${GIT_PROTOCOL:="git"} GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"} +SCRIPT_ARGS="$*" test_program_installed() { if ! [[ -n `type -p $1` ]] ; then @@ -353,9 +354,40 @@ git_clone() { invoke_git clone $GIT_URL } -git_pull_factorcode() { - echo "Updating the git repository from factorcode.org..." - invoke_git pull $GIT_URL master +update_script_name() { + echo `dirname $0`/_update.sh +} + +update_script() { + echo "Updating and restarting the factor.sh script..." + + update_script=`update_script_name` + + echo "#!/bin/sh" >"$update_script" + echo "git pull \"$GIT_URL\" master" >>"$update_script" + echo "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \ + >>"$update_script" + echo "exit 0" >>"$update_script" + + chmod 755 "$update_script" + exec "$update_script" +} + +update_script_changed() { + invoke_git diff --stat `invoke_git merge-base HEAD FETCH_HEAD` FETCH_HEAD | grep 'build-support.factor\.sh' >/dev/null +} + +git_fetch_factorcode() { + echo "Fetching the git repository from factorcode.org..." + + rm -f `update_script_name` + invoke_git fetch "$GIT_URL" master + + if update_script_changed; then + update_script + else + invoke_git pull "$GIT_URL" master + fi } cd_factor() { @@ -475,7 +507,7 @@ install() { update() { get_config_info - git_pull_factorcode + git_fetch_factorcode backup_factor make_clean make_factor From 54772c9de1c094fd2c32d2f749664f2d4283f449 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 27 Aug 2009 12:15:52 -0500 Subject: [PATCH 13/55] better factor.sh output after git fetch whether script is restarted or not --- build-support/factor.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 1bddb935ab..4943d3e5c0 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -359,8 +359,6 @@ update_script_name() { } update_script() { - echo "Updating and restarting the factor.sh script..." - update_script=`update_script_name` echo "#!/bin/sh" >"$update_script" @@ -384,8 +382,10 @@ git_fetch_factorcode() { invoke_git fetch "$GIT_URL" master if update_script_changed; then + echo "Updating and restarting the factor.sh script..." update_script else + echo "Updating the working tree..." invoke_git pull "$GIT_URL" master fi } From 7cc86bd0ab62f2016f006812409e06e8cb945bc0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Aug 2009 14:15:34 -0500 Subject: [PATCH 14/55] add initial gif parsing. needs to be run on more gifs, needs lzw decompression --- extra/images/gif/gif.factor | 232 ++++++++++++++++++++++++++++++++++++ 1 file changed, 232 insertions(+) create mode 100644 extra/images/gif/gif.factor diff --git a/extra/images/gif/gif.factor b/extra/images/gif/gif.factor new file mode 100644 index 0000000000..9e1bc347b2 --- /dev/null +++ b/extra/images/gif/gif.factor @@ -0,0 +1,232 @@ +! Copyrigt (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators constructors destructors +images images.loader io io.binary io.buffers +io.encodings.binary io.encodings.string io.encodings.utf8 +io.files io.files.info io.ports io.streams.limited kernel make +math math.bitwise math.functions multiline namespaces +prettyprint sequences ; +IN: images.gif + +SINGLETON: gif-image +"gif" gif-image register-image-class + +TUPLE: loading-gif +loading? +magic +width height +flags +background-color +default-aspect-ratio +global-color-table +graphic-control-extensions +application-extensions +plain-text-extensions +comment-extensions + +image-descriptor +local-color-table +compressed-bytes ; + +TUPLE: gif-frame +image-descriptor +local-color-table ; + +ERROR: unsupported-gif-format magic ; +ERROR: unknown-extension n ; +ERROR: gif-unexpected-eof ; + +TUPLE: graphics-control-extension +label block-size raw-data +packed delay-time color-index +block-terminator ; + +TUPLE: image-descriptor +separator left top width height flags ; + +TUPLE: plain-text-extension +introducer label block-size text-grid-left text-grid-top text-grid-width +text-grid-height cell-width cell-height +text-fg-color-index text-bg-color-index plain-text-data ; + +TUPLE: application-extension +introducer label block-size identifier authentication-code +application-data ; + +TUPLE: comment-extension +introducer label comment-data ; + +TUPLE: trailer byte ; +CONSTRUCTOR: trailer ( byte -- obj ) ; + +CONSTANT: image-descriptor HEX: 2c +! Extensions +CONSTANT: extension-identifier HEX: 21 +CONSTANT: plain-text-extension HEX: 01 +CONSTANT: graphic-control-extension HEX: f9 +CONSTANT: comment-extension HEX: fe +CONSTANT: application-extension HEX: ff +CONSTANT: trailer HEX: 3b + +: ( -- loading-gif ) + \ loading-gif new + V{ } clone >>graphic-control-extensions + V{ } clone >>application-extensions + V{ } clone >>plain-text-extensions + V{ } clone >>comment-extensions + t >>loading? ; + +GENERIC: stream-peek1 ( stream -- byte ) + +M: input-port stream-peek1 + dup check-disposed dup wait-to-read + [ drop f ] [ buffer>> buffer-peek ] if ; inline + +: peek1 ( -- byte ) input-stream get stream-peek1 ; + +: (read-sub-blocks) ( -- ) + read1 [ read , (read-sub-blocks) ] unless-zero ; + +: read-sub-blocks ( -- bytes ) + [ (read-sub-blocks) ] { } make B{ } concat-as ; + +: read-image-descriptor ( -- image-descriptor ) + \ image-descriptor new + 1 read le> >>separator + 2 read le> >>left + 2 read le> >>top + 2 read le> >>width + 2 read le> >>height + 1 read le> >>flags ; + +: read-graphic-control-extension ( -- graphic-control-extension ) + \ graphics-control-extension new + 1 read le> [ >>block-size ] [ read ] bi + >>raw-data + 1 read le> >>block-terminator ; + +: read-plain-text-extension ( -- plain-text-extension ) + \ plain-text-extension new + 1 read le> >>block-size + 2 read le> >>text-grid-left + 2 read le> >>text-grid-top + 2 read le> >>text-grid-width + 2 read le> >>text-grid-height + 1 read le> >>cell-width + 1 read le> >>cell-height + 1 read le> >>text-fg-color-index + 1 read le> >>text-bg-color-index + read-sub-blocks >>plain-text-data ; + +: read-comment-extension ( -- comment-extension ) + \ comment-extension new + read-sub-blocks >>comment-data ; + +: read-application-extension ( -- read-application-extension ) + \ application-extension new + 1 read le> >>block-size + 8 read utf8 decode >>identifier + 3 read >>authentication-code + read-sub-blocks >>application-data ; + +: read-gif-header ( loading-gif -- loading-gif ) + 6 read utf8 decode >>magic ; + +ERROR: unimplemented message ; +: read-GIF87a ( loading-gif -- loading-gif ) + "GIF87a" unimplemented ; + +: read-logical-screen-descriptor ( loading-gif -- loading-gif ) + 2 read le> >>width + 2 read le> >>height + 1 read le> >>flags + 1 read le> >>background-color + 1 read le> >>default-aspect-ratio ; + +: color-table? ( image -- ? ) flags>> 7 bit? ; inline +: interlaced? ( image -- ? ) flags>> 6 bit? ; inline +: sort? ( image -- ? ) flags>> 5 bit? ; inline +: color-table-size ( image -- ? ) flags>> 3 bits 1 + 2^ 3 * ; inline + +: color-resolution ( image -- ? ) flags>> -4 shift 3 bits ; inline + +: read-global-color-table ( loading-gif -- loading-gif ) + dup color-table? [ + dup color-table-size read >>global-color-table + ] when ; + +: maybe-read-local-color-table ( loading-gif -- loading-gif ) + dup image-descriptor>> color-table? [ + dup color-table-size read >>local-color-table + ] when ; + +: read-image-data ( loading-gif -- loading-gif ) + read-sub-blocks >>compressed-bytes ; + +: read-table-based-image ( loading-gif -- loading-gif ) + read-image-descriptor >>image-descriptor + maybe-read-local-color-table + read-image-data ; + +: read-graphic-rendering-block ( loading-gif -- loading-gif ) + read-table-based-image ; + +: read-extension ( loading-gif -- loading-gif ) + read1 { + { plain-text-extension [ + read-plain-text-extension over plain-text-extensions>> push + ] } + + { graphic-control-extension [ + read-graphic-control-extension + over graphic-control-extensions>> push + ] } + { comment-extension [ + read-comment-extension over comment-extensions>> push + ] } + { application-extension [ + read-application-extension over application-extensions>> push + ] } + { f [ gif-unexpected-eof ] } + [ unknown-extension ] + } case ; + +ERROR: unhandled-data byte ; + +: read-data ( loading-gif -- loading-gif ) + read1 { + { extension-identifier [ read-extension ] } + { graphic-control-extension [ + read-graphic-control-extension + over graphic-control-extensions>> push + ] } + { image-descriptor [ read-table-based-image ] } + { trailer [ f >>loading? ] } + [ unhandled-data ] + } case ; + +: read-GIF89a ( loading-gif -- loading-gif ) + read-logical-screen-descriptor + read-global-color-table + [ read-data dup loading?>> ] loop ; + +: load-gif ( stream -- loading-gif ) + [ + + read-gif-header dup magic>> { + { "GIF87a" [ read-GIF87a ] } + { "GIF89a" [ read-GIF89a ] } + [ unsupported-gif-format ] + } case + ] with-input-stream ; + +: loading-gif>image ( loading-gif -- image ) + ; + +ERROR: loading-gif-error gif-image ; + +: ensure-loaded ( gif-image -- gif-image ) + dup loading?>> [ loading-gif-error ] when ; + +M: gif-image stream>image ( path gif-image -- image ) + drop load-gif ensure-loaded loading-gif>image ; From 9777de8c35c210a2480fd978442ee5d7d589d8bd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Aug 2009 16:03:45 -0500 Subject: [PATCH 15/55] manually apply alec's patch for bloom filters --- extra/bloom-filters/bloom-filters-tests.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/bloom-filters/bloom-filters-tests.factor b/extra/bloom-filters/bloom-filters-tests.factor index 9b5bf48912..fa56aff8cc 100644 --- a/extra/bloom-filters/bloom-filters-tests.factor +++ b/extra/bloom-filters/bloom-filters-tests.factor @@ -66,7 +66,8 @@ IN: bloom-filters.tests [ t ] [ 2000 iota full-bloom-filter [ bloom-filter-member? ] curry map - [ ] all? ] unit-test + [ ] all? +] unit-test ! We shouldn't have more than 0.01 false-positive rate. [ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map @@ -74,5 +75,6 @@ IN: bloom-filters.tests [ bloom-filter-member? ] curry map [ ] filter ! TODO: This should be 10, but the false positive rate is currently very - ! high. It shouldn't be much more than this. - length 150 <= ] unit-test + ! high. 300 is large enough not to prevent builds from succeeding. + length 300 <= +] unit-test From e40ac7308522f2f0583466da887ccbe646481a24 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Aug 2009 16:10:00 -0500 Subject: [PATCH 16/55] fix typo in gensym reported by mnestic --- core/words/words-docs.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index b756c0b681..c670939c48 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -219,7 +219,11 @@ HELP: ( name vocab -- word ) HELP: gensym { $values { "word" word } } { $description "Creates an uninterned word that is not equal to any other word in the system." } -{ $examples { $unchecked-example "gensym ." "G:260561" } } +{ $examples { $example "USING: prettyprint words ;" + "gensym ." + "( gensym )" + } +} { $notes "Gensyms are often used as placeholder values that have no meaning of their own but must be unique. For example, the compiler uses gensyms to label sections of code." } ; HELP: bootstrapping? From ba0f3a9911b597ff0ab5cf028683be7bfd81fe27 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Aug 2009 18:57:56 -0500 Subject: [PATCH 17/55] compiler.tree.propagation.transforms: don't fail to compile if 'at' called on something that's not an assoc --- .../tree/propagation/propagation-tests.factor | 4 ++++ .../tree/propagation/transforms/transforms.factor | 14 ++++++++------ 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 511f87dd09..879ab82c4b 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -780,6 +780,10 @@ M: f whatever2 ; inline [ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test [ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test +SYMBOL: not-an-assoc + +[ f ] [ [ not-an-assoc at ] { at* } inlined? ] unit-test + [ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test [ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 683c182903..f3247b55fc 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -207,12 +207,14 @@ CONSTANT: lookup-table-at-max 256 ] ; : at-quot ( assoc -- quot ) - dup lookup-table-at? [ - dup fast-lookup-table-at? [ - fast-lookup-table-quot - ] [ - lookup-table-quot - ] if + dup assoc? [ + dup lookup-table-at? [ + dup fast-lookup-table-at? [ + fast-lookup-table-quot + ] [ + lookup-table-quot + ] if + ] [ drop f ] if ] [ drop f ] if ; \ at* [ at-quot ] 1 define-partial-eval From 02fe28ce82365c01e809fd641da3ae2340ff37ea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Aug 2009 19:05:44 -0500 Subject: [PATCH 18/55] add an image-control gadget --- extra/images/viewer/viewer.factor | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index b41dae9b38..c62293bbe7 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007, 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors images images.loader io.pathnames kernel namespaces -opengl opengl.gl opengl.textures sequences strings ui ui.gadgets -ui.gadgets.panes ui.render ui.images ; +USING: accessors images images.loader io.pathnames kernel +models namespaces opengl opengl.gl opengl.textures sequences +strings ui ui.gadgets ui.gadgets.panes ui.images ui.render +constructors ; IN: images.viewer TUPLE: image-gadget < gadget image texture ; @@ -13,7 +14,20 @@ M: image-gadget pref-dim* image>> dim>> ; dup texture>> [ ] [ dup image>> { 0 0 } >>texture texture>> ] ?if ; M: image-gadget draw-gadget* ( gadget -- ) - [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ; + dup image>> [ + [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture + ] [ + drop + ] if ; + +TUPLE: image-control < image-gadget ; + +CONSTRUCTOR: image-control ( model -- image-control ) ; + +M: image-control pref-dim* image>> [ dim>> ] [ { 640 480 } ] if* ; + +M: image-control model-changed + swap value>> >>image relayout ; ! Todo: delete texture on ungraft From 7771c55cb52d93821b99fbac8f87f80cfa1d675a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 27 Aug 2009 19:21:38 -0500 Subject: [PATCH 19/55] ui.backend.cocoa.views: yield in drawRect: impl so that windows will redraw while being resized on snow leopard --- basis/ui/backend/cocoa/views/views.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index ffff15a911..6ae56af030 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -149,7 +149,7 @@ CLASS: { ! Rendering { "drawRect:" "void" { "id" "SEL" "NSRect" } - [ 2drop window relayout-1 ] + [ 2drop window relayout-1 yield ] } ! Events From 0d70d07cf1282e25709bd1ef159dddad06bed727 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Aug 2009 20:27:35 -0500 Subject: [PATCH 20/55] tools.deploy.test: give PowerPC an extra 100kb --- basis/tools/deploy/test/test.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index 9a54e65f1a..28916033d4 100644 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -11,7 +11,9 @@ IN: tools.deploy.test ] with-directory ; : small-enough? ( n -- ? ) - [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ; + [ "test.image" temp-file file-info size>> ] + [ cell 4 / * cpu ppc? [ 100000 + ] when ] bi* + <= ; : run-temp-image ( -- ) os macosx? From f1b4d94f2f21fcb6009db0e7e25d63fb5902f6c9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Aug 2009 20:29:16 -0500 Subject: [PATCH 21/55] tools.deploy: remove malloc debugging better, and don't set next-method word prop for methods that don't call-next-method --- basis/tools/deploy/shaker/shaker.factor | 25 ++++++++++++--------- basis/tools/deploy/shaker/strip-libc.factor | 4 ++++ 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index b24981ed88..19f8fb9080 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays accessors io.backend io.streams.c init fry namespaces -math make assocs kernel parser parser.notes lexer strings.parser -vocabs sequences sequences.private words memory kernel.private -continuations io vocabs.loader system strings sets vectors quotations -byte-arrays sorting compiler.units definitions generic -generic.standard generic.single tools.deploy.config combinators -classes classes.builtin slots.private grouping ; +USING: arrays accessors io.backend io.streams.c init fry +namespaces math make assocs kernel parser parser.notes lexer +strings.parser vocabs sequences sequences.deep sequences.private +words memory kernel.private continuations io vocabs.loader +system strings sets vectors quotations byte-arrays sorting +compiler.units definitions generic generic.standard +generic.single tools.deploy.config combinators classes +classes.builtin slots.private grouping ; QUALIFIED: bootstrap.stage2 QUALIFIED: command-line QUALIFIED: compiler.errors @@ -120,6 +121,7 @@ IN: tools.deploy.shaker "combination" "compiled-generic-uses" "compiled-uses" + "constant" "constraints" "custom-inlining" "decision-tree" @@ -145,6 +147,7 @@ IN: tools.deploy.shaker "local-writer" "local-writer?" "local?" + "low-order" "macro" "members" "memo-quot" @@ -456,11 +459,13 @@ SYMBOL: deploy-vocab [ "method-generic" word-prop ] bi next-method ; +: calls-next-method? ( method -- ? ) + def>> flatten \ (call-next-method) swap memq? ; + : compute-next-methods ( -- ) [ standard-generic? ] instances [ - "methods" word-prop [ - nip dup next-method* "next-method" set-word-prop - ] assoc-each + "methods" word-prop values [ calls-next-method? ] filter + [ dup next-method* "next-method" set-word-prop ] each ] each "vocab:tools/deploy/shaker/next-methods.factor" run-file ; diff --git a/basis/tools/deploy/shaker/strip-libc.factor b/basis/tools/deploy/shaker/strip-libc.factor index 9c2dc4e8ec..1e73d8eb9f 100644 --- a/basis/tools/deploy/shaker/strip-libc.factor +++ b/basis/tools/deploy/shaker/strip-libc.factor @@ -8,3 +8,7 @@ IN: libc : calloc ( size count -- newalien ) (calloc) check-ptr ; : free ( alien -- ) (free) ; + +FORGET: malloc-ptr + +FORGET: From 469e7e8d67979fac70becbc25ac2140540d2c9a3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Aug 2009 20:35:37 -0500 Subject: [PATCH 22/55] newstructify PIXELFORMAT --- basis/io/backend/windows/nt/nt.factor | 8 +-- basis/ui/backend/windows/windows.factor | 77 +++++++++++++------------ basis/windows/types/types.factor | 56 +++++++++--------- basis/windows/user32/user32.factor | 2 +- 4 files changed, 72 insertions(+), 71 deletions(-) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index e29aa6c618..aa113c0efe 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -3,7 +3,7 @@ destructors io io.backend io.ports io.timeouts io.backend.windows io.files.windows io.files.windows.nt io.files io.pathnames io.buffers io.streams.c io.streams.null libc kernel math namespaces sequences threads windows windows.errors windows.kernel32 strings splitting -ascii system accessors locals classes.struct ; +ascii system accessors locals classes.struct combinators.short-circuit ; QUALIFIED: windows.winsock IN: io.backend.windows.nt @@ -36,7 +36,7 @@ M: winnt add-completion ( win32-handle -- ) handle>> master-completion-port get-global drop ; : eof? ( error -- ? ) - [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ; + { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ; : twiddle-thumbs ( overlapped port -- bytes-transferred ) [ @@ -66,9 +66,9 @@ M: winnt add-completion ( win32-handle -- ) : handle-overlapped ( us -- ? ) wait-for-overlapped [ - dup [ + [ [ drop GetLastError 1array ] dip resume-callback t - ] [ 2drop f ] if + ] [ drop f ] if* ] [ resume-callback t ] if ; M: win32-handle cancel-operation diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index f23989a1e2..7ce9afe5e6 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -11,7 +11,7 @@ threads libc combinators fry combinators.short-circuit continuations command-line shuffle opengl ui.render math.bitwise locals accessors math.rectangles math.order calendar ascii sets io.encodings.utf16n windows.errors literals ui.pixel-formats -ui.pixel-formats.private memoize classes struct-arrays ; +ui.pixel-formats.private memoize classes struct-arrays classes.struct ; IN: ui.backend.windows SINGLETON: windows-ui-backend @@ -89,26 +89,27 @@ CONSTANT: pfd-flag-map H{ [ value>> ] [ 0 ] if* ; : >pfd ( attributes -- pfd ) - "PIXELFORMATDESCRIPTOR" - "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize - 1 over set-PIXELFORMATDESCRIPTOR-nVersion - over >pfd-flags over set-PIXELFORMATDESCRIPTOR-dwFlags - PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType - over color-bits attr-value over set-PIXELFORMATDESCRIPTOR-cColorBits - over red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cRedBits - over green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cGreenBits - over blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cBlueBits - over alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAlphaBits - over accum-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBits - over accum-red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumRedBits - over accum-green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumGreenBits - over accum-blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBlueBits - over accum-alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumAlphaBits - over depth-bits attr-value over set-PIXELFORMATDESCRIPTOR-cDepthBits - over stencil-bits attr-value over set-PIXELFORMATDESCRIPTOR-cStencilBits - over aux-buffers attr-value over set-PIXELFORMATDESCRIPTOR-cAuxBuffers - PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask - nip ; + [ PIXELFORMATDESCRIPTOR ] dip + { + [ drop PIXELFORMATDESCRIPTOR heap-size >>nSize ] + [ drop 1 >>nVersion ] + [ >pfd-flags >>dwFlags ] + [ drop PFD_TYPE_RGBA >>iPixelType ] + [ color-bits attr-value >>cColorBits ] + [ red-bits attr-value >>cRedBits ] + [ green-bits attr-value >>cGreenBits ] + [ blue-bits attr-value >>cBlueBits ] + [ alpha-bits attr-value >>cAlphaBits ] + [ accum-bits attr-value >>cAccumBits ] + [ accum-red-bits attr-value >>cAccumRedBits ] + [ accum-green-bits attr-value >>cAccumGreenBits ] + [ accum-blue-bits attr-value >>cAccumBlueBits ] + [ accum-alpha-bits attr-value >>cAccumAlphaBits ] + [ depth-bits attr-value >>cDepthBits ] + [ stencil-bits attr-value >>cStencilBits ] + [ aux-buffers attr-value >>cAuxBuffers ] + [ drop PFD_MAIN_PLANE >>dwLayerMask ] + } cleave ; : pfd-make-pixel-format ( world attributes -- pf ) [ handle>> hDC>> ] [ >pfd ] bi* @@ -116,12 +117,12 @@ CONSTANT: pfd-flag-map H{ : get-pfd ( pixel-format -- pfd ) [ world>> handle>> hDC>> ] [ handle>> ] bi - "PIXELFORMATDESCRIPTOR" heap-size - "PIXELFORMATDESCRIPTOR" + PIXELFORMATDESCRIPTOR heap-size + PIXELFORMATDESCRIPTOR [ DescribePixelFormat win32-error=0/f ] keep ; : pfd-flag? ( pfd flag -- ? ) - [ PIXELFORMATDESCRIPTOR-dwFlags ] dip bitand c-bool> ; + [ dwFlags>> ] dip bitand c-bool> ; : (pfd-pixel-format-attribute) ( pfd attribute -- value ) { @@ -131,19 +132,19 @@ CONSTANT: pfd-flag-map H{ { fullscreen [ PFD_DRAW_TO_WINDOW pfd-flag? ] } { windowed [ PFD_DRAW_TO_WINDOW pfd-flag? ] } { software-rendered [ PFD_GENERIC_FORMAT pfd-flag? ] } - { color-bits [ PIXELFORMATDESCRIPTOR-cColorBits ] } - { red-bits [ PIXELFORMATDESCRIPTOR-cRedBits ] } - { green-bits [ PIXELFORMATDESCRIPTOR-cGreenBits ] } - { blue-bits [ PIXELFORMATDESCRIPTOR-cBlueBits ] } - { alpha-bits [ PIXELFORMATDESCRIPTOR-cAlphaBits ] } - { accum-bits [ PIXELFORMATDESCRIPTOR-cAccumBits ] } - { accum-red-bits [ PIXELFORMATDESCRIPTOR-cAccumRedBits ] } - { accum-green-bits [ PIXELFORMATDESCRIPTOR-cAccumGreenBits ] } - { accum-blue-bits [ PIXELFORMATDESCRIPTOR-cAccumBlueBits ] } - { accum-alpha-bits [ PIXELFORMATDESCRIPTOR-cAccumAlphaBits ] } - { depth-bits [ PIXELFORMATDESCRIPTOR-cDepthBits ] } - { stencil-bits [ PIXELFORMATDESCRIPTOR-cStencilBits ] } - { aux-buffers [ PIXELFORMATDESCRIPTOR-cAuxBuffers ] } + { color-bits [ cColorBits>> ] } + { red-bits [ cRedBits>> ] } + { green-bits [ cGreenBits>> ] } + { blue-bits [ cBlueBits>> ] } + { alpha-bits [ cAlphaBits>> ] } + { accum-bits [ cAccumBits>> ] } + { accum-red-bits [ cAccumRedBits>> ] } + { accum-green-bits [ cAccumGreenBits>> ] } + { accum-blue-bits [ cAccumBlueBits>> ] } + { accum-alpha-bits [ cAccumAlphaBits>> ] } + { depth-bits [ cDepthBits>> ] } + { stencil-bits [ cStencilBits>> ] } + { aux-buffers [ cAuxBuffers>> ] } [ 2drop f ] } case ; @@ -663,7 +664,7 @@ M: windows-ui-backend do-events : set-pixel-format ( pixel-format hdc -- ) swap handle>> - "PIXELFORMATDESCRIPTOR" SetPixelFormat win32-error=0/f ; + PIXELFORMATDESCRIPTOR SetPixelFormat win32-error=0/f ; : setup-gl ( world -- ) [ get-dc ] keep diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index b99e7ffe6f..36823db424 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax namespaces kernel words sequences math math.bitwise math.vectors colors -io.encodings.utf16n ; +io.encodings.utf16n classes.struct ; IN: windows.types TYPEDEF: char CHAR @@ -301,33 +301,33 @@ C-STRUCT: MSG TYPEDEF: MSG* LPMSG -C-STRUCT: PIXELFORMATDESCRIPTOR - { "WORD" "nSize" } - { "WORD" "nVersion" } - { "DWORD" "dwFlags" } - { "BYTE" "iPixelType" } - { "BYTE" "cColorBits" } - { "BYTE" "cRedBits" } - { "BYTE" "cRedShift" } - { "BYTE" "cGreenBits" } - { "BYTE" "cGreenShift" } - { "BYTE" "cBlueBits" } - { "BYTE" "cBlueShift" } - { "BYTE" "cAlphaBits" } - { "BYTE" "cAlphaShift" } - { "BYTE" "cAccumBits" } - { "BYTE" "cAccumRedBits" } - { "BYTE" "cAccumGreenBits" } - { "BYTE" "cAccumBlueBits" } - { "BYTE" "cAccumAlphaBits" } - { "BYTE" "cDepthBits" } - { "BYTE" "cStencilBits" } - { "BYTE" "cAuxBuffers" } - { "BYTE" "iLayerType" } - { "BYTE" "bReserved" } - { "DWORD" "dwLayerMask" } - { "DWORD" "dwVisibleMask" } - { "DWORD" "dwDamageMask" } ; +STRUCT: PIXELFORMATDESCRIPTOR + { nSize WORD } + { nVersion WORD } + { dwFlags DWORD } + { iPixelType BYTE } + { cColorBits BYTE } + { cRedBits BYTE } + { cRedShift BYTE } + { cGreenBits BYTE } + { cGreenShift BYTE } + { cBlueBits BYTE } + { cBlueShift BYTE } + { cAlphaBits BYTE } + { cAlphaShift BYTE } + { cAccumBits BYTE } + { cAccumRedBits BYTE } + { cAccumGreenBits BYTE } + { cAccumBlueBits BYTE } + { cAccumAlphaBits BYTE } + { cDepthBits BYTE } + { cStencilBits BYTE } + { cAuxBuffers BYTE } + { iLayerType BYTE } + { bReserved BYTE } + { dwLayerMask DWORD } + { dwVisibleMask DWORD } + { dwDamageMask DWORD } ; C-STRUCT: RECT { "LONG" "left" } diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 40c10d0f5b..58981920da 100755 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax parser namespaces kernel math -windows.types generalizations math.bitwise ; +windows.types generalizations math.bitwise classes.struct ; IN: windows.user32 ! HKL for ActivateKeyboardLayout From eb4081c696414ecc6c62af43f9b2c5bd3879fd9f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 27 Aug 2009 21:16:41 -0500 Subject: [PATCH 23/55] return YES from cocoa app delegate's applicationShouldHandleReopen: method. this allows app-icon-minimized windows on snow leopard to automatically restore when the dock icon is clicked --- basis/ui/backend/cocoa/tools/tools.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor index cf5493f33d..b8c01f0bd9 100644 --- a/basis/ui/backend/cocoa/tools/tools.factor +++ b/basis/ui/backend/cocoa/tools/tools.factor @@ -30,7 +30,7 @@ CLASS: { } { "applicationShouldHandleReopen:hasVisibleWindows:" "int" { "id" "SEL" "id" "int" } - [ [ 3drop ] dip 0 = [ show-listener ] when 0 ] + [ [ 3drop ] dip 0 = [ show-listener ] when 1 ] } { "factorListener:" "id" { "id" "SEL" "id" } From 80a5bf7138716517efc068bf87d886d26298e464 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 27 Aug 2009 21:39:43 -0500 Subject: [PATCH 24/55] support { type dimension } c-type syntax in STRUCT: definitions --- basis/classes/struct/prettyprint/prettyprint.factor | 4 ++-- basis/classes/struct/struct-tests.factor | 2 +- basis/classes/struct/struct.factor | 5 ++++- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index feeecd881b..6368424ec6 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -1,7 +1,7 @@ ! (c)Joe Groff bsd license USING: accessors assocs classes classes.struct combinators kernel math prettyprint.backend prettyprint.custom -prettyprint.sections see.private sequences words ; +prettyprint.sections see.private sequences strings words ; IN: classes.struct.prettyprint > text ] - [ c-type>> text ] + [ c-type>> dup string? [ text ] [ pprint* ] if ] [ read-only>> [ \ read-only pprint-word ] when ] [ initial>> [ \ initial: pprint-word pprint* ] when* ] } cleave diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 64b8ba83e2..2995e9d6d6 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -187,7 +187,7 @@ STRUCT: struct-test-array-slots ] unit-test STRUCT: struct-test-optimization - { x int[3] } { y int } ; + { x { "int" 3 } } { y int } ; [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test [ t ] [ diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 52f3b7df9f..2cafb5e8fe 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -232,10 +232,13 @@ ERROR: invalid-struct-slot token ; c-type c-type-boxed-class dup \ byte-array = [ drop \ c-ptr ] when ; +: scan-c-type ( -- c-type ) + scan dup "{" = [ drop \ } parse-until >array ] when ; + : parse-struct-slot ( -- slot ) struct-slot-spec new scan >>name - scan [ >>c-type ] [ struct-slot-class >>class ] bi + scan-c-type [ >>c-type ] [ struct-slot-class >>class ] bi \ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ; : parse-struct-slots ( slots -- slots' more? ) From 7cf4e608e5709702cb64becec9b369d904676e3b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Aug 2009 21:49:25 -0500 Subject: [PATCH 25/55] alien: move code for supporting CONSTANT: foo 123 { "int" foo } C types into one place instead of the old scattershot approach --- basis/alien/arrays/arrays.factor | 9 ++++++--- basis/alien/c-types/c-types-tests.factor | 2 +- basis/alien/c-types/c-types.factor | 11 ----------- basis/alien/structs/fields/fields.factor | 2 +- basis/alien/structs/structs.factor | 1 - basis/stack-checker/alien/alien.factor | 9 +++------ 6 files changed, 11 insertions(+), 23 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index fbf59e6f11..e56f151383 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.strings alien.c-types alien.accessors alien.structs arrays words sequences math kernel namespaces fry libc cpu.architecture -io.encodings.utf8 ; +io.encodings.utf8 accessors ; IN: alien.arrays UNION: value-type array struct-type ; @@ -13,7 +13,10 @@ M: array c-type-class drop object ; M: array c-type-boxed-class drop object ; -M: array heap-size unclip [ product ] [ heap-size ] bi* * ; +: array-length ( seq -- n ) + [ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ; + +M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ; M: array c-type-align first c-type-align ; @@ -31,7 +34,7 @@ M: array stack-size drop "void*" stack-size ; M: array c-type-boxer-quot unclip - [ product ] + [ array-length ] [ [ require-c-type-arrays ] keep ] bi* [ ] 2curry ; diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 0de26aad20..bfeff5f1de 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -4,7 +4,7 @@ IN: alien.c-types.tests CONSTANT: xyz 123 -[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test +[ 492 ] [ { "int" xyz } heap-size ] unit-test [ -1 ] [ -1 *char ] unit-test [ -1 ] [ -1 *short ] unit-test diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 400af25373..4c3c8d1668 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -326,17 +326,6 @@ M: long-long-type box-return ( type -- ) [ define-out ] tri ; -: expand-constants ( c-type -- c-type' ) - dup array? [ - unclip [ - [ - dup word? [ - def>> call( -- object ) - ] when - ] map - ] dip prefix - ] when ; - : malloc-file-contents ( path -- alien len ) binary file-contents [ malloc-byte-array ] [ length ] bi ; diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index 7e2d4615b5..25c595b864 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -16,7 +16,7 @@ TUPLE: field-spec name offset type reader writer ; field-spec new 0 >>offset swap >>name - swap expand-constants >>type + swap >>type 3dup name>> swap reader-word >>reader 3dup name>> swap writer-word >>writer 2nip ; diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 85b55f2cbc..3cc4857ecb 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -58,7 +58,6 @@ M: struct-type stack-size [ define-field ] each ; : define-union ( name members -- ) - [ expand-constants ] map [ [ heap-size ] [ max ] map-reduce ] keep compute-struct-align f struct-type (define-struct) ; diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 0b135319ff..da559abd78 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -14,9 +14,6 @@ TUPLE: alien-indirect-params < alien-node-params ; TUPLE: alien-callback-params < alien-node-params quot xt ; -: pop-parameters ( -- seq ) - pop-literal nip [ expand-constants ] map ; - : param-prep-quot ( node -- quot ) parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ; @@ -31,7 +28,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; : infer-alien-invoke ( -- ) alien-invoke-params new ! Compile-time parameters - pop-parameters >>parameters + pop-literal nip >>parameters pop-literal nip >>function pop-literal nip >>library pop-literal nip >>return @@ -50,7 +47,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; alien-indirect-params new ! Compile-time parameters pop-literal nip >>abi - pop-parameters >>parameters + pop-literal nip >>parameters pop-literal nip >>return ! Quotation which coerces parameters to required types dup param-prep-quot [ dip ] curry infer-quot-here @@ -71,7 +68,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; alien-callback-params new pop-literal nip >>quot pop-literal nip >>abi - pop-parameters >>parameters + pop-literal nip >>parameters pop-literal nip >>return gensym >>xt dup callback-bottom From e85925153cc6812420b8a0a770a3e4fc0839a881 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 27 Aug 2009 21:51:08 -0500 Subject: [PATCH 26/55] deprecate C-STRUCT:, C-UNION:, and old-school struct accessors --- basis/alien/structs/fields/fields.factor | 4 ++-- basis/alien/structs/structs-docs.factor | 2 +- basis/alien/structs/structs.factor | 4 ++-- basis/alien/syntax/syntax-docs.factor | 4 +++- basis/alien/syntax/syntax.factor | 4 ++-- 5 files changed, 10 insertions(+), 8 deletions(-) diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index 7e2d4615b5..f958847abd 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -7,10 +7,10 @@ IN: alien.structs.fields TUPLE: field-spec name offset type reader writer ; : reader-word ( class name vocab -- word ) - [ "-" glue ] dip create ; + [ "-" glue ] dip create dup make-deprecated ; : writer-word ( class name vocab -- word ) - [ [ swap "set-" % % "-" % % ] "" make ] dip create ; + [ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ; : ( struct-name vocab type field-name -- spec ) field-spec new diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor index c74fe22dfd..c2a7d43387 100644 --- a/basis/alien/structs/structs-docs.factor +++ b/basis/alien/structs/structs-docs.factor @@ -30,4 +30,4 @@ ARTICLE: "c-unions" "C unions" { $subsection POSTPONE: C-UNION: } "C union objects can be allocated by calling " { $link } " or " { $link malloc-object } "." $nl -"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ; \ No newline at end of file +"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ; diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 85b55f2cbc..fed3ce801b 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -55,12 +55,12 @@ M: struct-type stack-size [ struct-offsets ] keep [ [ type>> ] map compute-struct-align ] keep [ struct-type (define-struct) ] keep - [ define-field ] each ; + [ define-field ] each ; deprecated : define-union ( name members -- ) [ expand-constants ] map [ [ heap-size ] [ max ] map-reduce ] keep - compute-struct-align f struct-type (define-struct) ; + compute-struct-align f struct-type (define-struct) ; deprecated : offset-of ( field struct -- offset ) c-types get at fields>> diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index a3215cd8c6..c9e03724f5 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -1,6 +1,6 @@ IN: alien.syntax USING: alien alien.c-types alien.parser alien.structs -help.markup help.syntax ; +classes.struct help.markup help.syntax ; HELP: DLL" { $syntax "DLL\" path\"" } @@ -55,12 +55,14 @@ HELP: TYPEDEF: { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ; HELP: C-STRUCT: +{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." } { $syntax "C-STRUCT: name pairs... ;" } { $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } } { $description "Defines a C struct layout and accessor words." } { $notes "C type names are documented in " { $link "c-types-specs" } "." } ; HELP: C-UNION: +{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." } { $syntax "C-UNION: name members... ;" } { $values { "name" "a new C type name" } { "members" "a sequence of C types" } } { $description "Defines a new C type sized to fit its largest member." } diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index b70aa3557c..2b0270d5f5 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -22,10 +22,10 @@ SYNTAX: TYPEDEF: scan scan typedef ; SYNTAX: C-STRUCT: - scan current-vocab parse-definition define-struct ; + scan current-vocab parse-definition define-struct ; deprecated SYNTAX: C-UNION: - scan parse-definition define-union ; + scan parse-definition define-union ; deprecated SYNTAX: C-ENUM: ";" parse-tokens From d957ae4e4473c6a2210932552ee1850a65f134a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Aug 2009 05:21:16 -0500 Subject: [PATCH 27/55] Performance improvements to make struct-arrays benchmark faster - improved optimization of ##unbox-any-c-ptr on ##box-displaced-alien; convert it to ##unbox-c-ptr where possible using class info stored in the ##bda instruction - make fcos, fsin, etc inline again; everything in math.libm inline again, except for fsqrt which is an intrinsic - convert min and max on floats to float-min and float-max - make min and max not inline, so that the above can work - struct-arrays: rice a bit so that more fixnums come up --- .../compiler/cfg/builder/builder-tests.factor | 6 ++++ basis/compiler/cfg/hats/hats.factor | 5 ++- .../cfg/instructions/instructions.factor | 8 ++++- .../cfg/intrinsics/alien/alien.factor | 9 ++--- .../compiler/cfg/intrinsics/intrinsics.factor | 9 +++++ .../cfg/two-operand/two-operand.factor | 4 ++- .../expressions/expressions.factor | 9 +++++ .../value-numbering/rewrite/rewrite.factor | 12 +++---- .../value-numbering/simplify/simplify.factor | 13 ++++---- .../value-numbering-tests.factor | 12 +++---- basis/compiler/codegen/codegen.factor | 2 ++ basis/compiler/tests/float.factor | 5 +++ .../known-words/known-words.factor | 13 +++++--- .../propagation/transforms/transforms.factor | 12 ++++++- basis/cpu/architecture/architecture.factor | 2 ++ basis/cpu/x86/32/32.factor | 3 +- basis/cpu/x86/64/64.factor | 3 +- basis/cpu/x86/x86.factor | 7 ++++ basis/math/libm/libm.factor | 33 ++++++++++--------- basis/struct-arrays/struct-arrays.factor | 4 +-- core/math/floats/floats.factor | 3 ++ core/math/order/order.factor | 4 +-- 22 files changed, 123 insertions(+), 55 deletions(-) diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 412451f640..4e0c2aa112 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -184,4 +184,10 @@ IN: compiler.cfg.builder.tests [ f ] [ [ 1000 [ ] times ] [ [ ##peek? ] [ ##replace? ] bi or ] contains-insn? +] unit-test + +[ f t ] [ + [ { fixnum simple-alien } declare 0 alien-cell ] + [ [ ##unbox-any-c-ptr? ] contains-insn? ] + [ [ ##slot-imm? ] contains-insn? ] bi ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 012434bc03..de612f2c28 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -43,6 +43,8 @@ IN: compiler.cfg.hats : ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline : ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline : ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline +: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline +: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline : ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline : ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline : ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline @@ -51,7 +53,8 @@ IN: compiler.cfg.hats : ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline : ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline : ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline -: ^^box-displaced-alien ( base displacement -- dst ) ^^r2 next-vreg ##box-displaced-alien ; inline +: ^^box-displaced-alien ( base displacement base-class -- dst ) + ^^r3 [ next-vreg ] dip ##box-displaced-alien ; inline : ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline : ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ; : ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index b98e24253d..41e227ed76 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -106,6 +106,8 @@ INSN: ##add-float < ##commutative ; INSN: ##sub-float < ##binary ; INSN: ##mul-float < ##commutative ; INSN: ##div-float < ##binary ; +INSN: ##min-float < ##binary ; +INSN: ##max-float < ##binary ; INSN: ##sqrt < ##unary ; ! Float/integer conversion @@ -118,7 +120,7 @@ INSN: ##unbox-float < ##unary ; INSN: ##unbox-any-c-ptr < ##unary/temp ; INSN: ##box-float < ##unary/temp ; INSN: ##box-alien < ##unary/temp ; -INSN: ##box-displaced-alien < ##binary temp ; +INSN: ##box-displaced-alien < ##binary temp base-class ; : ##unbox-f ( dst src -- ) drop 0 ##load-immediate ; : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ; @@ -263,6 +265,8 @@ UNION: output-float-insn ##sub-float ##mul-float ##div-float + ##min-float + ##max-float ##sqrt ##integer>float ##unbox-float @@ -275,6 +279,8 @@ UNION: input-float-insn ##sub-float ##mul-float ##div-float + ##min-float + ##max-float ##sqrt ##float>integer ##box-float diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 332cb7f225..c2faf27f03 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -14,10 +14,11 @@ IN: compiler.cfg.intrinsics.alien } 1&& ; : emit- ( node -- ) - dup emit-? - [ drop 2inputs [ ^^untag-fixnum ] dip ^^box-displaced-alien ds-push ] - [ emit-primitive ] - if ; + dup emit-? [ + [ 2inputs [ ^^untag-fixnum ] dip ] dip + node-input-infos second class>> + ^^box-displaced-alien ds-push + ] [ emit-primitive ] if ; : (prepare-alien-accessor-imm) ( class offset -- offset-vreg ) ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index b1ecf24eea..17e8a1336d 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -21,6 +21,7 @@ QUALIFIED: strings.private QUALIFIED: classes.tuple.private QUALIFIED: math.private QUALIFIED: math.integers.private +QUALIFIED: math.floats.private QUALIFIED: math.libm IN: compiler.cfg.intrinsics @@ -98,6 +99,12 @@ IN: compiler.cfg.intrinsics : enable-fsqrt ( -- ) \ math.libm:fsqrt t "intrinsic" set-word-prop ; +: enable-float-min/max ( -- ) + { + math.floats.private:float-min + math.floats.private:float-max + } [ t "intrinsic" set-word-prop ] each ; + : enable-fixnum-log2 ( -- ) \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; @@ -136,6 +143,8 @@ IN: compiler.cfg.intrinsics { \ math.private:float= [ drop cc= emit-float-comparison ] } { \ math.private:float>fixnum [ drop emit-float>fixnum ] } { \ math.private:fixnum>float [ drop emit-fixnum>float ] } + { \ math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] } + { \ math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] } { \ math.libm:fsqrt [ drop emit-fsqrt ] } { \ slots.private:slot [ emit-slot ] } { \ slots.private:set-slot [ emit-set-slot ] } diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index 1705355842..e8fc036020 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -39,7 +39,9 @@ UNION: two-operand-insn ##add-float ##sub-float ##mul-float - ##div-float ; + ##div-float + ##min-float + ##max-float ; GENERIC: convert-two-operand* ( insn -- ) diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index 87fa959178..973a0a0dc1 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -12,6 +12,7 @@ TUPLE: commutative-expr < binary-expr ; TUPLE: compare-expr < binary-expr cc ; TUPLE: constant-expr < expr value ; TUPLE: reference-expr < expr value ; +TUPLE: box-displaced-alien-expr < expr displacement base base-class ; : ( constant -- expr ) f swap constant-expr boa ; inline @@ -85,6 +86,14 @@ M: ##compare-imm >expr compare-imm>expr ; M: ##compare-float >expr compare>expr ; +M: ##box-displaced-alien >expr + { + [ class ] + [ src1>> vreg>vn ] + [ src2>> vreg>vn ] + [ base-class>> ] + } cleave box-displaced-alien-expr boa ; + M: ##flushable >expr drop next-input-expr ; : init-expressions ( -- ) diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 7c7961449a..2662dc4665 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -354,18 +354,18 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ; : box-displaced-alien? ( expr -- ? ) op>> \ ##box-displaced-alien eq? ; -! ##box-displaced-alien f 1 2 3 -! ##unbox-any-c-ptr 4 1 +! ##box-displaced-alien f 1 2 3 +! ##unbox-c-ptr 4 1 ! => -! ##box-displaced-alien f 1 2 3 -! ##unbox-any-c-ptr 5 3 +! ##box-displaced-alien f 1 2 3 +! ##unbox-c-ptr 5 3 ! ##add 4 5 2 :: rewrite-unbox-displaced-alien ( insn expr -- insns ) [ next-vreg :> temp - temp expr in2>> vn>vreg insn temp>> ##unbox-any-c-ptr - insn dst>> temp expr in1>> vn>vreg ##add + temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr + insn dst>> temp expr displacement>> vn>vreg ##add ] { } make ; M: ##unbox-any-c-ptr rewrite diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor index 38a5136a63..d38159b4b4 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -87,12 +87,6 @@ M: unary-expr simplify* [ 2drop f ] } cond ; inline -: simplify-box-displaced-alien ( expr -- vn/expr/f ) - >binary-expr< { - { [ over expr-zero? ] [ nip ] } - [ 2drop f ] - } cond ; - M: binary-expr simplify* dup op>> { { \ ##add [ simplify-add ] } @@ -113,10 +107,15 @@ M: binary-expr simplify* { \ ##sar-imm [ simplify-shr ] } { \ ##shl [ simplify-shl ] } { \ ##shl-imm [ simplify-shl ] } - { \ ##box-displaced-alien [ simplify-box-displaced-alien ] } [ 2drop f ] } case ; +M: box-displaced-alien-expr simplify* + [ base>> ] [ displacement>> ] bi { + { [ dup expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; + M: expr simplify* drop f ; : simplify ( expr -- vn ) diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 7a746713d3..545c3fbbb3 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -4,7 +4,7 @@ cpu.architecture tools.test kernel math combinators.short-circuit accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce compiler.cfg.ssa.destruction compiler.cfg.loop-detection compiler.cfg.representations compiler.cfg assocs vectors arrays -layouts namespaces ; +layouts namespaces alien ; IN: compiler.cfg.value-numbering.tests : trim-temps ( insns -- insns ) @@ -877,7 +877,7 @@ cell 8 = [ { T{ ##peek f 0 D 0 } T{ ##load-immediate f 2 16 } - T{ ##box-displaced-alien f 1 2 0 } + T{ ##box-displaced-alien f 1 2 0 c-ptr } T{ ##unbox-any-c-ptr f 4 0 } T{ ##add-imm f 3 4 16 } } @@ -885,7 +885,7 @@ cell 8 = [ { T{ ##peek f 0 D 0 } T{ ##load-immediate f 2 16 } - T{ ##box-displaced-alien f 1 2 0 } + T{ ##box-displaced-alien f 1 2 0 c-ptr } T{ ##unbox-any-c-ptr f 3 1 } } value-numbering-step ] unit-test @@ -896,7 +896,7 @@ cell 8 = [ { T{ ##box-alien f 0 1 } T{ ##load-immediate f 2 16 } - T{ ##box-displaced-alien f 3 2 0 } + T{ ##box-displaced-alien f 3 2 0 c-ptr } T{ ##copy f 5 1 any-rep } T{ ##add-imm f 4 5 16 } } @@ -904,7 +904,7 @@ cell 8 = [ { T{ ##box-alien f 0 1 } T{ ##load-immediate f 2 16 } - T{ ##box-displaced-alien f 3 2 0 } + T{ ##box-displaced-alien f 3 2 0 c-ptr } T{ ##unbox-any-c-ptr f 4 3 } } value-numbering-step ] unit-test @@ -922,7 +922,7 @@ cell 8 = [ { T{ ##peek f 0 D 0 } T{ ##load-immediate f 2 0 } - T{ ##box-displaced-alien f 3 2 0 } + T{ ##box-displaced-alien f 3 2 0 c-ptr } T{ ##replace f 3 D 1 } } value-numbering-step ] unit-test diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 72c6feeb1a..7c95c9d0a8 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -169,6 +169,8 @@ M: ##add-float generate-insn dst/src1/src2 %add-float ; M: ##sub-float generate-insn dst/src1/src2 %sub-float ; M: ##mul-float generate-insn dst/src1/src2 %mul-float ; M: ##div-float generate-insn dst/src1/src2 %div-float ; +M: ##min-float generate-insn dst/src1/src2 %min-float ; +M: ##max-float generate-insn dst/src1/src2 %max-float ; M: ##sqrt generate-insn dst/src %sqrt ; diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 138437543e..86d7899fab 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -83,3 +83,8 @@ IN: compiler.tests.float [ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test [ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test + +[ 17.5 ] [ -11.3 17.5 [ float-max ] compile-call ] unit-test +[ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test +[ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test +[ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 2387db3c15..efcf05d7bc 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel effects accessors math math.private -math.integers.private math.partial-dispatch math.intervals -math.parser math.order math.functions math.libm layouts words -sequences sequences.private arrays assocs classes +math.integers.private math.floats.private math.partial-dispatch +math.intervals math.parser math.order math.functions math.libm +layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private definitions strings.private vectors hashtables @@ -303,3 +303,8 @@ generic-comparison-ops [ flog fpow fsqrt facosh fasinh fatanh } [ { float } "default-output-classes" set-word-prop ] each + +{ float-min float-max } [ + [ { float float } "input-classes" set-word-prop ] + [ { float } "default-output-classes" set-word-prop ] bi +] each diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index f3247b55fc..d0362b3222 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -3,7 +3,7 @@ USING: kernel sequences words fry generic accessors classes.tuple classes classes.algebra definitions stack-checker.state quotations classes.tuple.private math math.partial-dispatch math.private -math.intervals layouts math.order vectors hashtables +math.intervals math.floats.private layouts math.order vectors hashtables combinators effects generalizations assocs sets combinators.short-circuit sequences.private locals stack-checker namespaces compiler.tree.propagation.info ; @@ -79,6 +79,16 @@ IN: compiler.tree.propagation.transforms ] [ f ] if ] "custom-inlining" set-word-prop +{ + { min [ float-min ] } + { max [ float-max ] } +} [ + '[ + in-d>> first2 [ value-info class>> float class<= ] both? + [ _ ] [ f ] if + ] "custom-inlining" set-word-prop +] assoc-each + ! Generate more efficient code for common idiom \ clone [ in-d>> first value-info literal>> { diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index f80ec9458c..41cbd30146 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -110,6 +110,8 @@ HOOK: %add-float cpu ( dst src1 src2 -- ) HOOK: %sub-float cpu ( dst src1 src2 -- ) HOOK: %mul-float cpu ( dst src1 src2 -- ) HOOK: %div-float cpu ( dst src1 src2 -- ) +HOOK: %min-float cpu ( dst src1 src2 -- ) +HOOK: %max-float cpu ( dst src1 src2 -- ) HOOK: %sqrt cpu ( dst src -- ) HOOK: %integer>float cpu ( dst src -- ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 8808c47995..e9388e300d 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -303,8 +303,7 @@ USING: cpu.x86.features cpu.x86.features.private ; "Checking if your CPU supports SSE2..." print flush sse2? [ " - yes" print - enable-float-intrinsics - enable-fsqrt + enable-sse2 [ sse2? [ "This image was built to use SSE2, which your CPU does not support." print diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 153e2c511b..fbcb113e91 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -202,8 +202,7 @@ M: x86.64 %callback-value ( ctype -- ) enable-alien-4-intrinsics ! SSE2 is always available on x86-64. -enable-float-intrinsics -enable-fsqrt +enable-sse2 USE: vocabs.loader diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 0d028a4862..12414c3f94 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -203,6 +203,8 @@ M: x86 %add-float nip ADDSD ; M: x86 %sub-float nip SUBSD ; M: x86 %mul-float nip MULSD ; M: x86 %div-float nip DIVSD ; +M: x86 %min-float nip MINSD ; +M: x86 %max-float nip MAXSD ; M: x86 %sqrt SQRTSD ; M: x86 %integer>float CVTSI2SD ; @@ -572,3 +574,8 @@ M: x86 small-enough? ( n -- ? ) #! stack frame set up, and we want to read the frame #! set up by the caller. stack-frame get total-size>> + stack@ ; + +: enable-sse2 ( -- ) + enable-float-intrinsics + enable-fsqrt + enable-float-min/max ; diff --git a/basis/math/libm/libm.factor b/basis/math/libm/libm.factor index e2bd2ef6eb..d0a579e5f4 100644 --- a/basis/math/libm/libm.factor +++ b/basis/math/libm/libm.factor @@ -4,53 +4,54 @@ USING: alien ; IN: math.libm : facos ( x -- y ) - "double" "libm" "acos" { "double" } alien-invoke ; + "double" "libm" "acos" { "double" } alien-invoke ; inline : fasin ( x -- y ) - "double" "libm" "asin" { "double" } alien-invoke ; + "double" "libm" "asin" { "double" } alien-invoke ; inline : fatan ( x -- y ) - "double" "libm" "atan" { "double" } alien-invoke ; + "double" "libm" "atan" { "double" } alien-invoke ; inline : fatan2 ( x y -- z ) - "double" "libm" "atan2" { "double" "double" } alien-invoke ; + "double" "libm" "atan2" { "double" "double" } alien-invoke ; inline : fcos ( x -- y ) - "double" "libm" "cos" { "double" } alien-invoke ; + "double" "libm" "cos" { "double" } alien-invoke ; inline : fsin ( x -- y ) - "double" "libm" "sin" { "double" } alien-invoke ; + "double" "libm" "sin" { "double" } alien-invoke ; inline : ftan ( x -- y ) - "double" "libm" "tan" { "double" } alien-invoke ; + "double" "libm" "tan" { "double" } alien-invoke ; inline : fcosh ( x -- y ) - "double" "libm" "cosh" { "double" } alien-invoke ; + "double" "libm" "cosh" { "double" } alien-invoke ; inline : fsinh ( x -- y ) - "double" "libm" "sinh" { "double" } alien-invoke ; + "double" "libm" "sinh" { "double" } alien-invoke ; inline : ftanh ( x -- y ) - "double" "libm" "tanh" { "double" } alien-invoke ; + "double" "libm" "tanh" { "double" } alien-invoke ; inline : fexp ( x -- y ) - "double" "libm" "exp" { "double" } alien-invoke ; + "double" "libm" "exp" { "double" } alien-invoke ; inline : flog ( x -- y ) - "double" "libm" "log" { "double" } alien-invoke ; + "double" "libm" "log" { "double" } alien-invoke ; inline : fpow ( x y -- z ) - "double" "libm" "pow" { "double" "double" } alien-invoke ; + "double" "libm" "pow" { "double" "double" } alien-invoke ; inline +! Don't inline fsqrt -- its an intrinsic! : fsqrt ( x -- y ) "double" "libm" "sqrt" { "double" } alien-invoke ; ! Windows doesn't have these... : facosh ( x -- y ) - "double" "libm" "acosh" { "double" } alien-invoke ; + "double" "libm" "acosh" { "double" } alien-invoke ; inline : fasinh ( x -- y ) - "double" "libm" "asinh" { "double" } alien-invoke ; + "double" "libm" "asinh" { "double" } alien-invoke ; inline : fatanh ( x -- y ) - "double" "libm" "atanh" { "double" } alien-invoke ; + "double" "libm" "atanh" { "double" } alien-invoke ; inline diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index 97d952f845..a3dcd98f0e 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -17,7 +17,7 @@ M: struct-array length length>> ; inline M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline : (nth-ptr) ( i struct-array -- alien ) - [ element-size>> * ] [ underlying>> ] bi ; inline + [ element-size>> * >fixnum ] [ underlying>> ] bi ; inline M: struct-array nth-unsafe [ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline @@ -26,7 +26,7 @@ M: struct-array set-nth-unsafe [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline M: struct-array new-sequence - [ element-size>> [ * ] 2keep ] + [ element-size>> [ * (byte-array) ] 2keep ] [ class>> ] bi struct-array boa ; inline M: struct-array resize ( n seq -- newseq ) diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 661bccd88c..02dbd6ea84 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -3,6 +3,9 @@ USING: kernel math math.private ; IN: math.floats.private +: float-min ( x y -- z ) [ float< ] 2keep ? ; +: float-max ( x y -- z ) [ float> ] 2keep ? ; + M: fixnum >float fixnum>float ; inline M: bignum >float bignum>float ; inline diff --git a/core/math/order/order.factor b/core/math/order/order.factor index 707dc02af2..fe1454d1d8 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -32,8 +32,8 @@ M: real after? ( obj1 obj2 -- ? ) > ; inline M: real before=? ( obj1 obj2 -- ? ) <= ; inline M: real after=? ( obj1 obj2 -- ? ) >= ; inline -: min ( x y -- z ) [ before? ] most ; inline -: max ( x y -- z ) [ after? ] most ; inline +: min ( x y -- z ) [ before? ] most ; +: max ( x y -- z ) [ after? ] most ; : clamp ( x min max -- y ) [ max ] dip min ; inline : between? ( x y z -- ? ) From 624f6365330eb154e119c8ab040fb417394dad4f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Aug 2009 05:21:54 -0500 Subject: [PATCH 28/55] benchmark.struct-arrays: new benchmark to measure performance of struct-arrays, struct classes, and floating point math --- .../struct-arrays/struct-arrays.factor | 52 +++++++++++++++++++ 1 file changed, 52 insertions(+) create mode 100644 extra/benchmark/struct-arrays/struct-arrays.factor diff --git a/extra/benchmark/struct-arrays/struct-arrays.factor b/extra/benchmark/struct-arrays/struct-arrays.factor new file mode 100644 index 0000000000..827604a39e --- /dev/null +++ b/extra/benchmark/struct-arrays/struct-arrays.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors classes.struct combinators.smart fry kernel +math math.functions math.order math.parser sequences +struct-arrays hints io ; +IN: benchmark.struct-arrays + +STRUCT: point { x float } { y float } { z float } ; + +: xyz ( point -- x y z ) + [ x>> ] [ y>> ] [ z>> ] tri ; inline + +: change-xyz ( point obj x: ( x obj -- x' ) y: ( y obj -- y' ) z: ( z obj -- z' ) -- point ) + tri-curry [ change-x ] [ change-y ] [ change-z ] tri* ; inline + +: init-point ( n point -- n ) + over >fixnum >float + [ sin >>x ] [ cos 3 * >>y ] [ sin sq 2 / >>z ] tri drop + 1 + ; inline + +: make-points ( len -- points ) + point dup 0 [ init-point ] reduce drop ; inline + +: point-norm ( point -- norm ) + [ xyz [ absq ] tri@ ] sum-outputs sqrt ; inline + +: normalize-point ( point -- ) + dup point-norm [ / ] [ / ] [ / ] change-xyz drop ; inline + +: normalize-points ( points -- ) + [ normalize-point ] each ; inline + +: max-point ( point1 point2 -- point1 ) + [ x>> max ] [ y>> max ] [ z>> max ] change-xyz ; inline + +: ( -- point ) + 0 0 0 point ; inline + +: max-points ( points -- point ) + [ max-point ] reduce ; inline + +: print-point ( point -- ) + [ xyz [ number>string ] tri@ ] output>array ", " join print ; inline + +: struct-array-benchmark ( len -- ) + make-points [ normalize-points ] [ max-points ] bi print-point ; + +HINTS: struct-array-benchmark fixnum ; + +: main ( -- ) 5000000 struct-array-benchmark ; + +MAIN: main From a96743d3753c27aecd81edad1a8b2823fdc977d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Aug 2009 05:31:27 -0500 Subject: [PATCH 29/55] tools.deprecation: don't bail out if a word's usages are not all words --- basis/tools/deprecation/deprecation.factor | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/basis/tools/deprecation/deprecation.factor b/basis/tools/deprecation/deprecation.factor index 90dba554cb..d194870b18 100644 --- a/basis/tools/deprecation/deprecation.factor +++ b/basis/tools/deprecation/deprecation.factor @@ -39,12 +39,14 @@ T{ error-type : clear-deprecation-note ( word -- ) deprecation-notes get-global delete-at ; -: check-deprecations ( word -- ) - dup "forgotten" word-prop - [ clear-deprecation-note ] [ - dup def>> uses [ deprecated? ] filter - [ clear-deprecation-note ] [ >array deprecation-note ] if-empty - ] if ; +: check-deprecations ( usage -- ) + dup word? [ + dup "forgotten" word-prop + [ clear-deprecation-note ] [ + dup def>> uses [ deprecated? ] filter + [ clear-deprecation-note ] [ >array deprecation-note ] if-empty + ] if + ] [ drop ] if ; M: deprecated-usages summary drop "Deprecated words used" ; From 790e7ec0bc787f2c50551a1d9df67e7efd8e7030 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Aug 2009 05:32:34 -0500 Subject: [PATCH 30/55] tools.deprecation: suppress 'computing usage index...' message --- basis/tools/deprecation/deprecation.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/basis/tools/deprecation/deprecation.factor b/basis/tools/deprecation/deprecation.factor index d194870b18..ff6a7ef51a 100644 --- a/basis/tools/deprecation/deprecation.factor +++ b/basis/tools/deprecation/deprecation.factor @@ -1,6 +1,6 @@ ! (c)2009 Joe Groff bsd license -USING: accessors arrays assocs compiler.units -debugger init io kernel namespaces prettyprint sequences +USING: accessors arrays assocs compiler.units debugger init io +io.streams.null kernel namespaces prettyprint sequences source-files.errors summary tools.crossref tools.crossref.private tools.errors words ; IN: tools.deprecation @@ -60,8 +60,10 @@ M: deprecated-usages error. SINGLETON: deprecation-observer : initialize-deprecation-notes ( -- ) - get-crossref [ drop deprecated? ] assoc-filter - values [ keys [ check-deprecations ] each ] each ; + [ + get-crossref [ drop deprecated? ] assoc-filter + values [ keys [ check-deprecations ] each ] each + ] with-null-writer ; M: deprecation-observer definitions-changed drop keys [ word? ] filter From ff4213003b6ba918db7b3103c12c69fc73a82049 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Aug 2009 05:38:29 -0500 Subject: [PATCH 31/55] system-info.windows: fix load error --- extra/system-info/windows/nt/nt.factor | 4 ++-- extra/system-info/windows/windows.factor | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/system-info/windows/nt/nt.factor b/extra/system-info/windows/nt/nt.factor index a6b4c8176f..2c13c8d5d2 100755 --- a/extra/system-info/windows/nt/nt.factor +++ b/extra/system-info/windows/nt/nt.factor @@ -4,11 +4,11 @@ USING: alien alien.c-types alien.strings kernel libc math namespaces system-info.backend system-info.windows windows windows.advapi32 windows.kernel32 system byte-arrays windows.errors -classes classes.struct ; +classes classes.struct accessors ; IN: system-info.windows.nt M: winnt cpus ( -- n ) - system-info SYSTEM_INFO-dwNumberOfProcessors ; + system-info dwNumberOfProcessors>> ; : memory-status ( -- MEMORYSTATUSEX ) "MEMORYSTATUSEX" diff --git a/extra/system-info/windows/windows.factor b/extra/system-info/windows/windows.factor index 34915d0b7b..e68f6ce62f 100755 --- a/extra/system-info/windows/windows.factor +++ b/extra/system-info/windows/windows.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types kernel libc math namespaces -windows windows.kernel32 windows.advapi32 -words combinators vocabs.loader system-info.backend -system alien.strings windows.errors ; +USING: alien alien.c-types classes.struct accessors kernel +math namespaces windows windows.kernel32 windows.advapi32 words +combinators vocabs.loader system-info.backend system +alien.strings windows.errors ; IN: system-info.windows : system-info ( -- SYSTEM_INFO ) From c6c22a4d5d68f9a406d527f04e01006656ece979 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 28 Aug 2009 10:40:01 -0500 Subject: [PATCH 32/55] add a terrain-generation benchmark so slava will make it fast --- .../terrain-generation/terrain-generation.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 extra/benchmark/terrain-generation/terrain-generation.factor diff --git a/extra/benchmark/terrain-generation/terrain-generation.factor b/extra/benchmark/terrain-generation/terrain-generation.factor new file mode 100644 index 0000000000..7fbb0ff43f --- /dev/null +++ b/extra/benchmark/terrain-generation/terrain-generation.factor @@ -0,0 +1,10 @@ +! (c)Joe Groff bsd license +USING: io kernel terrain.generation threads ; +IN: benchmark.terrain-generation + +: terrain-generation-benchmark ( -- ) + "Generating terrain segment..." write flush yield + { 0.0 0.0 } terrain-segment drop + "done" print ; + +MAIN: terrain-generation-benchmark From 2bb6293217d0c6901cfb6d8aeebae86b44796374 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Aug 2009 19:02:59 -0500 Subject: [PATCH 33/55] compiler: add fixnum-min/max intrinsics; ~10% speedup on benchmark.yuv-to-rgb --- basis/compiler/cfg/hats/hats.factor | 2 + .../cfg/instructions/instructions.factor | 2 + .../compiler/cfg/intrinsics/intrinsics.factor | 21 +++++++--- .../cfg/two-operand/two-operand.factor | 2 + basis/compiler/codegen/codegen.factor | 2 + basis/compiler/tests/intrinsics.factor | 20 ++++++--- .../known-words/known-words.factor | 23 ++++++++--- .../propagation/transforms/transforms.factor | 41 ++++++++++++------- basis/cpu/architecture/architecture.factor | 2 + basis/cpu/x86/x86.factor | 6 +++ basis/math/intervals/intervals-tests.factor | 4 ++ basis/math/intervals/intervals.factor | 22 +++++++--- core/math/floats/floats.factor | 4 +- core/math/integers/integers.factor | 5 ++- 14 files changed, 117 insertions(+), 39 deletions(-) diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index de612f2c28..d0b2cd4d9e 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -35,6 +35,8 @@ IN: compiler.cfg.hats : ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline : ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline : ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline +: ^^min ( src1 src2 -- dst ) ^^r2 ##min ; inline +: ^^max ( src1 src2 -- dst ) ^^r2 ##max ; inline : ^^not ( src -- dst ) ^^r1 ##not ; inline : ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline : ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 41e227ed76..9706507193 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -91,6 +91,8 @@ INSN: ##shr < ##binary ; INSN: ##shr-imm < ##binary-imm ; INSN: ##sar < ##binary ; INSN: ##sar-imm < ##binary-imm ; +INSN: ##min < ##binary ; +INSN: ##max < ##binary ; INSN: ##not < ##unary ; INSN: ##log2 < ##unary ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 17e8a1336d..562c3ad836 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -25,6 +25,9 @@ QUALIFIED: math.floats.private QUALIFIED: math.libm IN: compiler.cfg.intrinsics +: enable-intrinsics ( words -- ) + [ t "intrinsic" set-word-prop ] each ; + { kernel.private:tag kernel.private:getenv @@ -67,7 +70,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-signed-2 alien.accessors:alien-cell alien.accessors:set-alien-cell -} [ t "intrinsic" set-word-prop ] each +} enable-intrinsics : enable-alien-4-intrinsics ( -- ) { @@ -75,7 +78,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-unsigned-4 alien.accessors:alien-signed-4 alien.accessors:set-alien-signed-4 - } [ t "intrinsic" set-word-prop ] each ; + } enable-intrinsics ; : enable-float-intrinsics ( -- ) { @@ -94,7 +97,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-float alien.accessors:alien-double alien.accessors:set-alien-double - } [ t "intrinsic" set-word-prop ] each ; + } enable-intrinsics ; : enable-fsqrt ( -- ) \ math.libm:fsqrt t "intrinsic" set-word-prop ; @@ -103,10 +106,16 @@ IN: compiler.cfg.intrinsics { math.floats.private:float-min math.floats.private:float-max - } [ t "intrinsic" set-word-prop ] each ; + } enable-intrinsics ; + +: enable-min/max ( -- ) + { + math.integers.private:fixnum-min + math.integers.private:fixnum-max + } enable-intrinsics ; : enable-fixnum-log2 ( -- ) - \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; + { math.integers.private:fixnum-log2 } enable-intrinsics ; : emit-intrinsic ( node word -- ) { @@ -130,6 +139,8 @@ IN: compiler.cfg.intrinsics { \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] } { \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] } { \ kernel:eq? [ drop cc= emit-fixnum-comparison ] } + { \ math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] } + { \ math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] } { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] } { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] } { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index e8fc036020..15151ff9e6 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -35,6 +35,8 @@ UNION: two-operand-insn ##shr-imm ##sar ##sar-imm + ##min + ##max ##fixnum-overflow ##add-float ##sub-float diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 7c95c9d0a8..c0f793a7dc 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -149,6 +149,8 @@ M: ##shr generate-insn dst/src1/src2 %shr ; M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ; M: ##sar generate-insn dst/src1/src2 %sar ; M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ; +M: ##min generate-insn dst/src1/src2 %min ; +M: ##max generate-insn dst/src1/src2 %max ; M: ##not generate-insn dst/src %not ; M: ##log2 generate-insn dst/src %log2 ; diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 6180e49bef..23d26b0033 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -1,11 +1,10 @@ -USING: accessors arrays compiler.units kernel kernel.private math -math.constants math.private sequences strings tools.test words -continuations sequences.private hashtables.private byte-arrays -system random layouts vectors +USING: accessors arrays compiler.units kernel kernel.private +math math.constants math.private math.integers.private sequences +strings tools.test words continuations sequences.private +hashtables.private byte-arrays system random layouts vectors sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.syntax alien.strings -namespaces libc io.encodings.ascii -classes compiler ; +namespaces libc io.encodings.ascii classes compiler ; IN: compiler.tests.intrinsics ! Make sure that intrinsic ops compile to correct code. @@ -271,6 +270,15 @@ cell 8 = [ [ 100000 swap array-nth ] compile-call ] unit-test +[ 2 ] [ 2 4 [ fixnum-min ] compile-call ] unit-test +[ 2 ] [ 4 2 [ fixnum-min ] compile-call ] unit-test +[ 4 ] [ 2 4 [ fixnum-max ] compile-call ] unit-test +[ 4 ] [ 4 2 [ fixnum-max ] compile-call ] unit-test +[ -2 ] [ -2 -4 [ fixnum-max ] compile-call ] unit-test +[ -2 ] [ -4 -2 [ fixnum-max ] compile-call ] unit-test +[ -4 ] [ -2 -4 [ fixnum-min ] compile-call ] unit-test +[ -4 ] [ -4 -2 [ fixnum-min ] compile-call ] unit-test + ! 64-bit overflow cell 8 = [ [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index efcf05d7bc..69785c8c0a 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -79,11 +79,16 @@ IN: compiler.tree.propagation.known-words ] unless ; : ensure-math-class ( class must-be -- class' ) - [ class<= ] 2keep ? ; + [ class<= ] most ; : number-valued ( class interval -- class' interval' ) [ number ensure-math-class ] dip ; +: fixnum-valued ( class interval -- class' interval' ) + over null-class? [ + [ drop fixnum ] dip + ] unless ; + : integer-valued ( class interval -- class' interval' ) [ integer ensure-math-class ] dip ; @@ -304,7 +309,15 @@ flog fpow fsqrt facosh fasinh fatanh } [ { float } "default-output-classes" set-word-prop ] each -{ float-min float-max } [ - [ { float float } "input-classes" set-word-prop ] - [ { float } "default-output-classes" set-word-prop ] bi -] each +! Find a less repetitive way of doing this +\ float-min { float float } "input-classes" set-word-prop +\ float-min [ interval-min ] [ float-valued ] binary-op + +\ float-max { float float } "input-classes" set-word-prop +\ float-max [ interval-max ] [ float-valued ] binary-op + +\ fixnum-min { fixnum fixnum } "input-classes" set-word-prop +\ fixnum-min [ interval-min ] [ fixnum-valued ] binary-op + +\ fixnum-max { fixnum fixnum } "input-classes" set-word-prop +\ fixnum-max [ interval-max ] [ fixnum-valued ] binary-op diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index d0362b3222..9d0e5c8999 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences words fry generic accessors classes.tuple -classes classes.algebra definitions stack-checker.state quotations -classes.tuple.private math math.partial-dispatch math.private -math.intervals math.floats.private layouts math.order vectors hashtables -combinators effects generalizations assocs sets -combinators.short-circuit sequences.private locals +USING: kernel sequences words fry generic accessors +classes.tuple classes classes.algebra definitions +stack-checker.state quotations classes.tuple.private math +math.partial-dispatch math.private math.intervals +math.floats.private math.integers.private layouts math.order +vectors hashtables combinators effects generalizations assocs +sets combinators.short-circuit sequences.private locals stack-checker namespaces compiler.tree.propagation.info ; IN: compiler.tree.propagation.transforms @@ -79,15 +80,25 @@ IN: compiler.tree.propagation.transforms ] [ f ] if ] "custom-inlining" set-word-prop -{ - { min [ float-min ] } - { max [ float-max ] } -} [ - '[ - in-d>> first2 [ value-info class>> float class<= ] both? - [ _ ] [ f ] if - ] "custom-inlining" set-word-prop -] assoc-each +! Integrate this with generic arithmetic optimization instead? +: both-inputs? ( #call class -- ? ) + [ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ; + +\ min [ + { + { [ dup fixnum both-inputs? ] [ [ fixnum-min ] ] } + { [ dup float both-inputs? ] [ [ float-min ] ] } + [ f ] + } cond nip +] "custom-inlining" set-word-prop + +\ max [ + { + { [ dup fixnum both-inputs? ] [ [ fixnum-max ] ] } + { [ dup float both-inputs? ] [ [ float-max ] ] } + [ f ] + } cond nip +] "custom-inlining" set-word-prop ! Generate more efficient code for common idiom \ clone [ diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 41cbd30146..fc972229e8 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -96,6 +96,8 @@ HOOK: %shr cpu ( dst src1 src2 -- ) HOOK: %shr-imm cpu ( dst src1 src2 -- ) HOOK: %sar cpu ( dst src1 src2 -- ) HOOK: %sar-imm cpu ( dst src1 src2 -- ) +HOOK: %min cpu ( dst src1 src2 -- ) +HOOK: %max cpu ( dst src1 src2 -- ) HOOK: %not cpu ( dst src -- ) HOOK: %log2 cpu ( dst src -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 12414c3f94..da7b89de0b 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -123,6 +123,10 @@ M: x86 %xor-imm nip XOR ; M: x86 %shl-imm nip SHL ; M: x86 %shr-imm nip SHR ; M: x86 %sar-imm nip SAR ; + +M: x86 %min nip [ CMP ] [ CMOVG ] 2bi ; +M: x86 %max nip [ CMP ] [ CMOVL ] 2bi ; + M: x86 %not drop NOT ; M: x86 %log2 BSR ; @@ -579,3 +583,5 @@ M: x86 small-enough? ( n -- ? ) enable-float-intrinsics enable-fsqrt enable-float-min/max ; + +enable-min/max diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 4e44fc1208..1ee4e1e100 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -235,6 +235,10 @@ IN: math.intervals.tests interval-contains? ] unit-test +[ t ] [ full-interval 10 10 [a,b] interval-max 10 1/0. [a,b] = ] unit-test + +[ t ] [ full-interval 10 10 [a,b] interval-min -1/0. 10 [a,b] = ] unit-test + [ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test ! Accuracy of interval-mod diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 99997ab8cb..05f9906bb9 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -7,7 +7,7 @@ IN: math.intervals SYMBOL: empty-interval -SYMBOL: full-interval +SINGLETON: full-interval TUPLE: interval { from read-only } { to read-only } ; @@ -238,12 +238,24 @@ MEMO: array-capacity-interval ( -- interval ) ] do-empty-interval ; : interval-max ( i1 i2 -- i3 ) - #! Inaccurate; could be tighter - [ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ] do-empty-interval ; + { + { [ over empty-interval eq? ] [ drop ] } + { [ dup empty-interval eq? ] [ nip ] } + { [ 2dup [ full-interval eq? ] both? ] [ drop ] } + { [ over full-interval eq? ] [ nip from>> first [a,inf] ] } + { [ dup full-interval eq? ] [ drop from>> first [a,inf] ] } + [ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ] + } cond ; : interval-min ( i1 i2 -- i3 ) - #! Inaccurate; could be tighter - [ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ] do-empty-interval ; + { + { [ over empty-interval eq? ] [ drop ] } + { [ dup empty-interval eq? ] [ nip ] } + { [ 2dup [ full-interval eq? ] both? ] [ drop ] } + { [ over full-interval eq? ] [ nip to>> first [-inf,a] ] } + { [ dup full-interval eq? ] [ drop to>> first [-inf,a] ] } + [ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ] + } cond ; : interval-interior ( i1 -- i2 ) dup special-interval? [ diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 02dbd6ea84..53c3fe543e 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -3,8 +3,8 @@ USING: kernel math math.private ; IN: math.floats.private -: float-min ( x y -- z ) [ float< ] 2keep ? ; -: float-max ( x y -- z ) [ float> ] 2keep ? ; +: float-min ( x y -- z ) [ float< ] most ; foldable +: float-max ( x y -- z ) [ float> ] most ; foldable M: fixnum >float fixnum>float ; inline M: bignum >float bignum>float ; inline diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 75abd8087e..ed25e3bfa6 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -1,10 +1,13 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! Copyright (C) 2008, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private sequences sequences.private math math.private combinators ; IN: math.integers.private +: fixnum-min ( x y -- z ) [ fixnum< ] most ; foldable +: fixnum-max ( x y -- z ) [ fixnum> ] most ; foldable + M: integer numerator ; inline M: integer denominator drop 1 ; inline From 908b4742c5bb3d9c4d2eb47f2a7240f591d3e9e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Aug 2009 19:05:49 -0500 Subject: [PATCH 34/55] compiler.cfg.value-numbering: fix ##box-displaced-alien simplification --- basis/compiler/cfg/value-numbering/simplify/simplify.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor index d38159b4b4..6508801840 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -112,7 +112,7 @@ M: binary-expr simplify* M: box-displaced-alien-expr simplify* [ base>> ] [ displacement>> ] bi { - { [ dup expr-zero? ] [ drop ] } + { [ dup vn>expr expr-zero? ] [ drop ] } [ 2drop f ] } cond ; From d26735c98f1887c0de61bf4f62b82f440d644b92 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 10:29:41 -0500 Subject: [PATCH 35/55] mark integer sequence methods as deprecated --- core/sequences/sequences.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 177a157994..90103a79f9 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -98,9 +98,9 @@ M: f like drop [ f ] when-empty ; inline INSTANCE: f immutable-sequence -! Integers support the sequence protocol -M: integer length ; inline -M: integer nth-unsafe drop ; inline +! Integers used to support the sequence protocol +M: integer length ; inline deprecated +M: integer nth-unsafe drop ; inline deprecated INSTANCE: integer immutable-sequence From 8a9d0e13bbfd821d12d0a0ecaec7b2f4fd50e473 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 11:15:23 -0500 Subject: [PATCH 36/55] deprecate , and make malloc-array box its returned buffer in a direct array --- basis/alien/c-types/c-types-docs.factor | 10 ++++++---- basis/alien/c-types/c-types.factor | 4 ++-- basis/specialized-arrays/functor/functor.factor | 3 +++ 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index f5f9e004c4..e7083a2a3a 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -49,12 +49,11 @@ HELP: c-setter { $errors "Throws an error if the type does not exist." } ; HELP: +{ $deprecated "New code should use " { $link } " or the " { $vocab-link "specialized-arrays" } " vocabularies." } { $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } } { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." } { $errors "Throws an error if the type does not exist or the requested size is negative." } ; -{ malloc-array } related-words - HELP: { $values { "type" "a C type" } { "array" byte-array } } { $description "Creates a byte array suitable for holding a value with the given C type." } @@ -73,9 +72,10 @@ HELP: byte-array>memory HELP: malloc-array { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } } -{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." } +{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link } "." } +{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ; { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } -{ $errors "Throws an error if the type does not exist, if the requested size is negative, or if memory allocation fails." } ; +{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ; HELP: malloc-object { $values { "type" "a C type" } { "alien" alien } } @@ -89,6 +89,8 @@ HELP: malloc-byte-array { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } { $errors "Throws an error if memory allocation fails." } ; +{ malloc-array } related-words + HELP: box-parameter { $values { "n" integer } { "ctype" string } } { $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." } diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 4c3c8d1668..6b56f52232 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -254,13 +254,13 @@ M: f byte-length drop 0 ; inline ] unless* ; : ( n type -- array ) - heap-size * ; inline + heap-size * ; inline deprecated : ( type -- array ) 1 swap ; inline : malloc-array ( n type -- alien ) - heap-size calloc ; inline + [ heap-size calloc ] [ ] 2bi ; inline : malloc-object ( type -- alien ) 1 swap malloc-array ; inline diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 3341a909d2..f5aca7fb95 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -13,6 +13,9 @@ M: bad-byte-array-length summary : (c-array) ( n c-type -- array ) heap-size * (byte-array) ; inline +: ( n type -- array ) + heap-size * ; inline + FUNCTOR: define-array ( T -- ) A DEFINES-CLASS ${T}-array From 2eff5542735dc37fa072096c73b145e4bb1ae628 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 12:22:55 -0500 Subject: [PATCH 37/55] update cocoa and core-foundation stuff to use classes.struct and boxed malloc-arrays --- basis/cocoa/enumeration/enumeration.factor | 19 ++--- basis/cocoa/messages/messages.factor | 17 ++--- basis/cocoa/runtime/runtime.factor | 8 +- basis/cocoa/types/types.factor | 24 +++--- basis/cocoa/views/views.factor | 2 +- basis/core-foundation/core-foundation.factor | 14 ++-- .../core-foundation/fsevents/fsevents.factor | 18 ++--- basis/core-graphics/types/types.factor | 73 +++++++++---------- basis/core-text/core-text.factor | 4 +- 9 files changed, 83 insertions(+), 96 deletions(-) diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor index 1f9430e443..9da68e368b 100644 --- a/basis/cocoa/enumeration/enumeration.factor +++ b/basis/cocoa/enumeration/enumeration.factor @@ -1,27 +1,28 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel cocoa cocoa.types alien.c-types locals math -sequences vectors fry libc destructors -specialized-arrays.direct.alien ; +USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types +locals math sequences vectors fry libc destructors ; IN: cocoa.enumeration +<< "id" require-c-type-arrays >> + CONSTANT: NS-EACH-BUFFER-SIZE 16 : with-enumeration-buffers ( quot -- ) '[ - "NSFastEnumerationState" malloc-object &free + NSFastEnumerationState malloc-struct &free NS-EACH-BUFFER-SIZE "id" malloc-array &free NS-EACH-BUFFER-SIZE @ ] with-destructors ; inline :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- ) - object state stackbuf count -> countByEnumeratingWithState:objects:count: - dup 0 = [ drop ] [ - state NSFastEnumerationState-itemsPtr [ stackbuf ] unless* - swap quot each + object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count + items-count 0 = [ + state itemsPtr>> [ items-count "id" ] [ stackbuf ] if* :> items + items-count iota [ items nth quot call ] each object quot state stackbuf count (NSFastEnumeration-each) - ] if ; inline recursive + ] unless ; inline recursive : NSFastEnumeration-each ( object quot -- ) [ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 9da285f34c..fe003c32e1 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.strings arrays assocs -continuations combinators compiler compiler.alien stack-checker kernel -math namespaces make quotations sequences strings words -cocoa.runtime io macros memoize io.encodings.utf8 effects libc -libc.private lexer init core-foundation fry generalizations -specialized-arrays.direct.alien ; +classes.struct continuations combinators compiler compiler.alien +stack-checker kernel math namespaces make quotations sequences +strings words cocoa.runtime io macros memoize io.encodings.utf8 +effects libc libc.private lexer init core-foundation fry +generalizations specialized-arrays.direct.alien ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -31,11 +31,8 @@ super-message-senders [ H{ } clone ] initialize bi ; : ( receiver -- super ) - "objc-super" [ - [ dup object_getClass class_getSuperclass ] dip - set-objc-super-class - ] keep - [ set-objc-super-receiver ] keep ; + [ ] [ object_getClass class_getSuperclass ] bi + objc-super ; TUPLE: selector name object ; diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 7817d0006c..28d812a489 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/basis/cocoa/runtime/runtime.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax classes.struct ; IN: cocoa.runtime TYPEDEF: void* SEL @@ -17,9 +17,9 @@ TYPEDEF: void* Class TYPEDEF: void* Method TYPEDEF: void* Protocol -C-STRUCT: objc-super - { "id" "receiver" } - { "Class" "class" } ; +STRUCT: objc-super + { receiver id } + { class Class } ; CONSTANT: CLS_CLASS HEX: 1 CONSTANT: CLS_META HEX: 2 diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index 6e03a21bbc..0e0ef72ad2 100644 --- a/basis/cocoa/types/types.factor +++ b/basis/cocoa/types/types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax combinators kernel layouts -core-graphics.types ; +classes.struct core-graphics.types ; IN: cocoa.types TYPEDEF: long NSInteger @@ -16,9 +16,9 @@ TYPEDEF: NSSize _NSSize TYPEDEF: CGRect NSRect TYPEDEF: NSRect _NSRect -C-STRUCT: NSRange - { "NSUInteger" "location" } - { "NSUInteger" "length" } ; +STRUCT: NSRange + { location NSUInteger } + { length NSUInteger } ; TYPEDEF: NSRange _NSRange @@ -27,13 +27,11 @@ TYPEDEF: int long32 TYPEDEF: uint ulong32 TYPEDEF: void* unknown_type -: ( length location -- size ) - "NSRange" - [ set-NSRange-length ] keep - [ set-NSRange-location ] keep ; +: ( location length -- size ) + NSRange ; -C-STRUCT: NSFastEnumerationState - { "ulong" "state" } - { "id*" "itemsPtr" } - { "ulong*" "mutationsPtr" } - { "ulong[5]" "extra" } ; +STRUCT: NSFastEnumerationState + { state ulong } + { itemsPtr id* } + { mutationsPtr ulong* } + { extra ulong[5] } ; diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index ce785dd8df..badcac5cdb 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -58,6 +58,6 @@ CONSTANT: NSOpenGLCPSwapInterval 222 : mouse-location ( view event -- loc ) [ -> locationInWindow f -> convertPoint:fromView: - [ CGPoint-x ] [ CGPoint-y ] bi + [ x>> ] [ y>> ] bi ] [ drop -> frame CGRect-h ] 2bi swap - [ >integer ] bi@ 2array ; diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 82f836f28e..63bfaf37ce 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax alien.c-types alien.destructors accessors kernel ; +USING: alien.syntax alien.c-types alien.destructors accessors classes.struct kernel ; IN: core-foundation TYPEDEF: void* CFTypeRef @@ -20,17 +20,15 @@ TYPEDEF: void* CFUUIDRef ALIAS: ALIAS: *CFIndex *long -C-STRUCT: CFRange -{ "CFIndex" "location" } -{ "CFIndex" "length" } ; +STRUCT: CFRange + { location CFIndex } + { length CFIndex } ; : ( location length -- range ) - "CFRange" - [ set-CFRange-length ] keep - [ set-CFRange-location ] keep ; + CFRange ; FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ; FUNCTION: void CFRelease ( CFTypeRef cf ) ; -DESTRUCTOR: CFRelease \ No newline at end of file +DESTRUCTOR: CFRelease diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 4aa531f182..4b2cce994a 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.strings alien.syntax kernel math sequences namespaces make assocs init accessors continuations combinators io.encodings.utf8 destructors locals -arrays specialized-arrays.direct.alien +arrays specialized-arrays.direct.alien classes.struct specialized-arrays.direct.int specialized-arrays.direct.longlong core-foundation core-foundation.run-loop core-foundation.strings core-foundation.time ; @@ -26,12 +26,12 @@ TYPEDEF: int FSEventStreamEventFlags TYPEDEF: longlong FSEventStreamEventId TYPEDEF: void* FSEventStreamRef -C-STRUCT: FSEventStreamContext - { "CFIndex" "version" } - { "void*" "info" } - { "void*" "retain" } - { "void*" "release" } - { "void*" "copyDescription" } ; +STRUCT: FSEventStreamContext + { version CFIndex } + { info void* } + { retain void* } + { release void* } + { copyDescription void* } ; ! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]); TYPEDEF: void* FSEventStreamCallback @@ -104,8 +104,8 @@ FUNCTION: void FSEventStreamShow ( FSEventStreamRef streamRef ) ; FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef ) ; : make-FSEventStreamContext ( info -- alien ) - "FSEventStreamContext" - [ set-FSEventStreamContext-info ] keep ; + FSEventStreamContext + swap >>info ; :: ( callback info paths latency flags -- event-stream ) f ! allocator diff --git a/basis/core-graphics/types/types.factor b/basis/core-graphics/types/types.factor index 0acdad9c0c..ad4620e174 100644 --- a/basis/core-graphics/types/types.factor +++ b/basis/core-graphics/types/types.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax kernel layouts +USING: accessors alien.c-types alien.syntax classes.struct kernel layouts math math.rectangles arrays ; IN: core-graphics.types @@ -12,63 +12,56 @@ IN: core-graphics.types : *CGFloat ( alien -- x ) cell 4 = [ *float ] [ *double ] if ; inline -C-STRUCT: CGPoint - { "CGFloat" "x" } - { "CGFloat" "y" } ; +STRUCT: CGPoint + { x CGFloat } + { y CGFloat } ; : ( x y -- point ) - "CGPoint" - [ set-CGPoint-y ] keep - [ set-CGPoint-x ] keep ; + CGPoint ; -C-STRUCT: CGSize - { "CGFloat" "w" } - { "CGFloat" "h" } ; +STRUCT: CGSize + { w CGFloat } + { h CGFloat } ; : ( w h -- size ) - "CGSize" - [ set-CGSize-h ] keep - [ set-CGSize-w ] keep ; + CGSize ; -C-STRUCT: CGRect - { "CGPoint" "origin" } - { "CGSize" "size" } ; +STRUCT: CGRect + { origin CGPoint } + { size CGSize } ; : CGPoint>loc ( CGPoint -- loc ) - [ CGPoint-x ] [ CGPoint-y ] bi 2array ; + [ x>> ] [ y>> ] bi 2array ; : CGSize>dim ( CGSize -- dim ) - [ CGSize-w ] [ CGSize-h ] bi 2array ; + [ w>> ] [ h>> ] bi 2array ; : CGRect>rect ( CGRect -- rect ) - [ CGRect-origin CGPoint>loc ] - [ CGRect-size CGSize>dim ] + [ origin>> CGPoint>loc ] + [ size>> CGSize>dim ] bi ; inline : CGRect-x ( CGRect -- x ) - CGRect-origin CGPoint-x ; inline + origin>> x>> ; inline : CGRect-y ( CGRect -- y ) - CGRect-origin CGPoint-y ; inline + origin>> y>> ; inline : CGRect-w ( CGRect -- w ) - CGRect-size CGSize-w ; inline + size>> w>> ; inline : CGRect-h ( CGRect -- h ) - CGRect-size CGSize-h ; inline + size>> h>> ; inline : set-CGRect-x ( x CGRect -- ) - CGRect-origin set-CGPoint-x ; inline + origin>> (>>x) ; inline : set-CGRect-y ( y CGRect -- ) - CGRect-origin set-CGPoint-y ; inline + origin>> (>>y) ; inline : set-CGRect-w ( w CGRect -- ) - CGRect-size set-CGSize-w ; inline + size>> (>>w) ; inline : set-CGRect-h ( h CGRect -- ) - CGRect-size set-CGSize-h ; inline + size>> (>>h) ; inline : ( x y w h -- rect ) - "CGRect" - [ set-CGRect-h ] keep - [ set-CGRect-w ] keep - [ set-CGRect-y ] keep - [ set-CGRect-x ] keep ; + [ CGPoint ] [ CGSize ] 2bi* + CGRect ; : CGRect-x-y ( alien -- origin-x origin-y ) [ CGRect-x ] [ CGRect-y ] bi ; @@ -76,13 +69,13 @@ C-STRUCT: CGRect : CGRect-top-left ( alien -- x y ) [ CGRect-x ] [ [ CGRect-y ] [ CGRect-h ] bi + ] bi ; -C-STRUCT: CGAffineTransform - { "CGFloat" "a" } - { "CGFloat" "b" } - { "CGFloat" "c" } - { "CGFloat" "d" } - { "CGFloat" "tx" } - { "CGFloat" "ty" } ; +STRUCT: CGAffineTransform + { a CGFloat } + { b CGFloat } + { c CGFloat } + { d CGFloat } + { tx CGFloat } + { ty CGFloat } ; TYPEDEF: void* CGColorRef TYPEDEF: void* CGColorSpaceRef diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor index 52f4eb5e2e..99849c1666 100644 --- a/basis/core-text/core-text.factor +++ b/basis/core-text/core-text.factor @@ -116,8 +116,8 @@ TUPLE: line < disposable line metrics image loc dim ; line [ string open-font font foreground>> |CFRelease ] rect [ line line-rect ] - (loc) [ rect CGRect-origin CGPoint>loc ] - (dim) [ rect CGRect-size CGSize>dim ] + (loc) [ rect origin>> CGPoint>loc ] + (dim) [ rect size>> CGSize>dim ] (ext) [ (loc) (dim) v+ ] loc [ (loc) [ floor ] map ] ext [ (loc) (dim) [ + ceiling ] 2map ] From 64baa58a3d8a5fabb9e9bf632dfcb76045d7b9ad Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 12:23:09 -0500 Subject: [PATCH 38/55] typo in alien.c-types docs --- basis/alien/c-types/c-types-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index e7083a2a3a..cd0f90f81c 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -73,7 +73,7 @@ HELP: byte-array>memory HELP: malloc-array { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } } { $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link } "." } -{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ; +{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } { $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ; From 0e8fe01d11279b97cbfd03c87e3db0a93943b11b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 12:45:59 -0500 Subject: [PATCH 39/55] change malloc-object and not to be in terms of malloc-array and --- basis/alien/c-types/c-types.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 6b56f52232..8a1b60a0db 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -257,13 +257,16 @@ M: f byte-length drop 0 ; inline heap-size * ; inline deprecated : ( type -- array ) - 1 swap ; inline + heap-size ; inline + +: (c-object) ( type -- array ) + heap-size (byte-array) ; inline : malloc-array ( n type -- alien ) [ heap-size calloc ] [ ] 2bi ; inline : malloc-object ( type -- alien ) - 1 swap malloc-array ; inline + heap-size malloc ; inline : malloc-byte-array ( byte-array -- alien ) dup byte-length [ nip malloc dup ] 2keep memcpy ; From e5897d52b26cc6196e73e41f8c29eb155b14ebcb Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 29 Aug 2009 21:42:15 +0200 Subject: [PATCH 40/55] Ensure that random-prime result has the right size As noted by Slava, choosing the next prime following a random number with a specified number of bits may give a number one more bit long. --- basis/math/primes/primes.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index 7e877a03ce..27743a4a85 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -56,7 +56,8 @@ PRIVATE> : coprime? ( a b -- ? ) gcd nip 1 = ; foldable : random-prime ( numbits -- p ) - random-bits* next-prime ; + [ ] [ 2^ ] [ random-bits* next-prime ] tri + 2dup < [ 2drop random-prime ] [ 2nip ] if ; : estimated-primes ( m -- n ) dup log / ; foldable From a71f242578c02bd24360f097c7649bb648a90145 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 15:28:31 -0500 Subject: [PATCH 41/55] change malloc-object back to using calloc --- basis/alien/c-types/c-types.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 8a1b60a0db..13607566e0 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -266,7 +266,7 @@ M: f byte-length drop 0 ; inline [ heap-size calloc ] [ ] 2bi ; inline : malloc-object ( type -- alien ) - heap-size malloc ; inline + 1 swap heap-size calloc ; inline : malloc-byte-array ( byte-array -- alien ) dup byte-length [ nip malloc dup ] 2keep memcpy ; From 4e7bada863c2988c25e477419f4fb8bd6cde1408 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 17:17:25 -0500 Subject: [PATCH 42/55] use calloc in malloc-struct for consistency with malloc-object and malloc-array --- basis/classes/struct/struct.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 2cafb5e8fe..88c207f418 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -45,7 +45,7 @@ M: struct equal? ] 1 define-partial-eval : malloc-struct ( class -- struct ) - [ heap-size malloc ] keep memory>struct ; inline + [ 1 swap heap-size calloc ] keep memory>struct ; inline : (struct) ( class -- struct ) [ heap-size ] keep memory>struct ; inline From 51405868d1c8fd970f29f0bff7cf0e97fdcc96e8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 17:41:21 -0500 Subject: [PATCH 43/55] ignore deprecations in words that are themselves deprecated --- basis/tools/deprecation/deprecation.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/tools/deprecation/deprecation.factor b/basis/tools/deprecation/deprecation.factor index ff6a7ef51a..0ee60b06b5 100644 --- a/basis/tools/deprecation/deprecation.factor +++ b/basis/tools/deprecation/deprecation.factor @@ -1,5 +1,6 @@ ! (c)2009 Joe Groff bsd license -USING: accessors arrays assocs compiler.units debugger init io +USING: accessors arrays assocs combinators.short-circuit +compiler.units debugger init io io.streams.null kernel namespaces prettyprint sequences source-files.errors summary tools.crossref tools.crossref.private tools.errors words ; @@ -41,7 +42,7 @@ T{ error-type : check-deprecations ( usage -- ) dup word? [ - dup "forgotten" word-prop + dup { [ "forgotten" word-prop ] [ deprecated? ] } 1|| [ clear-deprecation-note ] [ dup def>> uses [ deprecated? ] filter [ clear-deprecation-note ] [ >array deprecation-note ] if-empty From 4cc2330a2a9239d019b45db76b6143040e7473cf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 19:56:42 -0500 Subject: [PATCH 44/55] add STRUCT: support to functors --- basis/functors/functors-tests.factor | 65 +++++++++++++++++++++++++++- basis/functors/functors.factor | 39 +++++++++++++++-- 2 files changed, 99 insertions(+), 5 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a21313312b..a8d97927f8 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,5 +1,5 @@ -USING: functors tools.test math words kernel multiline parser -io.streams.string generic ; +USING: classes.struct functors tools.test math words kernel +multiline parser io.streams.string generic ; IN: functors.tests << @@ -151,3 +151,64 @@ SYMBOL: W-symbol test-redefinition +<< + +FUNCTOR: define-a-struct ( T NAME TYPE N -- ) + +T-class DEFINES-CLASS ${T} + +WHERE + +STRUCT: T-class + { NAME int } + { "x" { TYPE 4 } } + { "y" { "short" N } } + { "z" TYPE initial: 5 } + { "w" { "int" 2 } } ; + +;FUNCTOR + +"a-struct" "nemo" "char" 2 define-a-struct + +>> + +[ + { + T{ struct-slot-spec + { name "nemo" } + { offset 0 } + { class integer } + { initial 0 } + { c-type "int" } + } + T{ struct-slot-spec + { name "x" } + { offset 4 } + { class object } + { initial f } + { c-type { "char" 4 } } + } + T{ struct-slot-spec + { name "y" } + { offset 8 } + { class object } + { initial f } + { c-type { "short" 2 } } + } + T{ struct-slot-spec + { name "z" } + { offset 12 } + { class fixnum } + { initial 5 } + { c-type "char" } + } + T{ struct-slot-spec + { name "w" } + { offset 16 } + { class object } + { initial f } + { c-type { "int" 2 } } + } + } +] [ a-struct struct-slots ] unit-test + diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 5f519aeece..befe3aa174 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes.mixin classes.parser -classes.singleton classes.tuple classes.tuple.parser +classes.singleton classes.struct classes.tuple classes.tuple.parser combinators effects.parser fry generic generic.parser generic.standard interpolate io.streams.string kernel lexer -locals.parser locals.types macros make namespaces parser -quotations sequences vocabs.parser words words.symbol ; +locals locals.parser locals.types macros make namespaces parser +quotations sequences slots vectors vocabs.parser words words.symbol ; IN: functors ! This is a hack @@ -58,6 +58,32 @@ M: object (fake-quotations>) , ; [ parse-definition* ] dip parsed ; +: scan-c-type* ( -- c-type/param ) + scan { + { [ dup "{" = ] [ drop \ } parse-until >array ] } + { [ dup search ] [ search ] } + [ ] + } cond ; + +:: parse-struct-slot* ( accum -- accum ) + scan-param :> name + scan-c-type* :> c-type + \ } parse-until :> attributes + accum { + \ struct-slot-spec new + name >>name + c-type [ >>c-type ] [ struct-slot-class >>class ] bi + attributes [ dup empty? ] [ peel-off-attributes ] until drop + over push + } over push-all ; + +: parse-struct-slots* ( accum -- accum more? ) + scan { + { ";" [ f ] } + { "{" [ parse-struct-slot* t ] } + [ invalid-struct-slot ] + } case ; + SYNTAX: `TUPLE: scan-param parsed scan { @@ -71,6 +97,12 @@ SYNTAX: `TUPLE: } case \ define-tuple-class parsed ; +SYNTAX: `STRUCT: + scan-param parsed + [ 8 ] over push-all + [ parse-struct-slots* ] [ ] while + [ >array define-struct-class ] over push-all ; + SYNTAX: `SINGLETON: scan-param parsed \ define-singleton-class parsed ; @@ -147,6 +179,7 @@ DEFER: ;FUNCTOR delimiter : functor-words ( -- assoc ) H{ { "TUPLE:" POSTPONE: `TUPLE: } + { "STRUCT:" POSTPONE: `STRUCT: } { "SINGLETON:" POSTPONE: `SINGLETON: } { "MIXIN:" POSTPONE: `MIXIN: } { "M:" POSTPONE: `M: } From 309b11213c317248b2cd440cc7a191e89bb9ec51 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 19:58:07 -0500 Subject: [PATCH 45/55] correct some classes.struct docs --- basis/classes/struct/struct-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor index 2b27672018..bcc77f1b25 100644 --- a/basis/classes/struct/struct-docs.factor +++ b/basis/classes/struct/struct-docs.factor @@ -40,13 +40,13 @@ HELP: UNION-STRUCT: HELP: define-struct-class { $values - { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" } + { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" } } { $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ; HELP: define-union-struct-class { $values - { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" } + { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" } } { $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ; @@ -55,7 +55,7 @@ HELP: malloc-struct { "class" class } { "struct" struct } } -{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ; +{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are zeroed out. The struct should be " { $link free } "d when it is no longer needed." } ; HELP: memory>struct { $values From 2e3f75fd8783fdabb27b77b2cc00c70927245958 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 20:19:47 -0500 Subject: [PATCH 46/55] fix STRUCT: functor when a slot name is the same as a non-lexical word name --- basis/functors/functors-tests.factor | 12 ++++++------ basis/functors/functors.factor | 14 ++++++++------ 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a8d97927f8..bcdc1bae74 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -161,10 +161,10 @@ WHERE STRUCT: T-class { NAME int } - { "x" { TYPE 4 } } - { "y" { "short" N } } - { "z" TYPE initial: 5 } - { "w" { "int" 2 } } ; + { x { TYPE 4 } } + { y { "short" N } } + { z TYPE initial: 5 } + { float { "float" 2 } } ; ;FUNCTOR @@ -203,11 +203,11 @@ STRUCT: T-class { c-type "char" } } T{ struct-slot-spec - { name "w" } + { name "float" } { offset 16 } { class object } { initial f } - { c-type { "int" 2 } } + { c-type { "float" 2 } } } } ] [ a-struct struct-slots ] unit-test diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index befe3aa174..dcfd140e92 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -58,15 +58,17 @@ M: object (fake-quotations>) , ; [ parse-definition* ] dip parsed ; +: >string-param ( string -- string/param ) + dup search dup lexical? [ nip ] [ drop ] if ; + : scan-c-type* ( -- c-type/param ) - scan { - { [ dup "{" = ] [ drop \ } parse-until >array ] } - { [ dup search ] [ search ] } - [ ] - } cond ; + scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ; + +: scan-string-param ( -- name/param ) + scan >string-param ; :: parse-struct-slot* ( accum -- accum ) - scan-param :> name + scan-string-param :> name scan-c-type* :> c-type \ } parse-until :> attributes accum { From db7eb4e27a5b340594caa8adccf41691249b2a32 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 20:20:25 -0500 Subject: [PATCH 47/55] change alien.complex to use struct classes --- basis/alien/complex/complex-tests.factor | 15 +++++++------- basis/alien/complex/functor/functor.factor | 23 +++++++++------------- 2 files changed, 16 insertions(+), 22 deletions(-) diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor index 2844e505b5..7bf826d87e 100644 --- a/basis/alien/complex/complex-tests.factor +++ b/basis/alien/complex/complex-tests.factor @@ -1,22 +1,21 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test alien.complex kernel alien.c-types alien.syntax -namespaces math ; +USING: accessors tools.test alien.complex classes.struct kernel +alien.c-types alien.syntax namespaces math ; IN: alien.complex.tests -C-STRUCT: complex-holder - { "complex-float" "z" } ; +STRUCT: complex-holder + { z complex-float } ; : ( z -- alien ) - "complex-holder" - [ set-complex-holder-z ] keep ; + complex-holder ; [ ] [ C{ 1.0 2.0 } "h" set ] unit-test -[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test +[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test [ number ] [ "complex-float" c-type-boxed-class ] unit-test -[ number ] [ "complex-double" c-type-boxed-class ] unit-test \ No newline at end of file +[ number ] [ "complex-double" c-type-boxed-class ] unit-test diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 7727546c00..cb66175a29 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -1,33 +1,28 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.structs alien.c-types math math.functions sequences -arrays kernel functors vocabs.parser namespaces accessors -quotations ; +USING: accessors alien.structs alien.c-types classes.struct math +math.functions sequences arrays kernel functors vocabs.parser +namespaces quotations ; IN: alien.complex.functor FUNCTOR: define-complex-type ( N T -- ) -T-real DEFINES ${T}-real -T-imaginary DEFINES ${T}-imaginary -set-T-real DEFINES set-${T}-real -set-T-imaginary DEFINES set-${T}-imaginary +T-class DEFINES-CLASS ${T} DEFINES <${T}> *T DEFINES *${T} WHERE +STRUCT: T-class { real N } { imaginary N } ; + : ( z -- alien ) - >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline + >rect T-class ; : *T ( alien -- z ) - [ T-real ] [ T-imaginary ] bi rect> ; inline + T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline -T current-vocab -{ { N "real" } { N "imaginary" } } -define-struct - -T c-type +T-class c-type 1quotation >>unboxer-quot *T 1quotation >>boxer-quot number >>boxed-class From 7276fe44d70d9636e2c355fc8e8a6d01bb30383e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 21:04:19 -0500 Subject: [PATCH 48/55] refactor functors so that new functor syntax words can be added outside of functors vocab, and move STRUCT: functor syntax to classes.struct to break a circular dependency --- basis/classes/struct/struct.factor | 38 +++++++++-- basis/functors/backend/backend.factor | 33 +++++++++ basis/functors/functors.factor | 96 +++++---------------------- 3 files changed, 84 insertions(+), 83 deletions(-) create mode 100644 basis/functors/backend/backend.factor diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 88c207f418..45ad3c62bb 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -2,11 +2,11 @@ USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays byte-arrays classes classes.parser classes.tuple classes.tuple.parser classes.tuple.private -combinators combinators.short-circuit combinators.smart fry -generalizations generic.parser kernel kernel.private lexer -libc macros make math math.order parser quotations sequences -slots slots.private struct-arrays vectors words -compiler.tree.propagation.transforms ; +combinators combinators.short-circuit combinators.smart +functors.backend fry generalizations generic.parser kernel +kernel.private lexer libc locals macros make math math.order parser +quotations sequences slots slots.private struct-arrays vectors +words compiler.tree.propagation.transforms ; FROM: slots => reader-word writer-word ; IN: classes.struct @@ -259,6 +259,34 @@ SYNTAX: UNION-STRUCT: SYNTAX: S{ scan-word dup struct-slots parse-tuple-literal-slots parsed ; +: scan-c-type` ( -- c-type/param ) + scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ; + +:: parse-struct-slot` ( accum -- accum ) + scan-string-param :> name + scan-c-type` :> c-type + \ } parse-until :> attributes + accum { + \ struct-slot-spec new + name >>name + c-type [ >>c-type ] [ struct-slot-class >>class ] bi + attributes [ dup empty? ] [ peel-off-attributes ] until drop + over push + } over push-all ; + +: parse-struct-slots` ( accum -- accum more? ) + scan { + { ";" [ f ] } + { "{" [ parse-struct-slot` t ] } + [ invalid-struct-slot ] + } case ; + +FUNCTOR-SYNTAX: STRUCT: + scan-param parsed + [ 8 ] over push-all + [ parse-struct-slots` ] [ ] while + [ >array define-struct-class ] over push-all ; + USING: vocabs vocabs.loader ; "prettyprint" vocab [ "classes.struct.prettyprint" require ] when diff --git a/basis/functors/backend/backend.factor b/basis/functors/backend/backend.factor new file mode 100644 index 0000000000..dd3d891f7b --- /dev/null +++ b/basis/functors/backend/backend.factor @@ -0,0 +1,33 @@ +USING: accessors arrays assocs generic.standard kernel +lexer locals.types namespaces parser quotations vocabs.parser +words ; +IN: functors.backend + +DEFER: functor-words +\ functor-words [ H{ } clone ] initialize + +SYNTAX: FUNCTOR-SYNTAX: + scan-word + gensym [ parse-definition define-syntax ] keep + swap name>> \ functor-words get-global set-at ; + +: functor-words ( -- assoc ) + \ functor-words get-global ; + +: scan-param ( -- obj ) scan-object literalize ; + +: >string-param ( string -- string/param ) + dup search dup lexical? [ nip ] [ drop ] if ; + +: scan-string-param ( -- name/param ) + scan >string-param ; + +: scan-c-type-param ( -- c-type/param ) + scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ; + +: define* ( word def -- ) over set-word define ; + +: define-declared* ( word def effect -- ) pick set-word define-declared ; + +: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ; + diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index dcfd140e92..62654ece79 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,25 +1,17 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes.mixin classes.parser -classes.singleton classes.struct classes.tuple classes.tuple.parser -combinators effects.parser fry generic generic.parser -generic.standard interpolate io.streams.string kernel lexer -locals locals.parser locals.types macros make namespaces parser -quotations sequences slots vectors vocabs.parser words words.symbol ; +classes.singleton classes.tuple classes.tuple.parser +combinators effects.parser fry functors.backend generic +generic.parser interpolate io.streams.string kernel lexer +locals.parser locals.types macros make namespaces parser +quotations sequences vocabs.parser words words.symbol ; IN: functors ! This is a hack ) , ; [ parse-definition* ] dip parsed ; -: >string-param ( string -- string/param ) - dup search dup lexical? [ nip ] [ drop ] if ; - -: scan-c-type* ( -- c-type/param ) - scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ; - -: scan-string-param ( -- name/param ) - scan >string-param ; - -:: parse-struct-slot* ( accum -- accum ) - scan-string-param :> name - scan-c-type* :> c-type - \ } parse-until :> attributes - accum { - \ struct-slot-spec new - name >>name - c-type [ >>c-type ] [ struct-slot-class >>class ] bi - attributes [ dup empty? ] [ peel-off-attributes ] until drop - over push - } over push-all ; - -: parse-struct-slots* ( accum -- accum more? ) - scan { - { ";" [ f ] } - { "{" [ parse-struct-slot* t ] } - [ invalid-struct-slot ] - } case ; - -SYNTAX: `TUPLE: +FUNCTOR-SYNTAX: TUPLE: scan-param parsed scan { { ";" [ tuple parsed f parsed ] } @@ -99,66 +63,60 @@ SYNTAX: `TUPLE: } case \ define-tuple-class parsed ; -SYNTAX: `STRUCT: - scan-param parsed - [ 8 ] over push-all - [ parse-struct-slots* ] [ ] while - [ >array define-struct-class ] over push-all ; - -SYNTAX: `SINGLETON: +FUNCTOR-SYNTAX: SINGLETON: scan-param parsed \ define-singleton-class parsed ; -SYNTAX: `MIXIN: +FUNCTOR-SYNTAX: MIXIN: scan-param parsed \ define-mixin-class parsed ; -SYNTAX: `M: +FUNCTOR-SYNTAX: M: scan-param parsed scan-param parsed [ create-method-in dup method-body set ] over push-all parse-definition* \ define* parsed ; -SYNTAX: `C: +FUNCTOR-SYNTAX: C: scan-param parsed scan-param parsed complete-effect [ [ [ boa ] curry ] over push-all ] dip parsed \ define-declared* parsed ; -SYNTAX: `: +FUNCTOR-SYNTAX: : scan-param parsed parse-declared* \ define-declared* parsed ; -SYNTAX: `SYMBOL: +FUNCTOR-SYNTAX: SYMBOL: scan-param parsed \ define-symbol parsed ; -SYNTAX: `SYNTAX: +FUNCTOR-SYNTAX: SYNTAX: scan-param parsed parse-definition* \ define-syntax parsed ; -SYNTAX: `INSTANCE: +FUNCTOR-SYNTAX: INSTANCE: scan-param parsed scan-param parsed \ add-mixin-instance parsed ; -SYNTAX: `GENERIC: +FUNCTOR-SYNTAX: GENERIC: scan-param parsed complete-effect parsed \ define-simple-generic* parsed ; -SYNTAX: `MACRO: +FUNCTOR-SYNTAX: MACRO: scan-param parsed parse-declared* \ define-macro parsed ; -SYNTAX: `inline [ word make-inline ] over push-all ; +FUNCTOR-SYNTAX: inline [ word make-inline ] over push-all ; -SYNTAX: `call-next-method T{ fake-call-next-method } parsed ; +FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } parsed ; : (INTERPOLATE) ( accum quot -- accum ) [ scan interpolate-locals ] dip @@ -178,24 +136,6 @@ DEFER: ;FUNCTOR delimiter Date: Sat, 29 Aug 2009 21:23:35 -0500 Subject: [PATCH 49/55] benchmark.struct-arrays: doesn't actually need HINTS: --- extra/benchmark/struct-arrays/struct-arrays.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/extra/benchmark/struct-arrays/struct-arrays.factor b/extra/benchmark/struct-arrays/struct-arrays.factor index 827604a39e..faed2f4dca 100644 --- a/extra/benchmark/struct-arrays/struct-arrays.factor +++ b/extra/benchmark/struct-arrays/struct-arrays.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes.struct combinators.smart fry kernel math math.functions math.order math.parser sequences -struct-arrays hints io ; +struct-arrays io ; IN: benchmark.struct-arrays STRUCT: point { x float } { y float } { z float } ; @@ -45,8 +45,6 @@ STRUCT: point { x float } { y float } { z float } ; : struct-array-benchmark ( len -- ) make-points [ normalize-points ] [ max-points ] bi print-point ; -HINTS: struct-array-benchmark fixnum ; - : main ( -- ) 5000000 struct-array-benchmark ; MAIN: main From dca528eaef4fa5cab9262642ed6c697394a627e1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Aug 2009 22:09:51 -0500 Subject: [PATCH 50/55] benchmark.terrain-generation: fix type error --- extra/benchmark/terrain-generation/terrain-generation.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/terrain-generation/terrain-generation.factor b/extra/benchmark/terrain-generation/terrain-generation.factor index 7fbb0ff43f..623a905bbc 100644 --- a/extra/benchmark/terrain-generation/terrain-generation.factor +++ b/extra/benchmark/terrain-generation/terrain-generation.factor @@ -4,7 +4,7 @@ IN: benchmark.terrain-generation : terrain-generation-benchmark ( -- ) "Generating terrain segment..." write flush yield - { 0.0 0.0 } terrain-segment drop + { 0 0 } terrain-segment drop "done" print ; MAIN: terrain-generation-benchmark From 3e51bde4845d429ed7e462643985f8f7e158e29c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 22:40:13 -0500 Subject: [PATCH 51/55] change malloc-struct to initialize struct from initial values; add (malloc-struct) and (struct) words that leave their memory uninitialized --- basis/classes/struct/struct-docs.factor | 21 ++++++++++++++++++++- basis/classes/struct/struct-tests.factor | 2 +- basis/classes/struct/struct.factor | 17 +++++++++++------ 3 files changed, 32 insertions(+), 8 deletions(-) diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor index bcc77f1b25..787f03423e 100644 --- a/basis/classes/struct/struct-docs.factor +++ b/basis/classes/struct/struct-docs.factor @@ -9,6 +9,15 @@ HELP: } { $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ; +HELP: (struct) +{ $values + { "class" class } + { "struct" struct } +} +{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; in most cases, the " { $link } " word, which initializes the struct's slots with their initial values, should be used instead." } ; + +{ (struct) (malloc-struct) } related-words + HELP: { $values { "class" class } @@ -55,7 +64,14 @@ HELP: malloc-struct { "class" class } { "struct" struct } } -{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are zeroed out. The struct should be " { $link free } "d when it is no longer needed." } ; +{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized to their initial values. The struct should be " { $link free } "d when it is no longer needed." } ; + +HELP: (malloc-struct) +{ $values + { "class" class } + { "struct" struct } +} +{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; to initialize the allocated memory with the slots' initial values, use " { $link malloc-struct } ". The struct should be " { $link free } "d when it is no longer needed." } ; HELP: memory>struct { $values @@ -80,6 +96,9 @@ ARTICLE: "classes.struct" "Struct classes" { $subsection } { $subsection malloc-struct } { $subsection memory>struct } +"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:" +{ $subsection (struct) } +{ $subsection (malloc-struct) } "Structs have literal syntax like tuples:" { $subsection POSTPONE: S{ } "Union structs are also supported, which behave like structs but share the same memory for all the type's slots." diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 2995e9d6d6..52e766a682 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -63,7 +63,7 @@ UNION-STRUCT: struct-test-float-and-bits [ 1.0 ] [ struct-test-float-and-bits 1.0 float>bits >>bits f>> ] unit-test [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test -[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test +[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test STRUCT: struct-test-string-ptr { x char* } ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 45ad3c62bb..94eebca081 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -37,6 +37,8 @@ M: struct equal? [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ] } 2&& ; +: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable + : memory>struct ( ptr class -- struct ) [ 1array ] dip slots>tuple ; @@ -44,17 +46,20 @@ M: struct equal? dup struct-class? [ '[ _ boa ] ] [ drop f ] if ] 1 define-partial-eval +: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien ) + '[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline + +: (malloc-struct) ( class -- struct ) + [ heap-size malloc ] keep memory>struct ; inline + : malloc-struct ( class -- struct ) - [ 1 swap heap-size calloc ] keep memory>struct ; inline + [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; : (struct) ( class -- struct ) - [ heap-size ] keep memory>struct ; inline - -: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable + [ heap-size (byte-array) ] keep memory>struct ; inline : ( class -- struct ) - dup struct-prototype - [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline + [ >c-ptr clone ] [ heap-size ] (init-struct) ; MACRO: ( class -- quot: ( ... -- struct ) ) [ From 4d8ed23db5e6cd0ec309ef06bedd309e91609233 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 22:42:48 -0500 Subject: [PATCH 52/55] add non-initializing (malloc-array) and (malloc-object) for kicks --- basis/alien/c-types/c-types.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 13607566e0..d75a4898c5 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -265,9 +265,15 @@ M: f byte-length drop 0 ; inline : malloc-array ( n type -- alien ) [ heap-size calloc ] [ ] 2bi ; inline +: (malloc-array) ( n type -- alien ) + [ heap-size * malloc ] [ ] 2bi ; inline + : malloc-object ( type -- alien ) 1 swap heap-size calloc ; inline +: (malloc-object) ( type -- alien ) + heap-size malloc ; inline + : malloc-byte-array ( byte-array -- alien ) dup byte-length [ nip malloc dup ] 2keep memcpy ; From 20aa00f8df1363c212b1c452ddfecbddf70ed11e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 22:54:56 -0500 Subject: [PATCH 53/55] implement clone on struct classes to copy the struct contents --- basis/classes/struct/struct-tests.factor | 4 +++- basis/classes/struct/struct.factor | 3 +++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 52e766a682..0cd91da370 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -1,5 +1,5 @@ ! (c)Joe Groff bsd license -USING: accessors alien.c-types alien.libraries +USING: accessors alien alien.c-types alien.libraries alien.structs.fields alien.syntax ascii classes.struct combinators destructors io.encodings.utf8 io.pathnames io.streams.string kernel libc literals math multiline namespaces prettyprint @@ -203,3 +203,5 @@ STRUCT: struct-test-optimization ] unit-test [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test + +[ f ] [ struct-test-foo dup clone [ >c-ptr ] bi@ eq? ] unit-test diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 94eebca081..4cb275f86f 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -46,6 +46,9 @@ M: struct equal? dup struct-class? [ '[ _ boa ] ] [ drop f ] if ] 1 define-partial-eval +M: struct clone + [ >c-ptr ] [ byte-length memory>byte-array ] [ class memory>struct ] tri ; + : (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien ) '[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline From 32f014a030041203a5bae592e42522d9bb8e24cb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 22:59:13 -0500 Subject: [PATCH 54/55] privatize classes.struct's shameful bits --- basis/classes/struct/struct.factor | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 4cb275f86f..4238230e16 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -49,8 +49,10 @@ M: struct equal? M: struct clone [ >c-ptr ] [ byte-length memory>byte-array ] [ class memory>struct ] tri ; +struct ; inline +PRIVATE> : (malloc-struct) ( class -- struct ) [ heap-size malloc ] keep memory>struct ; inline @@ -74,6 +76,7 @@ MACRO: ( class -- quot: ( ... -- struct ) ) ] bi ] [ ] output>sequence ; +> ] map over length tail append ] keep ; @@ -90,6 +93,7 @@ MACRO: ( class -- quot: ( ... -- struct ) ) : (unboxer-quot) ( class -- quot ) drop [ >c-ptr ] ; +PRIVATE> M: struct-class boa>object swap pad-struct-slots @@ -106,6 +110,7 @@ M: struct-class reader-quot M: struct-class writer-quot nip (writer-quot) ; +> reader-word 1quotation ] map @@ -120,8 +125,6 @@ M: struct-class writer-quot [ \ byte-length create-method-in ] [ heap-size \ drop swap [ ] 2sequence ] bi define ; -! Struct as c-type - : slot>field ( slot -- field ) field-spec new swap { [ name>> >>name ] @@ -163,6 +166,7 @@ M: struct-class writer-quot : struct-align ( slots -- align ) [ c-type>> c-type-align ] [ max ] map-reduce ; +PRIVATE> M: struct-class c-type name>> c-type ; @@ -188,6 +192,7 @@ M: struct-class heap-size ! class definition + ] [ memory>struct ] @@ -227,6 +232,7 @@ M: struct-class heap-size (struct-word-props) ] [ drop define-struct-for-class ] 2tri ; inline +PRIVATE> : define-struct-class ( class slots -- ) [ struct-offsets ] (define-struct-class) ; @@ -236,6 +242,7 @@ M: struct-class heap-size ERROR: invalid-struct-slot token ; + [ parse-struct-slots ] [ ] while >array ; +PRIVATE> SYNTAX: STRUCT: parse-struct-definition define-struct-class ; @@ -267,6 +275,9 @@ SYNTAX: UNION-STRUCT: SYNTAX: S{ scan-word dup struct-slots parse-tuple-literal-slots parsed ; +! functor support + +array ] [ >string-param ] if ; @@ -288,6 +299,7 @@ SYNTAX: S{ { "{" [ parse-struct-slot` t ] } [ invalid-struct-slot ] } case ; +PRIVATE> FUNCTOR-SYNTAX: STRUCT: scan-param parsed From be406fa9649dac538f6ae80bc1108368f8a49ca3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 23:18:31 -0500 Subject: [PATCH 55/55] fix alien.complex unboxer --- basis/alien/complex/functor/functor.factor | 4 ++-- basis/classes/struct/struct.factor | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index cb66175a29..b05059e9cb 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.structs alien.c-types classes.struct math +USING: accessors alien alien.structs alien.c-types classes.struct math math.functions sequences arrays kernel functors vocabs.parser namespaces quotations ; IN: alien.complex.functor @@ -17,7 +17,7 @@ WHERE STRUCT: T-class { real N } { imaginary N } ; : ( z -- alien ) - >rect T-class ; + >rect T-class >c-ptr ; : *T ( alien -- z ) T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 4238230e16..99150e9bb6 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -110,6 +110,8 @@ M: struct-class reader-quot M: struct-class writer-quot nip (writer-quot) ; +! c-types +