1 ! Copyright (C) 2006, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays generic kernel kernel.private math memory
4 namespaces make sequences layouts system hashtables classes
5 alien byte-arrays combinators words sets ;
10 SINGLETON: single-float-regs
11 SINGLETON: double-float-regs
12 UNION: float-regs single-float-regs double-float-regs ;
13 UNION: reg-class int-regs float-regs ;
15 ! A pseudo-register class for parameters spilled on the stack
16 SINGLETON: stack-params
18 ! Return values of this class go here
19 GENERIC: return-reg ( register-class -- reg )
21 ! Sequence of registers used for parameter passing in class
22 GENERIC: param-regs ( register-class -- regs )
24 GENERIC: param-reg ( n register-class -- reg )
26 M: object param-reg param-regs nth ;
28 ! Sequence mapping vreg-n to native assembler registers
29 GENERIC: vregs ( register-class -- regs )
31 ! Load a literal (immediate or indirect)
32 GENERIC# load-literal 1 ( obj vreg -- )
34 HOOK: load-indirect cpu ( obj reg -- )
36 HOOK: stack-frame cpu ( frame-size -- n )
38 : stack-frame* ( -- n )
39 \ stack-frame get stack-frame ;
41 ! Set up caller stack frame
42 HOOK: %prologue cpu ( n -- )
44 : %prologue-later ( -- ) \ %prologue-later , ;
46 ! Tear down stack frame
47 HOOK: %epilogue cpu ( n -- )
49 : %epilogue-later ( -- ) \ %epilogue-later , ;
51 ! Store word XT in stack frame
52 HOOK: %save-word-xt cpu ( -- )
54 ! Store dispatch branch XT in stack frame
55 HOOK: %save-dispatch-xt cpu ( -- )
57 M: object %save-dispatch-xt %save-word-xt ;
60 HOOK: %call cpu ( word -- )
62 ! Local jump for branches
63 HOOK: %jump-label cpu ( label -- )
65 ! Test if vreg is 'f' or not
66 HOOK: %jump-f cpu ( label -- )
68 HOOK: %dispatch cpu ( -- )
70 HOOK: %dispatch-label cpu ( word -- )
73 HOOK: %return cpu ( -- )
75 ! Change datastack height
76 HOOK: %inc-d cpu ( n -- )
78 ! Change callstack height
79 HOOK: %inc-r cpu ( n -- )
81 ! Load stack into vreg
82 HOOK: %peek cpu ( vreg loc -- )
85 HOOK: %replace cpu ( vreg loc -- )
87 ! Box and unbox floats
88 HOOK: %unbox-float cpu ( dst src -- )
89 HOOK: %box-float cpu ( dst src -- )
93 ! Is this integer small enough to appear in value template
95 HOOK: small-enough? cpu ( n -- ? )
97 ! Is this structure small enough to be returned in registers?
98 HOOK: struct-small-enough? cpu ( heap-size -- ? )
100 ! Do we pass explode value structs?
101 HOOK: value-structs? cpu ( -- ? )
103 ! If t, fp parameters are shadowed by dummy int parameters
104 HOOK: fp-shadows-int? cpu ( -- ? )
106 HOOK: %prepare-unbox cpu ( -- )
108 HOOK: %unbox cpu ( n reg-class func -- )
110 HOOK: %unbox-long-long cpu ( n func -- )
112 HOOK: %unbox-small-struct cpu ( c-type -- )
114 HOOK: %unbox-large-struct cpu ( n c-type -- )
116 HOOK: %box cpu ( n reg-class func -- )
118 HOOK: %box-long-long cpu ( n func -- )
120 HOOK: %prepare-box-struct cpu ( size -- )
122 HOOK: %box-small-struct cpu ( c-type -- )
124 HOOK: %box-large-struct cpu ( n c-type -- )
126 GENERIC: %save-param-reg ( stack reg reg-class -- )
128 GENERIC: %load-param-reg ( stack reg reg-class -- )
130 HOOK: %prepare-alien-invoke cpu ( -- )
132 HOOK: %prepare-var-args cpu ( -- )
134 M: object %prepare-var-args ;
136 HOOK: %alien-invoke cpu ( function library -- )
138 HOOK: %cleanup cpu ( alien-node -- )
140 HOOK: %alien-callback cpu ( quot -- )
142 HOOK: %callback-value cpu ( ctype -- )
144 ! Return to caller with stdcall unwinding (only for x86)
145 HOOK: %unwind cpu ( n -- )
147 HOOK: %prepare-alien-indirect cpu ( -- )
149 HOOK: %alien-indirect cpu ( -- )
151 M: stack-params param-reg drop ;
153 M: stack-params param-regs drop f ;
155 GENERIC: v>operand ( obj -- operand )
157 M: integer v>operand tag-fixnum ;
159 M: f v>operand drop \ f tag-number ;
161 M: object load-literal v>operand load-indirect ;
163 PREDICATE: small-slot < integer cells small-enough? ;
165 PREDICATE: small-tagged < integer v>operand small-enough? ;
167 : if-small-struct ( n size true false -- ? )
168 [ over not over struct-small-enough? and ] 2dip
169 [ [ nip ] prepose ] dip if ;
172 : %unbox-struct ( n c-type -- )
179 : %box-struct ( n c-type -- )
187 HOOK: %unbox-byte-array cpu ( dst src -- )
189 HOOK: %unbox-alien cpu ( dst src -- )
191 HOOK: %unbox-f cpu ( dst src -- )
193 HOOK: %unbox-any-c-ptr cpu ( dst src -- )
195 HOOK: %box-alien cpu ( dst src -- )
200 : operand ( var -- op ) get v>operand ; inline
202 : unique-operands ( operands quot -- )
203 >r [ operand ] map prune r> each ; inline