PageRenderTime 58ms CodeModel.GetById 2ms app.highlight 51ms RepoModel.GetById 1ms app.codeStats 0ms

/unmaintained/arm/intrinsics/intrinsics.factor

http://github.com/abeaumont/factor
Unknown | 462 lines | 411 code | 51 blank | 0 comment | 0 complexity | 69e9005e3170cb78baff9a0447954750 MD5 | raw file
  1! Copyright (C) 2007 Slava Pestov.
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: alien arrays cpu.architecture cpu.arm.assembler
  4cpu.arm.architecture cpu.arm.allot kernel kernel.private math
  5math.private namespaces sequences words
  6quotations byte-arrays hashtables.private hashtables generator
  7generator.registers generator.fixup sequences.private sbufs
  8sbufs.private vectors vectors.private system
  9classes.tuple.private layouts strings.private slots.private ;
 10IN: cpu.arm.intrinsics
 11
 12: %slot-literal-known-tag
 13    "val" operand
 14    "obj" operand
 15    "n" get cells
 16    "obj" get operand-tag - <+/-> ;
 17
 18: %slot-literal-any-tag
 19    "scratch" operand "obj" operand %untag
 20    "val" operand "scratch" operand "n" get cells <+> ;
 21
 22: %slot-any
 23    "scratch" operand "obj" operand %untag
 24    "n" operand dup 1 <LSR> MOV
 25    "val" operand "scratch" operand "n" operand <+> ;
 26
 27\ slot {
 28    ! Slot number is literal and the tag is known
 29    {
 30        [ %slot-literal-known-tag LDR ] H{
 31            { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
 32            { +scratch+ { { f "val" } } }
 33            { +output+ { "val" } }
 34        }
 35    }
 36    ! Slot number is literal
 37    {
 38        [ %slot-literal-any-tag LDR ] H{
 39            { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
 40            { +scratch+ { { f "scratch" } { f "val" } } }
 41            { +output+ { "val" } }
 42        }
 43    }
 44    ! Slot number in a register
 45    {
 46        [ %slot-any LDR ] H{
 47            { +input+ { { f "obj" } { f "n" } } }
 48            { +scratch+ { { f "val" } { f "scratch" } } }
 49            { +output+ { "val" } }
 50            { +clobber+ { "n" } }
 51        }
 52    }
 53} define-intrinsics
 54
 55: %write-barrier ( -- )
 56    "val" get operand-immediate? "obj" get fresh-object? or [
 57        "cards_offset" f R12 %alien-global
 58        "scratch" operand R12 "obj" operand card-bits <LSR> ADD
 59        "val" operand "scratch" operand 0 <+> LDRB
 60        "val" operand dup card-mark ORR
 61        "val" operand "scratch" operand 0 <+> STRB
 62    ] unless ;
 63
 64\ set-slot {
 65    ! Slot number is literal and tag is known
 66    {
 67        [ %slot-literal-known-tag STR %write-barrier ] H{
 68            { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
 69            { +scratch+ { { f "scratch" } } }
 70            { +clobber+ { "val" } }
 71        }
 72    }
 73    ! Slot number is literal
 74    {
 75        [ %slot-literal-any-tag STR %write-barrier ] H{
 76            { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
 77            { +scratch+ { { f "scratch" } } }
 78            { +clobber+ { "val" } }
 79        }
 80    }
 81    ! Slot number is in a register
 82    {
 83        [ %slot-any STR %write-barrier ] H{
 84            { +input+ { { f "val" } { f "obj" } { f "n" } } }
 85            { +scratch+ { { f "scratch" } } }
 86            { +clobber+ { "val" "n" } }
 87        }
 88    }
 89} define-intrinsics
 90
 91: fixnum-op ( op -- quot )
 92    [ "out" operand "x" operand "y" operand ] swap add ;
 93
 94: fixnum-register-op ( op -- pair )
 95    fixnum-op H{
 96        { +input+ { { f "x" } { f "y" } } }
 97        { +scratch+ { { f "out" } } }
 98        { +output+ { "out" } }
 99    } 2array ;
100
101: fixnum-value-op ( op -- pair )
102    fixnum-op H{
103        { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
104        { +scratch+ { { f "out" } } }
105        { +output+ { "out" } }
106    } 2array ;
107
108: define-fixnum-op ( word op -- )
109    [ fixnum-value-op ] keep fixnum-register-op 2array
110    define-intrinsics ;
111
112{
113    { fixnum+fast ADD }
114    { fixnum-fast SUB }
115    { fixnum-bitand AND }
116    { fixnum-bitor ORR }
117    { fixnum-bitxor EOR }
118} [
119    first2 define-fixnum-op
120] each
121
122\ fixnum-bitnot [
123    "x" operand dup MVN
124    "x" operand dup %untag
125] H{
126    { +input+ { { f "x" } } }
127    { +output+ { "x" } }
128} define-intrinsic
129
130\ fixnum*fast [
131    "out" operand "y" operand %untag-fixnum
132    "out" operand "x" operand "out" operand MUL
133] H{
134    { +input+ { { f "x" } { f "y" } } }
135    { +scratch+ { { f "out" } } }
136    { +output+ { "out" } }
137} define-intrinsic
138
139\ fixnum-shift [
140    "out" operand "x" operand "y" get neg <ASR> MOV
141    ! Mask off low bits
142    "out" operand dup %untag
143] H{
144    { +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
145    { +scratch+ { { f "out" } } }
146    { +output+ { "out" } }
147} define-intrinsic
148
149: %untag-fixnums ( seq -- )
150    [ dup %untag-fixnum ] unique-operands ;
151
152: overflow-check ( insn -- )
153    [
154        "end" define-label
155        [ "out" operand "x" operand "y" operand roll S execute ] keep
156        "end" get VC B
157        { "x" "y" } %untag-fixnums
158        "x" operand "x" operand "y" operand roll execute
159        "out" get "x" get %allot-bignum-signed-1
160        "end" resolve-label
161    ] with-scope ; inline
162
163: overflow-template ( word insn -- )
164    [ overflow-check ] curry H{
165        { +input+ { { f "x" } { f "y" } } }
166        { +scratch+ { { f "out" } } }
167        { +output+ { "out" } }
168        { +clobber+ { "x" "y" } }
169    } define-intrinsic ;
170
171\ fixnum+ \ ADD overflow-template
172\ fixnum- \ SUB overflow-template
173
174\ fixnum>bignum [
175    "x" operand dup %untag-fixnum
176    "out" get "x" get %allot-bignum-signed-1
177] H{
178    { +input+ { { f "x" } } }
179    { +scratch+ { { f "out" } } }
180    { +clobber+ { "x" } }
181    { +output+ { "out" } }
182} define-intrinsic
183
184\ bignum>fixnum [
185    "end" define-label
186    "x" operand dup %untag
187    "y" operand "x" operand cell <+> LDR
188     ! if the length is 1, its just the sign and nothing else,
189     ! so output 0
190    "y" operand 1 v>operand CMP
191    "y" operand 0 EQ MOV
192    "end" get EQ B
193    ! load the value
194    "y" operand "x" operand 3 cells <+> LDR
195    ! load the sign
196    "x" operand "x" operand 2 cells <+> LDR
197    ! is the sign negative?
198    "x" operand 0 CMP
199    ! Negate the value
200    "y" operand "y" operand 0 NE RSB
201    "y" operand dup %tag-fixnum
202    "end" resolve-label
203] H{
204    { +input+ { { f "x" } } }
205    { +scratch+ { { f "y" } } }
206    { +clobber+ { "x" } }
207    { +output+ { "y" } }
208} define-intrinsic
209
210: fixnum-jump ( op -- quo )
211    [ "x" operand "y" operand CMP ] swap
212    1quotation [ B ] 3append ;
213
214: fixnum-register-jump ( op -- pair )
215   fixnum-jump { { f "x" } { f "y" } } 2array ;
216
217: fixnum-value-jump ( op -- pair )
218    fixnum-jump { { f "x" } { [ small-tagged? ] "y" } } 2array ;
219
220: define-fixnum-jump ( word op -- )
221    [ fixnum-value-jump ] keep fixnum-register-jump
222    2array define-if-intrinsics ;
223
224{
225    { fixnum< LT }
226    { fixnum<= LE }
227    { fixnum> GT }
228    { fixnum>= GE }
229    { eq? EQ }
230} [
231    first2 define-fixnum-jump
232] each
233
234\ tag [
235    "out" operand "in" operand tag-mask get AND
236    "out" operand dup %tag-fixnum
237] H{
238    { +input+ { { f "in" } } }
239    { +scratch+ { { f "out" } } }
240    { +output+ { "out" } }
241} define-intrinsic
242
243\ type [
244    ! Get the tag
245    "out" operand "obj" operand tag-mask get AND
246    ! Compare with object tag number (3).
247    "out" operand object tag-number CMP
248    ! Tag the tag if it is not equal to 3
249    "out" operand dup NE %tag-fixnum
250    ! Load the object header if tag is equal to 3
251    "out" operand "obj" operand object tag-number <-> EQ LDR
252] H{
253    { +input+ { { f "obj" } } }
254    { +scratch+ { { f "out" } } }
255    { +output+ { "out" } }
256} define-intrinsic
257
258\ class-hash [
259    "end" define-label
260    ! Get the tag
261    "out" operand "obj" operand tag-mask get AND
262    ! Compare with tuple tag number (2).
263    "out" operand tuple tag-number CMP
264    "out" operand "obj" operand tuple-class-offset <+/-> EQ LDR
265    "out" operand dup class-hash-offset <+/-> EQ LDR
266    "end" get EQ B
267    ! Compare with object tag number (3).
268    "out" operand object tag-number CMP
269    "out" operand "obj" operand object tag-number <-> EQ LDR
270    ! Tag the tag
271    "out" operand dup NE %tag-fixnum
272    "end" resolve-label
273] H{
274    { +input+ { { f "obj" } } }
275    { +scratch+ { { f "out" } } }
276    { +output+ { "out" } }
277} define-intrinsic
278
279: userenv ( reg -- )
280    #! Load the userenv pointer in a register.
281    "userenv" f rot compile-dlsym ;
282
283\ getenv [
284    "n" operand dup 1 <ASR> MOV
285    "x" operand userenv
286    "x" operand "x" operand "n" operand <+> LDR
287] H{
288    { +input+ { { f "n" } } }
289    { +scratch+ { { f "x" } } }
290    { +output+ { "x" } }
291    { +clobber+ { "n" } }
292} define-intrinsic
293
294\ setenv [
295    "n" operand dup 1 <ASR> MOV
296    "x" operand userenv
297    "val" operand "x" operand "n" operand <+> STR
298] H{
299    { +input+ { { f "val" } { f "n" } } }
300    { +scratch+ { { f "x" } } }
301    { +clobber+ { "n" } }
302} define-intrinsic
303
304: %set-slot R11 swap cells <+> STR ;
305
306: %store-length
307    R12 "n" operand MOV
308    R12 1 %set-slot ;
309
310: %fill-array swap 2 + %set-slot ;
311
312\ <tuple> [
313    tuple "n" get 2 + cells %allot
314    %store-length
315    ! Store class
316    "class" operand 2 %set-slot
317    ! Zero out the rest of the tuple
318    "initial" operand f v>operand MOV
319    "n" get 1- [ 1+ "initial" operand %fill-array ] each
320    "out" get tuple %store-tagged
321] H{
322    { +input+ { { f "class" } { [ inline-array? ] "n" } } }
323    { +scratch+ { { f "out" } { f "initial" } } }
324    { +output+ { "out" } }
325} define-intrinsic
326
327\ <array> [
328    array "n" get 2 + cells %allot
329    %store-length
330    ! Store initial element
331    "n" get [ "initial" operand %fill-array ] each
332    "out" get object %store-tagged
333] H{
334    { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
335    { +scratch+ { { f "out" } } }
336    { +output+ { "out" } }
337} define-intrinsic
338
339\ <byte-array> [
340    byte-array "n" get 2 cells + %allot
341    %store-length
342    ! Store initial element
343    R12 0 MOV
344    "n" get cell align cell /i [ R12 %fill-array ] each
345    "out" get object %store-tagged
346] H{
347    { +input+ { { [ inline-array? ] "n" } } }
348    { +scratch+ { { f "out" } } }
349    { +output+ { "out" } }
350} define-intrinsic
351
352\ <ratio> [
353    ratio 3 cells %allot
354    "numerator" operand 1 %set-slot
355    "denominator" operand 2 %set-slot
356    "out" get ratio %store-tagged
357] H{
358    { +input+ { { f "numerator" } { f "denominator" } } }
359    { +scratch+ { { f "out" } } }
360    { +output+ { "out" } }
361} define-intrinsic
362
363\ <complex> [
364    complex 3 cells %allot
365    "real" operand 1 %set-slot
366    "imaginary" operand 2 %set-slot
367    ! Store tagged ptr in reg
368    "out" get complex %store-tagged
369] H{
370    { +input+ { { f "real" } { f "imaginary" } } }
371    { +scratch+ { { f "out" } } }
372    { +output+ { "out" } }
373} define-intrinsic
374
375\ <wrapper> [
376    wrapper 2 cells %allot
377    "obj" operand 1 %set-slot
378    ! Store tagged ptr in reg
379    "out" get object %store-tagged
380] H{
381    { +input+ { { f "obj" } } }
382    { +scratch+ { { f "out" } } }
383    { +output+ { "out" } }
384} define-intrinsic
385
386! Alien intrinsics
387: %alien-accessor ( quot -- )
388    "offset" operand dup %untag-fixnum
389    "offset" operand dup "alien" operand ADD
390    "value" operand "offset" operand 0 <+> roll call ; inline
391
392: alien-integer-get-template
393    H{
394        { +input+ {
395            { unboxed-c-ptr "alien" c-ptr }
396            { f "offset" fixnum }
397        } }
398        { +scratch+ { { f "value" } } }
399        { +output+ { "value" } }
400        { +clobber+ { "offset" } }
401    } ;
402
403: %alien-integer-get ( quot -- )
404    %alien-accessor
405    "value" operand dup %tag-fixnum ; inline
406
407: alien-integer-set-template
408    H{
409        { +input+ {
410            { f "value" fixnum }
411            { unboxed-c-ptr "alien" c-ptr }
412            { f "offset" fixnum }
413        } }
414        { +clobber+ { "value" "offset" } }
415    } ;
416
417: %alien-integer-set ( quot -- )
418    "offset" get "value" get = [
419        "value" operand dup %untag-fixnum
420    ] unless
421    %alien-accessor ; inline
422
423: define-alien-integer-intrinsics ( word get-quot word set-quot -- )
424    [ %alien-integer-set ] curry
425    alien-integer-set-template
426    define-intrinsic
427    [ %alien-integer-get ] curry
428    alien-integer-get-template
429    define-intrinsic ;
430
431\ alien-unsigned-1 [ LDRB ]
432\ set-alien-unsigned-1 [ STRB ]
433define-alien-integer-intrinsics
434
435: alien-cell-template
436    H{
437        { +input+ {
438            { unboxed-c-ptr "alien" c-ptr }
439            { f "offset" fixnum }
440        } }
441        { +scratch+ { { unboxed-alien "value" } } }
442        { +output+ { "value" } }
443        { +clobber+ { "offset" } }
444    } ;
445
446\ alien-cell
447[ [ LDR ] %alien-accessor ]
448alien-cell-template define-intrinsic
449
450: set-alien-cell-template
451    H{
452        { +input+ {
453            { unboxed-c-ptr "value" pinned-c-ptr }
454            { unboxed-c-ptr "alien" c-ptr }
455            { f "offset" fixnum }
456        } }
457        { +clobber+ { "offset" } }
458    } ;
459
460\ set-alien-cell
461[ [ STR ] %alien-accessor ]
462set-alien-cell-template define-intrinsic