/unmaintained/arm/intrinsics/intrinsics.factor

http://github.com/abeaumont/factor · Factor · 462 lines · 381 code · 51 blank · 30 comment · 5 complexity · 69e9005e3170cb78baff9a0447954750 MD5 · raw file

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