basis/compiler/cfg/hats/hats.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien byte-arrays classes.algebra combinators
   4 combinators.short-circuit compiler.cfg.instructions
   5 compiler.cfg.instructions.syntax compiler.cfg.registers
   6 compiler.constants effects kernel layouts math namespaces parser
   7 sequences splitting words ;
   8 IN: compiler.cfg.hats
   9
  10 <<
  11
  12 <PRIVATE
  13
  14 : hat-name ( insn -- word )
  15     name>> "##" ?head drop "^^" prepend create-word-in ;
  16
  17 : hat-quot ( insn -- quot )
  18     [
  19         "insn-slots" word-prop [ ] [
  20             type>> {
  21                 { def [ [ next-vreg dup ] ] }
  22                 { temp [ [ next-vreg ] ] }
  23                 [ drop [ ] ]
  24             } case swap [ dip ] curry compose
  25         ] reduce
  26     ] keep insn-ctor-name "compiler.cfg.instructions" lookup-word suffix ;
  27
  28 : hat-effect ( insn -- effect )
  29     "insn-slots" word-prop
  30     [ type>> { def temp } member-eq? ] reject [ name>> ] map
  31     { "vreg" } <effect> ;
  32
  33 : define-hat ( insn -- )
  34     [ hat-name ] [ hat-quot ] [ hat-effect ] tri define-inline ;
  35
  36 PRIVATE>
  37
  38 insn-classes get [
  39     dup { [ insn-def-slots length 1 = ] [ name>> "##" head? ] } 1&&
  40     [ define-hat ] [ drop ] if
  41 ] each
  42
  43 >>
  44
  45 : ^^load-literal ( obj -- dst )
  46     dup fixnum? [ ^^load-integer ] [ ^^load-reference ] if ;
  47
  48 : ^^offset>slot ( slot -- vreg' )
  49     cell 4 = 2 3 ? ^^shl-imm ;
  50
  51 : ^^unbox-f ( src -- dst )
  52     drop 0 ^^load-literal ;
  53
  54 : ^^unbox-byte-array ( src -- dst )
  55     ^^tagged>integer byte-array-offset ^^add-imm ;
  56
  57 : ^^unbox-c-ptr ( src class -- dst )
  58     {
  59         { [ dup \ f class<= ] [ drop ^^unbox-f ] }
  60         { [ dup alien class<= ] [ drop ^^unbox-alien ] }
  61         { [ dup byte-array class<= ] [ drop ^^unbox-byte-array ] }
  62         [ drop ^^unbox-any-c-ptr ]
  63     } cond ;