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

linear IR and simplifier refactoring

cvs before-dataflow-ir-refactoring
Slava Pestov 2005-05-16 21:01:39 +00:00
parent 55aeaadfe0
commit 7418990bdc
19 changed files with 284 additions and 339 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
CHANGES.txt
View File

@ -7,6 +7,9 @@ for controlling it:
+Yn Size of 2 youngest generations, megabytes
+An Size of tenured and semi-spaces, megabytes
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.
Defining a predicate subclass of tuple is supported now. Note that

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

@ -30,11 +30,9 @@ t [
"/library/inference/dataflow.factor"
"/library/inference/values.factor"
"/library/inference/inference.factor"
"/library/inference/ties.factor"
"/library/inference/branches.factor"
"/library/inference/words.factor"
"/library/inference/stack.factor"
"/library/inference/types.factor"
"/library/inference/partial-eval.factor"
"/library/compiler/assembler.factor"

78
library/compiler/simplifier.factor
View File

@ -2,7 +2,7 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-backend
USING: generic inference kernel lists math namespaces
prettyprint strings words ;
prettyprint sequences strings words ;
! A peephole optimizer operating on the linear IR.
@ -51,51 +51,91 @@ M: %label simplify-node ( linear vop -- linear ? )
M: %inc-d simplify-node ( linear vop -- linear ? )
#! %inc-d cancels a following %inc-d.
dup vop-literal 0 = [
dup vop-in-1 0 = [
drop cdr t
] [
>r dup \ %inc-d next-physical? [
vop-literal r> vop-literal +
vop-in-1 r> vop-in-1 +
%inc-d >r cdr cdr r> swons t
] [
r> 2drop f
] ifte
] ifte ;
: dead-load? ( linear vop -- ? )
: basic-block ( linear quot -- | quot: vop -- ? )
#! Keep applying the quotation to each VOP until either a
#! VOP answering f to basic-block?, or the quotation answers
#! f.
over car basic-block? [
>r uncons r> tuck >r >r call [
r> r> basic-block
] [
r> r> 2drop
] ifte
] [
2drop
] ifte ; inline
: reads-vreg? ( vreg linear -- ? )
#! Tests if the vreg is read before being written in the
#! current basic block. Outputs a true value if the vreg
#! is not read or written before the end of the basic block.
[
2dup vop-inputs contains? [
! we are reading the vreg
2drop t f
] [
2dup vop-outputs contains? [
! we are writing the vreg
2drop f f
] [
! keep checking
drop t
] ifte
] ifte
] basic-block ;
: dead-load ( vreg linear -- linear ? )
#! If the vreg is not read before being written, drop
#! the current VOP.
tuck cdr reads-vreg? [ f ] [ cdr t ] ifte ;
M: %peek-d simplify-node ( linear vop -- linear ? )
vop-out-1 swap dead-load ;
M: %immediate simplify-node ( linear vop -- linear ? )
vop-out-1 swap dead-load ;
M: %indirect simplify-node ( linear vop -- linear ? )
vop-out-1 swap dead-load ;
: dead-peek? ( linear vop -- ? )
#! Is the %replace-d followed by a %peek-d of the same
#! stack slot and vreg?
swap cdr car dup %peek-d? [
over vop-source over vop-dest = >r
swap vop-literal swap vop-literal = r> and
over vop-in-2 over vop-out-1 = >r
swap vop-in-1 swap vop-in-1 = r> and
] [
2drop f
] ifte ;
: dead-store? ( linear n -- ? )
: dead-replace? ( linear n -- ? )
#! Is the %replace-d followed by a %dec-d, so the stored
#! value is lost?
swap \ %inc-d next-physical? [
vop-literal + 0 <
vop-in-1 + 0 <
] [
2drop f
] ifte ;
M: %replace-d simplify-node ( linear vop -- linear ? )
2dup dead-load? [
2dup dead-peek? [
drop uncons cdr cons t
] [
2dup vop-literal dead-store? [
drop cdr t
] [
drop f
] ifte
dupd vop-in-1 dead-replace? [ cdr t ] [ f ] ifte
] ifte ;
! M: %immediate-d simplify-node ( linear vop -- linear ? )
! over 0 dead-store? [ drop cdr t ] [ drop f ] ifte ;
: pop? ( vop -- ? ) dup %inc-d? swap vop-literal -1 = and ;
: pop? ( vop -- ? ) dup %inc-d? swap vop-in-1 -1 = and ;
: can-fast-branch? ( linear -- ? )
unswons class fast-branch [
@ -105,7 +145,7 @@ M: %replace-d simplify-node ( linear vop -- linear ? )
] ifte ;
: fast-branch-params ( linear -- src dest label linear )
uncons >r dup vop-source swap vop-dest r> cdr
uncons >r dup vop-in-1 swap vop-out-1 r> cdr
uncons >r vop-label r> ;
: make-fast-branch ( linear op -- linear ? )

190
library/compiler/vops.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-backend
USING: errors generic hashtables kernel math namespaces parser
words ;
USING: errors generic hashtables kernel lists math namespaces
parser sequences words ;
! The linear IR is the second of the two intermediate
! representations used by Factor. It is basically a high-level
@ -22,13 +22,21 @@ words ;
TUPLE: vreg n ;
! A virtual operation
TUPLE: vop source dest literal label ;
TUPLE: vop inputs outputs label ;
: vop-in-1 ( vop -- input ) vop-inputs car ;
: vop-in-2 ( vop -- input ) vop-inputs cdr car ;
: vop-in-3 ( vop -- input ) vop-inputs cdr cdr car ;
: vop-out-1 ( vop -- output ) vop-outputs car ;
GENERIC: basic-block? ( vop -- ? )
M: vop basic-block? drop f ;
! simplifies some code
M: f basic-block? drop f ;
GENERIC: calls-label? ( label vop -- ? )
M: vop calls-label? vop-label = ;
: make-vop ( source dest literal label vop -- vop )
: make-vop ( inputs outputs label vop -- vop )
[ >r <vop> r> set-delegate ] keep ;
: VOP:
@ -36,19 +44,21 @@ M: vop calls-label? vop-label = ;
scan dup [ ] define-tuple
create-in [ make-vop ] define-constructor ; parsing
: empty-vop f f f f ;
: label-vop ( label) >r f f f r> ;
: label/src-vop ( label src) swap >r f f r> ;
: src-vop ( src) f f f ;
: dest-vop ( dest) f swap f f ;
: src/dest-vop ( src dest) f f ;
: literal-vop ( literal) >r f f r> f ;
: src/literal-vop ( src literal) f swap f ;
: dest/literal-vop ( dest literal) >r f swap r> f ;
: empty-vop f f f ;
: label-vop ( label) >r f f r> ;
: label/src-vop ( label src) unit swap f swap ;
: src-vop ( src) unit f f ;
: dest-vop ( dest) unit dup f ;
: src/dest-vop ( src dest) >r unit r> unit f ;
: binary-vop ( src dest) [ 2list ] keep unit f ;
: 2-in-vop ( in1 in2) 2list f f ;
: 2-in/label-vop ( in1 in2 label) >r 2list f r> ;
: ternary-vop ( in1 in2 dest) >r 2list r> unit f ;
! miscellanea
VOP: %prologue
: %prologue empty-vop <%prologue> ;
VOP: %label
: %label label-vop <%label> ;
M: %label calls-label? 2drop f ;
@ -61,49 +71,69 @@ VOP: %return
VOP: %return-to
: %return-to label-vop <%return-to> ;
VOP: %jump
: %jump label-vop <%jump> ;
VOP: %jump-label
: %jump-label label-vop <%jump-label> ;
VOP: %call
: %call label-vop <%call> ;
VOP: %call-label
: %call-label label-vop <%call-label> ;
VOP: %jump-t
: %jump-t <vreg> label/src-vop <%jump-t> ;
VOP: %jump-f
: %jump-f <vreg> label/src-vop <%jump-f> ;
! dispatch tables
VOP: %dispatch
: %dispatch <vreg> src-vop <%dispatch> ;
VOP: %target-label
: %target-label label-vop <%target-label> ;
VOP: %target
: %target label-vop <%target> ;
VOP: %end-dispatch
: %end-dispatch empty-vop <%end-dispatch> ;
! stack operations
VOP: %peek-d
: %peek-d ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-d> ;
: %peek-d ( vreg n -- ) swap <vreg> src/dest-vop <%peek-d> ;
M: %peek-d basic-block? drop t ;
VOP: %replace-d
: %replace-d ( vreg n -- ) >r <vreg> f r> f <%replace-d> ;
: %replace-d ( vreg n -- ) swap <vreg> 2-in-vop <%replace-d> ;
M: %replace-d basic-block? drop t ;
VOP: %inc-d
: %inc-d ( n -- ) literal-vop <%inc-d> ;
: %inc-d ( n -- ) src-vop <%inc-d> ;
: %dec-d ( n -- ) neg %inc-d ;
M: %inc-d basic-block? drop t ;
VOP: %immediate
: %immediate ( vreg obj -- )
>r <vreg> r> dest/literal-vop <%immediate> ;
swap <vreg> src/dest-vop <%immediate> ;
M: %immediate basic-block? drop t ;
VOP: %peek-r
: %peek-r ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-r> ;
: %peek-r ( vreg n -- ) swap <vreg> src/dest-vop <%peek-r> ;
VOP: %replace-r
: %replace-r ( vreg n -- ) >r <vreg> f r> f <%replace-r> ;
: %replace-r ( vreg n -- ) swap <vreg> 2-in-vop <%replace-r> ;
VOP: %inc-r
: %inc-r ( n -- ) literal-vop <%inc-r> ;
: %inc-r ( n -- ) src-vop <%inc-r> ;
! this exists, unlike %dec-d which does not, due to x86 quirks
VOP: %dec-r
: %dec-r ( n -- ) literal-vop <%dec-r> ;
: %dec-r ( n -- ) src-vop <%dec-r> ;
: in-1 0 0 %peek-d , ;
: in-2 0 1 %peek-d , 1 0 %peek-d , ;
@ -112,44 +142,58 @@ VOP: %dec-r
! indirect load of a literal through a table
VOP: %indirect
: %indirect ( vreg obj -- ) >r <vreg> r> f -rot f <%indirect> ;
: %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
: %untag <vreg> dest-vop <%untag> ;
M: %untag basic-block? drop t ;
VOP: %slot
: %slot ( n vreg ) >r <vreg> r> <vreg> f f <%slot> ;
: %slot ( n vreg ) >r <vreg> r> <vreg> binary-vop <%slot> ;
M: %slot basic-block? drop t ;
VOP: %set-slot
: %set-slot ( vreg:value vreg:obj n )
>r >r <vreg> r> <vreg> r> <vreg> f <%set-slot> ;
: %set-slot ( value obj n )
#! %set-slot writes to vreg n.
>r >r <vreg> r> <vreg> r> <vreg> [ 3list ] keep unit f
<%set-slot> ;
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
: %fast-slot ( vreg n ) >r >r f r> <vreg> r> f <%fast-slot> ;
: %fast-slot ( vreg n )
swap <vreg> binary-vop <%fast-slot> ;
M: %fast-slot basic-block? drop t ;
VOP: %fast-set-slot
: %fast-set-slot ( vreg:value vreg:obj n )
>r >r <vreg> r> <vreg> r> f <%fast-set-slot> ;
: %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 ;
! fixnum intrinsics
VOP: %fixnum+ : %fixnum+ src/dest-vop <%fixnum+> ;
VOP: %fixnum- : %fixnum- src/dest-vop <%fixnum-> ;
VOP: %fixnum* : %fixnum* src/dest-vop <%fixnum*> ;
VOP: %fixnum-mod : %fixnum-mod src/dest-vop <%fixnum-mod> ;
VOP: %fixnum/i : %fixnum/i src/dest-vop <%fixnum/i> ;
VOP: %fixnum/mod : %fixnum/mod src/dest-vop <%fixnum/mod> ;
VOP: %fixnum-bitand : %fixnum-bitand src/dest-vop <%fixnum-bitand> ;
VOP: %fixnum-bitor : %fixnum-bitor src/dest-vop <%fixnum-bitor> ;
VOP: %fixnum-bitxor : %fixnum-bitxor src/dest-vop <%fixnum-bitxor> ;
VOP: %fixnum+ : %fixnum+ binary-vop <%fixnum+> ;
VOP: %fixnum- : %fixnum- binary-vop <%fixnum-> ;
VOP: %fixnum* : %fixnum* binary-vop <%fixnum*> ;
VOP: %fixnum-mod : %fixnum-mod binary-vop <%fixnum-mod> ;
VOP: %fixnum/i : %fixnum/i binary-vop <%fixnum/i> ;
VOP: %fixnum/mod : %fixnum/mod binary-vop <%fixnum/mod> ;
VOP: %fixnum-bitand : %fixnum-bitand binary-vop <%fixnum-bitand> ;
VOP: %fixnum-bitor : %fixnum-bitor binary-vop <%fixnum-bitor> ;
VOP: %fixnum-bitxor : %fixnum-bitxor binary-vop <%fixnum-bitxor> ;
VOP: %fixnum-bitnot : %fixnum-bitnot <vreg> dest-vop <%fixnum-bitnot> ;
VOP: %fixnum<= : %fixnum<= src/dest-vop <%fixnum<=> ;
VOP: %fixnum< : %fixnum< src/dest-vop <%fixnum<> ;
VOP: %fixnum>= : %fixnum>= src/dest-vop <%fixnum>=> ;
VOP: %fixnum> : %fixnum> src/dest-vop <%fixnum>> ;
VOP: %eq? : %eq? src/dest-vop <%eq?> ;
VOP: %fixnum<= : %fixnum<= binary-vop <%fixnum<=> ;
VOP: %fixnum< : %fixnum< binary-vop <%fixnum<> ;
VOP: %fixnum>= : %fixnum>= binary-vop <%fixnum>=> ;
VOP: %fixnum> : %fixnum> binary-vop <%fixnum>> ;
VOP: %eq? : %eq? binary-vop <%eq?> ;
! At the VOP level, the 'shift' operation is split into five
! distinct operations:
@ -159,19 +203,28 @@ VOP: %eq? : %eq? src/dest-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<< src/dest-vop <%fixnum<<> ;
VOP: %fixnum>> : %fixnum>> src/dest-vop <%fixnum>>> ;
VOP: %fixnum<< : %fixnum<< binary-vop <%fixnum<<> ;
VOP: %fixnum>> : %fixnum>> binary-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> ;
VOP: %fixnum-sgn : %fixnum-sgn binary-vop <%fixnum-sgn> ;
! Integer comparison followed by a conditional branch is
! optimized
VOP: %jump-fixnum<= : %jump-fixnum<= f swap <%jump-fixnum<=> ;
VOP: %jump-fixnum< : %jump-fixnum< f swap <%jump-fixnum<> ;
VOP: %jump-fixnum>= : %jump-fixnum>= f swap <%jump-fixnum>=> ;
VOP: %jump-fixnum> : %jump-fixnum> f swap <%jump-fixnum>> ;
VOP: %jump-eq? : %jump-eq? f swap <%jump-eq?> ;
VOP: %jump-fixnum<=
: %jump-fixnum<= 2-in/label-vop <%jump-fixnum<=> ;
VOP: %jump-fixnum<
: %jump-fixnum< 2-in/label-vop <%jump-fixnum<> ;
VOP: %jump-fixnum>=
: %jump-fixnum>= 2-in/label-vop <%jump-fixnum>=> ;
VOP: %jump-fixnum>
: %jump-fixnum> 2-in/label-vop <%jump-fixnum>> ;
VOP: %jump-eq?
: %jump-eq? 2-in/label-vop <%jump-eq?> ;
: fast-branch ( class -- class )
{{
@ -190,55 +243,62 @@ PREDICATE: tuple fast-branch
! some slightly optimized inline assembly
VOP: %type
: %type ( vreg ) <vreg> dest-vop <%type> ;
M: %type basic-block? drop t ;
VOP: %arithmetic-type
: %arithmetic-type <vreg> dest-vop <%arithmetic-type> ;
VOP: %tag-fixnum
: %tag-fixnum <vreg> dest-vop <%tag-fixnum> ;
M: %tag-fixnum basic-block? drop t ;
VOP: %untag-fixnum
: %untag-fixnum <vreg> dest-vop <%untag-fixnum> ;
M: %untag-fixnum basic-block? drop t ;
: check-dest ( vop reg -- )
swap vop-dest = [ "invalid VOP destination" throw ] unless ;
swap vop-out-1 = [
"invalid VOP destination" throw
] unless ;
VOP: %getenv
: %getenv dest/literal-vop <%getenv> ;
: %getenv swap src/dest-vop <%getenv> ;
M: %getenv basic-block? drop t ;
VOP: %setenv
: %setenv src/literal-vop <%setenv> ;
: %setenv 2-in-vop <%setenv> ;
M: %setenv basic-block? drop t ;
! alien operations
VOP: %parameters
: %parameters ( n -- vop ) literal-vop <%parameters> ;
: %parameters ( n -- vop ) src-vop <%parameters> ;
VOP: %parameter
: %parameter ( n -- vop ) literal-vop <%parameter> ;
: %parameter ( n -- vop ) src-vop <%parameter> ;
VOP: %cleanup
: %cleanup ( n -- vop ) literal-vop <%cleanup> ;
: %cleanup ( n -- vop ) src-vop <%cleanup> ;
VOP: %unbox
: %unbox ( [[ n func ]] -- vop ) literal-vop <%unbox> ;
: %unbox ( [[ n func ]] -- vop ) src-vop <%unbox> ;
VOP: %unbox-float
: %unbox-float ( [[ n func ]] -- vop ) literal-vop <%unbox-float> ;
: %unbox-float ( [[ n func ]] -- vop ) src-vop <%unbox-float> ;
VOP: %unbox-double
: %unbox-double ( [[ n func ]] -- vop ) literal-vop <%unbox-double> ;
: %unbox-double ( [[ n func ]] -- vop ) src-vop <%unbox-double> ;
VOP: %box
: %box ( func -- vop ) literal-vop <%box> ;
: %box ( func -- vop ) src-vop <%box> ;
VOP: %box-float
: %box-float ( func -- vop ) literal-vop <%box-float> ;
: %box-float ( func -- vop ) src-vop <%box-float> ;
VOP: %box-double
: %box-double ( [[ n func ]] -- vop ) literal-vop <%box-double> ;
: %box-double ( [[ n func ]] -- vop ) src-vop <%box-double> ;
VOP: %alien-invoke
: %alien-invoke ( func -- vop ) literal-vop <%alien-invoke> ;
: %alien-invoke ( func -- vop ) src-vop <%alien-invoke> ;
VOP: %alien-global
: %alien-global ( global -- vop ) literal-vop <%alien-global> ;
: %alien-global ( global -- vop ) src-vop <%alien-global> ;

10
library/compiler/x86/alien.factor
View File

@ -6,10 +6,10 @@ kernel-internals lists math memory namespaces words ;
M: %alien-invoke generate-node
#! call a C function.
vop-literal uncons load-library compile-c-call ;
vop-in-1 uncons load-library compile-c-call ;
M: %alien-global generate-node
vop-literal uncons load-library
vop-in-1 uncons load-library
2dup dlsym EAX swap unit MOV 0 0 rel-dlsym ;
M: %parameters generate-node
@ -23,7 +23,7 @@ M: %parameter generate-node
: UNBOX ( vop -- )
#! An unboxer function takes a value from the data stack and
#! converts it into a C value.
vop-literal cdr f compile-c-call ;
vop-in-1 cdr f compile-c-call ;
M: %unbox generate-node
#! C functions return integers in EAX.
@ -49,7 +49,7 @@ M: %unbox-double generate-node
#! A boxer function takes a C value as a parameter and
#! converts into a Factor value, and pushes it on the data
#! stack.
vop-literal f compile-c-call ;
vop-in-1 f compile-c-call ;
M: %box generate-node
#! C functions return integers in EAX.
@ -78,4 +78,4 @@ M: %cleanup generate-node
#! In the cdecl ABI, the caller must pop input parameters
#! off the C stack. In stdcall, the callee does it, so
#! this node is not used in that case.
vop-literal dup 0 = [ drop ] [ ESP swap ADD ] ifte ;
vop-in-1 dup 0 = [ drop ] [ ESP swap ADD ] ifte ;

12
library/compiler/x86/fixnum.factor
View File

@ -112,7 +112,7 @@ M: %fixnum-bitxor generate-node ( vop -- ) dest/src XOR ;
M: %fixnum-bitnot generate-node ( vop -- )
! Negate the bits of the operand
vop-dest v>operand dup NOT
vop-out-1 v>operand dup NOT
! Mask off the low 3 bits to give a fixnum tag
tag-mask XOR ;
@ -122,7 +122,7 @@ M: %fixnum<< generate-node
<label> "end" set
! make a copy
ECX EAX MOV
vop-source
vop-in-1
! check for potential overflow
1 over cell 8 * swap 1 - - shift ECX over ADD
2 * 1 - ECX swap CMP
@ -147,7 +147,7 @@ M: %fixnum<< generate-node
M: %fixnum>> generate-node
! shift register
dup vop-dest v>operand dup rot vop-source SAR
dup vop-out-1 v>operand dup rot vop-in-1 SAR
! give it a fixnum tag
tag-mask bitnot AND ;
@ -155,7 +155,7 @@ M: %fixnum-sgn generate-node
! store 0 in EDX if EAX is >=0, otherwise store -1.
CDQ
! give it a fixnum tag.
vop-dest v>operand tag-bits SHL ;
vop-out-1 v>operand tag-bits SHL ;
: conditional ( dest cond -- )
#! Compile this after a conditional jump to store f or t
@ -170,7 +170,7 @@ M: %fixnum-sgn generate-node
"end" get save-xt ; inline
: fixnum-compare ( vop -- dest )
dup vop-dest v>operand dup rot vop-source v>operand CMP ;
dup vop-out-1 v>operand dup rot vop-in-1 v>operand CMP ;
M: %fixnum< generate-node ( vop -- )
fixnum-compare \ JL conditional ;
@ -188,7 +188,7 @@ M: %eq? generate-node ( vop -- )
fixnum-compare \ JE conditional ;
: fixnum-branch ( vop -- label )
dup vop-dest v>operand over vop-source v>operand CMP
dup vop-in-2 v>operand over vop-in-1 v>operand CMP
vop-label ;
M: %jump-fixnum< generate-node ( vop -- )

20
library/compiler/x86/generator.factor
View File

@ -9,7 +9,7 @@ M: integer v>operand tag-bits shift ;
M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
: dest/src ( vop -- dest src )
dup vop-dest v>operand swap vop-source v>operand ;
dup vop-out-1 v>operand swap vop-in-1 v>operand ;
! Not used on x86
M: %prologue generate-node drop ;
@ -30,10 +30,10 @@ M: %jump generate-node ( vop -- )
vop-label dup postpone-word JMP ;
M: %jump-f generate-node ( vop -- )
dup vop-source v>operand f address CMP vop-label JE ;
dup vop-in-1 v>operand f address CMP vop-label JE ;
M: %jump-t generate-node ( vop -- )
dup vop-source v>operand f address CMP vop-label JNE ;
dup vop-in-1 v>operand f address CMP vop-label JNE ;
M: %return-to generate-node ( vop -- )
0 PUSH vop-label absolute ;
@ -42,19 +42,19 @@ M: %return generate-node ( vop -- )
drop RET ;
M: %untag generate-node ( vop -- )
vop-dest v>operand BIN: 111 bitnot AND ;
vop-out-1 v>operand BIN: 111 bitnot AND ;
M: %tag-fixnum generate-node ( vop -- )
vop-dest v>operand 3 SHL ;
vop-out-1 v>operand 3 SHL ;
M: %untag-fixnum generate-node ( vop -- )
vop-dest v>operand 3 SHR ;
vop-out-1 v>operand 3 SHR ;
M: %dispatch generate-node ( vop -- )
#! Compile a piece of code that jumps to an offset in a
#! jump table indexed by the fixnum at the top of the stack.
#! The jump table must immediately follow this macro.
vop-source v>operand
vop-in-1 v>operand
! Multiply by 4 to get a jump table offset
dup 2 SHL
! Add to jump table base
@ -68,10 +68,10 @@ M: %dispatch generate-node ( vop -- )
M: %type generate-node ( vop -- )
#! Intrinstic version of type primitive. It outputs an
#! UNBOXED value in vop-dest.
#! UNBOXED value in vop-out-1.
<label> "f" set
<label> "end" set
vop-dest v>operand
vop-out-1 v>operand
! Make a copy
ECX over MOV
! Get the tag
@ -96,7 +96,7 @@ M: %type generate-node ( vop -- )
M: %arithmetic-type generate-node ( vop -- )
#! This one works directly with the stack. It outputs an
#! UNBOXED value in vop-dest.
#! UNBOXED value in vop-out-1.
0 <vreg> check-dest
<label> "end" set
! Load top two stack values

42
library/compiler/x86/slots.factor
View File

@ -5,21 +5,21 @@ USING: alien assembler compiler inference kernel
kernel-internals lists math memory namespaces sequences words ;
M: %slot generate-node ( vop -- )
#! the untagged object is in vop-dest, the tagged slot
#! number is in vop-source.
#! the untagged object is in vop-out-1, the tagged slot
#! number is in vop-in-1.
dest/src
! turn tagged fixnum slot # into an offset, multiple of 4
dup 1 SHR
! compute slot address in vop-dest
! compute slot address in vop-out-1
dupd ADD
! load slot value in vop-dest
! load slot value in vop-out-1
dup unit MOV ;
M: %fast-slot generate-node ( vop -- )
#! the tagged object is in vop-dest, the pointer offset is
#! in vop-literal. the offset already takes the type tag
#! the tagged object is in vop-out-1, the pointer offset is
#! in vop-in-1. the offset already takes the type tag
#! into account, so its just one instruction to load.
dup vop-literal swap vop-dest v>operand tuck >r 2list r>
dup vop-in-1 swap vop-out-1 v>operand tuck >r 2list r>
swap MOV ;
: card-bits
@ -36,34 +36,34 @@ M: %fast-slot generate-node ( vop -- )
0 rel-cards ;
M: %set-slot generate-node ( vop -- )
#! the untagged object is in vop-dest, the new value is in
#! vop-source, the tagged slot number is in vop-literal.
dup vop-literal v>operand over vop-dest v>operand
#! the new value is vop-in-1, the object is vop-in-2, and
#! the slot number is vop-in-3.
dup vop-in-3 v>operand over vop-in-2 v>operand
! turn tagged fixnum slot # into an offset, multiple of 4
over 1 SHR
! compute slot address in vop-literal
! compute slot address in vop-in-2
2dup ADD
! store new slot value
>r >r vop-source v>operand r> unit swap MOV r>
>r >r vop-in-1 v>operand r> unit swap MOV r>
write-barrier ;
M: %fast-set-slot generate-node ( vop -- )
#! the tagged object is in vop-dest, the new value is in
#! vop-source, the pointer offset is in vop-literal. the
#! offset already takes the type tag into account, so its
#! just one instruction to load.
dup vop-literal over vop-dest v>operand
[ swap 2list swap vop-source v>operand MOV ] keep
#! the new value is vop-in-1, the object is vop-in-2, and
#! the slot offset is vop-in-3.
#! the offset already takes the type tag into account, so
#! it's just one instruction to load.
dup vop-in-3 over vop-in-2 v>operand
[ swap 2list swap vop-in-1 v>operand MOV ] keep
write-barrier ;
: userenv@ ( n -- addr )
cell * "userenv" f dlsym + ;
M: %getenv generate-node ( vop -- )
dup vop-dest v>operand swap vop-literal
dup vop-out-1 v>operand swap vop-in-1
[ userenv@ unit MOV ] keep 0 rel-userenv ;
M: %setenv generate-node ( vop -- )
dup vop-literal
[ userenv@ unit swap vop-source v>operand MOV ] keep
dup vop-in-2
[ userenv@ unit swap vop-in-1 v>operand MOV ] keep
0 rel-userenv ;

18
library/compiler/x86/stack.factor
View File

@ -18,38 +18,38 @@ memory sequences words ;
: cs-op ( n -- op ) ECX swap reg-stack ;
M: %peek-d generate-node ( vop -- )
dup vop-dest v>operand swap vop-literal ds-op MOV ;
dup vop-out-1 v>operand swap vop-in-1 ds-op MOV ;
M: %replace-d generate-node ( vop -- )
dup vop-source v>operand swap vop-literal ds-op swap MOV ;
dup vop-in-2 v>operand swap vop-in-1 ds-op swap MOV ;
M: %inc-d generate-node ( vop -- )
ESI swap vop-literal cell *
ESI swap vop-in-1 cell *
dup 0 > [ ADD ] [ neg SUB ] ifte ;
M: %immediate generate-node ( vop -- )
dup vop-dest v>operand swap vop-literal address MOV ;
dup vop-out-1 v>operand swap vop-in-1 address MOV ;
: load-indirect ( dest literal -- )
intern-literal unit MOV 0 0 rel-address ;
M: %indirect generate-node ( vop -- )
#! indirect load of a literal through a table
dup vop-dest v>operand swap vop-literal load-indirect ;
dup vop-out-1 v>operand swap vop-in-1 load-indirect ;
M: %peek-r generate-node ( vop -- )
ECX CS> dup vop-dest v>operand swap vop-literal cs-op MOV ;
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-literal ECX swap cell * SUB ECX >CS ;
vop-in-1 ECX swap cell * SUB ECX >CS ;
M: %replace-r generate-node ( vop -- )
#! Can only follow a %inc-r
dup vop-source v>operand swap vop-literal cs-op swap MOV
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-literal ECX swap cell * ADD ;
vop-in-1 ECX swap cell * ADD ;

4
library/generic/builtin.factor
View File

@ -25,7 +25,9 @@ builtin 50 "priority" set-word-prop
builtin [ 2drop t ] "class<" set-word-prop
: builtin-predicate ( class -- )
dup "predicate" word-prop car swap
dup "predicate" word-prop car
dup t "inline" set-word-prop
swap
[
\ type , "builtin-type" word-prop , \ eq? ,
] make-list

2
library/generic/tuple.factor
View File

@ -69,7 +69,7 @@ UNION: arrayed array tuple ;
] make-list define-compound ;
: forget-tuple ( class -- )
dup forget "predicate" word-prop car forget ;
dup forget "predicate" word-prop car [ forget ] when* ;
: check-shape ( word slots -- )
#! If the new list of slots is different from the previous,

75
library/inference/branches.factor
View File

@ -73,33 +73,11 @@ sequences strings vectors words hashtables prettyprint ;
terminate
] ifte* ;
SYMBOL: cloned
GENERIC: (deep-clone)
: deep-clone ( obj -- obj )
dup cloned get assq [ ] [
dup (deep-clone) [ swap cloned [ acons ] change ] keep
] ?ifte ;
M: tuple (deep-clone) ( obj -- obj )
#! Clone an object if it hasn't already been cloned in this
#! with-deep-clone scope.
clone dup <mirror> [ deep-clone ] nmap ;
M: vector (deep-clone) ( seq -- seq )
#! Clone a sequence and each object it contains.
[ deep-clone ] map ;
M: cons (deep-clone) ( cons -- cons )
uncons deep-clone >r deep-clone r> cons ;
M: object (deep-clone) ( obj -- obj ) ;
: deep-clone ( seq -- seq ) [ clone ] map ;
: copy-inference ( -- )
#! We avoid cloning the same object more than once in order
#! to preserve identity structure.
cloned off
meta-r [ deep-clone ] change
meta-d [ deep-clone ] change
d-in [ deep-clone ] change
@ -111,8 +89,6 @@ M: object (deep-clone) ( obj -- obj ) ;
#! terminate was called.
<namespace> [
copy-inference
uncons deep-clone pull-tie
cloned off
dup value-recursion recursive-state set
literal-value dup infer-quot
active? [
@ -124,10 +100,6 @@ M: object (deep-clone) ( obj -- obj ) ;
] extend ;
: (infer-branches) ( branchlist -- list )
#! The branchlist is a list of pairs: [[ value typeprop ]]
#! value is either a literal or computed instance; typeprop
#! is a pair [[ value class ]] indicating a type propagation
#! for the given branch.
[
[
inferring-base-case get [
@ -148,60 +120,23 @@ M: object (deep-clone) ( obj -- obj ) ;
#! base case to this stack effect and try again.
(infer-branches) dup unify-effects unify-dataflow ;
: boolean-value? ( value -- ? )
#! Return if the value's boolean valuation is known.
value-class dup \ f = >r \ f class-and null = r> or ;
: boolean-value ( value -- ? )
#! Only valid if boolean? returns true.
value-class \ f = not ;
: static-ifte? ( value -- ? )
#! Is the outcome of this branch statically known?
dup value-safe? swap boolean-value? and ;
: static-ifte ( true false -- )
#! If the branch taken is statically known, just infer
#! along that branch.
1 dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte
>literal< infer-quot-value ;
: infer-ifte ( true false -- )
#! If branch taken is computed, infer along both paths and
#! unify.
2list >r pop-d \ ifte r>
pick [ POSTPONE: f general-t ] [ <class-tie> ] map-with
zip ( condition )
infer-branches ;
2list >r pop-d \ ifte r> infer-branches ;
\ ifte [
2 dataflow-drop, pop-d pop-d swap
peek-d static-ifte? [
static-ifte
] [
infer-ifte
] ifte
2 dataflow-drop, pop-d pop-d swap infer-ifte
] "infer" set-word-prop
: vtable>list ( rstate vtable -- list )
[ swap <literal> ] map-with >list ;
: <dispatch-index> ( value -- value )
value-literal-ties
0 recursive-state get <literal>
[ set-value-literal-ties ] keep ;
USE: kernel-internals
: infer-dispatch ( rstate vtable -- )
>r >r peek-d \ dispatch r> r>
vtable>list
pop-d <dispatch-index>
over length [ <literal-tie> ] project-with
zip infer-branches ;
>r >r pop-d \ dispatch r> r> vtable>list infer-branches ;
\ dispatch [
pop-literal infer-dispatch
] "infer" set-word-prop
\ dispatch [ pop-literal infer-dispatch ] "infer" set-word-prop
\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop

23
library/inference/partial-eval.factor
View File

@ -39,6 +39,7 @@ sequences words ;
! Could probably add more words here
[
eq?
car
cdr
cons
@ -69,28 +70,6 @@ sequences words ;
stateless
] each
: eq-tie ( v1 v2 bool -- )
>r swap literal-value <literal-tie> general-t swons unit r>
set-value-class-ties ;
: eq-ties ( v1 v2 bool -- )
#! If the boolean is true, the values are equal.
pick literal? [
eq-tie
] [
over literal? [
swapd eq-tie
] [
3drop
] ifte
] ifte ;
\ eq? [
peek-d peek-next-d
\ eq? infer-eval
peek-d eq-ties
] "infer" set-word-prop
! Partially-evaluated words need their stack effects to be
! entered by hand.
\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop

48
library/inference/ties.factor
View File

@ -1,48 +0,0 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: kernel lists prettyprint ;
! A tie is when a literal value determines the type or value of
! a computed result. For example, in the following code, the
! type of the top of the stack depends on the outcome of the
! branch:
!
! dup cons? [ ... ] [ ... ] ifte
!
! In each branch, there is a different tie of the value to a
! type.
!
! Another type of tie happends with generic dispatch.
!
! The return value of the 'type' primitive determines the type
! of a value. The branch chosen in a dispatch determines the
! numeric value used as the dispatch parameter. Because of a
! pair of ties, this allows inferences such as the following
! having a stack effect of [ [ cons ] [ object ] ]:
!
! GENERIC: car
! M: cons car 0 slot ;
!
! The only branch that does not end with no-method pulls
! a tie that sets the value's type to cons after two steps.
! Formally, a tie is a tuple.
GENERIC: pull-tie ( tie -- )
TUPLE: class-tie value class ;
M: class-tie pull-tie ( tie -- )
dup class-tie-class swap class-tie-value
2dup set-value-class
value-class-ties assoc pull-tie ;
TUPLE: literal-tie value literal ;
M: literal-tie pull-tie ( tie -- )
dup literal-tie-literal swap literal-tie-value
dup literal? [ 2dup set-literal-value ] when
value-literal-ties assoc pull-tie ;
M: f pull-tie ( tie -- )
#! For convenience.
drop ;

30
library/inference/types.factor
View File

@ -1,30 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: generic interpreter kernel lists math namespaces words ;
: type-value-map ( value -- )
num-types
[ tuck builtin-type <class-tie> cons ] project-with
[ cdr class-tie-class ] subset ;
: infer-type ( -- )
f \ type dataflow, [
peek-d type-value-map >r
1 0 node-inputs
[ object ] consume-d
[ fixnum ] produce-d
r> peek-d set-value-literal-ties
1 0 node-outputs
] bind ;
: type-known? ( value -- ? )
dup value-safe? swap value-types cdr not and ;
\ type [
peek-d type-known? [
1 dataflow-drop, pop-d value-types car apply-literal
] [
infer-type
] ifte
] "infer" set-word-prop

2
library/inference/values.factor
View File

@ -7,7 +7,7 @@ GENERIC: value= ( literal value -- ? )
GENERIC: value-class-and ( class value -- )
GENERIC: safe-literal? ( value -- ? )
TUPLE: value class recursion class-ties literal-ties safe? ;
TUPLE: value class recursion safe? ;
C: value ( recursion -- value )
[ t swap set-value-safe? ] keep

8
library/test/compiler/intrinsics.factor
View File

@ -11,6 +11,9 @@ math-internals test words ;
[ 3 ] [ 3 1 2 cons [ [ 0 set-slot ] keep ] compile-1 car ] unit-test
[ 3 ] [ 3 1 2 [ cons [ 0 set-slot ] keep ] compile-1 car ] unit-test
[ 3 ] [ [ 3 1 2 cons [ 0 set-slot ] keep ] compile-1 car ] unit-test
[ 3 ] [ 3 1 2 cons [ [ 1 set-slot ] keep ] compile-1 cdr ] unit-test
[ 3 ] [ 3 1 2 [ cons [ 1 set-slot ] keep ] compile-1 cdr ] unit-test
[ 3 ] [ [ 3 1 2 cons [ 1 set-slot ] keep ] compile-1 cdr ] unit-test
[ ] [ 1 [ drop ] compile-1 ] unit-test
[ ] [ [ 1 drop ] compile-1 ] unit-test
@ -158,3 +161,8 @@ math-internals test words ;
[ 1 1 0 ] [ 1 1 [ arithmetic-type ] compile-1 ] unit-test
[ 1.0 1.0 5 ] [ 1.0 1 [ arithmetic-type ] compile-1 ] unit-test
[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] ifte ] compile-1 ] unit-test
[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] ifte ] compile-1 ] unit-test
[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] ifte ] compile-1 ] unit-test
[ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] ifte ] compile-1 ] unit-test

55
library/test/inference.factor
View File

@ -146,24 +146,17 @@ SYMBOL: sym-test
[ [[ 0 1 ]] ] [ [ sym-test ] infer old-effect ] unit-test
[ [[ 2 0 ]] ] [ [ push ] infer old-effect ] unit-test
[ [[ 2 0 ]] ] [ [ set-length ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ 2list ] infer old-effect ] unit-test
[ [[ 3 1 ]] ] [ [ 3list ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ append ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ swons ] infer old-effect ] unit-test
[ [[ 1 2 ]] ] [ [ uncons ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ unit ] infer old-effect ] unit-test
[ [[ 1 2 ]] ] [ [ unswons ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ last ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ peek ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ list? ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ length ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ reverse ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ contains? ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ remove ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ prune ] infer old-effect ] unit-test
[ [[ 1 0 ]] ] [ [ >n ] infer old-effect ] unit-test
[ [[ 0 1 ]] ] [ [ n> ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ bitor ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ bitand ] infer old-effect ] unit-test
@ -182,13 +175,6 @@ SYMBOL: sym-test
[ [[ 2 1 ]] ] [ [ >= ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ number= ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ = ] infer old-effect ] unit-test
[ [[ 1 0 ]] ] [ [ >n ] infer old-effect ] unit-test
[ [[ 0 1 ]] ] [ [ n> ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ get ] infer old-effect ] unit-test
: terminator-branch
dup [
car
@ -198,15 +184,13 @@ SYMBOL: sym-test
[ [[ 1 1 ]] ] [ [ terminator-branch ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ str>number ] infer old-effect ] unit-test
! Type inference
[ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
[ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
[ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
[ [ [ object ] [ general-t ] ] ] [ [ dup [ drop t ] unless ] infer ] unit-test
[ [ [ general-list ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
! [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
! [ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
! [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
! [ [ [ object ] [ boolean ] ] ] [ [ dup [ drop t ] unless ] infer ] unit-test
! [ [ [ general-list ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
! [ [ 5 car ] infer ] unit-test-fails
@ -219,12 +203,12 @@ M: fixnum potential-hang dup [ potential-hang ] when ;
! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
! [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test
[ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test
[ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test
[ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test
[ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test
! [ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test
! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test
! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test
! [ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test
[ [ [ object ] [ cons ] ] ] [ [ dup cons? [ drop [[ 1 2 ]] ] unless ] infer ] unit-test
! [ [ [ object ] [ cons ] ] ] [ [ dup cons? [ drop [[ 1 2 ]] ] unless ] infer ] unit-test
TUPLE: funny-cons car cdr ;
GENERIC: iterate
@ -233,3 +217,18 @@ M: f iterate drop ;
M: real iterate drop ;
[ [[ 1 0 ]] ] [ [ iterate ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ str>number ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ = ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ get ] infer old-effect ] unit-test
[ [[ 2 0 ]] ] [ [ push ] infer old-effect ] unit-test
[ [[ 2 0 ]] ] [ [ set-length ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ append ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ peek ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ length ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ reverse ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ contains? ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ remove ] infer old-effect ] unit-test
[ [[ 1 1 ]] ] [ [ prune ] infer old-effect ] unit-test

1
library/test/lists/lists.factor
View File

@ -44,7 +44,6 @@ USING: kernel lists sequences test ;
[ [ 1 2 3 ] ] [ 2 [ 1 2 3 ] unique ] unit-test
[ [ ] ] [ 0 count ] unit-test
[ [ ] ] [ -10 count ] unit-test
[ [ 0 1 2 3 ] ] [ 4 count ] unit-test
[ f ] [ f 0 head ] unit-test