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