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

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