basis/compiler/cfg/hats/hats.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien byte-arrays classes.algebra combinators
   4 compiler.cfg.instructions compiler.cfg.instructions.syntax
   5 compiler.cfg.registers compiler.constants effects kernel layouts
   6 math namespaces parser sequences splitting words ;
   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 insn-ctor-name "compiler.cfg.instructions" lookup-word suffix ;
  26
  27 : hat-effect ( insn -- effect )
  28     "insn-slots" word-prop
  29     [ type>> { def temp } member-eq? 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-slots length 1 = ] [ name>> "##" head? ] bi and
  39     [ define-hat ] [ drop ] if
  40 ] each
  41
  42 >>
  43
  44 : ^^load-literal ( obj -- dst )
  45     dup fixnum? [ ^^load-integer ] [ ^^load-reference ] if ;
  46
  47 : ^^offset>slot ( slot -- vreg' )
  48     cell 4 = 2 3 ? ^^shl-imm ;
  49
  50 : ^^unbox-f ( src -- dst )
  51     drop 0 ^^load-literal ;
  52
  53 : ^^unbox-byte-array ( src -- dst )
  54     ^^tagged>integer byte-array-offset ^^add-imm ;
  55
  56 : ^^unbox-c-ptr ( src class -- dst )
  57     {
  58         { [ dup \ f class<= ] [ drop ^^unbox-f ] }
  59         { [ dup alien class<= ] [ drop ^^unbox-alien ] }
  60         { [ dup byte-array class<= ] [ drop ^^unbox-byte-array ] }
  61         [ drop ^^unbox-any-c-ptr ]
  62     } cond ;