;	SCCSID = @(#)alloc.asm	1.1 85/04/09
;TITLE ALLOC.ASM - memory arena manager
;NAME Alloc
;
; Memory related system calls and low level routines for MSDOS 2.X.
; I/O specs are defined in DISPATCH.
;
;   $ALLOC
;   $SETBLOCK
;   $DEALLOC
;   $AllocOper
;   arena_free_process
;   arena_next
;   check_signature
;   Coalesce
;
;   Modification history:
;
;       Created: ARR 30 March 1983
;

[list -]
;
; get the appropriate segment definitions
;
%include "dosseg.nas"

[list +]
section DOSCODECODE
[list -]

;.xcref
%include "dossym.mac"
%include "devsym.mac"
%include "lmacros1.mac"
%include "memsw.mac"
;.cref
[list +]

;.lall

;SUBTTL memory allocation utility routines
;PAGE
;
; arena data
;
	i_need  arena_head,WORD         ; seg address of start of arena
first_mcb equ arena_head
	I_need	first_umcb, word
	i_need  CurrentPDB,WORD         ; current process data block addr
	i_need  FirstArena,WORD         ; first free block found
	i_need  BestArena,WORD          ; best free block found
	i_need  LastArena,WORD          ; last free block found
	i_need  AllocMethod,BYTE        ; how to alloc first(best)last
	I_need	alloc_strategy_ext, byte
	I_need	enable_uma, byte
	I_need  EXTERR_LOCUS,BYTE       ; Extended Error Locus

%ifdef LDOSMEM
getpsp:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	mov bx, word [ss:CurrentPDB]
	retn

%assign _UMA 1
%assign _ERRORFLAGS 0

section DOSCODECODE

%include "memory.asm"

section DOSCODECODE

	global ReleaseOwnersMCBs
	global arena_free_process
arena_free_process equ ReleaseOwnersMCBs


procedure   D_ALLOC,NEAR
 assume ds:nothing, es:nothing, ss:DOSGROUP
	EnterCrit   critMem
	call AllocateMCBCompatible
return_CF_bx_crit:
	jnc return_CF_crit
	cmp ax, errorInsufficientMemory
	jne return_CY_crit
	invoke get_user_stack
	mov [si + user_BX], bx
	jmp return_CY_crit
EndProc D_ALLOC


procedure   D_DEALLOC,NEAR
 assume ds:nothing, es:nothing, ss:DOSGROUP
	EnterCrit   critMem
	mov ax, es
	call ReleaseMCB
return_CF_crit:
	LeaveCrit   critMem
return_CF:
	jc .err
	transfer    SYS_RET_OK
.err:
	transfer    SYS_RET_ERR
EndProc D_DEALLOC

return_CY_crit:
	stc
	jmp return_CF_crit


procedure   D_SETBLOCK,NEAR
 assume ds:nothing, es:nothing, ss:DOSGROUP
	EnterCrit   critMem
	mov ax, es
	call ModifyMCB
	jmp return_CF_bx_crit
EndProc D_SETBLOCK


%else
;
; arena_free_process
; input:    BX - PID of process
; output:   free all blocks allocated to that PID
;
	procedure   arena_free_process,NEAR
	ASSUME  DS:NOTHING,ES:NOTHING
	MOV     DI,arena_signature
	MOV     AX,[ss:arena_head]
Check_Signature equ check_signature	; NASM port label
	CALL    Check_Signature         ; ES <- AX, check for valid block

arena_free_process_loop:
	retc
	PUSH    ES
	POP     DS
	CMP     [arena_owner],BX     ; is block owned by pid?
	JNZ     arena_free_next         ; no, skip to next
	MOV     [arena_owner],DI     ; yes... free him

arena_free_next:
	CMP     BYTE PTR [DI],arena_signature_end
					; end of road, Jack?
	retz                            ; never come back no more
	CALL    arena_next              ; next item in ES/AX carry set if trash
	JMP     arena_free_process_loop

EndProc arena_free_process

;
; arena_next
; input:    DS - pointer to block head
; output:   AX,ES - pointers to next head
;           carry set if trashed arena
;
	procedure   arena_next,NEAR
	ASSUME  DS:NOTHING,ES:NOTHING
	MOV     AX,DS                   ; AX <- current block
	ADD     AX,[arena_size]      ; AX <- AX + current block length
	INC     AX                      ; remember that header!
;
;       fall into check_signature and return
;
;       CALL    check_signature         ; ES <- AX, carry set if error
;       RET
EndProc arena_next

;
; check_signature
; input:    AX - address of block header
; output:   ES=AX, carry set if signature is bad
;
	procedure   check_signature,NEAR
	ASSUME  DS:NOTHING,ES:NOTHING
	MOV     ES,AX                   ; ES <- AX
	CMP     BYTE PTR [ES:DI],arena_signature_normal
					; IF next signature = not_end THEN
	retz                            ;   GOTO ok
	CMP     BYTE PTR [ES:DI],arena_signature_end
					; IF next signature = end then
	retz                            ;   GOTO ok
	STC                             ; set error
	return

EndProc Check_signature

;
; Coalesce - combine free blocks ahead with current block
; input:    DS - pointer to head of free block
; output:   updated head of block, AX is next block
;           carry set -> trashed arena
;
	procedure   Coalesce,NEAR
	ASSUME  DS:NOTHING,ES:NOTHING
	CMP     BYTE PTR [DI],arena_signature_end
					; IF current signature = END THEN
	retz                            ;   GOTO ok
	CALL    arena_next              ; ES, AX <- next block, Carry set if error
	retc                            ; IF no error THEN GOTO check

coalesce_check:
	CMP     [ES:arena_owner],DI
	retnz                           ; IF next block isnt free THEN return
	MOV     CX,[ES:arena_size]      ; CX <- next block size
	INC     CX                      ; CX <- CX + 1 (for header size)
	ADD     [arena_size],CX      ; current size <- current size + CX
	MOV     CL,[ES:DI]              ; move up signature
	MOV     [DI],CL
coalesce equ Coalesce	; NASM port label
	JMP     coalesce                ; try again
EndProc Coalesce

;SUBTTL $Alloc - allocate space in memory
;PAGE
;
;   Assembler usage:
;           MOV     BX,size
;           MOV     AH,Alloc
;           INT     21h
;         AX:0 is pointer to allocated memory
;         BX is max size if not enough memory
;
;   Description:
;           Alloc returns  a  pointer  to  a  free  block of
;       memory that has the requested  size  in  paragraphs.
;
;   Error return:
;           AX = error_not_enough_memory
;              = error_arena_trashed
;
	procedure   D_ALLOC,NEAR
	ASSUME  DS:NOTHING,ES:NOTHING

	EnterCrit   critMem
	XOR     AX,AX
	MOV     DI,AX

	MOV     [ss:FirstArena],AX         ; init the options
	MOV     [ss:BestArena],AX
	MOV     [ss:LastArena],AX

	PUSH    AX                      ; alloc_max <- 0
	MOV     AX,[ss:arena_head]         ; AX <- beginning of arena
Check_signature equ check_signature	; NASM port label
	CALL    Check_signature         ; ES <- AX, carry set if error
	JC      alloc_err               ; IF error THEN GOTO err

alloc_scan:
	PUSH    ES
	POP     DS                      ; DS <- ES
	CMP     [arena_owner],DI
	JZ      alloc_free              ; IF current block is free THEN examine

alloc_next:
	CMP     BYTE PTR [DI],arena_signature_end
					; IF current block is last THEN
	JZ      alloc_end               ;   GOTO end
	CALL    arena_next              ; AX, ES <- next block, Carry set if error
	JNC     alloc_scan              ; IF no error THEN GOTO scan

alloc_err:
	POP     AX

alloc_trashed:
	LeaveCrit   critMem
	error   error_arena_trashed

alloc_end:
	CMP     word [ss:FirstArena],0
	JNZ     alloc_do_split

alloc_fail:
	invoke  get_user_stack
	POP     BX
	MOV     [SI + user_BX],BX
	LeaveCrit   critMem
	error   error_not_enough_memory

alloc_free:
	CALL    coalesce                ; add following free block to current
	JC      alloc_err               ; IF error THEN GOTO err
	MOV     CX,[arena_size]

	POP     DX                      ; check for max found size
	CMP     CX,DX
	JNA     alloc_test
	MOV     DX,CX

alloc_test:
	PUSH    DX
	CMP     BX,CX                   ; IF BX > size of current block THEN
	JA      alloc_next              ;   GOTO next

	CMP     word [ss:FirstArena],0
	JNZ     alloc_best
	MOV     [ss:FirstArena],DS         ; save first one found
alloc_best:
	CMP     word [ss:BestArena],0
	JZ      alloc_make_best         ; initial best
	PUSH    ES
	MOV     ES,[ss:BestArena]
	CMP     [ES:arena_size],CX      ; is size of best larger than found?
	POP     ES
	JBE     alloc_last
alloc_make_best:
	MOV     [ss:BestArena],DS          ; assign best
alloc_last:
	MOV     [ss:LastArena],DS          ; assign last
	JMP     alloc_next

;
; split the block high
;
alloc_do_split_high:
	MOV     DS,[ss:LastArena]
	MOV     CX,[arena_size]
	SUB     CX,BX
	MOV     DX,DS
	JE      alloc_set_owner         ; sizes are equal, no split
	ADD     DX,CX                   ; point to next block
	MOV     ES,DX                   ; no decrement!
	DEC     CX
	XCHG    BX,CX                   ; bx has size of lower block
	JMP     alloc_set_sizes         ; cx has upper (requested) size
	nop	; identicalise

;
; we have scanned memory and have found all appropriate blocks
; check for the type of allocation desired; first and best are identical
; last must be split high
;
alloc_do_split:
	CMP     BYTE PTR [ss:AllocMethod], 1
	JA      alloc_do_split_high
	MOV     DS,[ss:FirstArena]
	JB      alloc_get_size
	MOV     DS,[ss:BestArena]
alloc_get_size:
	MOV     CX,[arena_size]
	SUB     CX,BX                   ; get room left over
	MOV     AX,DS
	MOV     DX,AX                   ; save for owner setting
	JE      alloc_set_owner         ; IF BX = size THEN (don't split)
	ADD     AX,BX
	INC     AX                      ; remember the header
	MOV     ES,AX                   ; ES <- DS + BX (new header location)
	DEC     CX                      ; CX <- size of split block
alloc_set_sizes:
	MOV     [arena_size],BX      ; current size <- BX
	MOV     [ES:arena_size],CX      ; split size <- CX
	MOV     BL,arena_signature_normal
	XCHG    BL,[DI]              ; current signature <- 4D
	MOV     [ES:DI],BL              ; new block sig <- old block sig
	MOV     [ES:arena_owner],DI

alloc_set_owner:
	MOV     DS,DX
	MOV     AX,[ss:CurrentPDB]
	MOV     [arena_owner],AX
	MOV     AX,DS
	INC     AX
	POP     BX
	LeaveCrit   critMem
	transfer    SYS_RET_OK

EndProc D_alloc

;SUBTTL $SETBLOCK - change size of an allocated block (if possible)
;PAGE
;
;   Assembler usage:
;           MOV     ES,block
;           MOV     BX,newsize
;           MOV     AH,setblock
;           INT     21h
;         if setblock fails for growing, BX will have the maximum
;         size possible
;   Error return:
;           AX = error_invalid_block
;              = error_arena_trashed
;              = error_not_enough_memory
;              = error_invalid_function
;
	procedure   D_SETBLOCK,NEAR
	ASSUME  DS:NOTHING,ES:NOTHING
	EnterCrit   critMem
	MOV     DI,arena_signature
	MOV     AX,ES
	DEC     AX
	CALL    check_signature
	JNC     setblock_grab

setblock_bad:
	JMP     alloc_trashed

setblock_grab:
	MOV     DS,AX
	CALL    coalesce
	JC      setblock_bad
	MOV     CX,[arena_size]
	PUSH    CX
	CMP     BX,CX
	JBE     alloc_get_size
	JMP     alloc_fail
EndProc D_setblock

;SUBTTL $DEALLOC - free previously allocated piece of memory
;PAGE
;
;   Assembler usage:
;           MOV     ES,block
;           MOV     AH,dealloc
;           INT     21h
;
;   Error return:
;           AX = error_invalid_block
;              = error_arena_trashed
;
	procedure   D_DEALLOC,NEAR
	ASSUME  DS:NOTHING,ES:NOTHING
	EnterCrit   critMem
	MOV     DI,arena_signature
	MOV     AX,ES
	DEC     AX
	CALL    check_signature
	JC      dealloc_err
	MOV     [ES:arena_owner],DI
	LeaveCrit   critMem
	transfer    SYS_RET_OK

dealloc_err:
	LeaveCrit   critMem
	error   error_invalid_block
EndProc D_DEALLOC
%endif

;SUBTTL $AllocOper - get/set allocation mechanism
;PAGE
;
;   Assembler usage:
;           MOV     AH,AllocOper
;           MOV     BX,method
;           MOV     AL,func
;           INT     21h
;
;   Error return:
;           AX = error_invalid_function
;
	procedure   D_AllocOper,NEAR
 assume ds:nothing, es:nothing, ss:DOSGROUP
%ifdef LDOSMEM
	cmp al, 3
	ja alloc_oper_invalid
	je set_umb_link
%endif
	CMP     AL,1
	JB      AllocOperGet
	JZ      AllocOperSet
%ifdef LDOSMEM
get_umb_link:
	xor ax, ax
	mov al, byte [ss:enable_uma]	; get allow/disallow flag
	transfer SYS_RET_OK

set_umb_link:
	mov dx, word [ss:first_umcb]	; any UMA ?
	cmp dx, -1
	jne .got

.none:
	test bl, 1			; (NC)
	jnz alloc_oper_invalid
	jmp alloc_oper_CF

.got:
	EnterCrit   critMem
	push ax
	call SetLinearMCBFlags		; ax = 0 = get first MCB
.next:
	mov dx, ax			; remember MCB in case it is the target
	call SNextMCB			; get next MCB
	jc .end
	jnz .error			; end ? UMCB not found -->
	cmp ax, word [ss:first_umcb]	; this the first UMCB ?
	jne .next			; no, loop -->

	test dx, dx			; no previous ?
	jz .error			; if so, error -->
	mov es, dx			; => MCB that points to first UMCB
 assume es:MCB
	test bl, 1			; (NC)
	jz .set_Z			; 0, set to 'Z' -->
.set_M:
	mov byte [es:mcbSignature], "M"	; nonzero, set to 'M'
	jmp @F
.set_Z:
	mov byte [es:mcbSignature], "Z"
@@:
%if _ERRORFLAGS
	test bh, bh
	jz @F
	or byte [ss:error_flags], EF_InvalidUMBLink	; invalid UMB link bits set
@@:
%endif
	mov byte [ss:enable_uma], bl	; store UMB link
	jmp .end

.error:
 assume es:nothing
	mov ax, errorMCBDestroyed
	stc
.end:
	pop si					; discard flags word
	pop si					; discard loop counter word
	pop si
	LeaveCrit   critMem
alloc_oper_CF:
	jnc alloc_oper_ok_ax
	pop si
	transfer SYS_RET_ERR
%endif

alloc_oper_invalid:
errLoc_mem equ errLOC_Mem	; NASM port equate
	MOV     byte [ss:EXTERR_LOCUS],errLoc_mem ; Extended Error Locus
	error   error_invalid_function
AllocOperGet:
	MOV     AL,BYTE PTR [ss:AllocMethod]
%ifdef LDOSMEM
	mov ah, [ss:alloc_strategy_ext]

alloc_oper_ok:
	db __TEST_IMM8		; (skip pop)
alloc_oper_ok_ax:
	pop ax
%else
	mov ah, 0
%endif
	transfer    SYS_RET_OK
AllocOperSet:
	MOV     [ss:AllocMethod],BL
	mov [ss:alloc_strategy_ext], bh
	transfer    SYS_RET_OK
EndProc D_AllocOper

    END
