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

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