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

   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
   5 compiler.tree.propagation.info
   6 compiler.cfg.hats
   7 compiler.cfg.stacks
   8 compiler.cfg.instructions
   9 compiler.cfg.utilities
  10 compiler.cfg.builder.blocks
  11 compiler.cfg.registers
  12 compiler.cfg.comparisons ;
  13 IN: compiler.cfg.intrinsics.fixnum
  14
  15 : emit-both-fixnums? ( -- )
  16     2inputs
  17     ^^or
  18     tag-mask get ^^and-imm
  19     0 cc= ^^compare-imm
  20     ds-push ;
  21
  22 : tag-literal ( n -- tagged )
  23     literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
  24
  25 : emit-fixnum-op ( insn -- )
  26     [ 2inputs ] dip call ds-push ; inline
  27
  28 : emit-fixnum-left-shift ( -- )
  29     [ ^^untag-fixnum ^^shl ] emit-fixnum-op ;
  30
  31 : emit-fixnum-right-shift ( -- )
  32     [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
  33
  34 : emit-fixnum-shift-general ( -- )
  35     ds-peek 0 cc> ##compare-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-bitnot ( -- )
  48     ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
  49
  50 : emit-fixnum-log2 ( -- )
  51     ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
  52
  53 : emit-fixnum*fast ( -- )
  54     2inputs ^^untag-fixnum ^^mul ds-push ;
  55
  56 : emit-fixnum-comparison ( cc -- )
  57     '[ _ ^^compare ] emit-fixnum-op ;
  58
  59 : emit-bignum>fixnum ( -- )
  60     ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
  61
  62 : emit-fixnum>bignum ( -- )
  63     ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
  64
  65 : emit-no-overflow-case ( dst -- final-bb )
  66     [ ds-drop ds-drop ds-push ] with-branch ;
  67
  68 : emit-overflow-case ( word -- final-bb )
  69     [ ##call -1 adjust-d ] with-branch ;
  70
  71 : emit-fixnum-overflow-op ( quot word -- )
  72     ! Inputs to the final instruction need to be copied because
  73     ! of loc>vreg sync
  74     [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip
  75     [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
  76     emit-conditional ; inline
  77
  78 : fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;
  79
  80 : fixnum-overflow ( x y -- z ) [ >bignum ] bi@ - ;
  81
  82 : fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ;
  83
  84 : emit-fixnum+ ( -- )
  85     [ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ;
  86
  87 : emit-fixnum- ( -- )
  88     [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
  89
  90 : emit-fixnum* ( -- )
  91     [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;