basis/compiler/cfg/intrinsics/slots/slots.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors classes.algebra classes.builtin
   4 combinators.short-circuit compiler.cfg.builder.blocks
   5 compiler.cfg.hats compiler.cfg.instructions
   6 compiler.cfg.registers compiler.cfg.stacks
   7 compiler.tree.propagation.info cpu.architecture kernel layouts
   8 math namespaces sequences ;
   9 IN: compiler.cfg.intrinsics.slots
  10
  11 : class-tag ( class -- tag/f )
  12     builtins get [ class<= ] with find drop ;
  13
  14 : value-tag ( info -- n/f )
  15     class>> class-tag ;
  16
  17 : slot-indexing ( slot tag -- slot scale tag )
  18     complex-addressing?
  19     [ [ cell log2 ] dip ] [ [ ^^offset>slot ] dip ^^sub-imm 0 0 ] if ;
  20
  21 : (emit-slot) ( infos -- dst )
  22     [ 2inputs ] [ first value-tag ] bi*
  23     slot-indexing ^^slot ;
  24
  25 : (emit-slot-imm) ( infos -- dst )
  26     ds-drop
  27     [ ds-pop ]
  28     [ [ second literal>> ] [ first value-tag ] bi ] bi*
  29     ^^slot-imm ;
  30
  31 : immediate-slot-offset? ( object -- ? )
  32     { [ fixnum? ] [ cell * immediate-arithmetic? ] } 1&& ;
  33
  34 : emit-slot ( block node -- block' )
  35     dup node-input-infos
  36     dup first value-tag [
  37         nip
  38         dup second literal>> immediate-slot-offset?
  39         [ (emit-slot-imm) ] [ (emit-slot) ] if
  40         ds-push
  41     ] [ drop emit-primitive ] if ;
  42
  43 :: (emit-set-slot-imm) ( write-barrier? tag slot -- )
  44     ds-drop
  45
  46     2inputs :> ( src obj )
  47
  48     src obj slot tag ##set-slot-imm,
  49
  50     write-barrier?
  51     [ obj slot tag next-vreg next-vreg ##write-barrier-imm, ] when ;
  52
  53 :: (emit-set-slot) ( write-barrier? tag -- )
  54     3inputs :> ( src obj slot )
  55
  56     slot tag slot-indexing :> ( slot scale tag )
  57
  58     src obj slot scale tag ##set-slot,
  59
  60     write-barrier?
  61     [ obj slot scale tag next-vreg next-vreg ##write-barrier, ] when ;
  62
  63 : node>set-slot-data ( #call -- write-barrier? tag literal )
  64     node-input-infos first3
  65     [ class>> immediate class<= not ] [ value-tag ] [ literal>> ] tri* ;
  66
  67 : emit-intrinsic-set-slot ( write-barrier? tag index-info -- )
  68     dup immediate-slot-offset? [
  69         (emit-set-slot-imm)
  70     ] [ drop (emit-set-slot) ] if ;
  71
  72 : emit-set-slot ( block #call -- block' )
  73     dup node>set-slot-data over [
  74         emit-intrinsic-set-slot drop
  75     ] [ 3drop emit-primitive ] if ;