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

working on the compiler

cvs
Slava Pestov 2005-05-16 01:17:56 +00:00
parent 7fa5d5f14a
commit fdcf721857
33 changed files with 388 additions and 299 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -28,12 +28,14 @@ recrossref
t [
"/library/inference/conditions.factor"
"/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"
"/library/compiler/relocate.factor"

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

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
USING: alien assembler command-line compiler io-internals kernel
lists math namespaces parser sequences stdio unparser words ;
USING: alien assembler command-line compiler compiler-backend
io-internals kernel lists math namespaces parser sequences stdio
unparser words ;
"Compiling base..." print
@ -36,6 +37,7 @@ compile? [
\ = compile
\ unparse compile
\ scan compile
\ (generate) compile
] when
"Loading more library code..." print

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

@ -182,7 +182,7 @@ C: range ( from to -- range )
[ set-range-from ] keep ;
M: range length ( range -- n )
dup range-to swap range-from - abs 1 + ;
dup range-to swap range-from - abs ;
M: range nth ( n range -- n )
[ range-step * ] keep range-from + ;
@ -200,6 +200,9 @@ M: slice nth ( n slice -- obj )
M: slice set-nth ( obj n slice -- )
[ delegate nth ] keep slice-seq set-nth ;
: tail-slice ( n seq -- slice )
[ length [ swap - ] keep ] keep <slice> ;
IN: kernel
: depth ( -- n )

27
library/compiler/intrinsics.factor
View File

@ -11,18 +11,20 @@ sequences words ;
#! by GC, and is indexed through a table.
dup fixnum? swap f eq? or ;
: push-1 ( obj -- )
0 swap literal-value dup
immediate? [ %immediate ] [ %indirect ] ifte , ;
#push [
1 %inc-d ,
[ node-param get ] bind dup immediate? [
%immediate-d ,
] [
0 swap %indirect , out-1
] ifte
[ node-produce-d get ] bind
dup length dup %inc-d ,
1 - swap [
push-1 0 over %replace-d ,
] each drop
] "linearizer" set-word-prop
\ drop [
drop
1 %dec-d ,
#drop [
[ node-consume-d get length ] bind %dec-d ,
] "linearizer" set-word-prop
\ dup [
@ -171,9 +173,12 @@ sequences words ;
1 <vreg> 0 <vreg> rot execute ,
r> 0 %replace-d , ;
: literal-fixnum? ( value -- ? )
dup literal? [ literal-value fixnum? ] [ drop f ] ifte ;
: binary-op ( node op out -- )
#! out is a vreg where the vop stores the result.
>r >r node-peek dup literal? [
>r >r node-peek dup literal-fixnum? [
1 %dec-d ,
in-1
literal-value 0 <vreg> r> execute ,
@ -206,7 +211,7 @@ sequences words ;
\ fixnum* [
! Turn multiplication by a power of two into a left shift.
node-peek dup literal? [
node-peek dup literal-fixnum? [
literal-value dup power-of-2? [
1 %dec-d ,
in-1

13
library/compiler/linearizer.factor
View File

@ -21,16 +21,6 @@ math namespaces words strings errors prettyprint sequences ;
#! rest is arguments.
[ %prologue , (linearize) ] make-list ;
: linearize-simple-label ( node -- )
#! Some labels become simple labels after the optimization
#! stage.
dup [ node-label get ] bind %label ,
[ node-param get ] bind (linearize) ;
#simple-label [
linearize-simple-label
] "linearizer" set-word-prop
: linearize-label ( node -- )
#! Labels are tricky, because they might contain non-tail
#! calls. So we push the address of the location right after
@ -39,7 +29,8 @@ math namespaces words strings errors prettyprint sequences ;
#! this in the common case where the labelled block does
#! not contain non-tail recursive calls to itself.
<label> dup %return-to , >r
linearize-simple-label
dup [ node-label get ] bind %label ,
[ node-param get ] bind (linearize)
f %return ,
r> %label , ;

37
library/compiler/optimizer.factor
View File

@ -100,9 +100,26 @@ SYMBOL: branch-returns
node-param [ [ dupd kill-nodes ] map nip ] change
] extend , ;
#push [ [ node-param get ] bind , ] "scan-literal" set-word-prop
#push [ consumes-literal? not ] "can-kill" set-word-prop
#push [ kill-node ] "kill-node" set-word-prop
: kill-literal ( literals values -- values )
[
swap [ swap value= ] some-with? not
] subset-with ;
#push [
[ node-produce-d get ] bind [ literal-value ] map %
] "scan-literal" set-word-prop
#push [ 2drop t ] "can-kill" set-word-prop
#push [
[ node-produce-d [ kill-literal ] change ] extend ,
] "kill-node" set-word-prop
#drop [ 2drop t ] "can-kill" set-word-prop
#drop [
[ node-consume-d [ kill-literal ] change ] extend ,
] "kill-node" set-word-prop
#label [
[ node-param get ] bind (scan-literals)
@ -123,10 +140,6 @@ SYMBOL: branch-returns
[ node-param get ] bind calls-label?
] "calls-label" set-word-prop
#simple-label [
[ node-param get ] bind calls-label?
] "calls-label" set-word-prop
: branches-call-label? ( label list -- ? )
[ calls-label? ] some-with? ;
@ -138,16 +151,8 @@ SYMBOL: branch-returns
[ node-param get ] bind branches-call-label?
] "calls-label" set-word-prop
: optimize-label ( -- op )
#! Does the label node contain calls to itself?
node-label get node-param get calls-label?
#label #simple-label ? ;
#label [ ( literals node -- )
[
optimize-label node-op set
node-param [ kill-nodes ] change
] extend ,
[ node-param [ kill-nodes ] change ] extend ,
] "kill-node" set-word-prop
#values [

19
library/compiler/simplifier.factor
View File

@ -51,14 +51,15 @@ M: %label simplify-node ( linear vop -- linear ? )
M: %inc-d simplify-node ( linear vop -- linear ? )
#! %inc-d cancels a following %inc-d.
>r dup \ %inc-d next-physical? [
vop-literal r> vop-literal + dup 0 = [
drop cdr cdr f
] [
%inc-d >r cdr cdr r> swons t
] ifte
dup vop-literal 0 = [
drop cdr t
] [
r> 2drop f
>r dup \ %inc-d next-physical? [
vop-literal r> vop-literal +
%inc-d >r cdr cdr r> swons t
] [
r> 2drop f
] ifte
] ifte ;
: dead-load? ( linear vop -- ? )
@ -91,8 +92,8 @@ M: %replace-d simplify-node ( linear vop -- linear ? )
] ifte
] ifte ;
M: %immediate-d simplify-node ( linear vop -- linear ? )
over 0 dead-store? [ drop cdr t ] [ drop f ] 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 ;

4
library/compiler/vops.factor
View File

@ -93,8 +93,8 @@ VOP: %inc-d
: %inc-d ( n -- ) literal-vop <%inc-d> ;
: %dec-d ( n -- ) neg %inc-d ;
VOP: %immediate
VOP: %immediate-d
: %immediate-d ( obj -- ) literal-vop <%immediate-d> ;
: %immediate ( vreg obj -- )
>r <vreg> r> dest/literal-vop <%immediate> ;
VOP: %peek-r
: %peek-r ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-r> ;
VOP: %replace-r

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

@ -36,7 +36,7 @@ memory namespaces words ;
! An untagged pointer to the bignum is now in EAX; tag it
EAX bignum-tag OR
ESP 4 ADD
"end" get save-xt ;
"end" get save-xt ; inline
M: %fixnum+ generate-node ( vop -- )
dest/src 2dup ADD \ SUB \ ADD simple-overflow ;

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

@ -30,9 +30,6 @@ M: %inc-d generate-node ( vop -- )
M: %immediate generate-node ( vop -- )
dup vop-dest v>operand swap vop-literal address MOV ;
M: %immediate-d generate-node ( vop -- )
vop-literal [ ESI ] swap address MOV ;
: load-indirect ( dest literal -- )
intern-literal unit MOV 0 0 rel-address ;

2
library/generic/builtin.factor
View File

@ -39,7 +39,7 @@ builtin [ 2drop t ] "class<" set-word-prop
dup intern-symbol
dup r> "builtin-type" set-word-prop
dup builtin define-class
dup r> unit "predicate" set-word-prop
dup r> set-predicate
dup builtin-predicate
dup r> define-slots
register-builtin ;

4
library/generic/generic.factor
View File

@ -174,4 +174,8 @@ SYMBOL: object
dup builtin-supertypes [ > ] sort
typemap get set-hash ;
: set-predicate ( class word -- )
dup t "inline" set-word-prop
unit "predicate" set-word-prop ;
typemap get [ <namespace> typemap set ] unless

8
library/generic/tuple.factor
View File

@ -69,8 +69,7 @@ UNION: arrayed array tuple ;
: tuple-predicate ( word -- )
#! Make a foo? word for testing the tuple class at the top
#! of the stack.
dup predicate-word
2dup unit "predicate" set-word-prop
dup predicate-word 2dup set-predicate
swap [
[ dup tuple? ] %
[ \ class-tuple , literal, \ eq? , ] make-list ,
@ -78,12 +77,15 @@ UNION: arrayed array tuple ;
\ ifte ,
] make-list define-compound ;
: forget-tuple ( class -- )
dup forget "predicate" word-prop car forget ;
: check-shape ( word slots -- )
#! If the new list of slots is different from the previous,
#! forget the old definition.
>r "use" get search dup [
dup "tuple-size" word-prop r> length 2 + =
[ drop ] [ forget ] ifte
[ drop ] [ forget-tuple ] ifte
] [
r> 2drop
] ifte ;

62
library/inference/branches.factor
View File

@ -4,7 +4,7 @@ IN: inference
USING: errors generic interpreter kernel lists math namespaces
sequences strings vectors words hashtables prettyprint ;
: longest-vector ( list -- length )
: longest ( list -- length )
0 swap [ length max ] each ;
: computed-value-vector ( n -- vector )
@ -17,7 +17,7 @@ sequences strings vectors words hashtables prettyprint ;
: unify-lengths ( list -- list )
#! Pad all vectors to the same length. If one vector is
#! shorter, pad it with unknown results at the bottom.
dup longest-vector swap [ add-inputs ] map-with ;
dup longest swap [ add-inputs ] map-with ;
: unify-results ( list -- value )
#! If all values in list are equal, return the value.
@ -137,49 +137,20 @@ SYMBOL: cloned
#! base case to this stack effect and try again.
(infer-branches) dup unify-effects unify-dataflow ;
: (with-block) ( [[ label quot ]] quot -- node )
#! Call a quotation in a new namespace, and transfer
#! inference state from the outer scope.
swap car >r [
dataflow-graph off
call
d-in get meta-d get meta-r get get-dataflow
] with-scope
r> swap #label dataflow, [ node-label set ] extend >r
meta-r set meta-d set d-in set r> ;
: with-block ( word [[ label quot ]] quot -- node )
#! Execute a quotation with the word on the stack, and add
#! its dataflow contribution to a new block node in the IR.
over [
>r
dupd cons
recursive-state [ cons ] change
r> call
] (with-block) ;
: dynamic-ifte ( true false -- )
: infer-ifte ( true false -- )
#! If branch taken is computed, infer along both paths and
#! unify.
2list >r peek-d \ ifte r>
pop-d [
dup \ general-t <class-tie> ,
\ f <class-tie> ,
] make-list zip ( condition )
2list >r pop-d \ ifte r>
pick [ general-t POSTPONE: f ] [ <class-tie> ] map-with
zip ( condition )
infer-branches ;
: infer-ifte ( -- )
#! Infer effects for both branches, unify.
[ object general-list general-list ] ensure-d
dataflow-drop, pop-d
dataflow-drop, pop-d swap
dynamic-ifte ;
\ ifte [
2 dataflow-drop, pop-d pop-d swap infer-ifte
] "infer" set-word-prop
\ ifte [ infer-ifte ] "infer" set-word-prop
: vtable>list ( value -- list )
dup value-recursion swap literal-value >list
[ over <literal> ] map nip ;
: vtable>list ( rstate vtable -- list )
[ swap <literal> ] map-with >list ;
: <dispatch-index> ( value -- value )
value-literal-ties
@ -188,17 +159,12 @@ SYMBOL: cloned
USE: kernel-internals
: dynamic-dispatch ( vtable -- )
>r peek-d \ dispatch r>
: 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 ;
: infer-dispatch ( -- )
#! Infer effects for all branches, unify.
[ object vector ] ensure-d
dataflow-drop, pop-d dynamic-dispatch ;
\ dispatch [ infer-dispatch ] "infer" set-word-prop
\ dispatch [ pop-literal infer-dispatch ] "infer" set-word-prop
\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop

57
library/inference/dataflow.factor
View File

@ -1,39 +1,11 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USE: interpreter
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: words
USE: vectors
USE: sequences
USING: interpreter kernel lists namespaces sequences vectors
words ;
! Recursive state. An alist, mapping words to labels.
SYMBOL: recursive-state
! We build a dataflow graph for the compiler.
SYMBOL: dataflow-graph
@ -41,14 +13,10 @@ SYMBOL: dataflow-graph
! Label nodes have the node-label variable set.
SYMBOL: #label
! A label that is not called recursively at all, or only tail
! recursively. The optimizer changes some #labels to
! #simple-labels.
SYMBOL: #simple-label
SYMBOL: #call ( non-tail call )
SYMBOL: #call-label
SYMBOL: #push ( literal )
SYMBOL: #drop
! This is purely a marker for values we retain after a
! conditional. It does not generate code, but merely alerts the
@ -101,10 +69,11 @@ SYMBOL: node-param
#! Add a node to the dataflow IR.
<dataflow-node> dup dataflow-graph [ cons ] change ;
: dataflow-drop, ( -- )
#! Remove the top stack element and add a dataflow node
#! noting this.
f \ drop dataflow, [ 1 0 node-inputs ] bind ;
: dataflow-drop, ( n -- )
f #drop dataflow, [ 0 node-inputs ] bind ;
: dataflow-push, ( n -- )
f #push dataflow, [ 0 node-outputs ] bind ;
: apply-dataflow ( dataflow name default -- )
#! For the dataflow node, look up named word property,

92
library/inference/inference.factor
View File

@ -17,68 +17,9 @@ SYMBOL: inferring-base-case
! inputs.
SYMBOL: d-in
! Recursive state. An alist, mapping words to labels.
SYMBOL: recursive-state
GENERIC: value= ( literal value -- ? )
GENERIC: value-class-and ( class value -- )
TUPLE: value class recursion class-ties literal-ties ;
C: value ( recursion -- value )
[ set-value-recursion ] keep ;
TUPLE: computed ;
C: computed ( class -- value )
swap recursive-state get <value> [ set-value-class ] keep
over set-delegate ;
M: computed value= ( literal value -- ? )
2drop f ;
: failing-class-and ( class class -- class )
2dup class-and dup null = [
-rot [
word-name , " and " , word-name ,
" do not intersect" ,
] make-string inference-warning
] [
2nip
] ifte ;
M: computed value-class-and ( class value -- )
[
value-class failing-class-and
] keep set-value-class ;
TUPLE: literal value ;
C: literal ( obj rstate -- value )
[
>r <value> [ >r dup class r> set-value-class ] keep
r> set-delegate
] keep
[ set-literal-value ] keep ;
M: literal value= ( literal value -- ? )
literal-value = ;
M: literal value-class-and ( class value -- )
value-class class-and drop ;
M: literal set-value-class ( class value -- )
2drop ;
M: computed literal-value ( value -- )
"A literal value was expected where a computed value was"
" found: " rot unparse cat3 inference-error ;
: value-types ( value -- list )
value-class builtin-supertypes ;
: pop-literal ( -- rstate obj )
dataflow-drop, pop-d dup value-recursion swap literal-value ;
1 dataflow-drop, pop-d
dup value-recursion swap literal-value ;
: (ensure-types) ( typelist n stack -- )
pick [
@ -131,8 +72,7 @@ GENERIC: apply-object
: apply-literal ( obj -- )
#! Literals are annotated with the current recursive
#! state.
dup recursive-state get <literal> push-d
#push dataflow, [ 1 0 node-outputs ] bind ;
recursive-state get <literal> push-d 1 dataflow-push, ;
M: object apply-object apply-literal ;
@ -140,11 +80,6 @@ M: object apply-object apply-literal ;
#! Is this branch not terminated?
d-in get meta-d get and ;
: check-active ( -- )
active? [
"Provable runtime error" inference-error
] unless ;
: effect ( -- [[ d-in meta-d ]] )
d-in get meta-d get cons ;
@ -170,9 +105,12 @@ M: object apply-object apply-literal ;
drop
] ifte ;
: check-active ( -- )
active? [ "Provable runtime error" inference-error ] unless ;
: check-return ( -- )
#! Raise an error if word leaves values on return stack.
meta-r get length 0 = [
meta-r get empty? [
"Word leaves elements on return stack" inference-error
] unless ;
@ -182,16 +120,18 @@ M: object apply-object apply-literal ;
meta-d get >list node-consume-d set
] bind ;
: (infer) ( quot -- )
f init-inference
infer-quot
check-active
#return values-node check-return ;
: with-infer ( quot -- )
[
f init-inference
call
check-active
check-return
] with-scope ;
: infer ( quot -- [[ in out ]] )
#! Stack effect of a quotation.
[ (infer) effect present-effect ] with-scope ;
[ infer-quot effect present-effect ] with-infer ;
: dataflow ( quot -- dataflow )
#! Data flow of a quotation.
[ (infer) get-dataflow ] with-scope ;
[ infer-quot #return values-node get-dataflow ] with-infer ;

96
library/inference/partial-eval.factor Normal file
View File

@ -0,0 +1,96 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: generic interpreter kernel lists math namespaces
sequences words ;
: literal-inputs? ( in stack -- )
tail-slice dup >list [ literal-safe? ] all? [
length dataflow-drop, t
] [
drop f
] ifte ;
: literal-inputs ( out stack -- )
tail-slice [ literal-value ] nmap ;
: literal-outputs ( out stack -- )
tail-slice dup [ recursive-state get <literal> ] nmap
length dataflow-push, ;
: partial-eval? ( word -- ? )
"infer-effect" word-prop car length
meta-d get literal-inputs? ;
: infer-eval ( word -- )
dup partial-eval? [
dup "infer-effect" word-prop 2unlist
>r length meta-d get
literal-inputs
host-word
r> length meta-d get literal-outputs
] [
dup "infer-effect" word-prop consume/produce
] ifte ;
: stateless ( word -- )
#! A stateless word can be evaluated at compile-time.
dup unit [ car infer-eval ] cons "infer" set-word-prop ;
! Could probably add more words here
[
car
cdr
cons
<
<=
>
>=
number=
+
-
*
/
/i
/f
mod
/mod
bitand
bitor
bitxor
shift
bitnot
>fixnum
>bignum
>float
real
imaginary
] [
stateless
] each
! Partially-evaluated words need their stack effects to be
! entered by hand.
\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ number= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop
\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop

11
library/inference/stack.factor
View File

@ -15,12 +15,13 @@ USING: interpreter kernel namespaces words ;
[ 1 0 node-outputs ] bind
] "infer" set-word-prop
: infer-shuffle ( word -- )
f over dup
"infer-effect" word-prop
[ host-word ] with-dataflow ;
: partial-eval ( word quot -- | quot: word -- )
>r f over dup "infer-effect" word-prop r> with-dataflow ;
\ drop [ \ drop infer-shuffle ] "infer" set-word-prop
: infer-shuffle ( word -- )
[ host-word ] partial-eval ;
\ drop [ 1 dataflow-drop, pop-d drop ] "infer" set-word-prop
\ dup [ \ dup infer-shuffle ] "infer" set-word-prop
\ swap [ \ swap infer-shuffle ] "infer" set-word-prop
\ over [ \ over infer-shuffle ] "infer" set-word-prop

66
library/inference/values.factor Normal file
View File

@ -0,0 +1,66 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: generic kernel namespaces sequences unparser words ;
GENERIC: value= ( literal value -- ? )
GENERIC: value-class-and ( class value -- )
TUPLE: value class recursion class-ties literal-ties ;
C: value ( recursion -- value )
[ set-value-recursion ] keep ;
TUPLE: computed ;
C: computed ( class -- value )
swap recursive-state get <value> [ set-value-class ] keep
over set-delegate ;
M: computed value= ( literal value -- ? )
2drop f ;
: failing-class-and ( class class -- class )
2dup class-and dup null = [
-rot [
word-name , " and " , word-name ,
" do not intersect" ,
] make-string inference-warning
] [
2nip
] ifte ;
M: computed value-class-and ( class value -- )
[
value-class failing-class-and
] keep set-value-class ;
TUPLE: literal value safe? ;
C: literal ( obj rstate -- value )
[ t swap set-literal-safe? ] keep
[
>r <value> [ >r dup class r> set-value-class ] keep
r> set-delegate
] keep
[ set-literal-value ] keep ;
M: literal value= ( literal value -- ? )
literal-value = ;
M: literal value-class-and ( class value -- )
value-class class-and drop ;
M: literal set-value-class ( class value -- )
2drop ;
M: computed literal-safe? drop f ;
M: computed set-literal-safe? 2drop ;
M: computed literal-value ( value -- )
"A literal value was expected where a computed value was"
" found: " rot unparse append3 inference-error ;
: value-types ( value -- list )
value-class builtin-supertypes ;

101
library/inference/words.factor
View File

@ -33,13 +33,48 @@ hashtables parser prettyprint ;
: no-effect ( word -- )
"Unknown stack effect: " swap word-name cat2 inference-error ;
: inline-compound ( word -- effect node )
: inhibit-parital ( -- )
meta-d get [ f swap set-literal-safe? ] each ;
: recursive? ( word -- ? )
f swap dup word-def [ = or ] tree-each-with ;
: (with-block) ( [[ label quot ]] quot -- node )
#! Call a quotation in a new namespace, and transfer
#! inference state from the outer scope.
swap car >r [
dataflow-graph off
call
d-in get meta-d get meta-r get get-dataflow
] with-scope
r> swap #label dataflow, [ node-label set ] extend >r
meta-r set meta-d set d-in set r> ;
: with-block ( word [[ label quot ]] quot -- node )
#! Execute a quotation with the word on the stack, and add
#! its dataflow contribution to a new block node in the IR.
over [
>r
dupd cons
recursive-state [ cons ] change
r> call
] (with-block) ;
: inline-block ( word -- effect node )
gensym over word-def cons [
inhibit-parital
word-def infer-quot effect
] with-block ;
: inline-compound ( word -- )
#! Infer the stack effect of a compound word in the current
#! inferencer instance. If the word in question is recursive
#! we infer its stack effect inside a new block.
gensym over word-def cons [
word-def infer-quot effect
] with-block ;
dup recursive? [
inline-block 2drop
] [
word-def infer-quot
] ifte ;
: infer-compound ( word -- )
#! Infer a word's stack effect in a separate inferencer
@ -47,7 +82,7 @@ hashtables parser prettyprint ;
[
[
recursive-state get init-inference
dup dup inline-compound drop present-effect
dup dup inline-block drop present-effect
[ "infer-effect" set-word-prop ] keep
] with-scope consume/produce
] [
@ -66,6 +101,9 @@ M: object (apply-word) ( word -- )
#! A primitive with an unknown stack effect.
no-effect ;
M: primitive (apply-word) ( word -- )
dup "infer-effect" word-prop consume/produce ;
M: compound (apply-word) ( word -- )
#! Infer a compound word's stack effect.
dup "no-effect" word-prop [
@ -95,7 +133,7 @@ M: word apply-word ( word -- )
M: compound apply-word ( word -- )
dup "inline" word-prop [
inline-compound 2drop
inline-compound
] [
apply-default
] ifte ;
@ -111,7 +149,7 @@ M: compound apply-word ( word -- )
: base-case ( word [ label quot ] -- )
[
car over inline-compound [
car over inline-block [
drop
[ #call-label ] [ #call ] ?ifte
node-op set
@ -126,11 +164,15 @@ M: compound apply-word ( word -- )
#! Handle a recursive call, by either applying a previously
#! inferred base case, or raising an error. If the recursive
#! call is to a local block, emit a label call node.
inferring-base-case get [
drop no-base-case
over "infer-effect" word-prop [
nip consume/produce
] [
base-case
] ifte ;
inferring-base-case get [
drop no-base-case
] [
base-case
] ifte
] ifte* ;
M: word apply-object ( word -- )
#! Apply the word's stack effect to the inferencer state.
@ -141,41 +183,28 @@ M: word apply-object ( word -- )
] ifte* ;
: infer-quot-value ( rstate quot -- )
gensym dup pick cons [
drop
swap recursive-state set
dup infer-quot
] with-block drop handle-terminator ;
recursive-state get >r
swap recursive-state set
dup infer-quot handle-terminator
r> recursive-state set ;
\ call [
[ general-list ] ensure-d pop-literal infer-quot-value
pop-literal infer-quot-value
] "infer" set-word-prop
\ execute [
[ word ] ensure-d pop-literal unit infer-quot-value
pop-literal unit infer-quot-value
] "infer" set-word-prop
! These hacks will go away soon
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
\ <= [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ < [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ >= [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ > [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ delegate [ [ object ] [ object ] ] "infer-effect" set-word-prop
\ no-method t "terminator" set-word-prop
\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
\ <no-method> [ [ object object ] [ tuple ] ] "infer-effect" set-word-prop
\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop
\ delegate [ [ object ] [ object ] ] "infer-effect" set-word-prop
\ no-method t "terminator" set-word-prop
\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
\ <no-method> [ [ object word ] [ tuple ] ] "infer-effect" set-word-prop
\ not-a-number t "terminator" set-word-prop
\ throw t "terminator" set-word-prop
\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop

11
library/math/math.factor
View File

@ -33,19 +33,18 @@ GENERIC: truncate ( n -- n )
GENERIC: floor ( n -- n )
GENERIC: ceiling ( n -- n )
: max ( x y -- z ) [ > ] 2keep ? ;
: min ( x y -- z ) [ < ] 2keep ? ;
: max ( x y -- z ) [ > ] 2keep ? ; inline
: min ( x y -- z ) [ < ] 2keep ? ; inline
: between? ( x min max -- ? )
#! Push if min <= x <= max. Handles case where min > max
#! by swapping them.
2dup > [ swap ] when >r dupd max r> min = ;
: sq dup * ;
: sq dup * ; inline
: neg 0 swap - ;
: recip 1 swap / ;
: neg 0 swap - ; inline
: recip 1 swap / ; inline
: rem ( x y -- x%y )
#! Like modulus, but always gives a positive result.

1
library/test/prettyprint.factor → library/test/benchmark/prettyprint.factor
View File

@ -4,6 +4,7 @@ USE: prettyprint
USE: test
USE: words
USE: kernel
USE: sequences
[ ] [ gensym dup [ ] define-compound . ] unit-test
[ ] [ vocabs [ words [ see ] each ] each ] unit-test

15
library/test/compiler/optimizer.factor
View File

@ -1,5 +1,6 @@
IN: temporary
USE: test
USE: assembler
USE: compiler
USE: compiler-frontend
USE: inference
@ -13,8 +14,6 @@ USE: sequences
[ [ ] ] [ \ foo word-def dataflow kill-set ] unit-test
[ [ [ + ] [ - ] ] ] [ [ 3 4 1 2 > [ + ] [ - ] ifte ] dataflow kill-set ] unit-test
[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test
[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test
@ -22,3 +21,15 @@ USE: sequences
[ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f <literal> ] map kill-mask ] unit-test
[ t ] [ 3 [ 3 over [ ] [ ] ifte drop ] dataflow kill-set contains? ] unit-test
: literal-kill-test-1 4 compiled-offset cell 2 * - ; compiled
[ 4 ] [ literal-kill-test-1 drop ] unit-test
: literal-kill-test-2 3 compiled-offset cell 2 * - ; compiled
[ 3 ] [ literal-kill-test-2 drop ] unit-test
: literal-kill-test-3 10 3 /mod drop ; compiled
[ 3 ] [ literal-kill-test-3 ] unit-test

9
library/test/dataflow.factor
View File

@ -19,7 +19,7 @@ sequences test words ;
] some-with? ;
[ t ] [
\ + [ 2 2 + ] dataflow dataflow-contains-param? >boolean
\ + [ 2 + ] dataflow dataflow-contains-param? >boolean
] unit-test
: inline-test
@ -79,10 +79,3 @@ SYMBOL: #test
[[ node-param 5 ]]
}} "foobar" [ [ node-param get ] bind 1 + ] apply-dataflow
] unit-test
! Somebody (cough) got the order of ifte nodes wrong.
[ t ] [
\ ifte [ [ 1 ] [ 2 ] ifte ] dataflow dataflow-contains-op? car
[ node-param get ] bind car car [ node-param get ] bind 1 =
] unit-test

2
library/test/gadgets.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: gadgets kernel lists math namespaces test ;
USING: gadgets kernel lists math namespaces test sequences ;
[ t ] [
[

1
library/test/math/bitops.factor
View File

@ -3,6 +3,7 @@ USE: kernel
USE: math
USE: test
USE: lists
USE: sequences
[ -2 ] [ 1 bitnot ] unit-test
[ -2 ] [ 1 >bignum bitnot ] unit-test

3
library/test/memory.factor
View File

@ -1,5 +1,6 @@
IN: temporary
USING: generic kernel lists math memory words prettyprint test ;
USING: generic kernel lists math memory words prettyprint
sequences test ;
[ ] [
num-types [

13
library/test/sequences.factor
View File

@ -1,8 +1,9 @@
IN: temporary
USING: lists test sequences ;
USING: lists sequences test vectors ;
[ [ 1 2 3 4 ] ] [ 1 4 <range> >list ] unit-test
[ 4 ] [ 1 4 <range> length ] unit-test
[ [ 4 3 2 1 ] ] [ 4 1 <range> >list ] unit-test
[ 2 ] [ 1 2 { 1 2 3 4 } <slice> length ] unit-test
[ [ 2 3 ] ] [ 1 2 { 1 2 3 4 } <slice> >list ] unit-test
[ [ 1 2 3 4 ] ] [ 1 5 <range> >list ] unit-test
[ 3 ] [ 1 4 <range> length ] unit-test
[ [ 4 3 2 1 ] ] [ 4 0 <range> >list ] unit-test
[ 2 ] [ 1 3 { 1 2 3 4 } <slice> length ] unit-test
[ [ 2 3 ] ] [ 1 3 { 1 2 3 4 } <slice> >list ] unit-test
[ { 4 5 } ] [ 2 { 1 2 3 4 5 } tail-slice >vector ] unit-test

4
library/test/test.factor
View File

@ -69,7 +69,7 @@ SYMBOL: failures
"lists/namespaces" "lists/combinators" "combinators"
"continuations" "errors" "hashtables" "strings"
"namespaces" "generic" "tuple" "files" "parser"
"parse-number" "prettyprint" "image" "init" "io/io"
"parse-number" "image" "init" "io/io"
"listener" "vectors" "words" "unparser" "random"
"stream" "math/bitops"
"math/math-combinators" "math/rational" "math/float"
@ -102,7 +102,7 @@ SYMBOL: failures
"benchmark/fib" "benchmark/sort"
"benchmark/continuations" "benchmark/ack"
"benchmark/hashtables" "benchmark/strings"
"benchmark/vectors"
"benchmark/vectors" "benchmark/prettyprint"
] %
] make-list ;

5
library/test/tuple.factor
View File

@ -41,13 +41,16 @@ C: quuux-tuple-2
[
100
] [
FORGET: point
FORGET: point?
FORGET: point-x
TUPLE: point x y ;
C: point [ set-point-y ] keep [ set-point-x ] keep ;
100 200 <point>
! Use eval to sequence parsing explicitly
"TUPLE: point x y z ;" eval
"IN: temporary TUPLE: point x y z ;" eval
point-x
] unit-test

2
library/test/words.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: generic kernel lists math namespaces test words ;
USING: generic kernel lists math namespaces test words sequences ;
[ 4 ] [
"poo" "scratchpad" create [ 2 2 + ] define-compound

2
library/tools/memory.factor
View File

@ -109,7 +109,7 @@ M: object (each-slot) ( quot obj -- )
: orphan? ( word -- ? )
#! Test if the word is not a member of its vocabulary.
dup dup word-name swap word-vocabulary dup [
vocab hash eq? not
vocab dup [ hash eq? not ] [ 3drop t ] ifte
] [
3drop t
] ifte ;

2
library/vocabularies.factor
View File

@ -37,7 +37,7 @@ SYMBOL: vocabularies
: recrossref ( -- )
#! Update word cross referencing information.
[ f "usages" set-word-prop ] each-word
global [ <namespace> crossref set ] bind
[ add-crossref ] each-word ;
: (search) ( name vocab -- word )