basis/compiler/cfg/intrinsics/misc/misc.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors classes.algebra layouts kernel math namespaces
   4 sequences cpu.architecture
   5 compiler.tree.propagation.info
   6 compiler.cfg.stacks
   7 compiler.cfg.hats
   8 compiler.cfg.comparisons
   9 compiler.cfg.instructions
  10 compiler.cfg.builder.blocks
  11 compiler.cfg.utilities ;
  12 FROM: vm => context-field-offset vm-field-offset ;
  13 QUALIFIED-WITH: alien.c-types c
  14 IN: compiler.cfg.intrinsics.misc
  15
  16 : emit-tag ( -- )
  17     [ ^^tagged>integer tag-mask get ^^and-imm ] unary-op ;
  18
  19 : emit-eq ( node -- )
  20     node-input-infos first2 [ class>> fixnum class<= ] both?
  21     [ [ cc= ^^compare-integer ] binary-op ] [ [ cc= ^^compare ] binary-op ] if ;
  22
  23 : special-object-offset ( n -- offset )
  24     cells "special-objects" vm-field-offset + ;
  25
  26 : emit-special-object ( node -- )
  27     dup node-input-infos first literal>> [
  28         ds-drop
  29         special-object-offset ^^vm-field
  30         ds-push
  31     ] [ emit-primitive ] ?if ;
  32
  33 : emit-set-special-object ( node -- )
  34     dup node-input-infos second literal>> [
  35         ds-drop
  36         [ ds-pop ] dip special-object-offset ##set-vm-field
  37     ] [ emit-primitive ] ?if ;
  38
  39 : context-object-offset ( n -- n )
  40     cells "context-objects" context-field-offset + ;
  41
  42 : emit-context-object ( node -- )
  43     dup node-input-infos first literal>> [
  44         "ctx" vm-field-offset ^^vm-field
  45         ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
  46     ] [ emit-primitive ] ?if ;
  47
  48 : emit-identity-hashcode ( -- )
  49     [
  50         ^^tagged>integer
  51         tag-mask get bitnot ^^load-integer ^^and
  52         0 int-rep f ^^load-memory-imm
  53         hashcode-shift ^^shr-imm
  54     ] unary-op ;
  55
  56 : emit-local-allot ( node -- )
  57     dup node-input-infos first literal>> dup integer?
  58     [ nip ds-drop f ^^local-allot ^^box-alien ds-push ]
  59     [ drop emit-primitive ]
  60     if ;