unmaintained: New home for misfit Factor vocabularies.

[factor-unmaintained.git] / arm / allot / allot.factor

diff --git a/arm/allot/allot.factor b/arm/allot/allot.factor
new file mode 100644 (file)
index 0000000..6949d3b
--- /dev/null
+++ b/arm/allot/allot.factor
@@ -0,0 +1,79 @@
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel cpu.architecture cpu.arm.assembler
+cpu.arm.architecture namespaces math sequences
+generator generator.registers generator.fixup system layouts
+alien ;
+IN: cpu.arm.allot
+
+: load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ;
+
+: %allot ( header size -- )
+    ! Store a pointer to 'size' bytes allocated from the
+    ! nursery in R11
+    8 align ! align the size
+    R12 load-zone-ptr ! nusery -> r12
+    R11 R12 cell <+> LDR ! nursery.here -> r11
+    R11 R11 pick ADD ! increment r11
+    R11 R12 cell <+> STR ! r11 -> nursery.here
+    R11 R11 rot SUB ! old value
+    R12 swap type-number tag-fixnum MOV ! compute header
+    R12 R11 0 <+> STR ! store header
+    ;
+    
+: %store-tagged ( reg tag -- )
+    >r dup fresh-object v>operand R11 r> tag-number ORR ;
+
+: %allot-bignum ( #digits -- )
+    ! 1 cell header, 1 cell length, 1 cell sign, + digits
+    ! length is the # of digits + sign
+    bignum over 3 + cells %allot
+    R12 swap 1+ v>operand MOV ! compute the length
+    R12 R11 cell <+> STR ! store the length
+    ;
+
+: %allot-bignum-signed-1 ( dst src -- )
+    ! on entry, reg is a 30-bit quantity sign-extended to
+    ! 32-bits.
+    ! exits with tagged ptr to bignum in reg.
+    [
+        "end" define-label
+        ! is it zero?
+        dup v>operand 0 CMP
+        0 >bignum pick EQ load-literal
+        "end" get EQ B
+        ! ! it is non-zero
+        1 %allot-bignum
+        ! is the fixnum negative?
+        dup v>operand 0 CMP
+        ! negative sign
+        R12 1 LT MOV
+        ! negate fixnum
+        dup v>operand dup 0 LT RSB
+        ! positive sign
+        R12 0 GE MOV
+        ! store sign
+        R12 R11 2 cells <+> STR
+        ! store the number
+        v>operand R11 3 cells <+> STR
+        ! tag the bignum, store it in reg
+        bignum %store-tagged
+        "end" resolve-label
+    ] with-scope ;
+
+M: arm-backend %box-alien ( dst src -- )
+    "end" define-label
+    dup v>operand 0 CMP
+    over v>operand f v>operand EQ MOV
+    "end" get EQ B
+    alien 4 cells %allot
+    ! Store offset
+    v>operand R11 3 cells <+> STR
+    R12 f v>operand MOV
+    ! Store expired slot
+    R12 R11 1 cells <+> STR
+    ! Store underlying-alien slot
+    R12 R11 2 cells <+> STR
+    ! Store tagged ptr in reg
+    object %store-tagged
+    "end" resolve-label ;