-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences accessors layouts kernel math math.intervals
-namespaces combinators fry arrays
-cpu.architecture
-compiler.tree.propagation.info
-compiler.cfg.hats
-compiler.cfg.stacks
-compiler.cfg.instructions
-compiler.cfg.utilities
-compiler.cfg.builder.blocks
-compiler.cfg.registers
-compiler.cfg.comparisons ;
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
+! See https://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators compiler.cfg.builder.blocks
+compiler.cfg.comparisons compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.stacks compiler.cfg.stacks.local
+compiler.tree.propagation.info cpu.architecture kernel layouts
+math math.intervals namespaces sequences ;
IN: compiler.cfg.intrinsics.fixnum
: emit-both-fixnums? ( -- )
- 2inputs
- ^^or
- tag-mask get ^^and-imm
- 0 cc= ^^compare-imm
- ds-push ;
-
-: tag-literal ( n -- tagged )
- literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
-
-: emit-fixnum-op ( insn -- )
- [ 2inputs ] dip call ds-push ; inline
+ [
+ [ ^^tagged>integer ] bi@
+ ^^or tag-mask get ^^and-imm
+ 0 cc= ^^compare-integer-imm
+ ] binary-op ;
: emit-fixnum-left-shift ( -- )
- [ ^^untag-fixnum ^^shl ] emit-fixnum-op ;
+ [ ^^shl ] binary-op ;
: emit-fixnum-right-shift ( -- )
- [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
-
-: emit-fixnum-shift-general ( -- )
- ds-peek 0 cc> ##compare-imm-branch
- [ emit-fixnum-left-shift ] with-branch
- [ emit-fixnum-right-shift ] with-branch
- 2array emit-conditional ;
-
-: emit-fixnum-shift-fast ( node -- )
+ [
+ [ tag-bits get ^^shl-imm ] dip
+ ^^neg ^^sar
+ tag-bits get ^^sar-imm
+ ] binary-op ;
+
+: emit-fixnum-shift-general ( block -- block' )
+ ds-peek 0 cc> ##compare-integer-imm-branch, dup
+ [ [ emit-fixnum-left-shift ] with-branch ]
+ [ [ emit-fixnum-right-shift ] with-branch ] bi 2array
+ emit-conditional ;
+
+: emit-fixnum-shift-fast ( block #call -- block' )
node-input-infos second interval>> {
{ [ dup 0 [a,inf] interval-subset? ] [ drop emit-fixnum-left-shift ] }
- { [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] }
+ { [ dup 0 [-inf,b] interval-subset? ] [ drop emit-fixnum-right-shift ] }
[ drop emit-fixnum-shift-general ]
} cond ;
-
-: emit-fixnum-bitnot ( -- )
- ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
-
-: emit-fixnum-log2 ( -- )
- ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
-
-: emit-fixnum*fast ( -- )
- 2inputs ^^untag-fixnum ^^mul ds-push ;
: emit-fixnum-comparison ( cc -- )
- '[ _ ^^compare ] emit-fixnum-op ;
+ '[ _ ^^compare-integer ] binary-op ;
-: emit-no-overflow-case ( dst -- final-bb )
- [ ds-drop ds-drop ds-push ] with-branch ;
+: emit-no-overflow-case ( dst block -- final-bb )
+ [ swap D: -2 inc-stack ds-push ] with-branch ;
-: emit-overflow-case ( word -- final-bb )
- [ ##call -1 adjust-d ] with-branch ;
+: emit-overflow-case ( word block -- final-bb )
+ [ -1 swap [ emit-call-block ] keep ] with-branch ;
-: emit-fixnum-overflow-op ( quot word -- )
- ! Inputs to the final instruction need to be copied because
- ! of loc>vreg sync
- [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
- [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
- emit-conditional ; inline
+:: emit-fixnum-overflow-op ( block quot word -- block' )
+ (2inputs) [ any-rep ^^copy ] bi@ cc/o
+ quot call( vreg1 vreg2 cc -- vreg ) block emit-no-overflow-case
+ word block emit-overflow-case 2array
+ block swap emit-conditional ; inline
: fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;
: fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ;
-: emit-fixnum+ ( -- )
+: emit-fixnum+ ( block -- block' )
[ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ;
-: emit-fixnum- ( -- )
+: emit-fixnum- ( block -- block' )
[ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
-: emit-fixnum* ( -- )
- [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
\ No newline at end of file
+: emit-fixnum* ( block -- block' )
+ [ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;