+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
"/library/inference/dataflow.factor"\r
"/library/inference/values.factor"\r
"/library/inference/inference.factor"\r
- "/library/inference/ties.factor"\r
"/library/inference/branches.factor"\r
"/library/inference/words.factor"\r
"/library/inference/stack.factor"\r
- "/library/inference/types.factor"\r
"/library/inference/partial-eval.factor"\r
\r
"/library/compiler/assembler.factor"\r
! 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.
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 [
] 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 ? )
! 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
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: calls-label? ( label vop -- ? )
+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:
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 ;
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 , ;
! 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:
! - 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 )
{{
! 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> ;
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
: 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.
#! 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.
#! 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 ;
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 ;
<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
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 ;
! 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
"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 ;
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 -- )
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 ;
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 ;
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
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
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
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
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 ;
: 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 ;
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
] 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,
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
#! 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? [
] 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 [
#! 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 ;
-
-\ dispatch [
- pop-literal infer-dispatch
-] "infer" set-word-prop
+ >r >r pop-d \ dispatch r> r> vtable>list infer-branches ;
+
+\ dispatch [ pop-literal infer-dispatch ] "infer" set-word-prop
\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop
! Could probably add more words here
[
+ eq?
car
cdr
cons
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
+++ /dev/null
-! 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 ;
+++ /dev/null
-! 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
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
[ 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
[ 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
[ [[ 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
[ [[ 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
[ [[ 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
! [ [ [ 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
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 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
projects / factor.git / commitdiff