#! namespace.
"alien-invoke cannot be interpreted." throw ;
-\ alien-invoke [ 4 | 0 ] "infer-effect" set-word-property
+\ alien-invoke [ [ object object object object ] [ ] ]
+"infer-effect" set-word-property
\ alien-invoke [ infer-alien ] "infer" set-word-property
: 2cdr ( cons cons -- car car )
swap cdr swap cdr ;
+: 2uncons ( cons1 cons2 -- car1 car2 cdr1 cdr2 )
+ [ 2car ] 2keep 2cdr ;
+
: last* ( list -- last )
#! Last cons of a list.
dup cdr cons? [ cdr last* ] when ;
USE: vectors
USE: words
USE: hashtables
+USE: prettyprint
: longest-vector ( list -- length )
[ vector-length ] map [ > ] top ;
[ [ meta-r get ] bind ] map
dup check-lengths unify-stacks ;
-: unify ( list -- )
+: unify-effects ( list -- )
filter-terminators dup balanced? [
dup unify-d-in d-in set
dup unify-datastacks meta-d set
: terminator-quot? ( quot -- ? )
literal-value [ terminator? ] some? ;
-: recursive-branch ( rstate value -- )
- #! Set base case if inference didn't fail.
+: dual-branch ( branchlist branch -- rstate )
+ #! Return a recursive state for a branch other than the
+ #! given one in the list.
+ swap [ over eq? not ] subset nip car value-recursion ;
+
+SYMBOL: dual-recursive-state
+
+: recursive-branch ( branchlist value -- namespace )
+ #! Return effect namespace if inference didn't fail.
[
- f infer-branch [
- effect old-effect swap set-base
- ] bind
+ [ dual-branch dual-recursive-state set ] keep
+ f infer-branch
] [
- [ 2drop ] when
+ [ 2drop f ] when
] catch ;
-: dual-branch ( branch branchlist -- rstate )
- #! Return a recursive state for a branch other than the
- #! given one in the list.
- [ over eq? not ] subset nip car value-recursion ;
+: infer-base-cases ( branchlist -- list )
+ [ terminator-quot? not ] subset
+ dup [ dupd recursive-branch ] map nip
+ [ ] subset ;
: infer-base-case ( branchlist -- )
- dup [
- dup terminator-quot? [
- drop
- ] [
- [ over dual-branch ] keep
- recursive-branch
- ] ifte
- ] each drop ;
+ [
+ infer-base-cases unify-effects
+ effect dual-recursive-state get set-base
+ ] with-scope ;
: (infer-branches) ( branchlist -- list )
dup infer-base-case [
- dup terminator-quot? [
- t infer-branch [
- meta-d off meta-r off d-in off
- ] extend
- ] [
- t infer-branch
- ] ifte
+ dup t infer-branch swap terminator-quot? [
+ [ meta-d off meta-r off d-in off ] extend
+ ] when
] map ;
+: unify-dataflow ( inputs instruction effectlist -- )
+ [ [ get-dataflow ] bind ] map
+ swap dataflow, [ node-consume-d set ] bind ;
+
: infer-branches ( inputs instruction branchlist -- )
#! Recursive stack effect inference is done here. If one of
#! the branches has an undecidable stack effect, we set the
#! base case to this stack effect and try again. The inputs
#! parameter is a vector.
- (infer-branches) [
- [ [ get-dataflow ] bind ] map
- swap dataflow, [ node-consume-d set ] bind
- ] keep unify ;
+ (infer-branches) dup unify-effects unify-dataflow ;
: infer-ifte ( -- )
#! Infer effects for both branches, unify.
USE: kernel-internals
\ dispatch [ infer-dispatch ] "infer" set-word-property
-\ dispatch [ 2 | 0 ] "infer-effect" set-word-property
+\ dispatch [ [ fixnum vector ] [ ] ]
+"infer-effect" set-word-property
meta-d get vector-tail* node-consume-d set ;
: dataflow-inputs ( in node -- )
- [ dup list? [ length ] when 0 node-inputs ] bind ;
+ [ length 0 node-inputs ] bind ;
: node-outputs ( d-count r-count -- )
#! Execute in the node's namespace.
meta-d get vector-tail* node-produce-d set ;
: dataflow-outputs ( out node -- )
- [ dup list? [ length ] when 0 node-outputs ] bind ;
+ [ length 0 node-outputs ] bind ;
: get-dataflow ( -- IR )
dataflow-graph get reverse ;
: <recursive-state> ( -- state )
<namespace> [
- base-case off effect old-effect entry-effect set
+ base-case off effect entry-effect set
] extend ;
: init-inference ( recursive-state -- )
#! quotations.
[ apply-object ] each ;
-: compose ( first second -- total )
- #! Stack effect composition.
- >r uncons r> uncons >r -
- dup 0 < [ neg + r> cons ] [ r> + cons ] ifte ;
-
: raise ( [ in | out ] -- [ in | out ] )
uncons 2dup min tuck - >r - r> cons ;
+: new-effect ( [ in | out ] -- [ intypes outtypes ] )
+ uncons
+ swap [ drop object ] project
+ swap [ drop object ] project
+ 2list ;
+
: decompose ( first second -- solution )
#! Return a stack effect such that first*solution = second.
- 2dup 2car
- 2dup > [ "No solution to decomposition" throw ] when
- swap - -rot 2cdr >r + r> cons raise ;
+ over [ [ ] [ ] ] = [
+ nip
+ ] [
+ swap old-effect swap old-effect
+ 2dup 2car
+ 2dup > [ "No solution to decomposition" throw ] when
+ swap - -rot 2cdr >r + r> cons raise new-effect
+ ] ifte ;
: set-base ( [ in | out ] rstate -- )
#! Set the base case of the current word.
#! Take input parameters, execute quotation, take output
#! parameters, add node. The quotation is called with the
#! stack effect.
- >r dup car dup list? [ [ drop object ] project ] unless ensure-d
+ >r dup car ensure-d
>r dataflow, r> r> rot
[ pick car swap dataflow-inputs ] keep
- pick 2slip cdr dup cons? [ car ] when swap
+ pick 2slip cdr car swap
dataflow-outputs ; inline
: consume-d ( typelist -- )
[ <computed> push-d ] each ;
: (consume/produce) ( param op effect -- )
- [
- dup cdr list? [
- ( new style )
- unswons consume-d car produce-d
- ] [
- ( old style, will go away shortly )
- unswons [ pop-d drop ] times [ object <computed> push-d ] times
- ] ifte
- ] with-dataflow ;
+ [ unswons consume-d car produce-d ] with-dataflow ;
: consume/produce ( word [ in-types out-types ] -- )
#! Add a node to the dataflow graph that consumes and
#! side-effect-free and all parameters are literal), or
#! simply apply its stack effect to the meta-interpreter.
over "infer" word-property dup [
- swap car dup list? [ [ drop object ] project ] unless ensure-d call drop
+ swap car ensure-d call drop
] [
drop consume/produce
] ifte ;
: intersection ( list list -- list )
#! Make a list of elements that occur in both lists.
[ over contains? ] subset nip ;
+
+: zip ( list list -- list )
+ #! Make a new list containing pairs of corresponding
+ #! elements from the two given lists.
+ dup [
+ 2uncons zip >r cons r> cons
+ ] [
+ 2drop [ ]
+ ] ifte ;
[ client-socket " host port -- in out " [ [ string integer ] [ port port ] ] ]
[ server-socket " port -- server " [ [ integer ] [ port ] ] ]
[ close-port " port -- " [ [ port ] ] ]
- [ add-accept-io-task " server callback -- " [ 2 | 0 ] ]
- [ accept-fd " server -- host port in out " [ 1 | 4 ] ]
- [ can-read-line? " port -- ? " [ 1 | 1 ] ]
- [ add-read-line-io-task " port callback -- " [ 2 | 0 ] ]
- [ read-line-fd-8 " port -- sbuf " [ 1 | 1 ] ]
- [ can-read-count? " n port -- ? " [ 2 | 1 ] ]
- [ add-read-count-io-task " n port callback -- " [ 3 | 0 ] ]
- [ read-count-fd-8 " n port -- sbuf " [ 2 | 1 ] ]
- [ can-write? " n port -- ? " [ 2 | 1 ] ]
- [ add-write-io-task " port callback -- " [ 2 | 0 ] ]
- [ write-fd-8 " ch/str port -- " [ 2 | 0 ] ]
- [ add-copy-io-task " from to callback -- " [ 3 | 1 ] ]
- [ pending-io-error " -- " [ 0 | 0 ] ]
- [ next-io-task " -- callback " [ 0 | 1 ] ]
- [ room " -- free total free total " [ 0 | 4 ] ]
- [ os-env " str -- str " [ 1 | 1 ] ]
+ [ add-accept-io-task " server callback -- " [ [ port general-list ] [ ] ] ]
+ [ accept-fd " server -- host port in out " [ [ port ] [ string integer port port ] ] ]
+ [ can-read-line? " port -- ? " [ [ port ] [ boolean ] ] ]
+ [ add-read-line-io-task " port callback -- " [ [ port general-list ] [ ] ] ]
+ [ read-line-fd-8 " port -- sbuf " [ [ port ] [ sbuf ] ] ]
+ [ can-read-count? " n port -- ? " [ [ integer port ] [ boolean ] ] ]
+ [ add-read-count-io-task " n port callback -- " [ [ integer port general-list ] [ ] ] ]
+ [ read-count-fd-8 " n port -- sbuf " [ [ integer port ] [ sbuf ] ] ]
+ [ can-write? " n port -- ? " [ [ integer port ] [ boolean ] ] ]
+ [ add-write-io-task " port callback -- " [ [ port general-list ] [ ] ] ]
+ [ write-fd-8 " ch/str port -- " [ [ text port ] [ ] ] ]
+ [ add-copy-io-task " from to callback -- " [ [ port port general-list ] [ ] ] ]
+ [ pending-io-error " -- " [ [ ] [ ] ] ]
+ [ next-io-task " -- callback " [ [ ] [ general-list ] ] ]
+ [ room " -- free total free total " [ [ ] [ integer integer integer integer ] ] ]
+ [ os-env " str -- str " [ [ string ] [ object ] ] ]
[ millis " -- n " [ [ ] [ integer ] ] ]
[ init-random " -- " [ [ ] [ ] ] ]
[ (random-int) " -- n " [ [ ] [ integer ] ] ]
[ [ 1 2 ] ] [ 1 2 2list ] unit-test
[ [ 1 2 3 ] ] [ 1 2 3 3list ] unit-test
+
+[ 1 3 ] [ [ 1 | 2 ] [ 3 | 4 ] 2car ] unit-test
+[ 2 4 ] [ [ 1 | 2 ] [ 3 | 4 ] 2cdr ] unit-test
+[ 1 3 2 4 ] [ [ 1 | 2 ] [ 3 | 4 ] 2uncons ] unit-test
void primitive_from_rect(void)
{
- CELL imaginary = dpop();
- CELL real = dpop();
+ CELL real, imaginary;
F_COMPLEX* complex;
maybe_garbage_collection();
+ imaginary = dpop();
+ real = dpop();
complex = allot(sizeof(F_COMPLEX));
complex->real = real;
complex->imaginary = imaginary;
library implementation, to avoid breaking invariants. */
void primitive_from_fraction(void)
{
- CELL denominator = dpop();
- CELL numerator = dpop();
+ CELL numerator, denominator;
F_RATIO* ratio;
maybe_garbage_collection();
+ denominator = dpop();
+ numerator = dpop();
ratio = allot(sizeof(F_RATIO));
ratio->numerator = numerator;
ratio->denominator = denominator;
projects / factor.git / commitdiff