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 ^^offset>slot ] [ second value-tag ] bi*
  32     pick [ ^^set-slot ] dip ;
  33
  34 : (emit-set-slot-imm) ( infos -- obj-reg )
  35     ds-drop
  36     [ 2inputs ]
  37     [ [ third literal>> ] [ second value-tag ] bi ] bi*
  38     pick [ ##set-slot-imm ] dip ;
  39
  40 : emit-set-slot ( node -- )
  41     dup node-input-infos
  42     dup second value-tag [
  43         nip
  44         [
  45             dup third value-info-small-fixnum?
  46             [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
  47         ] [ first class>> immediate class<= ] bi
  48         [ drop ] [ i i ##write-barrier ] if
  49     ] [ drop emit-primitive ] if ;
  50
  51 : emit-string-nth ( -- )
  52     2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
  53
  54 : emit-set-string-nth-fast ( -- )
  55     3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
  56     swap i ##set-string-nth-fast ;