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

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: layouts namespaces kernel accessors sequences
   4 classes.algebra locals compiler.tree.propagation.info
   5 compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
   6 compiler.cfg.instructions compiler.cfg.utilities
   7 compiler.cfg.builder.blocks compiler.constants ;
   8 IN: compiler.cfg.intrinsics.slots
   9
  10 : value-tag ( info -- n ) class>> class-tag ; inline
  11
  12 : ^^tag-offset>slot ( slot tag -- vreg' )
  13     [ ^^offset>slot ] dip ^^sub-imm ;
  14
  15 : (emit-slot) ( infos -- dst )
  16     [ 2inputs ] [ first value-tag ] bi*
  17     ^^tag-offset>slot ^^slot ;
  18
  19 : (emit-slot-imm) ( infos -- dst )
  20     ds-drop
  21     [ ds-pop ]
  22     [ [ second literal>> ] [ first value-tag ] bi ] bi*
  23     ^^slot-imm ;
  24
  25 : emit-slot ( node -- )
  26     dup node-input-infos
  27     dup first value-tag [
  28         nip
  29         dup second value-info-small-fixnum?
  30         [ (emit-slot-imm) ] [ (emit-slot) ] if
  31         ds-push
  32     ] [ drop emit-primitive ] if ;
  33
  34 : emit-write-barrier? ( infos -- ? )
  35     first class>> immediate class<= not ;
  36
  37 :: (emit-set-slot) ( infos -- )
  38     3inputs :> slot :> obj :> src
  39
  40     slot infos second value-tag ^^tag-offset>slot :> slot
  41
  42     src obj slot ##set-slot
  43
  44     infos emit-write-barrier?
  45     [ obj slot next-vreg next-vreg ##write-barrier ] when ;
  46
  47 :: (emit-set-slot-imm) ( infos -- )
  48     ds-drop
  49
  50     2inputs :> obj :> src
  51
  52     infos third literal>> :> slot
  53     infos second value-tag :> tag
  54
  55     src obj slot tag ##set-slot-imm
  56
  57     infos emit-write-barrier?
  58     [ obj slot tag slot-offset next-vreg next-vreg ##write-barrier-imm ] when ;
  59
  60 : emit-set-slot ( node -- )
  61     dup node-input-infos
  62     dup second value-tag [
  63         nip
  64         dup third value-info-small-fixnum?
  65         [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
  66     ] [ drop emit-primitive ] if ;
  67
  68 : emit-string-nth ( -- )
  69     2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
  70
  71 : emit-set-string-nth-fast ( -- )
  72     3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
  73     swap next-vreg ##set-string-nth-fast ;