1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors classes.algebra classes.struct
4 compiler.cfg.builder.blocks compiler.cfg.comparisons
5 compiler.cfg.hats compiler.cfg.instructions compiler.cfg.stacks
6 compiler.constants compiler.tree.propagation.info
7 cpu.architecture kernel layouts math namespaces sequences vm ;
8 IN: compiler.cfg.intrinsics.misc
11 [ ^^tagged>integer tag-mask get ^^and-imm ] unary-op ;
14 node-input-infos first2 [ class>> fixnum class<= ] both?
15 [ [ cc= ^^compare-integer ] binary-op ] [ [ cc= ^^compare ] binary-op ] if ;
17 : emit-special-object ( block node -- block' )
18 [ node-input-infos first literal>> ] [
20 vm-special-object-offset ^^vm-field
22 ] [ emit-primitive ] ??if ;
24 : emit-set-special-object ( block node -- block' )
25 [ node-input-infos second literal>> ] [
27 [ ds-pop ] dip vm-special-object-offset ##set-vm-field,
28 ] [ emit-primitive ] ??if ;
30 : context-object-offset ( n -- n )
31 cells "context-objects" context offset-of + ;
33 : emit-context-object ( block node -- block' )
34 [ node-input-infos first literal>> ] [
35 "ctx" vm offset-of ^^vm-field
36 ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
37 ] [ emit-primitive ] ??if ;
39 : emit-identity-hashcode ( -- )
42 tag-mask get bitnot ^^load-integer ^^and
43 0 int-rep f ^^load-memory-imm
44 hashcode-shift ^^shr-imm
47 : emit-local-allot ( block node -- block' )
48 dup node-input-infos first2 [ literal>> ] bi@ 2dup [ integer? ] both?
49 [ ds-drop ds-drop f ^^local-allot ^^box-alien ds-push drop ]
50 [ 2drop emit-primitive ] if ;
52 : emit-cleanup-allot ( block node -- block' )
53 drop [ drop ##no-tco, ] emit-trivial-block ;