diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index ad2d719eed..bfd9f671a8 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -69,10 +69,12 @@ sequences words ; out-1 ] "linearizer" set-word-prop -: top-literal? ( seq -- ? ) peek literal? ; +: node-peek ( node -- obj ) node-consume-d swap hash peek ; + : peek-2 dup length 2 - swap nth ; -: next-typed? ( seq -- ? ) - peek-2 value-types length 1 = ; +: node-peek-2 ( node -- obj ) node-consume-d swap hash peek-2 ; + +: typed? ( value -- ? ) value-types length 1 = ; : self ( word -- ) f swap dup "infer-effect" word-prop (consume/produce) ; @@ -82,14 +84,19 @@ sequences words ; \ slot intrinsic -: slot@ ( seq -- n ) +: slot@ ( node -- n ) #! Compute slot offset. + node-consume-d swap hash dup peek literal-value cell * swap peek-2 value-types car type-tag - ; +: typed-literal? ( node -- ? ) + #! Output if the node's first input is well-typed, and the + #! second is a literal. + dup node-peek literal? swap node-peek-2 typed? and ; + \ slot [ - node-consume-d swap hash - dup top-literal? over next-typed? and [ + dup typed-literal? [ 1 %dec-d , in-1 0 swap slot@ %fast-slot , @@ -105,8 +112,7 @@ sequences words ; \ set-slot intrinsic \ set-slot [ - node-consume-d swap hash - dup top-literal? over next-typed? and [ + dup typed-literal? [ 1 %dec-d , in-2 2 %dec-d , @@ -149,11 +155,10 @@ sequences words ; : binary-op ( node op out -- ) #! out is a vreg where the vop stores the result. - >r >r node-consume-d swap hash - dup top-literal? [ + >r >r node-peek dup literal? [ 1 %dec-d , in-1 - peek literal-value 0 r> execute , + literal-value 0 r> execute , r> 0 %replace-d , ] [ drop @@ -166,7 +171,6 @@ sequences words ; [[ fixnum-bitand %fixnum-bitand ]] [[ fixnum-bitor %fixnum-bitor ]] [[ fixnum-bitxor %fixnum-bitxor ]] - [[ fixnum-shift %fixnum-shift ]] [[ fixnum<= %fixnum<= ]] [[ fixnum< %fixnum< ]] [[ fixnum>= %fixnum>= ]] @@ -181,7 +185,19 @@ sequences words ; \ fixnum* intrinsic \ fixnum* [ - drop \ %fixnum* 0 binary-op-reg + ! Turn multiplication by a power of two into a left shift. + node-peek dup literal? [ + literal-value dup power-of-2? [ + 1 %dec-d , + in-1 + log2 0 %fixnum<< , + 0 0 %replace-d , + ] [ + drop binary-op-reg + ] ifte + ] [ + drop binary-op-reg + ] ifte ] "linearizer" set-word-prop \ fixnum-mod intrinsic @@ -218,3 +234,48 @@ sequences words ; 0 %fixnum-bitnot , out-1 ] "linearizer" set-word-prop + +: slow-shift ( -- ) \ fixnum-shift %call , ; + +: negative-shift ( n -- ) + 1 %dec-d , + in-1 + dup cell -8 * <= [ + drop 0 2 %fixnum-sgn , + 2 0 %replace-d , + ] [ + neg 0 %fixnum>> , + out-1 + ] ifte ; + +: positive-shift ( n -- ) + dup cell 8 * tag-bits - <= [ + 1 %dec-d , + in-1 + 0 %fixnum<< , + out-1 + ] [ + drop slow-shift + ] ifte ; + +: fast-shift ( n -- ) + dup 0 = [ + 1 %dec-d , + drop + ] [ + dup 0 < [ + negative-shift + ] [ + positive-shift + ] ifte + ] ifte ; + +\ fixnum-shift intrinsic + +\ fixnum-shift [ + node-peek dup literal? [ + literal-value fast-shift + ] [ + drop slow-shift + ] ifte +] "linearizer" set-word-prop diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor index 8d66824c5a..17623e785c 100644 --- a/library/compiler/simplifier.factor +++ b/library/compiler/simplifier.factor @@ -191,7 +191,7 @@ M: %call-label simplify-node ( linear vop -- ? ) : dead-code ( linear -- linear ? ) uncons (dead-code) >r cons r> ; -M: %jump-label simplify-node ( linear vop -- ? ) +M: %jump-label simplify-node ( linear vop -- linear ? ) drop \ %return dup double-jump [ t @@ -211,7 +211,6 @@ M: %jump-label simplify-node ( linear vop -- ? ) ! ] ifte ] ifte ] ifte ; - ! ! #jump-label [ ! [ #return #return double-jump ] diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor index 8312699052..ba2759e508 100644 --- a/library/compiler/vops.factor +++ b/library/compiler/vops.factor @@ -142,7 +142,6 @@ VOP: %fixnum-bitand : %fixnum-bitand src/dest-vop <%fixnum-bitand> ; VOP: %fixnum-bitor : %fixnum-bitor src/dest-vop <%fixnum-bitor> ; VOP: %fixnum-bitxor : %fixnum-bitxor src/dest-vop <%fixnum-bitxor> ; VOP: %fixnum-bitnot : %fixnum-bitnot dest-vop <%fixnum-bitnot> ; -VOP: %fixnum-shift : %fixnum-shift src/dest-vop <%fixnum-shift> ; VOP: %fixnum<= : %fixnum<= src/dest-vop <%fixnum<=> ; VOP: %fixnum< : %fixnum< src/dest-vop <%fixnum<> ; @@ -150,6 +149,22 @@ VOP: %fixnum>= : %fixnum>= src/dest-vop <%fixnum>=> ; VOP: %fixnum> : %fixnum> src/dest-vop <%fixnum>> ; VOP: %eq? : %eq? src/dest-vop <%eq?> ; +! At the VOP level, the 'shift' operation is split into five +! distinct operations: +! - shifts with a large positive count: calls runtime to make +! a bignum +! - shifts with a small positive count: %fixnum<< +! - shifts with a small negative count: %fixnum>> +! - shifts with a small negative count: %fixnum>> +! - shifts with a large negative count: %fixnum-sgn +VOP: %fixnum<< : %fixnum<< src/dest-vop <%fixnum<<> ; +VOP: %fixnum>> : %fixnum>> src/dest-vop <%fixnum>>> ; +! due to x86 limitations the destination of this VOP must be +! vreg 2 (EDX), and the source must be vreg 0 (EAX). +VOP: %fixnum-sgn : %fixnum-sgn src/dest-vop <%fixnum-sgn> ; + +! Integer comparison followed by a conditional branch is +! optimized VOP: %jump-fixnum<= : %jump-fixnum<= f swap <%jump-fixnum<=> ; VOP: %jump-fixnum< : %jump-fixnum< f swap <%jump-fixnum<> ; VOP: %jump-fixnum>= : %jump-fixnum>= f swap <%jump-fixnum>=> ; diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor index ac909daed2..0d0c6e02a8 100644 --- a/library/compiler/x86/assembler.factor +++ b/library/compiler/x86/assembler.factor @@ -202,7 +202,7 @@ M: word JUMPcc ( opcode addr -- ) : JNO HEX: 81 swap JUMPcc ; : JB HEX: 82 swap JUMPcc ; : JAE HEX: 83 swap JUMPcc ; -: JE HEX: 84 swap JUMPcc ; +: JE HEX: 84 swap JUMPcc ; ! aka JZ : JNE HEX: 85 swap JUMPcc ; : JBE HEX: 86 swap JUMPcc ; : JA HEX: 87 swap JUMPcc ; @@ -260,12 +260,14 @@ M: operand CMP OCT: 071 2-operand ; : CDQ HEX: 99 compile-byte ; +: ROL ( dst n -- ) HEX: c1 BIN: 000 immediate-8 ; +: ROR ( dst n -- ) HEX: c1 BIN: 001 immediate-8 ; +: RCL ( dst n -- ) HEX: c1 BIN: 010 immediate-8 ; +: RCR ( dst n -- ) HEX: c1 BIN: 011 immediate-8 ; : SHL ( dst n -- ) HEX: c1 BIN: 100 immediate-8 ; : SHR ( dst n -- ) HEX: c1 BIN: 101 immediate-8 ; : SAR ( dst n -- ) HEX: c1 BIN: 111 immediate-8 ; -: RCR ( dst -- ) HEX: d1 compile-byte BIN: 011 1-operand ; - : LEA ( dst src -- ) HEX: 8d compile-byte swap register 1-operand ; diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/fixnum.factor index f770c57c88..4baffd5de6 100644 --- a/library/compiler/x86/fixnum.factor +++ b/library/compiler/x86/fixnum.factor @@ -12,7 +12,7 @@ memory namespaces words ; "end" get JNO ! There was an overflow. Untag the fixnum and add the carry. ! Thanks to Dazhbog for figuring out this trick. - dup RCR + dup 1 RCR dup 2 SAR ! Create a bignum PUSH @@ -36,7 +36,6 @@ M: %fixnum* generate-node ( vop -- ) ECX IMUL