1 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: sequences accessors layouts kernel math math.intervals
4 namespaces combinators fry arrays
6 compiler.tree.propagation.info
9 compiler.cfg.instructions
10 compiler.cfg.utilities
11 compiler.cfg.builder.blocks
12 compiler.cfg.registers
13 compiler.cfg.comparisons ;
14 IN: compiler.cfg.intrinsics.fixnum
16 : emit-both-fixnums? ( -- )
19 tag-mask get ^^and-imm
23 : tag-literal ( n -- tagged )
24 literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
26 : emit-fixnum-op ( insn -- )
27 [ 2inputs ] dip call ds-push ; inline
29 : emit-fixnum-left-shift ( -- )
30 [ ^^untag-fixnum ^^shl ] emit-fixnum-op ;
32 : emit-fixnum-right-shift ( -- )
33 [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
35 : emit-fixnum-shift-general ( -- )
36 ds-peek 0 cc> ##compare-imm-branch
37 [ emit-fixnum-left-shift ] with-branch
38 [ emit-fixnum-right-shift ] with-branch
39 2array emit-conditional ;
41 : emit-fixnum-shift-fast ( node -- )
42 node-input-infos second interval>> {
43 { [ dup 0 [a,inf] interval-subset? ] [ drop emit-fixnum-left-shift ] }
44 { [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] }
45 [ drop emit-fixnum-shift-general ]
48 : emit-fixnum-bitnot ( -- )
49 ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
51 : emit-fixnum-log2 ( -- )
52 ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
54 : emit-fixnum*fast ( -- )
55 2inputs ^^untag-fixnum ^^mul ds-push ;
57 : emit-fixnum-comparison ( cc -- )
58 '[ _ ^^compare ] emit-fixnum-op ;
60 : emit-bignum>fixnum ( -- )
61 ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
63 : emit-fixnum>bignum ( -- )
64 ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
66 : emit-no-overflow-case ( dst -- final-bb )
67 [ ds-drop ds-drop ds-push ] with-branch ;
69 : emit-overflow-case ( word -- final-bb )
70 [ ##call -1 adjust-d ] with-branch ;
72 : emit-fixnum-overflow-op ( quot word -- )
73 ! Inputs to the final instruction need to be copied because
75 [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
76 [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
77 emit-conditional ; inline
79 : fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;
81 : fixnum-overflow ( x y -- z ) [ >bignum ] bi@ - ;
83 : fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ;
86 [ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ;
89 [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
92 [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;