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 ;
13 : hat-name ( insn -- word )
14 name>> "##" ?head drop "^^" prepend create-in ;
16 : hat-quot ( insn -- quot )
18 "insn-slots" word-prop [ ] [
20 { def [ [ next-vreg dup ] ] }
21 { temp [ [ next-vreg ] ] }
23 } case swap [ dip ] curry compose
25 ] keep insn-ctor-name "compiler.cfg.instructions" lookup-word suffix ;
27 : hat-effect ( insn -- effect )
28 "insn-slots" word-prop
29 [ type>> { def temp } member-eq? ] reject [ name>> ] map
32 : define-hat ( insn -- )
33 [ hat-name ] [ hat-quot ] [ hat-effect ] tri define-inline ;
38 dup [ insn-def-slots length 1 = ] [ name>> "##" head? ] bi and
39 [ define-hat ] [ drop ] if
44 : ^^load-literal ( obj -- dst )
45 dup fixnum? [ ^^load-integer ] [ ^^load-reference ] if ;
47 : ^^offset>slot ( slot -- vreg' )
48 cell 4 = 2 3 ? ^^shl-imm ;
50 : ^^unbox-f ( src -- dst )
51 drop 0 ^^load-literal ;
53 : ^^unbox-byte-array ( src -- dst )
54 ^^tagged>integer byte-array-offset ^^add-imm ;
56 : ^^unbox-c-ptr ( src class -- dst )
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 ]