commit 0f2ea4dcd385766ad63ee6577dd78b2cc6c51158
parent af8814cbc7b52bcdf834c1de1bf01090cb429754
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Sun, 19 Feb 2023 12:20:54 -0500
text/ed: improve memory usage
Previously, every insert resulted in the line buffer being reallocated, even if
it was preceeded by a deletion of the same number of characters. It was simple
but wasteful.
Now, we track allocated sizes. We still reallocate each time this size grows,
but once we have, we never reallocate again unless we grow the line even more.
Diffstat:
7 files changed, 105 insertions(+), 61 deletions(-)
diff --git a/fs/doc/lib/str.txt b/fs/doc/lib/str.txt
@@ -49,6 +49,24 @@ zstrlen ( ztr -- len )
Search for the first occurrence of "str" in range "a u" and return its index.
Returns -1 if not found.
+sfind ( str list -- idx )
+ Find "str" in "list" and return its index, -1 if not found.
+
+slistiter ( idx list -- str )
+ Given a string list "list", iterate to its "idx" element and return the str.
+
+toword ( -- c )
+ Read stdin until next non WS and yield it.
+
+expectchar ( c -- )
+ Read stdin, discarding whitespaces and expect the next char to be "c"
+
+stringlist ( n "name" "..." -- )
+ Create a list of strings (same format as sfind above) with the specified
+ number of elements. Each element must be "quoted" with no space (unless you
+ want them in the string) in the quotes.
+ Example: 3 stringlist mylist "foo" "bar" "hello world!"
+
rtrimright ( n a u -- a u )
Trim "n" characters at the right of range "a u" and return the resulting
range.
@@ -56,12 +74,6 @@ rtrimright ( n a u -- a u )
rtrimleft ( n a u -- a u )
Trim "n" characters at the left of range "a u" and return the resulting range.
-sfind ( str list -- idx )
- Find "str" in "list" and return its index, -1 if not found.
-
-slistiter ( idx list -- str )
- Given a string list "list", iterate to its "idx" element and return the str.
-
rmatch ( c range -- f )
Given a list of character ranges, which is given in the form of a string of
character pairs, return whether the specified character is in one of the
@@ -76,14 +88,9 @@ A-Za-z? ( c -- f )
alnum? ( c -- f )
Returns whether "c" is a letter or digit.
-toword ( -- c )
- Read stdin until next non WS and yield it.
-
-expectchar ( c -- )
- Read stdin, discarding whitespaces and expect the next char to be "c"
+move- ( src dst u -- )
+ Like "move", but operates backwards. You'll want to use this when copying
+ overlapping memory area "forward" (dst > src).
-stringlist ( n "name" "..." -- )
- Create a list of strings (same format as sfind above) with the specified
- number of elements. Each element must be "quoted" with no space (unless you
- want them in the string) in the quotes.
-\ Example: 3 stringlist mylist "foo" "bar" "hello world!"
+rslide+ ( by a u -- )
+ Move range "a u" forward in memory by "by" bytes.
diff --git a/fs/doc/text/ed.txt b/fs/doc/text/ed.txt
@@ -39,19 +39,43 @@ Line numbers and character numbers are 0-indexed.
The Line structure describes a line in the Ed buffer. The line structure does
not include the LF character. This means that an empty line has a cnt of 0.
+We maintain a separate character count and allocated size. It's possible,
+through deletion, that these two numbers differ. When inserting or appending
+contents to the line, if we have enough space, we don't needlessly reallocate in
+the arena buffer.
+
Fields:
-cnt Number of characters in the line
ptr Pointer to the first character of the line
+cnt (2b) Number of characters in the line
+allocsz (2b) Bytes allocated at ptr
Methods:
:range ( self -- a u )
Return the range corresponding to this line
+: init ( a u line -- )
+ Initialize line fields to range "a u". "allocsz" is set to u.
+
:print ( self -- )
Call "rtype" with the line's range.
+:delchars ( idx n line -- )
+ Delete "n" characters starting at index "idx".
+
+:?realloc ( arena n line -- )
+ Verify whether "n" characters could be added to the line. If not, reallocate
+ a sufficiently big buffer in "arena" to accomodate those "n" new characters.
+
+:append ( a u line -- )
+ Assuming that there's enough space (aborts if not), append range "a u" at the
+ end of the line.
+
+:insert ( a u idx line -- )
+ Assuming that there's enough space (aborts if not), insert range "a u" in the
+ middle of the line at index "idx".
+
## Edbuf API
The Edbuf is mainly an Array of Line structures with various metadata attached
diff --git a/fs/lib/array.fs b/fs/lib/array.fs
@@ -1,8 +1,5 @@
?f<< /lib/malloc.fs
-
-: move- ( src dst u -- )
- rot> over - >r over + swap for ( a ) \ V1=delta
- 1- dup c@ over V1 + c! next drop rdrop ;
+?f<< /lib/str.fs
struct[ Array
sfield ptr
@@ -30,9 +27,9 @@ struct[ Array
rot> to+ cnt ( a ) ;
: :insert ( cnt idx self -- a ) >r \ V1=self
dup V1 _inbounds? if ( cnt idx )
- V1 :' >r dup V1 elemsz * V2 + ( cnt dst ) \ V2=src
- V1 _'end V2 - ( cnt dst u )
- V2 rot> move- ( cnt )
+ V1 :' >r dup V1 elemsz * ( cnt by ) \ V2=src
+ V1 _'end V2 - ( cnt by u )
+ V2 swap rslide+ ( cnt )
V1 to+ cnt r> rdrop ( a )
else drop r> :append then ;
: :delete ( cnt idx self -- ) >r \ V1=self
diff --git a/fs/lib/str.fs b/fs/lib/str.fs
@@ -19,10 +19,6 @@ create _buf STR_MAXSZ allot
dup V2 c@+ []= if ( a ) V1 - break then 1+ next drop -1 then
else drop -1 then ( idx ) 2rdrop ;
-: rtrimright ( n a u -- a u ) rot - max0 ;
-
-: rtrimleft ( n a u -- a u ) rot tuck - max0 rot> + swap ;
-
: sfind ( str list -- idx ) -1 rot> begin ( idx s a )
rot 1+ rot> ( idx s a )
2dup s= if ( found ) 2drop exit then
@@ -30,6 +26,16 @@ create _buf STR_MAXSZ allot
: slistiter ( idx list -- str ) swap for s) next ;
+: toword ( -- c ) begin stdin dup ws? while drop repeat ( c ) ;
+
+: expectchar ( c -- )
+ toword over = not if emit abort" expected" else drop then ;
+
+: stringlist create for '"' expectchar [compile] S" drop next 0 c, ;
+
+: rtrimright ( n a u -- a u ) rot - max0 ;
+: rtrimleft ( n a u -- a u ) rot tuck - max0 rot> + swap ;
+
: rmatch ( c range -- f )
>r 8b to@+ V1 >> ( len/2 ) for ( c )
dup 8b to@+ V1 8b to@+ V1 ( c c lo hi )
@@ -43,9 +49,8 @@ create _ 4 c, ," AZaz"
create _ 6 c, ," AZaz09"
: alnum? ( c -- f ) _ rmatch ;
-: toword ( -- c ) begin stdin dup ws? while drop repeat ( c ) ;
+: move- ( src dst u -- )
+ rot> over - >r over + swap for ( a ) \ V1=delta
+ 1- dup c@ over V1 + c! next drop rdrop ;
-: expectchar ( c -- )
- toword over = not if emit abort" expected" else drop then ;
-
-: stringlist create for '"' expectchar [compile] S" drop next 0 c, ;
+: rslide+ ( by a u -- ) rot> tuck + ( u src dst ) rot move- ;
diff --git a/fs/tests/text/ed.fs b/fs/tests/text/ed.fs
@@ -32,6 +32,8 @@ eol capture I abc
S" tests that process textabc\n ^\n3 / 15" #s=
capture o appended line
S" appended line\n ^\n4 / 16" #s=
+4 c- capture I hello
+S" appended helloline\n ^\n4 / 16" #s=
capture O inserted line
S" inserted line\n ^\n4 / 17" #s=
0 g 1 capture dl
diff --git a/fs/text/ed.fs b/fs/text/ed.fs
@@ -9,10 +9,15 @@
: joinpos ( lpos cpos -- pos ) $ffff min swap 16 lshift or ;
struct[ Line
- sfield cnt
sfield ptr
+ sfieldw cnt
+ sfieldw allocsz
+
+ : _fits? ( n line -- ) tuck cnt + swap allocsz <= ;
+ : _#fits _fits? not if abort" not enough Line space" then ;
+ : _'end bi ptr | cnt + ;
: :range ( line -- a u ) bi ptr | cnt ;
- : :range! ( a u line -- ) tuck to cnt to ptr ;
+ : :init ( a u line -- ) tuck 2dup to cnt to allocsz to ptr ;
: :print ( line -- ) :range rtype nl> ;
: :delchars ( idx n line -- ) >r \ V1=self
2dup + V1 cnt < if ( idx n )
@@ -20,6 +25,21 @@ struct[ Line
swap dup V1 :range + -^ ( n src dst u )
move ( n ) neg r> to+ cnt
else ( idx n ) drop r> to cnt then ;
+ : :?realloc ( arena n line -- )
+ 2dup _fits? if 2drop drop else >r ( arena n ) \ V1=line
+ V1 :range >r >r \ V2=old-u V3=old-a
+ V2 + dup V1 to allocsz swap Arena :allot ( dst )
+ r> over r> move ( dst ) r> to ptr then ;
+ : :append ( a u line -- ) >r ( a u ) \ V1=line
+ dup V1 _#fits V1 _'end over V1 to+ cnt ( src u dst )
+ swap move rdrop ;
+ : _range+ ( n line -- a u ) dup >r :range rot r> to+ cnt ;
+ : :insert ( a u idx line -- )
+ 2dup cnt >= if nip :append else >r ( a u idx ) \ V1=line
+ over V1 _#fits ( a u idx )
+ 2dup V1 :range rtrimleft ( a u idx u ra ru )
+ rslide+ ( a u idx ) over V1 to+ cnt
+ r> ptr + ( src u dst ) swap move then ;
]struct
extends IO struct[ Edbuf
@@ -66,16 +86,10 @@ extends IO struct[ Edbuf
: :appendline ( self -- ) bi :lpos 1+ | _newline ;
: :insertline ( self -- ) bi :lpos | _newline ;
- : _ ( pos self -- cpos line ) dip bi cpos | lpos | :line ;
- : _rangebefore ( pos self -- a u ) _ Line ptr swap cpos ;
- : _rangeafter ( pos self -- a u ) _ Line :range rot cpos rot> rtrimleft ;
- : _writeline ( a u self -- ) dup >r :sel >r dup >r \ V1=self V2=sel V3=u
- V2 Line cnt over + V1 buf Arena :ensure ( a u new-a )
- V1 pos V1 _rangebefore ?dup if V1 buf Arena :move then drop ( a u new-a )
- rot> V1 buf Arena :move drop ( new-a )
- V1 pos V1 _rangeafter ?dup if V1 buf Arena :move then drop ( new-a )
- V2 to Line ptr ( )
- r> dup r> to+ Line cnt r> to+ pos ;
+ : _writeline ( a u self -- ) dup >r :sel >r ( a u ) \ V1=self V2=line
+ V1 buf over V2 Line :?realloc ( a u )
+ tuck V1 :cpos V2 Line :insert ( u )
+ rdrop r> to+ pos ;
: _writebuf ( a n self -- written-n ) >r \ V1=self
2dup LF rot> [c]? ( a u idx ) dup 0< if
@@ -92,22 +106,17 @@ extends IO struct[ Edbuf
: :dellines ( n self -- ) tuck bi :lpos | lines Array :delete _ensureline ;
: :empty ( self -- ) 0 over lines to Array cnt _ensureline ;
: :delchars ( n self -- ) bi :sel | :cpos rot> Line :delchars ;
- : _joinranges ( a1 u1 a2 u2 self -- a u ) buf >r \ V1=buf
- ?dup if ( a1 u1 a2 u2 )
- rot ?dup if ( a1 a2 u2 u1 )
- 2dup + dup >r V1 Arena :ensure >r \ V2=res-u V3=res-a
- dip rot | ( a2 u2 a1 u1 )
- V1 Arena :move drop V1 Arena :move drop ( ) r> r>
- else rot drop ( a2 u2 ) then
- else drop ( a1 u1 ) then rdrop ;
+ : _rangeafter ( pos self -- a u )
+ dip bi cpos | lpos | :line Line :range rot cpos rot> rtrimleft ;
: :delto ( pos self -- ) >r \ V1=self
- V1 pos ?swap ( lo hi ) swap V1 to pos ( hi )
- dup V1 pos V1 _rangebefore rot V1 _rangeafter ( hi loa lou hia hiu )
- V1 _joinranges ( hi a u ) ?dup if
- V1 :sel Line :range! ( hi )
- lpos V1 :lpos 1+ ( linehi linelo )
- else drop lpos V1 :lpos then ( linehi linelo )
- tuck - 1+ swap V1 lines Array :delete r> _ensureline ;
+ V1 pos ?swap ( lo hi ) swap V1 to pos ( hipos )
+ dup lpos V1 :lpos = if V1 pos - V1 :delchars else ( hi )
+ \ We join the two "leftovers" in :sel and then delete the rest.
+ V1 :cpos V1 :sel to Line cnt ( hi )
+ dup V1 _rangeafter V1 buf over V1 :sel Line :?realloc ( hi a u )
+ V1 :sel Line :append ( hi )
+ lpos V1 :lpos V1 :sel Line cnt bool + ( linehi linelo )
+ tuck - 1+ swap V1 lines Array :delete V1 _ensureline then rdrop ;
: :new ( -- edbuf )
Arena :new Line SZ $200 Array :new here ( arena lines edbuf ) >r
diff --git a/posix/vm.c b/posix/vm.c
@@ -577,7 +577,7 @@ static void MOVE() { // op: 4c
dword dst = ppop();
dword src = ppop();
if (memchk(dst+u) && memchk(src+u)) {
- if ((dst >= src) && (dst < src+u)) {
+ if (u && (dst >= src) && (dst < src+u)) {
fprintf(stderr, "overlapping MOVE! %x %x %d\n", src, dst, u);
ABORT_();
return;
