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

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