1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
(defpackage dawg.double-array.node-allocator
(:use :common-lisp :dawg.global)
(:export make
allocate))
(in-package :dawg.double-array.node-allocator)
;;;;;;;;;;;;;;;
;;; declamation
(declaim #.*fastest*
(inline get-next can-allocate?))
;;;;;;;;;;;;
;;; constant
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +BUFFER_SIZE+ 89120))
;;;;;;;;;;;;;;;;;;
;;; node-allocator
(defstruct node-allocator
(head #x100 :type array-index)
(bits #* :type (simple-bit-vector #.+BUFFER_SIZE+))
(nexts #() :type (simple-array fixnum (#.+BUFFER_SIZE+)))
(prevs #() :type (simple-array fixnum (#.+BUFFER_SIZE+)))
(offset 0 :type array-index))
;;;;;;;;;;;;;;;
;;; constructor
(defun make ()
(let ((bits (make-array +BUFFER_SIZE+ :element-type 'bit :initial-element 0))
(nexts (make-array +BUFFER_SIZE+ :element-type 'fixnum))
(prevs (make-array +BUFFER_SIZE+ :element-type 'fixnum)))
(loop FOR i FROM 0 BELOW +BUFFER_SIZE+
DO
(setf (aref nexts i) (1+ i)
(aref prevs i) (1- i)))
(make-node-allocator :nexts nexts :prevs prevs :bits bits)))
;;;;;;;;;;;;;;;;;;;;;;
;;; auxiliary function
(defun shift (alloca)
(with-slots (bits nexts prevs offset head) (the node-allocator alloca)
(let ((new-offset head))
(loop WHILE (< new-offset (+ offset (- +BUFFER_SIZE+ (* #x100 2))))
DO
(setf new-offset (aref nexts (- new-offset offset))))
(let* ((delta (- new-offset offset))
(use-len (- +BUFFER_SIZE+ delta)))
(shiftf (subseq bits 0 use-len) (subseq bits delta))
(fill bits 0 :start use-len)
(setf offset new-offset)
(shiftf (subseq nexts 0 use-len) (subseq nexts delta))
(shiftf (subseq prevs 0 use-len) (subseq prevs delta))
(loop FOR i FROM (+ offset use-len) BELOW (+ offset +BUFFER_SIZE+)
DO
(setf (aref nexts (- i offset)) (1+ i)
(aref prevs (- i offset)) (1- i)))
(setf head offset)
(loop WHILE (< head (+ offset #x100))
DO
(setf head (aref nexts (- head offset)))))))
alloca)
(defun ref (alloca index)
(declare (array-index index))
(with-slots (offset nexts) (the node-allocator alloca)
(if (<= (+ offset +BUFFER_SIZE+) index)
(ref (shift alloca) index)
(aref nexts (- index offset)))))
(defun bref (alloca index)
(declare (array-index index))
(with-slots (bits offset) (the node-allocator alloca)
(if (> offset index)
1
(if (<= (+ offset +BUFFER_SIZE+) index)
(bref (shift alloca) index)
(bit bits (- index offset))))))
(defun get-next (alloca index)
(ref alloca index))
(defun can-allocate? (alloca index arcs)
(declare (list arcs)
(array-index index))
(and (zerop (bref alloca index))
(every (lambda (arc)
(declare (octet arc))
(/= -1 (ref alloca (+ index arc))))
arcs)))
(defun allocate-impl (alloca index arcs)
(declare (array-index index))
(with-slots (bits head prevs nexts offset) (the node-allocator alloca)
(when (<= offset index)
(setf (bit bits (- index offset)) 1))
(loop WITH base = index
FOR arc OF-TYPE (mod #x100) IN arcs
FOR index OF-TYPE fixnum = (+ base arc)
DO
(when (<= offset index)
(ref alloca index)
(let ((prev (aref prevs (- index offset)))
(next (aref nexts (- index offset))))
(setf (aref prevs (- index offset)) -1
(aref nexts (- index offset)) -1)
(when (= head index)
(setf head next))
(when (<= offset prev)
(setf (aref nexts (- prev offset)) next))
(when (<= offset next)
(ref alloca next)
(setf (aref prevs (- next offset)) prev)))))))
;;;;;;;;;;;;;;;;;;;;;
;;; external function
(defun allocate (alloca arcs)
(with-slots (head) (the node-allocator alloca)
(loop WITH front OF-TYPE (mod #x100) = (car arcs)
FOR cur = (get-next alloca head) THEN (get-next alloca cur)
FOR base OF-TYPE fixnum = (- cur front)
UNTIL (and (plusp base) (can-allocate? alloca base (cdr arcs)))
FINALLY
(allocate-impl alloca base arcs)
(return base))))
|
