t [\r
"/library/inference/conditions.factor"\r
"/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
"/library/compiler/relocate.factor"\r
! 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
\ = compile
\ unparse compile
\ scan compile
+ \ (generate) compile
] when
"Loading more library code..." print
[ 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 + ;
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 )
#! 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 [
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 ,
\ 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
#! 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
#! 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 , ;
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)
[ 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? ;
[ 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 [
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
- ] [
+ dup vop-literal 0 = [
+ drop cdr t
+ ] [
+ >r dup \ %inc-d next-physical? [
+ vop-literal r> vop-literal +
%inc-d >r cdr cdr r> swons t
+ ] [
+ r> 2drop f
] ifte
- ] [
- r> 2drop f
] ifte ;
: dead-load? ( linear vop -- ? )
] 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 ;
: %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
! 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 ;
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 ;
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 ;
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
: 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 ,
\ 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 ;
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 )
: 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.
#! 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
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
-! :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
! 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
#! 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,
! 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 [
: 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 ;
#! 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 ;
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 ;
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 ;
--- /dev/null
+! 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
[ 1 0 node-outputs ] bind
] "infer" set-word-prop
+: partial-eval ( word quot -- | quot: word -- )
+ >r f over dup "infer-effect" word-prop r> with-dataflow ;
+
: infer-shuffle ( word -- )
- f over dup
- "infer-effect" word-prop
- [ host-word ] with-dataflow ;
+ [ host-word ] partial-eval ;
-\ drop [ \ drop infer-shuffle ] "infer" set-word-prop
+\ 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
--- /dev/null
+! 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 ;
: no-effect ( word -- )
"Unknown stack effect: " swap word-name cat2 inference-error ;
-: inline-compound ( word -- effect node )
- #! 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.
+: 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.
+ dup recursive? [
+ inline-block 2drop
+ ] [
+ word-def infer-quot
+ ] ifte ;
+
: infer-compound ( word -- )
#! Infer a word's stack effect in a separate inferencer
#! instance.
[
[
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
] [
#! 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 [
M: compound apply-word ( word -- )
dup "inline" word-prop [
- inline-compound 2drop
+ inline-compound
] [
apply-default
] ifte ;
: base-case ( word [ label quot ] -- )
[
- car over inline-compound [
+ car over inline-block [
drop
[ #call-label ] [ #call ] ?ifte
node-op set
#! 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.
] 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
-\ <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
+\ <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
\ 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
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.
--- /dev/null
+IN: temporary
+USE: lists
+USE: prettyprint
+USE: test
+USE: words
+USE: kernel
+USE: sequences
+
+[ ] [ gensym dup [ ] define-compound . ] unit-test
+[ ] [ vocabs [ words [ see ] each ] each ] unit-test
+[ ] [ classes [ methods. ] each ] unit-test
IN: temporary
USE: test
+USE: assembler
USE: compiler
USE: compiler-frontend
USE: inference
[ [ ] ] [ \ 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
[ [ 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
] some-with? ;
[ t ] [
- \ + [ 2 2 + ] dataflow dataflow-contains-param? >boolean
+ \ + [ 2 + ] dataflow dataflow-contains-param? >boolean
] unit-test
: inline-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
IN: temporary
-USING: gadgets kernel lists math namespaces test ;
+USING: gadgets kernel lists math namespaces test sequences ;
[ t ] [
[
USE: math
USE: test
USE: lists
+USE: sequences
[ -2 ] [ 1 bitnot ] unit-test
[ -2 ] [ 1 >bignum bitnot ] unit-test
IN: temporary
-USING: generic kernel lists math memory words prettyprint test ;
+USING: generic kernel lists math memory words prettyprint
+sequences test ;
[ ] [
num-types [
+++ /dev/null
-IN: temporary
-USE: lists
-USE: prettyprint
-USE: test
-USE: words
-USE: kernel
-
-[ ] [ gensym dup [ ] define-compound . ] unit-test
-[ ] [ vocabs [ words [ see ] each ] each ] unit-test
-[ ] [ classes [ methods. ] each ] unit-test
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
"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"
"benchmark/fib" "benchmark/sort"
"benchmark/continuations" "benchmark/ack"
"benchmark/hashtables" "benchmark/strings"
- "benchmark/vectors"
+ "benchmark/vectors" "benchmark/prettyprint"
] %
] make-list ;
[
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
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
: 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 ;
: 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 )
projects / factor.git / commitdiff