making a mess of type inference; fixing overflowing /mod
parent
b7d23654ba
commit
d236dd9ec8
|
@ -1,6 +1,12 @@
|
|||
+ compiler:
|
||||
|
||||
- type inference fails with some assembler words
|
||||
- investigate why : foo t or ; doesn't partially evaluate
|
||||
- investigate why ' doesn't infer
|
||||
- recursive? and tree-contains? should handle vectors
|
||||
- type inference and recursion flaw
|
||||
- type inference fails with some assembler words;
|
||||
displaced, register and other predicates need to inherit from list
|
||||
not cons, and need stronger branch partial eval
|
||||
- more accurate type inference in some cases
|
||||
- optimize away dispatch
|
||||
- goal: to compile hash* optimally
|
||||
|
@ -23,33 +29,39 @@
|
|||
|
||||
+ listener/plugin:
|
||||
|
||||
- update plugin docs
|
||||
- extract word keeps indent
|
||||
- word preview for remote words
|
||||
- WordPreview calls markTokens() -> NPE
|
||||
- stream server can hang because of exception handler limitations
|
||||
- listener should be multithreaded
|
||||
- compile all, infer all commands
|
||||
- compile all commands
|
||||
- faster completion
|
||||
- errors don't always disappear
|
||||
- NPE in ErrorHighlight
|
||||
- maple-like: press enter at old commands to evaluate there
|
||||
- completion in the listener
|
||||
- special completion for USE:/IN:
|
||||
|
||||
+ i/o:
|
||||
|
||||
- stream server can hang because of exception handler limitations
|
||||
- better i/o scheduler
|
||||
- nicer way to combine two paths
|
||||
- add a socket timeout
|
||||
- rename f* words to stream-*
|
||||
- <file[bc][rw]> is badly named -- <file-reader>, <file-writer>
|
||||
|
||||
+ kernel:
|
||||
|
||||
- ppc register decls
|
||||
- do partial objects cause problems?
|
||||
- better i/o scheduler
|
||||
- remove sbufs
|
||||
- cat, reverse-cat primitives
|
||||
- first-class hashtables
|
||||
- add a socket timeout
|
||||
|
||||
+ misc:
|
||||
|
||||
- perhaps /i should work with all numbers
|
||||
- unit test weirdness: 2 lines appears at end
|
||||
- jedit ==> jedit-word, jedit takes a file name
|
||||
- nicer way to combine two paths
|
||||
- browser responder for word links in HTTPd
|
||||
- worddef props
|
||||
- prettyprint: when unparse called due to recursion, write a link
|
||||
|
|
|
@ -215,7 +215,7 @@ M: f ' ( obj -- ptr )
|
|||
: transfer-word ( word -- word )
|
||||
#! This is a hack. See doc/bootstrap.txt.
|
||||
dup dup word-name swap word-vocabulary unit search
|
||||
[ "Missing DEFER: " word-error ] ?unless ;
|
||||
[ dup "Missing DEFER: " word-error ] ?unless ;
|
||||
|
||||
: fixup-word ( word -- offset )
|
||||
dup pooled-object [ "Not in image: " word-error ] ?unless ;
|
||||
|
|
|
@ -105,7 +105,7 @@ M: register register "register" word-property ;
|
|||
M: register displacement drop ;
|
||||
|
||||
( Indirect register operands -- eg, [ ECX ] )
|
||||
PREDICATE: list indirect
|
||||
PREDICATE: cons indirect
|
||||
dup length 1 = [ car register? ] [ drop f ] ifte ;
|
||||
|
||||
M: indirect modifier drop BIN: 00 ;
|
||||
|
@ -117,7 +117,7 @@ M: indirect register
|
|||
M: indirect displacement drop ;
|
||||
|
||||
( Displaced indirect register operands -- eg, [ EAX 4 ] )
|
||||
PREDICATE: list displaced
|
||||
PREDICATE: cons displaced
|
||||
dup length 2 = [
|
||||
2unlist integer? swap register? and
|
||||
] [
|
||||
|
@ -130,7 +130,7 @@ M: displaced displacement
|
|||
cdr car dup byte? [ compile-byte ] [ compile-cell ] ifte ;
|
||||
|
||||
( Displacement-only operands -- eg, [ 1234 ] )
|
||||
PREDICATE: list disp-only
|
||||
PREDICATE: cons disp-only
|
||||
dup length 1 = [ car integer? ] [ drop f ] ifte ;
|
||||
|
||||
M: disp-only modifier drop BIN: 00 ;
|
||||
|
|
|
@ -135,7 +135,7 @@ USE: math-internals
|
|||
[ ECX ] IDIV
|
||||
EAX 3 SHL
|
||||
0 JNO fixup
|
||||
\ fixnum/i compile-call
|
||||
\ fixnum/mod compile-call
|
||||
0 JMP fixup >r
|
||||
compiled-offset swap patch
|
||||
[ ECX -4 ] EAX MOV
|
||||
|
|
|
@ -47,7 +47,7 @@ USE: prettyprint
|
|||
|
||||
: add-inputs ( count stack -- stack )
|
||||
#! Add this many inputs to the given stack.
|
||||
dup >r vector-length - computed-value-vector dup r>
|
||||
[ vector-length - computed-value-vector ] keep
|
||||
vector-append ;
|
||||
|
||||
: unify-lengths ( list -- list )
|
||||
|
@ -89,7 +89,7 @@ USE: prettyprint
|
|||
] ifte ;
|
||||
|
||||
: datastack-effect ( list -- )
|
||||
[ [ d-in get meta-d get ] bind cons ] map
|
||||
[ [ effect ] bind ] map
|
||||
unify-effect
|
||||
meta-d set d-in set ;
|
||||
|
||||
|
@ -161,7 +161,7 @@ SYMBOL: cloned
|
|||
#! for the given branch.
|
||||
[
|
||||
[
|
||||
inferring-base-case get [
|
||||
branches-can-fail? [
|
||||
[
|
||||
infer-branch ,
|
||||
] [
|
||||
|
@ -196,7 +196,7 @@ SYMBOL: cloned
|
|||
meta-r set meta-d set d-in set ;
|
||||
|
||||
: static-branch? ( value -- )
|
||||
literal? inferring-base-case get not and ;
|
||||
literal? branches-can-fail? not and ;
|
||||
|
||||
: static-ifte ( true false -- )
|
||||
#! If the branch taken is statically known, just infer
|
||||
|
@ -222,11 +222,11 @@ SYMBOL: cloned
|
|||
[ object general-list general-list ] ensure-d
|
||||
dataflow-drop, pop-d
|
||||
dataflow-drop, pop-d swap
|
||||
! peek-d static-branch? [
|
||||
! static-ifte
|
||||
! ] [
|
||||
peek-d static-branch? [
|
||||
static-ifte
|
||||
] [
|
||||
dynamic-ifte
|
||||
( ] ifte ) ;
|
||||
] ifte ;
|
||||
|
||||
\ ifte [ infer-ifte ] "infer" set-word-property
|
||||
|
||||
|
|
|
@ -39,10 +39,18 @@ USE: hashtables
|
|||
USE: generic
|
||||
USE: prettyprint
|
||||
|
||||
! If this symbol is on, partial evalution of conditionals is
|
||||
! If this variable is on, partial evalution of conditionals is
|
||||
! disabled.
|
||||
SYMBOL: inferring-base-case
|
||||
|
||||
! If this variable is on, we are inferring the entry effect, so
|
||||
! we unify all entry point effects to the vecto stored in this
|
||||
! variable.
|
||||
SYMBOL: inferring-entry-effect
|
||||
|
||||
: branches-can-fail? ( -- ? )
|
||||
inferring-base-case get inferring-entry-effect get or ;
|
||||
|
||||
! Word properties that affect inference:
|
||||
! - infer-effect -- must be set. controls number of inputs
|
||||
! expected, and number of outputs produced.
|
||||
|
@ -130,7 +138,7 @@ M: literal set-value-class ( class value -- )
|
|||
] ifte ;
|
||||
|
||||
: vector-prepend ( values stack -- stack )
|
||||
>r list>vector dup r> vector-append ;
|
||||
>r list>vector r> vector-append ;
|
||||
|
||||
: ensure-d ( typelist -- )
|
||||
dup meta-d get ensure-types
|
||||
|
@ -138,17 +146,23 @@ M: literal set-value-class ( class value -- )
|
|||
meta-d [ vector-prepend ] change
|
||||
d-in [ vector-prepend ] change ;
|
||||
|
||||
: effect ( -- [ in-types out-types ] )
|
||||
: (present-effect) ( vector -- list )
|
||||
[ value-class ] vector-map vector>list ;
|
||||
|
||||
: present-effect ( [ d-in | meta-d ] -- [ in-types out-types ] )
|
||||
#! After inference is finished, collect information.
|
||||
d-in get [ value-class ] vector-map vector>list
|
||||
meta-d get [ value-class ] vector-map vector>list 2list ;
|
||||
uncons >r (present-effect) r> (present-effect) 2list ;
|
||||
|
||||
: effect ( -- [ d-in | meta-d ] )
|
||||
d-in get meta-d get cons ;
|
||||
|
||||
: init-inference ( recursive-state -- )
|
||||
init-interpreter
|
||||
0 <vector> d-in set
|
||||
recursive-state set
|
||||
dataflow-graph off
|
||||
inferring-base-case off ;
|
||||
inferring-base-case off
|
||||
inferring-entry-effect off ;
|
||||
|
||||
DEFER: apply-word
|
||||
|
||||
|
@ -186,7 +200,7 @@ DEFER: apply-word
|
|||
|
||||
: infer ( quot -- [ in | out ] )
|
||||
#! Stack effect of a quotation.
|
||||
[ (infer) effect ] with-scope ;
|
||||
[ (infer) effect present-effect ] with-scope ;
|
||||
|
||||
: dataflow ( quot -- dataflow )
|
||||
#! Data flow of a quotation.
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
! $Id$
|
||||
!
|
||||
! Copyright (C) 2004 Slava Pestov.
|
||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
|
@ -88,17 +88,32 @@ USE: prettyprint
|
|||
r> call
|
||||
] (with-block) ;
|
||||
|
||||
: entry-effect ( quot -- )
|
||||
[
|
||||
meta-d get inferring-entry-effect set
|
||||
copy-inference
|
||||
infer-quot
|
||||
inferring-entry-effect off
|
||||
] with-scope ;
|
||||
|
||||
: recursive? ( word -- ? )
|
||||
dup word-parameter tree-contains? ;
|
||||
|
||||
: 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 ;
|
||||
#! inferencer instance. If the word in question is recursive
|
||||
#! we infer its stack effect inside a new block.
|
||||
gensym [
|
||||
dup recursive? [ dup word-parameter entry-effect ] when
|
||||
word-parameter infer-quot effect
|
||||
] with-block ;
|
||||
|
||||
: infer-compound ( word -- effect )
|
||||
#! Infer a word's stack effect in a separate inferencer
|
||||
#! instance.
|
||||
[
|
||||
recursive-state get init-inference
|
||||
dup dup inline-compound
|
||||
dup dup inline-compound present-effect
|
||||
[ "infer-effect" set-word-property ] keep
|
||||
] with-scope consume/produce ;
|
||||
|
||||
|
@ -135,32 +150,77 @@ M: symbol (apply-word) ( word -- )
|
|||
] when
|
||||
] when ;
|
||||
|
||||
: decompose ( x y -- effect )
|
||||
: decompose ( x y -- [ d-in | meta-d ] )
|
||||
#! Return a stack effect such that x*effect = y.
|
||||
2unlist >r
|
||||
swap 2unlist >r
|
||||
over length over length - head nip
|
||||
r> append
|
||||
r> 2list ;
|
||||
uncons >r swap uncons >r
|
||||
over vector-length over vector-length -
|
||||
swap vector-head nip
|
||||
r> vector-append r> cons ;
|
||||
|
||||
: base-case ( word -- effect )
|
||||
effect swap
|
||||
: base-case ( word -- [ d-in | meta-d ] )
|
||||
[
|
||||
inferring-base-case on
|
||||
copy-inference
|
||||
inline-compound
|
||||
inferring-base-case off
|
||||
] with-scope decompose ;
|
||||
] with-scope effect swap decompose ;
|
||||
|
||||
: no-base-case ( word -- )
|
||||
word-name " does not have a base case." cat2 throw ;
|
||||
|
||||
: raise# ( n vec -- n )
|
||||
#! Parameter is a vector of pairs. Return the highest index
|
||||
#! where pairs are equal.
|
||||
2dup vector-length >= [
|
||||
drop
|
||||
] [
|
||||
2dup vector-nth uncons = [
|
||||
>r 1 + r> raise#
|
||||
] [
|
||||
drop
|
||||
] ifte
|
||||
] ifte ;
|
||||
|
||||
: raise ( vec1 vec2 -- list )
|
||||
#! Return a new vector consisting of the remainder of vec1,
|
||||
#! without any leading elements equal to those from vec2.
|
||||
over vector-zip 0 swap raise# swap vector-tail ;
|
||||
|
||||
: unify-entry-effect ( vector list -- )
|
||||
#! If any elements are not equal, the vector's element is
|
||||
#! replaced with the list's.
|
||||
over vector-length over length - -rot [
|
||||
( n vector elt )
|
||||
pick pick vector-nth over = [
|
||||
drop
|
||||
] [
|
||||
pick pick set-vector-nth
|
||||
] ifte
|
||||
>r 1 + r>
|
||||
] each 2drop ;
|
||||
|
||||
: apply-entry-effect ( word -- )
|
||||
#! Called at a recursive call point. We need this to compute
|
||||
#! the set of literals that is retained across a recursive
|
||||
#! call -- this is NOT the same as the literals present on
|
||||
#! entry. This word mutates the inferring-entry-effect
|
||||
#! vector.
|
||||
base-case uncons raise
|
||||
inferring-entry-effect get swap unify-entry-effect ;
|
||||
|
||||
: recursive-word ( word label -- )
|
||||
#! 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 word-name " does not have a base case." cat2 throw
|
||||
drop no-base-case
|
||||
] [
|
||||
2dup [ drop #call-label ] [ nip #call ] ifte
|
||||
rot base-case (consume/produce)
|
||||
inferring-entry-effect get [
|
||||
apply-entry-effect "Bail out" throw
|
||||
] [
|
||||
dup [ #call-label ] [ #call ] ?ifte
|
||||
rot base-case present-effect (consume/produce)
|
||||
] ifte
|
||||
] ifte ;
|
||||
|
||||
: apply-word ( word -- )
|
||||
|
@ -186,6 +246,7 @@ M: symbol (apply-word) ( word -- )
|
|||
|
||||
\ call [ infer-call ] "infer" set-word-property
|
||||
|
||||
! These hacks will go away soon
|
||||
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-property
|
||||
|
||||
\ undefined-method t "terminator" set-word-property
|
||||
|
|
|
@ -11,23 +11,35 @@ USE: kernel
|
|||
USE: math-internals
|
||||
USE: generic
|
||||
|
||||
[ [ [ object object ] f ] ]
|
||||
[ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ]
|
||||
[ 0 ]
|
||||
[ { 1 2 3 } { 4 5 6 } vector-zip 0 swap raise# ]
|
||||
unit-test
|
||||
|
||||
[ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ]
|
||||
[
|
||||
[ [ vector ] [ cons vector cons integer object cons ] ]
|
||||
[ [ vector ] [ cons vector cons ] ]
|
||||
decompose
|
||||
] unit-test
|
||||
[ 2 ]
|
||||
[ { 1 2 3 } { 1 2 6 } vector-zip 0 swap raise# ]
|
||||
unit-test
|
||||
|
||||
[ [ [ object ] [ object ] ] ]
|
||||
[
|
||||
[ [ object number ] [ object ] ]
|
||||
[ [ object number ] [ object ] ]
|
||||
decompose
|
||||
] unit-test
|
||||
[ { 4 5 6 } ]
|
||||
[ { 1 2 3 } dup [ 4 5 6 ] unify-entry-effect ]
|
||||
unit-test
|
||||
|
||||
! [ [ [ object object ] f ] ]
|
||||
! [ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ]
|
||||
! unit-test
|
||||
!
|
||||
! [ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ]
|
||||
! [
|
||||
! [ [ vector ] [ cons vector cons integer object cons ] ]
|
||||
! [ [ vector ] [ cons vector cons ] ]
|
||||
! decompose
|
||||
! ] unit-test
|
||||
!
|
||||
! [ [ [ object ] [ object ] ] ]
|
||||
! [
|
||||
! [ [ object number ] [ object ] ]
|
||||
! [ [ object number ] [ object ] ]
|
||||
! decompose
|
||||
! ] unit-test
|
||||
|
||||
: old-effect ( [ in-types out-types ] -- [ in | out ] )
|
||||
uncons car length >r length r> cons ;
|
||||
|
|
|
@ -50,7 +50,7 @@ USE: namespaces
|
|||
[ t ] [ { } hashcode { } hashcode = ] unit-test
|
||||
|
||||
[ { 1 2 3 4 5 6 } ]
|
||||
[ { 1 2 3 } vector-clone dup { 4 5 6 } vector-append ] unit-test
|
||||
[ { 1 2 3 } { 4 5 6 } vector-append ] unit-test
|
||||
|
||||
[ { "" "a" "aa" "aaa" } ]
|
||||
[ 4 [ CHAR: a fill ] vector-project ]
|
||||
|
|
|
@ -107,10 +107,15 @@ BUILTIN: vector 11
|
|||
: vector-all? ( vector pred -- ? )
|
||||
vector-map vector-and ; inline
|
||||
|
||||
: vector-append ( v1 v2 -- )
|
||||
: vector-nappend ( v1 v2 -- )
|
||||
#! Destructively append v2 to v1.
|
||||
[ over vector-push ] vector-each drop ;
|
||||
|
||||
: vector-append ( v1 v2 -- vec )
|
||||
over vector-length over vector-length + <vector>
|
||||
[ rot vector-nappend ] keep
|
||||
[ swap vector-nappend ] keep ;
|
||||
|
||||
: vector-project ( n quot -- accum )
|
||||
#! Execute the quotation n times, passing the loop counter
|
||||
#! the quotation as it ranges from 0..n-1. Collect results
|
||||
|
@ -122,7 +127,7 @@ BUILTIN: vector 11
|
|||
: vector-zip ( v1 v2 -- v )
|
||||
#! Make a new vector with each pair of elements from the
|
||||
#! first two in a pair.
|
||||
over vector-length [
|
||||
over vector-length over vector-length min [
|
||||
pick pick >r over >r vector-nth r> r> vector-nth cons
|
||||
] vector-project nip nip ;
|
||||
|
||||
|
@ -168,8 +173,13 @@ M: vector hashcode ( vec -- n )
|
|||
over ?vector-nth hashcode rot bitxor swap
|
||||
] times* drop ;
|
||||
|
||||
: vector-head ( n vector -- list )
|
||||
#! Return a new list with all elements up to the nth
|
||||
#! element.
|
||||
swap [ over vector-nth ] vector-project nip ;
|
||||
|
||||
: vector-tail ( n vector -- list )
|
||||
#! Return a new vector, with all elements from the nth
|
||||
#! Return a new list with all elements from the nth
|
||||
#! index upwards.
|
||||
2dup vector-length swap - [
|
||||
pick + over vector-nth
|
||||
|
|
Loading…
Reference in New Issue