2drop
] ifte r>
] each drop ;
+
+: 2cons ( car1 car2 cdr1 cdr2 -- cons1 cons2 )
+ rot swons >r cons r> ;
+
+: unzip ( assoc -- keys values )
+ #! Split an association list into two lists of keys and
+ #! values.
+ [ uncons >r uncons r> unzip 2cons ] [ [ ] [ ] ] ifte* ;
#! immediate just compiled.
"ds" f f rel-dlsym ;
+: PEEK-DS ( -- )
+ #! Peek datastack to EAX.
+ DS ECX [I]>R absolute-ds
+ ECX EAX [R]>R ;
+
: POP-DS ( -- )
#! Pop datastack to EAX.
- DS ECX [I]>R absolute-ds
- ECX EAX [R]>R
+ PEEK-DS
4 ECX R-I
ECX DS R>[I] absolute-ds ;
ECX DS R>[I] absolute-ds
] "generator" set-word-property
+#slot [
+ PEEK-DS
+
+] "generator" set-word-property
+
#call [
dup dup postpone-word
CALL compiled-offset defer-xt
USE: hashtables
USE: prettyprint
-: longest-vector ( list -- length )
- [ vector-length ] map [ > ] top ;
-
-: computed-value-vector ( n -- vector )
- [ drop object <computed> ] vector-project ;
-
-: add-inputs ( count stack -- count stack )
- #! Add this many inputs to the given stack.
- [ vector-length - dup ] keep
- >r computed-value-vector dup r> vector-append ;
-
-: 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 [ dupd add-inputs nip ] map nip ;
-
-: unify-classes ( value value -- value )
- value-class swap value-class class-or <computed> ;
+: vector-length< ( vec1 vec2 -- ? )
+ swap vector-length swap vector-length < ;
+
+: unify-length ( vec1 vec2 -- vec1 )
+ 2dup vector-length< [ swap ] unless [
+ vector-length over vector-length -
+ empty-vector [ swap vector-append ] keep
+ ] keep ;
+
+: unify-classes ( value value -- class )
+ #! If one of the values is f, it was added as a result of
+ #! length unification so we just replace it with a computed
+ #! object value.
+ 2dup and [
+ value-class swap value-class class-or
+ ] [
+ 2drop object
+ ] ifte ;
: unify-results ( value value -- value )
#! Replace values with unknown result if they differ,
#! otherwise retain them.
- 2dup = [ drop ] [ unify-classes ] ifte ;
+ 2dup = [ drop ] [ unify-classes <computed> ] ifte ;
: unify-stacks ( list -- stack )
#! Replace differing literals in stacks with unknown
#! results.
- uncons [ [ unify-results ] vector-2map ] each ;
-
-: unify-d-in ( list -- d-in )
- [ [ d-in get ] bind ] map unify-lengths unify-stacks ;
-
-: filter-terminators ( list -- list )
- [ [ d-in get meta-d get and ] bind ] subset ;
+ uncons [
+ unify-length vector-zip [
+ uncons unify-results
+ ] vector-map
+ ] each ;
: balanced? ( list -- ? )
- [
- [
- d-in get vector-length
- meta-d get vector-length -
- ] bind
- ] map all=? ;
-
-: unify-datastacks ( list -- datastack )
- [ [ meta-d get ] bind ] map
- unify-lengths unify-stacks ;
-
-: check-lengths ( list -- )
- dup [ vector-length ] map all=? [
- drop
- ] [
- "Unbalanced return stack effect:" <multi-error> throw
- ] ifte ;
-
-: unify-callstacks ( list -- datastack )
- [ [ meta-r get ] bind ] map
- dup check-lengths unify-stacks ;
+ #! Check if a list of [ instack | outstack ] pairs is
+ #! balanced.
+ [ uncons vector-length swap vector-length - ] map all=? ;
-: unify-effects ( list -- )
- filter-terminators
- [ "No branch has a stack effect" throw ] unless*
+: unify-effect ( list -- in out )
+ #! Unify a list of [ instack | outstack ] pairs.
dup balanced? [
- dup unify-d-in d-in set
- dup unify-datastacks meta-d set
- unify-callstacks meta-r set
+ unzip unify-stacks >r unify-stacks r>
] [
"Unbalanced branches" throw
] ifte ;
+: datastack-effect ( list -- )
+ [ [ d-in get meta-d get ] bind cons ] map
+ unify-effect
+ meta-d set d-in set ;
+
+: callstack-effect ( list -- )
+ [ [ { } meta-r get ] bind cons ] map
+ unify-effect
+ meta-r set drop ;
+
+: filter-terminators ( list -- list )
+ [ [ d-in get meta-d get and ] bind ] subset [
+ "No branch has a stack effect" throw
+ ] unless* ;
+
+: unify-effects ( list -- )
+ filter-terminators dup datastack-effect callstack-effect ;
+
: deep-clone ( vector -- vector )
#! Clone a vector of vectors.
[ vector-clone ] vector-map ;
SYMBOL: #>r
SYMBOL: #r>
+SYMBOL: #slot
+SYMBOL: #set-slot
+
SYMBOL: node-consume-d
SYMBOL: node-produce-d
SYMBOL: node-consume-r
USE: words
USE: hashtables
USE: generic
+USE: prettyprint
! Word properties that affect inference:
! - infer-effect -- must be set. controls number of inputs
: infer-quot ( quot -- )
#! Recursive calls to this word are made for nested
#! quotations.
- [ apply-object ] each ;
+ [
+ [ apply-object ] each
+ ] [
+ [ swap <chained-error> rethrow ] when*
+ ] catch ;
: raise ( [ in | out ] -- [ in | out ] )
uncons 2dup min tuck - >r - r> cons ;
: check-return ( -- )
#! Raise an error if word leaves values on return stack.
meta-r get vector-length 0 = [
- "Word leaves elements on return stack" throw
+ "Word leaves elements on return stack"
+ <chained-error> throw
] unless ;
: values-node ( op -- )
--- /dev/null
+! :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.
+
+IN: inference
+USE: errors
+USE: generic
+USE: interpreter
+USE: kernel
+USE: kernel-internals
+USE: lists
+USE: math
+USE: namespaces
+USE: strings
+USE: vectors
+USE: words
+USE: stdio
+
+! Enhanced inference of primitives relating to data types.
+! Optimizes type checks and slot access.
+
+: infer-check ( assert class -- )
+ peek-d dup value-class pick = [
+ [
+ "Optimized out " , rot word-name , " check." ,
+ ] make-string print 2drop
+ ] [
+ value-class-and
+ dup "infer-effect" word-property consume/produce
+ ] ifte ;
+
+\ >cons [
+ \ >cons \ cons infer-check
+] "infer" set-word-property
+
+\ >vector [
+ \ >vector \ vector infer-check
+] "infer" set-word-property
+
+\ >string [
+ \ >string \ string infer-check
+] "infer" set-word-property
+
+\ slot [
+ dataflow-drop, pop-d literal-value
+ peek-d value-class builtin-supertypes dup length 1 = [
+ cons #slot dataflow, [
+ 1 0 node-inputs
+ [ object ] consume-d
+ [ object ] produce-d
+ 1 0 node-outputs
+ ] bind
+ ] [
+ "slot called without static type knowledge" throw
+ ] ifte
+] "infer" set-word-property
: inline-compound ( word -- effect )
#! Infer the stack effect of a compound word in the current
#! inferencer instance.
- gensym [ word-parameter infer-quot effect ] with-block ;
+ [
+ gensym [ word-parameter infer-quot effect ] with-block
+ ] [
+ [ swap <chained-error> rethrow ] when*
+ ] catch ;
: (infer-compound) ( word -- effect )
#! Infer a word's stack effect in a separate inferencer
[ memory>string " address length -- str " [ [ integer integer ] [ string ] ] ]
[ local-alien? " alien -- ? " [ [ alien ] [ object ] ] ]
[ alien-address " alien -- address " [ [ alien ] [ integer ] ] ]
- [ >cons " cons -- cons " [ [ cons ] [ cons ] ] ]
- [ >vector " vector -- vector " [ [ vector ] [ vector ] ] ]
- [ >string " string -- string " [ [ string ] [ string ] ] ]
+ ! Note: a correct type spec for these would have [ X ] as
+ ! input, not [ object ]. However, we rely on the inferencer
+ ! to handle these specially, since they are also optimized
+ ! out in some cases, etc.
+ [ >cons " cons -- cons " [ [ object ] [ cons ] ] ]
+ [ >vector " vector -- vector " [ [ object ] [ vector ] ] ]
+ [ >string " string -- string " [ [ object ] [ string ] ] ]
[ >word " word -- word " [ [ word ] [ word ] ] ]
[ slot " obj n -- obj " [ [ object fixnum ] [ object ] ] ]
[ set-slot " obj obj n -- " [ [ object object fixnum ] [ ] ] ]
[ 3 | 4 ]
] "effects" set
-[ 3 ] [ [ { 1 2 } { 1 2 3 } ] longest-vector ] unit-test
-
-[ t ] [
- [ { 1 2 } { 1 2 3 } ] unify-lengths [ vector-length ] map all=?
+[ { f 1 2 } { 1 2 3 } ] [
+ { 1 2 } { 1 2 3 } unify-lengths
] unit-test
[ [ sq ] ] [
[ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
[ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
[ [ [ object ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
-[ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test
+! [ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test
! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test
! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
[ [ [ "one" + ] [ "four" * ] ] ] [
"three" "quot-alist" get remove-assoc
] unit-test
+
+[ [ "one" "three" "four" ] [ [ + ] [ - ] [ * ] ] ]
+[ "quot-alist" get unzip ] unit-test
USE: test
USE: vectors
USE: strings
+USE: namespaces
[ [ t f t ] vector-length ] unit-test-fails
[ 3 ] [ { t f t } vector-length ] unit-test
unit-test
[ { 6 8 10 12 } ]
-[ { 1 2 3 4 } { 5 6 7 8 } [ + ] vector-2map ]
+[ { 1 2 3 4 } { 5 6 7 8 } vector-zip [ uncons + ] vector-map ]
unit-test
[ { [ 1 | 5 ] [ 2 | 6 ] [ 3 | 7 ] [ 4 | 8 ] } ]
[ 2 [ ] vector-tail ] unit-test-fails
[ [ 3 ] ] [ 1 { 1 2 3 } vector-tail* ] unit-test
+
+0 <vector> "funny-stack" set
+
+[ ] [ { 1 5 } "funny-stack" get vector-push ] unit-test
+[ ] [ { 2 3 } "funny-stack" get vector-push ] unit-test
+[ { 2 3 } ] [ "funny-stack" get vector-pop ] unit-test
+[ { 1 5 } ] [ "funny-stack" get vector-peek ] unit-test
+[ { 1 5 } ] [ "funny-stack" get vector-pop ] unit-test
+[ "funny-stack" get vector-pop ] unit-test-fails
+[ "funny-stack" get vector-pop ] unit-test-fails
+[ ] [ "funky" "funny-stack" get vector-push ] unit-test
+[ "funky" ] [ "funny-stack" get vector-pop ] unit-test
GENERIC: error. ( error -- )
PREDICATE: cons kernel-error ( obj -- ? )
- uncons cons? swap fixnum? and ;
+ car kernel-error = ;
M: kernel-error error. ( error -- )
- uncons car swap {
+ cdr uncons car swap {
expired-error
io-task-twice-error
no-io-tasks-error
: init-error-handler ( -- )
[ 1 exit* ] >c ( last resort )
[ print-error 1 exit* ] >c
- [ dup save-error rethrow ] 5 setenv ( kernel calls on error ) ;
+ [ dup save-error rethrow ] 5 setenv ( kernel calls on error )
+ kernel-error 12 setenv ;
! So that stage 2 boot gives a useful error message if something
! fails after this file is loaded.
SYMBOL: meta-d
: push-d meta-d get vector-push ;
: pop-d meta-d get vector-pop ;
+: peek-d meta-d get vector-peek ;
SYMBOL: meta-n
SYMBOL: meta-c
"Vector length must be positive" throw 2drop
] [
2dup (set-vector-length) grow-vector-array
- ] ifte ;
+ ] ifte ; inline
: empty-vector ( len -- vec )
#! Creates a vector with 'len' elements set to f. Unlike
#! Push a value on the end of a vector.
dup vector-length swap set-vector-nth ;
+: vector-peek ( vector -- obj )
+ #! Get value at end of vector.
+ dup vector-length pred swap vector-nth ;
+
: vector-pop ( vector -- obj )
#! Get value at end of vector and remove it.
dup vector-length pred ( vector top )
pick pick >r over >r vector-nth r> r> vector-nth cons
] vector-project nip nip ;
-: vector-2map ( v1 v2 quot -- v )
- #! Apply a quotation with stack effect ( obj obj -- obj ) to
- #! each pair of elements from v1 and v2, collecting them
- #! into a new list. Behavior is undefined if vector lengths
- #! differ.
- -rot vector-zip [
- swap dup >r >r uncons r> call r> swap
- ] vector-map nip ; inline
-
: vector-clone ( vector -- vector )
#! Shallow copy of a vector.
[ ] vector-map ;
void general_error(CELL error, CELL tagged)
{
early_error(error);
- throw_error(cons(error,cons(tagged,F)),true);
+ throw_error(cons(userenv[ERROR_ENV],cons(error,cons(tagged,F))),true);
}
/* It is not safe to access 'ds' from a signal handler, so we just not
void signal_error(int signal)
{
early_error(ERROR_SIGNAL);
- throw_error(cons(ERROR_SIGNAL,cons(tag_fixnum(signal),F)),false);
+ throw_error(cons(userenv[ERROR_ENV],
+ cons(ERROR_SIGNAL,
+ cons(tag_fixnum(signal),F))),false);
}
void type_error(CELL type, CELL tagged)
#define RUNQUEUE_ENV 9 /* used by library only */
#define ARGS_ENV 10
#define OS_ENV 11
+#define ERROR_ENV 12 /* a marker consed onto kernel errors */
/* Profiling timer */
#ifndef WIN32
projects / factor.git / commitdiff