basis/compiler/cfg/hats/hats.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays byte-arrays kernel layouts math
   4 namespaces sequences combinators splitting parser effects
   5 words cpu.architecture compiler.cfg.registers
   6 compiler.cfg.instructions compiler.cfg.instructions.syntax ;
   7 IN: compiler.cfg.hats
   8
   9 <<
  10
  11 <PRIVATE
  12
  13 : hat-name ( insn -- word )
  14     name>> "##" ?head drop "^^" prepend create-in ;
  15
  16 : hat-quot ( insn -- quot )
  17     [
  18         "insn-slots" word-prop [ ] [
  19             type>> {
  20                 { def [ [ next-vreg dup ] ] }
  21                 { temp [ [ next-vreg ] ] }
  22                 [ drop [ ] ]
  23             } case swap [ dip ] curry compose
  24         ] reduce
  25     ] keep suffix ;
  26
  27 : hat-effect ( insn -- effect )
  28     "insn-slots" word-prop
  29     [ type>> { def temp } memq? not ] filter [ name>> ] map
  30     { "vreg" } <effect> ;
  31
  32 : define-hat ( insn -- )
  33     [ hat-name ] [ hat-quot ] [ hat-effect ] tri define-inline ;
  34
  35 PRIVATE>
  36
  37 insn-classes get [
  38     dup [ insn-def-slot ] [ name>> "##" head? ] bi and
  39     [ define-hat ] [ drop ] if
  40 ] each
  41
  42 >>
  43
  44 : ^^load-literal ( obj -- dst )
  45     [ next-vreg dup ] dip {
  46         { [ dup not ] [ drop \ f tag-number ##load-immediate ] }
  47         { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
  48         [ ##load-reference ]
  49     } cond ; inline
  50
  51 : ^^unbox-c-ptr ( src class -- dst )
  52     [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; inline
  53
  54 : ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
  55 : ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
  56 : ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
  57 : ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
  58 : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
  59 : ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
  60 : ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline