|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ O T ┃
Length: 11709 (0x2dbd)
Types: TextFile
Names: »OS2000_INTERNALS_ASM«
└─⟦afbc8121e⟧ Bits:30000532 8mm tape, Rational 1000, MC68020_OS2000 7_2_2
└─ ⟦77aa8350c⟧ »DATA«
└─⟦f794ecd1d⟧
└─⟦24d1ddd49⟧
└─⟦this⟧
; The use of this system is subject to the software license terms and
; conditions agreed upon between Rational and the Customer.
;
; Copyright 1988 by Rational.
;
; RESTRICTED RIGHTS LEGEND
;
; Use, duplication, or disclosure by the Government is subject to
; restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
; Technical Data and Computer Software clause at 52.227-7013.
;
;
; Rational
; 3320 Scott Boulevard
; Santa Clara, California 95054-3197
;
; PROPRIETARY AND CONFIDENTIAL INFORMATION OF RATIONAL;
; USE OR COPYING WITHOUT EXPRESS WRITTEN AUTHORIZATION
; IS STRICTLY PROHIBITED. THIS MATERIAL IS PROTECTED AS
; AN UNPUBLISHED WORK UNDER THE U.S. COPYRIGHT ACT OF
; 1976. CREATED 1988. ALL RIGHTS RESERVED.
;
;
.module "OS2000_INTERNALS"
;
; Implements operations which depend on the location and
; organization of OS-9 and OS2000 internal data structures.
;
.include "^^standard_assembler_include_file"
.include "^^common.os2000_definitions"
.include "^^common.runtime_definitions"
comp_unit runtime_compunit
.sect ada_runtime_code,code,relocatable,alignment:=2
.gbl.a __get_current_task_id
.gbl.a __verify_stack
.gbl.a __fork_process
.gbl.a __current_process_id
.gbl.a __current_process_priority
.gbl.a __set_process_priority
.gbl.l __serialization.acquire_lock
.gbl.l __serialization.release_lock
.gbl.l __release_task_lock
.ext.a __process_descriptor_pointer
.ext.a __tasking_lock
.ext.a __report_fatal_error;
.ext.l __abort_main_indirect
.ext.b __abort_main_flag
;
; function Get_Current_Task_Id return Task_Id;
;
subprogram sp_rt,sp.internal,linkage.simple
__get_current_task_id:
movea.l (__process_descriptor_pointer,a5),A0
movea.l (a0),a0
move.l (art$tsk_id,a0),d0
rts
;
; function Current_Process_Id return Integer;
;
subprogram sp_rt,sp.internal,linkage.simple
__current_process_id:
moveq.l #0,d0
movea.l (__process_descriptor_pointer,a5),a0
movea.l (a0),a0
move.w (p$id,a0),d0
rts
;
; function Current_Priority return Integer;
;
subprogram sp_rt,sp.internal,linkage.simple
__current_process_priority:
statement 0,0,0
moveq.l #0,D0
movea.l (__process_descriptor_pointer,a5),a0
movea.l (a0),a0
move.w (p$prior,a0),d0
rts
;
; procedure Fork (Parameter_Ref : System.Address;
; Parameter_Size : Integer;
; Priority : Integer;
; Memory_Size : Integer;
; Result : out Status);
;
subprogram sp_rt,sp.internal,linkage.simple
__Fork_Process:
.local
$param_ref'offset equ 4+20
$param_size'offset equ 8+20
$priority'offset equ 12+20
$memory_size'offset equ 16+20
$status'offset equ 20+20
movem.l d2/d3/d4/d5/a2,-(a7)
statement 20,0,0
moveq.l #0,d0 ; module type/revision
move.l ($memory_size'offset,sp),d1 ; memory size
addi.l #runtime$stack$cushion,d1 ; add cushion to mem size
move.l ($param_size'offset,sp),d2 ; parameter size
clr.l ($status'offset,sp) ; successful status
moveq.l #4,d3 ; I/O paths
move.l ($priority'offset,sp),d4 ; priority
lea (_ada_task_module_name:16,pc),a0; module name
movea.l ($param_ref'offset,sp),a1 ; parameter address
$save_child_id:
movea.l (__process_descriptor_pointer,a5),a2
movea.l (a2),a2
move.l (p$cid,a2),d5 ; save value of child id
trap #os9_call
.dc.w f$fork
bcs.b $error
$restore_child_id:
move.l d5,(p$cid,a2) ; restore value of child id
$done: movem.l (a7)+,d2/d3/d4/d5/a2
statement 0,0,0
rts
$error: move.l d1, ($status'offset,sp) ; error status
bra.b $done
_ada_task_module_name:
.asciz "ADA_TASK"
;
; procedure Set_Priority (Process_Id : Integer; Priority : Integer);
;
subprogram sp_rt,sp.internal,linkage.simple
__Set_Process_Priority:
.local
$process_id'offset equ 4
$priority'offset equ 8
move.l ($process_id'offset,sp),d0
move.l ($priority'offset,sp),d1
trap #os9_call
.dc.w f$sprior
rtd #8
;
; function Acquire_Lock (The_Lock : Lock) return Task_Id is
; Item : Q_Element;
; begin
; Item.Key := Get_Current_Task_Id;
; if Tasking_Lock.Key = Null_Id then \
; Tasking_Lock.Key := Item.Key; \
; Tasking_Lock.Next := null; \
; return True; - Atomic
; else /
; Item.Next := Tasking_Lock.Next; /
; Tasking_Lock.Next := Item; /
;
; while Tasking_Lock.Key /= Item.Key loop
; Sleep (Some_Amount); -- awakened either by release signal
; -- or delay expiration;
; end loop;
; end if;
; end Acquire;
;
;
subprogram sp_rt,sp.internal,linkage.simple
__serialization.acquire_lock:
.local
$lock'offset equ 4+4
$allocate_size equ element'size;
move.l d3,-(SP) ; save d3
statement 0,0,1
movea.l ($lock'offset,sp),a0 ; get address of The_Lock
movea.l (__process_descriptor_pointer,a5),a1
movea.l (a1),a1
move.l (art$tsk_id,a1),d3 ; fetch current task id
move.l d3,-(SP) ; Element.Key := Get_Current_Task_Id
statement 0,0,2
subq.l #4,sp ; Element.Next uninitialized
statement 0,0,3
movea.l a0, a1 ; The_Lock'Address is in A0
addq.l #element.key,a1 ; The_Lock.Key'Address
$retry: moveq.l #0,d1
cas.l d1,d3,(a1) ; if The_Lock.Key = 0 then
; The_Lock.Key := The_Element.Key;
bne.b $failed ; if Key /= 0 then failed
$done: move.l (element.key,a0),d0 ; get The_Lock.Key
addq.l #$allocate_size,sp ; pop local queue element
statement 0,0,1
move.l (sp)+,d3 ; restore d3
statement 0,0,0
rtd #4
$failed:move.l (a0),d0 ; get The_Lock.Next
move.l d0,(sp) ; Item.Next := Lock.Next
move.l SP,d3 ; The_Element.Next'Address
cas2.l d0:d1,d3:d1,(a0):(a1) ; if Lock unchanged then
; Lock.Next := Item and
beq.b $sleep ; if equal then properly enqueued
; else concurrent interference,
move.l (Element.Key,SP),d3 ; so get The_Element.Key
bra.b $retry ; and try again to enqueue
;
; Didn't get lock, so sleep until become head of queue
; and lock is released. Don't sleep indefinitely, because
; OS-9 signals are lost (not queued) if receiver is not
; already sleeping when signal is sent. This introduces
; a race condition.
;
$sleep: move.l #-2147483644,d0 ; sleep time
trap #os9_call ; do system call
.dc.w f$sleep
move.l (element.key,a0),d0 ; get the_Lock.Key
cmp.l (element.key,sp),d0 ; compare to The_Element.Key
beq.b $done ; if equal then got the lock
bra.b $sleep ; else try again
;
; procedure Release_Task_Lock
;
subprogram sp_rt,sp.internal,linkage.simple
__release_task_lock:
btst.b #0,(__abort_main_flag,a5) ; test for main program abort
beq.b $release
movea.l (__abort_main_indirect,a5),a0
jsr (a0)
$release:
pea (__Tasking_Lock,a5) ; get address of Tasking_Lock
bsr.b __serialization.release_lock
rts
;
; procedure Release_Lock (The_Lock : Address);
;
subprogram sp_rt,sp.internal,linkage.simple
__Serialization.Release_Lock:
.local
$lock'offset equ 4
movea.l ($lock'offset,sp),a0 ; get address of The_Lock
movea.l a0,a1
addq.l #Element.Key,a1 ; Lock.Key'Address
move.l (a1),d1 ; Lock.Key
moveq.l #0,d0 ; null, null id
cas2.l d0:d1,d0:d0,(a0):(a1) ; if Lock.Next = null and
; Lock.Key = Lock.Key then
; Lock.Next := null; and
; Lock.Key := null id;
bne.b $waiters ;
rtd #4 ; released the lock, no waiters
$waiters:
movem.l d2/d3/a3,-(a7)
statement 0,0,3
$retry: movea.l d0, a3 ; Lock.Next
move.l (a3), d2 ; Lock.Next.Next
move.l (Element.Key,a3), d3 ; Lock.Next.Key
cas2.l d0:d1,d2:d3,(a0):(a1) ; if Lock unchanged then
; Lock.Next := Lock.Next.Next;
; Lock.Key := Lock.Next.Key;
bne.b $Retry ; concurrent interference
movea.l d3,a0 ; get The_Lock.Key
movem.l (a7)+,d2/d3/a3 ; restore d2, d3, and a3
statement 0,0,0
moveq.l #1,d1 ; wakeup signal
move.l (tcb.process_id,a0),d0 ; get The_Lock.Key.Process_Id
trap #os9_call ; do system call
.dc.w f$send
rtd #4
;
; procedure Verify_Stack;
;
; Verify that the current stack pointer does not
; exceed the limits for the process; if it does
; then issue an error message and die. This routine
; is called only from runtime routines which do not
; do normal stack checking, but must be able to execute
; in order to insure correct program semantics.
;
subprogram sp_rt,sp.internal,linkage.simple
__verify_stack:
.local
move.l sp,d1 ; get current stack pointer
addi.l #runtime$stack$cushion,d1 ; give back cushion for runtime
blo.s $failed ; wraps around past zero
movea.l (__process_descriptor_pointer,a5),a0
movea.l (a0),a0 ; get descriptor ptr
cmp.l (art$stk_lo,a0),d1 ; compare to low bound
blo.s $failed ; past low bound
rts
$failed:
move.l #insufficient$stack$ferror,-(sp); push fatal error value
bsr.l __report_fatal_error ; give error message
moveq.l #some$error,d0 ; return status
trap #os9_call
.dc.w f$exit
end_subprograms
.end