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

Merge branch 'master' of git://factorcode.org/git/factor 

Conflicts:

	extra/irc/messages/messages.factor
db4
Bruno Deferrari 2008-09-15 15:28:16 -03:00
parent c3380865c1 e39d8ab92c
commit 4bd73a1eb7
455 changed files with 5279 additions and 1938 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alarms/alarms-docs.factor
View File

@ -23,7 +23,7 @@ HELP: every
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;
ARTICLE: "alarms" "Alarms"
"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
{ $subsection alarm }
{ $subsection add-alarm }
{ $subsection later }

9
basis/alias/alias-docs.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words help.markup help.syntax ;
IN: alias
@ -14,4 +16,11 @@ HELP: ALIAS:
}
} ;
ARTICLE: "alias" "Alias"
"The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl
"Make a new word that aliases another word:"
{ $subsection define-alias }
"Make an alias at parse-time:"
{ $subsection POSTPONE: ALIAS: } ;
ABOUT: "alias"

2
basis/alien/arrays/arrays.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays alien.c-types alien.structs
sequences math kernel namespaces libc cpu.architecture ;
sequences math kernel namespaces make libc cpu.architecture ;
IN: alien.arrays
UNION: value-type array struct-type ;

2
basis/alien/c-types/c-types.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
accessors combinators effects continuations ;

2
basis/alien/structs/fields/fields.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel kernel.private math namespaces
sequences strings words effects combinators alien.c-types ;
make sequences strings words effects combinators alien.c-types ;
IN: alien.structs.fields
TUPLE: field-spec name offset type reader writer ;

12
basis/alien/structs/structs.factor
View File

@ -18,20 +18,16 @@ M: struct-type c-type-align align>> ;
M: struct-type c-type-stack-align? drop f ;
M: struct-type unbox-parameter
[ heap-size %unbox-struct ]
[ unbox-parameter ]
if-value-structs? ;
[ %unbox-struct ] [ unbox-parameter ] if-value-structs? ;
M: struct-type unbox-return
f swap heap-size %unbox-struct ;
f swap %unbox-struct ;
M: struct-type box-parameter
[ heap-size %box-struct ]
[ box-parameter ]
if-value-structs? ;
[ %box-struct ] [ box-parameter ] if-value-structs? ;
M: struct-type box-return
f swap heap-size %box-struct ;
f swap %box-struct ;
M: struct-type stack-size
[ heap-size ] [ stack-size ] if-value-structs? ;

2
basis/ascii/ascii-docs.factor
View File

@ -38,7 +38,7 @@ HELP: quotable?
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
ARTICLE: "ascii" "ASCII character classes"
"Traditional ASCII character classes:"
"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:"
{ $subsection blank? }
{ $subsection letter? }
{ $subsection LETTER? }

18
basis/base64/base64-docs.factor
View File

@ -1,20 +1,28 @@
USING: help.markup help.syntax kernel math ;
USING: help.markup help.syntax kernel math sequences ;
IN: base64
HELP: >base64
{ $values { "seq" "a sequence" } { "base64" "a string of base64 characters" } }
{ $values { "seq" sequence } { "base64" "a string of base64 characters" } }
{ $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits." }
{ $examples
{ $unchecked-example "\"The monorail is a free service.\" >base64 ." "VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==" }
{ $example "USING: prettyprint base64 strings ;" "\"The monorail is a free service.\" >base64 >string ." "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\"" }
}
{ $see-also base64> } ;
HELP: base64>
{ $values { "base64" "a string of base64 characters" } { "str" "a string" } }
{ $values { "base64" "a string of base64 characters" } { "seq" sequence } }
{ $description "Converts a string in base64 encoding back into its binary representation." }
{ $examples
{ $unchecked-example "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\" base64> ." "\"The monorail is a free service.\"" }
{ $example "USING: prettyprint base64 strings ;" "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\" base64> >string ." "\"The monorail is a free service.\"" }
}
{ $notes "This word will throw if the input string contains characters other than those allowed in base64 encodings." }
{ $see-also >base64 } ;
ARTICLE: "base64" "Base 64 conversions"
"The " { $vocab-link "base64" } " vocabulary implements conversions of sequences to printable characters in base 64. These plain-text representations of binary data may be passed around and converted back to binary data later." $nl
"Converting to base 64:"
{ $subsection >base64 }
"Converting back to binary:"
{ $subsection base64> } ;
ABOUT: "base64"

2
basis/base64/base64.factor
View File

@ -43,7 +43,7 @@ PRIVATE>
[ [ "" ] [ >base64-rem ] if-empty ]
bi* append ;
: base64> ( base64 -- str )
: base64> ( base64 -- seq )
#! input length must be a multiple of 4
[ 4 <groups> [ decode4 ] map concat ]
[ [ CHAR: = = ] count-end ]

22
basis/binary-search/binary-search-docs.factor
View File

@ -1,17 +1,6 @@
IN: binary-search
USING: help.markup help.syntax sequences kernel math.order ;
ARTICLE: "binary-search" "Binary search"
"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
{ $subsection search }
"Variants of sequence words optimized for sorted sequences:"
{ $subsection sorted-index }
{ $subsection sorted-member? }
{ $subsection sorted-memq? }
{ $see-also "order-specifiers" "sequences-sorting" } ;
ABOUT: "binary-search"
HELP: search
{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")."
@ -41,3 +30,14 @@ HELP: sorted-memq?
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
{ memq? sorted-memq? } related-words
ARTICLE: "binary-search" "Binary search"
"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
{ $subsection search }
"Variants of sequence words optimized for sorted sequences:"
{ $subsection sorted-index }
{ $subsection sorted-member? }
{ $subsection sorted-memq? }
{ $see-also "order-specifiers" "sequences-sorting" } ;
ABOUT: "binary-search"

2
basis/bootstrap/image/image.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic assocs hashtables assocs
hashtables.private io kernel kernel.private math namespaces
hashtables.private io kernel kernel.private math namespaces make
parser prettyprint sequences sequences.private strings sbufs
vectors words quotations assocs system layouts splitting
grouping growable classes classes.builtin classes.tuple

2
basis/bootstrap/image/upload/upload.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io namespaces
kernel io.files bootstrap.image sequences io namespaces make
io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload

11
basis/channels/channels-docs.factor
View File

@ -33,3 +33,14 @@ HELP: from
" It will block the calling thread until there is data in the channel."
}
{ $see-also <channel> to } ;
ARTICLE: "channels" "Channels"
"The " { $vocab-link "channels" } " vocabulary provides a simple abstraction to send and receive objects." $nl
"Opening a channel:"
{ $subsection <channel> }
"Sending a message:"
{ $subsection to }
"Receiving a message:"
{ $subsection from } ;
ABOUT: "channels"

2
basis/channels/remote/remote.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
! Remote Channels
USING: kernel init namespaces assocs arrays random
USING: kernel init namespaces make assocs arrays random
sequences channels match concurrency.messaging
concurrency.distributed threads accessors ;
IN: channels.remote

2
basis/checksums/common/common.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitwise strings io.binary namespaces
grouping ;
make grouping ;
IN: checksums.common
SYMBOL: bytes-read

4
basis/checksums/sha1/sha1.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel io io.encodings.binary io.files
io.streams.byte-array math.vectors strings sequences namespaces
math parser sequences assocs grouping vectors io.binary hashtables
symbols math.bitwise checksums checksums.common ;
make math parser sequences assocs grouping vectors io.binary
hashtables symbols math.bitwise checksums checksums.common ;
IN: checksums.sha1
! Implemented according to RFC 3174.

2
basis/checksums/sha2/sha2.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting grouping math sequences namespaces
USING: kernel splitting grouping math sequences namespaces make
io.binary symbols math.bitwise checksums checksums.common
sbufs strings ;
IN: checksums.sha2

58
basis/circular/circular-docs.factor Normal file
View File

@ -0,0 +1,58 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string sequences
math kernel ;
IN: circular
HELP: <circular-string>
{ $values
{ "n" integer }
{ "circular" circular } }
{ $description "Creates a new circular string object. A circular string is a string object that can be accessed out of bounds and the index will wrap around to the start of the string." } ;
HELP: <circular>
{ $values
{ "seq" sequence }
{ "circular" circular } }
{ $description "Creates a new " { $link circular } " object that wraps an existing sequence. By default, the index is set to zero." } ;
HELP: <growing-circular>
{ $values
{ "capacity" integer }
{ "growing-circular" growing-circular } }
{ $description "Creates a new growing-circular object." } ;
HELP: change-circular-start
{ $values
{ "n" integer } { "circular" circular } }
{ $description "Changes the start index of a circular object." } ;
HELP: circular
{ $description "A tuple class that stores a sequence and its start index." } ;
HELP: growing-circular
{ $description "A circular sequence that is growable." } ;
HELP: push-circular
{ $values
{ "elt" object } { "circular" circular } }
{ $description "Pushes an element to a " { $link circular } " object." } ;
HELP: push-growing-circular
{ $values
{ "elt" object } { "circular" circular } }
{ $description "Pushes an element onto a " { $link growing-circular } " object." } ;
ARTICLE: "circular" "circular"
"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
"Creating a new circular object:"
{ $subsection <circular> }
{ $subsection <circular-string> }
{ $subsection <growing-circular> }
"Changing the start index:"
{ $subsection change-circular-start }
"Pushing new elements:"
{ $subsection push-circular }
{ $subsection push-growing-circular } ;
ABOUT: "circular"

4
basis/circular/circular.factor
View File

@ -11,9 +11,11 @@ TUPLE: circular seq start ;
: <circular> ( seq -- circular )
0 circular boa ;
<PRIVATE
: circular-wrap ( n circular -- n circular )
[ start>> + ] keep
[ seq>> length rem ] keep ; inline
PRIVATE>
M: circular length seq>> length ;
@ -37,11 +39,13 @@ TUPLE: growing-circular < circular length ;
M: growing-circular length length>> ;
<PRIVATE
: full? ( circular -- ? )
[ length ] [ seq>> length ] bi = ;
: set-peek ( elt seq -- )
[ length 1- ] keep set-nth ;
PRIVATE>
: push-growing-circular ( elt circular -- )
dup full? [ push-circular ]

4
basis/cocoa/enumeration/enumeration.factor
View File

@ -15,7 +15,7 @@ IN: cocoa.enumeration
object state stackbuf count -> countByEnumeratingWithState:objects:count:
dup zero? [ drop ] [
state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
'[ , void*-nth quot call ] each
'[ _ void*-nth quot call ] each
object quot state stackbuf count (NSFastEnumeration-each)
] if ; inline recursive
@ -24,7 +24,7 @@ IN: cocoa.enumeration
: NSFastEnumeration-map ( object quot -- vector )
NS-EACH-BUFFER-SIZE <vector>
[ '[ @ , push ] NSFastEnumeration-each ] keep ; inline
[ '[ @ _ push ] NSFastEnumeration-each ] keep ; inline
: NSFastEnumeration>vector ( object -- vector )
[ ] NSFastEnumeration-map ;

11
basis/cocoa/messages/messages.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings
arrays assocs combinators compiler kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
memoize debugger io.encodings.ascii effects compiler.generator
libc libc.private ;
USING: accessors alien alien.c-types alien.strings arrays assocs
combinators compiler kernel math namespaces make parser
prettyprint prettyprint.sections quotations sequences strings
words cocoa.runtime io macros memoize debugger
io.encodings.ascii effects compiler.generator libc libc.private ;
IN: cocoa.messages
: make-sender ( method function -- quot )

2
basis/cocoa/subclassing/subclassing.factor
View File

@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
parser sequences words cocoa.messages cocoa.runtime
compiler.units io.encodings.ascii generalizations
continuations ;
continuations make ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )

1
basis/cocoa/types/types.factor
View File

@ -46,6 +46,7 @@ C-STRUCT: NSSize
{ "CGFloat" "h" } ;
TYPEDEF: NSSize _NSSize
TYPEDEF: NSSize CGSize
TYPEDEF: NSPoint CGPoint
: <NSSize> ( w h -- size )

2
basis/cocoa/views/views.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays kernel math namespaces cocoa
USING: alien.c-types arrays kernel math namespaces make cocoa
cocoa.messages cocoa.classes cocoa.types sequences
continuations ;
IN: cocoa.views

14
basis/columns/columns-docs.factor
View File

@ -1,13 +1,6 @@
USING: help.markup help.syntax sequences ;
IN: columns
ARTICLE: "columns" "Column sequences"
"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
{ $subsection column }
{ $subsection <column> }
"A utility word:"
{ $subsection <flipped> } ;
HELP: column
{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
@ -30,4 +23,11 @@ HELP: <flipped>
{ $description "Outputs a new virtual sequence which presents the transpose of " { $snippet "seq" } "." }
{ $notes "This is the virtual sequence equivalent of " { $link flip } "." } ;
ARTICLE: "columns" "Column sequences"
"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
{ $subsection column }
{ $subsection <column> }
"A utility word:"
{ $subsection <flipped> } ;
ABOUT: "columns"

84
basis/combinators/short-circuit/short-circuit-docs.factor Normal file
View File

@ -0,0 +1,84 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string quotations
math ;
IN: combinators.short-circuit
HELP: 0&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true." } ;
HELP: 0||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true." } ;
HELP: 1&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same element from the datastack and must output a boolean." } ;
HELP: 1||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
HELP: 2&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same two elements from the datastack and must output a boolean." } ;
HELP: 2||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
HELP: 3&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same three elements from the datastack and must output a boolean." } ;
HELP: 3||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
HELP: n&&-rewrite
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quot" quotation } }
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ;
HELP: n||-rewrite
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quot" quotation } }
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ;
ARTICLE: "combinators.short-circuit" "combinators.short-circuit"
"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
"AND combinators:"
{ $subsection 0&& }
{ $subsection 1&& }
{ $subsection 2&& }
{ $subsection 3&& }
"OR combinators:"
{ $subsection 0|| }
{ $subsection 1|| }
{ $subsection 2|| }
{ $subsection 3|| }
"Generalized combinators:"
{ $subsection n&&-rewrite }
{ $subsection n||-rewrite }
;
ABOUT: "combinators.short-circuit"

4
basis/combinators/short-circuit/short-circuit.factor
View File

@ -11,7 +11,7 @@ IN: combinators.short-circuit
[ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
map
[ t ] [ N nnip ] 2array suffix
'[ f , cond ] ;
'[ f _ cond ] ;
MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
@ -25,7 +25,7 @@ MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ;
[ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
map
[ drop N ndrop t ] [ f ] 2array suffix
'[ f , cond ] ;
'[ f _ cond ] ;
MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;

37
basis/combinators/short-circuit/smart/smart-docs.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string quotations ;
IN: combinators.short-circuit.smart
HELP: &&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Infers the number of arguments that each quotation takes from the stack. Eacn quotation must take the same number of arguments. Returns true if every quotation yields true, and stops early if one yields false." }
{ $examples "Smart combinators will infer the two inputs:"
{ $example "USING: prettyprint kernel math combinators.short-circuit.smart ;"
"2 3 { [ + 5 = ] [ - -1 = ] } && ."
"t"
}
} ;
HELP: ||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Infers the number of arguments that each quotation takes from the stack. Eacn quotation must take the same number of arguments. Returns true if any quotation yields true, and stops early when one yields true." }
{ $examples "Smart combinators will infer the two inputs:"
{ $example "USING: prettyprint kernel math combinators.short-circuit.smart ;"
"2 3 { [ - 1 = ] [ + 5 = ] } || ."
"t"
}
} ;
ARTICLE: "combinators.short-circuit.smart" "combinators.short-circuit.smart"
"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary infers the number of inputs that the sequence of quotations takes." $nl
"Generalized AND:"
{ $subsection && }
"Generalized OR:"
{ $subsection || } ;
ABOUT: "combinators.short-circuit.smart"

74
basis/command-line/command-line-docs.factor
View File

@ -1,6 +1,43 @@
USING: help.markup help.syntax parser vocabs.loader strings ;
IN: command-line
HELP: run-bootstrap-init
{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
HELP: run-user-init
{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
HELP: cli-param
{ $values { "param" string } }
{ $description "Process a command-line switch."
$nl
"If the parameter contains " { $snippet "=" } ", the global variable named by the string before the equals sign is set to the string after the equals sign."
$nl
"If the parameter begins with " { $snippet "no-" } ", sets the global variable named by the parameter with the prefix removed to " { $link f } "."
$nl
"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ;
HELP: cli-args
{ $values { "args" "a sequence of strings" } }
{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
HELP: main-vocab-hook
{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
HELP: main-vocab
{ $values { "vocab" string } }
{ $description "Outputs the name of the vocabulary which is to be run on startup using the " { $link run } " word. The " { $snippet "-run" } " command line switch overrides this setting." } ;
HELP: default-cli-args
{ $description "Sets global variables corresponding to default command line arguments." } ;
HELP: ignore-cli-args?
{ $values { "?" "a boolean" } }
{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
HELP: parse-command-line
{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ;
ARTICLE: "runtime-cli-args" "Command line switches for the VM"
"A handful of command line switches are processed by the VM and not the library. They control low-level features."
{ $table
@ -77,40 +114,3 @@ $nl
{ $subsection main-vocab-hook } ;
ABOUT: "cli"
HELP: run-bootstrap-init
{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
HELP: run-user-init
{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
HELP: cli-param
{ $values { "param" string } }
{ $description "Process a command-line switch."
$nl
"If the parameter contains " { $snippet "=" } ", the global variable named by the string before the equals sign is set to the string after the equals sign."
$nl
"If the parameter begins with " { $snippet "no-" } ", sets the global variable named by the parameter with the prefix removed to " { $link f } "."
$nl
"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ;
HELP: cli-args
{ $values { "args" "a sequence of strings" } }
{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
HELP: main-vocab-hook
{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
HELP: main-vocab
{ $values { "vocab" string } }
{ $description "Outputs the name of the vocabulary which is to be run on startup using the " { $link run } " word. The " { $snippet "-run" } " command line switch overrides this setting." } ;
HELP: default-cli-args
{ $description "Sets global variables corresponding to default command line arguments." } ;
HELP: ignore-cli-args?
{ $values { "?" "a boolean" } }
{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
HELP: parse-command-line
{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ;

2
basis/compiler/compiler.factor
View File

@ -54,7 +54,7 @@ SYMBOL: +failed+
H{ } clone dependencies set
H{ } clone generic-dependencies set
, {
_ {
[ compile-begins ]
[
[ build-tree-from-word ] [ compile-failed return ] recover

2
basis/compiler/generator/fixup/fixup.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces sequences words
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private cpu.architecture
math.order accessors growable ;

44
basis/compiler/generator/generator.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes combinators
cpu.architecture effects generic hashtables io kernel
kernel.private layouts math math.parser namespaces prettyprint
quotations sequences system threads words vectors sets deques
continuations.private summary alien alien.c-types
kernel.private layouts math math.parser namespaces make
prettyprint quotations sequences system threads words vectors
sets deques continuations.private summary alien alien.c-types
alien.structs alien.strings alien.arrays libc compiler.errors
stack-checker.inlining
compiler.tree compiler.tree.builder compiler.tree.combinators
compiler.tree.propagation.info compiler.generator.fixup
compiler.generator.registers compiler.generator.iterator ;
stack-checker.inlining compiler.tree compiler.tree.builder
compiler.tree.combinators compiler.tree.propagation.info
compiler.generator.fixup compiler.generator.registers
compiler.generator.iterator ;
IN: compiler.generator
SYMBOL: compile-queue
@ -271,9 +271,7 @@ M: #return-recursive generate-node
! #alien-invoke
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
] [ drop f ] if ;
dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
@ -304,10 +302,10 @@ M: #return-recursive generate-node
alien-parameters parameter-sizes drop ;
: alien-invoke-frame ( params -- n )
#! One cell is temporary storage, temp@
dup return>> return-size
swap alien-stack-frame +
cell + ;
#! Two cells for temporary storage, temp@ and on x86.64,
#! small struct return value unpacking
[ return>> return-size ] [ alien-stack-frame ] bi
+ 2 cells + ;
: set-stack-frame ( n -- )
dup [ frame-required ] when* \ stack-frame set ;
@ -361,17 +359,17 @@ M: float-regs inc-reg-class
[ spill-param ] [ fastcall-param ] if
[ param-reg ] keep ;
: (flatten-int-type) ( size -- )
cell /i "void*" c-type <repetition> % ;
: (flatten-int-type) ( size -- types )
cell /i "void*" c-type <repetition> ;
GENERIC: flatten-value-type ( type -- )
GENERIC: flatten-value-type ( type -- types )
M: object flatten-value-type , ;
M: object flatten-value-type 1array ;
M: struct-type flatten-value-type ( type -- )
M: struct-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- )
M: long-long-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
: flatten-value-types ( params -- params )
@ -379,9 +377,9 @@ M: long-long-type flatten-value-type ( type -- )
[
0 [
c-type
[ parameter-align (flatten-int-type) ] keep
[ parameter-align (flatten-int-type) % ] keep
[ stack-size cell align + ] keep
flatten-value-type
flatten-value-type %
] reduce drop
] { } make ;

22
basis/compiler/generator/registers/registers.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes classes.private classes.algebra
combinators hashtables kernel layouts math namespaces quotations
sequences system vectors words effects alien byte-arrays
accessors sets math.order cpu.architecture
combinators hashtables kernel layouts math namespaces make
quotations sequences system vectors words effects alien
byte-arrays accessors sets math.order cpu.architecture
compiler.generator.fixup ;
IN: compiler.generator.registers
@ -50,13 +50,21 @@ C: <vreg> vreg ( n reg-class -- vreg )
M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
M: vreg live-vregs* , ;
M: vreg move-spec reg-class>> move-spec ;
M: vreg move-spec
reg-class>> {
{ [ dup int-regs? ] [ f ] }
{ [ dup float-regs? ] [ float ] }
} cond nip ;
M: vreg operand-class*
reg-class>> {
{ [ dup int-regs? ] [ f ] }
{ [ dup float-regs? ] [ float ] }
} cond nip ;
INSTANCE: vreg value
M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling
SINGLETON: temp-reg

146
basis/compiler/tests/alien.factor
View File

@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences stack-checker
stack-checker.errors words arrays parser quotations
continuations effects namespaces.private io io.streams.string
memory system threads tools.test math accessors ;
memory system threads tools.test math accessors combinators ;
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test
@ -401,3 +401,147 @@ C-STRUCT: test_struct_13
FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
[ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
! Joe Groff found this problem
C-STRUCT: double-rect
{ "double" "a" }
{ "double" "b" }
{ "double" "c" }
{ "double" "d" } ;
: <double-rect> ( a b c d -- foo )
"double-rect" <c-object>
{
[ set-double-rect-d ]
[ set-double-rect-c ]
[ set-double-rect-b ]
[ set-double-rect-a ]
[ ]
} cleave ;
: >double-rect< ( foo -- a b c d )
{
[ double-rect-a ]
[ double-rect-b ]
[ double-rect-c ]
[ double-rect-d ]
} cleave ;
: double-rect-callback ( -- alien )
"void" { "void*" "void*" "double-rect" } "cdecl"
[ "example" set-global 2drop ] alien-callback ;
: double-rect-test ( arg -- arg' )
f f rot
double-rect-callback
"void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect
"example" get-global ;
[ 1.0 2.0 3.0 4.0 ]
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
C-STRUCT: test_struct_14
{ "double" "x1" }
{ "double" "x2" } ;
FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
[ 1.0 2.0 ] [
1.0 2.0 ffi_test_40
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
] unit-test
: callback-10 ( -- callback )
"test_struct_14" { "double" "double" } "cdecl"
[
"test_struct_14" <c-object>
[ set-test_struct_14-x2 ] keep
[ set-test_struct_14-x1 ] keep
] alien-callback ;
: callback-10-test ( x1 x2 callback -- result )
"test_struct_14" { "double" "double" } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
] unit-test
FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
[ 1 2.0 ] [
1 2.0 ffi_test_41
[ test-struct-12-a ] [ test-struct-12-x ] bi
] unit-test
: callback-11 ( -- callback )
"test-struct-12" { "int" "double" } "cdecl"
[
"test-struct-12" <c-object>
[ set-test-struct-12-x ] keep
[ set-test-struct-12-a ] keep
] alien-callback ;
: callback-11-test ( x1 x2 callback -- result )
"test-struct-12" { "int" "double" } "cdecl" alien-indirect ;
[ 1 2.0 ] [
1 2.0 callback-11 callback-11-test
[ test-struct-12-a ] [ test-struct-12-x ] bi
] unit-test
C-STRUCT: test_struct_15
{ "float" "x" }
{ "float" "y" } ;
FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ test_struct_15-x ] [ test_struct_15-y ] bi ] unit-test
: callback-12 ( -- callback )
"test_struct_15" { "float" "float" } "cdecl"
[
"test_struct_15" <c-object>
[ set-test_struct_15-y ] keep
[ set-test_struct_15-x ] keep
] alien-callback ;
: callback-12-test ( x1 x2 callback -- result )
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test
[ test_struct_15-x ] [ test_struct_15-y ] bi
] unit-test
C-STRUCT: test_struct_16
{ "float" "x" }
{ "int" "a" } ;
FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ test_struct_16-x ] [ test_struct_16-a ] bi ] unit-test
: callback-13 ( -- callback )
"test_struct_16" { "float" "int" } "cdecl"
[
"test_struct_16" <c-object>
[ set-test_struct_16-a ] keep
[ set-test_struct_16-x ] keep
] alien-callback ;
: callback-13-test ( x1 x2 callback -- result )
"test_struct_16" { "float" "int" } "cdecl" alien-indirect ;
[ 1.0 2 ] [
1.0 2 callback-13 callback-13-test
[ test_struct_16-x ] [ test_struct_16-a ] bi
] unit-test
FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
[ 1.0 2.0 ] [ ffi_test_44 [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi ] unit-test
: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
[ ] [ stack-frame-bustage 2drop ] unit-test

2
basis/compiler/tests/curry.factor
View File

@ -1,5 +1,5 @@
USING: tools.test quotations math kernel sequences
assocs namespaces compiler.units ;
assocs namespaces make compiler.units ;
IN: compiler.tests
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test

2
basis/compiler/tests/templates-early.factor
View File

@ -3,7 +3,7 @@ IN: compiler.tests
USING: compiler compiler.generator compiler.generator.registers
compiler.generator.registers.private tools.test namespaces
sequences words kernel math effects definitions compiler.units
accessors cpu.architecture ;
accessors cpu.architecture make ;
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;

57
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -10,12 +10,11 @@ compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
compiler.tree.builder
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.checker ;
: cleaned-up-tree ( quot -- nodes )
build-tree normalize propagate cleanup dup check-nodes ;
compiler.tree.checker
compiler.tree.debugger ;
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
@ -33,12 +32,6 @@ compiler.tree.checker ;
[ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
: inlined? ( quot seq/word -- ? )
[ cleaned-up-tree ] dip
dup word? [ 1array ] when
'[ dup #call? [ word>> , member? ] [ drop f ] if ]
contains-node? not ;
[ f ] [
[ { integer } declare >fixnum ]
\ >fixnum inlined?
@ -457,3 +450,47 @@ cell-bits 32 = [
[ [ >r "A" throw r> ] [ "B" throw ] if ]
cleaned-up-tree drop
] unit-test
! Regression from benchmark.nsieve
: chicken-fingers ( i seq -- )
2dup < [
2drop
] [
chicken-fingers
] if ; inline recursive
: buffalo-wings ( i seq -- )
2dup < [
2dup chicken-fingers
>r 1+ r> buffalo-wings
] [
2drop
] if ; inline recursive
[ t ] [
[ 2 swap >fixnum buffalo-wings ]
{ <-integer-fixnum +-integer-fixnum } inlined?
] unit-test
! A reduction
: buffalo-sauce f ;
: steak ( -- )
buffalo-sauce [ steak ] when ; inline recursive
: ribs ( i seq -- )
2dup < [
steak
>r 1+ r> ribs
] [
2drop
] if ; inline recursive
[ t ] [
[ 2 swap >fixnum ribs ]
{ <-integer-fixnum +-integer-fixnum } inlined?
] unit-test
[ t ] [
[ hashtable new ] \ new inlined?
] unit-test

16
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -64,14 +64,6 @@ GENERIC: cleanup* ( node -- node/nodes )
] [ body>> cleanup ] bi ;
! Removing overflow checks
: no-overflow-variant ( op -- fast-op )
H{
{ fixnum+ fixnum+fast }
{ fixnum- fixnum-fast }
{ fixnum* fixnum*fast }
{ fixnum-shift fixnum-shift-fast }
} at ;
: (remove-overflow-check?) ( #call -- ? )
node-output-infos first class>> fixnum class<= ;
@ -101,7 +93,7 @@ M: #declare cleanup* drop f ;
: delete-unreachable-branches ( #branch -- )
dup live-branches>> '[
,
_
[ [ [ drop ] [ delete-nodes ] if ] 2each ]
[ select-children ]
2bi
@ -148,9 +140,9 @@ M: #branch cleanup*
M: #phi cleanup*
#! Remove #phi function inputs which no longer exist.
live-branches get
[ '[ , sift-children ] change-phi-in-d ]
[ '[ , sift-children ] change-phi-info-d ]
[ '[ , sift-children ] change-terminated ] tri
[ '[ _ sift-children ] change-phi-in-d ]
[ '[ _ sift-children ] change-phi-info-d ]
[ '[ _ sift-children ] change-terminated ] tri
eliminate-phi
live-branches off ;

16
basis/compiler/tree/combinators/combinators.factor
View File

@ -6,12 +6,12 @@ IN: compiler.tree.combinators
: each-node ( nodes quot: ( node -- ) -- )
dup dup '[
, [
_ [
dup #branch? [
children>> [ , each-node ] each
children>> [ _ each-node ] each
] [
dup #recursive? [
child>> , each-node
child>> _ each-node
] [ drop ] if
] if
] bi
@ -21,22 +21,22 @@ IN: compiler.tree.combinators
dup dup '[
@
dup #branch? [
[ [ , map-nodes ] map ] change-children
[ [ _ map-nodes ] map ] change-children
] [
dup #recursive? [
[ , map-nodes ] change-child
[ _ map-nodes ] change-child
] when
] if
] map flatten ; inline recursive
: contains-node? ( nodes quot: ( node -- ? ) -- ? )
dup dup '[
, keep swap [ drop t ] [
_ keep swap [ drop t ] [
dup #branch? [
children>> [ , contains-node? ] contains?
children>> [ _ contains-node? ] contains?
] [
dup #recursive? [
child>> , contains-node?
child>> _ contains-node?
] [ drop f ] if
] if
] if

8
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -33,10 +33,10 @@ M: #branch remove-dead-code*
: live-value-indices ( values -- indices )
[ length ] keep live-values get
'[ , nth , key? ] filter ; inline
'[ _ nth _ key? ] filter ; inline
: drop-indexed-values ( values indices -- node )
[ drop filter-live ] [ nths ] 2bi
[ drop filter-live ] [ swap nths ] 2bi
[ make-values ] keep
[ drop ] [ zip ] 2bi
#shuffle ;
@ -44,13 +44,13 @@ M: #branch remove-dead-code*
: insert-drops ( nodes values indices -- nodes' )
'[
over ends-with-terminate?
[ drop ] [ , drop-indexed-values suffix ] if
[ drop ] [ _ drop-indexed-values suffix ] if
] 2map ;
: hoist-drops ( #phi -- )
if-node get swap
[ phi-in-d>> ] [ out-d>> live-value-indices ] bi
'[ , , insert-drops ] change-children drop ;
'[ _ _ insert-drops ] change-children drop ;
: remove-phi-outputs ( #phi -- )
[ filter-live ] change-out-d drop ;

10
basis/compiler/tree/dead-code/dead-code-tests.factor
View File

@ -3,16 +3,17 @@ compiler.tree.dead-code compiler.tree.def-use compiler.tree
compiler.tree.combinators compiler.tree.propagation
compiler.tree.cleanup compiler.tree.escape-analysis
compiler.tree.tuple-unboxing compiler.tree.debugger
compiler.tree.normalization compiler.tree.checker tools.test
kernel math stack-checker.state accessors combinators io
prettyprint words sequences.deep sequences.private arrays
classes kernel.private ;
compiler.tree.recursive compiler.tree.normalization
compiler.tree.checker tools.test kernel math stack-checker.state
accessors combinators io prettyprint words sequences.deep
sequences.private arrays classes kernel.private ;
IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer
: count-live-values ( quot -- n )
build-tree
analyze-recursive
normalize
propagate
cleanup
@ -64,6 +65,7 @@ IN: compiler.tree.dead-code.tests
: optimize-quot ( quot -- quot' )
build-tree
analyze-recursive
normalize
propagate
cleanup

2
basis/compiler/tree/dead-code/recursive/recursive.factor
View File

@ -84,7 +84,7 @@ M:: #recursive remove-dead-code* ( node -- nodes )
drop-outputs [ node drop-recursive-outputs ] |
node [ (remove-dead-code) ] change-child drop
node label>> [ filter-live ] change-enter-out drop
drop-inputs node drop-outputs 3array
{ drop-inputs node drop-outputs }
] ;
M: #return-recursive remove-dead-code* ;

2
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -53,7 +53,7 @@ M: #alien-invoke compute-live-values* nip look-at-inputs ;
M: #alien-indirect compute-live-values* nip look-at-inputs ;
: filter-mapping ( assoc -- assoc' )
live-values get '[ drop , key? ] assoc-filter ;
live-values get '[ drop _ key? ] assoc-filter ;
: filter-corresponding ( new old -- old' )
#! Remove elements from 'old' if the element with the same

47
basis/compiler/tree/debugger/debugger.factor
View File

@ -1,13 +1,21 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs fry match accessors namespaces effects
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
combinators io sorting hints
combinators io sorting hints qualified
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.cleanup
compiler.tree.propagation
compiler.tree.propagation.info
compiler.tree.def-use
compiler.tree.builder
compiler.tree.optimizer
compiler.tree.combinators ;
compiler.tree.combinators
compiler.tree.checker ;
RENAME: _ match => __
IN: compiler.tree.debugger
! A simple tool for turning tree IR into quotations and
@ -16,7 +24,7 @@ IN: compiler.tree.debugger
GENERIC: node>quot ( node -- )
MACRO: match-choose ( alist -- )
[ '[ , ] ] assoc-map '[ , match-cond ] ;
[ [ ] curry ] assoc-map [ match-cond ] curry ;
MATCH-VARS: ?a ?b ?c ;
@ -42,7 +50,7 @@ MATCH-VARS: ?a ?b ?c ;
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
{ { { ?a ?b } { ?b } } [ nip ] }
{ { { ?a ?b ?c } { ?c } } [ 2nip ] }
{ _ f }
{ __ f }
} match-choose ;
TUPLE: shuffle-node { effect effect } ;
@ -146,3 +154,32 @@ SYMBOL: node-count
: optimizer-report. ( word -- )
make-report report. ;
! More utilities
: final-info ( quot -- seq )
build-tree
analyze-recursive
normalize
propagate
compute-def-use
dup check-nodes
peek node-input-infos ;
: final-classes ( quot -- seq )
final-info [ class>> ] map ;
: final-literals ( quot -- seq )
final-info [ literal>> ] map ;
: cleaned-up-tree ( quot -- nodes )
[
check-optimizer? on
build-tree optimize-tree
] with-scope ;
: inlined? ( quot seq/word -- ? )
[ cleaned-up-tree ] dip
dup word? [ 1array ] when
'[ dup #call? [ word>> _ member? ] [ drop f ] if ]
contains-node? not ;

17
basis/compiler/tree/def-use/def-use-tests.factor
View File

@ -1,9 +1,10 @@
USING: accessors namespaces assocs kernel sequences math
tools.test words sets combinators.short-circuit
stack-checker.state compiler.tree compiler.tree.builder
compiler.tree.normalization compiler.tree.propagation
compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
sorting math.order binary-search compiler.tree.checker ;
compiler.tree.recursive compiler.tree.normalization
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.def-use arrays kernel.private sorting math.order
binary-search compiler.tree.checker ;
IN: compiler.tree.def-use.tests
\ compute-def-use must-infer
@ -18,6 +19,7 @@ IN: compiler.tree.def-use.tests
: test-def-use ( quot -- )
build-tree
analyze-recursive
normalize
propagate
cleanup
@ -27,7 +29,14 @@ IN: compiler.tree.def-use.tests
: too-deep ( a b -- c )
dup [ drop ] [ 2dup too-deep too-deep drop ] if ; inline recursive
[ ] [ [ too-deep ] build-tree normalize compute-def-use check-nodes ] unit-test
[ ] [
[ too-deep ]
build-tree
analyze-recursive
normalize
compute-def-use
check-nodes
] unit-test
! compute-def-use checks for SSA violations, so we use that to
! ensure we generate some common patterns correctly.

10
basis/compiler/tree/def-use/simplified/simplified-tests.factor Normal file
View File

@ -0,0 +1,10 @@
USING: kernel tools.test compiler.tree compiler.tree.builder
compiler.tree.def-use compiler.tree.def-use.simplified accessors
sequences sorting classes ;
IN: compiler.tree.def-use.simplified
[ { #call #return } ] [
[ 1 dup reverse ] build-tree compute-def-use
first out-d>> first actually-used-by
[ node>> class ] map natural-sort
] unit-test

40
basis/compiler/tree/def-use/simplified/simplified.factor Normal file
View File

@ -0,0 +1,40 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences sequences.deep kernel
compiler.tree compiler.tree.def-use ;
IN: compiler.tree.def-use.simplified
! Simplified def-use follows chains of copies.
! A 'real' usage is a usage of a value that is not a #renaming.
TUPLE: real-usage value node ;
GENERIC: actually-used-by* ( value node -- real-usages )
! Def
GENERIC: actually-defined-by* ( value node -- real-usage )
: actually-defined-by ( value -- real-usage )
dup defined-by actually-defined-by* ;
M: #renaming actually-defined-by*
inputs/outputs swap [ index ] dip nth actually-defined-by ;
M: #return-recursive actually-defined-by* real-usage boa ;
M: node actually-defined-by* real-usage boa ;
! Use
: (actually-used-by) ( value -- real-usages )
dup used-by [ actually-used-by* ] with map ;
M: #renaming actually-used-by*
inputs/outputs [ indices ] dip nths
[ (actually-used-by) ] map ;
M: #return-recursive actually-used-by* real-usage boa ;
M: node actually-used-by* real-usage boa ;
: actually-used-by ( value -- real-usages )
(actually-used-by) flatten ;

16
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -1,13 +1,14 @@
IN: compiler.tree.escape-analysis.tests
USING: compiler.tree.escape-analysis
compiler.tree.escape-analysis.allocations compiler.tree.builder
compiler.tree.normalization math.functions
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math math.private
kernel tools.test accessors slots.private quotations.private
prettyprint classes.tuple.private classes classes.tuple
compiler.intrinsics namespaces compiler.tree.propagation.info
stack-checker.errors kernel.private ;
compiler.tree.recursive compiler.tree.normalization
math.functions compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math
math.private kernel tools.test accessors slots.private
quotations.private prettyprint classes.tuple.private classes
classes.tuple compiler.intrinsics namespaces
compiler.tree.propagation.info stack-checker.errors
kernel.private ;
\ escape-analysis must-infer
@ -28,6 +29,7 @@ M: node count-unboxed-allocations* drop ;
: count-unboxed-allocations ( quot -- sizes )
build-tree
analyze-recursive
normalize
propagate
cleanup

4
basis/compiler/tree/escape-analysis/recursive/recursive.factor
View File

@ -28,7 +28,7 @@ IN: compiler.tree.escape-analysis.recursive
: recursive-stacks ( #enter-recursive -- stacks )
recursive-phi-in
escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
escaping-values get '[ [ _ disjoint-set-member? ] all? ] filter
flip ;
: analyze-recursive-phi ( #enter-recursive -- )
@ -67,5 +67,5 @@ M: #return-recursive escape-analysis* ( #return-recursive -- )
[ call-next-method ]
[
[ in-d>> ] [ label>> calls>> ] bi
[ out-d>> escaping-values get '[ , equate ] 2each ] with each
[ out-d>> escaping-values get '[ _ equate ] 2each ] with each
] bi ;

33
basis/compiler/tree/finalization/finalization.factor
View File

@ -1,31 +1,25 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays accessors sequences sequences.private words
fry namespaces math math.order memoize classes.builtin
fry namespaces make math math.order memoize classes.builtin
classes.tuple.private slots.private combinators layouts
byte-arrays alien.accessors
compiler.intrinsics
compiler.tree
compiler.tree.builder
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.combinators
compiler.tree.propagation.info
compiler.tree.cleanup
compiler.tree.def-use
compiler.tree.dead-code
compiler.tree.combinators ;
compiler.tree.late-optimizations ;
IN: compiler.tree.finalization
! This is a late-stage optimization.
! See the comment in compiler.tree.late-optimizations.
! This pass runs after propagation, so that it can expand
! built-in type predicates and memory allocation; these cannot
! be expanded before propagation since we need to see 'fixnum?'
! instead of 'tag 0 eq?' and so on, for semantic reasoning.
! We also delete empty stack shuffles and copies to facilitate
! tail call optimization in the code generator. After this pass
! runs, stack flow information is no longer accurate, since we
! punt in 'splice-quot' and don't update everything that we
! should; this simplifies the code, improves performance, and we
! don't need the stack flow information after this pass anyway.
! tail call optimization in the code generator.
GENERIC: finalize* ( node -- nodes )
@ -36,17 +30,6 @@ M: #shuffle finalize*
[ in>> ] [ out>> ] bi sequence=
[ drop f ] when ;
: splice-quot ( quot -- nodes )
[
build-tree
normalize
propagate
cleanup
compute-def-use
remove-dead-code
but-last
] with-scope ;
: builtin-predicate? ( #call -- ? )
word>> "predicating" word-prop builtin-class? ;
@ -68,7 +51,7 @@ MEMO: builtin-predicate-expansion ( word -- nodes )
MEMO: (tuple-boa-expansion) ( n -- quot )
[
[ 2 + ] map <reversed>
[ '[ [ , set-slot ] keep ] % ] each
[ '[ [ _ set-slot ] keep ] % ] each
] [ ] make ;
: tuple-boa-expansion ( layout -- quot )

98
basis/compiler/tree/identities/identities.factor Normal file
View File

@ -0,0 +1,98 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences fry words math
math.partial-dispatch combinators arrays hashtables
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info ;
IN: compiler.tree.identities
: define-identities ( word identities -- )
[ integer-derived-ops ] dip
'[ _ "identities" set-word-prop ] each ;
SYMBOL: X
\ + {
{ { X 0 } drop }
{ { 0 X } nip }
} define-identities
\ - {
{ { X 0 } drop }
} define-identities
\ * {
{ { X 1 } drop }
{ { 1 X } nip }
{ { X 0 } nip }
{ { 0 X } drop }
} define-identities
\ / {
{ { X 1 } drop }
} define-identities
\ mod {
{ { X 1 } 0 }
} define-identities
\ rem {
{ { X 1 } 0 }
} define-identities
\ bitand {
{ { X -1 } drop }
{ { -1 X } nip }
{ { X 0 } nip }
{ { 0 X } drop }
} define-identities
\ bitor {
{ { X 0 } drop }
{ { 0 X } nip }
{ { X -1 } nip }
{ { -1 X } drop }
} define-identities
\ bitxor {
{ { X 0 } drop }
{ { 0 X } nip }
} define-identities
\ shift {
{ { 0 X } drop }
{ { X 0 } drop }
} define-identities
: matches? ( pattern infos -- ? )
[ over X eq? [ 2drop t ] [ literal>> = ] if ] 2all? ;
: find-identity ( patterns infos -- result )
'[ first _ matches? ] find swap [ second ] when ;
GENERIC: apply-identities* ( node -- node )
: simplify-to-constant ( #call constant -- nodes )
[ [ in-d>> #drop ] [ out-d>> first ] bi ] dip swap #push
2array ;
: select-input ( node n -- #shuffle )
[ [ in-d>> ] [ out-d>> ] bi ] dip
pick nth over first associate #shuffle ;
M: #call apply-identities*
dup word>> "identities" word-prop [
over node-input-infos find-identity [
{
{ \ drop [ 0 select-input ] }
{ \ nip [ 1 select-input ] }
[ simplify-to-constant ]
} case
] when*
] when* ;
M: node apply-identities* ;
: apply-identities ( nodes -- nodes' )
[ apply-identities* ] map-nodes ;

29
basis/compiler/tree/late-optimizations/late-optimizations.factor Normal file
View File

@ -0,0 +1,29 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences namespaces compiler.tree.builder
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.propagation.info
compiler.tree.cleanup
compiler.tree.def-use
compiler.tree.dead-code ;
IN: compiler.tree.late-optimizations
! Late optimizations modify the tree such that stack flow
! information is no longer accurate, since we punt in
! 'splice-quot' and don't update everything that we should;
! this simplifies the code, improves performance, and we
! don't need the stack flow information after this pass anyway.
: splice-quot ( quot -- nodes )
[
build-tree
analyze-recursive
normalize
propagate
cleanup
compute-def-use
remove-dead-code
but-last
] with-scope ;

130
basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor Normal file
View File

@ -0,0 +1,130 @@
IN: compiler.tree.modular-arithmetic.tests
USING: kernel kernel.private tools.test math math.partial-dispatch
math.private accessors slots.private sequences strings sbufs
compiler.tree.builder
compiler.tree.optimizer
compiler.tree.debugger ;
: test-modular-arithmetic ( quot -- quot' )
build-tree optimize-tree nodes>quot ;
[ [ >r >fixnum r> >fixnum fixnum+fast ] ]
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
[ [ +-integer-integer dup >fixnum ] ]
[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test
[ [ >r >fixnum r> >fixnum fixnum+fast 4 fixnum*fast ] ]
[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
TUPLE: declared-fixnum { x fixnum } ;
[ t ] [
[ { declared-fixnum } declare [ 1 + ] change-x ]
{ + fixnum+ >fixnum } inlined?
] unit-test
[ t ] [
[ { declared-fixnum } declare x>> drop ]
{ slot } inlined?
] unit-test
[ f ] [
[ { integer } declare -63 shift 4095 bitand ]
\ shift inlined?
] unit-test
[ t ] [
[ { integer } declare 127 bitand 3 + ]
{ + +-integer-fixnum bitand } inlined?
] unit-test
[ f ] [
[ { integer } declare 127 bitand 3 + ]
{ >fixnum } inlined?
] unit-test
[ t ] [
[
{ integer } declare
dup 0 >= [
615949 * 797807 + 20 2^ mod dup 19 2^ -
] [ dup ] if
] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
] unit-test
[ t ] [
[
{ fixnum } declare
615949 * 797807 + 20 2^ mod dup 19 2^ -
] { >fixnum } inlined?
] unit-test
[ t ] [
[
{ integer } declare 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
] unit-test
[ t ] [
[
{ fixnum } declare 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
] unit-test
[ t ] [
[ { string sbuf } declare ] \ push-all def>> append \ + inlined?
] unit-test
[ t ] [
[ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
] unit-test
[ t ] [
[ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
] unit-test
[ t ] [
[
{ integer } declare [ 256 mod ] map
] { mod fixnum-mod } inlined?
] unit-test
[ f ] [
[
256 mod
] { mod fixnum-mod } inlined?
] unit-test
[ f ] [
[
dup 0 >= [ 256 mod ] when
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare dup 0 >= [ 256 mod ] when
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare 256 rem
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare [ 256 rem ] map
] { mod fixnum-mod rem } inlined?
] unit-test

108
basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor Normal file
View File

@ -0,0 +1,108 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.partial-dispatch namespaces sequences sets
accessors assocs words kernel memoize fry combinators
compiler.tree
compiler.tree.combinators
compiler.tree.def-use
compiler.tree.def-use.simplified
compiler.tree.late-optimizations ;
IN: compiler.tree.modular-arithmetic
! This is a late-stage optimization.
! See the comment in compiler.tree.late-optimizations.
! Modular arithmetic optimization pass.
!
! { integer integer } declare + >fixnum
! ==>
! [ >fixnum ] bi@ fixnum+fast
{ + - * bitand bitor bitxor } [
[
t "modular-arithmetic" set-word-prop
] each-integer-derived-op
] each
{ bitand bitor bitxor bitnot }
[ t "modular-arithmetic" set-word-prop ] each
SYMBOL: modularize-values
: modular-value? ( value -- ? )
modularize-values get key? ;
: modularize-value ( value -- ) modularize-values get conjoin ;
GENERIC: maybe-modularize* ( value node -- )
: maybe-modularize ( value -- )
actually-defined-by [ value>> ] [ node>> ] bi
over actually-used-by length 1 = [
maybe-modularize*
] [ 2drop ] if ;
M: #call maybe-modularize*
dup word>> "modular-arithmetic" word-prop [
[ modularize-value ]
[ in-d>> [ maybe-modularize ] each ] bi*
] [ 2drop ] if ;
M: node maybe-modularize* 2drop ;
GENERIC: compute-modularized-values* ( node -- )
M: #call compute-modularized-values*
dup word>> {
{ [ \ >fixnum eq? ] [ in-d>> first maybe-modularize ] }
! { [
! {
! mod-integer-fixnum
! mod-integer-integer
! mod-fixnum-integer
! } memq?
! ] [ ] }
[ drop ]
} cond ;
M: node compute-modularized-values* drop ;
: compute-modularized-values ( nodes -- )
[ compute-modularized-values* ] each-node ;
GENERIC: optimize-modular-arithmetic* ( node -- nodes )
: redundant->fixnum? ( #call -- ? )
in-d>> first actually-defined-by value>> modular-value? ;
: optimize->fixnum ( #call -- nodes )
dup redundant->fixnum? [ drop f ] when ;
MEMO: fixnum-coercion ( flags -- nodes )
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
: optimize-modular-op ( #call -- nodes )
dup out-d>> first modular-value? [
[ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri
[
[
[ actually-defined-by value>> modular-value? ]
[ fixnum eq? ]
bi* or
] 2map fixnum-coercion
] [ [ modular-variant ] change-word ] bi* suffix
] when ;
M: #call optimize-modular-arithmetic*
dup word>> {
{ [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
[ drop ]
} cond ;
M: node optimize-modular-arithmetic* ;
: optimize-modular-arithmetic ( nodes -- nodes' )
H{ } clone modularize-values set
dup compute-modularized-values
[ optimize-modular-arithmetic* ] map-nodes ;

36
basis/compiler/tree/normalization/introductions/introductions.factor Normal file
View File

@ -0,0 +1,36 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences accessors math kernel
compiler.tree ;
IN: compiler.tree.normalization.introductions
SYMBOL: introductions
GENERIC: count-introductions* ( node -- )
: count-introductions ( nodes -- n )
#! Note: we use each, not each-node, since the #branch
#! method recurses into children directly and we don't
#! recurse into #recursive at all.
[
0 introductions set
[ count-introductions* ] each
introductions get
] with-scope ;
: introductions+ ( n -- ) introductions [ + ] change ;
M: #introduce count-introductions*
out-d>> length introductions+ ;
M: #branch count-introductions*
children>>
[ count-introductions ] map supremum
introductions+ ;
M: #recursive count-introductions*
[ label>> ] [ child>> count-introductions ] bi
>>introductions
drop ;
M: node count-introductions* drop ;

20
basis/compiler/tree/normalization/normalization-tests.factor
View File

@ -1,5 +1,8 @@
IN: compiler.tree.normalization.tests
USING: compiler.tree.builder compiler.tree.normalization
USING: compiler.tree.builder compiler.tree.recursive
compiler.tree.normalization
compiler.tree.normalization.introductions
compiler.tree.normalization.renaming
compiler.tree compiler.tree.checker
sequences accessors tools.test kernel math ;
@ -22,27 +25,30 @@ sequences accessors tools.test kernel math ;
[ 0 2 ] [
[ foo ] build-tree
[ recursive-inputs ]
[ normalize recursive-inputs ] bi
[ analyze-recursive normalize recursive-inputs ] bi
] unit-test
[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize check-nodes ] unit-test
: test-normalization ( quot -- )
build-tree analyze-recursive normalize check-nodes ;
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
DEFER: bbb
: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
[ ] [ [ bbb ] build-tree normalize check-nodes ] unit-test
[ ] [ [ bbb ] test-normalization ] unit-test
: ccc ( -- ) ccc drop 1 ; inline recursive
[ ] [ [ ccc ] build-tree normalize check-nodes ] unit-test
[ ] [ [ ccc ] test-normalization ] unit-test
DEFER: eee
: ddd ( -- ) eee ; inline recursive
: eee ( -- ) swap ddd ; inline recursive
[ ] [ [ eee ] build-tree normalize check-nodes ] unit-test
[ ] [ [ eee ] test-normalization ] unit-test
: call-recursive-5 ( -- ) call-recursive-5 ; inline recursive
[ ] [ [ call-recursive-5 swap ] build-tree normalize check-nodes ] unit-test
[ ] [ [ call-recursive-5 swap ] test-normalization ] unit-test

113
basis/compiler/tree/normalization/normalization.factor
View File

@ -6,7 +6,9 @@ stack-checker.backend
stack-checker.branches
stack-checker.inlining
compiler.tree
compiler.tree.combinators ;
compiler.tree.combinators
compiler.tree.normalization.introductions
compiler.tree.normalization.renaming ;
IN: compiler.tree.normalization
! A transform pass done before optimization can begin to
@ -16,9 +18,6 @@ IN: compiler.tree.normalization
! replaced with a single one, at the beginning of a program.
! This simplifies subsequent analysis.
!
! - We collect #return-recursive and #call-recursive nodes and
! store them in the #recursive's label slot.
!
! - We normalize #call-recursive as follows. The stack checker
! says that the inputs of a #call-recursive are the entire stack
! at the time of the call. This is a conservative estimate; we
@ -28,93 +27,6 @@ IN: compiler.tree.normalization
! #call-recursive into a #copy of the unchanged values and a
! #call-recursive with trimmed inputs and outputs.
! Collect introductions
SYMBOL: introductions
GENERIC: count-introductions* ( node -- )
: count-introductions ( nodes -- n )
#! Note: we use each, not each-node, since the #branch
#! method recurses into children directly and we don't
#! recurse into #recursive at all.
[
0 introductions set
[ count-introductions* ] each
introductions get
] with-scope ;
: introductions+ ( n -- ) introductions [ + ] change ;
M: #introduce count-introductions*
out-d>> length introductions+ ;
M: #branch count-introductions*
children>>
[ count-introductions ] map supremum
introductions+ ;
M: #recursive count-introductions*
[ label>> ] [ child>> count-introductions ] bi
>>introductions
drop ;
M: node count-introductions* drop ;
! Collect label info
GENERIC: collect-label-info ( node -- )
M: #return-recursive collect-label-info
dup label>> (>>return) ;
M: #call-recursive collect-label-info
dup label>> calls>> push ;
M: #recursive collect-label-info
label>> V{ } clone >>calls drop ;
M: node collect-label-info drop ;
! Rename
SYMBOL: rename-map
: rename-value ( value -- value' )
[ rename-map get at ] keep or ;
: rename-values ( values -- values' )
rename-map get '[ [ , at ] keep or ] map ;
GENERIC: rename-node-values* ( node -- node )
M: #introduce rename-node-values* ;
M: #shuffle rename-node-values*
[ rename-values ] change-in-d
[ [ rename-value ] assoc-map ] change-mapping ;
M: #push rename-node-values* ;
M: #r> rename-node-values*
[ rename-values ] change-in-r ;
M: #terminate rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r ;
M: #phi rename-node-values*
[ [ rename-values ] map ] change-phi-in-d ;
M: #declare rename-node-values*
[ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
M: #alien-callback rename-node-values* ;
M: node rename-node-values*
[ rename-values ] change-in-d ;
: rename-node-values ( nodes -- nodes' )
dup [ rename-node-values* drop ] each-node ;
! Normalize
GENERIC: normalize* ( node -- node' )
SYMBOL: introduction-stack
@ -125,10 +37,6 @@ SYMBOL: introduction-stack
: pop-introductions ( n -- values )
introduction-stack [ swap cut* swap ] change ;
: add-renamings ( old new -- )
[ rename-values ] dip
rename-map get '[ , set-at ] 2each ;
M: #introduce normalize*
out-d>> [ length pop-introductions ] keep add-renamings f ;
@ -158,7 +66,7 @@ M: #branch normalize*
M: #phi normalize*
remaining-introductions get swap dup terminated>>
'[ , eliminate-phi-introductions ] change-phi-in-d ;
'[ _ eliminate-phi-introductions ] change-phi-in-d ;
: (normalize) ( nodes introductions -- nodes )
introduction-stack [
@ -168,7 +76,7 @@ M: #phi normalize*
M: #recursive normalize*
dup label>> introductions>>
[ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ]
[ make-values '[ , (normalize) ] change-child ]
[ make-values '[ _ (normalize) ] change-child ]
2bi ;
M: #enter-recursive normalize*
@ -181,14 +89,14 @@ M: #enter-recursive normalize*
: call<return ( #call-recursive n -- nodes )
neg dup make-values [
[ pop-introductions '[ , prepend ] change-in-d ]
[ '[ , prepend ] change-out-d ]
[ pop-introductions '[ _ prepend ] change-in-d ]
[ '[ _ prepend ] change-out-d ]
bi*
] [ introduction-stack [ prepend ] change ] bi ;
: call>return ( #call-recursive n -- #call-recursive )
[ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ add-renamings ]
[ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ]
[ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ _ head ] ] bi* bi@ add-renamings ]
[ '[ _ tail ] [ change-in-d ] [ change-out-d ] bi ]
2bi ;
M: #call-recursive normalize*
@ -201,9 +109,8 @@ M: #call-recursive normalize*
M: node normalize* ;
: normalize ( nodes -- nodes' )
H{ } clone rename-map set
dup [ collect-label-info ] each-node
dup count-introductions make-values
H{ } clone rename-map set
[ (normalize) ] [ nip ] 2bi
[ #introduce prefix ] unless-empty
rename-node-values ;

48
basis/compiler/tree/normalization/renaming/renaming.factor Normal file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel accessors sequences fry
compiler.tree compiler.tree.combinators ;
IN: compiler.tree.normalization.renaming
SYMBOL: rename-map
: rename-value ( value -- value' )
[ rename-map get at ] keep or ;
: rename-values ( values -- values' )
rename-map get '[ [ _ at ] keep or ] map ;
: add-renamings ( old new -- )
[ rename-values ] dip
rename-map get '[ _ set-at ] 2each ;
GENERIC: rename-node-values* ( node -- node )
M: #introduce rename-node-values* ;
M: #shuffle rename-node-values*
[ rename-values ] change-in-d
[ [ rename-value ] assoc-map ] change-mapping ;
M: #push rename-node-values* ;
M: #r> rename-node-values*
[ rename-values ] change-in-r ;
M: #terminate rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r ;
M: #phi rename-node-values*
[ [ rename-values ] map ] change-phi-in-d ;
M: #declare rename-node-values*
[ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
M: #alien-callback rename-node-values* ;
M: node rename-node-values*
[ rename-values ] change-in-d ;
: rename-node-values ( nodes -- nodes' )
dup [ rename-node-values* drop ] each-node ;

11
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -1,15 +1,16 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.cleanup
compiler.tree.escape-analysis
compiler.tree.tuple-unboxing
compiler.tree.identities
compiler.tree.def-use
compiler.tree.dead-code
compiler.tree.strength-reduction
compiler.tree.loop.detection
compiler.tree.modular-arithmetic
compiler.tree.finalization
compiler.tree.checker ;
IN: compiler.tree.optimizer
@ -17,17 +18,19 @@ IN: compiler.tree.optimizer
SYMBOL: check-optimizer?
: optimize-tree ( nodes -- nodes' )
analyze-recursive
normalize
propagate
cleanup
detect-loops
escape-analysis
unbox-tuples
apply-identities
compute-def-use
remove-dead-code
! strength-reduce
check-optimizer? get [
compute-def-use
dup check-nodes
] when
compute-def-use
optimize-modular-arithmetic
finalize ;

4
basis/compiler/tree/propagation/branches/branches.factor
View File

@ -32,7 +32,7 @@ M: #if live-branches
M: #dispatch live-branches
[ children>> length ] [ in-d>> first value-info interval>> ] bi
'[ , interval-contains? ] map ;
'[ _ interval-contains? ] map ;
: live-children ( #branch -- children )
[ children>> ] [ live-branches>> ] bi select-children ;
@ -61,7 +61,7 @@ SYMBOL: infer-children-data
infer-children-data get
[
'[
, [
_ [
dup +bottom+ eq?
[ drop null-info ] [ value-info ] if
] bind

27
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -3,14 +3,23 @@
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces
words namespaces continuations
compiler.tree
compiler.tree.builder
compiler.tree.recursive
compiler.tree.combinators
compiler.tree.normalization
compiler.tree.propagation.info
compiler.tree.propagation.nodes ;
IN: compiler.tree.propagation.inlining
! We count nodes up-front; if there are relatively few nodes,
! we are more eager to inline
SYMBOL: node-count
: count-nodes ( nodes -- )
0 swap [ drop 1+ ] each-node node-count set ;
! Splicing nodes
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
@ -18,13 +27,13 @@ M: word splicing-nodes
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
M: quotation splicing-nodes
build-sub-tree normalize ;
build-sub-tree analyze-recursive normalize ;
: propagate-body ( #call -- )
body>> (propagate) ;
! Dispatch elimination
: eliminate-dispatch ( #call class/f word/f -- ? )
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
dup [
[ >>class ] dip
over method>> over = [ drop ] [
@ -113,12 +122,13 @@ DEFER: (flat-length)
[ classes-known? 2 0 ? ]
[
{
[ drop node-count get 45 swap [-] 8 /i ]
[ flat-length 24 swap [-] 4 /i ]
[ "default" word-prop -4 0 ? ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
} cleave
] bi* + + + + ;
] bi* + + + + + ;
: should-inline? ( #call word -- ? )
inlining-rank 5 >= ;
@ -146,12 +156,19 @@ SYMBOL: history
: always-inline-word? ( word -- ? )
{ curry compose } memq? ;
: custom-inlining? ( word -- ? )
"custom-inlining" word-prop ;
: inline-custom ( #call word -- ? )
[ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
first object swap eliminate-dispatch ;
: do-inlining ( #call word -- ? )
{
{ [ dup custom-inlining? ] [ inline-custom ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] }
{ [ dup method-body? ] [ inline-method-body ] }
[ 2drop f ]
} cond ;

40
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -118,7 +118,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
: binary-op ( word interval-quot post-proc-quot -- )
'[
[ binary-op-class ] [ , binary-op-interval ] 2bi
[ binary-op-class ] [ _ binary-op-interval ] 2bi
@
<class/interval-info>
] "outputs" set-word-prop ;
@ -159,14 +159,14 @@ most-negative-fixnum most-positive-fixnum [a,b]
in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
: define-comparison-constraints ( word op -- )
'[ , comparison-constraints ] "constraints" set-word-prop ;
'[ _ comparison-constraints ] "constraints" set-word-prop ;
comparison-ops
[ dup '[ , define-comparison-constraints ] each-derived-op ] each
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
generic-comparison-ops [
dup specific-comparison
'[ , , define-comparison-constraints ] each-derived-op
'[ _ _ define-comparison-constraints ] each-derived-op
] each
! Remove redundant comparisons
@ -179,13 +179,13 @@ generic-comparison-ops [
comparison-ops [
dup '[
[ , fold-comparison ] "outputs" set-word-prop
[ _ fold-comparison ] "outputs" set-word-prop
] each-derived-op
] each
generic-comparison-ops [
dup specific-comparison
'[ , fold-comparison ] "outputs" set-word-prop
'[ _ fold-comparison ] "outputs" set-word-prop
] each
: maybe-or-never ( ? -- info )
@ -221,7 +221,7 @@ generic-comparison-ops [
{ >float float }
} [
'[
,
_
[ nip ] [
[ interval>> ] [ class-interval ] bi*
interval-intersect
@ -230,6 +230,32 @@ generic-comparison-ops [
] "outputs" set-word-prop
] assoc-each
{
mod-integer-integer
mod-integer-fixnum
mod-fixnum-integer
fixnum-mod
rem
} [
[
in-d>> second value-info >literal<
[ power-of-2? [ 1- bitand ] f ? ] when
] "custom-inlining" set-word-prop
] each
{
bitand-integer-integer
bitand-integer-fixnum
bitand-fixnum-integer
} [
[
in-d>> second value-info >literal< [
0 most-positive-fixnum between?
[ [ >fixnum ] bi@ fixnum-bitand ] f ?
] when
] "custom-inlining" set-word-prop
] each
{
alien-signed-1
alien-unsigned-1

31
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -1,31 +1,18 @@
USING: kernel compiler.tree.builder compiler.tree
compiler.tree.propagation
compiler.tree.propagation compiler.tree.recursive
compiler.tree.normalization tools.test math math.order
accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private
byte-arrays classes.algebra classes.tuple.private
math.functions math.private strings layouts
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.checker slots.private words hashtables
classes assocs ;
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
float-arrays ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
: final-info ( quot -- seq )
build-tree
normalize
propagate
compute-def-use
dup check-nodes
peek node-input-infos ;
: final-classes ( quot -- seq )
final-info [ class>> ] map ;
: final-literals ( quot -- seq )
final-info [ literal>> ] map ;
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
@ -593,6 +580,16 @@ MIXIN: empty-mixin
[ { float } declare 0 eq? ] final-classes
] unit-test
[ V{ integer } ] [
[ { integer fixnum } declare mod ] final-classes
] unit-test
[ V{ integer } ] [
[ { fixnum integer } declare bitand ] final-classes
] unit-test
[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test

2
basis/compiler/tree/propagation/propagation.factor
View File

@ -6,6 +6,7 @@ compiler.tree.propagation.copy
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.simple
compiler.tree.propagation.inlining
compiler.tree.propagation.branches
compiler.tree.propagation.recursive
compiler.tree.propagation.constraints
@ -18,4 +19,5 @@ IN: compiler.tree.propagation
H{ } clone copies set
H{ } clone constraints set
H{ } clone value-infos set
dup count-nodes
dup (propagate) ;

3
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -70,7 +70,8 @@ M: #recursive propagate-around ( #recursive -- )
[ generalize-return-interval ] map ;
: return-infos ( node -- infos )
label>> return>> node-input-infos generalize-return ;
label>> [ return>> node-input-infos ] [ loop?>> ] bi
[ generalize-return ] unless ;
M: #call-recursive propagate-before ( #call-recursive -- )
[ ] [ return-infos ] [ node-output-infos ] tri

4
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -68,8 +68,8 @@ M: #declare propagate-before
[ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi*
'[ , , with-datastack [ <literal-info> ] map nip ]
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
'[ _ _ with-datastack [ <literal-info> ] map nip ]
[ drop [ object-info ] replicate ]
recover ;

36
basis/compiler/tree/loop/detection/detection-tests.factor → basis/compiler/tree/recursive/recursive-tests.factor
View File

@ -1,5 +1,5 @@
IN: compiler.tree.loop.detection.tests
USING: compiler.tree.loop.detection tools.test
IN: compiler.tree.recursive.tests
USING: compiler.tree.recursive tools.test
kernel combinators.short-circuit math sequences accessors
compiler.tree
compiler.tree.builder
@ -10,7 +10,7 @@ compiler.tree.combinators ;
[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
\ detect-loops must-infer
\ analyze-recursive must-infer
: label-is-loop? ( nodes word -- ? )
[
@ -38,22 +38,22 @@ compiler.tree.combinators ;
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-1 ] build-tree detect-loops
[ loop-test-1 ] build-tree analyze-recursive
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ loop-test-1 1 2 3 ] build-tree detect-loops
[ loop-test-1 1 2 3 ] build-tree analyze-recursive
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] build-tree detect-loops
[ [ loop-test-1 ] each ] build-tree analyze-recursive
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] build-tree detect-loops
[ [ loop-test-1 ] each ] build-tree analyze-recursive
\ (each-integer) label-is-loop?
] unit-test
@ -61,7 +61,7 @@ compiler.tree.combinators ;
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-2 ] build-tree detect-loops
[ loop-test-2 ] build-tree analyze-recursive
\ loop-test-2 label-is-not-loop?
] unit-test
@ -69,7 +69,7 @@ compiler.tree.combinators ;
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-3 ] build-tree detect-loops
[ loop-test-3 ] build-tree analyze-recursive
\ loop-test-3 label-is-not-loop?
] unit-test
@ -81,7 +81,7 @@ compiler.tree.combinators ;
] if ; inline recursive
[ f ] [
[ [ [ ] map ] map ] build-tree detect-loops
[ [ [ ] map ] map ] build-tree analyze-recursive
[
dup #recursive? [ label>> loop?>> not ] [ drop f ] if
] contains-node?
@ -98,22 +98,22 @@ DEFER: a
blah [ b ] [ a ] if ; inline recursive
[ t ] [
[ a ] build-tree detect-loops
[ a ] build-tree analyze-recursive
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] build-tree detect-loops
[ a ] build-tree analyze-recursive
\ b label-is-loop?
] unit-test
[ t ] [
[ b ] build-tree detect-loops
[ b ] build-tree analyze-recursive
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] build-tree detect-loops
[ a ] build-tree analyze-recursive
\ b label-is-loop?
] unit-test
@ -126,12 +126,12 @@ DEFER: a'
blah [ b' ] [ a' ] if ; inline recursive
[ f ] [
[ a' ] build-tree detect-loops
[ a' ] build-tree analyze-recursive
\ a' label-is-loop?
] unit-test
[ f ] [
[ b' ] build-tree detect-loops
[ b' ] build-tree analyze-recursive
\ b' label-is-loop?
] unit-test
@ -140,11 +140,11 @@ DEFER: a'
! sound.
[ t ] [
[ b' ] build-tree detect-loops
[ b' ] build-tree analyze-recursive
\ a' label-is-loop?
] unit-test
[ f ] [
[ a' ] build-tree detect-loops
[ a' ] build-tree analyze-recursive
\ b' label-is-loop?
] unit-test

24
basis/compiler/tree/loop/detection/detection.factor → basis/compiler/tree/recursive/recursive.factor
View File

@ -1,14 +1,27 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences namespaces assocs accessors fry
compiler.tree deques search-deques ;
IN: compiler.tree.loop.detection
USING: kernel assocs namespaces accessors sequences deques
search-deques compiler.tree compiler.tree.combinators ;
IN: compiler.tree.recursive
! Collect label info
GENERIC: collect-label-info ( node -- )
M: #return-recursive collect-label-info
dup label>> (>>return) ;
M: #call-recursive collect-label-info
dup label>> calls>> push ;
M: #recursive collect-label-info
label>> V{ } clone >>calls drop ;
M: node collect-label-info drop ;
! A loop is a #recursive which only tail calls itself, and those
! calls are nested inside other loops only. We optimistically
! assume all #recursive nodes are loops, disqualifying them as
! we see evidence to the contrary.
: (tail-calls) ( tail? seq -- seq' )
reverse [ swap [ and ] keep ] map nip reverse ;
@ -84,5 +97,6 @@ M: node collect-loop-info* 2drop ;
] [ drop ] if
] slurp-deque ;
: detect-loops ( nodes -- nodes )
: analyze-recursive ( nodes -- nodes )
dup [ collect-label-info ] each-node
dup collect-loop-info disqualify-loops ;

119
basis/compiler/tree/strength-reduction/strength-reduction-tests.factor
View File

@ -1,119 +0,0 @@
! TUPLE: declared-fixnum { x fixnum } ;
!
! [ t ] [
! [ { declared-fixnum } declare [ 1 + ] change-x ]
! { + fixnum+ >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [ { declared-fixnum } declare x>> drop ]
! { slot } inlined?
! ] unit-test
!
! [ t ] [
! [ hashtable new ] \ new inlined?
! ] unit-test
!
! [ t ] [
! [ dup hashtable eq? [ new ] when ] \ new inlined?
! ] unit-test
!
! [ f ] [
! [ { integer } declare -63 shift 4095 bitand ]
! \ shift inlined?
! ] unit-test
!
! [ t ] [
! [ { integer } declare 127 bitand 3 + ]
! { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
! ] unit-test
!
! [ f ] [
! [ { integer } declare 127 bitand 3 + ]
! { >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare
! dup 0 >= [
! 615949 * 797807 + 20 2^ mod dup 19 2^ -
! ] [ dup ] if
! ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
! ] unit-test
!
! [ t ] [
! [
! { fixnum } declare
! 615949 * 797807 + 20 2^ mod dup 19 2^ -
! ] { >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare 0 swap
! [
! drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
! ] map
! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
! ] unit-test
!
! [ t ] [
! [
! { fixnum } declare 0 swap
! [
! drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
! ] map
! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
! ] unit-test
!
! [ t ] [
! [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
! ] unit-test
!
! [ t ] [
! [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
! ] unit-test
!
!
!
! [ t ] [
! [
! { integer } declare [ 256 mod ] map
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
!
! [ f ] [
! [
! 256 mod
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ f ] [
! [
! dup 0 >= [ 256 mod ] when
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare dup 0 >= [ 256 mod ] when
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare 256 rem
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare [ 256 rem ] map
! ] { mod fixnum-mod rem } inlined?
! ] unit-test

5
basis/compiler/tree/strength-reduction/strength-reduction.factor
View File

@ -1,5 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.strength-reduction
: strength-reduce ( nodes -- nodes' ) ;

2
basis/compiler/tree/tree.factor
View File

@ -178,7 +178,7 @@ M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ mapping>> ] tri
'[ , at ] map
'[ _ at ] map
<effect> ;
: recursive-phi-in ( #enter-recursive -- seq )

14
basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
View File

@ -1,16 +1,18 @@
IN: compiler.tree.tuple-unboxing.tests
USING: tools.test compiler.tree.tuple-unboxing compiler.tree
compiler.tree.builder compiler.tree.normalization
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.escape-analysis compiler.tree.tuple-unboxing
compiler.tree.checker compiler.tree.def-use kernel accessors
sequences math math.private sorting math.order binary-search
sequences.private slots.private ;
compiler.tree.builder compiler.tree.recursive
compiler.tree.normalization compiler.tree.propagation
compiler.tree.cleanup compiler.tree.escape-analysis
compiler.tree.tuple-unboxing compiler.tree.checker
compiler.tree.def-use kernel accessors sequences math
math.private sorting math.order binary-search sequences.private
slots.private ;
\ unbox-tuples must-infer
: test-unboxing ( quot -- )
build-tree
analyze-recursive
normalize
propagate
cleanup

4
basis/concurrency/combinators/combinators.factor
View File

@ -4,8 +4,10 @@ USING: concurrency.futures concurrency.count-downs sequences
kernel ;
IN: concurrency.combinators
<PRIVATE
: (parallel-each) ( n quot -- )
>r <count-down> r> keep await ; inline
PRIVATE>
: parallel-each ( seq quot -- )
over length [
@ -20,7 +22,9 @@ IN: concurrency.combinators
: parallel-filter ( seq quot -- newseq )
over >r pusher >r each r> r> like ; inline
<PRIVATE
: future-values dup [ ?future ] change-each ; inline
PRIVATE>
: parallel-map ( seq quot -- newseq )
[ curry future ] curry map future-values ;

8
basis/concurrency/count-downs/count-downs.factor
View File

@ -11,14 +11,18 @@ TUPLE: count-down n promise ;
: count-down-check ( count-down -- )
dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;
ERROR: invalid-count-down-count count ;
: <count-down> ( n -- count-down )
dup 0 < [ "Invalid count for count down" throw ] when
dup 0 < [ invalid-count-down-count ] when
<promise> \ count-down boa
dup count-down-check ;
ERROR: count-down-already-done ;
: count-down ( count-down -- )
dup n>> dup zero?
[ "Count down already done" throw ]
[ count-down-already-done ]
[ 1- >>n count-down-check ] if ;
: await-timeout ( count-down timeout -- )

7
basis/concurrency/messaging/messaging-tests.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2005 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel threads vectors arrays sequences
namespaces tools.test continuations deques strings math words
match quotations concurrency.messaging concurrency.mailboxes
USING: kernel threads vectors arrays sequences namespaces make
tools.test continuations deques strings math words match
quotations concurrency.messaging concurrency.mailboxes
concurrency.count-downs accessors ;
IN: concurrency.messaging.tests

9
basis/concurrency/messaging/messaging.factor
View File

@ -4,7 +4,7 @@
! Concurrency library for Factor, based on Erlang/Termite style
! concurrency.
USING: kernel threads concurrency.mailboxes continuations
namespaces assocs random accessors ;
namespaces assocs random accessors summary ;
IN: concurrency.messaging
GENERIC: send ( message thread -- )
@ -52,9 +52,14 @@ TUPLE: reply data tag ;
[ >r tag>> r> tag>> = ]
[ 2drop f ] if ;
ERROR: cannot-send-synchronous-to-self message thread ;
M: cannot-send-synchronous-to-self summary
drop "Cannot synchronous send to myself" ;
: send-synchronous ( message thread -- reply )
dup self eq? [
"Cannot synchronous send to myself" throw
cannot-send-synchronous-to-self
] [
>r <synchronous> dup r> send
[ synchronous-reply? ] curry receive-if

3
basis/concurrency/promises/promises.factor
View File

@ -11,9 +11,10 @@ TUPLE: promise mailbox ;
: promise-fulfilled? ( promise -- ? )
mailbox>> mailbox-empty? not ;
ERROR: promise-already-fulfilled promise ;
: fulfill ( value promise -- )
dup promise-fulfilled? [
"Promise already fulfilled" throw
promise-already-fulfilled
] [
mailbox>> mailbox-put
] if ;

6
basis/core-foundation/fsevents/fsevents.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces assocs init accessors continuations
combinators core-foundation core-foundation.run-loop
io.encodings.utf8 destructors ;
math sequences namespaces make assocs init accessors
continuations combinators core-foundation
core-foundation.run-loop io.encodings.utf8 destructors ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !

18
basis/cpu/architecture/architecture.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory
namespaces sequences layouts system hashtables classes alien
byte-arrays combinators words sets ;
namespaces make sequences layouts system hashtables classes
alien byte-arrays combinators words sets ;
IN: cpu.architecture
! Register classes
@ -95,7 +95,7 @@ HOOK: %box-float cpu ( dst src -- )
HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( size -- ? )
HOOK: struct-small-enough? cpu ( heap-size -- ? )
! Do we pass explode value structs?
HOOK: value-structs? cpu ( -- ? )
@ -109,9 +109,9 @@ HOOK: %unbox cpu ( n reg-class func -- )
HOOK: %unbox-long-long cpu ( n func -- )
HOOK: %unbox-small-struct cpu ( size -- )
HOOK: %unbox-small-struct cpu ( c-type -- )
HOOK: %unbox-large-struct cpu ( n size -- )
HOOK: %unbox-large-struct cpu ( n c-type -- )
HOOK: %box cpu ( n reg-class func -- )
@ -119,9 +119,9 @@ HOOK: %box-long-long cpu ( n func -- )
HOOK: %prepare-box-struct cpu ( size -- )
HOOK: %box-small-struct cpu ( size -- )
HOOK: %box-small-struct cpu ( c-type -- )
HOOK: %box-large-struct cpu ( n size -- )
HOOK: %box-large-struct cpu ( n c-type -- )
GENERIC: %save-param-reg ( stack reg reg-class -- )
@ -169,14 +169,14 @@ PREDICATE: small-tagged < integer v>operand small-enough? ;
[ [ nip ] prepose ] dip if ;
inline
: %unbox-struct ( n size -- )
: %unbox-struct ( n c-type -- )
[
%unbox-small-struct
] [
%unbox-large-struct
] if-small-struct ;
: %box-struct ( n size -- )
: %box-struct ( n c-type -- )
[
%box-small-struct
] [

9
basis/cpu/ppc/architecture/architecture.factor
View File

@ -5,7 +5,7 @@ cpu.architecture generic kernel kernel.private math memory
namespaces sequences words assocs compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts classes words.private alien combinators
compiler.constants math.order ;
compiler.constants math.order make ;
IN: cpu.ppc.architecture
! PowerPC register assignments
@ -195,12 +195,12 @@ M: ppc %unbox-long-long ( n func -- )
4 1 rot cell + local@ STW
] when* ;
M: ppc %unbox-large-struct ( n size -- )
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
! Compute destination address
4 1 roll local@ ADDI
! Load struct size
5 LI
heap-size 5 LI
! Call the function
"to_value_struct" f %alien-invoke ;
@ -227,8 +227,9 @@ M: ppc %prepare-box-struct ( size -- )
3 1 rot f struct-return@ ADDI
3 1 0 local@ STW ;
M: ppc %box-large-struct ( n size -- )
M: ppc %box-large-struct ( n c-type -- )
#! If n = f, then we're boxing a returned struct
heap-size
[ swap struct-return@ ] keep
! Compute destination address
3 1 roll ADDI

2
basis/cpu/ppc/assembler/assembler-tests.factor
View File

@ -1,6 +1,6 @@
IN: cpu.ppc.assembler.tests
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
vocabs sequences ;
make vocabs sequences ;
: test-assembler ( expected quot -- )
[ 1array ] [ [ { } make ] curry ] bi* unit-test ;

2
basis/cpu/ppc/assembler/backend/backend.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.generator.fixup kernel namespaces sequences
USING: compiler.generator.fixup kernel namespaces make sequences
words math math.bitwise io.binary parser lexer ;
IN: cpu.ppc.assembler.backend

148
basis/cpu/x86/32/32.factor
View File

@ -28,6 +28,10 @@ M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
M: x86.32 struct-small-enough? ( size -- ? )
heap-size { 1 2 4 8 } member?
os { linux netbsd solaris } member? not and ;
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
@ -62,10 +66,6 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
: with-aligned-stack ( n quot -- )
swap dup align-sub slip align-add ; inline
! On x86, we can always use an address as an operand
! directly.
M: x86.32 address-operand ;
M: x86.32 fixnum>slot@ 1 SHR ;
M: x86.32 prepare-division CDQ ;
@ -77,62 +77,6 @@ M: object %load-param-reg 3drop ;
M: object %save-param-reg 3drop ;
M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX.
EAX ESI [] MOV
ESI 4 SUB ;
: (%unbox) ( func -- )
4 [
! Push parameter
EAX PUSH
! Call the unboxer
f %alien-invoke
] with-aligned-stack ;
M: x86.32 %unbox ( n reg-class func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
#! a parameter to a C function about to be called.
(%unbox)
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
M: x86.32 %unbox-long-long ( n func -- )
(%unbox)
! Store the return value on the C stack
[
dup stack@ EAX MOV
cell + stack@ EDX MOV
] when* ;
M: x86.32 %unbox-struct-2
#! Alien must be in EAX.
4 [
EAX PUSH
"alien_offset" f %alien-invoke
! Load second cell
EDX EAX 4 [+] MOV
! Load first cell
EAX EAX [] MOV
] with-aligned-stack ;
M: x86.32 %unbox-large-struct ( n size -- )
#! Alien must be in EAX.
! Compute destination address
ECX ESP roll [+] LEA
12 [
! Push struct size
PUSH
! Push destination address
ECX PUSH
! Push source address
EAX PUSH
! Copy the struct to the stack
"to_value_struct" f %alien-invoke
] with-aligned-stack ;
: box@ ( n reg-class -- stack@ )
#! Used for callbacks; we want to box the values given to
#! us by the C function caller. Computes stack location of
@ -173,8 +117,12 @@ M: x86.32 %box-long-long ( n func -- )
[ (%box-long-long) ] [ f %alien-invoke ] bi*
] with-aligned-stack ;
M: x86.32 %box-large-struct ( n size -- )
: struct-return@ ( size n -- n )
[ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
M: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
heap-size
[ swap struct-return@ ] keep
ECX ESP roll [+] LEA
8 [
@ -192,7 +140,46 @@ M: x86.32 %prepare-box-struct ( size -- )
! Store it as the first parameter
ESP [] EAX MOV ;
M: x86.32 %unbox-struct-1
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
12 [
heap-size PUSH
EDX PUSH
EAX PUSH
"box_small_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX.
EAX ESI [] MOV
ESI 4 SUB ;
: (%unbox) ( func -- )
4 [
! Push parameter
EAX PUSH
! Call the unboxer
f %alien-invoke
] with-aligned-stack ;
M: x86.32 %unbox ( n reg-class func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
#! a parameter to a C function about to be called.
(%unbox)
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
M: x86.32 %unbox-long-long ( n func -- )
(%unbox)
! Store the return value on the C stack
[
dup stack@ EAX MOV
cell + stack@ EDX MOV
] when* ;
: %unbox-struct-1 ( -- )
#! Alien must be in EAX.
4 [
EAX PUSH
@ -201,13 +188,38 @@ M: x86.32 %unbox-struct-1
EAX EAX [] MOV
] with-aligned-stack ;
M: x86.32 %box-small-struct ( size -- )
#! Box a <= 8-byte struct returned in EAX:DX. OS X only.
12 [
PUSH
EDX PUSH
: %unbox-struct-2 ( -- )
#! Alien must be in EAX.
4 [
EAX PUSH
"box_small_struct" f %alien-invoke
"alien_offset" f %alien-invoke
! Load second cell
EDX EAX 4 [+] MOV
! Load first cell
EAX EAX [] MOV
] with-aligned-stack ;
M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
heap-size cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
} case ;
M: x86.32 %unbox-large-struct ( n c-type -- )
#! Alien must be in EAX.
heap-size
! Compute destination address
ECX ESP roll [+] LEA
12 [
! Push struct size
PUSH
! Push destination address
ECX PUSH
! Push source address
EAX PUSH
! Copy the struct to the stack
"to_value_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %prepare-alien-indirect ( -- )

151
basis/cpu/x86/64/64.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences compiler.generator compiler.generator.registers
compiler.generator.fixup system layouts alien alien.accessors
alien.structs slots splitting assocs ;
namespaces make sequences compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts alien alien.accessors alien.structs slots splitting
assocs combinators ;
IN: cpu.x86.64
M: x86.64 ds-reg R14 ;
@ -32,13 +33,6 @@ M: float-regs vregs
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
M: x86.64 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.
temp-reg v>operand [ swap MOV ] keep ;
M: x86.64 fixnum>slot@ drop ;
M: x86.64 prepare-division CQO ;
@ -48,12 +42,50 @@ M: x86.64 load-indirect ( literal reg -- )
M: stack-params %load-param-reg
drop
>r temp-reg v>operand swap stack@ MOV
r> stack@ temp-reg v>operand MOV ;
>r R11 swap stack@ MOV
r> stack@ R11 MOV ;
M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-param-reg ;
: with-return-regs ( quot -- )
[
V{ RDX RAX } clone int-regs set
V{ XMM1 XMM0 } clone float-regs set
call
] with-scope ; inline
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
stack-params "__stack_value" c-type (>>reg-class) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
[ type>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split harvest ;
: flatten-small-struct ( c-type -- seq )
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
int-regs swap member? "void*" "double" ? c-type
] map ;
: flatten-large-struct ( c-type -- seq )
heap-size cell align
cell /i "__stack_value" c-type <repetition> ;
M: struct-type flatten-value-type ( type -- seq )
dup heap-size 16 > [
flatten-large-struct
] [
flatten-small-struct
] if ;
M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack
RDI R14 [] MOV
@ -68,22 +100,26 @@ M: x86.64 %unbox ( n reg-class func -- )
M: x86.64 %unbox-long-long ( n func -- )
int-regs swap %unbox ;
M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load first cell
RAX RAX [] MOV ;
: %unbox-struct-field ( c-type i -- )
! Alien must be in RDI.
RDI swap cells [+] swap reg-class>> {
{ int-regs [ int-regs get pop swap MOV ] }
{ double-float-regs [ float-regs get pop swap MOVSD ] }
} case ;
M: x86.64 %unbox-struct-2 ( -- )
#! Alien must be in RDI.
M: x86.64 %unbox-small-struct ( c-type -- )
! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load second cell
RDX RAX cell [+] MOV
! Load first cell
RAX RAX [] MOV ;
! Move alien_offset() return value to RDI so that we don't
! clobber it.
RDI RAX MOV
[
flatten-small-struct [ %unbox-struct-field ] each-index
] with-return-regs ;
M: x86.64 %unbox-large-struct ( n size -- )
M: x86.64 %unbox-large-struct ( n c-type -- )
! Source is in RDI
heap-size
! Load destination address
RSI RSP roll [+] LEA
! Load structure size
@ -106,17 +142,33 @@ M: x86.64 %box ( n reg-class func -- )
M: x86.64 %box-long-long ( n func -- )
int-regs swap %box ;
M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
M: x86.64 struct-small-enough? ( size -- ? )
heap-size 2 cells <= ;
M: x86.64 %box-small-struct ( size -- )
#! Box a <= 16-byte struct returned in RAX:RDX.
RDI RAX MOV
RSI RDX MOV
RDX swap MOV
"box_small_struct" f %alien-invoke ;
: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
M: x86.64 %box-large-struct ( n size -- )
: %box-struct-field ( c-type i -- )
box-struct-field@ swap reg-class>> {
{ int-regs [ int-regs get pop MOV ] }
{ double-float-regs [ float-regs get pop MOVSD ] }
} case ;
M: x86.64 %box-small-struct ( c-type -- )
#! Box a <= 16-byte struct.
[
[ flatten-small-struct [ %box-struct-field ] each-index ]
[ RDX swap heap-size MOV ] bi
RDI 0 box-struct-field@ MOV
RSI 1 box-struct-field@ MOV
"box_small_struct" f %alien-invoke
] with-return-regs ;
: struct-return@ ( size n -- n )
[ ] [ \ stack-frame get swap - ] ?if ;
M: x86.64 %box-large-struct ( n c-type -- )
! Struct size is parameter 2
heap-size
RSI over MOV
! Compute destination address
swap struct-return@ RDI RSP rot [+] LEA
@ -134,7 +186,9 @@ M: x86.64 %alien-global
[ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
M: x86.64 %alien-invoke
0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
R11 0 MOV
rc-absolute-cell rel-dlsym
R11 CALL ;
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
@ -171,32 +225,3 @@ USE: cpu.x86.intrinsics
\ alien-signed-4 small-reg-32 define-signed-getter
\ set-alien-signed-4 small-reg-32 define-setter
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
stack-params "__stack_value" c-type (>>reg-class) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
[ type>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split harvest ;
: flatten-large-struct ( type -- )
heap-size cell align
cell /i "__stack_value" c-type <repetition> % ;
M: struct-type flatten-value-type ( type -- seq )
dup heap-size 16 > [
flatten-large-struct
] [
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
int-regs swap member?
"void*" "double" ? c-type ,
] each
] if ;

26
basis/cpu/x86/architecture/architecture.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays cpu.x86.assembler
cpu.x86.assembler.private cpu.architecture kernel kernel.private
math memory namespaces sequences words compiler.generator
math memory namespaces make sequences words compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts combinators compiler.constants math.order ;
IN: cpu.x86.architecture
@ -39,8 +39,6 @@ GENERIC: store-return-reg ( stack@ reg-class -- )
HOOK: temp-reg-1 cpu ( -- reg )
HOOK: temp-reg-2 cpu ( -- reg )
HOOK: address-operand cpu ( address -- operand )
HOOK: fixnum>slot@ cpu ( op -- )
HOOK: prepare-division cpu ( -- )
@ -141,28 +139,6 @@ M: x86 small-enough? ( n -- ? )
: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
: struct-return@ ( size n -- n )
[
stack-frame* cell + +
] [
\ stack-frame get swap -
] ?if ;
HOOK: %unbox-struct-1 cpu ( -- )
HOOK: %unbox-struct-2 cpu ( -- )
M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
} case ;
M: x86 struct-small-enough? ( size -- ? )
{ 1 2 4 8 } member?
os { linux netbsd solaris } member? not and ;
M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics

2
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -1,4 +1,4 @@
USING: cpu.x86.assembler kernel tools.test namespaces ;
USING: cpu.x86.assembler kernel tools.test namespaces make ;
IN: cpu.x86.assembler.tests
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test

2
basis/cpu/x86/assembler/assembler.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays compiler.generator.fixup io.binary kernel
combinators kernel.private math namespaces sequences
combinators kernel.private math namespaces make sequences
words system layouts math.order accessors
cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler

3
basis/csv/csv.factor
View File

@ -4,7 +4,8 @@
! Simple CSV Parser
! Phil Dawes phil@phildawes.net
USING: kernel sequences io namespaces combinators unicode.categories ;
USING: kernel sequences io namespaces make
combinators unicode.categories ;
IN: csv
SYMBOL: delimiter

2
basis/db/postgresql/postgresql.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs alien alien.syntax continuations io
kernel math math.parser namespaces prettyprint quotations
kernel math math.parser namespaces make prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators classes locals words tools.walker

8
basis/db/queries/queries.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random strings
math.parser math.intervals combinators math.bitwise nmake db
db.tuples db.types db.sql classes words shuffle arrays destructors
continuations ;
USING: accessors kernel math namespaces make sequences random
strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types db.sql classes words shuffle arrays
destructors continuations ;
IN: db.queries
GENERIC: where ( specs obj -- )

2
basis/db/tuples/tuples-docs.factor
View File

@ -154,7 +154,7 @@ T{ book
"Now we've created a book. Let's save it to the database."
{ $code <" USING: db db.sqlite fry io.files ;
: with-book-tutorial ( quot -- )
'[ "book-tutorial.db" temp-file sqlite-db , with-db ] call ;
'[ "book-tutorial.db" temp-file sqlite-db _ with-db ] call ;
[
book recreate-table

4
basis/db/tuples/tuples-tests.factor
View File

@ -201,10 +201,10 @@ TUPLE: annotation n paste-id summary author mode contents ;
! ] with-db
: test-sqlite ( quot -- )
[ ] swap '[ "tuples-test.db" temp-file sqlite-db , with-db ] unit-test ;
[ ] swap '[ "tuples-test.db" temp-file sqlite-db _ with-db ] unit-test ;
: test-postgresql ( quot -- )
[ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db , with-db ] unit-test ;
[ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db _ with-db ] unit-test ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test

12
basis/debugger/debugger.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slots arrays definitions generic hashtables summary io
kernel math namespaces prettyprint prettyprint.config sequences
assocs sequences.private strings io.styles io.files vectors
words system splitting math.parser classes.tuple continuations
continuations.private combinators generic.math classes.builtin
classes compiler.units generic.standard vocabs init
kernel.private io.encodings accessors math.order
kernel math namespaces make prettyprint prettyprint.config
sequences assocs sequences.private strings io.styles io.files
vectors words system splitting math.parser classes.tuple
continuations continuations.private combinators generic.math
classes.builtin classes compiler.units generic.standard vocabs
init kernel.private io.encodings accessors math.order
destructors source-files parser classes.tuple.parser
effects.parser lexer compiler.errors generic.parser
strings.parser ;

2
basis/debugger/threads/threads.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors debugger continuations threads threads.private
io io.styles prettyprint kernel math.parser namespaces ;
io io.styles prettyprint kernel math.parser namespaces make ;
IN: debugger.threads
: error-in-thread. ( thread -- )

1
basis/delegate/delegate-docs.factor
View File

@ -45,5 +45,4 @@ $nl
{ $subsection define-consult }
"The " { $vocab-link "delegate.protocols" } " vocabulary defines formal protocols for the various informal protocols used in the Factor core, such as " { $link "sequence-protocol" } ", " { $link "assocs-protocol" } " or " { $link "stream-protocol" } ;
IN: delegate
ABOUT: { "delegate" "intro" }

4
basis/delegate/delegate.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
prettyprint math hashtables sets macros namespaces ;
prettyprint math hashtables sets macros namespaces make ;
IN: delegate
: protocol-words ( protocol -- words )
@ -62,7 +62,7 @@ M: tuple-class group-words
protocol-consult keys ;
: lost-words ( protocol wordlist -- lost-words )
>r protocol-words r> diff ;
[ protocol-words ] dip diff ;
: forget-old-definitions ( protocol new-wordlist -- )
[ drop protocol-users ] [ lost-words ] 2bi

119
basis/deques/deques-docs.factor
View File

@ -1,45 +1,29 @@
USING: help.markup help.syntax kernel math sequences
quotations ;
IN: deques
USING: help.markup help.syntax kernel ;
ARTICLE: "deques" "Dequeues"
"A deque is a data structure with constant-time insertion and removal of elements at both ends. Dequeue operations are defined in the " { $vocab-link "deques" } " vocabulary."
$nl
"Dequeues must be instances of a mixin class:"
{ $subsection deque }
"Dequeues must implement a protocol."
$nl
"Querying the deque:"
{ $subsection peek-front }
{ $subsection peek-back }
{ $subsection deque-length }
{ $subsection deque-member? }
"Adding and removing elements:"
{ $subsection push-front* }
{ $subsection push-back* }
{ $subsection pop-front* }
{ $subsection pop-back* }
{ $subsection clear-deque }
"Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":"
{ $subsection delete-node }
{ $subsection node-value }
"Utility operations built in terms of the above:"
{ $subsection deque-empty? }
{ $subsection push-front }
{ $subsection push-all-front }
{ $subsection push-back }
{ $subsection push-all-back }
{ $subsection pop-front }
{ $subsection pop-back }
{ $subsection slurp-deque }
"When using a deque as a queue, the convention is to queue elements with " { $link push-front } " and deque them with " { $link pop-back } "." ;
ABOUT: "deques"
HELP: deque-empty?
{ $values { "deque" { $link deque } } { "?" "a boolean" } }
{ $values { "deque" deque } { "?" "a boolean" } }
{ $description "Returns true if a deque is empty." }
{ $notes "This operation is O(1)." } ;
HELP: clear-deque
{ $values
{ "deque" deque } }
{ $description "Removes all elements from a deque." } ;
HELP: deque-length
{ $values
{ "deque" deque }
{ "n" integer } }
{ $description "Returns the number of elements in a deque." } ;
HELP: deque-member?
{ $values
{ "value" object } { "deque" deque }
{ "?" "a boolean" } }
{ $description "Returns true if the " { $snippet "value" } " is found in the deque." } ;
HELP: push-front
{ $values { "obj" object } { "deque" deque } }
{ $description "Push the object onto the front of the deque." }
@ -60,6 +44,16 @@ HELP: push-back*
{ $description "Push the object onto the back of the deque and return the newly created node." }
{ $notes "This operation is O(1)." } ;
HELP: push-all-back
{ $values
{ "seq" sequence } { "deque" deque } }
{ $description "Pushes a sequence of elements onto the back of a deque." } ;
HELP: push-all-front
{ $values
{ "seq" sequence } { "deque" deque } }
{ $description "Pushes a sequence of elements onto the front of a deque." } ;
HELP: peek-front
{ $values { "deque" deque } { "obj" object } }
{ $description "Returns the object at the front of the deque." } ;
@ -87,3 +81,56 @@ HELP: pop-back*
{ $values { "deque" deque } }
{ $description "Pop the object off the back of the deque." }
{ $notes "This operation is O(1)." } ;
HELP: delete-node
{ $values
{ "node" object } { "deque" deque } }
{ $description "Deletes the node from the deque." } ;
HELP: deque
{ $description "A data structure that has constant-time insertion and removal of elements at both ends." } ;
HELP: node-value
{ $values
{ "node" object }
{ "value" object } }
{ $description "Accesses the value stored at a node." } ;
HELP: slurp-deque
{ $values
{ "deque" deque } { "quot" quotation } }
{ $description "Pops off the back element of the deque and calls the quotation in a loop until the deque is empty." } ;
ARTICLE: "deques" "Deques"
"The " { $vocab-link "deques" } " vocabulary implements the deque data structure which has constant-time insertion and removal of elements at both ends."
$nl
"Deques must be instances of a mixin class:"
{ $subsection deque }
"Deques must implement a protocol."
$nl
"Querying the deque:"
{ $subsection peek-front }
{ $subsection peek-back }
{ $subsection deque-length }
{ $subsection deque-member? }
"Adding and removing elements:"
{ $subsection push-front* }
{ $subsection push-back* }
{ $subsection pop-front* }
{ $subsection pop-back* }
{ $subsection clear-deque }
"Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":"
{ $subsection delete-node }
{ $subsection node-value }
"Utility operations built in terms of the above:"
{ $subsection deque-empty? }
{ $subsection push-front }
{ $subsection push-all-front }
{ $subsection push-back }
{ $subsection push-all-back }
{ $subsection pop-front }
{ $subsection pop-back }
{ $subsection slurp-deque }
"When using a deque as a queue, the convention is to queue elements with " { $link push-front } " and deque them with " { $link pop-back } "." ;
ABOUT: "deques"

2
basis/disjoint-sets/disjoint-sets-docs.factor
View File

@ -37,7 +37,7 @@ HELP: assoc>disjoint-set
} ;
ARTICLE: "disjoint-sets" "Disjoint sets"
"The " { $emphasis "disjoint set" } " data structure, also known as " { $emphasis "union-find" } " (after the two main operations which it supports) represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set."
"The " { $vocab-link "disjoint-sets" } " vocabulary implements the " { $emphasis "disjoint set" } " data structure (also known as " { $emphasis "union-find" } ", after the two main operations which it supports) that represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set."
$nl
"The two main supported operations are equating two elements, which joins their equivalence classes, and checking if two elements belong to the same equivalence class. Both operations have the time complexity of the inverse Ackermann function, which for all intents and purposes is constant time."
$nl

8
basis/disjoint-sets/disjoint-sets.factor
View File

@ -64,7 +64,7 @@ M: disjoint-set add-atom
[ 1 -rot counts>> set-at ]
2tri ;
: add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
: add-atoms ( seq disjoint-set -- ) '[ _ add-atom ] each ;
GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
@ -89,7 +89,7 @@ M:: disjoint-set equate ( a b disjoint-set -- )
] if ;
: equate-all-with ( seq a disjoint-set -- )
'[ , , equate ] each ;
'[ _ _ equate ] each ;
: equate-all ( seq disjoint-set -- )
over empty? [ 2drop ] [
@ -102,7 +102,7 @@ M: disjoint-set clone
: assoc>disjoint-set ( assoc -- disjoint-set )
<disjoint-set>
[ '[ drop , add-atom ] assoc-each ]
[ '[ , equate ] assoc-each ]
[ '[ drop _ add-atom ] assoc-each ]
[ '[ _ equate ] assoc-each ]
[ nip ]
2tri ;

2
basis/documents/documents.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io kernel math models namespaces
USING: accessors arrays io kernel math models namespaces make
sequences strings splitting combinators unicode.categories
math.order ;
IN: documents

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