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

wrunt's alien-invoke shorthand, tons of bug fixes, cleanups and documentation updates

cvs
Slava Pestov 2005-06-12 07:38:57 +00:00
parent 58e3257bc6
commit 1c63f5f0db
36 changed files with 1077 additions and 586 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
CHANGES.txt
View File

@ -1,48 +1,68 @@
Factor 0.75:
------------
New generational garbage collector. There are two command line switches
for controlling it:
+ Runtime and core library
- New generational garbage collector. There are two command line
switches for controlling it:
+Yn Size of 2 youngest generations, megabytes
+An Size of tenured and semi-spaces, megabytes
OpenGL binding in contrib/gl/ (Alex Chapman).
The compiler now does constant folding for certain words with literal
operands. The compiler's peephole optimizer has been improved.
The alien interface now supports "float" and "double" types, and arrays
of C types.
The SO_OOBINLINE socket flag is now set. In 0.74, sending out-of-band
data could fill up the buffer and cause a denial-of-service attack.
Generic words can now dispatch on stack elements other than the top one;
define your generic like this to dispatch on the second element:
- Generic words can now dispatch on stack elements other than the top
one; define your generic like this to dispatch on the second element:
G: foo [ over ] [ type ] ;
Or this for the third:
Or this for the third:
G: foo [ pick ] [ type ] ;
Note that GENERIC: foo is the same as
Note that GENERIC: foo is the same as
G: foo [ dup ] [ type ] ;
Sequence API refactoring, as described in
http://www.jroller.com/page/slava/20050518.
- Sequence API refactoring, as described in
http://www.jroller.com/page/slava/20050518.
HTTP server now supports virtual hosting.
- The SO_OOBINLINE socket flag is now set. In 0.74, sending out-of-band
data could fill up the buffer and cause a denial-of-service attack.
You can now set timeouts for I/O operations with the set-timeout generic
word. The HTTP server sets a timeout of 60 seconds for client requests.
- You can now set timeouts for I/O operations with the set-timeout
generic word. The HTTP server sets a timeout of 60 seconds for client
requests.
The Factor plugin now supports connecting to Factor instances on
arbitrary host and port names. This allows interactive development on
one machine while testing on another. A new command was added to
evaluate the word definition at the caret in the listener.
+ Compiler
- The compiler now does constant folding for certain words with literal
operands. The compiler's peephole optimizer has been improved.
- The alien interface now supports "float" and "double" types, and
arrays of C types.
- New short-hand syntax for defining words that alien-invoke
(Alex Chapman).
LIBRARY: gl
FUNCTION: void glTranslatef ( GLfloat x, GLfloat y, GLfloat z ) ;
should be the same as doing:
: glTranslatef ( x y z -- )
"void" "gl" "glTranslatef"
[ "GLfloat" "GLfloat" "GLfloat" ] alien-invoke ;
\ glTranslatef compile
+ Framework
- OpenGL binding in contrib/gl/ (Alex Chapman).
- HTTP server now supports virtual hosting.
- The Factor plugin now supports connecting to Factor instances on
arbitrary host and port names. This allows interactive development on
one machine while testing on another. A new command was added to
evaluate the word definition at the caret in the listener.
Factor 0.74:
------------

24
TODO.FACTOR.txt
View File

@ -9,26 +9,14 @@
<erg> if write returns -1 and errno == EINTR then it's not a real error, you can try again
- single-stepper and variable access: wrong namespace?
- investigate if COPYING_GEN needs a fix
- faster layout
- http keep alive, and range get
- sleep word
- fix i/o on generic x86/ppc unix
- alien primitives need a more general input type
- 2map slow with lists
- nappend: instead of using push, enlarge the sequence with set-length
then add set the elements with set-nth
- faster sequence operations
- generic some? all? memq? fiber?
- index and index* are very slow with lists
- code walker & exceptions
- if two tasks write to a unix stream, the buffer can overflow
- rename prettyprint* to pprint, prettyprint to pp
- reader syntax for arrays, byte arrays, displaced aliens
- dipping seq-2nmap, seq-2each
- array sort
- images saved from plugin do not work
- generic skip
- inference needs to be more robust with heavily recursive code
- investigate orphans
+ plugin:
@ -40,6 +28,7 @@
+ ui:
- faster layout
- tiled window manager
- faster repaint
- console with presentations
@ -53,6 +42,7 @@
+ ffi:
- alien primitives need a more general input type
- smarter out parameter handling
- clarify powerpc passing of value struct parameters
- box/unbox_signed/unsigned_8
@ -64,6 +54,7 @@
+ compiler:
- inference needs to be more robust with heavily recursive code
- powerpc: float ffi parameters
- fix fixnum<< and /i overflow on PowerPC
- simplifier:
@ -84,6 +75,15 @@
+ sequences
- generic skip
- dipping seq-2nmap, seq-2each
- array sort
- 2map slow with lists
- nappend: instead of using push, enlarge the sequence with set-length
then add set the elements with set-nth
- faster sequence operations
- generic some? all? memq? fiber?
- index and index* are very slow with lists
- specialized arrays
- list map, subset: not tail recursive
- phase out sbuf-append

49
contrib/gl/gl-internals.factor
View File

@ -1,49 +0,0 @@
IN: gl-internals
USING: alien kernel sequences stdio math test parser namespaces lists strings words compiler ;
! usage of 'LIBRARY:' and 'FUNCTION:' :
!
! LIBRARY: gl
! FUNCTION: void glTranslatef ( GLfloat x, GLfloat y, GLfloat z ) ;
!
! should be the same as doing:
!
! : glTranslatef ( x y z -- )
! "void" "gl" "glTranslatef" [ "GLfloat" "GLfloat" "GLfloat" ] alien-invoke ;
! \ glTranslatef compile
!
! other forms:
!
! FUNCTION: void glEnd ( ) ; -> : glEnd ( -- ) "void" "gl" "glEnd" [ ] alien-invoke ;
!
! TODO: show returns in the stack effect
: LIBRARY: scan "c-library" set ; parsing
: compile-function-call ( type lib func types stack-effect -- )
>r over create-in >r
[ alien-invoke ] cons cons cons cons r> swap define-compound
word r> "stack-effect" set-word-prop
word compile ;
: unpair ( list -- list1 list2 )
[ uncons uncons unpair rot swons >r cons r> ]
[ f f ] ifte* ;
: remove-trailing-char ( str ch -- str )
>r dup length 1 - swap 2dup nth r> =
[ head ]
[ nip ] ifte ;
: parse-stack-effect ( lst -- str )
unpair reverse "--" swons reverse
[ CHAR: , remove-trailing-char " " append ] map " " swons concat ;
: (function) ( type lib func function-args -- )
unswons drop reverse unswons drop reverse
parse-stack-effect compile-function-call ;
: FUNCTION:
scan "c-library" get scan string-mode on
[ string-mode off (function) ] [ ] ; parsing

5
contrib/gl/load.factor
View File

@ -9,5 +9,8 @@ win32? [
"glu" "libGLU.so" "cdecl" add-library
] ifte
[ "gl-internals.factor" "sdl-gl.factor" "gl.factor" "glu.factor" ]
[ "sdl-gl.factor" "gl.factor" "glu.factor" ]
[ "contrib/gl/" swap append run-file ] each
"gl" words [ try-compile ] each
"glu" words [ try-compile ] each

175
doc/compiler.tex
View File

@ -66,8 +66,128 @@
\maketitle
\tableofcontents{}
\section{Stack effect inference}
The stack effect inference tool checks correctness of code before it is run.
A \emph{stack effect} is a list of input classes and a list of output classes corresponding to
the effect a quotation has on the stack when called. For example, the stack effect of \verb|[ dup * ]| is \verb|[ [ integer ] [ integer ] ]|. The stack checker is used by passing a quotation to the \texttt{infer} word. It uses a sophisticated algorithm to infer stack effects of recursive words, combinators, and other tricky constructions, however, it cannot infer the stack effect of all words. In particular, anything using continuations, such as \texttt{catch} and I/O, will stump the stack checker.
\subsection{Usage}
The main entry point of the stack checker is a single word.
\wordtable{
\vocabulary{inference}
\ordinaryword{infer}{infer ( quot -- effect )}
}
Takes a quotation and attempts to infer its stack effect. An exception is thrown if the stack effect cannot be inferred.
You can combine unit testing with stack effect inference by writing unit tests that check stack effects of words. In fact, this can be automated with the \texttt{infer>test.} word; it takes a quotation on the stack, and prints a code snippet that tests the stack effect of the quotation:
\begin{alltt}
\textbf{ok} [ draw-shape ] infer>test.
\textbf{[ [ [ object ] [ ] ] ]
[ [ draw-shape ] infer ]
unit-test}
\end{alltt}
You can then copy and paste this snippet into a test script, and run the test script after
making changes to the word to ensure its stack effect signature has not changed.
\subsection{The algorithm}
The stack effect inference algorithm mirrors the interpreter algorithm. A ``meta data stack'' holds two types of entries; computed values, whose type is known but literal value will only be known at runtime, and literals, whose value is known statically. When a literal value is encountered, it is simply placed on the meta data stack. When a word is encountered, one of several actions are taken, depending on the type of the word:
\begin{itemize}
\item If the word has special stack effect inference behavior, this behavior is invoked. Shuffle words and various primitives fall into this category.
\item If the word's stack effect is already known, then the inputs are removed from the meta data stack, and output values are added. If the meta data stack contains insufficient values, more values are added, and the newly added values are placed in the input list. Since inference begins with an empty stack, the input list contains all required input values when inference is complete.
\item If the word is marked to be inlined, stack effect inference recurses into the word definition and uses the same meta data stack. See \ref{declarations}.
\item Otherwise, the word's stack effect is inferred in a fresh inferencer instance, and the stack effect is cached. The fresh inferencer is used rather than the current one, so that type information and literals on the current meta data stack do not affect the subsequently-cached stack effect.
\end{itemize}
The following two examples demonstrate some simple cases:
\begin{alltt}
\textbf{ok} [ 1 2 3 ] infer .
\textbf{[ [ ] [ fixnum fixnum fixnum ] ]}
\textbf{ok} [ "hi" swap ] infer .
\textbf{[ [ object ] [ string object ] ]}
\end{alltt}
\subsubsection{Combinators}
A simple combinator such as \verb|keep| does not by itself have a stack effect, since \verb|call| takes an arbitrary quotation from the stack, which itself may have an arbitrary stack effect.
\begin{verbatim}
IN: kernel
: keep ( x quot -- x | quot: x -- )
over >r call r> ; inline
\end{verbatim}
On the other hand, the stack effect of word that passes a literal quotation to \verb|keep| can be inferred. The quotation is a literal on the meta data stack, and since \verb|keep| is marked \verb|inline|, the special inference behavior of \verb|call| receives this quotation.
\begin{alltt}
\textbf{ok} [ [ dup * ] keep ] infer .
\textbf{[ [ number ] [ number number ] ]}
\end{alltt}
Note that if \verb|call| is applied to a computed value, for example, a quotation taken from a variable, or a quotation that is constructed immediately before the \verb|call|, the stack effect inferencer will raise an error.
\begin{alltt}
\textbf{ok} [ frog get call ] infer .
\textbf{! Inference error: A literal value was expected where a
computed value was found: \#<computed @ 716167923>
! Recursive state:
:s :r :n :c show stacks at time of error.
:get ( var -- value ) inspects the error namestack.}
\end{alltt}
Another word with special inference behavior is \verb|execute|. It is used much more rarely than \verb|call|, but does pretty much the same thing, except it takes a word as input rather than a string.
\subsubsection{Conditionals}
Simpler than a stack effect is the concept of a stack height difference. This is simply the input value count subtracted from the output value count. A conditional's stack effect can be inferred if each branch has the same stack height difference; in this case, we say that the conditional is \emph{balanced}, and the total stack effect is computed by performing a unification of types across each branch.
The following two examples exhibit balanced conditionals:
\begin{verbatim}
[ 1 ] [ dup ] ifte
dup cons? [ unit ] when cons
\end{verbatim}
The following example is not balanced and raises an error when we attempt to infer its stack effect:
\begin{alltt}
\textbf{ok} [ [ dup ] [ drop ] ifte ] infer .
\textbf{! Inference error: Unbalanced branches
! Recursive state:
:s :r :n :c show stacks at time of error.
:get ( var -- value ) inspects the error namestack.}
\end{alltt}
\subsubsection{Recursive words}
Recursive words all have the same general form; there is a conditional, and one branch of the conditional is the \emph{base case} terminating the recursion, and the other branch is the \emph{inductive case}, which reduces the problem and recurses on the reduced problem. A key observation one must make is that in a well-formed recursion, the recursive call in the inductive case eventually results in the base case being called, so we can take the stack effect of the recursive call to be the stack effect of the base case.
Consider the following implementation of a word that measures the length of a list:
\begin{verbatim}
: length ( list -- n )
[ cdr length 1 + ] [ 0 ] ifte* ;
\end{verbatim}
The stack effect can be inferred without difficulty:
\begin{alltt}
\textbf{ok} [ length ] infer .
\textbf{[ [ object ] [ integer ] ]}
\end{alltt}
The base case is taken if the top of the stack is \verb|f|, and the base case has a stack effect \verb|[ [ object ] [ fixnum ] ]|.
On the other hand if the top of the stack is something else, the inductive case is taken. The inductive case makes a recursive call to \verb|length|, and once we substitute the stack effect of the base case into this call point, we can infer that the stack effect of the recursive case is \verb|[ [ object ] [ integer ] ]|.
If both branches contain a recursive call, the stack effect inferencer gives up.
\begin{alltt}
\textbf{ok} : fie [ fie ] [ fie ] ifte ;
\textbf{ok} [ fie ] infer .
\textbf{! Inference error: fie does not have a base case
! Recursive state:
:s :r :n :c show stacks at time of error.
:get ( var -- value ) inspects the error namestack.}
\end{alltt}
\section{The compiler}
\subsection{Basic usage}
The compiler can provide a substantial speed boost for words whose stack effect can be inferred. Words without a known stack effect cannot be compiled, and must be run in the interpreter. The compiler generates native code, and so far, x86 and PowerPC backends have been developed.
To compile a single word, call \texttt{compile}:
@ -89,6 +209,61 @@ The compiler has two limitations you must be aware of. First, if an exception is
The compiler consists of multiple stages -- first, a dataflow graph is inferred, then various optimizations are done on this graph, then it is transformed into a linear representation, further optimizations are done, and finally, machine code is generated from the linear representation.
\subsection{Stack effect inference}
While most programming errors in Factor are only caught at runtime, the stack effect checker can be useful for checking correctness of code before it is run. It can also help narrow down problems with stack shuffling. The stack checker is used by passing a quotation to the \texttt{infer} word. It uses a sophisticated algorithm to infer stack effects of recursive words, combinators, and other tricky constructions, however, it cannot infer the stack effect of all words. In particular, anything using continuations, such as \texttt{catch} and I/O, will stump the stack checker. Despite this fault, it is still a useful tool.
\begin{alltt}
\textbf{ok} [ pile-fill * >fixnum over pref-size dup y
\texttt{...} [ + ] change ] infer .
\textbf{[ [ tuple number tuple ] [ tuple fixnum object number ] ]}
\end{alltt}
The stack checker will report an error if it cannot infer the stack effect of a quotation. The ``recursive state'' dump is similar to a return stack, but it is not a real return stack, since only a code walk is taking place, not full evaluation. Understanding recursive state dumps is an art, much like understanding return stacks.
\begin{alltt}
\textbf{ok} [ 100 [ f f cons ] repeat ] infer .
\textbf{! Inference error: Unbalanced branches
! Recursive state:
! [ (repeat) G:54044 pick pick >= [ 3drop ]
[ [ swap >r call 1 + r> ] keep (repeat) ] ifte ]
! [ repeat G:54042 0 -rot (repeat) ]
:s :r :n :c show stacks at time of error.
:get ( var -- value ) inspects the error namestack.}
\end{alltt}
One reason stack inference might fail is if the quotation contains unbalanced branches, as above. For the inference to work, both branches of a conditional must exit with the same stack height.
Another situation when it fails is if your code calls quotations that are not statically known. This can happen if the word in question uses continuations, or if it pulls a quotation from a variable and calls it. This can also happen if you wrote your own combinator, but forgot to mark it as \texttt{inline}. For example, the following will fail:
\begin{alltt}
\textbf{ok} : dip swap >r call r> ;
\textbf{ok} [ [ + ] dip * ] infer .
! Inference error: A literal value was expected where a
computed value was found: \#<computed @ 679711507>
...
\end{alltt}
However, defining \texttt{dip} to be inlined will work:
\begin{alltt}
\textbf{ok} : dip swap >r call r> ; inline
\textbf{ok} [ [ + ] dip * ] infer .
\textbf{[ [ number number number ] [ number ] ]}
\end{alltt}
You can combine unit testing with stack effect inference by writing unit tests that check stack effects of words. In fact, this can be automated with the \texttt{infer>test.} word; it takes a quotation on the stack, and prints a code snippet that tests the stack effect of the quotation:
\begin{alltt}
\textbf{ok} [ draw-shape ] infer>test.
\textbf{[ [ [ object ] [ ] ] ]
[ [ draw-shape ] infer ]
unit-test}
\end{alltt}
You can then copy and paste this snippet into a test script, and run the test script after
making changes to the word to ensure its stack effect signature has not changed.
\subsection{Linear intermediate representation}
The linear IR is the second of the two intermediate

682
doc/handbook.tex
View File

File diff suppressed because it is too large Load Diff

24
library/alien/aliens.factor
View File

@ -5,10 +5,10 @@ USING: hashtables kernel lists math namespaces parser stdio ;
DEFER: dll?
BUILTIN: dll 15 dll? [ 1 "dll-path" f ] ;
DEFER: alien?
BUILTIN: alien 16 alien? ;
DEFER: byte-array?
BUILTIN: byte-array 19 byte-array? ;
DEFER: displaced-alien?
BUILTIN: displaced-alien 20 displaced-alien? ;
@ -31,10 +31,6 @@ M: alien = ( obj obj -- ? )
2drop f
] ifte ;
: ALIEN: scan-word <alien> swons ; parsing
: DLL" skip-blank parse-string dlopen swons ; parsing
: library ( name -- object )
dup [ "libraries" get hash ] when ;
@ -58,3 +54,19 @@ M: alien = ( obj obj -- ? )
: library-abi ( library -- abi )
library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;
! This will go elsewhere soon
: byte-bit ( n alien -- byte bit )
over -3 shift alien-unsigned-1 swap 7 bitand ;
: bit-nth ( n alien -- ? )
byte-bit 1 swap shift bitand 0 > ;
: set-bit ( ? byte bit -- byte )
1 swap shift rot [ bitor ] [ bitnot bitand ] ifte ;
: set-bit-nth ( ? n alien -- )
[ byte-bit set-bit ] 2keep
swap -3 shift set-alien-unsigned-1 ;
: ALIEN: scan-word <alien> swons ; parsing

26
library/alien/c-types.factor
View File

@ -2,8 +2,8 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler compiler-backend errors generic
hashtables kernel lists math namespaces parser sequences strings
words ;
hashtables kernel kernel-internals lists math namespaces parser
sequences strings words ;
: <c-type> ( -- type )
<namespace> [
@ -91,6 +91,11 @@ SYMBOL: c-types
2dup define-set-nth
define-out ;
: (typedef) c-types get [ >r get r> set ] bind ;
: typedef ( old new -- )
over "*" append over "*" append (typedef) (typedef) ;
global [ c-types nest drop ] bind
[
@ -225,19 +230,6 @@ global [ c-types nest drop ] bind
\ %unbox-double "unbox-op" set
] "double" define-primitive-type
: (alias-c-type)
c-types get [ >r get r> set ] bind ;
: alias-c-type ( old new -- )
over "*" append over "*" append
(alias-c-type) (alias-c-type) ;
! FIXME for 64-bit platforms
"int" "long" alias-c-type
"uint" "ulong" alias-c-type
: ALIAS:
#! Followed by old then new. This is a parsing word so that
#! we can define aliased types, and then a C struct, in the
#! same source file.
scan scan alias-c-type ; parsing
"int" "long" typedef
"uint" "ulong" typedef

21
library/alien/malloc.factor
View File

@ -1,19 +1,12 @@
! Copyright (C) 2004, 2005 Mackenzie Straight.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel-internals
USING: alien errors kernel math ;
USING: alien errors kernel ;
: malloc ( size -- address )
"ulong" "libc" "malloc" [ "ulong" ] alien-invoke ;
LIBRARY: libc
FUNCTION: ulong malloc ( ulong size ) ;
FUNCTION: ulong free ( ulong ptr ) ;
FUNCTION: ulong realloc ( ulong ptr, ulong size ) ;
FUNCTION: void memcpy ( ulong dst, ulong src, ulong size ) ;
: free ( address -- )
"void" "libc" "free" [ "ulong" ] alien-invoke ;
: realloc ( address size -- address )
"ulong" "libc" "realloc" [ "ulong" "ulong" ] alien-invoke ;
: memcpy ( dst src size -- )
"void" "libc" "memcpy" [ "ulong" "ulong" "ulong" ] alien-invoke ;
: check-ptr ( ptr -- ptr )
dup 0 number= [ "Out of memory" throw ] when ;
: check-ptr dup 0 = [ "Out of memory" throw ] when ;

46
library/alien/syntax.factor Normal file
View File

@ -0,0 +1,46 @@
! Copyright (C) 2005 Alex Chapman.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: compiler kernel lists namespaces parser sequences words ;
! usage of 'LIBRARY:' and 'FUNCTION:' :
!
! LIBRARY: gl
! FUNCTION: void glTranslatef ( GLfloat x, GLfloat y, GLfloat z ) ;
!
! should be the same as doing:
!
! : glTranslatef ( x y z -- )
! "void" "gl" "glTranslatef" [ "GLfloat" "GLfloat" "GLfloat" ] alien-invoke ;
! \ glTranslatef compile
!
! other forms:
!
! FUNCTION: void glEnd ( ) ; -> : glEnd ( -- ) "void" "gl" "glEnd" [ ] alien-invoke ;
!
! TODO: show returns in the stack effect
: LIBRARY: scan "c-library" set ; parsing
: parse-arglist ( lst -- types stack effect )
unpair [
" " % [ "," ?tail drop % " " % ] each "-- " %
] make-string ;
: (define-c-word) ( type lib func types stack-effect -- )
>r over create-in >r
[ alien-invoke ] cons cons cons cons r> swap define-compound
word r> "stack-effect" set-word-prop ;
: define-c-word ( type lib func function-args -- )
[ "()" subseq? not ] subset parse-arglist (define-c-word) ;
: FUNCTION:
scan "c-library" get scan string-mode on
[ string-mode off define-c-word ] [ ] ; parsing
: TYPEDEF:
#! TYPEDEF: old new
scan scan typedef ; parsing
: DLL" skip-blank parse-string dlopen swons ; parsing

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

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: image
USING: lists parser namespaces stdio kernel vectors words
hashtables sequences ;
USING: generic hashtables kernel lists math memory namespaces
parser prettyprint sequences stdio vectors words ;
"Bootstrap stage 1..." print
@ -14,16 +14,21 @@ hashtables sequences ;
[
[
"/version.factor"
"/library/stack.factor"
"/library/combinators.factor"
"/library/collections/sequences.factor"
"/library/collections/arrays.factor"
"/library/kernel.factor"
"/library/math/math.factor"
"/library/math/integer.factor"
"/library/math/ratio.factor"
"/library/math/float.factor"
"/library/math/complex.factor"
"/library/collections/cons.factor"
"/library/collections/assoc.factor"
"/library/collections/lists.factor"
@ -36,16 +41,21 @@ hashtables sequences ;
"/library/collections/vectors-epilogue.factor"
"/library/collections/slicing.factor"
"/library/collections/strings-epilogue.factor"
"/library/math/matrices.factor"
"/library/words.factor"
"/library/vocabularies.factor"
"/library/errors.factor"
"/library/continuations.factor"
"/library/io/stream.factor"
"/library/io/stdio.factor"
"/library/io/c-streams.factor"
"/library/io/files.factor"
"/library/threads.factor"
"/library/syntax/parse-numbers.factor"
"/library/syntax/parse-words.factor"
"/library/syntax/parse-errors.factor"
@ -54,29 +64,74 @@ hashtables sequences ;
"/library/syntax/generic.factor"
"/library/syntax/math.factor"
"/library/syntax/parse-syntax.factor"
"/library/alien/aliens.factor"
"/library/cli.factor"
"/library/syntax/unparser.factor"
"/library/syntax/prettyprint.factor"
"/library/tools/debugger.factor"
"/library/tools/gensym.factor"
"/library/tools/interpreter.factor"
"/library/tools/debugger.factor"
"/library/tools/memory.factor"
"/library/inference/conditions.factor"
"/library/inference/dataflow.factor"
"/library/inference/values.factor"
"/library/inference/inference.factor"
"/library/inference/branches.factor"
"/library/inference/words.factor"
"/library/inference/stack.factor"
"/library/inference/partial-eval.factor"
"/library/compiler/assembler.factor"
"/library/compiler/relocate.factor"
"/library/compiler/xt.factor"
"/library/compiler/optimizer.factor"
"/library/compiler/vops.factor"
"/library/compiler/linearizer.factor"
"/library/compiler/intrinsics.factor"
"/library/compiler/simplifier.factor"
"/library/compiler/generator.factor"
"/library/compiler/compiler.factor"
"/library/alien/c-types.factor"
"/library/alien/enums.factor"
"/library/alien/structs.factor"
"/library/alien/compiler.factor"
"/library/alien/syntax.factor"
"/library/cli.factor"
"/library/tools/memory.factor"
] pull-in
] make-list
"delegate" [ "generic" ] search
"object" [ "generic" ] search
"typemap" [ "generic" ] search
"builtins" [ "generic" ] search
"delegate" [ "generic" ] search
"object" [ "generic" ] search
"typemap" [ "generic" ] search
"builtins" [ "generic" ] search
vocabularies get [ "generic" off ] bind
vocabularies get [ "generic" off ] bind
reveal
reveal
reveal
reveal
reveal
reveal
reveal
reveal
[
[
boot
"Rehashing hash tables..." print
[ hashtable? ] instances
[ dup hash-size 1 max swap set-bucket-count ] each
"Building cross-reference database..." print
recrossref
] %
[
"/library/generic/generic.factor"
@ -91,9 +146,23 @@ hashtables sequences ;
"/library/bootstrap/init.factor"
] pull-in
! uncomment this if type numbers change. it takes a long time...
[
"Building generics..." print
all-words [ generic? ] subset [ make-generic ] each
] %
] make-list
"boot" [ "kernel" ] search swons
swap
[
"/library/bootstrap/boot-stage2.factor" run-resource
]
append3
vocabularies get [
"!syntax" get "syntax" set

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

@ -4,17 +4,6 @@ USING: alien assembler command-line compiler generic hashtables
kernel lists memory namespaces parser sequences stdio unparser
words ;
"Making the image happy..." print
! Rehash hashtables
[ hashtable? ] instances
[ dup hash-size swap set-bucket-count ] each
! Update generics
[ dup generic? [ make-generic ] [ drop ] ifte ] each-word
recrossref
: pull-in ( ? list -- )
swap [
[
@ -24,36 +13,7 @@ recrossref
drop
] ifte ;
"Loading compiler and friends..." print
t [
"/library/inference/conditions.factor"
"/library/inference/dataflow.factor"
"/library/inference/values.factor"
"/library/inference/inference.factor"
"/library/inference/branches.factor"
"/library/inference/words.factor"
"/library/inference/stack.factor"
"/library/inference/partial-eval.factor"
"/library/compiler/assembler.factor"
"/library/compiler/relocate.factor"
"/library/compiler/xt.factor"
"/library/compiler/optimizer.factor"
"/library/compiler/vops.factor"
"/library/compiler/linearizer.factor"
"/library/compiler/intrinsics.factor"
"/library/compiler/simplifier.factor"
"/library/compiler/generator.factor"
"/library/compiler/compiler.factor"
"/library/alien/c-types.factor"
"/library/alien/enums.factor"
"/library/alien/structs.factor"
"/library/alien/compiler.factor"
"/library/alien/malloc.factor"
"/library/io/buffer.factor"
] pull-in
"Loading compiler backend..." print
cpu "x86" = [
"/library/compiler/x86/assembler.factor"

4
library/bootstrap/boot-stage3.factor
View File

@ -43,7 +43,11 @@ compile? [
"Loading more library code..." print
t [
"/library/alien/malloc.factor"
"/library/io/buffer.factor"
"/library/math/constants.factor"
"/library/math/pow.factor"
"/library/math/more-matrices.factor"

20
library/bootstrap/image.factor
View File

@ -46,6 +46,7 @@ SYMBOL: boot-quot
: vector-type 11 ; inline
: string-type 12 ; inline
: word-type 17 ; inline
: tuple-type 18 ; inline
: immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
: >header ( id -- tagged ) object-tag immediate ;
@ -228,16 +229,19 @@ M: string ' ( string -- pointer )
( Arrays and vectors )
: emit-array ( list -- pointer )
[ ' ] map
: emit-array ( list type -- pointer )
>r [ ' ] map r>
object-tag here-as >r
array-type >header emit
>header emit
dup length emit-fixnum
( elements -- ) [ emit ] each
align-here r> ;
M: tuple ' ( tuple -- pointer )
<mirror> >list tuple-type emit-array ;
: emit-vector ( vector -- pointer )
dup >list emit-array swap length
dup >list array-type emit-array swap length
object-tag here-as >r
vector-type >header emit
emit-fixnum ( length )
@ -248,7 +252,8 @@ M: vector ' ( vector -- pointer )
emit-vector ;
: emit-hashtable ( hash -- pointer )
dup buckets>list emit-array swap hash>alist length
dup buckets>list array-type emit-array
swap hash>alist length
object-tag here-as >r
hashtable-type >header emit
emit-fixnum ( length )
@ -265,9 +270,7 @@ M: hashtable ' ( hashtable -- pointer )
: vocabulary, ( hash -- )
dup hashtable? [
[
cdr dup word? [ word, ] [ drop ] ifte
] hash-each
[ cdr dup word? [ word, ] [ drop ] ifte ] hash-each
] [
drop
] ifte ;
@ -282,6 +285,7 @@ M: hashtable ' ( hashtable -- pointer )
vocabularies set
typemap [ ] change
builtins [ ] change
crossref [ ] change
] extend '
global-offset fixup ;

4
library/bootstrap/init.factor
View File

@ -10,7 +10,3 @@ USING: io-internals namespaces parser stdio threads words ;
init-io
"HOME" os-env [ "." ] unless* "~" set
init-search-path ;
"Good morning!" print
flush
"/library/bootstrap/boot-stage2.factor" run-resource

3
library/bootstrap/primitives.factor
View File

@ -41,6 +41,7 @@ vocabularies get [
[ "execute" "words" [ [ word ] [ ] ] ]
[ "call" "kernel" [ [ general-list ] [ ] ] ]
[ "ifte" "kernel" [ [ object general-list general-list ] [ ] ] ]
[ "dispatch" "kernel-internals" [ [ fixnum vector ] [ ] ] ]
[ "cons" "lists" [ [ object object ] [ cons ] ] ]
[ "<vector>" "vectors" [ [ integer ] [ vector ] ] ]
[ "string-compare" "strings" [ [ string string ] [ integer ] ] ]
@ -152,7 +153,7 @@ vocabularies get [
[ "dlsym" "alien" [ [ string object ] [ integer ] ] ]
[ "dlclose" "alien" [ [ dll ] [ ] ] ]
[ "<alien>" "alien" [ [ integer ] [ alien ] ] ]
[ "<byte-array>" "alien" [ [ integer ] [ byte-array ] ] ]
[ "<byte-array>" "kernel-internals" [ [ integer ] [ byte-array ] ] ]
[ "<displaced-alien>" "alien" [ [ integer object ] [ displaced-alien ] ] ]
[ "alien-signed-cell" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-signed-cell" "alien" [ [ integer alien integer ] [ ] ] ]

7
library/collections/arrays.factor
View File

@ -23,7 +23,6 @@ BUILTIN: array 8 array? ;
: array-capacity ( a -- n ) 1 slot ; inline
: array-nth ( n a -- obj ) swap 2 fixnum+ slot ; inline
: set-array-nth ( obj n a -- ) swap 2 fixnum+ set-slot ; inline
: dispatch ( n vtable -- ) 2 slot array-nth call ;
M: array length array-capacity ;
M: array nth array-nth ;
@ -34,3 +33,9 @@ M: array resize resize-array ;
dup array-capacity [
3dup swap array-nth pick rot set-array-nth
] repeat 2drop ;
DEFER: byte-array?
BUILTIN: byte-array 19 byte-array? ;
M: byte-array length array-capacity ;
M: byte-array resize resize-array ;

3
library/collections/lists.factor
View File

@ -146,6 +146,9 @@ M: general-list nth ( n list -- element )
#! Is every element of list1 in list2?
swap [ swap contains? ] all-with? ;
: unpair ( list -- list1 list2 )
[ uncons uncons unpair rot swons >r cons r> ] [ f f ] ifte* ;
: <queue> ( -- queue )
#! Make a new functional queue.
[[ [ ] [ ] ]] ;

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

@ -11,7 +11,8 @@ vectors ;
UNION: sequence array string sbuf vector ;
M: object thaw clone ;
M: object freeze drop ;
M: object like drop ;
M: object empty? ( seq -- ? ) length 0 = ;
@ -52,7 +53,7 @@ M: sequence tree-each swap [ swap tree-each ] each-with ;
0 swap (nmap) ; inline
: immutable ( seq quot -- seq | quot: seq -- )
swap [ thaw ] keep >r dup >r swap call r> r> freeze ; inline
swap [ thaw ] keep >r dup >r swap call r> r> like ; inline
M: object map ( seq quot -- seq | quot: elt -- elt )
swap [ swap nmap ] immutable ;

1
library/collections/sequences.factor
View File

@ -18,7 +18,6 @@ GENERIC: nth ( n sequence -- obj )
GENERIC: set-nth ( value n sequence -- obj )
GENERIC: thaw ( seq -- mutable-seq )
GENERIC: like ( seq seq -- seq )
GENERIC: freeze ( new orig -- new )
GENERIC: reverse ( seq -- seq )
GENERIC: peek ( seq -- elt )
GENERIC: contains? ( elt seq -- ? )

4
library/collections/strings-epilogue.factor
View File

@ -23,8 +23,8 @@ sequences strings ;
M: object >string >sbuf (sbuf>string) ;
M: string thaw >sbuf ;
M: string freeze drop >string ;
M: string like ( seq sbuf -- sbuf ) drop >string ;
M: string like ( seq sbuf -- string ) drop >string ;
M: sbuf clone ( sbuf -- sbuf )
[ length <sbuf> dup ] keep nappend ;

2
library/collections/vectors-epilogue.factor
View File

@ -21,7 +21,7 @@ M: vector clone ( vector -- vector )
0 <repeated> >vector ;
M: general-list thaw >vector ;
M: general-list freeze drop >list ;
M: general-list like drop >list ;
M: vector like drop >vector ;

18
library/compiler/simplifier.factor
View File

@ -18,21 +18,19 @@ GENERIC: next-logical ( linear vop -- linear )
! No delegation.
M: tuple simplify-node drop f ;
: (simplify-1) ( ? list -- ? )
dup [
[ car simplify-node swap , or ] keep cdr (simplify-1)
] when ;
: simplify-1 ( list -- list ? )
#! Return a new linear IR.
dup [
dup car simplify-node
[ uncons simplify-1 drop cons t ]
[ uncons simplify-1 >r cons r> ] ifte
] [
f
] ifte ;
[ (simplify-1) ] make-list swap ;
: simplify ( linear -- linear )
#! Keep simplifying until simplify-1 returns f.
[
dup simplifying set simplify-1
] with-scope [ simplify ] when ;
[ dup simplifying set simplify-1 ] with-scope
[ simplify ] when ;
: label-called? ( label -- ? )
simplifying get [ calls-label? ] some-with? ;

212
library/compiler/vops.factor
View File

@ -40,11 +40,6 @@ M: vop calls-label? vop-label = ;
: make-vop ( inputs outputs label vop -- vop )
[ >r <vop> r> set-delegate ] keep ;
: VOP:
#! Followed by a VOP name.
scan dup [ ] define-tuple
create-in [ make-vop ] define-constructor ; parsing
: empty-vop f f f ;
: label-vop ( label) >r f f r> ;
: label/src-vop ( label src) unit swap f swap ;
@ -57,83 +52,105 @@ M: vop calls-label? vop-label = ;
: 3-vop ( in1 in2 dest) >r 2list r> unit f ;
! miscellanea
VOP: %prologue
TUPLE: %prologue ;
C: %prologue make-vop ;
: %prologue empty-vop <%prologue> ;
VOP: %label
TUPLE: %label ;
C: %label make-vop ;
: %label label-vop <%label> ;
M: %label calls-label? 2drop f ;
! Return vops take a label that is ignored, to have the
! same stack effect as jumps. This is needed for the
! simplifier.
VOP: %return
TUPLE: %return ;
C: %return make-vop ;
: %return ( label) label-vop <%return> ;
VOP: %return-to
TUPLE: %return-to ;
C: %return-to make-vop ;
: %return-to label-vop <%return-to> ;
VOP: %jump
TUPLE: %jump ;
C: %jump make-vop ;
: %jump label-vop <%jump> ;
VOP: %jump-label
TUPLE: %jump-label ;
C: %jump-label make-vop ;
: %jump-label label-vop <%jump-label> ;
VOP: %call
TUPLE: %call ;
C: %call make-vop ;
: %call label-vop <%call> ;
VOP: %call-label
TUPLE: %call-label ;
C: %call-label make-vop ;
: %call-label label-vop <%call-label> ;
VOP: %jump-t
TUPLE: %jump-t ;
C: %jump-t make-vop ;
: %jump-t <vreg> label/src-vop <%jump-t> ;
VOP: %jump-f
TUPLE: %jump-f ;
C: %jump-f make-vop ;
: %jump-f <vreg> label/src-vop <%jump-f> ;
! dispatch tables
VOP: %dispatch
TUPLE: %dispatch ;
C: %dispatch make-vop ;
: %dispatch <vreg> src-vop <%dispatch> ;
VOP: %target-label
TUPLE: %target-label ;
C: %target-label make-vop ;
: %target-label label-vop <%target-label> ;
VOP: %target
TUPLE: %target ;
C: %target make-vop ;
: %target label-vop <%target> ;
VOP: %end-dispatch
TUPLE: %end-dispatch ;
C: %end-dispatch make-vop ;
: %end-dispatch empty-vop <%end-dispatch> ;
! stack operations
VOP: %peek-d
TUPLE: %peek-d ;
C: %peek-d make-vop ;
: %peek-d ( vreg n -- ) swap <vreg> src/dest-vop <%peek-d> ;
M: %peek-d basic-block? drop t ;
VOP: %replace-d
TUPLE: %replace-d ;
C: %replace-d make-vop ;
: %replace-d ( vreg n -- ) swap <vreg> 2-in-vop <%replace-d> ;
M: %replace-d basic-block? drop t ;
VOP: %inc-d
TUPLE: %inc-d ;
C: %inc-d make-vop ;
: %inc-d ( n -- ) src-vop <%inc-d> ;
: %dec-d ( n -- ) neg %inc-d ;
M: %inc-d basic-block? drop t ;
VOP: %immediate
TUPLE: %immediate ;
C: %immediate make-vop ;
: %immediate ( vreg obj -- )
swap <vreg> src/dest-vop <%immediate> ;
M: %immediate basic-block? drop t ;
VOP: %peek-r
TUPLE: %peek-r ;
C: %peek-r make-vop ;
: %peek-r ( vreg n -- ) swap <vreg> src/dest-vop <%peek-r> ;
VOP: %replace-r
TUPLE: %replace-r ;
C: %replace-r make-vop ;
: %replace-r ( vreg n -- ) swap <vreg> 2-in-vop <%replace-r> ;
VOP: %inc-r
TUPLE: %inc-r ;
C: %inc-r make-vop ;
: %inc-r ( n -- ) src-vop <%inc-r> ;
! this exists, unlike %dec-d which does not, due to x86 quirks
VOP: %dec-r
TUPLE: %dec-r ;
C: %dec-r make-vop ;
: %dec-r ( n -- ) src-vop <%dec-r> ;
: in-1 0 0 %peek-d , ;
@ -142,22 +159,26 @@ VOP: %dec-r
: out-1 0 0 %replace-d , ;
! indirect load of a literal through a table
VOP: %indirect
TUPLE: %indirect ;
C: %indirect make-vop ;
: %indirect ( vreg obj -- )
swap <vreg> src/dest-vop <%indirect> ;
M: %indirect basic-block? drop t ;
! object slot accessors
! mask off a tag (see also %untag-fixnum)
VOP: %untag
TUPLE: %untag ;
C: %untag make-vop ;
: %untag <vreg> dest-vop <%untag> ;
M: %untag basic-block? drop t ;
VOP: %slot
TUPLE: %slot ;
C: %slot make-vop ;
: %slot ( n vreg ) >r <vreg> r> <vreg> 2-vop <%slot> ;
M: %slot basic-block? drop t ;
VOP: %set-slot
TUPLE: %set-slot ;
C: %set-slot make-vop ;
: %set-slot ( value obj n )
#! %set-slot writes to vreg n.
>r >r <vreg> r> <vreg> r> <vreg> 3list dup second f
@ -166,38 +187,56 @@ M: %set-slot basic-block? drop t ;
! in the 'fast' versions, the object's type and slot number is
! known at compile time, so these become a single instruction
VOP: %fast-slot
TUPLE: %fast-slot ;
C: %fast-slot make-vop ;
: %fast-slot ( vreg n )
swap <vreg> 2-vop <%fast-slot> ;
M: %fast-slot basic-block? drop t ;
VOP: %fast-set-slot
TUPLE: %fast-set-slot ;
C: %fast-set-slot make-vop ;
: %fast-set-slot ( value obj n )
#! %fast-set-slot writes to vreg obj.
>r >r <vreg> r> <vreg> r> over >r 3list r> unit f
<%fast-set-slot> ;
M: %fast-set-slot basic-block? drop t ;
VOP: %write-barrier
TUPLE: %write-barrier ;
C: %write-barrier make-vop ;
: %write-barrier ( ptr ) <vreg> unit dup f <%write-barrier> ;
! fixnum intrinsics
VOP: %fixnum+ : %fixnum+ 3-vop <%fixnum+> ;
VOP: %fixnum- : %fixnum- 3-vop <%fixnum-> ;
VOP: %fixnum* : %fixnum* 3-vop <%fixnum*> ;
VOP: %fixnum-mod : %fixnum-mod 3-vop <%fixnum-mod> ;
VOP: %fixnum/i : %fixnum/i 3-vop <%fixnum/i> ;
VOP: %fixnum/mod : %fixnum/mod f <%fixnum/mod> ;
VOP: %fixnum-bitand : %fixnum-bitand 3-vop <%fixnum-bitand> ;
VOP: %fixnum-bitor : %fixnum-bitor 3-vop <%fixnum-bitor> ;
VOP: %fixnum-bitxor : %fixnum-bitxor 3-vop <%fixnum-bitxor> ;
VOP: %fixnum-bitnot : %fixnum-bitnot 2-vop <%fixnum-bitnot> ;
TUPLE: %fixnum+ ;
C: %fixnum+ make-vop ; : %fixnum+ 3-vop <%fixnum+> ;
TUPLE: %fixnum- ;
C: %fixnum- make-vop ; : %fixnum- 3-vop <%fixnum-> ;
TUPLE: %fixnum* ;
C: %fixnum* make-vop ; : %fixnum* 3-vop <%fixnum*> ;
TUPLE: %fixnum-mod ;
C: %fixnum-mod make-vop ; : %fixnum-mod 3-vop <%fixnum-mod> ;
TUPLE: %fixnum/i ;
C: %fixnum/i make-vop ; : %fixnum/i 3-vop <%fixnum/i> ;
TUPLE: %fixnum/mod ;
C: %fixnum/mod make-vop ; : %fixnum/mod f <%fixnum/mod> ;
TUPLE: %fixnum-bitand ;
C: %fixnum-bitand make-vop ; : %fixnum-bitand 3-vop <%fixnum-bitand> ;
TUPLE: %fixnum-bitor ;
C: %fixnum-bitor make-vop ; : %fixnum-bitor 3-vop <%fixnum-bitor> ;
TUPLE: %fixnum-bitxor ;
C: %fixnum-bitxor make-vop ; : %fixnum-bitxor 3-vop <%fixnum-bitxor> ;
TUPLE: %fixnum-bitnot ;
C: %fixnum-bitnot make-vop ; : %fixnum-bitnot 2-vop <%fixnum-bitnot> ;
VOP: %fixnum<= : %fixnum<= 3-vop <%fixnum<=> ;
VOP: %fixnum< : %fixnum< 3-vop <%fixnum<> ;
VOP: %fixnum>= : %fixnum>= 3-vop <%fixnum>=> ;
VOP: %fixnum> : %fixnum> 3-vop <%fixnum>> ;
VOP: %eq? : %eq? 3-vop <%eq?> ;
TUPLE: %fixnum<= ;
C: %fixnum<= make-vop ; : %fixnum<= 3-vop <%fixnum<=> ;
TUPLE: %fixnum< ;
C: %fixnum< make-vop ; : %fixnum< 3-vop <%fixnum<> ;
TUPLE: %fixnum>= ;
C: %fixnum>= make-vop ; : %fixnum>= 3-vop <%fixnum>=> ;
TUPLE: %fixnum> ;
C: %fixnum> make-vop ; : %fixnum> 3-vop <%fixnum>> ;
TUPLE: %eq? ;
C: %eq? make-vop ; : %eq? 3-vop <%eq?> ;
! At the VOP level, the 'shift' operation is split into five
! distinct operations:
@ -207,27 +246,35 @@ VOP: %eq? : %eq? 3-vop <%eq?> ;
! - shifts with a small negative count: %fixnum>>
! - shifts with a small negative count: %fixnum>>
! - shifts with a large negative count: %fixnum-sgn
VOP: %fixnum<< : %fixnum<< 3-vop <%fixnum<<> ;
VOP: %fixnum>> : %fixnum>> 3-vop <%fixnum>>> ;
TUPLE: %fixnum<< ;
C: %fixnum<< make-vop ; : %fixnum<< 3-vop <%fixnum<<> ;
TUPLE: %fixnum>> ;
C: %fixnum>> make-vop ; : %fixnum>> 3-vop <%fixnum>>> ;
! due to x86 limitations the destination of this VOP must be
! vreg 2 (EDX), and the source must be vreg 0 (EAX).
VOP: %fixnum-sgn : %fixnum-sgn src/dest-vop <%fixnum-sgn> ;
TUPLE: %fixnum-sgn ;
C: %fixnum-sgn make-vop ; : %fixnum-sgn src/dest-vop <%fixnum-sgn> ;
! Integer comparison followed by a conditional branch is
! optimized
VOP: %jump-fixnum<=
TUPLE: %jump-fixnum<= ;
C: %jump-fixnum<= make-vop ;
: %jump-fixnum<= 2-in/label-vop <%jump-fixnum<=> ;
VOP: %jump-fixnum<
TUPLE: %jump-fixnum< ;
C: %jump-fixnum< make-vop ;
: %jump-fixnum< 2-in/label-vop <%jump-fixnum<> ;
VOP: %jump-fixnum>=
TUPLE: %jump-fixnum>= ;
C: %jump-fixnum>= make-vop ;
: %jump-fixnum>= 2-in/label-vop <%jump-fixnum>=> ;
VOP: %jump-fixnum>
TUPLE: %jump-fixnum> ;
C: %jump-fixnum> make-vop ;
: %jump-fixnum> 2-in/label-vop <%jump-fixnum>> ;
VOP: %jump-eq?
TUPLE: %jump-eq? ;
C: %jump-eq? make-vop ;
: %jump-eq? 2-in/label-vop <%jump-eq?> ;
: fast-branch ( class -- class )
@ -245,18 +292,22 @@ PREDICATE: tuple fast-branch
class fast-branch ;
! some slightly optimized inline assembly
VOP: %type
TUPLE: %type ;
C: %type make-vop ;
: %type ( vreg ) <vreg> dest-vop <%type> ;
M: %type basic-block? drop t ;
VOP: %arithmetic-type
TUPLE: %arithmetic-type ;
C: %arithmetic-type make-vop ;
: %arithmetic-type <vreg> dest-vop <%arithmetic-type> ;
VOP: %tag-fixnum
TUPLE: %tag-fixnum ;
C: %tag-fixnum make-vop ;
: %tag-fixnum <vreg> dest-vop <%tag-fixnum> ;
M: %tag-fixnum basic-block? drop t ;
VOP: %untag-fixnum
TUPLE: %untag-fixnum ;
C: %untag-fixnum make-vop ;
: %untag-fixnum <vreg> dest-vop <%untag-fixnum> ;
M: %untag-fixnum basic-block? drop t ;
@ -266,44 +317,57 @@ M: %untag-fixnum basic-block? drop t ;
: check-src ( vop reg -- )
swap vop-in-1 = [ "bad VOP source" throw ] unless ;
VOP: %getenv
TUPLE: %getenv ;
C: %getenv make-vop ;
: %getenv swap src/dest-vop <%getenv> ;
M: %getenv basic-block? drop t ;
VOP: %setenv
TUPLE: %setenv ;
C: %setenv make-vop ;
: %setenv 2-in-vop <%setenv> ;
M: %setenv basic-block? drop t ;
! alien operations
VOP: %parameters
TUPLE: %parameters ;
C: %parameters make-vop ;
: %parameters ( n -- vop ) src-vop <%parameters> ;
VOP: %parameter
TUPLE: %parameter ;
C: %parameter make-vop ;
: %parameter ( n -- vop ) src-vop <%parameter> ;
VOP: %cleanup
TUPLE: %cleanup ;
C: %cleanup make-vop ;
: %cleanup ( n -- vop ) src-vop <%cleanup> ;
VOP: %unbox
TUPLE: %unbox ;
C: %unbox make-vop ;
: %unbox ( [[ n func ]] -- vop ) src-vop <%unbox> ;
VOP: %unbox-float
TUPLE: %unbox-float ;
C: %unbox-float make-vop ;
: %unbox-float ( [[ n func ]] -- vop ) src-vop <%unbox-float> ;
VOP: %unbox-double
TUPLE: %unbox-double ;
C: %unbox-double make-vop ;
: %unbox-double ( [[ n func ]] -- vop ) src-vop <%unbox-double> ;
VOP: %box
TUPLE: %box ;
C: %box make-vop ;
: %box ( func -- vop ) src-vop <%box> ;
VOP: %box-float
TUPLE: %box-float ;
C: %box-float make-vop ;
: %box-float ( func -- vop ) src-vop <%box-float> ;
VOP: %box-double
TUPLE: %box-double ;
C: %box-double make-vop ;
: %box-double ( [[ n func ]] -- vop ) src-vop <%box-double> ;
VOP: %alien-invoke
TUPLE: %alien-invoke ;
C: %alien-invoke make-vop ;
: %alien-invoke ( func -- vop ) src-vop <%alien-invoke> ;
VOP: %alien-global
TUPLE: %alien-global ;
C: %alien-global make-vop ;
: %alien-global ( global -- vop ) src-vop <%alien-global> ;

2
library/inference/branches.factor
View File

@ -124,5 +124,3 @@ USE: kernel-internals
pop-literal vtable>list
#dispatch pop-d drop infer-branches
] "infer" set-word-prop
\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop

32
library/inference/dataflow.factor
View File

@ -14,11 +14,6 @@ TUPLE: node effect param in-d out-d in-r out-r
: make-node ( effect param in-d out-d in-r out-r node -- node )
[ >r f <node> r> set-delegate ] keep ;
: NODE:
#! Followed by a node name.
scan dup [ ] define-tuple
create-in [ make-node ] define-constructor ; parsing
: empty-node f f f f f f f f f ;
: param-node ( label) f swap f f f f f ;
: in-d-node ( inputs) >r f f r> f f f f ;
@ -27,31 +22,40 @@ TUPLE: node effect param in-d out-d in-r out-r
: d-tail ( n -- list ) meta-d get tail* >list ;
: r-tail ( n -- list ) meta-r get tail* >list ;
NODE: #label
TUPLE: #label ;
C: #label make-node ;
: #label ( label -- node ) param-node <#label> ;
NODE: #call
TUPLE: #call ;
C: #call make-node ;
: #call ( word -- node ) param-node <#call> ;
NODE: #call-label
TUPLE: #call-label ;
C: #call-label make-node ;
: #call-label ( label -- node ) param-node <#call-label> ;
NODE: #push
TUPLE: #push ;
C: #push make-node ;
: #push ( outputs -- node ) d-tail out-d-node <#push> ;
NODE: #drop
TUPLE: #drop ;
C: #drop make-node ;
: #drop ( inputs -- node ) d-tail in-d-node <#drop> ;
NODE: #values
TUPLE: #values ;
C: #values make-node ;
: #values ( -- node ) meta-d get >list in-d-node <#values> ;
NODE: #return
TUPLE: #return ;
C: #return make-node ;
: #return ( -- node ) meta-d get >list in-d-node <#return> ;
NODE: #ifte
TUPLE: #ifte ;
C: #ifte make-node ;
: #ifte ( in -- node ) 1 d-tail in-d-node <#ifte> ;
NODE: #dispatch
TUPLE: #dispatch ;
C: #dispatch make-node ;
: #dispatch ( in -- node ) 1 d-tail in-d-node <#dispatch> ;
: node-inputs ( d-count r-count node -- )

4
library/inference/words.factor
View File

@ -129,10 +129,6 @@ M: compound apply-word ( word -- )
rethrow
] catch ;
: no-base-case ( word -- )
word-name " does not have a base case." append
inference-error ;
: recursive-word ( word [[ label quot ]] -- )
#! Handle a recursive call, by either applying a previously
#! inferred base case, or raising an error. If the recursive

2
library/sdl/sdl-event.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: sdl USING: alien generic kernel ;
IN: sdl USING: alien generic kernel kernel-internals ;
BEGIN-ENUM: 0
ENUM: SDL_NOEVENT ! Unused (do not remove)

22
library/test/inference.factor
View File

@ -2,24 +2,6 @@ IN: temporary
USING: generic inference kernel lists math math-internals
namespaces parser sequences test vectors ;
! [ [ [ object object ] f ] ]
! [ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ]
! unit-test
!
! [ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ]
! [
! [ [ vector ] [ cons vector cons integer object cons ] ]
! [ [ vector ] [ cons vector cons ] ]
! decompose
! ] unit-test
!
! [ [ [ object ] [ object ] ] ]
! [
! [ [ object number ] [ object ] ]
! [ [ object number ] [ object ] ]
! decompose
! ] unit-test
: old-effect ( [ in-types out-types ] -- [[ in out ]] )
uncons car length >r length r> cons ;
@ -232,3 +214,7 @@ M: real iterate drop ;
[ [[ 2 1 ]] ] [ [ contains? ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ remove ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ prune ] infer old-effect ] unit-test
: no-base-case dup [ no-base-case ] [ no-base-case ] ifte ;
[ [ no-base-case ] infer ] unit-test-fails

1
library/test/sequences.factor
View File

@ -11,3 +11,4 @@ USING: lists sequences test vectors ;
[ { 1 2 } { 4 5 } ] [ 2 { 1 2 3 4 5 } cut* ] unit-test
[ { 3 4 } ] [ 2 4 1 10 <range> subseq ] unit-test
[ { 3 4 } ] [ 0 2 2 4 1 10 <range> <slice> subseq ] unit-test
[ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test

8
library/unix/syscalls.factor
View File

@ -37,6 +37,14 @@ END-STRUCT
: poll ( pollfds nfds timeout -- n )
"int" "libc" "poll" [ "pollfd*" "uint" "int" ] alien-invoke ;
BEGIN-STRUCT: timeval
FIELD: long sec
FIELD: long usec
END-STRUCT
: select ( nfds readfds writefds exceptfds timeout -- n )
"int" "libc" "select" [ "int" "void*" "void*" "void*" "timeval*" ] alien-invoke ;
BEGIN-STRUCT: hostent
FIELD: char* name
FIELD: void* aliases

2
library/words.factor
View File

@ -50,8 +50,6 @@ M: word set-allot-count ( n w -- ) 7 set-integer-slot ;
! words can be recompiled when redefined.
SYMBOL: crossref
global [ <namespace> crossref set ] bind
: (add-crossref)
dup word? [
crossref get [ dupd nest set-hash ] bind

1
native/primitives.c
View File

@ -7,6 +7,7 @@ void* primitives[] = {
primitive_execute,
primitive_call,
primitive_ifte,
primitive_dispatch,
primitive_cons,
primitive_vector,
primitive_string_compare,

7
native/run.c
View File

@ -94,6 +94,13 @@ void primitive_ifte(void)
call(cond == F ? f : t);
}
void primitive_dispatch(void)
{
F_VECTOR *v = (F_VECTOR*)UNTAG(dpop());
F_FIXNUM n = untag_fixnum_fast(dpop());
call(get(AREF(untag_array_fast(v->array),n)));
}
void primitive_getenv(void)
{
F_FIXNUM e = untag_fixnum_fast(dpeek());

1
native/run.h
View File

@ -93,5 +93,6 @@ void dosym(F_WORD* word);
void primitive_execute(void);
void primitive_call(void);
void primitive_ifte(void);
void primitive_dispatch(void);
void primitive_getenv(void);
void primitive_setenv(void);

31
native/string.c
View File

@ -31,7 +31,7 @@ void primitive_rehash_string(void)
}
/* untagged */
F_STRING* string(CELL capacity, CELL fill)
F_STRING *string(CELL capacity, CELL fill)
{
CELL i;
@ -73,7 +73,7 @@ void primitive_resize_string(void)
dpush(tag_object(resize_string(string,capacity,F)));
}
F_STRING* memory_to_string(const BYTE* string, CELL length)
F_STRING *memory_to_string(const BYTE* string, CELL length)
{
F_STRING* s = allot_string(length);
CELL i;
@ -92,24 +92,24 @@ F_STRING* memory_to_string(const BYTE* string, CELL length)
void primitive_memory_to_string(void)
{
CELL length = unbox_unsigned_cell();
BYTE* string = (BYTE*)unbox_unsigned_cell();
BYTE *string = (BYTE*)unbox_unsigned_cell();
dpush(tag_object(memory_to_string(string,length)));
}
/* untagged */
F_STRING* from_c_string(const char* c_string)
F_STRING *from_c_string(const char *c_string)
{
return memory_to_string((BYTE*)c_string,strlen(c_string));
}
/* FFI calls this */
void box_c_string(const char* c_string)
void box_c_string(const char *c_string)
{
dpush(tag_object(from_c_string(c_string)));
dpush(c_string ? tag_object(from_c_string(c_string)) : F);
}
/* untagged */
char* to_c_string(F_STRING* s)
char *to_c_string(F_STRING *s)
{
CELL i;
CELL capacity = string_capacity(s);
@ -123,7 +123,7 @@ char* to_c_string(F_STRING* s)
return to_c_string_unchecked(s);
}
void string_to_memory(F_STRING* s, BYTE* string)
void string_to_memory(F_STRING *s, BYTE *string)
{
CELL i;
CELL capacity = string_capacity(s);
@ -133,26 +133,27 @@ void string_to_memory(F_STRING* s, BYTE* string)
void primitive_string_to_memory(void)
{
BYTE* address = (BYTE*)unbox_unsigned_cell();
F_STRING* str = untag_string(dpop());
BYTE *address = (BYTE*)unbox_unsigned_cell();
F_STRING *str = untag_string(dpop());
string_to_memory(str,address);
}
/* untagged */
char* to_c_string_unchecked(F_STRING* s)
char *to_c_string_unchecked(F_STRING *s)
{
CELL capacity = string_capacity(s);
F_STRING* _c_str = allot_string(capacity / CHARS + 1);
BYTE* c_str = (BYTE*)(_c_str + 1);
F_STRING *_c_str = allot_string(capacity / CHARS + 1);
BYTE *c_str = (BYTE*)(_c_str + 1);
string_to_memory(s,c_str);
c_str[capacity] = '\0';
return (char*)c_str;
}
/* FFI calls this */
char* unbox_c_string(void)
char *unbox_c_string(void)
{
return to_c_string(untag_string(dpop()));
CELL str = dpop();
return (str ? to_c_string(untag_string(str)) : NULL);
}
/* FFI calls this */