picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

commit 9a16ac99912c09b780b7ba5454aca2b36b139d23
parent c844ff963ff67d3d8ee39a762b0114d0f1fce321
Author: Alexander Burger <abu@software-lab.de>
Date:   Wed, 16 Feb 2011 11:48:21 +0100

More flexible stack limits
Diffstat:
Mersatz/picolisp.jar | 0
Mlib/tags | 74+++++++++++++++++++++++++++++++++++++-------------------------------------
Msrc64/err.l | 14+++++++-------
Msrc64/flow.l | 15++++++++++++++-
Msrc64/gc.l | 5++++-
Msrc64/main.l | 7++-----
Msrc64/version.l | 4++--
7 files changed, 66 insertions(+), 53 deletions(-)

diff --git a/ersatz/picolisp.jar b/ersatz/picolisp.jar Binary files differ. diff --git a/lib/tags b/lib/tags @@ -1,5 +1,5 @@ -! (2841 . "@src64/flow.l") -$ (2943 . "@src64/flow.l") +! (2854 . "@src64/flow.l") +$ (2956 . "@src64/flow.l") % (2570 . "@src64/big.l") & (2805 . "@src64/big.l") * (2389 . "@src64/big.l") @@ -25,16 +25,16 @@ $ (2943 . "@src64/flow.l") >> (2625 . "@src64/big.l") abs (2729 . "@src64/big.l") accept (139 . "@src64/net.l") -adr (606 . "@src64/main.l") +adr (603 . "@src64/main.l") alarm (480 . "@src64/main.l") all (772 . "@src64/sym.l") and (1621 . "@src64/flow.l") any (3879 . "@src64/io.l") append (1338 . "@src64/subr.l") apply (713 . "@src64/apply.l") -arg (2267 . "@src64/main.l") -args (2243 . "@src64/main.l") -argv (2888 . "@src64/main.l") +arg (2264 . "@src64/main.l") +args (2240 . "@src64/main.l") +argv (2885 . "@src64/main.l") as (146 . "@src64/flow.l") asoq (3001 . "@src64/subr.l") assoc (2966 . "@src64/subr.l") @@ -46,7 +46,7 @@ bool (1721 . "@src64/flow.l") box (822 . "@src64/flow.l") box? (999 . "@src64/sym.l") by (1669 . "@src64/apply.l") -bye (3422 . "@src64/flow.l") +bye (3435 . "@src64/flow.l") caaaar (271 . "@src64/subr.l") caaadr (288 . "@src64/subr.l") caaar (99 . "@src64/subr.l") @@ -61,11 +61,11 @@ caddar (409 . "@src64/subr.l") cadddr (435 . "@src64/subr.l") caddr (156 . "@src64/subr.l") cadr (45 . "@src64/subr.l") -call (3074 . "@src64/flow.l") +call (3087 . "@src64/flow.l") car (5 . "@src64/subr.l") case (1962 . "@src64/flow.l") catch (2462 . "@src64/flow.l") -cd (2643 . "@src64/main.l") +cd (2640 . "@src64/main.l") cdaaar (464 . "@src64/subr.l") cdaadr (487 . "@src64/subr.l") cdaar (179 . "@src64/subr.l") @@ -88,7 +88,7 @@ circ (816 . "@src64/subr.l") circ? (2398 . "@src64/subr.l") clip (1795 . "@src64/subr.l") close (4267 . "@src64/io.l") -cmd (2870 . "@src64/main.l") +cmd (2867 . "@src64/main.l") cnt (1413 . "@src64/apply.l") co (2544 . "@src64/flow.l") commit (1496 . "@src64/db.l") @@ -99,9 +99,9 @@ connect (201 . "@src64/net.l") cons (747 . "@src64/subr.l") copy (1225 . "@src64/subr.l") ctl (4207 . "@src64/io.l") -ctty (2668 . "@src64/main.l") +ctty (2665 . "@src64/main.l") cut (1797 . "@src64/sym.l") -date (2382 . "@src64/main.l") +date (2379 . "@src64/main.l") dbck (2105 . "@src64/db.l") de (531 . "@src64/flow.l") dec (2323 . "@src64/big.l") @@ -111,15 +111,15 @@ del (1852 . "@src64/sym.l") delete (1401 . "@src64/subr.l") delq (1452 . "@src64/subr.l") diff (2585 . "@src64/subr.l") -dir (2801 . "@src64/main.l") +dir (2798 . "@src64/main.l") dm (543 . "@src64/flow.l") do (2136 . "@src64/flow.l") -e (2904 . "@src64/flow.l") +e (2917 . "@src64/flow.l") echo (4298 . "@src64/io.l") -env (618 . "@src64/main.l") +env (615 . "@src64/main.l") eof (3438 . "@src64/io.l") eol (3429 . "@src64/io.l") -errno (1378 . "@src64/main.l") +errno (1375 . "@src64/main.l") eval (182 . "@src64/flow.l") ext (5028 . "@src64/io.l") ext? (1034 . "@src64/sym.l") @@ -127,7 +127,7 @@ extern (900 . "@src64/sym.l") extra (1263 . "@src64/flow.l") extract (1218 . "@src64/apply.l") fifo (1963 . "@src64/sym.l") -file (2748 . "@src64/main.l") +file (2745 . "@src64/main.l") fill (3236 . "@src64/subr.l") filter (1161 . "@src64/apply.l") fin (2029 . "@src64/subr.l") @@ -139,13 +139,13 @@ flip (1695 . "@src64/subr.l") flush (5003 . "@src64/io.l") fold (3343 . "@src64/sym.l") for (2225 . "@src64/flow.l") -fork (3248 . "@src64/flow.l") +fork (3261 . "@src64/flow.l") format (2089 . "@src64/big.l") free (2047 . "@src64/db.l") from (3457 . "@src64/io.l") full (1075 . "@src64/subr.l") fun? (734 . "@src64/sym.l") -gc (429 . "@src64/gc.l") +gc (432 . "@src64/gc.l") ge0 (2705 . "@src64/big.l") get (2750 . "@src64/sym.l") getd (742 . "@src64/sym.l") @@ -164,14 +164,14 @@ ifn (1862 . "@src64/flow.l") in (4103 . "@src64/io.l") inc (2256 . "@src64/big.l") index (2633 . "@src64/subr.l") -info (2705 . "@src64/main.l") +info (2702 . "@src64/main.l") intern (875 . "@src64/sym.l") -ipid (3193 . "@src64/flow.l") +ipid (3206 . "@src64/flow.l") isa (959 . "@src64/flow.l") job (1426 . "@src64/flow.l") journal (970 . "@src64/db.l") key (3290 . "@src64/io.l") -kill (3225 . "@src64/flow.l") +kill (3238 . "@src64/flow.l") last (2040 . "@src64/subr.l") le0 (2691 . "@src64/big.l") length (2737 . "@src64/subr.l") @@ -181,7 +181,7 @@ lieu (1156 . "@src64/db.l") line (3613 . "@src64/io.l") lines (3766 . "@src64/io.l") link (1172 . "@src64/subr.l") -lisp (1945 . "@src64/main.l") +lisp (1942 . "@src64/main.l") list (887 . "@src64/subr.l") listen (151 . "@src64/net.l") lit (157 . "@src64/flow.l") @@ -220,10 +220,10 @@ n== (2083 . "@src64/subr.l") nT (2194 . "@src64/subr.l") name (499 . "@src64/sym.l") nand (1656 . "@src64/flow.l") -native (1386 . "@src64/main.l") +native (1383 . "@src64/main.l") need (919 . "@src64/subr.l") new (833 . "@src64/flow.l") -next (2250 . "@src64/main.l") +next (2247 . "@src64/main.l") nil (1739 . "@src64/flow.l") nond (1939 . "@src64/flow.l") nor (1677 . "@src64/flow.l") @@ -236,8 +236,8 @@ on (1583 . "@src64/sym.l") onOff (1613 . "@src64/sym.l") one (1646 . "@src64/sym.l") open (4229 . "@src64/io.l") -opid (3209 . "@src64/flow.l") -opt (2991 . "@src64/main.l") +opid (3222 . "@src64/flow.l") +opt (2988 . "@src64/main.l") or (1637 . "@src64/flow.l") out (4123 . "@src64/io.l") pack (1144 . "@src64/sym.l") @@ -270,9 +270,9 @@ push (1688 . "@src64/sym.l") push1 (1724 . "@src64/sym.l") put (2698 . "@src64/sym.l") putl (2950 . "@src64/sym.l") -pwd (2632 . "@src64/main.l") +pwd (2629 . "@src64/main.l") queue (1920 . "@src64/sym.l") -quit (1095 . "@src64/main.l") +quit (1092 . "@src64/main.l") quote (141 . "@src64/flow.l") rand (2973 . "@src64/big.l") range (997 . "@src64/subr.l") @@ -281,7 +281,7 @@ raw (458 . "@src64/main.l") rd (5045 . "@src64/io.l") read (2573 . "@src64/io.l") replace (1499 . "@src64/subr.l") -rest (2296 . "@src64/main.l") +rest (2293 . "@src64/main.l") reverse (1674 . "@src64/subr.l") rewind (5011 . "@src64/io.l") rollback (1890 . "@src64/db.l") @@ -314,15 +314,15 @@ super (1218 . "@src64/flow.l") sym (3919 . "@src64/io.l") sym? (2430 . "@src64/subr.l") sync (3102 . "@src64/io.l") -sys (3045 . "@src64/flow.l") +sys (3058 . "@src64/flow.l") t (1748 . "@src64/flow.l") tail (1907 . "@src64/subr.l") tell (3174 . "@src64/io.l") text (1272 . "@src64/sym.l") throw (2488 . "@src64/flow.l") -tick (3161 . "@src64/flow.l") +tick (3174 . "@src64/flow.l") till (3524 . "@src64/io.l") -time (2515 . "@src64/main.l") +time (2512 . "@src64/main.l") touch (1049 . "@src64/sym.l") trim (1755 . "@src64/subr.l") try (1172 . "@src64/flow.l") @@ -331,13 +331,13 @@ udp (268 . "@src64/net.l") unify (3931 . "@src64/subr.l") unless (1898 . "@src64/flow.l") until (2082 . "@src64/flow.l") -up (709 . "@src64/main.l") +up (706 . "@src64/main.l") upp? (3230 . "@src64/sym.l") uppc (3294 . "@src64/sym.l") use (1570 . "@src64/flow.l") -usec (2620 . "@src64/main.l") +usec (2617 . "@src64/main.l") val (1463 . "@src64/sym.l") -version (3005 . "@src64/main.l") +version (3002 . "@src64/main.l") wait (3064 . "@src64/io.l") when (1881 . "@src64/flow.l") while (2058 . "@src64/flow.l") @@ -347,7 +347,7 @@ wr (5128 . "@src64/io.l") xchg (1538 . "@src64/sym.l") xor (1698 . "@src64/flow.l") x| (2885 . "@src64/big.l") -yield (2699 . "@src64/flow.l") +yield (2712 . "@src64/flow.l") yoke (1196 . "@src64/subr.l") zap (1063 . "@src64/sym.l") zero (1631 . "@src64/sym.l") diff --git a/src64/err.l b/src64/err.l @@ -1,4 +1,4 @@ -# 12oct10abu +# 16feb11abu # (c) Software Lab. Alexander Burger # Debug print routine @@ -159,9 +159,7 @@ ld (EnvTrace) 0 ld L 0 # Init link register ld S (Stack0) # stack pointer - lea A (S 4096) # and stack limit - sub A (StkSize) - ld (StkLimit) A + ld (StkLimit) 0 # Clear stack limit ld (Stacks) 0 # Free all stack segments jmp restart # Restart interpreter : ErrTok asciz "!? " @@ -261,8 +259,10 @@ while ne # No add A A loop - not A # Clear in segment bitmask - and (Stacks) A + xor (Stacks) A # Clear in segment bitmask + if z # Last coroutine? + ld (StkLimit) 0 # Yes: Clear stack limit + end ld Z (Z) # Next coroutine loop load (Env) (EnvEnd) (X III) # Restore environment @@ -390,7 +390,7 @@ ld E 0 (code 'stkErrEX) ld Y StkErr - ld (StkLimit) 0 # Temporarily without stack limit + ld (StkLimit) 0 # Reset stack limit jmp errEXYZ : StkErr asciz "Stack overflow" diff --git a/src64/flow.l b/src64/flow.l @@ -1,4 +1,4 @@ -# 27jan11abu +# 16feb11abu # (c) Software Lab. Alexander Burger (code 'redefMsgEC) @@ -2633,6 +2633,12 @@ ld Y (Stack0) # Find unused stack segment ld Z 1 # New mask ld C (Stacks) # Segment bitmask + null C # Starting first coroutine? + if z # Yes + lea A ((Stack0) 4096) # Set stack limit + sub A (StkSize) + ld (StkLimit) A + end do sub Y (StkSize) # Next segment test C Z # Free? @@ -2662,6 +2668,10 @@ load (EnvCo) (EnvMid) (S III) # Restore environment pop (EnvCo7) # Restore coroutine link pop (StkLimit) # 'lim' + null (Stacks) # Stopped last coroutine? + if z # Yes + ld (StkLimit) 0 # Yes: Clear stack limit + end add S (pack I "+(EnvMid-EnvCo)") # Clean up pop L pop Z @@ -2682,6 +2692,9 @@ ldz E Nil if nz # No xor (Stacks) A # Clear in segment bitmask + if z # Stopped last coroutine? + ld (StkLimit) 0 # Yes: Clear stack limit + end ld E TSym # Return T end pop X diff --git a/src64/gc.l b/src64/gc.l @@ -1,4 +1,4 @@ -# 12oct10abu +# 16feb11abu # (c) Software Lab. Alexander Burger # Mark data @@ -324,6 +324,9 @@ test ((Y -I)) 1 # 'tag' symbol gone? if nz # Yes xor (Stacks) A # Clear in segment bitmask + if z # Last coroutine? + ld (StkLimit) 0 # Yes: Clear stack limit + end else null (Y -II) # Active? if nz # No diff --git a/src64/main.l b/src64/main.l @@ -1,4 +1,4 @@ -# 25jan11abu +# 16feb11abu # (c) Software Lab. Alexander Burger ### Global return labels ### @@ -82,7 +82,7 @@ or A CNT ld (Pid) A ld (Stack0) S # Save top level stack pointer - lea (StkLimit) (S (- 4096 STACK)) # Set stack limit + ld (StkLimit) 0 # Initially without stack limit ld L 0 # Init link register call heapAlloc # Allocate initial heap ld E Nil # Init internal symbols @@ -573,9 +573,6 @@ call evCntEX_FE shl E 20 # [MB] ld (StkSize) E # Set new stack size - lea A ((Stack0) 4096) # and stack limit - sub A E - ld (StkLimit) A shr E 16 # Make short number [MB] or E CNT pop X diff --git a/src64/version.l b/src64/version.l @@ -1,6 +1,6 @@ -# 06feb11abu +# 16feb11abu # (c) Software Lab. Alexander Burger -(de *Version 3 0 5 13) +(de *Version 3 0 5 14) # vi:et:ts=3:sw=3