This is a cross-referenced version of malloc.plan, to download the unmodified
source try malloc.plan.
#PROGRAM /GFMALLOC(15AM,22AM,DBM,EBM)
#PAGE
#INCLUDE STACK(/DEFS)
# Memory layout:
# Arena consists of list of blocks, each block starts and
# ends with a length field. Length fields are -ve if
# block is allocated. (Alternatively we could use the
# top two bits of the address as flags).
# Free blocks are also linked on a free list to speed
# allocation. (We could get away without the free list,
# but then allocation would slow down as the number of
# allocated blocks increased).
# We could sort the free list in order to do best (or
# worst) fit allocation, but most authorities seem to
# think that is a bad idea.
# We will use "next fit" allocation - keep a pointer to
# the next free block to start allocation from.
# The free block at the top of memory is not on the free
# list, it is called the "wilderness block" and only
# allocated from if no free block can be found.
# We might even consider returning memory from the
# wilderness block to the OS.
# Free list is double linked list:
#DEFINE LKNEXT=1
#DEFINE LKPREV=LKNEXT+1
#DEFINE SLOP=512 [ amount of extra memory to request
# #ELASTIC block to hold arena
# We'd like to initialise this at compile time, but that
# doesn't seem to work.
# See routine INIT for initialisation
#ELASTIC COMMON/ARENA/
# Fake block below lowest allocated block. Because the
# length is zero it will never be allocated, so the free
# list will never be empty. Also because it's length is
# zero we will never merge with it.
# (The bottom sentinel is never used. We might be able
# to zap it if PLAN/the consolidator let us initialise
# the freelist to "/BOTTOM-1". But if we keep it it
# could simplify diagnostics?)
BOTTOM(4)
# The initial wilderness, two words long. For a future
# optimisation we will preallocate some space.
# (The top sentinel of the wilderness is a minor
# optimisation for block merges, we don't care about
# its value)
WILD(2)
# LOWER storage used by our malloc package
#LOWER COMMON/MALLOCPRIV/
FREELIST /BOTTOM [ Free list
WILDERNESS /WILD [ Wilderness
#PROGRAM
# Insert block onto free list
# macro putblk (blok) {
# prev = *(free + PREV)
# *(prev + NEXT) = blok;
# *(blok + PREV) = prev;
# *(free + PREV) = blok;
# *(blok + NEXT) = free;
# }
# Args are:
# X - block to free
# #1,2 - scratch index registers
# preserves X and all nonscratch registers
#MACRO
PUT B F,P
LDX F FREELIST
LDX P LKPREV(F) [ prev = *(free + PREV)
STO B LKNEXT(P) [ *(prev + next) = blok
STO P LKPREV(B) [ *(blok + PREV) = prev
STO B LKPREV(F) [ *(free + PREV) = blok
STO F LKNEXT(B) [ *(blok + NEXT) = free
# Since FREELIST is in #LOWER we can use SMO
# instead of putting FREELIST in an index register.
# That allows us to use only 1 scratch register
# Args are:
# X - block to free
# #1 - scratch index register
# preserves X and all nonscratch registers
#MACRO
PUT2 B P
SMO FREELIST
LDX P LKPREV [ prev = *(free + PREV)
STO B LKNEXT(P) [ *(prev + next) = blok
STO P LKPREV(B) [ *(blok + PREV) = prev
LDX P FREELIST [ finished with prev, reuse reg
STO B LKPREV(P) [ *(free + PREV) = blok
STO P LKNEXT(B) [ *(blok + NEXT) = free
# Remove block from free list
# macro getblk (blok, next) {
# prev = *(blok + PREV);
# *(next + PREV) = prev;
# *(prev + NEXT) = next;
# free = next;
# }
# Args:
# X - block to remove from freelist
# #1 - next block
# #2 - scratch index register, may be same as X
# but note that if it is it will be trashed.
# preserves X and all nonscratch registers
#MACRO
GET B N,P
LDX P LKPREV(B) [ prev = *(blok + PREV)
STO P LKPREV(N) [ *(next + PREV) = prev
STO N LKNEXT(P) [ *(prev + NEXT) = next
STO N FREELIST [ free = next
# Args:
# X - block to remove from freelist - NOT PRESERVED
# #1 - scratch index reg
# preserves all other registers
#MACRO
GET2 B N
LDX N LKNEXT(B) [ next = *(blok + NEXT);
GET B N,B
# Mark a block as used.
#
# Args:
# X - address of block, must be in index reg
# #1 - length (in reg)
# destroys X
#MACRO
USED B L
NGS L 0(B) [ *blok = - len;
ADX B L [ *(blok + len
SBN B 1 [ - 1)
NGS L 0(B) [ = -len;
# Mark a block as available.
#
# Args:
# X - address of block, must be in index reg
# #1 - length (in reg)
# destroys X
#MACRO
AVAIL B L
STO L 0(B) [ *blok = len
ADX B L [ *(blok + len
SBN B 1 [ - 1)
STO L 0(B) [ = len
# SBRK(n) - Increase program size
#
# Args:
# X - Scratch register
# #1 - amount of memory to allocate
# #2 - goto here of ok
# #3 - goto here to retry
#MACRO
SBRK W L,J,R
LDX W L [ wlen = len + 2 + slop;
ADN W SLOP+2
ADX W WILDERNESS [ New top of store we want
GIVE W 4 [ Ask George politely
SBX W WILDERNESS [ work out new length of wilderness
SBN W 2 [ Is it big enough?
BXGE W L,J
# We should implement an option to let the caller
# handle this problem
SUSWT 2HCO
BRN R
# Check whether the wilderness is initialised
# Trashes X1 and X2
#MACRO
CHECK
LDX 1 WILDERNESS
LDX 1 0(1)
BNZ 1 *+2
CALL 1 INIT
#PROGRAM
# Allocate a block from the free list
# Uses FORTRAN calling conventions
# BLOCK = MALLOC (LEN)
# CALL 1 MALLOC [ call malloc linking via X1
# LDX 3 'LEN' [ load address of LEN into X3
# [ return value is in X6
# We also provide a non standard calling convention for
# internal use, GXMALLOC, enter with size wanted in X3
OBEY 0(1) [ get address of length var to X3
LDX 3 0(3) [ get length wanted to X4
ADN 1 1 [ skip arg on return
#CUE GXMALLOC
ALLOC LDX 4 3 [ move length to X4 so we can use X3
STO 1 7 [ save link in X7 to free up X1
CHECK
SBNC 4 2 [ is length less that 2?
BCC *+2 [ if not, that's ok
LDN 4 0 [ need at least 2 words in block
ADN 4 4 [ need two more words for sentinels
# Loop through free list looking for a block that's
# big enough
LDX 3 FREELIST [ base = freelist
LDX 5 4 [ get length to X5
SBN 5 1 [ one less, to simplify loop
# [ do {
LOOP LDX 2 LKNEXT(3) [ next = *(base + NEXT)
BXL 5 0(3),FOUND [ if (*base >= len) goto found
LDX 3 2 [ base = next
BXU 3 FREELIST,LOOP [ } until (base == free)
# Sad, we couln't find anything useful on the free list.
# Is the wilderness big enough?
NOFRE LDX 3 WILDERNESS [ base = wilderness;
LDX 5 0(3) [ wlen = *base;
SBN 5 2 [ wlen -= 2; # wilderness needs min 2 wds
BXGE 5 4,ENUF [ if (wlen >= len) don't need to grow
# No, we have to grow the wilderness.
GROW SBRK 5 4,ENUF,GROW [ Ask George for more memory
# Now we have enough space in the wilderness, carve off
# the part we want.
ENUF ADN 5 2 [ total length of wilderness
LDX 2 3 [ wilderness = base
ADX 2 4 [ + len
STO 2 WILDERNESS
SBX 5 4 [ wlen -= len
STO 5 0(2) [ *(wilderness) = wlen;
# [ don't bother saving top sentinel
BRN DONE
# We've found a block on the free list which looks to
# be big enough
FOUND GET 3 2,1 [ remove block in X3 from freelist
# If the block we found is big enough to split do it
LDX 5 0(3) [ blen = *base
SBX 5 4 [ blen -= len
SBNC 5 4 [ if (blen >= 4) {
BCS NSPLT
ADN 5 4 [ restore blen
LDX 2 3 [ next = base
ADX 2 4 [ + len
PUT2 2 1 [ put upper block on freelist
AVAIL 2 5 [ mark upper block available
BRN DONE
NSPLT LDX 4 0(3) [ allocate whole block
DONE LDX 6 3 [ move block addr into X6 for return
ADN 6 1 [ and hide length field from user
USED 3 4 [ mark block used
# And it's goodbye from him
BASE 2 [ a kindness to our users
EXIT 7 0
# Mark a block as free, coalescing with previous and next
# free blocks if we can.
# Uses FORTRAN calling convention:
# CALL FREE (BASE)
# CALL 1 FREE
# LDN 3 BASE
# We also provide a non-standard calling convetion
# for internal use,
# ... put block to free in X3
# CALL 1 GXFREE
#CUE GFFREE
OBEY 0(1) [ Get addr of callers var to X3
LDX 3 0(3) [ base = *arg;
ADN 1 1 [ skip over arg
#CUE GXFREE [ non-standard calling convention
FREE STO 1 7 [ Save link in X7 so we can use X1
BZE 3 BYE [ free(0) is a no-op
CHECK
SBN 3 1 [ --base; Point at length field
# Check that block is valid - length field must be
# negative and begin and end sentinels must be equal
LDX 4 0(3) [ len = *base; get lower sentinel
BPZ 4 FREE2 [ jif already free
LDX 1 3
SBX 1 4
SBN 1 1 [ point at top sentinel
BXU 4 0(1),BADB [ jump if sentinels unequal
NGX 4 4 [ convert sentinel to length
# Can we merge block with lower addressed block?
LDX 1 3 [ below = base
SBN 1 1 [ - 1
LDXC 5 0(1) [ blen = *below, set carry if allocated
BCS NODWN [ Can't merge if block below is allocated
BZE 5 NODWN [ Can't merge if block below is first block
# Merge block being freed with block below, which is
# already on the free list
LDX 3 1 [ base = below
SBX 3 5 [ base -= blen
ADN 3 1 [ base += 1
ADX 4 5 [ len += blen
BRN ABOVE [ go see if we can merge with block above
NODWN PUT 3 1,2 [ Add block in X3 to freelist
# Can we merge with next block above?
# X3 holds block, X4 length
ABOVE LDX 1 3
ADX 1 4 [ above = base + len
LDXC 5 0(1) [ alen = *above; set carry if allocated
BCS NOUP [ can't merge if block above allocated
# A merging we will go
# If block above is the wilderness block then this
# block becomes the wilderness block.
BXU 1 WILDERNESS,RMOVE
STO 3 WILDERNESS [ wilderness = base
# The wilderness block is not on the free list
# so remove ourselves from the free list
STO 3 1 [ above = base;
# Remove block above from the free list
# because we will merge it to the block we are freeing
# which we have already added to the free list
RMOVE GET2 1 2
# Merge the blocks
ADX 4 5 [ len += alen;
NOUP AVAIL 3 4 [ mark block as free
# It's goodnight from me
BYE BASE 2 [ make life easier for callers
EXIT 7 0
FREE2 SUSWT 2HF2 [ double free
BADB SUSWT 2HBB [ bad block
# Resize an allocated block, preserving contents
# Uses Fortran calling conventions
# I = RESIZE (J, LEN)
# CALL 1 RESIZE
# LDX 3 '/J'
# LDX 3 '/LEN'
# Return value in X6
#CUE GFRESIZE
RSIZE OBEY 1(1) [ get address of length
LDX 4 0(3) [ get length wanted to X4
ADN 4 2 [ add space for sentinels
OBEY 0(1) [ get address of var holding block
LDX 3 0(3) [ get block to be resized to X3
STO 1 7 [ save link to X7 so we can use X1
BZE 3 HARD [ Special case block==0
SBN 3 1 [ adjust to start of block
CHECK [ make sure initialised
NGX 0 0(3) [ len = -*blok; get current len
LDX 5 0 [ rlen = len - wanted; get shrink
SBX 5 4
BPZ 5 SHRNK
# Ok, we're growing, not shrinking
NGX 5 5 [ rlen = -rlen; amount to grow
LDX 6 3 [ if blok + len == wilderness
ADX 6 0
LDX 2 WILDERNESS
BXU 6 2,UPWDS
# Ok, we're merging with the wilderness. Is it
# big enough?
LDX 6 0(2) [ wlen = *wilderness;
SBX 6 5 [ wlen -= rlen
SBN 6 2 [ if (wlen < 2) {
BPZ 6 ENOW
# Grow the wilderness
AGAIN SBRK 6 4,ENOW,AGAIN [ Ask George for more memory
# Now we have enough space in the wilderness, carve off
# the part we want.
ENOW ADN 6 2 [ total length of wilderness
LDX 2 3 [ wilderness = base
ADX 2 4 [ + wanted
STO 2 WILDERNESS
STO 6 0(2) [ setup sentinels
LDX 0 4 [ get new block length in X0
BRN STLEN [ go setup block length
# Can we merge with the next block?
UPWDS LDX 2 3 [ next = blok
ADX 2 0 [ + len;
LDX 6 0(2) [ nlen = *next
SBXC 6 5 [ if nlen >= rlen
BCS HARD [ {
ADX 0 0(2) [ len += nlen;
GET2 2 1 [ get2 (next); remove from free
BRN SPLIT [ goto split;
# [ }
# No merging possible, need to allocate a new block
# Here we go, we must bite the bullet and save
# the link address in memory. We also need to
# use some lower to pass the parameters to free
# and malloc.
# X0
# X1 stack top
# X2 stack frame
# X3 block to resize
# X4 size wanted
# X5
# X6
# X7 return address
#SET RZFRAME=SXFRAME
#DEFINE RZWANT=RZFRAME [ wanted
#SET RZFRAME=RZFRAME+1
#DEFINE RZBLOK=RZFRAME [ block to resize
#SET RZFRAME=RZFRAME+1
#DEFINE RZNEW=RZFRAME [ new block
#SET RZFRAME=RZFRAME+1
HARD BEGIN 2 1,7,RZFRAME [ allocate stack frame
STO 4 RZWANT(2) [ save size wanted
STO 3 RZBLOK(2) [ save block to resize
# new = malloc (wanted);
SBN 4 2 [ remove sentinels
STO 4 3 [ save wanted for MALLOC
CALL 1 ALLOC
BZE 6 RS0 [ bail if malloc failed
LDX 3 RZBLOK(2) [ get old block
BZE 3 RS0 [ short circuit if resize (0)
STO 6 RZNEW(2) [ save new for later
# move (next + 1, blok, len - 2);
STO 3 5 [ get old block to X5
ADN 5 1 [ point X5 at old payload
LDX 1 0(3) [ get old block size to X1
SBN 1 2 [ don't move sentinels
MOVEW 56 1 [ move X1 words from X5 to X6
# free (blok)
LDX 3 RZBLOK(2) [ get old block
ADN 3 1 [ adjust for free
CALL 1 FREE
LDX 6 RZNEW(2) [ get pointer to new block
RS0 END 2 1,2
# Ok, we're shrinking the block. Is the leftover
# big enough to be a block all of it's own?
SHRNK SBNC 5 4 [ if rlen >= 4
BCS RSOUT [ {
ADN 5 4
SPLIT SBX 0 5 [ len -= rlen;
STO 3 6 [ save block for later
ADX 3 0 [ rest = blok + len
PUT 3 1,2 [ put (rest); free split block
AVAIL 3 5
STLEN LDX 3 6 [
USED 3 0 [ Mark block as used.
RSOUT ADN 6 1 [ blok += 1;
BASE 2 [ a kindness to our callers
EXIT 7 2
# Allocate memory and fill it with zeroes
#SET ZAFRAME=SXFRAME
#DEFINE ZAWORDS=SXPAR1
#SET ZAFRAME=ZAFRAME+1
#CUE GFZALLOC
# Fortran callable entry point
OBEY 0(1) [ get words to allocate
LDX 3 0(3)
ADN 1 1 [ skip arg
# Internal format entry point, length in X3
#CUE GXZALLOC
STACK 2
STO 3 ZAWORDS(2)
# Pascal style entry point
#CUE GPZALLOC
BEGIN 2 3,1,ZAFRAME
LDX 3 ZAWORDS(2)
CALL 1 ALLOC
BZE 6 ZAOUT
LDX 3 6
LDX 1 ZAWORDS(2)
STOZ 0(3) [ zero first word allocated
SBN 1 1 [ decrement words
BZE 1 ZAOUT [ exit if none left
LDX 4 3 [ X3 = 1st word (now zero)
ADN 4 1 [ X4 = 2nd word
MOVEW 34 1 [ Move X1 words from X3 to X4
ZAOUT END 2 1,0
# Check status of arena
#CUE GFCHKMALLOC
STO 1 5 [ save link
CHECK
# Loop through arena checking sentinels
LDX 6 '/BOTTOM'
LDX 1 6
ADN 1 4 [ point at first real block
CHK BXE 1 WILDERNESS,CHKFR [ reached end?
BXGE 1 WILDERNESS,CHKE1 [ or gone past?
LDX 0 0(1) [ get lower sentinel
LDX 3 0
BPZ 3 *+2 [ jump if free
NGX 3 3
ADX 3 1 [ find top sentinel
SBN 3 1
BXGE 3 WILDERNESS,CHKE6 [ jump if length impossible
BXU 0 0(3),CHKE2 [ jump if block corrupt
LDN 1 1(3) [ get addr of next block
BRN CHK
CHKE1 SUSWT 2HM1 [ malloc arena corrupt
CHKE2 SUSWT 2HM2 [ malloc arena corrupt
CHKE3 SUSWT 2HM3 [ malloc arena corrupt
CHKE4 SUSWT 2HM4 [ malloc arena corrupt
CHKE5 SUSWT 2HM5 [ malloc arena corrupt
CHKE6 SUSWT 2HM6 [ malloc arena corrupt
# Check malloc free list
CHKFR LDX 1 FREELIST [ get start of free list
# Don't check format of BOTTOM block
CHK2 BXE 1 6,CHK3 [ don't examine format of BOTTOM
# Check if block on free list is corrupt
LDXC 0 0(1) [ get lower sentinel
BCS CHKE3 [ jump if block not free
LDX 3 0
ADX 3 1
SBN 3 1 [ find top sentinel
BXU 0 0(3),CHKE4 [ jump if block corrupt
CHK3 STO 1 4 [ save previous block
LDX 1 LKNEXT(1) [ get next block
LDX 7 LKPREV(1) [ get prev link
BXU 4 7,CHKE5 [ jump if prev link broken
BXU 1 FREELIST,CHK2 [ loop if not hit end of list
CHKOK EXIT 5 0 [ exit
# Internal function - initialise the arena
# needed because we are not allowed to
# initialise #ELASTIC.
INIT LDX 2 FREELIST
STOZ 0(2) [ Initialise BOTTOM
STO 2 1(2)
STO 2 2(2)
STOZ 3(2)
LDN 2 2 [ Initialise WILD
SMO WILDERNESS
STO 2 0
# [ Don't bother with top sentinel
EXIT 1 0
#END
#FINISH