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 namespaces
   4 combinators fry
   5 compiler.tree.propagation.info
   6 compiler.cfg.hats
   7 compiler.cfg.stacks
   8 compiler.cfg.instructions
   9 compiler.cfg.utilities
  10 compiler.cfg.registers
  11 compiler.cfg.comparisons ;
  12 IN: compiler.cfg.intrinsics.fixnum
  13
  14 : emit-both-fixnums? ( -- )
  15     2inputs
  16     ^^or
  17     tag-mask get ^^and-imm
  18     0 cc= ^^compare-imm
  19     ds-push ;
  20
  21 : tag-literal ( n -- tagged )
  22     literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
  23
  24 : emit-fixnum-op ( insn -- dst )
  25     [ 2inputs ] dip call ds-push ; inline
  26
  27 : emit-fixnum-shift-fast ( node -- )
  28     dup node-input-infos dup second value-info-small-fixnum? [
  29         nip
  30         [ ds-drop ds-pop ] dip
  31         second literal>> dup sgn {
  32             { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
  33             {  0 [ drop ] }
  34             {  1 [ ^^shl-imm ] }
  35         } case
  36         ds-push
  37     ] [ drop emit-primitive ] if ;
  38
  39 : emit-fixnum-bitnot ( -- )
  40     ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
  41
  42 : emit-fixnum-log2 ( -- )
  43     ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
  44
  45 : emit-fixnum*fast ( -- )
  46     2inputs ^^untag-fixnum ^^mul ds-push ;
  47
  48 : emit-fixnum-comparison ( cc -- )
  49     '[ _ ^^compare ] emit-fixnum-op ;
  50
  51 : emit-bignum>fixnum ( -- )
  52     ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
  53
  54 : emit-fixnum>bignum ( -- )
  55     ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
  56
  57 : emit-fixnum-overflow-op ( quot -- next )
  58     [ 2inputs 1 ##inc-d ] dip call ##branch
  59     begin-basic-block ; inline