steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Imported https://downloads.factorcode.org/releases/0.82/Factor-0.82.zip

release import-0.82
nomennescio 2019-10-18 15:04:56 +02:00
parent 8038e4cb14 f5efb9635e
commit 37fbc8f959
182 changed files with 4059 additions and 3409 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
Makefile
View File

@ -3,8 +3,8 @@ CC = gcc
BINARY = f
IMAGE = factor.image
BUNDLE = Factor.app
DISK_IMAGE_DIR = Factor-0.81
DISK_IMAGE = Factor-0.81.dmg
DISK_IMAGE_DIR = Factor-0.82
DISK_IMAGE = Factor-0.82.dmg
ifdef DEBUG
DEFAULT_CFLAGS = -g
@ -110,13 +110,16 @@ macosx.app:
mkdir -p $(BUNDLE)/Contents/Resources/fonts/
cp -R fonts/*.ttf $(BUNDLE)/Contents/Resources/fonts/
find doc library contrib \( -name '*.factor' \
chmod +x cp_dir
find doc library contrib examples \( -name '*.factor' \
-o -name '*.facts' \
-o -name '*.txt' \
-o -name '*.html' \
-o -name '*.js' \) \
-exec ./cp_dir {} $(BUNDLE)/Contents/Resources/{} \;
cp version.factor $(BUNDLE)/Contents/Resources/
cp $(IMAGE) $(BUNDLE)/Contents/Resources/factor.image
install_name_tool \
@ -128,7 +131,7 @@ macosx.app:
Factor.app/Contents/MacOS/Factor
macosx.dmg:
rm $(DISK_IMAGE)
rm -f $(DISK_IMAGE)
rm -rf $(DISK_IMAGE_DIR)
mkdir $(DISK_IMAGE_DIR)
cp -R $(BUNDLE) $(DISK_IMAGE_DIR)/$(BUNDLE)

105
README.txt
View File

@ -4,6 +4,19 @@ The Factor programming language
This file covers installation and basic usage of the Factor
implementation. It is not an introduction to the language itself.
* Contents
- Platform support
- Compiling Factor
- Building Factor
- Running Factor on Unix with X11
- Running Factor on Mac OS X
- Running Factor on Windows
- Source organization
- Learning Factor
- Community
- Credits
* Platform support
Factor is fully supported on the following platforms:
@ -28,9 +41,8 @@ Other platforms are not supported.
The Factor runtime is written in C, and is built with GNU make and gcc.
Note that on x86 systems, Factor _cannot_ be compiled with gcc 3.3. This
is due to a bug in gcc and there is nothing we can do about it. Please
use gcc 2.95, 3.4, or 4.0.
Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
3.3 or earlier.
Run 'make' (or 'gmake' on non-Linux platforms) with one of the following
parameters to build the Factor runtime:
@ -48,9 +60,9 @@ The following options can be given to make:
DEBUG=1
The former allows optimization flags to be specified, for example
"-march=pentium4 -ffast-math -O3". Optimization flags can make a *huge*
difference in Factor's performance, so willing hackers should
experiment.
"-march=pentium4 -ffast-math -O3". Nowadays most of the hard work is
done by Factor compiled code, so optimizing the runtime is not that
important. Usually the defaults are fine.
The DEBUG flag disables optimization and builds an executable with
debug symbols. This is probably only of interest to people intending to
@ -85,72 +97,69 @@ completes, a 'factor.image' file will be generated. Note that this image
is both CPU and OS-specific, so in general cannot be shared between
machines.
* Running Factor
* Running Factor on Unix with X11
To run the Factor system, issue the following command:
On Unix, Factor can either run a graphical user interface using X11, or
a terminal listener.
If your DISPLAY environment variable is set, the UI will start
automatically:
./f factor.image
This will start the interactive listener where Factor expressions may
be entered.
To run an interactive terminal listener:
To run the graphical user interface, issue the following command:
./f factor.image -shell=tty
./f factor.image -shell=ui
If you're inside a terminal session, you can start the UI with one of
the following two commands:
Note that on Windows, this is the default.
ui
[ ui ] in-thread
The latter keeps the terminal listener running.
On Unix, this might fail if the SDL libraries are not installed, or are
installed under unconventional names. This can be solved by explicitly
naming the libraries during bootstrap, as in the next section.
* Running Factor on Mac OS X
* Setting up SDL libraries for use with Factor
On Mac OS X, a Cocoa UI is available in addition to the terminal
listener.
The Windows binary package for Factor includes all prerequisite DLLs.
On Unix, you need recent versions of SDL and FreeType.
The 'f' executable runs the terminal listener:
If you have installed these libraries but the UI still fails with an
error, you will need to find out the exact names that they are installed
as, and issue a command similar to the following to bootstrap Factor:
./f factor.image
./f boot.image.<foo> -libraries:sdl:name=libSDL-1.2.so
-libraries:freetype:name=libfreetype.so
The Cocoa UI requires that after bootstrapping you build the Factor.app
application bundle:
make macosx.app
This copies the runtime executable, factor.image (which must exist at
this point), and the library source into a self-contained Factor.app.
Factor.app runs the UI when double-clicked and can be transported
between PowerPC Macs.
* Running Factor on Windows
On Windows, double-clicking f.exe will start running the Win32-based UI
with the factor.image in the same directory as the executable.
Bootstrap runs in a Windows command prompt, however after bootstrapping
only the UI can be used.
* Source organization
doc/ - the developer's handbook, and various other bits and pieces
native/ - sources for the Factor runtime, written in C
library/ - sources for the library, written in Factor
alien/ - C library interface
bootstrap/ - code for generating boot images
cocoa/ - Mac OS X Cocoa API and Objective-C runtime binding
collections/ - data types including but not limited to lists,
vectors, hashtables, and operations on them
compiler/ - optimizing native compiler
freetype/ - FreeType binding, rendering glyphs to OpenGL textures
generic/ - generic words, for object oriented programming style
help/ - online help system
inference/ - stack effect inference, used by compiler, as well as a
useful development tool of its own
io/ - input and output streams
math/ - integers, ratios, floats, complex numbers, vectors, matrices
opengl/ - OpenGL graphics library binding
syntax/ - parser and object prettyprinter
test/ - unit test framework and test suite
tools/ - interactive development tools
ui/ - UI framework
unix/ - Unix-specific I/O code
win32/ - Windows-specific I/O code
contrib/ - various handy libraries not part of the core
examples/ - small examples illustrating various language features
fonts/ - TrueType fonts used by UI
* Learning Factor
The UI has a simple tutorial that will show you the most basic concepts.
There is a detailed language and library reference available at
http://factorcode.org/handbook.pdf.
The UI has a tutorial and defailed reference documentation. You can
browse it in the UI or by running the HTTP server (contrib/httpd).
You can browse the source code; it is organized into small,
well-commented files and should be easy to follow once you have a good

41
TODO.FACTOR.txt
View File

@ -1,27 +1,11 @@
should fix in 0.82:
- amd64 %box-struct
- another i/o bug: on factorcode eventually all i/o times out
- get factor running on mac intel
- when generating a 32-bit image on a 64-bit system, large numbers which should
be bignums become fixnums
- httpd fep
- defining methods returning structs in objc
- expired aliens in view hash
- clicks sent twice
- speed up ideas:
- only do clipping for certain gadgets
- use glRect
- remove <char*>, <ushort*>, set-char*-nth, set-ushort*-nth since they
have incorrect semantics
- cocoa: global menu bar with useful commands
+ portability:
- win64 port
- amd64 %unbox-struct
+ io:
- gdb triggers 'mutliple i/o ops on port' error
- stream server can hang because of exception handler limitations
- better i/o scheduler
- yield in a loop starves i/o
@ -29,6 +13,11 @@ should fix in 0.82:
+ ui/help:
- clicks sent twice
- speed up ideas:
- only do clipping for certain gadgets
- use glRect
- polish OS X menu bar code
- help search
- reimplement clicking input
- reimplement tab completion
@ -56,14 +45,19 @@ should fix in 0.82:
+ compiler/ffi:
- free up r11, r12 as a vreg on ppc
- float= on powerpc doesn't consider nans equal
- intrinsic fixnum>float float>fixnum
- win64 port
- amd64 %unbox-struct
- constant branch folding
- core foundation should use unicode strings
- alien>utf16-string, utf16-string>alien words
- can <void*> only be called with an alien?
- improve callback efficiency
- float intrinsics
- remove <char*>, <ushort*>, set-char*-nth, set-ushort*-nth since they
have incorrect semantics
- complex float type
- complex float intrinsics
- out of memory from overflow check
- remove literal table
- C functions returning structs by value
- FIELD: char key_vector[32];
@ -73,13 +67,12 @@ should fix in 0.82:
- [ [ dup call ] dup call ] infer hangs
- the invalid recursion form case needs to be fixed, for inlines too
- code gc
- compiled gc check slows things down
- fix compiled gc check
+ misc:
- 3 >n fep
- code walker & exceptions
- slice: if sequence or seq start is changed, abstraction violation
- make 3.4 bits>double an error
- colorcoded prettyprinting for vocabularies
- signal handler should not lose stack pointers
- code walker and callbacks is broken?

BIN
boot.image.amd64
View File

Binary file not shown.

BIN
boot.image.pentium4 Normal file
View File

Binary file not shown.

BIN
boot.image.ppc
View File

Binary file not shown.

BIN
boot.image.x86
View File

Binary file not shown.

4
contrib/coroutines.factor
View File

@ -56,8 +56,8 @@ TUPLE: coroutine resumecc exitcc ;
USE: prettyprint
USE: sequences
: test1 ( -- co )
[ swap [ over coyield 2drop ] tree-each f swap coyield ] cocreate ;
: test1 ( list -- co )
[ swap [ over coyield 2drop ] each f swap coyield ] cocreate ;
: test2 ( -- co )
[ 1 over coyield drop 2 over coyield drop 3 over coyield ] cocreate ;

38
contrib/factory/factory.factor
View File

@ -151,6 +151,7 @@ TUPLE: wm-root ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: wm-root handle-map-request-event ( event <wm-root> -- )
"handle-map-request-event called on wm-root" print flush
drop XMapRequestEvent-window id>obj ! obj
{ { [ dup wm-frame? ]
@ -164,6 +165,9 @@ M: wm-root handle-map-request-event ( event <wm-root> -- )
"new window has override_redirect attribute set." print flush
drop ] }
{ [ dup window-id window-parent+ id>obj wm-frame? ]
[ "Window is already managed" print flush drop ] }
{ [ t ] [ window-id manage-window ] } }
cond ;
@ -332,7 +336,9 @@ TUPLE: wm-frame child ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: manage-window ( window -- )
flush-dpy
grab-server
flush-dpy
create-wm-child ! child
create-wm-frame ! frame
@ -360,8 +366,11 @@ TUPLE: wm-frame child ;
dup map-subwindows%
dup wm-frame-child PropertyChangeMask swap select-input%
flush-dpy 0 sync-dpy ungrab-server ;
flush-dpy
0 sync-dpy
ungrab-server
flush-dpy ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -558,15 +567,15 @@ SYMBOL: window-list
: not-transient? ( frame -- ? ) wm-frame-child get-transient-for-hint% not ;
: add-window-to-list ( window-list frame -- window-list )
dup ! window-list frame frame
wm-frame-child ! window-list frame child
fetch-name% ! window-list frame name-or-f
dup ! window-list frame name-or-f name-or-f
dup ! window-list frame frame
wm-frame-child ! window-list frame child
fetch-name% ! window-list frame name-or-f
dup ! window-list frame name-or-f name-or-f
[ ] [ drop "*untitled*" ] if ! window-list frame name
swap ! window-list name frame
[ map-window% ] ! window-list name frame [ map-window% ]
cons ! window-list name action
pick ! window-list name action window-list
swap ! window-list name frame
[ map-window% ] ! window-list name frame [ map-window% ]
cons ! window-list name action
pick ! window-list name action window-list
add-popup-menu-item ;
: refresh-window-list ( window-list -- )
@ -591,16 +600,9 @@ SYMBOL: window-list
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: xlib-error-handler ( -- xt ) "void" { "Display*" "XErrorEvent*" }
[ "X11 : error-handler called" print flush ] alien-callback ; compiled
: install-error-handler ( -- ) xlib-error-handler XSetErrorHandler drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start-factory ( dpy-string -- )
initialize-x
install-error-handler
[ "X11 : error-handler called" print flush ] set-error-handler
root get [ make-drag-gc ] with-win drag-gc set
root get [ black-pixel get set-window-background clear-window ] with-win
root get create-wm-root

529
contrib/httpd/cont-responder.factor
View File

@ -1,29 +1,10 @@
! Copyright (C) 2004 Chris Double.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: cont-responder
! See http://factorcode.org/license.txt for BSD license.
USING: http httpd math namespaces io
lists strings kernel html hashtables
parser generic sequences ;
lists strings kernel html hashtables
parser generic sequences ;
IN: cont-responder
#! Used inside the session state of responders to indicate whether the
#! next request should use the post-refresh-get pattern. It is set to
@ -31,95 +12,95 @@ USING: http httpd math namespaces io
SYMBOL: post-refresh-get?
: expiry-timeout ( -- timeout-seconds )
#! Number of seconds to timeout continuations in
#! continuation table. This value will need to be
#! tuned. I leave it at 24 hours but it can be
#! higher/lower as needed. Default to 15 minutes for
#! testing.
900 ;
#! Number of seconds to timeout continuations in
#! continuation table. This value will need to be
#! tuned. I leave it at 24 hours but it can be
#! higher/lower as needed. Default to 15 minutes for
#! testing.
900 ;
: get-random-id ( -- id )
#! Generate a random id to use for continuation URL's
[ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ;
#! Generate a random id to use for continuation URL's
[ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ;
SYMBOL: table
: continuation-table ( -- <hashtable> )
#! Return the global table of continuations
table global hash ;
: reset-continuation-table ( -- )
#! Create the initial global table
continuation-table clear-hash ;
#! Return the global table of continuations
table get-global ;
H{ } clone table global set-hash
: reset-continuation-table ( -- )
#! Create the initial global table
continuation-table clear-hash ;
H{ } clone table set-global
#! Tuple for holding data related to a continuation.
TUPLE: item expire? quot id time-added ;
: continuation-item ( expire? quot id -- <item> )
#! A continuation item is the actual item stored
#! in the continuation table. It contains the id,
#! quotation/continuation, time added, etc. If
#! expire? is true then the continuation will
#! be expired after a certain amount of time.
millis <item> ;
#! A continuation item is the actual item stored
#! in the continuation table. It contains the id,
#! quotation/continuation, time added, etc. If
#! expire? is true then the continuation will
#! be expired after a certain amount of time.
millis <item> ;
: seconds>millis ( seconds -- millis )
#! Convert a number of seconds to milliseconds
1000 * ;
#! Convert a number of seconds to milliseconds
1000 * ;
: expired? ( timeout-seconds <item> -- bool )
#! Return true if the continuation item is expirable
#! and has expired (ie. was added to the table more than
#! timeout milliseconds ago).
[ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ;
#! Return true if the continuation item is expirable
#! and has expired (ie. was added to the table more than
#! timeout milliseconds ago).
[ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ;
: expire-continuations ( timeout-seconds -- )
#! Expire all continuations in the continuation table
#! if they are 'timeout-seconds' old (ie. were added
#! more than 'timeout-seconds' ago.
continuation-table clone [ ( timeout-seconds [[ id item ]] -- )
swapd expired? [
continuation-table remove-hash
] [
drop
] if
] hash-each-with ;
#! Expire all continuations in the continuation table
#! if they are 'timeout-seconds' old (ie. were added
#! more than 'timeout-seconds' ago.
continuation-table clone [
swapd expired? [
continuation-table remove-hash
] [
drop
] if
] hash-each-with ;
: expirable ( quot -- t quot )
#! Set the stack up for a register-continuation call
#! so that the given quotation is registered that it can
#! be expired.
t swap ;
#! Set the stack up for a register-continuation call
#! so that the given quotation is registered that it can
#! be expired.
t swap ;
: permanent ( quot -- f quot )
#! Set the stack up for a register-continuation call
#! so that the given quotation is never expired after
#! registration.
f swap ;
#! Set the stack up for a register-continuation call
#! so that the given quotation is never expired after
#! registration.
f swap ;
: register-continuation ( expire? quot -- id )
#! Store a continuation in the table and associate it with
#! a random id. That continuation will be expired after
#! a certain period of time if 'expire?' is true.
get-random-id
[ continuation-item ] keep ( item id -- )
[ continuation-table set-hash ] keep ;
#! Store a continuation in the table and associate it with
#! a random id. That continuation will be expired after
#! a certain period of time if 'expire?' is true.
get-random-id
[ continuation-item ] keep ( item id -- )
[ continuation-table set-hash ] keep ;
: register-continuation* ( expire? quots -- id )
#! Like register-continuation but registers a quotation
#! that will call all quotations in the list, in the order given.
concat register-continuation ;
#! Like register-continuation but registers a quotation
#! that will call all quotations in the list, in the order given.
concat register-continuation ;
: get-continuation-item ( id -- <item> )
#! Get the continuation item associated with the id.
continuation-table hash ;
#! Get the continuation item associated with the id.
continuation-table hash ;
: id>url ( id -- string )
#! Convert the continuation id to an URL suitable for
#! embedding in an HREF or other HTML.
url-encode "?id=" swap append ;
#! Convert the continuation id to an URL suitable for
#! embedding in an HREF or other HTML.
url-encode "?id=" swap append ;
DEFER: show-final
DEFER: show
@ -127,268 +108,262 @@ DEFER: show
TUPLE: resume value stdio ;
: (expired-page-handler) ( alist -- )
#! Display a page has expired message.
#! TODO: Need to handle this better to enable
#! returning back to root continuation.
#! Display a page has expired message.
#! TODO: Need to handle this better to enable
#! returning back to root continuation.
<html>
<body>
<p> "This page has expired." write </p>
</body>
</html> flush ;
: (expired-page-handler) ( alist -- )
#! Display a page has expired message.
#! TODO: Need to handle this better to enable
#! returning back to root continuation.
drop
<html>
<body>
<p> "This page has expired." write </p>
</body>
<body>
<p> "This page has expired." write </p>
</body>
</html> flush ;
: expired-page-handler ( alist -- )
[ (expired-page-handler) ] show-final ;
[ (expired-page-handler) ] show-final ;
: >callable ( quot|interp|f -- interp )
dup continuation? [
[ continue-with ] cons
] when ;
dup continuation? [
[ continue-with ] cons
] when ;
: get-registered-continuation ( id -- cont )
#! Return the continuation or quotation
#! associated with the given id.
#! TODO: handle expired pages better.
expiry-timeout expire-continuations
get-continuation-item [
item-quot
] [
[ (expired-page-handler) ]
] if* >callable ;
#! Return the continuation or quotation
#! associated with the given id.
#! TODO: handle expired pages better.
expiry-timeout expire-continuations
get-continuation-item [
item-quot
] [
[ (expired-page-handler) ]
] if* >callable ;
: resume-continuation ( resumed-data id -- )
#! Call the continuation associated with the given id,
#! with 'value' on the top of the stack.
get-registered-continuation call ;
#! Call the continuation associated with the given id,
#! with 'value' on the top of the stack.
get-registered-continuation call ;
#! Name of the variable holding the continuation used to exit
#! back to the httpd responder, returning any generated HTML.
SYMBOL: exit-cc
: exit-continuation ( -- exit )
#! Get the current exit continuation
exit-cc get ;
#! Get the current exit continuation
exit-cc get ;
: call-exit-continuation ( value -- )
#! Call the exit continuation, passing it the given value on the
#! top of the stack.
exit-cc get continue-with ;
#! Call the exit continuation, passing it the given value on the
#! top of the stack.
exit-cc get continue-with ;
: with-exit-continuation ( quot -- )
#! Call the quotation with the variable exit-cc bound such that when
#! the exit continuation is called, computation will resume from the
#! end of this 'with-exit-continuation' call, with the value passed
#! to the exit continuation on the top of the stack.
[ exit-cc set call f call-exit-continuation ] callcc1 nip ;
#! Call the quotation with the variable exit-cc bound such that when
#! the exit continuation is called, computation will resume from the
#! end of this 'with-exit-continuation' call, with the value passed
#! to the exit continuation on the top of the stack.
[ exit-cc set call f call-exit-continuation ] callcc1 nip ;
#! Name of variable holding the 'callback' continuation, used for
#! returning back to previous 'show' calls.
SYMBOL: callback-cc
: store-callback-cc ( -- )
#! Store the current continuation in the variable 'callback-cc'
#! so it can be returned to later by callbacks. Note that it
#! recalls itself when the continuation is called to ensure that
#! it resets its value back to the most recent show call.
[ ( 0 -- )
[ ( 0 1 -- )
callback-cc set ( 0 -- )
stdio get swap continue-with
] callcc1 ( 0 [ ] == )
nip
dup resume-stdio stdio set resume-value
call
store-callback-cc stdio get
] callcc1 stdio set ;
#! Store the current continuation in the variable 'callback-cc'
#! so it can be returned to later by callbacks. Note that it
#! recalls itself when the continuation is called to ensure that
#! it resets its value back to the most recent show call.
[ ( 0 -- )
[ ( 0 1 -- )
callback-cc set ( 0 -- )
stdio get swap continue-with
] callcc1
nip
dup resume-stdio stdio set
resume-value call
store-callback-cc stdio get
] callcc1 stdio set ;
: forward-to-url ( url -- )
#! When executed inside a 'show' call, this will force a
#! HTTP 302 to occur to instruct the browser to forward to
#! the request URL.
[
"HTTP/1.1 302 Document Moved\nLocation: " % %
"\nContent-Length: 0\nContent-Type: text/plain\n\n" %
] "" make write "" call-exit-continuation ;
#! When executed inside a 'show' call, this will force a
#! HTTP 302 to occur to instruct the browser to forward to
#! the request URL.
[
"HTTP/1.1 302 Document Moved\nLocation: " % %
"\nContent-Length: 0\nContent-Type: text/plain\n\n" %
] "" make write "" call-exit-continuation ;
: forward-to-id ( id -- )
#! When executed inside a 'show' call, this will force a
#! HTTP 302 to occur to instruct the browser to forward to
#! the request URL.
>r "request" get r> id>url append forward-to-url ;
#! When executed inside a 'show' call, this will force a
#! HTTP 302 to occur to instruct the browser to forward to
#! the request URL.
>r "request" get r> id>url append forward-to-url ;
: redirect-to-here ( -- )
#! Force a redirect to the client browser so that the browser
#! goes to the current point in the code. This forces an URL
#! change on the browser so that refreshing that URL will
#! immediately run from this code point. This prevents the
#! "this request will issue a POST" warning from the browser
#! and prevents re-running the previous POST logic. This is
#! known as the 'post-refresh-get' pattern.
post-refresh-get? get [
[
expirable register-continuation forward-to-id
] callcc1 resume-stdio stdio set
] [
t post-refresh-get? set
] if ;
#! Force a redirect to the client browser so that the browser
#! goes to the current point in the code. This forces an URL
#! change on the browser so that refreshing that URL will
#! immediately run from this code point. This prevents the
#! "this request will issue a POST" warning from the browser
#! and prevents re-running the previous POST logic. This is
#! known as the 'post-refresh-get' pattern.
post-refresh-get? get [
[
expirable register-continuation forward-to-id
] callcc1 resume-stdio stdio set
] [
t post-refresh-get? set
] if ;
: (show) ( quot -- namespace )
#! See comments for show. The difference is the
#! quotation MUST set the content-type using 'serving-html'
#! or similar.
store-callback-cc redirect-to-here
[
expirable register-continuation id>url swap
with-scope "" call-exit-continuation
] callcc1
nip dup resume-stdio stdio set resume-value ;
#! See comments for show. The difference is the
#! quotation MUST set the content-type using 'serving-html'
#! or similar.
store-callback-cc redirect-to-here
[
expirable register-continuation id>url swap
with-scope "" call-exit-continuation
] callcc1
nip dup resume-stdio stdio set resume-value ;
: show ( quot -- namespace )
#! Call the quotation with the URL associated with the current
#! continuation. All output from the quotation goes to the client
#! browser. When the URL is later referenced then
#! computation will resume from this 'show' call with a namespace on
#! the stack containing any query or post parameters.
#! NOTE: On return from 'show' the stack is exactly the same as
#! initial entry with 'quot' popped off an <namespace> put on. Even
#! if the quotation consumes items on the stack.
\ serving-html swons (show) ;
#! Call the quotation with the URL associated with the current
#! continuation. All output from the quotation goes to the client
#! browser. When the URL is later referenced then
#! computation will resume from this 'show' call with a namespace on
#! the stack containing any query or post parameters.
#! NOTE: On return from 'show' the stack is exactly the same as
#! initial entry with 'quot' popped off an <namespace> put on. Even
#! if the quotation consumes items on the stack.
\ serving-html swons (show) ;
: (show-final) ( quot -- namespace )
#! See comments for show-final. The difference is the
#! quotation MUST set the content-type using 'serving-html'
#! or similar.
store-callback-cc redirect-to-here
with-scope "" call-exit-continuation ;
#! See comments for show-final. The difference is the
#! quotation MUST set the content-type using 'serving-html'
#! or similar.
store-callback-cc redirect-to-here
with-scope "" call-exit-continuation ;
: show-final ( quot -- namespace )
#! Similar to 'show', except the quotation does not receive the URL
#! to resume computation following 'show-final'. No continuation is
#! stored for this resumption. As a result, 'show-final' is for use
#! when a page is to be displayed with no further action to occur. Its
#! use is an optimisation to save having to generate and save a continuation
#! in that special case.
\ serving-html swons (show-final) ;
#! Similar to 'show', except the quotation does not receive the URL
#! to resume computation following 'show-final'. No continuation is
#! stored for this resumption. As a result, 'show-final' is for use
#! when a page is to be displayed with no further action to occur. Its
#! use is an optimisation to save having to generate and save a continuation
#! in that special case.
\ serving-html swons (show-final) ;
#! Name of variable for holding initial continuation id that starts
#! the responder.
SYMBOL: root-continuation
: id-or-root ( -- id )
#! Return the continuation id for the current requested continuation
#! or the root continuation if no id is supplied.
"id" "query" get hash [ root-continuation get ] unless* ;
#! Return the continuation id for the current requested continuation
#! or the root continuation if no id is supplied.
"id" "query" get hash [ root-continuation get ] unless* ;
: cont-get/post-responder ( id-or-f -- )
#! httpd responder that retrieves a continuation and calls it.
#! The continuation id must be in a query parameter called 'id'.
#! If it does not exist the root continuation is called. If
#! no root continuation exists the expired continuation handler
#! should be called.
drop [
"response" get stdio get <resume>
id-or-root [
resume-continuation
] [
(expired-page-handler) "" call-exit-continuation
] if*
] with-exit-continuation drop ;
#! httpd responder that retrieves a continuation and calls it.
#! The continuation id must be in a query parameter called 'id'.
#! If it does not exist the root continuation is called. If
#! no root continuation exists the expired continuation handler
#! should be called.
[
drop [
"response" get stdio get <resume>
id-or-root [
resume-continuation
] [
(expired-page-handler) "" call-exit-continuation
] if*
] with-exit-continuation drop
] with-scope ;
: callback-quot ( quot -- quot )
#! Convert the given quotation so it works as a callback
#! by returning a quotation that will pass the original
#! quotation to the callback continuation.
[ , \ stdio , \ get , \ <resume> , callback-cc get , \ continue-with , ] [ ] make ;
#! Convert the given quotation so it works as a callback
#! by returning a quotation that will pass the original
#! quotation to the callback continuation.
[
, \ stdio , \ get , \ <resume> , callback-cc get ,
\ continue-with ,
] [ ] make ;
: quot-url ( quot -- url )
callback-quot expirable register-continuation id>url ;
callback-quot expirable register-continuation id>url ;
: quot-href ( text quot -- )
#! Write to standard output an HTML HREF where the href,
#! when referenced, will call the quotation and then return
#! back to the most recent 'show' call (via the callback-cc).
#! The text of the link will be the 'text' argument on the
#! stack.
<a quot-url =href a> write </a> ;
#! Write to standard output an HTML HREF where the href,
#! when referenced, will call the quotation and then return
#! back to the most recent 'show' call (via the callback-cc).
#! The text of the link will be the 'text' argument on the
#! stack.
<a quot-url =href a> write </a> ;
: init-session-namespace ( <resume> -- )
#! Setup the initial session namespace. Currently this only
#! sets the redirect flag so that the initial request of the
#! responder will not do a post-refresh-get style redirect.
#! This prevents the initial request to a responder from redirecting
#! to an URL with a continuation id. This word must be run from
#! within the session namespace.
f post-refresh-get? set dup resume-stdio stdio set ;
#! Setup the initial session namespace. Currently this only
#! sets the redirect flag so that the initial request of the
#! responder will not do a post-refresh-get style redirect.
#! This prevents the initial request to a responder from redirecting
#! to an URL with a continuation id. This word must be run from
#! within the session namespace.
f post-refresh-get? set dup resume-stdio stdio set ;
: install-cont-responder ( name quot -- )
#! Install a cont-responder with the given name
#! that will initially run the given quotation.
#!
#! Convert the quotation so it is run within a session namespace
#! and that namespace is initialized first.
\ init-session-namespace swons [ , \ with-scope , ] [ ] make
[
[ cont-get/post-responder ] "get" set
[ cont-get/post-responder ] "post" set
swap "responder" set
permanent register-continuation root-continuation set
] make-responder ;
#! Install a cont-responder with the given name
#! that will initially run the given quotation.
#!
#! Convert the quotation so it is run within a session namespace
#! and that namespace is initialized first.
\ init-session-namespace swons [ , \ with-scope , ] [ ] make
[
[ cont-get/post-responder ] "get" set
[ cont-get/post-responder ] "post" set
swap "responder" set
permanent register-continuation root-continuation set
] make-responder ;
: simple-page ( title quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
<html>
<head> <title> swap write </title> </head>
<body> call </body>
</html> ;
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
<html>
<head> <title> swap write </title> </head>
<body> call </body>
</html> ;
: styled-page ( title stylesheet-quot quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title. stylesheet-quot
#! is called to generate the required stylesheet.
<html>
<head>
<title> rot write </title>
swap call
</head>
<body> call </body>
</html> ;
#! Call the quotation, with all output going to the
#! body of an html page with the given title. stylesheet-quot
#! is called to generate the required stylesheet.
<html>
<head>
<title> rot write </title>
swap call
</head>
<body> call </body>
</html> ;
: paragraph ( str -- )
#! Output the string as an html paragraph
<p> write </p> ;
#! Output the string as an html paragraph
<p> write </p> ;
: show-message-page ( message -- )
#! Display the message in an HTML page with an OK button.
[
"Press OK to Continue" [
swap paragraph
<a =href a> "OK" write </a>
] simple-page
] show 2drop ;
#! Display the message in an HTML page with an OK button.
[
"Press OK to Continue" [
swap paragraph
<a =href a> "OK" write </a>
] simple-page
] show 2drop ;
: vertical-layout ( list -- )
#! Given a list of HTML components, arrange them vertically.
<table>
#! Given a list of HTML components, arrange them vertically.
<table>
[ <tr> <td> call </td> </tr> ] each
</table> ;
</table> ;
: horizontal-layout ( list -- )
#! Given a list of HTML components, arrange them horizontally.
<table>
<tr "top" =valign tr> [ <td> call </td> ] each </tr>
</table> ;
#! Given a list of HTML components, arrange them horizontally.
<table>
<tr "top" =valign tr> [ <td> call </td> ] each </tr>
</table> ;
: button ( label -- )
#! Output an HTML submit button with the given label.
<input "submit" =type =value input/> ;
#! Output an HTML submit button with the given label.
<input "submit" =type =value input/> ;

2
contrib/math/infix.factor
View File

@ -89,6 +89,8 @@ UNION: value number string ;
#! The semicolon token
T{ tok f CHAR: ; } ;
: unswons uncons swap ;
: nest-apply ( [ ast ] -- apply )
unswons unit swap [
swap <apply> unit

2
contrib/parser-combinators/parser-combinators.factor
View File

@ -237,6 +237,8 @@ M: list pdrop ( n object -- object )
>r uncons r> ( x1 xs2 x )
swap cons cons ;
: unswons uncons swap ;
: <&>-do-parser2 ( [[ x xs ]] parser2 -- result )
#! Called by the <&>-parser on each result of the
#! successfull parse of parser1. It's input is the

2
contrib/random-tester/random-tester.factor
View File

@ -241,7 +241,7 @@ SYMBOL: first-arg
dup .
[ last-quot set ] keep
[ call ] keep
[ last car update-xt ] keep call
[ peek update-xt ] keep call
2dup swap unparse write " " write unparse print
= [ "update-xt problem" throw ] unless ;

4
contrib/splay-trees.factor
View File

@ -111,5 +111,5 @@ DEFER: (splay)
USING: namespaces words ;
<splay-tree> "foo" set
[ dup word-name "foo" get set-splay ] each-word
[ dup word-name "foo" get get-splay drop ] each-word
all-words [ dup word-name "foo" get set-splay ] each
all-words [ dup word-name "foo" get get-splay drop ] each

30
contrib/x11/concurrent-widgets.factor
View File

@ -58,21 +58,21 @@ GENERIC: handle-property-event
: handle-event ( event obj -- )
over XAnyEvent-type
{ { [ dup Expose = ] [ drop handle-expose-event ] }
{ [ dup KeyPress = ] [ drop handle-key-press-event ] }
{ [ dup KeyRelease = ] [ drop handle-key-release-event ] }
{ [ dup ButtonPress = ] [ drop handle-button-press-event ] }
{ [ dup ButtonRelease = ] [ drop handle-button-release-event ] }
{ [ dup ConfigureNotify = ] [ drop handle-configure-event ] }
{ [ dup EnterNotify = ] [ drop handle-enter-window-event ] }
{ [ dup LeaveNotify = ] [ drop handle-leave-window-event ] }
{ [ dup DestroyNotify = ] [ drop handle-destroy-window-event ] }
{ [ dup MapRequest = ] [ drop handle-map-request-event ] }
{ [ dup MapNotify = ] [ drop handle-map-event ] }
{ [ dup ConfigureRequest = ] [ drop handle-configure-request-event ] }
{ [ dup UnmapNotify = ] [ drop handle-unmap-event ] }
{ [ dup PropertyNotify = ] [ drop handle-property-event ] }
{ [ t ] [ "handle-event ignoring event" print flush 3drop ] } }
{ { [ dup Expose = ] [ drop handle-expose-event ] }
{ [ dup KeyPress = ] [ drop handle-key-press-event ] }
{ [ dup KeyRelease = ] [ drop handle-key-release-event ] }
{ [ dup ButtonPress = ] [ drop handle-button-press-event ] }
{ [ dup ButtonRelease = ] [ drop handle-button-release-event ] }
{ [ dup ConfigureNotify = ] [ drop handle-configure-event ] }
{ [ dup EnterNotify = ] [ drop handle-enter-window-event ] }
{ [ dup LeaveNotify = ] [ drop handle-leave-window-event ] }
{ [ dup DestroyNotify = ] [ drop handle-destroy-window-event ] }
{ [ dup MapRequest = ] [ drop handle-map-request-event ] }
{ [ dup MapNotify = ] [ drop handle-map-event ] }
{ [ dup ConfigureRequest = ] [ drop handle-configure-request-event ] }
{ [ dup UnmapNotify = ] [ drop handle-unmap-event ] }
{ [ dup PropertyNotify = ] [ drop handle-property-event ] }
{ [ t ] [ "handle-event ignoring event" print flush 3drop ] } }
cond ;
M: window handle-configure-event ( event obj -- )

112
contrib/x11/x.factor
View File

@ -1,5 +1,6 @@
USING: namespaces kernel compiler math arrays strings alien sequences io
prettyprint xlib rectangle ;
USING: namespaces kernel math arrays strings alien sequences xlib rectangle ;
IN: x
SYMBOL: dpy
@ -133,12 +134,99 @@ DEFER: with-win
: get-window-attributes ( -- <XWindowAttributes> )
dpy get win get "XWindowAttributes" <c-object> dup >r XGetWindowAttributes drop r> ;
: window-root get-window-attributes XWindowAttributes-root ;
: window-map-state
get-window-attributes XWindowAttributes-map_state ;
: window-event-mask
get-window-attributes XWindowAttributes-your_event_mask ;
: window-all-event-masks
get-window-attributes XWindowAttributes-all_event_masks ;
: window-override-redirect
get-window-attributes XWindowAttributes-override_redirect ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: event-masks
{ { "NoEventMask" 0 }
{ "KeyPressMask" 1 }
{ "KeyReleaseMask" 2 }
{ "ButtonPressMask" 4 }
{ "ButtonReleaseMask" 8 }
{ "EnterWindowMask" 16 }
{ "LeaveWindowMask" 32 }
{ "PointerMotionMask" 64 }
{ "PointerMotionHintMask" 128 }
{ "Button1MotionMask" 256 }
{ "Button2MotionMask" 512 }
{ "Button3MotionMask" 1024 }
{ "Button4MotionMask" 2048 }
{ "Button5MotionMask" 4096 }
{ "ButtonMotionMask" 8192 }
{ "KeymapStateMask" 16384 }
{ "ExposureMask" 32768 }
{ "VisibilityChangeMask" 65536 }
{ "StructureNotifyMask" 131072 }
{ "ResizeRedirectMask" 262144 }
{ "SubstructureNotifyMask" 524288 }
{ "SubstructureRedirectMask" 1048576 }
{ "FocusChangeMask" 2097152 }
{ "PropertyChangeMask" 4194304 }
{ "ColormapChangeMask" 8388608 }
{ "OwnerGrabButtonMask" 16777216 }
} event-masks set-global
: bit-test ( a b -- t-or-f ) bitand 0 = not ;
: name>event-mask ( str -- i )
event-masks get [ first over = ] find 2nip second ;
: event-mask>name ( i -- str )
event-masks get [ second over = ] find 2nip first ;
: event-mask-names ( -- seq ) event-masks get [ first ] map ;
: event-mask>names ( mask -- seq )
event-mask-names [ name>event-mask bit-test ] subset-with ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Pretty printing window information
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: print-field ( name value -- ) swap "=" append write pprint ;
: spc ( -- ) " " write ;
: print-window-geometry ( -- )
window-width pprint "x" write window-height pprint "+" write
window-x pprint "+" write window-y pprint ;
: print-map-state ( -- )
"map-state=" write
window-map-state
{ { [ dup 0 = ] [ drop "IsUnmapped" write ] }
{ [ dup 1 = ] [ drop "IsUnviewable" write ] }
{ [ dup 2 = ] [ drop "IsViewable" write ] }
} cond ;
: print-window-info ( -- )
"id" win get print-field spc
"parent" window-parent print-field spc
"root" window-root print-field spc
print-window-geometry terpri
"children" window-children print-field terpri
"override-redirect" window-override-redirect print-field spc
print-map-state terpri
"event-mask" window-event-mask event-mask>names print-field terpri
"all-event-masks" window-all-event-masks event-mask>names print-field
terpri ;
: .win print-window-info ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 6 - Color Management Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -205,14 +293,15 @@ dup length 1 - [ swap 2nth draw-line ] each-with ;
! 8.6 - Drawing Text
: draw-string ( { x y } string -- )
>r >r dpy get win get gcontext get r> [ ] each r> dup length XDrawString drop ;
: draw-string ( { x y } string -- ) >r >r
dpy get win get gcontext get r> [ ] each r> dup length XDrawString drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 9 - Window and Session Manager Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: reparent-window ( parent -- ) >r dpy get win get r> 0 0 XReparentWindow drop ;
: reparent-window ( parent -- ) >r
dpy get win get r> 0 0 XReparentWindow drop ;
: add-to-save-set ( -- ) dpy get win get XAddToSaveSet drop ;
@ -238,6 +327,16 @@ dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
: events-queued ( mode -- n ) >r dpy get r> XEventsQueued ;
! 11.8 - Handling Protocol Errors
SYMBOL: error-handler-quot
: error-handler-callback ( -- xt ) "void" { "Display*" "XErrorEvent*" }
[ error-handler-quot get call ] alien-callback ; compiled
: set-error-handler ( quot -- )
error-handler-quot set error-handler-callback XSetErrorHandler drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 12 - Input Device Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -246,8 +345,8 @@ dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
>r >r dpy get win get r> r> XSetInputFocus drop ;
: grab-pointer ( mask -- )
>r dpy get win get False r> GrabModeAsync GrabModeAsync None None CurrentTime
XGrabPointer drop ;
>r dpy get win get False r> GrabModeAsync GrabModeAsync None None CurrentTime
XGrabPointer drop ;
: ungrab-pointer ( time -- )
>r dpy get r> XUngrabPointer drop ;
@ -284,6 +383,7 @@ dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
: destroy-window+ [ destroy-window ] with-win ;
: map-window+ [ map-window ] with-win ;
: unmap-window+ [ unmap-window ] with-win ;
: window-parent+ [ window-parent ] with-win ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

22
contrib/x11/xlib.factor
View File

@ -472,11 +472,11 @@ FUNCTION: Status XKillClient ( Display* display, XID resource ) ;
: MotionNotify 6 ;
: EnterNotify 7 ;
: LeaveNotify 8 ;
: FocusIn 9 ;
: FocusIn 9 ;
: FocusOut 10 ;
: KeymapNotify 11 ;
: Expose 12 ;
: GraphicsExpose 13 ;
: Expose 12 ;
: GraphicsExpose 13 ;
: NoExpose 14 ;
: VisibilityNotify 15 ;
: CreateNotify 16 ;
@ -484,24 +484,22 @@ FUNCTION: Status XKillClient ( Display* display, XID resource ) ;
: UnmapNotify 18 ;
: MapNotify 19 ;
: MapRequest 20 ;
: ReparentNotify 21 ;
: ConfigureNotify 22 ;
: ReparentNotify 21 ;
: ConfigureNotify 22 ;
: ConfigureRequest 23 ;
: GravityNotify 24 ;
: ResizeRequest 25 ;
: CirculateNotify 26 ;
: CirculateNotify 26 ;
: CirculateRequest 27 ;
: PropertyNotify 28 ;
: SelectionClear 29 ;
: PropertyNotify 28 ;
: SelectionClear 29 ;
: SelectionRequest 30 ;
: SelectionNotify 31 ;
: ColormapNotify 32 ;
: SelectionNotify 31 ;
: ColormapNotify 32 ;
: ClientMessage 33 ;
: MappingNotify 34 ;
: LASTEvent 35 ;
BEGIN-STRUCT: XAnyEvent
FIELD: int type
FIELD: ulong serial

0
cp_dir Normal file → Executable file
View File

10
doc/handbook/changes.facts
View File

@ -1,6 +1,16 @@
USING: generic help inspector memory sequences ;
ARTICLE: "changes" "Changes in the latest release"
{ $subheading "Factor 0.82" }
{ $list
"New code generator framework in compiler"
"Floating point operations are now open-coded, resulting in a performance gain"
{ "Remove " { $snippet "unswons" } " word" }
"Implement value type struct inputs to callbacks on AMD64"
"Fix some Unix I/O bugs"
"Standard OS X-style menu bar in the Cocoa UI (Kevin Reid)"
"Objective C methods defined in Factor can now return C structures by value"
}
{ $subheading "Factor 0.81" }
{ $subtopic "UI"
{ $list

2
doc/handbook/collections.facts
View File

@ -52,7 +52,6 @@ ARTICLE: "hashtables-lookup" "Looking up keys in hashtables"
ARTICLE: "hashtables-mutation" "Storing keys in hashtables"
{ $subsection set-hash }
{ $subsection ?set-hash }
{ $subsection remove-hash }
{ $subsection clear-hash } ;
@ -140,7 +139,6 @@ ARTICLE: "namespaces-make" "Constructing sequences"
ARTICLE: "namespaces-internals" "Namespace implementation details"
"The namestack holds namespaces."
{ $subsection namestack* }
{ $subsection namestack }
{ $subsection set-namestack }
"A pair of words push and pop namespaces on the namestack."

4
doc/handbook/streams.facts
View File

@ -24,7 +24,7 @@ GLOSSARY: "output stream" "an object responding to the output words of the " { $
GLOSSARY: "bidirectional stream" "an object that is both an input and output stream" ;
ARTICLE: "stream-protocol" "Stream protocol"
"The stream protocol consits of a large number of generic words, many of which are optional."
"The stream protocol consists of a large number of generic words, many of which are optional."
$terpri
"A word required to be implemented for all streams:"
{ $subsection stream-close }
@ -86,8 +86,6 @@ ARTICLE: "character-styles" "Character styles"
"Character styles for " { $link stream-format } ":"
{ $subsection foreground }
{ $subsection background }
{ $subsection foreground }
{ $subsection background }
{ $subsection font }
{ $subsection font-size }
{ $subsection font-style }

156
examples/homology.factor Normal file
View File

@ -0,0 +1,156 @@
IN: homology
USING: kernel sequences arrays math words namespaces
hashtables prettyprint io ;
! Utilities
: S{ [ [ dup ] map>hash ] [ ] ; parsing
: (lengthen) ( seq n -- seq )
over length - f <array> append ;
: lengthen ( sim sim -- sim sim )
2dup max-length tuck (lengthen) >r (lengthen) r> ;
: unswons* 1 over tail swap first ;
: swons* 1array swap append ;
: rot-seq ( seq -- seq ) unswons* add ;
: <point> ( -- sim ) gensym 1array ;
: (C) ( point sim -- sim )
[ [ append natural-sort ] map-with ] map-with ;
: (\/) ( sim sim -- sim ) lengthen [ append natural-sort ] 2map ;
: <range> ( from to -- seq ) dup <slice> ;
! Simplicial complexes
SYMBOL: basepoint
: {*} ( -- sim )
#! Initial object in category
{ { { basepoint } } } ;
: \/ ( sim sim -- sim )
#! Glue two complexes at base point
(\/) [ prune ] map ;
: +point ( sim -- sim )
#! Adjoint an isolated point
unswons* <point> add swons* ;
: C ( sim -- sim )
#! Cone on a space
<point> over first over add >r swap (C) r> swons* ;
: S ( sim -- sim )
#! Suspension
[
<point> <point> 2dup 2array >r
pick (C) >r swap (C) r> (\/) r> swons*
] keep (\/) ;
: S^0 ( -- sim )
#! Degenerate sphere -- two points
{*} +point ;
: S^ ( n -- sim )
#! Sphere
S^0 swap [ S ] times ;
: D^ ( n -- sim )
#! Disc
1- S^ C ;
! Mod 2 matrix algebra
: remove-1 ( n seq -- seq )
>r { } swap dup 1+ r> replace-slice ;
: symmetric-diff ( hash hash -- hash )
clone swap [
drop dup pick hash [
over remove-hash
] [
dup pick set-hash
] if
] hash-each ;
SYMBOL: row-basis
SYMBOL: matrix
SYMBOL: current-row
: rows ( -- n ) matrix get length ;
: exchange-rows ( m n -- )
2dup = [ 2drop ] [ matrix get exchange ] if ;
: row ( n -- row ) matrix get nth ;
: set-row ( row n -- ) matrix get set-nth ;
: add-row ( src# dst# -- )
[ [ row ] 2apply symmetric-diff ] keep set-row ;
: pivot-row ( basis-elt -- n )
current-row get rows <range>
[ row hash-member? ] find-with nip ;
: kill-column ( basis-elt pivot -- )
dup 1+ rows <range> [
pick over row hash-member? [ dupd add-row ] [ drop ] if
] each 2drop ;
: with-matrix ( matrix basis quot -- matrix )
[
>r row-basis set matrix set r> call matrix get
] with-scope ; inline
: (row-reduce)
0 current-row set
row-basis get [
dup pivot-row dup [
current-row get exchange-rows
current-row get kill-column
current-row inc
] [
2drop
] if
] each ;
: ker/im ( -- ker im )
matrix get [ hash-empty? ] subset length
row-basis get [
matrix get [ hash-member? ] contains-with?
] subset length ;
: row-reduce ( matrix basis -- rowsp colsp matrix )
[ (row-reduce) ker/im ] with-matrix ;
! Mod 2 homology
: (boundary) ( seq -- chain )
dup length 1 <= [
H{ }
] [
dup length [ over remove-1 dup ] map>hash
] if nip ;
: boundary ( chain -- chain )
H{ } swap [ drop (boundary) symmetric-diff ] hash-each ;
: homology ( sim -- seq )
dup [ [ (boundary) ] map ] map rot-seq
[ row-reduce drop 2array ] 2map ;
: print-matrix ( matrix basis -- )
swap [
swap [
( row basis-elt )
swap hash-member? 1 0 ? pprint bl
] each-with terpri
] each-with ;
2 S^ [ [ [ (boundary) ] map ] map unswons* drop ] keep
[ [ row-reduce 2nip ] 2map ] keep
[ print-matrix terpri ] 2each

4
examples/mandel.factor
View File

@ -70,7 +70,7 @@ strings test ;
] map-with ;
: iter ( c z nb-iter -- x )
over absq 4.0 >= over 0 = or
over absq 4.0 >= over zero? or
[ 2nip ] [ 1- >r sq dupd + r> iter ] if ; inline
SYMBOL: cols
@ -88,7 +88,7 @@ SYMBOL: cols
: render ( -- )
height [
width [
2dup swap c 0 nb-iter iter dup 0 = [
2dup swap c 0 nb-iter iter dup zero? [
drop "\0\0\0"
] [
cols get [ length mod ] keep nth

2
examples/numbers-game.factor
View File

@ -1,5 +1,5 @@
IN: numbers-game
USING: kernel math parser random io ;
USING: kernel math parser io ;
: read-number ( -- n ) readln string>number ;

29
examples/raytracer.factor
View File

@ -2,7 +2,7 @@
! http://www.ffconsultancy.com/free/ray_tracer/languages.html
USING: arrays compiler generic io kernel lists math namespaces
sequences test ;
sequences test words ;
IN: ray
! parameters
@ -27,24 +27,26 @@ GENERIC: intersect-scene ( hit ray scene -- hit )
TUPLE: sphere center radius ;
: sphere-v ( sphere ray -- v )
swap sphere-center swap ray-orig v- ;
swap sphere-center swap ray-orig v- ; inline
: sphere-b ( ray v -- b ) swap ray-dir v. ;
: sphere-b ( ray v -- b ) swap ray-dir v. ; inline
: sphere-disc ( sphere v b -- d )
sq swap norm-sq - swap sphere-radius sq + ;
sq swap norm-sq - swap sphere-radius sq + ; inline
: -+ ( x y -- x-y x+y ) [ - ] 2keep + ;
: -+ ( x y -- x-y x+y ) [ - ] 2keep + ; inline
: sphere-b/d ( b d -- t )
-+ dup 0.0 < [ 2drop 1.0/0.0 ] [ >r [ 0.0 > ] keep r> ? ] if ;
-+ dup 0.0 < [ 2drop 1.0/0.0 ] [ >r [ 0.0 > ] keep r> ? ] if ; inline
: ray-sphere ( sphere ray -- t )
2dup sphere-v tuck sphere-b [ sphere-disc ] keep
over 0.0 < [ 2drop 1.0/0.0 ] [ swap sqrt sphere-b/d ] if ;
inline
: sphere-n ( ray sphere l -- n )
pick ray-dir n*v swap sphere-center v- swap ray-orig v+ ;
inline
: if-ray-sphere ( hit ray sphere quot -- hit )
#! quot: hit ray sphere l -- hit
@ -69,20 +71,20 @@ M: group intersect-scene ( hit ray group -- hit )
drop
] if-ray-sphere ;
: initial-hit T{ hit f { 0.0 0.0 0.0 } 1.0/0.0 } ;
: initial-hit T{ hit f { 0.0 0.0 0.0 } 1.0/0.0 } ; inline
: initial-intersect ( ray scene -- hit )
initial-hit -rot intersect-scene ;
initial-hit -rot intersect-scene ; inline
: ray-o ( ray hit -- o )
over ray-dir over hit-lambda v*n
swap hit-normal delta v*n v+
swap ray-orig v+ ;
swap ray-orig v+ ; inline
: sray-intersect ( ray scene hit -- ray )
swap >r ray-o light vneg <ray> r> initial-intersect ;
swap >r ray-o light vneg <ray> r> initial-intersect ; inline
: ray-g ( hit -- g ) hit-normal light v. ;
: ray-g ( hit -- g ) hit-normal light v. ; inline
: cast-ray ( ray scene -- g )
2dup initial-intersect dup hit-lambda 1.0/0.0 = [
@ -90,9 +92,10 @@ M: group intersect-scene ( hit ray group -- hit )
] [
dup ray-g >r sray-intersect hit-lambda 1.0/0.0 =
[ r> neg ] [ r> drop 0.0 ] if
] if ;
] if ; inline
: create-center ( c r d -- c2 ) >r 3.0 12.0 sqrt / * r> n*v v+ ;
: create-center ( c r d -- c2 )
>r 3.0 12.0 sqrt / * r> n*v v+ ; inline
DEFER: create ( level c r -- scene )

2
examples/turing.factor
View File

@ -38,7 +38,7 @@ SYMBOL: position
SYMBOL: tape
! Initial tape
20 zero-array >vector tape set
20 0 <array> >vector tape set
: sym ( -- sym )
#! Symbol at head position.

157
library/bootstrap/boot-stage1.factor
View File

@ -9,6 +9,17 @@ vectors words ;
"/library/bootstrap/primitives.factor" run-resource
: parse-resource* ( path -- )
[ parse-resource ] catch [
dup error.
"Try again? [yn]" print flush readln "yY" subseq?
[ drop parse-resource* ] [ rethrow ] if
] when* ;
: if-arch ( arch seq -- )
architecture get rot member?
[ [ parse-resource* % ] each ] [ drop ] if ;
! The [ ] make form creates a boot quotation
[
\ boot ,
@ -77,7 +88,7 @@ vectors words ;
"/library/generic/math-combination.factor"
"/library/generic/tuple.factor"
"/library/alien/aliens.factor"
"/library/compiler/alien/aliens.factor"
"/library/syntax/prettyprint.factor"
"/library/syntax/see.factor"
@ -109,39 +120,37 @@ vectors words ;
"/library/io/server.factor"
"/library/tools/jedit.factor"
"/library/compiler/architecture.factor"
"/library/compiler/inference/shuffle.factor"
"/library/compiler/inference/dataflow.factor"
"/library/compiler/inference/inference.factor"
"/library/compiler/inference/branches.factor"
"/library/compiler/inference/words.factor"
"/library/compiler/inference/stack.factor"
"/library/compiler/inference/known-words.factor"
"/library/inference/shuffle.factor"
"/library/inference/dataflow.factor"
"/library/inference/inference.factor"
"/library/inference/branches.factor"
"/library/inference/words.factor"
"/library/inference/class-infer.factor"
"/library/inference/kill-literals.factor"
"/library/inference/optimizer.factor"
"/library/inference/inline-methods.factor"
"/library/inference/known-words.factor"
"/library/inference/stack.factor"
"/library/inference/call-optimizers.factor"
"/library/inference/print-dataflow.factor"
"/library/compiler/optimizer/specializers.factor"
"/library/compiler/optimizer/class-infer.factor"
"/library/compiler/optimizer/kill-literals.factor"
"/library/compiler/optimizer/optimizer.factor"
"/library/compiler/optimizer/inline-methods.factor"
"/library/compiler/optimizer/call-optimizers.factor"
"/library/compiler/optimizer/print-dataflow.factor"
"/library/compiler/generator/architecture.factor"
"/library/compiler/generator/assembler.factor"
"/library/compiler/generator/templates.factor"
"/library/compiler/generator/xt.factor"
"/library/compiler/generator/generator.factor"
"/library/compiler/assembler.factor"
"/library/compiler/vops.factor"
"/library/compiler/linearizer.factor"
"/library/compiler/xt.factor"
"/library/compiler/stack.factor"
"/library/compiler/intrinsics.factor"
"/library/compiler/generator.factor"
"/library/compiler/basic-blocks.factor"
"/library/compiler/compiler.factor"
"/library/alien/malloc.factor"
"/library/alien/c-types.factor"
"/library/alien/structs.factor"
"/library/alien/compiler.factor"
"/library/alien/alien-invoke.factor"
"/library/alien/alien-callback.factor"
"/library/alien/syntax.factor"
"/library/compiler/alien/malloc.factor"
"/library/compiler/alien/c-types.factor"
"/library/compiler/alien/structs.factor"
"/library/compiler/alien/compiler.factor"
"/library/compiler/alien/alien-invoke.factor"
"/library/compiler/alien/alien-callback.factor"
"/library/compiler/alien/syntax.factor"
"/library/io/buffer.factor"
@ -193,13 +202,6 @@ vectors words ;
"/library/kernel.facts"
"/library/threads.facts"
"/library/words.facts"
"/library/alien/alien-callback.facts"
"/library/alien/alien-invoke.facts"
"/library/alien/aliens.facts"
"/library/alien/c-types.facts"
"/library/alien/malloc.facts"
"/library/alien/structs.facts"
"/library/alien/syntax.facts"
"/library/bootstrap/image.facts"
"/library/collections/growable.facts"
"/library/collections/arrays.facts"
@ -217,6 +219,14 @@ vectors words ;
"/library/collections/flatten.facts"
"/library/collections/vectors.facts"
"/library/collections/virtual-sequences.facts"
"/library/compiler/alien/alien-callback.facts"
"/library/compiler/alien/alien-invoke.facts"
"/library/compiler/alien/aliens.facts"
"/library/compiler/alien/c-types.facts"
"/library/compiler/alien/malloc.facts"
"/library/compiler/alien/structs.facts"
"/library/compiler/alien/syntax.facts"
"/library/compiler/inference/inference.facts"
"/library/compiler/compiler.facts"
"/library/generic/early-generic.facts"
"/library/generic/generic.facts"
@ -224,7 +234,6 @@ vectors words ;
"/library/generic/slots.facts"
"/library/generic/standard-combination.facts"
"/library/generic/tuple.facts"
"/library/inference/inference.facts"
"/library/io/binary.facts"
"/library/io/buffer.facts"
"/library/io/c-streams.facts"
@ -277,49 +286,34 @@ vectors words ;
"/doc/handbook/tools.facts"
"/doc/handbook/tutorial.facts"
"/doc/handbook/words.facts"
} [ parse-resource % ] each
} [ parse-resource* % ] each
architecture get {
{
[ dup "x86" = ] [
{
"/library/compiler/x86/assembler.factor"
"/library/compiler/x86/architecture.factor"
"/library/compiler/x86/generator.factor"
"/library/compiler/x86/slots.factor"
"/library/compiler/x86/stack.factor"
"/library/compiler/x86/fixnum.factor"
"/library/compiler/x86/alien.factor"
}
]
} {
[ dup "ppc" = ] [
{
"/library/compiler/ppc/assembler.factor"
"/library/compiler/ppc/architecture.factor"
"/library/compiler/ppc/generator.factor"
"/library/compiler/ppc/slots.factor"
"/library/compiler/ppc/stack.factor"
"/library/compiler/ppc/fixnum.factor"
"/library/compiler/ppc/alien.factor"
}
]
} {
[ dup "amd64" = ] [
{
"/library/compiler/x86/assembler.factor"
"/library/compiler/amd64/architecture.factor"
"/library/compiler/x86/generator.factor"
"/library/compiler/amd64/generator.factor"
"/library/compiler/x86/slots.factor"
"/library/compiler/amd64/slots.factor"
"/library/compiler/x86/stack.factor"
"/library/compiler/x86/fixnum.factor"
"/library/compiler/amd64/alien.factor"
}
]
}
} cond [ parse-resource % ] each drop
{ "x86" "pentium4" } {
"/library/compiler/x86/assembler.factor"
"/library/compiler/x86/architecture.factor"
"/library/compiler/x86/alien.factor"
"/library/compiler/x86/intrinsics.factor"
} if-arch
{ "pentium4" } {
"/library/compiler/x86/intrinsics-sse2.factor"
} if-arch
{ "ppc" } {
"/library/compiler/ppc/assembler.factor"
"/library/compiler/ppc/architecture.factor"
"/library/compiler/ppc/intrinsics.factor"
} if-arch
{ "amd64" } {
"/library/compiler/x86/assembler.factor"
"/library/compiler/x86/architecture.factor"
"/library/compiler/amd64/architecture.factor"
"/library/compiler/amd64/alien.factor"
"/library/compiler/x86/intrinsics.factor"
"/library/compiler/x86/intrinsics-sse2.factor"
"/library/compiler/amd64/intrinsics.factor"
} if-arch
[
"/library/bootstrap/boot-stage2.factor" run-resource
@ -339,3 +333,6 @@ vocabularies get [
"Building generic words..." print flush
all-words [ generic? ] subset [ make-generic ] each
FORGET: if-arch
FORGET: parse-resource*

29
library/bootstrap/boot-stage2.factor
View File

@ -1,20 +1,20 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler compiler-backend help io io-internals kernel
USING: compiler generic help io io-internals kernel
kernel-internals lists math memory namespaces optimizer parser
sequences sequences-internals words ;
"Cross-referencing..." print
xref-words
xref-articles
"Cross-referencing..." print flush
H{ } clone crossref set-global xref-words
H{ } clone help-graph set-global xref-articles
"compile" get [
"native-io" get [
unix? [
"/library/unix/load.factor" run-resource
] when
] when
windows? [
"/library/windows/load.factor" run-resource
] when
@ -23,15 +23,14 @@ xref-articles
"Compiling base..." print flush
{
uncons 1+ 1- + <= > >= mod length
nth-unsafe set-nth-unsafe
= string>number number>string scan
kill-values (generate)
} [ compile ] each
"Compiling system..." print flush
compile-all
[
\ + compile
\ = compile
{ "kernel" "sequences" "assembler" } compile-vocabs
"Compiling system..." print flush
compile-all
] with-class<cache
terpri
"Unless you're working on the compiler, ignore the errors above." print
@ -78,5 +77,5 @@ number>string write " ms" print
"Bootstrapping is complete." print
"Now, you can run ./f factor.image" print flush
"factor.image" save-image
"factor.image" resource-path save-image
0 exit

42
library/bootstrap/image.factor
View File

@ -62,9 +62,6 @@ SYMBOL: architecture
: word-type 16 ; inline
: tuple-type 17 ; inline
: immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
: >header ( id -- tagged ) object-tag immediate ;
( Image header )
: base 1024 ;
@ -104,11 +101,7 @@ GENERIC: ' ( obj -- ptr )
: align-here ( -- )
here 8 mod 4 = [ 0 emit ] when ;
( Fixnums )
: emit-fixnum ( n -- ) fixnum-tag immediate emit ;
M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
: emit-fixnum ( n -- ) fixnum-tag tag-address emit ;
( Bignums )
@ -136,14 +129,25 @@ M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
M: bignum ' ( bignum -- tagged )
#! This can only emit 0, -1 and 1.
bignum-tag here-as >r
bignum-tag >header emit
bignum-tag tag-header emit
emit-bignum align-here r> ;
( Fixnums )
M: fixnum ' ( n -- tagged )
#! When generating a 32-bit image on a 64-bit system,
#! some fixnums should be bignums.
dup most-negative-fixnum most-positive-fixnum between? [
fixnum-tag tag-address
] [
>bignum '
] if ;
( Floats )
M: float ' ( float -- tagged )
float-tag here-as >r
float-tag >header emit
float-tag tag-header emit
align-here
double>bits emit-64
r> ;
@ -177,7 +181,7 @@ M: f ' ( obj -- ptr )
dup word-vocabulary ' >r
dup word-name ' >r
object-tag here-as over objects get set-hash
word-type >header emit
word-type tag-header emit
hashcode emit-fixnum
r> emit
r> emit
@ -209,7 +213,7 @@ M: word ' ( word -- pointer ) ;
M: wrapper ' ( wrapper -- pointer )
wrapped '
object-tag here-as >r
wrapper-type >header emit
wrapper-type tag-header emit
emit r> ;
( Conses )
@ -234,7 +238,7 @@ M: complex ' ( c -- tagged ) >rect complex-tag emit-cons ;
: emit-string ( string -- ptr )
object-tag here-as swap
string-type >header emit
string-type tag-header emit
dup length emit-fixnum
dup hashcode emit-fixnum
pack-string emit-chars
@ -250,7 +254,7 @@ M: string ' ( string -- pointer )
: emit-array ( list type -- pointer )
>r [ ' ] map r>
object-tag here-as >r
>header emit
tag-header emit
dup length emit-fixnum
( elements -- ) emit-seq
align-here r> ;
@ -270,7 +274,7 @@ M: array ' ( array -- pointer )
M: vector ' ( vector -- pointer )
dup underlying ' swap length
object-tag here-as >r
vector-type >header emit
vector-type tag-header emit
emit-fixnum ( length )
emit ( array ptr )
align-here r> ;
@ -278,7 +282,7 @@ M: vector ' ( vector -- pointer )
M: sbuf ' ( sbuf -- pointer )
dup underlying ' swap length
object-tag here-as >r
sbuf-type >header emit
sbuf-type tag-header emit
emit-fixnum ( length )
emit ( array ptr )
align-here r> ;
@ -288,7 +292,7 @@ M: sbuf ' ( sbuf -- pointer )
M: hashtable ' ( hashtable -- pointer )
[ hash-array ' ] keep
object-tag here-as >r
hashtable-type >header emit
hashtable-type tag-header emit
dup hash-count emit-fixnum
hash-deleted emit-fixnum
emit ( array ptr )
@ -337,7 +341,7 @@ M: hashtable ' ( hashtable -- pointer )
] if ;
: image-name
"boot.image." architecture get append ;
"boot.image." architecture get append resource-path ;
: write-image ( image -- )
"Writing image to " write dup write "..." print flush
@ -361,4 +365,4 @@ M: hashtable ' ( hashtable -- pointer )
] with-scope ;
: make-images ( -- )
{ "x86" "ppc" "amd64" } [ make-image ] each ;
{ "x86" "pentium4" "ppc" "amd64" } [ make-image ] each ;

131
library/bootstrap/primitives.factor
View File

@ -11,13 +11,14 @@ vectors words ;
"Creating primitives and basic runtime structures..." print flush
H{ } clone c-types set
"/library/alien/primitive-types.factor" parse-resource
"/library/compiler/alien/primitive-types.factor" parse-resource
! These symbols need the same hashcode in the target as in the
! host.
! host. They must be symbols -- colon definitions are not
! permitted to be carried over
{
vocabularies typemap builtins c-types
cell crossref articles terms
crossref articles terms
}
! Bring up a bare cross-compiling vocabulary.
@ -59,7 +60,9 @@ call
{ "bits>double" "math" }
{ "<complex>" "math-internals" }
{ "fixnum+" "math-internals" }
{ "fixnum+fast" "math-internals" }
{ "fixnum-" "math-internals" }
{ "fixnum-fast" "math-internals" }
{ "fixnum*" "math-internals" }
{ "fixnum/i" "math-internals" }
{ "fixnum/f" "math-internals" }
@ -256,35 +259,39 @@ num-types f <array> builtins set
"fixnum?" "math" create t "inline" set-word-prop
"fixnum" "math" create 0 "fixnum?" "math" create { } define-builtin
"fixnum" "math" create 0 "math-priority" set-word-prop
"fixnum" "math" create ">fixnum" "math" lookup unit "coercer" set-word-prop
"bignum?" "math" create t "inline" set-word-prop
"bignum" "math" create 1 "bignum?" "math" create { } define-builtin
"bignum" "math" create 1 "math-priority" set-word-prop
"bignum" "math" create ">bignum" "math" lookup unit "coercer" set-word-prop
"cons?" "lists" create t "inline" set-word-prop
"cons" "lists" create 2 "cons?" "lists" create
{ { 0 { "car" "lists" } f } { 1 { "cdr" "lists" } f } } define-builtin
{
{ 0 object { "car" "lists" } f }
{ 1 object { "cdr" "lists" } f }
} define-builtin
"ratio?" "math" create t "inline" set-word-prop
"ratio" "math" create 4 "ratio?" "math" create
{ { 0 { "numerator" "math" } f } { 1 { "denominator" "math" } f } } define-builtin
"ratio" "math" create 2 "math-priority" set-word-prop
{
{ 0 integer { "numerator" "math" } f }
{ 1 integer { "denominator" "math" } f }
} define-builtin
"float?" "math" create t "inline" set-word-prop
"float" "math" create 5 "float?" "math" create { } define-builtin
"float" "math" create 3 "math-priority" set-word-prop
"float" "math" create ">float" "math" lookup unit "coercer" set-word-prop
"complex?" "math" create t "inline" set-word-prop
"complex" "math" create 6 "complex?" "math" create
{ { 0 { "real" "math" } f } { 1 { "imaginary" "math" } f } } define-builtin
"complex" "math" create 4 "math-priority" set-word-prop
{
{ 0 real { "real" "math" } f }
{ 1 real { "imaginary" "math" } f }
} define-builtin
"alien" "alien" create 7 "alien?" "alien" create
{ { 1 { "underlying-alien" "alien" } f } } define-builtin
{ { 1 object { "underlying-alien" "alien" } f } } define-builtin
"array?" "arrays" create t "inline" set-word-prop
"array" "arrays" create 8 "array?" "arrays" create
@ -296,49 +303,115 @@ num-types f <array> builtins set
"hashtable?" "hashtables" create t "inline" set-word-prop
"hashtable" "hashtables" create 10 "hashtable?" "hashtables" create
{
{ 1 { "hash-count" "hashtables" } { "set-hash-count" "hashtables-internals" } }
{ 2 { "hash-deleted" "hashtables" } { "set-hash-deleted" "hashtables-internals" } }
{ 3 { "hash-array" "hashtables-internals" } { "set-hash-array" "hashtables-internals" } }
{
1
fixnum
{ "hash-count" "hashtables" }
{ "set-hash-count" "hashtables-internals" }
} {
2
fixnum
{ "hash-deleted" "hashtables" }
{ "set-hash-deleted" "hashtables-internals" }
} {
3
array
{ "hash-array" "hashtables-internals" }
{ "set-hash-array" "hashtables-internals" }
}
} define-builtin
"vector?" "vectors" create t "inline" set-word-prop
"vector" "vectors" create 11 "vector?" "vectors" create
{
{ 1 { "length" "sequences" } { "set-fill" "sequences-internals" } }
{ 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
{
1
fixnum
{ "length" "sequences" }
{ "set-fill" "sequences-internals" }
} {
2
array
{ "underlying" "sequences-internals" }
{ "set-underlying" "sequences-internals" }
}
} define-builtin
"string?" "strings" create t "inline" set-word-prop
"string" "strings" create 12 "string?" "strings" create
{
{ 1 { "length" "sequences" } f }
{ 2 { "string-hashcode" "kernel-internals" } { "set-string-hashcode" "kernel-internals" } }
{
1
fixnum
{ "length" "sequences" }
f
} {
2
fixnum
{ "string-hashcode" "kernel-internals" }
{ "set-string-hashcode" "kernel-internals" }
}
} define-builtin
"sbuf?" "strings" create t "inline" set-word-prop
"sbuf" "strings" create 13 "sbuf?" "strings" create
{
{ 1 { "length" "sequences" } { "set-fill" "sequences-internals" } }
{ 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
{
1
fixnum
{ "length" "sequences" }
{ "set-fill" "sequences-internals" }
}
{
2
string
{ "underlying" "sequences-internals" }
{ "set-underlying" "sequences-internals" }
}
} define-builtin
"wrapper?" "kernel" create t "inline" set-word-prop
"wrapper" "kernel" create 14 "wrapper?" "kernel" create
{ { 1 { "wrapped" "kernel" } f } } define-builtin
{ { 1 object { "wrapped" "kernel" } f } } define-builtin
"dll?" "alien" create t "inline" set-word-prop
"dll" "alien" create 15 "dll?" "alien" create
{ { 1 { "dll-path" "alien" } f } } define-builtin
{ { 1 object { "dll-path" "alien" } f } } define-builtin
"word?" "words" create t "inline" set-word-prop
"word" "words" create 16 "word?" "words" create
{
{ 1 { "hashcode" "kernel" } f }
{ 2 { "word-name" "words" } f }
{ 3 { "word-vocabulary" "words" } { "set-word-vocabulary" "words" } }
{ 4 { "word-primitive" "words" } { "set-word-primitive" "words" } }
{ 5 { "word-def" "words" } { "set-word-def" "words" } }
{ 6 { "word-props" "words" } { "set-word-props" "words" } }
{ 1 fixnum { "hashcode" "kernel" } f }
{
2
object
{ "word-name" "words" }
f
}
{
3
object
{ "word-vocabulary" "words" }
{ "set-word-vocabulary" "words" }
}
{
4
object
{ "word-primitive" "words" }
{ "set-word-primitive" "words" }
}
{
5
object
{ "word-def" "words" }
{ "set-word-def" "words" }
}
{
6
object
{ "word-props" "words" }
{ "set-word-props" "words" }
}
} define-builtin
"tuple?" "kernel" create t "inline" set-word-prop

6
library/bootstrap/profile-pentium4.factor Normal file
View File

@ -0,0 +1,6 @@
USING: image kernel-internals namespaces ;
! Do not load this file into a running image, ever.
4 \ cell set
big-endian off

2
library/cli.factor
View File

@ -12,7 +12,7 @@ parser sequences strings ;
] when ;
: set-path ( value seq -- )
unswons over [ nest [ set-path ] bind ] [ nip set ] if ;
uncons swap over [ nest [ set-path ] bind ] [ nip set ] if ;
: cli-var-param ( name value -- )
swap ":" split >list set-path ;

27
library/cocoa/callback.factor Normal file
View File

@ -0,0 +1,27 @@
IN: objc-FactorCallback
DEFER: FactorCallback
IN: cocoa
USING: hashtables kernel namespaces objc objc-NSObject ;
SYMBOL: callbacks
H{ } clone callbacks set
"NSObject" "FactorCallback" {
{ "perform:" "void" { "id" "SEL" "id" }
[ nip swap callbacks get hash call ]
}
{ "dealloc" "void" { "id" "SEL" }
[
drop
dup callbacks get remove-hash
SUPER-> [dealloc]
]
}
} { } define-objc-class
: <FactorCallback> ( quot -- id | quot: id -- )
FactorCallback [alloc] [init]
[ callbacks get set-hash ] keep ;

2
library/cocoa/load.factor
View File

@ -7,9 +7,11 @@ USING: compiler io parser sequences words ;
"/library/cocoa/core-foundation.factor"
"/library/cocoa/types.factor"
"/library/cocoa/init-cocoa.factor"
"/library/cocoa/callback.factor"
"/library/cocoa/application-utils.factor"
"/library/cocoa/window-utils.factor"
"/library/cocoa/view-utils.factor"
"/library/cocoa/menu-bar.factor"
"/library/cocoa/ui.factor"
} [
run-resource

142
library/cocoa/menu-bar.factor Normal file
View File

@ -0,0 +1,142 @@
USING: kernel sequences objc cocoa objc-NSObject objc-NSApplication objc-NSWindow objc-NSMenu objc-NSMenuItem objc-FactorCallback gadgets gadgets-layouts gadgets-listener words compiler strings lists ;
! for words used by menu bar actions (copied from launchpad.factor)
USING: gadgets gadgets-browser gadgets-listener help inspector io kernel memory namespaces sequences gadgets-launchpad ;
IN: cocoa
: NSApp NSApplication [sharedApplication] ;
! -------------------------------------------------------------------------
GENERIC: to-target-and-action ( selector-string-or-quotation -- target action )
M: string to-target-and-action sel_registerName f swap ;
M: f to-target-and-action f ;
M: list to-target-and-action \ drop swons <FactorCallback> "perform:" sel_registerName ;
: <NSMenu> NSMenu [alloc] swap <NSString> [initWithTitle:] [autorelease] ;
: set-main-menu NSApp swap [setMainMenu:] ;
: <NSMenuItem> ( title action equivalent -- item )
>r >r >r
NSMenuItem [alloc]
r> <NSString>
r> dup [ sel_registerName ] when
r> <NSString>
[initWithTitle:action:keyEquivalent:] [autorelease] ;
: make-menu-item-2 ( title selector-string-or-quotation equivalent -- item )
swap to-target-and-action swap >r swap <NSMenuItem> dup r> [setTarget:] ;
: submenu-to-item ( menu -- item )
dup [title] CF>string f "" <NSMenuItem> dup rot [setSubmenu:] ;
: add-submenu ( menu submenu -- )
submenu-to-item [addItem:] ;
: and-modifiers ( item key-equivalent-modifier-mask -- item )
dupd [setKeyEquivalentModifierMask:] ;
: and-alternate ( item -- item )
dup 1 [setAlternate:] ;
: and-option-equivalent-modifier 1572864 and-modifiers ;
! -------------------------------------------------------------------------
DEFER: described-menu
! { } => separator
! { { ... } } or
! { { ... } modify-quotation } => submenu as described in inner sequence
! { title action equivalent } or
! { title action equivalent modify-quotation } => item
! this is a mess
: described-item ( desc -- menu-item )
dup length 0 = [
drop NSMenuItem [separatorItem]
] [
dup first string? [
[ first3 make-menu-item-2 ] keep
dup length 4 = [ fourth call ] [ drop ] if
] [
[ first described-menu ] keep
dup length 2 = [ second call ] [ drop ] if
submenu-to-item
] if
] if ;
: and-described-item ( menu desc -- same-menu )
described-item dupd [addItem:] ;
: described-menu ( { title items* } -- menu )
[ first <NSMenu> ] keep
1 swap tail [ and-described-item ] each ;
: and-described-submenu ( menu { title items* } -- menu )
described-menu dupd add-submenu ;
! -------------------------------------------------------------------------
: default-main-menu
{
"<top>"
{ {
"Factor"
! About goes here
! Preferences goes here
{ {
"Services"
} [ dup NSApp swap [setServicesMenu:] ] }
{ }
{ "Hide Factor" "hide:" "h" }
{ "Hide Others" "hideOtherApplications:" "h" [ and-option-equivalent-modifier ] }
{ "Show All" "unhideAllApplications:" "" }
{ }
{ "Save Image" [ save ] "s" }
{ }
{ "Quit" "terminate:" "q" }
} [ dup NSApp swap [setAppleMenu:] ] }
{ {
! Tools is standing in for the File menu
"Tools"
{ "Listener" [ listener-window ] "n" }
{ "Vocabulary List" [ [ vocabs. ] "Vocabularies" pane-window ] "y" }
{ "Globals" [ global browser-window ] "u" }
{ "Memory" [ [ heap-stats. terpri room. ] "Memory" pane-window ] "u" }
} }
{ {
"Edit"
{ "Undo" "undo:" "z" }
{ "Redo" "redo:" "Z" }
{ }
{ "Cut" "cut:" "x" }
{ "Copy" "copy:" "c" }
{ "Paste" "paste:" "v" }
{ "Paste and Match Style" "pasteAsPlainText:" "V" [ and-option-equivalent-modifier ] }
{ "Delete" "delete:" "" }
{ "Select All" "selectAll:" "a" }
! { }
! Find, Spelling, and Speech submenus go here
} }
{ {
"Window"
{ "Close" "performClose:" "w" }
{ "Zoom" "performZoom:" "" }
{ "Minimize" "performMiniaturize:" "m" }
{ "Minimize All" "miniaturizeAll:" "m" [ and-alternate and-option-equivalent-modifier ] }
{ }
{ "Bring All to Front" "arrangeInFront:" "" }
} [ dup NSApp swap [setWindowsMenu:] ] }
{ {
"Help"
{ "Factor Documentation" [ handbook-window ] "?" }
{ "Help Index" [ [ articles. ] "Help index" pane-window ] "" }
{ "Vocabularies" [ [ vocabs. ] "Vocabularies" pane-window ] "" }
} }
} described-menu set-main-menu ;

18
library/cocoa/subclassing.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: objc
USING: alien arrays compiler hashtables kernel kernel-internals
libc math namespaces sequences strings words ;
libc lists math namespaces sequences strings words ;
: init-method ( method alien -- )
>r first3 r>
@ -64,13 +64,19 @@ libc math namespaces sequences strings words ;
>r 1array r> append
[ [ alien>objc-types get hash % CHAR: 0 , ] each ] "" make ;
: prepare-method ( { name ret types quot } -- { name type imp } )
[ first3 encode-types ] keep
[ 1 swap tail % \ alien-callback , ] [ ] make compile-quot
3array ;
: struct-return ( ret types quot -- ret types quot )
pick c-struct? [
pick c-size [ memcpy ] curry append
>r { "void*" } swap append >r drop "void" r> r>
] when ;
: prepare-method ( ret types quot -- type imp )
>r [ encode-types ] 2keep r>
[ struct-return 3array % \ alien-callback , ] [ ] make
compile-quot ;
: prepare-methods ( methods -- methods )
[ prepare-method ] map ;
[ first4 prepare-method 3array ] map ;
: define-objc-class ( superclass name imeth cmeth -- )
pick >r

11
library/cocoa/types.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
IN: cocoa
USING: alien kernel ;
USING: alien kernel math ;
BEGIN-STRUCT: NSRect
FIELD: float x
@ -20,6 +20,15 @@ TYPEDEF: NSRect CGRect
[ set-NSRect-y ] keep
[ set-NSRect-x ] keep ;
: NSRect-x-y ( rect -- origin-x origin-y )
[ NSRect-x ] keep NSRect-y ;
: NSRect-x-far-y ( rect -- origin-x far-y )
[ NSRect-x-y ] keep NSRect-h + ;
: <far-y-NSRect> ( x y w h -- rect )
rot dupd swap - -rot <NSRect> ;
BEGIN-STRUCT: NSPoint
FIELD: float x
FIELD: float y

51
library/cocoa/ui.factor
View File

@ -2,12 +2,14 @@
! See http://factorcode.org/license.txt for BSD license.
IN: objc-FactorView
DEFER: FactorView
IN: objc-FactorUIWindowDelegate
DEFER: FactorUIWindowDelegate
USING: arrays cocoa errors freetype gadgets gadgets-launchpad
gadgets-layouts gadgets-listener gadgets-panes hashtables kernel
lists math namespaces objc objc-NSApplication objc-NSEvent
objc-NSObject objc-NSOpenGLContext objc-NSOpenGLView objc-NSView
objc-NSWindow sequences threads ;
USING: alien arrays cocoa errors freetype gadgets
gadgets-launchpad gadgets-layouts gadgets-listener gadgets-panes
hashtables kernel lists math namespaces objc objc-NSApplication
objc-NSEvent objc-NSObject objc-NSOpenGLContext
objc-NSOpenGLView objc-NSView objc-NSWindow sequences threads ;
! Cocoa backend for Factor UI
@ -18,6 +20,11 @@ SYMBOL: views
H{ } clone views set-global
: purge-views ( hash -- hash )
global [
views [ [ drop expired? not ] hash-subset ] change
] bind ;
: view ( handle -- world ) views get hash ;
: mouse-location ( view event -- loc )
@ -166,13 +173,42 @@ H{ } clone views set-global
FactorView over rect-dim <GLView>
[ over set-world-handle dup add-notify register-view ] keep ;
: window-root-gadget-pref-dim [contentView] view pref-dim ;
: frame-rect-for-window-content-rect ( window rect -- rect )
swap [styleMask] NSWindow -rot [frameRectForContentRect:styleMask:] ;
: content-rect-for-window-frame-rect ( window rect -- rect )
swap [styleMask] NSWindow -rot [contentRectForFrameRect:styleMask:] ;
: window-content-rect ( window -- rect )
dup [frame] content-rect-for-window-frame-rect ;
"NSObject" "FactorUIWindowDelegate" {
{ "windowWillUseStandardFrame:defaultFrame:" "NSRect" { "id" "SEL" "id" "NSRect" }
[
drop 2nip ( self sel window default-frame -- window )
dup window-content-rect NSRect-x-far-y ( window -- window x y )
pick window-root-gadget-pref-dim first2 ( window x y -- window x y w h )
<far-y-NSRect>
frame-rect-for-window-content-rect
]
}
} { } define-objc-class
: install-window-delegate ( window -- )
FactorUIWindowDelegate [alloc] [init] [setDelegate:] ;
IN: gadgets
: redraw-world ( handle -- )
world-handle 1 [setNeedsDisplay:] ;
: open-window* ( world title -- )
>r <FactorView> r> <ViewWindow> [contentView] [release] ;
>r <FactorView> r> <ViewWindow>
dup install-window-delegate
[contentView] [release] ;
: select-gl-context ( handle -- )
[openGLContext] [makeCurrentContext] ;
@ -189,7 +225,8 @@ IN: shells
[
[
init-ui
launchpad-window
purge-views
default-main-menu
listener-window
finish-launching
event-loop

3
library/cocoa/utilities.factor
View File

@ -119,9 +119,6 @@ H{
: class-methods ( classname -- seq )
objc-meta-class objc-methods ;
: make-dip ( quot n -- quot )
dup \ >r <array> -rot \ r> <array> append3 ;
: <super> ( receiver class -- super )
"objc-super" <c-object>
[ set-objc-super-class ] keep

3
library/collections/graphs.factor
View File

@ -17,8 +17,7 @@ USING: hashtables kernel namespaces sequences ;
swap [ swap (add-vertex) ] each-with
] if-graph ;
: (remove-vertex) ( vertex graph -- )
nest remove-hash ;
: (remove-vertex) ( vertex graph -- ) nest remove-hash ;
: remove-vertex ( vertex edges graph -- )
[

9
library/collections/growable.factor
View File

@ -13,7 +13,7 @@ GENERIC: set-fill
: capacity ( seq -- n ) underlying length ; inline
: expand ( len seq -- )
[ underlying resize ] keep set-underlying ;
[ underlying resize ] keep set-underlying ; inline
: new-size ( n -- n ) 3 * dup 50 < [ drop 50 ] when ;
@ -22,7 +22,7 @@ GENERIC: set-fill
>r 1+ r>
2dup capacity > [ over new-size over expand ] when
2dup set-fill
] when 2drop ;
] when 2drop ; inline
TUPLE: bounds-error index seq ;
@ -35,7 +35,8 @@ TUPLE: bounds-error index seq ;
2dup bounds-check? [ bounds-error ] unless ; inline
: grow-length ( len seq -- )
growable-check 2dup capacity > [ 2dup expand ] when set-fill ;
growable-check 2dup capacity > [ 2dup expand ] when set-fill
; inline
: clone-growable ( obj -- obj )
(clone) dup underlying clone over set-underlying ;
(clone) dup underlying clone over set-underlying ; inline

48
library/collections/hashtables.factor
View File

@ -9,9 +9,10 @@ TUPLE: tombstone ;
: ((empty)) T{ tombstone f } ; inline
: ((tombstone)) T{ tombstone t } ; inline
: hash@ ( key keys -- n ) >r hashcode r> length 2 /i rem 2 * ;
: hash@ ( key keys -- n )
>r hashcode r> length 2 /i rem 2 * ; inline
: probe ( heys i -- hash i ) 2 + over length mod ;
: probe ( heys i -- hash i ) 2 + over length mod ; inline
: (key@) ( key keys i -- n )
3dup swap nth-unsafe {
@ -21,51 +22,58 @@ TUPLE: tombstone ;
{ [ t ] [ probe (key@) ] }
} cond ;
: key@ ( key hash -- n ) hash-array 2dup hash@ (key@) ;
: key@ ( key hash -- n )
hash-array 2dup hash@ (key@) ; inline
: if-key ( key hash true false -- | true: index key hash -- )
>r >r [ key@ ] 2keep pick -1 > r> r> if ; inline
: <hash-array> ( n -- array ) 1+ 4 * ((empty)) <array> ;
: <hash-array> ( n -- array )
1+ 4 * ((empty)) <array> ; inline
: init-hash ( hash -- )
0 over set-hash-count 0 swap set-hash-deleted ;
: reset-hash ( n hash -- )
swap <hash-array> over set-hash-array
0 over set-hash-count 0 swap set-hash-deleted ;
swap <hash-array> over set-hash-array init-hash ;
: (new-key@) ( key keys i -- n )
3dup swap nth-unsafe dup tombstone? [
2drop 2nip
] [
= [ 2nip ] [ probe (new-key@) ] if
] if ;
] if ; inline
: new-key@ ( key hash -- n )
hash-array 2dup hash@ (new-key@) ;
hash-array 2dup hash@ (new-key@) ; inline
: nth-pair ( n seq -- key value )
[ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ;
[ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ; inline
: set-nth-pair ( value key n seq -- )
[ set-nth-unsafe ] 2keep >r 1+ r> set-nth-unsafe ;
[ set-nth-unsafe ] 2keep >r 1+ r> set-nth-unsafe ; inline
: hash-count+ dup hash-count 1+ swap set-hash-count ;
: hash-count+
dup hash-count 1+ swap set-hash-count ; inline
: hash-deleted+ dup hash-deleted 1+ swap set-hash-deleted ;
: hash-deleted+
dup hash-deleted 1+ swap set-hash-deleted ; inline
: hash-deleted- dup hash-deleted 1- swap set-hash-deleted ;
: hash-deleted-
dup hash-deleted 1- swap set-hash-deleted ; inline
: change-size ( hash old -- )
dup ((tombstone)) eq? [
drop hash-deleted-
] [
((empty)) eq? [ hash-count+ ] [ drop ] if
] if ;
] if ; inline
: (set-hash) ( value key hash -- )
2dup new-key@ swap
[ hash-array 2dup nth-unsafe ] keep
( value key n hash-array old hash )
swap change-size set-nth-pair ;
swap change-size set-nth-pair ; inline
: (each-pair) ( quot array i -- | quot: k v -- )
over length over number= [
@ -124,7 +132,7 @@ IN: hashtables
dup [ hash ] [ 2drop f ] if ;
: clear-hash ( hash -- )
[ hash-array length ] keep reset-hash ;
dup init-hash hash-array [ drop ((empty)) ] inject ;
: remove-hash ( key hash -- )
[
@ -135,7 +143,8 @@ IN: hashtables
3drop
] if-key ;
: hash-size ( hash -- n ) dup hash-count swap hash-deleted - ;
: hash-size ( hash -- n )
dup hash-count swap hash-deleted - ; inline
: hash-empty? ( hash -- ? ) hash-size zero? ;
@ -146,7 +155,7 @@ IN: hashtables
: ?grow-hash ( hash -- )
dup hash-count 3 * over hash-array length >
[ dup grow-hash ] when drop ;
[ dup grow-hash ] when drop ; inline
: set-hash ( value key hash -- )
[ (set-hash) ] keep ?grow-hash ;
@ -235,9 +244,6 @@ M: hashtable hashcode ( hash -- n )
: ?hash* ( key hash/f -- value/f )
dup [ hash* ] [ 2drop f f ] if ; flushable
: ?set-hash ( value key hash/f -- hash )
[ [ set-hash ] keep ] [ associate ] if ;
: hash-stack ( key seq -- value )
[ dupd hash-member? ] find-last nip ?hash ; flushable

5
library/collections/hashtables.facts
View File

@ -146,11 +146,6 @@ HELP: set-hash "( value key hash -- )"
{ $description "Stores an entry into the hashtable." }
{ $see-also hash remove-hash } ;
HELP: ?set-hash "( value key hash/f -- hash )"
{ $values { "value" "a value" } { "key" "a key" } { "hash/f" "a hashtable or " { $link f } } }
{ $description "If the mapping is " { $link f } ", constructs a new hashtable storing the given key/value pair. Otherwise, stores the key/value pair into the hashtable." }
{ $see-also hash remove-hash } ;
HELP: hash-keys "( hash -- keys )"
{ $values { "hash" "a hashtable" } { "keys" "an array of keys" } }
{ $description "Outputs an array of all keys in the hashtable." }

6
library/collections/lists.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: lists USING: errors generic kernel math sequences ;
IN: lists USING: arrays errors generic kernel math sequences ;
M: f car ;
M: f cdr ;
@ -16,7 +16,6 @@ PREDICATE: general-list list ( list -- ? )
[ cdr list? ] [ t ] if* ;
: uncons ( [[ car cdr ]] -- car cdr ) dup car swap cdr ; inline
: unswons ( [[ car cdr ]] -- cdr car ) dup cdr swap car ; inline
: swons ( cdr car -- [[ car cdr ]] ) swap cons ; inline
: unit ( a -- [ a ] ) f cons ; inline
@ -79,6 +78,9 @@ M: cons = ( obj cons -- ? )
: curry ( obj quot -- quot ) >r literalize r> cons ;
: make-dip ( quot n -- quot )
dup \ >r <array> -rot \ r> <array> append3 >list ;
: (>list) ( n i seq -- list )
pick pick <= [
3drop [ ]

27
library/collections/namespaces.factor
View File

@ -1,18 +1,23 @@
! Copyright (C) 2003, 2005 Slava Pestov.
! Copyright (C) 2003, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: kernel-internals
USING: vectors ;
: namestack* ( -- ns ) 3 getenv { vector } declare ; inline
IN: namespaces
USING: arrays hashtables kernel kernel-internals lists math
sequences strings vectors words ;
sequences strings words ;
: namestack* ( -- ns ) 3 getenv ; inline
: namestack ( -- ns ) namestack* clone ; inline
: set-namestack ( ns -- ) clone 3 setenv ; inline
: namespace ( -- namespace ) namestack* peek ; inline
: >n ( namespace -- n:namespace ) namestack* push ; inline
: n> ( n:namespace -- namespace ) namestack* pop ; inline
: global ( -- g ) 4 getenv ; inline
: set-namestack ( ns -- ) >vector 3 setenv ; inline
: namespace ( -- namespace ) namestack* peek ;
: >n ( namespace -- n:namespace ) namestack* push ;
: n> ( n:namespace -- namespace ) namestack* pop ;
: ndrop ( n:namespace -- ) namestack* pop* ;
: global ( -- g ) 4 getenv { hashtable } declare ; inline
: get ( variable -- value ) namestack* hash-stack ; flushable
: set ( value variable -- ) namespace set-hash ;
: set ( value variable -- ) namespace set-hash ; inline
: on ( var -- ) t swap set ; inline
: off ( var -- ) f swap set ; inline
: get-global ( var -- value ) global hash ; inline
@ -30,13 +35,13 @@ sequences strings vectors words ;
: dec ( var -- ) -1 swap +@ ; inline
: bind ( namespace quot -- ) swap >n call n> drop ; inline
: bind ( namespace quot -- ) swap >n call ndrop ; inline
: counter ( var -- n ) global [ dup inc get ] bind ;
: make-hash ( quot -- hash ) H{ } clone >n call n> ; inline
: with-scope ( quot -- ) make-hash drop ; inline
: with-scope ( quot -- ) H{ } clone >n call ndrop ; inline
! Building sequences
SYMBOL: building

2
library/collections/namespaces.facts
View File

@ -1,5 +1,5 @@
IN: namespaces
USING: help ;
USING: help kernel-internals ;
HELP: get "( variable -- value )"
{ $values { "variable" "a variable, by convention a symbol" } { "value" "the value, or " { $link f } } }

2
library/collections/sequence-combinators.facts
View File

@ -3,7 +3,7 @@ USING: help math sequences-internals ;
HELP: collect "( n quot -- array )"
{ $values { "n" "a non-negative integer" } { "quot" "a quotation with stack effect " { $snippet "( n -- value )" } } { "array" "an array with " { $snippet "n" } " elements" } }
{ $description "A primitive mapping operation that applies a quotation to all integers from 0 up to but not including " { $snippet "n" } ", and collects the results in a new array. Client code should use " { $snippet map } " instead." } ;
{ $description "A primitive mapping operation that applies a quotation to all integers from 0 up to but not including " { $snippet "n" } ", and collects the results in a new array. Client code should use " { $link map } " instead." } ;
HELP: each "( seq quot -- )"
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }

2
library/collections/sequence-eq.factor
View File

@ -13,7 +13,7 @@ UNION: sequence array string sbuf vector ;
dup length [ >r 2dup r> 2nth-unsafe = ] all? 2nip
] [
2drop f
] if ; inline
] if ;
M: sequence = ( obj seq -- ? )
2dup eq? [

17
library/collections/sequences-epilogue.factor
View File

@ -1,17 +1,17 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: sequences
USING: errors generic kernel kernel-internals math
USING: arrays errors generic kernel kernel-internals math
sequences-internals strings vectors words ;
: first2 ( { x y } -- x y )
1 swap bounds-check nip first2-unsafe ; inline
1 swap bounds-check nip first2-unsafe ; flushable
: first3 ( { x y z } -- x y z )
2 swap bounds-check nip first3-unsafe ; inline
2 swap bounds-check nip first3-unsafe ; flushable
: first4 ( { x y z w } -- x y z w )
3 swap bounds-check nip first4-unsafe ; inline
3 swap bounds-check nip first4-unsafe ; flushable
M: object like drop ;
@ -82,6 +82,11 @@ M: object like drop ;
: add ( seq elt -- seq )
swap [ push ] immutable ; flushable
: add* ( seq elt -- seq )
over >r
over thaw [ push ] keep [ swap nappend ] keep
r> like ; flushable
: diff ( seq1 seq2 -- seq2-seq1 )
[ swap member? not ] subset-with ; flushable
@ -93,10 +98,10 @@ M: object like drop ;
: pop* ( sequence -- )
[ length 1- ] keep
[ 0 -rot set-nth ] 2keep
set-length ; inline
set-length ;
: pop ( sequence -- element )
dup peek swap pop* ; inline
dup peek swap pop* ;
M: object reverse-slice ( seq -- seq ) <reversed> ;

4
library/collections/sequences-epilogue.facts
View File

@ -40,8 +40,8 @@ HELP: memq? "( obj seq -- ? )"
}
{ $see-also index index* member? } ;
HELP: remove "( elt seq -- ? )"
{ $values { "elt" "an object" } { "seq" "a sequence" } }
HELP: remove "( elt seq -- newseq )"
{ $values { "elt" "an object" } { "seq" "a sequence" } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence containing all elements of the input sequence except those equal to the given element." } ;
HELP: subst "( newseq oldseq seq -- )"

6
library/collections/sequences.factor
View File

@ -12,7 +12,7 @@ GENERIC: like ( seq seq -- seq ) flushable
GENERIC: reverse ( seq -- seq ) flushable
GENERIC: reverse-slice ( seq -- seq ) flushable
: empty? ( seq -- ? ) length zero? ;
: empty? ( seq -- ? ) length zero? ; inline
: first 0 swap nth ; inline
: second 1 swap nth ; inline
@ -20,13 +20,13 @@ GENERIC: reverse-slice ( seq -- seq ) flushable
: fourth 3 swap nth ; inline
: push ( element sequence -- )
dup length swap set-nth ; inline
dup length swap set-nth ;
: ?push ( elt seq/f -- seq )
[ 1 <vector> ] unless* [ push ] keep ;
: bounds-check? ( n seq -- ? )
over 0 >= [ length < ] [ 2drop f ] if ;
over 0 >= [ length < ] [ 2drop f ] if ; inline
: ?nth ( n seq/f -- elt/f )
2dup bounds-check? [ nth ] [ 2drop f ] if ;

3
library/collections/slicing.factor
View File

@ -104,8 +104,7 @@ strings vectors ;
tuck swap tail-slice >r swap tail-slice r> ;
: unpair ( seq -- firsts seconds )
2 swap group flip
dup empty? [ drop { } { } ] [ first2 ] if ;
flip dup empty? [ drop { } { } ] [ first2 ] if ;
: concat ( seq -- seq )
dup empty? [ [ [ % ] each ] over first make ] unless ;

32
library/alien/alien-callback.factor → library/compiler/alien/alien-callback.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: alien
USING: compiler-backend compiler-frontend errors generic
hashtables inference inspector kernel lists namespaces sequences
strings words ;
USING: compiler errors generic hashtables inference inspector
kernel lists namespaces sequences strings words ;
TUPLE: alien-callback return parameters quot xt ;
C: alien-callback make-node ;
@ -33,35 +32,34 @@ M: alien-callback-error summary ( error -- )
] "infer" set-word-prop
: box-parameters ( parameters -- )
[ box-parameter ] map-parameters % ;
[ box-parameter ] each-parameter ;
: registers>objects ( parameters -- )
dup \ %freg>stack move-parameters %
"nest_stacks" f %alien-invoke , box-parameters ;
dup \ %freg>stack move-parameters
"nest_stacks" f %alien-invoke box-parameters ;
: unbox-return ( node -- )
alien-callback-return [
"unnest_stacks" f %alien-invoke ,
"unnest_stacks" f %alien-invoke
] [
c-type [
"reg-class" get
"unboxer-function" get
%callback-value ,
%callback-value
] bind
] if-void ;
: linearize-callback ( node -- )
dup alien-callback-xt [
dup stack-reserve* %prologue ,
: generate-callback ( node -- )
[ alien-callback-xt ] keep [
dup alien-callback-parameters registers>objects
dup alien-callback-quot \ init-error-handler swons
%alien-callback ,
dup alien-callback-quot \ init-error-handler add*
%alien-callback
unbox-return
%return ,
] make-linear ;
%return
] generate-block ;
M: alien-callback linearize* ( node -- )
compile-gc linearize-callback iterate-next ;
M: alien-callback generate-node ( node -- )
end-basic-block compile-gc generate-callback iterate-next ;
M: alien-callback stack-reserve*
alien-callback-parameters stack-space ;

0
library/alien/alien-callback.facts → library/compiler/alien/alien-callback.facts
View File

34
library/alien/alien-invoke.factor → library/compiler/alien/alien-invoke.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: alien
USING: arrays assembler compiler compiler-backend
compiler-frontend errors generic hashtables inference inspector
USING: arrays assembler compiler compiler
errors generic hashtables inference inspector
io kernel kernel-internals lists math namespaces parser
prettyprint sequences strings words ;
@ -39,48 +39,50 @@ M: alien-invoke-error summary ( error -- )
node,
] "infer" set-word-prop
: unbox-parameter ( stack# type -- node )
: unbox-parameter ( stack# type -- )
c-type [ "reg-class" get "unboxer" get call ] bind ;
: unbox-parameters ( parameters -- )
[ unbox-parameter , ] reverse-each-parameter ;
[ unbox-parameter ] reverse-each-parameter ;
: objects>registers ( parameters -- )
#! Generate code for boxing a list of C types, then generate
#! code for moving these parameters to register on
#! architectures where parameters are passed in registers
#! (PowerPC, AMD64).
dup unbox-parameters "save_stacks" f %alien-invoke ,
\ %stack>freg move-parameters % ;
dup unbox-parameters "save_stacks" f %alien-invoke
\ %stack>freg move-parameters ;
: box-return ( node -- )
alien-invoke-return [ ] [ f swap box-parameter , ] if-void ;
alien-invoke-return [ ] [ f swap box-parameter ] if-void ;
: linearize-cleanup ( node -- )
: generate-cleanup ( node -- )
dup alien-invoke-library library-abi "stdcall" = [
drop
] [
alien-invoke-parameters stack-space %cleanup ,
alien-invoke-parameters stack-space %cleanup
] if ;
M: alien-invoke linearize* ( node -- )
compile-gc
M: alien-invoke generate-node ( node -- )
end-basic-block compile-gc
dup alien-invoke-parameters objects>registers
dup alien-invoke-dlsym %alien-invoke ,
dup linearize-cleanup box-return
dup alien-invoke-dlsym %alien-invoke
dup generate-cleanup box-return
iterate-next ;
M: alien-invoke stack-reserve*
alien-invoke-parameters stack-space ;
: parse-arglist ( return seq -- types stack-effect )
unpair rot dup "void" = [ drop { } ] [ 1array ] if 2array
2 swap group unpair
rot dup "void" = [ drop { } ] [ 1array ] if 2array
effect>string ;
: (define-c-word) ( type lib func types stack-effect -- )
>r over create-in >r
[ alien-invoke ] cons cons cons cons r> swap define-compound
word r> "stack-effect" set-word-prop ;
[ alien-invoke ] curry curry curry curry
r> swap define-compound word r>
"stack-effect" set-word-prop ;
: define-c-word ( return library function parameters -- )
[ "()" subseq? not ] subset >r pick r> parse-arglist

0
library/alien/alien-invoke.facts → library/compiler/alien/alien-invoke.facts
View File

0
library/alien/aliens.factor → library/compiler/alien/aliens.factor
View File

0
library/alien/aliens.facts → library/compiler/alien/aliens.facts
View File

10
library/alien/c-types.factor → library/compiler/alien/c-types.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: arrays compiler compiler-backend errors generic
USING: arrays compiler errors generic
hashtables kernel kernel-internals libc lists math namespaces
parser sequences strings words ;
@ -53,10 +53,10 @@ SYMBOL: c-types
: define-deref ( name vocab -- )
>r dup "*" swap append r> create
swap c-getter 0 swons define-compound ;
swap c-getter 0 add* define-compound ;
: (define-nth) ( word type quot -- )
>r c-size [ rot * ] curry r> append define-compound ;
>r c-size [ rot * ] swap add* r> append define-compound ;
: define-nth ( name vocab -- )
>r dup "-nth" append r> create
@ -67,8 +67,8 @@ SYMBOL: c-types
swap dup c-setter (define-nth) ;
: define-out ( name vocab -- )
over [ <c-object> tuck 0 ] over c-setter append
>r >r constructor-word r> r> cons define-compound ;
over [ <c-object> tuck 0 ] over c-setter append swap
>r >r constructor-word r> r> add* define-compound ;
: init-c-type ( name vocab -- )
over define-pointer define-nth ;

0
library/alien/c-types.facts → library/compiler/alien/c-types.facts
View File

24
library/alien/compiler.factor → library/compiler/alien/compiler.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: alien
USING: arrays compiler-backend generic hashtables kernel
USING: arrays compiler generic hashtables kernel
kernel-internals math namespaces sequences words ;
: parameter-size c-size cell align ;
@ -27,7 +27,8 @@ kernel-internals math namespaces sequences words ;
#! n is a stack location, and the value of the class
#! variable is a register number.
c-type "reg-class" swap hash dup reg-class-full?
[ spill-param ] [ fastcall-param ] if ;
[ spill-param ] [ fastcall-param ] if
[ fastcall-regs nth ] keep ;
: flatten-value-types ( params -- params )
#! Convert value type structs to consecutive void*s.
@ -36,22 +37,25 @@ kernel-internals math namespaces sequences words ;
[ c-size cell / "void*" <array> ] [ 1array ] if
] map concat ;
: each-parameter ( parameters quot -- )
>r [ parameter-sizes ] keep r> 2each ; inline
: reverse-each-parameter ( parameters quot -- )
>r [ parameter-sizes ] keep
[ reverse-slice ] 2apply r> 2each ; inline
: map-parameters ( parameters quot -- seq )
>r [ parameter-sizes ] keep r> 2map ; inline
: reset-freg-counts ( -- )
0 { int-regs float-regs stack-params } [ set ] each-with ;
: move-parameters ( params vop -- seq )
#! Moves values from C stack to registers (if vop is
#! %stack>freg) and registers to C stack (if vop is
: move-parameters ( params word -- )
#! Moves values from C stack to registers (if word is
#! %stack>freg) and registers to C stack (if word is
#! %freg>stack).
swap [
flatten-value-types
0 { int-regs float-regs stack-params } [ set ] each-with
[ pick >r alloc-parameter r> execute ] map-parameters
nip
reset-freg-counts
[ pick >r alloc-parameter r> execute ] each-parameter
drop
] with-scope ; inline
: box-parameter ( stack# type -- node )

0
library/alien/malloc.factor → library/compiler/alien/malloc.factor
View File

0
library/alien/malloc.facts → library/compiler/alien/malloc.facts
View File

3
library/alien/primitive-types.factor → library/compiler/alien/primitive-types.factor
View File

@ -1,5 +1,4 @@
USING: alien compiler-backend kernel kernel-internals
math namespaces ;
USING: alien compiler kernel kernel-internals math namespaces ;
[
[ alien-unsigned-cell <alien> ] "getter" set

6
library/alien/structs.factor → library/compiler/alien/structs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler compiler-backend errors generic
USING: assembler compiler errors generic
hashtables kernel kernel-internals lists math namespaces parser
sequences strings words ;
@ -10,12 +10,12 @@ sequences strings words ;
: define-getter ( offset type name -- )
#! Define a word with stack effect ( alien -- obj ) in the
#! current 'in' vocabulary.
create-in >r c-getter cons r> swap define-compound ;
create-in >r c-getter swap add* r> swap define-compound ;
: define-setter ( offset type name -- )
#! Define a word with stack effect ( obj alien -- ) in the
#! current 'in' vocabulary.
"set-" swap append create-in >r c-setter cons r>
"set-" swap append create-in >r c-setter swap add* r>
swap define-compound ;
: define-field ( offset type name -- offset )

0
library/alien/structs.facts → library/compiler/alien/structs.facts
View File

0
library/alien/syntax.factor → library/compiler/alien/syntax.factor
View File

0
library/alien/syntax.facts → library/compiler/alien/syntax.facts
View File

98
library/compiler/amd64/alien.factor
View File

@ -1,92 +1,80 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler-backend
IN: compiler
USING: alien arrays assembler kernel kernel-internals math
sequences ;
GENERIC: freg>stack ( stack reg reg-class -- )
GENERIC: stack>freg ( stack reg reg-class -- )
: stack@ RSP swap [+] ;
M: int-regs freg>stack drop >r stack@ r> MOV ;
M: int-regs %freg>stack drop >r stack@ r> MOV ;
M: int-regs stack>freg drop swap stack@ MOV ;
M: int-regs %stack>freg drop swap stack@ MOV ;
: MOVSS/LPD float-regs-size 4 = [ MOVSS ] [ MOVLPD ] if ;
: MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ;
M: float-regs freg>stack >r >r stack@ r> r> MOVSS/LPD ;
M: float-regs %freg>stack >r >r stack@ r> r> MOVSS/D ;
M: float-regs stack>freg >r swap stack@ r> MOVSS/LPD ;
M: float-regs %stack>freg >r swap stack@ r> MOVSS/D ;
M: stack-params stack>freg
M: stack-params %stack>freg
drop >r R11 swap stack@ MOV r> stack@ R11 MOV ;
M: stack-params freg>stack
>r stack-increment + cell + swap r> stack>freg ;
M: stack-params %freg>stack
>r stack-increment + cell + swap r> %stack>freg ;
M: %unbox-struct generate-node ( vop -- )
drop
: struct-ptr/size ( n reg-class size func -- )
rot drop
! Load destination address
RDI RSP MOV
RDI 0 input ADD
>r RDI RSP MOV
RDI rot ADD
! Load struct size
RSI 2 input MOV
RSI swap MOV
! Copy the struct to the stack
"unbox_value_struct" f compile-c-call ;
r> f compile-c-call ;
M: %unbox generate-node ( vop -- )
drop
: %unbox-struct ( n reg-class size -- )
"unbox_value_struct" struct-ptr/size ;
: %unbox ( n reg-class func -- )
! Call the unboxer
2 input f compile-c-call
f compile-c-call
! Store the return value on the C stack
0 input 1 input [ return-reg ] keep freg>stack ;
[ return-reg ] keep %freg>stack ;
: (%move) 0 input 1 input 2 input [ fastcall-regs nth ] keep ;
M: %stack>freg generate-node ( vop -- )
! Move a value from the C stack into the fastcall register
drop (%move) stack>freg ;
M: %freg>stack generate-node ( vop -- )
! Move a value from a fastcall register to the C stack
drop (%move) freg>stack ;
: reset-sse RAX RAX XOR ;
M: %alien-invoke generate-node
reset-sse
drop 0 input 1 input load-library compile-c-call ;
: %box-struct ( n reg-class size -- )
"box_value_struct" struct-ptr/size ;
: load-return-value ( reg-class -- )
dup fastcall-regs first swap return-reg
2dup eq? [ 2drop ] [ MOV ] if ;
M: %box generate-node ( vop -- )
drop
0 input [
1 input [ fastcall-regs first ] keep stack>freg
: %box ( n reg-class func -- )
rot [
rot [ fastcall-regs first ] keep %stack>freg
] [
1 input load-return-value
swap load-return-value
] if*
2 input f compile-c-call ;
f compile-c-call ;
M: %alien-callback generate-node ( vop -- )
drop
RDI 0 input load-indirect
"run_callback" f compile-c-call ;
: reset-sse RAX RAX XOR ;
: save-return 0 swap [ return-reg ] keep freg>stack ;
: load-return 0 swap [ return-reg ] keep stack>freg ;
: %alien-invoke ( symbol dll -- )
reset-sse compile-c-call ;
M: %callback-value generate-node ( vop -- )
drop
: %alien-callback ( quot -- )
RDI load-indirect "run_callback" f compile-c-call ;
: save-return 0 swap [ return-reg ] keep %freg>stack ;
: load-return 0 swap [ return-reg ] keep %stack>freg ;
: %callback-value ( reg-class func -- )
! Call the unboxer
1 input f compile-c-call
f compile-c-call
! Save return register
0 input save-return
dup save-return
! Restore data/callstacks
"unnest_stacks" f compile-c-call
! Restore return register
0 input load-return ;
load-return ;
: %cleanup ( n -- ) drop ;

59
library/compiler/amd64/architecture.factor
View File

@ -1,59 +1,60 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler-backend
USING: alien arrays assembler compiler compiler-frontend kernel
kernel-internals math namespaces sequences ;
IN: compiler
USING: alien arrays assembler generic kernel kernel-internals
math namespaces sequences ;
! AMD64 register assignments
! RAX RCX RDX RSI RDI R8 R9 R10 R11 vregs
! RAX RCX RDX RSI RDI R8 R9 R10 integer vregs
! XMM0 - XMM7 float vregs
! R13 cards_offset
! R14 datastack
! R15 callstack
: fixnum-imm? ( -- ? )
#! Can fixnum operations take immediate operands?
f ; inline
: ds-reg R14 ; inline
: cs-reg R15 ; inline
: remainder-reg RDX ; inline
: vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ; inline
: alloc-tmp-reg RBX ; inline
M: int-regs return-reg drop RAX ;
M: int-regs vregs drop { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs return-reg drop XMM0 ;
M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
M: float-regs fastcall-regs vregs ;
: address-operand ( address -- operand )
#! On AMD64, we have to load 64-bit addresses into a
#! scratch register first. The usage of R11 here is a hack.
#! This word can only be called right before a subroutine
#! call, where all vregs have been flushed anyway.
R11 [ swap MOV ] keep ; inline
: compile-c-call ( symbol dll -- )
2dup dlsym R10 swap MOV
rel-absolute-cell rel-dlsym R10 CALL ;
2dup dlsym address-operand
>r rel-absolute-cell rel-dlsym r> CALL ;
: compile-c-call* ( symbol dll args -- )
T{ int-regs } fastcall-regs
swap [ MOV ] 2each compile-c-call ;
M: float-regs return-reg drop XMM0 ;
M: float-regs fastcall-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
: address-operand ( address -- operand )
#! On AMD64, we have to load 64-bit addresses into a
#! scratch register first. The usage of R11 here is a hack.
#! We cannot write '0 scratch' since scratch registers are
#! not permitted inside basic-block VOPs.
R11 [ swap MOV ] keep ; inline
: fixnum>slot@ drop ; inline
: prepare-division CQO ; inline
: load-indirect ( dest literal -- )
: load-indirect ( vreg literal -- )
swap add-literal from 3 - [] MOV ;
M: object load-literal ( literal vreg -- )
#! We use RIP-relative addressing. The '3' is a hardcoded
#! instruction length.
add-literal from 3 - [] MOV ; inline
v>operand load-indirect ;
: stack-increment \ stack-reserve get 16 align 8 + ;
: compile-epilogue ( -- )
RSP stack-increment ADD ; inline
: %prologue ( n -- )
\ stack-reserve set RSP stack-increment SUB ;
: %epilogue ( -- )
RSP stack-increment ADD ;

9
library/compiler/amd64/generator.factor
View File

@ -1,9 +0,0 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler-backend
USING: assembler compiler-frontend kernel math namespaces ;
M: %prologue generate-node ( vop -- )
drop
0 input \ stack-reserve set
RSP stack-increment SUB ;

9
library/compiler/amd64/intrinsics.factor Normal file
View File

@ -0,0 +1,9 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assembler ;
IN: compiler
: generate-write-barrier ( -- )
#! Mark the card pointed to by vreg.
"obj" operand card-bits SHR
"obj" operand R13 [+] card-mark OR ;

11
library/compiler/amd64/slots.factor
View File

@ -1,11 +0,0 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler-backend
USING: alien arrays assembler compiler inference kernel
kernel-internals lists math memory namespaces sequences words ;
M: %write-barrier generate-node ( vop -- )
#! Mark the card pointed to by vreg.
drop
0 input-operand card-bits SHR
0 input-operand R13 [+] card-mark OR ;

10
library/compiler/architecture.factor
View File

@ -1,10 +0,0 @@
IN: compiler-backend
! A few things the front-end needs to know about the back-end.
DEFER: fixnum-imm? ( -- ? )
#! Can fixnum operations take immediate operands?
DEFER: vregs ( -- regs )
DEFER: compile-c-call ( library function -- )

177
library/compiler/basic-blocks.factor
View File

@ -1,177 +0,0 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-backend
USING: arrays hashtables kernel lists math namespaces sequences ;
! Optimizations performed here:
! - combining %inc-d/%inc-r within a single basic block
! - if a literal is loaded into a vreg but the vreg is
! overwritten before being read, the literal load is deleted
! - if a %replace is writing a vreg to a stack location already
! holding that vreg, or a stack location that is not read
! before being popped, the %replace is deleted
! - if a %peek is reading a stack location into a vreg that
! already holds that vreg, or if the vreg is overwritten
! before being read, the %peek is deleted
! - removing dead loads of stack locations into vregs
! - removing dead stores of vregs into stack locations
: vop-in ( vop n -- input ) swap vop-inputs nth ;
: set-vop-in ( input vop n -- ) swap vop-inputs set-nth ;
: vop-out ( vop n -- input ) swap vop-outputs nth ;
: (split-blocks) ( n linear -- )
2dup length = [
dup like , drop
] [
2dup nth basic-block? [
>r 1+ r> (split-blocks)
] [
(cut) >r , 1 r> (cut) >r , 0 r> (split-blocks)
] if
] if ;
: split-blocks ( linear -- blocks )
[ 0 swap (split-blocks) ] { } make ;
SYMBOL: d-height
SYMBOL: r-height
! combining %inc-d/%inc-r
GENERIC: simplify-stack* ( vop -- )
M: tuple simplify-stack* ( vop -- ) drop ;
: accum-height ( vop var -- )
>r dup 0 vop-in r> [ + ] change 0 swap 0 set-vop-in ;
M: %inc-d simplify-stack* ( vop -- ) d-height accum-height ;
M: %inc-r simplify-stack* ( vop -- ) r-height accum-height ;
GENERIC: update-loc ( loc -- )
M: ds-loc update-loc
dup ds-loc-n d-height get - swap set-ds-loc-n ;
M: cs-loc update-loc
dup cs-loc-n r-height get - swap set-cs-loc-n ;
M: %peek simplify-stack* ( vop -- ) 0 vop-in update-loc ;
M: %replace simplify-stack* ( vop -- ) 0 vop-out update-loc ;
: simplify-stack ( block -- )
#! Combine all %inc-d/%inc-r into two final ones.
#! Destructively modifies the VOPs in the block.
[ simplify-stack* ] each ;
: each-tail ( seq quot -- | quot: tail -- )
>r dup length [ swap tail-slice ] map-with r> each ; inline
! removing dead loads/stores
: preserves-location? ( exitcc location vop -- ? )
#! If the VOP writes the register, call the loop exit
#! continuation with 'f'.
{
{ [ 2dup vop-inputs member? ] [ 3drop t ] }
{ [ 2dup vop-outputs member? ] [ 2drop f swap continue-with ] }
{ [ t ] [ 3drop f ] }
} cond ;
GENERIC: live@end? ( location -- ? )
M: tuple live@end? drop t ;
M: ds-loc live@end? ds-loc-n d-height get + 0 >= ;
M: cs-loc live@end? cs-loc-n r-height get + 0 >= ;
: location-live? ( location tail -- ? )
#! A location is not live if and only if it is overwritten
#! before the end of the basic block.
[
-rot [ >r 2dup r> preserves-location? ] contains?
[ dup live@end? ] unless*
] callcc1 2nip ;
! Used for elimination of dead loads from the stack:
! we keep a map of vregs to ds-loc/cs-loc/f.
SYMBOL: vreg-contents
GENERIC: trim-dead* ( tail vop -- )
: forget-vregs ( vop -- )
vop-outputs [ vreg-contents get remove-hash ] each ;
M: tuple trim-dead* ( tail vop -- ) dup forget-vregs , drop ;
: ?, [ , ] [ drop ] if ;
: simplify-inc ( vop -- ) dup 0 vop-in zero? not ?, ;
M: %inc-d trim-dead* ( tail vop -- ) simplify-inc drop ;
M: %inc-r trim-dead* ( tail vop -- ) simplify-inc drop ;
: live-load? ( tail vop -- ? )
#! If the VOP's output location is overwritten before being
#! read again, kill the VOP.
0 vop-out swap location-live? ;
: remember-peek ( vop -- )
dup 0 vop-in swap 0 vop-out vreg-contents get set-hash ;
: redundant-peek? ( vop -- ? )
dup 0 vop-in swap 0 vop-out vreg-contents get hash = ;
M: %peek trim-dead* ( tail vop -- )
dup redundant-peek? >r tuck live-load? not r> or
[ dup remember-peek dup , ] unless drop ;
: redundant-replace? ( vop -- ? )
dup 0 vop-out swap 0 vop-in vreg-contents get hash = ;
: forget-stack-loc ( loc -- )
#! Forget that any vregs hold this stack location.
vreg-contents [ [ nip swap = not ] hash-subset-with ] change ;
: remember-replace ( vop -- )
#! If a vreg claims to hold the stack location we are
#! writing to, we must forget this fact, since that stack
#! location no longer holds this value!
dup 0 vop-out forget-stack-loc
dup 0 vop-out swap 0 vop-in vreg-contents get set-hash ;
M: %replace trim-dead* ( tail vop -- )
dup redundant-replace? >r tuck live-load? not r> or
[ dup remember-replace dup , ] unless drop ;
: ?dead-literal dup forget-vregs tuck live-load? ?, ;
M: %immediate trim-dead* ( tail vop -- ) ?dead-literal ;
M: %indirect trim-dead* ( tail vop -- ) ?dead-literal ;
: trim-dead ( block -- )
#! Remove dead loads and stores.
[ dup first >r 1 swap tail-slice r> trim-dead* ] each-tail ;
: simplify-block ( block -- block )
#! Destructively modifies the VOPs in the block.
[
0 d-height set
0 r-height set
H{ } clone vreg-contents set
dup simplify-stack
d-height get %inc-d r-height get %inc-r 2array append
trim-dead
] { } make ;
: keep-simplifying ( block -- block )
dup length >r simplify-block dup length r> =
[ keep-simplifying ] unless ;
: simplify ( blocks -- blocks )
#! Simplify basic block IR.
[ keep-simplifying ] map ;

22
library/compiler/compiler.factor
View File

@ -1,28 +1,20 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler
USING: compiler-backend compiler-frontend errors hashtables
inference io kernel lists math namespaces optimizer prettyprint
sequences test words ;
USING: errors hashtables inference io kernel lists math
namespaces optimizer prettyprint sequences test words ;
: (compile) ( word -- )
#! Should be called inside the with-compiler scope.
dup word-def dataflow optimize linearize
[ split-blocks simplify generate ] hash-each ;
: benchmark-compile
[ [ (compile) ] keep ] benchmark nip
"compile-time" set-word-prop ;
dup specialized-def dataflow optimize generate ;
: inform-compile ( word -- ) "Compiling " write . flush ;
: compile-postponed ( -- )
compile-words get dup empty? [
dup pop
dup inform-compile
benchmark-compile
compile-postponed
] unless drop ;
drop
] [
pop dup inform-compile (compile) compile-postponed
] if ;
: compile ( word -- )
[ postpone-word compile-postponed ] with-compiler ;

69
library/compiler/generator.factor
View File

@ -1,69 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-backend
USING: alien assembler compiler errors inference kernel
kernel-internals lists math memory namespaces sequences strings
vectors words ;
! Compile a VOP.
GENERIC: generate-node ( vop -- )
: generate-code ( word linear -- length )
compiled-offset >r
compile-aligned
swap save-xt
[ [ dup [ generate-node ] with-vop ] each ] each
compile-aligned
compiled-offset r> - ;
: generate-reloc ( -- length )
relocation-table get
dup [ assemble-cell ] each
length cells ;
: (generate) ( word linear -- )
#! Compile a word definition from linear IR.
V{ } clone relocation-table set
begin-assembly swap >r >r
generate-code
generate-reloc
r> set-compiled-cell
r> set-compiled-cell ;
SYMBOL: previous-offset
: generate ( word linear -- )
#! If generation fails, reset compiled offset.
[
compiled-offset previous-offset set
(generate)
] [
previous-offset get set-compiled-offset
rethrow
] recover ;
! A few VOPs have trivial generators.
M: %label generate-node ( vop -- )
vop-label save-xt ;
M: %target-label generate-node ( vop -- )
drop label 0 assemble-cell absolute-cell ;
M: %cleanup generate-node ( vop -- ) drop ;
M: %freg>stack generate-node ( vop -- ) drop ;
M: %stack>freg generate-node ( vop -- ) drop ;
M: %alien-invoke generate-node
#! call a C function.
drop 0 input 1 input compile-c-call ;
: dest/src ( -- dest src ) 0 output-operand 0 input-operand ;
! These constants must match native/card.h
: card-bits 7 ;
: card-mark HEX: 80 ;
: string-offset 3 cells object-tag - ;

133
library/compiler/generator/architecture.factor Normal file
View File

@ -0,0 +1,133 @@
IN: compiler
USING: arrays generic kernel kernel-internals math memory
namespaces sequences ;
! A scratch register for computations
TUPLE: vreg n ;
C: vreg ( n reg-class -- vreg )
[ set-delegate ] keep [ set-vreg-n ] keep ;
! Register classes
TUPLE: int-regs ;
TUPLE: float-regs size ;
: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
: <float-vreg> ( n -- vreg ) T{ float-regs f 8 } <vreg> ;
! A pseudo-register class for parameters spilled on the stack
TUPLE: stack-params ;
! Return values of this class go here
GENERIC: return-reg ( register-class -- reg )
! Sequence of registers used for parameter passing in class
GENERIC: fastcall-regs ( register-class -- regs )
! Sequence mapping vreg-n to native assembler registers
GENERIC: vregs ( register-class -- regs )
! Map a sequence of literals to f or float
DEFER: literal-template ( literals -- template )
! Load a literal (immediate or indirect)
G: load-literal ( obj vreg -- ) 1 standard-combination ;
! Set up caller stack frame (PowerPC and AMD64)
: %prologue ( n -- ) drop ; inline
! Tear down stack frame (PowerPC and AMD64)
: %epilogue ( -- ) ; inline
! Tail call another word
DEFER: %jump ( label -- )
! Call another word
DEFER: %call ( label -- )
! Local jump for branches or tail calls in nested #label
DEFER: %jump-label ( label -- )
! Test if vreg is 'f' or not
DEFER: %jump-t ( label vreg -- )
! Jump table of addresses (one cell each) is right after this
DEFER: %dispatch ( vreg -- )
! Return to caller
DEFER: %return ( -- )
! Change datastack height
DEFER: %inc-d ( n -- )
! Change callstack height
DEFER: %inc-r ( n -- )
! Load stack into vreg
GENERIC: (%peek) ( vreg loc reg-class -- )
: %peek ( vreg loc -- ) over (%peek) ;
! Store vreg to stack
GENERIC: (%replace) ( vreg loc reg-class -- )
: %replace ( vreg loc -- ) over (%replace) ;
! Move one vreg to another
DEFER: %move-int>int ( dst src -- )
DEFER: %move-int>float ( dst src -- )
: %move ( dst src -- )
2dup = [
2drop
] [
2dup [ delegate class ] 2apply 2array {
{ [ dup { int-regs int-regs } = ] [ drop %move-int>int ] }
{ [ dup { float-regs int-regs } = ] [ drop %move-int>float ] }
} cond
] if ;
! FFI stuff
DEFER: %unbox ( n reg-class func -- )
DEFER: %unbox-struct ( n reg-class size -- )
DEFER: %box ( n reg-class func -- )
DEFER: %box-struct ( n reg-class size -- )
GENERIC: %freg>stack ( stack reg reg-class -- )
GENERIC: %stack>freg ( stack reg reg-class -- )
DEFER: %alien-invoke ( library function -- )
DEFER: %cleanup ( n -- )
DEFER: %alien-callback ( quot -- )
DEFER: %callback-value ( reg-class func -- )
M: stack-params fastcall-regs drop 0 ;
GENERIC: reg-size ( register-class -- n )
GENERIC: inc-reg-class ( register-class -- )
M: int-regs reg-size drop cell ;
: (inc-reg-class)
dup class inc
macosx? [ reg-size stack-params +@ ] [ drop ] if ;
M: int-regs inc-reg-class
(inc-reg-class) ;
M: float-regs reg-size float-regs-size ;
M: float-regs inc-reg-class
dup (inc-reg-class)
macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
GENERIC: v>operand
M: integer v>operand tag-bits shift ;
M: vreg v>operand dup vreg-n swap vregs nth ;
M: f v>operand address ;

0
library/compiler/assembler.factor → library/compiler/generator/assembler.factor
View File

242
library/compiler/generator/generator.factor Normal file
View File

@ -0,0 +1,242 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler
USING: arrays assembler errors generic hashtables inference
kernel kernel-internals lists math namespaces queues sequences
words ;
GENERIC: stack-reserve*
M: object stack-reserve* drop 0 ;
: stack-reserve ( node -- n )
0 swap [ stack-reserve* max ] each-node ;
: intrinsic ( #call -- quot )
node-param "intrinsic" word-prop ;
: if-intrinsic ( #call -- quot )
node-param "if-intrinsic" word-prop ;
DEFER: #terminal?
PREDICATE: #merge #terminal-merge node-successor #terminal? ;
PREDICATE: #call #terminal-call
dup node-successor #if?
over node-successor node-successor #terminal? and
swap if-intrinsic and ;
UNION: #terminal
POSTPONE: f #return #values #terminal-merge ;
: tail-call? ( -- ? )
node-stack get [
dup #terminal-call? swap node-successor #terminal? or
] all? ;
: generate-code ( word node quot -- length | quot: node -- )
compiled-offset >r
compile-aligned
rot save-xt
over stack-reserve %prologue
call
compile-aligned
compiled-offset r> - ;
: generate-reloc ( -- length )
relocation-table get
dup [ assemble-cell ] each
length cells ;
SYMBOL: previous-offset
: begin-generating ( -- code-len-fixup reloc-len-fixup )
compiled-offset previous-offset set
V{ } clone relocation-table set
init-templates begin-assembly swap ;
: generate-1 ( word node quot -- | quot: node -- )
#! If generation fails, reset compiled offset.
[
begin-generating >r >r
generate-code
generate-reloc
r> set-compiled-cell
r> set-compiled-cell
] [
previous-offset get set-compiled-offset rethrow
] recover ;
SYMBOL: generate-queue
: generate-loop ( -- )
generate-queue get dup queue-empty? [
drop
] [
deque first3 generate-1 generate-loop
] if ;
: generate-block ( word node quot -- | quot: node -- )
3array generate-queue get enque ;
GENERIC: generate-node ( node -- )
: generate-nodes ( node -- )
[ node@ generate-node ] iterate-nodes end-basic-block ;
: generate-word ( node -- )
[ [ generate-nodes ] with-node-iterator ]
generate-block ;
: generate ( word node -- )
[
<queue> generate-queue set
generate-word generate-loop
] with-scope ;
! node
M: node generate-node ( node -- next ) drop iterate-next ;
! #label
: generate-call ( label -- next )
end-basic-block
tail-call? [ %jump f ] [ %call iterate-next ] if ;
M: #label generate-node ( node -- next )
#! We remap the IR node's label to a new label object here,
#! to avoid problems with two IR #label nodes having the
#! same label in different lexical scopes.
dup node-param dup generate-call >r
swap node-child generate-word r> ;
! #if
: end-false-branch ( label -- )
tail-call? [ %return drop ] [ %jump-label ] if ;
: generate-if ( node label -- next )
<label> [
>r >r node-children first2 generate-nodes
r> r> end-false-branch save-xt generate-nodes
] keep save-xt iterate-next ;
M: #if generate-node ( node -- next )
[
end-basic-block
<label> dup %jump-t
] H{
{ +input { { f "flag" } } }
} with-template generate-if ;
! #call
: [with-template] ( quot template -- quot )
2array >list [ with-template ] append ;
: define-intrinsic ( word quot template -- | quot: -- )
[with-template] "intrinsic" set-word-prop ;
: define-if-intrinsic ( word quot template -- | quot: label -- )
[with-template] "if-intrinsic" set-word-prop ;
: if>boolean-intrinsic ( label -- )
<label> "end" set
f 0 <int-vreg> load-literal
"end" get %jump-label
save-xt
t 0 <int-vreg> load-literal
"end" get save-xt
0 <int-vreg> phantom-d get phantom-push
compute-free-vregs ;
: do-if-intrinsic ( node -- next )
[ <label> dup ] keep if-intrinsic call
>r node-successor dup #if? [
r> generate-if node-successor
] [
drop r> if>boolean-intrinsic iterate-next
] if ;
M: #call generate-node ( node -- next )
{
{ [ dup if-intrinsic ] [ do-if-intrinsic ] }
{ [ dup intrinsic ] [ intrinsic call iterate-next ] }
{ [ t ] [ node-param generate-call ] }
} cond ;
! #call-label
M: #call-label generate-node ( node -- next )
node-param generate-call ;
! #dispatch
: target-label ( label -- ) 0 assemble-cell absolute-cell ;
: dispatch-head ( node -- label/node )
#! Output the jump table insn and return a list of
#! label/branch pairs.
[ end-basic-block %dispatch ] H{
{ +input { { f "n" } } }
{ +scratch { { f "scratch" } } }
} with-template
node-children [ <label> dup target-label 2array ] map ;
: dispatch-body ( label/node -- )
<label> swap [
first2 save-xt generate-nodes end-basic-block
dup %jump-label
] each save-xt ;
M: #dispatch generate-node ( node -- next )
#! The parameter is a list of nodes, each one is a branch to
#! take in case the top of stack has that type.
dispatch-head dispatch-body iterate-next ;
! #push
UNION: immediate fixnum POSTPONE: f ;
: generate-push ( node -- )
>#push<
dup length ?fp-scratch + 0 ensure-vregs
[ f spec>vreg [ load-literal ] keep ] map
phantom-d get phantom-append ;
M: #push generate-node ( #push -- )
generate-push iterate-next ;
! #shuffle
: phantom-shuffle-input ( n phantom -- seq )
2dup length <= [
cut-phantom
] [
[ phantom-locs ] keep [ length swap head-slice* ] keep
[ append 0 ] keep set-length
] if ;
: phantom-shuffle-inputs ( shuffle -- locs locs )
dup shuffle-in-d length phantom-d get phantom-shuffle-input
swap shuffle-in-r length phantom-r get phantom-shuffle-input ;
: adjust-shuffle ( shuffle -- )
dup shuffle-in-d length neg phantom-d get adjust-phantom
shuffle-in-r length neg phantom-r get adjust-phantom ;
: shuffle-vregs# ( shuffle -- n )
dup shuffle-in-d swap shuffle-in-r additional-vregs ;
: phantom-shuffle ( shuffle -- )
dup shuffle-vregs# 0 ensure-vregs
[ phantom-shuffle-inputs ] keep
[ shuffle* ] keep adjust-shuffle
(template-outputs) ;
M: #shuffle generate-node ( #shuffle -- )
node-shuffle phantom-shuffle iterate-next ;
! #return
M: #return generate-node drop end-basic-block %return f ;
! These constants must match native/card.h
: card-bits 7 ;
: card-mark HEX: 80 ;
: float-offset 8 float-tag - ;
: string-offset 3 cells object-tag - ;

284
library/compiler/generator/templates.factor Normal file
View File

@ -0,0 +1,284 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler
USING: arrays generic hashtables inference io kernel math
namespaces prettyprint sequences vectors words ;
! Register allocation
! Hash mapping reg-classes to mutable vectors
: free-vregs ( reg-class -- seq ) \ free-vregs get hash ;
: alloc-reg ( reg-class -- vreg ) free-vregs pop ;
: take-reg ( vreg -- ) dup delegate free-vregs delete ;
: reg-spec>class ( spec -- class )
float eq? T{ float-regs f 8 } T{ int-regs } ? ;
: spec>vreg ( spec -- vreg )
dup integer? [
<int-vreg> dup take-reg
] [
reg-spec>class alloc-reg
] if ;
! A data stack location.
TUPLE: ds-loc n ;
! A call stack location.
TUPLE: cs-loc n ;
UNION: loc ds-loc cs-loc ;
TUPLE: phantom-stack height ;
C: phantom-stack ( -- stack )
0 over set-phantom-stack-height
V{ } clone over set-delegate ;
GENERIC: finalize-height ( n stack -- )
GENERIC: <loc> ( n stack -- loc )
: (loc)
#! Utility for methods on <loc>
phantom-stack-height - ;
: (finalize-height) ( stack word -- )
#! We consolidate multiple stack height changes until the
#! last moment, and we emit the final height changing
#! instruction here.
swap [
phantom-stack-height
dup zero? [ 2drop ] [ swap execute ] if
0
] keep set-phantom-stack-height ; inline
TUPLE: phantom-datastack ;
C: phantom-datastack
[ >r <phantom-stack> r> set-delegate ] keep ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ;
TUPLE: phantom-callstack ;
C: phantom-callstack
[ >r <phantom-stack> r> set-delegate ] keep ;
M: phantom-callstack <loc> (loc) <cs-loc> ;
M: phantom-callstack finalize-height
\ %inc-r (finalize-height) ;
: phantom-locs ( n phantom -- locs )
#! A sequence of n ds-locs or cs-locs indexing the stack.
swap reverse-slice [ swap <loc> ] map-with ;
: phantom-locs* ( phantom -- locs )
dup length swap phantom-locs ;
: adjust-phantom ( n phantom -- )
[ phantom-stack-height + ] keep set-phantom-stack-height ;
GENERIC: cut-phantom ( n phantom -- seq )
M: phantom-stack cut-phantom ( n phantom -- seq )
[ delegate cut* swap ] keep set-delegate ;
SYMBOL: phantom-d
SYMBOL: phantom-r
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
: init-templates ( -- )
<phantom-datastack> phantom-d set
<phantom-callstack> phantom-r set ;
: finalize-heights ( -- )
phantoms [ finalize-height ] 2apply ;
: vreg>stack ( value loc -- )
over loc? over not or [ 2drop ] [ %replace ] if ;
: vregs>stack ( phantom -- )
[
dup phantom-locs* [ vreg>stack ] 2each 0
] keep set-length ;
: (live-locs) ( seq -- seq )
dup phantom-locs* [ 2array ] 2map
[ first2 over loc? >r = not r> and ] subset
[ first ] map ;
: stack>new-vreg ( loc spec -- vreg )
spec>vreg [ swap %peek ] keep ;
: live-locs ( phantom phantom -- hash )
[ (live-locs) ] 2apply append prune
[ dup f stack>new-vreg ] map>hash ;
: lazy-store ( value loc -- )
over loc? [
2dup =
[ 2drop ] [ >r \ live-locs get hash r> vreg>stack ] if
] [
2drop
] if ;
: flush-locs ( phantom phantom -- )
2dup live-locs \ live-locs set
[ dup phantom-locs* [ lazy-store ] 2each ] 2apply ;
: finalize-contents ( -- )
phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
: end-basic-block ( -- ) finalize-contents finalize-heights ;
: used-vregs ( -- seq ) phantoms append [ vreg? ] subset ;
: (compute-free-vregs) ( used class -- vector )
dup vregs length reverse [ swap <vreg> ] map-with diff
>vector ;
: compute-free-vregs ( -- )
used-vregs
{ T{ int-regs } T{ float-regs f 8 } }
[ 2dup (compute-free-vregs) ] map>hash \ free-vregs set
drop ;
: additional-vregs ( seq seq -- n )
2array phantoms 2array [ [ length ] map ] 2apply v-
0 [ 0 max + ] reduce ;
: free-vregs# ( -- int# float# )
T{ int-regs } free-vregs length
phantoms [ [ loc? ] subset length ] 2apply + -
T{ float-regs f 8 } free-vregs length ;
: ensure-vregs ( int# float# -- )
compute-free-vregs free-vregs# swapd <= >r <= r> and
[ finalize-contents compute-free-vregs ] unless ;
: (lazy-load) ( spec value -- value )
{
{ [ dup loc? ] [ >r spec>vreg dup r> %peek ] }
{ [ dup [ float-regs? ] is? ] [ nip ] }
{ [ over float eq? ] [ >r spec>vreg dup r> %move ] }
{ [ t ] [ nip ] }
} cond ;
: lazy-load ( values template -- )
dup length neg phantom-d get adjust-phantom
[ first2 >r swap (lazy-load) r> set ] 2each ;
: compatible-vreg? ( n vreg -- ? )
dup [ int-regs? ] is? [ vreg-n = ] [ 2drop f ] if ;
: compatible-values? ( value template -- ? )
{
{ [ over loc? ] [ 2drop t ] }
{ [ dup not ] [ drop [ float-regs? ] is? not ] }
{ [ dup float eq? ] [ 2drop t ] }
{ [ dup integer? ] [ swap compatible-vreg? ] }
} cond ;
: template-match? ( template phantom -- ? )
[ reverse-slice ] 2apply
t [ swap first compatible-values? and ] 2reduce ;
: split-template ( template phantom -- slow fast )
over length over length <=
[ drop { } swap ] [ length swap cut* ] if ;
: match-template ( template -- slow fast )
phantom-d get 2dup template-match?
[ split-template ] [ drop { } ] if ;
: fast-input ( template -- )
phantom-d get over length swap cut-phantom swap lazy-load ;
: phantom-push ( obj stack -- )
1 over adjust-phantom push ;
: phantom-append ( seq stack -- )
over length over adjust-phantom swap nappend ;
: (template-outputs) ( seq stack -- )
phantoms swapd phantom-append phantom-append ;
SYMBOL: +input
SYMBOL: +output
SYMBOL: +scratch
SYMBOL: +clobber
: fix-spec ( spec -- spec )
H{
{ +input { } }
{ +output { } }
{ +scratch { } }
{ +clobber { } }
} swap hash-union ;
: output-vregs ( -- seq seq )
+output +clobber [ get [ get ] map ] 2apply ;
: outputs-clash? ( -- ? )
output-vregs append phantoms append
[ swap member? ] contains-with? ;
: slow-input ( template -- )
#! Are we loading stuff from the stack? Then flush out
#! remaining vregs, not slurped in by fast-input.
#! Do the outputs clash with vregs on the phantom stacks?
#! Then we must flush them first.
dup empty? not outputs-clash? or [ finalize-contents ] when
[ length phantom-d get phantom-locs ] keep lazy-load ;
: requested-vregs ( template -- int# float# )
dup length swap [ float eq? ] subset length [ - ] keep ;
: (requests-class?) ( class template -- )
[ second reg-spec>class eq? ] contains-with? ;
: requests-class? ( class -- ? )
dup +input get (requests-class?) swap
+scratch get (requests-class?) or ;
: ?fp-scratch ( -- n )
T{ float-regs f 8 } requests-class? 1 0 ? ;
: fp-scratch ( -- vreg )
"fp-scratch" get [
T{ int-regs } alloc-reg dup "fp-scratch" set
] unless* ;
: guess-vregs ( -- int# float# )
+input get { } additional-vregs ?fp-scratch +
+scratch get [ first ] map requested-vregs >r + r> ;
: alloc-scratch ( -- )
+scratch get [ first2 >r spec>vreg r> set ] each ;
: template-inputs ( -- )
! Ensure we have enough to hold any new stack elements we
! will read (if any), and scratch.
guess-vregs ensure-vregs
! Split the template into available (fast) parts and those
! that require allocating registers and reading the stack
+input get match-template fast-input slow-input
! Finally allocate scratch registers
alloc-scratch ;
: template-outputs ( -- )
+output get [ get ] map { } (template-outputs) ;
: with-template ( quot spec -- )
fix-spec [ template-inputs call template-outputs ] bind
compute-free-vregs ; inline
: operand ( var -- op ) get v>operand ; inline

14
library/compiler/xt.factor → library/compiler/generator/xt.factor
View File

@ -1,9 +1,16 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: assembler compiler-backend compiler-frontend errors
generic hashtables kernel kernel-internals lists math namespaces
prettyprint sequences strings vectors words ;
USING: assembler errors generic hashtables kernel
kernel-internals lists math namespaces prettyprint queues
sequences strings vectors words ;
: <label> ( -- label )
#! Make a label.
gensym dup t "label" set-word-prop ;
: label? ( obj -- ? )
dup word? [ "label" word-prop ] [ drop f ] if ;
! We use a hashtable "compiled-xts" that maps words to
! xt's that are currently being compiled. The commit-xt's word
@ -170,7 +177,6 @@ SYMBOL: compile-words
#! added to the list of words to be compiled.
dup compiled?
over label? or
over linearized get ?hash or
over compile-words get member? or
swap compiled-xts get hash or ;

3
library/inference/branches.factor → library/compiler/inference/branches.factor
View File

@ -31,8 +31,7 @@ namespaces parser prettyprint sequences strings vectors words ;
: unbalanced-branches ( in out -- )
{ "Unbalanced branches:" } -rot [
swap number>string " " rot length number>string
append3
swap unparse " " rot length unparse append3
] 2map append "\n" join inference-error ;
: unify-effect ( in out -- in out )

48
library/inference/dataflow.factor → library/compiler/inference/dataflow.factor
View File

@ -4,26 +4,6 @@ IN: inference
USING: arrays generic hashtables interpreter kernel lists math
namespaces parser sequences words ;
! Recursive state. An alist, mapping words to labels.
SYMBOL: recursive-state
: <computed> \ <computed> counter ;
TUPLE: value uid literal recursion ;
C: value ( obj -- value )
<computed> over set-value-uid
recursive-state get over set-value-recursion
[ set-value-literal ] keep ;
M: value hashcode value-uid ;
M: value = eq? ;
M: integer value-uid ;
M: integer value-recursion drop f ;
! The dataflow IR is the first of the two intermediate
! representations used by Factor. It annotates concatenative
! code with stack flow information and types.
@ -51,6 +31,7 @@ M: node = eq? ;
: param-node ( label) { } { } { } { } ;
: in-node ( inputs) >r f r> { } { } { } ;
: out-node ( outputs) >r f { } r> { } { } ;
: meta-d-node meta-d get clone in-node ;
: d-tail ( n -- list ) meta-d get tail* ;
: r-tail ( n -- list ) meta-r get tail* ;
@ -63,7 +44,8 @@ C: #label make-node ;
TUPLE: #entry ;
C: #entry make-node ;
: #entry ( -- node ) meta-d get clone in-node <#entry> ;
: #entry ( -- node ) meta-d-node <#entry> ;
TUPLE: #call ;
C: #call make-node ;
@ -73,30 +55,33 @@ TUPLE: #call-label ;
C: #call-label make-node ;
: #call-label ( label -- node ) param-node <#call-label> ;
TUPLE: #push ;
C: #push make-node ;
: #push ( -- node ) peek-d 1array out-node <#push> ;
: >#push< ( node -- seq ) node-out-d [ value-literal ] map ;
TUPLE: #shuffle ;
C: #shuffle make-node ;
: #shuffle ( -- node ) empty-node <#shuffle> ;
: #push ( outputs -- node ) d-tail out-node <#shuffle> ;
TUPLE: #values ;
C: #values make-node ;
: #values ( -- node ) meta-d get clone in-node <#values> ;
: #values ( -- node ) meta-d-node <#values> ;
TUPLE: #return ;
C: #return make-node ;
: #return ( label -- node )
#! The parameter is the label we are returning from, or if
#! f, this is a top-level return.
meta-d get clone in-node <#return>
[ set-node-param ] keep ;
meta-d-node <#return> [ set-node-param ] keep ;
TUPLE: #if ;
C: #if make-node ;
: #if ( in -- node ) 1 d-tail in-node <#if> ;
: #if ( in -- node ) peek-d 1array in-node <#if> ;
TUPLE: #dispatch ;
C: #dispatch make-node ;
: #dispatch ( in -- node ) 1 d-tail in-node <#dispatch> ;
: #dispatch ( in -- node ) peek-d 1array in-node <#dispatch> ;
TUPLE: #merge ;
C: #merge make-node ;
@ -106,6 +91,10 @@ TUPLE: #terminate ;
C: #terminate make-node ;
: #terminate ( -- node ) empty-node <#terminate> ;
TUPLE: #declare ;
C: #declare make-node ;
: #declare ( classes -- node ) param-node <#declare> ;
: node-inputs ( d-count r-count node -- )
tuck
>r r-tail r> set-node-in-r
@ -135,11 +124,6 @@ SYMBOL: current-node
dup node-in-r % node-out-r %
] { } make ;
: uses-value? ( value node -- ? ) node-values memq? ;
: outputs-value? ( value node -- ? )
2dup node-out-d member? >r node-out-r member? r> or ;
: last-node ( node -- last )
dup node-successor [ last-node ] [ ] ?if ;

2
library/inference/inference.factor → library/compiler/inference/inference.factor
View File

@ -76,7 +76,7 @@ GENERIC: apply-object
: apply-literal ( obj -- )
#! Literals are annotated with the current recursive
#! state.
<value> push-d 1 #push node, ;
<value> push-d #push node, ;
M: object apply-object apply-literal ;

0
library/inference/inference.facts → library/compiler/inference/inference.facts
View File

28
library/inference/known-words.factor → library/compiler/inference/known-words.factor
View File

@ -4,13 +4,14 @@ hashtables-internals interpreter io io-internals kernel
kernel-internals lists math math-internals memory parser
sequences strings vectors words prettyprint ;
! We transform calls to these words into 'branched' forms;
! eg, there is no VOP for fixnum<=, only fixnum<= followed
! by an #if, so if we have a 'bare' fixnum<= we add
! [ t ] [ f ] if at the end.
\ declare [
pop-literal nip
dup length ensure-values
dup #declare [ >r length d-tail r> set-node-in-d ] keep
node,
] "infer" set-word-prop
\ declare [ [ object ] [ ] ] "infer-effect" set-word-prop
! This transformation really belongs in the optimizer, but it
! is simpler to do it here.
\ fixnum< [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
\ fixnum< t "flushable" set-word-prop
\ fixnum< t "foldable" set-word-prop
@ -31,13 +32,6 @@ sequences strings vectors words prettyprint ;
\ eq? t "flushable" set-word-prop
\ eq? t "foldable" set-word-prop
: manual-branch ( word -- )
dup "infer-effect" word-prop consume/produce
[ [ t ] [ f ] if ] infer-quot ;
! { fixnum<= fixnum< fixnum>= fixnum> eq? }
! [ dup [ manual-branch ] curry "infer" set-word-prop ] each
! Primitive combinators
\ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop
@ -139,10 +133,18 @@ sequences strings vectors words prettyprint ;
\ fixnum+ t "flushable" set-word-prop
\ fixnum+ t "foldable" set-word-prop
\ fixnum+fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
\ fixnum+fast t "flushable" set-word-prop
\ fixnum+fast t "foldable" set-word-prop
\ fixnum- [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
\ fixnum- t "flushable" set-word-prop
\ fixnum- t "foldable" set-word-prop
\ fixnum-fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
\ fixnum-fast t "flushable" set-word-prop
\ fixnum-fast t "foldable" set-word-prop
\ fixnum* [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
\ fixnum* t "flushable" set-word-prop
\ fixnum* t "foldable" set-word-prop

46
library/inference/shuffle.factor → library/compiler/inference/shuffle.factor
View File

@ -1,9 +1,29 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: inference
USING: hashtables kernel math namespaces sequences ;
TUPLE: shuffle in-d in-r out-d out-r ;
! Recursive state. An alist, mapping words to labels.
SYMBOL: recursive-state
: empty-shuffle { } { } { } { } <shuffle> ;
: <computed> \ <computed> counter ;
TUPLE: value uid literal recursion ;
C: value ( obj -- value )
<computed> over set-value-uid
recursive-state get over set-value-recursion
[ set-value-literal ] keep ;
M: value hashcode value-uid ;
M: value = eq? ;
M: integer value-uid ;
M: integer value-recursion drop f ;
TUPLE: shuffle in-d in-r out-d out-r ;
: load-shuffle ( d r shuffle -- )
tuck shuffle-in-r [ set ] 2each shuffle-in-d [ set ] 2each ;
@ -31,28 +51,6 @@ TUPLE: shuffle in-d in-r out-d out-r ;
#! the shuffle.
[ split-shuffle ] keep shuffle* join-shuffle ;
: fix-compose-d ( s1 s2 -- )
over shuffle-out-d over shuffle-in-d [ length ] 2apply < [
over shuffle-out-d length over shuffle-in-d head*
[ pick shuffle-in-d append pick set-shuffle-in-d ] keep
pick shuffle-out-d append pick set-shuffle-out-d
] when 2drop ;
: fix-compose-r ( s1 s2 -- )
over shuffle-out-r over shuffle-in-r [ length ] 2apply < [
over shuffle-out-r length over shuffle-in-r head*
[ pick shuffle-in-r append pick set-shuffle-in-r ] keep
pick shuffle-out-r append pick set-shuffle-out-r
] when 2drop ;
: compose-shuffle ( s1 s2 -- s1+s2 )
#! s1's d and r output lengths must be at least the required
#! length for the shuffle. If they are not, a special
#! behavior is used which is only valid for the optimizer.
[ clone ] 2apply 2dup fix-compose-d 2dup fix-compose-r
>r dup shuffle-out-d over shuffle-out-r r> shuffle
>r >r dup shuffle-in-d swap shuffle-in-r r> r> <shuffle> ;
M: shuffle clone ( shuffle -- shuffle )
[ shuffle-in-d clone ] keep
[ shuffle-in-r clone ] keep

0
library/inference/stack.factor → library/compiler/inference/stack.factor
View File

2
library/inference/words.factor → library/compiler/inference/words.factor
View File

@ -104,7 +104,7 @@ M: #call-label collect-recursion* ( label node -- )
: infer-compound ( word base-case -- terminates? effect )
#! Infer a word's stack effect in a separate inferencer
#! instance. Outputs a boolean if the word terminates
#! instance. Outputs a true boolean if the word terminates
#! control flow by throwing an exception or restoring a
#! continuation.
[

235
library/compiler/intrinsics.factor
View File

@ -1,235 +0,0 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-frontend
USING: arrays assembler compiler-backend generic hashtables
inference kernel kernel-internals lists math math-internals
namespaces sequences words ;
: node-peek ( node -- value ) node-in-d peek ;
: type-tag ( type -- tag )
#! Given a type number, return the tag number.
dup 6 > [ drop 3 ] when ;
: value-tag ( value node -- n/f )
#! If the tag is known, output it, otherwise f.
node-classes ?hash dup [
types [ type-tag ] map dup all-equal?
[ first ] [ drop f ] if
] [
drop f
] if ;
: slot@ ( node -- n/f )
#! Compute slot offset.
dup node-in-d reverse-slice dup first dup value? [
value-literal cells swap second
rot value-tag dup [ - ] [ 2drop f ] if
] [
3drop f
] if ;
\ slot [
dup slot@ [
-1 %inc-d ,
in-1
0 swap slot@ %fast-slot ,
] [
drop
in-2
-1 %inc-d ,
0 %untag ,
1 0 %slot ,
] if out-1
] "intrinsic" set-word-prop
\ set-slot [
dup slot@ [
-1 %inc-d ,
in-2
-2 %inc-d ,
slot@ >r 0 1 r> %fast-set-slot ,
] [
drop
in-3
-3 %inc-d ,
1 %untag ,
0 1 2 %set-slot ,
] if
1 %write-barrier ,
] "intrinsic" set-word-prop
\ char-slot [
drop
in-2
-1 %inc-d ,
0 1 %char-slot ,
1 <vreg> 0 %replace-d ,
] "intrinsic" set-word-prop
\ set-char-slot [
drop
in-3
-3 %inc-d ,
0 2 1 %set-char-slot ,
] "intrinsic" set-word-prop
\ type [
drop
in-1
0 %type ,
out-1
] "intrinsic" set-word-prop
\ tag [
drop
in-1
0 %tag ,
out-1
] "intrinsic" set-word-prop
\ getenv [
-1 %inc-d ,
node-peek value-literal 0 <vreg> swap %getenv ,
1 %inc-d ,
out-1
] "intrinsic" set-word-prop
\ setenv [
-1 %inc-d ,
in-1
node-peek value-literal 0 <vreg> swap %setenv ,
-1 %inc-d ,
] "intrinsic" set-word-prop
: value/vreg-list ( in -- list )
[ 0 swap length 1- ] keep
[ >r 2dup r> 3array >r 1- >r 1+ r> r> ] map 2nip ;
: values>vregs ( in -- in )
value/vreg-list
dup [ first3 load-value ] each
[ first <vreg> ] map ;
: binary-inputs ( node -- in1 in2 )
node-in-d values>vregs first2 swap ;
: binary-op-reg ( node op -- )
>r binary-inputs dup -1 %inc-d , r> execute , out-1 ; inline
: binary-imm ( node -- in1 in2 )
-1 %inc-d , in-1 node-peek value-literal 0 <vreg> ;
: binary-op-imm ( node op -- )
>r binary-imm dup r> execute , out-1 ; inline
: literal-immediate? ( value -- ? )
dup value? [ value-literal immediate? ] [ drop f ] if ;
: binary-op-imm? ( node -- ? )
fixnum-imm? >r node-peek literal-immediate? r> and ;
: binary-op ( node op -- )
#! out is a vreg where the vop stores the result.
over binary-op-imm?
[ binary-op-imm ] [ binary-op-reg ] if ;
{
{ fixnum+ %fixnum+ }
{ fixnum- %fixnum- }
{ fixnum-bitand %fixnum-bitand }
{ fixnum-bitor %fixnum-bitor }
{ fixnum-bitxor %fixnum-bitxor }
} [
first2 [ binary-op ] curry "intrinsic" set-word-prop
] each
: binary-jump-reg ( node label op -- )
>r >r binary-inputs -2 %inc-d , r> r> execute , ; inline
: binary-jump-imm ( node label op -- )
>r >r binary-imm -1 %inc-d , r> r> execute , ; inline
: binary-jump ( node label op -- )
pick binary-op-imm?
[ binary-jump-imm ] [ binary-jump-reg ] if ;
{
{ fixnum<= %jump-fixnum<= }
{ fixnum< %jump-fixnum< }
{ fixnum>= %jump-fixnum>= }
{ fixnum> %jump-fixnum> }
{ eq? %jump-eq? }
} [
first2 [ binary-jump ] curry "if-intrinsic" set-word-prop
] each
\ fixnum/i [
\ %fixnum/i binary-op-reg
] "intrinsic" set-word-prop
\ fixnum-mod [
! This is not clever. Because of x86, %fixnum-mod is
! hard-coded to put its output in vreg 2, which happends to
! be EDX there.
drop
in-2
-1 %inc-d ,
1 <vreg> 0 <vreg> 2 <vreg> %fixnum-mod ,
T{ vreg f 2 } 0 %replace-d ,
] "intrinsic" set-word-prop
\ fixnum/mod [
! See the remark on fixnum-mod for vreg usage
drop
in-2
{ T{ vreg f 1 } T{ vreg f 0 } }
{ T{ vreg f 2 } T{ vreg f 0 } }
%fixnum/mod ,
T{ vreg f 2 } 0 %replace-d ,
T{ vreg f 0 } 1 %replace-d ,
] "intrinsic" set-word-prop
\ fixnum-bitnot [
drop
in-1
0 <vreg> 0 <vreg> %fixnum-bitnot ,
out-1
] "intrinsic" set-word-prop
\ fixnum* [
\ %fixnum* binary-op-reg
] "intrinsic" set-word-prop
: slow-shift ( -- ) \ fixnum-shift %call , ;
: negative-shift ( n -- )
-1 %inc-d ,
in-1
dup cell-bits neg <= [
drop 0 <vreg> 2 <vreg> %fixnum-sgn ,
T{ vreg f 2 } 0 %replace-d ,
] [
neg 0 <vreg> 0 <vreg> %fixnum>> ,
out-1
] if ;
: fast-shift ( n -- )
dup zero? [
-1 %inc-d ,
drop
] [
dup 0 < [
negative-shift
] [
drop slow-shift
] if
] if ;
\ fixnum-shift [
node-peek dup value? [
value-literal fast-shift
] [
drop slow-shift
] if
] "intrinsic" set-word-prop

140
library/compiler/linearizer.factor
View File

@ -1,140 +0,0 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays compiler-backend generic hashtables inference
kernel math namespaces sequences words ;
IN: compiler-frontend
! On PowerPC and AMD64, we use a stack discipline whereby
! stack frames are used to hold parameters. We need to compute
! the stack frame size to compile the prologue on entry to a
! word.
GENERIC: stack-reserve*
M: object stack-reserve* drop 0 ;
: stack-reserve ( node -- )
0 swap [ stack-reserve* max ] each-node ;
DEFER: #terminal?
PREDICATE: #merge #terminal-merge node-successor #terminal? ;
UNION: #terminal POSTPONE: f #return #values #terminal-merge ;
: tail-call? ( -- ? )
node-stack get [ node-successor ] map [ #terminal? ] all? ;
GENERIC: linearize* ( node -- next )
: linearize-child ( node -- )
[ node@ linearize* ] iterate-nodes ;
! A map from words to linear IR.
SYMBOL: linearized
! Renamed labels. To avoid problems with labels with the same
! name in different scopes.
SYMBOL: renamed-labels
: make-linear ( word quot -- )
[
swap >r { } make r> linearized get set-hash
] with-node-iterator ; inline
: linearize-1 ( word node -- )
swap [
dup stack-reserve %prologue , linearize-child
] make-linear ;
: init-linearizer ( -- )
H{ } clone linearized set
H{ } clone renamed-labels set ;
: linearize ( word dataflow -- linearized )
#! Outputs a hashtable mapping from labels to their
#! respective linear IR.
init-linearizer linearize-1 linearized get ;
M: node linearize* ( node -- next ) drop iterate-next ;
: linearize-call ( label -- next )
tail-call? [
%jump , f
] [
%call , iterate-next
] if ;
: rename-label ( label -- label )
<label> dup rot renamed-labels get set-hash ;
: renamed-label ( label -- label )
renamed-labels get hash ;
: linearize-call-label ( label -- next )
rename-label linearize-call ;
M: #label linearize* ( node -- next )
#! We remap the IR node's label to a new label object here,
#! to avoid problems with two IR #label nodes having the
#! same label in different lexical scopes.
dup node-param dup linearize-call-label >r
renamed-label swap node-child linearize-1
r> ;
: in-1 0 0 %peek-d , ;
: in-2 0 1 %peek-d , 1 0 %peek-d , ;
: in-3 0 2 %peek-d , 1 1 %peek-d , 2 0 %peek-d , ;
: out-1 T{ vreg f 0 } 0 %replace-d , ;
: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
: if-intrinsic ( #call -- quot )
dup node-successor #if?
[ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
: linearize-if ( node label -- next )
<label> dup >r >r >r node-children first2 linearize-child
r> r> %jump-label , %label , linearize-child r> %label ,
iterate-next ;
M: #call linearize* ( node -- next )
dup if-intrinsic [
>r <label> 2dup r> call
>r node-successor r> linearize-if node-successor
] [
dup intrinsic
[ call iterate-next ] [ node-param linearize-call ] if*
] if* ;
M: #call-label linearize* ( node -- next )
node-param renamed-label linearize-call ;
: ?static-branch ( node -- n )
node-in-d first dup value?
[ value-literal 0 1 ? ] [ drop f ] if ;
M: #if linearize* ( node -- next )
dup ?static-branch [
-1 %inc-d ,
swap node-children nth linearize-child iterate-next
] [
in-1 -1 %inc-d , <label> dup 0 %jump-t , linearize-if
] if* ;
: dispatch-head ( vtable -- label/node )
#! Output the jump table insn and return a list of
#! label/branch pairs.
in-1 -1 %inc-d , 0 %dispatch ,
[ <label> dup %target-label , 2array ] map ;
: dispatch-body ( label/node -- )
<label> swap [
first2 %label , linearize-child dup %jump-label ,
] each %label , ;
M: #dispatch linearize* ( node -- next )
#! The parameter is a list of nodes, each one is a branch to
#! take in case the top of stack has that type.
node-children dispatch-head dispatch-body iterate-next ;
M: #return linearize* drop %return , f ;

27
library/inference/call-optimizers.factor → library/compiler/optimizer/call-optimizers.factor
View File

@ -1,5 +1,5 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer
USING: arrays errors generic hashtables inference kernel lists
math math-internals sequences words ;
@ -36,17 +36,17 @@ math math-internals sequences words ;
[ with-datastack ] catch
[ 3drop t ] [ inline-literals ] if ;
: flip-subst ( not -- )
: call>no-op ( not -- )
#! Note: cloning the vectors, since subst-values will modify
#! them.
[ node-in-d clone ] keep
[ node-out-d clone ] keep
subst-values ;
[ subst-values ] keep node-successor ;
: flip-branches ( not -- #if )
#! If a not is followed by an #if, flip branches and
#! remove the not.
dup flip-subst node-successor dup
call>no-op dup
dup node-children reverse swap set-node-children ;
\ not {
@ -62,6 +62,16 @@ math math-internals sequences words ;
{ [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
} define-optimizers
: useless-coerce? ( node -- )
dup 0 node-class#
swap node-param "infer-effect" word-prop second first eq? ;
{ >fixnum >bignum >float } [
{
{ [ dup useless-coerce? ] [ call>no-op ] }
} define-optimizers
] each
! Arithmetic identities
SYMBOL: @
@ -109,7 +119,7 @@ SYMBOL: @
{ { -1 @ } [ nip 0 swap - ] }
} define-identities
[ / /i /f fixnum/i fixnum/f bignum/i bignum/f float/f ] {
[ / fixnum/i fixnum/f bignum/i bignum/f float/f ] {
{ { @ 1 } [ drop ] }
{ { @ -1 } [ drop 0 swap - ] }
} define-identities
@ -163,7 +173,7 @@ SYMBOL: @
{ { @ @ } [ 2drop t ] }
} define-identities
[ eq? number= = ] {
[ eq? bignum= float= number= = ] {
{ { @ @ } [ 2drop t ] }
} define-identities
@ -172,7 +182,6 @@ M: #call optimize-node* ( node -- node/t )
{ [ dup partial-eval? ] [ partial-eval ] }
{ [ dup find-identity nip ] [ apply-identities ] }
{ [ dup optimizer-hooks ] [ optimize-hooks ] }
{ [ dup inlining-class ] [ inline-method ] }
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ t ] [ drop t ] }
{ [ t ] [ inline-method ] }
} cond ;

50
library/inference/class-infer.factor → library/compiler/optimizer/class-infer.factor
View File

@ -1,11 +1,17 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer
USING: arrays generic hashtables inference kernel
kernel-internals math namespaces sequences words ;
! Infer possible classes of values in a dataflow IR.
: node-class ( value node -- class )
node-classes ?hash [ object ] unless* ;
: node-class# ( node n -- class )
swap [ node-in-d reverse-slice ?nth ] keep node-class ;
! Variables used by the class inferencer
! Current value --> class mapping
@ -104,26 +110,29 @@ M: node child-ties ( node -- seq )
] if ;
\ make-tuple [
dup node-in-d first value-literal 1array
node-in-d first value-literal 1array
] "output-classes" set-word-prop
{ clone (clone) } [
[
node-in-d [ value-class* ] map
] "output-classes" set-word-prop
] each
: output-classes ( node -- seq )
dup node-param "output-classes" word-prop [
call
] [
node-param "infer-effect" word-prop second
dup integer? [ drop f ] when
] ?if ;
] if* ;
M: #call infer-classes* ( node -- )
dup node-param [
dup create-ties
dup output-classes
[ over node-out-d intersect-classes ] when*
] when drop ;
dup create-ties dup output-classes
[ swap node-out-d intersect-classes ] [ drop ] if* ;
M: #shuffle infer-classes* ( node -- )
node-out-d [ value? ] subset
M: #push infer-classes* ( node -- )
node-out-d
[ [ value-literal ] keep set-value-literal* ] each ;
M: #if child-ties ( node -- seq )
@ -134,6 +143,9 @@ M: #dispatch child-ties ( node -- seq )
dup node-in-d first
swap node-children length [ <literal-tie> ] map-with ;
M: #declare infer-classes* ( node -- )
dup node-param swap node-in-d [ set-value-class* ] 2each ;
DEFER: (infer-classes)
: infer-children ( node -- )
@ -154,10 +166,20 @@ DEFER: (infer-classes)
node-successor (infer-classes)
] when* ;
: infer-classes ( node -- )
: ?<hashtable> [ H{ } clone ] unless* ;
: infer-classes-with ( node classes literals -- )
[
H{ } clone value-classes set
H{ } clone value-literals set
?<hashtable> value-literals set
?<hashtable> value-classes set
H{ } clone ties set
(infer-classes)
] with-scope ;
: infer-classes ( node -- )
f f infer-classes-with ;
: infer-classes/node ( existing node -- )
#! Infer classes, using the existing node's class info as a
#! starting point.
over node-classes rot node-literals infer-classes-with ;

128
library/compiler/optimizer/inline-methods.factor Normal file
View File

@ -0,0 +1,128 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer
USING: arrays generic hashtables inference kernel
kernel-internals lists math namespaces prettyprint sequences
words ;
! Some utilities for splicing in dataflow IR subtrees
: post-inline ( #return/#values #call/#merge -- )
[
>r node-in-d r> node-out-d 2array unify-lengths first2
] keep subst-values ;
: ?hash-union ( hash/f hash -- hash )
over [ hash-union ] [ nip ] if ;
: add-node-literals ( hash node -- )
[ node-literals ?hash-union ] keep set-node-literals ;
: add-node-classes ( hash node -- )
[ node-classes ?hash-union ] keep set-node-classes ;
: (subst-classes) ( literals classes node -- )
dup [
3dup [ add-node-classes ] keep add-node-literals
node-successor (subst-classes)
] [
3drop
] if ;
: subst-classes ( #return/#values #call/#merge -- )
>r dup node-literals swap node-classes r> (subst-classes) ;
: subst-node ( old new -- )
#! The last node of 'new' becomes 'old', then values are
#! substituted. A subsequent optimizer phase kills the
#! last node of 'new' and the first node of 'old'.
last-node 2dup swap 2dup post-inline subst-classes
set-node-successor ;
: (inline-method) ( #call quot -- node )
dup t eq? [
2drop t
] [
over node-in-d dataflow-with
2dup infer-classes/node
over node-param over remember-node
[ subst-node ] keep
] if ;
! Single dispatch method inlining optimization
: dispatch# ( #call -- n )
node-param "combination" word-prop first ;
: dispatching-class ( node -- seq ) dup dispatch# node-class# ;
: already-inlined? ( node -- ? )
#! Was this node inlined from definition of 'word'?
dup node-param swap node-history memq? ;
: specific-method ( word class -- ? ) swap order min-class ;
: inlining-class ( #call -- class )
#! If the generic dispatch can be eliminated, return the
#! class of the method that will always be invoked here.
dup node-param swap dispatching-class specific-method ;
: will-inline-method ( node -- quot/t )
#! t indicates failure
dup inlining-class dup [
swap node-param "methods" word-prop hash
] [
2drop t
] if ;
: inline-standard-method ( node -- node )
dup will-inline-method (inline-method) ;
: inline-standard-method? ( #call -- ? )
dup already-inlined? not swap node-param standard-generic?
and ;
! Partial dispatch of 2generic words
: math-both-known? ( word left right -- ? )
math-class-max specific-method ;
: will-inline-math-method ( word left right -- quot/t )
#! t indicates failure
3dup math-both-known? [ math-method ] [ 3drop t ] if ;
: inline-math-method ( #call -- node )
dup node-param over 1 node-class# pick 0 node-class#
will-inline-math-method (inline-method) ;
: inline-math-method? ( #call -- ? )
dup node-history [ 2generic? ] contains? not
swap node-param 2generic? and ;
: inline-method ( #call -- node )
{
{ [ dup inline-standard-method? ] [ inline-standard-method ] }
{ [ dup inline-math-method? ] [ inline-math-method ] }
{ [ t ] [ drop t ] }
} cond ;
! Resolve type checks at compile time where possible
: comparable? ( actual testing -- ? )
#! If actual is a subset of testing or if the two classes
#! are disjoint, return t.
2dup class< >r classes-intersect? not r> or ;
: optimize-predicate? ( #call -- ? )
dup node-param "predicating" word-prop dup [
>r 0 node-class# r> comparable?
] [
2drop f
] if ;
: inline-literals ( node literals -- node )
#! Make #shuffle -> #push -> #return -> successor
over drop-inputs [
>r >list [ literalize ] map dataflow [ subst-node ] keep
r> set-node-successor
] keep ;
: optimize-predicate ( #call -- node )
dup node-param "predicating" word-prop >r
dup 0 node-class# r> class< 1array inline-literals ;

29
library/inference/kill-literals.factor → library/compiler/optimizer/kill-literals.factor
View File

@ -14,11 +14,6 @@ GENERIC: literals* ( node -- seq )
: literals ( node -- hash )
[ literals* ] node-union ;
! GENERIC: flushable-values* ( node -- seq )
!
! : flushable-values ( node -- hash )
! [ flushable-values* ] node-union ;
GENERIC: live-values* ( node -- seq )
: live-values ( node -- hash )
@ -35,36 +30,26 @@ GENERIC: live-values* ( node -- seq )
over hash-empty?
[ 2drop ] [ [ kill-node* ] each-node-with ] if ;
: kill-unused-literals ( node -- )
\ live-values get over literals hash-diff swap kill-node ;
: kill-values ( node -- )
dup live-values over literals hash-diff swap kill-node ;
! Generic nodes
M: node literals* ( node -- ) drop { } ;
! M: node flushable-values* ( node -- ) drop { } ;
M: node live-values* ( node -- seq )
node-in-d [ value? ] subset ;
M: node live-values* ( node -- ) node-values ;
! #shuffle
M: #shuffle literals* ( node -- seq )
dup node-out-d swap node-out-r
[ [ value? ] subset ] 2apply append ;
! #call
! M: #call flushable-values* ( node -- )
! dup node-param "flushable" word-prop
! [ node-out-d ] [ drop { } ] if ;
! #push
M: #push literals* ( node -- seq ) node-out-d ;
! #return
M: #return live-values* ( node -- seq )
#! Values returned by local labels can be killed.
dup node-param [ drop { } ] [ delegate live-values* ] if ;
! nodes that don't use their input values directly
UNION: #killable #shuffle #call-label #merge #values #entry ;
! nodes that don't use their values directly
UNION: #killable
#push #shuffle #call-label #merge #values #entry ;
M: #killable live-values* ( node -- seq ) drop { } ;

28
library/inference/optimizer.factor → library/compiler/optimizer/optimizer.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer
USING: compiler-backend generic hashtables inference io kernel
lists math namespaces sequences vectors ;
USING: generic hashtables inference io kernel lists math
namespaces sequences test vectors ;
SYMBOL: optimizer-changed
GENERIC: optimize-node* ( node -- node/t )
: keep-optimizing ( node -- node ? )
dup optimize-node* dup t =
dup optimize-node* dup t eq?
[ drop f ] [ nip keep-optimizing t or ] if ;
: optimize-node ( node -- node )
@ -34,24 +34,12 @@ M: f optimize-node* drop t ;
M: node optimize-node* ( node -- t ) drop t ;
! #shuffle
: can-compose? ( shuffle -- ? )
dup shuffle-in-d length swap shuffle-in-r length +
vregs length <= ;
: compose-shuffle-nodes ( #shuffle #shuffle -- #shuffle/t )
[ [ node-shuffle ] 2apply compose-shuffle ] keep
over can-compose?
[ [ set-node-shuffle ] keep ] [ 2drop t ] if ;
M: #shuffle optimize-node* ( node -- node/t )
dup node-successor dup #shuffle? [
compose-shuffle-nodes
] [
drop [
dup node-in-d over node-out-d sequence=
>r dup node-in-r swap node-out-r sequence= r> and
] prune-if
] if ;
[ node-values empty? ] prune-if ;
! #push
M: #push optimize-node* ( node -- node/t )
[ node-out-d empty? ] prune-if ;
! #return
M: #return optimize-node* ( node -- node/t )

10
library/inference/print-dataflow.factor → library/compiler/optimizer/print-dataflow.factor
View File

@ -38,6 +38,8 @@ M: comment pprint* ( ann -- )
M: #shuffle node>quot ( ? node -- )
>r drop t r> dup effect-str "#shuffle: " swap append comment, ;
M: #push node>quot ( ? node -- ) nip >#push< % ;
DEFER: dataflow>quot
: #call>quot ( ? node -- )
@ -63,13 +65,7 @@ M: #dispatch node>quot ( ? node -- )
M: #return node>quot ( ? node -- )
dup node-param unparse "#return " swap append comment, ;
M: #values node>quot ( ? node -- ) "#values" comment, ;
M: #merge node>quot ( ? node -- ) "#merge" comment, ;
M: #entry node>quot ( ? node -- ) "#entry" comment, ;
M: #terminate node>quot ( ? node -- ) "#terminate" comment, ;
M: object node>quot ( ? node -- ) dup class word-name comment, ;
: (dataflow>quot) ( ? node -- )
dup [

61
library/compiler/optimizer/specializers.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler
USING: arrays generic hashtables kernel kernel-internals math
namespaces sequences vectors words ;
: make-standard-specializer ( quot class picker -- quot )
over \ object eq? [
2drop
] [
[
, "predicate" word-prop % dup , , \ if ,
] [ ] make
] if ;
: make-math-specializer ( quot picker -- quot )
[
, \ tag , num-tags swap <array> , \ dispatch ,
] [ ] make ;
: make-specializer ( quot class picker -- quot )
over number eq? [
nip make-math-specializer
] [
make-standard-specializer
] if ;
: specialized-def ( word -- quot )
dup word-def swap "specializer" word-prop [
reverse-slice { dup over pick } [
make-specializer
] 2each
] when* ;
{ 1+ 1- sq neg recip sgn truncate } [
{ number } "specializer" set-word-prop
] each
{ vneg norm-sq norm normalize } [
{ array } "specializer" set-word-prop
] each
\ n*v { object array } "specializer" set-word-prop
\ v*n { array object } "specializer" set-word-prop
\ n/v { object array } "specializer" set-word-prop
\ v/n { array object } "specializer" set-word-prop
{ v+ v- v* v/ vmax vmin v. } [
{ array array } "specializer" set-word-prop
] each
{ hash* remove-hash set-hash } [
{ hashtable } "specializer" set-word-prop
] each
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each
{ peek pop* pop push } [
{ vector } "specializer" set-word-prop
] each

89
library/compiler/ppc/alien.factor
View File

@ -1,89 +0,0 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler-backend
USING: alien assembler kernel kernel-internals math sequences ;
GENERIC: freg>stack ( stack reg reg-class -- )
GENERIC: stack>freg ( stack reg reg-class -- )
M: int-regs freg>stack drop 1 rot stack@ STW ;
M: int-regs stack>freg drop 1 rot stack@ LWZ ;
: STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
M: float-regs freg>stack >r 1 rot stack@ r> STF ;
: LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
M: float-regs stack>freg >r 1 rot stack@ r> LF ;
M: stack-params stack>freg
drop 2dup = [
2drop
] [
>r 0 1 rot stack@ LWZ 0 1 r> stack@ STW
] if ;
M: stack-params freg>stack
>r stack-increment + swap r> stack>freg ;
M: %unbox generate-node ( vop -- )
drop
! Call the unboxer
2 input f compile-c-call
! Store the return value on the C stack
0 input 1 input [ return-reg ] keep freg>stack ;
: struct-ptr/size ( func -- )
! Load destination address
3 1 0 input stack@ ADDI
! Load struct size
2 input 4 LI
f compile-c-call ;
M: %unbox-struct generate-node ( vop -- )
drop "unbox_value_struct" struct-ptr/size ;
M: %box-struct generate-node ( vop -- )
drop "box_value_struct" struct-ptr/size ;
: (%move) 0 input 1 input 2 input [ fastcall-regs nth ] keep ;
M: %stack>freg generate-node ( vop -- )
! Move a value from the C stack into the fastcall register
drop (%move) stack>freg ;
M: %freg>stack generate-node ( vop -- )
! Move a value from a fastcall register to the C stack
drop (%move) freg>stack ;
M: %box generate-node ( vop -- )
drop
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
0 input [
1 input [ fastcall-regs first ] keep stack>freg
] when*
2 input f compile-c-call ;
M: %alien-callback generate-node ( vop -- )
drop
3 0 input load-indirect
"run_callback" f compile-c-call ;
: save-return 0 swap [ return-reg ] keep freg>stack ;
: load-return 0 swap [ return-reg ] keep stack>freg ;
M: %callback-value generate-node ( vop -- )
drop
! Call the unboxer
1 input f compile-c-call
! Save return register
0 input save-return
! Restore data/callstacks
"unnest_stacks" f compile-c-call
! Restore return register
0 input load-return ;

Some files were not shown because too many files have changed in this diff Show More