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     [ node-input-infos first literal>> ]
  19     [
  20         ds-drop
  21         vm-special-object-offset ^^vm-field
  22         ds-push
  23     ] [ emit-primitive ] ?if ;
  24
  25 : emit-set-special-object ( block node -- block' )
  26     [ node-input-infos second literal>> ]
  27     [
  28         ds-drop
  29         [ ds-pop ] dip vm-special-object-offset ##set-vm-field,
  30     ] [ emit-primitive ] ?if ;
  31
  32 : context-object-offset ( n -- n )
  33     cells "context-objects" context offset-of + ;
  34
  35 : emit-context-object ( block node -- block' )
  36     [ node-input-infos first literal>> ] [
  37         "ctx" vm offset-of ^^vm-field
  38         ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
  39     ] [ emit-primitive ] ?if ;
  40
  41 : emit-identity-hashcode ( -- )
  42     [
  43         ^^tagged>integer
  44         tag-mask get bitnot ^^load-integer ^^and
  45         0 int-rep f ^^load-memory-imm
  46         hashcode-shift ^^shr-imm
  47     ] unary-op ;
  48
  49 : emit-local-allot ( block node -- block' )
  50     dup node-input-infos first2 [ literal>> ] bi@ 2dup [ integer? ] both?
  51     [ ds-drop ds-drop f ^^local-allot ^^box-alien ds-push drop ]
  52     [ 2drop emit-primitive ] if ;
  53
  54 : emit-cleanup-allot ( block node -- block' )
  55     drop [ drop ##no-tco, ] emit-trivial-block ;