basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators compiler.cfg.builder.blocks
   4 compiler.cfg.comparisons compiler.cfg.hats
   5 compiler.cfg.instructions compiler.cfg.stacks.local compiler.cfg.registers
   6 compiler.cfg.stacks compiler.tree.propagation.info cpu.architecture fry kernel
   7 layouts math math.intervals namespaces sequences ;
   8 IN: compiler.cfg.intrinsics.fixnum
   9
  10 : emit-both-fixnums? ( -- )
  11     [
  12         [ ^^tagged>integer ] bi@
  13         ^^or tag-mask get ^^and-imm
  14         0 cc= ^^compare-integer-imm
  15     ] binary-op ;
  16
  17 : emit-fixnum-left-shift ( -- )
  18     [ ^^shl ] binary-op ;
  19
  20 : emit-fixnum-right-shift ( -- )
  21     [
  22         [ tag-bits get ^^shl-imm ] dip
  23         ^^neg ^^sar
  24         tag-bits get ^^sar-imm
  25     ] binary-op ;
  26
  27 : emit-fixnum-shift-general ( -- )
  28     ds-peek 0 cc> ##compare-integer-imm-branch,
  29     [ emit-fixnum-left-shift ] with-branch
  30     [ emit-fixnum-right-shift ] with-branch
  31     2array emit-conditional ;
  32
  33 : emit-fixnum-shift-fast ( node -- )
  34     node-input-infos second interval>> {
  35         { [ dup 0 [a,inf] interval-subset? ] [ drop emit-fixnum-left-shift ] }
  36         { [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] }
  37         [ drop emit-fixnum-shift-general ]
  38     } cond ;
  39
  40 : emit-fixnum-comparison ( cc -- )
  41     '[ _ ^^compare-integer ] binary-op ;
  42
  43 : emit-no-overflow-case ( dst -- final-bb )
  44     [ D -2 inc-stack ds-push ] with-branch ;
  45
  46 : emit-overflow-case ( word -- final-bb )
  47     [
  48         -1 emit-call-block
  49     ] with-branch ;
  50
  51 : emit-fixnum-overflow-op ( quot word -- )
  52     ! Inputs to the final instruction need to be copied because
  53     ! of loc>vreg sync
  54     [ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip
  55     [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
  56     emit-conditional ; inline
  57
  58 : fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;
  59
  60 : fixnum-overflow ( x y -- z ) [ >bignum ] bi@ - ;
  61
  62 : fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ;
  63
  64 : emit-fixnum+ ( -- )
  65     [ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ;
  66
  67 : emit-fixnum- ( -- )
  68     [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
  69
  70 : emit-fixnum* ( -- )
  71     [ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;