From 6b6e56a179e1d7d08ac533827142e69055ad68ab Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 19 Oct 2009 22:17:02 -0400 Subject: [PATCH 001/513] change add-init-hook to add-startup-hook, new add-shutdown-hook word --- basis/alarms/alarms.factor | 2 +- basis/bootstrap/finish-bootstrap.factor | 2 +- basis/bootstrap/finish-staging.factor | 2 +- basis/calendar/model/model.factor | 2 +- basis/channels/remote/remote.factor | 2 +- basis/cocoa/application/application.factor | 2 +- basis/cocoa/cocoa.factor | 2 +- basis/cocoa/messages/messages.factor | 8 +++--- basis/command-line/command-line.factor | 2 +- .../core-foundation/fsevents/fsevents.factor | 2 +- basis/core-text/core-text.factor | 2 +- basis/core-text/fonts/fonts.factor | 2 +- basis/cpu/x86/features/features.factor | 2 +- basis/cpu/x86/x86.factor | 2 +- basis/environment/environment.factor | 2 +- basis/game/input/input.factor | 2 +- basis/io/launcher/launcher.factor | 2 +- basis/io/sockets/unix/unix.factor | 3 +- basis/io/thread/thread.factor | 2 +- basis/logging/server/server.factor | 2 +- basis/opengl/gl/extensions/extensions.factor | 2 +- basis/openssl/openssl.factor | 2 +- basis/pango/cairo/cairo.factor | 2 +- basis/pango/fonts/fonts.factor | 2 +- .../mersenne-twister/mersenne-twister.factor | 2 +- basis/random/unix/unix.factor | 15 ++++++++-- basis/random/windows/windows.factor | 8 +++++- basis/threads/threads-docs.factor | 2 +- basis/threads/threads.factor | 2 +- basis/tools/crossref/crossref.factor | 4 +-- basis/tools/deploy/shaker/shaker.factor | 28 +++++++++---------- basis/tools/deploy/shaker/strip-cocoa.factor | 4 +-- basis/tools/deprecation/deprecation.factor | 2 +- basis/tools/errors/model/model.factor | 2 +- basis/ui/backend/cocoa/cocoa.factor | 6 ++-- basis/ui/backend/cocoa/tools/tools.factor | 2 +- basis/ui/ui.factor | 2 +- basis/vocabs/cache/cache.factor | 2 +- basis/vocabs/refresh/monitor/monitor.factor | 2 +- basis/windows/com/wrapper/wrapper.factor | 4 +-- .../windows/dinput/constants/constants.factor | 2 +- basis/windows/fonts/fonts.factor | 2 +- basis/windows/uniscribe/uniscribe.factor | 5 +++- basis/windows/winsock/winsock.factor | 5 +++- core/alien/alien.factor | 2 +- core/alien/strings/strings.factor | 3 +- core/compiler/units/units.factor | 4 +-- core/destructors/destructors.factor | 2 +- core/init/init-docs.factor | 24 +++++++++++----- core/init/init.factor | 24 +++++++++++----- core/io/backend/backend.factor | 4 +-- core/io/files/files.factor | 2 +- core/source-files/errors/errors.factor | 4 +-- extra/site-watcher/site-watcher.factor | 2 +- 54 files changed, 134 insertions(+), 93 deletions(-) diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index 9943d39ad1..c29371d26f 100644 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -75,7 +75,7 @@ ERROR: bad-alarm-frequency frequency ; [ alarm-thread-loop t ] "Alarms" spawn-server alarm-thread set-global ; -[ init-alarms ] "alarms" add-init-hook +[ init-alarms ] "alarms" add-startup-hook PRIVATE> diff --git a/basis/bootstrap/finish-bootstrap.factor b/basis/bootstrap/finish-bootstrap.factor index ab08aa87a9..65115fc2df 100644 --- a/basis/bootstrap/finish-bootstrap.factor +++ b/basis/bootstrap/finish-bootstrap.factor @@ -3,7 +3,7 @@ namespaces eval kernel vocabs.loader io ; [ boot - do-init-hooks + do-startup-hooks [ (command-line) parse-command-line load-vocab-roots diff --git a/basis/bootstrap/finish-staging.factor b/basis/bootstrap/finish-staging.factor index 49f504fd41..e75f0fa5c5 100644 --- a/basis/bootstrap/finish-staging.factor +++ b/basis/bootstrap/finish-staging.factor @@ -3,7 +3,7 @@ io ; [ boot - do-init-hooks + do-startup-hooks (command-line) parse-command-line "run" get run output-stream get [ stream-flush ] when* diff --git a/basis/calendar/model/model.factor b/basis/calendar/model/model.factor index 8665cc22ce..38ad986952 100644 --- a/basis/calendar/model/model.factor +++ b/basis/calendar/model/model.factor @@ -16,4 +16,4 @@ SYMBOL: time ] "Time model update" spawn drop ; f time set-global -[ time-thread ] "calendar.model" add-init-hook +[ time-thread ] "calendar.model" add-startup-hook diff --git a/basis/channels/remote/remote.factor b/basis/channels/remote/remote.factor index 6e10b23407..bf2438ac19 100644 --- a/basis/channels/remote/remote.factor +++ b/basis/channels/remote/remote.factor @@ -64,4 +64,4 @@ M: remote-channel from ( remote-channel -- value ) [ H{ } clone \ remote-channels set-global start-channel-node -] "channel-registry" add-init-hook +] "channel-registry" add-startup-hook diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index cbf8636a75..83213b47ba 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -49,7 +49,7 @@ TUPLE: objc-error alien reason ; M: objc-error summary ( error -- ) drop "Objective C exception" ; -[ [ objc-error ] 19 setenv ] "cocoa.application" add-init-hook +[ [ objc-error ] 19 setenv ] "cocoa.application" add-startup-hook : running.app? ( -- ? ) #! Test if we're running a .app. diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index ec5db31940..7f9d3f6814 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -27,7 +27,7 @@ SYMBOL: frameworks frameworks [ V{ } clone ] initialize -[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook +[ frameworks get [ load-framework ] each ] "cocoa" add-startup-hook SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index c0d8939a7a..85cff72749 100755 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -74,13 +74,13 @@ MACRO: (send) ( selector super? -- quot ) : super-send ( receiver args... selector -- return... ) t (send) ; inline ! Runtime introspection -SYMBOL: class-init-hooks +SYMBOL: class-startup-hooks -class-init-hooks [ H{ } clone ] initialize +class-startup-hooks [ H{ } clone ] initialize : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ - drop over class-init-hooks get at [ call( -- ) ] when* + drop over class-startup-hooks get at [ call( -- ) ] when* 2dup execute dup [ 2nip ] [ 2drop "No such class: " prepend throw ] if @@ -218,7 +218,7 @@ ERROR: no-objc-type name ; : class-exists? ( string -- class ) objc_getClass >boolean ; : define-objc-class-word ( quot name -- ) - [ class-init-hooks get set-at ] + [ class-startup-hooks get set-at ] [ [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi (( -- class )) define-declared diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 19421359a3..f1748d3708 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -69,4 +69,4 @@ SYMBOL: main-vocab-hook : ignore-cli-args? ( -- ? ) os macosx? "run" get "ui" = and ; -[ default-cli-args ] "command-line" add-init-hook +[ default-cli-args ] "command-line" add-startup-hook diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 6f5484fb77..e7a7962e6e 100755 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -156,7 +156,7 @@ SYMBOL: event-stream-callbacks [ event-stream-callbacks [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global -] "core-foundation" add-init-hook +] "core-foundation" add-startup-hook : add-event-source-callback ( quot -- id ) event-stream-counter diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor index 3459b368f7..d672815cbe 100644 --- a/basis/core-text/core-text.factor +++ b/basis/core-text/core-text.factor @@ -150,4 +150,4 @@ SYMBOL: cached-lines : cached-line ( font string -- line ) cached-lines get [ ] 2cache ; -[ cached-lines set-global ] "core-text" add-init-hook +[ cached-lines set-global ] "core-text" add-startup-hook diff --git a/basis/core-text/fonts/fonts.factor b/basis/core-text/fonts/fonts.factor index 5c57034632..63b9a0f6e1 100644 --- a/basis/core-text/fonts/fonts.factor +++ b/basis/core-text/fonts/fonts.factor @@ -127,4 +127,4 @@ MEMO: (cache-font-metrics) ( font -- metrics ) [ \ (cache-font) reset-memoized \ (cache-font-metrics) reset-memoized -] "core-text.fonts" add-init-hook +] "core-text.fonts" add-startup-hook diff --git a/basis/cpu/x86/features/features.factor b/basis/cpu/x86/features/features.factor index b21aa762d8..38364805eb 100644 --- a/basis/cpu/x86/features/features.factor +++ b/basis/cpu/x86/features/features.factor @@ -17,7 +17,7 @@ MEMO: sse-version ( -- n ) sse_version "sse-version" get string>number [ min ] when* ; -[ \ sse-version reset-memoized ] "cpu.x86.features" add-init-hook +[ \ sse-version reset-memoized ] "cpu.x86.features" add-startup-hook : sse? ( -- ? ) sse-version 10 >= ; : sse2? ( -- ? ) sse-version 20 >= ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 5db2641907..e6c95fcbff 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -1362,7 +1362,7 @@ enable-fixnum-log2 flush 1 exit ] when - ] "cpu.x86" add-init-hook ; + ] "cpu.x86" add-startup-hook ; : enable-sse2 ( version -- ) 20 >= [ diff --git a/basis/environment/environment.factor b/basis/environment/environment.factor index e60a52c995..ccdbd66d96 100644 --- a/basis/environment/environment.factor +++ b/basis/environment/environment.factor @@ -32,4 +32,4 @@ HOOK: (set-os-envs) os ( seq -- ) os windows? ";" ":" ? split [ add-vocab-root ] each ] when* -] "environment" add-init-hook +] "environment" add-startup-hook diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index 377a89a884..25283df4bf 100755 --- a/basis/game/input/input.factor +++ b/basis/game/input/input.factor @@ -35,7 +35,7 @@ M: f (reset-game-input) ; : reset-game-input ( -- ) (reset-game-input) ; -[ reset-game-input ] "game-input" add-init-hook +[ reset-game-input ] "game-input" add-startup-hook PRIVATE> diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 34325780c0..d1a41a1f09 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -75,7 +75,7 @@ SYMBOL: wait-flag [ H{ } clone processes set-global start-wait-thread -] "io.launcher" add-init-hook +] "io.launcher" add-startup-hook : process-started ( process handle -- ) >>handle diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index fa46a71ca0..583fd8fba9 100755 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -113,7 +113,8 @@ SYMBOL: receive-buffer CONSTANT: packet-size 65536 -[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook +[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-startup-hook +[ receive-buffer get-global free ] "io.sockets.unix" add-shutdown-hook :: do-receive ( port -- packet sockaddr ) port addr>> empty-sockaddr/size :> len :> sockaddr diff --git a/basis/io/thread/thread.factor b/basis/io/thread/thread.factor index 88db135f44..994dcd9c50 100644 --- a/basis/io/thread/thread.factor +++ b/basis/io/thread/thread.factor @@ -17,4 +17,4 @@ SYMBOL: io-thread-running? [ t io-thread-running? set-global start-io-thread -] "io.thread" add-init-hook +] "io.thread" add-startup-hook diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index 848ad5d40e..f5539b2813 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -106,4 +106,4 @@ CONSTANT: keep-logs 10 [ H{ } clone log-files set-global log-server -] "logging" add-init-hook +] "logging" add-startup-hook diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index 6292a683e3..540fba40f0 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/basis/opengl/gl/extensions/extensions.factor @@ -19,7 +19,7 @@ SYMBOL: +gl-function-pointers+ : reset-gl-function-pointers ( -- ) 100 +gl-function-pointers+ set-global ; -[ reset-gl-function-pointers ] "opengl.gl" add-init-hook +[ reset-gl-function-pointers ] "opengl.gl" add-startup-hook reset-gl-function-pointers reset-gl-function-number-counter diff --git a/basis/openssl/openssl.factor b/basis/openssl/openssl.factor index 8f14c60e14..76806f9523 100644 --- a/basis/openssl/openssl.factor +++ b/basis/openssl/openssl.factor @@ -34,4 +34,4 @@ SYMBOL: ssl-initialized? t ssl-initialized? set-global ] unless ; -[ f ssl-initialized? set-global ] "openssl" add-init-hook +[ f ssl-initialized? set-global ] "openssl" add-startup-hook diff --git a/basis/pango/cairo/cairo.factor b/basis/pango/cairo/cairo.factor index 6fd8d57893..d6baaffe2e 100644 --- a/basis/pango/cairo/cairo.factor +++ b/basis/pango/cairo/cairo.factor @@ -240,4 +240,4 @@ SYMBOL: cached-layouts : cached-line ( font string -- line ) cached-layout layout>> first-line ; -[ cached-layouts set-global ] "pango.cairo" add-init-hook +[ cached-layouts set-global ] "pango.cairo" add-startup-hook diff --git a/basis/pango/fonts/fonts.factor b/basis/pango/fonts/fonts.factor index 280ddd20d6..31a51e3f12 100644 --- a/basis/pango/fonts/fonts.factor +++ b/basis/pango/fonts/fonts.factor @@ -111,4 +111,4 @@ MEMO: (cache-font-description) ( font -- description ) : cache-font-description ( font -- description ) strip-font-colors (cache-font-description) ; -[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-init-hook +[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-startup-hook diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index a0e40e5c38..90489d3052 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -79,5 +79,5 @@ M: mersenne-twister random-32* ( mt -- r ) [ default-mersenne-twister random-generator set-global -] "bootstrap.random" add-init-hook +] "bootstrap.random" add-startup-hook diff --git a/basis/random/unix/unix.factor b/basis/random/unix/unix.factor index 599cd5e0ad..b15b9ab8b9 100644 --- a/basis/random/unix/unix.factor +++ b/basis/random/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types io io.files kernel namespaces random -io.encodings.binary init accessors system ; +io.encodings.binary init accessors system destructors ; IN: random.unix TUPLE: unix-random reader ; @@ -9,6 +9,8 @@ TUPLE: unix-random reader ; : ( path -- random ) binary unix-random boa ; +M: unix-random dispose reader>> dispose ; + M: unix-random random-bytes* ( n tuple -- byte-array ) reader>> stream-read ; @@ -16,10 +18,17 @@ os openbsd? [ [ "/dev/srandom" secure-random-generator set-global "/dev/arandom" system-random-generator set-global - ] "random.unix" add-init-hook + ] "random.unix" add-startup-hook ] [ [ "/dev/random" secure-random-generator set-global "/dev/urandom" system-random-generator set-global - ] "random.unix" add-init-hook + ] "random.unix" add-startup-hook ] if + +[ + [ + secure-random-generator get-global &dispose drop + system-random-generator get-global &dispose drop + ] with-destructors +] "random.unix" add-shutdown-hook diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index d959b191c9..c948fc01e4 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -65,5 +65,11 @@ M: windows-rng random-bytes* ( n tuple -- bytes ) [ MS_STRONG_PROV PROV_RSA_FULL ] [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES ] recover secure-random-generator set-global +] "random.windows" add-startup-hook -] "random.windows" add-init-hook +[ + [ + system-random-generator get-global &dispose drop + secure-random-generator get-global &dispose drop + ] with-destructors +] "random.windows" add-shutdown-hook diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index 8956051b25..85952ccd91 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -16,7 +16,7 @@ ARTICLE: "threads-start/stop" "Starting and stopping threads" } "Threads stop either when the quotation given to " { $link spawn } " returns, or when the following word is called:" { $subsections stop } -"If the image is saved and started again, all runnable threads are stopped. Vocabularies wishing to have a background thread always running should use " { $link add-init-hook } "." ; +"If the image is saved and started again, all runnable threads are stopped. Vocabularies wishing to have a background thread always running should use " { $link add-startup-hook } "." ; ARTICLE: "threads-yield" "Yielding and suspending threads" "Yielding to other threads:" diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index dec44625f7..b7e0e1b87f 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -225,4 +225,4 @@ GENERIC: error-in-thread ( error thread -- ) PRIVATE> -[ init-threads ] "threads" add-init-hook +[ init-threads ] "threads" add-startup-hook diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index beaf1c0673..f5d4b55129 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -135,6 +135,6 @@ SINGLETON: invalidate-crossref M: invalidate-crossref definitions-changed 2drop crossref global delete-at ; -[ invalidate-crossref add-definition-observer ] "tools.crossref" add-init-hook +[ invalidate-crossref add-definition-observer ] "tools.crossref" add-startup-hook -PRIVATE> \ No newline at end of file +PRIVATE> diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 0c703cae13..470194ed9d 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -23,9 +23,9 @@ IN: tools.deploy.shaker : add-command-line-hook ( -- ) [ (command-line) command-line set-global ] "command-line" - init-hooks get set-at ; + startup-hooks get set-at ; -: strip-init-hooks ( -- ) +: strip-startup-hooks ( -- ) "Stripping startup hooks" show { "alien.strings" @@ -34,17 +34,17 @@ IN: tools.deploy.shaker "environment" "libc" } - [ init-hooks get delete-at ] each + [ startup-hooks get delete-at ] each deploy-threads? get [ - "threads" init-hooks get delete-at + "threads" startup-hooks get delete-at ] unless native-io? [ - "io.thread" init-hooks get delete-at + "io.thread" startup-hooks get delete-at ] unless strip-io? [ - "io.files" init-hooks get delete-at - "io.backend" init-hooks get delete-at - "io.thread" init-hooks get delete-at + "io.files" startup-hooks get delete-at + "io.backend" startup-hooks get delete-at + "io.thread" startup-hooks get delete-at ] when strip-dictionary? [ { @@ -52,7 +52,7 @@ IN: tools.deploy.shaker "vocabs" "vocabs.cache" "source-files.errors" - } [ init-hooks get delete-at ] each + } [ startup-hooks get delete-at ] each ] when ; : strip-debugger ( -- ) @@ -293,7 +293,7 @@ IN: tools.deploy.shaker continuations:error-continuation continuations:error-thread continuations:restarts - init:init-hooks + init:startup-hooks source-files:source-files input-stream output-stream @@ -448,7 +448,7 @@ SYMBOL: deploy-vocab : deploy-boot-quot ( word -- ) [ [ boot ] % - init-hooks get values concat % + startup-hooks get values concat % strip-debugger? [ , ] [ ! Don't reference 'try' directly since we don't want ! to pull in the debugger and prettyprinter into every @@ -467,7 +467,7 @@ SYMBOL: deploy-vocab ] [ ] make set-boot-quot ; -: init-stripper ( -- ) +: startup-stripper ( -- ) t "quiet" set-global f output-stream set-global ; @@ -506,7 +506,7 @@ SYMBOL: deploy-vocab [ clear-megamorphic-cache ] each ; : strip ( -- ) - init-stripper + startup-stripper strip-libc strip-destructors strip-call @@ -514,7 +514,7 @@ SYMBOL: deploy-vocab strip-debugger strip-specialized-arrays compute-next-methods - strip-init-hooks + strip-startup-hooks add-command-line-hook strip-c-io strip-default-methods diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index 133308b732..d5c5bd54da 100644 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/basis/tools/deploy/shaker/strip-cocoa.factor @@ -17,7 +17,7 @@ IN: cocoa.application : objc-error ( error -- ) die ; -[ [ die ] 19 setenv ] "cocoa.application" add-init-hook +[ [ die ] 19 setenv ] "cocoa.application" add-startup-hook H{ } clone \ pool [ global [ @@ -46,4 +46,4 @@ H{ } clone \ pool [ \ make-prepare-send reset-memoized \ reset-memoized -\ (send) def>> second clear-assoc \ No newline at end of file +\ (send) def>> second clear-assoc diff --git a/basis/tools/deprecation/deprecation.factor b/basis/tools/deprecation/deprecation.factor index 0ee60b06b5..8dbfda3011 100644 --- a/basis/tools/deprecation/deprecation.factor +++ b/basis/tools/deprecation/deprecation.factor @@ -73,6 +73,6 @@ M: deprecation-observer definitions-changed [ drop initialize-deprecation-notes ] if ; [ \ deprecation-observer add-definition-observer ] -"tools.deprecation" add-init-hook +"tools.deprecation" add-startup-hook initialize-deprecation-notes diff --git a/basis/tools/errors/model/model.factor b/basis/tools/errors/model/model.factor index c874363fe6..b41d236fd7 100644 --- a/basis/tools/errors/model/model.factor +++ b/basis/tools/errors/model/model.factor @@ -14,5 +14,5 @@ SINGLETON: updater M: updater errors-changed drop f (error-list-model) get-global set-model ; -[ updater add-error-observer ] "ui.tools.error-list" add-init-hook +[ updater add-error-observer ] "ui.tools.error-list" add-startup-hook diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 0213b8433c..84e55ed134 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -225,9 +225,9 @@ CLASS: { : install-app-delegate ( -- ) NSApp FactorApplicationDelegate install-delegate ; -SYMBOL: cocoa-init-hook +SYMBOL: cocoa-startup-hook -cocoa-init-hook [ +cocoa-startup-hook [ [ "MiniFactor.nib" load-nib install-app-delegate ] ] initialize @@ -235,7 +235,7 @@ M: cocoa-ui-backend (with-ui) "UI" assert.app [ [ init-clipboard - cocoa-init-hook get call( -- ) + cocoa-startup-hook get call( -- ) start-ui f io-thread-running? set-global init-thread-timer diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor index b8c01f0bd9..ddcf79208d 100644 --- a/basis/ui/backend/cocoa/tools/tools.factor +++ b/basis/ui/backend/cocoa/tools/tools.factor @@ -100,4 +100,4 @@ FUNCTION: void NSUpdateDynamicServices ; install-app-delegate "Factor.nib" load-nib register-services -] cocoa-init-hook set-global +] cocoa-startup-hook set-global diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index aa3c549cf0..c75f5956b3 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -236,7 +236,7 @@ M: object close-window [ f \ ui-running set-global ui-notify-flag set-global -] "ui" add-init-hook +] "ui" add-startup-hook : with-ui ( quot -- ) ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ; diff --git a/basis/vocabs/cache/cache.factor b/basis/vocabs/cache/cache.factor index 24ccd391f1..1f62f02dde 100644 --- a/basis/vocabs/cache/cache.factor +++ b/basis/vocabs/cache/cache.factor @@ -18,4 +18,4 @@ M: cache-observer vocabs-changed drop reset-cache ; [ f changed-vocabs set-global cache-observer add-vocab-observer -] "vocabs.cache" add-init-hook \ No newline at end of file +] "vocabs.cache" add-startup-hook diff --git a/basis/vocabs/refresh/monitor/monitor.factor b/basis/vocabs/refresh/monitor/monitor.factor index 1445b9f882..1bf73862e6 100644 --- a/basis/vocabs/refresh/monitor/monitor.factor +++ b/basis/vocabs/refresh/monitor/monitor.factor @@ -56,4 +56,4 @@ TR: convert-separators "/\\" ".." ; [ "-no-monitors" (command-line) member? [ start-monitor-thread ] unless -] "vocabs.refresh.monitor" add-init-hook +] "vocabs.refresh.monitor" add-startup-hook diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 27672df833..c007a8c400 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -141,11 +141,11 @@ unless dup callbacks>> (callbacks>vtbls) >>vtbls f >>disposed drop ; -: (init-hook) ( -- ) +: com-startup-hook ( -- ) +live-wrappers+ get-global [ (allocate-wrapper) ] each H{ } +wrapped-objects+ set-global ; -[ (init-hook) ] "windows.com.wrapper" add-init-hook +[ com-startup-hook ] "windows.com.wrapper" add-startup-hook PRIVATE> diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index 3c0509c49d..ab37f96c2a 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -832,7 +832,7 @@ M: array array-base-type first ; define-guid-constants define-format-constants ; -[ define-constants ] "windows.dinput.constants" add-init-hook +[ define-constants ] "windows.dinput.constants" add-startup-hook : uninitialize ( variable quot -- ) '[ _ when* f ] change-global ; inline diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor index 9e113e8c3b..65a08ce3c7 100755 --- a/basis/windows/fonts/fonts.factor +++ b/basis/windows/fonts/fonts.factor @@ -37,7 +37,7 @@ MEMO:: (cache-font) ( font -- HFONT ) : cache-font ( font -- HFONT ) strip-font-colors (cache-font) ; -[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook +[ \ (cache-font) reset-memoized ] "windows.fonts" add-startup-hook : TEXTMETRIC>metrics ( TEXTMETRIC -- metrics ) [ metrics new 0 >>width ] dip { diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 9555927ab1..1651e8b3d8 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -114,4 +114,7 @@ SYMBOL: cached-script-strings cached-script-strings get-global [ ] 2cache ; [ cached-script-strings set-global ] -"windows.uniscribe" add-init-hook +"windows.uniscribe" add-startup-hook + +[ cached-script-strings get-global dispose ] +"windows.uniscribe" add-shutdown-hook diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 7bd86c8e47..b8d1f099d2 100755 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -442,4 +442,7 @@ CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e} : init-winsock ( -- ) HEX: 0202 WSAStartup winsock-return-check ; -[ init-winsock ] "windows.winsock" add-init-hook +: shutdown-winsock ( -- ) WSACleanup winsock-return-check ; + +[ init-winsock ] "windows.winsock" add-startup-hook +[ shutdown-winsock ] "windows.winsock" add-shutdown-hook diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 3f2b5f95bf..368f0b25e7 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -72,7 +72,7 @@ ERROR: alien-invoke-error library symbol ; ! cleared on startup. SYMBOL: callbacks -[ H{ } clone callbacks set-global ] "alien" add-init-hook +[ H{ } clone callbacks set-global ] "alien" add-startup-hook symbol [ string>symbol* ] map ; [ 8 getenv utf8 alien>string string>cpu \ cpu set-global 9 getenv utf8 alien>string string>os \ os set-global -] "alien.strings" add-init-hook - +] "alien.strings" add-startup-hook diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index f1f9131f08..ac1c9627ac 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -59,11 +59,11 @@ SYMBOL: definition-observers GENERIC: definitions-changed ( assoc obj -- ) [ V{ } clone definition-observers set-global ] -"compiler.units" add-init-hook +"compiler.units" add-startup-hook ! This goes here because vocabs cannot depend on init [ V{ } clone vocab-observers set-global ] -"vocabs" add-init-hook +"vocabs" add-startup-hook : add-definition-observer ( obj -- ) definition-observers get push ; diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index 3e57f498af..7b10a75212 100644 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -6,7 +6,7 @@ IN: destructors SYMBOL: disposables -[ H{ } clone disposables set-global ] "destructors" add-init-hook +[ H{ } clone disposables set-global ] "destructors" add-startup-hook ERROR: already-unregistered disposable ; diff --git a/core/init/init-docs.factor b/core/init/init-docs.factor index e76b6e8fee..edee683bde 100644 --- a/core/init/init-docs.factor +++ b/core/init/init-docs.factor @@ -15,29 +15,39 @@ HELP: set-boot-quot { $description "Sets the initial quotation called by the VM on startup. This quotation must begin with a call to " { $link boot } ". The image must be saved for changes to the boot quotation to take effect." } { $notes "The " { $link "tools.deploy" } " tool uses this word." } ; -HELP: init-hooks +HELP: startup-hooks { $var-description "An association list mapping string identifiers to quotations to be run on startup." } ; -HELP: do-init-hooks +HELP: shutdown-hooks +{ $var-description "An association list mapping string identifiers to quotations to be run on shutdown." } ; + +HELP: do-startup-hooks { $description "Calls all initialization hook quotations." } ; -HELP: add-init-hook +HELP: do-shutdown-hooks +{ $description "Calls all shutdown hook quotations." } ; + +HELP: add-startup-hook { $values { "quot" quotation } { "name" string } } { $description "Registers a startup hook. The hook will always run when Factor is started. If the hook was not already defined, this word also calls it immediately." } ; -{ init-hooks do-init-hooks add-init-hook } related-words +{ startup-hooks do-startup-hooks add-startup-hook add-shutdown-hook do-shutdown-hooks shutdown-hooks } related-words ARTICLE: "init" "Initialization and startup" "When Factor starts, the first thing it does is call a word:" { $subsections boot } "Next, initialization hooks are called:" -{ $subsections do-init-hooks } +{ $subsections do-startup-hooks } "Initialization hooks can be defined:" -{ $subsections add-init-hook } +{ $subsections add-startup-hook } +"Corresponding shutdown hooks may also be defined:" +{ $subsections add-shutdown-hook } "The boot quotation can be changed:" { $subsections boot-quot set-boot-quot -} ; +} +"When quitting Factor, shutdown hooks are called:" +{ $subsection do-shutdown-hooks } ; ABOUT: "init" diff --git a/core/init/init.factor b/core/init/init.factor index 5d8e88b85f..540768ee63 100644 --- a/core/init/init.factor +++ b/core/init/init.factor @@ -4,16 +4,26 @@ USING: continuations continuations.private kernel kernel.private sequences assocs namespaces namespaces.private ; IN: init -SYMBOL: init-hooks +SYMBOL: startup-hooks +SYMBOL: shutdown-hooks -init-hooks global [ drop V{ } clone ] cache drop +startup-hooks global [ drop V{ } clone ] cache drop +shutdown-hooks global [ drop V{ } clone ] cache drop -: do-init-hooks ( -- ) - init-hooks get [ nip call( -- ) ] assoc-each ; +: do-hooks ( assoc -- ) + [ nip call( -- ) ] assoc-each ; -: add-init-hook ( quot name -- ) - dup init-hooks get at [ over call( -- ) ] unless - init-hooks get set-at ; +: do-startup-hooks ( -- ) startup-hooks get do-hooks ; + +: do-shutdown-hooks ( -- ) shutdown-hooks get do-hooks ; + +: add-startup-hook ( quot name -- ) + startup-hooks get + [ at [ drop ] [ call( -- ) ] if ] + [ set-at ] 3bi ; + +: add-shutdown-hook ( quot name -- ) + shutdown-hooks get set-at ; : boot ( -- ) init-namespaces init-catchstack init-error-handler ; diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 494ccbff22..ee50500754 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -29,9 +29,9 @@ M: object normalize-directory normalize-path ; : set-io-backend ( io-backend -- ) io-backend set-global init-io init-stdio - "io.files" init-hooks get at call( -- ) ; + "io.files" startup-hooks get at call( -- ) ; ! Note that we have 'alien' in our using list so that the alien ! init hook runs before this one. [ init-io embedded? [ init-stdio ] unless ] -"io.backend" add-init-hook +"io.backend" add-startup-hook diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6779c6d094..9824fba18c 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -60,4 +60,4 @@ PRIVATE> 13 getenv alien>native-string cwd prepend-path \ image set-global 14 getenv alien>native-string cwd prepend-path \ vm set-global image parent-directory "resource-path" set-global -] "io.files" add-init-hook +] "io.files" add-startup-hook diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor index 93078c162b..f5c41285ee 100644 --- a/core/source-files/errors/errors.factor +++ b/core/source-files/errors/errors.factor @@ -67,7 +67,7 @@ GENERIC: errors-changed ( observer -- ) SYMBOL: error-observers -[ V{ } clone error-observers set-global ] "source-files.errors" add-init-hook +[ V{ } clone error-observers set-global ] "source-files.errors" add-startup-hook : add-error-observer ( observer -- ) error-observers get push ; @@ -86,4 +86,4 @@ SYMBOL: error-observers error-types get [ second forget-quot>> dup [ call( definition -- ) ] [ 2drop ] if - ] with each ; \ No newline at end of file + ] with each ; diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index 535c8cd626..dcae438679 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -10,7 +10,7 @@ SYMBOL: site-watcher-frequency 5 minutes site-watcher-frequency set-global SYMBOL: running-site-watcher -[ f running-site-watcher set-global ] "site-watcher" add-init-hook +[ f running-site-watcher set-global ] "site-watcher" add-startup-hook Date: Tue, 20 Oct 2009 00:28:18 -0400 Subject: [PATCH 002/513] the exit primitive is now called (exit) and exit calls shutdown hooks. add a stop_factor function to the vm to allow calling the shutdown quotation --- core/bootstrap/primitives.factor | 2 +- core/bootstrap/stage1.factor | 2 +- core/init/init.factor | 14 ++++++++++---- core/system/system.factor | 2 ++ vm/factor.cpp | 7 +++++++ vm/run.hpp | 1 + vm/vm.hpp | 1 + 7 files changed, 23 insertions(+), 6 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index ef66cc3cd6..8058707efa 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -432,7 +432,7 @@ tuple { "set-datastack" "kernel" (( ds -- )) } { "set-retainstack" "kernel" (( rs -- )) } { "set-callstack" "kernel" (( cs -- )) } - { "exit" "system" (( n -- )) } + { "(exit)" "system" (( n -- )) } { "data-room" "memory" (( -- cards decks generations )) } { "code-room" "memory" (( -- code-total code-used code-free largest-free-block )) } { "micros" "system" (( -- us )) } diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 9c84904ff7..6dab0f4162 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -47,7 +47,7 @@ load-help? off "Cannot find " write write "." print "Please move " write image write " to the same directory as the Factor sources," print "and try again." print - 1 exit + 1 (exit) ] if ] % ] [ ] make diff --git a/core/init/init.factor b/core/init/init.factor index 540768ee63..16a39bbc21 100644 --- a/core/init/init.factor +++ b/core/init/init.factor @@ -10,12 +10,12 @@ SYMBOL: shutdown-hooks startup-hooks global [ drop V{ } clone ] cache drop shutdown-hooks global [ drop V{ } clone ] cache drop -: do-hooks ( assoc -- ) - [ nip call( -- ) ] assoc-each ; +: do-hooks ( symbol -- ) + get [ nip call( -- ) ] assoc-each ; -: do-startup-hooks ( -- ) startup-hooks get do-hooks ; +: do-startup-hooks ( -- ) startup-hooks do-hooks ; -: do-shutdown-hooks ( -- ) shutdown-hooks get do-hooks ; +: do-shutdown-hooks ( -- ) shutdown-hooks do-hooks ; : add-startup-hook ( quot name -- ) startup-hooks get @@ -30,3 +30,9 @@ shutdown-hooks global [ drop V{ } clone ] cache drop : boot-quot ( -- quot ) 20 getenv ; : set-boot-quot ( quot -- ) 20 setenv ; + +: shutdown-quot ( -- quot ) 67 getenv ; + +: set-shutdown-quot ( quot -- ) 67 setenv ; + +[ do-shutdown-hooks ] set-shutdown-quot diff --git a/core/system/system.factor b/core/system/system.factor index 38b4a5fd9b..5ee10374fc 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -56,3 +56,5 @@ PRIVATE> : embedded? ( -- ? ) 15 getenv ; : millis ( -- ms ) micros 1000 /i ; + +: exit ( n -- ) do-shutdown-hooks (exit) ; diff --git a/vm/factor.cpp b/vm/factor.cpp index 5548ebd610..2f4994c9a2 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -185,6 +185,13 @@ void factor_vm::start_factor(vm_parameters *p) unnest_stacks(); } +void factor_vm::stop_factor() +{ + nest_stacks(NULL); + c_to_factor_toplevel(userenv[SHUTDOWN_ENV]); + unnest_stacks(); +} + char *factor_vm::factor_eval_string(char *string) { char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]); diff --git a/vm/run.hpp b/vm/run.hpp index 9a23979066..86590e96a2 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -90,6 +90,7 @@ enum special_object { THREADS_ENV = 64, RUN_QUEUE_ENV = 65, SLEEP_QUEUE_ENV = 66, + SHUTDOWN_ENV = 67, }; #define FIRST_SAVE_ENV BOOT_ENV diff --git a/vm/vm.hpp b/vm/vm.hpp index d232d6153d..4aef9a4f72 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -668,6 +668,7 @@ struct factor_vm void init_factor(vm_parameters *p); void pass_args_to_factor(int argc, vm_char **argv); void start_factor(vm_parameters *p); + void stop_factor(); void start_embedded_factor(vm_parameters *p); void start_standalone_factor(int argc, vm_char **argv); char *factor_eval_string(char *string); From 5b4c1aea5d4ccfa1b9834afc218d14e55b098329 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 20 Oct 2009 18:26:10 -0400 Subject: [PATCH 003/513] run bootstrap and startup hooks inside a with-destructors. use &dispose instead of setting shutdown hooks in a couple of places --- basis/bootstrap/finish-bootstrap.factor | 24 +++++++++++++----------- basis/bootstrap/finish-staging.factor | 11 ++++++----- basis/bootstrap/stage2.factor | 1 + basis/io/sockets/unix/unix.factor | 3 +-- basis/random/unix/unix.factor | 15 ++++----------- basis/windows/uniscribe/uniscribe.factor | 5 +---- core/bootstrap/stage1.factor | 4 ++-- 7 files changed, 28 insertions(+), 35 deletions(-) diff --git a/basis/bootstrap/finish-bootstrap.factor b/basis/bootstrap/finish-bootstrap.factor index 65115fc2df..35b40df97a 100644 --- a/basis/bootstrap/finish-bootstrap.factor +++ b/basis/bootstrap/finish-bootstrap.factor @@ -1,17 +1,19 @@ USING: init command-line debugger system continuations -namespaces eval kernel vocabs.loader io ; +namespaces eval kernel vocabs.loader io destructors ; [ boot - do-startup-hooks [ - (command-line) parse-command-line - load-vocab-roots - run-user-init - "e" get [ eval( -- ) ] when* - ignore-cli-args? not script get and - [ run-script ] [ "run" get run ] if* - output-stream get [ stream-flush ] when* - 0 exit - ] [ print-error 1 exit ] recover + do-startup-hooks + [ + (command-line) parse-command-line + load-vocab-roots + run-user-init + "e" get [ eval( -- ) ] when* + ignore-cli-args? not script get and + [ run-script ] [ "run" get run ] if* + output-stream get [ stream-flush ] when* + 0 + ] [ print-error 1 ] recover + ] with-destructors exit ] set-boot-quot diff --git a/basis/bootstrap/finish-staging.factor b/basis/bootstrap/finish-staging.factor index e75f0fa5c5..10d81d6ff6 100644 --- a/basis/bootstrap/finish-staging.factor +++ b/basis/bootstrap/finish-staging.factor @@ -3,9 +3,10 @@ io ; [ boot - do-startup-hooks - (command-line) parse-command-line - "run" get run - output-stream get [ stream-flush ] when* - 0 exit + [ + do-startup-hooks + (command-line) parse-command-line + "run" get run + output-stream get [ stream-flush ] when* + ] with-destructors 0 exit ] set-boot-quot diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 3cbe155dd2..b8531abd90 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -56,6 +56,7 @@ SYMBOL: bootstrap-time error-continuation set-global error set-global ; inline + [ ! We time bootstrap millis diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index 583fd8fba9..d2df4d9e13 100755 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -113,8 +113,7 @@ SYMBOL: receive-buffer CONSTANT: packet-size 65536 -[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-startup-hook -[ receive-buffer get-global free ] "io.sockets.unix" add-shutdown-hook +[ packet-size malloc &free receive-buffer set-global ] "io.sockets.unix" add-startup-hook :: do-receive ( port -- packet sockaddr ) port addr>> empty-sockaddr/size :> len :> sockaddr diff --git a/basis/random/unix/unix.factor b/basis/random/unix/unix.factor index b15b9ab8b9..fd93d6492c 100644 --- a/basis/random/unix/unix.factor +++ b/basis/random/unix/unix.factor @@ -16,19 +16,12 @@ M: unix-random random-bytes* ( n tuple -- byte-array ) os openbsd? [ [ - "/dev/srandom" secure-random-generator set-global - "/dev/arandom" system-random-generator set-global + "/dev/srandom" &dispose secure-random-generator set-global + "/dev/arandom" &dispose system-random-generator set-global ] "random.unix" add-startup-hook ] [ [ - "/dev/random" secure-random-generator set-global - "/dev/urandom" system-random-generator set-global + "/dev/random" &dispose secure-random-generator set-global + "/dev/urandom" &dispose system-random-generator set-global ] "random.unix" add-startup-hook ] if - -[ - [ - secure-random-generator get-global &dispose drop - system-random-generator get-global &dispose drop - ] with-destructors -] "random.unix" add-shutdown-hook diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 1651e8b3d8..87540dc24f 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -113,8 +113,5 @@ SYMBOL: cached-script-strings : cached-script-string ( font string -- script-string ) cached-script-strings get-global [ ] 2cache ; -[ cached-script-strings set-global ] +[ &dispose cached-script-strings set-global ] "windows.uniscribe" add-startup-hook - -[ cached-script-strings get-global dispose ] -"windows.uniscribe" add-shutdown-hook diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 6dab0f4162..1e8ebe2938 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -3,7 +3,7 @@ USING: arrays assocs continuations debugger generic hashtables init io io.files kernel kernel.private make math memory namespaces parser prettyprint sequences splitting system -vectors vocabs vocabs.loader words ; +vectors vocabs vocabs.loader words destructors ; QUALIFIED: bootstrap.image.private IN: bootstrap.stage1 @@ -42,7 +42,7 @@ load-help? off [ "resource:basis/bootstrap/stage2.factor" dup exists? [ - run-file + [ run-file ] with-destructors ] [ "Cannot find " write write "." print "Please move " write image write " to the same directory as the Factor sources," print From a4a687ab32b3f8df4a36c8139a344ec2fb8b2e1a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 21 Oct 2009 12:32:51 -0500 Subject: [PATCH 004/513] clean up global destructors as a shutdown hook in case exit is called --- core/destructors/destructors.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index 7b10a75212..afe40d861c 100644 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -91,3 +91,10 @@ PRIVATE> [ do-error-destructors ] cleanup ] with-scope ; inline + +[ + [ + always-destructors get-global dispose-each + error-destructors get-global dispose-each + ] with-destructors +] "destructors.global" add-shutdown-hook From b34bfe563e0ca001a61c99bd934bab96498feb92 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 21 Oct 2009 13:07:31 -0500 Subject: [PATCH 005/513] only call dispose-each once --- core/destructors/destructors.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index afe40d861c..1f640beddb 100644 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -93,8 +93,6 @@ PRIVATE> ] with-scope ; inline [ - [ - always-destructors get-global dispose-each - error-destructors get-global dispose-each - ] with-destructors + always-destructors get-global + error-destructors get-global append dispose-each ] "destructors.global" add-shutdown-hook From 0a350bbe6e081e3d83f9cd31c2bdf656a1fd4132 Mon Sep 17 00:00:00 2001 From: Guillaume Nargeot Date: Mon, 26 Oct 2009 21:17:06 +0900 Subject: [PATCH 006/513] Solution to Project Euler problem 62 --- extra/project-euler/062/062-tests.factor | 4 ++ extra/project-euler/062/062.factor | 54 ++++++++++++++++++++++++ extra/project-euler/062/authors.txt | 1 + extra/project-euler/project-euler.factor | 20 ++++----- 4 files changed, 69 insertions(+), 10 deletions(-) create mode 100644 extra/project-euler/062/062-tests.factor create mode 100644 extra/project-euler/062/062.factor create mode 100644 extra/project-euler/062/authors.txt diff --git a/extra/project-euler/062/062-tests.factor b/extra/project-euler/062/062-tests.factor new file mode 100644 index 0000000000..d8e0b9682e --- /dev/null +++ b/extra/project-euler/062/062-tests.factor @@ -0,0 +1,4 @@ +USING: project-euler.062 tools.test ; +IN: project-euler.062.tests + +[ 127035954683 ] [ euler062 ] unit-test diff --git a/extra/project-euler/062/062.factor b/extra/project-euler/062/062.factor new file mode 100644 index 0000000000..037cdc1af5 --- /dev/null +++ b/extra/project-euler/062/062.factor @@ -0,0 +1,54 @@ +! Copyright (c) 2009 Guillaume Nargeot. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs hashtables kernel math math.functions +project-euler.common sequences sorting ; +IN: project-euler.062 + +! http://projecteuler.net/index.php?section=problems&id=062 + +! DESCRIPTION +! ----------- + +! The cube, 41063625 (345^3), can be permuted to produce two +! other cubes: 56623104 (384^3) and 66430125 (405^3). In +! fact, 41063625 is the smallest cube which has exactly three +! permutations of its digits which are also cube. + +! Find the smallest cube for which exactly five permutations of +! its digits are cube. + + +! SOLUTION +! -------- + +key ( n -- k ) cube number>digits natural-sort ; inline +: has-entry? ( n assoc -- ? ) [ >key ] dip key? ; inline + +: (euler062) ( n assoc -- n ) + 2dup has-entry? [ + 2dup [ >key ] dip + [ dup 0 swap [ 1 + ] change-nth ] change-at + 2dup [ >key ] dip at first 5 = + [ + [ >key ] dip at second + ] [ + [ 1 + ] dip (euler062) + ] if + ] [ + 2dup 1 pick cube 2array -rot + [ >key ] dip set-at [ 1 + ] dip + (euler062) + ] if ; + +PRIVATE> + +: euler062 ( -- answer ) + 1 1 (euler062) ; + +! [ euler062 ] 100 ave-time +! 78 ms ave run time - 0.9 SD (100 trials) + +SOLUTION: euler062 diff --git a/extra/project-euler/062/authors.txt b/extra/project-euler/062/authors.txt new file mode 100644 index 0000000000..6eb6698c00 --- /dev/null +++ b/extra/project-euler/062/authors.txt @@ -0,0 +1 @@ +Guillaume Nargeot diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index e64bd61852..66f4296827 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -16,16 +16,16 @@ USING: definitions io io.files io.pathnames kernel math math.parser project-euler.045 project-euler.046 project-euler.047 project-euler.048 project-euler.049 project-euler.051 project-euler.052 project-euler.053 project-euler.054 project-euler.055 project-euler.056 project-euler.057 - project-euler.058 project-euler.059 project-euler.063 project-euler.065 - project-euler.067 project-euler.069 project-euler.071 project-euler.072 - project-euler.073 project-euler.074 project-euler.075 project-euler.076 - project-euler.079 project-euler.081 project-euler.085 project-euler.092 - project-euler.097 project-euler.099 project-euler.100 project-euler.102 - project-euler.112 project-euler.116 project-euler.117 project-euler.124 - project-euler.134 project-euler.148 project-euler.150 project-euler.151 - project-euler.164 project-euler.169 project-euler.173 project-euler.175 - project-euler.186 project-euler.188 project-euler.190 project-euler.203 - project-euler.215 ; + project-euler.058 project-euler.059 project-euler.062 project-euler.063 + project-euler.065 project-euler.067 project-euler.069 project-euler.071 + project-euler.072 project-euler.073 project-euler.074 project-euler.075 + project-euler.076 project-euler.079 project-euler.081 project-euler.085 + project-euler.092 project-euler.097 project-euler.099 project-euler.100 + project-euler.102 project-euler.112 project-euler.116 project-euler.117 + project-euler.124 project-euler.134 project-euler.148 project-euler.150 + project-euler.151 project-euler.164 project-euler.169 project-euler.173 + project-euler.175 project-euler.186 project-euler.188 project-euler.190 + project-euler.203 project-euler.215 ; IN: project-euler Date: Sun, 1 Nov 2009 22:10:28 -0600 Subject: [PATCH 007/513] move define-inline-method from classes.struct.private to generic.parser --- basis/classes/struct/struct.factor | 3 --- core/generic/parser/parser.factor | 3 +++ 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index d5e5fdc6c3..f86f3c9d97 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -189,9 +189,6 @@ M: struct-c-type c-struct? drop t ; \ cleave [ ] 2sequence \ output>array [ ] 2sequence ; -: define-inline-method ( class generic quot -- ) - [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ; - : (define-struct-slot-values-method) ( class -- ) [ \ struct-slot-values ] [ struct-slot-values-quot ] bi define-inline-method ; diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor index ce048c41da..11fb2b5b42 100644 --- a/core/generic/parser/parser.factor +++ b/core/generic/parser/parser.factor @@ -13,6 +13,9 @@ ERROR: not-in-a-method-error ; : create-method-in ( class generic -- method ) create-method dup set-word dup save-location ; +: define-inline-method ( class generic quot -- ) + [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ; + : CREATE-METHOD ( -- method ) scan-word bootstrap-word scan-word create-method-in ; From 092dd9fc393a8a71b12a135af7e38e9101ab2bdb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 1 Nov 2009 23:16:26 -0600 Subject: [PATCH 008/513] add sorted-histogram word --- basis/math/statistics/statistics-docs.factor | 14 ++++++++++++++ basis/math/statistics/statistics.factor | 3 +++ 2 files changed, 17 insertions(+) diff --git a/basis/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor index 3b6e7d62ba..9834f44add 100644 --- a/basis/math/statistics/statistics-docs.factor +++ b/basis/math/statistics/statistics-docs.factor @@ -98,6 +98,19 @@ HELP: histogram* } { $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ; +HELP: sorted-histogram +{ $values + { "seq" sequence } + { "alist" "an array of key/value pairs" } +} +{ $description "Outputs a " { $link histogram } " of a sequence sorted by number of occurences from lowest to highest." } +{ $examples + { $example "USING: prettyprint math.statistics ;" + """"abababbbbbbc" sorted-histogram .""" + "{ { 99 1 } { 97 3 } { 98 8 } }" + } +} ; + HELP: sequence>assoc { $values { "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" } @@ -145,6 +158,7 @@ ARTICLE: "histogram" "Computing histograms" { $subsections histogram histogram* + sorted-histogram } "Combinators for implementing histogram:" { $subsections diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 9c72b848ca..73a87ffb72 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -79,6 +79,9 @@ PRIVATE> : histogram ( seq -- hashtable ) [ inc-at ] sequence>hashtable ; +: sorted-histogram ( seq -- alist ) + histogram >alist sort-values ; + : collect-values ( seq quot: ( obj hashtable -- ) -- hash ) '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline From e0ba0c5539809c661625d29b2492e2c3c0feeb59 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 2 Nov 2009 14:21:19 -0600 Subject: [PATCH 009/513] genericize vector ops --- basis/math/vectors/vectors.factor | 265 +++++++++++++++++------------- core/sequences/sequences.factor | 3 +- 2 files changed, 157 insertions(+), 111 deletions(-) diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 63564f064d..f3dfcda18a 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -6,29 +6,47 @@ byte-arrays accessors locals ; QUALIFIED-WITH: alien.c-types c IN: math.vectors -MIXIN: simd-128 -MIXIN: simd-256 +GENERIC: vneg ( u -- v ) +M: object vneg [ neg ] map ; -GENERIC: element-type ( obj -- c-type ) -M: object element-type drop f ; inline +GENERIC# v+n 1 ( u n -- v ) +M: object v+n [ + ] curry map ; -: vneg ( u -- v ) [ neg ] map ; +GENERIC: n+v ( n v -- w ) +M: object n+v [ + ] with map ; -: v+n ( u n -- v ) [ + ] curry map ; -: n+v ( n u -- v ) [ + ] with map ; -: v-n ( u n -- v ) [ - ] curry map ; -: n-v ( n u -- v ) [ - ] with map ; +GENERIC# v-n 1 ( u n -- w ) +M: object v-n [ - ] curry map ; -: v*n ( u n -- v ) [ * ] curry map ; -: n*v ( n u -- v ) [ * ] with map ; -: v/n ( u n -- v ) [ / ] curry map ; -: n/v ( n u -- v ) [ / ] with map ; +GENERIC: n-v ( n v -- w ) +M: object n-v [ - ] with map ; -: v+ ( u v -- w ) [ + ] 2map ; -: v- ( u v -- w ) [ - ] 2map ; -: [v-] ( u v -- w ) [ [-] ] 2map ; -: v* ( u v -- w ) [ * ] 2map ; -: v/ ( u v -- w ) [ / ] 2map ; +GENERIC# v*n 1 ( u n -- v ) +M: object v*n [ * ] curry map ; + +GENERIC: n*v ( n v -- w ) +M: object n*v [ * ] with map ; + +GENERIC# v/n 1 ( u n -- v ) +M: object v/n [ / ] curry map ; + +GENERIC: n/v ( n v -- w ) +M: object n/v [ / ] with map ; + +GENERIC: v+ ( u v -- w ) +M: object v+ [ + ] 2map ; + +GENERIC: v- ( u v -- w ) +M: object v- [ - ] 2map ; + +GENERIC: [v-] ( u v -- w ) +M: object [v-] [ [-] ] 2map ; + +GENERIC: v* ( u v -- w ) +M: object v* [ * ] 2map ; + +GENERIC: v/ ( u v -- w ) +M: object v/ [ / ] 2map ; -: vmax ( u v -- w ) [ [ float-max ] [ max ] if-both-floats ] 2map ; -: vmin ( u v -- w ) [ [ float-min ] [ min ] if-both-floats ] 2map ; +GENERIC: vmax ( u v -- w ) +M: object vmax [ [ float-max ] [ max ] if-both-floats ] 2map ; -: v+- ( u v -- w ) +GENERIC: vmin ( u v -- w ) +M: object vmin [ [ float-min ] [ min ] if-both-floats ] 2map ; + +GENERIC: v+- ( u v -- w ) +M: object v+- [ t ] 2dip [ [ not ] 2dip pick [ + ] [ - ] if ] 2map nip ; - +GENERIC: vs* ( u v -- w ) +M: object vs* [ * ] 2map ; -: vs+ ( u v -- w ) [ + ] 2saturate-map ; -: vs- ( u v -- w ) [ - ] 2saturate-map ; -: vs* ( u v -- w ) [ * ] 2saturate-map ; +GENERIC: vabs ( u -- v ) +M: object vabs [ abs ] map ; -: vabs ( u -- v ) [ abs ] map ; -: vsqrt ( u -- v ) [ >float fsqrt ] map ; +GENERIC: vsqrt ( u -- v ) +M: object vsqrt [ >float fsqrt ] map ; bits ] bi@ ] dip call bits>double ] } - { c:float [ [ [ float>bits ] bi@ ] dip call bits>float ] } - [ drop call ] - } case ; inline - -: fp-bitwise-unary ( x seq quot -- z ) - swap element-type { - { c:double [ [ double>bits ] dip call bits>double ] } - { c:float [ [ float>bits ] dip call bits>float ] } - [ drop call ] - } case ; inline - -: element>bool ( x seq -- ? ) - element-type [ [ f ] when-zero ] when ; inline - : bitandn ( x y -- z ) [ bitnot ] dip bitand ; inline -GENERIC: new-underlying ( underlying seq -- seq' ) - -: change-underlying ( seq quot -- seq' ) - '[ underlying>> @ ] keep new-underlying ; inline - PRIVATE> -: vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ; -: vbitandn ( u v -- w ) over '[ _ [ bitandn ] fp-bitwise-op ] 2map ; -: vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ; -: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ; -: vbitnot ( u -- w ) dup '[ _ [ bitnot ] fp-bitwise-unary ] map ; +GENERIC: vbitand ( u v -- w ) +M: object vbitand [ bitand ] 2map ; +GENERIC: vbitandn ( u v -- w ) +M: object vbitandn [ bitandn ] 2map ; +GENERIC: vbitor ( u v -- w ) +M: object vbitor [ bitor ] 2map ; +GENERIC: vbitxor ( u v -- w ) +M: object vbitxor [ bitxor ] 2map ; +GENERIC: vbitnot ( u -- w ) +M: object vbitnot [ bitnot ] 2map ; -:: vbroadcast ( u n -- v ) u length n u nth u like ; +GENERIC# vbroadcast 1 ( u n -- v ) +M:: object vbroadcast ( u n -- v ) u length n u nth u like ; -: vshuffle-elements ( u perm -- v ) +GENERIC# vshuffle-elements 1 ( u perm -- v ) +M: object vshuffle-elements over length 0 pad-tail swap [ '[ _ nth ] ] keep map-as ; -: vshuffle-bytes ( u perm -- v ) +GENERIC# vshuffle-bytes 1 ( u perm -- v ) +M: object vshuffle-bytes underlying>> [ swap [ '[ 15 bitand _ nth ] ] keep map-as ] curry change-underlying ; @@ -107,43 +116,72 @@ PRIVATE> GENERIC: vshuffle ( u perm -- v ) M: array vshuffle ( u perm -- v ) vshuffle-elements ; inline -M: simd-128 vshuffle ( u perm -- v ) - vshuffle-bytes ; inline -: vlshift ( u n -- w ) '[ _ shift ] map ; -: vrshift ( u n -- w ) neg '[ _ shift ] map ; +GENERIC# vlshift 1 ( u n -- w ) +M: object vlshift '[ _ shift ] map ; +GENERIC# vrshift 1 ( u n -- w ) +M: object vrshift neg '[ _ shift ] map ; -: hlshift ( u n -- w ) '[ _ prepend 16 head ] change-underlying ; -: hrshift ( u n -- w ) '[ _ append 16 tail* ] change-underlying ; +GENERIC# hlshift 1 ( u n -- w ) +M: object hlshift '[ _ prepend 16 head ] change-underlying ; +GENERIC# hrshift 1 ( u n -- w ) +M: object hrshift '[ _ append 16 tail* ] change-underlying ; -: (vmerge-head) ( u v -- h ) - over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ; -: (vmerge-tail) ( u v -- t ) - over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ; +GENERIC: (vmerge-head) ( u v -- h ) +M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ; +GENERIC: (vmerge-tail) ( u v -- t ) +M: object (vmerge-tail) over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ; -: (vmerge) ( u v -- h t ) +GENERIC: (vmerge) ( u v -- h t ) [ (vmerge-head) ] [ (vmerge-tail) ] 2bi ; inline -: vmerge ( u v -- w ) [ zip ] keep concat-as ; +GENERIC: vmerge ( u v -- w ) +M: object vmerge [ zip ] keep concat-as ; -: vand ( u v -- w ) over '[ [ _ element>bool ] bi@ and ] 2map ; -: vandn ( u v -- w ) over '[ [ _ element>bool ] bi@ [ not ] dip and ] 2map ; -: vor ( u v -- w ) over '[ [ _ element>bool ] bi@ or ] 2map ; -: vxor ( u v -- w ) over '[ [ _ element>bool ] bi@ xor ] 2map ; -: vnot ( u -- w ) dup '[ _ element>bool not ] map ; +GENERIC: vand ( u v -- w ) +M: object vand [ and ] 2map ; -: vall? ( v -- ? ) dup '[ _ element>bool ] all? ; -: vany? ( v -- ? ) dup '[ _ element>bool ] any? ; -: vnone? ( v -- ? ) dup '[ _ element>bool not ] all? ; +GENERIC: vandn ( u v -- w ) +M: object vandn [ [ not ] dip and ] 2map ; -: v< ( u v -- w ) [ < ] 2map ; -: v<= ( u v -- w ) [ <= ] 2map ; -: v>= ( u v -- w ) [ >= ] 2map ; -: v> ( u v -- w ) [ > ] 2map ; -: vunordered? ( u v -- w ) [ unordered? ] 2map ; -: v= ( u v -- w ) [ = ] 2map ; +GENERIC: vor ( u v -- w ) +M: object vor [ or ] 2map ; -: v? ( mask true false -- result ) +GENERIC: vxor ( u v -- w ) +M: object vxor [ xor ] 2map ; + +GENERIC: vnot ( u -- w ) +M: object vnot [ not ] map ; + +GENERIC: vall? ( v -- ? ) +M: object vall? [ ] all? ; + +GENERIC: vany? ( v -- ? ) +M: object vany? [ ] any? ; + +GENERIC: vnone? ( v -- ? ) +M: object vnone? [ not ] all? ; + +GENERIC: v< ( u v -- w ) +M: object v< [ < ] 2map ; + +GENERIC: v<= ( u v -- w ) +M: object v<= [ <= ] 2map ; + +GENERIC: v>= ( u v -- w ) +M: object v>= [ >= ] 2map ; + +GENERIC: v> ( u v -- w ) +M: object v> [ > ] 2map ; + +GENERIC: vunordered? ( u v -- w ) +M: object vunordered? [ unordered? ] 2map ; + +GENERIC: v= ( u v -- w ) +M: object v= [ = ] 2map ; + +GENERIC: v? ( mask true false -- result ) +M: object v? [ vand ] [ vandn ] bi-curry* bi vor ; inline :: vif ( mask true-quot false-quot -- result ) @@ -157,15 +195,22 @@ M: simd-128 vshuffle ( u perm -- v ) : vceiling ( u -- v ) [ ceiling ] map ; : vtruncate ( u -- v ) [ truncate ] map ; -: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; -: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; +: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; inline +: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; inline -: v. ( u v -- x ) [ conjugate * ] [ + ] 2map-reduce ; -: norm-sq ( v -- x ) [ absq ] [ + ] map-reduce ; -: norm ( v -- x ) norm-sq sqrt ; -: normalize ( u -- v ) dup norm v/n ; +GENERIC: v. ( u v -- x ) +M: object v. [ conjugate * ] [ + ] 2map-reduce ; -: distance ( u v -- x ) [ - absq ] [ + ] 2map-reduce sqrt ; +GENERIC: norm-sq ( v -- x ) +M: object norm-sq [ absq ] [ + ] map-reduce ; + +GENERIC: norm ( v -- x ) +M: object norm norm-sq sqrt ; + +: normalize ( u -- v ) dup norm v/n ; inline + +GENERIC: distance ( u v -- x ) +M: object distance [ - absq ] [ + ] 2map-reduce sqrt ; : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; @@ -198,27 +243,27 @@ PRIVATE> : v~ ( a b epsilon -- ? ) [ ~ ] curry 2all? ; inline -HINTS: vneg { array } ; -HINTS: norm-sq { array } ; -HINTS: norm { array } ; -HINTS: normalize { array } ; -HINTS: distance { array array } ; +HINTS: M\ object vneg { array } ; +HINTS: M\ object norm-sq { array } ; +HINTS: M\ object norm { array } ; +HINTS: M\ object distance { array array } ; -HINTS: n*v { object array } ; -HINTS: v*n { array object } ; -HINTS: n/v { array } ; -HINTS: v/n { array object } ; +HINTS: M\ object n*v { object array } ; +HINTS: M\ object v*n { array object } ; +HINTS: M\ object n/v { object array } ; +HINTS: M\ object v/n { array object } ; -HINTS: v+ { array array } ; -HINTS: v- { array array } ; -HINTS: v* { array array } ; -HINTS: v/ { array array } ; -HINTS: vmax { array array } ; -HINTS: vmin { array array } ; -HINTS: v. { array array } ; +HINTS: M\ object v+ { array array } ; +HINTS: M\ object v- { array array } ; +HINTS: M\ object v* { array array } ; +HINTS: M\ object v/ { array array } ; +HINTS: M\ object vmax { array array } ; +HINTS: M\ object vmin { array array } ; +HINTS: M\ object v. { array array } ; HINTS: vlerp { array array array } ; HINTS: vnlerp { array array object } ; HINTS: bilerp { object object object object array } ; HINTS: trilerp { object object object object object object object object array } ; + diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 1bcedb1d15..e8c24a3b96 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -929,7 +929,8 @@ PRIVATE> : trim ( seq quot -- newseq ) [ trim-slice ] [ drop ] 2bi like ; inline -: sum ( seq -- n ) 0 [ + ] binary-reduce ; +GENERIC: sum ( seq -- n ) +M: object sum 0 [ + ] binary-reduce ; inline : product ( seq -- n ) 1 [ * ] binary-reduce ; From 9cf3ab3da1afb5699919d3f5511df6bca17fbf19 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 2 Nov 2009 14:24:29 -0600 Subject: [PATCH 010/513] redo math.vectors.simd to use generics for specialization --- basis/math/vectors/simd/simd.factor | 353 +++++++++++++++++++++++++--- 1 file changed, 325 insertions(+), 28 deletions(-) diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index 388fed5f31..139060333c 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -1,42 +1,339 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types combinators fry kernel parser math math.parser -math.vectors.simd.functor sequences splitting vocabs.generated -vocabs.loader vocabs.parser words accessors vocabs compiler.units -definitions ; +! (c)2009 Slava Pestov, Joe Groff bsd license +USING: math.vectors math.vectors.private ; QUALIFIED-WITH: alien.c-types c IN: math.vectors.simd -ERROR: bad-base-type type ; +DEFER: vconvert +DEFER: simd-with +DEFER: simd-boa +DEFER: simd-cast > "math.vectors.simd.instances." prepend ; +! Primitive SIMD constructors -: parse-base-type ( c-type -- c-type ) - dup { c:char c:uchar c:short c:ushort c:int c:uint c:longlong c:ulonglong c:float c:double } member-eq? - [ bad-base-type ] unless ; +GENERIC: new-underlying ( underlying seq -- seq' ) -: forget-instances ( -- ) - [ - "math.vectors.simd.instances" child-vocabs - [ forget-vocab ] each - ] with-compilation-unit ; +: make-underlying ( seq quot -- seq' ) + dip new-underlying ; inline +: change-underlying ( seq quot -- seq' ) + '[ underlying>> @ ] keep new-underlying ; inline + +! SIMD intrinsics + +: (simd-v+) ( a b rep -- c ) \ v+ bad-simd-call ; +: (simd-v-) ( a b rep -- c ) \ v- bad-simd-call ; +: (simd-vneg) ( a rep -- c ) \ vneg bad-simd-call ; +: (simd-v+-) ( a b rep -- c ) \ v+- bad-simd-call ; +: (simd-vs+) ( a b rep -- c ) \ vs+ bad-simd-call ; +: (simd-vs-) ( a b rep -- c ) \ vs- bad-simd-call ; +: (simd-vs*) ( a b rep -- c ) \ vs* bad-simd-call ; +: (simd-v*) ( a b rep -- c ) \ v* bad-simd-call ; +: (simd-v/) ( a b rep -- c ) \ v/ bad-simd-call ; +: (simd-vmin) ( a b rep -- c ) \ vmin bad-simd-call ; +: (simd-vmax) ( a b rep -- c ) \ vmax bad-simd-call ; +: (simd-v.) ( a b rep -- n ) \ v. bad-simd-call ; +: (simd-vsqrt) ( a rep -- c ) \ vsqrt bad-simd-call ; +: (simd-sum) ( a b rep -- n ) \ sum bad-simd-call ; +: (simd-vabs) ( a rep -- c ) \ vabs bad-simd-call ; +: (simd-vbitand) ( a b rep -- c ) \ vbitand bad-simd-call ; +: (simd-vbitandn) ( a b rep -- c ) \ vbitandn bad-simd-call ; +: (simd-vbitor) ( a b rep -- c ) \ vbitor bad-simd-call ; +: (simd-vbitxor) ( a b rep -- c ) \ vbitxor bad-simd-call ; +: (simd-vbitnot) ( a b rep -- c ) \ vbitnot bad-simd-call ; +: (simd-vand) ( a b rep -- c ) \ vand bad-simd-call ; +: (simd-vandn) ( a b rep -- c ) \ vandn bad-simd-call ; +: (simd-vor) ( a b rep -- c ) \ vor bad-simd-call ; +: (simd-vxor) ( a b rep -- c ) \ vxor bad-simd-call ; +: (simd-vnot) ( a b rep -- c ) \ vnot bad-simd-call ; +: (simd-vlshift) ( a n rep -- c ) \ vlshift bad-simd-call ; +: (simd-vrshift) ( a n rep -- c ) \ vrshift bad-simd-call ; +: (simd-hlshift) ( a n rep -- c ) \ hlshift bad-simd-call ; +: (simd-hrshift) ( a n rep -- c ) \ hrshift bad-simd-call ; +: (simd-vshuffle-elements) ( a n rep -- c ) \ vshuffle-elements bad-simd-call ; +: (simd-vshuffle-bytes) ( a b rep -- c ) \ vshuffle-bytes bad-simd-call ; +: (simd-vmerge-head) ( a b rep -- c ) \ (vmerge-head) bad-simd-call ; +: (simd-vmerge-tail) ( a b rep -- c ) \ (vmerge-tail) bad-simd-call ; +: (simd-v<=) ( a b rep -- c ) \ v<= bad-simd-call ; +: (simd-v<) ( a b rep -- c ) \ v< bad-simd-call ; +: (simd-v=) ( a b rep -- c ) \ v= bad-simd-call ; +: (simd-v>) ( a b rep -- c ) \ v> bad-simd-call ; +: (simd-v>=) ( a b rep -- c ) \ v>= bad-simd-call ; +: (simd-vunordered?) ( a b rep -- c ) \ vunordered? bad-simd-call ; +: (simd-vany?) ( a rep -- ? ) \ vany? bad-simd-call ; +: (simd-vall?) ( a rep -- ? ) \ vall? bad-simd-call ; +: (simd-vnone?) ( a rep -- ? ) \ vnone? bad-simd-call ; +: (simd-v>float) ( a rep -- c ) \ vconvert bad-simd-call ; +: (simd-v>integer) ( a rep -- c ) \ vconvert bad-simd-call ; +: (simd-vpack-signed) ( a rep -- c ) \ vconvert bad-simd-call ; +: (simd-vpack-unsigned) ( a rep -- c ) \ vconvert bad-simd-call ; +: (simd-vunpack-head) ( a rep -- c ) \ vconvert bad-simd-call ; +: (simd-vunpack-tail) ( a rep -- c ) \ vconvert bad-simd-call ; +: (simd-with) ( n rep -- v ) \ simd-with bad-simd-call ; +: (simd-gather-2) ( m n rep -- v ) \ simd-boa bad-simd-call ; +: (simd-gather-4) ( m n o p rep -- v ) \ simd-boa bad-simd-call ; +: (simd-select) ( a n rep -- n ) \ nth bad-simd-call ; + +: alien-vector ( c-ptr n rep -- value ) \ alien-vector bad-simd-call ; +: set-alien-vector ( c-ptr n rep -- value ) \ set-alien-vector bad-simd-call ; + +: alien-vector-aligned ( c-ptr n rep -- value ) \ alien-vector-aligned bad-simd-call ; +: set-alien-vector-aligned ( c-ptr n rep -- value ) \ set-alien-vector-aligned bad-simd-call ; + +! Helper for boolean vector literals + +: vector-true-value ( class -- value ) + { c:float c:double } member? [ -1 bits>double ] [ -1 ] if ; foldable + +: vector-false-value ( type -- value ) + { c:float c:double } member? [ 0.0 ] [ 0 ] if ; foldable + +: boolean>element ( bool/elt type -- elt ) + swap { + { t [ vector-true-value ] } + { f [ vector-false-value ] } + [ nip ] + } case ; inline PRIVATE> -: define-simd-vocab ( type -- vocab ) - parse-base-type - [ simd-vocab ] keep '[ - _ - [ define-simd-128 ] - [ define-simd-256 ] bi - ] generate-vocab ; +! SIMD base type -SYNTAX: SIMD: - scan-word define-simd-vocab use-vocab ; +TUPLE: simd-128 + { underlying byte-array read-only initial: $[ 16 ] } ; -SYNTAX: SIMDS: - \ ; parse-until [ define-simd-vocab use-vocab ] each ; +GENERIC: simd-element-type ( obj -- c-type ) +GENERIC: simd-rep ( simd -- rep ) + +: rep-length ( rep -- n ) + 16 swap rep-component-type heap-size /i ; foldable + +<< A DEFINES >${T} +A-boa DEFINES ${T}-boa +A-with DEFINES ${T}-with +A-cast DEFINES ${T}-cast +A{ DEFINES ${T}{ + +ELT [ A-rep rep-component-type ] +N [ A-rep rep-length ] + +SET-NTH [ ELT dup c:c-setter c:array-accessor ] + +WHERE + +TUPLE: A < simd-128 ; + +M: A new-underlying drop \ A boa ; inline +M: A simd-rep drop A-rep ; inline +M: A simd-element-type drop ELT ; inline +M: A length drop N ; inline + +M: A set-nth-unsafe + [ ELT boolean>element ] 2dip + underlying>> SET-NTH call ; inline + +: >A ( seq -- simd ) \ A new clone-like ; inline + +M: A like drop dup \ A instance? [ >A ] unless ; inline + +: A-with ( n -- v ) \ A new simd-with ; inline +: A-cast ( v -- v' ) \ A new simd-cast ; inline +: A-boa ( ...n -- v ) \ A new simd-boa ; inline + +M: A pprint-delims drop \ A{ \ } ; +SYNTAX: A{ \ } [ >A ] parse-literal ; + +c: + byte-array >>class + A >>boxed-class + [ A-rep alien-vector \ A boa ] >>getter + [ [ underlying>> ] 2dip A-rep set-alien-vector ] >>setter + 16 >>size + 16 >>align + A-rep >>rep +\ A c:typedef + +;FUNCTOR + +SYNTAX: SIMD-128: + scan scan-word define-simd-128 ; + +PRIVATE> >> + +SIMD-128: char-16 +SIMD-128: uchar-16 +SIMD-128: short-8 +SIMD-128: ushort-8 +SIMD-128: int-4 +SIMD-128: uint-4 +SIMD-128: longlong-2 +SIMD-128: ulonglong-2 +SIMD-128: float-4 +SIMD-128: double-2 + +ERROR: bad-simd-call word ; +ERROR: bad-simd-length got expected ; + +: assert-positive ( x -- y ) ; + +! SIMD vectors as sequences + +M: simd-128 clone [ clone ] change-underlying ; inline +M: simd-128 length simd-rep rep-length ; inline +M: simd-128 nth-unsafe tuck simd-rep (simd-select) ; inline +M: simd-128 c:byte-length drop 16 ; inline + +M: simd-128 new-sequence + 2dup length = + [ nip [ 16 (byte-array) ] make-underlying ] + [ length bad-simd-length ] if ; inline + +M: simd-128 equal? + [ v= vall? ] [ 2drop f ] if-vectors-match ; inline + +M: simd-128 >pprint-sequence ; +M: simd-128 pprint* pprint-object ; + +INSTANCE: simd-128 sequence + +! Unboxers for SIMD operations + +> ] [ simd-rep ] tri ; inline + +: simd-v->v-op ( a quot: ( (a) rep -- (c) ) -- c ) + [ simd-unbox ] dip 2curry make-underlying ; inline + +: simd-v->n-op ( a quot: ( (a) rep -- n ) -- n ) + [ [ underlying>> ] [ simd-rep ] bi ] dip call ; inline + +: ((simd-vv->v-op)) ( a b quot: ( (a) (b) rep -- (c) ) -- c ) + [ simd-unbox ] [ underlying>> swap ] [ 3curry ] tri* make-underlying ; inline + +: ((simd-vv->n-op)) ( a b quot: ( (a) (b) rep -- n ) -- n ) + [ [ underlying>> ] [ simd-rep ] bi ] + [ underlying>> swap ] [ ] tri* call ; inline + +: (simd-vv->v-op) ( a b quot: ( (a) (b) rep -- (c) ) fallback-quot -- c ) + [ '[ _ ((simd-vv->v-op)) ] ] dip if-both-vectors-match ; inline + +: (simd-vv'->v-op) ( a b quot: ( (a) (b) rep -- (c) ) fallback-quot -- c ) + [ '[ _ ((simd-vv->v-op)) ] ] dip if-both-vectors ; inline + +: (simd-vv->n-op) ( a b quot: ( (a) (b) rep -- n ) fallback-quot -- n ) + [ '[ _ ((simd-vv->n-op)) ] ] dip if-both-vectors-match ; inline + +: (simd-method-fallback) ( accum word -- accum ) + [ current-method get \ (call-next-method) [ ] 2sequence suffix! ] + dip suffix! ; + +SYNTAX: simd-vv->v-op + \ (simd-vv->v-op) (simd-method-fallback) ; +SYNTAX: simd-vv'->v-op + \ (simd-vv'->v-op) (simd-method-fallback) ; +SYNTAX: simd-vv->n-op + \ (simd-vv->n-op) (simd-method-fallback) ; + +PRIVATE> + +! SIMD constructors + +: simd-with ( n seq -- v ) + [ (simd-with) ] simd-construct-op ; inline + +MACRO: simd-boa ( seq -- ) + dup length { + { 2 [ '[ _ dup [ (simd-gather-2) ] simd-construct-op ] ] } + { 4 [ '[ _ dup [ (simd-gather-4) ] simd-construct-op ] ] } + [ '[ _ _ nsequence ] ] + } case ; + +: simd-cast ( v seq -- v' ) + [ underlying>> ] dip new-underlying ; inline + +! SIMD primitive operations + +M: simd-128 v+ [ (simd-v+) ] simd-vv->v-op ; inline +M: simd-128 v- [ (simd-v-) ] simd-vv->v-op ; inline +M: simd-128 vneg [ (simd-vneg) ] simd-v->v-op ; inline +M: simd-128 v+- [ (simd-v+-) ] simd-vv->v-op ; inline +M: simd-128 vs+ [ (simd-vs+) ] simd-vv->v-op ; inline +M: simd-128 vs- [ (simd-vs-) ] simd-vv->v-op ; inline +M: simd-128 vs* [ (simd-vs*) ] simd-vv->v-op ; inline +M: simd-128 v* [ (simd-v*) ] simd-vv->v-op ; inline +M: simd-128 v/ [ (simd-v/) ] simd-vv->v-op ; inline +M: simd-128 vmin [ (simd-vmin) ] simd-vv->v-op ; inline +M: simd-128 vmax [ (simd-vmax) ] simd-vv->v-op ; inline +M: simd-128 v. [ (simd-v.) ] simd-vv->n-op ; inline +M: simd-128 vsqrt [ (simd-vsqrt) ] simd-v->v-op ; inline +M: simd-128 sum [ (simd-sum) ] simd-vv->n-op ; inline +M: simd-128 vabs [ (simd-vabs) ] simd-v->v-op ; inline +M: simd-128 vbitand [ (simd-vbitand) ] simd-vv->v-op ; inline +M: simd-128 vbitandn [ (simd-vbitandn) ] simd-vv->v-op ; inline +M: simd-128 vbitor [ (simd-vbitor) ] simd-vv->v-op ; inline +M: simd-128 vbitxor [ (simd-vbitxor) ] simd-vv->v-op ; inline +M: simd-128 vbitnot [ (simd-vbitnot) ] simd-vv->v-op ; inline +M: simd-128 vand [ (simd-vand) ] simd-vv->v-op ; inline +M: simd-128 vandn [ (simd-vandn) ] simd-vv->v-op ; inline +M: simd-128 vor [ (simd-vor) ] simd-vv->v-op ; inline +M: simd-128 vxor [ (simd-vxor) ] simd-vv->v-op ; inline +M: simd-128 vnot [ (simd-vnot) ] simd-vv->v-op ; inline +M: simd-128 vlshift [ (simd-vlshift) ] simd-vn->v-op ; inline +M: simd-128 vrshift [ (simd-vrshift) ] simd-vn->v-op ; inline +M: simd-128 hlshift [ (simd-hlshift) ] simd-vn->v-op ; inline +M: simd-128 hrshift [ (simd-hrshift) ] simd-vn->v-op ; inline +M: simd-128 vshuffle-elements [ (simd-vshuffle-elements) ] simd-vn->v-op ; inline +M: simd-128 vshuffle-bytes [ (simd-vshuffle-bytes) ] simd-vv->v-op ; inline +M: simd-128 vmerge-head [ (simd-vmerge-head) ] simd-vv->v-op ; inline +M: simd-128 vmerge-tail [ (simd-vmerge-tail) ] simd-vv->v-op ; inline +M: simd-128 v<= [ (simd-v<=) ] simd-vv->v-op ; inline +M: simd-128 v< [ (simd-v<) ] simd-vv->v-op ; inline +M: simd-128 v= [ (simd-v=) ] simd-vv->v-op ; inline +M: simd-128 v> [ (simd-v>) ] simd-vv->v-op ; inline +M: simd-128 v>= [ (simd-v>=) ] simd-vv->v-op ; inline +M: simd-128 vunordered? [ (simd-vunordered?) ] simd-vv->v-op ; inline +M: simd-128 vany? [ (simd-vany?) ] simd-v->n-op ; inline +M: simd-128 vall? [ (simd-vall?) ] simd-v->n-op ; inline +M: simd-128 vnone? [ (simd-vnone?) ] simd-v->n-op ; inline + +! SIMD high-level specializations + +M: simd-128 vbroadcast [ swap nth ] keep simd-with ; inline +M: simd-128 n+v [ simd-with ] keep v+ ; inline +M: simd-128 n-v [ simd-with ] keep v- ; inline +M: simd-128 n*v [ simd-with ] keep v* ; inline +M: simd-128 n/v [ simd-with ] keep v/ ; inline +M: simd-128 v+n over simd-with v+ +M: simd-128 v-n over simd-with v- ; inline +M: simd-128 v*n over simd-with v* ; inline +M: simd-128 v/n over simd-with v/ ; inline +M: simd-128 norm-sq dup v. assert-positive ; inline +M: simd-128 norm norm-sq sqrt ; inline +M: simd-128 normalize dup norm v/n ; inline +M: simd-128 distance v- norm ; inline + +! misc + +M: simd-128 vshuffle ( u perm -- v ) + vshuffle-bytes ; inline From 73d2a756440f41a0913781afd15673937b739fae Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 2 Nov 2009 15:00:39 -0600 Subject: [PATCH 011/513] remove math.vectors .specialization, .simd.functor, .simd.intrinsics --- basis/math/vectors/simd/functor/authors.txt | 1 - .../math/vectors/simd/functor/functor.factor | 522 ------------------ .../math/vectors/simd/intrinsics/authors.txt | 1 - .../simd/intrinsics/intrinsics-tests.factor | 18 - .../vectors/simd/intrinsics/intrinsics.factor | 207 ------- .../specialization-tests.factor | 28 - .../specialization/specialization.factor | 207 ------- 7 files changed, 984 deletions(-) delete mode 100644 basis/math/vectors/simd/functor/authors.txt delete mode 100644 basis/math/vectors/simd/functor/functor.factor delete mode 100644 basis/math/vectors/simd/intrinsics/authors.txt delete mode 100644 basis/math/vectors/simd/intrinsics/intrinsics-tests.factor delete mode 100644 basis/math/vectors/simd/intrinsics/intrinsics.factor delete mode 100644 basis/math/vectors/specialization/specialization-tests.factor delete mode 100644 basis/math/vectors/specialization/specialization.factor diff --git a/basis/math/vectors/simd/functor/authors.txt b/basis/math/vectors/simd/functor/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/math/vectors/simd/functor/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/math/vectors/simd/functor/functor.factor b/basis/math/vectors/simd/functor/functor.factor deleted file mode 100644 index 480981d165..0000000000 --- a/basis/math/vectors/simd/functor/functor.factor +++ /dev/null @@ -1,522 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs byte-arrays classes classes.algebra effects fry -functors generalizations kernel literals locals math math.functions -math.vectors math.vectors.private math.vectors.simd.intrinsics -math.vectors.conversion.backend -math.vectors.specialization parser prettyprint.custom sequences -sequences.private strings words definitions macros cpu.architecture -namespaces arrays quotations combinators combinators.short-circuit sets -layouts ; -QUALIFIED-WITH: alien.c-types c -QUALIFIED: math.private -IN: math.vectors.simd.functor - -ERROR: bad-length got expected ; - -: vector-true-value ( class -- value ) - { - { [ dup integer class<= ] [ drop -1 ] } - { [ dup float class<= ] [ drop -1 bits>double ] } - } cond ; foldable - -: vector-false-value ( class -- value ) - { - { [ dup integer class<= ] [ drop 0 ] } - { [ dup float class<= ] [ drop 0.0 ] } - } cond ; foldable - -: boolean>element ( bool/elt class -- elt ) - swap { - { t [ vector-true-value ] } - { f [ vector-false-value ] } - [ nip ] - } case ; inline - -MACRO: simd-boa ( rep class -- simd-array ) - [ rep-components ] [ new ] bi* '[ _ _ nsequence ] ; - -: can-be-unboxed? ( type -- ? ) - { - { c:float [ \ math.private:float+ "intrinsic" word-prop ] } - { c:double [ \ math.private:float+ "intrinsic" word-prop ] } - [ c:heap-size cell < ] - } case ; - -: simd-boa-fast? ( rep -- ? ) - [ dup rep-gather-word supported-simd-op? ] - [ rep-component-type can-be-unboxed? ] - bi and ; - -:: define-boa-custom-inlining ( word rep class -- ) - word [ - drop - rep simd-boa-fast? [ - [ rep (simd-boa) class boa ] - ] [ word def>> ] if - ] "custom-inlining" set-word-prop ; - -: simd-with ( rep class x -- simd-array ) - [ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline - -: simd-with/nth-fast? ( rep -- ? ) - [ \ (simd-vshuffle-elements) supported-simd-op? ] - [ rep-component-type can-be-unboxed? ] - bi and ; - -:: define-with-custom-inlining ( word rep class -- ) - word [ - drop - rep simd-with/nth-fast? [ - [ rep rep-coerce rep (simd-with) class boa ] - ] [ word def>> ] if - ] "custom-inlining" set-word-prop ; - -: simd-nth-fast ( rep -- quot ) - [ rep-components ] keep - '[ swap _ '[ _ _ (simd-select) ] 2array ] map-index - '[ swap >fixnum _ case ] ; - -: simd-nth-slow ( rep -- quot ) - rep-component-type dup c:c-type-getter-boxer c:array-accessor ; - -MACRO: simd-nth ( rep -- x ) - dup simd-with/nth-fast? [ simd-nth-fast ] [ simd-nth-slow ] if ; - -: boa-effect ( rep n -- effect ) - [ rep-components ] dip * - [ CHAR: a + 1string ] map - { "simd-vector" } ; - -: supported-simd-ops ( assoc rep -- assoc' ) - [ simd-ops get ] dip - '[ nip _ swap supported-simd-op? ] assoc-filter - '[ drop _ key? ] assoc-filter ; - -ERROR: bad-schema op schema ; - -:: op-wrapper ( op specials schemas -- wrapper ) - op { - [ specials at ] - [ word-schema schemas at ] - [ dup word-schema bad-schema ] - } 1|| ; - -: low-level-ops ( simd-ops specials schemas -- alist ) - '[ 1quotation over _ _ op-wrapper [ ] 2sequence ] assoc-map ; - -:: high-level-ops ( ctor elt-class -- assoc ) - ! Some SIMD operations are defined in terms of others. - { - { vbroadcast [ swap nth ctor execute ] } - { n+v [ [ ctor execute ] dip v+ ] } - { v+n [ ctor execute v+ ] } - { n-v [ [ ctor execute ] dip v- ] } - { v-n [ ctor execute v- ] } - { n*v [ [ ctor execute ] dip v* ] } - { v*n [ ctor execute v* ] } - { n/v [ [ ctor execute ] dip v/ ] } - { v/n [ ctor execute v/ ] } - { norm-sq [ dup v. assert-positive ] } - { norm [ norm-sq sqrt ] } - { normalize [ dup norm v/n ] } - } - ! To compute dot product and distance with integer vectors, we - ! have to do things less efficiently, with integer overflow checks, - ! in the general case. - elt-class float = [ { distance [ v- norm ] } suffix ] when ; - -TUPLE: simd class elt-class ops special-wrappers schema-wrappers ctor rep ; - -: define-simd ( simd -- ) - dup rep>> rep-component-type c:c-type-boxed-class >>elt-class - { - [ class>> ] - [ elt-class>> ] - [ [ ops>> ] [ special-wrappers>> ] [ schema-wrappers>> ] tri low-level-ops ] - [ rep>> supported-simd-ops ] - [ [ ctor>> ] [ elt-class>> ] bi high-level-ops assoc-union ] - } cleave - specialize-vector-words ; - -:: define-simd-128-type ( class rep -- ) - c: - byte-array >>class - class >>boxed-class - [ rep alien-vector class boa ] >>getter - [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter - 16 >>size - 8 >>align - rep >>rep - class c:typedef ; - -: (define-simd-128) ( simd -- ) - simd-ops get >>ops - [ define-simd ] - [ [ class>> ] [ rep>> ] bi define-simd-128-type ] bi ; - -FUNCTOR: define-simd-128 ( T -- ) - -N [ 16 T c:heap-size /i ] - -A DEFINES-CLASS ${T}-${N} -A-boa DEFINES ${A}-boa -A-with DEFINES ${A}-with -A-cast DEFINES ${A}-cast ->A DEFINES >${A} -A{ DEFINES ${A}{ - -SET-NTH [ T dup c:c-setter c:array-accessor ] - -A-rep [ A name>> "-rep" append "cpu.architecture" lookup ] -A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op -A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op -A-vv->n-op DEFINES-PRIVATE ${A}-vv->n-op -A-v->v-op DEFINES-PRIVATE ${A}-v->v-op -A-v->n-op DEFINES-PRIVATE ${A}-v->n-op -A-v-conversion-op DEFINES-PRIVATE ${A}-v-conversion-op -A-vv-conversion-op DEFINES-PRIVATE ${A}-vv-conversion-op - -A-element-class [ A-rep rep-component-type c:c-type-boxed-class ] - -WHERE - -TUPLE: A -{ underlying byte-array read-only initial: $[ 16 ] } ; - -INSTANCE: A simd-128 - -M: A clone underlying>> clone \ A boa ; inline - -M: A length drop N ; inline - -M: A equal? - over \ A instance? [ v= vall? ] [ 2drop f ] if ; - -M: A nth-unsafe underlying>> A-rep simd-nth ; inline - -M: A set-nth-unsafe - [ A-element-class boolean>element ] 2dip - underlying>> SET-NTH call ; inline - -: >A ( seq -- simd-array ) \ A new clone-like ; - -M: A like drop dup \ A instance? [ >A ] unless ; inline - -M: A new-underlying drop \ A boa ; inline - -M: A new-sequence - drop dup N = - [ drop 16 \ A boa ] - [ N bad-length ] - if ; inline - -M: A c:byte-length underlying>> length ; inline - -M: A element-type drop A-rep rep-component-type ; - -M: A pprint-delims drop \ A{ \ } ; - -M: A >pprint-sequence ; - -M: A pprint* pprint-object ; - -SYNTAX: A{ \ } [ >A ] parse-literal ; - -: A-with ( x -- simd-array ) [ A-rep A ] dip simd-with ; - -\ A-with \ A-rep \ A define-with-custom-inlining - -\ A-boa [ \ A-rep \ A simd-boa ] \ A-rep 1 boa-effect define-declared - -\ A-rep rep-gather-word [ - \ A-boa \ A-rep \ A define-boa-custom-inlining -] when - -: A-cast ( simd-array -- simd-array' ) - underlying>> \ A boa ; inline - -INSTANCE: A sequence - -v-op ( v1 v2 quot -- v3 ) - [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline - -: A-vn->v-op ( v1 v2 quot -- v3 ) - [ [ underlying>> ] dip A-rep ] dip call \ A boa ; inline - -: A-vv->n-op ( v1 v2 quot -- n ) - [ [ underlying>> ] bi@ A-rep ] dip call ; inline - -: A-v->v-op ( v1 quot -- v2 ) - [ underlying>> A-rep ] dip call \ A boa ; inline - -: A-v->n-op ( v quot -- n ) - [ underlying>> A-rep ] dip call ; inline - -: A-v-conversion-op ( v1 to-type quot -- v2 ) - swap [ underlying>> A-rep ] [ call ] [ '[ _ boa ] call( u -- v ) ] tri* ; inline - -: A-vv-conversion-op ( v1 v2 to-type quot -- v2 ) - swap { - [ underlying>> ] - [ underlying>> A-rep ] - [ call ] - [ '[ _ boa ] call( u -- v ) ] - } spread ; inline - -simd new - \ A >>class - \ A-with >>ctor - \ A-rep >>rep - { - { (v>float) A-v-conversion-op } - { (v>integer) A-v-conversion-op } - { (vpack-signed) A-vv-conversion-op } - { (vpack-unsigned) A-vv-conversion-op } - { (vunpack-head) A-v-conversion-op } - { (vunpack-tail) A-v-conversion-op } - } >>special-wrappers - { - { { +vector+ +vector+ -> +vector+ } A-vv->v-op } - { { +vector+ +any-vector+ -> +vector+ } A-vv->v-op } - { { +vector+ +scalar+ -> +vector+ } A-vn->v-op } - { { +vector+ +literal+ -> +vector+ } A-vn->v-op } - { { +vector+ +vector+ -> +scalar+ } A-vv->n-op } - { { +vector+ +vector+ -> +boolean+ } A-vv->n-op } - { { +vector+ -> +vector+ } A-v->v-op } - { { +vector+ -> +scalar+ } A-v->n-op } - { { +vector+ -> +boolean+ } A-v->n-op } - { { +vector+ -> +nonnegative+ } A-v->n-op } - } >>schema-wrappers -(define-simd-128) - -PRIVATE> - -;FUNCTOR - -! Synthesize 256-bit vectors from a pair of 128-bit vectors -SLOT: underlying1 -SLOT: underlying2 - -:: define-simd-256-type ( class rep -- ) - c: - class >>class - class >>boxed-class - [ - [ rep alien-vector ] - [ 16 + >fixnum rep alien-vector ] 2bi - class boa - ] >>getter - [ - [ [ underlying1>> ] 2dip rep set-alien-vector ] - [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ] - 3bi - ] >>setter - 32 >>size - 8 >>align - rep >>rep - class c:typedef ; - -: (define-simd-256) ( simd -- ) - simd-ops get { vshuffle-elements vshuffle-bytes hlshift hrshift } unique assoc-diff >>ops - [ define-simd ] - [ [ class>> ] [ rep>> ] bi define-simd-256-type ] bi ; - -FUNCTOR: define-simd-256 ( T -- ) - -N [ 32 T c:heap-size /i ] - -N/2 [ N 2 /i ] -A/2 IS ${T}-${N/2} -A/2-boa IS ${A/2}-boa -A/2-with IS ${A/2}-with - -A DEFINES-CLASS ${T}-${N} -A-boa DEFINES ${A}-boa -A-with DEFINES ${A}-with -A-cast DEFINES ${A}-cast ->A DEFINES >${A} -A{ DEFINES ${A}{ - -A-deref DEFINES-PRIVATE ${A}-deref - -A-rep [ A/2 name>> "-rep" append "cpu.architecture" lookup ] -A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op -A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op -A-v->v-op DEFINES-PRIVATE ${A}-v->v-op -A-v.-op DEFINES-PRIVATE ${A}-v.-op -(A-v->n-op) DEFINES-PRIVATE (${A}-v->v-op) -A-sum-op DEFINES-PRIVATE ${A}-sum-op -A-vany-op DEFINES-PRIVATE ${A}-vany-op -A-vall-op DEFINES-PRIVATE ${A}-vall-op -A-vmerge-head-op DEFINES-PRIVATE ${A}-vmerge-head-op -A-vmerge-tail-op DEFINES-PRIVATE ${A}-vmerge-tail-op -A-v-conversion-op DEFINES-PRIVATE ${A}-v-conversion-op -A-vpack-op DEFINES-PRIVATE ${A}-vpack-op -A-vunpack-head-op DEFINES-PRIVATE ${A}-vunpack-head-op -A-vunpack-tail-op DEFINES-PRIVATE ${A}-vunpack-tail-op - -WHERE - -SLOT: underlying1 -SLOT: underlying2 - -TUPLE: A -{ underlying1 byte-array initial: $[ 16 ] read-only } -{ underlying2 byte-array initial: $[ 16 ] read-only } ; - -INSTANCE: A simd-256 - -M: A clone - [ underlying1>> clone ] [ underlying2>> clone ] bi - \ A boa ; inline - -M: A length drop N ; inline - -M: A equal? - over \ A instance? [ v= vall? ] [ 2drop f ] if ; - -: A-deref ( n seq -- n' seq' ) - over N/2 < [ underlying1>> ] [ [ N/2 - ] dip underlying2>> ] if \ A/2 boa ; inline - -M: A nth-unsafe A-deref nth-unsafe ; inline - -M: A set-nth-unsafe A-deref set-nth-unsafe ; inline - -: >A ( seq -- simd-array ) \ A new clone-like ; - -M: A like drop dup \ A instance? [ >A ] unless ; inline - -M: A new-sequence - drop dup N = - [ drop 16 16 \ A boa ] - [ N bad-length ] - if ; inline - -M: A c:byte-length drop 32 ; inline - -M: A element-type drop A-rep rep-component-type ; - -SYNTAX: A{ \ } [ >A ] parse-literal ; - -M: A pprint-delims drop \ A{ \ } ; - -M: A >pprint-sequence ; - -M: A pprint* pprint-object ; - -: A-with ( x -- simd-array ) - [ A/2-with ] [ A/2-with ] bi [ underlying>> ] bi@ - \ A boa ; inline - -: A-boa ( ... -- simd-array ) - [ A/2-boa ] N/2 ndip A/2-boa [ underlying>> ] bi@ - \ A boa ; inline - -\ A-rep 2 boa-effect \ A-boa set-stack-effect - -: A-cast ( simd-array -- simd-array' ) - [ underlying1>> ] [ underlying2>> ] bi \ A boa ; inline - -INSTANCE: A sequence - -: A-vv->v-op ( v1 v2 quot -- v3 ) - [ [ [ underlying1>> ] bi@ A-rep ] dip call ] - [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi - \ A boa ; inline - -: A-vn->v-op ( v1 v2 quot -- v3 ) - [ [ [ underlying1>> ] dip A-rep ] dip call ] - [ [ [ underlying2>> ] dip A-rep ] dip call ] 3bi - \ A boa ; inline - -: A-v->v-op ( v1 combine-quot -- v2 ) - [ [ underlying1>> A-rep ] dip call ] - [ [ underlying2>> A-rep ] dip call ] 2bi - \ A boa ; inline - -: A-v.-op ( v1 v2 quot -- n ) - [ [ [ underlying1>> ] bi@ A-rep ] dip call ] - [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi - + ; inline - -: (A-v->n-op) ( v1 quot reduce-quot -- n ) - '[ [ underlying1>> ] [ underlying2>> ] bi A-rep @ A-rep ] dip call ; inline - -: A-sum-op ( v1 quot -- n ) - [ (simd-v+) ] (A-v->n-op) ; inline - -: A-vany-op ( v1 quot -- n ) - [ (simd-vbitor) ] (A-v->n-op) ; inline -: A-vall-op ( v1 quot -- n ) - [ (simd-vbitand) ] (A-v->n-op) ; inline - -: A-vmerge-head-op ( v1 v2 quot -- v ) - drop - [ underlying1>> ] bi@ - [ A-rep (simd-(vmerge-head)) ] - [ A-rep (simd-(vmerge-tail)) ] 2bi - \ A boa ; inline - -: A-vmerge-tail-op ( v1 v2 quot -- v ) - drop - [ underlying2>> ] bi@ - [ A-rep (simd-(vmerge-head)) ] - [ A-rep (simd-(vmerge-tail)) ] 2bi - \ A boa ; inline - -: A-v-conversion-op ( v1 to-type quot -- v ) - swap [ - [ [ underlying1>> A-rep ] dip call ] - [ [ underlying2>> A-rep ] dip call ] 2bi - ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline - -: A-vpack-op ( v1 v2 to-type quot -- v ) - swap [ - '[ [ underlying1>> ] [ underlying2>> ] bi A-rep @ ] bi* - ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline - -: A-vunpack-head-op ( v1 to-type quot -- v ) - '[ - underlying1>> - [ A-rep @ ] - [ A-rep (simd-(vunpack-tail)) ] bi - ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline - -: A-vunpack-tail-op ( v1 to-type quot -- v ) - '[ - underlying2>> - [ A-rep (simd-(vunpack-head)) ] - [ A-rep @ ] bi - ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline - -simd new - \ A >>class - \ A-with >>ctor - \ A-rep >>rep - { - { v. A-v.-op } - { sum A-sum-op } - { vnone? A-vany-op } - { vany? A-vany-op } - { vall? A-vall-op } - { (vmerge-head) A-vmerge-head-op } - { (vmerge-tail) A-vmerge-tail-op } - { (v>integer) A-v-conversion-op } - { (v>float) A-v-conversion-op } - { (vpack-signed) A-vpack-op } - { (vpack-unsigned) A-vpack-op } - { (vunpack-head) A-vunpack-head-op } - { (vunpack-tail) A-vunpack-tail-op } - } >>special-wrappers - { - { { +vector+ +vector+ -> +vector+ } A-vv->v-op } - { { +vector+ +scalar+ -> +vector+ } A-vn->v-op } - { { +vector+ +literal+ -> +vector+ } A-vn->v-op } - { { +vector+ -> +vector+ } A-v->v-op } - } >>schema-wrappers -(define-simd-256) - -;FUNCTOR diff --git a/basis/math/vectors/simd/intrinsics/authors.txt b/basis/math/vectors/simd/intrinsics/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/math/vectors/simd/intrinsics/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor b/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor deleted file mode 100644 index 84eee935a0..0000000000 --- a/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor +++ /dev/null @@ -1,18 +0,0 @@ -IN: math.vectors.simd.intrinsics.tests -USING: math.vectors.simd.intrinsics cpu.architecture tools.test ; - -[ 16 ] [ uchar-16-rep rep-components ] unit-test -[ 16 ] [ char-16-rep rep-components ] unit-test -[ 8 ] [ ushort-8-rep rep-components ] unit-test -[ 8 ] [ short-8-rep rep-components ] unit-test -[ 4 ] [ uint-4-rep rep-components ] unit-test -[ 4 ] [ int-4-rep rep-components ] unit-test -[ 4 ] [ float-4-rep rep-components ] unit-test -[ 2 ] [ double-2-rep rep-components ] unit-test - -{ 4 1 } [ uint-4-rep (simd-boa) ] must-infer-as -{ 4 1 } [ int-4-rep (simd-boa) ] must-infer-as -{ 4 1 } [ float-4-rep (simd-boa) ] must-infer-as -{ 2 1 } [ double-2-rep (simd-boa) ] must-infer-as - - diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor deleted file mode 100644 index 003b42fe83..0000000000 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ /dev/null @@ -1,207 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.data assocs combinators -cpu.architecture compiler.cfg.comparisons fry generalizations -kernel libc macros math -math.vectors.conversion.backend -sequences sets effects accessors namespaces -lexer parser vocabs.parser words arrays math.vectors ; -IN: math.vectors.simd.intrinsics - -ERROR: bad-simd-call word ; - -<< - -: simd-effect ( word -- effect ) - stack-effect [ in>> "rep" suffix ] [ out>> ] bi ; -: simd-conversion-effect ( word -- effect ) - stack-effect [ in>> but-last "rep" suffix ] [ out>> ] bi ; - -SYMBOL: simd-ops - -V{ } clone simd-ops set-global - -: (SIMD-OP:) ( accum quot -- accum ) - [ - scan-word dup name>> "(simd-" ")" surround create-in - [ nip dup '[ _ bad-simd-call ] define ] - ] dip - '[ _ dip set-stack-effect ] - [ 2array simd-ops get push ] - 2tri ; inline - -SYNTAX: SIMD-OP: - [ simd-effect ] (SIMD-OP:) ; - -SYNTAX: SIMD-CONVERSION-OP: - [ simd-conversion-effect ] (SIMD-OP:) ; - ->> - -SIMD-OP: v+ -SIMD-OP: v- -SIMD-OP: vneg -SIMD-OP: v+- -SIMD-OP: vs+ -SIMD-OP: vs- -SIMD-OP: vs* -SIMD-OP: v* -SIMD-OP: v/ -SIMD-OP: vmin -SIMD-OP: vmax -SIMD-OP: v. -SIMD-OP: vsqrt -SIMD-OP: sum -SIMD-OP: vabs -SIMD-OP: vbitand -SIMD-OP: vbitandn -SIMD-OP: vbitor -SIMD-OP: vbitxor -SIMD-OP: vbitnot -SIMD-OP: vand -SIMD-OP: vandn -SIMD-OP: vor -SIMD-OP: vxor -SIMD-OP: vnot -SIMD-OP: vlshift -SIMD-OP: vrshift -SIMD-OP: hlshift -SIMD-OP: hrshift -SIMD-OP: vshuffle-elements -SIMD-OP: vshuffle-bytes -SIMD-OP: (vmerge-head) -SIMD-OP: (vmerge-tail) -SIMD-OP: v<= -SIMD-OP: v< -SIMD-OP: v= -SIMD-OP: v> -SIMD-OP: v>= -SIMD-OP: vunordered? -SIMD-OP: vany? -SIMD-OP: vall? -SIMD-OP: vnone? - -SIMD-CONVERSION-OP: (v>float) -SIMD-CONVERSION-OP: (v>integer) -SIMD-CONVERSION-OP: (vpack-signed) -SIMD-CONVERSION-OP: (vpack-unsigned) -SIMD-CONVERSION-OP: (vunpack-head) -SIMD-CONVERSION-OP: (vunpack-tail) - -: (simd-with) ( x rep -- v ) bad-simd-call ; -: (simd-gather-2) ( a b rep -- v ) bad-simd-call ; -: (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ; -: (simd-select) ( v n rep -- x ) bad-simd-call ; - -: assert-positive ( x -- y ) ; - -: alien-vector ( c-ptr n rep -- value ) - ! Inefficient version for when intrinsics are missing - [ swap ] dip rep-size memory>byte-array ; - -: set-alien-vector ( value c-ptr n rep -- ) - ! Inefficient version for when intrinsics are missing - [ swap swap ] dip rep-size memcpy ; - -<< - -: rep-components ( rep -- n ) - 16 swap rep-component-type heap-size /i ; foldable - -: rep-coercer ( rep -- quot ) - { - { [ dup int-vector-rep? ] [ [ >fixnum ] ] } - { [ dup float-vector-rep? ] [ [ >float ] ] } - } cond nip ; foldable - -: rep-coerce ( value rep -- value' ) - rep-coercer call( value -- value' ) ; inline - -CONSTANT: rep-gather-words - { - { 2 (simd-gather-2) } - { 4 (simd-gather-4) } - } - -: rep-gather-word ( rep -- word ) - rep-components rep-gather-words at ; - ->> - -MACRO: (simd-boa) ( rep -- quot ) - { - [ rep-coercer ] - [ rep-components ] - [ ] - [ rep-gather-word ] - } cleave - '[ _ _ napply _ _ execute ] ; - -GENERIC# supported-simd-op? 1 ( rep intrinsic -- ? ) - -: (%unpack-reps) ( -- reps ) - %merge-vector-reps [ int-vector-rep? ] filter - %unpack-vector-head-reps union ; - -: (%abs-reps) ( -- reps ) - cc> %compare-vector-reps [ int-vector-rep? ] filter - %xor-vector-reps [ float-vector-rep? ] filter - union - [ { } ] [ { uchar-16-rep ushort-8-rep uint-4-rep ulonglong-2-rep } union ] if-empty ; - -: (%shuffle-imm-reps) ( -- reps ) - %shuffle-vector-reps %shuffle-vector-imm-reps union ; - -M: vector-rep supported-simd-op? - { - { \ (simd-v+) [ %add-vector-reps ] } - { \ (simd-vs+) [ %saturated-add-vector-reps ] } - { \ (simd-v+-) [ %add-sub-vector-reps ] } - { \ (simd-v-) [ %sub-vector-reps ] } - { \ (simd-vs-) [ %saturated-sub-vector-reps ] } - { \ (simd-vneg) [ %sub-vector-reps ] } - { \ (simd-v*) [ %mul-vector-reps ] } - { \ (simd-vs*) [ %saturated-mul-vector-reps ] } - { \ (simd-v/) [ %div-vector-reps ] } - { \ (simd-vmin) [ %min-vector-reps cc< %compare-vector-reps union ] } - { \ (simd-vmax) [ %max-vector-reps cc> %compare-vector-reps union ] } - { \ (simd-v.) [ %dot-vector-reps ] } - { \ (simd-vsqrt) [ %sqrt-vector-reps ] } - { \ (simd-sum) [ %horizontal-add-vector-reps ] } - { \ (simd-vabs) [ (%abs-reps) ] } - { \ (simd-vbitand) [ %and-vector-reps ] } - { \ (simd-vbitandn) [ %andn-vector-reps ] } - { \ (simd-vbitor) [ %or-vector-reps ] } - { \ (simd-vbitxor) [ %xor-vector-reps ] } - { \ (simd-vbitnot) [ %xor-vector-reps ] } - { \ (simd-vand) [ %and-vector-reps ] } - { \ (simd-vandn) [ %andn-vector-reps ] } - { \ (simd-vor) [ %or-vector-reps ] } - { \ (simd-vxor) [ %xor-vector-reps ] } - { \ (simd-vnot) [ %xor-vector-reps ] } - { \ (simd-vlshift) [ %shl-vector-reps ] } - { \ (simd-vrshift) [ %shr-vector-reps ] } - { \ (simd-hlshift) [ %horizontal-shl-vector-imm-reps ] } - { \ (simd-hrshift) [ %horizontal-shr-vector-imm-reps ] } - { \ (simd-vshuffle-elements) [ (%shuffle-imm-reps) ] } - { \ (simd-vshuffle-bytes) [ %shuffle-vector-reps ] } - { \ (simd-(vmerge-head)) [ %merge-vector-reps ] } - { \ (simd-(vmerge-tail)) [ %merge-vector-reps ] } - { \ (simd-(v>float)) [ %integer>float-vector-reps ] } - { \ (simd-(v>integer)) [ %float>integer-vector-reps ] } - { \ (simd-(vpack-signed)) [ %signed-pack-vector-reps ] } - { \ (simd-(vpack-unsigned)) [ %unsigned-pack-vector-reps ] } - { \ (simd-(vunpack-head)) [ (%unpack-reps) ] } - { \ (simd-(vunpack-tail)) [ (%unpack-reps) ] } - { \ (simd-v<=) [ unsign-rep cc<= %compare-vector-reps ] } - { \ (simd-v<) [ unsign-rep cc< %compare-vector-reps ] } - { \ (simd-v=) [ unsign-rep cc= %compare-vector-reps ] } - { \ (simd-v>) [ unsign-rep cc> %compare-vector-reps ] } - { \ (simd-v>=) [ unsign-rep cc>= %compare-vector-reps ] } - { \ (simd-vunordered?) [ unsign-rep cc/<>= %compare-vector-reps ] } - { \ (simd-gather-2) [ %gather-vector-2-reps ] } - { \ (simd-gather-4) [ %gather-vector-4-reps ] } - { \ (simd-vany?) [ %test-vector-reps ] } - { \ (simd-vall?) [ %test-vector-reps ] } - { \ (simd-vnone?) [ %test-vector-reps ] } - } case member? ; diff --git a/basis/math/vectors/specialization/specialization-tests.factor b/basis/math/vectors/specialization/specialization-tests.factor deleted file mode 100644 index f4d4fd93e8..0000000000 --- a/basis/math/vectors/specialization/specialization-tests.factor +++ /dev/null @@ -1,28 +0,0 @@ -IN: math.vectors.specialization.tests -USING: compiler.tree.debugger math.vectors tools.test kernel -kernel.private math specialized-arrays ; -QUALIFIED-WITH: alien.c-types c -QUALIFIED-WITH: alien.complex c -SPECIALIZED-ARRAY: c:double -SPECIALIZED-ARRAY: c:complex-float -SPECIALIZED-ARRAY: c:float - -[ V{ t } ] [ - [ { double-array double-array } declare distance 0.0 < not ] final-literals -] unit-test - -[ V{ float } ] [ - [ { float-array float } declare v*n norm ] final-classes -] unit-test - -[ V{ complex } ] [ - [ { complex-float-array complex-float-array } declare v. ] final-classes -] unit-test - -[ V{ float } ] [ - [ { float-array float } declare v*n norm ] final-classes -] unit-test - -[ V{ float } ] [ - [ { complex-float-array complex } declare v*n norm ] final-classes -] unit-test \ No newline at end of file diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor deleted file mode 100644 index 602fd9802c..0000000000 --- a/basis/math/vectors/specialization/specialization.factor +++ /dev/null @@ -1,207 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: words kernel make sequences effects sets kernel.private -accessors combinators math math.intervals math.vectors -math.vectors.conversion.backend namespaces assocs fry splitting -classes.algebra generalizations locals -compiler.tree.propagation.info ; -IN: math.vectors.specialization - -SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ; - -: parent-vector-class ( type -- type' ) - { - { [ dup simd-128 class<= ] [ drop simd-128 ] } - { [ dup simd-256 class<= ] [ drop simd-256 ] } - [ "Not a vector class" throw ] - } cond ; - -: signature-for-schema ( array-type elt-type schema -- signature ) - [ - { - { +vector+ [ drop ] } - { +any-vector+ [ drop parent-vector-class ] } - { +scalar+ [ nip ] } - { +boolean+ [ 2drop boolean ] } - { +nonnegative+ [ nip ] } - { +literal+ [ 2drop f ] } - } case - ] with with map ; - -: (specialize-vector-word) ( word array-type elt-type schema -- word' ) - signature-for-schema - [ [ name>> ] [ [ name>> ] map "," join ] bi* "=>" glue f ] - [ [ , \ declare , def>> % ] [ ] make ] - [ drop stack-effect ] - 2tri - [ define-declared ] [ 2drop ] 3bi ; - -: output-infos ( array-type elt-type schema -- value-infos ) - [ - { - { +vector+ [ drop ] } - { +any-vector+ [ drop parent-vector-class ] } - { +scalar+ [ nip ] } - { +boolean+ [ 2drop boolean ] } - { - +nonnegative+ - [ - nip - dup complex class<= [ drop float ] when - [0,inf] - ] - } - } case - ] with with map ; - -: record-output-signature ( word array-type elt-type schema -- word ) - output-infos - [ drop ] - [ drop ] - [ [ stack-effect in>> length '[ _ ndrop ] ] dip append ] 2tri - "outputs" set-word-prop ; - -CONSTANT: vector-words -H{ - { [v-] { +vector+ +vector+ -> +vector+ } } - { distance { +vector+ +vector+ -> +nonnegative+ } } - { n*v { +scalar+ +vector+ -> +vector+ } } - { n+v { +scalar+ +vector+ -> +vector+ } } - { n-v { +scalar+ +vector+ -> +vector+ } } - { n/v { +scalar+ +vector+ -> +vector+ } } - { norm { +vector+ -> +nonnegative+ } } - { norm-sq { +vector+ -> +nonnegative+ } } - { normalize { +vector+ -> +vector+ } } - { v* { +vector+ +vector+ -> +vector+ } } - { vs* { +vector+ +vector+ -> +vector+ } } - { v*n { +vector+ +scalar+ -> +vector+ } } - { v+ { +vector+ +vector+ -> +vector+ } } - { vs+ { +vector+ +vector+ -> +vector+ } } - { v+- { +vector+ +vector+ -> +vector+ } } - { v+n { +vector+ +scalar+ -> +vector+ } } - { v- { +vector+ +vector+ -> +vector+ } } - { vneg { +vector+ -> +vector+ } } - { vs- { +vector+ +vector+ -> +vector+ } } - { v-n { +vector+ +scalar+ -> +vector+ } } - { v. { +vector+ +vector+ -> +scalar+ } } - { v/ { +vector+ +vector+ -> +vector+ } } - { v/n { +vector+ +scalar+ -> +vector+ } } - { vceiling { +vector+ -> +vector+ } } - { vfloor { +vector+ -> +vector+ } } - { vmax { +vector+ +vector+ -> +vector+ } } - { vmin { +vector+ +vector+ -> +vector+ } } - { vneg { +vector+ -> +vector+ } } - { vtruncate { +vector+ -> +vector+ } } - { sum { +vector+ -> +scalar+ } } - { vabs { +vector+ -> +vector+ } } - { vsqrt { +vector+ -> +vector+ } } - { vbitand { +vector+ +vector+ -> +vector+ } } - { vbitandn { +vector+ +vector+ -> +vector+ } } - { vbitor { +vector+ +vector+ -> +vector+ } } - { vbitxor { +vector+ +vector+ -> +vector+ } } - { vbitnot { +vector+ -> +vector+ } } - { vand { +vector+ +vector+ -> +vector+ } } - { vandn { +vector+ +vector+ -> +vector+ } } - { vor { +vector+ +vector+ -> +vector+ } } - { vxor { +vector+ +vector+ -> +vector+ } } - { vnot { +vector+ -> +vector+ } } - { vlshift { +vector+ +scalar+ -> +vector+ } } - { vrshift { +vector+ +scalar+ -> +vector+ } } - { hlshift { +vector+ +literal+ -> +vector+ } } - { hrshift { +vector+ +literal+ -> +vector+ } } - { vshuffle-elements { +vector+ +literal+ -> +vector+ } } - { vshuffle-bytes { +vector+ +any-vector+ -> +vector+ } } - { vbroadcast { +vector+ +literal+ -> +vector+ } } - { (vmerge-head) { +vector+ +vector+ -> +vector+ } } - { (vmerge-tail) { +vector+ +vector+ -> +vector+ } } - { (v>float) { +vector+ +literal+ -> +vector+ } } - { (v>integer) { +vector+ +literal+ -> +vector+ } } - { (vpack-signed) { +vector+ +vector+ +literal+ -> +vector+ } } - { (vpack-unsigned) { +vector+ +vector+ +literal+ -> +vector+ } } - { (vunpack-head) { +vector+ +literal+ -> +vector+ } } - { (vunpack-tail) { +vector+ +literal+ -> +vector+ } } - { v<= { +vector+ +vector+ -> +vector+ } } - { v< { +vector+ +vector+ -> +vector+ } } - { v= { +vector+ +vector+ -> +vector+ } } - { v> { +vector+ +vector+ -> +vector+ } } - { v>= { +vector+ +vector+ -> +vector+ } } - { vunordered? { +vector+ +vector+ -> +vector+ } } - { vany? { +vector+ -> +boolean+ } } - { vall? { +vector+ -> +boolean+ } } - { vnone? { +vector+ -> +boolean+ } } -} - -PREDICATE: vector-word < word vector-words key? ; - -: specializations ( word -- assoc ) - dup "specializations" word-prop - [ ] [ V{ } clone [ "specializations" set-word-prop ] keep ] ?if ; - -M: vector-word subwords specializations values [ word? ] filter ; - -: add-specialization ( new-word signature word -- ) - specializations set-at ; - -ERROR: bad-vector-word word ; - -: word-schema ( word -- schema ) - vector-words ?at [ bad-vector-word ] unless ; - -: inputs ( schema -- seq ) { -> } split first ; - -: outputs ( schema -- seq ) { -> } split second ; - -: loop-vector-op ( word array-type elt-type -- word' ) - pick word-schema - [ inputs (specialize-vector-word) ] - [ outputs record-output-signature ] 3bi ; - -:: specialize-vector-word ( word array-type elt-type simd -- word/quot' ) - word simd key? [ word simd at ] [ word array-type elt-type loop-vector-op ] if ; - -:: input-signature ( word array-type elt-type -- signature ) - array-type elt-type word word-schema inputs signature-for-schema ; - -: vector-words-for-type ( elt-type -- words ) - { - ! Can't do shifts on floats - { [ dup float class<= ] [ vector-words keys { vlshift vrshift } diff ] } - ! Can't divide integers - { [ dup integer class<= ] [ vector-words keys { vsqrt n/v v/n v/ normalize } diff ] } - ! Can't compute square root of complex numbers (vsqrt uses fsqrt not sqrt) - { [ dup complex class<= ] [ vector-words keys { vsqrt } diff ] } - [ { } ] - } cond - ! Don't specialize horizontal shifts, shuffles, and conversions at all, they're only for SIMD - { - hlshift hrshift vshuffle-elements vshuffle-bytes vbroadcast - (v>integer) (v>float) - (vpack-signed) (vpack-unsigned) - (vunpack-head) (vunpack-tail) - } diff - nip ; - -:: specialize-vector-words ( array-type elt-type simd -- ) - elt-type vector-words-for-type simd keys union [ - [ array-type elt-type simd specialize-vector-word ] - [ array-type elt-type input-signature ] - [ ] - tri add-specialization - ] each ; - -: specialization-matches? ( value-infos signature -- ? ) - [ [ [ class>> ] dip class<= ] [ literal?>> ] if* ] 2all? ; - -: find-specialization ( classes word -- word/f ) - specializations - [ first specialization-matches? ] with find - swap [ second ] when ; - -: vector-word-custom-inlining ( #call -- word/f ) - [ in-d>> [ value-info ] map ] [ word>> ] bi - find-specialization ; - -vector-words keys [ - [ vector-word-custom-inlining ] - "custom-inlining" set-word-prop -] each From 42493b9778a19797866e32f63e48e44516cd6251 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 2 Nov 2009 15:09:16 -0600 Subject: [PATCH 012/513] update compiler.tree.propagation.simd, and don't load it till math.vectors.simd is loaded --- .../known-words/known-words.factor | 3 +-- .../tree/propagation/simd/simd.factor | 19 ++++++++++--------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 5646dca3fb..aa2bc01f9e 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -16,8 +16,7 @@ compiler.tree.propagation.slots compiler.tree.propagation.simple compiler.tree.propagation.constraints compiler.tree.propagation.call-effect -compiler.tree.propagation.transforms -compiler.tree.propagation.simd ; +compiler.tree.propagation.transforms ; FROM: alien.c-types => (signed-interval) (unsigned-interval) ; IN: compiler.tree.propagation.known-words diff --git a/basis/compiler/tree/propagation/simd/simd.factor b/basis/compiler/tree/propagation/simd/simd.factor index 1637148b88..1eac88598b 100644 --- a/basis/compiler/tree/propagation/simd/simd.factor +++ b/basis/compiler/tree/propagation/simd/simd.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-arrays combinators fry sequences compiler.tree.propagation.info cpu.architecture kernel words math -math.intervals math.vectors.simd.intrinsics ; +math.intervals math.vectors.simd ; IN: compiler.tree.propagation.simd { @@ -33,14 +33,14 @@ IN: compiler.tree.propagation.simd (simd-hrshift) (simd-vshuffle-bytes) (simd-vshuffle-elements) - (simd-(vmerge-head)) - (simd-(vmerge-tail)) - (simd-(v>float)) - (simd-(v>integer)) - (simd-(vpack-signed)) - (simd-(vpack-unsigned)) - (simd-(vunpack-head)) - (simd-(vunpack-tail)) + (simd-vmerge-head) + (simd-vmerge-tail) + (simd-v>float) + (simd-v>integer) + (simd-vpack-signed) + (simd-vpack-unsigned) + (simd-vunpack-head) + (simd-vunpack-tail) (simd-v<=) (simd-v<) (simd-v=) @@ -51,6 +51,7 @@ IN: compiler.tree.propagation.simd (simd-gather-2) (simd-gather-4) alien-vector + alien-vector-aligned } [ { byte-array } "default-output-classes" set-word-prop ] each : scalar-output-class ( rep -- class ) From e36eb438fa518997ee605eea11979d68153f4c15 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 2 Nov 2009 15:17:34 -0600 Subject: [PATCH 013/513] move all simd intrinsics to compiler.cfg.intrinsics.simd, and only load it when math.vectors.simd is loaded --- .../compiler/cfg/intrinsics/intrinsics.factor | 59 ------------------ .../compiler/cfg/intrinsics/simd/simd.factor | 62 ++++++++++++++++++- basis/cpu/x86/x86.factor | 1 - 3 files changed, 61 insertions(+), 61 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index a03f04f182..632c32b12f 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -151,64 +151,5 @@ IN: compiler.cfg.intrinsics { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] } } enable-intrinsics ; -: enable-simd ( -- ) - { - { math.vectors.simd.intrinsics:assert-positive [ drop ] } - { math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vneg) [ [ generate-neg-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vbitandn) [ [ ^^andn-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vbitnot) [ [ generate-not-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vand) [ [ ^^and-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vandn) [ [ ^^andn-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vor) [ [ ^^or-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vxor) [ [ ^^xor-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vnot) [ [ generate-not-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-v<=) [ [ cc<= generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-v<) [ [ cc< generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-v=) [ [ cc= generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-v>) [ [ cc> generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-v>=) [ [ cc>= generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vunordered?) [ [ cc/<>= generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector-imm ] [ ^^shr-vector ] emit-shift-vector-op ] } - { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] } - { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector-imm ] emit-shift-vector-imm-op ] } - { math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] } - { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] } - { math.vectors.simd.intrinsics:(simd-vshuffle-elements) [ emit-shuffle-vector ] } - { math.vectors.simd.intrinsics:(simd-vshuffle-bytes) [ emit-shuffle-vector-var ] } - { math.vectors.simd.intrinsics:(simd-(vmerge-head)) [ [ ^^merge-vector-head ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-(vmerge-tail)) [ [ ^^merge-vector-tail ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-(v>float)) [ [ ^^integer>float-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-(v>integer)) [ [ ^^float>integer-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-(vpack-signed)) [ [ ^^signed-pack-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-(vpack-unsigned)) [ [ ^^unsigned-pack-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-(vunpack-head)) [ [ generate-unpack-vector-head ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-(vunpack-tail)) [ [ generate-unpack-vector-tail ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-select) [ emit-select-vector ] } - { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] } - { math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] } - } enable-intrinsics ; - : emit-intrinsic ( node word -- ) "intrinsic" word-prop call( node -- ) ; diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index a8dfaab2dd..bac86e2457 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien byte-arrays fry classes.algebra cpu.architecture kernel math sequences math.vectors -math.vectors.simd.intrinsics macros generalizations combinators +math.vectors.simd macros generalizations combinators combinators.short-circuit arrays locals compiler.tree.propagation.info compiler.cfg.builder.blocks compiler.cfg.comparisons @@ -351,3 +351,63 @@ MACRO: if-literals-match ( quots -- ) [ generate-blend-vector ] 3bi ] if ; +: enable-simd ( -- ) + { + { math.vectors.simd:assert-positive [ drop ] } + { math.vectors.simd:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vneg) [ [ generate-neg-vector ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vbitandn) [ [ ^^andn-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vbitnot) [ [ generate-not-vector ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-vand) [ [ ^^and-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vandn) [ [ ^^andn-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vor) [ [ ^^or-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vxor) [ [ ^^xor-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vnot) [ [ generate-not-vector ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-v<=) [ [ cc<= generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-v<) [ [ cc< generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-v=) [ [ cc= generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-v>) [ [ cc> generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-v>=) [ [ cc>= generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vunordered?) [ [ cc/<>= generate-compare-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] } + { math.vectors.simd:(simd-vrshift) [ [ ^^shr-vector-imm ] [ ^^shr-vector ] emit-shift-vector-op ] } + { math.vectors.simd:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] } + { math.vectors.simd:(simd-hrshift) [ [ ^^horizontal-shr-vector-imm ] emit-shift-vector-imm-op ] } + { math.vectors.simd:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-gather-2) [ emit-gather-vector-2 ] } + { math.vectors.simd:(simd-gather-4) [ emit-gather-vector-4 ] } + { math.vectors.simd:(simd-vshuffle-elements) [ emit-shuffle-vector ] } + { math.vectors.simd:(simd-vshuffle-bytes) [ emit-shuffle-vector-var ] } + { math.vectors.simd:(simd-vmerge-head) [ [ ^^merge-vector-head ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vmerge-tail) [ [ ^^merge-vector-tail ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-v>float) [ [ ^^integer>float-vector ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-v>integer) [ [ ^^float>integer-vector ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-vpack-signed) [ [ ^^signed-pack-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vpack-unsigned) [ [ ^^unsigned-pack-vector ] emit-binary-vector-op ] } + { math.vectors.simd:(simd-vunpack-head) [ [ generate-unpack-vector-head ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-vunpack-tail) [ [ generate-unpack-vector-tail ] emit-unary-vector-op ] } + { math.vectors.simd:(simd-select) [ emit-select-vector ] } + { math.vectors.simd:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] } + { math.vectors.simd:alien-vector [ emit-alien-vector ] } + { math.vectors.simd:set-alien-vector [ emit-set-alien-vector ] } + } enable-intrinsics ; + +enable-simd diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index b4d4b43e59..53c9c98ed3 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -1370,7 +1370,6 @@ M: x86 immediate-bitwise? ( n -- ? ) #! set up by the caller. stack-frame get total-size>> + stack@ ; -enable-simd enable-min/max enable-fixnum-log2 From d655c3c9cca88d9cd952082c9ae24d7e2bfa8b38 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 3 Nov 2009 21:38:29 -0600 Subject: [PATCH 014/513] make horizontal shift available to float vectors (it'd still be faster than the software fallback despite pipeline penalty) --- basis/cpu/x86/x86.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 53c9c98ed3..b0a5dc0897 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -1166,7 +1166,7 @@ M: x86 %horizontal-shl-vector-imm ( dst src1 src2 rep -- ) M: x86 %horizontal-shl-vector-imm-reps { - { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } } } available-reps ; M: x86 %horizontal-shr-vector-imm ( dst src1 src2 rep -- ) @@ -1174,7 +1174,7 @@ M: x86 %horizontal-shr-vector-imm ( dst src1 src2 rep -- ) M: x86 %horizontal-shr-vector-imm-reps { - { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } } } available-reps ; M: x86 %abs-vector ( dst src rep -- ) From bd77633d5b3ab8ca1114af0bf2f3a5e7f3fc2f1f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 3 Nov 2009 21:38:45 -0600 Subject: [PATCH 015/513] new intrinsic generators, pt1 --- .../compiler/cfg/intrinsics/simd/simd.factor | 720 +++++++++--------- 1 file changed, 345 insertions(+), 375 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index bac86e2457..208e19ccc3 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -10,78 +10,27 @@ compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers compiler.cfg.intrinsics.alien specialized-arrays ; -FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ; -SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ; +FROM: alien.c-types => heap-size char short int longlong float double ; +SPECIALIZED-ARRAYS: char short int longlong float double ; IN: compiler.cfg.intrinsics.simd -MACRO: check-elements ( quots -- ) - [ length '[ _ firstn ] ] - [ '[ _ spread ] ] - [ length 1 - \ and [ ] like ] - tri 3append ; +! compound vector ops -MACRO: if-literals-match ( quots -- ) - [ length ] [ ] [ length ] tri - ! n quots n - '[ - ! node quot - [ - dup node-input-infos - _ tail-slice* [ literal>> ] map - dup _ check-elements - ] dip - swap [ - ! node literals quot - [ _ firstn ] dip call - drop - ] [ 2drop emit-primitive ] if - ] ; +: ^load-neg-zero-vector ( rep -- dst ) + { + { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] } + { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] } + } case ; -: emit-vector-op ( node quot: ( rep -- ) -- ) - { [ representation? ] } if-literals-match ; inline - -: [binary] ( quot -- quot' ) - '[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline - -: emit-binary-vector-op ( node quot -- ) - [binary] emit-vector-op ; inline - -: [unary] ( quot -- quot' ) - '[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline - -: emit-unary-vector-op ( node quot -- ) - [unary] emit-vector-op ; inline - -: [unary/param] ( quot -- quot' ) - '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline - -: emit-shift-vector-imm-op ( node quot -- ) - [unary/param] - { [ integer? ] [ representation? ] } if-literals-match ; inline - -:: emit-shift-vector-op ( node imm-quot var-quot -- ) - node node-input-infos 2 tail-slice* first literal>> integer? - [ node imm-quot emit-shift-vector-imm-op ] - [ node var-quot emit-binary-vector-op ] if ; inline - -: emit-gather-vector-2 ( node -- ) - [ ^^gather-vector-2 ] emit-binary-vector-op ; - -: emit-gather-vector-4 ( node -- ) - [ - ds-drop - [ - D 3 peek-loc - D 2 peek-loc - D 1 peek-loc - D 0 peek-loc - -4 inc-d - ] dip - ^^gather-vector-4 - ds-push - ] emit-vector-op ; - -: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ; +: ^load-add-sub-vector ( rep -- dst ) + unsign-rep { + { float-4-rep [ float-array{ -0.0 0.0 -0.0 0.0 } underlying>> ^^load-constant ] } + { double-2-rep [ double-array{ -0.0 0.0 } underlying>> ^^load-constant ] } + { char-16-rep [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] } + { short-8-rep [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] } + { int-4-rep [ int-array{ -1 0 -1 0 } underlying>> ^^load-constant ] } + { longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-constant ] } + } case ; : >variable-shuffle ( shuffle rep -- shuffle' ) rep-component-type heap-size @@ -89,325 +38,346 @@ MACRO: if-literals-match ( quots -- ) [ iota >byte-array ] bi '[ _ n*v _ v+ ] map concat ; -: generate-shuffle-vector-imm ( src shuffle rep -- dst ) - dup %shuffle-vector-imm-reps member? - [ ^^shuffle-vector-imm ] - [ - [ >variable-shuffle ^^load-constant ] keep - ^^shuffle-vector - ] if ; +: ^load-immediate-shuffle ( shuffle rep -- dst ) + >variable-shuffle ^^load-constant ; -: emit-shuffle-vector-imm ( node -- ) - ! Pad the permutation with zeroes if it's too short, since we - ! can't throw an error at this point. - [ [ rep-components 0 pad-tail ] keep generate-shuffle-vector-imm ] [unary/param] - { [ shuffle? ] [ representation? ] } if-literals-match ; - -: emit-shuffle-vector-var ( node -- ) - [ ^^shuffle-vector ] [binary] - { [ %shuffle-vector-reps member? ] } if-literals-match ; - -: emit-shuffle-vector ( node -- ) - dup node-input-infos { - [ length 3 = ] - [ first class>> byte-array class<= ] - [ second class>> byte-array class<= ] - [ third literal>> representation? ] - } 1&& [ emit-shuffle-vector-var ] [ emit-shuffle-vector-imm ] if ; - -: ^^broadcast-vector ( src n rep -- dst ) - [ rep-components swap ] keep - generate-shuffle-vector-imm ; - -: emit-broadcast-vector ( node -- ) - [ ^^broadcast-vector ] [unary/param] - { [ integer? ] [ representation? ] } if-literals-match ; - -: ^^with-vector ( src rep -- dst ) - [ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ; - -: ^^select-vector ( src n rep -- dst ) - [ ^^broadcast-vector ] keep ^^vector>scalar ; - -: emit-select-vector ( node -- ) - [ ^^select-vector ] [unary/param] - { [ integer? ] [ representation? ] } if-literals-match ; inline - -: emit-alien-vector-op ( node quot: ( rep -- ) -- ) - { [ %alien-vector-reps member? ] } if-literals-match ; inline - -: emit-alien-vector ( node -- ) - dup [ - '[ - ds-drop prepare-alien-getter - _ ^^alien-vector ds-push - ] - [ inline-alien-getter? ] inline-alien - ] with emit-alien-vector-op ; - -: emit-set-alien-vector ( node -- ) - dup [ - '[ - ds-drop prepare-alien-setter ds-pop - _ ##set-alien-vector - ] - [ byte-array inline-alien-setter? ] - inline-alien - ] with emit-alien-vector-op ; - -: generate-not-vector ( src rep -- dst ) - dup %not-vector-reps member? - [ ^^not-vector ] - [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ; - -:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst ) - {cc,swap} first2 :> ( cc swap? ) - swap? - [ src2 src1 rep cc ^^compare-vector ] - [ src1 src2 rep cc ^^compare-vector ] if ; - -:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst ) - rep orig-cc %compare-vector-ccs :> ( ccs not? ) - - ccs empty? - [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ] - [ - ccs unclip :> ( rest-ccs first-cc ) - src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst - - rest-ccs first-dst - [ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ] - reduce - - not? [ rep generate-not-vector ] when - ] if ; - -: sign-bit-mask ( rep -- byte-array ) - unsign-rep { - { char-16-rep [ uchar-array{ - HEX: 80 HEX: 80 HEX: 80 HEX: 80 - HEX: 80 HEX: 80 HEX: 80 HEX: 80 - HEX: 80 HEX: 80 HEX: 80 HEX: 80 - HEX: 80 HEX: 80 HEX: 80 HEX: 80 - } underlying>> ] } - { short-8-rep [ ushort-array{ - HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000 - HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000 - } underlying>> ] } - { int-4-rep [ uint-array{ - HEX: 8000,0000 HEX: 8000,0000 - HEX: 8000,0000 HEX: 8000,0000 - } underlying>> ] } - { longlong-2-rep [ ulonglong-array{ - HEX: 8000,0000,0000,0000 - HEX: 8000,0000,0000,0000 - } underlying>> ] } - } case ; - -:: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst ) - orig-cc order-cc { - { cc< [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] } - { cc<= [ src1 src2 rep ^^min-vector src1 rep cc= (generate-compare-vector) ] } - { cc> [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] } - { cc>= [ src1 src2 rep ^^max-vector src1 rep cc= (generate-compare-vector) ] } - } case ; - -:: generate-compare-vector ( src1 src2 rep orig-cc -- dst ) - { - { - [ rep orig-cc %compare-vector-reps member? ] - [ src1 src2 rep orig-cc (generate-compare-vector) ] - } - { - [ rep %min-vector-reps member? ] - [ src1 src2 rep orig-cc (generate-minmax-compare-vector) ] - } - { - [ rep unsign-rep orig-cc %compare-vector-reps member? ] - [ - rep sign-bit-mask ^^load-constant :> sign-bits - src1 sign-bits rep ^^xor-vector - src2 sign-bits rep ^^xor-vector - rep unsign-rep orig-cc (generate-compare-vector) - ] - } - } cond ; - -:: generate-unpack-vector-head ( src rep -- dst ) - { - { - [ rep %unpack-vector-head-reps member? ] - [ src rep ^^unpack-vector-head ] - } - { - [ rep unsigned-int-vector-rep? ] - [ - rep ^^zero-vector :> zero - src zero rep ^^merge-vector-head - ] - } - { - [ rep widen-vector-rep %shr-vector-imm-reps member? ] - [ - src src rep ^^merge-vector-head - rep rep-component-type - heap-size 8 * rep widen-vector-rep ^^shr-vector-imm - ] - } - [ - rep ^^zero-vector :> zero - zero src rep cc> ^^compare-vector :> sign - src sign rep ^^merge-vector-head - ] - } cond ; - -:: generate-unpack-vector-tail ( src rep -- dst ) - { - { - [ rep %unpack-vector-tail-reps member? ] - [ src rep ^^unpack-vector-tail ] - } - { - [ rep %unpack-vector-head-reps member? ] - [ - src rep ^^tail>head-vector :> tail - tail rep ^^unpack-vector-head - ] - } - { - [ rep unsigned-int-vector-rep? ] - [ - rep ^^zero-vector :> zero - src zero rep ^^merge-vector-tail - ] - } - { - [ rep widen-vector-rep %shr-vector-imm-reps member? ] - [ - src src rep ^^merge-vector-tail - rep rep-component-type - heap-size 8 * rep widen-vector-rep ^^shr-vector-imm - ] - } - [ - rep ^^zero-vector :> zero - zero src rep cc> ^^compare-vector :> sign - src sign rep ^^merge-vector-tail - ] - } cond ; - -:: generate-load-neg-zero-vector ( rep -- dst ) - rep { - { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] } - { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] } - [ drop rep ^^zero-vector ] - } case ; - -:: generate-neg-vector ( src rep -- dst ) - rep generate-load-neg-zero-vector - src rep ^^sub-vector ; - -:: generate-blend-vector ( mask true false rep -- dst ) - mask true rep ^^and-vector +:: ^blend-vector ( mask true false rep -- dst ) + true mask rep ^^and-vector mask false rep ^^andn-vector rep ^^or-vector ; -:: generate-abs-vector ( src rep -- dst ) +: ^compare-vector ( src1 src2 rep cc -- dst ) + ... ; + +: ^widened-shr-vector-imm ( src shift rep -- dst ) + widen-vector-rep ^^shr-vector-imm ; + +! intrinsic emitters + +: emit-simd-v+ ( node -- ) { - { - [ rep unsigned-int-vector-rep? ] - [ src ] - } - { - [ rep %abs-vector-reps member? ] - [ src rep ^^abs-vector ] - } - { - [ rep float-vector-rep? ] - [ - rep generate-load-neg-zero-vector - src rep ^^andn-vector - ] - } - [ + [ ^^add-vector ] + } emit-vv-vector-op ; + +: emit-simd-v- ( node -- ) + { + [ ^^sub-vector ] + } emit-vv-vector-op ; + +: emit-simd-vneg ( node -- ) + { + { float-vector-rep [ [ ^load-neg-zero-vector ] [ ^^sub-vector ] bi ] } + { int-vector-rep [ [ ^^zero-vector ] [ ^^sub-vector ] bi ] } + } emit-v-vector-op ; + +: emit-simd-v+- ( node -- ) + { + [ ^^add-sub-vector ] + { float-vector-rep [| src1 src2 rep | + rep ^load-add-sub-vector :> signs + src2 signs rep ^^xor-vector :> src2' + src1 src2' rep ^^add-vector + ] } + { int-vector-rep [| src1 src2 rep | + rep ^load-add-sub-vector :> signs + src2 signs rep ^^xor-vector :> src2' + src2' signs rep ^^sub-vector :> src2'' + src1 src2'' rep ^^add-vector + ] } + } emit-vv-vector-op ; + +: emit-simd-vs+ ( node -- ) + { + { float-vector-rep [ ^^add-vector ] } + { int-vector-rep [ ^^saturated-add-vector ] } + } emit-vv-vector-op ; + +: emit-simd-vs- ( node -- ) + { + { float-vector-rep [ ^^sub-vector ] } + { int-vector-rep [ ^^saturated-sub-vector ] } + } emit-vv-vector-op ; + +: emit-simd-vs* ( node -- ) + { + { float-vector-rep [ ^^mul-vector ] } + { int-vector-rep [ ^^saturated-mul-vector ] } + } emit-vv-vector-op ; + +: emit-simd-v* ( node -- ) + { + [ ^^mul-vector ] + } emit-vv-vector-op ; + +: emit-simd-v/ ( node -- ) + { + [ ^^div-vector ] + } emit-vv-vector-op ; + +: emit-simd-vmin ( node -- ) + { + [ ^^min-vector ] + [ + [ cc< ^compare-vector ] + [ ^blend-vector ] 3bi + ] + } emit-vv-vector-op ; + +: emit-simd-vmax ( node -- ) + { + [ ^^max-vector ] + [ + [ cc> ^compare-vector ] + [ ^blend-vector ] 3bi + ] + } emit-vv-vector-op ; + +: emit-simd-v. ( node -- ) + { + [ ^^dot-vector ] + { float-vector-rep [| src1 src2 rep | + + ] } + { int-vector-rep [| src1 src2 rep | + ... + ] } + } emit-vv-vector-op ; + +: emit-simd-vsqrt ( node -- ) + { + [ ^^sqrt-vector ] + } emit-v-vector-op ; + +: emit-simd-sum ( node -- ) + ... ; + +: emit-simd-vabs ( node -- ) + { + { unsigned-int-vector-rep [ drop ] } + [ ^^abs-vector ] + { float-vector-rep [ [ ^load-neg-zero-vector ] [ swapd ^^andn-vector ] bi ] } + { int-vector-rep [| src rep | rep ^^zero-vector :> zero zero src rep ^^sub-vector :> -src - zero src rep cc> ^^compare-vector :> sign - sign -src src rep generate-blend-vector - ] - } cond ; + zero src rep cc> ^compare-vector :> sign + sign -src src rep ^blend-vector + ] } + } emit-v-vector-op ; -: generate-min-vector ( src1 src2 rep -- dst ) - dup %min-vector-reps member? - [ ^^min-vector ] [ - [ cc< generate-compare-vector ] - [ generate-blend-vector ] 3bi - ] if ; +: emit-simd-vand ( node -- ) + { + [ ^^and-vector ] + } emit-vv-vector-op ; -: generate-max-vector ( src1 src2 rep -- dst ) - dup %max-vector-reps member? - [ ^^max-vector ] [ - [ cc> generate-compare-vector ] - [ generate-blend-vector ] 3bi - ] if ; +: emit-simd-vandn ( node -- ) + { + [ ^^andn-vector ] + } emit-vv-vector-op ; + +: emit-simd-vor ( node -- ) + { + [ ^^or-vector ] + } emit-vv-vector-op ; + +: emit-simd-vxor ( node -- ) + { + [ ^^xor-vector ] + } emit-vv-vector-op ; + +: emit-simd-vnot ( node -- ) + { + [ ^^not-vector ] + [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] + } emit-v-vector-op ; + +: emit-simd-vlshift ( node -- ) + { + [ ^^shl-vector ] + } { + [ ^^shl-vector-imm ] + } emit-vn-or-vl-vector-op ; + +: emit-simd-vrshift ( node -- ) + { + [ ^^shr-vector ] + } { + [ ^^shr-vector-imm ] + } emit-vn-or-vl-vector-op ; + +: emit-simd-hlshift ( node -- ) + { + [ ^^horizontal-shl-vector-imm ] + } emit-vl-vector-op ; + +: emit-simd-hrshift ( node -- ) + { + [ ^^horizontal-shr-vector-imm ] + } emit-vl-vector-op ; + +: emit-simd-vshuffle-elements ( node -- ) + { + [ ^^shuffle-vector-imm ] + [ [ ^load-immediate-shuffle ] [ ^^shuffle-vector ] ] + } emit-vl-vector-op ; + +: emit-simd-vshuffle-bytes ( node -- ) + { + [ ^^shuffle-vector ] + } emit-vv-vector-op ; + +: emit-simd-vmerge-head ( node -- ) + { + [ ^^merge-vector-head ] + } emit-vv-vector-op ; + +: emit-simd-vmerge-tail ( node -- ) + { + [ ^^merge-vector-tail ] + } emit-vv-vector-op ; + +: emit-simd-v<= ( node -- ) + [ cc<= ^compare-vector ] (emit-vv-vector-op) ; +: emit-simd-v< ( node -- ) + [ cc< ^compare-vector ] (emit-vv-vector-op) ; +: emit-simd-v= ( node -- ) + [ cc= ^compare-vector ] (emit-vv-vector-op) ; +: emit-simd-v> ( node -- ) + [ cc> ^compare-vector ] (emit-vv-vector-op) ; +: emit-simd-v>= ( node -- ) + [ cc>= ^compare-vector ] (emit-vv-vector-op) ; +: emit-simd-vunordered? ( node -- ) + [ cc/<>= ^compare-vector ] (emit-vv-vector-op) ; + +: emit-simd-vany? ( node -- ) + [ vcc-any ^test-vector ] (emit-vv-vector-op) ; +: emit-simd-vall? ( node -- ) + [ vcc-all ^test-vector ] (emit-vv-vector-op) ; +: emit-simd-vnone? ( node -- ) + [ vcc-none ^test-vector ] (emit-vv-vector-op) ; + +: emit-simd-v>float ( node -- ) + { + { float-vector-rep [ drop ] } + { int-vector-rep [ ^^integer>float-vector ] } + } emit-vv-vector-op ; + +: emit-simd-v>integer ( node -- ) + { + { float-vector-rep [ ^^float>integer-vector ] } + { int-vector-rep [ dup ] } + } emit-vv-vector-op ; + +: emit-simd-vpack-signed ( node -- ) + { + [ ^^signed-pack-vector ] + } emit-vv-vector-op ; + +: emit-simd-vpack-unsigned ( node -- ) + { + [ ^^unsigned-pack-vector ] + } emit-vv-vector-op ; + +! XXX shr vector rep is widened! +: emit-simd-vunpack-head ( node -- ) + { + [ ^^unpack-vector-head ] + { unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-head ] bi ] } + { signed-int-vector-rep [| src rep | + src src rep ^^merge-vector-head :> merged + rep rep-component-type heap-size 8 * :> bits + merged bits rep ^widened-shr-vector-imm + ] } + { signed-int-vector-rep [| src rep | + rep ^^zero-vector :> zero + zero src rep cc> ^compare-vector :> sign + src sign rep ^^merge-vector-head + ] } + } emit-v-vector-op ; + +: emit-simd-vunpack-tail ( node -- ) + { + [ ^^unpack-vector-tail ] + [ [ ^^tail>head-vector ] [ ^^unpack-vector-head ] bi ] + { unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-tail ] bi ] } + { signed-int-vector-rep [| src rep | + src src rep ^^merge-vector-tail :> merged + rep rep-component-type heap-size 8 * :> bits + merged bits rep widen-vector-rep ^widened-shr-vector-imm + ] } + { signed-int-vector-rep [| src rep | + rep ^^zero-vector :> zero + zero src rep cc> ^compare-vector :> sign + src sign rep ^^merge-vector-tail + ] } + } emit-v-vector-op ; + +: emit-simd-with ( node -- ) +: emit-simd-gather-2 ( node -- ) +: emit-simd-gather-4 ( node -- ) +: emit-simd-select ( node -- ) +: emit-alien-vector ( node -- ) +: emit-set-alien-vector ( node -- ) +: emit-alien-vector-aligned ( node -- ) +: emit-set-alien-vector-aligned ( node -- ) : enable-simd ( -- ) { - { math.vectors.simd:assert-positive [ drop ] } - { math.vectors.simd:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vneg) [ [ generate-neg-vector ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vbitandn) [ [ ^^andn-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vbitnot) [ [ generate-not-vector ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-vand) [ [ ^^and-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vandn) [ [ ^^andn-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vor) [ [ ^^or-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vxor) [ [ ^^xor-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vnot) [ [ generate-not-vector ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-v<=) [ [ cc<= generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-v<) [ [ cc< generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-v=) [ [ cc= generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-v>) [ [ cc> generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-v>=) [ [ cc>= generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vunordered?) [ [ cc/<>= generate-compare-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] } - { math.vectors.simd:(simd-vrshift) [ [ ^^shr-vector-imm ] [ ^^shr-vector ] emit-shift-vector-op ] } - { math.vectors.simd:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] } - { math.vectors.simd:(simd-hrshift) [ [ ^^horizontal-shr-vector-imm ] emit-shift-vector-imm-op ] } - { math.vectors.simd:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-gather-2) [ emit-gather-vector-2 ] } - { math.vectors.simd:(simd-gather-4) [ emit-gather-vector-4 ] } - { math.vectors.simd:(simd-vshuffle-elements) [ emit-shuffle-vector ] } - { math.vectors.simd:(simd-vshuffle-bytes) [ emit-shuffle-vector-var ] } - { math.vectors.simd:(simd-vmerge-head) [ [ ^^merge-vector-head ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vmerge-tail) [ [ ^^merge-vector-tail ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-v>float) [ [ ^^integer>float-vector ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-v>integer) [ [ ^^float>integer-vector ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-vpack-signed) [ [ ^^signed-pack-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vpack-unsigned) [ [ ^^unsigned-pack-vector ] emit-binary-vector-op ] } - { math.vectors.simd:(simd-vunpack-head) [ [ generate-unpack-vector-head ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-vunpack-tail) [ [ generate-unpack-vector-tail ] emit-unary-vector-op ] } - { math.vectors.simd:(simd-select) [ emit-select-vector ] } - { math.vectors.simd:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] } - { math.vectors.simd:alien-vector [ emit-alien-vector ] } - { math.vectors.simd:set-alien-vector [ emit-set-alien-vector ] } + { (simd-v+) [ emit-simd-v+ ] } + { (simd-v-) [ emit-simd-v- ] } + { (simd-vneg) [ emit-simd-vneg ] } + { (simd-v+-) [ emit-simd-v+- ] } + { (simd-vs+) [ emit-simd-vs+ ] } + { (simd-vs-) [ emit-simd-vs- ] } + { (simd-vs*) [ emit-simd-vs* ] } + { (simd-v*) [ emit-simd-v* ] } + { (simd-v/) [ emit-simd-v/ ] } + { (simd-vmin) [ emit-simd-vmin ] } + { (simd-vmax) [ emit-simd-vmax ] } + { (simd-v.) [ emit-simd-v. ] } + { (simd-vsqrt) [ emit-simd-vsqrt ] } + { (simd-sum) [ emit-simd-sum ] } + { (simd-vabs) [ emit-simd-vabs ] } + { (simd-vbitand) [ emit-simd-vand ] } + { (simd-vbitandn) [ emit-simd-vandn ] } + { (simd-vbitor) [ emit-simd-vor ] } + { (simd-vbitxor) [ emit-simd-vxor ] } + { (simd-vbitnot) [ emit-simd-vnot ] } + { (simd-vand) [ emit-simd-vand ] } + { (simd-vandn) [ emit-simd-vandn ] } + { (simd-vor) [ emit-simd-vor ] } + { (simd-vxor) [ emit-simd-vxor ] } + { (simd-vnot) [ emit-simd-vnot ] } + { (simd-vlshift) [ emit-simd-vlshift ] } + { (simd-vrshift) [ emit-simd-vrshift ] } + { (simd-hlshift) [ emit-simd-hlshift ] } + { (simd-hrshift) [ emit-simd-hrshift ] } + { (simd-vshuffle-elements) [ emit-simd-vshuffle-elements ] } + { (simd-vshuffle-bytes) [ emit-simd-vshuffle-bytes ] } + { (simd-vmerge-head) [ emit-simd-vmerge-head ] } + { (simd-vmerge-tail) [ emit-simd-vmerge-tail ] } + { (simd-v<=) [ emit-simd-v<= ] } + { (simd-v<) [ emit-simd-v< ] } + { (simd-v=) [ emit-simd-v= ] } + { (simd-v>) [ emit-simd-v> ] } + { (simd-v>=) [ emit-simd-v>= ] } + { (simd-vunordered?) [ emit-simd-vunordered? ] } + { (simd-vany?) [ emit-simd-vany? ] } + { (simd-vall?) [ emit-simd-vall? ] } + { (simd-vnone?) [ emit-simd-vnone? ] } + { (simd-v>float) [ emit-simd-v>float ] } + { (simd-v>integer) [ emit-simd-v>integer ] } + { (simd-vpack-signed) [ emit-simd-vpack-signed ] } + { (simd-vpack-unsigned) [ emit-simd-vpack-unsigned ] } + { (simd-vunpack-head) [ emit-simd-vunpack-head ] } + { (simd-vunpack-tail) [ emit-simd-vunpack-tail ] } + { (simd-with) [ emit-simd-with ] } + { (simd-gather-2) [ emit-simd-gather-2 ] } + { (simd-gather-4) [ emit-simd-gather-4 ] } + { (simd-select) [ emit-simd-select ] } + { alien-vector [ emit-alien-vector ] } + { set-alien-vector [ emit-set-alien-vector ] } + { alien-vector-aligned [ emit-alien-vector ] } + { set-alien-vector-aligned [ emit-set-alien-vector ] } } enable-intrinsics ; enable-simd From b98742be3095ba51cc21ca5f769d01dc26ad15db Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 3 Nov 2009 21:38:55 -0600 Subject: [PATCH 016/513] typos --- basis/math/vectors/simd/simd.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index 139060333c..1aff80a0a9 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -65,8 +65,8 @@ GENERIC: new-underlying ( underlying seq -- seq' ) : (simd-vnone?) ( a rep -- ? ) \ vnone? bad-simd-call ; : (simd-v>float) ( a rep -- c ) \ vconvert bad-simd-call ; : (simd-v>integer) ( a rep -- c ) \ vconvert bad-simd-call ; -: (simd-vpack-signed) ( a rep -- c ) \ vconvert bad-simd-call ; -: (simd-vpack-unsigned) ( a rep -- c ) \ vconvert bad-simd-call ; +: (simd-vpack-signed) ( a b rep -- c ) \ vconvert bad-simd-call ; +: (simd-vpack-unsigned) ( a b rep -- c ) \ vconvert bad-simd-call ; : (simd-vunpack-head) ( a rep -- c ) \ vconvert bad-simd-call ; : (simd-vunpack-tail) ( a rep -- c ) \ vconvert bad-simd-call ; : (simd-with) ( n rep -- v ) \ simd-with bad-simd-call ; @@ -337,3 +337,5 @@ M: simd-128 distance v- norm ; inline M: simd-128 vshuffle ( u perm -- v ) vshuffle-bytes ; inline +"compiler.tree.propagation.simd" require +"compiler.cfg.intrinsics.simd" require From f6643a1c72a905a543fa40b403fb5cd3dce1f45a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 4 Nov 2009 12:18:01 -0600 Subject: [PATCH 017/513] change ##horizontal-add-vector insn to better match what the HADD SSE instructions do (add adjacent pairs, pack results) --- .../cfg/instructions/instructions.factor | 8 ++--- basis/cpu/architecture/architecture.factor | 4 +-- basis/cpu/x86/x86.factor | 31 ++++++++++++++----- 3 files changed, 29 insertions(+), 14 deletions(-) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index d4d84a088a..30fe8b590e 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -408,13 +408,13 @@ use: src1 src2 literal: rep ; PURE-INSN: ##horizontal-add-vector -def: dst/scalar-rep -use: src +def: dst +use: src1 src2 literal: rep ; PURE-INSN: ##horizontal-sub-vector -def: dst/scalar-rep -use: src +def: dst +use: src1 src2 literal: rep ; PURE-INSN: ##horizontal-shl-vector-imm diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 75fbb85542..81aea67eb5 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -277,8 +277,8 @@ HOOK: %min-vector cpu ( dst src1 src2 rep -- ) HOOK: %max-vector cpu ( dst src1 src2 rep -- ) HOOK: %dot-vector cpu ( dst src1 src2 rep -- ) HOOK: %sqrt-vector cpu ( dst src rep -- ) -HOOK: %horizontal-add-vector cpu ( dst src rep -- ) -HOOK: %horizontal-sub-vector cpu ( dst src rep -- ) +HOOK: %horizontal-add-vector cpu ( dst src1 src2 rep -- ) +HOOK: %horizontal-sub-vector cpu ( dst src1 src2 rep -- ) HOOK: %abs-vector cpu ( dst src rep -- ) HOOK: %and-vector cpu ( dst src1 src2 rep -- ) HOOK: %andn-vector cpu ( dst src1 src2 rep -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index b0a5dc0897..68c2fb0438 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -1134,14 +1134,25 @@ M: x86 %dot-vector { float-4-rep [ sse4.1? [ HEX: ff DPPS ] - [ [ MULPS ] [ drop dup float-4-rep %horizontal-add-vector ] 2bi ] - if + [ + [ MULPS ] [ + drop 2dup float-4-rep + [ %horizontal-add-vector ] + [ %horizontal-add-vector ] + [ nip %vector>scalar ] 3tri + ] 2bi + ] if ] } { double-2-rep [ sse4.1? [ HEX: ff DPPD ] - [ [ MULPD ] [ drop dup double-2-rep %horizontal-add-vector ] 2bi ] - if + [ + [ MULPD ] [ + drop 2dup double-2-rep + [ %horizontal-add-vector ] + [ nip %vector>scalar ] 3bi + ] 2bi + ] if ] } } case ; @@ -1150,15 +1161,19 @@ M: x86 %dot-vector-reps { sse3? { float-4-rep double-2-rep } } } available-reps ; -M: x86 %horizontal-add-vector ( dst src rep -- ) - { - { float-4-rep [ [ float-4-rep %copy ] [ HADDPS ] [ HADDPS ] 2tri ] } - { double-2-rep [ [ double-2-rep %copy ] [ HADDPD ] 2bi ] } +M: x86 %horizontal-add-vector ( dst src1 src2 rep -- ) + [ two-operand ] keep + unsign-rep { + { float-4-rep [ HADDPS ] } + { double-2-rep [ HADDPD ] } + { int-4-rep [ PHADDD ] } + { short-8-rep [ PHADDW ] } } case ; M: x86 %horizontal-add-vector-reps { { sse3? { float-4-rep double-2-rep } } + { ssse3? { int-4-rep uint-4-rep short-8-rep ushort-8-rep } } } available-reps ; M: x86 %horizontal-shl-vector-imm ( dst src1 src2 rep -- ) From 4d54f27cd1add5af1b55a742f161a565a0ff9c17 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 09:52:57 -0600 Subject: [PATCH 018/513] more intrinsic madness --- .../compiler/cfg/intrinsics/simd/simd.factor | 298 ++++++++++++++---- basis/cpu/x86/x86.factor | 27 +- basis/math/vectors/simd/simd.factor | 3 - 3 files changed, 245 insertions(+), 83 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index 208e19ccc3..c4fcdca23e 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien byte-arrays fry classes.algebra cpu.architecture kernel math sequences math.vectors @@ -16,6 +16,28 @@ IN: compiler.cfg.intrinsics.simd ! compound vector ops +: sign-bit-mask ( rep -- byte-array ) + unsign-rep { + { char-16-rep [ uchar-array{ + HEX: 80 HEX: 80 HEX: 80 HEX: 80 + HEX: 80 HEX: 80 HEX: 80 HEX: 80 + HEX: 80 HEX: 80 HEX: 80 HEX: 80 + HEX: 80 HEX: 80 HEX: 80 HEX: 80 + } underlying>> ] } + { short-8-rep [ ushort-array{ + HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000 + HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000 + } underlying>> ] } + { int-4-rep [ uint-array{ + HEX: 8000,0000 HEX: 8000,0000 + HEX: 8000,0000 HEX: 8000,0000 + } underlying>> ] } + { longlong-2-rep [ ulonglong-array{ + HEX: 8000,0000,0000,0000 + HEX: 8000,0000,0000,0000 + } underlying>> ] } + } case ; + : ^load-neg-zero-vector ( rep -- dst ) { { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] } @@ -46,11 +68,163 @@ IN: compiler.cfg.intrinsics.simd mask false rep ^^andn-vector rep ^^or-vector ; -: ^compare-vector ( src1 src2 rep cc -- dst ) - ... ; +: ^minmax-compare-vector ( src1 src2 rep cc -- dst ) + order-cc { + { cc< [ src1 src2 rep ^^max-vector src1 rep cc/= ^^compare-vector ] } + { cc<= [ src1 src2 rep ^^min-vector src1 rep cc= ^^compare-vector ] } + { cc> [ src1 src2 rep ^^min-vector src1 rep cc/= ^^compare-vector ] } + { cc>= [ src1 src2 rep ^^max-vector src1 rep cc= ^^compare-vector ] } + } case ; -: ^widened-shr-vector-imm ( src shift rep -- dst ) - widen-vector-rep ^^shr-vector-imm ; +: ^compare-vector ( src1 src2 rep cc -- dst ) + { + [ ^^compare-vector ] + [ ^minmax-compare-vector ] + { unsigned-int-vector-rep [| src1 src2 rep cc | + rep sign-bit-mask ^^load-constant :> sign-bits + src1 sign-bits rep ^^xor-vector + src2 sign-bits rep ^^xor-vector + rep unsign-rep cc ^^compare-vector + ] } + } vv-cc-vector-op ; + +: ^unpack-vector-head ( src rep -- dst ) + { + [ ^^unpack-vector-head ] + { unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-head ] bi ] } + { signed-int-vector-rep [| src rep | + src src rep ^^merge-vector-head :> merged + rep rep-component-type heap-size 8 * :> bits + merged bits rep ^widened-shr-vector-imm + ] } + { signed-int-vector-rep [| src rep | + rep ^^zero-vector :> zero + zero src rep cc> ^compare-vector :> sign + src sign rep ^^merge-vector-head + ] } + } v-vector-op ; + +: ^unpack-vector-tail ( src rep -- dst ) + { + [ ^^unpack-vector-tail ] + [ [ ^^tail>head-vector ] [ ^^unpack-vector-head ] bi ] + { unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-tail ] bi ] } + { signed-int-vector-rep [| src rep | + src src rep ^^merge-vector-tail :> merged + rep rep-component-type heap-size 8 * :> bits + merged bits rep ^widened-shr-vector-imm + ] } + { signed-int-vector-rep [| src rep | + rep ^^zero-vector :> zero + zero src rep cc> ^compare-vector :> sign + src sign rep ^^merge-vector-tail + ] } + } v-vector-op ; + +: ^(sum-2) ( src rep -- dst ) + { + [ dupd ^^horizontal-add-vector ] + [| src rep | + src src rep ^^merge-vector-head :> head + src src rep ^^merge-vector-tail :> tail + head tail rep ^^add-vector + ] + } v-vector-op ; + +: ^(sum-4) ( src rep -- dst ) + { + [ + [ dupd ^^horizontal-add-vector ] + [ dupd ^^horizontal-add-vector ] bi + ] + [| src rep | + src src rep ^^merge-vector-head :> head + src src rep ^^merge-vector-tail :> tail + head tail rep ^^add-vector :> src' + + rep widen-rep :> rep' + src' src' rep' ^^merge-vector-head :> head' + src' src' rep' ^^merge-vector-tail :> tail' + head' tail' rep ^^add-vector + ] + } v-vector-op ; + +: ^(sum-8) ( src rep -- dst ) + { + [ + [ dupd ^^horizontal-add-vector ] + [ dupd ^^horizontal-add-vector ] + [ dupd ^^horizontal-add-vector ] tri + ] + [| src rep | + src src rep ^^merge-vector-head :> head + src src rep ^^merge-vector-tail :> tail + head tail rep ^^add-vector :> src' + + rep widen-rep :> rep' + src' src' rep' ^^merge-vector-head :> head' + src' src' rep' ^^merge-vector-tail :> tail' + head' tail' rep ^^add-vector :> src'' + + rep' widen-rep :> rep'' + src'' src'' rep'' ^^merge-vector-head :> head'' + src'' src'' rep'' ^^merge-vector-tail :> tail'' + head'' tail'' rep ^^add-vector + ] + } v-vector-op ; + +: ^(sum-16) ( src rep -- dst ) + { + [ + { + [ dupd ^^horizontal-add-vector ] + [ dupd ^^horizontal-add-vector ] + [ dupd ^^horizontal-add-vector ] + [ dupd ^^horizontal-add-vector ] + } cleave + ] + [| src rep | + src src rep ^^merge-vector-head :> head + src src rep ^^merge-vector-tail :> tail + head tail rep ^^add-vector :> src' + + rep widen-rep :> rep' + src' src' rep' ^^merge-vector-head :> head' + src' src' rep' ^^merge-vector-tail :> tail' + head' tail' rep ^^add-vector :> src'' + + rep' widen-rep :> rep'' + src'' src'' rep'' ^^merge-vector-head :> head'' + src'' src'' rep'' ^^merge-vector-tail :> tail'' + head'' tail'' rep ^^add-vector :> src''' + + rep'' widen-rep :> rep''' + src''' src''' rep''' ^^merge-vector-head :> head''' + src''' src''' rep''' ^^merge-vector-tail :> tail''' + head''' tail''' rep ^^add-vector + ] + } v-vector-op ; + +: ^(sum-vector) ( src rep -- dst ) + [ + rep-length { + { 2 [ ^(sum-2) ] } + { 4 [ ^(sum-4) ] } + { 8 [ ^(sum-8) ] } + { 16 [ ^(sum-16) ] } + } case + ] [ ^^vector>scalar ] bi ; + +: ^sum-vector ( src rep -- dst ) + unsign-rep { + { float-vector-rep [ ^(sum-vector) ] } + { int-vector-rep [| src rep | + src rep ^unpack-vector-head :> head + src rep ^unpack-vector-tail :> tail + rep widen-rep :> wide-rep + head tail wide-rep ^^add-vector wide-rep ^(sum-vector) + ] } + } v-vector-op ; ! intrinsic emitters @@ -135,12 +309,7 @@ IN: compiler.cfg.intrinsics.simd : emit-simd-v. ( node -- ) { [ ^^dot-vector ] - { float-vector-rep [| src1 src2 rep | - - ] } - { int-vector-rep [| src1 src2 rep | - ... - ] } + [ [ ^^mul-vector ] [ ^sum-vector ] bi ] } emit-vv-vector-op ; : emit-simd-vsqrt ( node -- ) @@ -149,7 +318,9 @@ IN: compiler.cfg.intrinsics.simd } emit-v-vector-op ; : emit-simd-sum ( node -- ) - ... ; + { + [ ^sum-vector ] + } emit-v-vector-op ; : emit-simd-vabs ( node -- ) { @@ -195,30 +366,32 @@ IN: compiler.cfg.intrinsics.simd [ ^^shl-vector ] } { [ ^^shl-vector-imm ] - } emit-vn-or-vl-vector-op ; + } [ integer? ] emit-vv-or-vl-vector-op ; : emit-simd-vrshift ( node -- ) { [ ^^shr-vector ] } { [ ^^shr-vector-imm ] - } emit-vn-or-vl-vector-op ; + } [ integer? ] emit-vv-or-vl-vector-op ; : emit-simd-hlshift ( node -- ) { [ ^^horizontal-shl-vector-imm ] - } emit-vl-vector-op ; + } [ integer? ] emit-vl-vector-op ; : emit-simd-hrshift ( node -- ) { [ ^^horizontal-shr-vector-imm ] - } emit-vl-vector-op ; + } [ integer? ] emit-vl-vector-op ; + +: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ; : emit-simd-vshuffle-elements ( node -- ) { [ ^^shuffle-vector-imm ] [ [ ^load-immediate-shuffle ] [ ^^shuffle-vector ] ] - } emit-vl-vector-op ; + } [ shuffle? ] emit-vl-vector-op ; : emit-simd-vshuffle-bytes ( node -- ) { @@ -236,24 +409,42 @@ IN: compiler.cfg.intrinsics.simd } emit-vv-vector-op ; : emit-simd-v<= ( node -- ) - [ cc<= ^compare-vector ] (emit-vv-vector-op) ; + { + [ cc<= ^compare-vector ] + } emit-vv-vector-op ; : emit-simd-v< ( node -- ) - [ cc< ^compare-vector ] (emit-vv-vector-op) ; + { + [ cc< ^compare-vector ] + } emit-vv-vector-op ; : emit-simd-v= ( node -- ) - [ cc= ^compare-vector ] (emit-vv-vector-op) ; + { + [ cc= ^compare-vector ] + } emit-vv-vector-op ; : emit-simd-v> ( node -- ) - [ cc> ^compare-vector ] (emit-vv-vector-op) ; + { + [ cc> ^compare-vector ] + } emit-vv-vector-op ; : emit-simd-v>= ( node -- ) - [ cc>= ^compare-vector ] (emit-vv-vector-op) ; + { + [ cc>= ^compare-vector ] + } emit-vv-vector-op ; : emit-simd-vunordered? ( node -- ) - [ cc/<>= ^compare-vector ] (emit-vv-vector-op) ; + { + [ cc/<>= ^compare-vector ] + } emit-vv-vector-op ; : emit-simd-vany? ( node -- ) - [ vcc-any ^test-vector ] (emit-vv-vector-op) ; + { + [ vcc-any ^test-vector ] + } emit-vv-vector-op ; : emit-simd-vall? ( node -- ) - [ vcc-all ^test-vector ] (emit-vv-vector-op) ; + { + [ vcc-all ^test-vector ] + } emit-vv-vector-op ; : emit-simd-vnone? ( node -- ) - [ vcc-none ^test-vector ] (emit-vv-vector-op) ; + { + [ vcc-none ^test-vector ] + } emit-vv-vector-op ; : emit-simd-v>float ( node -- ) { @@ -277,48 +468,45 @@ IN: compiler.cfg.intrinsics.simd [ ^^unsigned-pack-vector ] } emit-vv-vector-op ; -! XXX shr vector rep is widened! : emit-simd-vunpack-head ( node -- ) { - [ ^^unpack-vector-head ] - { unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-head ] bi ] } - { signed-int-vector-rep [| src rep | - src src rep ^^merge-vector-head :> merged - rep rep-component-type heap-size 8 * :> bits - merged bits rep ^widened-shr-vector-imm - ] } - { signed-int-vector-rep [| src rep | - rep ^^zero-vector :> zero - zero src rep cc> ^compare-vector :> sign - src sign rep ^^merge-vector-head - ] } + [ ^unpack-vector-head ] } emit-v-vector-op ; : emit-simd-vunpack-tail ( node -- ) { - [ ^^unpack-vector-tail ] - [ [ ^^tail>head-vector ] [ ^^unpack-vector-head ] bi ] - { unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-tail ] bi ] } - { signed-int-vector-rep [| src rep | - src src rep ^^merge-vector-tail :> merged - rep rep-component-type heap-size 8 * :> bits - merged bits rep widen-vector-rep ^widened-shr-vector-imm - ] } - { signed-int-vector-rep [| src rep | - rep ^^zero-vector :> zero - zero src rep cc> ^compare-vector :> sign - src sign rep ^^merge-vector-tail - ] } + [ ^unpack-vector-tail ] } emit-v-vector-op ; : emit-simd-with ( node -- ) + { + [ ^^with-vector ] + } emit-v-vector-op ; + : emit-simd-gather-2 ( node -- ) + { + [ ^^gather-vector-2 ] + } emit-vv-vector-op ; + : emit-simd-gather-4 ( node -- ) + { + [ ^^gather-vector-4 ] + } emit-vvvv-vector-op ; + : emit-simd-select ( node -- ) + { + [ ^^select-vector ] + } [ integer? ] emit-vl-vector-op ; + : emit-alien-vector ( node -- ) + { + [ ^^alien-vector ] + } emit-alien-vector-op ; + : emit-set-alien-vector ( node -- ) -: emit-alien-vector-aligned ( node -- ) -: emit-set-alien-vector-aligned ( node -- ) + { + [ ^^set-alien-vector ] + } emit-set-alien-vector-op ; : enable-simd ( -- ) { @@ -376,8 +564,6 @@ IN: compiler.cfg.intrinsics.simd { (simd-select) [ emit-simd-select ] } { alien-vector [ emit-alien-vector ] } { set-alien-vector [ emit-set-alien-vector ] } - { alien-vector-aligned [ emit-alien-vector ] } - { set-alien-vector-aligned [ emit-set-alien-vector ] } } enable-intrinsics ; enable-simd diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 68c2fb0438..d78d8c852e 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -1131,34 +1131,13 @@ M: x86 %max-vector-reps M: x86 %dot-vector [ two-operand ] keep { - { float-4-rep [ - sse4.1? - [ HEX: ff DPPS ] - [ - [ MULPS ] [ - drop 2dup float-4-rep - [ %horizontal-add-vector ] - [ %horizontal-add-vector ] - [ nip %vector>scalar ] 3tri - ] 2bi - ] if - ] } - { double-2-rep [ - sse4.1? - [ HEX: ff DPPD ] - [ - [ MULPD ] [ - drop 2dup double-2-rep - [ %horizontal-add-vector ] - [ nip %vector>scalar ] 3bi - ] 2bi - ] if - ] } + { float-4-rep [ HEX: ff DPPS ] } + { double-2-rep [ HEX: ff DPPD ] } } case ; M: x86 %dot-vector-reps { - { sse3? { float-4-rep double-2-rep } } + { sse4.1? { float-4-rep double-2-rep } } } available-reps ; M: x86 %horizontal-add-vector ( dst src1 src2 rep -- ) diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index 1aff80a0a9..c155c797ff 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -77,9 +77,6 @@ GENERIC: new-underlying ( underlying seq -- seq' ) : alien-vector ( c-ptr n rep -- value ) \ alien-vector bad-simd-call ; : set-alien-vector ( c-ptr n rep -- value ) \ set-alien-vector bad-simd-call ; -: alien-vector-aligned ( c-ptr n rep -- value ) \ alien-vector-aligned bad-simd-call ; -: set-alien-vector-aligned ( c-ptr n rep -- value ) \ set-alien-vector-aligned bad-simd-call ; - ! Helper for boolean vector literals : vector-true-value ( class -- value ) From 02f209b30a06a187036542cfab52fe81669f5f0f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 13:16:20 -0600 Subject: [PATCH 019/513] remove unused nspin generalization --- basis/generalizations/generalizations-docs.factor | 7 ------- basis/generalizations/generalizations-tests.factor | 2 -- basis/generalizations/generalizations.factor | 3 --- 3 files changed, 12 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index e9a709030e..b04d0c53fb 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -338,12 +338,6 @@ HELP: ntuck } { $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; -HELP: nspin -{ $values - { "n" integer } -} -{ $description "A generalization of " { $link spin } " that can work for any stack depth. The top " { $snippet "n" } " items will be reversed in order." } ; - ARTICLE: "sequence-generalizations" "Generalized sequence operations" { $subsections narray @@ -364,7 +358,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words" nnip ndrop ntuck - nspin mnswap nweave } ; diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index c54e35002f..546413447e 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -26,8 +26,6 @@ IN: generalizations.tests { 0 } [ 0 1 2 3 4 4 ndrop ] unit-test [ [ 1 ] 5 ndip ] must-infer [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test -[ 5 nspin ] must-infer -[ 1 5 4 3 2 ] [ 1 2 3 4 5 4 nspin ] unit-test [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer [ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] must-infer diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 8d6d6f2ac0..dbbfc7354e 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -139,6 +139,3 @@ MACRO: nbi-curry ( n -- ) : nappend ( n -- seq ) narray concat ; inline -MACRO: nspin ( n -- ) - [ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ; - From fa6d7b70690d103fdec5f1b4f8420578ddb68313 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 14:05:06 -0600 Subject: [PATCH 020/513] eliminate spin from basis --- basis/images/jpeg/jpeg.factor | 4 ++-- basis/io/backend/windows/nt/nt.factor | 19 ++++++++++--------- basis/math/blas/vectors/vectors.factor | 8 ++++---- .../matrices/elimination/elimination.factor | 15 +++++++-------- .../hashtables/hashtables-tests.factor | 4 ++-- basis/persistent/hashtables/hashtables.factor | 6 +++--- basis/regexp/disambiguate/disambiguate.factor | 12 ++++++------ basis/validators/validators.factor | 2 +- basis/windows/com/com-tests.factor | 4 ++-- basis/windows/com/wrapper/wrapper-docs.factor | 4 ++-- 10 files changed, 39 insertions(+), 39 deletions(-) diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 4f10808b04..e8af7144ad 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays combinators -grouping compression.huffman images +grouping compression.huffman images fry images.processing io io.binary io.encodings.binary io.files io.streams.byte-array kernel locals math math.bitwise math.constants math.functions math.matrices math.order @@ -232,7 +232,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; block dup length>> sqrt >fixnum group flip dup matrix-dim coord-matrix flip [ - [ first2 spin nth nth ] + [ '[ _ [ second ] [ first ] bi ] dip nth nth ] [ x,y v+ color-id jpeg-image draw-color ] bi ] with each^2 ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 452dc4a409..1301d69913 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -50,16 +50,17 @@ M: winnt add-completion ( win32-handle -- ) } cond ] with-timeout ; -:: wait-for-overlapped ( us -- bytes-transferred overlapped error? ) +:: wait-for-overlapped ( usec -- bytes-transferred overlapped error? ) master-completion-port get-global - 0 [ ! bytes - f ! key - f [ ! overlapped - us [ 1000 /i ] [ INFINITE ] if* ! timeout - GetQueuedCompletionStatus zero? - ] keep - *void* dup [ OVERLAPPED memory>struct ] when - ] keep *int spin ; + 0 :> bytes + f :> key + f :> overlapped + usec [ 1000 /i ] [ INFINITE ] if* :> timeout + bytes key overlapped timeout GetQueuedCompletionStatus zero? :> error? + + bytes *int + overlapped *void* dup [ OVERLAPPED memory>struct ] when + error? ; : resume-callback ( result overlapped -- ) >c-ptr pending-overlapped get-global delete-at* drop resume-with ; diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 8d057de720..8fa41c5026 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -78,10 +78,10 @@ PRIVATE> : n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline : n*V ( alpha x -- alpha*x ) clone n*V! ; inline -: V+ ( x y -- x+y ) - 1.0 -rot n*V+V ; inline -: V- ( x y -- x-y ) - -1.0 spin n*V+V ; inline +:: V+ ( x y -- x+y ) + 1.0 x y n*V+V ; inline +:: V- ( x y -- x-y ) + -1.0 y x n*V+V ; inline : Vneg ( x -- -x ) -1.0 swap n*V ; inline diff --git a/basis/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor index 8411447aac..5c154a6820 100755 --- a/basis/math/matrices/elimination/elimination.factor +++ b/basis/math/matrices/elimination/elimination.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.vectors math.matrices namespaces -sequences ; +USING: kernel locals math math.vectors math.matrices +namespaces sequences ; IN: math.matrices.elimination SYMBOL: matrix @@ -85,12 +85,11 @@ SYMBOL: matrix ] each ] with-matrix ; -: basis-vector ( row col# -- ) - [ clone ] dip - [ swap nth neg recip ] 2keep - [ 0 spin set-nth ] 2keep - [ n*v ] dip - matrix get set-nth ; +:: basis-vector ( row col# -- ) + row clone :> row' + col# row' nth neg recip :> a + 0 col# row' set-nth + a row n*v col# matrix get set-nth ; : nullspace ( matrix -- seq ) echelon reduced dup empty? [ diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor index eea31dd34e..d66fdd0c08 100644 --- a/basis/persistent/hashtables/hashtables-tests.factor +++ b/basis/persistent/hashtables/hashtables-tests.factor @@ -1,6 +1,6 @@ IN: persistent.hashtables.tests USING: persistent.hashtables persistent.assocs hashtables assocs -tools.test kernel namespaces random math.ranges sequences fry ; +tools.test kernel locals namespaces random math.ranges sequences fry ; [ t ] [ PH{ } assoc-empty? ] unit-test @@ -86,7 +86,7 @@ M: hash-0-b hashcode* 2drop 0 ; : random-assocs ( n -- hash phash ) [ random-string ] replicate [ H{ } clone [ '[ swap _ set-at ] each-index ] keep ] - [ PH{ } clone swap [ spin new-at ] each-index ] + [ PH{ } clone swap [| ph elt i | i elt ph new-at ] each-index ] bi ; : ok? ( assoc1 assoc2 -- ? ) diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index 0179216e62..256baabd5e 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. USING: kernel math accessors assocs fry combinators parser -prettyprint.custom make +prettyprint.custom locals make persistent.assocs persistent.hashtables.nodes persistent.hashtables.nodes.empty @@ -38,8 +38,8 @@ M: persistent-hash pluck-at M: persistent-hash >alist [ root>> >alist% ] { } make ; -: >persistent-hash ( assoc -- phash ) - T{ persistent-hash } swap [ spin new-at ] assoc-each ; +:: >persistent-hash ( assoc -- phash ) + T{ persistent-hash } assoc [| ph k v | v k ph new-at ] assoc-each ; M: persistent-hash equal? over persistent-hash? [ assoc= ] [ 2drop f ] if ; diff --git a/basis/regexp/disambiguate/disambiguate.factor b/basis/regexp/disambiguate/disambiguate.factor index 876d898cb4..fcde135cf8 100644 --- a/basis/regexp/disambiguate/disambiguate.factor +++ b/basis/regexp/disambiguate/disambiguate.factor @@ -44,12 +44,12 @@ TUPLE: parts in out ; [ _ meaningful-integers ] keep add-out ] map ; -: class-partitions ( classes -- assoc ) - [ integer? ] partition [ - dup powerset-partition spin add-integers - [ [ partition>class ] keep 2array ] map - [ first ] filter - ] [ '[ _ singleton-partition ] map ] 2bi append ; +:: class-partitions ( classes -- assoc ) + classes [ integer? ] partition :> ( integers classes ) + + classes powerset-partition classes integers add-integers + [ [ partition>class ] keep 2array ] map [ first ] filter + integers [ classes singleton-partition ] map append ; : new-transitions ( transitions -- assoc ) ! assoc is class, partition values [ keys ] gather diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index f0ee13dd38..f2c5691452 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -9,7 +9,7 @@ IN: validators >lower "on" = ; : v-default ( str def -- str/def ) - over empty? spin ? ; + [ nip empty? ] 2keep ? ; : v-required ( str -- str ) dup empty? [ "required" throw ] when ; diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor index ae8ef62c16..25e30829c0 100644 --- a/basis/windows/com/com-tests.factor +++ b/basis/windows/com/com-tests.factor @@ -44,8 +44,8 @@ C: test-implementation [ >>x drop ] ! IInherited::setX } } { IUnrelated { - [ swap x>> + ] ! IUnrelated::xPlus - [ spin x>> * + ] ! IUnrelated::xMulAdd + [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus + [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd } } } dup +test-wrapper+ set [ diff --git a/basis/windows/com/wrapper/wrapper-docs.factor b/basis/windows/com/wrapper/wrapper-docs.factor index 6a6f6f2bb4..0298e80445 100644 --- a/basis/windows/com/wrapper/wrapper-docs.factor +++ b/basis/windows/com/wrapper/wrapper-docs.factor @@ -27,8 +27,8 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} [ >>x drop ] ! IInherited::setX } } { "IUnrelated" { - [ swap x>> + ] ! IUnrelated::xPlus - [ spin x>> * + ] ! IUnrealted::xMulAdd + [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus + [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrealted::xMulAdd } } } """ } ; From 08370a236d2a0c324bbde7d504b6028035ec808b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 14:05:39 -0600 Subject: [PATCH 021/513] update hints docs to demonstrate M\ method syntax instead of old array syntax for referencing methods --- basis/hints/hints-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/hints/hints-docs.factor b/basis/hints/hints-docs.factor index 56a2cb9142..46bdc698b7 100644 --- a/basis/hints/hints-docs.factor +++ b/basis/hints/hints-docs.factor @@ -20,7 +20,7 @@ HELP: specialized-def { $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; HELP: HINTS: -{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes or literals" } } +{ $values { "defspec" "a word or method" } { "hints..." "a list of sequences of classes or literals" } } { $description "Defines specialization hints for a word or a method." $nl "Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." } @@ -35,8 +35,8 @@ $nl "M: assoc count-occurrences" " swap [ = nip ] curry assoc-filter assoc-size ;" "" - "HINTS: { sequence count-occurrences } { object array } ;" - "HINTS: { assoc count-occurrences } { object hashtable } ;" + "HINTS: M\ sequence count-occurrences { object array } ;" + "HINTS: M\ assoc count-occurrences { object hashtable } ;" } } ; From 6c48852fb0c22c3b093d179d9f76be33f519e02d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 15:34:31 -0600 Subject: [PATCH 022/513] eliminate most spins from extra --- extra/bank/bank.factor | 2 +- extra/c/preprocessor/preprocessor.factor | 10 +++---- extra/couchdb/couchdb.factor | 9 ++++--- extra/digraphs/digraphs.factor | 2 +- extra/fries/fries.factor | 8 ++++-- extra/gpu/framebuffers/framebuffers.factor | 11 +++++--- extra/jamshred/tunnel/tunnel.factor | 4 +-- extra/koszul/koszul.factor | 26 +++++++++---------- extra/reports/noise/noise.factor | 1 - extra/set-n/set-n.factor | 6 ++--- extra/space-invaders/space-invaders.factor | 15 ++++++----- extra/sudokus/sudokus.factor | 2 +- extra/tetris/game/game.factor | 2 +- .../tokyo/assoc-functor/assoc-functor.factor | 8 +++--- extra/ui/gadgets/layout/layout.factor | 5 ++-- extra/units/units.factor | 6 ++--- 16 files changed, 63 insertions(+), 54 deletions(-) diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor index 31a4b75eb2..a379a03828 100644 --- a/extra/bank/bank.factor +++ b/extra/bank/bank.factor @@ -63,7 +63,7 @@ C: transaction : process-to-date ( account date -- account ) over interest-last-paid>> 1 days time+ - [ dupd process-day ] spin each-day ; + [ [ dupd process-day ] ] 2dip swap each-day ; : inserting-transactions ( account transactions -- account ) [ [ date>> process-to-date ] keep >>transaction ] each ; diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index 3018fa7a24..77f041835b 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -93,11 +93,11 @@ ERROR: header-file-missing path ; skip-whitespace/comments [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; -: handle-define ( preprocessor-state sequence-parser -- ) - [ take-define-identifier ] - [ skip-whitespace/comments take-rest ] bi - "\\" ?tail [ readlns append ] when - spin symbol-table>> set-at ; +:: handle-define ( preprocessor-state sequence-parser -- ) + sequence-parser take-define-identifier :> ident + sequence-parser skip-whitespace/comments take-rest :> def + def "\\" ?tail [ readlns append ] when :> def + def ident preprocessor-state symbol-table>> set-at ; : handle-undef ( preprocessor-state sequence-parser -- ) take-token swap symbol-table>> delete-at ; diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index da71acb074..ed5dd1268f 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations debugger hashtables http http.client io io.encodings.string io.encodings.utf8 json.reader -json.writer kernel make math math.parser namespaces sequences strings -urls urls.encoding vectors ; +json.writer kernel locals make math math.parser namespaces sequences +strings urls urls.encoding vectors ; IN: couchdb ! NOTE: This code only works with the latest couchdb (0.9.*), because old @@ -136,8 +136,9 @@ C: db : attachments> ( assoc -- attachments ) "_attachments" swap at ; : >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ; -: copy-key ( to from to-key from-key -- ) - rot at spin set-at ; +:: copy-key ( to from to-key from-key -- ) + from-key from at + to-key to set-at ; : copy-id ( to from -- ) "_id" "id" copy-key ; diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor index 2b3379861f..ccbe90fb3c 100755 --- a/extra/digraphs/digraphs.factor +++ b/extra/digraphs/digraphs.factor @@ -44,7 +44,7 @@ DEFER: (topological-sort) ] if ; : topological-sort ( digraph -- seq ) - dup clone V{ } clone spin + [ V{ } clone ] dip [ clone ] keep [ drop (topological-sort) ] assoc-each drop reverse ; : topological-sorted-values ( digraph -- seq ) diff --git a/extra/fries/fries.factor b/extra/fries/fries.factor index 133e8913dd..3f970a86bf 100644 --- a/extra/fries/fries.factor +++ b/extra/fries/fries.factor @@ -1,11 +1,15 @@ USING: arrays vectors combinators effects kernel math sequences splitting strings.parser parser fry sequences.extras ; + +! a b c glue => acb +! c b a [ append ] dip prepend + IN: fries : str-fry ( str on -- quot ) split - [ unclip-last [ [ spin glue ] reduce-r ] 2curry ] + [ unclip-last [ [ [ append ] [ prepend ] bi* ] reduce-r ] 2curry ] [ length 1 - 1 [ call-effect ] 2curry ] bi ; : gen-fry ( str on -- quot ) split - [ unclip-last [ [ spin 1array glue ] reduce-r ] 2curry ] + [ unclip-last [ [ [ 1array ] [ append ] [ prepend ] tri* ] reduce-r ] 2curry ] [ length 1 - 1 [ call-effect ] 2curry ] bi ; SYNTAX: i" parse-string rest "_" str-fry append! ; diff --git a/extra/gpu/framebuffers/framebuffers.factor b/extra/gpu/framebuffers/framebuffers.factor index efd71782d0..bea72961e4 100755 --- a/extra/gpu/framebuffers/framebuffers.factor +++ b/extra/gpu/framebuffers/framebuffers.factor @@ -157,10 +157,13 @@ M: renderbuffer framebuffer-attachment-dim [ swap depth-attachment>> [ swap call ] [ drop ] if* ] [ swap stencil-attachment>> [ swap call ] [ drop ] if* ] 2tri ; inline -: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- ) - [ [ color-attachments>> ] dip [ GL_COLOR_ATTACHMENT0 + swap ] prepose each-index ] - [ swap depth-attachment>> [ GL_DEPTH_ATTACHMENT spin call ] [ drop ] if* ] - [ swap stencil-attachment>> [ GL_STENCIL_ATTACHMENT spin call ] [ drop ] if* ] 2tri ; inline +:: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- ) + framebuffer color-attachments>> + [| attachment n | n GL_COLOR_ATTACHMENT0 + attachment quot call ] each-index + framebuffer depth-attachment>> + [| attachment | GL_DEPTH_ATTACHMENT attachment quot call ] when* + framebuffer stencil-attachment>> + [| attachment | GL_STENCIL_ATTACHMENT attachment quot call ] when* ; inline GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- ) diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index f7eac9d02c..e7285dcbbc 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -77,10 +77,10 @@ CONSTANT: default-segment-radius 1 find 2drop ; : nearest-segment-forward ( segments oint start -- segment ) - rot dup length swap find-nearest-segment ; + rot tail-slice find-nearest-segment ; : nearest-segment-backward ( segments oint start -- segment ) - swapd 1 + 0 spin find-nearest-segment ; + 1 + rot head-slice find-nearest-segment ; : nearest-segment ( segments oint start-segment -- segment ) #! find the segment nearest to 'oint', and return it. diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 59efec1c02..3e3d67195e 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays hashtables assocs io kernel math +USING: accessors arrays hashtables assocs io kernel locals math math.vectors math.matrices math.matrices.elimination namespaces parser prettyprint sequences words combinators math.parser splitting sorting shuffle sets math.order ; @@ -191,12 +191,12 @@ DEFER: (d) [ ?nth ?nth ] 3keep [ [ 2 + ] dip 1 - ] dip ?nth ?nth dim-im/ker-d ; -: bigraded-ker/im-d ( bigraded-basis -- seq ) - dup length [ - over first length [ - [ 2dup ] dip spin (bigraded-ker/im-d) - ] map 2nip - ] with map ; +:: bigraded-ker/im-d ( basis -- seq ) + basis length iota [| z | + basis first length iota [| u | + u z basis (bigraded-ker/im-d) + ] map + ] map ; : bigraded-betti ( u-generators z-generators -- seq ) [ basis graded ] bi@ tensor bigraded-ker/im-d @@ -270,12 +270,12 @@ DEFER: (d) 3tri 3array ; -: bigraded-triples ( grid -- triples ) - dup length [ - over first length [ - [ 2dup ] dip spin bigraded-triple - ] map 2nip - ] with map ; +:: bigraded-triples ( grid -- triples ) + grid length [| z | + grid first length [| u | + u z grid bigraded-triple + ] map + ] map ; : bigraded-laplacian ( u-generators z-generators quot -- seq ) [ [ basis graded ] bi@ tensor bigraded-triples ] dip diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 9eb2804b42..69ac897e34 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -54,7 +54,6 @@ IN: reports.noise { over 2 } { pick 4 } { rot 3 } - { spin 3 } { swap 1 } { swapd 3 } { tuck 2 } diff --git a/extra/set-n/set-n.factor b/extra/set-n/set-n.factor index 04731b0e27..80d8bf2246 100644 --- a/extra/set-n/set-n.factor +++ b/extra/set-n/set-n.factor @@ -1,9 +1,9 @@ -USING: accessors assocs fry generalizations kernel math -namespaces parser sequences words ; +USING: accessors assocs fry generalizations kernel locals math +namespaces parser sequences shuffle words ; IN: set-n : get* ( var n -- val ) namestack dup length rot - head assoc-stack ; : set* ( val var n -- ) 1 + namestack [ length swap - ] keep nth set-at ; ! dynamic lambda -SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ; \ No newline at end of file +SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ; diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index 07b5608a76..db6ed7ed04 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -40,12 +40,13 @@ CONSTANT: game-height 256 #! Point is a {x y}. first2 game-width 3 * * swap 3 * + ; -: set-bitmap-pixel ( color point array -- ) - #! 'color' is a {r g b}. Point is {x y}. - [ bitmap-index ] dip ! color index array - [ [ first ] 2dip set-nth ] 3keep - [ [ second ] 2dip [ 1 + ] dip set-nth ] 3keep - [ third ] 2dip [ 2 + ] dip set-nth ; +:: set-bitmap-pixel ( bitmap point color -- ) + color point bitmap + + point color :> index + color first index bitmap set-nth + color second index 1 + bitmap set-nth + color third index 2 + bitmap set-nth ; : get-bitmap-pixel ( point array -- color ) #! Point is a {x y}. color is a {r g b} @@ -317,7 +318,7 @@ CONSTANT: red { 255 0 0 } : plot-bitmap-pixel ( bitmap point color -- ) #! point is a {x y}. color is a {r g b}. - spin set-bitmap-pixel ; + set-bitmap-pixel ; : within ( n a b -- bool ) #! n >= a and n <= b diff --git a/extra/sudokus/sudokus.factor b/extra/sudokus/sudokus.factor index ff20f15204..c7bc6944fb 100644 --- a/extra/sudokus/sudokus.factor +++ b/extra/sudokus/sudokus.factor @@ -21,7 +21,7 @@ IN: sudokus : solution ( puzzle random? -- solution ) dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if ; : hint ( puzzle -- puzzle' ) [ [ f swap indices random dup ] [ f solution ] bi nth ] keep swapd >vector [ set-nth ] keep ; : create ( difficulty -- puzzle ) 81 [ f ] replicate - 40 random solution [ [ dup length random f spin set-nth ] curry times ] keep ; + 40 random solution [ [ f swap [ length random ] keep set-nth ] curry times ] keep ; : do-sudoku ( -- ) [ [ [ diff --git a/extra/tetris/game/game.factor b/extra/tetris/game/game.factor index e1b5867f64..c9e235ff79 100644 --- a/extra/tetris/game/game.factor +++ b/extra/tetris/game/game.factor @@ -38,7 +38,7 @@ CONSTANT: default-height 20 level>> 1 - 60 * 1000 swap - ; : add-block ( tetris block -- ) - over board>> spin current-piece tetromino>> colour>> set-block ; + over [ board>> ] 2dip current-piece tetromino>> colour>> set-block ; : game-over? ( tetris -- ? ) [ board>> ] [ next-piece ] bi piece-valid? not ; diff --git a/extra/tokyo/assoc-functor/assoc-functor.factor b/extra/tokyo/assoc-functor/assoc-functor.factor index 122e613387..bb2b1d8b6d 100644 --- a/extra/tokyo/assoc-functor/assoc-functor.factor +++ b/extra/tokyo/assoc-functor/assoc-functor.factor @@ -44,11 +44,11 @@ M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ; M: TYPE >alist ( db -- alist ) [ DBKEYS dup ] keep '[ dup _ at 2array ] map! drop ; -M: TYPE set-at ( value key db -- ) - handle>> spin [ object>bytes dup length ] bi@ DBPUT drop ; +M:: TYPE set-at ( value key db -- ) + db handle>> key value [ object>bytes dup length ] bi@ DBPUT drop ; -M: TYPE delete-at ( key db -- ) - handle>> swap object>bytes dup length DBOUT drop ; +M:: TYPE delete-at ( key db -- ) + db handle>> key object>bytes dup length DBOUT drop ; M: TYPE clear-assoc ( db -- ) handle>> DBVANISH drop ; diff --git a/extra/ui/gadgets/layout/layout.factor b/extra/ui/gadgets/layout/layout.factor index 7bdde95d60..c287b9a059 100644 --- a/extra/ui/gadgets/layout/layout.factor +++ b/extra/ui/gadgets/layout/layout.factor @@ -23,8 +23,9 @@ TUPLE: placeholder < gadget members ; ! Just take the previous mentioned placeholder and use it ! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves DEFER: with-interface -: insertion-quot ( quot -- quot' ) make:building get [ [ placeholder? ] find-last nip [ dup , ] unless* - templates get spin '[ [ _ templates set _ , @ ] with-interface ] ] when* ; +: insertion-quot ( quot -- quot' ) + make:building get [ [ placeholder? ] find-last nip [ dup , ] unless* + [ templates get ] 2dip swap '[ [ _ templates set _ , @ ] with-interface ] ] when* ; SYNTAX: ,% scan string>number [ , ] curry append! ; SYNTAX: ->% scan string>number '[ [ _ , ] [ output-model ] bi ] append! ; diff --git a/extra/units/units.factor b/extra/units/units.factor index b8e3f45a16..a293d79f78 100755 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -28,9 +28,9 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; dimensioned boa ; : >dimensioned< ( d -- n top bot ) - [ value>> ] [ top>> ] [ bot>> ] tri ; + [ bot>> ] [ top>> ] [ value>> ] tri ; -\ [ >dimensioned< ] define-inverse +\ [ [ dimensioned boa ] undo ] define-inverse : dimensions ( dimensioned -- top bot ) [ top>> ] [ bot>> ] bi ; @@ -65,7 +65,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; : d-sq ( d -- d ) dup d* ; : d-recip ( d -- d' ) - >dimensioned< spin recip dimension-op> ; + >dimensioned< recip dimension-op> ; : d/ ( d d -- d ) d-recip d* ; From 6e9d3693312065568bdebe2c9d4cca58fe683cc6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 15:40:48 -0600 Subject: [PATCH 023/513] remove spin from core and retire it to basis/shuffle --- basis/shuffle/shuffle-docs.factor | 1 + basis/shuffle/shuffle.factor | 2 ++ core/generic/single/single.factor | 4 ++-- core/kernel/kernel.factor | 2 -- 4 files changed, 5 insertions(+), 4 deletions(-) diff --git a/basis/shuffle/shuffle-docs.factor b/basis/shuffle/shuffle-docs.factor index 15398450a7..ebb87eda7a 100644 --- a/basis/shuffle/shuffle-docs.factor +++ b/basis/shuffle/shuffle-docs.factor @@ -1,5 +1,6 @@ USING: help.markup help.syntax ; IN: shuffle +HELP: spin $complex-shuffle ; HELP: roll $complex-shuffle ; HELP: -roll $complex-shuffle ; diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 43c0b75be1..4388aedb3e 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -22,6 +22,8 @@ MACRO: shuffle-effect ( effect -- ) SYNTAX: shuffle( ")" parse-effect suffix! \ shuffle-effect suffix! ; +: spin ( x y z -- z y x ) swap rot ; inline deprecated + : roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline deprecated : -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline deprecated diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 1434acf521..5636c336c3 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -63,7 +63,7 @@ TUPLE: predicate-engine class methods ; C: predicate-engine -: push-method ( method specializer atomic assoc -- ) +: push-method ( specializer method atomic assoc -- ) dupd [ [ ] [ H{ } clone ] ?if [ methods>> set-at ] keep @@ -71,7 +71,7 @@ C: predicate-engine : flatten-method ( class method assoc -- ) [ [ flatten-class keys ] keep ] 2dip [ - [ spin ] dip push-method + [ swap rot ] dip push-method ] 3curry each ; : flatten-methods ( assoc -- assoc' ) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index a0934c2b17..bb27f7e57e 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -8,8 +8,6 @@ DEFER: 2dip DEFER: 3dip ! Stack stuff -: spin ( x y z -- z y x ) swap rot ; inline - : 2over ( x y z -- x y z x y ) pick pick ; inline : clear ( -- ) { } set-datastack ; From 9ec0c3e9239a2fad4bbc415e3b099b7d6d70cf74 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 16:12:13 -0600 Subject: [PATCH 024/513] remove unused ntuck generalization, and rewrite napply not to use tuck --- basis/generalizations/generalizations-docs.factor | 7 ------- basis/generalizations/generalizations.factor | 7 ++----- 2 files changed, 2 insertions(+), 12 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index b04d0c53fb..ef6c376703 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -332,12 +332,6 @@ HELP: nappend-as { nappend nappend-as } related-words -HELP: ntuck -{ $values - { "n" integer } -} -{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; - ARTICLE: "sequence-generalizations" "Generalized sequence operations" { $subsections narray @@ -357,7 +351,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words" -nrot nnip ndrop - ntuck mnswap nweave } ; diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index dbbfc7354e..6c8a0b5fde 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -71,9 +71,6 @@ MACRO: ndrop ( n -- ) MACRO: nnip ( n -- ) '[ [ _ ndrop ] dip ] ; -MACRO: ntuck ( n -- ) - 2 + '[ dup _ -nrot ] ; - MACRO: ndip ( n -- ) [ [ dip ] curry ] n*quot [ call ] compose ; @@ -112,8 +109,8 @@ MACRO: cleave* ( n -- ) [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ] if-zero ; -MACRO: napply ( n -- ) - [ [ drop ] ] dip [ '[ tuck _ 2dip call ] ] times ; +: napply ( quot n -- ) + [ dupn ] [ spread* ] bi ; inline : apply-curry ( ...a quot n -- ) [ [curry] ] dip napply ; inline From 61d579360dfa9dc7cfc0680a68ad7414202874a2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 17:03:24 -0600 Subject: [PATCH 025/513] remove non-primitive-related uses of tuck from basis --- basis/core-text/core-text-tests.factor | 11 ++++---- basis/csv/csv-tests.factor | 5 ++-- basis/db/sqlite/sqlite.factor | 13 +++++----- basis/fry/fry-docs.factor | 1 - basis/game/input/input.factor | 3 +-- basis/images/jpeg/jpeg.factor | 2 +- basis/io/buffers/buffers-tests.factor | 2 +- basis/io/files/info/windows/windows.factor | 25 ++++++++++++------- basis/io/launcher/windows/windows.factor | 2 +- basis/lists/lazy/lazy.factor | 2 +- basis/math/combinatorics/combinatorics.factor | 6 ++--- basis/math/intervals/intervals-tests.factor | 4 +-- basis/persistent/vectors/vectors.factor | 4 +-- basis/regexp/dfa/dfa.factor | 2 +- basis/regexp/minimize/minimize.factor | 2 +- basis/suffix-arrays/suffix-arrays.factor | 3 +-- basis/tools/scaffold/scaffold.factor | 2 +- basis/ui/traverse/traverse.factor | 9 ++++--- basis/unix/groups/groups.factor | 2 +- basis/xmode/catalog/catalog.factor | 2 +- basis/xmode/marker/marker.factor | 10 ++++---- core/kernel/kernel-docs.factor | 2 -- 22 files changed, 60 insertions(+), 54 deletions(-) diff --git a/basis/core-text/core-text-tests.factor b/basis/core-text/core-text-tests.factor index a5cf69fdee..b6b54df7c3 100644 --- a/basis/core-text/core-text-tests.factor +++ b/basis/core-text/core-text-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test core-text core-text.fonts core-foundation core-foundation.dictionaries destructors arrays kernel generalizations -math accessors core-foundation.utilities combinators hashtables colors +locals math accessors core-foundation.utilities combinators hashtables colors colors.constants ; IN: core-text.tests @@ -18,10 +18,11 @@ IN: core-text.tests ] with-destructors ] unit-test -: test-typographic-bounds ( string font -- ? ) +:: test-typographic-bounds ( string font -- ? ) [ - test-font &CFRelease tuck COLOR: white &CFRelease - compute-line-metrics { + font test-font &CFRelease :> ctfont + string ctfont COLOR: white &CFRelease :> ctline + ctfont ctline compute-line-metrics { [ width>> float? ] [ ascent>> float? ] [ descent>> float? ] @@ -33,4 +34,4 @@ IN: core-text.tests [ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test -[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test \ No newline at end of file +[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 6ba8e2d5b8..829637b4aa 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -70,11 +70,12 @@ IN: csv.tests "can write csv too!" [ "foo1,bar1\nfoo2,bar2\n" ] -[ { { "foo1" "bar1" } { "foo2" "bar2" } } tuck write-csv >string ] named-unit-test +[ { { "foo1" "bar1" } { "foo2" "bar2" } } [ write-csv ] keep >string ] named-unit-test + "escapes quotes commas and newlines when writing" [ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ] -[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } tuck write-csv >string ] named-unit-test ! " +[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } [ write-csv ] keep >string ] named-unit-test ! " [ { { "writing" "some" "csv" "tests" } } ] [ diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index ffcbec70d0..8d26d3b098 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint fry sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators -math.intervals io nmake accessors vectors math.ranges random +math.intervals io locals nmake accessors vectors math.ranges random math.bitwise db.queries destructors db.tuples.private interpolate io.streams.string make db.private sequences.deep db.errors.sqlite ; @@ -85,12 +85,11 @@ M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) nip [ key>> ] [ value>> ] [ type>> ] tri ; -M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) - tuck - [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi - rot set-slot-named - [ [ key>> ] [ type>> ] bi ] dip - swap ; +M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) + generate-bind generator-singleton>> eval-generator :> obj + generate-bind slot-name>> :> name + obj name tuple set-slot-named + generate-bind key>> obj generate-bind type>> ; M: sqlite-statement bind-tuple ( tuple statement -- ) [ diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 9602933785..3401208858 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -59,7 +59,6 @@ $nl { { $link literalize } { $snippet ": literalize '[ _ ] ;" } } { { $link curry } { $snippet ": curry '[ _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } - { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } } } ; ARTICLE: "fry.philosophy" "Fried quotation philosophy" diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index 377a89a884..954602cf06 100755 --- a/basis/game/input/input.factor +++ b/basis/game/input/input.factor @@ -75,9 +75,8 @@ SYMBOLS: get-controllers [ product-id = ] with filter ; : find-controller-instance ( product-id instance-id -- controller/f ) get-controllers [ - tuck [ product-id = ] - [ instance-id = ] 2bi* and + [ instance-id = ] bi-curry bi* and ] with with find nip ; TUPLE: keyboard-state keys ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index e8af7144ad..e305c8477a 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -295,7 +295,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; binary [ [ { HEX: FF } read-until - read1 tuck HEX: 00 = and + read1 [ HEX: 00 = and ] keep swap ] [ drop ] produce swap >marker { EOI } assert= diff --git a/basis/io/buffers/buffers-tests.factor b/basis/io/buffers/buffers-tests.factor index d366df7c54..93d2f5b2fc 100644 --- a/basis/io/buffers/buffers-tests.factor +++ b/basis/io/buffers/buffers-tests.factor @@ -8,7 +8,7 @@ strings accessors destructors ; [ length ] dip buffer-reset ; : string>buffer ( string -- buffer ) - dup length tuck buffer-set ; + dup length [ buffer-set ] keep ; : buffer-read-all ( buffer -- byte-array ) [ [ pos>> ] [ ptr>> ] bi ] diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 5ae21fcfee..6bd3f77ffa 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -151,12 +151,16 @@ PRIVATE> M: winnt file-system-info ( path -- file-system-info ) normalize-path root-directory (file-system-info) ; -: volume>paths ( string -- array ) - 16384 tuck dup length - 0 dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [ - win32-error-string throw +:: volume>paths ( string -- array ) + 16384 :> names-buf-length + names-buf-length :> names + 0 :> names-length + + string names names-buf-length names-length GetVolumePathNamesForVolumeName :> ret + ret 0 = [ + ret win32-error-string throw ] [ - *uint "ushort" heap-size * head + names names-length *uint "ushort" heap-size * head utf16n alien>string CHAR: \0 split ] if ; @@ -166,13 +170,16 @@ M: winnt file-system-info ( path -- file-system-info ) FindFirstVolume dup win32-error=0/f [ utf16n alien>string ] dip ; -: find-next-volume ( handle -- string/f ) - MAX_PATH 1 + [ tuck ] keep - FindNextVolume 0 = [ +:: find-next-volume ( handle -- string/f ) + MAX_PATH 1 + :> buf-length + buf-length :> buf + + handle buf buf-length FindNextVolume :> ret + ret 0 = [ GetLastError ERROR_NO_MORE_FILES = [ drop f ] [ win32-error-string throw ] if ] [ - utf16n alien>string + buf utf16n alien>string ] if ; : find-volumes ( -- array ) diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 6cae50bd9e..8a800115f6 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -132,7 +132,7 @@ M: windows run-process* ( process -- handle ) current-directory get absolute-path cd dup make-CreateProcess-args - tuck fill-redirection + [ fill-redirection ] keep dup call-CreateProcess lpProcessInformation>> ] with-destructors ; diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 7b386e9c81..57cacaa494 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -114,7 +114,7 @@ M: lazy-until car ( lazy-until -- car ) cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) + [ quot>> ] [ cons>> unswons ] bi over call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- ? ) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index bc09f9fe0f..5c03e41870 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -96,9 +96,9 @@ C: combo initial-values [ over 0 > ] [ next-values ] produce [ 3drop ] dip ; -: combination-indices ( m combo -- seq ) - [ tuck dual-index combinadic ] keep - seq>> length 1 - swap [ - ] with map ; +:: combination-indices ( m combo -- seq ) + combo m combo dual-index combinadic + combo seq>> length 1 - swap [ - ] with map ; : apply-combination ( m combo -- seq ) [ combination-indices ] keep seq>> nths ; diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 1ee4e1e100..a569b4af7b 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -79,7 +79,7 @@ IN: math.intervals.tests [ t ] [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test -[ t ] [ empty-interval 1 2 [a,b] tuck interval-union = ] unit-test +[ t ] [ 1 2 [a,b] empty-interval over interval-union = ] unit-test [ t ] [ 0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] = @@ -250,7 +250,7 @@ IN: math.intervals.tests dup full-interval eq? [ drop 32 random-bits 31 2^ - ] [ - dup to>> first over from>> first tuck - random + + [ ] [ from>> first ] [ to>> first ] tri over - random + 2dup swap interval-contains? [ nip ] [ diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index 2527959f32..b02604e9bd 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -58,7 +58,7 @@ M: persistent-vector nth-unsafe [ 2array ] [ drop level>> 1 + ] 2bi node boa ; : new-child ( new-child node -- node' expansion/f ) - dup full? [ tuck level>> 1node ] [ node-add f ] if ; + dup full? [ [ level>> 1node ] keep swap ] [ node-add f ] if ; : new-last ( val seq -- seq' ) [ length 1 - ] keep new-nth ; @@ -70,7 +70,7 @@ M: persistent-vector nth-unsafe dup level>> 1 = [ new-child ] [ - tuck children>> last (ppush-new-tail) + [ nip ] 2keep children>> last (ppush-new-tail) [ swap new-child ] [ swap node-set-last f ] ?if ] if ; diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index 2de4e8b0e0..fa75232fd5 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -25,7 +25,7 @@ IN: regexp.dfa ] unless ; : epsilon-table ( states nfa -- table ) - [ H{ } clone tuck ] dip + [ [ H{ } clone ] dip over ] dip '[ _ _ t epsilon-loop ] each ; : find-epsilon-closure ( states nfa -- dfa-state ) diff --git a/basis/regexp/minimize/minimize.factor b/basis/regexp/minimize/minimize.factor index 1885144e6c..a6eb4f00a2 100644 --- a/basis/regexp/minimize/minimize.factor +++ b/basis/regexp/minimize/minimize.factor @@ -85,7 +85,7 @@ IN: regexp.minimize '[ _ delete-duplicates ] change-transitions ; : combine-state-transitions ( hash -- hash ) - H{ } clone tuck '[ + [ H{ } clone ] dip over '[ _ [ 2array ] change-at ] assoc-each [ swap ] assoc-map ; diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index 931cb36ea9..f486adcb32 100755 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -22,8 +22,7 @@ IN: suffix-arrays : ( from/f to/f seq -- slice ) [ - tuck - [ drop 0 or ] [ length or ] 2bi* + [ drop 0 or ] [ length or ] bi-curry bi* [ min ] keep ] keep ; inline diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 089bad3158..936d388b01 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -98,7 +98,7 @@ M: bad-developer-name summary [ main-file-string ] dip utf8 set-file-contents ; : scaffold-main ( vocab-root vocab -- ) - tuck ".factor" vocab-root/vocab/suffix>path scaffolding? [ + [ ".factor" vocab-root/vocab/suffix>path ] keep swap scaffolding? [ set-scaffold-main-file ] [ 2drop diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 11c2a48a2a..5a92a4cea2 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -20,8 +20,9 @@ TUPLE: node value children ; ] [ [ [ children>> swap first head-slice % ] - [ tuck traverse-step traverse-to-path ] - 2bi + [ nip ] + [ traverse-step traverse-to-path ] + 2tri ] make-node ] if ] if ; @@ -35,7 +36,9 @@ TUPLE: node value children ; ] [ [ [ traverse-step traverse-from-path ] - [ tuck children>> swap first 1 + tail-slice % ] 2bi + [ nip ] + [ children>> swap first 1 + tail-slice % ] + 2tri ] make-node ] if ] if ; diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index c4392c4c6d..02d9f37023 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -23,7 +23,7 @@ GENERIC: group-struct ( obj -- group/f ) gr_mem>> utf8 alien>strings ; : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) - \ unix:group tuck 4096 + [ \ unix:group ] dip over 4096 [ ] keep f ; : check-group-struct ( group-struct ptr -- group-struct/f ) diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor index 97de95a932..40b8e2191c 100644 --- a/basis/xmode/catalog/catalog.factor +++ b/basis/xmode/catalog/catalog.factor @@ -110,7 +110,7 @@ ERROR: mutually-recursive-rulesets ruleset ; dup [ glob-matches? ] [ 2drop f ] if ; : suitable-mode? ( file-name first-line mode -- ? ) - tuck first-line-glob>> ?glob-matches + [ nip ] 2keep first-line-glob>> ?glob-matches [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ; : find-mode ( file-name first-line -- mode ) diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index d3a4f1e9a2..6b8db76ac9 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -86,7 +86,7 @@ M: regexp text-matches? [ >string ] dip first-match dup [ to>> ] when ; : rule-start-matches? ( rule -- match-count/f ) - dup start>> tuck swap can-match-here? [ + [ start>> dup ] keep can-match-here? [ rest-of-line swap text>> text-matches? ] [ drop f @@ -96,7 +96,7 @@ M: regexp text-matches? dup mark-following-rule? [ dup start>> swap can-match-here? 0 and ] [ - dup end>> tuck swap can-match-here? [ + [ end>> dup ] keep can-match-here? [ rest-of-line swap text>> context get end>> or text-matches? @@ -170,7 +170,7 @@ M: seq-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck body-token>> next-token, + [ body-token>> next-token, ] keep delegate>> [ push-context ] when* ; UNION: abstract-span-rule span-rule eol-span-rule ; @@ -179,7 +179,7 @@ M: abstract-span-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck rule-match-token* next-token, + [ rule-match-token* next-token, ] keep ! ... end subst ... dup context get (>>in-rule) delegate>> push-context ; @@ -190,7 +190,7 @@ M: span-rule handle-rule-end M: mark-following-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck rule-match-token* next-token, + [ rule-match-token* next-token, ] keep f context get (>>end) context get (>>in-rule) ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index f70d9d4214..7327285ffd 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -21,7 +21,6 @@ HELP: 2over $shuffle ; HELP: pick ( x y z -- x y z x ) $shuffle ; HELP: swap ( x y -- y x ) $shuffle ; -HELP: spin $complex-shuffle ; HELP: rot ( x y z -- y z x ) $complex-shuffle ; HELP: -rot ( x y z -- z x y ) $complex-shuffle ; HELP: dupd ( x y -- x x y ) $complex-shuffle ; @@ -828,7 +827,6 @@ $nl swapd rot -rot - spin } ; ARTICLE: "shuffle-words" "Shuffle words" From dbadab67ef69d40095a9445c942da2515059fdc4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 17:03:39 -0600 Subject: [PATCH 026/513] remove tuck from reports/noise --- extra/reports/noise/noise.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 69ac897e34..cc6c9ee33f 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -49,14 +49,12 @@ IN: reports.noise { nkeep 5 } { npick 6 } { nrot 5 } - { ntuck 6 } { nwith 4 } { over 2 } { pick 4 } { rot 3 } { swap 1 } { swapd 3 } - { tuck 2 } { with 1/2 } { bi 1/2 } From 3e28be6568279df3127d66f88ae515a20c895996 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 5 Nov 2009 17:12:10 -0600 Subject: [PATCH 027/513] move sequence-parser to sequences.parser --- basis/compression/run-length/run-length.factor | 2 +- basis/sequences/parser/authors.txt | 2 ++ .../sequences/parser/parser-tests.factor | 2 +- .../sequences/parser/parser.factor | 2 +- extra/c/lexer/lexer-tests.factor | 2 +- extra/c/lexer/lexer.factor | 2 +- extra/c/preprocessor/preprocessor.factor | 2 +- extra/html/parser/parser.factor | 2 +- 8 files changed, 9 insertions(+), 7 deletions(-) create mode 100644 basis/sequences/parser/authors.txt rename extra/sequence-parser/sequence-parser-tests.factor => basis/sequences/parser/parser-tests.factor (98%) rename extra/sequence-parser/sequence-parser.factor => basis/sequences/parser/parser.factor (99%) diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index cde2a7e113..ce25cd6a63 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators grouping kernel locals math -math.matrices math.order multiline sequence-parser sequences +math.matrices math.order multiline sequences.parser sequences tools.continuations ; IN: compression.run-length diff --git a/basis/sequences/parser/authors.txt b/basis/sequences/parser/authors.txt new file mode 100644 index 0000000000..a07c427c98 --- /dev/null +++ b/basis/sequences/parser/authors.txt @@ -0,0 +1,2 @@ +Daniel Ehrenberg +Doug Coleman diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/basis/sequences/parser/parser-tests.factor similarity index 98% rename from extra/sequence-parser/sequence-parser-tests.factor rename to basis/sequences/parser/parser-tests.factor index af13e5b86e..f788a6da6a 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/basis/sequences/parser/parser-tests.factor @@ -1,6 +1,6 @@ USING: tools.test sequence-parser unicode.categories kernel accessors ; -IN: sequence-parser.tests +IN: sequences.parser.tests [ "hello" ] [ "hello" [ take-rest ] parse-sequence ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/basis/sequences/parser/parser.factor similarity index 99% rename from extra/sequence-parser/sequence-parser.factor rename to basis/sequences/parser/parser.factor index d14a77057f..93bbbdf53d 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/basis/sequences/parser/parser.factor @@ -3,7 +3,7 @@ USING: accessors circular combinators.short-circuit fry io kernel locals math math.order sequences sorting.functor sorting.slots unicode.categories ; -IN: sequence-parser +IN: sequences.parser TUPLE: sequence-parser sequence n ; diff --git a/extra/c/lexer/lexer-tests.factor b/extra/c/lexer/lexer-tests.factor index c972b8816c..082827353d 100644 --- a/extra/c/lexer/lexer-tests.factor +++ b/extra/c/lexer/lexer-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors c.lexer kernel sequence-parser tools.test ; +USING: accessors c.lexer kernel sequences.parser tools.test ; IN: c.lexer.tests [ 36 ] diff --git a/extra/c/lexer/lexer.factor b/extra/c/lexer/lexer.factor index 962407e6ec..57894217bd 100644 --- a/extra/c/lexer/lexer.factor +++ b/extra/c/lexer/lexer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.short-circuit generalizations kernel locals math.order math.ranges -sequence-parser sequences sorting.functor sorting.slots +sequences.parser sequences sorting.functor sorting.slots unicode.categories ; IN: c.lexer diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index 3018fa7a24..e8176c8df8 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: sequence-parser io io.encodings.utf8 io.files +USING: sequences.parser io io.encodings.utf8 io.files io.streams.string kernel combinators accessors io.pathnames fry sequences arrays locals namespaces io.directories assocs math splitting make unicode.categories diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 9fcbffd0db..8d506cda28 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays hashtables sequence-parser +USING: accessors arrays hashtables sequences.parser html.parser.utils kernel namespaces sequences math unicode.case unicode.categories combinators.short-circuit quoting fry ; From 72ab6ec5481c51fa18f1a04b7d57f63094d0c12a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Nov 2009 19:03:51 -0600 Subject: [PATCH 028/513] vm: rewrite 'become' primitive so that it uses a slot visitor instead of GC --- Makefile | 1 + vm/aging_space.hpp | 9 --- vm/bump_allocator.hpp | 17 ++++++ vm/code_heap.cpp | 7 +-- vm/contexts.cpp | 8 +++ vm/data_heap.cpp | 20 ++---- vm/data_heap.hpp | 1 + vm/factor.cpp | 1 + vm/full_collector.cpp | 4 ++ vm/gc.cpp | 35 +---------- vm/master.hpp | 1 + vm/objects.cpp | 137 ++++++++++++++++++++++++++++++++++++++++++ vm/objects.hpp | 101 +++++++++++++++++++++++++++++++ vm/primitives.cpp | 8 +-- vm/quotations.cpp | 2 - vm/run.cpp | 52 ---------------- vm/run.hpp | 99 ------------------------------ vm/vm.hpp | 42 ++++++++++--- 18 files changed, 316 insertions(+), 229 deletions(-) create mode 100644 vm/objects.cpp create mode 100644 vm/objects.hpp diff --git a/Makefile b/Makefile index 2ea43706f4..52914d128a 100755 --- a/Makefile +++ b/Makefile @@ -58,6 +58,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/math.o \ vm/nursery_collector.o \ vm/object_start_map.o \ + vm/objects.o \ vm/primitives.o \ vm/profiler.o \ vm/quotations.o \ diff --git a/vm/aging_space.hpp b/vm/aging_space.hpp index 7a28f54ebf..ccb2d1a1a2 100644 --- a/vm/aging_space.hpp +++ b/vm/aging_space.hpp @@ -15,15 +15,6 @@ struct aging_space : bump_allocator { starts.record_object_start_offset(obj); return obj; } - - cell next_object_after(cell scan) - { - cell size = ((object *)scan)->size(); - if(scan + size < here) - return scan + size; - else - return 0; - } }; } diff --git a/vm/bump_allocator.hpp b/vm/bump_allocator.hpp index 5488c65323..bbe4df8eec 100644 --- a/vm/bump_allocator.hpp +++ b/vm/bump_allocator.hpp @@ -32,6 +32,23 @@ template struct bump_allocator { { return end - here; } + + cell next_object_after(cell scan) + { + cell size = ((Block *)scan)->size(); + if(scan + size < here) + return scan + size; + else + return 0; + } + + cell first_object() + { + if(start != here) + return start; + else + return 0; + } }; } diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index b4e071d644..44a7a54dfa 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -118,10 +118,8 @@ struct word_and_literal_code_heap_updater { void factor_vm::update_code_heap_words_and_literals() { - current_gc->event->started_code_sweep(); word_and_literal_code_heap_updater updater(this); - code->allocator->sweep(updater); - current_gc->event->ended_code_sweep(); + iterate_code_heap(updater); } /* After growing the heap, we have to perform a full relocation to update @@ -152,8 +150,7 @@ void factor_vm::primitive_modify_code_heap() if(count == 0) return; - cell i; - for(i = 0; i < count; i++) + for(cell i = 0; i < count; i++) { data_root pair(array_nth(alist.untagged(),i),this); diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 7af7fdaa57..16b882f2cc 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -196,4 +196,12 @@ void factor_vm::primitive_check_datastack() } } +void factor_vm::primitive_load_locals() +{ + fixnum count = untag_fixnum(dpop()); + memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count); + ds -= sizeof(cell) * count; + rs += sizeof(cell) * count; +} + } diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index bb705e276c..f9771d47a0 100755 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -103,6 +103,12 @@ bool data_heap::low_memory_p() return (tenured->free_space() <= nursery->size + aging->size); } +void data_heap::mark_all_cards() +{ + memset(cards,-1,cards_end - cards); + memset(decks,-1,decks_end - decks); +} + void factor_vm::set_data_heap(data_heap *data_) { data = data_; @@ -115,15 +121,6 @@ void factor_vm::init_data_heap(cell young_size, cell aging_size, cell tenured_si set_data_heap(new data_heap(young_size,aging_size,tenured_size)); } -/* Size of the object pointed to by a tagged pointer */ -cell factor_vm::object_size(cell tagged) -{ - if(immediate_p(tagged)) - return 0; - else - return untag(tagged)->size(); -} - /* Size of the object pointed to by an untagged pointer */ cell object::size() const { @@ -201,11 +198,6 @@ cell object::binary_payload_start() const } } -void factor_vm::primitive_size() -{ - box_unsigned_cell(object_size(dpop())); -} - data_heap_room factor_vm::data_room() { data_heap_room room; diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp index 760a10942e..ce156696b8 100755 --- a/vm/data_heap.hpp +++ b/vm/data_heap.hpp @@ -30,6 +30,7 @@ struct data_heap { void reset_generation(aging_space *gen); void reset_generation(tenured_space *gen); bool low_memory_p(); + void mark_all_cards(); }; struct data_heap_room { diff --git a/vm/factor.cpp b/vm/factor.cpp index d382745da8..589d1898b1 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -86,6 +86,7 @@ void factor_vm::do_stage1_init() fflush(stdout); compile_all_words(); + update_code_heap_words(); special_objects[OBJ_STAGE2] = true_object; std::cout << "done\n"; diff --git a/vm/full_collector.cpp b/vm/full_collector.cpp index 3b92e2574e..07c410218c 100644 --- a/vm/full_collector.cpp +++ b/vm/full_collector.cpp @@ -116,6 +116,10 @@ void factor_vm::collect_sweep_impl() data->tenured->sweep(); update_code_roots_for_sweep(); current_gc->event->ended_data_sweep(); + + current_gc->event->started_code_sweep(); + code->allocator->sweep(); + current_gc->event->ended_code_sweep(); } void factor_vm::collect_full(bool trace_contexts_p) diff --git a/vm/gc.cpp b/vm/gc.cpp index de8a2886f7..79f04db802 100755 --- a/vm/gc.cpp +++ b/vm/gc.cpp @@ -218,37 +218,6 @@ void factor_vm::primitive_compact_gc() true /* trace contexts? */); } -/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this - to coalesce equal but distinct quotations and wrappers. */ -void factor_vm::primitive_become() -{ - array *new_objects = untag_check(dpop()); - array *old_objects = untag_check(dpop()); - - cell capacity = array_capacity(new_objects); - if(capacity != array_capacity(old_objects)) - critical_error("bad parameters to become",0); - - cell i; - - for(i = 0; i < capacity; i++) - { - tagged old_obj(array_nth(old_objects,i)); - tagged new_obj(array_nth(new_objects,i)); - - if(old_obj != new_obj) - old_obj->h.forward_to(new_obj.untagged()); - } - - primitive_full_gc(); - - /* If a word's definition quotation was in old_objects and the - quotation in new_objects is not compiled, we might leak memory - by referencing the old quotation unless we recompile all - unoptimized words. */ - compile_all_words(); -} - void factor_vm::inline_gc(cell *data_roots_base, cell data_roots_size) { for(cell i = 0; i < data_roots_size; i++) @@ -290,9 +259,7 @@ object *factor_vm::allot_large_object(header header, cell size) /* Allows initialization code to store old->new pointers without hitting the write barrier in the common case of a nursery allocation */ - char *start = (char *)obj; - for(cell offset = 0; offset < size; offset += card_size) - write_barrier((cell *)(start + offset)); + write_barrier(obj,size); obj->h = header; return obj; diff --git a/vm/master.hpp b/vm/master.hpp index 39242a36af..23c70782df 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -44,6 +44,7 @@ namespace factor #include "segments.hpp" #include "contexts.hpp" #include "run.hpp" +#include "objects.hpp" #include "profiler.hpp" #include "errors.hpp" #include "bignumint.hpp" diff --git a/vm/objects.cpp b/vm/objects.cpp new file mode 100644 index 0000000000..ad76d7c1b6 --- /dev/null +++ b/vm/objects.cpp @@ -0,0 +1,137 @@ +#include "master.hpp" + +namespace factor +{ + +void factor_vm::primitive_special_object() +{ + fixnum e = untag_fixnum(dpeek()); + drepl(special_objects[e]); +} + +void factor_vm::primitive_set_special_object() +{ + fixnum e = untag_fixnum(dpop()); + cell value = dpop(); + special_objects[e] = value; +} + +void factor_vm::primitive_set_slot() +{ + fixnum slot = untag_fixnum(dpop()); + object *obj = untag(dpop()); + cell value = dpop(); + + cell *slot_ptr = &obj->slots()[slot]; + *slot_ptr = value; + write_barrier(slot_ptr); +} + +cell factor_vm::clone_object(cell obj_) +{ + data_root obj(obj_,this); + + if(immediate_p(obj.value())) + return obj.value(); + else + { + cell size = object_size(obj.value()); + object *new_obj = allot_object(header(obj.type()),size); + memcpy(new_obj,obj.untagged(),size); + return tag_dynamic(new_obj); + } +} + +void factor_vm::primitive_clone() +{ + drepl(clone_object(dpeek())); +} + +/* Size of the object pointed to by a tagged pointer */ +cell factor_vm::object_size(cell tagged) +{ + if(immediate_p(tagged)) + return 0; + else + return untag(tagged)->size(); +} + +void factor_vm::primitive_size() +{ + box_unsigned_cell(object_size(dpop())); +} + +struct slot_become_visitor { + std::map *become_map; + + explicit slot_become_visitor(std::map *become_map_) : + become_map(become_map_) {} + + object *operator()(object *old) + { + std::map::const_iterator iter = become_map->find(old); + if(iter != become_map->end()) + return iter->second; + else + return old; + } +}; + +struct object_become_visitor { + slot_visitor *workhorse; + + explicit object_become_visitor(slot_visitor *workhorse_) : + workhorse(workhorse_) {} + + void operator()(cell obj) + { + workhorse->visit_slots(tagged(obj).untagged()); + } +}; + +/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this + to coalesce equal but distinct quotations and wrappers. */ +void factor_vm::primitive_become() +{ + array *new_objects = untag_check(dpop()); + array *old_objects = untag_check(dpop()); + + cell capacity = array_capacity(new_objects); + if(capacity != array_capacity(old_objects)) + critical_error("bad parameters to become",0); + + /* Build the forwarding map */ + std::map become_map; + + for(cell i = 0; i < capacity; i++) + { + tagged old_obj(array_nth(old_objects,i)); + tagged new_obj(array_nth(new_objects,i)); + + if(old_obj != new_obj) + become_map[old_obj.untagged()] = new_obj.untagged(); + } + + /* Update all references to old objects to point to new objects */ + slot_visitor workhorse(this,slot_become_visitor(&become_map)); + workhorse.visit_roots(); + workhorse.visit_contexts(); + + object_become_visitor object_visitor(&workhorse); + each_object(object_visitor); + + /* Since we may have introduced old->new references, need to revisit + all objects on a minor GC. */ + data->mark_all_cards(); + + /* If a word's definition quotation was in old_objects and the + quotation in new_objects is not compiled, we might leak memory + by referencing the old quotation unless we recompile all + unoptimized words. */ + compile_all_words(); + + /* Update references to old objects in the code heap */ + update_code_heap_words_and_literals(); +} + +} diff --git a/vm/objects.hpp b/vm/objects.hpp new file mode 100644 index 0000000000..c4e8547ce6 --- /dev/null +++ b/vm/objects.hpp @@ -0,0 +1,101 @@ +namespace factor +{ + +static const cell special_object_count = 70; + +enum special_object { + OBJ_NAMESTACK, /* used by library only */ + OBJ_CATCHSTACK, /* used by library only, per-callback */ + + OBJ_CURRENT_CALLBACK = 2, /* used by library only, per-callback */ + OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */ + OBJ_CALLCC_1, /* used to pass the value in callcc1 */ + + OBJ_BREAK = 5, /* quotation called by throw primitive */ + OBJ_ERROR, /* a marker consed onto kernel errors */ + + OBJ_CELL_SIZE = 7, /* sizeof(cell) */ + OBJ_CPU, /* CPU architecture */ + OBJ_OS, /* operating system name */ + + OBJ_ARGS = 10, /* command line arguments */ + OBJ_STDIN, /* stdin FILE* handle */ + OBJ_STDOUT, /* stdout FILE* handle */ + + OBJ_IMAGE = 13, /* image path name */ + OBJ_EXECUTABLE, /* runtime executable path name */ + + OBJ_EMBEDDED = 15, /* are we embedded in another app? */ + OBJ_EVAL_CALLBACK, /* used when Factor is embedded in a C app */ + OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */ + OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */ + + OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */ + + OBJ_BOOT = 20, /* boot quotation */ + OBJ_GLOBAL, /* global namespace */ + + /* Quotation compilation in quotations.c */ + JIT_PROLOG = 23, + JIT_PRIMITIVE_WORD, + JIT_PRIMITIVE, + JIT_WORD_JUMP, + JIT_WORD_CALL, + JIT_WORD_SPECIAL, + JIT_IF_WORD, + JIT_IF, + JIT_EPILOG, + JIT_RETURN, + JIT_PROFILING, + JIT_PUSH_IMMEDIATE, + JIT_DIP_WORD, + JIT_DIP, + JIT_2DIP_WORD, + JIT_2DIP, + JIT_3DIP_WORD, + JIT_3DIP, + JIT_EXECUTE_WORD, + JIT_EXECUTE_JUMP, + JIT_EXECUTE_CALL, + JIT_DECLARE_WORD, + + /* Callback stub generation in callbacks.c */ + CALLBACK_STUB = 45, + + /* Polymorphic inline cache generation in inline_cache.c */ + PIC_LOAD = 47, + PIC_TAG, + PIC_TUPLE, + PIC_CHECK_TAG, + PIC_CHECK_TUPLE, + PIC_HIT, + PIC_MISS_WORD, + PIC_MISS_TAIL_WORD, + + /* Megamorphic cache generation in dispatch.c */ + MEGA_LOOKUP = 57, + MEGA_LOOKUP_WORD, + MEGA_MISS_WORD, + + OBJ_UNDEFINED = 60, /* default quotation for undefined words */ + + OBJ_STDERR = 61, /* stderr FILE* handle */ + + OBJ_STAGE2 = 62, /* have we bootstrapped? */ + + OBJ_CURRENT_THREAD = 63, + + OBJ_THREADS = 64, + OBJ_RUN_QUEUE = 65, + OBJ_SLEEP_QUEUE = 66, +}; + +#define OBJ_FIRST_SAVE OBJ_BOOT +#define OBJ_LAST_SAVE OBJ_STAGE2 + +inline static bool save_env_p(cell i) +{ + return (i >= OBJ_FIRST_SAVE && i <= OBJ_LAST_SAVE); +} + +} diff --git a/vm/primitives.cpp b/vm/primitives.cpp index 957e6128ed..b8d909fbe8 100644 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -49,8 +49,8 @@ PRIMITIVE_FORWARD(float_greater) PRIMITIVE_FORWARD(float_greatereq) PRIMITIVE_FORWARD(word) PRIMITIVE_FORWARD(word_xt) -PRIMITIVE_FORWARD(getenv) -PRIMITIVE_FORWARD(setenv) +PRIMITIVE_FORWARD(special_object) +PRIMITIVE_FORWARD(set_special_object) PRIMITIVE_FORWARD(existsp) PRIMITIVE_FORWARD(minor_gc) PRIMITIVE_FORWARD(full_gc) @@ -185,8 +185,8 @@ const primitive_type primitives[] = { primitive_float_greatereq, primitive_word, primitive_word_xt, - primitive_getenv, - primitive_setenv, + primitive_special_object, + primitive_set_special_object, primitive_existsp, primitive_minor_gc, primitive_full_gc, diff --git a/vm/quotations.cpp b/vm/quotations.cpp index fc19266cee..8ccafc9d8f 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -341,8 +341,6 @@ void factor_vm::compile_all_words() update_word_xt(word.untagged()); } - - update_code_heap_words(); } /* Allocates memory */ diff --git a/vm/run.cpp b/vm/run.cpp index 6d3e9f7374..59375df1fb 100755 --- a/vm/run.cpp +++ b/vm/run.cpp @@ -3,19 +3,6 @@ namespace factor { -void factor_vm::primitive_getenv() -{ - fixnum e = untag_fixnum(dpeek()); - drepl(special_objects[e]); -} - -void factor_vm::primitive_setenv() -{ - fixnum e = untag_fixnum(dpop()); - cell value = dpop(); - special_objects[e] = value; -} - void factor_vm::primitive_exit() { exit(to_fixnum(dpop())); @@ -31,43 +18,4 @@ void factor_vm::primitive_sleep() sleep_micros(to_cell(dpop())); } -void factor_vm::primitive_set_slot() -{ - fixnum slot = untag_fixnum(dpop()); - object *obj = untag(dpop()); - cell value = dpop(); - - cell *slot_ptr = &obj->slots()[slot]; - *slot_ptr = value; - write_barrier(slot_ptr); -} - -void factor_vm::primitive_load_locals() -{ - fixnum count = untag_fixnum(dpop()); - memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count); - ds -= sizeof(cell) * count; - rs += sizeof(cell) * count; -} - -cell factor_vm::clone_object(cell obj_) -{ - data_root obj(obj_,this); - - if(immediate_p(obj.value())) - return obj.value(); - else - { - cell size = object_size(obj.value()); - object *new_obj = allot_object(header(obj.type()),size); - memcpy(new_obj,obj.untagged(),size); - return tag_dynamic(new_obj); - } -} - -void factor_vm::primitive_clone() -{ - drepl(clone_object(dpeek())); -} - } diff --git a/vm/run.hpp b/vm/run.hpp index 6ca2e50464..412ef35bb4 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -1,103 +1,4 @@ namespace factor { -static const cell special_object_count = 70; - -enum special_object { - OBJ_NAMESTACK, /* used by library only */ - OBJ_CATCHSTACK, /* used by library only, per-callback */ - - OBJ_CURRENT_CALLBACK = 2, /* used by library only, per-callback */ - OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */ - OBJ_CALLCC_1, /* used to pass the value in callcc1 */ - - OBJ_BREAK = 5, /* quotation called by throw primitive */ - OBJ_ERROR, /* a marker consed onto kernel errors */ - - OBJ_CELL_SIZE = 7, /* sizeof(cell) */ - OBJ_CPU, /* CPU architecture */ - OBJ_OS, /* operating system name */ - - OBJ_ARGS = 10, /* command line arguments */ - OBJ_STDIN, /* stdin FILE* handle */ - OBJ_STDOUT, /* stdout FILE* handle */ - - OBJ_IMAGE = 13, /* image path name */ - OBJ_EXECUTABLE, /* runtime executable path name */ - - OBJ_EMBEDDED = 15, /* are we embedded in another app? */ - OBJ_EVAL_CALLBACK, /* used when Factor is embedded in a C app */ - OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */ - OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */ - - OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */ - - OBJ_BOOT = 20, /* boot quotation */ - OBJ_GLOBAL, /* global namespace */ - - /* Quotation compilation in quotations.c */ - JIT_PROLOG = 23, - JIT_PRIMITIVE_WORD, - JIT_PRIMITIVE, - JIT_WORD_JUMP, - JIT_WORD_CALL, - JIT_WORD_SPECIAL, - JIT_IF_WORD, - JIT_IF, - JIT_EPILOG, - JIT_RETURN, - JIT_PROFILING, - JIT_PUSH_IMMEDIATE, - JIT_DIP_WORD, - JIT_DIP, - JIT_2DIP_WORD, - JIT_2DIP, - JIT_3DIP_WORD, - JIT_3DIP, - JIT_EXECUTE_WORD, - JIT_EXECUTE_JUMP, - JIT_EXECUTE_CALL, - JIT_DECLARE_WORD, - - /* Callback stub generation in callbacks.c */ - CALLBACK_STUB = 45, - - /* Polymorphic inline cache generation in inline_cache.c */ - PIC_LOAD = 47, - PIC_TAG, - PIC_TUPLE, - PIC_CHECK_TAG, - PIC_CHECK_TUPLE, - PIC_HIT, - PIC_MISS_WORD, - PIC_MISS_TAIL_WORD, - - /* Megamorphic cache generation in dispatch.c */ - MEGA_LOOKUP = 57, - MEGA_LOOKUP_WORD, - MEGA_MISS_WORD, - - OBJ_UNDEFINED = 60, /* default quotation for undefined words */ - - OBJ_STDERR = 61, /* stderr FILE* handle */ - - OBJ_STAGE2 = 62, /* have we bootstrapped? */ - - OBJ_CURRENT_THREAD = 63, - - OBJ_THREADS = 64, - OBJ_RUN_QUEUE = 65, - OBJ_SLEEP_QUEUE = 66, -}; - -#define OBJ_FIRST_SAVE OBJ_BOOT -#define OBJ_LAST_SAVE OBJ_STAGE2 - -inline static bool save_env_p(cell i) -{ - return (i >= OBJ_FIRST_SAVE && i <= OBJ_LAST_SAVE); } - -} - - diff --git a/vm/vm.hpp b/vm/vm.hpp index aa5a3051e6..0a65873f6c 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -102,6 +102,7 @@ struct factor_vm void primitive_set_datastack(); void primitive_set_retainstack(); void primitive_check_datastack(); + void primitive_load_locals(); template void iterate_active_frames(Iterator &iter) { @@ -116,15 +117,18 @@ struct factor_vm } // run - void primitive_getenv(); - void primitive_setenv(); void primitive_exit(); void primitive_micros(); void primitive_sleep(); void primitive_set_slot(); - void primitive_load_locals(); + + // objects + void primitive_special_object(); + void primitive_set_special_object(); + cell object_size(cell tagged); cell clone_object(cell obj_); void primitive_clone(); + void primitive_become(); // profiler void init_profiler(); @@ -225,15 +229,27 @@ struct factor_vm void primitive_next_object(); void primitive_end_scan(); cell find_all_words(); - cell object_size(cell tagged); + + template + inline void each_object(Generation *gen, Iterator &iterator) + { + cell obj = gen->first_object(); + while(obj) + { + iterator(obj); + obj = gen->next_object_after(obj); + } + } template inline void each_object(Iterator &iterator) { - begin_scan(); - cell obj; - while(to_boolean(obj = next_object())) - iterator(obj); - end_scan(); + gc_off = true; + + each_object(data->tenured,iterator); + each_object(data->aging,iterator); + each_object(data->nursery,iterator); + + gc_off = false; } /* the write barrier must be called any time we are potentially storing a @@ -244,6 +260,13 @@ struct factor_vm *(char *)(decks_offset + ((cell)slot_ptr >> deck_bits)) = card_mark_mask; } + inline void write_barrier(object *obj, cell size) + { + char *start = (char *)obj; + for(cell offset = 0; offset < size; offset += card_size) + write_barrier((cell *)(start + offset)); + } + // gc void end_gc(); void start_gc_again(); @@ -264,7 +287,6 @@ struct factor_vm void primitive_minor_gc(); void primitive_full_gc(); void primitive_compact_gc(); - void primitive_become(); void inline_gc(cell *data_roots_base, cell data_roots_size); void primitive_enable_gc_events(); void primitive_disable_gc_events(); From 22c717616c924ed2281d372d1b527575685482fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Nov 2009 19:29:27 -0600 Subject: [PATCH 029/513] vm: speed up some bit twiddling on 32-bit --- basis/vm/vm.factor | 2 +- vm/bitwise_hacks.hpp | 59 +++++++++++++++++++---------------------- vm/mark_bits.hpp | 40 +++++++++++++++------------- vm/object_start_map.cpp | 7 ++++- 4 files changed, 55 insertions(+), 53 deletions(-) diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index ba057edffa..86ff4497b8 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -3,7 +3,7 @@ USING: classes.struct alien.c-types alien.syntax ; IN: vm -TYPEDEF: intptr_t cell +TYPEDEF: uintptr_t cell C-TYPE: context STRUCT: zone diff --git a/vm/bitwise_hacks.hpp b/vm/bitwise_hacks.hpp index dc685bb28c..8830e4f876 100644 --- a/vm/bitwise_hacks.hpp +++ b/vm/bitwise_hacks.hpp @@ -3,65 +3,60 @@ namespace factor /* These algorithms were snarfed from various places. I did not come up with them myself */ -inline cell popcount(u64 x) +inline cell popcount(cell x) { +#ifdef FACTOR_64 u64 k1 = 0x5555555555555555ll; u64 k2 = 0x3333333333333333ll; u64 k4 = 0x0f0f0f0f0f0f0f0fll; u64 kf = 0x0101010101010101ll; + cell ks = 56; +#else + u32 k1 = 0x55555555; + u32 k2 = 0x33333333; + u32 k4 = 0xf0f0f0f; + u32 kf = 0x1010101; + cell ks = 24; +#endif + x = x - ((x >> 1) & k1); // put count of each 2 bits into those 2 bits x = (x & k2) + ((x >> 2) & k2); // put count of each 4 bits into those 4 bits x = (x + (x >> 4)) & k4 ; // put count of each 8 bits into those 8 bits - x = (x * kf) >> 56; // returns 8 most significant bits of x + (x<<8) + (x<<16) + (x<<24) + ... + x = (x * kf) >> ks; // returns 8 most significant bits of x + (x<<8) + (x<<16) + (x<<24) + ... return (cell)x; } -inline cell log2(u64 x) +inline cell log2(cell x) { -#ifdef FACTOR_AMD64 +#if defined(FACTOR_X86) cell n; - asm ("bsr %1, %0;":"=r"(n):"r"((cell)x)); + asm ("bsr %1, %0;":"=r"(n):"r"(x)); +#elif defined(FACTOR_AMD64) + cell n; + asm ("bsr %1, %0;":"=r"(n):"r"(x)); #else cell n = 0; +#ifdef FACTOR_64 if (x >= (u64)1 << 32) { x >>= 32; n += 32; } - if (x >= (u64)1 << 16) { x >>= 16; n += 16; } - if (x >= (u64)1 << 8) { x >>= 8; n += 8; } - if (x >= (u64)1 << 4) { x >>= 4; n += 4; } - if (x >= (u64)1 << 2) { x >>= 2; n += 2; } - if (x >= (u64)1 << 1) { n += 1; } +#endif + if (x >= (u32)1 << 16) { x >>= 16; n += 16; } + if (x >= (u32)1 << 8) { x >>= 8; n += 8; } + if (x >= (u32)1 << 4) { x >>= 4; n += 4; } + if (x >= (u32)1 << 2) { x >>= 2; n += 2; } + if (x >= (u32)1 << 1) { n += 1; } #endif return n; } -inline cell log2(u16 x) -{ -#if defined(FACTOR_X86) || defined(FACTOR_AMD64) - cell n; - asm ("bsr %1, %0;":"=r"(n):"r"((cell)x)); -#else - cell n = 0; - if (x >= 1 << 8) { x >>= 8; n += 8; } - if (x >= 1 << 4) { x >>= 4; n += 4; } - if (x >= 1 << 2) { x >>= 2; n += 2; } - if (x >= 1 << 1) { n += 1; } -#endif - return n; -} - -inline cell rightmost_clear_bit(u64 x) +inline cell rightmost_clear_bit(cell x) { return log2(~x & (x + 1)); } -inline cell rightmost_set_bit(u64 x) +inline cell rightmost_set_bit(cell x) { return log2(x & -x); } -inline cell rightmost_set_bit(u16 x) -{ - return log2((u16)(x & -x)); -} - } diff --git a/vm/mark_bits.hpp b/vm/mark_bits.hpp index b54a2c9d46..d4b1dcda8d 100644 --- a/vm/mark_bits.hpp +++ b/vm/mark_bits.hpp @@ -2,18 +2,19 @@ namespace factor { const int block_granularity = 16; -const int forwarding_granularity = 64; +const int mark_bits_granularity = sizeof(cell) * 8; +const int mark_bits_mask = sizeof(cell) * 8 - 1; template struct mark_bits { cell size; cell start; cell bits_size; - u64 *marked; + cell *marked; cell *forwarding; void clear_mark_bits() { - memset(marked,0,bits_size * sizeof(u64)); + memset(marked,0,bits_size * sizeof(cell)); } void clear_forwarding() @@ -24,8 +25,8 @@ template struct mark_bits { explicit mark_bits(cell size_, cell start_) : size(size_), start(start_), - bits_size(size / block_granularity / forwarding_granularity), - marked(new u64[bits_size]), + bits_size(size / block_granularity / mark_bits_granularity), + marked(new cell[bits_size]), forwarding(new cell[bits_size]) { clear_mark_bits(); @@ -53,15 +54,15 @@ template struct mark_bits { std::pair bitmap_deref(Block *address) { cell line_number = block_line(address); - cell word_index = (line_number >> 6); - cell word_shift = (line_number & 63); + cell word_index = (line_number / mark_bits_granularity); + cell word_shift = (line_number & mark_bits_mask); return std::make_pair(word_index,word_shift); } - bool bitmap_elt(u64 *bits, Block *address) + bool bitmap_elt(cell *bits, Block *address) { std::pair position = bitmap_deref(address); - return (bits[position.first] & ((u64)1 << position.second)) != 0; + return (bits[position.first] & ((cell)1 << position.second)) != 0; } Block *next_block_after(Block *block) @@ -69,13 +70,13 @@ template struct mark_bits { return (Block *)((cell)block + block->size()); } - void set_bitmap_range(u64 *bits, Block *address) + void set_bitmap_range(cell *bits, Block *address) { std::pair start = bitmap_deref(address); std::pair end = bitmap_deref(next_block_after(address)); - u64 start_mask = ((u64)1 << start.second) - 1; - u64 end_mask = ((u64)1 << end.second) - 1; + cell start_mask = ((cell)1 << start.second) - 1; + cell end_mask = ((cell)1 << end.second) - 1; if(start.first == end.first) bits[start.first] |= start_mask ^ end_mask; @@ -87,7 +88,7 @@ template struct mark_bits { bits[start.first] |= ~start_mask; for(cell index = start.first + 1; index < end.first; index++) - bits[index] = (u64)-1; + bits[index] = (cell)-1; if(end_mask != 0) { @@ -121,7 +122,8 @@ template struct mark_bits { } } - /* We have the popcount for every 64 entries; look up and compute the rest */ + /* We have the popcount for every mark_bits_granularity entries; look + up and compute the rest */ Block *forward_block(Block *original) { #ifdef FACTOR_DEBUG @@ -130,7 +132,7 @@ template struct mark_bits { std::pair position = bitmap_deref(original); cell approx_popcount = forwarding[position.first]; - u64 mask = ((u64)1 << position.second) - 1; + cell mask = ((cell)1 << position.second) - 1; cell new_line_number = approx_popcount + popcount(marked[position.first] & mask); Block *new_block = line_block(new_line_number); @@ -147,13 +149,13 @@ template struct mark_bits { for(cell index = position.first; index < bits_size; index++) { - u64 mask = ((s64)marked[index] >> bit_index); + cell mask = ((fixnum)marked[index] >> bit_index); if(~mask) { /* Found an unmarked block on this page. Stop, it's hammer time */ cell clear_bit = rightmost_clear_bit(mask); - return line_block(index * 64 + bit_index + clear_bit); + return line_block(index * mark_bits_granularity + bit_index + clear_bit); } else { @@ -174,13 +176,13 @@ template struct mark_bits { for(cell index = position.first; index < bits_size; index++) { - u64 mask = (marked[index] >> bit_index); + cell mask = (marked[index] >> bit_index); if(mask) { /* Found an marked block on this page. Stop, it's hammer time */ cell set_bit = rightmost_set_bit(mask); - return line_block(index * 64 + bit_index + set_bit); + return line_block(index * mark_bits_granularity + bit_index + set_bit); } else { diff --git a/vm/object_start_map.cpp b/vm/object_start_map.cpp index 724f365e79..3159313dd5 100644 --- a/vm/object_start_map.cpp +++ b/vm/object_start_map.cpp @@ -79,11 +79,16 @@ void object_start_map::update_for_sweep(mark_bits *state) { for(cell index = 0; index < state->bits_size; index++) { - u64 mask = state->marked[index]; + cell mask = state->marked[index]; +#ifdef FACTOR_64 update_card_for_sweep(index * 4, mask & 0xffff); update_card_for_sweep(index * 4 + 1, (mask >> 16) & 0xffff); update_card_for_sweep(index * 4 + 2, (mask >> 32) & 0xffff); update_card_for_sweep(index * 4 + 3, (mask >> 48) & 0xffff); +#else + update_card_for_sweep(index * 2, mask & 0xffff); + update_card_for_sweep(index * 2 + 1, (mask >> 16) & 0xffff); +#endif } } From 18a2ce1f8cd0208af1ccd0e2b942ddd84ac8b991 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Nov 2009 19:32:26 -0600 Subject: [PATCH 030/513] vm: remove some dead code --- vm/code_heap.cpp | 6 ----- vm/free_list_allocator.hpp | 54 -------------------------------------- vm/vm.hpp | 1 - 3 files changed, 61 deletions(-) diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 44a7a54dfa..98da158b16 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -135,12 +135,6 @@ struct code_heap_relocator { } }; -void factor_vm::relocate_code_heap() -{ - code_heap_relocator relocator(this); - code->allocator->sweep(relocator); -} - void factor_vm::primitive_modify_code_heap() { data_root alist(dpop(),this); diff --git a/vm/free_list_allocator.hpp b/vm/free_list_allocator.hpp index a4801daa72..62e4e09758 100644 --- a/vm/free_list_allocator.hpp +++ b/vm/free_list_allocator.hpp @@ -23,7 +23,6 @@ template struct free_list_allocator { cell largest_free_block(); cell free_block_count(); void sweep(); - template void sweep(Iterator &iter); template void compact(Iterator &iter, Sizer &sizer); template void iterate(Iterator &iter, Sizer &sizer); template void iterate(Iterator &iter); @@ -152,59 +151,6 @@ void free_list_allocator::sweep() } } -template -template -void free_list_allocator::sweep(Iterator &iter) -{ - free_blocks.clear_free_list(); - - Block *prev = NULL; - Block *scan = this->first_block(); - Block *end = this->last_block(); - - while(scan != end) - { - cell size = scan->size(); - - if(scan->free_p()) - { - if(prev && prev->free_p()) - { - free_heap_block *free_prev = (free_heap_block *)prev; - free_prev->make_free(free_prev->size() + size); - } - else - prev = scan; - } - else if(this->state.marked_p(scan)) - { - if(prev && prev->free_p()) - free_blocks.add_to_free_list((free_heap_block *)prev); - prev = scan; - iter(scan,size); - } - else - { - if(prev && prev->free_p()) - { - free_heap_block *free_prev = (free_heap_block *)prev; - free_prev->make_free(free_prev->size() + size); - } - else - { - free_heap_block *free_block = (free_heap_block *)scan; - free_block->make_free(size); - prev = scan; - } - } - - scan = (Block *)((cell)scan + size); - } - - if(prev && prev->free_p()) - free_blocks.add_to_free_list((free_heap_block *)prev); -} - template struct heap_compactor { mark_bits *state; char *address; diff --git a/vm/vm.hpp b/vm/vm.hpp index 0a65873f6c..81dd30000e 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -530,7 +530,6 @@ struct factor_vm void jit_compile_word(cell word_, cell def_, bool relocate); void update_code_heap_words(); void update_code_heap_words_and_literals(); - void relocate_code_heap(); void primitive_modify_code_heap(); code_heap_room code_room(); void primitive_code_room(); From 4061951d1c94bd9cd0db6500e95506c80122c297 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Nov 2009 21:49:03 -0600 Subject: [PATCH 031/513] vm: simpler object space implementation. begin-scan/next-object/end-scan primitives replaced by a single all-instances primitive --- .../known-words/known-words.factor | 6 +- basis/tools/memory/memory-docs.factor | 7 +- core/bootstrap/primitives.factor | 4 +- core/bootstrap/stage1.factor | 16 +--- core/memory/memory-docs.factor | 35 +------ core/memory/memory.factor | 19 +--- vm/compaction.cpp | 4 +- vm/data_heap.cpp | 92 ++++++------------- vm/debug.cpp | 21 +++-- vm/image.cpp | 2 +- vm/objects.cpp | 5 +- vm/primitives.cpp | 8 +- vm/vm.hpp | 20 ++-- 13 files changed, 64 insertions(+), 175 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 2c0ce853aa..26b122257f 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -623,11 +623,7 @@ M: bad-executable summary \ { integer object } { array } define-primitive \ make-flushable -\ begin-scan { } { } define-primitive - -\ next-object { } { object } define-primitive - -\ end-scan { } { } define-primitive +\ all-instances { } { array } define-primitive \ size { object } { fixnum } define-primitive \ size make-flushable diff --git a/basis/tools/memory/memory-docs.factor b/basis/tools/memory/memory-docs.factor index f729e8945f..b18396538f 100644 --- a/basis/tools/memory/memory-docs.factor +++ b/basis/tools/memory/memory-docs.factor @@ -13,11 +13,8 @@ ARTICLE: "tools.memory" "Object memory tools" data-room code-room } -"There are a pair of combinators, analogous to " { $link each } " and " { $link filter } ", which operate on the entire collection of objects in the object heap:" -{ $subsections - each-object - instances -} +"A combinator to get objects from the heap:" +{ $subsections instances } "You can check an object's the heap memory usage:" { $subsections size } "The garbage collector can be invoked manually:" diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 5d4144e354..07e5eee1c3 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -473,9 +473,7 @@ tuple { "resize-array" "arrays" (( n array -- newarray )) } { "resize-string" "strings" (( n str -- newstr )) } { "" "arrays" (( n elt -- array )) } - { "begin-scan" "memory" (( -- )) } - { "next-object" "memory" (( -- obj )) } - { "end-scan" "memory" (( -- )) } + { "all-instances" "memory" (( -- array )) } { "size" "memory" (( obj -- n )) } { "die" "kernel" (( -- )) } { "(fopen)" "io.streams.c" (( path mode -- alien )) } diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 9c84904ff7..1a2cdf6a70 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -17,25 +17,19 @@ load-help? off ! Create a boot quotation for the target [ [ - ! Rehash hashtables, since bootstrap.image creates them - ! using the host image's hashing algorithms. We don't - ! use each-object here since the catch stack isn't yet - ! set up. - gc - begin-scan - [ hashtable? ] pusher [ (each-object) ] dip - end-scan - [ rehash ] each + ! Rehash hashtables first, since bootstrap.image creates + ! them using the host image's hashing algorithms. + [ hashtable? ] instances [ rehash ] each boot ] % "math.integers" require "math.floats" require "memory" require - + "io.streams.c" require "vocabs.loader" require - + "syntax" require "bootstrap.layouts" require diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index d40705a531..d1832b41ba 100644 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -2,31 +2,9 @@ USING: help.markup help.syntax debugger sequences kernel quotations math ; IN: memory -HELP: begin-scan ( -- ) -{ $description "Disables the garbage collector and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects." -$nl -"This word must always be paired with a call to " { $link end-scan } "." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: next-object ( -- obj ) -{ $values { "obj" object } } -{ $description "Outputs the object at the heap scan pointer, and then advances the heap scan pointer. If the end of the heap has been reached, outputs " { $link f } ". This is unambiguous since the " { $link f } " object is tagged immediate and not actually stored in the heap." } -{ $errors "Throws a " { $link heap-scan-error. } " if called outside a " { $link begin-scan } "/" { $link end-scan } " pair." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: end-scan ( -- ) -{ $description "Finishes a heap iteration by re-enabling the garbage collector. This word must always be paired with a call to " { $link begin-scan } "." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: each-object -{ $values { "quot" { $quotation "( obj -- )" } } } -{ $description "Applies a quotation to each object in the heap. The garbage collector is switched off while this combinator runs, so the given quotation must not allocate too much memory." } -{ $notes "This word is the low-level facility used to implement the " { $link instances } " word." } ; - HELP: instances { $values { "quot" { $quotation "( obj -- ? )" } } { "seq" "a fresh sequence" } } -{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." } -{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ; +{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." } ; HELP: gc ( -- ) { $description "Performs a full garbage collection." } ; @@ -56,17 +34,6 @@ HELP: save-image-and-exit ( path -- ) HELP: save { $description "Saves a snapshot of the heap to the current image file." } ; -HELP: count-instances -{ $values - { "quot" quotation } - { "n" integer } } -{ $description "Applies the predicate quotation to each object in the heap and returns the number of objects that match. Since this word uses " { $link each-object } " with the garbage collector switched off, avoid allocating too much memory in the quotation." } -{ $examples { $unchecked-example - "USING: memory words prettyprint ;" - "[ word? ] count-instances ." - "24210" -} } ; - ARTICLE: "images" "Images" "Factor has the ability to save the entire state of the system into an " { $emphasis "image file" } ". The image contains a complete dump of all data and code in the current Factor instance." { $subsections diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 1c61e33d83..4ab68a1ef1 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -1,26 +1,11 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences vectors arrays system math +USING: kernel continuations sequences system io.backend alien.strings memory.private ; IN: memory -: (each-object) ( quot: ( obj -- ) -- ) - next-object dup [ - swap [ call ] keep (each-object) - ] [ 2drop ] if ; inline recursive - -: each-object ( quot -- ) - gc begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline - -: count-instances ( quot -- n ) - 0 swap [ 1 0 ? + ] compose each-object ; inline - : instances ( quot -- seq ) - #! To ensure we don't need to grow the vector while scanning - #! the heap, we do two scans, the first one just counts the - #! number of objects that satisfy the predicate. - [ count-instances 100 + ] keep swap - [ [ push-if ] 2curry each-object ] keep >array ; inline + [ all-instances ] dip filter ; inline : save-image ( path -- ) normalize-path native-string>alien (save-image) ; diff --git a/vm/compaction.cpp b/vm/compaction.cpp index 10e37db263..1c9dfc0def 100644 --- a/vm/compaction.cpp +++ b/vm/compaction.cpp @@ -150,9 +150,9 @@ struct object_code_block_updater { explicit object_code_block_updater(code_block_visitor > *visitor_) : visitor(visitor_) {} - void operator()(cell obj) + void operator()(object *obj) { - visitor->visit_object_code_block(tagged(obj).untagged()); + visitor->visit_object_code_block(obj); } }; diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index f9771d47a0..9791c33892 100755 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -226,82 +226,42 @@ void factor_vm::primitive_data_room() dpush(tag(byte_array_from_value(&room))); } -/* Disables GC and activates next-object ( -- obj ) primitive */ -void factor_vm::begin_scan() +struct object_accumulator { + cell type; + std::vector objects; + + explicit object_accumulator(cell type_) : type(type_) {} + + void operator()(object *obj) + { + if(type == TYPE_COUNT || obj->h.hi_tag() == type) + objects.push_back(tag_dynamic(obj)); + } +}; + +cell factor_vm::instances(cell type) { - heap_scan_ptr = data->tenured->first_object(); + object_accumulator accum(type); + each_object(accum); + cell object_count = accum.objects.size(); + gc_off = true; -} - -void factor_vm::end_scan() -{ + array *objects = allot_array(object_count,false_object); + memcpy(objects->data(),&accum.objects[0],object_count * sizeof(cell)); gc_off = false; + + return tag(objects); } -void factor_vm::primitive_begin_scan() +void factor_vm::primitive_all_instances() { - begin_scan(); + primitive_full_gc(); + dpush(instances(TYPE_COUNT)); } -cell factor_vm::next_object() -{ - if(!gc_off) - general_error(ERROR_HEAP_SCAN,false_object,false_object,NULL); - - if(heap_scan_ptr) - { - cell current = heap_scan_ptr; - heap_scan_ptr = data->tenured->next_object_after(heap_scan_ptr); - return tag_dynamic((object *)current); - } - else - return false_object; -} - -/* Push object at heap scan cursor and advance; pushes f when done */ -void factor_vm::primitive_next_object() -{ - dpush(next_object()); -} - -/* Re-enables GC */ -void factor_vm::primitive_end_scan() -{ - gc_off = false; -} - -struct word_counter { - cell count; - - explicit word_counter() : count(0) {} - - void operator()(cell obj) - { - if(tagged(obj).type_p(WORD_TYPE)) - count++; - } -}; - -struct word_accumulator { - growable_array words; - - explicit word_accumulator(int count,factor_vm *vm) : words(vm,count) {} - - void operator()(cell obj) - { - if(tagged(obj).type_p(WORD_TYPE)) - words.add(obj); - } -}; - cell factor_vm::find_all_words() { - word_counter counter; - each_object(counter); - word_accumulator accum(counter.count,this); - each_object(accum); - accum.words.trim(); - return accum.words.elements.value(); + return instances(WORD_TYPE); } } diff --git a/vm/debug.cpp b/vm/debug.cpp index fee3e6a257..df23615419 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -241,12 +241,12 @@ struct object_dumper { explicit object_dumper(factor_vm *parent_, cell type_) : parent(parent_), type(type_) {} - void operator()(cell obj) + void operator()(object *obj) { - if(type == TYPE_COUNT || tagged(obj).type_p(type)) + if(type == TYPE_COUNT || obj->h.hi_tag() == type) { - std::cout << padded_address(obj) << " "; - parent->print_nested_obj(obj,2); + std::cout << padded_address((cell)obj) << " "; + parent->print_nested_obj(tag_dynamic(obj),2); std::cout << std::endl; } } @@ -260,18 +260,19 @@ void factor_vm::dump_objects(cell type) } struct data_reference_slot_visitor { - cell look_for, obj; + cell look_for; + object *obj; factor_vm *parent; - explicit data_reference_slot_visitor(cell look_for_, cell obj_, factor_vm *parent_) : + explicit data_reference_slot_visitor(cell look_for_, object *obj_, factor_vm *parent_) : look_for(look_for_), obj(obj_), parent(parent_) { } void operator()(cell *scan) { if(look_for == *scan) { - std::cout << padded_address(obj) << " "; - parent->print_nested_obj(obj,2); + std::cout << padded_address((cell)obj) << " "; + parent->print_nested_obj(tag_dynamic(obj),2); std::cout << std::endl; } } @@ -284,10 +285,10 @@ struct data_reference_object_visitor { explicit data_reference_object_visitor(cell look_for_, factor_vm *parent_) : look_for(look_for_), parent(parent_) {} - void operator()(cell obj) + void operator()(object *obj) { data_reference_slot_visitor visitor(look_for,obj,parent); - parent->do_slots(UNTAG(obj),visitor); + parent->do_slots(obj,visitor); } }; diff --git a/vm/image.cpp b/vm/image.cpp index b3a9eae7a5..be6cd813fc 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -154,7 +154,7 @@ void factor_vm::relocate_object(object *object, else { object_fixupper fixupper(this,data_relocation_base); - do_slots((cell)object,fixupper); + do_slots(object,fixupper); switch(hi_tag) { diff --git a/vm/objects.cpp b/vm/objects.cpp index ad76d7c1b6..fa2446d54f 100644 --- a/vm/objects.cpp +++ b/vm/objects.cpp @@ -83,9 +83,9 @@ struct object_become_visitor { explicit object_become_visitor(slot_visitor *workhorse_) : workhorse(workhorse_) {} - void operator()(cell obj) + void operator()(object *obj) { - workhorse->visit_slots(tagged(obj).untagged()); + workhorse->visit_slots(obj); } }; @@ -123,6 +123,7 @@ void factor_vm::primitive_become() /* Since we may have introduced old->new references, need to revisit all objects on a minor GC. */ data->mark_all_cards(); + primitive_minor_gc(); /* If a word's definition quotation was in old_objects and the quotation in new_objects is not compiled, we might leak memory diff --git a/vm/primitives.cpp b/vm/primitives.cpp index b8d909fbe8..013250a502 100644 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -82,9 +82,7 @@ PRIMITIVE_FORWARD(set_string_nth_slow) PRIMITIVE_FORWARD(resize_array) PRIMITIVE_FORWARD(resize_string) PRIMITIVE_FORWARD(array) -PRIMITIVE_FORWARD(begin_scan) -PRIMITIVE_FORWARD(next_object) -PRIMITIVE_FORWARD(end_scan) +PRIMITIVE_FORWARD(all_instances) PRIMITIVE_FORWARD(size) PRIMITIVE_FORWARD(die) PRIMITIVE_FORWARD(fopen) @@ -244,9 +242,7 @@ const primitive_type primitives[] = { primitive_resize_array, primitive_resize_string, primitive_array, - primitive_begin_scan, - primitive_next_object, - primitive_end_scan, + primitive_all_instances, primitive_size, primitive_die, primitive_fopen, diff --git a/vm/vm.hpp b/vm/vm.hpp index 81dd30000e..b89dda4085 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -40,10 +40,6 @@ struct factor_vm unsigned int signal_fpu_status; stack_frame *signal_callstack_top; - /* A heap walk allows useful things to be done, like finding all - references to an object for debugging purposes. */ - cell heap_scan_ptr; - /* GC is off during heap walking */ bool gc_off; @@ -224,10 +220,8 @@ struct factor_vm void primitive_data_room(); void begin_scan(); void end_scan(); - void primitive_begin_scan(); - cell next_object(); - void primitive_next_object(); - void primitive_end_scan(); + cell instances(cell type); + void primitive_all_instances(); cell find_all_words(); template @@ -236,7 +230,7 @@ struct factor_vm cell obj = gen->first_object(); while(obj) { - iterator(obj); + iterator((object *)obj); obj = gen->next_object_after(obj); } } @@ -589,11 +583,11 @@ struct factor_vm /* Every object has a regular representation in the runtime, which makes GC much simpler. Every slot of the object until binary_payload_start is a pointer to some other object. */ - template void do_slots(cell obj, Iterator &iter) + template void do_slots(object *obj, Iterator &iter) { - cell scan = obj; - cell payload_start = ((object *)obj)->binary_payload_start(); - cell end = obj + payload_start; + cell scan = (cell)obj; + cell payload_start = obj->binary_payload_start(); + cell end = scan + payload_start; scan += sizeof(cell); From c08d325132fb9469276a0e5ca7f824d70fc39bb0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Nov 2009 21:52:31 -0600 Subject: [PATCH 032/513] Remove unused error from VM --- basis/debugger/debugger-docs.factor | 3 --- basis/debugger/debugger.factor | 18 +++++++----------- vm/errors.hpp | 1 - 3 files changed, 7 insertions(+), 15 deletions(-) diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index 87e70d69e7..4bcd9c5b78 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -129,9 +129,6 @@ HELP: c-string-error. HELP: ffi-error. { $error-description "Thrown by " { $link dlopen } " and " { $link dlsym } " if a problem occurs while loading a native library or looking up a symbol. See " { $link "alien" } "." } ; -HELP: heap-scan-error. -{ $error-description "Thrown if " { $link next-object } " is called outside of a " { $link begin-scan } "/" { $link end-scan } " pair." } ; - HELP: undefined-symbol-error. { $error-description "Thrown if a previously-compiled " { $link alien-invoke } " call refers to a native library symbol which no longer exists." } ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 690e631e81..f1e23b18f5 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -103,9 +103,6 @@ HOOK: signal-error. os ( obj -- ) : ffi-error. ( obj -- ) "FFI error" print drop ; -: heap-scan-error. ( obj -- ) - "Cannot do next-object outside begin/end-scan" print drop ; - : undefined-symbol-error. ( obj -- ) "The image refers to a library or symbol that was not found at load time" print drop ; @@ -148,14 +145,13 @@ PREDICATE: vm-error < array { 6 [ array-size-error. ] } { 7 [ c-string-error. ] } { 8 [ ffi-error. ] } - { 9 [ heap-scan-error. ] } - { 10 [ undefined-symbol-error. ] } - { 11 [ datastack-underflow. ] } - { 12 [ datastack-overflow. ] } - { 13 [ retainstack-underflow. ] } - { 14 [ retainstack-overflow. ] } - { 15 [ memory-error. ] } - { 16 [ fp-trap-error. ] } + { 9 [ undefined-symbol-error. ] } + { 10 [ datastack-underflow. ] } + { 11 [ datastack-overflow. ] } + { 12 [ retainstack-underflow. ] } + { 13 [ retainstack-overflow. ] } + { 14 [ memory-error. ] } + { 15 [ fp-trap-error. ] } } ; inline M: vm-error summary drop "VM error" ; diff --git a/vm/errors.hpp b/vm/errors.hpp index c1ea2e1907..4b237e03a0 100755 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -13,7 +13,6 @@ enum vm_error_type ERROR_ARRAY_SIZE, ERROR_C_STRING, ERROR_FFI, - ERROR_HEAP_SCAN, ERROR_UNDEFINED_SYMBOL, ERROR_DS_UNDERFLOW, ERROR_DS_OVERFLOW, From a5957b188d770a60d86e64e0e998f0dfc8c28649 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 22:22:21 -0600 Subject: [PATCH 033/513] nip most uses of tuck from extra --- .../benchmark/knucleotide/knucleotide.factor | 15 ++++++-------- extra/curses/curses.factor | 6 ++++-- extra/decimals/decimals.factor | 2 +- extra/ecdsa/ecdsa.factor | 2 +- extra/io/serial/windows/windows.factor | 3 +-- extra/jamshred/gl/gl.factor | 7 ++++--- extra/jamshred/oint/oint.factor | 4 ++-- extra/jamshred/player/player.factor | 5 +++-- extra/jamshred/tunnel/tunnel.factor | 7 ++++--- extra/joystick-demo/joystick-demo.factor | 12 +++++------ extra/key-handlers/key-handlers.factor | 2 +- extra/koszul/koszul.factor | 14 ++++++------- .../affine-transforms.factor | 2 +- extra/math/binpack/binpack.factor | 12 ++++++----- extra/math/finance/finance.factor | 2 +- extra/math/quadratic/quadratic.factor | 4 ++-- extra/models/combinators/combinators.factor | 4 ++-- extra/mongodb/msg/msg.factor | 2 +- extra/mongodb/tuple/state/state.factor | 2 +- .../parser-combinators.factor | 12 ++++++----- extra/project-euler/002/002.factor | 8 ++++---- extra/project-euler/100/100.factor | 15 +++++++------- extra/project-euler/117/117.factor | 2 +- extra/project-euler/ave-time/ave-time.factor | 4 ++-- extra/quadtrees/quadtrees.factor | 17 ++++++++-------- .../blum-blum-shub-tests.factor | 2 +- extra/rot13/rot13.factor | 2 +- extra/sequences/abbrev/abbrev.factor | 2 +- extra/sequences/modified/modified.factor | 10 +++++----- extra/space-invaders/space-invaders.factor | 20 ++++++++----------- extra/spider/spider.factor | 2 +- extra/tetris/piece/piece.factor | 2 +- extra/trees/avl/avl.factor | 2 +- extra/trees/splay/splay.factor | 2 +- extra/trees/trees.factor | 3 ++- extra/ui/gadgets/lists/lists.factor | 10 +++++----- extra/units/units-tests.factor | 2 +- extra/usa-cities/usa-cities.factor | 2 +- 38 files changed, 113 insertions(+), 113 deletions(-) diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index fb4f17cca5..a28a676b90 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -1,4 +1,4 @@ -USING: kernel io io.files splitting strings io.encodings.ascii +USING: kernel locals io io.files splitting strings io.encodings.ascii hashtables sequences assocs math namespaces prettyprint math.parser combinators arrays sorting unicode.case ; @@ -21,10 +21,7 @@ IN: benchmark.knucleotide CHAR: \n swap remove >upper ; : tally ( x exemplar -- b ) - clone tuck - [ - [ [ 1 + ] [ 1 ] if* ] change-at - ] curry each ; + clone [ [ inc-at ] curry each ] keep ; : small-groups ( x n -- b ) swap @@ -42,10 +39,10 @@ IN: benchmark.knucleotide ] each drop ; -: handle-n ( inputs x -- ) - tuck length - small-groups H{ } tally - at [ 0 ] unless* +:: handle-n ( inputs x -- ) + inputs x length small-groups :> groups + groups H{ } tally :> b + x b at [ 0 ] unless* number>string 8 CHAR: \s pad-tail write ; : process-input ( input -- ) diff --git a/extra/curses/curses.factor b/extra/curses/curses.factor index 4d6c77fd23..23adf31700 100644 --- a/extra/curses/curses.factor +++ b/extra/curses/curses.factor @@ -123,8 +123,10 @@ PRIVATE> : curses-writef ( window string -- ) [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ; -: (curses-read) ( window-ptr n encoding -- string ) - [ [ tuck ] keep wgetnstr curses-error ] dip alien>string ; +:: (curses-read) ( window-ptr n encoding -- string ) + n :> buf + window-ptr buf n wgetnstr curses-error + buf encoding alien>string ; : curses-read ( window n -- string ) utf8 [ window-ptr ] 2dip (curses-read) ; diff --git a/extra/decimals/decimals.factor b/extra/decimals/decimals.factor index cc12b4fed1..d5c62fee5e 100644 --- a/extra/decimals/decimals.factor +++ b/extra/decimals/decimals.factor @@ -37,7 +37,7 @@ SYNTAX: D: parse-decimal suffix! ; ] 2bi ; : scale-decimals ( D1 D2 -- D1' D2' ) - scale-mantissas tuck [ ] 2dip ; + scale-mantissas [ ] curry bi@ ; ERROR: decimal-types-expected d1 d2 ; diff --git a/extra/ecdsa/ecdsa.factor b/extra/ecdsa/ecdsa.factor index c4d889991e..8e285a0904 100644 --- a/extra/ecdsa/ecdsa.factor +++ b/extra/ecdsa/ecdsa.factor @@ -50,7 +50,7 @@ PRIVATE> : get-private-key ( -- bin/f ) ec-key-handle EC_KEY_get0_private_key - dup [ dup BN_num_bits bits>bytes tuck BN_bn2bin drop ] when ; + dup [ dup BN_num_bits bits>bytes [ BN_bn2bin drop ] keep ] when ; :: get-public-key ( -- bin/f ) ec-key-handle :> KEY diff --git a/extra/io/serial/windows/windows.factor b/extra/io/serial/windows/windows.factor index 551fd16b33..645e4939de 100755 --- a/extra/io/serial/windows/windows.factor +++ b/extra/io/serial/windows/windows.factor @@ -11,8 +11,7 @@ IN: io.serial.windows : get-comm-state ( duplex -- dcb ) in>> handle>> - DCB tuck - GetCommState win32-error=0/f ; + DCB [ GetCommState win32-error=0/f ] keep ; : set-comm-state ( duplex dcb -- ) [ in>> handle>> ] dip diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index 60e9e39d9f..48bf2b693a 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -3,7 +3,7 @@ USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu -opengl.demo-support sequences specialized-arrays ; +opengl.demo-support sequences specialized-arrays locals ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: jamshred.gl @@ -50,8 +50,9 @@ CONSTANT: wall-drawing-offset 0.15 over color>> gl-color segment-vertex-and-normal gl-normal gl-vertex ; -: draw-vertex-pair ( theta next-segment segment -- ) - rot tuck draw-segment-vertex draw-segment-vertex ; +:: draw-vertex-pair ( theta next-segment segment -- ) + segment theta draw-segment-vertex + next-segment theta draw-segment-vertex ; : draw-segment ( next-segment segment -- ) GL_QUAD_STRIP [ diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index ae72bd847c..b1644ef443 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -53,13 +53,13 @@ C: oint : scalar-projection ( v1 v2 -- n ) #! the scalar projection of v1 onto v2 - tuck v. swap norm / ; + [ v. ] [ norm ] bi / ; : proj-perp ( u v -- w ) dupd proj v- ; : perpendicular-distance ( oint oint -- distance ) - tuck distance-vector swap 2dup left>> scalar-projection abs + [ distance-vector ] keep 2dup left>> scalar-projection abs -rot up>> scalar-projection abs + ; :: reflect ( v n -- v' ) diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index baeacd750b..ecce29180c 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -31,8 +31,9 @@ CONSTANT: max-speed 30.0 forward-pivot ; : to-tunnel-start ( player -- ) - [ tunnel>> first dup location>> ] - [ tuck (>>location) (>>nearest-segment) ] bi ; + dup tunnel>> first + [ >>nearest-segment ] + [ location>> >>location ] bi drop ; : play-in-tunnel ( player segments -- ) >>tunnel to-tunnel-start ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index e7285dcbbc..7f8646b778 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -63,9 +63,10 @@ CONSTANT: default-segment-radius 1 #! valid values [ '[ _ clamp-length ] bi@ ] keep ; -: nearer-segment ( segment segment oint -- segment ) - #! return whichever of the two segments is nearer to the oint - [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ; +:: nearer-segment ( seg-a seg-b oint -- segment ) + seg-a oint distance + seg-b oint distance < + seg-a seg-b ? ; : (find-nearest-segment) ( nearest next oint -- nearest ? ) #! find the nearest of 'next' and 'nearest' to 'oint', and return diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor index 90e28594e7..6ea1dc5633 100755 --- a/extra/joystick-demo/joystick-demo.factor +++ b/extra/joystick-demo/joystick-demo.factor @@ -50,10 +50,10 @@ CONSTANT: pov-polygons [ [ 0.0 ] unless* ] tri@ [ (xy>loc) ] dip (z>loc) ; -: move-axis ( gadget x y z -- ) - (xyz>loc) rot tuck - [ indicator>> (>>loc) ] - [ z-indicator>> (>>loc) ] 2bi* ; +:: move-axis ( gadget x y z -- ) + x y z (xyz>loc) :> ( xy z ) + xy gadget indicator>> (>>loc) + z gadget z-indicator>> (>>loc) ; : move-pov ( gadget pov -- ) swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ] @@ -82,10 +82,10 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ; [ >>controller ] [ product-string