diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 35039602a9..115d9e43a5 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -245,7 +245,10 @@ FORGET: set-stack-effect ! Okay, now we have primitives fleshed out. Bring up the generic ! word system. : builtin-predicate ( class predicate -- ) - [ \ type , over types first , \ eq? , ] [ ] make + [ + over types first dup + tag-mask < \ tag \ type ? , , \ eq? , + ] [ ] make define-predicate ; : register-builtin ( class -- ) diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index 9e6355858f..17b64fc239 100644 --- a/library/collections/hashtables.factor +++ b/library/collections/hashtables.factor @@ -140,6 +140,9 @@ IN: hashtables : hash-subset ( hash quot -- hash | quot: [[ k v ]] -- ? ) >r hash>alist r> subset alist>hash ; inline +: hash-subset-with ( obj hash quot -- hash ) + swap [ with rot ] hash-subset 2nip ; inline + M: hashtable clone ( hash -- hash ) dup bucket-count over hash-size over set-hash-size diff --git a/library/compiler/basic-blocks.factor b/library/compiler/basic-blocks.factor index 8705430435..c4863a1aa8 100644 --- a/library/compiler/basic-blocks.factor +++ b/library/compiler/basic-blocks.factor @@ -1,5 +1,5 @@ IN: compiler-backend -USING: hashtables kernel math namespaces sequences vectors ; +USING: hashtables kernel lists math namespaces sequences vectors ; : (split-blocks) ( n linear -- ) 2dup length = [ @@ -117,7 +117,15 @@ M: %peek-r trim-dead* ( tail vop -- ) ?dead-peek ; : redundant-replace? ( vop -- ? ) dup 0 vop-out swap 0 vop-in vreg-contents get hash = ; +: forget-stack-loc ( loc -- ) + #! Forget that any vregs hold this stack location. + vreg-contents [ [ cdr swap = not ] hash-subset-with ] change ; + : remember-replace ( vop -- ) + #! If a vreg claims to hold the stack location we are + #! writing to, we must forget this fact, since that stack + #! location no longer holds this value! + dup 0 vop-out forget-stack-loc dup 0 vop-out swap 0 vop-in vreg-contents get set-hash ; : ?dead-replace ( tail vop -- ) diff --git a/library/inference/call-optimizers.factor b/library/inference/call-optimizers.factor index dcbca9142c..5dd20ea0ae 100644 --- a/library/inference/call-optimizers.factor +++ b/library/inference/call-optimizers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: optimizer -USING: errors generic hashtables inference kernel math +USING: errors generic hashtables inference kernel lists math math-internals sequences vectors words ; ! A system for associating dataflow optimizers with words. diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor index 0643d73c51..19decb5daf 100644 --- a/library/inference/known-words.factor +++ b/library/inference/known-words.factor @@ -3,6 +3,42 @@ USING: alien assembler errors generic hashtables interpreter io io-internals kernel kernel-internals lists math math-internals memory parser sequences strings vectors words prettyprint ; +! We transform calls to these words into 'branched' forms; +! eg, there is no VOP for fixnum<=, only fixnum<= followed +! by an #ifte, so if we have a 'bare' fixnum<= we add +! [ t ] [ f ] ifte at the end. + +! This transformation really belongs in the optimizer, but it +! is simpler to do it here. +\ fixnum< [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop +\ fixnum< t "flushable" set-word-prop +\ fixnum< t "foldable" set-word-prop + +\ fixnum<= [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop +\ fixnum<= t "flushable" set-word-prop +\ fixnum<= t "foldable" set-word-prop + +\ fixnum> [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop +\ fixnum> t "flushable" set-word-prop +\ fixnum> t "foldable" set-word-prop + +\ fixnum>= [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop +\ fixnum>= t "flushable" set-word-prop +\ fixnum>= t "foldable" set-word-prop + +\ eq? [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop +\ eq? t "flushable" set-word-prop +\ eq? t "foldable" set-word-prop + +! : manual-branch ( word -- ) +! dup "infer-effect" word-prop consume/produce +! [ [ t ] [ f ] ifte ] infer-quot ; +! +! { fixnum<= fixnum< fixnum>= fixnum> eq? } [ +! dup dup literalize [ manual-branch ] cons +! "infer" set-word-prop +! ] each + ! Primitive combinators \ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop @@ -153,22 +189,6 @@ memory parser sequences strings vectors words prettyprint ; \ fixnum-shift t "flushable" set-word-prop \ fixnum-shift t "foldable" set-word-prop -\ fixnum< [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop -\ fixnum< t "flushable" set-word-prop -\ fixnum< t "foldable" set-word-prop - -\ fixnum<= [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop -\ fixnum<= t "flushable" set-word-prop -\ fixnum<= t "foldable" set-word-prop - -\ fixnum> [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop -\ fixnum> t "flushable" set-word-prop -\ fixnum> t "foldable" set-word-prop - -\ fixnum>= [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop -\ fixnum>= t "flushable" set-word-prop -\ fixnum>= t "foldable" set-word-prop - \ bignum= [ [ bignum bignum ] [ boolean ] ] "infer-effect" set-word-prop \ bignum= t "flushable" set-word-prop \ bignum= t "foldable" set-word-prop @@ -327,10 +347,6 @@ memory parser sequences strings vectors words prettyprint ; \ update-xt [ [ word ] [ ] ] "infer-effect" set-word-prop \ compiled? [ [ word ] [ boolean ] ] "infer-effect" set-word-prop -\ eq? [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop -\ eq? t "flushable" set-word-prop -\ eq? t "foldable" set-word-prop - \ getenv [ [ fixnum ] [ object ] ] "infer-effect" set-word-prop \ setenv [ [ object fixnum ] [ ] ] "infer-effect" set-word-prop \ stat [ [ string ] [ general-list ] ] "infer-effect" set-word-prop diff --git a/library/inference/split-nodes.factor b/library/inference/split-nodes.factor index fbce44fb27..e234cada00 100644 --- a/library/inference/split-nodes.factor +++ b/library/inference/split-nodes.factor @@ -37,6 +37,13 @@ M: node split-node* ( node -- ) drop ; [ last-node 2dup swap post-inline set-node-successor ] keep split-node ; +: inline-literals ( node literals -- node ) + #! Make #push -> #return -> successor + over drop-inputs [ + >r [ literalize ] map dataflow [ subst-node ] keep + r> set-node-successor + ] keep ; + : split-branch ( node -- ) dup node-successor over node-children [ >r clone-node r> subst-node ] each-with @@ -51,10 +58,3 @@ M: #dispatch split-node* ( node -- ) ! #label M: #label split-node* ( node -- ) node-child split-node ; - -: inline-literals ( node literals -- node ) - #! Make #push -> #return -> successor - over drop-inputs [ - >r [ literalize ] map dataflow [ subst-node ] keep - r> set-node-successor - ] keep ; diff --git a/library/test/compiler/intrinsics.factor b/library/test/compiler/intrinsics.factor index a0ca804017..3b39eb5873 100644 --- a/library/test/compiler/intrinsics.factor +++ b/library/test/compiler/intrinsics.factor @@ -170,3 +170,8 @@ math-internals test words ; ! regression [ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-1 2nip ] unit-test + +! regression +: blah over cons? [ "x" get >r 2cdr r> ] [ 2drop f f f ] ifte ; compiled + +[ f ] [ f "x" set [ 1 2 3 ] [ 1 3 2 ] blah drop 2car = ] unit-test