release
import-0.78
nomennescio
commit
24979f3de8
13
CHANGES.html
13
CHANGES.html
|
|
@ -4,6 +4,15 @@
|
|||
<head><title>Factor change log</title></head>
|
||||
<body>
|
||||
|
||||
<h1>Factor 0.78:</h1>
|
||||
|
||||
<ul>
|
||||
<li>Consecutive stack operations are now composed into single shuffle expressions.</li>
|
||||
<li>The return stack pointer is now stored in a register on x86.</li>
|
||||
<li>Non-recursive inline words are compiled more efficiently.</li>
|
||||
<li>Fix PowerPC bootstrap issue, and <code>fixnum-shift</code>, <code>fixnum/i</code> overflow.</li>
|
||||
</ul>
|
||||
|
||||
<h1>Factor 0.77:</h1>
|
||||
|
||||
<ul>
|
||||
|
|
@ -22,6 +31,8 @@
|
|||
<li>Collections:
|
||||
|
||||
<ul>
|
||||
<li><code>sort ( seq quot -- | quot: elt elt -- -1/0/1 )</code> combinator now works with any sequence, not just a list. The comparator also has to return a signed integer, not just a boolean. It is much faster than the old sorting algorithm.</li>
|
||||
<li><code>binsearch ( elt seq quot -- i | quot: elt elt -- -1/0/1 )</code> and <code>binsearch ( elt seq quot -- elt | quot: elt elt -- -1/0/1 )</code> combinators perform a binary search on a sorted sequence.</li>
|
||||
<li><code>2each ( seq seq quot -- quot: elt -- elt )</code> combinator</li>
|
||||
<li><code>join ( seq glue -- seq )</code> word. Takes a sequence of sequences, and constructs a new sequence with the glue in between each sequence. For example:
|
||||
<pre> [ "usr" "bin" "grep" ] "/" join
|
||||
|
|
@ -79,7 +90,7 @@ make-sbuf ==> SBUF" " make
|
|||
<li>New <code>sleep ( ms -- )</code> word pauses current thread for a number of milliseconds.</li>
|
||||
<li>New <code>with-datastack ( stack word -- stack )</code> combinator.</li>
|
||||
<li>New <code>cond ( conditions -- )</code> combinator. It behaves like a set of nested <code>ifte</code>s, and compiles if each branch has the same stack effect. See its documentation comment for details.</li>
|
||||
<li>Formally documented method combination (<code>G:</code> syntax) in handbook.
|
||||
<li>Formally documented method combination (<code>G:</code> syntax) in handbook.</li>
|
||||
<li>Erlang/Termite-style concurrency library in <code>contrib/concurrency</code> (Chris Double).</li>
|
||||
<li>Completely redid infix algebra in <code>contrib/algebra/</code>. Now, vector operations are possible
|
||||
and the syntax doesn't use so many spaces. New way to write the quadratic formula:
|
||||
|
|
|
|||
|
|
@ -48,24 +48,25 @@
|
|||
|
||||
+ compiler:
|
||||
|
||||
- removing unneeded #label
|
||||
- flushing optimization
|
||||
- compile-byte/cell: instantiating aliens
|
||||
- fix fixnum<< and /i overflow on PowerPC
|
||||
- simplifier:
|
||||
- kill replace after a peek
|
||||
- merge inc-d's across VOPs that don't touch the stack
|
||||
- intrinsic char-slot set-char-slot integer-slot set-integer-slot
|
||||
- fix fixnum/mod overflow on PowerPC
|
||||
- eliminate simplifier
|
||||
- intrinsic char-slot set-char-slot
|
||||
- [ [ dup call ] dup call ] infer hangs
|
||||
- declarations
|
||||
- the invalid recursion form case needs to be fixed, for inlines too
|
||||
- #jump-f #jump-f-label
|
||||
- re-introduce #target-label => #target optimization
|
||||
- recursion is iffy; if the stack at the recursive call doesn't match
|
||||
up, throw an error
|
||||
- remove %fixnum-</<=/>/>=, always use %jump-* form
|
||||
- remove %jump-t, use %jump-eq? f instead
|
||||
- kill dead code after 'throw'
|
||||
- better type inference
|
||||
|
||||
+ kernel:
|
||||
|
||||
- better handling of random arrangements of html words when
|
||||
prettyprinting
|
||||
- friendlier .factor-rc load error handling
|
||||
- reader syntax for arrays, byte arrays, displaced aliens
|
||||
- out of memory error when printing global namespace
|
||||
- first time hash/vector is grown, set size to something big
|
||||
|
|
|
|||
BIN
boot.image.be32
BIN
boot.image.be32
Binary file not shown.
BIN
boot.image.be64
BIN
boot.image.be64
Binary file not shown.
BIN
boot.image.le32
BIN
boot.image.le32
Binary file not shown.
BIN
boot.image.le64
BIN
boot.image.le64
Binary file not shown.
|
|
@ -2627,10 +2627,11 @@ Outputs \texttt{t} if the quotation yields true when applied to each element, ot
|
|||
\ordinaryword{monotonic?}{monotonic?~( seq quot -- ?~)}
|
||||
\texttt{quot:~element element -- ?}\\
|
||||
}
|
||||
Tests if all elements of the sequence are equivalent under the relation. The quotation should be an equality relation (see \ref{equality}), otherwise the result will not be useful. This is implemented by vacuously outputting \verb|t| if the sequence is empty, or otherwise, by applying the quotation to each element together with the first element in turn, and testing if it always yields a true value. Usually, this word is used to test if all elements of a sequence are equal, or the same element:
|
||||
Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation. Examples:
|
||||
\begin{verbatim}
|
||||
[ = ] every?
|
||||
[ eq? ] every?
|
||||
[ = ] monotonic? ! is every element equal?
|
||||
[ eq? ] monotonic? ! is every element identical?
|
||||
[ < ] monotonic? ! is the sequence increasing?
|
||||
\end{verbatim}
|
||||
|
||||
A pair of utility words test of every element in a sequence is true, or if the sequence contains at least one true element.
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
#!/bin/sh
|
||||
makeindex -s $1.ist -t $1.glg -o $1.gls $1.glo
|
||||
|
|
@ -95,137 +95,3 @@ SYMBOL: c-types
|
|||
over "*" append over "*" append (typedef) (typedef) ;
|
||||
|
||||
global [ c-types nest drop ] bind
|
||||
|
||||
[
|
||||
[ alien-unsigned-cell <alien> ] "getter" set
|
||||
[
|
||||
>r >r alien-address r> r> set-alien-unsigned-cell
|
||||
] "setter" set
|
||||
cell "width" set
|
||||
cell "align" set
|
||||
"box_alien" "boxer" set
|
||||
"unbox_alien" "unboxer" set
|
||||
] "void*" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-8 ] "getter" set
|
||||
[ set-alien-signed-8 ] "setter" set
|
||||
8 "width" set
|
||||
8 "align" set
|
||||
"box_signed_8" "boxer" set
|
||||
"unbox_signed_8" "unboxer" set
|
||||
] "longlong" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-8 ] "getter" set
|
||||
[ set-alien-unsigned-8 ] "setter" set
|
||||
8 "width" set
|
||||
8 "align" set
|
||||
"box_unsinged_8" "boxer" set
|
||||
"unbox_unsigned_8" "unboxer" set
|
||||
] "ulonglong" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-4 ] "getter" set
|
||||
[ set-alien-signed-4 ] "setter" set
|
||||
4 "width" set
|
||||
4 "align" set
|
||||
"box_signed_4" "boxer" set
|
||||
"unbox_signed_4" "unboxer" set
|
||||
] "int" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 ] "getter" set
|
||||
[ set-alien-unsigned-4 ] "setter" set
|
||||
4 "width" set
|
||||
4 "align" set
|
||||
"box_unsigned_4" "boxer" set
|
||||
"unbox_unsigned_4" "unboxer" set
|
||||
] "uint" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-2 ] "getter" set
|
||||
[ set-alien-signed-2 ] "setter" set
|
||||
2 "width" set
|
||||
2 "align" set
|
||||
"box_signed_2" "boxer" set
|
||||
"unbox_signed_2" "unboxer" set
|
||||
] "short" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-2 ] "getter" set
|
||||
[ set-alien-unsigned-2 ] "setter" set
|
||||
2 "width" set
|
||||
2 "align" set
|
||||
"box_unsigned_2" "boxer" set
|
||||
"unbox_unsigned_2" "unboxer" set
|
||||
] "ushort" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-1 ] "getter" set
|
||||
[ set-alien-signed-1 ] "setter" set
|
||||
1 "width" set
|
||||
1 "align" set
|
||||
"box_signed_1" "boxer" set
|
||||
"unbox_signed_1" "unboxer" set
|
||||
] "char" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-1 ] "getter" set
|
||||
[ set-alien-unsigned-1 ] "setter" set
|
||||
1 "width" set
|
||||
1 "align" set
|
||||
"box_unsigned_1" "boxer" set
|
||||
"unbox_unsigned_1" "unboxer" set
|
||||
] "uchar" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-c-string ] "getter" set
|
||||
[ set-alien-c-string ] "setter" set
|
||||
cell "width" set
|
||||
cell "align" set
|
||||
"box_c_string" "boxer" set
|
||||
"unbox_c_string" "unboxer" set
|
||||
] "char*" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 ] "getter" set
|
||||
[ set-alien-unsigned-4 ] "setter" set
|
||||
cell "width" set
|
||||
cell "align" set
|
||||
"box_utf16_string" "boxer" set
|
||||
"unbox_utf16_string" "unboxer" set
|
||||
] "ushort*" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 0 = not ] "getter" set
|
||||
[ 1 0 ? set-alien-unsigned-4 ] "setter" set
|
||||
cell "width" set
|
||||
cell "align" set
|
||||
"box_boolean" "boxer" set
|
||||
"unbox_boolean" "unboxer" set
|
||||
] "bool" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-float ] "getter" set
|
||||
[ set-alien-float ] "setter" set
|
||||
cell "width" set
|
||||
cell "align" set
|
||||
"box_float" "boxer" set
|
||||
"unbox_float" "unboxer" set
|
||||
<< float-regs f 4 >> "reg-class" set
|
||||
] "float" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-double ] "getter" set
|
||||
[ set-alien-double ] "setter" set
|
||||
cell 2 * "width" set
|
||||
cell 2 * "align" set
|
||||
"box_double" "boxer" set
|
||||
"unbox_double" "unboxer" set
|
||||
<< float-regs f 8 >> "reg-class" set
|
||||
] "double" define-primitive-type
|
||||
|
||||
! FIXME for 64-bit platforms
|
||||
"int" "long" typedef
|
||||
"uint" "ulong" typedef
|
||||
|
|
|
|||
|
|
@ -0,0 +1,135 @@
|
|||
USING: alien compiler-backend kernel math namespaces ;
|
||||
|
||||
[
|
||||
[ alien-unsigned-cell <alien> ] "getter" set
|
||||
[
|
||||
>r >r alien-address r> r> set-alien-unsigned-cell
|
||||
] "setter" set
|
||||
cell "width" set
|
||||
cell "align" set
|
||||
"box_alien" "boxer" set
|
||||
"unbox_alien" "unboxer" set
|
||||
] "void*" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-8 ] "getter" set
|
||||
[ set-alien-signed-8 ] "setter" set
|
||||
8 "width" set
|
||||
8 "align" set
|
||||
"box_signed_8" "boxer" set
|
||||
"unbox_signed_8" "unboxer" set
|
||||
] "longlong" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-8 ] "getter" set
|
||||
[ set-alien-unsigned-8 ] "setter" set
|
||||
8 "width" set
|
||||
8 "align" set
|
||||
"box_unsinged_8" "boxer" set
|
||||
"unbox_unsigned_8" "unboxer" set
|
||||
] "ulonglong" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-4 ] "getter" set
|
||||
[ set-alien-signed-4 ] "setter" set
|
||||
4 "width" set
|
||||
4 "align" set
|
||||
"box_signed_4" "boxer" set
|
||||
"unbox_signed_4" "unboxer" set
|
||||
] "int" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 ] "getter" set
|
||||
[ set-alien-unsigned-4 ] "setter" set
|
||||
4 "width" set
|
||||
4 "align" set
|
||||
"box_unsigned_4" "boxer" set
|
||||
"unbox_unsigned_4" "unboxer" set
|
||||
] "uint" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-2 ] "getter" set
|
||||
[ set-alien-signed-2 ] "setter" set
|
||||
2 "width" set
|
||||
2 "align" set
|
||||
"box_signed_2" "boxer" set
|
||||
"unbox_signed_2" "unboxer" set
|
||||
] "short" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-2 ] "getter" set
|
||||
[ set-alien-unsigned-2 ] "setter" set
|
||||
2 "width" set
|
||||
2 "align" set
|
||||
"box_unsigned_2" "boxer" set
|
||||
"unbox_unsigned_2" "unboxer" set
|
||||
] "ushort" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-signed-1 ] "getter" set
|
||||
[ set-alien-signed-1 ] "setter" set
|
||||
1 "width" set
|
||||
1 "align" set
|
||||
"box_signed_1" "boxer" set
|
||||
"unbox_signed_1" "unboxer" set
|
||||
] "char" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-1 ] "getter" set
|
||||
[ set-alien-unsigned-1 ] "setter" set
|
||||
1 "width" set
|
||||
1 "align" set
|
||||
"box_unsigned_1" "boxer" set
|
||||
"unbox_unsigned_1" "unboxer" set
|
||||
] "uchar" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-c-string ] "getter" set
|
||||
[ set-alien-c-string ] "setter" set
|
||||
cell "width" set
|
||||
cell "align" set
|
||||
"box_c_string" "boxer" set
|
||||
"unbox_c_string" "unboxer" set
|
||||
] "char*" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 ] "getter" set
|
||||
[ set-alien-unsigned-4 ] "setter" set
|
||||
cell "width" set
|
||||
cell "align" set
|
||||
"box_utf16_string" "boxer" set
|
||||
"unbox_utf16_string" "unboxer" set
|
||||
] "ushort*" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 0 = not ] "getter" set
|
||||
[ 1 0 ? set-alien-unsigned-4 ] "setter" set
|
||||
cell "width" set
|
||||
cell "align" set
|
||||
"box_boolean" "boxer" set
|
||||
"unbox_boolean" "unboxer" set
|
||||
] "bool" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-float ] "getter" set
|
||||
[ set-alien-float ] "setter" set
|
||||
cell "width" set
|
||||
cell "align" set
|
||||
"box_float" "boxer" set
|
||||
"unbox_float" "unboxer" set
|
||||
<< float-regs f 4 >> "reg-class" set
|
||||
] "float" define-primitive-type
|
||||
|
||||
[
|
||||
[ alien-double ] "getter" set
|
||||
[ set-alien-double ] "setter" set
|
||||
cell 2 * "width" set
|
||||
cell 2 * "align" set
|
||||
"box_double" "boxer" set
|
||||
"unbox_double" "unboxer" set
|
||||
<< float-regs f 8 >> "reg-class" set
|
||||
] "double" define-primitive-type
|
||||
|
||||
! FIXME for 64-bit platforms
|
||||
"int" "long" typedef
|
||||
"uint" "ulong" typedef
|
||||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: alien
|
||||
USING: assembler compiler errors generic hashtables kernel lists
|
||||
math namespaces parser sequences strings words ;
|
||||
USING: assembler compiler compiler-backend errors generic
|
||||
hashtables kernel lists math namespaces parser sequences strings
|
||||
words ;
|
||||
|
||||
! Some code for interfacing with C structures.
|
||||
|
||||
|
|
|
|||
|
|
@ -82,7 +82,6 @@ sequences io vectors words ;
|
|||
"/library/generic/math-combination.factor"
|
||||
"/library/generic/predicate.factor"
|
||||
"/library/generic/union.factor"
|
||||
"/library/generic/complement.factor"
|
||||
"/library/generic/tuple.factor"
|
||||
|
||||
"/library/syntax/generic.factor"
|
||||
|
|
@ -113,6 +112,9 @@ sequences io vectors words ;
|
|||
|
||||
"/library/bootstrap/image.factor"
|
||||
|
||||
"/library/compiler/architecture.factor"
|
||||
|
||||
"/library/inference/shuffle.factor"
|
||||
"/library/inference/dataflow.factor"
|
||||
"/library/inference/inference.factor"
|
||||
"/library/inference/branches.factor"
|
||||
|
|
@ -124,6 +126,7 @@ sequences io vectors words ;
|
|||
"/library/inference/optimizer.factor"
|
||||
"/library/inference/inline-methods.factor"
|
||||
"/library/inference/known-words.factor"
|
||||
"/library/inference/stack.factor"
|
||||
"/library/inference/call-optimizers.factor"
|
||||
"/library/inference/print-dataflow.factor"
|
||||
|
||||
|
|
@ -132,6 +135,7 @@ sequences io vectors words ;
|
|||
"/library/compiler/xt.factor"
|
||||
"/library/compiler/vops.factor"
|
||||
"/library/compiler/linearizer.factor"
|
||||
"/library/compiler/stack.factor"
|
||||
"/library/compiler/intrinsics.factor"
|
||||
"/library/compiler/simplifier.factor"
|
||||
"/library/compiler/generator.factor"
|
||||
|
|
|
|||
|
|
@ -18,20 +18,24 @@ words ;
|
|||
|
||||
cpu "x86" = [
|
||||
"/library/compiler/x86/assembler.factor"
|
||||
"/library/compiler/x86/architecture.factor"
|
||||
"/library/compiler/x86/generator.factor"
|
||||
"/library/compiler/x86/slots.factor"
|
||||
"/library/compiler/x86/stack.factor"
|
||||
"/library/compiler/x86/fixnum.factor"
|
||||
"/library/compiler/x86/alien.factor"
|
||||
"/library/alien/primitive-types.factor"
|
||||
] pull-in
|
||||
|
||||
cpu "ppc" = [
|
||||
"/library/compiler/ppc/assembler.factor"
|
||||
"/library/compiler/ppc/architecture.factor"
|
||||
"/library/compiler/ppc/generator.factor"
|
||||
"/library/compiler/ppc/slots.factor"
|
||||
"/library/compiler/ppc/stack.factor"
|
||||
"/library/compiler/ppc/fixnum.factor"
|
||||
"/library/compiler/ppc/alien.factor"
|
||||
"/library/alien/primitive-types.factor"
|
||||
] pull-in
|
||||
|
||||
"statically-linked" get [
|
||||
|
|
|
|||
|
|
@ -103,10 +103,21 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind
|
|||
{ "update-xt" "words" }
|
||||
{ "compiled?" "words" }
|
||||
{ "drop" "kernel" }
|
||||
{ "2drop" "kernel" }
|
||||
{ "3drop" "kernel" }
|
||||
{ "dup" "kernel" }
|
||||
{ "swap" "kernel" }
|
||||
{ "2dup" "kernel" }
|
||||
{ "3dup" "kernel" }
|
||||
{ "rot" "kernel" }
|
||||
{ "-rot" "kernel" }
|
||||
{ "dupd" "kernel" }
|
||||
{ "swapd" "kernel" }
|
||||
{ "nip" "kernel" }
|
||||
{ "2nip" "kernel" }
|
||||
{ "tuck" "kernel" }
|
||||
{ "over" "kernel" }
|
||||
{ "pick" "kernel" }
|
||||
{ "swap" "kernel" }
|
||||
{ ">r" "kernel" }
|
||||
{ "r>" "kernel" }
|
||||
{ "eq?" "kernel" }
|
||||
|
|
@ -202,10 +213,21 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind
|
|||
|
||||
{
|
||||
{ "drop" "kernel" " x -- " }
|
||||
{ "2drop" "kernel" " x y -- " }
|
||||
{ "3drop" "kernel" " x y z -- " }
|
||||
{ "dup" "kernel" " x -- x x " }
|
||||
{ "swap" "kernel" " x y -- y x " }
|
||||
{ "2dup" "kernel" " x y -- x y x y " }
|
||||
{ "3dup" "kernel" " x y z -- x y z x y z " }
|
||||
{ "rot" "kernel" " x y z -- y z x " }
|
||||
{ "-rot" "kernel" " x y z -- z x y " }
|
||||
{ "dupd" "kernel" " x y -- x x y " }
|
||||
{ "swapd" "kernel" " x y z -- y x z " }
|
||||
{ "nip" "kernel" " x y -- y " }
|
||||
{ "2nip" "kernel" " x y z -- z " }
|
||||
{ "tuck" "kernel" " x y -- y x y " }
|
||||
{ "over" "kernel" " x y -- x y x " }
|
||||
{ "pick" "kernel" " x y z -- x y z x " }
|
||||
{ "swap" "kernel" " x y -- y x " }
|
||||
{ ">r" "kernel" " x -- r: x " }
|
||||
{ "r>" "kernel" " r: x -- x " }
|
||||
{ "datastack" "kernel" " -- ds " }
|
||||
|
|
@ -327,6 +349,12 @@ null null define-class
|
|||
|
||||
"displaced-alien" "alien" create 20 "displaced-alien?" "alien" create { } define-builtin
|
||||
|
||||
! Define general-t type, which is any object that is not f.
|
||||
"general-t" "kernel" create dup define-symbol
|
||||
"general-t?" "kernel" create
|
||||
"f" "!syntax" lookup builtins get remove [ ] subset
|
||||
define-union
|
||||
|
||||
FORGET: builtin-predicate
|
||||
FORGET: register-builtin
|
||||
FORGET: define-builtin
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ kernel-internals ;
|
|||
! if it is somewhat 'implementation detail', is in the
|
||||
! public 'hashtables' vocabulary.
|
||||
|
||||
: bucket-count ( hash -- n ) hash-array length ;
|
||||
: bucket-count ( hash -- n ) hash-array array-capacity ;
|
||||
|
||||
IN: kernel-internals
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,12 @@
|
|||
IN: compiler-backend
|
||||
|
||||
! A few things the front-end needs to know about the back-end.
|
||||
|
||||
DEFER: cell ( -- n )
|
||||
#! Word size
|
||||
|
||||
DEFER: fixnum-imm? ( -- ? )
|
||||
#! Can fixnum operations take immediate operands?
|
||||
|
||||
DEFER: vregs ( -- n )
|
||||
#! Number of vregs
|
||||
|
|
@ -1,21 +1,21 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: assembler
|
||||
USING: alien math memory kernel hashtables namespaces ;
|
||||
USING: alien compiler-backend math memory kernel hashtables
|
||||
namespaces ;
|
||||
|
||||
SYMBOL: interned-literals
|
||||
|
||||
: cell 4 ; inline
|
||||
: compiled-header HEX: 01c3babe ; inline
|
||||
|
||||
: compiled-byte ( a -- n )
|
||||
<alien> 0 alien-signed-1 ; inline
|
||||
f swap alien-signed-1 ; inline
|
||||
: set-compiled-byte ( n a -- )
|
||||
<alien> 0 set-alien-signed-1 ; inline
|
||||
f swap set-alien-signed-1 ; inline
|
||||
: compiled-cell ( a -- n )
|
||||
<alien> 0 alien-signed-cell ; inline
|
||||
f swap alien-signed-cell ; inline
|
||||
: set-compiled-cell ( n a -- )
|
||||
<alien> 0 set-alien-signed-cell ; inline
|
||||
f swap set-alien-signed-cell ; inline
|
||||
|
||||
: compile-aligned ( n -- )
|
||||
compiled-offset cell 2 * align set-compiled-offset ; inline
|
||||
|
|
|
|||
|
|
@ -6,21 +6,14 @@ kernel lists math namespaces prettyprint sequences words ;
|
|||
: supported-cpu? ( -- ? )
|
||||
cpu "unknown" = not ;
|
||||
|
||||
: check-architecture ( -- )
|
||||
supported-cpu? [
|
||||
"Unsupported CPU; compiler disabled" throw
|
||||
] unless ;
|
||||
|
||||
: compiling ( word -- word parameter )
|
||||
check-architecture "Compiling " write dup . dup word-def ;
|
||||
|
||||
GENERIC: (compile) ( word -- )
|
||||
|
||||
M: word (compile) drop ;
|
||||
|
||||
M: compound (compile) ( word -- )
|
||||
#! Should be called inside the with-compiler scope.
|
||||
compiling dataflow optimize linearize simplify generate ;
|
||||
"Compiling " write dup .
|
||||
dup word-def dataflow optimize linearize simplify generate ;
|
||||
|
||||
: precompile ( word -- )
|
||||
#! Print linear IR of word.
|
||||
|
|
@ -40,30 +33,18 @@ M: compound (compile) ( word -- )
|
|||
#! Compile the most recently defined word.
|
||||
"compile" get [ word compile ] when ; parsing
|
||||
|
||||
: cannot-compile ( word error -- )
|
||||
"Cannot compile " write swap . print-error ;
|
||||
|
||||
: try-compile ( word -- )
|
||||
[ compile ] [ [ cannot-compile ] when* ] catch ;
|
||||
[ compile ] [ error. ] catch ;
|
||||
|
||||
: compile-all ( -- ) [ try-compile ] each-word ;
|
||||
|
||||
: recompile ( word -- )
|
||||
dup update-xt compile ;
|
||||
|
||||
: compile-1 ( quot -- word )
|
||||
#! Compute a quotation into an uninterned word, for testing
|
||||
#! purposes.
|
||||
gensym [ swap define-compound ] keep dup compile execute ;
|
||||
|
||||
\ dataflow profile
|
||||
\ optimize profile
|
||||
\ linearize profile
|
||||
\ simplify profile
|
||||
\ generate profile
|
||||
\ kill-node profile
|
||||
\ partial-eval profile
|
||||
\ inline-method profile
|
||||
\ apply-identities profile
|
||||
\ subst-values profile
|
||||
\ split-branch profile
|
||||
: compile-1 ( quot -- )
|
||||
#! Compute and call a quotation.
|
||||
"compile" get [
|
||||
gensym [ swap define-compound ] keep dup compile execute
|
||||
] [
|
||||
call
|
||||
] ifte ;
|
||||
|
|
|
|||
|
|
@ -5,55 +5,6 @@ USING: assembler compiler-backend generic hashtables inference
|
|||
kernel kernel-internals lists math math-internals namespaces
|
||||
sequences vectors words ;
|
||||
|
||||
! Architecture description
|
||||
: fixnum-imm?
|
||||
#! Can fixnum operations take immediate operands?
|
||||
cpu "x86" = ;
|
||||
|
||||
\ dup [
|
||||
drop
|
||||
in-1
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ swap [
|
||||
drop
|
||||
in-2
|
||||
0 0 %replace-d ,
|
||||
1 1 %replace-d ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ over [
|
||||
drop
|
||||
0 1 %peek-d ,
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ pick [
|
||||
drop
|
||||
0 2 %peek-d ,
|
||||
1 %inc-d ,
|
||||
out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ >r [
|
||||
drop
|
||||
in-1
|
||||
1 %inc-r ,
|
||||
1 %dec-d ,
|
||||
0 0 %replace-r ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ r> [
|
||||
drop
|
||||
0 0 %peek-r ,
|
||||
1 %inc-d ,
|
||||
1 %dec-r ,
|
||||
out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
: node-peek ( node -- value ) node-in-d peek ;
|
||||
|
||||
: type-tag ( type -- tag )
|
||||
|
|
@ -80,13 +31,13 @@ sequences vectors words ;
|
|||
|
||||
\ slot [
|
||||
dup slot@ [
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-1
|
||||
0 swap slot@ %fast-slot ,
|
||||
] [
|
||||
drop
|
||||
in-2
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
0 %untag ,
|
||||
1 0 %slot ,
|
||||
] ifte out-1
|
||||
|
|
@ -94,14 +45,14 @@ sequences vectors words ;
|
|||
|
||||
\ set-slot [
|
||||
dup slot@ [
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-2
|
||||
2 %dec-d ,
|
||||
-2 %inc-d,
|
||||
slot@ >r 0 1 r> %fast-set-slot ,
|
||||
] [
|
||||
drop
|
||||
in-3
|
||||
3 %dec-d ,
|
||||
-3 %inc-d,
|
||||
1 %untag ,
|
||||
0 1 2 %set-slot ,
|
||||
] ifte
|
||||
|
|
@ -125,17 +76,17 @@ sequences vectors words ;
|
|||
] "intrinsic" set-word-prop
|
||||
|
||||
\ getenv [
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
node-peek literal-value 0 <vreg> swap %getenv ,
|
||||
1 %inc-d ,
|
||||
1 %inc-d,
|
||||
out-1
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ setenv [
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-1
|
||||
node-peek literal-value 0 <vreg> swap %setenv ,
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
: value/vreg-list ( in -- list )
|
||||
|
|
@ -149,7 +100,7 @@ sequences vectors words ;
|
|||
|
||||
: load-inputs ( node -- in )
|
||||
dup node-in-d values>vregs
|
||||
[ length swap node-out-d length - %dec-d , ] keep ;
|
||||
[ >r node-out-d length r> length - %inc-d, ] keep ;
|
||||
|
||||
: binary-op-reg ( node op -- )
|
||||
>r load-inputs first2 swap dup r> execute ,
|
||||
|
|
@ -159,7 +110,7 @@ sequences vectors words ;
|
|||
dup literal? [ literal-value immediate? ] [ drop f ] ifte ;
|
||||
|
||||
: binary-op-imm ( imm op -- )
|
||||
1 %dec-d , in-1
|
||||
-1 %inc-d, in-1
|
||||
>r 0 <vreg> dup r> execute ,
|
||||
0 0 %replace-d , ; inline
|
||||
|
||||
|
|
@ -192,7 +143,7 @@ sequences vectors words ;
|
|||
] each
|
||||
|
||||
: fast-fixnum* ( n -- )
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-1
|
||||
log2 0 <vreg> 0 <vreg> %fixnum<< ,
|
||||
0 0 %replace-d , ;
|
||||
|
|
@ -218,7 +169,7 @@ sequences vectors words ;
|
|||
! be EDX there.
|
||||
drop
|
||||
in-2
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
1 <vreg> 0 <vreg> 2 <vreg> %fixnum-mod ,
|
||||
2 0 %replace-d ,
|
||||
] "intrinsic" set-word-prop
|
||||
|
|
@ -250,7 +201,7 @@ sequences vectors words ;
|
|||
: slow-shift ( -- ) \ fixnum-shift %call , ;
|
||||
|
||||
: negative-shift ( n -- )
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-1
|
||||
dup cell -8 * <= [
|
||||
drop 0 <vreg> 2 <vreg> %fixnum-sgn ,
|
||||
|
|
@ -262,7 +213,7 @@ sequences vectors words ;
|
|||
|
||||
: positive-shift ( n -- )
|
||||
dup cell 8 * tag-bits - <= [
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
in-1
|
||||
0 <vreg> 0 <vreg> %fixnum<< ,
|
||||
out-1
|
||||
|
|
@ -272,7 +223,7 @@ sequences vectors words ;
|
|||
|
||||
: fast-shift ( n -- )
|
||||
dup 0 = [
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
drop
|
||||
] [
|
||||
dup 0 < [
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ M: node linearize-node* ( node -- ) drop ;
|
|||
M: #label linearize-node* ( node -- )
|
||||
<label> dup %return-to , >r
|
||||
dup node-param %label ,
|
||||
node-children first linearize-node
|
||||
node-child linearize-node
|
||||
r> %label , ;
|
||||
|
||||
M: #call linearize-node* ( node -- )
|
||||
|
|
@ -56,14 +56,11 @@ M: literal load-value ( vreg n value -- )
|
|||
: push-1 ( value -- ) 0 swap push-literal ;
|
||||
|
||||
M: #push linearize-node* ( node -- )
|
||||
node-out-d dup length dup %inc-d ,
|
||||
node-out-d dup length dup %inc-d,
|
||||
1 - swap [ push-1 0 over %replace-d , ] each drop ;
|
||||
|
||||
M: #drop linearize-node* ( node -- )
|
||||
node-in-d length %dec-d , ;
|
||||
|
||||
: ifte-head ( label -- )
|
||||
in-1 1 %dec-d , 0 %jump-t , ;
|
||||
in-1 -1 %inc-d, 0 %jump-t , ;
|
||||
|
||||
M: #ifte linearize-node* ( node -- )
|
||||
node-children first2
|
||||
|
|
@ -76,7 +73,7 @@ M: #ifte linearize-node* ( node -- )
|
|||
#! Output the jump table insn and return a list of
|
||||
#! label/branch pairs.
|
||||
in-1
|
||||
1 %dec-d ,
|
||||
-1 %inc-d,
|
||||
0 %untag-fixnum ,
|
||||
0 %dispatch ,
|
||||
[ <label> dup %target-label , cons ] map
|
||||
|
|
|
|||
|
|
@ -0,0 +1,21 @@
|
|||
IN: compiler-backend
|
||||
USING: assembler compiler-backend math ;
|
||||
|
||||
! PowerPC register assignments
|
||||
! r3-r10 vregs
|
||||
! r14 data stack
|
||||
! r15 call stack
|
||||
|
||||
: cell
|
||||
#! Word size.
|
||||
4 ; inline
|
||||
|
||||
: fixnum-imm? ( -- ? )
|
||||
#! Can fixnum operations take immediate operands?
|
||||
f ; inline
|
||||
|
||||
: vregs ( -- n )
|
||||
#! Number of vregs
|
||||
8 ; inline
|
||||
|
||||
M: vreg v>operand vreg-n 3 + ;
|
||||
|
|
@ -70,7 +70,7 @@ USING: compiler errors generic kernel math memory words ;
|
|||
|
||||
: (DIVW) 491 xo-form 31 insn ;
|
||||
: DIVW 0 0 (DIVW) ; : DIVW. 0 1 (DIVW) ;
|
||||
: DIVWO 1 0 (DIVW) ; : DIVWO 1 1 (DIVW) ;
|
||||
: DIVWO 1 0 (DIVW) ; : DIVWO. 1 1 (DIVW) ;
|
||||
|
||||
: (DIVWU) 459 xo-form 31 insn ;
|
||||
: DIVWU 0 0 (DIVWU) ; : DIVWU. 0 1 (DIVWU) ;
|
||||
|
|
|
|||
|
|
@ -38,33 +38,54 @@ M: %fixnum- generate-node ( vop -- )
|
|||
\ ADD \ SUBF simple-overflow ;
|
||||
|
||||
M: %fixnum* generate-node ( vop -- )
|
||||
dup >3-vop< dup dup tag-bits SRAWI
|
||||
#! Note that this assumes the output will be in r3.
|
||||
>3-vop< dup dup tag-bits SRAWI
|
||||
0 MTXER
|
||||
[ >r >r drop 4 r> r> MULLWO. 3 ] 2keep
|
||||
[ >r >r drop 6 r> r> MULLWO. 3 ] 2keep
|
||||
<label> "end" set
|
||||
"end" get BNO
|
||||
MULHW
|
||||
4 6 MR
|
||||
"s48_long_long_to_bignum" f compile-c-call
|
||||
! now we have to shift it by three bits to remove the second
|
||||
! tag
|
||||
tag-bits neg 4 LI
|
||||
"s48_bignum_arithmetic_shift" f compile-c-call
|
||||
! An untagged pointer to the bignum is now in r3; tag it
|
||||
3 4 bignum-tag ORI
|
||||
3 6 bignum-tag ORI
|
||||
"end" get save-xt
|
||||
vop-out-1 v>operand 4 MR ;
|
||||
3 6 MR ;
|
||||
|
||||
: first-bignum ( -- n )
|
||||
1 cell 8 * tag-bits - 1 - shift ; inline
|
||||
|
||||
: most-positive-fixnum ( -- n )
|
||||
first-bignum 1 - >fixnum ; inline
|
||||
|
||||
: most-negative-fixnum ( -- n )
|
||||
first-bignum neg >fixnum ; inline
|
||||
|
||||
M: %fixnum/i generate-node ( vop -- )
|
||||
dup >3-vop< swap DIVW
|
||||
vop-out-1 v>operand dup tag-fixnum ;
|
||||
#! This has specific vreg requirements.
|
||||
<label> "end" set
|
||||
drop
|
||||
5 3 4 DIVW
|
||||
most-positive-fixnum 4 LOAD
|
||||
5 3 tag-fixnum
|
||||
5 0 4 CMP
|
||||
"end" get BLE
|
||||
most-negative-fixnum neg 3 LOAD
|
||||
"s48_long_to_bignum" f compile-c-call
|
||||
3 3 bignum-tag ORI
|
||||
"end" get save-xt ;
|
||||
|
||||
: generate-fixnum/mod ( -- )
|
||||
#! The same code is used for %fixnum/i and %fixnum/mod.
|
||||
#! mdest is vreg where to put the modulus. Note this has
|
||||
#! precise vreg requirements.
|
||||
20 17 18 DIVW ! divide in2 by in1, store result in out1
|
||||
21 20 18 MULLW ! multiply out1 by in1, store result in in1
|
||||
19 21 17 SUBF ! subtract in2 from in1, store result in out1.
|
||||
6 3 4 DIVW ! divide in2 by in1, store result in out1
|
||||
7 6 4 MULLW ! multiply out1 by in1, store result in in1
|
||||
5 7 3 SUBF ! subtract in2 from in1, store result in out1.
|
||||
;
|
||||
|
||||
M: %fixnum-mod generate-node ( vop -- )
|
||||
|
|
@ -74,8 +95,8 @@ M: %fixnum-mod generate-node ( vop -- )
|
|||
M: %fixnum/mod generate-node ( vop -- )
|
||||
#! This has specific vreg requirements.
|
||||
drop generate-fixnum/mod
|
||||
17 20 MR
|
||||
17 17 tag-fixnum ;
|
||||
3 6 MR
|
||||
3 3 tag-fixnum ;
|
||||
|
||||
M: %fixnum-bitand generate-node ( vop -- )
|
||||
>3-vop< AND ;
|
||||
|
|
@ -95,22 +116,23 @@ M: %fixnum<< generate-node ( vop -- )
|
|||
<label> "end" set
|
||||
vop-in-1
|
||||
! check for potential overflow
|
||||
dup shift-add dup 19 LOAD
|
||||
18 17 19 ADD
|
||||
0 18 rot 2 * 1 - CMPLI
|
||||
dup shift-add dup 5 LOAD
|
||||
4 3 5 ADD
|
||||
2 * 1 - 5 LOAD
|
||||
5 0 4 CMPL
|
||||
! is there going to be an overflow?
|
||||
"no-overflow" get BGE
|
||||
! there is going to be an overflow, make a bignum
|
||||
3 17 tag-bits SRAWI
|
||||
3 3 tag-bits SRAWI
|
||||
"s48_long_to_bignum" f compile-c-call
|
||||
dup 4 LI
|
||||
"s48_bignum_arithmetic_shift" f compile-c-call
|
||||
! tag the result
|
||||
3 17 bignum-tag ORI
|
||||
3 3 bignum-tag ORI
|
||||
"end" get B
|
||||
! there is not going to be an overflow
|
||||
"no-overflow" get save-xt
|
||||
17 17 rot SLWI
|
||||
3 3 rot SLWI.
|
||||
"end" get save-xt ;
|
||||
|
||||
M: %fixnum>> generate-node ( vop -- )
|
||||
|
|
@ -119,9 +141,6 @@ M: %fixnum>> generate-node ( vop -- )
|
|||
M: %fixnum-sgn generate-node ( vop -- )
|
||||
dest/src dupd 31 SRAWI dup untag ;
|
||||
|
||||
: MULLW 0 0 (MULLW) ;
|
||||
: MULLW. 0 1 (MULLW) ;
|
||||
|
||||
: compare ( vop -- )
|
||||
dup vop-in-2 v>operand swap vop-in-1 dup integer? [
|
||||
0 -rot address CMPI
|
||||
|
|
|
|||
|
|
@ -4,15 +4,8 @@ IN: compiler-backend
|
|||
USING: alien assembler compiler inference kernel
|
||||
kernel-internals lists math memory namespaces words ;
|
||||
|
||||
! PowerPC register assignments
|
||||
! r14 data stack
|
||||
! r15 call stack
|
||||
! r16-r30 vregs
|
||||
|
||||
: compile-c-call ( symbol dll -- )
|
||||
2dup dlsym 19 LOAD32 0 1 rel-dlsym 19 MTLR BLRL ;
|
||||
|
||||
M: vreg v>operand vreg-n 17 + ;
|
||||
2dup dlsym 11 LOAD32 0 1 rel-dlsym 11 MTLR BLRL ;
|
||||
|
||||
M: %prologue generate-node ( vop -- )
|
||||
drop
|
||||
|
|
@ -39,18 +32,19 @@ M: %call-label generate-node ( vop -- )
|
|||
B ;
|
||||
|
||||
: word-addr ( word -- )
|
||||
dup word-xt 19 LOAD32 0 1 rel-word ;
|
||||
#! Load a word address into r3.
|
||||
dup word-xt 3 LOAD32 0 1 rel-word ;
|
||||
|
||||
: compile-call ( label -- )
|
||||
#! Far C call for primitives, near C call for compiled defs.
|
||||
dup primitive? [ word-addr 19 MTLR BLRL ] [ BL ] ifte ;
|
||||
dup primitive? [ word-addr 3 MTLR BLRL ] [ BL ] ifte ;
|
||||
|
||||
M: %call generate-node ( vop -- )
|
||||
vop-label dup postpone-word compile-call ;
|
||||
|
||||
: compile-jump ( label -- )
|
||||
#! For tail calls. IP not saved on C stack.
|
||||
dup primitive? [ word-addr 19 MTCTR BCTR ] [ B ] ifte ;
|
||||
dup primitive? [ word-addr 3 MTCTR BCTR ] [ B ] ifte ;
|
||||
|
||||
M: %jump generate-node ( vop -- )
|
||||
vop-label dup postpone-word compile-epilogue compile-jump ;
|
||||
|
|
@ -68,9 +62,9 @@ M: %jump-t generate-node ( vop -- )
|
|||
conditional BNE ;
|
||||
|
||||
M: %return-to generate-node ( vop -- )
|
||||
vop-label 0 18 LOAD32 absolute-16/16
|
||||
vop-label 0 3 LOAD32 absolute-16/16
|
||||
1 1 -16 STWU
|
||||
18 1 20 STW ;
|
||||
3 1 20 STW ;
|
||||
|
||||
M: %return generate-node ( vop -- )
|
||||
drop compile-epilogue BLR ;
|
||||
|
|
@ -83,7 +77,7 @@ M: %untag generate-node ( vop -- )
|
|||
M: %untag-fixnum generate-node ( vop -- )
|
||||
dest/src tag-bits SRAWI ;
|
||||
|
||||
: tag-fixnum ( dest src -- ) tag-bits SLWI ;
|
||||
: tag-fixnum ( src dest -- ) tag-bits SLWI ;
|
||||
|
||||
M: %retag-fixnum generate-node ( vop -- )
|
||||
! todo: formalize scratch register usage
|
||||
|
|
@ -91,13 +85,13 @@ M: %retag-fixnum generate-node ( vop -- )
|
|||
|
||||
M: %dispatch generate-node ( vop -- )
|
||||
0 <vreg> check-src
|
||||
17 17 2 SLWI
|
||||
3 3 2 SLWI
|
||||
! The value 24 is a magic number. It is the length of the
|
||||
! instruction sequence that follows to be generated.
|
||||
0 1 rel-address compiled-offset 24 + 18 LOAD32
|
||||
17 17 18 ADD
|
||||
17 17 0 LWZ
|
||||
17 MTLR
|
||||
0 1 rel-address compiled-offset 24 + 4 LOAD32
|
||||
3 3 4 ADD
|
||||
3 3 0 LWZ
|
||||
3 MTLR
|
||||
BLR ;
|
||||
|
||||
M: %type generate-node ( vop -- )
|
||||
|
|
@ -105,24 +99,24 @@ M: %type generate-node ( vop -- )
|
|||
<label> "f" set
|
||||
<label> "end" set
|
||||
! Get the tag
|
||||
17 18 tag-mask ANDI
|
||||
3 4 tag-mask ANDI
|
||||
! Compare with object tag number (3).
|
||||
0 18 object-tag CMPI
|
||||
0 4 object-tag CMPI
|
||||
! Jump if the object doesn't store type info in its header
|
||||
"end" get BNE
|
||||
! It does store type info in its header
|
||||
! Is the pointer itself equal to 3? Then its F_TYPE (9).
|
||||
0 17 object-tag CMPI
|
||||
0 3 object-tag CMPI
|
||||
"f" get BEQ
|
||||
! The pointer is not equal to 3. Load the object header.
|
||||
18 17 object-tag neg LWZ
|
||||
18 18 3 SRAWI
|
||||
4 3 object-tag neg LWZ
|
||||
4 4 3 SRAWI
|
||||
"end" get B
|
||||
"f" get save-xt
|
||||
! The pointer is equal to 3. Load F_TYPE (9).
|
||||
f type 18 LI
|
||||
f type 4 LI
|
||||
"end" get save-xt
|
||||
17 18 MR ;
|
||||
3 4 MR ;
|
||||
|
||||
M: %tag generate-node ( vop -- )
|
||||
dup vop-in-1 swap vop-out-1 tag-mask ANDI ;
|
||||
dup vop-in-1 v>operand swap vop-out-1 v>operand tag-mask ANDI ;
|
||||
|
|
|
|||
|
|
@ -32,12 +32,13 @@ M: %fast-set-slot generate-node ( vop -- )
|
|||
|
||||
M: %write-barrier generate-node ( vop -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
#! Uses r6 for storage.
|
||||
vop-in-1 v>operand
|
||||
dup dup card-bits SRAWI
|
||||
dup dup 16 ADD
|
||||
20 over 0 LBZ
|
||||
20 20 card-mark ORI
|
||||
20 swap 0 STB ;
|
||||
6 over 0 LBZ
|
||||
6 6 card-mark ORI
|
||||
6 swap 0 STB ;
|
||||
|
||||
: userenv ( reg -- )
|
||||
#! Load the userenv pointer in a virtual register.
|
||||
|
|
|
|||
|
|
@ -27,9 +27,6 @@ M: %inc-d generate-node ( vop -- )
|
|||
M: %inc-r generate-node ( vop -- )
|
||||
15 15 rot vop-in-1 cell * ADDI ;
|
||||
|
||||
M: %dec-r generate-node ( vop -- )
|
||||
15 15 rot vop-in-1 cell * SUBI ;
|
||||
|
||||
M: %peek-r generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand swap vop-in-1 cs-op LWZ ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: compiler
|
||||
USING: assembler kernel lists math namespaces sequences words ;
|
||||
USING: assembler compiler-backend kernel lists math namespaces
|
||||
sequences words ;
|
||||
|
||||
! To support saving compiled code to disk, generator words
|
||||
! append relocation instructions to this vector.
|
||||
|
|
|
|||
|
|
@ -131,10 +131,11 @@ M: %replace-d basic-block? drop t ;
|
|||
|
||||
TUPLE: %inc-d ;
|
||||
C: %inc-d make-vop ;
|
||||
: %inc-d ( n -- ) src-vop <%inc-d> ;
|
||||
: %dec-d ( n -- ) neg %inc-d ;
|
||||
: %inc-d ( n -- node ) src-vop <%inc-d> ;
|
||||
M: %inc-d basic-block? drop t ;
|
||||
|
||||
: %inc-d, ( n -- ) dup 0 = [ dup %inc-d , ] unless drop ;
|
||||
|
||||
TUPLE: %immediate ;
|
||||
C: %immediate make-vop ;
|
||||
: %immediate ( vreg obj -- )
|
||||
|
|
@ -151,12 +152,10 @@ C: %replace-r make-vop ;
|
|||
|
||||
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
|
||||
TUPLE: %dec-r ;
|
||||
C: %dec-r make-vop ;
|
||||
: %dec-r ( n -- ) src-vop <%dec-r> ;
|
||||
: %inc-r, ( n -- ) dup 0 = [ dup %inc-r , ] unless drop ;
|
||||
|
||||
: in-1 0 0 %peek-d , ;
|
||||
: in-2 0 1 %peek-d , 1 0 %peek-d , ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,21 @@
|
|||
IN: compiler-backend
|
||||
USING: assembler compiler-backend sequences ;
|
||||
|
||||
! x86 register assignments
|
||||
! EAX, ECX, EDX vregs
|
||||
! ESI datastack
|
||||
! EBX callstack
|
||||
|
||||
: cell
|
||||
#! Word size.
|
||||
4 ; inline
|
||||
|
||||
: fixnum-imm? ( -- ? )
|
||||
#! Can fixnum operations take immediate operands?
|
||||
t ; inline
|
||||
|
||||
: vregs ( -- n )
|
||||
#! Number of vregs
|
||||
3 ; inline
|
||||
|
||||
M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
|
||||
|
|
@ -4,8 +4,6 @@ IN: compiler-backend
|
|||
USING: alien assembler compiler inference kernel
|
||||
kernel-internals lists math memory namespaces sequences words ;
|
||||
|
||||
M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
|
||||
|
||||
! Not used on x86
|
||||
M: %prologue generate-node drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,28 +4,27 @@ IN: compiler-backend
|
|||
USING: alien assembler compiler inference kernel lists math
|
||||
memory sequences words ;
|
||||
|
||||
: rel-cs ( -- )
|
||||
#! Add an entry to the relocation table for the 32-bit
|
||||
#! immediate just compiled.
|
||||
"cs" f 0 0 rel-dlsym ;
|
||||
|
||||
: CS ( -- [ address ] ) "cs" f dlsym unit ;
|
||||
: CS> ( register -- ) CS MOV rel-cs ;
|
||||
: >CS ( register -- ) CS swap MOV rel-cs ;
|
||||
|
||||
: reg-stack ( reg n -- op ) cell * neg 2list ;
|
||||
: ds-op ( n -- op ) ESI swap reg-stack ;
|
||||
: cs-op ( n -- op ) ECX swap reg-stack ;
|
||||
: cs-op ( n -- op ) EBX swap reg-stack ;
|
||||
|
||||
M: %peek-d generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand swap vop-in-1 ds-op MOV ;
|
||||
: (%peek) dup vop-out-1 v>operand swap vop-in-1 ;
|
||||
|
||||
M: %replace-d generate-node ( vop -- )
|
||||
dup vop-in-2 v>operand swap vop-in-1 ds-op swap MOV ;
|
||||
M: %peek-d generate-node ( vop -- ) (%peek) ds-op MOV ;
|
||||
|
||||
M: %inc-d generate-node ( vop -- )
|
||||
ESI swap vop-in-1 cell *
|
||||
dup 0 > [ ADD ] [ neg SUB ] ifte ;
|
||||
M: %peek-r generate-node ( vop -- ) (%peek) cs-op MOV ;
|
||||
|
||||
: (%replace) dup vop-in-2 v>operand swap vop-in-1 ;
|
||||
|
||||
M: %replace-d generate-node ( vop -- ) (%replace) ds-op swap MOV ;
|
||||
|
||||
M: %replace-r generate-node ( vop -- ) (%replace) cs-op swap MOV ;
|
||||
|
||||
: (%inc) swap vop-in-1 cell * dup 0 > [ ADD ] [ neg SUB ] ifte ;
|
||||
|
||||
M: %inc-d generate-node ( vop -- ) ESI (%inc) ;
|
||||
|
||||
M: %inc-r generate-node ( vop -- ) EBX (%inc) ;
|
||||
|
||||
M: %immediate generate-node ( vop -- )
|
||||
dup vop-out-1 v>operand swap vop-in-1 address MOV ;
|
||||
|
|
@ -36,20 +35,3 @@ M: %immediate generate-node ( vop -- )
|
|||
M: %indirect generate-node ( vop -- )
|
||||
#! indirect load of a literal through a table
|
||||
dup vop-out-1 v>operand swap vop-in-1 load-indirect ;
|
||||
|
||||
M: %peek-r generate-node ( vop -- )
|
||||
ECX CS> dup vop-out-1 v>operand swap vop-in-1 cs-op MOV ;
|
||||
|
||||
M: %dec-r generate-node ( vop -- )
|
||||
#! Can only follow a %peek-r
|
||||
vop-in-1 ECX swap cell * SUB ECX >CS ;
|
||||
|
||||
M: %replace-r generate-node ( vop -- )
|
||||
#! Can only follow a %inc-r
|
||||
dup vop-in-2 v>operand swap vop-in-1 cs-op swap MOV
|
||||
ECX >CS ;
|
||||
|
||||
M: %inc-r generate-node ( vop -- )
|
||||
#! Can only follow a %peek-r
|
||||
ECX CS>
|
||||
vop-in-1 ECX swap cell * ADD ;
|
||||
|
|
|
|||
|
|
@ -1,23 +0,0 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
|
||||
IN: generic
|
||||
USING: errors hashtables kernel lists math parser strings
|
||||
sequences vectors words ;
|
||||
|
||||
! Complement metaclass, contains all objects not in a certain class.
|
||||
SYMBOL: complement
|
||||
|
||||
: complement-predicate ( complement -- list )
|
||||
"predicate" word-prop [ not ] append ;
|
||||
|
||||
: complement-types ( class -- types )
|
||||
"complement" word-prop types object types seq-diff ;
|
||||
|
||||
: define-complement ( class complement -- )
|
||||
2dup "complement" set-word-prop
|
||||
dupd complement-predicate "predicate" set-word-prop
|
||||
dup dup complement-types "types" set-word-prop
|
||||
complement define-class ;
|
||||
|
||||
PREDICATE: word complement metaclass complement = ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: generic
|
||||
USING: kernel kernel-internals ;
|
||||
USING: errors kernel kernel-internals ;
|
||||
|
||||
DEFER: standard-combination
|
||||
|
||||
|
|
@ -11,4 +11,8 @@ DEFER: math-combination
|
|||
dup tuple? [ 3 slot ] [ drop f ] ifte ; inline
|
||||
|
||||
: set-delegate ( delegate tuple -- )
|
||||
dup tuple? [ 3 set-slot ] [ drop drop ] ifte ; inline
|
||||
dup tuple? [
|
||||
3 set-slot
|
||||
] [
|
||||
"Only tuples can have delegates" throw
|
||||
] ifte ; inline
|
||||
|
|
|
|||
|
|
@ -37,11 +37,21 @@ sequences vectors words ;
|
|||
[ 3drop t ] [ inline-literals ] ifte
|
||||
] catch ;
|
||||
|
||||
: flip-branches ( #ifte -- )
|
||||
: flip-subst ( not -- )
|
||||
#! Note: cloning the vectors, since subst-values will modify
|
||||
#! them.
|
||||
[ node-in-d clone ] keep
|
||||
[ node-out-d clone ] keep
|
||||
subst-values ;
|
||||
|
||||
: flip-branches ( not -- #ifte )
|
||||
#! If a not is followed by an #ifte, flip branches and
|
||||
#! remove the note.
|
||||
dup flip-subst node-successor dup
|
||||
dup node-children first2 swap 2vector swap set-node-children ;
|
||||
|
||||
\ not {
|
||||
{ [ dup node-successor #ifte? ] [ node-successor dup flip-branches ] }
|
||||
{ [ dup node-successor #ifte? ] [ flip-branches ] }
|
||||
} define-optimizers
|
||||
|
||||
: disjoint-eq? ( node -- ? )
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ C: meet ( values -- value )
|
|||
! representations used by Factor. It annotates concatenative
|
||||
! code with stack flow information and types.
|
||||
|
||||
TUPLE: node param in-d out-d in-r out-r
|
||||
TUPLE: node param shuffle
|
||||
classes literals history
|
||||
successor children ;
|
||||
|
||||
|
|
@ -53,16 +53,31 @@ M: node = eq? ;
|
|||
|
||||
: make-node ( param in-d out-d in-r out-r node -- node )
|
||||
[
|
||||
>r {{ }} clone {{ }} clone { } clone f f <node> r>
|
||||
>r
|
||||
swapd <shuffle> {{ }} clone {{ }} clone { } clone f f <node>
|
||||
r>
|
||||
set-delegate
|
||||
] keep ;
|
||||
|
||||
: node-in-d node-shuffle shuffle-in-d ;
|
||||
: node-in-r node-shuffle shuffle-in-r ;
|
||||
: node-out-d node-shuffle shuffle-out-d ;
|
||||
: node-out-r node-shuffle shuffle-out-r ;
|
||||
|
||||
: set-node-in-d node-shuffle set-shuffle-in-d ;
|
||||
: set-node-in-r node-shuffle set-shuffle-in-r ;
|
||||
: set-node-out-d node-shuffle set-shuffle-out-d ;
|
||||
: set-node-out-r node-shuffle set-shuffle-out-r ;
|
||||
|
||||
: empty-node f { } { } { } { } ;
|
||||
: param-node ( label) { } { } { } { } ;
|
||||
: in-d-node ( inputs) >r f r> { } { } { } ;
|
||||
: out-d-node ( outputs) >r f { } r> { } { } ;
|
||||
|
||||
: d-tail ( n -- list ) meta-d get tail* >vector ;
|
||||
: r-tail ( n -- list ) meta-r get tail* >vector ;
|
||||
: d-tail ( n -- list ) meta-d get tail* ;
|
||||
: r-tail ( n -- list ) meta-r get tail* ;
|
||||
|
||||
: node-child node-children first ;
|
||||
|
||||
TUPLE: #label ;
|
||||
C: #label make-node ;
|
||||
|
|
@ -84,9 +99,9 @@ TUPLE: #push ;
|
|||
C: #push make-node ;
|
||||
: #push ( outputs -- node ) d-tail out-d-node <#push> ;
|
||||
|
||||
TUPLE: #drop ;
|
||||
C: #drop make-node ;
|
||||
: #drop ( inputs -- node ) d-tail in-d-node <#drop> ;
|
||||
TUPLE: #shuffle ;
|
||||
C: #shuffle make-node ;
|
||||
: #shuffle ( -- node ) empty-node <#shuffle> ;
|
||||
|
||||
TUPLE: #values ;
|
||||
C: #values make-node ;
|
||||
|
|
@ -143,12 +158,6 @@ SYMBOL: current-node
|
|||
: with-nesting ( quot -- new-node | quot: -- new-node )
|
||||
nest-node 2slip unnest-node ; inline
|
||||
|
||||
: copy-effect ( from to -- )
|
||||
over node-in-d over set-node-in-d
|
||||
over node-in-r over set-node-in-r
|
||||
over node-out-d over set-node-out-d
|
||||
swap node-out-r swap set-node-out-r ;
|
||||
|
||||
: node-effect ( node -- [[ d-in meta-d ]] )
|
||||
dup node-in-d swap node-out-d cons ;
|
||||
|
||||
|
|
@ -161,6 +170,9 @@ SYMBOL: current-node
|
|||
: uses-value? ( value node -- ? )
|
||||
node-values [ value-refers? ] contains-with? ;
|
||||
|
||||
: outputs-value? ( value node -- ? )
|
||||
2dup node-out-d member? >r node-out-r member? r> or ;
|
||||
|
||||
: last-node ( node -- last )
|
||||
dup node-successor [ last-node ] [ ] ?ifte ;
|
||||
|
||||
|
|
@ -172,8 +184,11 @@ SYMBOL: current-node
|
|||
2drop f
|
||||
] ifte ;
|
||||
|
||||
: drop-inputs ( node -- #drop )
|
||||
node-in-d clone in-d-node <#drop> ;
|
||||
: drop-inputs ( node -- #shuffle )
|
||||
node-in-d clone in-d-node <#shuffle> ;
|
||||
|
||||
: #drop ( n -- #shuffle )
|
||||
d-tail in-d-node <#shuffle> ;
|
||||
|
||||
: each-node ( node quot -- | quot: node -- )
|
||||
over [
|
||||
|
|
@ -266,11 +281,7 @@ DEFER: subst-value
|
|||
] each-node-with ;
|
||||
|
||||
: (clone-node) ( node -- node )
|
||||
clone
|
||||
dup node-in-d clone over set-node-in-d
|
||||
dup node-in-r clone over set-node-in-r
|
||||
dup node-out-d clone over set-node-out-d
|
||||
dup node-out-r clone over set-node-out-r ;
|
||||
clone dup node-shuffle clone over set-node-shuffle ;
|
||||
|
||||
: clone-node ( node -- node )
|
||||
dup [
|
||||
|
|
@ -278,3 +289,15 @@ DEFER: subst-value
|
|||
dup node-children [ clone-node ] map over set-node-children
|
||||
dup node-successor clone-node over set-node-successor
|
||||
] when ;
|
||||
|
||||
GENERIC: calls-label* ( label node -- ? )
|
||||
|
||||
M: node calls-label* 2drop f ;
|
||||
|
||||
M: #call-label calls-label* node-param eq? ;
|
||||
|
||||
: calls-label? ( label node -- ? )
|
||||
[ calls-label* not ] all-nodes-with? not ;
|
||||
|
||||
: recursive-label? ( node -- ? )
|
||||
dup node-param swap calls-label? ;
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ SYMBOL: d-in
|
|||
meta-d [ append ] change
|
||||
d-in [ append ] change ;
|
||||
|
||||
: hairy-node ( node effect quot -- )
|
||||
: hairy-node ( node effect quot -- quot: -- )
|
||||
over car ensure-d
|
||||
-rot 2dup car length 0 rot node-inputs
|
||||
2slip
|
||||
|
|
|
|||
|
|
@ -44,51 +44,8 @@ M: #push can-kill? ( literal node -- ? ) 2drop t ;
|
|||
M: #push kill-node* ( literals node -- )
|
||||
[ node-out-d seq-diff ] keep set-node-out-d ;
|
||||
|
||||
! #drop
|
||||
M: #drop can-kill? ( literal node -- ? ) 2drop t ;
|
||||
|
||||
! #call
|
||||
: (kill-shuffle) ( word -- map )
|
||||
{{
|
||||
[[ dup {{ }} ]]
|
||||
[[ drop {{ }} ]]
|
||||
[[ swap {{ }} ]]
|
||||
[[ over
|
||||
{{
|
||||
[[ { f t } dup ]]
|
||||
}}
|
||||
]]
|
||||
[[ pick
|
||||
{{
|
||||
[[ { f f t } over ]]
|
||||
[[ { f t f } over ]]
|
||||
[[ { f t t } dup ]]
|
||||
}}
|
||||
]]
|
||||
[[ >r {{ }} ]]
|
||||
[[ r> {{ }} ]]
|
||||
}} hash ;
|
||||
|
||||
M: #call can-kill? ( literal node -- ? )
|
||||
dup node-param (kill-shuffle) >r delegate can-kill? r> or ;
|
||||
|
||||
: kill-mask ( killing node -- mask )
|
||||
dup node-param \ r> = [ node-in-r ] [ node-in-d ] ifte
|
||||
[ swap memq? ] map-with ;
|
||||
|
||||
: lookup-mask ( mask word -- word )
|
||||
over [ ] contains? [ (kill-shuffle) hash ] [ nip ] ifte ;
|
||||
|
||||
: kill-shuffle ( literals node -- )
|
||||
#! If certain values passing through a stack op are being
|
||||
#! killed, the stack op can be reduced, in extreme cases
|
||||
#! to a no-op.
|
||||
[ [ kill-mask ] keep node-param lookup-mask ] keep
|
||||
set-node-param ;
|
||||
|
||||
M: #call kill-node* ( literals node -- )
|
||||
dup node-param (kill-shuffle)
|
||||
[ kill-shuffle ] [ 2drop ] ifte ;
|
||||
! #shuffle
|
||||
M: #shuffle can-kill? ( literal node -- ? ) 2drop t ;
|
||||
|
||||
! #call-label
|
||||
M: #call-label can-kill? ( literal node -- ? ) 2drop t ;
|
||||
|
|
|
|||
|
|
@ -37,42 +37,6 @@ memory parser sequences strings vectors words prettyprint ;
|
|||
#dispatch pop-d drop infer-branches
|
||||
] "infer" set-word-prop
|
||||
|
||||
! Stack manipulation
|
||||
\ >r [ [ object ] [ ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ >r [
|
||||
\ >r #call
|
||||
1 0 pick node-inputs
|
||||
pop-d push-r
|
||||
0 1 pick node-outputs
|
||||
node,
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ r> [ [ ] [ object ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ r> [
|
||||
\ r> #call
|
||||
0 1 pick node-inputs
|
||||
pop-r push-d
|
||||
1 0 pick node-outputs
|
||||
node,
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop
|
||||
\ drop [ [ object ] [ ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ dup [ \ dup infer-shuffle ] "infer" set-word-prop
|
||||
\ dup [ [ object ] [ object object ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ swap [ \ swap infer-shuffle ] "infer" set-word-prop
|
||||
\ swap [ [ object object ] [ object object ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ over [ \ over infer-shuffle ] "infer" set-word-prop
|
||||
\ over [ [ object object ] [ object object object ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ pick [ \ pick infer-shuffle ] "infer" set-word-prop
|
||||
\ pick [ [ object object object ] [ object object object object ] ] "infer-effect" set-word-prop
|
||||
|
||||
! Non-standard control flow
|
||||
\ throw [ [ object ] [ ] ] "infer-effect" set-word-prop
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: inference
|
||||
USING: generic hashtables inference kernel lists
|
||||
matrices namespaces sequences vectors ;
|
||||
USING: compiler-backend generic hashtables inference kernel
|
||||
lists math matrices namespaces sequences vectors ;
|
||||
|
||||
! We use the recursive-state variable here, to track nested
|
||||
! label scopes, to prevent infinite loops when inlining
|
||||
|
|
@ -54,9 +54,23 @@ M: node optimize-node* ( node -- t )
|
|||
M: #push optimize-node* ( node -- node/t )
|
||||
[ node-out-d empty? ] prune-if ;
|
||||
|
||||
! #drop
|
||||
M: #drop optimize-node* ( node -- node/t )
|
||||
[ node-in-d empty? ] prune-if ;
|
||||
! #shuffle
|
||||
: compose-shuffle-nodes ( #shuffle #shuffle -- #shuffle/t )
|
||||
[ >r node-shuffle r> node-shuffle compose-shuffle ] keep
|
||||
over shuffle-in-d length pick shuffle-in-r length + vregs > [
|
||||
2drop t
|
||||
] [
|
||||
[ set-node-shuffle ] keep
|
||||
] ifte ;
|
||||
|
||||
M: #shuffle optimize-node* ( node -- node/t )
|
||||
dup node-successor dup #shuffle? [
|
||||
compose-shuffle-nodes
|
||||
] [
|
||||
drop [
|
||||
dup node-in-d empty? swap node-in-r empty? and
|
||||
] prune-if
|
||||
] ifte ;
|
||||
|
||||
! #ifte
|
||||
: static-branch? ( node -- lit ? )
|
||||
|
|
@ -80,15 +94,3 @@ M: #values optimize-node* ( node -- node/t )
|
|||
! #return
|
||||
M: #return optimize-node* ( node -- node/t )
|
||||
optimize-fold ;
|
||||
|
||||
! M: #label optimize-node* ( node -- node/t )
|
||||
! dup node-param over node-children first calls-label? [
|
||||
! drop t
|
||||
! ] [
|
||||
! dup node-children first dup node-successor [
|
||||
! dup penultimate-node rot
|
||||
! node-successor swap set-node-successor
|
||||
! ] [
|
||||
! drop node-successor
|
||||
! ] ifte
|
||||
! ] ifte ;
|
||||
|
|
|
|||
|
|
@ -16,28 +16,23 @@ M: comment pprint* ( ann -- )
|
|||
: comment, ( ? node text -- )
|
||||
rot [ <comment> , ] [ 2drop ] ifte ;
|
||||
|
||||
: value-str ( classes values -- str )
|
||||
[ swap hash [ object ] unless* ] map-with
|
||||
[ word-name ] map
|
||||
" " join ;
|
||||
: value-str ( prefix values -- str )
|
||||
[ value-uid word-name append ] map-with concat ;
|
||||
|
||||
: effect-str ( node -- str )
|
||||
[
|
||||
dup node-classes swap
|
||||
2dup node-in-d value-str %
|
||||
"--" %
|
||||
node-out-d value-str %
|
||||
] "" make ;
|
||||
" " over node-in-d value-str %
|
||||
" r: " over node-in-r value-str %
|
||||
" --" %
|
||||
" " over node-out-d value-str %
|
||||
" r: " swap node-out-r value-str %
|
||||
] "" make 1 swap tail ;
|
||||
|
||||
M: #push node>quot ( ? node -- )
|
||||
node-out-d [ literal-value literalize ] map % drop ;
|
||||
|
||||
M: #drop node>quot ( ? node -- )
|
||||
node-in-d length dup 3 > [
|
||||
\ drop <repeated>
|
||||
] [
|
||||
{ f [ drop ] [ 2drop ] [ 3drop ] } nth
|
||||
] ifte % drop ;
|
||||
M: #shuffle node>quot ( ? node -- )
|
||||
>r drop t r> dup effect-str "#shuffle: " swap append comment, ;
|
||||
|
||||
DEFER: dataflow>quot
|
||||
|
||||
|
|
@ -51,7 +46,7 @@ M: #call-label node>quot ( ? node -- ) #call>quot ;
|
|||
|
||||
M: #label node>quot ( ? node -- )
|
||||
[ "#label: " over node-param word-name append comment, ] 2keep
|
||||
node-children first swap dataflow>quot , \ call , ;
|
||||
node-child swap dataflow>quot , \ call , ;
|
||||
|
||||
M: #ifte node>quot ( ? node -- )
|
||||
[ "#ifte" comment, ] 2keep
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ M: node solve-recursion* ( node -- ) drop ;
|
|||
|
||||
M: #label solve-recursion* ( node -- )
|
||||
dup node-param over collect-recursion >r
|
||||
node-children first dup node-in-d r> swap
|
||||
node-child dup node-in-d r> swap
|
||||
join-values rot subst-values ;
|
||||
|
||||
: solve-recursion ( node -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,59 @@
|
|||
IN: inference
|
||||
USING: kernel math namespaces sequences ;
|
||||
|
||||
TUPLE: shuffle in-d in-r out-d out-r ;
|
||||
|
||||
: empty-shuffle { } { } { } { } <shuffle> ;
|
||||
|
||||
: cut* ( seq1 seq2 -- seq seq ) [ head* ] 2keep tail* ;
|
||||
|
||||
: load-shuffle ( d r shuffle -- )
|
||||
tuck shuffle-in-r [ set ] 2each shuffle-in-d [ set ] 2each ;
|
||||
|
||||
: store-shuffle ( shuffle -- d r )
|
||||
dup shuffle-out-d [ get ] map swap shuffle-out-r [ get ] map ;
|
||||
|
||||
: shuffle* ( d r shuffle -- d r )
|
||||
[ [ load-shuffle ] keep store-shuffle ] with-scope ;
|
||||
|
||||
: split-shuffle ( d r shuffle -- d' r' d r )
|
||||
tuck shuffle-in-r length swap cut*
|
||||
>r >r shuffle-in-d length swap cut*
|
||||
r> swap r> ;
|
||||
|
||||
: join-shuffle ( d' r' d r -- d r )
|
||||
swapd append >r append r> ;
|
||||
|
||||
: shuffle ( d r shuffle -- d r )
|
||||
#! d and r lengths must be at least the required length for
|
||||
#! the shuffle.
|
||||
[ split-shuffle ] keep shuffle* join-shuffle ;
|
||||
|
||||
: fix-compose-d ( s1 s2 -- )
|
||||
over shuffle-out-d over shuffle-in-d length< [
|
||||
over shuffle-out-d length over shuffle-in-d head*
|
||||
[ pick shuffle-in-d append pick set-shuffle-in-d ] keep
|
||||
pick shuffle-out-d append pick set-shuffle-out-d
|
||||
] when 2drop ;
|
||||
|
||||
: fix-compose-r ( s1 s2 -- )
|
||||
over shuffle-out-r over shuffle-in-r length< [
|
||||
over shuffle-out-r length over shuffle-in-r head*
|
||||
[ pick shuffle-in-r append pick set-shuffle-in-r ] keep
|
||||
pick shuffle-out-r append pick set-shuffle-out-r
|
||||
] when 2drop ;
|
||||
|
||||
: compose-shuffle ( s1 s2 -- s1+s2 )
|
||||
#! s1's d and r output lengths must be at least the required
|
||||
#! length for the shuffle. If they are not, a special
|
||||
#! behavior is used which is only valid for the optimizer.
|
||||
>r clone r> clone 2dup fix-compose-d 2dup fix-compose-r
|
||||
>r dup shuffle-out-d over shuffle-out-r r> shuffle
|
||||
>r >r dup shuffle-in-d swap shuffle-in-r r> r> <shuffle> ;
|
||||
|
||||
M: shuffle clone ( shuffle -- shuffle )
|
||||
[ shuffle-in-d clone ] keep
|
||||
[ shuffle-in-r clone ] keep
|
||||
[ shuffle-out-d clone ] keep
|
||||
shuffle-out-r clone
|
||||
<shuffle> ;
|
||||
|
|
@ -48,8 +48,9 @@ M: #ifte split-node* ( node -- )
|
|||
M: #dispatch split-node* ( node -- )
|
||||
split-branch ;
|
||||
|
||||
! #label
|
||||
M: #label split-node* ( node -- )
|
||||
node-children first split-node ;
|
||||
node-child split-node ;
|
||||
|
||||
: inline-literals ( node literals -- node )
|
||||
#! Make #push -> #return -> successor
|
||||
|
|
|
|||
|
|
@ -119,17 +119,27 @@ M: symbol apply-object ( word -- )
|
|||
] ifte*
|
||||
] ifte* ;
|
||||
|
||||
|
||||
: splice-node ( node -- )
|
||||
dup node-successor [
|
||||
dup node, penultimate-node f over set-node-successor
|
||||
dup current-node set
|
||||
] when drop ;
|
||||
|
||||
: block, ( block -- )
|
||||
#! If the block does not call itself, there is no point in
|
||||
#! having the block node in the IR. Just add its contents.
|
||||
dup recursive-label? [
|
||||
node,
|
||||
] [
|
||||
node-child node-successor splice-node
|
||||
] ifte ;
|
||||
|
||||
M: compound apply-object ( word -- )
|
||||
#! Apply the word's stack effect to the inferencer state.
|
||||
dup recursive-state get assoc [
|
||||
recursive-word
|
||||
] [
|
||||
dup "inline" word-prop
|
||||
[ inline-block node, ] [ apply-default ] ifte
|
||||
[ inline-block block, ] [ apply-default ] ifte
|
||||
] ifte* ;
|
||||
|
||||
: infer-shuffle ( word -- )
|
||||
dup #call [
|
||||
over "infer-effect" word-prop
|
||||
[ meta-d [ swap with-datastack ] change ] hairy-node
|
||||
] keep node, ;
|
||||
|
|
|
|||
|
|
@ -82,7 +82,7 @@ C: buffer ( size -- buffer )
|
|||
|
||||
: ch>buffer ( char buffer -- )
|
||||
1 over check-overflow
|
||||
[ buffer-end <alien> 0 set-alien-unsigned-1 ] keep
|
||||
[ buffer-end f swap set-alien-unsigned-1 ] keep
|
||||
[ buffer-fill 1 + ] keep set-buffer-fill ;
|
||||
|
||||
: n>buffer ( count buffer -- )
|
||||
|
|
@ -90,7 +90,7 @@ C: buffer ( size -- buffer )
|
|||
[ buffer-fill + ] keep set-buffer-fill ;
|
||||
|
||||
: buffer-peek ( buffer -- char )
|
||||
buffer@ <alien> 0 alien-unsigned-1 ;
|
||||
buffer@ f swap alien-unsigned-1 ;
|
||||
|
||||
: buffer-pop ( buffer -- char )
|
||||
[ buffer-peek 1 ] keep buffer-consume ;
|
||||
|
|
|
|||
|
|
@ -3,18 +3,7 @@
|
|||
IN: kernel
|
||||
USING: generic kernel-internals vectors ;
|
||||
|
||||
: 2drop ( x x -- ) drop drop ; inline
|
||||
: 3drop ( x x x -- ) drop drop drop ; inline
|
||||
: 2dup ( x y -- x y x y ) over over ; inline
|
||||
: 3dup ( x y z -- x y z x y z ) pick pick pick ; inline
|
||||
: rot ( x y z -- y z x ) >r swap r> swap ; inline
|
||||
: -rot ( x y z -- z x y ) swap >r swap r> ; inline
|
||||
: dupd ( x y -- x x y ) >r dup r> ; inline
|
||||
: swapd ( x y z -- y x z ) >r swap r> ; inline
|
||||
: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
|
||||
: nip ( x y -- y ) swap drop ; inline
|
||||
: 2nip ( x y z -- z ) >r drop drop r> ; inline
|
||||
: tuck ( x y -- y x y ) dup >r swap r> ; inline
|
||||
|
||||
: clear ( -- )
|
||||
#! Clear the datastack. For interactive use only; invoking
|
||||
|
|
@ -23,7 +12,6 @@ USING: generic kernel-internals vectors ;
|
|||
{ } set-datastack ;
|
||||
|
||||
UNION: boolean POSTPONE: f POSTPONE: t ;
|
||||
COMPLEMENT: general-t f
|
||||
|
||||
GENERIC: hashcode ( obj -- n ) flushable
|
||||
M: object hashcode drop 0 ;
|
||||
|
|
|
|||
|
|
@ -14,12 +14,6 @@ words ;
|
|||
#! G: word combination ;
|
||||
CREATE dup reset-word [ define-generic* ] [ ] ; parsing
|
||||
|
||||
: COMPLEMENT: ( -- )
|
||||
#! Followed by a class name, then a complemented class.
|
||||
CREATE
|
||||
dup intern-symbol
|
||||
scan-word define-complement ; parsing
|
||||
|
||||
: UNION: ( -- class predicate definition )
|
||||
#! Followed by a class name, then a list of union members.
|
||||
CREATE
|
||||
|
|
|
|||
|
|
@ -310,7 +310,8 @@ M: wrapper pprint* ( wrapper -- )
|
|||
|
||||
: with-pprint ( quot -- )
|
||||
[
|
||||
<pprinter> pprinter set call pprinter get do-pprint
|
||||
<pprinter> pprinter set call end-blocks
|
||||
pprinter get do-pprint
|
||||
] with-scope ; inline
|
||||
|
||||
: pprint ( object -- ) [ pprint* ] with-pprint ;
|
||||
|
|
@ -347,12 +348,12 @@ M: wrapper pprint* ( wrapper -- )
|
|||
|
||||
: define-open
|
||||
#! The word will be pretty-printed as a block opener.
|
||||
#! Examples are [ { {{ << and so on.
|
||||
#! Examples are [ { {{ [[ << and so on.
|
||||
[ <block ] "pprint-after-hook" set-word-prop ;
|
||||
|
||||
: define-close ( word -- )
|
||||
#! The word will be pretty-printed as a block closer.
|
||||
#! Examples are ] } }} ]] and so on.
|
||||
#! Examples are ] } }} ]] >> and so on.
|
||||
[ block> ] "pprint-before-hook" set-word-prop ;
|
||||
|
||||
{
|
||||
|
|
|
|||
|
|
@ -93,11 +93,6 @@ M: union class.
|
|||
dup pprint-word
|
||||
"members" word-prop pprint-elements pprint-; newline ;
|
||||
|
||||
M: complement class.
|
||||
\ COMPLEMENT: pprint-word
|
||||
dup pprint-word
|
||||
"complement" word-prop pprint-word newline ;
|
||||
|
||||
M: predicate class.
|
||||
\ PREDICATE: pprint-word
|
||||
dup "superclass" word-prop pprint-word
|
||||
|
|
|
|||
|
|
@ -164,4 +164,6 @@ math-internals test words ;
|
|||
|
||||
[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-1 ] unit-test
|
||||
|
||||
[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-1 ] unit-test
|
||||
|
||||
[ t ] [ f [ f eq? ] compile-1 ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,16 +1,7 @@
|
|||
IN: temporary
|
||||
USING: generic kernel-internals strings vectors ;
|
||||
USE: test
|
||||
USE: assembler
|
||||
USE: compiler
|
||||
USE: compiler-frontend
|
||||
USE: inference
|
||||
USE: words
|
||||
USE: math
|
||||
USE: kernel
|
||||
USE: lists
|
||||
USE: sequences
|
||||
USE: prettyprint
|
||||
USING: assembler compiler compiler-backend generic inference
|
||||
kernel kernel-internals lists math prettyprint sequences strings
|
||||
test vectors words ;
|
||||
|
||||
! Some dataflow tests
|
||||
! [ 3 ] [ 1 2 3 (subst-value) ] unit-test
|
||||
|
|
@ -37,11 +28,6 @@ USE: prettyprint
|
|||
|
||||
[ { [ 1 ] [ 2 ] } ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test
|
||||
|
||||
[ [ t t f ] ] [
|
||||
[ 1 2 3 ] [ <literal> ] map
|
||||
[ [ literal-value 2 <= ] subset ] keep in-d-node <#drop> kill-mask
|
||||
] unit-test
|
||||
|
||||
: literal-kill-test-1 4 compiled-offset cell 2 * - ; compiled
|
||||
|
||||
[ 4 ] [ literal-kill-test-1 drop ] unit-test
|
||||
|
|
@ -171,3 +157,9 @@ TUPLE: pred-test ;
|
|||
: fixnum-declarations >fixnum 24 shift 1234 bitxor ; compiled
|
||||
|
||||
[ ] [ 1000000 fixnum-declarations . ] unit-test
|
||||
|
||||
! regression
|
||||
|
||||
: literal-not-branch 0 not [ ] [ ] ifte ; compiled
|
||||
|
||||
[ ] [ literal-not-branch ] unit-test
|
||||
|
|
|
|||
|
|
@ -6,6 +6,24 @@ USE: lists
|
|||
USE: math
|
||||
USE: kernel
|
||||
|
||||
! Test shuffle intrinsics
|
||||
[ ] [ 1 [ drop ] compile-1 ] unit-test
|
||||
[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test
|
||||
[ ] [ 1 2 3 [ 3drop ] compile-1 ] unit-test
|
||||
[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
|
||||
[ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-1 ] unit-test
|
||||
[ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-1 ] unit-test
|
||||
[ 2 3 1 ] [ 1 2 3 [ rot ] compile-1 ] unit-test
|
||||
[ 3 1 2 ] [ 1 2 3 [ -rot ] compile-1 ] unit-test
|
||||
[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
|
||||
[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-1 ] unit-test
|
||||
[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
|
||||
[ 3 ] [ 1 2 3 [ 2nip ] compile-1 ] unit-test
|
||||
[ 2 1 2 ] [ 1 2 [ tuck ] compile-1 ] unit-test
|
||||
[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
|
||||
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
|
||||
[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
|
||||
|
||||
! Test various kill combinations
|
||||
|
||||
: kill-1
|
||||
|
|
|
|||
|
|
@ -145,13 +145,6 @@ TUPLE: another-one ;
|
|||
[ "IN: temporary\nSYMBOL: bah\nUNION: bah fixnum alien ;\n" ]
|
||||
[ [ \ bah see ] string-out ] unit-test
|
||||
|
||||
[ t ] [
|
||||
DEFER: not-fixnum
|
||||
"IN: temporary\nSYMBOL: not-fixnum\nCOMPLEMENT: not-fixnum fixnum\n"
|
||||
dup eval
|
||||
[ \ not-fixnum see ] string-out =
|
||||
] unit-test
|
||||
|
||||
! Weird bug
|
||||
GENERIC: stack-underflow
|
||||
M: object stack-underflow 2drop ;
|
||||
|
|
|
|||
|
|
@ -2,6 +2,22 @@ IN: temporary
|
|||
USING: generic inference kernel lists math math-internals
|
||||
namespaces parser sequences test vectors ;
|
||||
|
||||
[
|
||||
<< shuffle f { "a" } { } { "a" } { "a" } >>
|
||||
] [
|
||||
<< shuffle f { "a" } { } { "a" "a" } { } >>
|
||||
<< shuffle f { "b" } { } { } { "b" } >>
|
||||
compose-shuffle
|
||||
] unit-test
|
||||
|
||||
[
|
||||
<< shuffle f { "b" "a" } { } { "b" "b" } { } >>
|
||||
] [
|
||||
<< shuffle f { "a" } { } { } { } >>
|
||||
<< shuffle f { "b" } { } { "b" "b" } { } >>
|
||||
compose-shuffle
|
||||
] unit-test
|
||||
|
||||
: simple-effect first2 >r length r> length 2vector ;
|
||||
|
||||
[ { 0 2 } ] [ [ 2 "Hello" ] infer simple-effect ] unit-test
|
||||
|
|
|
|||
|
|
@ -44,6 +44,8 @@ parser prettyprint sequences io strings vectors words ;
|
|||
PREDICATE: cons kernel-error ( obj -- ? )
|
||||
car kernel-error = ;
|
||||
|
||||
M: f error. ( f -- ) ;
|
||||
|
||||
M: kernel-error error. ( error -- )
|
||||
#! Kernel errors are indexed by integers.
|
||||
cdr uncons car swap {
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ styles threads words ;
|
|||
ttf-init
|
||||
global [
|
||||
<world> world set
|
||||
{ 600 800 0 } world get set-gadget-dim
|
||||
{ 600 700 0 } world get set-gadget-dim
|
||||
|
||||
world-theme world get set-gadget-paint
|
||||
|
||||
|
|
@ -38,11 +38,11 @@ global [ first-time on ] bind
|
|||
: ?init-world
|
||||
first-time get [ init-world first-time off ] when ;
|
||||
|
||||
IN: shells
|
||||
|
||||
: ui-title
|
||||
[ "Factor " % version % " - " % "image" get % ] "" make ;
|
||||
|
||||
IN: shells
|
||||
|
||||
: ui ( -- )
|
||||
#! Start the Factor graphics subsystem with the given screen
|
||||
#! dimensions.
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: io-internals
|
||||
USING: alien assembler errors generic hashtables io kernel
|
||||
kernel-internals lists math parser sequences strings threads
|
||||
unix-internals vectors ;
|
||||
USING: alien compiler-backend errors generic hashtables io
|
||||
kernel kernel-internals lists math parser sequences strings
|
||||
threads unix-internals vectors ;
|
||||
|
||||
! We want namespaces::bind to shadow the bind system call from
|
||||
! unix-internals
|
||||
|
|
|
|||
|
|
@ -9,7 +9,6 @@
|
|||
#define DLLEXPORT
|
||||
#endif
|
||||
|
||||
/* CELL must be 32 bits and your system must have 32-bit pointers */
|
||||
typedef unsigned long int CELL;
|
||||
#define CELLS ((signed)sizeof(CELL))
|
||||
|
||||
|
|
@ -29,10 +28,12 @@ CELL ds_bot;
|
|||
CELL cs_bot;
|
||||
|
||||
/* raw pointer to callstack top */
|
||||
#if defined(FACTOR_PPC)
|
||||
#if defined(FACTOR_X86)
|
||||
register CELL cs asm("ebx");
|
||||
#elif defined(FACTOR_PPC)
|
||||
register CELL cs asm("r15");
|
||||
#else
|
||||
DLLEXPORT CELL cs;
|
||||
CELL cs;
|
||||
#endif
|
||||
|
||||
/* TAGGED currently executing quotation */
|
||||
|
|
|
|||
|
|
@ -82,10 +82,21 @@ void* primitives[] = {
|
|||
primitive_update_xt,
|
||||
primitive_word_compiledp,
|
||||
primitive_drop,
|
||||
primitive_2drop,
|
||||
primitive_3drop,
|
||||
primitive_dup,
|
||||
primitive_swap,
|
||||
primitive_2dup,
|
||||
primitive_3dup,
|
||||
primitive_rot,
|
||||
primitive__rot,
|
||||
primitive_dupd,
|
||||
primitive_swapd,
|
||||
primitive_nip,
|
||||
primitive_2nip,
|
||||
primitive_tuck,
|
||||
primitive_over,
|
||||
primitive_pick,
|
||||
primitive_swap,
|
||||
primitive_to_r,
|
||||
primitive_from_r,
|
||||
primitive_eq,
|
||||
|
|
|
|||
|
|
@ -37,17 +37,98 @@ void primitive_drop(void)
|
|||
dpop();
|
||||
}
|
||||
|
||||
void primitive_2drop(void)
|
||||
{
|
||||
ds -= 2 * CELLS;
|
||||
}
|
||||
|
||||
void primitive_3drop(void)
|
||||
{
|
||||
ds -= 3 * CELLS;
|
||||
}
|
||||
|
||||
void primitive_dup(void)
|
||||
{
|
||||
dpush(dpeek());
|
||||
}
|
||||
|
||||
void primitive_swap(void)
|
||||
void primitive_2dup(void)
|
||||
{
|
||||
CELL top = dpeek();
|
||||
CELL next = get(ds - CELLS);
|
||||
ds += CELLS * 2;
|
||||
put(ds - CELLS,next);
|
||||
put(ds,top);
|
||||
}
|
||||
|
||||
void primitive_3dup(void)
|
||||
{
|
||||
CELL c1 = dpeek();
|
||||
CELL c2 = get(ds - CELLS);
|
||||
CELL c3 = get(ds - CELLS * 2);
|
||||
ds += CELLS * 3;
|
||||
put (ds,c1);
|
||||
put (ds - CELLS,c2);
|
||||
put (ds - CELLS * 2,c3);
|
||||
}
|
||||
|
||||
void primitive_rot(void)
|
||||
{
|
||||
CELL c1 = dpeek();
|
||||
CELL c2 = get(ds - CELLS);
|
||||
CELL c3 = get(ds - CELLS * 2);
|
||||
put(ds,c3);
|
||||
put(ds - CELLS,c1);
|
||||
put(ds - CELLS * 2,c2);
|
||||
}
|
||||
|
||||
void primitive__rot(void)
|
||||
{
|
||||
CELL c1 = dpeek();
|
||||
CELL c2 = get(ds - CELLS);
|
||||
CELL c3 = get(ds - CELLS * 2);
|
||||
put(ds,c2);
|
||||
put(ds - CELLS,c3);
|
||||
put(ds - CELLS * 2,c1);
|
||||
}
|
||||
|
||||
void primitive_dupd(void)
|
||||
{
|
||||
CELL top = dpeek();
|
||||
CELL next = get(ds - CELLS);
|
||||
put(ds,next);
|
||||
put(ds - CELLS,next);
|
||||
dpush(top);
|
||||
}
|
||||
|
||||
void primitive_swapd(void)
|
||||
{
|
||||
CELL top = get(ds - CELLS);
|
||||
CELL next = get(ds - CELLS * 2);
|
||||
put(ds - CELLS,next);
|
||||
put(ds - CELLS * 2,top);
|
||||
}
|
||||
|
||||
void primitive_nip(void)
|
||||
{
|
||||
CELL top = dpop();
|
||||
drepl(top);
|
||||
}
|
||||
|
||||
void primitive_2nip(void)
|
||||
{
|
||||
CELL top = dpeek();
|
||||
ds -= CELLS * 2;
|
||||
drepl(top);
|
||||
}
|
||||
|
||||
void primitive_tuck(void)
|
||||
{
|
||||
CELL top = dpeek();
|
||||
CELL next = get(ds - CELLS);
|
||||
put(ds,next);
|
||||
put(ds - CELLS,top);
|
||||
dpush(top);
|
||||
}
|
||||
|
||||
void primitive_over(void)
|
||||
|
|
@ -60,6 +141,14 @@ void primitive_pick(void)
|
|||
dpush(get(ds - CELLS * 2));
|
||||
}
|
||||
|
||||
void primitive_swap(void)
|
||||
{
|
||||
CELL top = dpeek();
|
||||
CELL next = get(ds - CELLS);
|
||||
put(ds,next);
|
||||
put(ds - CELLS,top);
|
||||
}
|
||||
|
||||
void primitive_to_r(void)
|
||||
{
|
||||
cpush(dpop());
|
||||
|
|
|
|||
|
|
@ -9,10 +9,21 @@ void fix_stacks(void);
|
|||
void init_stacks(CELL ds_size, CELL cs_size);
|
||||
|
||||
void primitive_drop(void);
|
||||
void primitive_2drop(void);
|
||||
void primitive_3drop(void);
|
||||
void primitive_dup(void);
|
||||
void primitive_swap(void);
|
||||
void primitive_2dup(void);
|
||||
void primitive_3dup(void);
|
||||
void primitive_rot(void);
|
||||
void primitive__rot(void);
|
||||
void primitive_dupd(void);
|
||||
void primitive_swapd(void);
|
||||
void primitive_nip(void);
|
||||
void primitive_2nip(void);
|
||||
void primitive_tuck(void);
|
||||
void primitive_over(void);
|
||||
void primitive_pick(void);
|
||||
void primitive_swap(void);
|
||||
void primitive_to_r(void);
|
||||
void primitive_from_r(void);
|
||||
F_VECTOR* stack_to_vector(CELL bottom, CELL top);
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
IN: kernel
|
||||
: version "0.77" ;
|
||||
: version "0.78" ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue